From c0c414227216aeb093403783caa3a56449bfb337 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Johannes=20=C3=85man=20Pohjola?= Date: Mon, 20 May 2019 10:14:44 +1000 Subject: [PATCH 1/7] Extirpate intermediate theorem syntax This commit replaces all(?) occurrences of the old-style Theorem syntax Theorem name `thm_statement ` (tactic) with Theorem name: thm_statement Proof tactic QED Instances of the Theorem syntax that get piped into forward reasoning are treated specially, as per a suggestion by @mn2000. So Theorem name `thm_statement` (tactic) |> forward_rules; maps to Theorem name = Q.prove(` thm_statement`, tactic) |> forward_rules; This will produce silly output in some cases (if the forward rules end in a call to save_thm, the theorem gets saved twice), but it seems not worth it to try to detect this automatically. --- basis/ArrayProofScript.sml | 255 +- basis/CommandLineProofScript.sml | 126 +- basis/IntProgScript.sml | 20 +- basis/ListProgScript.sml | 13 +- basis/MarshallingProgScript.sml | 72 +- basis/MarshallingScript.sml | 56 +- basis/RatProgScript.sml | 115 +- basis/RuntimeProofScript.sml | 44 +- basis/TextIOProofScript.sml | 1205 +++--- basis/Word64ProgScript.sml | 30 +- basis/Word8ArrayProofScript.sml | 70 +- basis/Word8ProgScript.sml | 70 +- basis/basisProgScript.sml | 24 +- basis/basis_ffiScript.sml | 216 +- basis/clFFIScript.sml | 34 +- basis/fsFFIPropsScript.sml | 1335 +++--- basis/fsFFIScript.sml | 70 +- basis/mlbasicsProgScript.sml | 30 +- basis/pure/mlintScript.sml | 236 +- basis/pure/mllistScript.sml | 137 +- basis/pure/mlmapScript.sml | 126 +- basis/pure/mlstringScript.sml | 631 +-- basis/pure/mlvectorScript.sml | 119 +- basis/runtimeFFIScript.sml | 17 +- candle/set-theory/jrhSetScript.sml | 426 +- candle/set-theory/setModelScript.sml | 30 +- candle/set-theory/setSpecScript.sml | 460 +- candle/set-theory/zfc/setModelScript.sml | 29 +- candle/set-theory/zfc/setSpecScript.sml | 918 ++-- .../standard/ml_kernel/ml_hol_initScript.sml | 12 +- .../ml_kernel/ml_hol_kernelProgScript.sml | 6 +- .../standard/monadic/holKernelProofScript.sml | 1192 +++--- .../ag32/proofs/readerProgProofScript.sml | 48 +- .../proofs/readerProgProofScript.sml | 12 +- .../opentheory/monadIO/readerIOProgScript.sml | 76 +- .../monadIO/readerIOProofScript.sml | 148 +- candle/standard/opentheory/prettyScript.sml | 138 +- .../standard/opentheory/readerProgScript.sml | 128 +- .../standard/opentheory/readerProofScript.sml | 1260 +++--- candle/standard/opentheory/readerScript.sml | 114 +- .../opentheory/readerSoundnessScript.sml | 12 +- .../opentheory/reader_commonProgScript.sml | 24 +- candle/standard/semantics/holAxiomsScript.sml | 70 +- candle/standard/semantics/holBoolScript.sml | 118 +- .../semantics/holConsistencyScript.sml | 112 +- .../standard/semantics/holExtensionScript.sml | 84 +- .../semantics/holSemanticsExtraScript.sml | 520 ++- .../standard/semantics/holSoundnessScript.sml | 128 +- .../standard/syntax/holAxiomsSyntaxScript.sml | 34 +- .../standard/syntax/holBoolSyntaxScript.sml | 67 +- .../standard/syntax/holConservativeScript.sml | 24 +- .../standard/syntax/holSyntaxExtraScript.sml | 2101 ++++++---- candle/standard/syntax/holSyntaxScript.sml | 76 +- candle/syntax-lib/holSyntaxLibScript.sml | 344 +- characteristic/cfAppScript.sml | 330 +- characteristic/cfDivScript.sml | 12 +- characteristic/cfFFITypeScript.sml | 85 +- characteristic/cfHeapsBaseScript.sml | 1058 ++--- characteristic/cfHeapsScript.sml | 161 +- characteristic/cfLetAutoScript.sml | 553 ++- characteristic/cfMainScript.sml | 54 +- characteristic/cfNormaliseScript.sml | 75 +- characteristic/cfScript.sml | 613 +-- characteristic/cfStoreScript.sml | 157 +- characteristic/cfTacticsScript.sml | 183 +- characteristic/examples/cf_examplesScript.sml | 11 +- compiler/backend/ag32/ag32_memoryScript.sml | 696 ++-- .../ag32/proofs/ag32_basis_ffiProofScript.sml | 893 ++-- .../ag32/proofs/ag32_configProofScript.sml | 32 +- .../ag32/proofs/ag32_ffi_codeProofScript.sml | 468 ++- .../ag32/proofs/ag32_machine_configScript.sml | 19 +- .../ag32/proofs/ag32_memoryProofScript.sml | 205 +- .../backend/ag32/proofs/ag32_progScript.sml | 116 +- .../arm6/proofs/arm6_configProofScript.sml | 32 +- .../arm8/proofs/arm8_configProofScript.sml | 32 +- compiler/backend/backendScript.sml | 54 +- compiler/backend/backend_commonScript.sml | 7 +- compiler/backend/bvi_letScript.sml | 30 +- compiler/backend/bvi_tailrecScript.sml | 292 +- compiler/backend/bvi_to_dataScript.sml | 69 +- compiler/backend/bvl_constScript.sml | 88 +- compiler/backend/bvl_handleScript.sml | 31 +- compiler/backend/bvl_inlineScript.sml | 40 +- compiler/backend/bvl_to_bviScript.sml | 31 +- compiler/backend/closLangScript.sml | 10 +- compiler/backend/clos_annotateScript.sml | 80 +- compiler/backend/clos_callScript.sml | 100 +- compiler/backend/clos_fvsScript.sml | 8 +- compiler/backend/clos_knownScript.sml | 169 +- compiler/backend/clos_labelsScript.sml | 8 +- compiler/backend/clos_letopScript.sml | 10 +- compiler/backend/clos_mtiScript.sml | 73 +- compiler/backend/clos_numberScript.sml | 12 +- compiler/backend/clos_ticksScript.sml | 8 +- compiler/backend/clos_to_bvlScript.sml | 149 +- compiler/backend/data_liveScript.sml | 11 +- compiler/backend/data_spaceScript.sml | 22 +- compiler/backend/data_to_wordScript.sml | 46 +- compiler/backend/db_varsScript.sml | 126 +- compiler/backend/displayLangScript.sml | 8 +- compiler/backend/exportScript.sml | 10 +- compiler/backend/flatLangScript.sml | 44 +- compiler/backend/flat_elimScript.sml | 18 +- compiler/backend/flat_exh_matchScript.sml | 20 +- compiler/backend/flat_reorder_matchScript.sml | 52 +- compiler/backend/flat_to_patScript.sml | 99 +- compiler/backend/flat_uncheck_ctorsScript.sml | 70 +- compiler/backend/gc/copying_gcScript.sml | 172 +- compiler/backend/gc/gc_sharedScript.sml | 524 ++- compiler/backend/gc/gen_gcScript.sml | 351 +- compiler/backend/gc/gen_gc_partialScript.sml | 372 +- compiler/backend/lab_filterScript.sml | 8 +- compiler/backend/lab_to_targetScript.sml | 22 +- .../mips/proofs/mips_configProofScript.sml | 32 +- compiler/backend/patLangScript.sml | 16 +- compiler/backend/presLangScript.sml | 22 +- .../backend/proofs/backendProofScript.sml | 159 +- .../backend/proofs/bvi_letProofScript.sml | 136 +- .../backend/proofs/bvi_tailrecProofScript.sml | 781 ++-- .../backend/proofs/bvi_to_dataProofScript.sml | 108 +- .../backend/proofs/bvl_constProofScript.sml | 146 +- .../backend/proofs/bvl_handleProofScript.sml | 486 ++- .../backend/proofs/bvl_inlineProofScript.sml | 346 +- .../backend/proofs/bvl_jumpProofScript.sml | 22 +- .../backend/proofs/bvl_to_bviProofScript.sml | 618 +-- .../proofs/clos_annotateProofScript.sml | 418 +- .../backend/proofs/clos_callProofScript.sml | 1335 +++--- .../backend/proofs/clos_fvsProofScript.sml | 258 +- .../backend/proofs/clos_knownProofScript.sml | 1916 +++++---- .../backend/proofs/clos_knownPropsScript.sml | 218 +- .../backend/proofs/clos_labelsProofScript.sml | 364 +- .../backend/proofs/clos_letopProofScript.sml | 230 +- .../backend/proofs/clos_mtiProofScript.sml | 437 +- .../backend/proofs/clos_numberProofScript.sml | 278 +- .../backend/proofs/clos_ticksProofScript.sml | 348 +- .../backend/proofs/clos_to_bvlProofScript.sml | 1502 ++++--- .../backend/proofs/data_liveProofScript.sml | 22 +- .../backend/proofs/data_simpProofScript.sml | 20 +- .../backend/proofs/data_spaceProofScript.sml | 44 +- .../proofs/data_to_wordProofScript.sml | 310 +- .../proofs/data_to_word_assignProofScript.sml | 1985 +++++---- .../proofs/data_to_word_bignumProofScript.sml | 398 +- .../proofs/data_to_word_gcProofScript.sml | 3622 +++++++++------- .../proofs/data_to_word_memoryProofScript.sml | 3029 ++++++++------ .../backend/proofs/flat_elimProofScript.sml | 918 ++-- .../proofs/flat_exh_matchProofScript.sml | 463 ++- .../proofs/flat_reorder_matchProofScript.sml | 694 ++-- .../backend/proofs/flat_to_patProofScript.sml | 1076 +++-- .../proofs/flat_uncheck_ctorsProofScript.sml | 232 +- .../backend/proofs/lab_filterProofScript.sml | 36 +- .../proofs/lab_to_targetProofScript.sml | 2341 ++++++----- .../backend/proofs/pat_to_closProofScript.sml | 298 +- .../proofs/source_to_flatProofScript.sml | 258 +- .../backend/proofs/stack_allocProofScript.sml | 706 ++-- .../backend/proofs/stack_namesProofScript.sml | 228 +- .../proofs/stack_removeProofScript.sml | 701 ++-- .../proofs/stack_to_labProofScript.sml | 879 ++-- .../backend/proofs/word_allocProofScript.sml | 496 ++- .../backend/proofs/word_bignumProofScript.sml | 150 +- .../backend/proofs/word_elimProofScript.sml | 496 ++- .../backend/proofs/word_gcFunctionsScript.sml | 400 +- .../backend/proofs/word_instProofScript.sml | 130 +- .../backend/proofs/word_removeProofScript.sml | 284 +- .../backend/proofs/word_simpProofScript.sml | 890 ++-- .../proofs/word_to_stackProofScript.sml | 1362 +++--- .../proofs/word_to_wordProofScript.sml | 45 +- .../backend/reg_alloc/linear_scanScript.sml | 10 +- compiler/backend/reg_alloc/parmoveScript.sml | 552 ++- .../proofs/linear_scanProofScript.sml | 2124 +++++----- .../reg_alloc/proofs/reg_allocProofScript.sml | 669 +-- .../backend/reg_alloc/reg_allocScript.sml | 12 +- .../riscv/proofs/riscv_configProofScript.sml | 32 +- .../backend/semantics/backendPropsScript.sml | 36 +- compiler/backend/semantics/bviPropsScript.sml | 608 +-- compiler/backend/semantics/bviSemScript.sml | 34 +- compiler/backend/semantics/bvlPropsScript.sml | 556 ++- compiler/backend/semantics/bvlSemScript.sml | 54 +- .../backend/semantics/closPropsScript.sml | 1417 ++++--- compiler/backend/semantics/closSemScript.sml | 56 +- .../backend/semantics/dataPropsScript.sml | 666 +-- compiler/backend/semantics/dataSemScript.sml | 44 +- .../backend/semantics/flatPropsScript.sml | 712 ++-- compiler/backend/semantics/flatSemScript.sml | 44 +- compiler/backend/semantics/labPropsScript.sml | 529 ++- compiler/backend/semantics/labSemScript.sml | 12 +- compiler/backend/semantics/patPropsScript.sml | 263 +- compiler/backend/semantics/patSemScript.sml | 47 +- .../backend/semantics/stackPropsScript.sml | 342 +- compiler/backend/semantics/stackSemScript.sml | 62 +- .../backend/semantics/targetPropsScript.sml | 90 +- .../backend/semantics/wordPropsScript.sml | 1102 +++-- compiler/backend/semantics/wordSemScript.sml | 44 +- compiler/backend/source_to_flatScript.sml | 70 +- compiler/backend/stack_removeScript.sml | 10 +- compiler/backend/wordLangScript.sml | 10 +- compiler/backend/word_allocScript.sml | 33 +- compiler/backend/word_instScript.sml | 77 +- compiler/backend/word_removeScript.sml | 11 +- compiler/backend/word_simpScript.sml | 77 +- compiler/backend/word_to_wordScript.sml | 12 +- .../x64/proofs/x64_configProofScript.sml | 32 +- .../32/proofs/ag32BootstrapProofScript.sml | 152 +- .../translation/compiler32ProgScript.sml | 34 +- .../translation/compiler64ProgScript.sml | 34 +- .../bootstrap/translation/inferProgScript.sml | 132 +- .../bootstrap/translation/lexerProgScript.sml | 8 +- .../translation/parserProgScript.sml | 32 +- .../translation/reg_allocProgScript.sml | 18 +- .../translation/sexp_parserProgScript.sml | 52 +- .../translation/to_bviProgScript.sml | 12 +- .../translation/to_bvlProgScript.sml | 22 +- .../translation/to_closProgScript.sml | 6 +- .../translation/to_target32ProgScript.sml | 6 +- .../translation/to_target64ProgScript.sml | 6 +- .../ag32/proofs/ag32_targetProofScript.sml | 26 +- .../arm6/proofs/arm6_targetProofScript.sml | 9 +- .../arm8/proofs/arm8_targetProofScript.sml | 20 +- compiler/encoders/asm/asmPropsScript.sml | 307 +- .../mips/proofs/mips_targetProofScript.sml | 9 +- .../monadic_enc/monadic_enc32Script.sml | 50 +- .../monadic_enc/monadic_enc64Script.sml | 50 +- .../riscv/proofs/riscv_targetProofScript.sml | 17 +- .../x64/proofs/x64_targetProofScript.sml | 9 +- compiler/inference/inferScript.sml | 12 +- compiler/inference/infer_tScript.sml | 12 +- compiler/inference/proofs/envRelScript.sml | 434 +- .../inference/proofs/inferCompleteScript.sml | 108 +- .../inference/proofs/inferPropsScript.sml | 1432 ++++--- .../inference/proofs/inferSoundScript.sml | 122 +- .../proofs/infer_eCompleteScript.sml | 172 +- .../inference/proofs/infer_eSoundScript.sml | 92 +- .../inference/proofs/type_dCanonScript.sml | 550 ++- .../inference/proofs/type_eDetermScript.sml | 85 +- compiler/inference/unifyScript.sml | 484 ++- compiler/parsing/cmlPEGScript.sml | 10 +- compiler/parsing/fromSexpScript.sml | 1110 +++-- compiler/parsing/lexer_implScript.sml | 66 +- compiler/parsing/proofs/pegCompleteScript.sml | 1538 ++++--- compiler/parsing/proofs/pegSoundScript.sml | 316 +- compiler/proofs/compilerProofScript.sml | 64 +- examples/array_searchProgScript.sml | 137 +- examples/catProgScript.sml | 75 +- .../ag32/proofs/helloProofScript.sml | 48 +- .../ag32/proofs/sortProofScript.sml | 48 +- .../ag32/proofs/wordcountProofScript.sml | 56 +- examples/diffProgScript.sml | 36 +- examples/diffScript.sml | 501 ++- examples/doubleProgScript.sml | 44 +- examples/echoProgScript.sml | 24 +- examples/grepProgScript.sml | 227 +- examples/helloErrProgScript.sml | 26 +- examples/helloProgScript.sml | 24 +- examples/insertSortProgScript.sml | 48 +- examples/iocatProgScript.sml | 24 +- examples/lcsScript.sml | 941 +++-- examples/patchProgScript.sml | 43 +- examples/queueProgScript.sml | 92 +- examples/quicksortProgScript.sml | 104 +- examples/sortProgScript.sml | 230 +- examples/stackProgScript.sml | 60 +- misc/byteScript.sml | 36 +- misc/miscScript.sml | 3689 ++++++++++------- .../alt_semantics/proofs/bigClockScript.sml | 624 +-- .../proofs/bigSmallEquivScript.sml | 24 +- .../proofs/bigStepPropsScript.sml | 76 +- .../alt_semantics/proofs/determScript.sml | 60 +- .../proofs/funBigStepEquivScript.sml | 96 +- .../alt_semantics/proofs/interpScript.sml | 89 +- .../proofs/untypedSafetyScript.sml | 40 +- semantics/cmlPtreeConversionScript.sml | 11 +- semantics/lexer_funScript.sml | 70 +- .../proofs/cmlPtreeConversionPropsScript.sml | 482 ++- semantics/proofs/evaluatePropsScript.sml | 627 +-- semantics/proofs/gramPropsScript.sml | 46 +- semantics/proofs/namespacePropsScript.sml | 1066 +++-- semantics/proofs/primSemEnvScript.sml | 12 +- .../proofs/semanticPrimitivesPropsScript.sml | 558 ++- semantics/proofs/semanticsPropsScript.sml | 118 +- semantics/proofs/typeSoundScript.sml | 313 +- semantics/proofs/typeSysPropsScript.sml | 1506 ++++--- semantics/proofs/weakeningScript.sml | 411 +- semantics/terminationScript.sml | 122 +- semantics/tokenUtilsScript.sml | 24 +- translator/ml_optimiseScript.sml | 18 +- translator/ml_pmatchScript.sml | 90 +- translator/ml_progScript.sml | 687 +-- translator/ml_translatorScript.sml | 1602 ++++--- translator/ml_translator_demoScript.sml | 12 +- translator/ml_translator_testScript.sml | 10 +- translator/monadic/cfMonadScript.sml | 48 +- .../examples/floyd_warshallProgScript.sml | 82 +- translator/monadic/ml_monadStoreScript.sml | 252 +- .../monadic/ml_monad_translatorBaseScript.sml | 652 +-- .../monadic/ml_monad_translatorScript.sml | 882 ++-- .../monadic/monad_base/ml_monadBaseScript.sml | 102 +- .../okasaki-examples/BinomialHeapScript.sml | 120 +- .../BottomUpMergeSortScript.sml | 48 +- .../LazyPairingHeapScript.sml | 76 +- .../okasaki-examples/LeftistHeapScript.sml | 76 +- .../okasaki-examples/PairingHeapScript.sml | 76 +- .../okasaki-examples/RedBlackSetScript.sml | 58 +- .../okasaki-examples/SplayHeapScript.sml | 72 +- .../okasaki-examples/UnbalancedSetScript.sml | 36 +- .../okasaki-examples/okasaki_miscScript.sml | 94 +- .../auxiliary/ninetyOneScript.sml | 10 +- .../auxiliary/regexpMatchScript.sml | 10 +- translator/std_preludeScript.sml | 18 +- tutorial/arith_exp_demoScript.sml | 8 +- tutorial/simple_bstScript.sml | 90 +- tutorial/solutions/simple_bstScript.sml | 90 +- tutorial/solutions/wordfreqProgScript.sml | 95 +- tutorial/splitwordsScript.sml | 80 +- tutorial/wordcountProgScript.sml | 46 +- tutorial/wordfreqProgScript.sml | 95 +- tutorial/wordfreqProofScript.sml | 12 +- 315 files changed, 53951 insertions(+), 38131 deletions(-) diff --git a/basis/ArrayProofScript.sml b/basis/ArrayProofScript.sml index 19b7a9bbf5..5f8e55a6c3 100644 --- a/basis/ArrayProofScript.sml +++ b/basis/ArrayProofScript.sml @@ -20,49 +20,60 @@ fun prove_array_spec op_name = xsimpl \\ fs [INT_def, NUM_def, WORD_def, w2w_def, UNIT_TYPE_def, REPLICATE] \\ TRY (simp_tac (arith_ss ++ intSimps.INT_ARITH_ss) []) -Theorem array_alloc_spec - `!n nv v. +Theorem array_alloc_spec: + !n nv v. NUM n nv ==> app (p:'ffi ffi_proj) ^(fetch_v "Array.array" array_st) [nv; v] - emp (POSTv av. ARRAY av (REPLICATE n v))` - (prove_array_spec "Array.array"); + emp (POSTv av. ARRAY av (REPLICATE n v)) +Proof + prove_array_spec "Array.array" +QED -Theorem array_alloc_empty_spec - `!v. +Theorem array_alloc_empty_spec: + !v. UNIT_TYPE () v ⇒ app (p:'ffi ffi_proj) ^(fetch_v "Array.arrayEmpty" array_st) [v] - emp (POSTv av. ARRAY av [])` - (prove_array_spec "Array.arrayEmpty"); + emp (POSTv av. ARRAY av []) +Proof + prove_array_spec "Array.arrayEmpty" +QED -Theorem array_sub_spec - `!a av n nv. +Theorem array_sub_spec: + !a av n nv. NUM n nv /\ n < LENGTH a ==> app (p:'ffi ffi_proj) ^(fetch_v "Array.sub" array_st) [av; nv] - (ARRAY av a) (POSTv v. cond (v = EL n a) * ARRAY av a)` - (prove_array_spec "Array.sub"); + (ARRAY av a) (POSTv v. cond (v = EL n a) * ARRAY av a) +Proof + prove_array_spec "Array.sub" +QED -Theorem array_length_spec - `!a av. +Theorem array_length_spec: + !a av. app (p:'ffi ffi_proj) ^(fetch_v "Array.length" array_st) [av] (ARRAY av a) - (POSTv v. cond (NUM (LENGTH a) v) * ARRAY av a)` - (prove_array_spec "Array.length"); + (POSTv v. cond (NUM (LENGTH a) v) * ARRAY av a) +Proof + prove_array_spec "Array.length" +QED -Theorem array_update_spec - `!a av n nv v. +Theorem array_update_spec: + !a av n nv v. NUM n nv /\ n < LENGTH a ==> app (p:'ffi ffi_proj) ^(fetch_v "Array.update" array_st) [av; nv; v] (ARRAY av a) - (POSTv uv. cond (UNIT_TYPE () uv) * ARRAY av (LUPDATE v n a))` - (prove_array_spec "Array.update"); + (POSTv uv. cond (UNIT_TYPE () uv) * ARRAY av (LUPDATE v n a)) +Proof + prove_array_spec "Array.update" +QED -Theorem array_fromList_spec - `!l lv a A. +Theorem array_fromList_spec: + !l lv a A. LIST_TYPE A l lv /\ v_to_list lv = SOME a ==> app (p:'ffi ffi_proj) ^(fetch_v "Array.fromList" array_st) [lv] - emp (POSTv av. ARRAY av a)` - (xcf "Array.fromList" array_st \\ + emp (POSTv av. ARRAY av a) +Proof + xcf "Array.fromList" array_st \\ xfun_spec `f` `!ls lsv i iv a l_pre rest ar. NUM i iv /\ LENGTH l_pre = i /\ @@ -134,7 +145,8 @@ Theorem array_fromList_spec qpat_x_assum`_ = list_type_num`(assume_tac o SYM) \\ fs[GSYM ADD1] \\ disch_then xapp_spec >> xsimpl >> - rw [REPLICATE, GSYM ADD1]); + rw [REPLICATE, GSYM ADD1] +QED val eq_v_thm = fetch "mlbasicsProg" "eq_v_thm" val eq_num_v_thm = MATCH_MP (DISCH_ALL eq_v_thm) (EqualityType_NUM_BOOL |> CONJUNCT1) @@ -143,12 +155,13 @@ val num_eq_thm = Q.prove( `!n nv x xv. NUM n nv /\ NUM x xv ==> (n = x <=> nv = xv)`, metis_tac[EqualityType_NUM_BOOL, EqualityType_def]); -Theorem array_tabulate_spec - `!n nv f fv (A: 'a -> v -> bool). +Theorem array_tabulate_spec: + !n nv f fv (A: 'a -> v -> bool). NUM n nv /\ (NUM --> A) f fv ==> app (p:'ffi ffi_proj) ^(fetch_v "Array.tabulate" array_st) [nv; fv] - emp (POSTv av. SEP_EXISTS vs. ARRAY av vs * cond (EVERY2 A (GENLIST f n) vs))` - (xcf "Array.tabulate" array_st + emp (POSTv av. SEP_EXISTS vs. ARRAY av vs * cond (EVERY2 A (GENLIST f n) vs)) +Proof + xcf "Array.tabulate" array_st \\ xfun_spec `u` `!x xv l_pre rest av. NUM x xv /\ LENGTH l_pre = x /\ LENGTH l_pre + LENGTH rest = n ==> @@ -220,7 +233,8 @@ Theorem array_tabulate_spec disch_then xapp_spec >> xsimpl >> rw [REPLICATE, GENLIST_CONS] >> - simp [combinTheory.o_DEF, ADD1]); + simp [combinTheory.o_DEF, ADD1] +QED (* val _ = show_types := false @@ -257,16 +271,17 @@ val lupdate_breakdown_thm = Q.prove( \\ EVAL_TAC \\ rw[lupdate_append2] ); -Theorem array_copy_aux_spec - `!src n srcv dstv di div nv max maxv bfr mid afr. +Theorem array_copy_aux_spec: + !src n srcv dstv di div nv max maxv bfr mid afr. NUM di div /\ NUM n nv /\ NUM max maxv /\ di = LENGTH bfr/\ LENGTH mid = max - n /\ n <= max /\ max <= LENGTH src ==> app (p:'ffi ffi_proj) Array_copy_aux_v [srcv; dstv; div; maxv; nv] (ARRAY srcv src * ARRAY dstv (bfr ++ mid ++ afr)) (POSTv uv. ARRAY srcv src * - ARRAY dstv (bfr ++ (TAKE (max -n) (DROP n src)) ++ afr))` - (gen_tac \\ gen_tac \\ Induct_on `max - n` >> + ARRAY dstv (bfr ++ (TAKE (max -n) (DROP n src)) ++ afr)) +Proof + gen_tac \\ gen_tac \\ Induct_on `max - n` >> xcf_with_def "Array.copy_aux" Array_copy_aux_v_def >-(xlet_auto >> (xsimpl >> xif) >> instantiate >> xcon >> xsimpl >> metis_tac[TAKE_0,LENGTH_NIL]) >> @@ -285,21 +300,24 @@ Theorem array_copy_aux_spec cases_on`DROP n src` >- fs[DROP_NIL] >> `EL (0 + n) src = EL 0 (DROP n src)` by fs[EL_DROP] >> fs[] >> `DROP 1 (DROP n src) = t'` by fs[GSYM DROP_DROP_T] >> - fs[DROP_DROP_T]); + fs[DROP_DROP_T] +QED -Theorem array_copy_spec - `!src srcv bfr mid afr dstv di div. +Theorem array_copy_spec: + !src srcv bfr mid afr dstv di div. NUM di div /\ LENGTH src = LENGTH mid /\ di = LENGTH bfr ==> app (p:'ffi ffi_proj) ^(fetch_v "Array.copy" array_st) [srcv; dstv; div] (ARRAY srcv src * ARRAY dstv (bfr ++ mid ++ afr)) - (POSTv uv. ARRAY srcv src * ARRAY dstv (bfr ++ src ++ afr))` - (xcf "Array.copy" array_st \\ + (POSTv uv. ARRAY srcv src * ARRAY dstv (bfr ++ src ++ afr)) +Proof + xcf "Array.copy" array_st \\ xlet_auto >- xsimpl >> xapp >> xsimpl >> instantiate >> - fs[] >> instantiate >> metis_tac[TAKE_LENGTH_ID]); + fs[] >> instantiate >> metis_tac[TAKE_LENGTH_ID] +QED -Theorem array_app_aux_spec - `∀l idx len_v idx_v a_v f_v eff. +Theorem array_app_aux_spec: + ∀l idx len_v idx_v a_v f_v eff. NUM (LENGTH l) len_v ∧ NUM idx idx_v ∧ idx ≤ LENGTH l ∧ @@ -309,8 +327,9 @@ Theorem array_app_aux_spec ⇒ app (p:'ffi ffi_proj) Array_app_aux_v [f_v; a_v; len_v; idx_v] (eff l idx * ARRAY a_v l) - (POSTv v. &UNIT_TYPE () v * (eff l (LENGTH l)) * ARRAY a_v l)` - (ntac 2 gen_tac >> + (POSTv v. &UNIT_TYPE () v * (eff l (LENGTH l)) * ARRAY a_v l) +Proof + ntac 2 gen_tac >> completeInduct_on `LENGTH l - idx` >> xcf_with_def "Array.app_aux" Array_app_aux_v_def >> rw [] >> @@ -342,25 +361,28 @@ Theorem array_app_aux_spec fs [NUM_def, INT_def] >> intLib.ARITH_TAC) >> first_x_assum xapp_spec >> - simp []); + simp [] +QED (* eff is the effect of executing the function on the first n elements of l *) -Theorem array_app_spec - `∀l a_v f_v eff. +Theorem array_app_spec: + ∀l a_v f_v eff. (!n. n < LENGTH l ⇒ app p f_v [EL n l] (eff l n) (POSTv v. &UNIT_TYPE () v * (eff l (n+1)))) ⇒ app (p:'ffi ffi_proj) ^(fetch_v "Array.app" array_st) [f_v; a_v] (eff l 0 * ARRAY a_v l) - (POSTv v. &UNIT_TYPE () v * (eff l (LENGTH l)) * ARRAY a_v l)` - (rw [] >> + (POSTv v. &UNIT_TYPE () v * (eff l (LENGTH l)) * ARRAY a_v l) +Proof + rw [] >> xcf "Array.app" array_st >> xlet `POSTv len_v. eff l 0 * ARRAY a_v l * &NUM (LENGTH l) len_v` >- ( xapp >> xsimpl) >> xapp >> - rw [NUM_def]); + rw [NUM_def] +QED val list_rel_take_thm = Q.prove( `!A xs ys n. @@ -378,12 +400,13 @@ val ARRAY_TYPE_def = Define` ARRAY_TYPE A a av = SEP_EXISTS vs. ARRAY av vs * & LIST_REL A a vs`; *) -Theorem array_modify_aux_spec - `!a n f fv vs av max maxv nv A. +Theorem array_modify_aux_spec: + !a n f fv vs av max maxv nv A. NUM max maxv /\ LENGTH a = max /\ NUM n nv /\ (A --> A) f fv /\ n <= max /\ LIST_REL A a vs ==> app (p:'ffi ffi_proj) Array_modify_aux_v [fv; av; maxv; nv] - (ARRAY av vs) (POSTv uv. SEP_EXISTS vs1 vs2. ARRAY av (vs1 ++ vs2) * cond(EVERY2 A (TAKE n a) vs1) * cond(EVERY2 A (MAP f (DROP n a)) vs2))` - (gen_tac \\ gen_tac \\ Induct_on `LENGTH a - n` + (ARRAY av vs) (POSTv uv. SEP_EXISTS vs1 vs2. ARRAY av (vs1 ++ vs2) * cond(EVERY2 A (TAKE n a) vs1) * cond(EVERY2 A (MAP f (DROP n a)) vs2)) +Proof + gen_tac \\ gen_tac \\ Induct_on `LENGTH a - n` >-(xcf_with_def "Array.modify_aux" Array_modify_aux_v_def \\ rw[] \\ xlet `POSTv bool. & (BOOL (nv = maxv) bool) * ARRAY av vs` >- (xapp_spec eq_num_v_thm \\ xsimpl \\ instantiate \\ fs[NUM_def, INT_def, BOOL_def]) @@ -429,28 +452,31 @@ Theorem array_modify_aux_spec \\ simp[] \\ fs[ADD1] \\ qpat_x_assum`_ = LENGTH x`(SUBST_ALL_TAC o SYM) - \\ fs[]); + \\ fs[] +QED -Theorem array_modify_spec - `!f fv a vs av A A'. +Theorem array_modify_spec: + !f fv a vs av A A'. (A --> A) f fv /\ LIST_REL A a vs ==> app (p:'ffi ffi_proj) ^(fetch_v "Array.modify" array_st) [fv; av] - (ARRAY av vs) (POSTv uv. SEP_EXISTS vs1. ARRAY av vs1 * cond(EVERY2 A (MAP f a) vs1))` - (xcf "Array.modify" array_st + (ARRAY av vs) (POSTv uv. SEP_EXISTS vs1. ARRAY av vs1 * cond(EVERY2 A (MAP f a) vs1)) +Proof + xcf "Array.modify" array_st \\ xlet `POSTv len. & NUM (LENGTH a) len * ARRAY av vs` >-(xapp \\ xsimpl \\ imp_res_tac LIST_REL_LENGTH \\ fs[INT_def, NUM_def]) \\ xapp \\ xsimpl \\ instantiate -); +QED -Theorem array_modifyi_aux_spec - `!a n f fv vs av max maxv nv A. +Theorem array_modifyi_aux_spec: + !a n f fv vs av max maxv nv A. NUM max maxv /\ max = LENGTH a /\ NUM n nv /\ (NUM --> A --> A) f fv /\ n <= max /\ LIST_REL A a vs ==> app (p:'ffi ffi_proj) Array_modifyi_aux_v [fv; av; maxv; nv] (ARRAY av vs) (POSTv uv. SEP_EXISTS vs1 vs2. ARRAY av (vs1 ++ vs2) * cond(EVERY2 A (TAKE n a) vs1) * - cond(EVERY2 A (MAPi (\i. f (n + i)) (DROP n a)) vs2))` - (gen_tac \\ gen_tac \\ Induct_on `LENGTH a - n` + cond(EVERY2 A (MAPi (\i. f (n + i)) (DROP n a)) vs2)) +Proof + gen_tac \\ gen_tac \\ Induct_on `LENGTH a - n` >-(xcf_with_def "Array.modifyi_aux" Array_modifyi_aux_v_def \\ xlet `POSTv bool. & BOOL (nv=maxv) bool * ARRAY av vs` >-(xapp_spec eq_num_v_thm \\ xsimpl \\ instantiate \\ fs[INT_def, NUM_def, BOOL_def]) @@ -495,28 +521,30 @@ Theorem array_modifyi_aux_spec \\ first_x_assum(qspec_then`z`mp_tac) \\ simp[] \\ fs[ADD1] \\ qpat_x_assum`_ = LENGTH x`(SUBST_ALL_TAC o SYM) \\ fs[] -); +QED -Theorem array_modifyi_spec - `!f fv a vs av A A'. +Theorem array_modifyi_spec: + !f fv a vs av A A'. (NUM --> A --> A) f fv /\ LIST_REL A a vs ==> app (p:'ffi ffi_proj) ^(fetch_v "Array.modifyi" array_st) [fv; av] - (ARRAY av vs) (POSTv uv. SEP_EXISTS vs1. ARRAY av vs1 * cond(EVERY2 A (MAPi f a) vs1))` - (xcf "Array.modifyi" array_st + (ARRAY av vs) (POSTv uv. SEP_EXISTS vs1. ARRAY av vs1 * cond(EVERY2 A (MAPi f a) vs1)) +Proof + xcf "Array.modifyi" array_st \\ xlet `POSTv len. & NUM (LENGTH a) len * ARRAY av vs` >-(xapp \\ xsimpl \\ imp_res_tac LIST_REL_LENGTH \\ fs[INT_def, NUM_def]) \\ xapp \\ xsimpl \\ metis_tac [BETA_THM] -); +QED (* -Theorem array_foldli_aux_spec - `!a n f fv init initv vs av max maxv nv (A:'a->v->bool) (B:'b->v->bool). +Theorem array_foldli_aux_spec: + !a n f fv init initv vs av max maxv nv (A:'a->v->bool) (B:'b->v->bool). (NUM-->B-->A-->A) f fv /\ LIST_REL B a vs /\ A init initv /\ NUM max maxv /\ NUM n nv /\ max = LENGTH a /\ n <= max ==> app (p:'ffi ffi_proj) Array_foldli_aux_v [fv; initv; av; maxv; nv] - (ARRAY av vs) (POSTv val. & A (mllist$foldli (\i. f (i + n)) init (DROP n a)) val * ARRAY av vs)` - (gen_tac \\ gen_tac \\ Induct_on `LENGTH a - n` + (ARRAY av vs) (POSTv val. & A (mllist$foldli (\i. f (i + n)) init (DROP n a)) val * ARRAY av vs) +Proof + gen_tac \\ gen_tac \\ Induct_on `LENGTH a - n` >-(xcf_with_def "foldli_aux" Array_foldli_aux_v_def \\ xlet `POSTv bool. & BOOL (nv = maxv) bool * ARRAY av vs` >-(xapp \\ xsimpl \\ instantiate\\ fs[BOOL_def, INT_def, NUM_def]) @@ -537,26 +565,28 @@ Theorem array_foldli_aux_spec \\ first_x_assum(qspecl_then [`a`, `n + 1`] mp_tac) \\ rw[] \\ xapp \\ xsimpl \\ instantiate \\ rw[mllistTheory.foldli_def, mllistTheory.foldli_aux_def, DROP_EL_CONS] \\ ... (*How to deal with foldli_aux as it has nothing proved about it *) -); +QED -Theorem array_foldli_spec - `!f fv init initv a vs av (A:'a->v->bool) (B:'b->v->bool). +Theorem array_foldli_spec: + !f fv init initv a vs av (A:'a->v->bool) (B:'b->v->bool). (NUM-->B-->A-->A) f fv /\ LIST_REL B a vs /\ A init initv ==> app (p:'ffi ffi_proj) ^(fetch_v "foldli" foldli_st) [fv; initv; av] - (ARRAY av vs) (POSTv val. &A (mllist$foldli f init a) val * ARRAY av vs)` - (xcf "foldli" foldli_st + (ARRAY av vs) (POSTv val. &A (mllist$foldli f init a) val * ARRAY av vs) +Proof + xcf "foldli" foldli_st \\ xlet `POSTv len. & NUM (LENGTH a) len * ARRAY av vs` >-(xapp \\ xsimpl \\ imp_res_tac LIST_REL_LENGTH \\ fs[]) \\ xapp \\ xsimpl \\ instantiate \\ srw_tac[ETA_ss][] -); +QED -Theorem array_foldl_aux_spec - `!f fv init initv a vs av max maxv n nv (A:'a->v->bool) (B:'b->v->bool). +Theorem array_foldl_aux_spec: + !f fv init initv a vs av max maxv n nv (A:'a->v->bool) (B:'b->v->bool). (B-->A-->A) f fv /\ LIST_REL B a vs /\ A init initv /\ NUM max maxv /\ NUM n nv /\ max = LENGTH a /\ n <= max ==> app (p:'ffi ffi_proj) Array_foldl_aux_v [fv; initv; av; maxv; nv] - (ARRAY av vs) (POSTv val. & A (FOLDL (\i. f (i + n)) init (DROP n a)) val * ARRAY av vs)` - (xcf_with_def "foldl_aux" Array_foldl_aux_v_def + (ARRAY av vs) (POSTv val. & A (FOLDL (\i. f (i + n)) init (DROP n a)) val * ARRAY av vs) +Proof + xcf_with_def "foldl_aux" Array_foldl_aux_v_def \\ xlet `POSTv bool. & BOOL (nv = maxv) bool * ARRAY av vs` >-(xapp \\ xsimpl \\ instantiate\\ fs[BOOL_def, INT_def, NUM_def]) \\ xif @@ -570,27 +600,29 @@ Theorem array_foldl_aux_spec \\ Induct_on `LENGTH a - n` >-(rw[] \\ imp_res_tac LIST_REL_LENGTH \\ fs[NUM_def, INT_def] \\ rfs[]) \\ rw[] \\ ... (*xapp*) -); +QED -Theorem array_foldl_spec - `!f fv init initv a vs av (A:'a->v->bool) (B:'b->v->bool). +Theorem array_foldl_spec: + !f fv init initv a vs av (A:'a->v->bool) (B:'b->v->bool). (B-->A-->A) f fv /\ LIST_REL B a vs /\ A init initv ==> app (p:'ffi ffi_proj) ^(fetch_v "foldl" foldl_st) [fv; initv; av] - (ARRAY av vs) (POSTv val. &A (FOLDL f init a) val * ARRAY av vs)` - (xcf "foldl" foldl_st + (ARRAY av vs) (POSTv val. &A (FOLDL f init a) val * ARRAY av vs) +Proof + xcf "foldl" foldl_st \\ xlet `POSTv len. & NUM (LENGTH a) len * ARRAY av vs` >-(xapp \\ xsimpl \\ imp_res_tac LIST_REL_LENGTH \\ fs[]) \\ xapp \\ xsimpl \\ instantiate -); +QED -Theorem array_foldri_aux_spec - `!n f fv init initv a vs av nv (A:'a->v->bool) (B:'b->v->bool). +Theorem array_foldri_aux_spec: + !n f fv init initv a vs av nv (A:'a->v->bool) (B:'b->v->bool). (NUM-->B-->A-->A) f fv /\ LIST_REL B a vs /\ A init initv /\ NUM n nv /\ n <= LENGTH a ==> app (p:'ffi ffi_proj) Array_foldri_aux_v [fv; initv; av; nv] - (ARRAY av vs) (POSTv val. & A (FOLDRi f init (TAKE n a)) val * ARRAY av vs)` - (gen_tac \\ Induct_on `n` + (ARRAY av vs) (POSTv val. & A (FOLDRi f init (TAKE n a)) val * ARRAY av vs) +Proof + gen_tac \\ Induct_on `n` >-(xcf_with_def "foldri_aux" Array_foldri_aux_v_def \\ xlet `POSTv bool. SEP_EXISTS ov. & BOOL (nv = ov) bool * ARRAY av vs * & NUM 0 ov` >-(xapp \\ xsimpl \\ instantiate \\ fs[NUM_def, INT_def]) @@ -614,29 +646,31 @@ Theorem array_foldri_aux_spec >-(xapp \\ xsimpl \\ instantiate \\ qexists_tac`EL n a` \\ fs[LIST_REL_EL_EQN]) \\ xapp \\ xsimpl \\ instantiate \\ fs[TAKE_EL_SNOC, ADD1] (*need something similar to FOLDR SNOC*) \\ ... -); +QED -Theorem array_foldri_spec - `!f fv init initv a av vs (A:'a->v->bool) (B:'b->v->bool). +Theorem array_foldri_spec: + !f fv init initv a av vs (A:'a->v->bool) (B:'b->v->bool). (NUM-->B-->A-->A) f fv /\ LIST_REL B a vs /\ A init initv ==> app (p:'ffi ffi_proj) ^(fetch_v "foldri" foldri_st) [fv; initv; av] - (ARRAY av vs) (POSTv val. & A (FOLDRi f init a) val * ARRAY av vs)` - (xcf "foldri" foldri_st + (ARRAY av vs) (POSTv val. & A (FOLDRi f init a) val * ARRAY av vs) +Proof + xcf "foldri" foldri_st \\ xlet `POSTv len. & NUM (LENGTH vs) len * ARRAY av vs` >-(xapp \\ xsimpl) \\ xapp \\ xsimpl \\ instantiate \\ imp_res_tac LIST_REL_LENGTH \\ fs[] \\ metis_tac[TAKE_LENGTH_ID] -); +QED *) -Theorem array_foldr_aux_spec - `!n f fv init initv a vs av nv (A:'a->v->bool) (B:'b->v->bool). +Theorem array_foldr_aux_spec: + !n f fv init initv a vs av nv (A:'a->v->bool) (B:'b->v->bool). (B-->A-->A) f fv /\ LIST_REL B a vs /\ A init initv /\ NUM n nv /\ n <= LENGTH a ==> app (p:'ffi ffi_proj) Array_foldr_aux_v [fv; initv; av; nv] - (ARRAY av vs) (POSTv val. & A (FOLDR f init (TAKE n a)) val * ARRAY av vs)` - (gen_tac \\ Induct_on `n` + (ARRAY av vs) (POSTv val. & A (FOLDR f init (TAKE n a)) val * ARRAY av vs) +Proof + gen_tac \\ Induct_on `n` >-(xcf_with_def "Array.foldr_aux" Array_foldr_aux_v_def \\ xlet `POSTv bool. SEP_EXISTS ov. & BOOL (nv = ov) bool * ARRAY av vs * & NUM 0 ov` >-(xapp_spec eq_num_v_thm \\ xsimpl \\ instantiate \\ fs[NUM_def, INT_def]) @@ -657,18 +691,19 @@ Theorem array_foldr_aux_spec \\ xlet `POSTv res. & (A (f (EL n a) init) res) * ARRAY av vs` >-(xapp \\ xsimpl \\ instantiate \\ qexists_tac`EL n a` \\ fs[LIST_REL_EL_EQN]) \\ xapp \\ xsimpl \\ instantiate \\ fs[TAKE_EL_SNOC, ADD1, FOLDR_SNOC] -); +QED -Theorem array_foldr_spec - `!f fv init initv a av vs (A:'a->v->bool) (B:'b->v->bool). +Theorem array_foldr_spec: + !f fv init initv a av vs (A:'a->v->bool) (B:'b->v->bool). (B-->A-->A) f fv /\ LIST_REL B a vs /\ A init initv ==> app (p:'ffi ffi_proj) ^(fetch_v "Array.foldr" array_st) [fv; initv; av] - (ARRAY av vs) (POSTv val. & A (FOLDR f init a) val * ARRAY av vs)` - (xcf "Array.foldr" array_st + (ARRAY av vs) (POSTv val. & A (FOLDR f init a) val * ARRAY av vs) +Proof + xcf "Array.foldr" array_st \\ xlet `POSTv len. & NUM (LENGTH vs) len * ARRAY av vs` >-(xapp \\ xsimpl) \\ xapp \\ xsimpl \\ instantiate \\ imp_res_tac LIST_REL_LENGTH \\ fs[] \\metis_tac[TAKE_LENGTH_ID] -); +QED val _ = export_theory(); diff --git a/basis/CommandLineProofScript.sml b/basis/CommandLineProofScript.sml index 4e8275608c..2e88845f2f 100644 --- a/basis/CommandLineProofScript.sml +++ b/basis/CommandLineProofScript.sml @@ -30,23 +30,26 @@ val COMMANDLINE_precond = Q.prove( rw[set_thm]) |> UNDISCH |> curry save_thm "COMMANDLINE_precond"; -Theorem COMMANDLINE_FFI_part_hprop - `FFI_part_hprop (COMMANDLINE x)` - (rw [COMMANDLINE_def,cfHeapsBaseTheory.IO_def,cfMainTheory.FFI_part_hprop_def, +Theorem COMMANDLINE_FFI_part_hprop: + FFI_part_hprop (COMMANDLINE x) +Proof + rw [COMMANDLINE_def,cfHeapsBaseTheory.IO_def,cfMainTheory.FFI_part_hprop_def, cfHeapsBaseTheory.IOx_def, cl_ffi_part_def, set_sepTheory.SEP_CLAUSES,set_sepTheory.SEP_EXISTS_THM, set_sepTheory.cond_STAR ] - \\ fs[set_sepTheory.one_def]); + \\ fs[set_sepTheory.one_def] +QED val eq_v_thm = fetch "mlbasicsProg" "eq_v_thm" val eq_num_v_thm = MATCH_MP (DISCH_ALL eq_v_thm) (EqualityType_NUM_BOOL |> CONJUNCT1) -Theorem CommandLine_read16bit - `2 <= LENGTH a ==> +Theorem CommandLine_read16bit: + 2 <= LENGTH a ==> app (p:'ffi ffi_proj) CommandLine_read16bit_v [av] (W8ARRAY av a) - (POSTv v. W8ARRAY av a * & NUM (w2n (EL 0 a) + 256 * w2n (EL 1 a)) v)` - (xcf_with_def "CommandLine.read16bit" CommandLine_read16bit_v_def + (POSTv v. W8ARRAY av a * & NUM (w2n (EL 0 a) + 256 * w2n (EL 1 a)) v) +Proof + xcf_with_def "CommandLine.read16bit" CommandLine_read16bit_v_def \\ xlet_auto THEN1 xsimpl \\ xlet_auto THEN1 (fs [] \\ xsimpl) \\ xlet_auto THEN1 (fs [] \\ xsimpl) @@ -56,14 +59,16 @@ Theorem CommandLine_read16bit \\ Cases_on `a` \\ fs [] \\ Cases_on `t` \\ fs [NUM_def] \\ rpt (asm_exists_tac \\ fs []) \\ Cases_on `h` \\ Cases_on `h'` \\ fs [] - \\ fs [INT_def] \\ intLib.COOPER_TAC); + \\ fs [INT_def] \\ intLib.COOPER_TAC +QED -Theorem CommandLine_write16bit - `NUM n nv /\ 2 <= LENGTH a ==> +Theorem CommandLine_write16bit: + NUM n nv /\ 2 <= LENGTH a ==> app (p:'ffi ffi_proj) CommandLine_write16bit_v [av;nv] (W8ARRAY av a) - (POSTv v. W8ARRAY av (n2w n::n2w (n DIV 256)::TL (TL a)))` - (xcf_with_def "CommandLine.write16bit" CommandLine_write16bit_v_def + (POSTv v. W8ARRAY av (n2w n::n2w (n DIV 256)::TL (TL a))) +Proof + xcf_with_def "CommandLine.write16bit" CommandLine_write16bit_v_def \\ xlet_auto THEN1 xsimpl \\ xlet_auto THEN1 (fs [] \\ xsimpl) \\ xlet_auto THEN1 (fs [] \\ xsimpl) @@ -71,7 +76,8 @@ Theorem CommandLine_write16bit \\ xapp \\ xsimpl \\ Cases_on `a` \\ fs [] \\ Cases_on `t` \\ fs [NUM_def] \\ rpt (asm_exists_tac \\ fs []) - \\ EVAL_TAC); + \\ EVAL_TAC +QED val SUC_SUC_LENGTH = prove( ``SUC (SUC (LENGTH (TL (TL (REPLICATE (MAX 2 n) x))))) = (MAX 2 n)``, @@ -103,14 +109,15 @@ val DROP_SUC_LENGTH_MAP = prove( SUC (LENGTH ys) = LENGTH (MAP f ys ⧺ [y])` THEN1 simp_tac std_ss [DROP_LENGTH_APPEND] \\ fs []); -Theorem CommandLine_cloop_spec - `!n nv av cv a. +Theorem CommandLine_cloop_spec: + !n nv av cv a. LIST_TYPE STRING_TYPE (DROP n cl) cv /\ NUM n nv /\ n <= LENGTH cl /\ LENGTH a = 2 ==> app (p:'ffi ffi_proj) CommandLine_cloop_v [av; nv; cv] (COMMANDLINE cl * W8ARRAY av a) - (POSTv v. & LIST_TYPE STRING_TYPE cl v * COMMANDLINE cl)` - (rw [] \\ qpat_abbrev_tac `Q = $POSTv _` + (POSTv v. & LIST_TYPE STRING_TYPE cl v * COMMANDLINE cl) +Proof + rw [] \\ qpat_abbrev_tac `Q = $POSTv _` \\ simp [COMMANDLINE_def, cl_ffi_part_def, IOx_def, IO_def] \\ xpull \\ qunabbrev_tac `Q` \\ rpt (pop_assum mp_tac) @@ -193,14 +200,16 @@ Theorem CommandLine_cloop_spec \\ asm_rewrite_tac [TAKE_LENGTH_APPEND] \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,APPEND,EL_LENGTH_APPEND,NULL,HD] \\ fs [MAP_MAP_o, CHR_w2n_n2w_ORD, GSYM mlstringTheory.implode_def] - \\ fs[DROP_APPEND,DROP_LENGTH_TOO_LONG]); + \\ fs[DROP_APPEND,DROP_LENGTH_TOO_LONG] +QED -Theorem CommandLine_cline_spec - `UNIT_TYPE u uv ==> +Theorem CommandLine_cline_spec: + UNIT_TYPE u uv ==> app (p:'ffi ffi_proj) CommandLine_cline_v [uv] (COMMANDLINE cl) - (POSTv v. & LIST_TYPE STRING_TYPE cl v * COMMANDLINE cl)` - (rw [] \\ qpat_abbrev_tac `Q = $POSTv _` + (POSTv v. & LIST_TYPE STRING_TYPE cl v * COMMANDLINE cl) +Proof + rw [] \\ qpat_abbrev_tac `Q = $POSTv _` \\ simp [COMMANDLINE_def,cl_ffi_part_def,IOx_def,IO_def] \\ xpull \\ qunabbrev_tac `Q` \\ xcf_with_def "CommandLine.cline" CommandLine_cline_v_def @@ -240,22 +249,25 @@ Theorem CommandLine_cline_spec \\ `DROP (LENGTH cl) cl = []` by fs [DROP_NIL] \\ fs [LIST_TYPE_def] \\ fs [wfcl_def] \\ rfs [two_byte_sum] - \\ rw [] \\ qexists_tac `x` \\ xsimpl); + \\ rw [] \\ qexists_tac `x` \\ xsimpl +QED val hd_v_thm = fetch "ListProg" "hd_v_thm"; val mlstring_hd_v_thm = hd_v_thm |> INST_TYPE [alpha |-> mlstringSyntax.mlstring_ty] -Theorem CommandLine_name_spec - `UNIT_TYPE u uv ==> +Theorem CommandLine_name_spec: + UNIT_TYPE u uv ==> app (p:'ffi ffi_proj) CommandLine_name_v [uv] (COMMANDLINE cl) - (POSTv namev. & STRING_TYPE (HD cl) namev * COMMANDLINE cl)` - (xcf_with_def "CommandLine.name" CommandLine_name_v_def + (POSTv namev. & STRING_TYPE (HD cl) namev * COMMANDLINE cl) +Proof + xcf_with_def "CommandLine.name" CommandLine_name_v_def \\ xlet `POSTv cs. & LIST_TYPE STRING_TYPE cl cs * COMMANDLINE cl` >-(xapp \\ rw[] \\ fs []) \\ Cases_on`cl=[]` >- ( fs[COMMANDLINE_def] \\ xpull \\ fs[wfcl_def] ) \\ xapp_spec mlstring_hd_v_thm - \\ xsimpl \\ instantiate \\ Cases_on `cl` \\ rw[]); + \\ xsimpl \\ instantiate \\ Cases_on `cl` \\ rw[] +QED val tl_v_thm = fetch "ListProg" "tl_v_thm"; val mlstring_tl_v_thm = tl_v_thm |> INST_TYPE [alpha |-> mlstringSyntax.mlstring_ty] @@ -263,57 +275,67 @@ val mlstring_tl_v_thm = tl_v_thm |> INST_TYPE [alpha |-> mlstringSyntax.mlstring val name_def = Define ` name () = (\cl. (Success (HD cl), cl))`; -Theorem EvalM_name - `Eval env exp (UNIT_TYPE u) /\ +Theorem EvalM_name: + Eval env exp (UNIT_TYPE u) /\ (nsLookup env.v (Long "CommandLine" (Short "name")) = SOME CommandLine_name_v) ==> EvalM F env st (App Opapp [Var (Long "CommandLine" (Short "name")); exp]) (MONAD STRING_TYPE exc_ty (name u)) - (COMMANDLINE,p:'ffi ffi_proj)` - (ho_match_mp_tac EvalM_from_app \\ rw [name_def] - \\ metis_tac [CommandLine_name_spec]); + (COMMANDLINE,p:'ffi ffi_proj) +Proof + ho_match_mp_tac EvalM_from_app \\ rw [name_def] + \\ metis_tac [CommandLine_name_spec] +QED -Theorem CommandLine_arguments_spec - `UNIT_TYPE u uv ==> +Theorem CommandLine_arguments_spec: + UNIT_TYPE u uv ==> app (p:'ffi ffi_proj) CommandLine_arguments_v [uv] (COMMANDLINE cl) (POSTv argv. & LIST_TYPE STRING_TYPE - (TL cl) argv * COMMANDLINE cl)` - (xcf_with_def "CommandLine.arguments" CommandLine_arguments_v_def + (TL cl) argv * COMMANDLINE cl) +Proof + xcf_with_def "CommandLine.arguments" CommandLine_arguments_v_def \\ xlet `POSTv cs. & LIST_TYPE STRING_TYPE cl cs * COMMANDLINE cl` >-(xapp \\ rw[] \\ fs []) \\ Cases_on`cl=[]` >- ( fs[COMMANDLINE_def] \\ xpull \\ fs[wfcl_def] ) \\ xapp_spec mlstring_tl_v_thm \\ xsimpl \\ instantiate - \\ Cases_on `cl` \\ rw[TL_DEF]); + \\ Cases_on `cl` \\ rw[TL_DEF] +QED val arguments_def = Define ` arguments () = (\cl. (Success (TL cl), cl))` -Theorem EvalM_arguments - `Eval env exp (UNIT_TYPE u) /\ +Theorem EvalM_arguments: + Eval env exp (UNIT_TYPE u) /\ (nsLookup env.v (Long "CommandLine" (Short "arguments")) = SOME CommandLine_arguments_v) ==> EvalM F env st (App Opapp [Var (Long "CommandLine" (Short "arguments")); exp]) (MONAD (LIST_TYPE STRING_TYPE) exc_ty (arguments u)) - (COMMANDLINE,p:'ffi ffi_proj)` - (ho_match_mp_tac EvalM_from_app \\ rw [arguments_def] - \\ metis_tac [CommandLine_arguments_spec]); + (COMMANDLINE,p:'ffi ffi_proj) +Proof + ho_match_mp_tac EvalM_from_app \\ rw [arguments_def] + \\ metis_tac [CommandLine_arguments_spec] +QED fun prove_hprop_inj_tac thm = rw[HPROP_INJ_def, GSYM STAR_ASSOC, SEP_CLAUSES, SEP_EXISTS_THM, HCOND_EXTRACT] >> EQ_TAC >-(DISCH_TAC >> IMP_RES_TAC thm >> rw[]) >> rw[]; -Theorem UNIQUE_COMMANDLINE - `!s cl1 cl2 H1 H2. VALID_HEAP s ==> - (COMMANDLINE cl1 * H1) s /\ (COMMANDLINE cl2 * H2) s ==> cl2 = cl1` - (rw[COMMANDLINE_def,cfHeapsBaseTheory.IOx_def,cl_ffi_part_def, +Theorem UNIQUE_COMMANDLINE: + !s cl1 cl2 H1 H2. VALID_HEAP s ==> + (COMMANDLINE cl1 * H1) s /\ (COMMANDLINE cl2 * H2) s ==> cl2 = cl1 +Proof + rw[COMMANDLINE_def,cfHeapsBaseTheory.IOx_def,cl_ffi_part_def, GSYM STAR_ASSOC] \\ IMP_RES_TAC FRAME_UNIQUE_IO \\ fs[] \\ rw[] - \\ metis_tac[decode_encode,SOME_11]); + \\ metis_tac[decode_encode,SOME_11] +QED -Theorem COMMANDLINE_HPROP_INJ[hprop_inj] - `!cl1 cl2. HPROP_INJ (COMMANDLINE cl1) (COMMANDLINE cl2) (cl2 = cl1)` - (prove_hprop_inj_tac UNIQUE_COMMANDLINE); +Theorem COMMANDLINE_HPROP_INJ[hprop_inj]: + !cl1 cl2. HPROP_INJ (COMMANDLINE cl1) (COMMANDLINE cl2) (cl2 = cl1) +Proof + prove_hprop_inj_tac UNIQUE_COMMANDLINE +QED val _ = export_theory(); diff --git a/basis/IntProgScript.sml b/basis/IntProgScript.sml index c38dffb6b7..0f8b2f4c7d 100644 --- a/basis/IntProgScript.sml +++ b/basis/IntProgScript.sml @@ -93,10 +93,12 @@ val fromstring_unsafe_side_def = definition"fromstring_unsafe_side_def"; val fromchars_unsafe_side_def = theorem"fromchars_unsafe_side_def"; val fromchars_range_unsafe_side_def = theorem"fromchars_range_unsafe_side_def"; -Theorem fromchars_unsafe_side_thm - `∀n s. n ≤ LENGTH s ⇒ fromchars_unsafe_side n (strlit s)` - (completeInduct_on`n` \\ rw[] - \\ rw[Once fromchars_unsafe_side_def,fromchars_range_unsafe_side_def]); +Theorem fromchars_unsafe_side_thm: + ∀n s. n ≤ LENGTH s ⇒ fromchars_unsafe_side n (strlit s) +Proof + completeInduct_on`n` \\ rw[] + \\ rw[Once fromchars_unsafe_side_def,fromchars_range_unsafe_side_def] +QED val fromString_unsafe_side = Q.prove( `∀x. fromstring_unsafe_side x = T`, @@ -123,10 +125,12 @@ val fromstring_side_def = definition"fromstring_side_def"; val fromchars_side_def = theorem"fromchars_side_def"; val fromchars_range_side_def = theorem"fromchars_range_side_def"; -Theorem fromchars_side_thm - `∀n s. n ≤ LENGTH s ⇒ fromchars_side n (strlit s)` - (completeInduct_on`n` \\ rw[] - \\ rw[Once fromchars_side_def,fromchars_range_side_def]); +Theorem fromchars_side_thm: + ∀n s. n ≤ LENGTH s ⇒ fromchars_side n (strlit s) +Proof + completeInduct_on`n` \\ rw[] + \\ rw[Once fromchars_side_def,fromchars_range_side_def] +QED val fromString_side = Q.prove( `∀x. fromstring_side x = T`, diff --git a/basis/ListProgScript.sml b/basis/ListProgScript.sml index 0ff68ccba5..89d6424aeb 100644 --- a/basis/ListProgScript.sml +++ b/basis/ListProgScript.sml @@ -23,8 +23,7 @@ val res = translate LENGTH_AUX_def; val _ = ml_prog_update open_local_in_block; val result = next_ml_names := ["length"] -val res = translate - (LENGTH_AUX_THM |> Q.SPECL [`xs`,`0`] |> SIMP_RULE std_ss [] |> GSYM); +val res = translate LENGTH_AUX_THM; val _ = ml_prog_update open_local_block; val res = translate REV_DEF; @@ -78,10 +77,12 @@ val MAP_let = prove( | (y::ys) => let z = f y in z :: MAP f ys``, Cases_on `xs` \\ fs []); -Theorem MAP_ind - `∀P. (∀f xs. (∀y ys z. xs = y::ys ∧ z = f y ⇒ P f ys) ⇒ P f xs) ⇒ - ∀f xs. P f xs` - (ntac 2 strip_tac \\ Induct_on `xs` \\ fs []); +Theorem MAP_ind: + ∀P. (∀f xs. (∀y ys z. xs = y::ys ∧ z = f y ⇒ P f ys) ⇒ P f xs) ⇒ + ∀f xs. P f xs +Proof + ntac 2 strip_tac \\ Induct_on `xs` \\ fs [] +QED val _ = add_preferred_thy "-"; (* so that the translator finds MAP_ind above *) diff --git a/basis/MarshallingProgScript.sml b/basis/MarshallingProgScript.sml index 83080df25b..b9c990ce12 100644 --- a/basis/MarshallingProgScript.sml +++ b/basis/MarshallingProgScript.sml @@ -30,28 +30,33 @@ val _ = ml_prog_update (close_module NONE); open ml_translatorTheory -Theorem n2w2_UNICITY_R[xlet_auto_match] - `!n1 n2.n1 < 256**2 ==> ((n2w2 n1 = n2w2 n2 /\ n2 < 256**2) <=> n1 = n2)` - (rw[n2w2_def] >> eq_tac >> rw[DIV_MOD_MOD_DIV] >> +Theorem n2w2_UNICITY_R[xlet_auto_match]: + !n1 n2.n1 < 256**2 ==> ((n2w2 n1 = n2w2 n2 /\ n2 < 256**2) <=> n1 = n2) +Proof + rw[n2w2_def] >> eq_tac >> rw[DIV_MOD_MOD_DIV] >> `0 < (256 : num)` by fs[] >> imp_res_tac DIVISION >> fs[] >> first_assum (assume_tac o Q.SPEC`n1`) >> fs[] >> - first_x_assum (assume_tac o Q.SPEC`n2`) >> fs[]); - -Theorem WORD_n2w2_UNICITY_L[xlet_auto_match] - `!n1 n2 f. n1 < 256**2 /\ LIST_TYPE WORD (n2w2 n1) f ==> - (LIST_TYPE WORD (n2w2 n2) f /\ n2 < 256**2 <=> n1 = n2)` - (rw[] >> eq_tac >> rw[] >> fs[n2w2_def,LIST_TYPE_def] >> rw[] >> + first_x_assum (assume_tac o Q.SPEC`n2`) >> fs[] +QED + +Theorem WORD_n2w2_UNICITY_L[xlet_auto_match]: + !n1 n2 f. n1 < 256**2 /\ LIST_TYPE WORD (n2w2 n1) f ==> + (LIST_TYPE WORD (n2w2 n2) f /\ n2 < 256**2 <=> n1 = n2) +Proof + rw[] >> eq_tac >> rw[] >> fs[n2w2_def,LIST_TYPE_def] >> rw[] >> imp_res_tac Word8ProgTheory.WORD_UNICITY_L >> rw[] >> fs[n2w_11] >> rw[] >> `(n1 DIV 256) MOD 256 = (n1 DIV 256)` by fs[DIV_LT_X] >> `(n2 DIV 256) MOD 256 = (n2 DIV 256)` by fs[DIV_LT_X] >> `0 < (256 : num)` by fs[] >> imp_res_tac DIVISION >> fs[] >> rw[] >> first_assum (assume_tac o Q.SPEC`n1`) >> fs[] >> - first_x_assum (assume_tac o Q.SPEC`n2`) >> fs[]); + first_x_assum (assume_tac o Q.SPEC`n2`) >> fs[] +QED (* needed? *) -Theorem n2w8_UNICITY_R[xlet_auto_match] - `!n1 n2.n1 < 256**8 ==> ((n2w8 n1 = n2w8 n2 /\ n2 < 256**8) <=> n1 = n2)` - (rw[] >> eq_tac >> rw[DIV_MOD_MOD_DIV] >> +Theorem n2w8_UNICITY_R[xlet_auto_match]: + !n1 n2.n1 < 256**8 ==> ((n2w8 n1 = n2w8 n2 /\ n2 < 256**8) <=> n1 = n2) +Proof + rw[] >> eq_tac >> rw[DIV_MOD_MOD_DIV] >> `0 < (256 : num)` by fs[] >> imp_res_tac DIVISION >> fs[] >> rw[] >> NTAC 7( qmatch_abbrev_tac`x1 = x2` >> @@ -66,12 +71,14 @@ Theorem n2w8_UNICITY_R[xlet_auto_match] `x1 DIV 256 = x2 DIV 256` suffices_by ( unabbrev_all_tac >> fs[n2w8_def,DIV_MOD_MOD_DIV]) >> unabbrev_all_tac >> fs[DIV_DIV_DIV_MULT] >> rw[] >> - fs[LESS_DIV_EQ_ZERO]); - -Theorem WORD_n2w8_UNICITY_L[xlet_auto_match] - `!n1 n2 f. n1 < 256**8 /\ LIST_TYPE WORD (n2w8 n1) f ==> - (LIST_TYPE WORD (n2w8 n2) f /\ n2 < 256**8 <=> n1 = n2)` - (rw[] >> eq_tac >> rw[] >> fs[n2w8_def,LIST_TYPE_def] >> rw[] >> + fs[LESS_DIV_EQ_ZERO] +QED + +Theorem WORD_n2w8_UNICITY_L[xlet_auto_match]: + !n1 n2 f. n1 < 256**8 /\ LIST_TYPE WORD (n2w8 n1) f ==> + (LIST_TYPE WORD (n2w8 n2) f /\ n2 < 256**8 <=> n1 = n2) +Proof + rw[] >> eq_tac >> rw[] >> fs[n2w8_def,LIST_TYPE_def] >> rw[] >> imp_res_tac Word8ProgTheory.WORD_UNICITY_L >> rw[] >> fs[n2w_11] >> rw[] >> mp_tac (Q.SPEC `256` DIVISION) >> rw[] >> @@ -79,27 +86,32 @@ Theorem WORD_n2w8_UNICITY_L[xlet_auto_match] first_assum(fn x => simp[Once (Q.SPEC `x2` x)]) >> `(x1 DIV 256) = (x2 DIV 256)` suffices_by fs[] >> unabbrev_all_tac >> fs[DIV_DIV_DIV_MULT]) >> - fs[LESS_DIV_EQ_ZERO]); + fs[LESS_DIV_EQ_ZERO] +QED -Theorem n2w2_spec - `!n off b nv offv bl. NUM n nv /\ NUM off offv /\ off + 2 <= LENGTH b ==> +Theorem n2w2_spec: + !n off b nv offv bl. NUM n nv /\ NUM off offv /\ off + 2 <= LENGTH b ==> app (p:'ffi ffi_proj) ^(fetch_v "Marshalling.n2w2" (get_ml_prog_state())) [nv; bl; offv] (W8ARRAY bl b) - (POSTv u. &UNIT_TYPE () u * W8ARRAY bl (insert_atI (n2w2 n) off b))` - (xcf "Marshalling.n2w2" (get_ml_prog_state()) >> + (POSTv u. &UNIT_TYPE () u * W8ARRAY bl (insert_atI (n2w2 n) off b)) +Proof + xcf "Marshalling.n2w2" (get_ml_prog_state()) >> NTAC 6 (xlet_auto >- xsimpl) >> xcon >> xsimpl >> fs[n2w2_def] >> Cases_on`b` >- fs[] >> Cases_on`t` >> - fs[insert_atI_CONS,insert_atI_def,LUPDATE_commutes]); + fs[insert_atI_CONS,insert_atI_def,LUPDATE_commutes] +QED -Theorem w22n_spec - `!off b offv bl. NUM off offv /\ off + 2 <= LENGTH b ==> +Theorem w22n_spec: + !off b offv bl. NUM off offv /\ off + 2 <= LENGTH b ==> app (p:'ffi ffi_proj) ^(fetch_v "Marshalling.w22n" (get_ml_prog_state())) [bl; offv] (W8ARRAY bl b) - (POSTv nv. &NUM (w22n [EL off b; EL (off+1) b]) nv * W8ARRAY bl b)` - (xcf "Marshalling.w22n" (get_ml_prog_state()) >> + (POSTv nv. &NUM (w22n [EL off b; EL (off+1) b]) nv * W8ARRAY bl b) +Proof + xcf "Marshalling.w22n" (get_ml_prog_state()) >> NTAC 6 (xlet_auto >- xsimpl) >> - xapp >> xsimpl >> fs[w22n_def,NUM_def,INT_def,integerTheory.INT_ADD]); + xapp >> xsimpl >> fs[w22n_def,NUM_def,INT_def,integerTheory.INT_ADD] +QED val _ = export_theory() diff --git a/basis/MarshallingScript.sml b/basis/MarshallingScript.sml index 3e6681fb60..0ca07b8b73 100644 --- a/basis/MarshallingScript.sml +++ b/basis/MarshallingScript.sml @@ -26,24 +26,29 @@ val w82n_def = Define` 256 * ( 256 * ( 256 * ( 256 * ( 256 * ( 256 * ( 256 * w2n b7 + w2n b6) + w2n b5) + w2n b4) + w2n b3) + w2n b2) + w2n b1) + w2n b0` -Theorem w22n_n2w2 - `!i. i < 2**(2*8) ==> w22n (n2w2 i) = i` - (rw[w22n_def,n2w2_def] >> +Theorem w22n_n2w2: + !i. i < 2**(2*8) ==> w22n (n2w2 i) = i +Proof + rw[w22n_def,n2w2_def] >> `0 < (256 : num)` by fs[] >> imp_res_tac DIVISION >> fs[] >> - first_x_assum (assume_tac o Q.SPEC`i`) >> fs[]); + first_x_assum (assume_tac o Q.SPEC`i`) >> fs[] +QED -Theorem n2w2_w22n - `!b. LENGTH b = 2 ==> n2w2 (w22n b) = b` - (Cases_on`b` >> fs[] >> Cases_on`t` >> rw[w22n_def,n2w2_def] +Theorem n2w2_w22n: + !b. LENGTH b = 2 ==> n2w2 (w22n b) = b +Proof + Cases_on`b` >> fs[] >> Cases_on`t` >> rw[w22n_def,n2w2_def] >-(PURE_REWRITE_TAC[Once MULT_COMM] >> fs[ADD_DIV_ADD_DIV] >> fs[LESS_DIV_EQ_ZERO,w2n_lt_256]) >> fs[GSYM word_add_n2w,GSYM word_mul_n2w] >> `256w : word8 = 0w` by fs[GSYM n2w_dimword] >> - first_x_assum (fn x => PURE_REWRITE_TAC[x]) >> fs[]); + first_x_assum (fn x => PURE_REWRITE_TAC[x]) >> fs[] +QED -Theorem w82n_n2w8 - `!i. i <= 256**8 - 1 ==> w82n (n2w8 i) = i` - (rw[w82n_def,n2w8_def] >> +Theorem w82n_n2w8: + !i. i <= 256**8 - 1 ==> w82n (n2w8 i) = i +Proof + rw[w82n_def,n2w8_def] >> `0 < (256 : num)` by fs[] >> imp_res_tac DIVISION >> fs[] >> rw[] >> NTAC 6(qmatch_abbrev_tac`256* i0 + x MOD 256 = x` >> `i0 = x DIV 256` suffices_by fs[] >> @@ -53,12 +58,14 @@ Theorem w82n_n2w8 `i0 = x DIV 256` suffices_by fs[] >> unabbrev_all_tac >> fs[DIV_DIV_DIV_MULT] >> `i DIV 256**7 <= 255` suffices_by fs[] >> - fs[DIV_LE_X]); + fs[DIV_LE_X] +QED -Theorem nw8_w8n - `!b. LENGTH b = 8 ==> n2w8 (w82n b) = b` - (Cases_on`b` >> fs[] >> +Theorem nw8_w8n: + !b. LENGTH b = 8 ==> n2w8 (w82n b) = b +Proof + Cases_on`b` >> fs[] >> NTAC 4 (Cases_on`t` >> fs[] >> Cases_on`t'` >> fs[]) >> fs[w82n_def,n2w8_def] >> rpt (TRY strip_tac >-(rpt(qmatch_goalsub_abbrev_tac`(a + 256 * b) DIV m` >> @@ -74,13 +81,18 @@ Theorem nw8_w8n rw[LESS_DIV_EQ_ZERO,w2n_lt_256] >> fs[GSYM word_add_n2w,GSYM word_mul_n2w] >> `256w : word8 = 0w` by fs[GSYM n2w_dimword] >> - first_x_assum (fn x => PURE_REWRITE_TAC[x]) >> fs[]))); + first_x_assum (fn x => PURE_REWRITE_TAC[x]) >> fs[])) +QED -Theorem LENGTH_n2w2 - `!n. LENGTH(n2w2 n) = 2` - (fs[n2w2_def]); +Theorem LENGTH_n2w2: + !n. LENGTH(n2w2 n) = 2 +Proof + fs[n2w2_def] +QED -Theorem LENGTH_n2w8 - `!n. LENGTH(n2w8 n) = 8` - (fs[n2w8_def]) +Theorem LENGTH_n2w8: + !n. LENGTH(n2w8 n) = 8 +Proof + fs[n2w8_def] +QED val _ = export_theory() diff --git a/basis/RatProgScript.sml b/basis/RatProgScript.sml index 9fb50cfd9f..ab66ad7cf3 100644 --- a/basis/RatProgScript.sml +++ b/basis/RatProgScript.sml @@ -39,13 +39,16 @@ val real_of_rat_def = Define ` intreal$real_of_int (RATN r) / real_of_num (RATD r) `; -Theorem real_of_rat_int - `real_of_rat (&x) = &x` - (simp[real_of_rat_def, intrealTheory.real_of_int]); - -Theorem real_of_rat_le[simp] - `∀r1 r2. real_of_rat r1 ≤ real_of_rat r2 ⇔ r1 ≤ r2` - (simp[real_of_rat_def] >> rpt gen_tac >> +Theorem real_of_rat_int: + real_of_rat (&x) = &x +Proof + simp[real_of_rat_def, intrealTheory.real_of_int] +QED + +Theorem real_of_rat_le[simp]: + ∀r1 r2. real_of_rat r1 ≤ real_of_rat r2 ⇔ r1 ≤ r2 +Proof + simp[real_of_rat_def] >> rpt gen_tac >> assume_tac (RATN_DIV_RATD |> Q.INST [‘r’ |-> ‘r1’] |> SYM) >> assume_tac (RATN_DIV_RATD |> Q.INST [‘r’ |-> ‘r2’] |> SYM) >> map_every qabbrev_tac @@ -58,11 +61,12 @@ Theorem real_of_rat_le[simp] GSYM intrealTheory.real_of_int_mul, intrealTheory.real_of_int_le, GSYM rat_of_int_of_num, rat_of_int_MUL, rat_of_int_LE, integerTheory.INT_MUL_COMM] -); +QED -Theorem real_of_rat_eq[simp] - `∀r1 r2. real_of_rat r1 = real_of_rat r2 ⇔ r1 = r2` - (simp[real_of_rat_def] >> rpt gen_tac >> +Theorem real_of_rat_eq[simp]: + ∀r1 r2. real_of_rat r1 = real_of_rat r2 ⇔ r1 = r2 +Proof + simp[real_of_rat_def] >> rpt gen_tac >> assume_tac (RATN_DIV_RATD |> Q.INST [‘r’ |-> ‘r1’] |> SYM) >> assume_tac (RATN_DIV_RATD |> Q.INST [‘r’ |-> ‘r2’] |> SYM) >> map_every qabbrev_tac @@ -73,20 +77,24 @@ Theorem real_of_rat_eq[simp] simp_tac bool_ss [GSYM intrealTheory.real_of_int_num, GSYM intrealTheory.real_of_int_mul, intrealTheory.real_of_int_11, GSYM rat_of_int_of_num, - rat_of_int_MUL, rat_of_int_11, integerTheory.INT_MUL_COMM]); + rat_of_int_MUL, rat_of_int_11, integerTheory.INT_MUL_COMM] +QED -Theorem real_of_rat_lt - `∀r1 r2. real_of_rat r1 < real_of_rat r2 ⇔ r1 < r2` - (rpt gen_tac >> +Theorem real_of_rat_lt: + ∀r1 r2. real_of_rat r1 < real_of_rat r2 ⇔ r1 < r2 +Proof + rpt gen_tac >> ‘∀s1:real s2. s1 < s2 <=> s1 <= s2 /\ s1 <> s2’ by metis_tac[realTheory.REAL_LE_LT, realTheory.REAL_LT_REFL] >> ‘∀r1 r2:rat. r1 < r2 <=> r1 <= r2 /\ r1 <> r2’ by metis_tac[rat_leq_def, RAT_LES_REF] >> - simp[]); + simp[] +QED -Theorem real_of_rat_add - `∀r1 r2. real_of_rat (r1 + r2) = real_of_rat r1 + real_of_rat r2` - (simp[real_of_rat_def] >> rpt gen_tac >> +Theorem real_of_rat_add: + ∀r1 r2. real_of_rat (r1 + r2) = real_of_rat r1 + real_of_rat r2 +Proof + simp[real_of_rat_def] >> rpt gen_tac >> map_every (fn q => assume_tac (RATN_DIV_RATD |> Q.INST [‘r’ |-> q] |> SYM)) [‘r1’, ‘r2’, ‘r1 + r2’] >> @@ -105,7 +113,8 @@ Theorem real_of_rat_add simp[RAT_LDIV_EQ, RAT_RDIV_EQ, RDIV_MUL_OUT, LDIV_MUL_OUT] >> simp_tac bool_ss [GSYM rat_of_int_of_num, rat_of_int_MUL, rat_of_int_ADD, rat_of_int_11] >> - simp[integerTheory.INT_MUL_COMM]); + simp[integerTheory.INT_MUL_COMM] +QED val real_of_rat_mul = store_thm("real_of_rat_mul", “∀r1 r2. real_of_rat (r1 * r2) = real_of_rat r1 * real_of_rat r2”, @@ -134,27 +143,33 @@ val real_of_rat_ainv = store_thm("real_of_rat_ainv", “∀r. real_of_rat (-r) = -real_of_rat r”, gen_tac >> simp[real_of_rat_def, realTheory.neg_rat]); -Theorem real_of_rat_sub - `∀r1 r2. real_of_rat (r1 - r2) = real_of_rat r1 - real_of_rat r2` - (rpt gen_tac >> +Theorem real_of_rat_sub: + ∀r1 r2. real_of_rat (r1 - r2) = real_of_rat r1 - real_of_rat r2 +Proof + rpt gen_tac >> simp[RAT_SUB_ADDAINV, real_of_rat_ainv, real_of_rat_add, - realTheory.real_sub]); + realTheory.real_sub] +QED val inv_div = Q.prove( ‘x ≠ 0r ∧ y ≠ 0 ⇒ (inv (x / y) = y / x)’, simp[realTheory.real_div, realTheory.REAL_INV_MUL, realTheory.REAL_INV_EQ_0, realTheory.REAL_INV_INV, realTheory.REAL_MUL_COMM]); -Theorem real_of_int_eq_num[simp] - `((real_of_int i = &n) <=> (i = &n)) /\ - ((&n = real_of_int i) <=> (i = &n))` - (simp[EQ_IMP_THM] >> simp[intrealTheory.real_of_int_def] >> - Cases_on ‘i’ >> simp[realTheory.eq_ints]); - -Theorem rat_of_int_eq_num[simp] - `((rat_of_int i = &n) <=> (i = &n)) /\ - ((&n = rat_of_int i) <=> (i = &n))` - (Cases_on ‘i’ >> simp[rat_of_int_def]); +Theorem real_of_int_eq_num[simp]: + ((real_of_int i = &n) <=> (i = &n)) /\ + ((&n = real_of_int i) <=> (i = &n)) +Proof + simp[EQ_IMP_THM] >> simp[intrealTheory.real_of_int_def] >> + Cases_on ‘i’ >> simp[realTheory.eq_ints] +QED + +Theorem rat_of_int_eq_num[simp]: + ((rat_of_int i = &n) <=> (i = &n)) /\ + ((&n = rat_of_int i) <=> (i = &n)) +Proof + Cases_on ‘i’ >> simp[rat_of_int_def] +QED val real_of_rat_inv = store_thm("real_of_rat_inv", “!r. r ≠ 0 ==> real_of_rat (rat_minv r) = inv (real_of_rat r)”, @@ -441,17 +456,20 @@ val gcd_LESS_EQ = prove( \\ once_rewrite_tac [gcdTheory.gcd_def] \\ rw [] \\ fs []); -Theorem DIV_EQ_0 - `0 < n ==> ((m DIV n = 0) <=> m < n)` - (strip_tac >> IMP_RES_THEN mp_tac DIVISION >> +Theorem DIV_EQ_0: + 0 < n ==> ((m DIV n = 0) <=> m < n) +Proof + strip_tac >> IMP_RES_THEN mp_tac DIVISION >> rpt (disch_then (qspec_then `m` assume_tac)) >> qabbrev_tac `q = m DIV n` >> qabbrev_tac `r = m MOD n` >> RM_ALL_ABBREVS_TAC >> rw[] >> eq_tac >> simp[] >> - Cases_on ‘q’ >> simp[MULT_CLAUSES]); + Cases_on ‘q’ >> simp[MULT_CLAUSES] +QED -Theorem DIV_GCD_NONZERO - `(0 < m ==> 0 < m DIV gcd m n) /\ (0 < n ==> 0 < n DIV gcd m n)` - (rw[] >> ‘gcd m n <> 0’ by simp[GCD_EQ_0] +Theorem DIV_GCD_NONZERO: + (0 < m ==> 0 < m DIV gcd m n) /\ (0 < n ==> 0 < n DIV gcd m n) +Proof + rw[] >> ‘gcd m n <> 0’ by simp[GCD_EQ_0] >- (‘~(m < gcd m n)’ by metis_tac[dividesTheory.NOT_LT_DIVIDES, GCD_IS_GREATEST_COMMON_DIVISOR] >> @@ -465,7 +483,8 @@ Theorem DIV_GCD_NONZERO spose_not_then assume_tac >> rev_full_simp_tac bool_ss [DIV_EQ_0, arithmeticTheory.NOT_LT_ZERO_EQ_ZERO, - arithmeticTheory.NOT_ZERO_LT_ZERO])); + arithmeticTheory.NOT_ZERO_LT_ZERO]) +QED val INT_NEG_DIV_FACTOR = Q.prove( ‘0 < (x:num) ==> (-&(x * y):int / &x = -&y)’, @@ -729,9 +748,9 @@ val v = translate toString_def; val RATIONAL_TYPE_def = fetch "-" "RATIONAL_TYPE_def" -Theorem EqualityType_RAT_TYPE - `EqualityType RAT_TYPE` - (rw [EqualityType_def] +Theorem EqualityType_RAT_TYPE = Q.prove(` + EqualityType RAT_TYPE`, + rw [EqualityType_def] \\ fs [RAT_TYPE_def,RATIONAL_TYPE_def,INT_def,NUM_def] \\ EVAL_TAC \\ rveq \\ fs [] \\ EQ_TAC \\ strip_tac \\ fs [] @@ -771,9 +790,9 @@ Theorem EqualityType_RAT_TYPE \\ rveq \\ rfs [arithmeticTheory.EQ_MULT_RCANCEL]) |> store_eq_thm; -Theorem EqualityType_REAL_TYPE - `EqualityType REAL_TYPE` - (assume_tac EqualityType_RAT_TYPE +Theorem EqualityType_REAL_TYPE = Q.prove(` + EqualityType REAL_TYPE`, + assume_tac EqualityType_RAT_TYPE \\ fs [REAL_TYPE_def,EqualityType_def,PULL_EXISTS] \\ rw [real_of_rat_eq] \\ fs [real_of_rat_eq] \\ metis_tac []) diff --git a/basis/RuntimeProofScript.sml b/basis/RuntimeProofScript.sml index f1f27fa994..5a465679cf 100644 --- a/basis/RuntimeProofScript.sml +++ b/basis/RuntimeProofScript.sml @@ -16,22 +16,25 @@ val RUNTIME_def = Define ` RUNTIME = IOx runtime_ffi_part ()` -Theorem RUNTIME_FFI_part_hprop -`FFI_part_hprop RUNTIME` - (rw [RUNTIME_def,cfHeapsBaseTheory.IO_def,cfMainTheory.FFI_part_hprop_def, +Theorem RUNTIME_FFI_part_hprop: + FFI_part_hprop RUNTIME +Proof + rw [RUNTIME_def,cfHeapsBaseTheory.IO_def,cfMainTheory.FFI_part_hprop_def, cfHeapsBaseTheory.IOx_def, runtime_ffi_part_def, set_sepTheory.SEP_CLAUSES,set_sepTheory.SEP_EXISTS_THM, set_sepTheory.cond_STAR ] - \\ fs[set_sepTheory.one_def]); + \\ fs[set_sepTheory.one_def] +QED val st = get_ml_prog_state(); -Theorem Runtime_exit_spec - `INT i iv ==> +Theorem Runtime_exit_spec: + INT i iv ==> app (p:'ffi ffi_proj) ^(fetch_v "Runtime.exit" st) [iv] (RUNTIME) - (POSTf n. λc b. RUNTIME * &(n = "exit" /\ c = [] /\ b = [i2w i]))` - (qpat_abbrev_tac `Q = $POSTf _` + (POSTf n. λc b. RUNTIME * &(n = "exit" /\ c = [] /\ b = [i2w i])) +Proof + qpat_abbrev_tac `Q = $POSTf _` \\ simp [RUNTIME_def,runtime_ffi_part_def,IOx_def,IO_def] \\ xpull \\ qpat_abbrev_tac `H = one _` \\ xcf "Runtime.exit" st @@ -68,23 +71,28 @@ Theorem Runtime_exit_spec \\ fs[mk_ffi_next_def,encode_def,decode_def,ffi_exit_def] \\ xsimpl \\ MAP_EVERY qexists_tac [`events`,`loc`] - \\ xsimpl); + \\ xsimpl +QED -Theorem Runtime_abort_spec - `UNIT_TYPE u uv ==> +Theorem Runtime_abort_spec: + UNIT_TYPE u uv ==> app (p:'ffi ffi_proj) ^(fetch_v "Runtime.abort" st) [uv] (RUNTIME) - (POSTf n. λc b. RUNTIME * &(n = "exit" /\ c = [] /\ b = [1w]))` - (xcf "Runtime.abort" st + (POSTf n. λc b. RUNTIME * &(n = "exit" /\ c = [] /\ b = [1w])) +Proof + xcf "Runtime.abort" st \\ fs [UNIT_TYPE_def] \\ xmatch \\ xapp - \\ xsimpl \\ EVAL_TAC); + \\ xsimpl \\ EVAL_TAC +QED -Theorem RUNTIME_HPROP_INJ[hprop_inj] - `!cl1 cl2. HPROP_INJ (RUNTIME) (RUNTIME) (T)` - (rw[HPROP_INJ_def,STAR_def,EQ_IMP_THM] +Theorem RUNTIME_HPROP_INJ[hprop_inj]: + !cl1 cl2. HPROP_INJ (RUNTIME) (RUNTIME) (T) +Proof + rw[HPROP_INJ_def,STAR_def,EQ_IMP_THM] THEN1 (asm_exists_tac \\ rw[] \\ rw[SPLIT_emp1,cond_def]) - \\ fs[SPLIT_emp1,cond_def] \\ metis_tac[]); + \\ fs[SPLIT_emp1,cond_def] \\ metis_tac[] +QED val _ = export_theory(); diff --git a/basis/TextIOProofScript.sml b/basis/TextIOProofScript.sml index 9acb2bcb15..62fcc9cf67 100644 --- a/basis/TextIOProofScript.sml +++ b/basis/TextIOProofScript.sml @@ -20,17 +20,20 @@ val IOFS_iobuff_def = Define` val IOFS_def = Define ` IOFS fs = IOx (fs_ffi_part) fs * IOFS_iobuff * &wfFS fs` -Theorem UNIQUE_IOFS -`!s. VALID_HEAP s ==> !fs1 fs2 H1 H2. (IOFS fs1 * H1) s /\ - (IOFS fs2 * H2) s ==> fs1 = fs2` - (rw[IOFS_def,cfHeapsBaseTheory.IOx_def, fs_ffi_part_def, +Theorem UNIQUE_IOFS: + !s. VALID_HEAP s ==> !fs1 fs2 H1 H2. (IOFS fs1 * H1) s /\ + (IOFS fs2 * H2) s ==> fs1 = fs2 +Proof + rw[IOFS_def,cfHeapsBaseTheory.IOx_def, fs_ffi_part_def, GSYM STAR_ASSOC,encode_def] >> IMP_RES_TAC FRAME_UNIQUE_IO >> - fs[IO_fs_component_equality]); + fs[IO_fs_component_equality] +QED -Theorem IOFS_FFI_part_hprop - `FFI_part_hprop (IOFS fs)` - (rw [IOFS_def, +Theorem IOFS_FFI_part_hprop: + FFI_part_hprop (IOFS fs) +Proof + rw [IOFS_def, cfHeapsBaseTheory.IO_def, cfHeapsBaseTheory.IOx_def, fs_ffi_part_def, cfMainTheory.FFI_part_hprop_def, set_sepTheory.SEP_CLAUSES,set_sepTheory.SEP_EXISTS_THM, @@ -38,14 +41,17 @@ Theorem IOFS_FFI_part_hprop cfHeapsBaseTheory.cell_def] \\ fs[set_sepTheory.one_STAR,STAR_def] \\ imp_res_tac SPLIT_SUBSET >> fs[SUBSET_DEF] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem IOFS_iobuff_HPROP_INJ[hprop_inj] -`!fs1 fs2. HPROP_INJ (IOFS fs1) (IOFS fs2) (fs2 = fs1)` - (rw[HPROP_INJ_def, IOFS_def, GSYM STAR_ASSOC, SEP_CLAUSES, SEP_EXISTS_THM, +Theorem IOFS_iobuff_HPROP_INJ[hprop_inj]: + !fs1 fs2. HPROP_INJ (IOFS fs1) (IOFS fs2) (fs2 = fs1) +Proof + rw[HPROP_INJ_def, IOFS_def, GSYM STAR_ASSOC, SEP_CLAUSES, SEP_EXISTS_THM, HCOND_EXTRACT] >> fs[IOFS_def,cfHeapsBaseTheory.IOx_def, fs_ffi_part_def] >> - EQ_TAC >> rpt DISCH_TAC >> IMP_RES_TAC FRAME_UNIQUE_IO >> fs[]); + EQ_TAC >> rpt DISCH_TAC >> IMP_RES_TAC FRAME_UNIQUE_IO >> fs[] +QED (* "end-user" property *) (* abstracts away the lazy list and ensure that standard streams are opened on @@ -58,28 +64,35 @@ val STDIO_def = Define` (* Used by the monadic translator *) val MONAD_IO_def = Define `MONAD_IO fs = STDIO fs * &hasFreeFD fs`; -Theorem STDIO_numchars - `STDIO (fs with numchars := x) = STDIO fs` - (rw[STDIO_def,GSYM STD_streams_numchars]); +Theorem STDIO_numchars: + STDIO (fs with numchars := x) = STDIO fs +Proof + rw[STDIO_def,GSYM STD_streams_numchars] +QED -Theorem STDIO_bumpFD[simp] - `STDIO (bumpFD fd fs n) = STDIO (forwardFD fs fd n)` - (rw[bumpFD_forwardFD,STDIO_numchars]); +Theorem STDIO_bumpFD[simp]: + STDIO (bumpFD fd fs n) = STDIO (forwardFD fs fd n) +Proof + rw[bumpFD_forwardFD,STDIO_numchars] +QED -Theorem UNIQUE_STDIO -`!s. VALID_HEAP s ==> !fs1 fs2 H1 H2. (STDIO fs1 * H1) s /\ +Theorem UNIQUE_STDIO: + !s. VALID_HEAP s ==> !fs1 fs2 H1 H2. (STDIO fs1 * H1) s /\ (STDIO fs2 * H2) s ==> - (fs1.infds = fs2.infds /\ fs1.inode_tbl = fs2.inode_tbl /\ fs1.maxFD = fs2.maxFD /\ fs1.files = fs2.files)` - (rw[STDIO_def,STD_streams_def,SEP_CLAUSES,SEP_EXISTS_THM,STAR_COMM,STAR_ASSOC,cond_STAR] >> + (fs1.infds = fs2.infds /\ fs1.inode_tbl = fs2.inode_tbl /\ fs1.maxFD = fs2.maxFD /\ fs1.files = fs2.files) +Proof + rw[STDIO_def,STD_streams_def,SEP_CLAUSES,SEP_EXISTS_THM,STAR_COMM,STAR_ASSOC,cond_STAR] >> fs[Once STAR_COMM] >> imp_res_tac UNIQUE_IOFS >> - cases_on`fs1` >> cases_on`fs2` >> fs[IO_fs_numchars_fupd]); + cases_on`fs1` >> cases_on`fs2` >> fs[IO_fs_numchars_fupd] +QED (* weak injection theorem *) -Theorem STDIO_HPROP_INJ[hprop_inj] -`HPROP_INJ (STDIO fs1) (STDIO fs2) - (fs1.infds = fs2.infds /\ fs1.inode_tbl = fs2.inode_tbl /\ fs1.maxFD = fs2.maxFD /\ fs1.files = fs2.files)` - (rw[HPROP_INJ_def, GSYM STAR_ASSOC, SEP_CLAUSES, SEP_EXISTS_THM, +Theorem STDIO_HPROP_INJ[hprop_inj]: + HPROP_INJ (STDIO fs1) (STDIO fs2) + (fs1.infds = fs2.infds /\ fs1.inode_tbl = fs2.inode_tbl /\ fs1.maxFD = fs2.maxFD /\ fs1.files = fs2.files) +Proof + rw[HPROP_INJ_def, GSYM STAR_ASSOC, SEP_CLAUSES, SEP_EXISTS_THM, HCOND_EXTRACT] >> EQ_TAC >> rpt DISCH_TAC >-(mp_tac UNIQUE_STDIO >> disch_then drule >> @@ -102,7 +115,8 @@ Theorem STDIO_HPROP_INJ[hprop_inj] qexists_tac`u0` >> qexists_tac`v0` >> fs[] >> qexists_tac`u1` >> fs[PULL_EXISTS] >> qexists_tac`ll` >> fs[] >> cases_on`fs1` >> cases_on`fs2` >> fs[IO_fs_numchars_fupd] >> - metis_tac[]); + metis_tac[] +QED (* refinement invariant for filenames *) @@ -115,42 +129,63 @@ val FILENAME_def = Define ` val filename_tac = metis_tac[FILENAME_def,EqualityType_NUM_BOOL,EqualityType_def]; -Theorem FILENAME_UNICITY_R[xlet_auto_match] -`!f fv fv'. FILENAME f fv ==> (FILENAME f fv' <=> fv' = fv)` (filename_tac); - -Theorem FILENAME_UNICITY_L[xlet_auto_match] -`!f f' fv. FILENAME f fv ==> (FILENAME f' fv <=> f' = f)` (filename_tac); - -Theorem FILENAME_STRING_UNICITY_R[xlet_auto_match] - `!f fv fv'. FILENAME f fv ==> (STRING_TYPE f fv' <=> fv' = fv)` - (filename_tac); - -Theorem FILENAME_STRING_UNICITY_L[xlet_auto_match] - `!f f' fv. FILENAME f fv ==> (STRING_TYPE f' fv <=> f' = f)` (filename_tac); - -Theorem STRING_FILENAME_UNICITY_R[xlet_auto_match] - `!f fv fv'. STRING_TYPE f fv ==> - (FILENAME f fv' <=> fv' = fv /\ ¬MEM #"\^@" (explode f) /\ strlen f < 256 * 256)` - (filename_tac); - -Theorem STRING_FILENAME_UNICITY_L[xlet_auto_match] - `!f f' fv. STRING_TYPE f fv ==> - (FILENAME f' fv <=> f' = f /\ ¬MEM #"\^@" (explode f) /\ strlen f < 256 * 256)` - (filename_tac); +Theorem FILENAME_UNICITY_R[xlet_auto_match]: + !f fv fv'. FILENAME f fv ==> (FILENAME f fv' <=> fv' = fv) +Proof +filename_tac +QED + +Theorem FILENAME_UNICITY_L[xlet_auto_match]: + !f f' fv. FILENAME f fv ==> (FILENAME f' fv <=> f' = f) +Proof +filename_tac +QED + +Theorem FILENAME_STRING_UNICITY_R[xlet_auto_match]: + !f fv fv'. FILENAME f fv ==> (STRING_TYPE f fv' <=> fv' = fv) +Proof + filename_tac +QED + +Theorem FILENAME_STRING_UNICITY_L[xlet_auto_match]: + !f f' fv. FILENAME f fv ==> (STRING_TYPE f' fv <=> f' = f) +Proof +filename_tac +QED + +Theorem STRING_FILENAME_UNICITY_R[xlet_auto_match]: + !f fv fv'. STRING_TYPE f fv ==> + (FILENAME f fv' <=> fv' = fv /\ ¬MEM #"\^@" (explode f) /\ strlen f < 256 * 256) +Proof + filename_tac +QED + +Theorem STRING_FILENAME_UNICITY_L[xlet_auto_match]: + !f f' fv. STRING_TYPE f fv ==> + (FILENAME f' fv <=> f' = f /\ ¬MEM #"\^@" (explode f) /\ strlen f < 256 * 256) +Proof + filename_tac +QED (* exception refinement invariant lemmas *) -Theorem BadFileName_UNICITY[xlet_auto_match] -`!v1 v2. BadFileName_exn v1 ==> (BadFileName_exn v2 <=> v2 = v1)` - (fs[BadFileName_exn_def]); +Theorem BadFileName_UNICITY[xlet_auto_match]: + !v1 v2. BadFileName_exn v1 ==> (BadFileName_exn v2 <=> v2 = v1) +Proof + fs[BadFileName_exn_def] +QED -Theorem InvalidFD_UNICITY[xlet_auto_match] -`!v1 v2. InvalidFD_exn v1 ==> (InvalidFD_exn v2 <=> v2 = v1)` - (fs[InvalidFD_exn_def]); +Theorem InvalidFD_UNICITY[xlet_auto_match]: + !v1 v2. InvalidFD_exn v1 ==> (InvalidFD_exn v2 <=> v2 = v1) +Proof + fs[InvalidFD_exn_def] +QED -Theorem EndOfFile_UNICITY[xlet_auto_match] -`!v1 v2. EndOfFile_exn v1 ==> (EndOfFile_exn v2 <=> v2 = v1)` - (fs[EndOfFile_exn_def]); +Theorem EndOfFile_UNICITY[xlet_auto_match]: + !v1 v2. EndOfFile_exn v1 ==> (EndOfFile_exn v2 <=> v2 = v1) +Proof + fs[EndOfFile_exn_def] +QED (* convenient functions for standard output/error * n.b. numchars is ignored *) @@ -163,234 +198,313 @@ val stdo_def = Define` val _ = overload_on("stdout",``stdo 1 "stdout"``); val _ = overload_on("stderr",``stdo 2 "stderr"``); -Theorem stdo_UNICITY_R[xlet_auto_match] -`!fd name fs out out'. stdo fd name fs out ==> (stdo fd name fs out' <=> out = out')` -(rw[stdo_def] >> EQ_TAC >> rw[explode_11]); +Theorem stdo_UNICITY_R[xlet_auto_match]: + !fd name fs out out'. stdo fd name fs out ==> (stdo fd name fs out' <=> out = out') +Proof +rw[stdo_def] >> EQ_TAC >> rw[explode_11] +QED val up_stdo_def = Define `up_stdo fd fs out = fsupdate fs fd 0 (strlen out) (explode out)` val _ = overload_on("up_stdout",``up_stdo 1``); val _ = overload_on("up_stderr",``up_stdo 2``); -Theorem stdo_numchars - `stdo fd name (fs with numchars := l) out ⇔ stdo fd name fs out` - (rw[stdo_def]); - -Theorem up_stdo_numchars[simp] - `(up_stdo fd fs x).numchars = fs.numchars` - (rw[up_stdo_def,fsupdate_def] - \\ CASE_TAC \\ CASE_TAC \\ rw[]); - -Theorem fsupdate_files[simp] - `(fsupdate fs fd k pos c).files = fs.files` - (fs[fsupdate_def] >> NTAC 2 CASE_TAC >>fs[]); - -Theorem up_stdo_files[simp] - `(up_stdo fd fs x).files = fs.files` - (fs[up_stdo_def,fsupdate_def] >> NTAC 2 CASE_TAC >>fs[]); +Theorem stdo_numchars: + stdo fd name (fs with numchars := l) out ⇔ stdo fd name fs out +Proof + rw[stdo_def] +QED -Theorem up_stdo_maxFD[simp] - `(up_stdo fd fs x).maxFD = fs.maxFD` - (rw[up_stdo_def,fsupdate_def] - \\ CASE_TAC \\ CASE_TAC \\ rw[]); +Theorem up_stdo_numchars[simp]: + (up_stdo fd fs x).numchars = fs.numchars +Proof + rw[up_stdo_def,fsupdate_def] + \\ CASE_TAC \\ CASE_TAC \\ rw[] +QED + +Theorem fsupdate_files[simp]: + (fsupdate fs fd k pos c).files = fs.files +Proof + fs[fsupdate_def] >> NTAC 2 CASE_TAC >>fs[] +QED + +Theorem up_stdo_files[simp]: + (up_stdo fd fs x).files = fs.files +Proof + fs[up_stdo_def,fsupdate_def] >> NTAC 2 CASE_TAC >>fs[] +QED + +Theorem up_stdo_maxFD[simp]: + (up_stdo fd fs x).maxFD = fs.maxFD +Proof + rw[up_stdo_def,fsupdate_def] + \\ CASE_TAC \\ CASE_TAC \\ rw[] +QED -Theorem up_stdo_with_numchars - `up_stdo fd (fs with numchars := ns) x = - up_stdo fd fs x with numchars := ns` - (rw[up_stdo_def,fsupdate_numchars]); +Theorem up_stdo_with_numchars: + up_stdo fd (fs with numchars := ns) x = + up_stdo fd fs x with numchars := ns +Proof + rw[up_stdo_def,fsupdate_numchars] +QED val add_stdo_def = Define` add_stdo fd nm fs out = up_stdo fd fs ((@init. stdo fd nm fs init) ^ out)`; val _ = overload_on("add_stdout",``add_stdo 1 "stdout"``); val _ = overload_on("add_stderr",``add_stdo 2 "stderr"``); -Theorem stdo_add_stdo - `stdo fd nm fs init ⇒ stdo fd nm (add_stdo fd nm fs out) (strcat init out)` - (rw[add_stdo_def] +Theorem stdo_add_stdo: + stdo fd nm fs init ⇒ stdo fd nm (add_stdo fd nm fs out) (strcat init out) +Proof + rw[add_stdo_def] \\ SELECT_ELIM_TAC \\ rw[] >- metis_tac[] \\ imp_res_tac stdo_UNICITY_R \\ rveq - \\ fs[up_stdo_def,stdo_def,fsupdate_def,AFUPDKEY_ALOOKUP]); - -Theorem up_stdo_unchanged - `!fs out. stdo fd nm fs out ==> up_stdo fd fs out = fs` -(fs[up_stdo_def,stdo_def,fsupdate_unchanged,get_file_content_def,PULL_EXISTS]); - -Theorem stdo_up_stdo - `!fs out out'. stdo fd nm fs out ==> stdo fd nm (up_stdo fd fs out') out'` - (rw[up_stdo_def,stdo_def,fsupdate_def,AFUPDKEY_ALOOKUP,PULL_EXISTS] - \\ rw[]); - -Theorem add_stdo_nil - `stdo fd nm fs out ⇒ add_stdo fd nm fs (strlit "") = fs` - (rw[add_stdo_def] + \\ fs[up_stdo_def,stdo_def,fsupdate_def,AFUPDKEY_ALOOKUP] +QED + +Theorem up_stdo_unchanged: + !fs out. stdo fd nm fs out ==> up_stdo fd fs out = fs +Proof +fs[up_stdo_def,stdo_def,fsupdate_unchanged,get_file_content_def,PULL_EXISTS] +QED + +Theorem stdo_up_stdo: + !fs out out'. stdo fd nm fs out ==> stdo fd nm (up_stdo fd fs out') out' +Proof + rw[up_stdo_def,stdo_def,fsupdate_def,AFUPDKEY_ALOOKUP,PULL_EXISTS] + \\ rw[] +QED + +Theorem add_stdo_nil: + stdo fd nm fs out ⇒ add_stdo fd nm fs (strlit "") = fs +Proof + rw[add_stdo_def] \\ SELECT_ELIM_TAC - \\ metis_tac[up_stdo_unchanged]); - -Theorem add_stdo_o - `stdo fd nm fs out ⇒ - add_stdo fd nm (add_stdo fd nm fs x1) x2 = add_stdo fd nm fs (x1 ^ x2)` - (rw[add_stdo_def] + \\ metis_tac[up_stdo_unchanged] +QED + +Theorem add_stdo_o: + stdo fd nm fs out ⇒ + add_stdo fd nm (add_stdo fd nm fs x1) x2 = add_stdo fd nm fs (x1 ^ x2) +Proof + rw[add_stdo_def] \\ SELECT_ELIM_TAC \\ rw[] >- metis_tac[] \\ SELECT_ELIM_TAC \\ rw[] >- metis_tac[stdo_up_stdo] \\ imp_res_tac stdo_UNICITY_R \\ rveq \\ rename1`stdo _ _ (up_stdo _ _ _) l` \\ `l = out ^ x1` by metis_tac[stdo_UNICITY_R,stdo_up_stdo] - \\ rveq \\ fs[up_stdo_def]); - -Theorem add_stdo_numchars[simp] - `(add_stdo fd nm fs x).numchars = fs.numchars` - (rw[add_stdo_def]); - -Theorem add_stdo_maxFD[simp] - `(add_stdo fd nm fs x).maxFD = fs.maxFD` - (rw[add_stdo_def]); - -Theorem add_stdo_with_numchars - `add_stdo fd nm (fs with numchars := ns) x = - add_stdo fd nm fs x with numchars := ns` - (rw[add_stdo_def,stdo_numchars,up_stdo_with_numchars]); - -Theorem up_stdo_MAP_FST_infds[simp] - `MAP FST (up_stdo fd fs out).infds = MAP FST fs.infds` - (rw[up_stdo_def]); - -Theorem add_stdo_MAP_FST_infds[simp] - `MAP FST (add_stdo fd nm fs out).infds = MAP FST fs.infds` - (rw[add_stdo_def]); - -Theorem up_stdo_MAP_FST_files[simp] - `MAP FST (up_stdo fd fs out).files = MAP FST fs.files` - (rw[up_stdo_def]); - -Theorem up_stdo_MAP_FST_inode_tbl[simp] - `MAP FST (up_stdo fd fs out).inode_tbl = MAP FST fs.inode_tbl` - (rw[up_stdo_def]); - -Theorem add_stdo_MAP_FST_inode_tbl[simp] - `MAP FST (add_stdo fd nm fs out).inode_tbl = MAP FST fs.inode_tbl` - (rw[add_stdo_def]); - -Theorem inFS_fname_add_stdo[simp] - `inFS_fname (add_stdo fd nm fs out) = inFS_fname fs` - (rw[inFS_fname_def,FUN_EQ_THM] >> EVAL_TAC >> EVERY_CASE_TAC >> rw[]); - -Theorem STD_streams_stdout - `STD_streams fs ⇒ ∃out. stdout fs out` - (rw[STD_streams_def,stdo_def] \\ rw[] \\ metis_tac[explode_implode,strlen_implode]); - -Theorem STD_streams_stderr - `STD_streams fs ⇒ ∃out. stderr fs out` - (rw[STD_streams_def,stdo_def] \\ rw[] \\ metis_tac[explode_implode,strlen_implode]); - -Theorem STD_streams_add_stdout - `STD_streams fs ⇒ STD_streams (add_stdout fs out)` - (rw[] + \\ rveq \\ fs[up_stdo_def] +QED + +Theorem add_stdo_numchars[simp]: + (add_stdo fd nm fs x).numchars = fs.numchars +Proof + rw[add_stdo_def] +QED + +Theorem add_stdo_maxFD[simp]: + (add_stdo fd nm fs x).maxFD = fs.maxFD +Proof + rw[add_stdo_def] +QED + +Theorem add_stdo_with_numchars: + add_stdo fd nm (fs with numchars := ns) x = + add_stdo fd nm fs x with numchars := ns +Proof + rw[add_stdo_def,stdo_numchars,up_stdo_with_numchars] +QED + +Theorem up_stdo_MAP_FST_infds[simp]: + MAP FST (up_stdo fd fs out).infds = MAP FST fs.infds +Proof + rw[up_stdo_def] +QED + +Theorem add_stdo_MAP_FST_infds[simp]: + MAP FST (add_stdo fd nm fs out).infds = MAP FST fs.infds +Proof + rw[add_stdo_def] +QED + +Theorem up_stdo_MAP_FST_files[simp]: + MAP FST (up_stdo fd fs out).files = MAP FST fs.files +Proof + rw[up_stdo_def] +QED + +Theorem up_stdo_MAP_FST_inode_tbl[simp]: + MAP FST (up_stdo fd fs out).inode_tbl = MAP FST fs.inode_tbl +Proof + rw[up_stdo_def] +QED + +Theorem add_stdo_MAP_FST_inode_tbl[simp]: + MAP FST (add_stdo fd nm fs out).inode_tbl = MAP FST fs.inode_tbl +Proof + rw[add_stdo_def] +QED + +Theorem inFS_fname_add_stdo[simp]: + inFS_fname (add_stdo fd nm fs out) = inFS_fname fs +Proof + rw[inFS_fname_def,FUN_EQ_THM] >> EVAL_TAC >> EVERY_CASE_TAC >> rw[] +QED + +Theorem STD_streams_stdout: + STD_streams fs ⇒ ∃out. stdout fs out +Proof + rw[STD_streams_def,stdo_def] \\ rw[] \\ metis_tac[explode_implode,strlen_implode] +QED + +Theorem STD_streams_stderr: + STD_streams fs ⇒ ∃out. stderr fs out +Proof + rw[STD_streams_def,stdo_def] \\ rw[] \\ metis_tac[explode_implode,strlen_implode] +QED + +Theorem STD_streams_add_stdout: + STD_streams fs ⇒ STD_streams (add_stdout fs out) +Proof + rw[] \\ imp_res_tac STD_streams_stdout \\ rw[add_stdo_def] \\ SELECT_ELIM_TAC \\ rw[] >- metis_tac[] \\ rw[up_stdo_def] - \\ match_mp_tac STD_streams_fsupdate \\ rw[]); + \\ match_mp_tac STD_streams_fsupdate \\ rw[] +QED -Theorem STD_streams_add_stderr - `STD_streams fs ⇒ STD_streams (add_stderr fs out)` - (rw[] +Theorem STD_streams_add_stderr: + STD_streams fs ⇒ STD_streams (add_stderr fs out) +Proof + rw[] \\ imp_res_tac STD_streams_stderr \\ rw[add_stdo_def] \\ SELECT_ELIM_TAC \\ rw[] >- metis_tac[] \\ rw[up_stdo_def] - \\ match_mp_tac STD_streams_fsupdate \\ rw[]); - -Theorem validFD_up_stdo[simp] - `validFD fd (up_stdo fd' fs out) ⇔ validFD fd fs` - (rw[up_stdo_def]); - -Theorem validFD_add_stdo[simp] - `validFD fd (add_stdo fd' nm fs out) ⇔ validFD fd fs` - (rw[add_stdo_def]); - -Theorem validFileFD_up_stdo[simp] - `validFileFD fd (up_stdo fd' fs out).infds ⇔ validFileFD fd fs.infds` - (rw[up_stdo_def]); - -Theorem validFileFD_add_stdo[simp] - `validFileFD fd (add_stdo fd' nm fs out).infds ⇔ validFileFD fd fs.infds` - (rw[add_stdo_def]); - -Theorem up_stdo_ADELKEY - `fd ≠ fd' ⇒ + \\ match_mp_tac STD_streams_fsupdate \\ rw[] +QED + +Theorem validFD_up_stdo[simp]: + validFD fd (up_stdo fd' fs out) ⇔ validFD fd fs +Proof + rw[up_stdo_def] +QED + +Theorem validFD_add_stdo[simp]: + validFD fd (add_stdo fd' nm fs out) ⇔ validFD fd fs +Proof + rw[add_stdo_def] +QED + +Theorem validFileFD_up_stdo[simp]: + validFileFD fd (up_stdo fd' fs out).infds ⇔ validFileFD fd fs.infds +Proof + rw[up_stdo_def] +QED + +Theorem validFileFD_add_stdo[simp]: + validFileFD fd (add_stdo fd' nm fs out).infds ⇔ validFileFD fd fs.infds +Proof + rw[add_stdo_def] +QED + +Theorem up_stdo_ADELKEY: + fd ≠ fd' ⇒ up_stdo fd (fs with infds updated_by ADELKEY fd') out = - up_stdo fd fs out with infds updated_by ADELKEY fd'` - (rw[up_stdo_def,fsupdate_ADELKEY]); - -Theorem stdo_ADELKEY - `fd ≠ fd' ⇒ - stdo fd nm (fs with infds updated_by ADELKEY fd') = stdo fd nm fs` - (rw[stdo_def,FUN_EQ_THM,ALOOKUP_ADELKEY]); - -Theorem add_stdo_ADELKEY - `fd ≠ fd' ⇒ + up_stdo fd fs out with infds updated_by ADELKEY fd' +Proof + rw[up_stdo_def,fsupdate_ADELKEY] +QED + +Theorem stdo_ADELKEY: + fd ≠ fd' ⇒ + stdo fd nm (fs with infds updated_by ADELKEY fd') = stdo fd nm fs +Proof + rw[stdo_def,FUN_EQ_THM,ALOOKUP_ADELKEY] +QED + +Theorem add_stdo_ADELKEY: + fd ≠ fd' ⇒ add_stdo fd nm (fs with infds updated_by ADELKEY fd') out = - add_stdo fd nm fs out with infds updated_by ADELKEY fd'` - (rw[add_stdo_def,up_stdo_ADELKEY,stdo_ADELKEY]); - -Theorem get_file_content_add_stdout - `STD_streams fs ∧ fd ≠ 1 ⇒ - get_file_content (add_stdout fs out) fd = get_file_content fs fd` - (rw[get_file_content_def,add_stdo_def,up_stdo_def,fsupdate_def] + add_stdo fd nm fs out with infds updated_by ADELKEY fd' +Proof + rw[add_stdo_def,up_stdo_ADELKEY,stdo_ADELKEY] +QED + +Theorem get_file_content_add_stdout: + STD_streams fs ∧ fd ≠ 1 ⇒ + get_file_content (add_stdout fs out) fd = get_file_content fs fd +Proof + rw[get_file_content_def,add_stdo_def,up_stdo_def,fsupdate_def] \\ CASE_TAC \\ CASE_TAC \\ simp[AFUPDKEY_ALOOKUP] \\ TOP_CASE_TAC \\ fs[] \\ pairarg_tac \\ fs[] \\ CASE_TAC >- metis_tac[STD_streams_def,SOME_11,PAIR,FST,SND] - \\ CASE_TAC); + \\ CASE_TAC +QED -Theorem get_mode_add_stdo[simp] - `get_mode (add_stdo fd nm fs x) fd' = get_mode fs fd'` - (rw[get_mode_def,add_stdo_def, up_stdo_def, fsupdate_def] +Theorem get_mode_add_stdo[simp]: + get_mode (add_stdo fd nm fs x) fd' = get_mode fs fd' +Proof + rw[get_mode_def,add_stdo_def, up_stdo_def, fsupdate_def] \\ TOP_CASE_TAC \\ rw[] \\ TOP_CASE_TAC \\ rw[] \\ simp[AFUPDKEY_ALOOKUP] - \\ TOP_CASE_TAC \\ rw[]); - -Theorem get_mode_bumpFD[simp] - `get_mode (bumpFD fd fs n) fd' = get_mode fs fd'` - (rw[get_mode_def,bumpFD_def,AFUPDKEY_ALOOKUP] - \\ TOP_CASE_TAC \\ rw[]); - -Theorem linesFD_add_stdout - `STD_streams fs ∧ fd ≠ 1 ⇒ - linesFD (add_stdout fs out) fd = linesFD fs fd` - (rw[linesFD_def,get_file_content_add_stdout]); - -Theorem get_file_content_add_stderr - `STD_streams fs ∧ fd ≠ 2 ⇒ - get_file_content (add_stderr fs err) fd = get_file_content fs fd` - (rw[get_file_content_def,add_stdo_def,up_stdo_def,fsupdate_def] + \\ TOP_CASE_TAC \\ rw[] +QED + +Theorem get_mode_bumpFD[simp]: + get_mode (bumpFD fd fs n) fd' = get_mode fs fd' +Proof + rw[get_mode_def,bumpFD_def,AFUPDKEY_ALOOKUP] + \\ TOP_CASE_TAC \\ rw[] +QED + +Theorem linesFD_add_stdout: + STD_streams fs ∧ fd ≠ 1 ⇒ + linesFD (add_stdout fs out) fd = linesFD fs fd +Proof + rw[linesFD_def,get_file_content_add_stdout] +QED + +Theorem get_file_content_add_stderr: + STD_streams fs ∧ fd ≠ 2 ⇒ + get_file_content (add_stderr fs err) fd = get_file_content fs fd +Proof + rw[get_file_content_def,add_stdo_def,up_stdo_def,fsupdate_def] \\ CASE_TAC \\ CASE_TAC \\ simp[AFUPDKEY_ALOOKUP] \\ TOP_CASE_TAC \\ fs[] \\ pairarg_tac \\ fs[] \\ CASE_TAC >- metis_tac[STD_streams_def,SOME_11,PAIR,FST,SND] - \\ CASE_TAC); - -Theorem linesFD_add_stderr - `STD_streams fs ∧ fd ≠ 2 ⇒ - linesFD (add_stderr fs err) fd = linesFD fs fd` - (rw[linesFD_def,get_file_content_add_stderr]); - -Theorem up_stdo_forwardFD - `fd ≠ fd' ⇒ up_stdo fd' (forwardFD fs fd n) out = forwardFD (up_stdo fd' fs out) fd n` - (rw[forwardFD_def,up_stdo_def,fsupdate_def,AFUPDKEY_ALOOKUP] + \\ CASE_TAC +QED + +Theorem linesFD_add_stderr: + STD_streams fs ∧ fd ≠ 2 ⇒ + linesFD (add_stderr fs err) fd = linesFD fs fd +Proof + rw[linesFD_def,get_file_content_add_stderr] +QED + +Theorem up_stdo_forwardFD: + fd ≠ fd' ⇒ up_stdo fd' (forwardFD fs fd n) out = forwardFD (up_stdo fd' fs out) fd n +Proof + rw[forwardFD_def,up_stdo_def,fsupdate_def,AFUPDKEY_ALOOKUP] \\ CASE_TAC \\ CASE_TAC \\ rw[] \\ rpt(AP_TERM_TAC ORELSE AP_THM_TAC) - \\ match_mp_tac AFUPDKEY_comm \\ rw[]); - -Theorem up_stdout_fastForwardFD - `STD_streams fs ⇒ - up_stdout (fastForwardFD fs fd) out = fastForwardFD (up_stdout fs out) fd` - (rw[fastForwardFD_def,up_stdo_def] + \\ match_mp_tac AFUPDKEY_comm \\ rw[] +QED + +Theorem up_stdout_fastForwardFD: + STD_streams fs ⇒ + up_stdout (fastForwardFD fs fd) out = fastForwardFD (up_stdout fs out) fd +Proof + rw[fastForwardFD_def,up_stdo_def] \\ Cases_on`ALOOKUP fs.infds fd` >- ( fs[libTheory.the_def,fsupdate_def] \\ CASE_TAC \\ fs[libTheory.the_def] @@ -408,12 +522,14 @@ Theorem up_stdout_fastForwardFD \\ CASE_TAC \\ fs[libTheory.the_def] \\ CASE_TAC \\ fs[libTheory.the_def,AFUPDKEY_ALOOKUP] \\ rw[libTheory.the_def,AFUPDKEY_comm] - \\ metis_tac[STD_streams_def,SOME_11,PAIR,FST,SND]); - -Theorem up_stderr_fastForwardFD - `STD_streams fs ⇒ - up_stderr (fastForwardFD fs fd) out = fastForwardFD (up_stderr fs out) fd` - (rw[fastForwardFD_def,up_stdo_def] + \\ metis_tac[STD_streams_def,SOME_11,PAIR,FST,SND] +QED + +Theorem up_stderr_fastForwardFD: + STD_streams fs ⇒ + up_stderr (fastForwardFD fs fd) out = fastForwardFD (up_stderr fs out) fd +Proof + rw[fastForwardFD_def,up_stdo_def] \\ Cases_on`ALOOKUP fs.infds fd` >- ( fs[libTheory.the_def,fsupdate_def] \\ CASE_TAC \\ fs[libTheory.the_def] @@ -431,54 +547,70 @@ Theorem up_stderr_fastForwardFD \\ CASE_TAC \\ fs[libTheory.the_def] \\ CASE_TAC \\ fs[libTheory.the_def,AFUPDKEY_ALOOKUP] \\ rw[libTheory.the_def,AFUPDKEY_comm] - \\ metis_tac[STD_streams_def,SOME_11,PAIR,FST,SND]); + \\ metis_tac[STD_streams_def,SOME_11,PAIR,FST,SND] +QED -Theorem stdo_forwardFD - `fd ≠ fd' ⇒ (stdo fd' nm (forwardFD fs fd n) out ⇔ stdo fd' nm fs out)` - (rw[stdo_def,forwardFD_def,AFUPDKEY_ALOOKUP] - \\ CASE_TAC); +Theorem stdo_forwardFD: + fd ≠ fd' ⇒ (stdo fd' nm (forwardFD fs fd n) out ⇔ stdo fd' nm fs out) +Proof + rw[stdo_def,forwardFD_def,AFUPDKEY_ALOOKUP] + \\ CASE_TAC +QED -Theorem stdo_fastForwardFD - `fd ≠ fd' ⇒ (stdo fd' nm (fastForwardFD fs fd) out ⇔ stdo fd' nm fs out)` - (rw[stdo_def,fastForwardFD_def,AFUPDKEY_ALOOKUP] +Theorem stdo_fastForwardFD: + fd ≠ fd' ⇒ (stdo fd' nm (fastForwardFD fs fd) out ⇔ stdo fd' nm fs out) +Proof + rw[stdo_def,fastForwardFD_def,AFUPDKEY_ALOOKUP] \\ Cases_on`ALOOKUP fs.infds fd` \\ fs[libTheory.the_def] \\ pairarg_tac \\ fs[] \\ Cases_on`ALOOKUP fs.inode_tbl ino` \\ fs[libTheory.the_def] \\ fs[AFUPDKEY_ALOOKUP] \\ rw[] - \\ CASE_TAC); - -Theorem add_stdo_forwardFD - `fd ≠ fd' ⇒ add_stdo fd' nm (forwardFD fs fd n) out = forwardFD (add_stdo fd' nm fs out) fd n` - (rw[add_stdo_def,stdo_forwardFD,up_stdo_forwardFD]); - -Theorem add_stdout_lineForwardFD - `STD_streams fs ∧ fd ≠ 1 ⇒ - add_stdout (lineForwardFD fs fd) out = lineForwardFD (add_stdout fs out) fd` - (rw[lineForwardFD_def,get_file_content_add_stdout] + \\ CASE_TAC +QED + +Theorem add_stdo_forwardFD: + fd ≠ fd' ⇒ add_stdo fd' nm (forwardFD fs fd n) out = forwardFD (add_stdo fd' nm fs out) fd n +Proof + rw[add_stdo_def,stdo_forwardFD,up_stdo_forwardFD] +QED + +Theorem add_stdout_lineForwardFD: + STD_streams fs ∧ fd ≠ 1 ⇒ + add_stdout (lineForwardFD fs fd) out = lineForwardFD (add_stdout fs out) fd +Proof + rw[lineForwardFD_def,get_file_content_add_stdout] \\ CASE_TAC \\ CASE_TAC - \\ rw[] \\ pairarg_tac \\ fs[add_stdo_forwardFD]); - -Theorem add_stdout_fastForwardFD - `STD_streams fs ∧ fd ≠ 1 ⇒ - add_stdout (fastForwardFD fs fd) out = fastForwardFD (add_stdout fs out) fd` - (rw[add_stdo_def,up_stdout_fastForwardFD,stdo_fastForwardFD]); - -Theorem add_stderr_lineForwardFD - `STD_streams fs ∧ fd ≠ 2 ⇒ - add_stderr (lineForwardFD fs fd) out = lineForwardFD (add_stderr fs out) fd` - (rw[lineForwardFD_def,get_file_content_add_stderr] + \\ rw[] \\ pairarg_tac \\ fs[add_stdo_forwardFD] +QED + +Theorem add_stdout_fastForwardFD: + STD_streams fs ∧ fd ≠ 1 ⇒ + add_stdout (fastForwardFD fs fd) out = fastForwardFD (add_stdout fs out) fd +Proof + rw[add_stdo_def,up_stdout_fastForwardFD,stdo_fastForwardFD] +QED + +Theorem add_stderr_lineForwardFD: + STD_streams fs ∧ fd ≠ 2 ⇒ + add_stderr (lineForwardFD fs fd) out = lineForwardFD (add_stderr fs out) fd +Proof + rw[lineForwardFD_def,get_file_content_add_stderr] \\ CASE_TAC \\ CASE_TAC - \\ rw[] \\ pairarg_tac \\ fs[add_stdo_forwardFD]); - -Theorem add_stderr_fastForwardFD - `STD_streams fs ∧ fd ≠ 2 ⇒ - add_stderr (fastForwardFD fs fd) out = fastForwardFD (add_stderr fs out) fd` - (rw[add_stdo_def,up_stderr_fastForwardFD,stdo_fastForwardFD]); - -Theorem FILTER_File_add_stdo - `stdo fd nm fs init ⇒ - FILTER (isFile o FST) (add_stdo fd nm fs out).inode_tbl = FILTER (isFile o FST) fs.inode_tbl` - (rw[add_stdo_def,up_stdo_def,fsupdate_def] + \\ rw[] \\ pairarg_tac \\ fs[add_stdo_forwardFD] +QED + +Theorem add_stderr_fastForwardFD: + STD_streams fs ∧ fd ≠ 2 ⇒ + add_stderr (fastForwardFD fs fd) out = fastForwardFD (add_stderr fs out) fd +Proof + rw[add_stdo_def,up_stderr_fastForwardFD,stdo_fastForwardFD] +QED + +Theorem FILTER_File_add_stdo: + stdo fd nm fs init ⇒ + FILTER (isFile o FST) (add_stdo fd nm fs out).inode_tbl = FILTER (isFile o FST) fs.inode_tbl +Proof + rw[add_stdo_def,up_stdo_def,fsupdate_def] \\ CASE_TAC \\ CASE_TAC \\ fs[] \\ match_mp_tac FILTER_EL_EQ \\ simp[] \\ qmatch_assum_rename_tac`_ = SOME (k,_)` @@ -487,17 +619,22 @@ Theorem FILTER_File_add_stdo \\ reverse(Cases_on`FST (EL n fs.inode_tbl) = k`) >- simp[EL_AFUPDKEY_unchanged] \\ simp[FST_EL_AFUPDKEY,GSYM AND_IMP_INTRO] - \\ fs[stdo_def]); - -Theorem FILTER_File_add_stdout - `STD_streams fs ⇒ - FILTER (isFile o FST) (add_stdout fs out).inode_tbl = FILTER (isFile o FST) fs.inode_tbl` - (metis_tac[STD_streams_stdout,FILTER_File_add_stdo]); - -Theorem FILTER_File_add_stderr - `STD_streams fs ⇒ - FILTER (isFile o FST) (add_stderr fs out).inode_tbl = FILTER (isFile o FST) fs.inode_tbl` - (metis_tac[STD_streams_stderr,FILTER_File_add_stdo]); + \\ fs[stdo_def] +QED + +Theorem FILTER_File_add_stdout: + STD_streams fs ⇒ + FILTER (isFile o FST) (add_stdout fs out).inode_tbl = FILTER (isFile o FST) fs.inode_tbl +Proof + metis_tac[STD_streams_stdout,FILTER_File_add_stdo] +QED + +Theorem FILTER_File_add_stderr: + STD_streams fs ⇒ + FILTER (isFile o FST) (add_stderr fs out).inode_tbl = FILTER (isFile o FST) fs.inode_tbl +Proof + metis_tac[STD_streams_stderr,FILTER_File_add_stdo] +QED val stdin_def = Define `stdin fs inp pos = (ALOOKUP fs.infds 0 = SOME(UStream(strlit"stdin"),ReadMode,pos) /\ @@ -509,50 +646,62 @@ val up_stdin_def = Define val get_stdin_def = Define` get_stdin fs = let (inp,pos) = @(inp,pos). stdin fs inp pos in DROP pos inp`; -Theorem stdin_11 - `stdin fs i1 p1 ∧ stdin fs i2 p2 ⇒ i1 = i2 ∧ p1 = p2` - (rw[stdin_def] \\ fs[]); - -Theorem stdin_get_file_content - `stdin fs inp pos ⇒ get_file_content fs 0 = SOME (inp,pos)` - (rw[stdin_def,fsFFITheory.get_file_content_def]); - -Theorem stdin_forwardFD - `stdin fs inp pos ⇒ - stdin (forwardFD fs fd n) inp (if fd = 0 then pos+n else pos)` - (rw[stdin_def,forwardFD_def] - \\ simp[AFUPDKEY_ALOOKUP]); +Theorem stdin_11: + stdin fs i1 p1 ∧ stdin fs i2 p2 ⇒ i1 = i2 ∧ p1 = p2 +Proof + rw[stdin_def] \\ fs[] +QED + +Theorem stdin_get_file_content: + stdin fs inp pos ⇒ get_file_content fs 0 = SOME (inp,pos) +Proof + rw[stdin_def,fsFFITheory.get_file_content_def] +QED + +Theorem stdin_forwardFD: + stdin fs inp pos ⇒ + stdin (forwardFD fs fd n) inp (if fd = 0 then pos+n else pos) +Proof + rw[stdin_def,forwardFD_def] + \\ simp[AFUPDKEY_ALOOKUP] +QED -Theorem stdin_get_stdin - `stdin fs inp pos ⇒ get_stdin fs = DROP pos inp` - (rw[get_stdin_def] +Theorem stdin_get_stdin: + stdin fs inp pos ⇒ get_stdin fs = DROP pos inp +Proof + rw[get_stdin_def] \\ SELECT_ELIM_TAC \\ rw[EXISTS_PROD,FORALL_PROD] >- metis_tac[] \\ pairarg_tac \\ fs[] - \\ imp_res_tac stdin_11 \\ fs[]); + \\ imp_res_tac stdin_11 \\ fs[] +QED -Theorem get_stdin_forwardFD - `stdin fs inp pos ⇒ +Theorem get_stdin_forwardFD: + stdin fs inp pos ⇒ get_stdin (forwardFD fs fd n) = if fd = 0 then DROP n (get_stdin fs) - else get_stdin fs` - (strip_tac + else get_stdin fs +Proof + strip_tac \\ imp_res_tac stdin_get_stdin \\ imp_res_tac stdin_forwardFD \\ first_x_assum(qspecl_then[`n`,`fd`]mp_tac) \\ strip_tac \\ simp[DROP_DROP_T] \\ imp_res_tac stdin_get_stdin - \\ rw[]); + \\ rw[] +QED -Theorem linesFD_splitlines_get_stdin - `stdin fs inp pos ⇒ - MAP (λl. l ++ "\n") (splitlines (get_stdin fs)) = linesFD fs 0` - (rw[linesFD_def] +Theorem linesFD_splitlines_get_stdin: + stdin fs inp pos ⇒ + MAP (λl. l ++ "\n") (splitlines (get_stdin fs)) = linesFD fs 0 +Proof + rw[linesFD_def] \\ imp_res_tac stdin_get_stdin - \\ fs[stdin_def,get_file_content_def]); + \\ fs[stdin_def,get_file_content_def] +QED (* file descriptors are encoded on 8 bytes *) val FD_def = Define ` @@ -568,22 +717,28 @@ val OUTSTREAM_def = Define ` OUTSTREAM_TYPE (Outstream (strlit(MAP (CHR ∘ w2n) (n2w8 fd)))) fdv ∧ fd < 256**8` -Theorem INSTREAM_stdin - `INSTREAM 0 stdin_v` - (fs[INSTREAM_def,MarshallingTheory.n2w8_def,stdin_v_thm,GSYM stdIn_def]); +Theorem INSTREAM_stdin: + INSTREAM 0 stdin_v +Proof + fs[INSTREAM_def,MarshallingTheory.n2w8_def,stdin_v_thm,GSYM stdIn_def] +QED -Theorem OUTSTREAM_stdout - `OUTSTREAM 1 stdout_v` - (fs[OUTSTREAM_def,MarshallingTheory.n2w8_def,stdout_v_thm,GSYM stdOut_def]); +Theorem OUTSTREAM_stdout: + OUTSTREAM 1 stdout_v +Proof + fs[OUTSTREAM_def,MarshallingTheory.n2w8_def,stdout_v_thm,GSYM stdOut_def] +QED -Theorem OUTSTREAM_stderr - `OUTSTREAM 2 stderr_v` - (fs[OUTSTREAM_def,MarshallingTheory.n2w8_def,stderr_v_thm,GSYM stdErr_def]); +Theorem OUTSTREAM_stderr: + OUTSTREAM 2 stderr_v +Proof + fs[OUTSTREAM_def,MarshallingTheory.n2w8_def,stderr_v_thm,GSYM stdErr_def] +QED (* -- *) -Theorem openIn_spec - `∀s sv fs. +Theorem openIn_spec: + ∀s sv fs. FILENAME s sv ∧ hasFreeFD fs ⇒ app (p:'ffi ffi_proj) TextIO_openIn_v [sv] @@ -594,8 +749,9 @@ Theorem openIn_spec inFS_fname fs s) * IOFS (openFileFS s fs ReadMode 0)) - (\e. &(BadFileName_exn e ∧ ~inFS_fname fs s) * IOFS fs))` - (rw [] >> qpat_abbrev_tac `Q = POSTve _ _` >> + (\e. &(BadFileName_exn e ∧ ~inFS_fname fs s) * IOFS fs)) +Proof + rw [] >> qpat_abbrev_tac `Q = POSTve _ _` >> simp [IOFS_def, fs_ffi_part_def, IOx_def, IO_def] >> xpull >> qunabbrev_tac `Q` >> xcf_with_def "TextIO.openIn" TextIO_openIn_v_def >> @@ -668,11 +824,12 @@ Theorem openIn_spec xlet_auto >- (xsimpl >> imp_res_tac WORD_UNICITY_R) >> xif >-(rfs[Abbr`fd0`,EL_LUPDATE,HD_LUPDATE]) >> xlet_auto >-(xcon >> xsimpl) >> xraise >> xsimpl >> - simp[BadFileName_exn_def,Abbr`fd0`,LENGTH_explode]); + simp[BadFileName_exn_def,Abbr`fd0`,LENGTH_explode] +QED (* STDIO version *) -Theorem openIn_STDIO_spec - `∀s sv fs. +Theorem openIn_STDIO_spec: + ∀s sv fs. FILENAME s sv ∧ hasFreeFD fs ⇒ app (p:'ffi ffi_proj) TextIO_openIn_v [sv] @@ -682,26 +839,29 @@ Theorem openIn_STDIO_spec validFD (nextFD fs) (openFileFS s fs ReadMode 0) ∧ inFS_fname fs s) * STDIO (openFileFS s fs ReadMode 0)) - (\e. &(BadFileName_exn e ∧ ~inFS_fname fs s) * STDIO fs))` - (rw[STDIO_def] >> xpull >> xapp_spec openIn_spec >> + (\e. &(BadFileName_exn e ∧ ~inFS_fname fs s) * STDIO fs)) +Proof + rw[STDIO_def] >> xpull >> xapp_spec openIn_spec >> map_every qexists_tac [`emp`,`s`,`fs with numchars := ll`] >> xsimpl >> rw[] >> qexists_tac`ll` >> fs[openFileFS_fupd_numchars] >> xsimpl >> rw[] >> fs[nextFD_numchars,nextFD_numchars,openFileFS_fupd_numchars,STD_streams_openFileFS] >> - fs[GSYM validFD_numchars,GSYM openFileFS_fupd_numchars,inFS_fname_numchars]) + fs[GSYM validFD_numchars,GSYM openFileFS_fupd_numchars,inFS_fname_numchars] +QED (* openOut, openAppend here *) -Theorem closeIn_spec - `∀fdw fdv fs. +Theorem closeIn_spec: + ∀fdw fdv fs. INSTREAM fdw fdv ⇒ app (p:'ffi ffi_proj) TextIO_closeIn_v [fdv] (IOFS fs) (POSTve (\u. &(UNIT_TYPE () u /\ validFileFD fdw fs.infds) * IOFS (fs with infds updated_by ADELKEY fdw)) - (\e. &(InvalidFD_exn e /\ ¬ validFileFD fdw fs.infds) * IOFS fs))` - (rw [] >> qpat_abbrev_tac `Q = POSTve _ _` >> + (\e. &(InvalidFD_exn e /\ ¬ validFileFD fdw fs.infds) * IOFS fs)) +Proof + rw [] >> qpat_abbrev_tac `Q = POSTve _ _` >> simp [IOFS_def, fs_ffi_part_def, IOx_def, IO_def] >> xpull >> qunabbrev_tac `Q` >> xcf_with_def "TextIO.closeIn" TextIO_closeIn_v_def >> @@ -736,18 +896,20 @@ Theorem closeIn_spec CASE_TAC >> xif >> instantiate >-(xcon >> fs[IOFS_def,liveFS_def] >> xsimpl) >> xlet_auto >-(xcon >> xsimpl) >> - xraise >> fs[InvalidFD_exn_def,IOFS_def] >> xsimpl); + xraise >> fs[InvalidFD_exn_def,IOFS_def] >> xsimpl +QED -Theorem closeOut_spec - `∀fdw fdv fs. +Theorem closeOut_spec: + ∀fdw fdv fs. OUTSTREAM fdw fdv ⇒ app (p:'ffi ffi_proj) TextIO_closeOut_v [fdv] (IOFS fs) (POSTve (\u. &(UNIT_TYPE () u /\ validFileFD fdw fs.infds) * IOFS (fs with infds updated_by ADELKEY fdw)) - (\e. &(InvalidFD_exn e /\ ¬ validFileFD fdw fs.infds) * IOFS fs))` - (rw [] >> qpat_abbrev_tac `Q = POSTve _ _` >> + (\e. &(InvalidFD_exn e /\ ¬ validFileFD fdw fs.infds) * IOFS fs)) +Proof + rw [] >> qpat_abbrev_tac `Q = POSTve _ _` >> simp [IOFS_def, fs_ffi_part_def, IOx_def, IO_def] >> xpull >> qunabbrev_tac `Q` >> xcf_with_def "TextIO.closeOut" TextIO_closeOut_v_def >> @@ -782,46 +944,51 @@ Theorem closeOut_spec CASE_TAC >> xif >> instantiate >-(xcon >> fs[IOFS_def,liveFS_def] >> xsimpl) >> xlet_auto >-(xcon >> xsimpl) >> - xraise >> fs[InvalidFD_exn_def,IOFS_def] >> xsimpl); + xraise >> fs[InvalidFD_exn_def,IOFS_def] >> xsimpl +QED -Theorem closeIn_STDIO_spec - `∀fd fs fdv. +Theorem closeIn_STDIO_spec: + ∀fd fs fdv. INSTREAM fd fdv /\ fd >= 3 /\ fd <= fs.maxFD ⇒ app (p:'ffi ffi_proj) TextIO_closeIn_v [fdv] (STDIO fs) (POSTve (\u. &(UNIT_TYPE () u /\ validFileFD fd fs.infds) * STDIO (fs with infds updated_by ADELKEY fd)) - (\e. &(InvalidFD_exn e /\ ¬ validFileFD fd fs.infds) * STDIO fs))` - (rw[STDIO_def] >> xpull >> xapp_spec closeIn_spec >> + (\e. &(InvalidFD_exn e /\ ¬ validFileFD fd fs.infds) * STDIO fs)) +Proof + rw[STDIO_def] >> xpull >> xapp_spec closeIn_spec >> map_every qexists_tac [`emp`,`fs with numchars := ll`,`fd`] >> xsimpl >> rw[] >> qexists_tac`ll` >> fs[validFileFD_def] >> xsimpl >> fs[STD_streams_def,ALOOKUP_ADELKEY] \\ Cases_on`fd = 0` \\ fs[] \\ Cases_on`fd = 1` \\ fs[] \\ Cases_on`fd = 2` \\ fs[] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem closeOut_STDIO_spec - `∀fd fs fdv. +Theorem closeOut_STDIO_spec: + ∀fd fs fdv. OUTSTREAM fd fdv /\ fd >= 3 /\ fd <= fs.maxFD ⇒ app (p:'ffi ffi_proj) TextIO_closeOut_v [fdv] (STDIO fs) (POSTve (\u. &(UNIT_TYPE () u /\ validFileFD fd fs.infds) * STDIO (fs with infds updated_by ADELKEY fd)) - (\e. &(InvalidFD_exn e /\ ¬ validFileFD fd fs.infds) * STDIO fs))` - (rw[STDIO_def] >> xpull >> xapp_spec closeOut_spec >> + (\e. &(InvalidFD_exn e /\ ¬ validFileFD fd fs.infds) * STDIO fs)) +Proof + rw[STDIO_def] >> xpull >> xapp_spec closeOut_spec >> map_every qexists_tac [`emp`,`fs with numchars := ll`,`fd`] >> xsimpl >> rw[] >> qexists_tac`ll` >> fs[validFileFD_def] >> xsimpl >> fs[STD_streams_def,ALOOKUP_ADELKEY] \\ Cases_on`fd = 0` \\ fs[] \\ Cases_on`fd = 1` \\ fs[] \\ Cases_on`fd = 2` \\ fs[] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem writei_spec - `wfFS fs ⇒ 0 < n ⇒ +Theorem writei_spec: + wfFS fs ⇒ 0 < n ⇒ MAX (i+n) 2048 <= LENGTH rest ⇒ i + n < 256**2 ⇒ get_file_content fs fd = SOME(content, pos) ⇒ get_mode fs fd = SOME WriteMode ⇒ @@ -837,8 +1004,9 @@ Theorem writei_spec (insert_atI (TAKE nw (MAP (CHR o w2n) (DROP i rest))) pos content))) (\e. &(InvalidFD_exn e) * W8ARRAY iobuff_loc (1w :: n2w n :: n2w2 i ++ rest) * &(F) * - IOFS (fs with numchars:= THE(LDROP (1 + Lnext_pos fs.numchars) fs.numchars))))` - (strip_tac >> + IOFS (fs with numchars:= THE(LDROP (1 + Lnext_pos fs.numchars) fs.numchars)))) +Proof + strip_tac >> `?ll. fs.numchars = ll` by simp[] >> fs[] >> `ll ≠ [||]` by (cases_on`ll` >> fs[wfFS_def,liveFS_def,live_numchars_def]) >> `always (eventually (λll. ∃k. LHD ll = SOME k ∧ k ≠ 0)) ll` @@ -963,10 +1131,11 @@ Theorem writei_spec `Lnext_pos (0:::t) = SUC(Lnext_pos t)` by (fs[Lnext_pos_def,Once Lnext_def]) >> csimp[ADD] >> xsimpl >> cases_on`t` >> - fs[get_mode_def] >> rw[] >> instantiate >> xsimpl); + fs[get_mode_def] >> rw[] >> instantiate >> xsimpl +QED -Theorem write_spec - `!n fs fd i pos h1 h2 h3 h4 rest bc fdv nv iv content. +Theorem write_spec: + !n fs fd i pos h1 h2 h3 h4 rest bc fdv nv iv content. wfFS fs ⇒ MAX(i + n) 2048 <= LENGTH rest ⇒ i + n < 256 ** 2 ⇒ get_file_content fs fd = SOME(content, pos) ⇒ get_mode fs fd = SOME WriteMode ⇒ @@ -977,8 +1146,9 @@ Theorem write_spec (POSTv nwv. SEP_EXISTS k. IOFS(fsupdate fs fd k (pos + n) (insert_atI (TAKE n (MAP (CHR o w2n) (DROP i rest))) pos - content)))` - (strip_tac >> `?N. n <= N` by (qexists_tac`n` >> fs[]) >> + content))) +Proof + strip_tac >> `?N. n <= N` by (qexists_tac`n` >> fs[]) >> FIRST_X_ASSUM MP_TAC >> qid_spec_tac`n` >> Induct_on`N` >> xcf_with_def "TextIO.write" TextIO_write_v_def @@ -1014,10 +1184,11 @@ Theorem write_spec qmatch_abbrev_tac`_ (_ _ _ _ _ (_ c1 _ _)) ==>> _ (_ _ _ _ _ (_ c2 _ _)) * _` >> `c1 = c2` suffices_by xsimpl >> fs[Abbr`c1`,Abbr`c2`] >> PURE_REWRITE_TAC[Once (Q.SPECL [`i`,`nw`] ADD_COMM)] >> - fs[Once ADD_COMM,GSYM DROP_DROP_T,take_drop_partition,MAP_DROP]); + fs[Once ADD_COMM,GSYM DROP_DROP_T,take_drop_partition,MAP_DROP] +QED -Theorem output1_spec - `!fd fdv c cv bc content pos. +Theorem output1_spec: + !fd fdv c cv bc content pos. get_file_content fs fd = SOME(content, pos) ⇒ get_mode fs fd = SOME WriteMode ⇒ CHAR c cv ⇒ OUTSTREAM fd fdv ⇒ @@ -1025,8 +1196,9 @@ Theorem output1_spec (IOFS fs) (POSTv uv. &UNIT_TYPE () uv * SEP_EXISTS k. - IOFS (fsupdate fs fd k (pos+1) (insert_atI [c] pos content)))` - (xcf_with_def "TextIO.output1" TextIO_output1_v_def >> + IOFS (fsupdate fs fd k (pos+1) (insert_atI [c] pos content))) +Proof + xcf_with_def "TextIO.output1" TextIO_output1_v_def >> fs[IOFS_def,IOFS_iobuff_def] >> xpull >> rename [`W8ARRAY _ bdef`] >> ntac 3 (xlet_auto >- xsimpl) >> @@ -1040,18 +1212,20 @@ Theorem output1_spec simp[LUPDATE_compute] >> xlet_auto >-(xsimpl >> fs [FD_def]) >> xcon >> fs[IOFS_def,IOFS_iobuff_def] >> xsimpl >> rw[] >> - fs[CHR_ORD,LESS_MOD,ORD_BOUND] >> qexists_tac`k` >> xsimpl); + fs[CHR_ORD,LESS_MOD,ORD_BOUND] >> qexists_tac`k` >> xsimpl +QED -Theorem output1_STDIO_spec - `!fd. get_file_content fs fd = SOME(content, pos) ∧ +Theorem output1_STDIO_spec: + !fd. get_file_content fs fd = SOME(content, pos) ∧ get_mode fs fd = SOME WriteMode ∧ CHAR c cv ∧ OUTSTREAM fd fdv ⇒ app (p:'ffi ffi_proj) TextIO_output1_v [fdv; cv] (STDIO fs) (POSTv uv. &UNIT_TYPE () uv * - STDIO (fsupdate fs fd 0 (pos+1) (insert_atI [c] pos content)))` - (rw[STDIO_def] \\ xpull \\ xapp_spec output1_spec \\ + STDIO (fsupdate fs fd 0 (pos+1) (insert_atI [c] pos content))) +Proof + rw[STDIO_def] \\ xpull \\ xapp_spec output1_spec \\ mp_tac(SYM(SPEC_ALL get_file_content_numchars)) \\ rw[] \\ mp_tac(get_mode_with_numchars) \\ rw[] \\ instantiate \\ simp[GSYM validFD_numchars] \\ xsimpl \\ rw[] \\ @@ -1067,7 +1241,8 @@ Theorem output1_STDIO_spec \\ qmatch_abbrev_tac`IOFS fs1 ==>> IOFS fs2 * _` \\ `fs1 = fs2` suffices_by xsimpl \\ fs[get_file_content_def] \\ pairarg_tac \\ fs[] - \\ rw[Abbr`fs1`,Abbr`fs2`,IO_fs_component_equality,fsupdate_def]); + \\ rw[Abbr`fs1`,Abbr`fs2`,IO_fs_component_equality,fsupdate_def] +QED val tac = simp[w82n_n2w8,FD_def,LENGTH_n2w8,STRING_TYPE_def] \\ xsimpl @@ -1082,28 +1257,32 @@ val tac = \\ simp[Q.ISPEC`explode x`(Q.GEN`l2`insert_atI_end) |> SIMP_RULE(srw_ss())[]] \\ xsimpl; -Theorem output1_stdout_spec - `CHAR c cv ∧ fdv = stdout_v ==> +Theorem output1_stdout_spec: + CHAR c cv ∧ fdv = stdout_v ==> app (p:'ffi ffi_proj) TextIO_output1_v [fdv; cv] (STDIO fs) - (POSTv uv. &UNIT_TYPE () uv * STDIO (add_stdout fs (str c)))` - (reverse(Cases_on`STD_streams fs`) >- (fs[STDIO_def] \\ strip_tac \\ xpull) + (POSTv uv. &UNIT_TYPE () uv * STDIO (add_stdout fs (str c))) +Proof + reverse(Cases_on`STD_streams fs`) >- (fs[STDIO_def] \\ strip_tac \\ xpull) \\ strip_tac \\ xapp_spec output1_STDIO_spec - \\ tac); + \\ tac +QED -Theorem output1_stderr_spec - `CHAR c cv ∧ fdv = stderr_v ==> +Theorem output1_stderr_spec: + CHAR c cv ∧ fdv = stderr_v ==> app (p:'ffi ffi_proj) TextIO_output1_v [fdv; cv] (STDIO fs) - (POSTv uv. &UNIT_TYPE () uv * STDIO (add_stderr fs (str c)))` - (reverse(Cases_on`STD_streams fs`) >- (fs[STDIO_def] \\ strip_tac \\ xpull) + (POSTv uv. &UNIT_TYPE () uv * STDIO (add_stderr fs (str c))) +Proof + reverse(Cases_on`STD_streams fs`) >- (fs[STDIO_def] \\ strip_tac \\ xpull) \\ strip_tac \\ xapp_spec output1_STDIO_spec - \\ tac); + \\ tac +QED -Theorem output_spec - `!s fd fdv sv fs content pos. +Theorem output_spec: + !s fd fdv sv fs content pos. OUTSTREAM fd fdv ⇒ STRING_TYPE s sv ⇒ (get_file_content fs fd = SOME(content, pos)) ⇒ (get_mode fs fd = SOME WriteMode) ⇒ @@ -1111,8 +1290,9 @@ Theorem output_spec (IOFS fs) (POSTv uv. &(UNIT_TYPE () uv) * SEP_EXISTS k. IOFS (fsupdate fs fd k (pos + (strlen s)) - (insert_atI (explode s) pos content)))` - (strip_tac >> + (insert_atI (explode s) pos content))) +Proof + strip_tac >> `?n. strlen s <= n` by (qexists_tac`strlen s` >> fs[]) >> FIRST_X_ASSUM MP_TAC >> qid_spec_tac`s` >> Induct_on`n` >> @@ -1186,16 +1366,18 @@ Theorem output_spec IF_CASES_TAC \\ fs[TAKE_LENGTH_ID_rwt,LENGTH_explode,strlen_substring, DROP_DROP_T,TAKE_LENGTH_TOO_LONG,DROP_LENGTH_TOO_LONG] - \\ Cases_on`s` \\ fs[substring_def,SEG_TAKE_DROP,TAKE_LENGTH_ID_rwt]); + \\ Cases_on`s` \\ fs[substring_def,SEG_TAKE_DROP,TAKE_LENGTH_ID_rwt] +QED -Theorem output_STDIO_spec - `!fd fdv fs content pos s. +Theorem output_STDIO_spec: + !fd fdv fs content pos s. OUTSTREAM fd fdv ∧ get_file_content fs fd = SOME (content,pos) ∧ get_mode fs fd = SOME WriteMode ∧ STRING_TYPE s sv ⇒ app (p:'ffi ffi_proj) TextIO_output_v [fdv;sv] (STDIO fs) (POSTv uv. &(UNIT_TYPE () uv) * - STDIO (fsupdate fs fd 0 (pos+strlen s) (insert_atI (explode s) pos content)))` - (rpt strip_tac + STDIO (fsupdate fs fd 0 (pos+strlen s) (insert_atI (explode s) pos content))) +Proof + rpt strip_tac \\ fs[STDIO_def] \\ xpull \\ xapp_spec output_spec @@ -1214,79 +1396,86 @@ Theorem output_STDIO_spec by ( fs[STD_streams_def] \\ metis_tac[SOME_11,PAIR,FST,SND] ) \\ - rw[] \\ fs[] \\ simp[insert_atI_end,LENGTH_explode]); + rw[] \\ fs[] \\ simp[insert_atI_end,LENGTH_explode] +QED -Theorem print_spec - `!fs sv s. +Theorem print_spec: + !fs sv s. STRING_TYPE s sv ⇒ app (p:'ffi ffi_proj) TextIO_print_v [sv] (STDIO fs) - (POSTv uv. &(UNIT_TYPE () uv) * STDIO (add_stdout fs s))` - (xcf_with_def "TextIO.print" TextIO_print_v_def + (POSTv uv. &(UNIT_TYPE () uv) * STDIO (add_stdout fs s)) +Proof + xcf_with_def "TextIO.print" TextIO_print_v_def \\ reverse(Cases_on`STD_streams fs`) >- (fs[STDIO_def] \\ xpull) \\ xapp_spec output_STDIO_spec - \\ tac); + \\ tac +QED val print_def = Define ` print s = (\fs. (Success (), add_stdout fs s))` -Theorem EvalM_print - `Eval env exp (STRING_TYPE x) /\ +Theorem EvalM_print: + Eval env exp (STRING_TYPE x) /\ (nsLookup env.v (Short "print") = SOME TextIO_print_v) ==> EvalM F env st (App Opapp [Var (Short "print"); exp]) (MONAD UNIT_TYPE exc_ty (print x)) - (MONAD_IO,p:'ffi ffi_proj)` - ( + (MONAD_IO,p:'ffi ffi_proj) +Proof ho_match_mp_tac EvalM_from_app \\ rw [print_def] \\ fs [MONAD_IO_def] \\ xpull \\ fs [SEP_CLAUSES] \\ xapp_spec print_spec \\ fs[] - ); +QED -Theorem output_stderr_spec - `!fs sv s fdv. +Theorem output_stderr_spec: + !fs sv s fdv. STRING_TYPE s sv ∧ fdv = stderr_v ⇒ app (p:'ffi ffi_proj) TextIO_output_v [fdv;sv] (STDIO fs) - (POSTv uv. &(UNIT_TYPE () uv) * STDIO (add_stderr fs s))` - (rpt strip_tac + (POSTv uv. &(UNIT_TYPE () uv) * STDIO (add_stderr fs s)) +Proof + rpt strip_tac \\ reverse(Cases_on`STD_streams fs`) >- (fs[STDIO_def] \\ xpull) \\ xapp_spec output_STDIO_spec - \\ tac); + \\ tac +QED -Theorem print_err_spec - `!fs sv s. +Theorem print_err_spec: + !fs sv s. STRING_TYPE s sv ⇒ app (p:'ffi ffi_proj) TextIO_print_err_v [sv] (STDIO fs) - (POSTv uv. &(UNIT_TYPE () uv) * STDIO (add_stderr fs s))` - (xcf_with_def "TextIO.print_err" TextIO_print_err_v_def + (POSTv uv. &(UNIT_TYPE () uv) * STDIO (add_stderr fs s)) +Proof + xcf_with_def "TextIO.print_err" TextIO_print_err_v_def \\ reverse(Cases_on`STD_streams fs`) >- (fs[STDIO_def] \\ xpull) - \\ xapp_spec output_stderr_spec \\ fs []); + \\ xapp_spec output_stderr_spec \\ fs [] +QED val print_err_def = Define ` print_err s = (\fs. (Success (), add_stderr fs s))`; -Theorem EvalM_print_err - `Eval env exp (STRING_TYPE x) /\ +Theorem EvalM_print_err: + Eval env exp (STRING_TYPE x) /\ (nsLookup env.v (Long "TextIO" (Short "print_err")) = SOME TextIO_print_err_v) ==> EvalM F env st (App Opapp [Var (Long "TextIO" (Short "print_err")); exp]) (MONAD UNIT_TYPE exc_ty (print_err x)) - (MONAD_IO,p:'ffi ffi_proj)` - ( + (MONAD_IO,p:'ffi ffi_proj) +Proof ho_match_mp_tac EvalM_from_app \\ rw [print_err_def] \\ fs [MONAD_IO_def] \\ xpull \\ fs [SEP_CLAUSES] \\ xapp_spec print_err_spec \\ fs[] - ); +QED -Theorem read_spec - `!fs fd fdv n nv rest h1 h2 h3 h4. wfFS fs ⇒ FD fd fdv ⇒ NUM n nv ⇒ +Theorem read_spec: + !fs fd fdv n nv rest h1 h2 h3 h4. wfFS fs ⇒ FD fd fdv ⇒ NUM n nv ⇒ n < 256**2 ⇒ MAX n 2048 <= LENGTH rest ⇒ app (p:'ffi ffi_proj) TextIO_read_v [fdv;nv] (W8ARRAY iobuff_loc (h1::h2::h3::h4::rest) * IOx fs_ffi_part fs) @@ -1301,8 +1490,9 @@ Theorem read_spec IOx fs_ffi_part (bumpFD fd fs nr) * W8ARRAY iobuff_loc (0w :: n2w (nr DIV 256) :: n2w nr :: h4:: MAP (n2w o ORD) (TAKE nr (DROP pos content))++DROP nr rest)) - (\e. &InvalidFD_exn e * &(get_file_content fs fd = NONE ∨ get_mode fs fd ≠ SOME ReadMode) * IOFS fs))` - (xcf_with_def "TextIO.read" TextIO_read_v_def >> + (\e. &InvalidFD_exn e * &(get_file_content fs fd = NONE ∨ get_mode fs fd ≠ SOME ReadMode) * IOFS fs)) +Proof + xcf_with_def "TextIO.read" TextIO_read_v_def >> fs[IOFS_def,IOFS_iobuff_def] >> xlet_auto >- xsimpl >> simp[insert_atI_def,n2w2_def] >> @@ -1392,10 +1582,11 @@ Theorem read_spec qexists_tac `new_events` >> xsimpl) >> rpt(xlet_auto >- xsimpl) >> xif >> instantiate >> xapp >> xsimpl >> rw[] >> instantiate >> - simp[GSYM n2w2_def,w22n_n2w2] >> xsimpl); + simp[GSYM n2w2_def,w22n_n2w2] >> xsimpl +QED -Theorem read_byte_spec - `!fd fdv content pos. +Theorem read_byte_spec: + !fd fdv content pos. FD fd fdv ⇒ get_file_content fs fd = SOME(content, pos) ⇒ get_mode fs fd = SOME ReadMode ⇒ @@ -1406,8 +1597,9 @@ Theorem read_byte_spec eof fd fs = SOME F) * IOFS (bumpFD fd fs 1)) (\e. &(EndOfFile_exn e /\ eof fd fs = SOME T) * - IOFS(bumpFD fd fs 0)))` - (xcf_with_def "TextIO.read_byte" TextIO_read_byte_v_def >> + IOFS(bumpFD fd fs 0))) +Proof + xcf_with_def "TextIO.read_byte" TextIO_read_byte_v_def >> fs[IOFS_def,IOFS_iobuff_def] >> xpull >> rename [`W8ARRAY _ bdef`] >> Cases_on `bdef` >> fs[] >> qmatch_goalsub_rename_tac`h1 :: t` >> @@ -1421,10 +1613,11 @@ Theorem read_byte_spec fs[EndOfFile_exn_def,eof_def,get_file_content_def,liveFS_bumpFD] >> xsimpl) >> xapp >> xsimpl >> `nr = 1` by fs[] >> fs[] >> xsimpl >> - fs[TAKE1_DROP,eof_def,get_file_content_def] >> pairarg_tac >> fs[liveFS_bumpFD]); + fs[TAKE1_DROP,eof_def,get_file_content_def] >> pairarg_tac >> fs[liveFS_bumpFD] +QED -Theorem read_byte_STDIO_spec - ` FD fd fdv ∧ fd ≠ 1 ∧ fd ≠ 2 ∧ +Theorem read_byte_STDIO_spec: + FD fd fdv ∧ fd ≠ 1 ∧ fd ≠ 2 ∧ get_file_content fs fd = SOME(content, pos) ⇒ get_mode fs fd = SOME ReadMode ⇒ app (p:'ffi ffi_proj) TextIO_read_byte_v [fdv] @@ -1434,18 +1627,20 @@ Theorem read_byte_STDIO_spec eof fd fs = SOME F) * STDIO (bumpFD fd fs 1)) (\e. &(EndOfFile_exn e /\ eof fd fs = SOME T) * - STDIO(bumpFD fd fs 0)))` - (rw[STDIO_def] >> xpull >> xapp_spec read_byte_spec >> + STDIO(bumpFD fd fs 0))) +Proof + rw[STDIO_def] >> xpull >> xapp_spec read_byte_spec >> mp_tac(GSYM(SPEC_ALL get_file_content_numchars)) >> rw[] >> mp_tac(get_mode_with_numchars) >> rw[] >> instantiate >> xsimpl >> simp[bumpFD_forwardFD,forwardFD_numchars,STD_streams_forwardFD] \\ - rw[] \\ qexists_tac`THE (LTL ll)` \\ xsimpl); + rw[] \\ qexists_tac`THE (LTL ll)` \\ xsimpl +QED (* TODO: call the low-level IOFS specs with the non-standard name, not vice versa *) -Theorem input1_spec - ` INSTREAM fd fdv ∧ fd ≠ 1 ∧ fd ≠ 2 ∧ +Theorem input1_spec: + INSTREAM fd fdv ∧ fd ≠ 1 ∧ fd ≠ 2 ∧ get_file_content fs fd = SOME(content, pos) ⇒ get_mode fs fd = SOME ReadMode ⇒ app (p:'ffi ffi_proj) TextIO_input1_v [fdv] @@ -1458,8 +1653,9 @@ Theorem input1_spec | SOME T => &OPTION_TYPE CHAR NONE v * STDIO (bumpFD fd fs 0) - | _ => &F)` - (xcf_with_def "TextIO.input1" TextIO_input1_v_def + | _ => &F) +Proof + xcf_with_def "TextIO.input1" TextIO_input1_v_def \\ xhandle`POSTve (λv. &OPTION_TYPE CHAR (SOME (EL pos content)) v * STDIO (forwardFD fs fd 1) * &(eof fd fs = SOME F)) (λe. &EndOfFile_exn e * STDIO fs * &(eof fd fs = SOME T))` @@ -1479,10 +1675,11 @@ Theorem input1_spec \\ reverse conj_tac >- (EVAL_TAC \\ fs[]) \\ xcon \\ xsimpl - \\ fs[std_preludeTheory.OPTION_TYPE_def]); + \\ fs[std_preludeTheory.OPTION_TYPE_def] +QED -Theorem input_IOFS_spec - `!fd fdv fs content pos off offv. +Theorem input_IOFS_spec: + !fd fdv fs content pos off offv. len + off <= LENGTH buf ∧ INSTREAM fd fdv ∧ NUM off offv ∧ NUM len lenv ∧ get_file_content fs fd = SOME(content, pos) ⇒ @@ -1492,8 +1689,9 @@ Theorem input_IOFS_spec (POSTv nv. &(NUM (MIN len (LENGTH content - pos)) nv) * W8ARRAY bufv (insert_atI (TAKE len (DROP pos (MAP (n2w o ORD) content))) off buf) * - SEP_EXISTS k. IOFS (fsupdate fs fd k (MIN (len + pos) (MAX pos (LENGTH content))) content))` - (xcf_with_def "TextIO.input" TextIO_input_v_def >> + SEP_EXISTS k. IOFS (fsupdate fs fd k (MIN (len + pos) (MAX pos (LENGTH content))) content)) +Proof + xcf_with_def "TextIO.input" TextIO_input_v_def >> reverse(Cases_on`pos ≤ LENGTH content`) >- ( imp_res_tac get_file_content_eof \\ rfs[] \\ reverse(Cases_on`wfFS fs`) >- (fs[IOFS_def] \\ xpull) \\ @@ -1668,10 +1866,11 @@ Theorem input_IOFS_spec fs[IO_fs_component_equality,AFUPDKEY_unchanged,fsupdate_def,LDROP_1] >> fs[AFUPDKEY_ALOOKUP,AFUPDKEY_o,AFUPDKEY_eq] >> simp[AFUPDKEY_unchanged]) - \\ xapp \\ instantiate \\ xsimpl); + \\ xapp \\ instantiate \\ xsimpl +QED -Theorem input_spec - `!fd fdv fs content pos off offv len lenv buf bufv. +Theorem input_spec: + !fd fdv fs content pos off offv len lenv buf bufv. len + off <= LENGTH buf ∧ INSTREAM fd fdv ∧ NUM off offv ∧ NUM len lenv ∧ get_file_content fs fd = SOME(content, pos) ⇒ @@ -1681,8 +1880,9 @@ Theorem input_spec (POSTv nv. &(NUM (MIN len (LENGTH content - pos)) nv) * W8ARRAY bufv (insert_atI (TAKE len (DROP pos (MAP (n2w o ORD) content))) off buf) * - STDIO (fsupdate fs fd 0 (MIN (len + pos) (MAX pos (LENGTH content))) content))` - (rw[STDIO_def] + STDIO (fsupdate fs fd 0 (MIN (len + pos) (MAX pos (LENGTH content))) content)) +Proof + rw[STDIO_def] \\ xpull \\ `fd = 1 ∨ fd = 2 ⇒ pos = LENGTH content` by ( @@ -1702,26 +1902,30 @@ Theorem input_spec \\ qexists_tac`THE (LDROP x ll)` \\ simp[fsupdate_def] \\ fs[get_file_content_def] - \\ xsimpl); + \\ xsimpl +QED -Theorem extend_array_spec - `∀arrv arr. +Theorem extend_array_spec: + ∀arrv arr. app (p:'ffi ffi_proj) TextIO_extend_array_v [arrv] (W8ARRAY arrv arr) - (POSTv v. W8ARRAY v (arr ++ (REPLICATE (LENGTH arr) 0w)))` - (xcf_with_def "TextIO.extend_array" TextIO_extend_array_v_def + (POSTv v. W8ARRAY v (arr ++ (REPLICATE (LENGTH arr) 0w))) +Proof + xcf_with_def "TextIO.extend_array" TextIO_extend_array_v_def \\ ntac 5 (xlet_auto >- xsimpl) \\ xret \\ xsimpl - \\ simp[DROP_REPLICATE] ); + \\ simp[DROP_REPLICATE] +QED -Theorem inputLine_spec - `INSTREAM fd fdv ∧ IS_SOME (get_file_content fs fd) ∧ get_mode fs fd = SOME ReadMode +Theorem inputLine_spec: + INSTREAM fd fdv ∧ IS_SOME (get_file_content fs fd) ∧ get_mode fs fd = SOME ReadMode ⇒ app (p:'ffi ffi_proj) TextIO_inputLine_v [fdv] (STDIO fs) (POSTv sov. &OPTION_TYPE STRING_TYPE (OPTION_MAP implode (lineFD fs fd)) sov * - STDIO (lineForwardFD fs fd))` - (strip_tac \\ + STDIO (lineForwardFD fs fd)) +Proof + strip_tac \\ xcf_with_def "TextIO.inputLine" TextIO_inputLine_v_def \\ xlet_auto >- xsimpl \\ xlet_auto >- xsimpl \\ @@ -1987,10 +2191,11 @@ Theorem inputLine_spec \\ qexists_tac`pos` \\ simp[] \\ instantiate \\ xsimpl - \\ EVAL_TAC); + \\ EVAL_TAC +QED -Theorem inputLines_spec - `!fd fdv fs. INSTREAM fd fdv ∧ +Theorem inputLines_spec: + !fd fdv fs. INSTREAM fd fdv ∧ get_file_content fs fd = SOME (content,pos) ∧ get_mode fs fd = SOME ReadMode ⇒ @@ -2000,8 +2205,9 @@ Theorem inputLines_spec &LIST_TYPE STRING_TYPE (MAP (\x. strcat (implode x) (implode "\n")) (splitlines (DROP pos content))) fcv * - STDIO (fastForwardFD fs fd))` - (Induct_on`splitlines (DROP pos content)` \\ rw[] + STDIO (fastForwardFD fs fd)) +Proof + Induct_on`splitlines (DROP pos content)` \\ rw[] >- ( qpat_x_assum`[] = _`(assume_tac o SYM) \\ fs[DROP_NIL] \\ `LENGTH content - pos = 0` by simp[] @@ -2057,10 +2263,11 @@ Theorem inputLines_spec \\ Cases_on`LENGTH h = LENGTH content - pos` \\ fs[] \\ imp_res_tac SPLITP_JOIN \\ pop_assum(mp_tac o Q.AP_TERM`LENGTH`) \\ simp[] - \\ Cases_on`LENGTH r = 0` \\ simp[] \\ fs[] ); + \\ Cases_on`LENGTH r = 0` \\ simp[] \\ fs[] +QED -Theorem inputLinesFrom_spec - `FILENAME f fv /\ hasFreeFD fs +Theorem inputLinesFrom_spec: + FILENAME f fv /\ hasFreeFD fs ⇒ app (p:'ffi ffi_proj) TextIO_inputLinesFrom_v [fv] @@ -2069,8 +2276,9 @@ Theorem inputLinesFrom_spec (if inFS_fname fs f then SOME(all_lines fs f) else NONE) sv - * STDIO fs)` - (xcf_with_def "TextIO.inputLinesFrom" TextIO_inputLinesFrom_v_def + * STDIO fs) +Proof + xcf_with_def "TextIO.inputLinesFrom" TextIO_inputLinesFrom_v_def \\ reverse(xhandle`POSTve (λv. &OPTION_TYPE (LIST_TYPE STRING_TYPE) (if inFS_fname fs f @@ -2146,7 +2354,8 @@ Theorem inputLinesFrom_spec \\ unabbrev_all_tac \\ simp[fastForwardFD_def,ADELKEY_AFUPDKEY,o_DEF, libTheory.the_def, openFileFS_numchars,openFileFS_files, - IO_fs_component_equality,openFileFS_inode_tbl]); + IO_fs_component_equality,openFileFS_inode_tbl] +QED val inputLinesFrom_def = Define ` inputLinesFrom f = @@ -2154,14 +2363,15 @@ val inputLinesFrom_def = Define ` SOME(all_lines fs f) else NONE), fs))`; -Theorem EvalM_inputLinesFrom - `Eval env exp (FILENAME f) /\ +Theorem EvalM_inputLinesFrom: + Eval env exp (FILENAME f) /\ (nsLookup env.v (Long "TextIO" (Short "inputLinesFrom")) = SOME TextIO_inputLinesFrom_v) ==> EvalM F env st (App Opapp [Var (Long "TextIO" (Short "inputLinesFrom")); exp]) (MONAD (OPTION_TYPE (LIST_TYPE STRING_TYPE)) exc_ty (inputLinesFrom f)) - (MONAD_IO,p:'ffi ffi_proj)` - (ho_match_mp_tac EvalM_from_app + (MONAD_IO,p:'ffi ffi_proj) +Proof + ho_match_mp_tac EvalM_from_app \\ rw[inputLinesFrom_def] \\ rw[MONAD_IO_def] \\ xpull @@ -2169,18 +2379,19 @@ Theorem EvalM_inputLinesFrom \\ xapp_spec inputLinesFrom_spec \\ fs[] \\ rpt (xsimpl \\ asm_exists_tac) - ); +QED -Theorem inputAll_spec - `INSTREAM fd fdv ∧ +Theorem inputAll_spec: + INSTREAM fd fdv ∧ get_file_content fs fd = SOME (content,pos) ⇒ get_mode fs fd = SOME ReadMode ⇒ app (p:'ffi ffi_proj) TextIO_inputAll_v [fdv] (STDIO fs) (POSTv v. &STRING_TYPE (implode (DROP pos content)) v * - STDIO (fastForwardFD fs fd))` - (xcf_with_def "TextIO.inputAll" TextIO_inputAll_v_def \\ + STDIO (fastForwardFD fs fd)) +Proof + xcf_with_def "TextIO.inputAll" TextIO_inputAll_v_def \\ reverse(Cases_on`pos ≤ LENGTH content`) >- ( xfun_spec `inputAll_aux` @@ -2316,14 +2527,16 @@ Theorem inputAll_spec \\ disch_then(first_assum o mp_then Any mp_tac) \\ simp[Abbr`arrmax`,MAX_DEF,Once REPLICATE_compute] \\ strip_tac - \\ xapp \\ xsimpl ); + \\ xapp \\ xsimpl +QED -Theorem print_list_spec - `∀ls lv fs out. LIST_TYPE STRING_TYPE ls lv ⇒ +Theorem print_list_spec: + ∀ls lv fs out. LIST_TYPE STRING_TYPE ls lv ⇒ app (p:'ffi ffi_proj) TextIO_print_list_v [lv] (STDIO fs) - (POSTv v. &UNIT_TYPE () v * STDIO (add_stdout fs (concat ls)))` - (Induct \\ rw[LIST_TYPE_def] + (POSTv v. &UNIT_TYPE () v * STDIO (add_stdout fs (concat ls))) +Proof + Induct \\ rw[LIST_TYPE_def] \\ xcf_with_def "TextIO.print_list" TextIO_print_list_v_def \\ (reverse(Cases_on`STD_streams fs`) >- (fs[STDIO_def] \\ xpull)) \\ xmatch @@ -2335,11 +2548,12 @@ Theorem print_list_spec \\ imp_res_tac add_stdo_o \\ simp[concat_cons] \\ map_every qexists_tac [`emp`,`add_stdout fs s`] - \\ xsimpl); + \\ xsimpl +QED (* input and output file descriptors need to bind to different inodes to ensure termination *) -Theorem copy_spec - `∀ ino1 ino2 content1 inp out pos content2 fs inpv outv. +Theorem copy_spec: + ∀ ino1 ino2 content1 inp out pos content2 fs inpv outv. INSTREAM inp inpv /\ OUTSTREAM out outv /\ ino1 <> ino2 /\ ALOOKUP fs.infds inp = SOME (ino1,ReadMode,pos) /\ ALOOKUP fs.infds out = SOME (ino2,WriteMode,LENGTH content2) /\ @@ -2352,8 +2566,8 @@ Theorem copy_spec STDIO (fsupdate (fastForwardFD fs inp) out 0 (LENGTH content2 + (LENGTH content1) - pos) - (content2 ++ (DROP pos content1))))` - ( + (content2 ++ (DROP pos content1)))) +Proof NTAC 6 strip_tac >> `?N. STRLEN content1 - pos <= N` by (qexists_tac`STRLEN content1 - pos` >> fs[]) >> @@ -2448,6 +2662,7 @@ Theorem copy_spec xsimpl >> fs[] >> first_x_assum (fn z => PURE_REWRITE_TAC [Once (Q.SPECL [`fs`,`x`] STD_streams_numchars),GSYM z]) >> - fs[GSYM STD_streams_numchars])); + fs[GSYM STD_streams_numchars]) +QED val _ = export_theory(); diff --git a/basis/Word64ProgScript.sml b/basis/Word64ProgScript.sml index 6ca3a2b76d..c450198d9a 100644 --- a/basis/Word64ProgScript.sml +++ b/basis/Word64ProgScript.sml @@ -50,12 +50,14 @@ val var_word_lsl_def = Define ` else if n < 7 then w << 6 else w << 7 else var_word_lsl (w << 8) (n − 8)` -Theorem var_word_lsl_thm[simp] - `var_word_lsl w n = word_lsl w n` - (ntac 32 ( +Theorem var_word_lsl_thm[simp]: + var_word_lsl w n = word_lsl w n +Proof + ntac 32 ( Cases_on `n` \\ fs [ADD1] THEN1 (EVAL_TAC \\ fs [LSL_ADD]) \\ Cases_on `n'` \\ fs [ADD1] THEN1 (EVAL_TAC \\ fs [LSL_ADD])) - \\ ntac 9 (once_rewrite_tac [var_word_lsl_def] \\ fs [])); + \\ ntac 9 (once_rewrite_tac [var_word_lsl_def] \\ fs []) +QED val var_word_lsr_def = Define ` var_word_lsr (w:word64) (n:num) = if 64 < n then 0w @@ -68,12 +70,14 @@ val var_word_lsr_def = Define ` else if n < 7 then w >>> 6 else w >>> 7 else var_word_lsr (w >>> 8) (n − 8)` -Theorem var_word_lsr_thm[simp] - `var_word_lsr w n = word_lsr w n` - (ntac 32 ( +Theorem var_word_lsr_thm[simp]: + var_word_lsr w n = word_lsr w n +Proof + ntac 32 ( Cases_on `n` \\ fs [ADD1] THEN1 (EVAL_TAC \\ fs [LSR_ADD]) \\ Cases_on `n'` \\ fs [ADD1] THEN1 (EVAL_TAC \\ fs [LSR_ADD])) - \\ ntac 9 (once_rewrite_tac [var_word_lsr_def] \\ fs [])); + \\ ntac 9 (once_rewrite_tac [var_word_lsr_def] \\ fs []) +QED val var_word_asr_def = Define ` var_word_asr (w:word64) (n:num) = if 64 < n then w >> 64 @@ -86,12 +90,14 @@ val var_word_asr_def = Define ` else if n < 7 then w >> 6 else w >> 7 else var_word_asr (w >> 8) (n − 8)` -Theorem var_word_asr_thm[simp] - `var_word_asr w n = word_asr w n` - (ntac 32 ( +Theorem var_word_asr_thm[simp]: + var_word_asr w n = word_asr w n +Proof + ntac 32 ( Cases_on `n` \\ fs [ADD1] THEN1 (EVAL_TAC \\ fs [ASR_ADD]) \\ Cases_on `n'` \\ fs [ADD1] THEN1 (EVAL_TAC \\ fs [ASR_ADD])) - \\ ntac 9 (once_rewrite_tac [var_word_asr_def] \\ fs [])); + \\ ntac 9 (once_rewrite_tac [var_word_asr_def] \\ fs []) +QED val _ = (next_ml_names := ["<<"]); val _ = translate var_word_lsl_def; diff --git a/basis/Word8ArrayProofScript.sml b/basis/Word8ArrayProofScript.sml index 255de42509..d5db979730 100644 --- a/basis/Word8ArrayProofScript.sml +++ b/basis/Word8ArrayProofScript.sml @@ -27,37 +27,45 @@ fun prove_array_spec op_name = \\ Cases_on`s` \\ fs[STRING_TYPE_def] \\ fs[mlstringTheory.substring_def, SEG_TAKE_DROP] ) -Theorem w8array_alloc_spec - `!n nv w wv. +Theorem w8array_alloc_spec: + !n nv w wv. NUM n nv /\ WORD w wv ==> app (p:'ffi ffi_proj) ^(fetch_v "Word8Array.array" (basis_st())) [nv; wv] - emp (POSTv v. W8ARRAY v (REPLICATE n w))` - (prove_array_spec "Word8Array.array"); + emp (POSTv v. W8ARRAY v (REPLICATE n w)) +Proof + prove_array_spec "Word8Array.array" +QED -Theorem w8array_sub_spec - `!a av n nv. +Theorem w8array_sub_spec: + !a av n nv. NUM n nv /\ n < LENGTH a ==> app (p:'ffi ffi_proj) ^(fetch_v "Word8Array.sub" (basis_st())) [av; nv] - (W8ARRAY av a) (POSTv v. cond (WORD (EL n a) v) * W8ARRAY av a)` - (prove_array_spec "Word8Array.sub"); + (W8ARRAY av a) (POSTv v. cond (WORD (EL n a) v) * W8ARRAY av a) +Proof + prove_array_spec "Word8Array.sub" +QED -Theorem w8array_length_spec - `!a av. +Theorem w8array_length_spec: + !a av. app (p:'ffi ffi_proj) ^(fetch_v "Word8Array.length" (basis_st())) [av] - (W8ARRAY av a) (POSTv v. cond (NUM (LENGTH a) v) * W8ARRAY av a)` - (prove_array_spec "Word8Array.length"); + (W8ARRAY av a) (POSTv v. cond (NUM (LENGTH a) v) * W8ARRAY av a) +Proof + prove_array_spec "Word8Array.length" +QED -Theorem w8array_update_spec - `!a av n nv w wv. +Theorem w8array_update_spec: + !a av n nv w wv. NUM n nv /\ n < LENGTH a /\ WORD w wv ==> app (p:'ffi ffi_proj) ^(fetch_v "Word8Array.update" (basis_st())) [av; nv; wv] (W8ARRAY av a) - (POSTv v. cond (UNIT_TYPE () v) * W8ARRAY av (LUPDATE w n a))` - (prove_array_spec "Word8Array.update"); + (POSTv v. cond (UNIT_TYPE () v) * W8ARRAY av (LUPDATE w n a)) +Proof + prove_array_spec "Word8Array.update" +QED -Theorem w8array_copy_spec - `!src srcv srcoff srcoffv len lenv dst dstv dstoff dstoffv. +Theorem w8array_copy_spec: + !src srcv srcoff srcoffv len lenv dst dstv dstoff dstoffv. NUM srcoff srcoffv /\ NUM dstoff dstoffv /\ NUM len lenv /\ srcoff + len <= LENGTH src /\ dstoff + len <= LENGTH dst ==> @@ -67,11 +75,13 @@ Theorem w8array_copy_spec (POSTv v. &(UNIT_TYPE () v) * W8ARRAY srcv src * W8ARRAY dstv (TAKE dstoff dst ⧺ TAKE len (DROP srcoff src) ⧺ - DROP (dstoff + len) dst) )` - (prove_array_spec "Word8Array.copy"); + DROP (dstoff + len) dst) ) +Proof + prove_array_spec "Word8Array.copy" +QED -Theorem w8array_copyVec_spec - `!src srcv srcoff srcoffv len lenv dst dstv dstoff dstoffv. +Theorem w8array_copyVec_spec: + !src srcv srcoff srcoffv len lenv dst dstv dstoff dstoffv. NUM srcoff srcoffv /\ NUM dstoff dstoffv /\ NUM len lenv /\ STRING_TYPE src srcv /\ srcoff + len <= strlen src /\ dstoff + len <= LENGTH dst ==> @@ -81,18 +91,22 @@ Theorem w8array_copyVec_spec (POSTv v. &(UNIT_TYPE () v) * W8ARRAY dstv (TAKE dstoff dst ⧺ MAP (n2w o ORD) (explode (mlstring$substring src srcoff len)) ⧺ - DROP (dstoff + len) dst) )` - (prove_array_spec "Word8Array.copyVec"); + DROP (dstoff + len) dst) ) +Proof + prove_array_spec "Word8Array.copyVec" +QED -Theorem w8array_substring_spec - `!src srcv srcoff srcoffv len lenv. +Theorem w8array_substring_spec: + !src srcv srcoff srcoffv len lenv. NUM srcoff srcoffv /\ NUM len lenv /\ srcoff + len <= LENGTH src ==> app (p:'ffi ffi_proj) ^(fetch_v "Word8Array.substring" (basis_st())) [srcv; srcoffv; lenv] (W8ARRAY srcv src) (POSTv v. &(STRING_TYPE (strlit (MAP (CHR o w2n) (TAKE len (DROP srcoff src)))) v) * - W8ARRAY srcv src)` - (prove_array_spec "Word8Array.substring"); + W8ARRAY srcv src) +Proof + prove_array_spec "Word8Array.substring" +QED val _ = export_theory() diff --git a/basis/Word8ProgScript.sml b/basis/Word8ProgScript.sml index 4b671ebc2e..c411bd64ec 100644 --- a/basis/Word8ProgScript.sml +++ b/basis/Word8ProgScript.sml @@ -53,12 +53,14 @@ val var_word_lsl_def = Define ` else if n < 7 then w << 6 else w << 7 else 0w` -Theorem var_word_lsl_thm[simp] - `var_word_lsl w n = word_lsl w n` - (ntac 32 ( +Theorem var_word_lsl_thm[simp]: + var_word_lsl w n = word_lsl w n +Proof + ntac 32 ( Cases_on `n` \\ fs [ADD1] THEN1 (EVAL_TAC \\ fs [LSL_ADD]) \\ Cases_on `n'` \\ fs [ADD1] THEN1 (EVAL_TAC \\ fs [LSL_ADD])) - \\ ntac 9 (once_rewrite_tac [var_word_lsl_def] \\ fs [])); + \\ ntac 9 (once_rewrite_tac [var_word_lsl_def] \\ fs []) +QED val var_word_lsr_def = Define ` var_word_lsr (w:word8) (n:num) = @@ -71,12 +73,14 @@ val var_word_lsr_def = Define ` else if n < 7 then w >>> 6 else w >>> 7 else 0w` -Theorem var_word_lsr_thm[simp] - `var_word_lsr w n = word_lsr w n` - (ntac 32 ( +Theorem var_word_lsr_thm[simp]: + var_word_lsr w n = word_lsr w n +Proof + ntac 32 ( Cases_on `n` \\ fs [ADD1] THEN1 (EVAL_TAC \\ fs [LSR_ADD]) \\ Cases_on `n'` \\ fs [ADD1] THEN1 (EVAL_TAC \\ fs [LSR_ADD])) - \\ ntac 9 (once_rewrite_tac [var_word_lsr_def] \\ fs [])); + \\ ntac 9 (once_rewrite_tac [var_word_lsr_def] \\ fs []) +QED val var_word_asr_def = Define ` var_word_asr (w:word8) (n:num) = @@ -89,12 +93,14 @@ val var_word_asr_def = Define ` else if n < 7 then w >> 6 else w >> 7 else w >> 8` -Theorem var_word_asr_thm[simp] - `var_word_asr w n = word_asr w n` - (ntac 32 ( +Theorem var_word_asr_thm[simp]: + var_word_asr w n = word_asr w n +Proof + ntac 32 ( Cases_on `n` \\ fs [ADD1] THEN1 (EVAL_TAC \\ fs [ASR_ADD]) \\ Cases_on `n'` \\ fs [ADD1] THEN1 (EVAL_TAC \\ fs [ASR_ADD])) - \\ ntac 9 (once_rewrite_tac [var_word_asr_def] \\ fs [])); + \\ ntac 9 (once_rewrite_tac [var_word_asr_def] \\ fs []) +QED val _ = (next_ml_names := ["<<"]); val _ = translate var_word_lsl_def; @@ -114,21 +120,31 @@ val _ = ml_prog_update (close_module (SOME sigs)); open ml_translatorTheory -Theorem WORD_UNICITY_R[xlet_auto_match] -`!f fv fv'. WORD (f :word8) fv ==> (WORD f fv' <=> fv' = fv)` (fs[WORD_def]); - -Theorem WORD_UNICITY_L[xlet_auto_match] -`!f f' fv. WORD (f :word8) fv ==> (WORD f' fv <=> f = f')` (fs[WORD_def]); - -Theorem n2w_UNICITY[xlet_auto_match] - `!n1 n2.n1 <= 255 ==> ((n2w n1 :word8 = n2w n2 /\ n2 <= 255) <=> n1 = n2)` - (rw[] >> eq_tac >> fs[]) - -Theorem WORD_n2w_UNICITY_L[xlet_auto_match] - `!n1 n2 f. n1 <= 255 /\ WORD (n2w n1 :word8) f ==> - (WORD (n2w n2 :word8) f /\ n2 <= 255 <=> n1 = n2)` - (rw[] >> eq_tac >> rw[] >> imp_res_tac WORD_UNICITY_L >> -`n1 MOD 256 = n1` by fs[] >> `n2 MOD 256 = n2` by fs[] >> fs[]) +Theorem WORD_UNICITY_R[xlet_auto_match]: + !f fv fv'. WORD (f :word8) fv ==> (WORD f fv' <=> fv' = fv) +Proof +fs[WORD_def] +QED + +Theorem WORD_UNICITY_L[xlet_auto_match]: + !f f' fv. WORD (f :word8) fv ==> (WORD f' fv <=> f = f') +Proof +fs[WORD_def] +QED + +Theorem n2w_UNICITY[xlet_auto_match]: + !n1 n2.n1 <= 255 ==> ((n2w n1 :word8 = n2w n2 /\ n2 <= 255) <=> n1 = n2) +Proof + rw[] >> eq_tac >> fs[] +QED + +Theorem WORD_n2w_UNICITY_L[xlet_auto_match]: + !n1 n2 f. n1 <= 255 /\ WORD (n2w n1 :word8) f ==> + (WORD (n2w n2 :word8) f /\ n2 <= 255 <=> n1 = n2) +Proof + rw[] >> eq_tac >> rw[] >> imp_res_tac WORD_UNICITY_L >> +`n1 MOD 256 = n1` by fs[] >> `n2 MOD 256 = n2` by fs[] >> fs[] +QED val _ = overload_on("WORD8",``WORD:word8 -> v -> bool``); diff --git a/basis/basisProgScript.sml b/basis/basisProgScript.sml index 06f8d781b5..8cc4c3faeb 100644 --- a/basis/basisProgScript.sml +++ b/basis/basisProgScript.sml @@ -30,11 +30,12 @@ val print_app_list = process_topdecs | Append l1 l2 => (print_app_list l1; print_app_list l2))`; val () = append_prog print_app_list; -Theorem print_app_list_spec - `∀ls lv out. APP_LIST_TYPE STRING_TYPE ls lv ⇒ +Theorem print_app_list_spec: + ∀ls lv out. APP_LIST_TYPE STRING_TYPE ls lv ⇒ app (p:'ffi ffi_proj) ^(fetch_v "print_app_list" (get_ml_prog_state())) [lv] - (STDIO fs) (POSTv v. &UNIT_TYPE () v * STDIO (add_stdout fs (concat (append ls))))` - (reverse(Cases_on`STD_streams fs`) >- (rw[STDIO_def] \\ xpull) \\ + (STDIO fs) (POSTv v. &UNIT_TYPE () v * STDIO (add_stdout fs (concat (append ls)))) +Proof + reverse(Cases_on`STD_streams fs`) >- (rw[STDIO_def] \\ xpull) \\ pop_assum mp_tac \\ simp[PULL_FORALL] \\ qid_spec_tac`fs` \\ reverse (Induct_on`ls`) \\ rw[APP_LIST_TYPE_def] >- ( @@ -57,18 +58,21 @@ Theorem print_app_list_spec \\ xcf "print_app_list" (get_ml_prog_state()) \\ xmatch \\ xapp - \\ simp[]); + \\ simp[] +QED val _ = (append_prog o process_topdecs) `fun print_int i = TextIO.print (Int.toString i)`; -Theorem print_int_spec - `INT i iv ⇒ +Theorem print_int_spec: + INT i iv ⇒ app (p:'ffi ffi_proj) ^(fetch_v "print_int" (get_ml_prog_state())) [iv] - (STDIO fs) (POSTv v. &UNIT_TYPE () v * STDIO (add_stdout fs (toString i)))` - (xcf"print_int"(get_ml_prog_state()) + (STDIO fs) (POSTv v. &UNIT_TYPE () v * STDIO (add_stdout fs (toString i))) +Proof + xcf"print_int"(get_ml_prog_state()) \\ xlet_auto >- xsimpl - \\ xapp \\ xsimpl); + \\ xapp \\ xsimpl +QED val basis_st = get_ml_prog_state (); diff --git a/basis/basis_ffiScript.sml b/basis/basis_ffiScript.sml index 6fea259a71..b3339b3110 100644 --- a/basis/basis_ffiScript.sml +++ b/basis/basis_ffiScript.sml @@ -74,9 +74,11 @@ val basis_proj2_def = Define ` mk_proj2 fs_ffi_part; mk_proj2 runtime_ffi_part]`; -Theorem basis_proj1_write - `basis_proj1 ffi ' "write" = encode(SND ffi)` - (PairCases_on`ffi` \\ EVAL_TAC); +Theorem basis_proj1_write: + basis_proj1 ffi ' "write" = encode(SND ffi) +Proof + PairCases_on`ffi` \\ EVAL_TAC +QED (* builds the file system from a list of events *) @@ -92,24 +94,26 @@ val extract_fs_with_numchars_def = Define ` | _ => NONE) | NONE => extract_fs_with_numchars init_fs xs)` -Theorem extract_fs_with_numchars_APPEND - `!xs ys init_fs. extract_fs_with_numchars init_fs (xs ++ ys) = +Theorem extract_fs_with_numchars_APPEND: + !xs ys init_fs. extract_fs_with_numchars init_fs (xs ++ ys) = case extract_fs_with_numchars init_fs xs of | NONE => NONE - | SOME fs => extract_fs_with_numchars fs ys` - (Induct_on`xs` \\ simp[extract_fs_with_numchars_def] + | SOME fs => extract_fs_with_numchars fs ys +Proof + Induct_on`xs` \\ simp[extract_fs_with_numchars_def] \\ Cases \\ simp[extract_fs_with_numchars_def] \\ CASE_TAC \\ rpt gen_tac - \\ rpt CASE_TAC); + \\ rpt CASE_TAC +QED val extract_fs_def = Define` extract_fs init_fs events = OPTION_MAP (numchars_fupd (K init_fs.numchars)) (extract_fs_with_numchars init_fs events)`; -Theorem extract_fs_with_numchars_keeps_iostreams - `∀ls fs fs' off. +Theorem extract_fs_with_numchars_keeps_iostreams: + ∀ls fs fs' off. (extract_fs_with_numchars fs ls = SOME fs') ∧ (ALOOKUP fs'.infds fd = SOME(UStream nm, md, off)) ⇒ ∃off'. @@ -120,8 +124,9 @@ Theorem extract_fs_with_numchars_keeps_iostreams ⇒ ∃written. (ALOOKUP fs'.inode_tbl (UStream nm) = SOME (content ++ written)) ∧ - (off = off' + LENGTH written))` - (Induct + (off = off' + LENGTH written)) +Proof + Induct >- ( rw[extract_fs_with_numchars_def]) \\ Cases \\ rw[extract_fs_with_numchars_def] @@ -159,15 +164,17 @@ Theorem extract_fs_with_numchars_keeps_iostreams Cases_on`fnm = UStream nm` \\ fsrw_tac[DNF_ss][] \\ fs[FORALL_PROD] \\ rveq \\ fs[] \\ rfs[] \\ metis_tac[] ) - \\ fsrw_tac[DNF_ss][FORALL_PROD]); + \\ fsrw_tac[DNF_ss][FORALL_PROD] +QED -Theorem extract_fs_with_numchars_closes_iostreams - `∀ls fs fs' fd nm off. +Theorem extract_fs_with_numchars_closes_iostreams: + ∀ls fs fs' fd nm off. (extract_fs_with_numchars fs ls = SOME fs') ∧ (∀fd off. ALOOKUP fs.infds fd ≠ SOME(UStream nm, md, off)) ⇒ - (ALOOKUP fs'.infds fd ≠ SOME(UStream nm, md, off))` - (Induct + (ALOOKUP fs'.infds fd ≠ SOME(UStream nm, md, off)) +Proof + Induct >- ( rw[extract_fs_with_numchars_def] \\ metis_tac[] ) @@ -195,7 +202,8 @@ Theorem extract_fs_with_numchars_closes_iostreams \\ rveq \\ fs[ALOOKUP_ADELKEY, fsFFITheory.bumpFD_def, AFUPDKEY_ALOOKUP] \\ rw[fsFFITheory.fsupdate_def, AFUPDKEY_ALOOKUP] \\ PURE_CASE_TAC \\ fs[CaseEq"option"] - \\ CCONTR_TAC \\ fs[]); + \\ CCONTR_TAC \\ fs[] +QED (* val extract_stdo_def = Define` @@ -328,25 +336,28 @@ Theorem extract_stdout_intro (* TODO: remove? *) (* the failure of an fs ffi call doesn't depend on the filesystem -Theorem fs_ffi_NONE_irrel - `!f. f ∈ {ffi_read; ffi_write; ffi_open_in; ffi_open_out; ffi_close} ∧ - f bytes fs = NONE ⇒ f bytes fs' = NONE` - (rw[] >> +Theorem fs_ffi_NONE_irrel: + !f. f ∈ {ffi_read; ffi_write; ffi_open_in; ffi_open_out; ffi_close} ∧ + f bytes fs = NONE ⇒ f bytes fs' = NONE +Proof + rw[] >> fs[ffi_read_def,ffi_write_def,ffi_open_in_def,ffi_open_out_def,ffi_close_def] >> - every_case_tac >> fs[OPTION_CHOICE_EQ_NONE]); *) + every_case_tac >> fs[OPTION_CHOICE_EQ_NONE] +QED *) (*RTC_call_FFI_rel_IMP_basis_events show that extracting output from two ffi_states will use the same function if the two states are related by a series of FFI_calls. If this is the case for your oracle (and projs), then this proof should be relatively similar. Note that to make the subsequent proofs similar one should show an equivalence between extract_output and proj1 *) -Theorem RTC_call_FFI_rel_IMP_basis_events - `!fs st st'. call_FFI_rel^* st st' ==> st.oracle = basis_ffi_oracle ==> +Theorem RTC_call_FFI_rel_IMP_basis_events: + !fs st st'. call_FFI_rel^* st st' ==> st.oracle = basis_ffi_oracle ==> (extract_fs_with_numchars fs st.io_events = fsFFI$decode (basis_proj1 st.ffi_state ' "write") ==> extract_fs_with_numchars fs st'.io_events - = fsFFI$decode (basis_proj1 st'.ffi_state ' "write"))` - (strip_tac + = fsFFI$decode (basis_proj1 st'.ffi_state ' "write")) +Proof + strip_tac \\ HO_MATCH_MP_TAC RTC_INDUCT \\ rw [] \\ fs [] \\ fs [evaluatePropsTheory.call_FFI_rel_def] \\ fs [ffiTheory.call_FFI_def] @@ -361,57 +372,61 @@ Theorem RTC_call_FFI_rel_IMP_basis_events \\ simp[basis_ffi_oracle_def,fs_ffi_part_def] \\ rpt(pairarg_tac \\ fs[]) \\ rw[] \\ rpt(full_case_tac \\ fs[option_eq_some,MAP_ZIP] \\ rw[]) >> - rfs[MAP_ZIP]); + rfs[MAP_ZIP] +QED (* the first condition for the previous theorem holds for the init_state ffi *) -Theorem extract_fs_basis_ffi - `!ll. extract_fs fs (basis_ffi cls fs).io_events = - decode (basis_proj1 (basis_ffi cls fs).ffi_state ' "write")` - (rw[ml_progTheory.init_state_def,extract_fs_def,extract_fs_with_numchars_def, - basis_ffi_def,basis_proj1_write,IO_fs_component_equality]); - -Theorem append_hprop - `A s1 /\ B s2 ==> DISJOINT s1 s2 ==> (A * B) (s1 ∪ s2)` - (rw[set_sepTheory.STAR_def] \\ SPLIT_TAC -); +Theorem extract_fs_basis_ffi: + !ll. extract_fs fs (basis_ffi cls fs).io_events = + decode (basis_proj1 (basis_ffi cls fs).ffi_state ' "write") +Proof + rw[ml_progTheory.init_state_def,extract_fs_def,extract_fs_with_numchars_def, + basis_ffi_def,basis_proj1_write,IO_fs_component_equality] +QED + +Theorem append_hprop: + A s1 /\ B s2 ==> DISJOINT s1 s2 ==> (A * B) (s1 ∪ s2) +Proof + rw[set_sepTheory.STAR_def] \\ SPLIT_TAC +QED val iobuff_loc_num = TextIOProgTheory.iobuff_loc_def |> concl |> rhs |> rand; -Theorem IOFS_precond - `wfFS fs ⇒ LENGTH v >= 2052 ⇒ +Theorem IOFS_precond = Q.prove(` + wfFS fs ⇒ LENGTH v >= 2052 ⇒ IOFS fs ({FFI_part (encode fs) (mk_ffi_next fs_ffi_part) (MAP FST (SND(SND fs_ffi_part))) events} - ∪ {Mem ^iobuff_loc_num (W8array v)})` - (rw[IOFS_def,cfHeapsBaseTheory.IOx_def,fs_ffi_part_def,cfHeapsBaseTheory.IO_def,one_def, + ∪ {Mem ^iobuff_loc_num (W8array v)})`, + rw[IOFS_def,cfHeapsBaseTheory.IOx_def,fs_ffi_part_def,cfHeapsBaseTheory.IO_def,one_def, IOFS_iobuff_def,W8ARRAY_def,cell_def] \\ rw[set_sepTheory.SEP_EXISTS_THM,set_sepTheory.cond_STAR,set_sepTheory.SEP_CLAUSES, TextIOProgTheory.iobuff_loc_def] \\ qexists_tac`events` \\ qexists_tac`v` \\ exists_tac iobuff_loc_num - \\ fs[SEP_CLAUSES,one_STAR,one_def,append_hprop] - )|> UNDISCH_ALL; + \\ fs[SEP_CLAUSES,one_STAR,one_def,append_hprop])|> UNDISCH_ALL; -Theorem STDIO_precond -` wfFS fs ==> +Theorem STDIO_precond = Q.prove(` + wfFS fs ==> STD_streams fs ==> LENGTH v >= 2052 ==> STDIO fs ({FFI_part (encode fs) (mk_ffi_next fs_ffi_part) (MAP FST (SND(SND fs_ffi_part))) events} - ∪ {Mem ^iobuff_loc_num (W8array v)})` - (rw[STDIO_def,IOFS_precond,SEP_EXISTS_THM,SEP_CLAUSES] >> + ∪ {Mem ^iobuff_loc_num (W8array v)})`, + rw[STDIO_def,IOFS_precond,SEP_EXISTS_THM,SEP_CLAUSES] >> qexists_tac`fs.numchars` >> mp_tac (IOFS_precond |> DISCH_ALL |> GEN ``fs : IO_fs``)>> - cases_on`fs` >> fs[IO_fs_numchars_fupd] - ) |> UNDISCH_ALL |> curry save_thm "STDIO_precond"; + cases_on`fs` >> fs[IO_fs_numchars_fupd]) |> UNDISCH_ALL |> curry save_thm "STDIO_precond"; -Theorem RUNTIME_precond - `RUNTIME {FFI_part (encode ()) (mk_ffi_next runtime_ffi_part) - (MAP FST (SND(SND runtime_ffi_part))) events}` - (rw[RUNTIME_def,runtimeFFITheory.runtime_ffi_part_def, - IOx_def,SEP_EXISTS_THM,SEP_CLAUSES,IO_def,one_def]); +Theorem RUNTIME_precond: + RUNTIME {FFI_part (encode ()) (mk_ffi_next runtime_ffi_part) + (MAP FST (SND(SND runtime_ffi_part))) events} +Proof + rw[RUNTIME_def,runtimeFFITheory.runtime_ffi_part_def, + IOx_def,SEP_EXISTS_THM,SEP_CLAUSES,IO_def,one_def] +QED (*call_main_thm_basis uses call_main_thm2 to get Semantics_prog, and then uses the previous two theorems to prove the outcome of extract_output. If RTC_call_FFI_rel_IMP* uses proj1, after @@ -441,8 +456,8 @@ val whole_prog_ffidiv_spec_def = Define` (POSTf n. λc b. STDIO fs' * RUNTIME * &(n = n' /\ c = c' /\ b = b')) ∧ post n' c' b' (fs' with numchars := fs.numchars)`; -Theorem whole_prog_spec_semantics_prog - `∀fname fv. +Theorem whole_prog_spec_semantics_prog: + ∀fname fv. Decls env1 (init_state (basis_ffi cl fs)) prog env2 st2 ==> lookup_var fname env2 = SOME fv ==> whole_prog_spec fv cl fs sprop Q ==> @@ -452,8 +467,9 @@ Theorem whole_prog_spec_semantics_prog ∃io_events fs'. semantics_prog (init_state (basis_ffi cl fs)) env1 (SNOC ^main_call prog) (Terminate Success io_events) /\ - extract_fs fs io_events = SOME fs' ∧ Q fs'` - (rw[whole_prog_spec_def] + extract_fs fs io_events = SOME fs' ∧ Q fs' +Proof + rw[whole_prog_spec_def] \\ drule (GEN_ALL call_main_thm2) \\ rpt(disch_then drule) \\ disch_then (qspecl_then [`h2`, `h1`] mp_tac) @@ -488,10 +504,11 @@ Theorem whole_prog_spec_semantics_prog \\ fs[FLOOKUP_DEF, MAP_MAP_o, n2w_ORD_CHR_w2n, basis_proj1_write] \\ FIRST_X_ASSUM(ASSUME_TAC o Q.SPEC`"write"`) \\ fs[basis_proj1_write,STAR_def,cond_def] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem whole_prog_spec_semantics_prog_ffidiv - `∀fname fv. +Theorem whole_prog_spec_semantics_prog_ffidiv: + ∀fname fv. Decls env1 (init_state (basis_ffi cl fs)) prog env2 st2 ==> lookup_var fname env2 = SOME fv ==> whole_prog_ffidiv_spec fv cl fs Q ==> @@ -502,8 +519,9 @@ Theorem whole_prog_spec_semantics_prog_ffidiv semantics_prog (init_state (basis_ffi cl fs)) env1 (SNOC ^main_call prog) (Terminate (FFI_outcome(Final_event n c b FFI_diverged)) io_events) /\ - extract_fs fs io_events = SOME fs' ∧ Q n c b fs'` - (rw[whole_prog_ffidiv_spec_def] + extract_fs fs io_events = SOME fs' ∧ Q n c b fs' +Proof + rw[whole_prog_ffidiv_spec_def] \\ drule (GEN_ALL call_main_thm2_ffidiv) \\ rpt(disch_then drule) \\ disch_then (qspecl_then [`basis_proj2`,`basis_proj1`] mp_tac) @@ -537,7 +555,8 @@ Theorem whole_prog_spec_semantics_prog_ffidiv \\ fs[FLOOKUP_DEF, MAP_MAP_o, n2w_ORD_CHR_w2n, basis_proj1_write] \\ FIRST_X_ASSUM(ASSUME_TAC o Q.SPEC`"write"`) \\ fs[basis_proj1_write,STAR_def,cond_def] - \\ metis_tac[]); + \\ metis_tac[] +QED val basis_ffi_length_thms = save_thm("basis_ffi_length_thms", LIST_CONJ @@ -551,16 +570,17 @@ val basis_ffi_part_defs = save_thm("basis_ffi_part_defs", [fs_ffi_part_def,clFFITheory.cl_ffi_part_def,runtime_ffi_part_def]); (* This is used to show to show one of the parts of parts_ok for the state after a spec *) -Theorem oracle_parts - `!st. +Theorem oracle_parts: + !st. st.ffi.oracle = basis_ffi_oracle /\ MEM (ns, u) basis_proj2 /\ MEM m ns /\ u m conf bytes (basis_proj1 x ' m) = SOME (FFIreturn new_bytes w) ==> (?y. st.ffi.oracle m x conf bytes = Oracle_return y new_bytes /\ - basis_proj1 x |++ MAP (\n. (n,w)) ns = basis_proj1 y)` - (simp[basis_proj2_def,basis_proj1_def] + basis_proj1 x |++ MAP (\n. (n,w)) ns = basis_proj1 y) +Proof + simp[basis_proj2_def,basis_proj1_def] \\ pairarg_tac \\ fs[] \\ rw[cfHeapsBaseTheory.mk_proj1_def, cfHeapsBaseTheory.mk_proj2_def, @@ -573,38 +593,42 @@ Theorem oracle_parts \\ TRY ( fs[ffi_exit_def] \\ NO_TAC) \\ disj2_tac - \\ CCONTR_TAC \\ fs[] \\ rfs[]); + \\ CCONTR_TAC \\ fs[] \\ rfs[] +QED (* TODO: move to fsFFI? *) -Theorem fs_ffi_no_ffi_div ` - (ffi_open_in conf bytes fs = SOME FFIdiverge ==> F) /\ +Theorem fs_ffi_no_ffi_div: + (ffi_open_in conf bytes fs = SOME FFIdiverge ==> F) /\ (ffi_open_out conf bytes fs = SOME FFIdiverge ==> F) /\ (ffi_read conf bytes fs = SOME FFIdiverge ==> F) /\ (ffi_close conf bytes fs = SOME FFIdiverge ==> F) /\ (ffi_write conf bytes fs = SOME FFIdiverge ==> F) -` - (rw[ffi_open_in_def,ffi_open_out_def,ffi_read_def,ffi_close_def,ffi_write_def, +Proof + rw[ffi_open_in_def,ffi_open_out_def,ffi_read_def,ffi_close_def,ffi_write_def, OPTION_GUARD_COND,OPTION_CHOICE_EQUALS_OPTION,ELIM_UNCURRY] \\ rpt(PURE_TOP_CASE_TAC \\ rw[]) - \\ rw[OPTION_CHOICE_EQUALS_OPTION,ELIM_UNCURRY]); + \\ rw[OPTION_CHOICE_EQUALS_OPTION,ELIM_UNCURRY] +QED (* TODO: move to clFFI? *) -Theorem cl_ffi_no_ffi_div ` - (ffi_get_arg_count conf bytes cls = SOME FFIdiverge ==> F) /\ +Theorem cl_ffi_no_ffi_div: + (ffi_get_arg_count conf bytes cls = SOME FFIdiverge ==> F) /\ (ffi_get_arg_length conf bytes cls = SOME FFIdiverge ==> F) /\ (ffi_get_arg conf bytes cls = SOME FFIdiverge ==> F) -` - (rw[clFFITheory.ffi_get_arg_count_def,clFFITheory.ffi_get_arg_length_def, - clFFITheory.ffi_get_arg_def]); +Proof + rw[clFFITheory.ffi_get_arg_count_def,clFFITheory.ffi_get_arg_length_def, + clFFITheory.ffi_get_arg_def] +QED -Theorem oracle_parts_div - `!st. +Theorem oracle_parts_div: + !st. st.ffi.oracle = basis_ffi_oracle /\ MEM (ns, u) basis_proj2 /\ MEM m ns /\ u m conf bytes (basis_proj1 x ' m) = SOME FFIdiverge ==> - st.ffi.oracle m x conf bytes = Oracle_final FFI_diverged` - (simp[basis_proj2_def,basis_proj1_def] + st.ffi.oracle m x conf bytes = Oracle_final FFI_diverged +Proof + simp[basis_proj2_def,basis_proj1_def] \\ pairarg_tac \\ fs[] \\ rw[cfHeapsBaseTheory.mk_proj1_def, cfHeapsBaseTheory.mk_proj2_def, @@ -616,16 +640,18 @@ Theorem oracle_parts_div \\ rw[] ) \\ fs[cl_ffi_no_ffi_div,fs_ffi_no_ffi_div] \\ disj2_tac - \\ CCONTR_TAC \\ fs[] \\ rfs[]); + \\ CCONTR_TAC \\ fs[] \\ rfs[] +QED val _ = translation_extends "TextIOProg"; val st_f = get_ml_prog_state () |> get_state |> strip_comb |> fst; val st = mk_icomb (st_f, ``basis_ffi cls fs``); val _ = reset_translation () -Theorem parts_ok_basis_st - `parts_ok (^st).ffi (basis_proj1, basis_proj2)` - (qmatch_goalsub_abbrev_tac`st.ffi` +Theorem parts_ok_basis_st: + parts_ok (^st).ffi (basis_proj1, basis_proj2) +Proof + qmatch_goalsub_abbrev_tac`st.ffi` \\ `st.ffi.oracle = basis_ffi_oracle` by( simp[Abbr`st`] \\ EVAL_TAC \\ NO_TAC) \\ rw[cfStoreTheory.parts_ok_def] @@ -641,14 +667,16 @@ Theorem parts_ok_basis_st \\ TRY(PURE_FULL_CASE_TAC \\ fs[]) \\ EVERY (map imp_res_tac (CONJUNCTS basis_ffi_length_thms)) \\ fs[] \\ srw_tac[DNF_ss][] \\ fs[ffi_exit_def] -); +QED (* TODO: move somewhere else? *) -Theorem SPLIT_exists - `(A * B) s /\ s ⊆ C - ==> (?h1 h2. SPLIT C (h1, h2) /\ (A * B) h1)` - (rw[] +Theorem SPLIT_exists: + (A * B) s /\ s ⊆ C + ==> (?h1 h2. SPLIT C (h1, h2) /\ (A * B) h1) +Proof + rw[] \\ qexists_tac `s` \\ qexists_tac `C DIFF s` - \\ SPLIT_TAC); + \\ SPLIT_TAC +QED val _ = export_theory(); diff --git a/basis/clFFIScript.sml b/basis/clFFIScript.sml index 30df9381b6..1dcd215697 100644 --- a/basis/clFFIScript.sml +++ b/basis/clFFIScript.sml @@ -43,20 +43,26 @@ val ffi_get_arg_def = Define ` (* lengths *) -Theorem ffi_get_arg_count_length - `ffi_get_arg_count conf bytes args = SOME (FFIreturn bytes' args') ==> - LENGTH bytes' = LENGTH bytes` - (fs [ffi_get_arg_count_def] \\ rw [] \\ fs []); - -Theorem ffi_get_arg_length_length - `ffi_get_arg_length conf bytes args = SOME (FFIreturn bytes' args') ==> - LENGTH bytes' = LENGTH bytes` - (fs [ffi_get_arg_length_def] \\ rw [] \\ fs []); - -Theorem ffi_get_arg_length - `ffi_get_arg conf bytes args = SOME (FFIreturn bytes' args') ==> - LENGTH bytes' = LENGTH bytes` - (fs [ffi_get_arg_def] \\ rw [] \\ fs [mlstringTheory.LENGTH_explode]); +Theorem ffi_get_arg_count_length: + ffi_get_arg_count conf bytes args = SOME (FFIreturn bytes' args') ==> + LENGTH bytes' = LENGTH bytes +Proof + fs [ffi_get_arg_count_def] \\ rw [] \\ fs [] +QED + +Theorem ffi_get_arg_length_length: + ffi_get_arg_length conf bytes args = SOME (FFIreturn bytes' args') ==> + LENGTH bytes' = LENGTH bytes +Proof + fs [ffi_get_arg_length_def] \\ rw [] \\ fs [] +QED + +Theorem ffi_get_arg_length: + ffi_get_arg conf bytes args = SOME (FFIreturn bytes' args') ==> + LENGTH bytes' = LENGTH bytes +Proof + fs [ffi_get_arg_def] \\ rw [] \\ fs [mlstringTheory.LENGTH_explode] +QED (* FFI part for the commandline *) diff --git a/basis/fsFFIPropsScript.sml b/basis/fsFFIPropsScript.sml index 95058b77b3..ed5041d7e0 100644 --- a/basis/fsFFIPropsScript.sml +++ b/basis/fsFFIPropsScript.sml @@ -10,9 +10,11 @@ val _ = option_monadsyntax.temp_add_option_monadsyntax(); val option_case_eq = prove_case_eq_thm { nchotomy = option_nchotomy, case_def = option_case_def} -Theorem numchars_self - `!fs. fs = fs with numchars := fs.numchars` - (cases_on`fs` >> fs[fsFFITheory.IO_fs_numchars_fupd]); +Theorem numchars_self: + !fs. fs = fs with numchars := fs.numchars +Proof + cases_on`fs` >> fs[fsFFITheory.IO_fs_numchars_fupd] +QED (* we can actually open a file if the OS limit has not been reached and we can * still encode the file descriptor on 8 bits *) @@ -20,9 +22,10 @@ val _ = overload_on("hasFreeFD",``λfs. CARD (set (MAP FST fs.infds)) < MIN fs.m (* nextFD lemmas *) -Theorem nextFD_ltX - `CARD (set (MAP FST fs.infds)) < x ⇒ nextFD fs < x` - (simp[nextFD_def] >> strip_tac >> numLib.LEAST_ELIM_TAC >> simp[] >> +Theorem nextFD_ltX: + CARD (set (MAP FST fs.infds)) < x ⇒ nextFD fs < x +Proof + simp[nextFD_def] >> strip_tac >> numLib.LEAST_ELIM_TAC >> simp[] >> qabbrev_tac `ns = MAP FST fs.infds` >> RM_ALL_ABBREVS_TAC >> conj_tac >- (qexists_tac `MAX_SET (set ns) + 1` >> pop_assum kall_tac >> DEEP_INTRO_TAC MAX_SET_ELIM >> simp[] >> @@ -31,11 +34,13 @@ Theorem nextFD_ltX `count x ⊆ set ns` by simp[SUBSET_DEF] >> `x ≤ CARD (set ns)` by metis_tac[CARD_COUNT, CARD_SUBSET, FINITE_LIST_TO_SET] >> - fs[]); + fs[] +QED -Theorem nextFD_leX - `CARD (set (MAP FST fs.infds)) ≤ x ⇒ nextFD fs ≤ x` - (simp[nextFD_def] >> strip_tac >> numLib.LEAST_ELIM_TAC >> simp[] >> +Theorem nextFD_leX: + CARD (set (MAP FST fs.infds)) ≤ x ⇒ nextFD fs ≤ x +Proof + simp[nextFD_def] >> strip_tac >> numLib.LEAST_ELIM_TAC >> simp[] >> qabbrev_tac `ns = MAP FST fs.infds` >> RM_ALL_ABBREVS_TAC >> conj_tac >- (qexists_tac `MAX_SET (set ns) + 1` >> pop_assum kall_tac >> DEEP_INTRO_TAC MAX_SET_ELIM >> simp[] >> @@ -47,66 +52,87 @@ Theorem nextFD_leX qexists_tac`x` \\ simp[] ) \\ `x < CARD (set ns)` by metis_tac[CARD_COUNT, CARD_PSUBSET, FINITE_LIST_TO_SET] >> - fs[]); + fs[] +QED -Theorem nextFD_NOT_MEM - `∀f m n fs. ¬MEM (nextFD fs,f,m,n) fs.infds` - (rpt gen_tac >> simp[nextFD_def] >> numLib.LEAST_ELIM_TAC >> conj_tac +Theorem nextFD_NOT_MEM: + ∀f m n fs. ¬MEM (nextFD fs,f,m,n) fs.infds +Proof + rpt gen_tac >> simp[nextFD_def] >> numLib.LEAST_ELIM_TAC >> conj_tac >- (qexists_tac `MAX_SET (set (MAP FST fs.infds)) + 1` >> DEEP_INTRO_TAC MAX_SET_ELIM >> simp[MEM_MAP, EXISTS_PROD, FORALL_PROD] >> rw[] >> strip_tac >> res_tac >> fs[]) >> - simp[EXISTS_PROD, FORALL_PROD, MEM_MAP]); + simp[EXISTS_PROD, FORALL_PROD, MEM_MAP] +QED -Theorem nextFD_numchars - `!fs ll. nextFD (fs with numchars := ll) = nextFD fs` - (rw[nextFD_def]); +Theorem nextFD_numchars: + !fs ll. nextFD (fs with numchars := ll) = nextFD fs +Proof + rw[nextFD_def] +QED (* bumpFD lemmas *) -Theorem bumpFD_numchars - `!fs fd n ll. bumpFD fd (fs with numchars := ll) n = - (bumpFD fd fs n) with numchars := THE (LTL ll)` - (fs[bumpFD_def]); +Theorem bumpFD_numchars: + !fs fd n ll. bumpFD fd (fs with numchars := ll) n = + (bumpFD fd fs n) with numchars := THE (LTL ll) +Proof + fs[bumpFD_def] +QED Theorem bumpFD_inode_tbl[simp] `(bumpFD fd fs n).inode_tbl = fs.inode_tbl` -Theorem bumpFD_files[simp] - `(bumpFD fd fs n).files = fs.files` - (EVAL_TAC); (EVAL_TAC); +Theorem bumpFD_files[simp]: + (bumpFD fd fs n).files = fs.files +Proof + EVAL_TAC +QED (EVAL_TAC); -Theorem bumpFD_o - `!fs fd n1 n2. +Theorem bumpFD_o: + !fs fd n1 n2. bumpFD fd (bumpFD fd fs n1) n2 = - bumpFD fd fs (n1 + n2) with numchars := THE (LTL (THE (LTL fs.numchars)))` - (rw[bumpFD_def] >> cases_on`fs` >> fs[IO_fs_component_equality] >> - fs[AFUPDKEY_o] >> irule AFUPDKEY_eq >> rw[] >> PairCases_on `v` >> fs[]) - -Theorem bumpFD_0 - `bumpFD fd fs 0 = fs with numchars := THE (LTL fs.numchars)` - (rw[bumpFD_def,IO_fs_component_equality] \\ + bumpFD fd fs (n1 + n2) with numchars := THE (LTL (THE (LTL fs.numchars))) +Proof + rw[bumpFD_def] >> cases_on`fs` >> fs[IO_fs_component_equality] >> + fs[AFUPDKEY_o] >> irule AFUPDKEY_eq >> rw[] >> PairCases_on `v` >> fs[] +QED + +Theorem bumpFD_0: + bumpFD fd fs 0 = fs with numchars := THE (LTL fs.numchars) +Proof + rw[bumpFD_def,IO_fs_component_equality] \\ match_mp_tac AFUPDKEY_unchanged \\ - simp[FORALL_PROD]); + simp[FORALL_PROD] +QED (* validFD lemmas *) -Theorem validFD_numchars - `!fd fs ll. validFD fd fs <=> validFD fd (fs with numchars := ll)` - (rw[validFD_def]) - -Theorem validFD_bumpFD - `validFD fd' fs ⇒ validFD fd' (bumpFD fd fs n)` - (rw[bumpFD_def,validFD_def]); - -Theorem validFD_ALOOKUP - `validFD fd fs ==> ?v. ALOOKUP fs.infds fd = SOME v` - (rw[validFD_def] >> cases_on`ALOOKUP fs.infds fd` >> fs[ALOOKUP_NONE]); - -Theorem ALOOKUP_validFD - `ALOOKUP fs.infds fd = SOME (fname, md, pos) ⇒ validFD fd fs` - (rw[validFD_def] >> imp_res_tac ALOOKUP_MEM >> - fs[MEM_MAP,EXISTS_PROD] >> metis_tac[]); +Theorem validFD_numchars: + !fd fs ll. validFD fd fs <=> validFD fd (fs with numchars := ll) +Proof + rw[validFD_def] +QED + +Theorem validFD_bumpFD: + validFD fd' fs ⇒ validFD fd' (bumpFD fd fs n) +Proof + rw[bumpFD_def,validFD_def] +QED + +Theorem validFD_ALOOKUP: + validFD fd fs ==> ?v. ALOOKUP fs.infds fd = SOME v +Proof + rw[validFD_def] >> cases_on`ALOOKUP fs.infds fd` >> fs[ALOOKUP_NONE] +QED + +Theorem ALOOKUP_validFD: + ALOOKUP fs.infds fd = SOME (fname, md, pos) ⇒ validFD fd fs +Proof + rw[validFD_def] >> imp_res_tac ALOOKUP_MEM >> + fs[MEM_MAP,EXISTS_PROD] >> metis_tac[] +QED val validFileFD_def = Define` validFileFD fd infds ⇔ @@ -114,15 +140,19 @@ val validFileFD_def = Define` (* getNullTermStr lemmas *) -Theorem getNullTermStr_add_null - `∀cs. ¬MEM 0w cs ⇒ getNullTermStr (cs++(0w::ls)) = SOME (MAP (CHR o w2n) cs)` - (simp[getNullTermStr_def, findi_APPEND, NOT_MEM_findi, findi_def, TAKE_APPEND]) +Theorem getNullTermStr_add_null: + ∀cs. ¬MEM 0w cs ⇒ getNullTermStr (cs++(0w::ls)) = SOME (MAP (CHR o w2n) cs) +Proof + simp[getNullTermStr_def, findi_APPEND, NOT_MEM_findi, findi_def, TAKE_APPEND] +QED -Theorem getNullTermStr_insert_atI - `∀cs l. LENGTH cs < LENGTH l ∧ ¬MEM 0w cs ⇒ - getNullTermStr (insert_atI (cs++[0w]) 0 l) = SOME (MAP (CHR o w2n) cs)` - (simp[getNullTermStr_def, insert_atI_def, findi_APPEND, NOT_MEM_findi, - findi_def, TAKE_APPEND]) +Theorem getNullTermStr_insert_atI: + ∀cs l. LENGTH cs < LENGTH l ∧ ¬MEM 0w cs ⇒ + getNullTermStr (insert_atI (cs++[0w]) 0 l) = SOME (MAP (CHR o w2n) cs) +Proof + simp[getNullTermStr_def, insert_atI_def, findi_APPEND, NOT_MEM_findi, + findi_def, TAKE_APPEND] +QED (* the filesystem will always eventually allow to write something *) @@ -151,53 +181,67 @@ val wfFS_def = Define` consistentFS fs ∧ liveFS fs) `; -Theorem consistentFS_with_numchars[simp] - `!fs ll. consistentFS fs ⇒ consistentFS (fs with numchars := ll)` - (fs[consistentFS_def]); +Theorem consistentFS_with_numchars[simp]: + !fs ll. consistentFS fs ⇒ consistentFS (fs with numchars := ll) +Proof + fs[consistentFS_def] +QED -Theorem wfFS_numchars - `!fs ll. wfFS fs ==> ¬LFINITE ll ==> +Theorem wfFS_numchars: + !fs ll. wfFS fs ==> ¬LFINITE ll ==> always (eventually (λll. ∃k. LHD ll = SOME k ∧ k ≠ 0)) ll ==> - wfFS (fs with numchars := ll)` - (rw[wfFS_def,liveFS_def,live_numchars_def]); - -Theorem wfFS_LTL - `!fs ll. wfFS (fs with numchars := ll) ==> - wfFS (fs with numchars := THE (LTL ll))` - (rw[wfFS_def,liveFS_def,live_numchars_def,consistentFS_def] >> - cases_on `ll` >> fs[LDROP_1] >> imp_res_tac always_thm >> metis_tac[]); - -Theorem wfFS_openFile - `wfFS fs ⇒ wfFS (openFileFS fnm fs md off)` - (simp[openFileFS_def, openFile_def] >> + wfFS (fs with numchars := ll) +Proof + rw[wfFS_def,liveFS_def,live_numchars_def] +QED + +Theorem wfFS_LTL: + !fs ll. wfFS (fs with numchars := ll) ==> + wfFS (fs with numchars := THE (LTL ll)) +Proof + rw[wfFS_def,liveFS_def,live_numchars_def,consistentFS_def] >> + cases_on `ll` >> fs[LDROP_1] >> imp_res_tac always_thm >> metis_tac[] +QED + +Theorem wfFS_openFile: + wfFS fs ⇒ wfFS (openFileFS fnm fs md off) +Proof + simp[openFileFS_def, openFile_def] >> Cases_on `nextFD fs <= fs.maxFD` >> simp[] >> Cases_on`ALOOKUP fs.files fnm` >> simp[] >> Cases_on `ALOOKUP fs.inode_tbl (File x)` >> simp[] >> dsimp[wfFS_def,consistentFS_def, MEM_MAP, EXISTS_PROD, FORALL_PROD] >> rw[] >> fs[liveFS_def] >> imp_res_tac ALOOKUP_EXISTS_IFF >> - metis_tac[]); + metis_tac[] +QED -Theorem wfFS_ADELKEY[simp] - `wfFS fs ⇒ wfFS (fs with infds updated_by ADELKEY k)` - (simp[wfFS_def, MEM_MAP, PULL_EXISTS, FORALL_PROD, EXISTS_PROD, +Theorem wfFS_ADELKEY[simp]: + wfFS fs ⇒ wfFS (fs with infds updated_by ADELKEY k) +Proof + simp[wfFS_def, MEM_MAP, PULL_EXISTS, FORALL_PROD, EXISTS_PROD, ALOOKUP_ADELKEY,liveFS_def,consistentFS_def] >> - metis_tac[]); + metis_tac[] +QED -Theorem wfFS_LDROP - `wfFS fs ==> wfFS (fs with numchars := (THE (LDROP k fs.numchars)))` - (rw[wfFS_def,liveFS_def,live_numchars_def,always_DROP,consistentFS_def] >> +Theorem wfFS_LDROP: + wfFS fs ==> wfFS (fs with numchars := (THE (LDROP k fs.numchars))) +Proof + rw[wfFS_def,liveFS_def,live_numchars_def,always_DROP,consistentFS_def] >> imp_res_tac NOT_LFINITE_DROP >> first_x_assum (assume_tac o Q.SPEC `k`) >> fs[] >> - metis_tac[NOT_LFINITE_DROP_LFINITE]); + metis_tac[NOT_LFINITE_DROP_LFINITE] +QED -Theorem wfFS_bumpFD[simp] - `wfFS fs ⇒ wfFS (bumpFD fd fs n)` - (simp[bumpFD_def] >> +Theorem wfFS_bumpFD[simp]: + wfFS fs ⇒ wfFS (bumpFD fd fs n) +Proof + simp[bumpFD_def] >> dsimp[wfFS_def, AFUPDKEY_ALOOKUP, option_case_eq, bool_case_eq, EXISTS_PROD,consistentFS_def] >> rw[] >- metis_tac[] >> cases_on`fs.numchars` >> fs[liveFS_def,live_numchars_def] >> - imp_res_tac always_thm >> metis_tac[]); + imp_res_tac always_thm >> metis_tac[] +QED (* end of file is reached when the position index is the length of the file *) @@ -210,41 +254,50 @@ val eof_def = Define` od `; -Theorem eof_numchars[simp] - `eof fd (fs with numchars := ll) = eof fd fs` - (rw[eof_def]); +Theorem eof_numchars[simp]: + eof fd (fs with numchars := ll) = eof fd fs +Proof + rw[eof_def] +QED -Theorem wfFS_eof_EQ_SOME - `wfFS fs ∧ validFD fd fs ⇒ - ∃b. eof fd fs = SOME b` - (simp[eof_def, EXISTS_PROD, PULL_EXISTS, MEM_MAP, wfFS_def, validFD_def] >> - rpt strip_tac >> res_tac >> metis_tac[ALOOKUP_EXISTS_IFF]); +Theorem wfFS_eof_EQ_SOME: + wfFS fs ∧ validFD fd fs ⇒ + ∃b. eof fd fs = SOME b +Proof + simp[eof_def, EXISTS_PROD, PULL_EXISTS, MEM_MAP, wfFS_def, validFD_def] >> + rpt strip_tac >> res_tac >> metis_tac[ALOOKUP_EXISTS_IFF] +QED (* -Theorem eof_read - `!fd fs n. wfFS fs ⇒ +Theorem eof_read: + !fd fs n. wfFS fs ⇒ 0 < n ⇒ (eof fd fs = SOME T) ⇒ - read fd fs n = SOME ([], fs with numchars := THE(LTL fs.numchars))` - (rw[eof_def,read_def,MIN_DEF] >> + read fd fs n = SOME ([], fs with numchars := THE(LTL fs.numchars)) +Proof + rw[eof_def,read_def,MIN_DEF] >> qexists_tac `x` >> rw[] >> pairarg_tac >> fs[bumpFD_def,wfFS_def] >> cases_on`fs.numchars` >> fs[IO_fs_component_equality,liveFS_def,live_numchars_def] >> - irule AFUPDKEY_unchanged >> cases_on`v` >> rw[]); + irule AFUPDKEY_unchanged >> cases_on`v` >> rw[] +QED *) -Theorem eof_read - `!fd fs n fs'. 0 < n ⇒ read fd fs n = SOME ([], fs') ⇒ eof fd fs = SOME T` - (rw[eof_def,read_def] >> +Theorem eof_read: + !fd fs n fs'. 0 < n ⇒ read fd fs n = SOME ([], fs') ⇒ eof fd fs = SOME T +Proof + rw[eof_def,read_def] >> qexists_tac `x` >> rw[] >> PairCases_on `x` >> - fs[DROP_NIL]); + fs[DROP_NIL] +QED (* -Theorem neof_read - `eof fd fs = SOME F ⇒ 0 < n ⇒ +Theorem neof_read: + eof fd fs = SOME F ⇒ 0 < n ⇒ wfFS fs ⇒ - ∃l fs'. l <> "" /\ read fd fs n = SOME (l,fs')` - (mp_tac (Q.SPECL [`fd`, `fs`, `n`] read_def) >> + ∃l fs'. l <> "" /\ read fd fs n = SOME (l,fs') +Proof + mp_tac (Q.SPECL [`fd`, `fs`, `n`] read_def) >> rw[wfFS_def,liveFS_def,live_numchars_def] >> cases_on `ALOOKUP fs.infds fd` >> fs[eof_def] >> cases_on `x` >> fs[] >> @@ -252,92 +305,116 @@ Theorem neof_read cases_on `fs.numchars` >> fs[] >> cases_on `DROP x2 contents` >> fs[] >> `x2 ≥ LENGTH contents` by fs[DROP_EMPTY] >> - fs[]); + fs[] +QED *) -Theorem get_file_content_eof - `get_file_content fs fd = SOME (content,pos) ⇒ eof fd fs = SOME (¬(pos < LENGTH content))` - (rw[get_file_content_def,eof_def] - \\ pairarg_tac \\ fs[]); +Theorem get_file_content_eof: + get_file_content fs fd = SOME (content,pos) ⇒ eof fd fs = SOME (¬(pos < LENGTH content)) +Proof + rw[get_file_content_def,eof_def] + \\ pairarg_tac \\ fs[] +QED (* inFS_fname *) val inFS_fname_def = Define ` inFS_fname fs s = (?ino. ALOOKUP fs.files s = SOME ino)` -Theorem not_inFS_fname_openFile - `~inFS_fname fs iname ⇒ openFile iname fs md off = NONE` - (rw[inFS_fname_def, openFile_def] >> - Cases_on`ALOOKUP fs.files iname` >> fs[]); +Theorem not_inFS_fname_openFile: + ~inFS_fname fs iname ⇒ openFile iname fs md off = NONE +Proof + rw[inFS_fname_def, openFile_def] >> + Cases_on`ALOOKUP fs.files iname` >> fs[] +QED -Theorem inFS_fname_ALOOKUP_EXISTS - `! fs fname. consistentFS fs /\ inFS_fname fs fname ⇒ +Theorem inFS_fname_ALOOKUP_EXISTS: + ! fs fname. consistentFS fs /\ inFS_fname fs fname ⇒ ∃ino content. ALOOKUP fs.files fname = SOME ino /\ - ALOOKUP fs.inode_tbl (File ino) = SOME content` - (fs [inFS_fname_def] >> rpt strip_tac >> fs[] >> + ALOOKUP fs.inode_tbl (File ino) = SOME content +Proof + fs [inFS_fname_def] >> rpt strip_tac >> fs[] >> Cases_on`ALOOKUP fs.files fname` >> fs[ALOOKUP_NONE,wfFS_def] >> rename1 `File ino` >> Cases_on`ALOOKUP fs.inode_tbl (File ino)` >> fs[ALOOKUP_NONE,consistentFS_def] >> - rw[] >> res_tac >> fs[MEM_MAP]); + rw[] >> res_tac >> fs[MEM_MAP] +QED -Theorem ALOOKUP_SOME_inFS_fname - `ALOOKUP fs.files fnm = SOME ino ==> inFS_fname fs fnm` - (rw[openFileFS_def,openFile_def] \\ imp_res_tac inFS_fname_def); +Theorem ALOOKUP_SOME_inFS_fname: + ALOOKUP fs.files fnm = SOME ino ==> inFS_fname fs fnm +Proof + rw[openFileFS_def,openFile_def] \\ imp_res_tac inFS_fname_def +QED -Theorem ALOOKUP_inFS_fname_openFileFS_nextFD - `!fs f ino off md. consistentFS fs /\ inFS_fname fs f ∧ nextFD fs <= fs.maxFD ∧ +Theorem ALOOKUP_inFS_fname_openFileFS_nextFD: + !fs f ino off md. consistentFS fs /\ inFS_fname fs f ∧ nextFD fs <= fs.maxFD ∧ ALOOKUP fs.files f = SOME ino ⇒ - ALOOKUP (openFileFS f fs md off).infds (nextFD fs) = SOME (File ino,md,off)` - ( + ALOOKUP (openFileFS f fs md off).infds (nextFD fs) = SOME (File ino,md,off) +Proof rw[openFileFS_def,openFile_def] \\ imp_res_tac inFS_fname_ALOOKUP_EXISTS - \\ rfs[]); + \\ rfs[] +QED -Theorem inFS_fname_numchars - `!s fs ll. inFS_fname (fs with numchars := ll) s = inFS_fname fs s` - (EVAL_TAC >> rw[]); +Theorem inFS_fname_numchars: + !s fs ll. inFS_fname (fs with numchars := ll) s = inFS_fname fs s +Proof + EVAL_TAC >> rw[] +QED (* ffi lengths *) -Theorem ffi_open_in_length - `ffi_open_in conf bytes fs = SOME (FFIreturn bytes' fs') ==> LENGTH bytes' = LENGTH bytes` - (rw[ffi_open_in_def] \\ fs[option_eq_some] - \\ TRY(pairarg_tac) \\ rw[] \\ fs[] \\ rw[] \\ fs[n2w8_def]); - -Theorem ffi_open_out_length - `ffi_open_out conf bytes fs = SOME (FFIreturn bytes' fs') ==> LENGTH bytes' = LENGTH bytes` - (rw[ffi_open_out_def] \\ fs[option_eq_some] - \\ TRY(pairarg_tac) \\ rw[] \\ fs[] \\ rw[] \\ fs[n2w8_def]); - -Theorem read_length - `read fd fs k = SOME (l, fs') ==> LENGTH l <= k` - (rw[read_def] >> pairarg_tac >> fs[option_eq_some,LENGTH_TAKE] >> +Theorem ffi_open_in_length: + ffi_open_in conf bytes fs = SOME (FFIreturn bytes' fs') ==> LENGTH bytes' = LENGTH bytes +Proof + rw[ffi_open_in_def] \\ fs[option_eq_some] + \\ TRY(pairarg_tac) \\ rw[] \\ fs[] \\ rw[] \\ fs[n2w8_def] +QED + +Theorem ffi_open_out_length: + ffi_open_out conf bytes fs = SOME (FFIreturn bytes' fs') ==> LENGTH bytes' = LENGTH bytes +Proof + rw[ffi_open_out_def] \\ fs[option_eq_some] + \\ TRY(pairarg_tac) \\ rw[] \\ fs[] \\ rw[] \\ fs[n2w8_def] +QED + +Theorem read_length: + read fd fs k = SOME (l, fs') ==> LENGTH l <= k +Proof + rw[read_def] >> pairarg_tac >> fs[option_eq_some,LENGTH_TAKE] >> ` l = TAKE (MIN k (MIN (STRLEN content − off) (SUC strm))) (DROP off content)` by (fs[]) >> - fs[MIN_DEF,LENGTH_DROP]); + fs[MIN_DEF,LENGTH_DROP] +QED -Theorem ffi_read_length - `ffi_read conf bytes fs = SOME (FFIreturn bytes' fs') ==> LENGTH bytes' = LENGTH bytes` - (rw[ffi_read_def] +Theorem ffi_read_length: + ffi_read conf bytes fs = SOME (FFIreturn bytes' fs') ==> LENGTH bytes' = LENGTH bytes +Proof + rw[ffi_read_def] \\ fs[option_case_eq,prove_case_eq_thm{nchotomy=list_nchotomy,case_def=list_case_def}] \\ fs[option_eq_some] \\ TRY(pairarg_tac) \\ rveq \\ fs[] \\ rveq \\ fs[n2w2_def] - \\ imp_res_tac read_length \\ fs[]); + \\ imp_res_tac read_length \\ fs[] +QED -Theorem ffi_write_length - `ffi_write conf bytes fs = SOME (FFIreturn bytes' fs') ==> LENGTH bytes' = LENGTH bytes` - (EVAL_TAC \\ rw[] +Theorem ffi_write_length: + ffi_write conf bytes fs = SOME (FFIreturn bytes' fs') ==> LENGTH bytes' = LENGTH bytes +Proof + EVAL_TAC \\ rw[] \\ fs[option_eq_some] \\ every_case_tac \\ fs[] \\ rw[] \\ pairarg_tac \\ fs[] \\ pairarg_tac \\ fs[n2w2_def] \\ rw[] \\ Cases_on`bytes` \\ fs[] - \\ rpt(Cases_on`t` \\ fs[] \\ Cases_on`t'` \\ fs[])); + \\ rpt(Cases_on`t` \\ fs[] \\ Cases_on`t'` \\ fs[]) +QED -Theorem ffi_close_length - `ffi_close conf bytes fs = SOME (FFIreturn bytes' fs') ==> LENGTH bytes' = LENGTH bytes` - (rw[ffi_close_def] \\ fs[option_eq_some] \\ TRY pairarg_tac \\ fs[] \\ rw[]); +Theorem ffi_close_length: + ffi_close conf bytes fs = SOME (FFIreturn bytes' fs') ==> LENGTH bytes' = LENGTH bytes +Proof + rw[ffi_close_def] \\ fs[option_eq_some] \\ TRY pairarg_tac \\ fs[] \\ rw[] +QED (* fastForwardFD *) @@ -349,119 +426,144 @@ val fastForwardFD_def = Define` SOME (fs with infds updated_by AFUPDKEY fd (I ## I ## MAX (LENGTH content))) od)`; -Theorem validFD_fastForwardFD[simp] - `validFD fd (fastForwardFD fs fd) = validFD fd fs` - (rw[validFD_def,fastForwardFD_def,bumpFD_def] +Theorem validFD_fastForwardFD[simp]: + validFD fd (fastForwardFD fs fd) = validFD fd fs +Proof + rw[validFD_def,fastForwardFD_def,bumpFD_def] \\ Cases_on`ALOOKUP fs.infds fd` \\ fs[libTheory.the_def] \\ pairarg_tac \\ fs[] \\ Cases_on`ALOOKUP fs.inode_tbl ino` \\ fs[libTheory.the_def] - \\ rw[OPTION_GUARD_COND,libTheory.the_def]); + \\ rw[OPTION_GUARD_COND,libTheory.the_def] +QED -Theorem validFileFD_fastForwardFD[simp] - `validFileFD fd (fastForwardFD fs x).infds ⇔ validFileFD fd fs.infds` - (rw[validFileFD_def, fastForwardFD_def] +Theorem validFileFD_fastForwardFD[simp]: + validFileFD fd (fastForwardFD fs x).infds ⇔ validFileFD fd fs.infds +Proof + rw[validFileFD_def, fastForwardFD_def] \\ Cases_on`ALOOKUP fs.infds x` \\ rw[libTheory.the_def] \\ pairarg_tac \\ fs[] \\ Cases_on`ALOOKUP fs.inode_tbl ino` \\ fs[libTheory.the_def] \\ simp[AFUPDKEY_ALOOKUP] \\ TOP_CASE_TAC \\ simp[] \\ rw[PAIR_MAP, FST_EQ_EQUIV, PULL_EXISTS, SND_EQ_EQUIV] - \\ rw[EQ_IMP_THM]); + \\ rw[EQ_IMP_THM] +QED -Theorem fastForwardFD_inode_tbl[simp] - `(fastForwardFD fs fd).inode_tbl = fs.inode_tbl` - (EVAL_TAC +Theorem fastForwardFD_inode_tbl[simp]: + (fastForwardFD fs fd).inode_tbl = fs.inode_tbl +Proof + EVAL_TAC \\ Cases_on`ALOOKUP fs.infds fd` \\ fs[libTheory.the_def] \\ pairarg_tac \\ fs[] \\ Cases_on`ALOOKUP fs.inode_tbl ino` \\ fs[libTheory.the_def] - \\ rw[OPTION_GUARD_COND,libTheory.the_def]); + \\ rw[OPTION_GUARD_COND,libTheory.the_def] +QED -Theorem fastForwardFD_files[simp] - `!fs fd. (fastForwardFD fs fd).files = fs.files` - (rw[fastForwardFD_def] >> +Theorem fastForwardFD_files[simp]: + !fs fd. (fastForwardFD fs fd).files = fs.files +Proof + rw[fastForwardFD_def] >> Cases_on`ALOOKUP fs.infds fd` >> fs[libTheory.the_def] >> pairarg_tac >> fs[] >> - Cases_on`ALOOKUP fs.inode_tbl ino` >> fs[libTheory.the_def]) + Cases_on`ALOOKUP fs.inode_tbl ino` >> fs[libTheory.the_def] +QED -Theorem ADELKEY_fastForwardFD_elim[simp] - `ADELKEY fd (fastForwardFD fs fd).infds = ADELKEY fd fs.infds` - (rw[fastForwardFD_def,bumpFD_def] +Theorem ADELKEY_fastForwardFD_elim[simp]: + ADELKEY fd (fastForwardFD fs fd).infds = ADELKEY fd fs.infds +Proof + rw[fastForwardFD_def,bumpFD_def] \\ Cases_on`ALOOKUP fs.infds fd` \\ fs[libTheory.the_def] \\ pairarg_tac \\ fs[] \\ Cases_on`ALOOKUP fs.inode_tbl ino` \\ fs[libTheory.the_def] - \\ rw[OPTION_GUARD_COND,libTheory.the_def]); - -Theorem fastForwardFD_ADELKEY_same[simp] - `fastForwardFD fs fd with infds updated_by ADELKEY fd = - fs with infds updated_by ADELKEY fd` - (rw[fastForwardFD_def] + \\ rw[OPTION_GUARD_COND,libTheory.the_def] +QED + +Theorem fastForwardFD_ADELKEY_same[simp]: + fastForwardFD fs fd with infds updated_by ADELKEY fd = + fs with infds updated_by ADELKEY fd +Proof + rw[fastForwardFD_def] \\ Cases_on`ALOOKUP fs.infds fd` \\ fs[libTheory.the_def] \\ pairarg_tac \\ fs[libTheory.the_def] \\ Cases_on`ALOOKUP fs.inode_tbl ino` \\ fs[libTheory.the_def] - \\ fs[IO_fs_component_equality,ADELKEY_unchanged]) - -Theorem fastForwardFD_0 - `(∀content pos. get_file_content fs fd = SOME (content,pos) ⇒ LENGTH content ≤ pos) ⇒ - fastForwardFD fs fd = fs` - (rw[fastForwardFD_def,get_file_content_def] + \\ fs[IO_fs_component_equality,ADELKEY_unchanged] +QED + +Theorem fastForwardFD_0: + (∀content pos. get_file_content fs fd = SOME (content,pos) ⇒ LENGTH content ≤ pos) ⇒ + fastForwardFD fs fd = fs +Proof + rw[fastForwardFD_def,get_file_content_def] \\ Cases_on`ALOOKUP fs.infds fd` \\ fs[libTheory.the_def] \\ pairarg_tac \\ fs[] \\ Cases_on`ALOOKUP fs.inode_tbl ino` \\ fs[libTheory.the_def] \\ fs[IO_fs_component_equality] \\ match_mp_tac AFUPDKEY_unchanged \\ rw[] \\ rw[PAIR_MAP_THM] - \\ rw[MAX_DEF]); + \\ rw[MAX_DEF] +QED -Theorem fastForwardFD_with_numchars - `fastForwardFD (fs with numchars := ns) fd = fastForwardFD fs fd with numchars := ns` - (rw[fastForwardFD_def] +Theorem fastForwardFD_with_numchars: + fastForwardFD (fs with numchars := ns) fd = fastForwardFD fs fd with numchars := ns +Proof + rw[fastForwardFD_def] \\ Cases_on`ALOOKUP fs.infds fd` \\ simp[libTheory.the_def] \\ pairarg_tac \\ fs[] - \\ Cases_on`ALOOKUP fs.inode_tbl ino` \\ simp[libTheory.the_def]); + \\ Cases_on`ALOOKUP fs.inode_tbl ino` \\ simp[libTheory.the_def] +QED -Theorem fastForwardFD_numchars[simp] - `(fastForwardFD fs fd).numchars = fs.numchars` - (rw[fastForwardFD_def] +Theorem fastForwardFD_numchars[simp]: + (fastForwardFD fs fd).numchars = fs.numchars +Proof + rw[fastForwardFD_def] \\ Cases_on`ALOOKUP fs.infds fd` \\ simp[libTheory.the_def] \\ pairarg_tac \\ fs[] - \\ Cases_on`ALOOKUP fs.inode_tbl ino` \\ simp[libTheory.the_def]); + \\ Cases_on`ALOOKUP fs.inode_tbl ino` \\ simp[libTheory.the_def] +QED -Theorem fastForwardFD_maxFD[simp] - `(fastForwardFD fs fd).maxFD = fs.maxFD` - (rw[fastForwardFD_def] +Theorem fastForwardFD_maxFD[simp]: + (fastForwardFD fs fd).maxFD = fs.maxFD +Proof + rw[fastForwardFD_def] \\ Cases_on`ALOOKUP fs.infds fd` \\ simp[libTheory.the_def] \\ pairarg_tac \\ fs[] - \\ Cases_on`ALOOKUP fs.inode_tbl ino` \\ simp[libTheory.the_def]); + \\ Cases_on`ALOOKUP fs.inode_tbl ino` \\ simp[libTheory.the_def] +QED -Theorem wfFS_fastForwardFD[simp] - `!fs fd. validFD fd fs /\ wfFS fs ==> wfFS (fastForwardFD fs fd)` - (rw[wfFS_def,fastForwardFD_def,validFD_def] +Theorem wfFS_fastForwardFD[simp]: + !fs fd. validFD fd fs /\ wfFS fs ==> wfFS (fastForwardFD fs fd) +Proof + rw[wfFS_def,fastForwardFD_def,validFD_def] \\ Cases_on`ALOOKUP fs.infds fd` \\ fs[libTheory.the_def] \\ pairarg_tac \\ fs[] \\ Cases_on`ALOOKUP fs.inode_tbl ino` \\ fs[libTheory.the_def] \\ rw[] >-(res_tac \\ simp[AFUPDKEY_ALOOKUP] \\ CASE_TAC \\ fs[]) >-(fs[consistentFS_def] \\ rw[] \\ res_tac) - >-(fs[liveFS_def])) + >-(fs[liveFS_def]) +QED -Theorem fsupdate_fastForwardFD_comm - `∀fs fd1 fd2 k p c . +Theorem fsupdate_fastForwardFD_comm: + ∀fs fd1 fd2 k p c . ALOOKUP fs.infds fd1 = SOME(ino1,r,pos1) /\ ALOOKUP fs.infds fd2 = SOME(ino2,r',pos2) /\ ALOOKUP fs.inode_tbl ino1 = SOME content1 /\ ALOOKUP fs.inode_tbl ino2 = SOME content2 /\ ino1 ≠ ino2 ⇒ fsupdate (fastForwardFD fs fd1) fd2 k p c = - fastForwardFD (fsupdate fs fd2 k p c) fd1` - (rw[fsupdate_def,fastForwardFD_def,AFUPDKEY_ALOOKUP] >> EVAL_TAC >> - fs[AFUPDKEY_ALOOKUP,IO_fs_component_equality,AFUPDKEY_comm]); + fastForwardFD (fsupdate fs fd2 k p c) fd1 +Proof + rw[fsupdate_def,fastForwardFD_def,AFUPDKEY_ALOOKUP] >> EVAL_TAC >> + fs[AFUPDKEY_ALOOKUP,IO_fs_component_equality,AFUPDKEY_comm] +QED (* fsupdate *) -Theorem wfFS_fsupdate - `! fs fd content pos k. wfFS fs ==> MEM fd (MAP FST fs.infds) ==> - wfFS (fsupdate fs fd k pos content)` - (rw[wfFS_def,fsupdate_def,consistentFS_def] +Theorem wfFS_fsupdate: + ! fs fd content pos k. wfFS fs ==> MEM fd (MAP FST fs.infds) ==> + wfFS (fsupdate fs fd k pos content) +Proof + rw[wfFS_def,fsupdate_def,consistentFS_def] >- (res_tac \\ fs[]) >- (CASE_TAC \\ fs[] \\ @@ -471,19 +573,23 @@ Theorem wfFS_fsupdate >-( CASE_TAC \\ fs[] \\ CASE_TAC \\ fs[] \\ fs[liveFS_def,live_numchars_def,always_DROP] >> `∃y. LDROP k fs.numchars = SOME y` by(fs[NOT_LFINITE_DROP]) >> - fs[] >> metis_tac[NOT_LFINITE_DROP_LFINITE])); - -Theorem fsupdate_unchanged - `get_file_content fs fd = SOME(content, pos) ==> - fsupdate fs fd 0 pos content = fs` - (fs[fsupdate_def,get_file_content_def,validFD_def,IO_fs_component_equality]>> - rw[] >> pairarg_tac >> fs[AFUPDKEY_unchanged] >> rw[]); - -Theorem fsupdate_o - `liveFS fs ==> + fs[] >> metis_tac[NOT_LFINITE_DROP_LFINITE]) +QED + +Theorem fsupdate_unchanged: + get_file_content fs fd = SOME(content, pos) ==> + fsupdate fs fd 0 pos content = fs +Proof + fs[fsupdate_def,get_file_content_def,validFD_def,IO_fs_component_equality]>> + rw[] >> pairarg_tac >> fs[AFUPDKEY_unchanged] >> rw[] +QED + +Theorem fsupdate_o: + liveFS fs ==> fsupdate (fsupdate fs fd k1 pos1 c1) fd k2 pos2 c2 = - fsupdate fs fd (k1+k2) pos2 c2` - (rw[fsupdate_def] + fsupdate fs fd (k1+k2) pos2 c2 +Proof + rw[fsupdate_def] \\ CASE_TAC \\ fs[] \\ CASE_TAC \\ fs[] \\ fs[IO_fs_component_equality] @@ -491,210 +597,271 @@ Theorem fsupdate_o fs[LDROP_ADD,liveFS_def,live_numchars_def] >> imp_res_tac NOT_LFINITE_DROP >> FIRST_X_ASSUM(ASSUME_TAC o Q.SPEC`k1`) >> fs[] \\ rpt (AP_TERM_TAC ORELSE AP_THM_TAC) - \\ simp[FUN_EQ_THM, FORALL_PROD]); - -Theorem fsupdate_o_0[simp] - `fsupdate (fsupdate fs fd 0 pos1 c1) fd 0 pos2 c2 = - fsupdate fs fd 0 pos2 c2` - (rw[fsupdate_def] \\ CASE_TAC \\ fs[] \\ CASE_TAC \\ fs[] \\ + \\ simp[FUN_EQ_THM, FORALL_PROD] +QED + +Theorem fsupdate_o_0[simp]: + fsupdate (fsupdate fs fd 0 pos1 c1) fd 0 pos2 c2 = + fsupdate fs fd 0 pos2 c2 +Proof + rw[fsupdate_def] \\ CASE_TAC \\ fs[] \\ CASE_TAC \\ fs[] \\ rw[IO_fs_component_equality,AFUPDKEY_ALOOKUP,AFUPDKEY_o] \\ rpt(AP_TERM_TAC ORELSE AP_THM_TAC) - \\ simp[FUN_EQ_THM, FORALL_PROD]); + \\ simp[FUN_EQ_THM, FORALL_PROD] +QED -Theorem fsupdate_comm - `!fs fd1 fd2 k1 p1 c1 fnm1 pos1 k2 p2 c2 fnm2 pos2. +Theorem fsupdate_comm: + !fs fd1 fd2 k1 p1 c1 fnm1 pos1 k2 p2 c2 fnm2 pos2. ALOOKUP fs.infds fd1 = SOME(fnm1, pos1) /\ ALOOKUP fs.infds fd2 = SOME(fnm2, pos2) /\ fnm1 <> fnm2 /\ fd1 <> fd2 /\ ¬ LFINITE fs.numchars ==> fsupdate (fsupdate fs fd1 k1 p1 c1) fd2 k2 p2 c2 = - fsupdate (fsupdate fs fd2 k2 p2 c2) fd1 k1 p1 c1` - (fs[fsupdate_def] >> rw[] >> fs[AFUPDKEY_ALOOKUP] >> - rpt CASE_TAC >> fs[AFUPDKEY_comm,LDROP_LDROP]); - -Theorem fsupdate_MAP_FST_infds[simp] - `MAP FST (fsupdate fs fd k pos c).infds = MAP FST fs.infds` - (rw[fsupdate_def] \\ every_case_tac \\ rw[]); - -Theorem fsupdate_MAP_FST_inode_tbl[simp] - `MAP FST (fsupdate fs fd k pos c).inode_tbl = MAP FST fs.inode_tbl` - (rw[fsupdate_def] \\ every_case_tac \\ rw[]); - -Theorem fsupdate_MAP_FST_files[simp] - `MAP FST (fsupdate fs fd k pos c).files = MAP FST fs.files` - (rw[fsupdate_def] \\ every_case_tac \\ rw[]); - -Theorem validFD_fsupdate[simp] - `validFD fd (fsupdate fs fd' x y z) ⇔ validFD fd fs` - (rw[fsupdate_def,validFD_def]); - -Theorem validFileFD_fsupdate[simp] - `validFileFD fd (fsupdate fs fd' x y z).infds ⇔ validFileFD fd fs.infds` - (rw[fsupdate_def,validFileFD_def] + fsupdate (fsupdate fs fd2 k2 p2 c2) fd1 k1 p1 c1 +Proof + fs[fsupdate_def] >> rw[] >> fs[AFUPDKEY_ALOOKUP] >> + rpt CASE_TAC >> fs[AFUPDKEY_comm,LDROP_LDROP] +QED + +Theorem fsupdate_MAP_FST_infds[simp]: + MAP FST (fsupdate fs fd k pos c).infds = MAP FST fs.infds +Proof + rw[fsupdate_def] \\ every_case_tac \\ rw[] +QED + +Theorem fsupdate_MAP_FST_inode_tbl[simp]: + MAP FST (fsupdate fs fd k pos c).inode_tbl = MAP FST fs.inode_tbl +Proof + rw[fsupdate_def] \\ every_case_tac \\ rw[] +QED + +Theorem fsupdate_MAP_FST_files[simp]: + MAP FST (fsupdate fs fd k pos c).files = MAP FST fs.files +Proof + rw[fsupdate_def] \\ every_case_tac \\ rw[] +QED + +Theorem validFD_fsupdate[simp]: + validFD fd (fsupdate fs fd' x y z) ⇔ validFD fd fs +Proof + rw[fsupdate_def,validFD_def] +QED + +Theorem validFileFD_fsupdate[simp]: + validFileFD fd (fsupdate fs fd' x y z).infds ⇔ validFileFD fd fs.infds +Proof + rw[fsupdate_def,validFileFD_def] \\ TOP_CASE_TAC \\ simp[] \\ TOP_CASE_TAC \\ simp[] \\ simp[AFUPDKEY_ALOOKUP] \\ TOP_CASE_TAC \\ simp[] \\ rw[] \\ PairCases_on`x` - \\ simp[]); - -Theorem fsupdate_numchars - `!fs fd k p c ll. fsupdate fs fd k p c with numchars := ll = - fsupdate (fs with numchars := ll) fd 0 p c` - (rw[fsupdate_def] \\ CASE_TAC \\ CASE_TAC \\ rw[]); - -Theorem fsupdate_ADELKEY - `fd ≠ fd' ⇒ + \\ simp[] +QED + +Theorem fsupdate_numchars: + !fs fd k p c ll. fsupdate fs fd k p c with numchars := ll = + fsupdate (fs with numchars := ll) fd 0 p c +Proof + rw[fsupdate_def] \\ CASE_TAC \\ CASE_TAC \\ rw[] +QED + +Theorem fsupdate_ADELKEY: + fd ≠ fd' ⇒ fsupdate (fs with infds updated_by ADELKEY fd') fd k pos content = - fsupdate fs fd k pos content with infds updated_by ADELKEY fd'` - (rw[fsupdate_def,ALOOKUP_ADELKEY] + fsupdate fs fd k pos content with infds updated_by ADELKEY fd' +Proof + rw[fsupdate_def,ALOOKUP_ADELKEY] \\ CASE_TAC \\ CASE_TAC - \\ rw[ADELKEY_AFUPDKEY]); + \\ rw[ADELKEY_AFUPDKEY] +QED -Theorem fsupdate_0_numchars - `IS_SOME (ALOOKUP fs.infds fd) ⇒ +Theorem fsupdate_0_numchars: + IS_SOME (ALOOKUP fs.infds fd) ⇒ fsupdate fs fd n pos content = - fsupdate (fs with numchars := THE (LDROP n fs.numchars)) fd 0 pos content` - (rw[fsupdate_def] \\ TOP_CASE_TAC \\ fs[]); - -Theorem fsupdate_maxFD[simp] - `!fs fd k pos content. - (fsupdate fs fd k pos content).maxFD = fs.maxFD` - (rw [fsupdate_def] \\ every_case_tac \\ simp []); + fsupdate (fs with numchars := THE (LDROP n fs.numchars)) fd 0 pos content +Proof + rw[fsupdate_def] \\ TOP_CASE_TAC \\ fs[] +QED + +Theorem fsupdate_maxFD[simp]: + !fs fd k pos content. + (fsupdate fs fd k pos content).maxFD = fs.maxFD +Proof + rw [fsupdate_def] \\ every_case_tac \\ simp [] +QED (* get_file_content *) -Theorem get_file_content_numchars - `!fs fd. get_file_content fs fd = - get_file_content (fs with numchars := ll) fd` - (fs[get_file_content_def]); - -Theorem get_file_content_validFD - `get_file_content fs fd = SOME(c,p) ⇒ validFD fd fs` - (fs[get_file_content_def,validFD_def] >> rw[] >> pairarg_tac >> +Theorem get_file_content_numchars: + !fs fd. get_file_content fs fd = + get_file_content (fs with numchars := ll) fd +Proof + fs[get_file_content_def] +QED + +Theorem get_file_content_validFD: + get_file_content fs fd = SOME(c,p) ⇒ validFD fd fs +Proof + fs[get_file_content_def,validFD_def] >> rw[] >> pairarg_tac >> imp_res_tac ALOOKUP_MEM >> fs[ALOOKUP_MEM,MEM_MAP] >> - qexists_tac`(fd,x)` >> fs[]); - -Theorem get_file_content_fsupdate - `!fs fd x i c u. get_file_content fs fd = SOME u ⇒ - get_file_content (fsupdate fs fd x i c) fd = SOME(c,i)` - (rw[get_file_content_def, fsupdate_def] >> - pairarg_tac >> fs[AFUPDKEY_ALOOKUP]); - -Theorem get_file_content_fsupdate_unchanged - `!fs fd u fnm pos fd' fnm' pos' x i c. + qexists_tac`(fd,x)` >> fs[] +QED + +Theorem get_file_content_fsupdate: + !fs fd x i c u. get_file_content fs fd = SOME u ⇒ + get_file_content (fsupdate fs fd x i c) fd = SOME(c,i) +Proof + rw[get_file_content_def, fsupdate_def] >> + pairarg_tac >> fs[AFUPDKEY_ALOOKUP] +QED + +Theorem get_file_content_fsupdate_unchanged: + !fs fd u fnm pos fd' fnm' pos' x i c. get_file_content fs fd = SOME u ⇒ ALOOKUP fs.infds fd = SOME (fnm,pos) ⇒ ALOOKUP fs.infds fd' = SOME (fnm',pos') ⇒ fnm ≠ fnm' ⇒ - get_file_content (fsupdate fs fd' x i c) fd = SOME u` - (rw[get_file_content_def, fsupdate_def] >> + get_file_content (fsupdate fs fd' x i c) fd = SOME u +Proof + rw[get_file_content_def, fsupdate_def] >> pairarg_tac >> fs[AFUPDKEY_ALOOKUP] >> - rpt(CASE_TAC >> fs[])); + rpt(CASE_TAC >> fs[]) +QED -Theorem get_file_content_bumpFD[simp] - `!fs fd c pos n. +Theorem get_file_content_bumpFD[simp]: + !fs fd c pos n. get_file_content (bumpFD fd fs n) fd = - OPTION_MAP (I ## (+) n) (get_file_content fs fd)` - (rw[get_file_content_def,bumpFD_def,AFUPDKEY_ALOOKUP] + OPTION_MAP (I ## (+) n) (get_file_content fs fd) +Proof + rw[get_file_content_def,bumpFD_def,AFUPDKEY_ALOOKUP] \\ CASE_TAC \\ fs[] \\ pairarg_tac \\ fs[] \\ pairarg_tac \\ fs[] \\ rw[] - \\ Cases_on`ALOOKUP fs.inode_tbl ino` \\ fs[]); + \\ Cases_on`ALOOKUP fs.inode_tbl ino` \\ fs[] +QED (* liveFS *) -Theorem liveFS_openFileFS - `liveFS fs ⇒ liveFS (openFileFS s fs md n)` - (rw[liveFS_def,openFileFS_def, openFile_def] >> +Theorem liveFS_openFileFS: + liveFS fs ⇒ liveFS (openFileFS s fs md n) +Proof + rw[liveFS_def,openFileFS_def, openFile_def] >> CASE_TAC >> fs[] >> CASE_TAC >> fs[] >> `r.numchars = fs.numchars` by (cases_on`fs` >> cases_on`r` >> fs[IO_fs_infds_fupd]) >> - fs[]); + fs[] +QED -Theorem liveFS_fsupdate - `liveFS fs ⇒ liveFS (fsupdate fs fd n k c)` - (rw[liveFS_def,live_numchars_def,fsupdate_def] >> +Theorem liveFS_fsupdate: + liveFS fs ⇒ liveFS (fsupdate fs fd n k c) +Proof + rw[liveFS_def,live_numchars_def,fsupdate_def] >> every_case_tac \\ fs[always_DROP] \\ - metis_tac[NOT_LFINITE_DROP,NOT_LFINITE_DROP_LFINITE,THE_DEF]); + metis_tac[NOT_LFINITE_DROP,NOT_LFINITE_DROP_LFINITE,THE_DEF] +QED -Theorem liveFS_bumpFD - `liveFS fs ⇒ liveFS (bumpFD fd fs k)` - (rw[liveFS_def,live_numchars_def,bumpFD_def] >> cases_on`fs.numchars` >> fs[] >> - imp_res_tac always_thm); +Theorem liveFS_bumpFD: + liveFS fs ⇒ liveFS (bumpFD fd fs k) +Proof + rw[liveFS_def,live_numchars_def,bumpFD_def] >> cases_on`fs.numchars` >> fs[] >> + imp_res_tac always_thm +QED (* openFile, openFileFS *) -Theorem openFile_fupd_numchars - `!s fs k ll fd fs'. openFile s (fs with numchars := ll) md k = +Theorem openFile_fupd_numchars: + !s fs k ll fd fs'. openFile s (fs with numchars := ll) md k = case openFile s fs md k of SOME (fd, fs') => SOME (fd, fs' with numchars := ll) - | NONE => NONE` - (rw[openFile_def,nextFD_def] >> rpt(CASE_TAC >> fs[]) >> - rfs[IO_fs_component_equality]); - -Theorem openFileFS_numchars[simp] - `!s fs k. (openFileFS s fs md k).numchars = fs.numchars` - (rw[openFileFS_def] \\ CASE_TAC \\ CASE_TAC - \\ fs[openFile_def] \\ rw[]); - -Theorem openFileFS_inode_tbl[simp] - `!s fs k md. (openFileFS s fs md k).inode_tbl = fs.inode_tbl` - (rw[openFileFS_def] \\ CASE_TAC \\ CASE_TAC \\ fs[openFile_def] \\ rw[]); - - Theorem openFileFS_files[simp] - `!s fs k md. (openFileFS s fs md k).files = fs.files` - (rw[openFileFS_def] \\ CASE_TAC \\ CASE_TAC \\ fs[openFile_def] \\ rw[]); - -Theorem wfFS_openFileFS - `!f fs k md. CARD (FDOM (alist_to_fmap fs.infds)) <= fs.maxFD /\ wfFS fs ==> - wfFS (openFileFS f fs md k)` - (rw[wfFS_def,openFileFS_def,liveFS_def] >> full_case_tac >> fs[openFile_def] >> + | NONE => NONE +Proof + rw[openFile_def,nextFD_def] >> rpt(CASE_TAC >> fs[]) >> + rfs[IO_fs_component_equality] +QED + +Theorem openFileFS_numchars[simp]: + !s fs k. (openFileFS s fs md k).numchars = fs.numchars +Proof + rw[openFileFS_def] \\ CASE_TAC \\ CASE_TAC + \\ fs[openFile_def] \\ rw[] +QED + +Theorem openFileFS_inode_tbl[simp]: + !s fs k md. (openFileFS s fs md k).inode_tbl = fs.inode_tbl +Proof + rw[openFileFS_def] \\ CASE_TAC \\ CASE_TAC \\ fs[openFile_def] \\ rw[] +QED + + Theorem openFileFS_files[simp]: + !s fs k md. (openFileFS s fs md k).files = fs.files +Proof + rw[openFileFS_def] \\ CASE_TAC \\ CASE_TAC \\ fs[openFile_def] \\ rw[] +QED + +Theorem wfFS_openFileFS: + !f fs k md. CARD (FDOM (alist_to_fmap fs.infds)) <= fs.maxFD /\ wfFS fs ==> + wfFS (openFileFS f fs md k) +Proof + rw[wfFS_def,openFileFS_def,liveFS_def] >> full_case_tac >> fs[openFile_def] >> cases_on`x` >> rw[] >> fs[MEM_MAP] >> res_tac >> fs[] >-(imp_res_tac ALOOKUP_MEM >-(qexists_tac`(File iname,x')` >> fs[])) >-(CASE_TAC >-(cases_on`y` >> fs[] >> PairCases_on`r` >> fs[] >> metis_tac[nextFD_NOT_MEM]) >-(metis_tac[])) - >-(fs[consistentFS_def,MEM_MAP] >> rw[] >> res_tac >> metis_tac[])); - -Theorem openFileFS_inode_tbl[simp] - `!f fs pos. (openFileFS f fs md pos).inode_tbl = fs.inode_tbl` - (rw[openFileFS_def] >> CASE_TAC >> cases_on`x` >> - fs[IO_fs_component_equality,openFile_def]); - -Theorem openFileFS_maxFD[simp] - `(openFileFS f fs md pos).maxFD = fs.maxFD` - (rw[openFileFS_def] + >-(fs[consistentFS_def,MEM_MAP] >> rw[] >> res_tac >> metis_tac[]) +QED + +Theorem openFileFS_inode_tbl[simp]: + !f fs pos. (openFileFS f fs md pos).inode_tbl = fs.inode_tbl +Proof + rw[openFileFS_def] >> CASE_TAC >> cases_on`x` >> + fs[IO_fs_component_equality,openFile_def] +QED + +Theorem openFileFS_maxFD[simp]: + (openFileFS f fs md pos).maxFD = fs.maxFD +Proof + rw[openFileFS_def] \\ CASE_TAC \\ CASE_TAC \\ fs[openFile_def] - \\ rw[]); - -Theorem openFileFS_fupd_numchars - `!s fs k ll. openFileFS s (fs with numchars := ll) md k = - (openFileFS s fs md k with numchars := ll)` - (rw[openFileFS_def,openFile_fupd_numchars] >> rpt CASE_TAC); - -Theorem IS_SOME_get_file_content_openFileFS_nextFD - `!fs f off md. consistentFS fs ∧ inFS_fname fs f ∧ nextFD fs ≤ fs.maxFD - ⇒ IS_SOME (get_file_content (openFileFS f fs md off) (nextFD fs)) ` - (rw[get_file_content_def] + \\ rw[] +QED + +Theorem openFileFS_fupd_numchars: + !s fs k ll. openFileFS s (fs with numchars := ll) md k = + (openFileFS s fs md k with numchars := ll) +Proof + rw[openFileFS_def,openFile_fupd_numchars] >> rpt CASE_TAC +QED + +Theorem IS_SOME_get_file_content_openFileFS_nextFD: + !fs f off md. consistentFS fs ∧ inFS_fname fs f ∧ nextFD fs ≤ fs.maxFD + ⇒ IS_SOME (get_file_content (openFileFS f fs md off) (nextFD fs)) +Proof + rw[get_file_content_def] \\ imp_res_tac inFS_fname_ALOOKUP_EXISTS \\ fs[] - \\ imp_res_tac ALOOKUP_inFS_fname_openFileFS_nextFD \\ simp[]); - -Theorem ADELKEY_nextFD_openFileFS[simp] - `nextFD fs <= fs.maxFD ⇒ - ADELKEY (nextFD fs) (openFileFS f fs md off).infds = fs.infds` - (rw[openFileFS_def] + \\ imp_res_tac ALOOKUP_inFS_fname_openFileFS_nextFD \\ simp[] +QED + +Theorem ADELKEY_nextFD_openFileFS[simp]: + nextFD fs <= fs.maxFD ⇒ + ADELKEY (nextFD fs) (openFileFS f fs md off).infds = fs.infds +Proof + rw[openFileFS_def] \\ CASE_TAC \\ TRY CASE_TAC \\ simp[ADELKEY_unchanged,nextFD_NOT_MEM,MEM_MAP,EXISTS_PROD] \\ fs[openFile_def] \\ rw[] - \\ rw[ADELKEY_def,FILTER_EQ_ID,EVERY_MEM,FORALL_PROD,nextFD_NOT_MEM]); + \\ rw[ADELKEY_def,FILTER_EQ_ID,EVERY_MEM,FORALL_PROD,nextFD_NOT_MEM] +QED -Theorem openFileFS_ADELKEY_nextFD - `nextFD fs ≤ fs.maxFD ⇒ - openFileFS f fs md off with infds updated_by ADELKEY (nextFD fs) = fs` - (rw[IO_fs_component_equality,ADELKEY_nextFD_openFileFS]); +Theorem openFileFS_ADELKEY_nextFD: + nextFD fs ≤ fs.maxFD ⇒ + openFileFS f fs md off with infds updated_by ADELKEY (nextFD fs) = fs +Proof + rw[IO_fs_component_equality,ADELKEY_nextFD_openFileFS] +QED (* forwardFD: like bumpFD but leave numchars *) @@ -702,79 +869,103 @@ val forwardFD_def = Define` forwardFD fs fd n = fs with infds updated_by AFUPDKEY fd (I ## I ## (+) n)`; -Theorem forwardFD_const[simp] - `(forwardFD fs fd n).files = fs.files ∧ +Theorem forwardFD_const[simp]: + (forwardFD fs fd n).files = fs.files ∧ (forwardFD fs fd n).inode_tbl = fs.inode_tbl ∧ (forwardFD fs fd n).numchars = fs.numchars ∧ - (forwardFD fs fd n).maxFD = fs.maxFD` - (rw[forwardFD_def]); - -Theorem forwardFD_o - `forwardFD (forwardFD fs fd n) fd m = forwardFD fs fd (n+m)` - (rw[forwardFD_def,IO_fs_component_equality,AFUPDKEY_o] + (forwardFD fs fd n).maxFD = fs.maxFD +Proof + rw[forwardFD_def] +QED + +Theorem forwardFD_o: + forwardFD (forwardFD fs fd n) fd m = forwardFD fs fd (n+m) +Proof + rw[forwardFD_def,IO_fs_component_equality,AFUPDKEY_o] \\ AP_THM_TAC \\ AP_TERM_TAC - \\ simp[FUN_EQ_THM,FORALL_PROD]); + \\ simp[FUN_EQ_THM,FORALL_PROD] +QED -Theorem forwardFD_0[simp] - `forwardFD fs fd 0 = fs` - (rw[forwardFD_def,IO_fs_component_equality] +Theorem forwardFD_0[simp]: + forwardFD fs fd 0 = fs +Proof + rw[forwardFD_def,IO_fs_component_equality] \\ match_mp_tac AFUPDKEY_unchanged - \\ simp[FORALL_PROD]); - -Theorem forwardFD_numchars - `forwardFD (fs with numchars := ll) fd n = forwardFD fs fd n with numchars := ll` - (rw[forwardFD_def]); - -Theorem liveFS_forwardFD[simp] - `liveFS (forwardFD fs fd n) = liveFS fs` - (rw[liveFS_def]); - -Theorem MAP_FST_forwardFD_infds[simp] - `MAP FST (forwardFD fs fd n).infds = MAP FST fs.infds` - (rw[forwardFD_def]); - -Theorem validFD_forwardFD[simp] - `validFD fd (forwardFD fs fd n)= validFD fd fs` - (rw[validFD_def]); - -Theorem wfFS_forwardFD[simp] - `wfFS (forwardFD fs fd n) = wfFS fs` - (rw[wfFS_def,consistentFS_def] + \\ simp[FORALL_PROD] +QED + +Theorem forwardFD_numchars: + forwardFD (fs with numchars := ll) fd n = forwardFD fs fd n with numchars := ll +Proof + rw[forwardFD_def] +QED + +Theorem liveFS_forwardFD[simp]: + liveFS (forwardFD fs fd n) = liveFS fs +Proof + rw[liveFS_def] +QED + +Theorem MAP_FST_forwardFD_infds[simp]: + MAP FST (forwardFD fs fd n).infds = MAP FST fs.infds +Proof + rw[forwardFD_def] +QED + +Theorem validFD_forwardFD[simp]: + validFD fd (forwardFD fs fd n)= validFD fd fs +Proof + rw[validFD_def] +QED + +Theorem wfFS_forwardFD[simp]: + wfFS (forwardFD fs fd n) = wfFS fs +Proof + rw[wfFS_def,consistentFS_def] \\ rw[forwardFD_def,AFUPDKEY_ALOOKUP] \\ rw[EQ_IMP_THM] \\ res_tac \\ fs[] \\ FULL_CASE_TAC \\ fs[] \\ FULL_CASE_TAC \\ fs[] - \\ Cases_on`x` \\ fs[]); + \\ Cases_on`x` \\ fs[] +QED -Theorem get_file_content_forwardFD[simp] - `!fs fd c pos n. +Theorem get_file_content_forwardFD[simp]: + !fs fd c pos n. get_file_content (forwardFD fs fd n) fd = - OPTION_MAP (I ## (+) n) (get_file_content fs fd)` - (rw[get_file_content_def,forwardFD_def,AFUPDKEY_ALOOKUP] + OPTION_MAP (I ## (+) n) (get_file_content fs fd) +Proof + rw[get_file_content_def,forwardFD_def,AFUPDKEY_ALOOKUP] \\ CASE_TAC \\ fs[] \\ pairarg_tac \\ fs[] \\ pairarg_tac \\ fs[] \\ rw[] - \\ Cases_on`ALOOKUP fs.inode_tbl ino` \\ fs[]); - -Theorem bumpFD_forwardFD - `bumpFD fd fs n = forwardFD fs fd n with numchars := THE (LTL fs.numchars)` - (rw[bumpFD_def,forwardFD_def]); - -Theorem fastForwardFD_forwardFD - `get_file_content fs fd = SOME (content,pos) ∧ pos + n ≤ LENGTH content ⇒ - fastForwardFD (forwardFD fs fd n) fd = fastForwardFD fs fd` - (rw[fastForwardFD_def,get_file_content_def,forwardFD_def,AFUPDKEY_ALOOKUP] + \\ Cases_on`ALOOKUP fs.inode_tbl ino` \\ fs[] +QED + +Theorem bumpFD_forwardFD: + bumpFD fd fs n = forwardFD fs fd n with numchars := THE (LTL fs.numchars) +Proof + rw[bumpFD_def,forwardFD_def] +QED + +Theorem fastForwardFD_forwardFD: + get_file_content fs fd = SOME (content,pos) ∧ pos + n ≤ LENGTH content ⇒ + fastForwardFD (forwardFD fs fd n) fd = fastForwardFD fs fd +Proof + rw[fastForwardFD_def,get_file_content_def,forwardFD_def,AFUPDKEY_ALOOKUP] \\ rw[] \\ pairarg_tac \\ fs[] \\ pairarg_tac \\ fs[libTheory.the_def] \\ fs[IO_fs_component_equality,AFUPDKEY_o] \\ match_mp_tac AFUPDKEY_eq - \\ simp[MAX_DEF]); + \\ simp[MAX_DEF] +QED -Theorem forwardFD_ADELKEY_same - `forwardFD fs fd n with infds updated_by ADELKEY fd = fs with infds updated_by ADELKEY fd` - (rw[forwardFD_def,IO_fs_component_equality]); +Theorem forwardFD_ADELKEY_same: + forwardFD fs fd n with infds updated_by ADELKEY fd = fs with infds updated_by ADELKEY fd +Proof + rw[forwardFD_def,IO_fs_component_equality] +QED (* lineFD: the next line *) @@ -795,12 +986,14 @@ val linesFD_def = Define` MAP (λx. x ++ "\n") (splitlines (DROP pos content))`; -Theorem linesFD_nil_lineFD_NONE - `linesFD fs fd = [] ⇔ lineFD fs fd = NONE` - (rw[lineFD_def,linesFD_def] +Theorem linesFD_nil_lineFD_NONE: + linesFD fs fd = [] ⇔ lineFD fs fd = NONE +Proof + rw[lineFD_def,linesFD_def] \\ CASE_TAC \\ fs[] \\ CASE_TAC \\ fs[] - \\ pairarg_tac \\ fs[DROP_NIL]); + \\ pairarg_tac \\ fs[DROP_NIL] +QED val lines_of_def = Define ` @@ -819,10 +1012,11 @@ val all_lines_def = Define ` all_lines fs fname = all_lines_inode fs (File (THE(ALOOKUP fs.files fname)))` -Theorem concat_lines_of - `!s. concat (lines_of s) = s ∨ - concat (lines_of s) = s ^ str #"\n"` - (rw[lines_of_def] \\ +Theorem concat_lines_of: + !s. concat (lines_of s) = s ∨ + concat (lines_of s) = s ^ str #"\n" +Proof + rw[lines_of_def] \\ `s = implode (explode s)` by fs [explode_implode] \\ qabbrev_tac `ls = explode s` \\ pop_assum kall_tac \\ rveq \\ Induct_on`splitlines ls` \\ rw[] \\ @@ -846,25 +1040,32 @@ Theorem concat_lines_of AP_TERM_TAC \\ rw[] \\ Cases_on`LENGTH h < LENGTH ls` \\ fs[IS_PREFIX_APPEND,DROP_APPEND,ADD1,DROP_LENGTH_TOO_LONG] \\ - qpat_x_assum`strlit [] = _`mp_tac \\ EVAL_TAC )); - -Theorem concat_all_lines - `concat (all_lines fs fname) = implode (THE (ALOOKUP fs.inode_tbl (File (THE (ALOOKUP fs.files fname))))) ∨ - concat (all_lines fs fname) = implode (THE (ALOOKUP fs.inode_tbl (File (THE (ALOOKUP fs.files fname))))) ^ str #"\n"` - (fs [all_lines_def,concat_lines_of]); - -Theorem all_lines_with_numchars - `all_lines (fs with numchars := ns) = all_lines fs` - (rw[FUN_EQ_THM,all_lines_def]); - -Theorem linesFD_openFileFS_nextFD - `consistentFS fs ∧ inFS_fname fs f ∧ nextFD fs ≤ fs.maxFD ⇒ - linesFD (openFileFS f fs md 0) (nextFD fs) = MAP explode (all_lines fs f)` - (rw[linesFD_def,get_file_content_def,ALOOKUP_inFS_fname_openFileFS_nextFD] + qpat_x_assum`strlit [] = _`mp_tac \\ EVAL_TAC ) +QED + +Theorem concat_all_lines: + concat (all_lines fs fname) = implode (THE (ALOOKUP fs.inode_tbl (File (THE (ALOOKUP fs.files fname))))) ∨ + concat (all_lines fs fname) = implode (THE (ALOOKUP fs.inode_tbl (File (THE (ALOOKUP fs.files fname))))) ^ str #"\n" +Proof + fs [all_lines_def,concat_lines_of] +QED + +Theorem all_lines_with_numchars: + all_lines (fs with numchars := ns) = all_lines fs +Proof + rw[FUN_EQ_THM,all_lines_def] +QED + +Theorem linesFD_openFileFS_nextFD: + consistentFS fs ∧ inFS_fname fs f ∧ nextFD fs ≤ fs.maxFD ⇒ + linesFD (openFileFS f fs md 0) (nextFD fs) = MAP explode (all_lines fs f) +Proof + rw[linesFD_def,get_file_content_def,ALOOKUP_inFS_fname_openFileFS_nextFD] \\ rw[all_lines_def,lines_of_def] \\ imp_res_tac inFS_fname_ALOOKUP_EXISTS \\ imp_res_tac ALOOKUP_inFS_fname_openFileFS_nextFD - \\ fs[MAP_MAP_o,o_DEF,GSYM mlstringTheory.implode_STRCAT]); + \\ fs[MAP_MAP_o,o_DEF,GSYM mlstringTheory.implode_STRCAT] +QED (* lineForwardFD: seek past the next line *) @@ -878,9 +1079,10 @@ val lineForwardFD_def = Define` forwardFD fs fd (LENGTH l + if NULL r then 0 else 1) else fs`; -Theorem fastForwardFD_lineForwardFD[simp] - `fastForwardFD (lineForwardFD fs fd) fd = fastForwardFD fs fd` - (rw[fastForwardFD_def,lineForwardFD_def] +Theorem fastForwardFD_lineForwardFD[simp]: + fastForwardFD (lineForwardFD fs fd) fd = fastForwardFD fs fd +Proof + rw[fastForwardFD_def,lineForwardFD_def] \\ TOP_CASE_TAC \\ fs[libTheory.the_def] \\ TOP_CASE_TAC \\ fs[libTheory.the_def] \\ TOP_CASE_TAC \\ fs[libTheory.the_def] @@ -894,21 +1096,25 @@ Theorem fastForwardFD_lineForwardFD[simp] \\ imp_res_tac SPLITP_JOIN \\ pop_assum(mp_tac o Q.AP_TERM`LENGTH`) \\ simp[SUB_RIGHT_EQ] - \\ rw[MAX_DEF,NULL_EQ] \\ fs[]); - -Theorem IS_SOME_get_file_content_lineForwardFD[simp] - `IS_SOME (get_file_content (lineForwardFD fs fd) fd) = - IS_SOME (get_file_content fs fd)` - (rw[lineForwardFD_def] + \\ rw[MAX_DEF,NULL_EQ] \\ fs[] +QED + +Theorem IS_SOME_get_file_content_lineForwardFD[simp]: + IS_SOME (get_file_content (lineForwardFD fs fd) fd) = + IS_SOME (get_file_content fs fd) +Proof + rw[lineForwardFD_def] \\ CASE_TAC \\ simp[] \\ CASE_TAC \\ simp[] \\ CASE_TAC \\ simp[] - \\ pairarg_tac \\ simp[]); - -Theorem lineFD_NONE_lineForwardFD_fastForwardFD - `lineFD fs fd = NONE ⇒ - lineForwardFD fs fd = fastForwardFD fs fd` - (rw[lineFD_def,lineForwardFD_def,fastForwardFD_def,get_file_content_def] + \\ pairarg_tac \\ simp[] +QED + +Theorem lineFD_NONE_lineForwardFD_fastForwardFD: + lineFD fs fd = NONE ⇒ + lineForwardFD fs fd = fastForwardFD fs fd +Proof + rw[lineFD_def,lineForwardFD_def,fastForwardFD_def,get_file_content_def] \\ fs[libTheory.the_def] \\ pairarg_tac \\ fs[libTheory.the_def] \\ rveq \\ fs[libTheory.the_def] @@ -917,13 +1123,15 @@ Theorem lineFD_NONE_lineForwardFD_fastForwardFD \\ match_mp_tac (GSYM AFUPDKEY_unchanged) \\ simp[MAX_DEF] ) \\ rw[] \\ fs[forwardFD_def,libTheory.the_def] - \\ pairarg_tac \\ fs[]); + \\ pairarg_tac \\ fs[] +QED -Theorem linesFD_cons_imp - `linesFD fs fd = ln::ls ⇒ +Theorem linesFD_cons_imp: + linesFD fs fd = ln::ls ⇒ lineFD fs fd = SOME ln ∧ - linesFD (lineForwardFD fs fd) fd = ls` - (simp[linesFD_def,lineForwardFD_def] + linesFD (lineForwardFD fs fd) fd = ls +Proof + simp[linesFD_def,lineForwardFD_def] \\ CASE_TAC \\ CASE_TAC \\ strip_tac \\ rename1`_ = SOME (content,off)` @@ -949,14 +1157,16 @@ Theorem linesFD_cons_imp \\ imp_res_tac splitlines_CONS_FST_SPLITP \\ rfs[] \\ IF_CASES_TAC \\ fs[] \\ rw[] \\ fs[SPLITP_NIL_SND_EVERY] - \\ rveq \\ fs[DROP_LENGTH_TOO_LONG]); + \\ rveq \\ fs[DROP_LENGTH_TOO_LONG] +QED -Theorem linesFD_lineForwardFD - `linesFD (lineForwardFD fs fd) fd' = +Theorem linesFD_lineForwardFD: + linesFD (lineForwardFD fs fd) fd' = if fd = fd' then DROP 1 (linesFD fs fd) - else linesFD fs fd'` - (rw[linesFD_def,lineForwardFD_def] + else linesFD fs fd' +Proof + rw[linesFD_def,lineForwardFD_def] >- ( CASE_TAC \\ fs[] \\ CASE_TAC \\ fs[] @@ -978,11 +1188,13 @@ Theorem linesFD_lineForwardFD \\ pairarg_tac \\ fs[] \\ simp[get_file_content_def] \\ simp[forwardFD_def,AFUPDKEY_ALOOKUP] - \\ CASE_TAC \\ fs[]); + \\ CASE_TAC \\ fs[] +QED -Theorem lineForwardFD_forwardFD - `∀fs fd. ∃n. lineForwardFD fs fd = forwardFD fs fd n` - (rw[forwardFD_def,lineForwardFD_def] +Theorem lineForwardFD_forwardFD: + ∀fs fd. ∃n. lineForwardFD fs fd = forwardFD fs fd n +Proof + rw[forwardFD_def,lineForwardFD_def] \\ CASE_TAC >- ( qexists_tac`0` @@ -998,19 +1210,22 @@ Theorem lineForwardFD_forwardFD qexists_tac`0` \\ simp[IO_fs_component_equality] \\ match_mp_tac (GSYM AFUPDKEY_unchanged) - \\ simp[FORALL_PROD] )); + \\ simp[FORALL_PROD] ) +QED -Theorem get_file_content_lineForwardFD_forwardFD - `∀fs fd. get_file_content fs fd = SOME (x,pos) ⇒ +Theorem get_file_content_lineForwardFD_forwardFD: + ∀fs fd. get_file_content fs fd = SOME (x,pos) ⇒ lineForwardFD fs fd = forwardFD fs fd (LENGTH(FST(SPLITP((=)#"\n")(DROP pos x))) + - if NULL(SND(SPLITP((=)#"\n")(DROP pos x))) then 0 else 1)` - (simp[forwardFD_def,lineForwardFD_def] + if NULL(SND(SPLITP((=)#"\n")(DROP pos x))) then 0 else 1) +Proof + simp[forwardFD_def,lineForwardFD_def] \\ ntac 3 strip_tac \\ pairarg_tac \\ fs[] \\ reverse IF_CASES_TAC \\ fs[DROP_LENGTH_TOO_LONG,SPLITP] \\ rw[IO_fs_component_equality] \\ match_mp_tac (GSYM AFUPDKEY_unchanged) - \\ simp[FORALL_PROD] ); + \\ simp[FORALL_PROD] +QED (* Property ensuring that standard streams are correctly opened *) val STD_streams_def = Define @@ -1021,16 +1236,17 @@ val STD_streams_def = Define (∀fd md off. ALOOKUP fs.infds fd = SOME (UStream(strlit "stdout"),md,off) ⇔ fd = 1 ∧ md = WriteMode ∧ off = LENGTH out) ∧ (∀fd md off. ALOOKUP fs.infds fd = SOME (UStream(strlit "stderr"),md,off) ⇔ fd = 2 ∧ md = WriteMode ∧ off = LENGTH err)`; -Theorem STD_streams_fsupdate - `! fs fd k pos c. +Theorem STD_streams_fsupdate: + ! fs fd k pos c. ((fd = 1 \/ fd = 2) ==> LENGTH c = pos) /\ (* (fd >= 3 ==> (FST(THE (ALOOKUP fs.infds fd)) <> UStream(strlit "stdout") /\ FST(THE (ALOOKUP fs.infds fd)) <> UStream(strlit "stderr"))) /\ *) STD_streams fs ==> - STD_streams (fsupdate fs fd k pos c)` - (rw[STD_streams_def,fsupdate_def] + STD_streams (fsupdate fs fd k pos c) +Proof + rw[STD_streams_def,fsupdate_def] \\ CASE_TAC \\ fs[] >- metis_tac[] \\ CASE_TAC \\ fs[AFUPDKEY_ALOOKUP] \\ qmatch_goalsub_abbrev_tac`out' = SOME _ ∧ (err' = SOME _ ∧ _)` @@ -1041,30 +1257,36 @@ Theorem STD_streams_fsupdate \\ unabbrev_all_tac \\ rw[] \\ fs[] \\ rw[] \\ TOP_CASE_TAC \\ fs[] \\ rw[] \\ rfs[] \\ rw[] \\ rfs[PAIR_MAP] - \\ metis_tac[NOT_SOME_NONE,SOME_11,PAIR,FST]); + \\ metis_tac[NOT_SOME_NONE,SOME_11,PAIR,FST] +QED -Theorem STD_streams_openFileFS - `!fs s k. STD_streams fs ==> STD_streams (openFileFS s fs md k)` - (rw[STD_streams_def,openFileFS_files] >> +Theorem STD_streams_openFileFS: + !fs s k. STD_streams fs ==> STD_streams (openFileFS s fs md k) +Proof + rw[STD_streams_def,openFileFS_files] >> map_every qexists_tac[`inp`,`out`,`err`] >> fs[openFileFS_def] >> rpt(CASE_TAC >> fs[]) >> fs[openFile_def,IO_fs_component_equality] >> qpat_x_assum`_::_ = _`(assume_tac o SYM) \\ fs[] \\ - rw[] \\ metis_tac[ALOOKUP_MEM,nextFD_NOT_MEM,PAIR]); + rw[] \\ metis_tac[ALOOKUP_MEM,nextFD_NOT_MEM,PAIR] +QED -Theorem STD_streams_numchars - `!fs ll. STD_streams fs = STD_streams (fs with numchars := ll)` - (fs[STD_streams_def]); +Theorem STD_streams_numchars: + !fs ll. STD_streams fs = STD_streams (fs with numchars := ll) +Proof + fs[STD_streams_def] +QED val lemma = Q.prove( `UStream (strlit "stdin") ≠ UStream (strlit "stdout") ∧ UStream (strlit "stdin") ≠ UStream (strlit "stderr") ∧ UStream (strlit "stdout") ≠ UStream (strlit "stderr")`,rw[]); -Theorem STD_streams_forwardFD - `fd ≠ 1 ∧ fd ≠ 2 ⇒ - (STD_streams (forwardFD fs fd n) = STD_streams fs)` - (rw[STD_streams_def,forwardFD_def,AFUPDKEY_ALOOKUP] +Theorem STD_streams_forwardFD: + fd ≠ 1 ∧ fd ≠ 2 ⇒ + (STD_streams (forwardFD fs fd n) = STD_streams fs) +Proof + rw[STD_streams_def,forwardFD_def,AFUPDKEY_ALOOKUP] \\ Cases_on`fd = 0` >- ( EQ_TAC \\ rw[] @@ -1085,16 +1307,20 @@ Theorem STD_streams_forwardFD \\ EQ_TAC \\ rw[] \\ fsrw_tac[ETA_ss][option_case_eq,PULL_EXISTS,PAIR_MAP] \\ qexists_tac`inp` \\ rw[] - \\ metis_tac[PAIR,SOME_11,FST,SND,lemma]); - -Theorem STD_streams_bumpFD - `fd ≠ 1 ∧ fd ≠ 2 ⇒ - (STD_streams (bumpFD fd fs n) = STD_streams fs)` - (rw[bumpFD_forwardFD,GSYM STD_streams_numchars,STD_streams_forwardFD]); - -Theorem STD_streams_nextFD - `STD_streams fs ⇒ 3 ≤ nextFD fs` - (rw[STD_streams_def,nextFD_def,MEM_MAP,EXISTS_PROD] + \\ metis_tac[PAIR,SOME_11,FST,SND,lemma] +QED + +Theorem STD_streams_bumpFD: + fd ≠ 1 ∧ fd ≠ 2 ⇒ + (STD_streams (bumpFD fd fs n) = STD_streams fs) +Proof + rw[bumpFD_forwardFD,GSYM STD_streams_numchars,STD_streams_forwardFD] +QED + +Theorem STD_streams_nextFD: + STD_streams fs ⇒ 3 ≤ nextFD fs +Proof + rw[STD_streams_def,nextFD_def,MEM_MAP,EXISTS_PROD] \\ numLib.LEAST_ELIM_TAC \\ rw[] >- ( CCONTR_TAC \\ fs[] @@ -1107,22 +1333,26 @@ Theorem STD_streams_nextFD \\ Cases_on`n=0` >- metis_tac[ALOOKUP_MEM] \\ Cases_on`n=1` >- metis_tac[ALOOKUP_MEM] \\ Cases_on`n=2` >- metis_tac[ALOOKUP_MEM] - \\ decide_tac); - -Theorem STD_streams_lineForwardFD - `fd ≠ 1 ∧ fd ≠ 2 ⇒ - (STD_streams (lineForwardFD fs fd) ⇔ STD_streams fs)` - (rw[lineForwardFD_def] + \\ decide_tac +QED + +Theorem STD_streams_lineForwardFD: + fd ≠ 1 ∧ fd ≠ 2 ⇒ + (STD_streams (lineForwardFD fs fd) ⇔ STD_streams fs) +Proof + rw[lineForwardFD_def] \\ CASE_TAC \\ fs[] \\ CASE_TAC \\ fs[] \\ pairarg_tac \\ fs[] \\ IF_CASES_TAC \\ fs[] - \\ simp[STD_streams_forwardFD]); - -Theorem STD_streams_fastForwardFD - `fd ≠ 1 ∧ fd ≠ 2 ⇒ - (STD_streams (fastForwardFD fs fd) ⇔ STD_streams fs)` - (rw[fastForwardFD_def] + \\ simp[STD_streams_forwardFD] +QED + +Theorem STD_streams_fastForwardFD: + fd ≠ 1 ∧ fd ≠ 2 ⇒ + (STD_streams (fastForwardFD fs fd) ⇔ STD_streams fs) +Proof + rw[fastForwardFD_def] \\ Cases_on`ALOOKUP fs.infds fd` \\ fs[libTheory.the_def] \\ pairarg_tac \\ fs[] \\ Cases_on`ALOOKUP fs.inode_tbl ino` \\ fs[libTheory.the_def] @@ -1133,37 +1363,48 @@ Theorem STD_streams_fastForwardFD metis_tac[SOME_11,PAIR,FST,SND,lemma] ) \\ qmatch_assum_rename_tac`ALOOKUP _ ino = SOME r` \\ qexists_tac`if fd = 0 then MAX (LENGTH r) off else inp` \\ rw[EXISTS_PROD] \\ - metis_tac[SOME_11,PAIR,FST,SND,lemma] ); + metis_tac[SOME_11,PAIR,FST,SND,lemma] +QED val get_mode_def = Define` get_mode fs fd = OPTION_MAP (FST o SND) (ALOOKUP fs.infds fd)`; -Theorem get_mode_with_numchars - `get_mode (fs with numchars := ll) fd = get_mode fs fd` - (rw[get_mode_def]); - -Theorem get_mode_with_files - `get_mode (fs with files := n) fd = get_mode fs fd` - (rw[get_mode_def]); - -Theorem get_mode_forwardFD[simp] - `get_mode (forwardFD fs fd n) fd' = get_mode fs fd'` - (rw[get_mode_def,forwardFD_def,AFUPDKEY_ALOOKUP] - \\ TOP_CASE_TAC \\ rw[]); - -Theorem get_mode_lineForwardFD[simp] - `get_mode (lineForwardFD fs fd) fd' = get_mode fs fd'` - (qspecl_then[`fs`,`fd`]strip_assume_tac lineForwardFD_forwardFD - \\ rw[]); +Theorem get_mode_with_numchars: + get_mode (fs with numchars := ll) fd = get_mode fs fd +Proof + rw[get_mode_def] +QED + +Theorem get_mode_with_files: + get_mode (fs with files := n) fd = get_mode fs fd +Proof + rw[get_mode_def] +QED + +Theorem get_mode_forwardFD[simp]: + get_mode (forwardFD fs fd n) fd' = get_mode fs fd' +Proof + rw[get_mode_def,forwardFD_def,AFUPDKEY_ALOOKUP] + \\ TOP_CASE_TAC \\ rw[] +QED + +Theorem get_mode_lineForwardFD[simp]: + get_mode (lineForwardFD fs fd) fd' = get_mode fs fd' +Proof + qspecl_then[`fs`,`fd`]strip_assume_tac lineForwardFD_forwardFD + \\ rw[] +QED -Theorem STD_streams_get_mode - `STD_streams fs ⇒ +Theorem STD_streams_get_mode: + STD_streams fs ⇒ (get_mode fs 0 = SOME ReadMode) ∧ (get_mode fs 1 = SOME WriteMode) ∧ - (get_mode fs 2 = SOME WriteMode)` - (rw[STD_streams_def, get_mode_def, EXISTS_PROD] - \\ metis_tac[]); + (get_mode fs 2 = SOME WriteMode) +Proof + rw[STD_streams_def, get_mode_def, EXISTS_PROD] + \\ metis_tac[] +QED val _ = overload_on("hard_link", ``λfs fn1 fn2. ∃ino. ALOOKUP fs.files fn1 = SOME ino ∧ diff --git a/basis/fsFFIScript.sml b/basis/fsFFIScript.sml index c6cde9d42c..60a40138cb 100644 --- a/basis/fsFFIScript.sml +++ b/basis/fsFFIScript.sml @@ -37,9 +37,11 @@ val _ = Datatype` val IO_fs_component_equality = theorem"IO_fs_component_equality"; -Theorem with_same_numchars - `fs with numchars := fs.numchars = fs` - (rw[IO_fs_component_equality]); +Theorem with_same_numchars: + fs with numchars := fs.numchars = fs +Proof + rw[IO_fs_component_equality] +QED val get_file_content_def = Define` get_file_content fs fd = @@ -311,36 +313,48 @@ val encode_def = zDefine` (encode_files fs.files)) (Num fs.maxFD)` -Theorem encode_inode_11[simp] - `!x y. encode_inode x = encode_inode y <=> x = y` - (Cases \\ Cases_on `y` \\ fs [encode_inode_def,explode_11]); +Theorem encode_inode_11[simp]: + !x y. encode_inode x = encode_inode y <=> x = y +Proof + Cases \\ Cases_on `y` \\ fs [encode_inode_def,explode_11] +QED -Theorem encode_inode_tbl_11[simp] - `!xs ys. encode_inode_tbl xs = encode_inode_tbl ys <=> xs = ys` - (rw [] \\ eq_tac \\ rw [encode_inode_tbl_def] +Theorem encode_inode_tbl_11[simp]: + !xs ys. encode_inode_tbl xs = encode_inode_tbl ys <=> xs = ys +Proof + rw [] \\ eq_tac \\ rw [encode_inode_tbl_def] \\ drule encode_list_11 - \\ fs [encode_pair_def,FORALL_PROD,encode_inode_def]); - -Theorem encode_mode_11[simp] - `∀x y. encode_mode x = encode_mode y ⇔ x = y` - (Cases \\ Cases \\ rw[encode_mode_def]); - -Theorem encode_fds_11[simp] - `!xs ys. encode_fds xs = encode_fds ys <=> xs = ys` - (rw [] \\ eq_tac \\ rw [encode_fds_def] + \\ fs [encode_pair_def,FORALL_PROD,encode_inode_def] +QED + +Theorem encode_mode_11[simp]: + ∀x y. encode_mode x = encode_mode y ⇔ x = y +Proof + Cases \\ Cases \\ rw[encode_mode_def] +QED + +Theorem encode_fds_11[simp]: + !xs ys. encode_fds xs = encode_fds ys <=> xs = ys +Proof + rw [] \\ eq_tac \\ rw [encode_fds_def] \\ drule encode_list_11 - \\ fs [encode_pair_def,FORALL_PROD,encode_inode_def]); + \\ fs [encode_pair_def,FORALL_PROD,encode_inode_def] +QED -Theorem encode_files_11[simp] - `!xs ys. encode_files xs = encode_files ys <=> xs = ys` - (rw [] \\ eq_tac \\ rw [encode_files_def] +Theorem encode_files_11[simp]: + !xs ys. encode_files xs = encode_files ys <=> xs = ys +Proof + rw [] \\ eq_tac \\ rw [encode_files_def] \\ drule encode_list_11 - \\ fs [encode_pair_def,FORALL_PROD]); - -Theorem encode_11[simp] - `!x y. encode x = encode y <=> x = y` - (fs [encode_def] \\ rw [] \\ eq_tac \\ rw [] - \\ fs [IO_fs_component_equality]); + \\ fs [encode_pair_def,FORALL_PROD] +QED + +Theorem encode_11[simp]: + !x y. encode x = encode y <=> x = y +Proof + fs [encode_def] \\ rw [] \\ eq_tac \\ rw [] + \\ fs [IO_fs_component_equality] +QED val decode_encode = new_specification("decode_encode",["decode"], prove(``?decode. !cls. decode (encode cls) = SOME cls``, diff --git a/basis/mlbasicsProgScript.sml b/basis/mlbasicsProgScript.sml index b305c3b13f..ec67a2c393 100644 --- a/basis/mlbasicsProgScript.sml +++ b/basis/mlbasicsProgScript.sml @@ -67,22 +67,28 @@ fun prove_ref_spec op_name = xsimpl \\ fs [UNIT_TYPE_def] (* -Theorem ref_spec - `!xv. app (p:'ffi ffi_proj) ^(fetch_v "op ref" (get_ml_prog_state ())) [xv] - emp (POSTv rv. rv ~~> xv)` - (prove_ref_spec "op ref"); +Theorem ref_spec: + !xv. app (p:'ffi ffi_proj) ^(fetch_v "op ref" (get_ml_prog_state ())) [xv] + emp (POSTv rv. rv ~~> xv) +Proof + prove_ref_spec "op ref" +QED *) -Theorem deref_spec - `!xv. app (p:'ffi ffi_proj) ^(fetch_v "op !" (get_ml_prog_state ())) [rv] - (rv ~~> xv) (POSTv yv. cond (xv = yv) * rv ~~> xv)` - (prove_ref_spec "op !"); +Theorem deref_spec: + !xv. app (p:'ffi ffi_proj) ^(fetch_v "op !" (get_ml_prog_state ())) [rv] + (rv ~~> xv) (POSTv yv. cond (xv = yv) * rv ~~> xv) +Proof + prove_ref_spec "op !" +QED -Theorem assign_spec - `!rv xv yv. +Theorem assign_spec: + !rv xv yv. app (p:'ffi ffi_proj) ^(fetch_v "op :=" (get_ml_prog_state ())) [rv; yv] - (rv ~~> xv) (POSTv v. cond (UNIT_TYPE () v) * rv ~~> yv)` - (prove_ref_spec "op :="); + (rv ~~> xv) (POSTv v. cond (UNIT_TYPE () v) * rv ~~> yv) +Proof + prove_ref_spec "op :=" +QED val bool_toString_def = Define ` bool_toString b = if b then strlit "True" else strlit"False"`; diff --git a/basis/pure/mlintScript.sml b/basis/pure/mlintScript.sml index 5ac6025433..d0f6e25f10 100644 --- a/basis/pure/mlintScript.sml +++ b/basis/pure/mlintScript.sml @@ -9,9 +9,11 @@ val toChar_def = Define` toChar digit = if digit < 10 then CHR (ORD #"0" + digit) else CHR (ORD #"A" + digit - 10)`; -Theorem toChar_HEX - `d < 16 ⇒ (toChar d = HEX d)` - (strip_tac \\ rpt(fs[Once NUMERAL_LESS_THM] >- EVAL_TAC)); +Theorem toChar_HEX: + d < 16 ⇒ (toChar d = HEX d) +Proof + strip_tac \\ rpt(fs[Once NUMERAL_LESS_THM] >- EVAL_TAC) +QED (* This should be smaller than the maximum smallint supported by the compiler (see bvl_to_bviTheory for that. 2**28-1?) Also it must be a power of the radix @@ -29,9 +31,11 @@ val zero_pad_def = Define` (zero_pad 0 acc = acc) ∧ (zero_pad (SUC n) acc = zero_pad n (#"0" :: acc))`; -Theorem zero_pad_thm - `∀n acc. zero_pad n acc = REPLICATE n #"0" ++ acc` - (Induct \\ rw[GSYM SNOC_REPLICATE,zero_pad_def] \\ EVAL_TAC); +Theorem zero_pad_thm: + ∀n acc. zero_pad n acc = REPLICATE n #"0" ++ acc +Proof + Induct \\ rw[GSYM SNOC_REPLICATE,zero_pad_def] \\ EVAL_TAC +QED val simple_toChars_def = Define` simple_toChars pad i acc = @@ -39,10 +43,11 @@ val simple_toChars_def = Define` else simple_toChars (pad-1) (i DIV 10) (toChar (i MOD 10) :: acc)`; val simple_toChars_ind = theorem"simple_toChars_ind"; -Theorem simple_toChars_thm - `∀pad i acc. simple_toChars pad i acc = - REPLICATE (pad - LENGTH (num_to_dec_string i)) #"0" ++ num_to_dec_string i ++ acc` - (ho_match_mp_tac simple_toChars_ind \\ +Theorem simple_toChars_thm: + ∀pad i acc. simple_toChars pad i acc = + REPLICATE (pad - LENGTH (num_to_dec_string i)) #"0" ++ num_to_dec_string i ++ acc +Proof + ho_match_mp_tac simple_toChars_ind \\ rw[ASCIInumbersTheory.num_to_dec_string_def, ASCIInumbersTheory.n2s_def] \\ rw[Once simple_toChars_def] @@ -51,7 +56,8 @@ Theorem simple_toChars_thm \\ rw[Once numposrepTheory.n2l_def,SimpRHS] \\ match_mp_tac toChar_HEX \\ `i MOD 10 < 10` by simp[MOD_LESS] - \\ rw[]); + \\ rw[] +QED val toChars_def = tDefine"toChars"` toChars chunk rest acc = @@ -66,11 +72,12 @@ val toChars_def = tDefine"toChars"` \\ rw[maxSmall_DEC_def,DIV_LT_X] \\ fs[maxSmall_DEC_def]); val toChars_ind = theorem"toChars_ind"; -Theorem toChars_thm - `∀chunk rest acc. chunk < maxSmall_DEC ⇒ +Theorem toChars_thm: + ∀chunk rest acc. chunk < maxSmall_DEC ⇒ (toChars chunk rest acc = - num_to_dec_string (rest * maxSmall_DEC + chunk) ++ acc)` - (ho_match_mp_tac toChars_ind + num_to_dec_string (rest * maxSmall_DEC + chunk) ++ acc) +Proof + ho_match_mp_tac toChars_ind \\ rw[] \\ rw[Once toChars_def] \\ rw[simple_toChars_thm,REPLICATE] @@ -87,7 +94,8 @@ Theorem toChars_thm \\ pop_assum (SUBST_ALL_TAC) \\ simp[GSYM MAP_REVERSE,REVERSE_REPLICATE,map_replicate] \\ qspecl_then[`maxSmall_DEC`,`chunk`]mp_tac DIV_MULT - \\ simp[]); + \\ simp[] +QED val toString_def = Define` toString i = @@ -97,9 +105,10 @@ val toString_def = Define` implode ((if i < 0i then "~" else "")++ (toChars (Num (ABS i) MOD maxSmall_DEC) (Num (ABS i) DIV maxSmall_DEC) ""))`; -Theorem toString_thm - `toString i = implode ((if i < 0i then "~" else "") ++ num_to_dec_string (Num (ABS i)))` - (rw[toString_def] +Theorem toString_thm: + toString i = implode ((if i < 0i then "~" else "") ++ num_to_dec_string (Num (ABS i))) +Proof + rw[toString_def] >- (`F` by intLib.COOPER_TAC) >- ( rw[str_def] @@ -114,7 +123,8 @@ Theorem toString_thm \\ `0 < maxSmall_DEC` by EVAL_TAC \\ simp[toChars_thm] \\ qspec_then`maxSmall_DEC`mp_tac DIVISION - \\ simp[] )); + \\ simp[] ) +QED val num_to_str_def = Define `num_to_str (n:num) = toString (&n)`; val _ = overload_on("toString",``num_to_str``); @@ -143,11 +153,13 @@ val fromChar_def = Define` | _ => NONE`; (* Equivalence between the safe and unsafe versions of fromChar *) -Theorem fromChar_eq_unsafe - `∀char. isDigit char ⇒ fromChar char = SOME (fromChar_unsafe char)` - (Cases_on `char` \\ rw [isDigit_def, fromChar_def, fromChar_unsafe_def] +Theorem fromChar_eq_unsafe: + ∀char. isDigit char ⇒ fromChar char = SOME (fromChar_unsafe char) +Proof + Cases_on `char` \\ rw [isDigit_def, fromChar_def, fromChar_unsafe_def] \\ rpt (pop_assum (ASSUME_TAC o CONV_RULE (BINOP_CONV (TRY_CONV numLib.num_CONV))) - \\ fs [LE])); + \\ fs [LE]) +QED val fromChars_range_unsafe_def = Define` fromChars_range_unsafe l 0 str = 0 ∧ @@ -161,15 +173,17 @@ val fromChars_range_def = Define` head = fromChar (strsub str (l + n)) in OPTION_MAP2 $+ rest head`; -Theorem fromChars_range_eq_unsafe - `∀str l r. EVERY isDigit str ∧ l + r <= STRLEN str ⇒ +Theorem fromChars_range_eq_unsafe: + ∀str l r. EVERY isDigit str ∧ l + r <= STRLEN str ⇒ fromChars_range l r (strlit str) = - SOME (fromChars_range_unsafe l r (strlit str))` - (Induct_on `r` + SOME (fromChars_range_unsafe l r (strlit str)) +Proof + Induct_on `r` \\ rw [fromChars_range_def , fromChars_range_unsafe_def , fromChar_eq_unsafe - , EVERY_EL]); + , EVERY_EL] +QED val fromChars_unsafe_def = tDefine "fromChars_unsafe" ` fromChars_unsafe 0 str = 0n ∧ (* Shouldn't happend *) @@ -195,10 +209,11 @@ val fromChars_def = tDefine "fromChars" ` (wf_rel_tac `measure FST` \\ rw [padLen_DEC_eq]); val fromChars_ind = theorem"fromChars_ind" -Theorem fromChars_eq_unsafe - `∀n s. EVERY isDigit (explode s) ∧ n ≤ strlen s ⇒ - fromChars n s = SOME (fromChars_unsafe n s)` - (let val tactics = [fromChars_def +Theorem fromChars_eq_unsafe: + ∀n s. EVERY isDigit (explode s) ∧ n ≤ strlen s ⇒ + fromChars n s = SOME (fromChars_unsafe n s) +Proof + let val tactics = [fromChars_def , fromChars_unsafe_def , fromChars_range_eq_unsafe , strlen_def @@ -208,7 +223,8 @@ Theorem fromChars_eq_unsafe \\ rw [] \\ Cases_on `str'` \\ rw tactics \\ fs tactics - end); + end +QED val fromString_unsafe_def = Define` fromString_unsafe str = @@ -241,40 +257,47 @@ val fromNatString_def = Define ` | SOME i => if 0 <= i then SOME (Num i) else NONE`; (* fromString auxiliar lemmas *) -Theorem fromChars_range_unsafe_0_substring_thm - `∀m r s. r ≤ m ⇒ +Theorem fromChars_range_unsafe_0_substring_thm: + ∀m r s. r ≤ m ⇒ fromChars_range_unsafe 0 r s = - fromChars_range_unsafe 0 r (substring s 0 m)` - (Induct_on `r` \\ rw [fromChars_range_unsafe_def, strsub_substring_0_thm]); + fromChars_range_unsafe 0 r (substring s 0 m) +Proof + Induct_on `r` \\ rw [fromChars_range_unsafe_def, strsub_substring_0_thm] +QED -Theorem fromChars_range_unsafe_split - `∀m n s. m ≠ 0 ∧ m < n +Theorem fromChars_range_unsafe_split: + ∀m n s. m ≠ 0 ∧ m < n ⇒ fromChars_range_unsafe 0 n s = 10 ** m * fromChars_range_unsafe 0 (n - m) s - + fromChars_range_unsafe (n - m) m s` - (Induct_on `m` + + fromChars_range_unsafe (n - m) m s +Proof + Induct_on `m` >- rw [] >- (`∀m k w. 10**SUC m*k + 10*w = 10*(10**m*k + w)` by simp [EXP] \\ Cases_on `n` \\ rw [fromChars_range_unsafe_def] \\ Cases_on `m` - \\ rw [fromChars_range_unsafe_def])); + \\ rw [fromChars_range_unsafe_def]) +QED (* fromString proofs *) -Theorem fromChar_unsafe_thm - `∀ h. isDigit h ⇒ fromChar_unsafe h = num_from_dec_string [h]` - (let +Theorem fromChar_unsafe_thm: + ∀ h. isDigit h ⇒ fromChar_unsafe h = num_from_dec_string [h] +Proof + let val num_conv = ASSUME_TAC o CONV_RULE (BINOP_CONV (TRY_CONV numLib.num_CONV)) in Cases_on `h` \\ rw [isDigit_def] \\ rpt (pop_assum num_conv >> fs [LE, fromChar_unsafe_def]) - end); + end +QED -Theorem fromChars_range_unsafe_thm - `∀str. EVERY isDigit str ⇒ +Theorem fromChars_range_unsafe_thm: + ∀str. EVERY isDigit str ⇒ fromChars_range_unsafe 0 (STRLEN str) (strlit str) = - num_from_dec_string str` - (recInduct SNOC_INDUCT + num_from_dec_string str +Proof + recInduct SNOC_INDUCT \\ rw [fromChars_range_unsafe_def ,ASCIInumbersTheory.num_from_dec_string_def] \\ `isDigit x` by fs [EVERY_SNOC] @@ -294,27 +317,31 @@ Theorem fromChars_range_unsafe_thm , SEG_0_SNOC |> SPEC ``LENGTH l`` |> SPEC ``l : 'a list`` |> SIMP_RULE std_ss [SEG_LENGTH_ID]] - \\ fs [ASCIInumbersTheory.s2n_def,EVERY_SNOC]); + \\ fs [ASCIInumbersTheory.s2n_def,EVERY_SNOC] +QED -Theorem fromChars_range_unsafe_eq - `∀n s. n ≤ (strlen s) ⇒ fromChars_unsafe n s = fromChars_range_unsafe 0 n s` - (recInduct fromChars_unsafe_ind +Theorem fromChars_range_unsafe_eq: + ∀n s. n ≤ (strlen s) ⇒ fromChars_unsafe n s = fromChars_range_unsafe 0 n s +Proof + recInduct fromChars_unsafe_ind \\ rw [fromChars_unsafe_def , fromChars_range_unsafe_def , padLen_DEC_eq , maxSmall_DEC_def , fromChars_range_unsafe_split |> SPEC ``8n`` |> SIMP_RULE std_ss [] - |> GSYM]); + |> GSYM] +QED -Theorem fromString_unsafe_thm - `∀str. (HD str ≠ #"~" ⇒ EVERY isDigit str) ∧ +Theorem fromString_unsafe_thm: + ∀str. (HD str ≠ #"~" ⇒ EVERY isDigit str) ∧ (HD str = #"~" ⇒ EVERY isDigit (DROP 1 str)) ⇒ fromString_unsafe (strlit str) = if HD str = #"~" then ~&num_from_dec_string (DROP 1 str) - else &num_from_dec_string str` - (rw [fromString_unsafe_def + else &num_from_dec_string str +Proof + rw [fromString_unsafe_def , fromChars_range_unsafe_eq , fromChars_range_unsafe_thm , substring_def, SEG_TAKE_DROP @@ -323,18 +350,20 @@ Theorem fromString_unsafe_thm |> ISPEC ``DROP 1 str' : string`` |> REWRITE_RULE [prove(``STRLEN (DROP 1 str') = STRLEN str' - 1``, rw [])]] - \\ rename1`s ≠ ""` \\ Cases_on `s` \\ fs[]); + \\ rename1`s ≠ ""` \\ Cases_on `s` \\ fs[] +QED -Theorem fromString_thm - `∀str. (HD str ≠ #"~" ∧ HD str ≠ #"-" ∧ HD str ≠ #"+" ⇒ EVERY isDigit str) ∧ +Theorem fromString_thm: + ∀str. (HD str ≠ #"~" ∧ HD str ≠ #"-" ∧ HD str ≠ #"+" ⇒ EVERY isDigit str) ∧ (HD str = #"~" ∨ HD str = #"-" ∨ HD str = #"+" ⇒ EVERY isDigit (DROP 1 str)) ⇒ fromString (strlit str) = SOME if HD str = #"~" ∨ HD str = #"-" then ~&num_from_dec_string (DROP 1 str) else if HD str = #"+" then &num_from_dec_string (DROP 1 str) - else &num_from_dec_string str` - (rw [fromString_def + else &num_from_dec_string str +Proof + rw [fromString_def , fromChars_eq_unsafe , fromChars_range_unsafe_eq , fromChars_range_unsafe_thm @@ -344,14 +373,16 @@ Theorem fromString_thm |> ISPEC ``DROP 1 str' : string`` |> REWRITE_RULE [prove(``STRLEN (DROP 1 str') = STRLEN str' - 1``, rw [])]] - \\ rename1`s ≠ ""` \\ Cases_on `s` \\ fs[]); + \\ rename1`s ≠ ""` \\ Cases_on `s` \\ fs[] +QED val fromString_eq_unsafe = save_thm("fromString_eq_unsafe", fromString_thm |> SIMP_RULE std_ss [GSYM fromString_unsafe_thm]); -Theorem fromString_toString_Num - `0 ≤ n ⇒ fromString (strlit (num_to_dec_string (Num n))) = SOME n` - (strip_tac +Theorem fromString_toString_Num: + 0 ≤ n ⇒ fromString (strlit (num_to_dec_string (Num n))) = SOME n +Proof + strip_tac \\ DEP_REWRITE_TAC[fromString_thm] \\ qspec_then`Num n`assume_tac EVERY_isDigit_num_to_dec_string \\ Cases_on`num_to_dec_string (Num n)` \\ fs[] @@ -361,11 +392,13 @@ Theorem fromString_toString_Num \\ simp[FUN_EQ_THM] \\ disch_then(qspec_then`Num n`mp_tac) \\ simp[] - \\ simp[integerTheory.INT_OF_NUM]); + \\ simp[integerTheory.INT_OF_NUM] +QED -Theorem fromString_toString[simp] - `!i:int. fromString (toString i) = SOME i` - (rw [toString_thm,implode_def] +Theorem fromString_toString[simp]: + !i:int. fromString (toString i) = SOME i +Proof + rw [toString_thm,implode_def] \\ qmatch_goalsub_abbrev_tac `strlit sss` \\ qspec_then `sss` mp_tac fromString_thm THEN1 @@ -381,25 +414,31 @@ Theorem fromString_toString[simp] \\ CCONTR_TAC \\ fs [] \\ rveq \\ fs [isDigit_def]) \\ fs [Abbr `sss`,EVERY_isDigit_num_to_dec_string] \\ fs [toString_thm,ASCIInumbersTheory.toNum_toString] - \\ rw [] \\ last_x_assum mp_tac \\ intLib.COOPER_TAC); - -Theorem fromNatString_toString[simp] - `!n:num. fromNatString (toString n) = SOME n` - (fs [num_to_str_def,fromNatString_def]); - -Theorem fromChar_IS_SOME_IFF - `IS_SOME (fromChar c) ⇔ isDigit c` - (simp[fromChar_def] + \\ rw [] \\ last_x_assum mp_tac \\ intLib.COOPER_TAC +QED + +Theorem fromNatString_toString[simp]: + !n:num. fromNatString (toString n) = SOME n +Proof + fs [num_to_str_def,fromNatString_def] +QED + +Theorem fromChar_IS_SOME_IFF: + IS_SOME (fromChar c) ⇔ isDigit c +Proof + simp[fromChar_def] \\ rpt(IF_CASES_TAC \\ rveq >- EVAL_TAC) \\ rw[] \\ EVAL_TAC \\ Cases_on`c` \\ simp[] - \\ fs[]); + \\ fs[] +QED -Theorem fromChars_range_IS_SOME_IFF - `∀s x y. (x + y ≤ strlen s) ⇒ (IS_SOME (fromChars_range x y s) ⇔ EVERY isDigit (TAKE y (DROP x (explode s))))` - (Induct_on`y` +Theorem fromChars_range_IS_SOME_IFF: + ∀s x y. (x + y ≤ strlen s) ⇒ (IS_SOME (fromChars_range x y s) ⇔ EVERY isDigit (TAKE y (DROP x (explode s)))) +Proof + Induct_on`y` \\ rw[fromChars_range_def] \\ fs[IS_SOME_EXISTS] \\ rw[] \\ fs[PULL_EXISTS] @@ -421,11 +460,13 @@ Theorem fromChars_range_IS_SOME_IFF \\ simp[GSYM IS_SOME_EXISTS] \\ simp[fromChar_IS_SOME_IFF] \\ first_x_assum(qspec_then`y`mp_tac) - \\ simp[]); + \\ simp[] +QED -Theorem fromChars_IS_SOME_IFF - `∀n s. n ≤ strlen s ⇒ (IS_SOME (fromChars n s) ⇔ EVERY isDigit (TAKE n (explode s)))` - (recInduct fromChars_ind +Theorem fromChars_IS_SOME_IFF: + ∀n s. n ≤ strlen s ⇒ (IS_SOME (fromChars n s) ⇔ EVERY isDigit (TAKE n (explode s))) +Proof + recInduct fromChars_ind \\ rw[fromChars_def] \\ fs[fromChars_range_IS_SOME_IFF] \\ fs[IS_SOME_EXISTS, PULL_EXISTS] @@ -445,14 +486,17 @@ Theorem fromChars_IS_SOME_IFF \\ strip_tac \\ fs[] \\ qspecl_then[`str'`,`SUC v2 - padLen_DEC`,`padLen_DEC`]mp_tac fromChars_range_IS_SOME_IFF \\ simp[IS_SOME_EXISTS] - \\ fs[EVERY_MEM, MEM_EL, PULL_EXISTS, LENGTH_TAKE_EQ, EL_TAKE, EL_DROP]); + \\ fs[EVERY_MEM, MEM_EL, PULL_EXISTS, LENGTH_TAKE_EQ, EL_TAKE, EL_DROP] +QED -Theorem fromString_EQ_NONE - `~isDigit c /\ c <> #"+" /\ c <> #"~" /\ c <> #"-" ==> - fromString (implode (STRING c x)) = NONE` - (rw [fromString_def,implode_def,strsub_def] +Theorem fromString_EQ_NONE: + ~isDigit c /\ c <> #"+" /\ c <> #"~" /\ c <> #"-" ==> + fromString (implode (STRING c x)) = NONE +Proof + rw [fromString_def,implode_def,strsub_def] \\ `(SUC (STRLEN x)) <= strlen (strlit (STRING c x))` by fs [strlen_def] - \\ drule fromChars_IS_SOME_IFF \\ fs [explode_def]); + \\ drule fromChars_IS_SOME_IFF \\ fs [explode_def] +QED (* this formulation avoids a comparsion using = for better performance *) val int_cmp_def = Define ` diff --git a/basis/pure/mllistScript.sml b/basis/pure/mllistScript.sml index ab7e064118..4d86a3ae20 100644 --- a/basis/pure/mllistScript.sml +++ b/basis/pure/mllistScript.sml @@ -42,11 +42,12 @@ val MAPI_thm_gen = Q.prove ( match_mp_tac MAPi_CONG \\ rw[] ); -Theorem MAPI_thm - `!f l. MAPi f l = mapi f 0 l` - (rw [(MAPI_thm_gen |> Q.SPECL[`f`,`l`,`0`] +Theorem MAPI_thm: + !f l. MAPi f l = mapi f 0 l +Proof + rw [(MAPI_thm_gen |> Q.SPECL[`f`,`l`,`0`] |> SIMP_RULE (srw_ss()++ETA_ss) [])] -); +QED val mapPartial_def = Define` (mapPartial f [] = []) /\ @@ -54,21 +55,24 @@ val mapPartial_def = Define` NONE => mapPartial f t |(SOME x) => x::mapPartial f t)`; -Theorem mapPartial_thm - `!f l. mapPartial f l = MAP THE (FILTER IS_SOME (MAP f l))` - (Induct_on `l` \\ rw [mapPartial_def] \\ Cases_on `f h` \\ rw [THE_DEF] \\ fs [IS_SOME_DEF] -); - -Theorem index_find_thm - `!x y. OPTION_MAP SND (INDEX_FIND x f l) = OPTION_MAP SND (INDEX_FIND y f l)` - (Induct_on`l` \\ rw[INDEX_FIND_def] -); - -Theorem FIND_thm - `(FIND f [] = NONE) ∧ - (∀h t. FIND f (h::t) = if f h then SOME h else FIND f t)` - (rw[FIND_def,INDEX_FIND_def,index_find_thm] -); +Theorem mapPartial_thm: + !f l. mapPartial f l = MAP THE (FILTER IS_SOME (MAP f l)) +Proof + Induct_on `l` \\ rw [mapPartial_def] \\ Cases_on `f h` \\ rw [THE_DEF] \\ fs [IS_SOME_DEF] +QED + +Theorem index_find_thm: + !x y. OPTION_MAP SND (INDEX_FIND x f l) = OPTION_MAP SND (INDEX_FIND y f l) +Proof + Induct_on`l` \\ rw[INDEX_FIND_def] +QED + +Theorem FIND_thm: + (FIND f [] = NONE) ∧ + (∀h t. FIND f (h::t) = if f h then SOME h else FIND f t) +Proof + rw[FIND_def,INDEX_FIND_def,index_find_thm] +QED val partition_aux_def = Define` (partition_aux f [] pos neg = @@ -86,15 +90,17 @@ val partition_aux_thm = Q.prove( rw [partition_aux_def] ); -Theorem partition_pos_thm - `!f l. FST (partition f l) = FILTER f l` - (rw [partition_def, FILTER, partition_aux_thm] -); +Theorem partition_pos_thm: + !f l. FST (partition f l) = FILTER f l +Proof + rw [partition_def, FILTER, partition_aux_thm] +QED -Theorem partition_neg_thm - `!f l. SND (partition f l) = FILTER ($~ o f) l` - (rw [partition_def, FILTER, partition_aux_thm] -); +Theorem partition_neg_thm: + !f l. SND (partition f l) = FILTER ($~ o f) l +Proof + rw [partition_def, FILTER, partition_aux_thm] +QED val foldl_aux_def = Define` (foldl_aux f e n [] = e) /\ @@ -118,10 +124,11 @@ val foldli_aux_thm = Q.prove ( rw [ADD1] ); -Theorem foldli_thm - `!f e l. foldli f e l = FOLDRi (\n. f (LENGTH l - (SUC n))) e (REVERSE l)` - (rw [foldli_def, foldli_aux_thm] -); +Theorem foldli_thm: + !f e l. foldli f e l = FOLDRi (\n. f (LENGTH l - (SUC n))) e (REVERSE l) +Proof + rw [foldli_def, foldli_aux_thm] +QED (* these definitions are in A normal form in order to be able to prove CF specs about them @@ -142,19 +149,23 @@ val tabulate_aux_def = tDefine"tabulate_aux"` val tabulate_def = Define `tabulate n f = let l = [] in tabulate_aux 0 n f l`; -Theorem tabulate_aux_GENLIST - `∀n m f acc. tabulate_aux n m f acc = REVERSE acc ++ GENLIST (f o FUNPOW SUC n) (m-n)` - (recInduct(theorem"tabulate_aux_ind") \\ rw[] +Theorem tabulate_aux_GENLIST: + ∀n m f acc. tabulate_aux n m f acc = REVERSE acc ++ GENLIST (f o FUNPOW SUC n) (m-n) +Proof + recInduct(theorem"tabulate_aux_ind") \\ rw[] \\ rw[Once tabulate_aux_def] >- ( `m - n = 0` by simp[] \\ rw[] ) \\ Cases_on`m` \\ fs[] \\ rename1`SUC m - n` \\ `SUC m - n = SUC (m - n)` by simp[] \\ simp[GENLIST_CONS,FUNPOW,o_DEF,FUNPOW_SUC_PLUS] - \\ simp[ADD1]); + \\ simp[ADD1] +QED -Theorem tabulate_GENLIST - `!n. tabulate n f = GENLIST f n` - (rw[tabulate_def,tabulate_aux_GENLIST,FUNPOW_SUC_PLUS,o_DEF,ETA_AX]); +Theorem tabulate_GENLIST: + !n. tabulate n f = GENLIST f n +Proof + rw[tabulate_def,tabulate_aux_GENLIST,FUNPOW_SUC_PLUS,o_DEF,ETA_AX] +QED val collate_def = Define` (collate f [] [] = EQUAL) /\ @@ -167,44 +178,48 @@ val collate_def = Define` val collate_ind = theorem"collate_ind"; -Theorem collate_equal_thm - `!l. (!x. MEM x l ==> (f x x = EQUAL)) ==> (collate f l l = EQUAL)` - (Induct_on `l` \\ rw [collate_def] \\ rw [collate_def] -); - -Theorem collate_short_thm - `!f l1 l2. (!x. f x x = EQUAL) ∧ (l1 ≠ l2) /\ (l1 ≼ l2) ==> - (collate f l1 l2 = LESS)` - (ho_match_mp_tac collate_ind +Theorem collate_equal_thm: + !l. (!x. MEM x l ==> (f x x = EQUAL)) ==> (collate f l l = EQUAL) +Proof + Induct_on `l` \\ rw [collate_def] \\ rw [collate_def] +QED + +Theorem collate_short_thm: + !f l1 l2. (!x. f x x = EQUAL) ∧ (l1 ≠ l2) /\ (l1 ≼ l2) ==> + (collate f l1 l2 = LESS) +Proof + ho_match_mp_tac collate_ind \\ rw[collate_def] \\ fs[] -); +QED -Theorem collate_long_thm - `!f l1 l2. (!x. f x x = EQUAL) ∧ (l1 ≠ l2) /\ (l2 ≼ l1) ==> - (collate f l1 l2 = GREATER)` - (ho_match_mp_tac collate_ind +Theorem collate_long_thm: + !f l1 l2. (!x. f x x = EQUAL) ∧ (l1 ≠ l2) /\ (l2 ≼ l1) ==> + (collate f l1 l2 = GREATER) +Proof + ho_match_mp_tac collate_ind \\ rw[collate_def] \\ fs[] -); +QED val cpn_to_reln_def = Define` cpn_to_reln f x1 x2 = (f x1 x2 = LESS)`; -Theorem collate_cpn_reln_thm - `!f l1 l2. (!x1 x2. (f x1 x2 = EQUAL) <=> - (x1 = x2)) ==> (cpn_to_reln (collate f) l1 l2 = LLEX (cpn_to_reln f) l1 l2)` - (ho_match_mp_tac collate_ind \\ rw [collate_def, cpn_to_reln_def, LLEX_def] \\ +Theorem collate_cpn_reln_thm: + !f l1 l2. (!x1 x2. (f x1 x2 = EQUAL) <=> + (x1 = x2)) ==> (cpn_to_reln (collate f) l1 l2 = LLEX (cpn_to_reln f) l1 l2) +Proof + ho_match_mp_tac collate_ind \\ rw [collate_def, cpn_to_reln_def, LLEX_def] \\ first_assum (qspecl_then [`h1`, `h1`] (fn th => assume_tac (GSYM th))) \\ `(h1 = h1) = T` by DECIDE_TAC \\ rw[] \\`EQUAL ≠ LESS` by fs[] \\ rw[] -); +QED (* from std_preludeLib *) val LENGTH_AUX_def = Define ` (LENGTH_AUX [] n = (n:num)) /\ (LENGTH_AUX (x::xs) n = LENGTH_AUX xs (n+1))`; -Theorem LENGTH_AUX_THM - `!xs n. LENGTH_AUX xs n = LENGTH xs + n` - (Induct THEN ASM_SIMP_TAC std_ss [LENGTH_AUX_def,LENGTH,ADD1,AC ADD_COMM ADD_ASSOC]) +Theorem LENGTH_AUX_THM = Q.prove(` + !xs n. LENGTH_AUX xs n = LENGTH xs + n`, + Induct THEN ASM_SIMP_TAC std_ss [LENGTH_AUX_def,LENGTH,ADD1,AC ADD_COMM ADD_ASSOC]) |> Q.SPECL [`xs`,`0`] |> GSYM |> SIMP_RULE std_ss []; val _ = save_thm("list_compare_def", diff --git a/basis/pure/mlmapScript.sml b/basis/pure/mlmapScript.sml index fed8d70c5f..87b3f86607 100644 --- a/basis/pure/mlmapScript.sml +++ b/basis/pure/mlmapScript.sml @@ -69,21 +69,27 @@ val to_fmap_def = Define ` (* theorems *) -Theorem lookup_insert - `map_ok t ==> - lookup (insert t k1 v) k2 = if k1 = k2 then SOME v else lookup t k2` - (Cases_on `t` +Theorem lookup_insert: + map_ok t ==> + lookup (insert t k1 v) k2 = if k1 = k2 then SOME v else lookup t k2 +Proof + Cases_on `t` \\ fs [map_ok_def,balanced_mapTheory.lookup_insert,lookup_def,insert_def, comparisonTheory.TotOrder_imp_good_cmp] - \\ metis_tac [totoTheory.TotOrd]); + \\ metis_tac [totoTheory.TotOrd] +QED -Theorem cmp_of_insert[simp] - `cmp_of (insert t k v) = cmp_of t` - (Cases_on `t` \\ fs [insert_def,cmp_of_def]); +Theorem cmp_of_insert[simp]: + cmp_of (insert t k v) = cmp_of t +Proof + Cases_on `t` \\ fs [insert_def,cmp_of_def] +QED -Theorem cmp_of_empty[simp] - `cmp_of (empty cmp) = cmp` - (fs [empty_def,cmp_of_def]); +Theorem cmp_of_empty[simp]: + cmp_of (empty cmp) = cmp +Proof + fs [empty_def,cmp_of_def] +QED val fmap_FLOOKUP_EQ = prove( ``f1 = f2 <=> FLOOKUP f1 = FLOOKUP f2``, @@ -93,15 +99,18 @@ val fmap_FLOOKUP_EQ = prove( \\ first_x_assum (qspec_then `x` mp_tac) \\ rw [] \\ fs [IN_DEF]); -Theorem TotOrd_key_set[simp] - `TotOrd cmp ==> key_set cmp k = {k}` - (rw[key_set_def,EXTENSION] \\ metis_tac [totoTheory.TotOrd]); +Theorem TotOrd_key_set[simp]: + TotOrd cmp ==> key_set cmp k = {k} +Proof + rw[key_set_def,EXTENSION] \\ metis_tac [totoTheory.TotOrd] +QED -Theorem to_fmap_thm - `!t cmp. +Theorem to_fmap_thm: + !t cmp. TotOrd cmp ==> - to_fmap cmp t = MAP_KEYS (\x. {x}) (to_fmap (Map cmp t))` - (Induct \\ fs [to_fmap_def,balanced_mapTheory.to_fmap_def] + to_fmap cmp t = MAP_KEYS (\x. {x}) (to_fmap (Map cmp t)) +Proof + Induct \\ fs [to_fmap_def,balanced_mapTheory.to_fmap_def] \\ rw [] \\ rw [fmap_FLOOKUP_EQ,FUN_EQ_THM] \\ fs [FLOOKUP_UPDATE,FLOOKUP_FUNION] \\ qmatch_goalsub_abbrev_tac `MAP_KEYS ff` @@ -120,16 +129,20 @@ Theorem to_fmap_thm \\ rewrite_tac [GSYM (METIS_PROVE [] ``x = y /\ p <=> x = y /\ (y = x ==> p)``)] \\ Cases_on `y ∈ FDOM (to_fmap (Map cmp t))` \\ fs [] \\ Cases_on `y ∈ FDOM (to_fmap (Map cmp t'))` \\ fs [] - \\ fs [FLOOKUP_DEF,FAPPLY_FUPDATE_THM,FUNION_DEF]); - -Theorem empty_thm - `(map_ok (empty cmp) = TotOrd cmp) /\ to_fmap (empty cmp) = FEMPTY` - (fs [empty_def,map_ok_def,balanced_mapTheory.empty_thm, - to_fmap_def,balanced_mapTheory.empty_def,balanced_mapTheory.invariant_def]); - -Theorem MAP_KEYS_sing_set - `MAP_KEYS (λx. {x}) f1 = MAP_KEYS (λx. {x}) f2 <=> (f1 = f2)` - (eq_tac \\ fs [] \\ fs [fmap_FLOOKUP_EQ] + \\ fs [FLOOKUP_DEF,FAPPLY_FUPDATE_THM,FUNION_DEF] +QED + +Theorem empty_thm: + (map_ok (empty cmp) = TotOrd cmp) /\ to_fmap (empty cmp) = FEMPTY +Proof + fs [empty_def,map_ok_def,balanced_mapTheory.empty_thm, + to_fmap_def,balanced_mapTheory.empty_def,balanced_mapTheory.invariant_def] +QED + +Theorem MAP_KEYS_sing_set: + MAP_KEYS (λx. {x}) f1 = MAP_KEYS (λx. {x}) f2 <=> (f1 = f2) +Proof + eq_tac \\ fs [] \\ fs [fmap_FLOOKUP_EQ] \\ qmatch_goalsub_abbrev_tac `MAP_KEYS ff` \\ `!x. INJ ff x UNIV` by fs [INJ_DEF,Abbr`ff`] \\ simp [FUN_EQ_THM] \\ simp [FLOOKUP_MAP_KEYS] @@ -137,11 +150,13 @@ Theorem MAP_KEYS_sing_set \\ first_x_assum (qspec_then `{x}` mp_tac) \\ fs [] \\ `!f1 v. x = v /\ f1 v <=> x = v /\ f1 x` by metis_tac [] \\ fs [] \\ Cases_on `x ∈ FDOM f1` \\ fs [] - \\ Cases_on `x ∈ FDOM f2` \\ fs [FLOOKUP_DEF]); + \\ Cases_on `x ∈ FDOM f2` \\ fs [FLOOKUP_DEF] +QED -Theorem MAP_KEYS_sing_set_UPDATE - `MAP_KEYS (λx. {x}) f |+ ({k},v) = MAP_KEYS (λx. {x}) (f |+ (k,v))` - (fs [fmap_FLOOKUP_EQ] +Theorem MAP_KEYS_sing_set_UPDATE: + MAP_KEYS (λx. {x}) f |+ ({k},v) = MAP_KEYS (λx. {x}) (f |+ (k,v)) +Proof + fs [fmap_FLOOKUP_EQ] \\ qmatch_goalsub_abbrev_tac `MAP_KEYS ff` \\ `!x. INJ ff x UNIV` by fs [INJ_DEF,Abbr`ff`] \\ simp [FUN_EQ_THM] \\ simp [FLOOKUP_MAP_KEYS,FLOOKUP_UPDATE] @@ -153,13 +168,15 @@ Theorem MAP_KEYS_sing_set_UPDATE \\ once_rewrite_tac [METIS_PROVE [] ``x = y /\ p <=> x = y /\ (y = x ==> p)``] \\ simp [] \\ rewrite_tac [GSYM (METIS_PROVE [] ``x = y /\ p <=> x = y /\ (y = x ==> p)``)] - \\ Cases_on `y ∈ FDOM f` \\ fs [FLOOKUP_UPDATE]); + \\ Cases_on `y ∈ FDOM f` \\ fs [FLOOKUP_UPDATE] +QED -Theorem insert_thm - `map_ok t ==> +Theorem insert_thm: + map_ok t ==> map_ok (insert t k v) /\ - to_fmap (insert t k v) = (to_fmap t |+ (k, v))` - (Cases_on `t` + to_fmap (insert t k v) = (to_fmap t |+ (k, v)) +Proof + Cases_on `t` \\ strip_tac \\ conj_asm1_tac THEN1 @@ -169,11 +186,13 @@ Theorem insert_thm \\ fs [map_ok_def,insert_def] \\ imp_res_tac comparisonTheory.TotOrder_imp_good_cmp \\ imp_res_tac balanced_mapTheory.insert_thm - \\ rfs [to_fmap_thm,MAP_KEYS_sing_set_UPDATE,MAP_KEYS_sing_set]); + \\ rfs [to_fmap_thm,MAP_KEYS_sing_set_UPDATE,MAP_KEYS_sing_set] +QED -Theorem lookup_thm - `map_ok t ==> lookup t k = FLOOKUP (to_fmap t) k` - (Cases_on `t` +Theorem lookup_thm: + map_ok t ==> lookup t k = FLOOKUP (to_fmap t) k +Proof + Cases_on `t` \\ strip_tac \\ fs [map_ok_def,lookup_def] \\ imp_res_tac comparisonTheory.TotOrder_imp_good_cmp @@ -185,24 +204,28 @@ Theorem lookup_thm \\ fs [Abbr`ff`] \\ `!f1 v. k = v /\ f1 v <=> k = v /\ f1 k` by metis_tac [] \\ fs [] \\ Cases_on `k ∈ FDOM (to_fmap (Map f b))` \\ fs [] - \\ fs [FLOOKUP_DEF]); + \\ fs [FLOOKUP_DEF] +QED -Theorem MAP_FST_toAscList - `map_ok t ⇒ +Theorem MAP_FST_toAscList: + map_ok t ⇒ SORTED (λx y. cmp_of t x y = Less) (MAP FST (toAscList t)) ∧ - FDOM (to_fmap t) = set (MAP FST (toAscList t))` - (Cases_on `t` \\ fs [map_ok_def,lookup_def] \\ strip_tac + FDOM (to_fmap t) = set (MAP FST (toAscList t)) +Proof + Cases_on `t` \\ fs [map_ok_def,lookup_def] \\ strip_tac \\ imp_res_tac comparisonTheory.TotOrder_imp_good_cmp \\ imp_res_tac balanced_mapTheory.MAP_FST_toAscList \\ rfs [cmp_of_def,toAscList_def,to_fmap_thm,MAP_KEYS_def] \\ `(λx. {x}) = key_set f` by fs [FUN_EQ_THM] \\ fs [] \\ `(∀x y. key_set f x = key_set f y ⇔ x = y)` by fs [] \\ drule (GEN_ALL pred_setTheory.IMAGE_11) - \\ strip_tac \\ fs []); + \\ strip_tac \\ fs [] +QED -Theorem MEM_toAscList - `map_ok t /\ MEM (k,v) (toAscList t) ==> FLOOKUP (to_fmap t) k = SOME v` - (Cases_on `t` \\ fs [map_ok_def,lookup_def,toAscList_def] \\ strip_tac +Theorem MEM_toAscList: + map_ok t /\ MEM (k,v) (toAscList t) ==> FLOOKUP (to_fmap t) k = SOME v +Proof + Cases_on `t` \\ fs [map_ok_def,lookup_def,toAscList_def] \\ strip_tac \\ imp_res_tac comparisonTheory.TotOrder_imp_good_cmp \\ imp_res_tac balanced_mapTheory.MEM_toAscList \\ rfs [toAscList_def,to_fmap_thm] @@ -213,6 +236,7 @@ Theorem MEM_toAscList \\ fs [Abbr`ff`] \\ `!f1 v. k = v /\ f1 v <=> k = v /\ f1 k` by metis_tac [] \\ fs [] \\ Cases_on `k ∈ FDOM (to_fmap (Map f b))` \\ fs [] - \\ fs [FLOOKUP_DEF]); + \\ fs [FLOOKUP_DEF] +QED val _ = export_theory() diff --git a/basis/pure/mlstringScript.sml b/basis/pure/mlstringScript.sml index f1804a4148..5669bd839b 100644 --- a/basis/pure/mlstringScript.sml +++ b/basis/pure/mlstringScript.sml @@ -35,8 +35,11 @@ val substring_def = Define` val concat_def = Define` concat l = strlit (FLAT (MAP (λs. case s of strlit x => x) l))`; -Theorem concat_nil[simp] - `concat [] = strlit ""` (EVAL_TAC); +Theorem concat_nil[simp]: + concat [] = strlit "" +Proof +EVAL_TAC +QED val _ = export_rewrites["strlen_def","strsub_def"]; @@ -46,65 +49,88 @@ val explode_aux_def = Define` strsub s n :: (explode_aux s (n + 1) len))`; val _ = export_rewrites["explode_aux_def"]; -Theorem explode_aux_thm - `∀max n ls. +Theorem explode_aux_thm: + ∀max n ls. (n + max = LENGTH ls) ⇒ - (explode_aux (strlit ls) n max = DROP n ls)` - (Induct \\ rw[] \\ fs[LENGTH_NIL_SYM,DROP_LENGTH_TOO_LONG] + (explode_aux (strlit ls) n max = DROP n ls) +Proof + Induct \\ rw[] \\ fs[LENGTH_NIL_SYM,DROP_LENGTH_TOO_LONG] \\ match_mp_tac (GSYM rich_listTheory.DROP_EL_CONS) - \\ simp[]); + \\ simp[] +QED val explode_def = Define` explode s = explode_aux s 0 (strlen s)`; -Theorem explode_thm[simp] - `explode (strlit ls) = ls` - (rw[explode_def,SIMP_RULE std_ss [] explode_aux_thm]); - -Theorem explode_implode[simp] - `∀x. explode (implode x) = x` - (rw[implode_def]) - -Theorem implode_explode[simp] - `∀x. implode (explode x) = x` - (Cases >> rw[implode_def]) - -Theorem explode_11[simp] - `∀s1 s2. (explode s1 = explode s2) ⇔ (s1 = s2)` - (Cases >> Cases >> simp[]) - -Theorem implode_BIJ - `BIJ implode UNIV UNIV` - (rw[BIJ_IFF_INV] >> +Theorem explode_thm[simp]: + explode (strlit ls) = ls +Proof + rw[explode_def,SIMP_RULE std_ss [] explode_aux_thm] +QED + +Theorem explode_implode[simp]: + ∀x. explode (implode x) = x +Proof + rw[implode_def] +QED + +Theorem implode_explode[simp]: + ∀x. implode (explode x) = x +Proof + Cases >> rw[implode_def] +QED + +Theorem explode_11[simp]: + ∀s1 s2. (explode s1 = explode s2) ⇔ (s1 = s2) +Proof + Cases >> Cases >> simp[] +QED + +Theorem implode_BIJ: + BIJ implode UNIV UNIV +Proof + rw[BIJ_IFF_INV] >> qexists_tac`explode` >> rw[implode_explode, - explode_implode]) + explode_implode] +QED -Theorem explode_BIJ - `BIJ explode UNIV UNIV` - (rw[BIJ_IFF_INV] >> +Theorem explode_BIJ: + BIJ explode UNIV UNIV +Proof + rw[BIJ_IFF_INV] >> qexists_tac`implode` >> rw[implode_explode, - explode_implode]) - -Theorem LENGTH_explode[simp] - `LENGTH (explode s) = strlen s` - (Cases_on`s` \\ simp[]); - -Theorem concat_thm - `concat l = implode (FLAT (MAP explode l))` - (rw[concat_def,implode_def] \\ + explode_implode] +QED + +Theorem LENGTH_explode[simp]: + LENGTH (explode s) = strlen s +Proof + Cases_on`s` \\ simp[] +QED + +Theorem concat_thm: + concat l = implode (FLAT (MAP explode l)) +Proof + rw[concat_def,implode_def] \\ rpt (AP_TERM_TAC ORELSE AP_THM_TAC) \\ - rw[FUN_EQ_THM] \\ CASE_TAC \\ simp[]); + rw[FUN_EQ_THM] \\ CASE_TAC \\ simp[] +QED -Theorem strlen_implode[simp] - `strlen (implode s) = LENGTH s` (EVAL_TAC); +Theorem strlen_implode[simp]: + strlen (implode s) = LENGTH s +Proof +EVAL_TAC +QED -Theorem strlen_substring - `strlen (substring s i j) = if i + j <= strlen s then j +Theorem strlen_substring: + strlen (substring s i j) = if i + j <= strlen s then j else if i <= strlen s then strlen s - i - else 0` - (Cases_on`s` \\ rw[substring_def,LENGTH_SEG]); + else 0 +Proof + Cases_on`s` \\ rw[substring_def,LENGTH_SEG] +QED val extract_def = Define` extract s i opt = @@ -114,60 +140,81 @@ val extract_def = Define` SOME x => substring s i (MIN (strlen s - i) x) | NONE => substring s i (strlen s - i)`; -Theorem strlen_extract_le -`!s x y. strlen (extract s x y) <= strlen s - x` - (rw[extract_def] >> CASE_TAC >> fs[strlen_substring]); - -Theorem strsub_substring_0_thm - `∀m n l. m < n ⇒ strsub (substring l 0 n) m = strsub l m` - (Cases_on`l` \\ rw[strsub_def,substring_def] - \\ rw[SEG_TAKE_DROP,EL_TAKE]); - -Theorem substring_full[simp] - `substring s 0 (strlen s) = s` - (Cases_on`s` \\ rw[substring_def,SEG_LENGTH_ID]); - -Theorem substring_too_long - `strlen s <= i ==> substring s i j = strlit ""` - (Cases_on`s` \\ rw[substring_def,DROP_NIL] \\ - `j = 0` by decide_tac \\ fs[SEG]); +Theorem strlen_extract_le: + !s x y. strlen (extract s x y) <= strlen s - x +Proof + rw[extract_def] >> CASE_TAC >> fs[strlen_substring] +QED + +Theorem strsub_substring_0_thm: + ∀m n l. m < n ⇒ strsub (substring l 0 n) m = strsub l m +Proof + Cases_on`l` \\ rw[strsub_def,substring_def] + \\ rw[SEG_TAKE_DROP,EL_TAKE] +QED + +Theorem substring_full[simp]: + substring s 0 (strlen s) = s +Proof + Cases_on`s` \\ rw[substring_def,SEG_LENGTH_ID] +QED + +Theorem substring_too_long: + strlen s <= i ==> substring s i j = strlit "" +Proof + Cases_on`s` \\ rw[substring_def,DROP_NIL] \\ + `j = 0` by decide_tac \\ fs[SEG] +QED val strcat_def = Define`strcat s1 s2 = concat [s1; s2]` val _ = Parse.add_infix("^",480,Parse.LEFT) val _ = Parse.overload_on("^",``λx y. strcat x y``) -Theorem concat_cons - `concat (h::t) = strcat h (concat t)` - (rw[strcat_def,concat_def]); - -Theorem strcat_thm - `strcat s1 s2 = implode (explode s1 ++ explode s2)` - (rw[strcat_def,concat_def] - \\ CASE_TAC \\ rw[] \\ CASE_TAC \\ rw[implode_def]); - -Theorem strcat_assoc[simp] - `!s1 s2 s3. - s1 ^ (s2 ^ s3) = s1 ^ s2 ^ s3` - (rw[strcat_def,concat_def]); - -Theorem strcat_nil[simp] - `(strcat (strlit "") s = s) ∧ - (strcat s (strlit "") = s)` - (rw[strcat_def,concat_def] \\ CASE_TAC \\ rw[]); - -Theorem implode_STRCAT - `!l1 l2. - implode(STRCAT l1 l2) = implode l1 ^ implode l2` - (rw[implode_def, strcat_def, concat_def] -); - -Theorem explode_strcat[simp] - `explode (strcat s1 s2) = explode s1 ++ explode s2` - (rw[strcat_thm]); - -Theorem strlen_strcat[simp] - `strlen (strcat s1 s2) = strlen s1 + strlen s2` - (rw[strcat_thm]); +Theorem concat_cons: + concat (h::t) = strcat h (concat t) +Proof + rw[strcat_def,concat_def] +QED + +Theorem strcat_thm: + strcat s1 s2 = implode (explode s1 ++ explode s2) +Proof + rw[strcat_def,concat_def] + \\ CASE_TAC \\ rw[] \\ CASE_TAC \\ rw[implode_def] +QED + +Theorem strcat_assoc[simp]: + !s1 s2 s3. + s1 ^ (s2 ^ s3) = s1 ^ s2 ^ s3 +Proof + rw[strcat_def,concat_def] +QED + +Theorem strcat_nil[simp]: + (strcat (strlit "") s = s) ∧ + (strcat s (strlit "") = s) +Proof + rw[strcat_def,concat_def] \\ CASE_TAC \\ rw[] +QED + +Theorem implode_STRCAT: + !l1 l2. + implode(STRCAT l1 l2) = implode l1 ^ implode l2 +Proof + rw[implode_def, strcat_def, concat_def] +QED + +Theorem explode_strcat[simp]: + explode (strcat s1 s2) = explode s1 ++ explode s2 +Proof + rw[strcat_thm] +QED + +Theorem strlen_strcat[simp]: + strlen (strcat s1 s2) = strlen s1 + strlen s2 +Proof + rw[strcat_thm] +QED val concatWith_aux_def = tDefine "concatWith_aux"` (concatWith_aux s [] bool = implode []) /\ @@ -187,20 +234,26 @@ val concatWith_CONCAT_WITH_aux = Q.prove ( \\ Cases_on `l` \\ rw[concatWith_aux_def, explode_implode, strcat_thm, implode_def]) ); -Theorem concatWith_CONCAT_WITH - `!s l. CONCAT_WITH s l = explode (concatWith (implode s) (MAP implode l))` - (rw[concatWith_def, CONCAT_WITH_def, concatWith_CONCAT_WITH_aux] -); +Theorem concatWith_CONCAT_WITH: + !s l. CONCAT_WITH s l = explode (concatWith (implode s) (MAP implode l)) +Proof + rw[concatWith_def, CONCAT_WITH_def, concatWith_CONCAT_WITH_aux] +QED val str_def = Define` str (c: char) = implode [c]`; -Theorem explode_str[simp] - `explode (str c) = [c]` - (rw[str_def]) +Theorem explode_str[simp]: + explode (str c) = [c] +Proof + rw[str_def] +QED -Theorem strlen_str[simp] - `strlen (str c) = 1` (rw[str_def]); +Theorem strlen_str[simp]: + strlen (str c) = 1 +Proof +rw[str_def] +QED val translate_aux_def = Define` (translate_aux f s n 0 = []) /\ @@ -216,10 +269,11 @@ val translate_aux_thm = Q.prove ( rw [strsub_def, DROP_EL_CONS] ); -Theorem translate_thm - `!f s. translate f s = implode (MAP f (explode s))` - (rw [translate_def, translate_aux_thm] -); +Theorem translate_thm: + !f s. translate f s = implode (MAP f (explode s)) +Proof + rw [translate_def, translate_aux_thm] +QED val splitl_aux_def = tDefine"splitl_aux"` splitl_aux P s i = @@ -233,12 +287,13 @@ val splitl_aux_ind = theorem"splitl_aux_ind"; val splitl_def = Define` splitl P s = splitl_aux P s 0`; -Theorem splitl_aux_SPLITP - `∀P s i. +Theorem splitl_aux_SPLITP: + ∀P s i. splitl_aux P s i = (implode o ((++)(TAKE i (explode s))) ## implode) - (SPLITP ((~) o P) (DROP i (explode s)))` - (recInduct splitl_aux_ind + (SPLITP ((~) o P) (DROP i (explode s))) +Proof + recInduct splitl_aux_ind \\ rw[] \\ Cases_on`SPLITP P (DROP i (explode s))` \\ fs[] \\ simp[Once splitl_aux_def] @@ -272,12 +327,15 @@ Theorem splitl_aux_SPLITP \\ Cases_on`s` \\ rw[extract_def,substring_def,implode_def] \\ fs[MIN_DEF] \\ simp[TAKE_SEG] \\ rfs[] - \\ rfs[DROP_SEG]); + \\ rfs[DROP_SEG] +QED -Theorem splitl_SPLITL - `splitl P s = (implode ## implode) (SPLITL P (explode s))` - (rw[splitl_def,splitl_aux_SPLITP,SPLITL_def] - \\ Cases_on`SPLITP((~)o P)(explode s)` \\ fs[]); +Theorem splitl_SPLITL: + splitl P s = (implode ## implode) (SPLITL P (explode s)) +Proof + rw[splitl_def,splitl_aux_SPLITP,SPLITL_def] + \\ Cases_on`SPLITP((~)o P)(explode s)` \\ fs[] +QED val tokens_aux_def = Define` (tokens_aux f s [] n 0 = []) /\ @@ -305,21 +363,23 @@ val tokens_aux_filter = Q.prove ( Cases_on `ss` \\ rw [tokens_aux_def, DROP_EL_CONS, concat_cons, strcat_thm, implode_def] ); -Theorem tokens_filter - `!f s. concat (tokens f s) = implode (FILTER ($~ o f) (explode s))` - (rw [tokens_def, tokens_aux_filter] -); +Theorem tokens_filter: + !f s. concat (tokens f s) = implode (FILTER ($~ o f) (explode s)) +Proof + rw [tokens_def, tokens_aux_filter] +QED -Theorem TOKENS_eq_tokens_aux - `!P ls ss n len. (n + len = LENGTH (explode ls)) ==> +Theorem TOKENS_eq_tokens_aux: + !P ls ss n len. (n + len = LENGTH (explode ls)) ==> (MAP explode (tokens_aux P ls ss n len) = case ss of | (h::t) => if (len <> 0) /\ ($~ (P (EL n (explode ls)))) then (REVERSE (h::t) ++ HD (TOKENS P (DROP n (explode ls))))::TL (TOKENS P (DROP n (explode ls))) else if (len <> 0) then REVERSE (h::t)::(TOKENS P (DROP n (explode ls))) else [REVERSE(h::t)] - | [] => (TOKENS P (DROP n (explode ls))))` - (ho_match_mp_tac tokens_aux_ind \\ rw[] \\ Cases_on `s` + | [] => (TOKENS P (DROP n (explode ls)))) +Proof + ho_match_mp_tac tokens_aux_ind \\ rw[] \\ Cases_on `s` \\ rw[explode_thm, tokens_aux_def, TOKENS_def, implode_def, strlen_def, strsub_def] \\ fs[strsub_def, DROP_LENGTH_TOO_LONG, TOKENS_def] >-(rw[EQ_SYM_EQ, Once DROP_EL_CONS] \\ rw[TOKENS_def] @@ -363,7 +423,8 @@ Theorem TOKENS_eq_tokens_aux \\ pairarg_tac \\ fs[NULL_EQ] \\ rw[] \\ fs[SPLITP] \\ rfs[] \\ rw[TOKENS_def]) \\(rw[DROP_EL_CONS, DROP_LENGTH_TOO_LONG, TOKENS_def] \\ pairarg_tac \\ fs[NULL_EQ] \\ rw[] \\ fs[SPLITP] \\ rfs[] \\ rw[TOKENS_def] - \\ pairarg_tac \\ fs[NULL_EQ] \\ rw[] \\ fs[SPLITP] \\ rfs[] \\ metis_tac[TL])); + \\ pairarg_tac \\ fs[NULL_EQ] \\ rw[] \\ fs[SPLITP] \\ rfs[] \\ metis_tac[TL]) +QED (* >> TRY ( recogniser (e.g., rename1_tac or qmatch_goalsub_rename_tac ...) >> @@ -375,10 +436,11 @@ Theorem TOKENS_eq_tokens_aux *) -Theorem TOKENS_eq_tokens - `!P ls.(MAP explode (tokens P ls) = TOKENS P (explode ls))` - (Cases_on `ls` \\ rw[tokens_def, TOKENS_eq_tokens_aux] -); +Theorem TOKENS_eq_tokens: + !P ls.(MAP explode (tokens P ls) = TOKENS P (explode ls)) +Proof + Cases_on `ls` \\ rw[tokens_def, TOKENS_eq_tokens_aux] +QED (* Theorem TOKENS_eq_tokens_sym @@ -395,15 +457,17 @@ val TOKENS_eq_tokens_sym = save_thm("TOKENS_eq_tokens_sym", |> SIMP_RULE(srw_ss())[MAP_MAP_o,implode_explode,o_DEF]); -Theorem tokens_append - `!P s1 x s2. +Theorem tokens_append: + !P s1 x s2. P x ==> - (tokens P (strcat (strcat s1 (str x)) s2) = tokens P s1 ++ tokens P s2)` - (rw[TOKENS_eq_tokens_sym] \\ Cases_on `s1` \\ Cases_on `s2` + (tokens P (strcat (strcat s1 (str x)) s2) = tokens P s1 ++ tokens P s2) +Proof + rw[TOKENS_eq_tokens_sym] \\ Cases_on `s1` \\ Cases_on `s2` \\ rewrite_tac[GSYM MAP_APPEND] \\ AP_TERM_TAC \\ rw[explode_thm] \\ rewrite_tac[GSYM APPEND_ASSOC,APPEND] - \\ match_mp_tac TOKENS_APPEND \\ rw[]); + \\ match_mp_tac TOKENS_APPEND \\ rw[] +QED val fields_aux_def = Define ` @@ -428,10 +492,11 @@ val fields_aux_filter = Q.prove ( rw [DROP_EL_CONS] ); -Theorem fields_filter - `!f s. concat (fields f s) = implode (FILTER ($~ o f) (explode s))` - (rw [fields_def, fields_aux_filter] -); +Theorem fields_filter: + !f s. concat (fields f s) = implode (FILTER ($~ o f) (explode s)) +Proof + rw [fields_def, fields_aux_filter] +QED val fields_aux_length = Q.prove ( `!f s ss n len. (n + len = strlen s) ==> @@ -441,10 +506,11 @@ val fields_aux_length = Q.prove ( ); -Theorem fields_length - `!f s. LENGTH (fields f s) = (LENGTH (FILTER f (explode s)) + 1)` - (rw [fields_def, fields_aux_length] -) +Theorem fields_length: + !f s. LENGTH (fields f s) = (LENGTH (FILTER f (explode s)) + 1) +Proof + rw [fields_def, fields_aux_length] +QED val isStringThere_aux_def = Define` (isStringThere_aux s1 s2 s1i s2i 0 = T) /\ @@ -492,32 +558,37 @@ val isSubstring_def = Define` else F`; (* proof that isSubstring has the right sort of properties *) -Theorem isStringThere_SEG - `∀i1 i2. +Theorem isStringThere_SEG: + ∀i1 i2. i1 + n ≤ LENGTH s1 ∧ i2 + n ≤ LENGTH s2 ⇒ (isStringThere_aux (strlit s1) (strlit s2) i1 i2 n <=> - (SEG n i1 s1 = SEG n i2 s2))` - (Induct_on `n` + (SEG n i1 s1 = SEG n i2 s2)) +Proof + Induct_on `n` >- simp[SEG, isStringThere_aux_def] - >- simp[isStringThere_aux_def, SEG_SUC_EL]); + >- simp[isStringThere_aux_def, SEG_SUC_EL] +QED -Theorem isSubstring_aux_lemma - `∀i len. +Theorem isSubstring_aux_lemma: + ∀i len. i + len ≤ strlen s2 ==> (isSubstring_aux s1 s2 lens1 i len ⇔ - ∃n. n < len ∧ isStringThere_aux s1 s2 0 (n+i) lens1)` - (Induct_on `len` + ∃n. n < len ∧ isStringThere_aux s1 s2 0 (n+i) lens1) +Proof + Induct_on `len` >- simp[isSubstring_aux_def] >> fs[isSubstring_aux_def] >> rw[EQ_IMP_THM] >- (qexists_tac ‘0’ >> simp[]) >- (rename [‘n < len’, ‘i + (n + 1)’] >> qexists_tac ‘n + 1’ >> simp[]) >> rename [‘isStringThere_aux _ _ 0 (i + n)’] >> - Cases_on ‘n’ >> fs[] >> metis_tac[ADD1]); - -Theorem isSubstring_SEG - `isSubstring (strlit s1) (strlit s2) <=> - ∃i. i + LENGTH s1 ≤ LENGTH s2 ∧ SEG (LENGTH s1) i s2 = s1` - (rw[isSubstring_def] >> Cases_on `s1` >> simp[] + Cases_on ‘n’ >> fs[] >> metis_tac[ADD1] +QED + +Theorem isSubstring_SEG: + isSubstring (strlit s1) (strlit s2) <=> + ∃i. i + LENGTH s1 ≤ LENGTH s2 ∧ SEG (LENGTH s1) i s2 = s1 +Proof + rw[isSubstring_def] >> Cases_on `s1` >> simp[] >- (fs[isSubstring_aux_def, isStringThere_aux_def, GSYM ADD1] >> qexists_tac `0` >> simp[SEG]) >- (simp[] >> @@ -526,15 +597,19 @@ Theorem isSubstring_SEG csimp[isSubstring_aux_lemma, isStringThere_SEG, SUB_LEFT_LESS, DECIDE “x < y + 1n ⇔ x ≤ y”] >> ‘STRLEN (STRING h s0) = SUC (STRLEN s0)’ by simp[] >> - metis_tac[SEG_LENGTH_ID])) - -Theorem strlit_STRCAT - `strlit a ^ strlit b = strlit (a ++ b)` - (fs[strcat_def, concat_def]); - -Theorem isSubString_spec - `isSubstring s1 s2 ⇔ ∃p s. s2 = p ^ s1 ^ s` - (map_every Cases_on [`s1`,`s2`] >> rw[isSubstring_SEG, EQ_IMP_THM] + metis_tac[SEG_LENGTH_ID]) +QED + +Theorem strlit_STRCAT: + strlit a ^ strlit b = strlit (a ++ b) +Proof + fs[strcat_def, concat_def] +QED + +Theorem isSubString_spec: + isSubstring s1 s2 ⇔ ∃p s. s2 = p ^ s1 ^ s +Proof + map_every Cases_on [`s1`,`s2`] >> rw[isSubstring_SEG, EQ_IMP_THM] >- (rename [‘SEG (STRLEN s1) i s2 = s1’] >> map_every qexists_tac [ ‘strlit (TAKE i s2)’, ‘strlit (DROP (i + STRLEN s1) s2)’ @@ -542,7 +617,8 @@ Theorem isSubString_spec rename [‘strlit s2 = px ^ strlit s1 ^ sx’] >> qexists_tac `strlen px` >> Cases_on `px` >> simp[strlit_STRCAT] >> Cases_on `sx` >> fs[strlit_STRCAT] >> - simp[SEG_APPEND1, SEG_APPEND2, SEG_LENGTH_ID]); + simp[SEG_APPEND1, SEG_APPEND2, SEG_LENGTH_ID] +QED (* String orderings *) val compare_aux_def = Define` @@ -688,9 +764,10 @@ val take_prefix = Q.prove ( Cases_on `l` >> fs []); -Theorem mlstring_lt_inv_image - `mlstring_lt = inv_image string_lt explode` - (simp [inv_image_def, FUN_EQ_THM] >> +Theorem mlstring_lt_inv_image: + mlstring_lt = inv_image string_lt explode +Proof + simp [inv_image_def, FUN_EQ_THM] >> Cases >> Cases >> simp [mlstring_lt_def, compare_def, compare_aux_spec] >> @@ -708,11 +785,13 @@ Theorem mlstring_lt_inv_image >- metis_tac [string_lt_take_mono, TAKE_LENGTH_ID] >- metis_tac [take_prefix, string_prefix_le, string_lt_antisym, string_le_def] >- metis_tac [string_lt_remove_take, TAKE_LENGTH_ID] - >- metis_tac [string_lt_take_mono, TAKE_LENGTH_ID]); + >- metis_tac [string_lt_take_mono, TAKE_LENGTH_ID] +QED -Theorem TotOrd_compare - `TotOrd compare` - (rw [TotOrd] +Theorem TotOrd_compare: + TotOrd compare +Proof + rw [TotOrd] >- ( rw [compare_def, compare_aux_refl] >> Cases_on `x` >> @@ -732,78 +811,105 @@ Theorem TotOrd_compare metis_tac [compare_aux_sym, flip_ord_def]) >- ( fs [GSYM mlstring_lt_def, mlstring_lt_inv_image] >> - metis_tac [string_lt_trans])); - -Theorem good_cmp_compare - `good_cmp compare` - (match_mp_tac comparisonTheory.TotOrder_imp_good_cmp \\ - MATCH_ACCEPT_TAC TotOrd_compare); - -Theorem mlstring_lt_antisym - `∀s t. ¬(s < t ∧ t < s)` - (rw [mlstring_lt_def] >> - metis_tac [TotOrd_compare, TotOrd, cpn_distinct]); - -Theorem mlstring_lt_cases - `∀s t. (s = t) ∨ s < t ∨ t < s` - (rw [mlstring_lt_def] >> - metis_tac [TotOrd_compare, TotOrd, cpn_nchotomy]); - -Theorem mlstring_lt_nonrefl - `∀s. ¬(s < s)` - (rw [mlstring_lt_def] >> - metis_tac [TotOrd_compare, TotOrd, cpn_distinct]); - -Theorem mlstring_lt_trans - `∀s1 s2 s3. s1 < s2 ∧ s2 < s3 ⇒ s1 < s3` - (rw [mlstring_lt_def] >> - metis_tac [TotOrd_compare, TotOrd]); - -Theorem mlstring_le_thm - `!s1 s2. s1 ≤ s2 ⇔ (s1 = s2) ∨ s1 < s2` - (rw [mlstring_le_def, mlstring_lt_def] >> - metis_tac [TotOrd_compare, TotOrd, cpn_distinct, cpn_nchotomy]); - -Theorem mlstring_gt_thm - `!s1 s2. s1 > s2 ⇔ s2 < s1` - (rw [mlstring_gt_def, mlstring_lt_def] >> - metis_tac [TotOrd_compare, TotOrd]); - -Theorem mlstring_ge_thm - `!s1 s2. s1 ≥ s2 ⇔ s2 ≤ s1` - (rw [mlstring_ge_def, mlstring_le_def] >> - metis_tac [TotOrd_compare, TotOrd]); - -Theorem transitive_mlstring_le - `transitive mlstring_le` - (fs [transitive_def,mlstring_le_thm] + metis_tac [string_lt_trans]) +QED + +Theorem good_cmp_compare: + good_cmp compare +Proof + match_mp_tac comparisonTheory.TotOrder_imp_good_cmp \\ + MATCH_ACCEPT_TAC TotOrd_compare +QED + +Theorem mlstring_lt_antisym: + ∀s t. ¬(s < t ∧ t < s) +Proof + rw [mlstring_lt_def] >> + metis_tac [TotOrd_compare, TotOrd, cpn_distinct] +QED + +Theorem mlstring_lt_cases: + ∀s t. (s = t) ∨ s < t ∨ t < s +Proof + rw [mlstring_lt_def] >> + metis_tac [TotOrd_compare, TotOrd, cpn_nchotomy] +QED + +Theorem mlstring_lt_nonrefl: + ∀s. ¬(s < s) +Proof + rw [mlstring_lt_def] >> + metis_tac [TotOrd_compare, TotOrd, cpn_distinct] +QED + +Theorem mlstring_lt_trans: + ∀s1 s2 s3. s1 < s2 ∧ s2 < s3 ⇒ s1 < s3 +Proof + rw [mlstring_lt_def] >> + metis_tac [TotOrd_compare, TotOrd] +QED + +Theorem mlstring_le_thm: + !s1 s2. s1 ≤ s2 ⇔ (s1 = s2) ∨ s1 < s2 +Proof + rw [mlstring_le_def, mlstring_lt_def] >> + metis_tac [TotOrd_compare, TotOrd, cpn_distinct, cpn_nchotomy] +QED + +Theorem mlstring_gt_thm: + !s1 s2. s1 > s2 ⇔ s2 < s1 +Proof + rw [mlstring_gt_def, mlstring_lt_def] >> + metis_tac [TotOrd_compare, TotOrd] +QED + +Theorem mlstring_ge_thm: + !s1 s2. s1 ≥ s2 ⇔ s2 ≤ s1 +Proof + rw [mlstring_ge_def, mlstring_le_def] >> + metis_tac [TotOrd_compare, TotOrd] +QED + +Theorem transitive_mlstring_le: + transitive mlstring_le +Proof + fs [transitive_def,mlstring_le_thm] \\ rw [] \\ fs [mlstring_lt_inv_image] - \\ imp_res_tac string_lt_trans \\ fs []); + \\ imp_res_tac string_lt_trans \\ fs [] +QED -Theorem antisymmetric_mlstring_le - `antisymmetric mlstring_le` - (fs [antisymmetric_def,mlstring_le_thm] +Theorem antisymmetric_mlstring_le: + antisymmetric mlstring_le +Proof + fs [antisymmetric_def,mlstring_le_thm] \\ rw [] \\ fs [mlstring_lt_inv_image] - \\ imp_res_tac string_lt_antisym); - -Theorem char_lt_total - `!(c1:char) c2. ¬(c1 < c2) ∧ ¬(c2 < c1) ⇒ c1 = c2` - (rw [char_lt_def, CHAR_EQ_THM]); - -Theorem string_lt_total - `!(s1:string) s2. ¬(s1 < s2) ∧ ¬(s2 < s1) ⇒ s1 = s2` - (ho_match_mp_tac string_lt_ind >> + \\ imp_res_tac string_lt_antisym +QED + +Theorem char_lt_total: + !(c1:char) c2. ¬(c1 < c2) ∧ ¬(c2 < c1) ⇒ c1 = c2 +Proof + rw [char_lt_def, CHAR_EQ_THM] +QED + +Theorem string_lt_total: + !(s1:string) s2. ¬(s1 < s2) ∧ ¬(s2 < s1) ⇒ s1 = s2 +Proof + ho_match_mp_tac string_lt_ind >> rw [string_lt_def, char_lt_total] >- ( Cases_on `s1` >> fs [string_lt_def]) >> - metis_tac [char_lt_total]); + metis_tac [char_lt_total] +QED -Theorem total_mlstring_le - `total mlstring_le` - (fs [total_def,mlstring_le_thm] \\ CCONTR_TAC \\ fs [] +Theorem total_mlstring_le: + total mlstring_le +Proof + fs [total_def,mlstring_le_thm] \\ CCONTR_TAC \\ fs [] \\ rw [] \\ fs [mlstring_lt_inv_image] - \\ imp_res_tac string_lt_total \\ fs []); + \\ imp_res_tac string_lt_total \\ fs [] +QED val transitive_mlstring_lt = Q.prove( `transitive mlstring_lt`, @@ -811,10 +917,12 @@ val transitive_mlstring_lt = Q.prove( match_mp_tac transitive_inv_image >> metis_tac[transitive_def,string_lt_trans]) -Theorem strlit_le_strlit - `strlit s1 ≤ strlit s2 <=> s1 <= s2` - (fs [mlstring_le_thm] \\ Cases_on `s1 = s2` - \\ fs [string_le_def,mlstring_lt_inv_image]); +Theorem strlit_le_strlit: + strlit s1 ≤ strlit s2 <=> s1 <= s2 +Proof + fs [mlstring_le_thm] \\ Cases_on `s1 = s2` + \\ fs [string_le_def,mlstring_lt_inv_image] +QED val irreflexive_mlstring_lt = Q.prove( `irreflexive mlstring_lt`, @@ -829,10 +937,12 @@ val trichotomous_mlstring_lt = Q.prove( reverse conj_tac >- metis_tac[explode_BIJ,BIJ_DEF] >> metis_tac[trichotomous,string_lt_cases]) -Theorem StrongLinearOrder_mlstring_lt - `StrongLinearOrder mlstring_lt` - (rw[StrongLinearOrder,trichotomous_mlstring_lt, - StrongOrder,irreflexive_mlstring_lt,transitive_mlstring_lt]) +Theorem StrongLinearOrder_mlstring_lt: + StrongLinearOrder mlstring_lt +Proof + rw[StrongLinearOrder,trichotomous_mlstring_lt, + StrongOrder,irreflexive_mlstring_lt,transitive_mlstring_lt] +QED val collate_aux_def = Define` (collate_aux f (s1: mlstring) s2 ord n 0 = ord) /\ @@ -877,23 +987,28 @@ val collate_aux_greater_thm = Q.prove ( >- rw [DROP_LENGTH_TOO_LONG, mllistTheory.collate_def] ); -Theorem collate_thm - `!f s1 s2. collate f s1 s2 = mllist$collate f (explode s1) (explode s2)` - (rw [collate_def, collate_aux_greater_thm, collate_aux_equal_thm, collate_aux_less_thm] -); +Theorem collate_thm: + !f s1 s2. collate f s1 s2 = mllist$collate f (explode s1) (explode s2) +Proof + rw [collate_def, collate_aux_greater_thm, collate_aux_equal_thm, collate_aux_less_thm] +QED -Theorem ALL_DISTINCT_MAP_implode - `ALL_DISTINCT ls ⇒ ALL_DISTINCT (MAP implode ls)` - (strip_tac >> +Theorem ALL_DISTINCT_MAP_implode: + ALL_DISTINCT ls ⇒ ALL_DISTINCT (MAP implode ls) +Proof + strip_tac >> match_mp_tac ALL_DISTINCT_MAP_INJ >> - rw[implode_def]) + rw[implode_def] +QED val _ = export_rewrites["ALL_DISTINCT_MAP_implode"] -Theorem ALL_DISTINCT_MAP_explode - `∀ls. ALL_DISTINCT (MAP explode ls) ⇔ ALL_DISTINCT ls` - (gen_tac >> EQ_TAC >- MATCH_ACCEPT_TAC ALL_DISTINCT_MAP >> +Theorem ALL_DISTINCT_MAP_explode: + ∀ls. ALL_DISTINCT (MAP explode ls) ⇔ ALL_DISTINCT ls +Proof + gen_tac >> EQ_TAC >- MATCH_ACCEPT_TAC ALL_DISTINCT_MAP >> STRIP_TAC >> MATCH_MP_TAC ALL_DISTINCT_MAP_INJ >> - simp[explode_11]) + simp[explode_11] +QED val _ = export_rewrites["ALL_DISTINCT_MAP_explode"] (* The translator turns each `empty_ffi s` into a call to the FFI with diff --git a/basis/pure/mlvectorScript.sml b/basis/pure/mlvectorScript.sml index 75c95a4b89..ebbda9a113 100644 --- a/basis/pure/mlvectorScript.sml +++ b/basis/pure/mlvectorScript.sml @@ -41,34 +41,43 @@ val toList_aux_thm = Q.prove ( fs [sub_def, length_def, DROP_EL_CONS] ); -Theorem toList_thm - `!ls. toList (Vector ls) = ls` - (rw [toList_def, toList_aux_thm] -); - -Theorem length_toList - `LENGTH (toList vec) = length vec` - (Induct_on `vec` >> rw[length_def, toList_thm]); - -Theorem toList_11[simp] `(toList l = toList l') = (l = l')` - (Induct_on `l` >> Induct_on `l'` >> fs[toList_thm]); +Theorem toList_thm: + !ls. toList (Vector ls) = ls +Proof + rw [toList_def, toList_aux_thm] +QED + +Theorem length_toList: + LENGTH (toList vec) = length vec +Proof + Induct_on `vec` >> rw[length_def, toList_thm] +QED + +Theorem toList_11[simp]: + (toList l = toList l') = (l = l') +Proof + Induct_on `l` >> Induct_on `l'` >> fs[toList_thm] +QED val EL_toList= Q.store_thm("EL_toList",`EL n (toList l) = sub l n`, Induct_on `l` >> fs[sub_def,toList_thm]); -Theorem toList_fromList[simp] - `(toList(fromList l) = l) /\ (fromList(toList v) = v)` - (Cases_on `v` >> fs[toList_thm,fromList_def]); +Theorem toList_fromList[simp]: + (toList(fromList l) = l) /\ (fromList(toList v) = v) +Proof + Cases_on `v` >> fs[toList_thm,fromList_def] +QED val update_def = Define` update vec i x = Vector (LUPDATE x i (toList(vec)))`; -Theorem update_thm - `!vec i x. sub (update vec i x) i = if i < length vec then x - else sub vec i` - (Cases \\ +Theorem update_thm: + !vec i x. sub (update vec i x) i = if i < length vec then x + else sub vec i +Proof + Cases \\ rw [update_def, toList_thm, EL_LUPDATE, length_def, sub_def] -); +QED @@ -110,10 +119,11 @@ val foldli_aux_thm = Q.prove ( \\ rw [DROP_EL_CONS, mllistTheory.foldli_aux_def, ADD1] ); -Theorem foldli_thm - `!f e vec. foldli f e vec = mllist$foldli f e (toList vec)` - (rw [foldli_def, mllistTheory.foldli_def, foldli_aux_thm] -); +Theorem foldli_thm: + !f e vec. foldli f e vec = mllist$foldli f e (toList vec) +Proof + rw [foldli_def, mllistTheory.foldli_def, foldli_aux_thm] +QED val foldl_aux_def = Define` (foldl_aux f e vec n 0 = e) /\ @@ -137,10 +147,11 @@ val foldl_aux_thm = Q.prove ( FOLDL, DROP_LENGTH_APPEND] ); -Theorem foldl_thm - `!f e vec. foldl f e vec = FOLDL f e (toList vec)` - (rw [foldl_aux_thm, foldl_def] -); +Theorem foldl_thm: + !f e vec. foldl f e vec = FOLDL f e (toList vec) +Proof + rw [foldl_aux_thm, foldl_def] +QED @@ -160,11 +171,12 @@ val foldri_aux_thm = Q.prove ( rw [ADD1, TAKE_SUM, TAKE1_DROP, FOLDRi_APPEND] ); -Theorem foldri_thm - `!f e vec. foldri f e vec = FOLDRi f e (toList vec)` - (Cases_on `vec` \\ +Theorem foldri_thm: + !f e vec. foldri f e vec = FOLDRi f e (toList vec) +Proof + Cases_on `vec` \\ rw [foldri_aux_thm, foldri_def, toList_thm, length_def] -); +QED @@ -183,11 +195,12 @@ val foldr_aux_thm = Q.prove ( rw [ADD1, TAKE_SUM, TAKE1_DROP, FOLDR_APPEND] ); -Theorem foldr_thm - `!f e vec. foldr f e vec = FOLDR f e (toList vec)` - (Cases_on `vec` \\ +Theorem foldr_thm: + !f e vec. foldr f e vec = FOLDR f e (toList vec) +Proof + Cases_on `vec` \\ rw[foldr_def, foldr_aux_thm, length_def, toList_thm] -); +QED val findi_aux_def = Define` @@ -221,10 +234,11 @@ val find_aux_thm = Q.prove ( rw [DROP_EL_CONS, INDEX_FIND_def, index_find_thm] ); -Theorem find_thm - `!f vec. find f vec = FIND f (toList vec)` - (rw [find_aux_thm, find_def] -); +Theorem find_thm: + !f vec. find f vec = FIND f (toList vec) +Proof + rw [find_aux_thm, find_def] +QED @@ -246,11 +260,12 @@ val exists_aux_thm = Q.prove( rw [DROP_EL_CONS] ); -Theorem exists_thm - `!f vec. exists f vec = EXISTS f (toList vec)` - (Cases_on `vec` \\ +Theorem exists_thm: + !f vec. exists f vec = EXISTS f (toList vec) +Proof + Cases_on `vec` \\ rw [exists_def, exists_aux_thm] -); +QED @@ -271,10 +286,11 @@ val all_aux_thm = Q.prove ( rw [DROP_EL_CONS] ); -Theorem all_thm - `!f vec. all f vec = EVERY f (toList vec)` - (Cases_on `vec` \\ rw[all_def, all_aux_thm] -); +Theorem all_thm: + !f vec. all f vec = EVERY f (toList vec) +Proof + Cases_on `vec` \\ rw[all_def, all_aux_thm] +QED @@ -320,9 +336,10 @@ val collate_aux_greater_thm = Q.prove ( >- rw [DROP_LENGTH_TOO_LONG, mllistTheory.collate_def] ); -Theorem collate_thm - `!f vec1 vec2. collate f vec1 vec2 = mllist$collate f (toList vec1) (toList vec2)` - (rw [collate_def, collate_aux_greater_thm, collate_aux_equal_thm, collate_aux_less_thm] -); +Theorem collate_thm: + !f vec1 vec2. collate f vec1 vec2 = mllist$collate f (toList vec1) (toList vec2) +Proof + rw [collate_def, collate_aux_greater_thm, collate_aux_equal_thm, collate_aux_less_thm] +QED val _ = export_theory() diff --git a/basis/runtimeFFIScript.sml b/basis/runtimeFFIScript.sml index a6df0c94a3..9b690020e8 100644 --- a/basis/runtimeFFIScript.sml +++ b/basis/runtimeFFIScript.sml @@ -10,10 +10,12 @@ val ffi_exit_def = Define ` ffi_exit (conf:word8 list) (bytes:word8 list) () = SOME(FFIdiverge:unit ffi_result) ` -Theorem ffi_exit_length ` - ffi_exit (conf:word8 list) (bytes:word8 list) u = SOME (FFIreturn bytes' args') - ==> LENGTH bytes' = LENGTH bytes` - (Cases_on `u` \\ rw[ffi_exit_def]); +Theorem ffi_exit_length: + ffi_exit (conf:word8 list) (bytes:word8 list) u = SOME (FFIreturn bytes' args') + ==> LENGTH bytes' = LENGTH bytes +Proof + Cases_on `u` \\ rw[ffi_exit_def] +QED (* FFI part for the runtime *) @@ -25,8 +27,11 @@ val encode_11 = prove( ``!x y. encode x = encode y <=> x = y``, rw [encode_def]); -Theorem decode_encode - `decode(encode cls) = SOME cls` (rw[decode_def,encode_def]); +Theorem decode_encode: + decode(encode cls) = SOME cls +Proof +rw[decode_def,encode_def] +QED val runtime_ffi_part_def = Define` runtime_ffi_part = (encode,decode, diff --git a/candle/set-theory/jrhSetScript.sml b/candle/set-theory/jrhSetScript.sml index 04fa427edb..4f021fa789 100644 --- a/candle/set-theory/jrhSetScript.sml +++ b/candle/set-theory/jrhSetScript.sml @@ -34,9 +34,11 @@ val mk_I_onto = prove_abs_fn_onto inacc_bij val dest_I_11 = prove_rep_fn_one_one inacc_bij val dest_I_onto = prove_rep_fn_onto inacc_bij -Theorem FINITE_CARD_LT - `∀s. FINITE s ⇔ s ≺ 𝕌(:num)` - (metis_tac[INFINITE_Unum]) +Theorem FINITE_CARD_LT: + ∀s. FINITE s ⇔ s ≺ 𝕌(:num) +Proof + metis_tac[INFINITE_Unum] +QED val lemma = Q.prove( `∀s. s ≺ 𝕌(:I) ⇔ FINITE s`, @@ -47,18 +49,21 @@ val lemma = Q.prove( simp[cardleq_def,INJ_DEF] >> metis_tac[inacc_bij,dest_I_11,mk_I_11,IN_UNIV,IN_DEF]) -Theorem I_AXIOM - `𝕌(:ind_model) ≺ 𝕌(:I) ∧ - ∀s. s ≺ 𝕌(:I) ⇒ POW s ≺ 𝕌(:I)` - (simp[lemma,FINITE_POW] >> +Theorem I_AXIOM: + 𝕌(:ind_model) ≺ 𝕌(:I) ∧ + ∀s. s ≺ 𝕌(:I) ⇒ POW s ≺ 𝕌(:I) +Proof + simp[lemma,FINITE_POW] >> `UNIV = IMAGE mk_ind (@s. s ≠ {} ∧ FINITE s)` by ( simp[Once EXTENSION,IN_DEF,ind_model_bij] >> metis_tac[ind_model_bij]) >> - metis_tac[IMAGE_FINITE,NOT_INSERT_EMPTY,FINITE_EMPTY,FINITE_INSERT]) + metis_tac[IMAGE_FINITE,NOT_INSERT_EMPTY,FINITE_EMPTY,FINITE_INSERT] +QED -Theorem I_INFINITE - `INFINITE 𝕌(:I)` - (DISCH_TAC >> +Theorem I_INFINITE: + INFINITE 𝕌(:I) +Proof + DISCH_TAC >> Q.ISPEC_THEN`count (CARD 𝕌(:I) - 1)`mp_tac (CONJUNCT2 I_AXIOM) >> simp[] >> simp[CARD_LT_CARD,CARDLEQ_CARD,FINITE_POW] >> @@ -86,7 +91,8 @@ Theorem I_INFINITE qsuff_tac`CARD a ≠ 0`>-DECIDE_TAC>> simp[CARD_EQ_0,Abbr`a`] >> simp[EXTENSION,IN_POW] >> - qexists_tac`{}`>>simp[]) + qexists_tac`{}`>>simp[] +QED val I_PAIR_EXISTS = Q.prove( `∃f:I#I->I. !x y. (f x = f y) ==> (x = y)`, @@ -103,11 +109,13 @@ val I_PAIR_def = new_specification("I_PAIR_def",["I_PAIR"], REWRITE_RULE[INJ_LEMMA] I_PAIR_EXISTS) -Theorem CARD_BOOL_LT_I - `𝕌(:bool) ≺ 𝕌(:I)` - (strip_tac >> mp_tac I_INFINITE >> simp[] >> +Theorem CARD_BOOL_LT_I: + 𝕌(:bool) ≺ 𝕌(:I) +Proof + strip_tac >> mp_tac I_INFINITE >> simp[] >> match_mp_tac (INST_TYPE[beta|->``:bool``]CARDLEQ_FINITE) >> - HINT_EXISTS_TAC >> simp[UNIV_BOOL]) + HINT_EXISTS_TAC >> simp[UNIV_BOOL] +QED val I_BOOL_EXISTS = Q.prove( `∃f:bool->I. !x y. (f x = f y) ==> (x = y)`, @@ -152,9 +160,10 @@ val setlevel_def = Define` setlevel (Powerset l) = IMAGE (I_SET (setlevel l)) (POW (setlevel l))` -Theorem setlevel_CARD - `∀l. setlevel l ≺ 𝕌(:I)` - (Induct >> simp_tac std_ss [setlevel_def] +Theorem setlevel_CARD: + ∀l. setlevel l ≺ 𝕌(:I) +Proof + Induct >> simp_tac std_ss [setlevel_def] >- ( strip_tac >> match_mp_tac (ISPEC``𝕌(:I)``(GEN_ALL cardlt_REFL)) >> @@ -174,13 +183,16 @@ Theorem setlevel_CARD `𝕌(:I) ≼ s × t` by metis_tac[IMAGE_cardleq,cardleq_TRANS] >> qsuff_tac`s × t ≺ 𝕌(:I) ∨ t × s ≺ 𝕌(:I)` >- metis_tac[cardleq_lt_trans,CARDEQ_CROSS_SYM,cardleq_TRANS,cardleq_lteq] >> - metis_tac[cardleq_dichotomy,CARD_MUL_LT_LEMMA,I_INFINITE])) + metis_tac[cardleq_dichotomy,CARD_MUL_LT_LEMMA,I_INFINITE]) +QED -Theorem I_SET_SETLEVEL - `∀l s t. s ⊆ setlevel l ∧ t ⊆ setlevel l ∧ +Theorem I_SET_SETLEVEL: + ∀l s t. s ⊆ setlevel l ∧ t ⊆ setlevel l ∧ (I_SET (setlevel l) s = I_SET (setlevel l) t) - ⇒ s = t` - (metis_tac[setlevel_CARD,I_SET_def]) + ⇒ s = t +Proof + metis_tac[setlevel_CARD,I_SET_def] +QED val universe_def = Define` universe = {(t,x) | x ∈ setlevel t}` @@ -203,10 +215,12 @@ val universe_IN = Q.prove( `universe x ⇔ x ∈ universe`, rw[IN_DEF]) -Theorem V_bij - `∀l e. e ∈ setlevel l ⇔ dest_V(mk_V(l,e)) = (l,e)` - (rw[GSYM(CONJUNCT2 v_bij)] >> - rw[universe_IN,universe_def]) +Theorem V_bij: + ∀l e. e ∈ setlevel l ⇔ dest_V(mk_V(l,e)) = (l,e) +Proof + rw[GSYM(CONJUNCT2 v_bij)] >> + rw[universe_IN,universe_def] +QED val droplevel_def = Define` droplevel (Powerset l) = l` @@ -221,13 +235,17 @@ val level_def = Define` val element_def = Define` element x = SND(dest_V x)` -Theorem ELEMENT_IN_LEVEL - `∀x. (element x) ∈ setlevel (level x)` - (rw[element_def,level_def,V_bij,v_bij]) +Theorem ELEMENT_IN_LEVEL: + ∀x. (element x) ∈ setlevel (level x) +Proof + rw[element_def,level_def,V_bij,v_bij] +QED -Theorem SET - `∀x. mk_V(level x,element x) = x` - (rw[level_def,element_def,v_bij]) +Theorem SET: + ∀x. mk_V(level x,element x) = x +Proof + rw[level_def,element_def,v_bij] +QED val set_def = Define` set x = @s. s ⊆ (setlevel(droplevel(level x))) ∧ @@ -246,38 +264,48 @@ val _ = Parse.add_infix("<=:",450,Parse.NONASSOC) val subset_def = xDefine"subset"` s <=: t ⇔ level s = level t ∧ ∀x. x <: s ⇒ x <: t` -Theorem MEMBERS_ISASET - `∀x s. x <: s ⇒ isaset s` - (rw[inset_def,isaset_def]) - -Theorem LEVEL_NONEMPTY - `∀l. ∃x. x ∈ setlevel l` - (simp[MEMBER_NOT_EMPTY] >> - Induct >> rw[setlevel_def,CROSS_EMPTY_EQN]) - -Theorem LEVEL_SET_EXISTS - `∀l. ∃s. level s = l` - (mp_tac LEVEL_NONEMPTY >> +Theorem MEMBERS_ISASET: + ∀x s. x <: s ⇒ isaset s +Proof + rw[inset_def,isaset_def] +QED + +Theorem LEVEL_NONEMPTY: + ∀l. ∃x. x ∈ setlevel l +Proof + simp[MEMBER_NOT_EMPTY] >> + Induct >> rw[setlevel_def,CROSS_EMPTY_EQN] +QED + +Theorem LEVEL_SET_EXISTS: + ∀l. ∃s. level s = l +Proof + mp_tac LEVEL_NONEMPTY >> simp[V_bij,level_def] >> - metis_tac[FST]) - -Theorem MK_V_CLAUSES - `e ∈ setlevel l ⇒ - level(mk_V(l,e)) = l ∧ element(mk_V(l,e)) = e` - (rw[level_def,element_def,V_bij]) - -Theorem MK_V_SET - `s ⊆ setlevel l ⇒ + metis_tac[FST] +QED + +Theorem MK_V_CLAUSES: + e ∈ setlevel l ⇒ + level(mk_V(l,e)) = l ∧ element(mk_V(l,e)) = e +Proof + rw[level_def,element_def,V_bij] +QED + +Theorem MK_V_SET: + s ⊆ setlevel l ⇒ set(mk_V(Powerset l,I_SET (setlevel l) s)) = s ∧ level(mk_V(Powerset l,I_SET (setlevel l) s)) = Powerset l ∧ - element(mk_V(Powerset l,I_SET (setlevel l) s)) = I_SET (setlevel l) s` - (strip_tac >> + element(mk_V(Powerset l,I_SET (setlevel l) s)) = I_SET (setlevel l) s +Proof + strip_tac >> `I_SET (setlevel l) s ∈ setlevel (Powerset l)` by ( rw[setlevel_def,IN_POW] ) >> simp[MK_V_CLAUSES] >> simp[set_def,MK_V_CLAUSES,droplevel_def] >> SELECT_ELIM_TAC >> - metis_tac[I_SET_SETLEVEL]) + metis_tac[I_SET_SETLEVEL] +QED val EMPTY_EXISTS = Q.prove( `∀l. ∃s. level s = l ∧ ∀x. ¬(x <: s)`, @@ -312,28 +340,34 @@ val suchthat_def = new_specification("suchthat_def",["suchthat"], SIMP_RULE std_ss [SKOLEM_THM] COMPREHENSION_EXISTS) -Theorem SETLEVEL_EXISTS - `∀l. ∃s. (level s = Powerset l) ∧ - ∀x. x <: s ⇔ level x = l ∧ element x ∈ setlevel l` - (gen_tac >> +Theorem SETLEVEL_EXISTS: + ∀l. ∃s. (level s = Powerset l) ∧ + ∀x. x <: s ⇔ level x = l ∧ element x ∈ setlevel l +Proof + gen_tac >> qexists_tac`mk_V(Powerset l,I_SET (setlevel l) (setlevel l))` >> - simp[MK_V_SET,inset_def] >> metis_tac[]) + simp[MK_V_SET,inset_def] >> metis_tac[] +QED -Theorem SET_DECOMP - `∀s. isaset s ⇒ +Theorem SET_DECOMP: + ∀s. isaset s ⇒ set s ⊆ setlevel(droplevel(level s)) ∧ - I_SET (setlevel(droplevel(level s))) (set s) = element s` - (gen_tac >> simp[isaset_def] >> strip_tac >> + I_SET (setlevel(droplevel(level s))) (set s) = element s +Proof + gen_tac >> simp[isaset_def] >> strip_tac >> simp[set_def] >> SELECT_ELIM_TAC >> simp[setlevel_def,droplevel_def] >> qspec_then`s`mp_tac ELEMENT_IN_LEVEL >> simp[setlevel_def,IN_POW] >> - metis_tac[]) + metis_tac[] +QED -Theorem SET_SUBSET_SETLEVEL - `∀s. isaset s ⇒ set s ⊆ setlevel(droplevel(level s))` - (metis_tac[SET_DECOMP]) +Theorem SET_SUBSET_SETLEVEL: + ∀s. isaset s ⇒ set s ⊆ setlevel(droplevel(level s)) +Proof + metis_tac[SET_DECOMP] +QED val POWERSET_EXISTS = Q.prove( `∀s. ∃t. level t = Powerset(level s) ∧ ∀x. x <: t ⇔ x <=: s`, @@ -356,27 +390,35 @@ val pair_def = Define` pair x y = mk_V(Cartprod (level x) (level y), I_PAIR(element x,element y))` -Theorem PAIR_IN_LEVEL - `∀x y l m. x ∈ setlevel l ∧ y ∈ setlevel m - ⇒ I_PAIR(x,y) ∈ setlevel (Cartprod l m)` - (simp[setlevel_def]) - -Theorem DEST_MK_PAIR - `dest_V(pair x y) = (Cartprod (level x) (level y), I_PAIR(element x,element y))` - (simp[pair_def,GSYM V_bij] >> - simp[PAIR_IN_LEVEL,ELEMENT_IN_LEVEL]) - -Theorem PAIR_INJ - `∀x1 y1 x2 y2. (pair x1 y1 = pair x2 y2) ⇔ (x1 = x2) ∧ (y1 = y2)` - (simp[EQ_IMP_THM] >> rpt gen_tac >> +Theorem PAIR_IN_LEVEL: + ∀x y l m. x ∈ setlevel l ∧ y ∈ setlevel m + ⇒ I_PAIR(x,y) ∈ setlevel (Cartprod l m) +Proof + simp[setlevel_def] +QED + +Theorem DEST_MK_PAIR: + dest_V(pair x y) = (Cartprod (level x) (level y), I_PAIR(element x,element y)) +Proof + simp[pair_def,GSYM V_bij] >> + simp[PAIR_IN_LEVEL,ELEMENT_IN_LEVEL] +QED + +Theorem PAIR_INJ: + ∀x1 y1 x2 y2. (pair x1 y1 = pair x2 y2) ⇔ (x1 = x2) ∧ (y1 = y2) +Proof + simp[EQ_IMP_THM] >> rpt gen_tac >> disch_then(assume_tac o AP_TERM``dest_V``) >> fs[DEST_MK_PAIR,I_PAIR_def] >> fs[level_def,element_def] >> - metis_tac[v_bij,PAIR_EQ,FST,SND,pair_CASES]) + metis_tac[v_bij,PAIR_EQ,FST,SND,pair_CASES] +QED -Theorem LEVEL_PAIR - `∀x y. level(pair x y) = Cartprod (level x) (level y)` - (rw[level_def,DEST_MK_PAIR]) +Theorem LEVEL_PAIR: + ∀x y. level(pair x y) = Cartprod (level x) (level y) +Proof + rw[level_def,DEST_MK_PAIR] +QED val fst_def = Define` fst p = @x. ∃y. p = pair x y` @@ -384,9 +426,11 @@ val fst_def = Define` val snd_def = Define` snd p = @y. ∃x. p = pair x y` -Theorem PAIR_CLAUSES - `∀x y. (fst(pair x y) = x) ∧ (snd(pair x y) = y)` - (rw[fst_def,snd_def] >> metis_tac[PAIR_INJ]) +Theorem PAIR_CLAUSES: + ∀x y. (fst(pair x y) = x) ∧ (snd(pair x y) = y) +Proof + rw[fst_def,snd_def] >> metis_tac[PAIR_INJ] +QED val CARTESIAN_EXISTS = Q.prove( `∀s t. ∃u. level u = Powerset(Cartprod (droplevel(level s)) @@ -414,35 +458,45 @@ val PRODUCT_def = new_specification("PRODUCT_def",["product"], SIMP_RULE std_ss [SKOLEM_THM] CARTESIAN_EXISTS) -Theorem IN_SET_ELEMENT - `∀s. isaset s ∧ e ∈ set s ⇒ - ∃x. e = element x ∧ level s = Powerset (level x) ∧ x <: s` - (rw[isaset_def] >> +Theorem IN_SET_ELEMENT: + ∀s. isaset s ∧ e ∈ set s ⇒ + ∃x. e = element x ∧ level s = Powerset (level x) ∧ x <: s +Proof + rw[isaset_def] >> qexists_tac`mk_V(l,e)` >> simp[inset_def] >> qsuff_tac`e ∈ setlevel l` >- simp[MK_V_CLAUSES] >> - metis_tac[isaset_def,SET_SUBSET_SETLEVEL,SUBSET_DEF,droplevel_def]) - -Theorem SUBSET_ALT - `isaset s ∧ isaset t ⇒ - (s <=: t ⇔ level s = level t ∧ set s SUBSET set t)` - (simp[subset_def,inset_def] >> + metis_tac[isaset_def,SET_SUBSET_SETLEVEL,SUBSET_DEF,droplevel_def] +QED + +Theorem SUBSET_ALT: + isaset s ∧ isaset t ⇒ + (s <=: t ⇔ level s = level t ∧ set s SUBSET set t) +Proof + simp[subset_def,inset_def] >> Cases_on`level s = level t` >> simp[SUBSET_DEF] >> - metis_tac[IN_SET_ELEMENT]) + metis_tac[IN_SET_ELEMENT] +QED -Theorem SUBSET_ANTISYM_LEVEL - `∀s t. isaset s ∧ isaset t ∧ s <=: t ∧ t <=: s ⇒ s = t` - (rw[] >> rfs[SUBSET_ALT] >> +Theorem SUBSET_ANTISYM_LEVEL: + ∀s t. isaset s ∧ isaset t ∧ s <=: t ∧ t <=: s ⇒ s = t +Proof + rw[] >> rfs[SUBSET_ALT] >> imp_res_tac SET_DECOMP >> - metis_tac[SET,SUBSET_ANTISYM]) + metis_tac[SET,SUBSET_ANTISYM] +QED -Theorem EXTENSIONALITY_LEVEL - `∀s t. isaset s ∧ isaset t ∧ level s = level t ∧ (∀x. x <: s ⇔ x <: t) ⇒ s = t` - (metis_tac[SUBSET_ANTISYM_LEVEL,subset_def]) +Theorem EXTENSIONALITY_LEVEL: + ∀s t. isaset s ∧ isaset t ∧ level s = level t ∧ (∀x. x <: s ⇔ x <: t) ⇒ s = t +Proof + metis_tac[SUBSET_ANTISYM_LEVEL,subset_def] +QED -Theorem EXTENSIONALITY_NONEMPTY - `∀s t. (∃x. x <: s) ∧ (∃x. x <: t) ∧ (∀x. x <: s ⇔ x <: t) ⇒ s = t` - (metis_tac[EXTENSIONALITY_LEVEL,MEMBERS_ISASET,inset_def]) +Theorem EXTENSIONALITY_NONEMPTY: + ∀s t. (∃x. x <: s) ∧ (∃x. x <: t) ∧ (∀x. x <: s ⇔ x <: t) ⇒ s = t +Proof + metis_tac[EXTENSIONALITY_LEVEL,MEMBERS_ISASET,inset_def] +QED val true_def = Define` true = mk_V(Ur_bool,I_BOOL T)` @@ -457,37 +511,47 @@ val setlevel_bool = Q.prove( `∀b. I_BOOL b ∈ setlevel Ur_bool`, simp[setlevel_def,I_BOOL_def]) -Theorem IN_BOOL - `∀x. x <: boolset ⇔ x = true ∨ x = false` - (rw[inset_def,boolset_def,true_def,false_def] >> +Theorem IN_BOOL: + ∀x. x <: boolset ⇔ x = true ∨ x = false +Proof + rw[inset_def,boolset_def,true_def,false_def] >> simp[MK_V_SET,setlevel_def] >> - metis_tac[SET,V_bij,PAIR_EQ,ELEMENT_IN_LEVEL,setlevel_bool]) + metis_tac[SET,V_bij,PAIR_EQ,ELEMENT_IN_LEVEL,setlevel_bool] +QED -Theorem TRUE_NE_FALSE - `true ≠ false` - (rw[true_def,false_def] >> +Theorem TRUE_NE_FALSE: + true ≠ false +Proof + rw[true_def,false_def] >> disch_then(mp_tac o AP_TERM``dest_V``) >> simp[] >> - metis_tac[V_bij,setlevel_bool,PAIR_EQ,I_BOOL_def]) + metis_tac[V_bij,setlevel_bool,PAIR_EQ,I_BOOL_def] +QED -Theorem BOOLEAN_EQ - `∀x y. x <: boolset ∧ y <: boolset ∧ ((x = true) ⇔ (y = true)) - ⇒ x = y` - (metis_tac[TRUE_NE_FALSE,IN_BOOL]) +Theorem BOOLEAN_EQ: + ∀x y. x <: boolset ∧ y <: boolset ∧ ((x = true) ⇔ (y = true)) + ⇒ x = y +Proof + metis_tac[TRUE_NE_FALSE,IN_BOOL] +QED val indset_def = Define` indset = mk_V(Powerset Ur_ind,I_SET (setlevel Ur_ind) (setlevel Ur_ind))` -Theorem INDSET_IND_MODEL - `∃f. (∀i:ind_model. f i <: indset) ∧ (∀i j. f i = f j ⇒ i = j)` - (qexists_tac`λi. mk_V(Ur_ind,I_IND i)` >> simp[] >> +Theorem INDSET_IND_MODEL: + ∃f. (∀i:ind_model. f i <: indset) ∧ (∀i j. f i = f j ⇒ i = j) +Proof + qexists_tac`λi. mk_V(Ur_ind,I_IND i)` >> simp[] >> `!i. (I_IND i) ∈ setlevel Ur_ind` by ( simp[setlevel_def] ) >> simp[MK_V_SET,indset_def,inset_def,MK_V_CLAUSES] >> - metis_tac[V_bij,I_IND_def,ELEMENT_IN_LEVEL,PAIR_EQ]) + metis_tac[V_bij,I_IND_def,ELEMENT_IN_LEVEL,PAIR_EQ] +QED -Theorem INDSET_INHABITED - `∃x. x <: indset` - (metis_tac[INDSET_IND_MODEL]) +Theorem INDSET_INHABITED: + ∃x. x <: indset +Proof + metis_tac[INDSET_IND_MODEL] +QED val ch_def = new_specification("ch_def",["ch"], @@ -521,34 +585,44 @@ val abstract_def = Define` abstract s t f = (product s t suchthat λz. ∀x y. pair x y = z ⇒ y = f x)` -Theorem APPLY_ABSTRACT - `∀f x s t. x <: s ∧ f x <: t ⇒ apply(abstract s t f) x = f x` - (rw[apply_def,abstract_def,IN_PRODUCT,suchthat_def] >> - SELECT_ELIM_TAC >> rw[PAIR_INJ]) - -Theorem APPLY_IN_RANSPACE - `∀f x s t. x <: s ∧ f <: funspace s t ⇒ apply f x <: t` - (simp[funspace_def,suchthat_def,IN_POWERSET,IN_PRODUCT,subset_def] >> - rw[apply_def] >> metis_tac[PAIR_INJ]) - -Theorem ABSTRACT_IN_FUNSPACE - `∀f x s t. (∀x. x <: s ⇒ f x <: t) ⇒ abstract s t f <: funspace s t` - (rw[funspace_def,abstract_def,suchthat_def,IN_POWERSET,IN_PRODUCT,subset_def,PAIR_INJ] >> metis_tac[]) - -Theorem FUNSPACE_INHABITED - `∀s t. ((∃x. x <: s) ⇒ (∃y. y <: t)) ⇒ ∃f. f <: funspace s t` - (rw[] >> qexists_tac`abstract s t (λx. @y. y <: t)` >> - match_mp_tac ABSTRACT_IN_FUNSPACE >> metis_tac[]) - -Theorem ABSTRACT_EQ - `∀s t1 t2 f g. +Theorem APPLY_ABSTRACT: + ∀f x s t. x <: s ∧ f x <: t ⇒ apply(abstract s t f) x = f x +Proof + rw[apply_def,abstract_def,IN_PRODUCT,suchthat_def] >> + SELECT_ELIM_TAC >> rw[PAIR_INJ] +QED + +Theorem APPLY_IN_RANSPACE: + ∀f x s t. x <: s ∧ f <: funspace s t ⇒ apply f x <: t +Proof + simp[funspace_def,suchthat_def,IN_POWERSET,IN_PRODUCT,subset_def] >> + rw[apply_def] >> metis_tac[PAIR_INJ] +QED + +Theorem ABSTRACT_IN_FUNSPACE: + ∀f x s t. (∀x. x <: s ⇒ f x <: t) ⇒ abstract s t f <: funspace s t +Proof + rw[funspace_def,abstract_def,suchthat_def,IN_POWERSET,IN_PRODUCT,subset_def,PAIR_INJ] >> metis_tac[] +QED + +Theorem FUNSPACE_INHABITED: + ∀s t. ((∃x. x <: s) ⇒ (∃y. y <: t)) ⇒ ∃f. f <: funspace s t +Proof + rw[] >> qexists_tac`abstract s t (λx. @y. y <: t)` >> + match_mp_tac ABSTRACT_IN_FUNSPACE >> metis_tac[] +QED + +Theorem ABSTRACT_EQ: + ∀s t1 t2 f g. (∃x. x <: s) ∧ (∀x. x <: s ⇒ f x <: t1 ∧ g x <: t2 ∧ f x = g x) - ⇒ abstract s t1 f = abstract s t2 g` - (rw[abstract_def] >> + ⇒ abstract s t1 f = abstract s t2 g +Proof + rw[abstract_def] >> match_mp_tac EXTENSIONALITY_NONEMPTY >> simp[suchthat_def,IN_PRODUCT,PAIR_INJ] >> - metis_tac[PAIR_INJ]) + metis_tac[PAIR_INJ] +QED val boolean_def = Define` boolean b = if b then true else false` @@ -556,18 +630,23 @@ val boolean_def = Define` val holds_def = Define` holds s x ⇔ apply s x = true` -Theorem BOOLEAN_IN_BOOLSET - `∀b. boolean b <: boolset` - (metis_tac[boolean_def,IN_BOOL]) - -Theorem BOOLEAN_EQ_TRUE - `∀b. boolean b = true ⇔ b` - (metis_tac[boolean_def,TRUE_NE_FALSE]) - -Theorem in_funspace_abstract - `∀z s t. z <: funspace s t ∧ (∃z. z <: s) ∧ (∃z. z <: t) ⇒ - ∃f. z = abstract s t f ∧ (∀x. x <: s ⇒ f x <: t)` - (rw[funspace_def,suchthat_def,powerset_def] >> +Theorem BOOLEAN_IN_BOOLSET: + ∀b. boolean b <: boolset +Proof + metis_tac[boolean_def,IN_BOOL] +QED + +Theorem BOOLEAN_EQ_TRUE: + ∀b. boolean b = true ⇔ b +Proof + metis_tac[boolean_def,TRUE_NE_FALSE] +QED + +Theorem in_funspace_abstract: + ∀z s t. z <: funspace s t ∧ (∃z. z <: s) ∧ (∃z. z <: t) ⇒ + ∃f. z = abstract s t f ∧ (∀x. x <: s ⇒ f x <: t) +Proof + rw[funspace_def,suchthat_def,powerset_def] >> qexists_tac`λx. @y. pair x y <: z` >> conj_tac >- ( match_mp_tac EXTENSIONALITY_NONEMPTY >> @@ -605,13 +684,15 @@ Theorem in_funspace_abstract rw[] >> fs[subset_def,EXISTS_UNIQUE_THM,PRODUCT_def] >> SELECT_ELIM_TAC >> - metis_tac[PAIR_INJ]) + metis_tac[PAIR_INJ] +QED open relationTheory -Theorem WF_inset - `WF $<:` - (simp[WF_DEF] >> rw[] >> +Theorem WF_inset: + WF $<: +Proof + simp[WF_DEF] >> rw[] >> Induct_on`level w` >> TRY ( rw[] >> qexists_tac`w` >> rw[] >> @@ -620,7 +701,8 @@ Theorem WF_inset reverse(Cases_on`∃u. u <: w ∧ B u`) >> fs[] >- ( qexists_tac`w` >> rw[] >> metis_tac[] ) >> first_x_assum(qspec_then`u`mp_tac) >> - fs[inset_def]) + fs[inset_def] +QED val inset_ind = save_thm("inset_ind",MATCH_MP WF_INDUCTION_THM WF_inset) diff --git a/candle/set-theory/setModelScript.sml b/candle/set-theory/setModelScript.sml index df87e7d900..0fda8d743e 100644 --- a/candle/set-theory/setModelScript.sml +++ b/candle/set-theory/setModelScript.sml @@ -16,9 +16,10 @@ val is_set_theory_pred_def = Define` (∀x y. is_v_rep x ∧ is_v_rep y ⇒ ∃z. is_v_rep z ∧ (∀a. is_v_rep a ⇒ (in_rep a z ⇔ (a = x ∨ a = y)))) ∧ (∀x. is_v_rep x ⇒ ∃y. is_v_rep y ∧ (∀a. is_v_rep a ∧ in_rep a x ⇒ in_rep y x))` -Theorem l_model_exists - `∃(P : α+num -> bool) (mem : α+num -> α+num -> bool). is_set_theory_pred P mem` - (qexists_tac`ISR` >> +Theorem l_model_exists: + ∃(P : α+num -> bool) (mem : α+num -> α+num -> bool). is_set_theory_pred P mem +Proof + qexists_tac`ISR` >> REWRITE_TAC[is_set_theory_pred_def] >> qexists_tac`λl1 l2. BIT (OUTR l1) (OUTR l2)` >> conj_tac >- (qexists_tac`INR 0` >> simp[]) >> @@ -169,7 +170,8 @@ Theorem l_model_exists Cases_on`OUTR x=0`>>simp[BIT_ZERO] >- ( qexists_tac`INR 0` >> simp[] ) >> qexists_tac`INR (LOG2 (OUTR x))` >> - simp[BIT_LOG2,EVERY_GENLIST]) + simp[BIT_LOG2,EVERY_GENLIST] +QED val is_V_def = new_specification("is_V_def",["is_V"],REWRITE_RULE[is_set_theory_pred_def]l_model_exists) @@ -184,9 +186,10 @@ val V_mem_rep_def = val V_mem_def = Define`V_mem x y = V_mem_rep (dest_V x) (dest_V y)` -Theorem is_set_theory_V - `is_set_theory V_mem` - (simp[is_set_theory_def] >> +Theorem is_set_theory_V: + is_set_theory V_mem +Proof + simp[is_set_theory_def] >> conj_tac >- ( simp[extensional_def] >> simp[V_mem_def] >> @@ -225,7 +228,8 @@ Theorem is_set_theory_V (List.nth(CONJUNCTS V_mem_rep_def,5)) >> simp[V_bij] >> simp[V_mem_def] >> - metis_tac[V_bij] ) + metis_tac[V_bij] +QED val V_choice_exists = Q.prove( `∃ch. is_choice V_mem ch`, @@ -243,9 +247,11 @@ val V_indset_def = new_specification("V_indset_def",["V_indset"], METIS_PROVE[]``∃i:α V. (∃x:α V. is_infinite V_mem x) ⇒ is_infinite V_mem i``) -Theorem is_model_V - `(∃I:α V. is_infinite V_mem I) ⇒ - is_model (V_mem,V_indset:α V,V_choice)` - (simp[is_model_def,is_set_theory_V,V_choice_def,V_indset_def]) +Theorem is_model_V: + (∃I:α V. is_infinite V_mem I) ⇒ + is_model (V_mem,V_indset:α V,V_choice) +Proof + simp[is_model_def,is_set_theory_V,V_choice_def,V_indset_def] +QED val _ = export_theory() diff --git a/candle/set-theory/setSpecScript.sml b/candle/set-theory/setSpecScript.sml index 3df30314ad..6f7b0e7678 100644 --- a/candle/set-theory/setSpecScript.sml +++ b/candle/set-theory/setSpecScript.sml @@ -43,25 +43,33 @@ val is_set_theory_def = Define` (∃union. is_union mem union) ∧ (∃upair. is_upair mem upair)` -Theorem separation_unique - `extensional ^mem ⇒ - ∀sub1 sub2. is_separation mem sub1 ∧ is_separation mem sub2 ⇒ sub1 = sub2` - (rw[is_separation_def,extensional_def,FUN_EQ_THM]) - -Theorem power_unique - `extensional ^mem ⇒ - ∀power1 power2. is_power mem power1 ∧ is_power mem power2 ⇒ power1 = power2` - (rw[is_power_def,extensional_def,FUN_EQ_THM]) - -Theorem union_unique - `extensional ^mem ⇒ - ∀union1 union2. is_union mem union1 ∧ is_union mem union2 ⇒ union1 = union2` - (rw[is_union_def,extensional_def,FUN_EQ_THM]) - -Theorem upair_unique - `extensional ^mem ⇒ - ∀upair1 upair2. is_upair mem upair1 ∧ is_upair mem upair2 ⇒ upair1 = upair2` - (rw[is_upair_def,extensional_def,FUN_EQ_THM]) +Theorem separation_unique: + extensional ^mem ⇒ + ∀sub1 sub2. is_separation mem sub1 ∧ is_separation mem sub2 ⇒ sub1 = sub2 +Proof + rw[is_separation_def,extensional_def,FUN_EQ_THM] +QED + +Theorem power_unique: + extensional ^mem ⇒ + ∀power1 power2. is_power mem power1 ∧ is_power mem power2 ⇒ power1 = power2 +Proof + rw[is_power_def,extensional_def,FUN_EQ_THM] +QED + +Theorem union_unique: + extensional ^mem ⇒ + ∀union1 union2. is_union mem union1 ∧ is_union mem union2 ⇒ union1 = union2 +Proof + rw[is_union_def,extensional_def,FUN_EQ_THM] +QED + +Theorem upair_unique: + extensional ^mem ⇒ + ∀upair1 upair2. is_upair mem upair1 ∧ is_upair mem upair2 ⇒ upair1 = upair2 +Proof + rw[is_upair_def,extensional_def,FUN_EQ_THM] +QED val sub_def = Define` sub ^mem = @sub. is_separation mem sub` @@ -75,136 +83,172 @@ val union_def = Define` val upair_def = Define` upair ^mem = @upair. is_upair mem upair` -Theorem is_extensional - `is_set_theory ^mem ⇒ extensional mem` - (rw[is_set_theory_def]) - -Theorem is_separation_sub - `is_set_theory ^mem ⇒ is_separation mem (sub mem)` - (rw[sub_def] >> SELECT_ELIM_TAC >> fsrw_tac[SATISFY_ss][is_set_theory_def]) - -Theorem is_power_power - `is_set_theory ^mem ⇒ is_power mem (power mem)` - (rw[power_def] >> SELECT_ELIM_TAC >> fsrw_tac[SATISFY_ss][is_set_theory_def]) - -Theorem is_union_union - `is_set_theory ^mem ⇒ is_union mem (union mem)` - (rw[union_def] >> SELECT_ELIM_TAC >> fsrw_tac[SATISFY_ss][is_set_theory_def]) - -Theorem is_upair_upair - `is_set_theory ^mem ⇒ is_upair mem (upair mem)` - (rw[upair_def] >> SELECT_ELIM_TAC >> fsrw_tac[SATISFY_ss][is_set_theory_def]) +Theorem is_extensional: + is_set_theory ^mem ⇒ extensional mem +Proof + rw[is_set_theory_def] +QED + +Theorem is_separation_sub: + is_set_theory ^mem ⇒ is_separation mem (sub mem) +Proof + rw[sub_def] >> SELECT_ELIM_TAC >> fsrw_tac[SATISFY_ss][is_set_theory_def] +QED + +Theorem is_power_power: + is_set_theory ^mem ⇒ is_power mem (power mem) +Proof + rw[power_def] >> SELECT_ELIM_TAC >> fsrw_tac[SATISFY_ss][is_set_theory_def] +QED + +Theorem is_union_union: + is_set_theory ^mem ⇒ is_union mem (union mem) +Proof + rw[union_def] >> SELECT_ELIM_TAC >> fsrw_tac[SATISFY_ss][is_set_theory_def] +QED + +Theorem is_upair_upair: + is_set_theory ^mem ⇒ is_upair mem (upair mem) +Proof + rw[upair_def] >> SELECT_ELIM_TAC >> fsrw_tac[SATISFY_ss][is_set_theory_def] +QED val _ = Parse.add_infix("suchthat",9,Parse.LEFT) val _ = Parse.overload_on("suchthat",``sub ^mem``) val _ = Parse.overload_on("Pow",``power ^mem``) val _ = Parse.overload_on("+",``upair ^mem``) -Theorem mem_sub - `is_set_theory ^mem ⇒ ∀x s P. x <: (s suchthat P) ⇔ x <: s ∧ P x` - (strip_tac >> imp_res_tac is_separation_sub >> fs[is_separation_def]) - -Theorem mem_power - `is_set_theory ^mem ⇒ - ∀x y. x <: (Pow y) ⇔ (∀b. b <: x ⇒ b <: y)` - (strip_tac >> imp_res_tac is_power_power >> fs[is_power_def]) - -Theorem mem_union - `is_set_theory ^mem ⇒ - ∀x s. x <: (union mem s) ⇔ ∃a. x <: a ∧ a <: s` - (strip_tac >> imp_res_tac is_union_union >> fs[is_union_def]) - -Theorem mem_upair - `is_set_theory ^mem ⇒ ∀a x y. a <: (x + y) ⇔ a = x ∨ a = y` - (strip_tac >> imp_res_tac is_upair_upair >> fs[is_upair_def]) +Theorem mem_sub: + is_set_theory ^mem ⇒ ∀x s P. x <: (s suchthat P) ⇔ x <: s ∧ P x +Proof + strip_tac >> imp_res_tac is_separation_sub >> fs[is_separation_def] +QED + +Theorem mem_power: + is_set_theory ^mem ⇒ + ∀x y. x <: (Pow y) ⇔ (∀b. b <: x ⇒ b <: y) +Proof + strip_tac >> imp_res_tac is_power_power >> fs[is_power_def] +QED + +Theorem mem_union: + is_set_theory ^mem ⇒ + ∀x s. x <: (union mem s) ⇔ ∃a. x <: a ∧ a <: s +Proof + strip_tac >> imp_res_tac is_union_union >> fs[is_union_def] +QED + +Theorem mem_upair: + is_set_theory ^mem ⇒ ∀a x y. a <: (x + y) ⇔ a = x ∨ a = y +Proof + strip_tac >> imp_res_tac is_upair_upair >> fs[is_upair_def] +QED val empty_def = Define` empty ^mem = sub mem ARB (K F)` val _ = Parse.overload_on("∅",``empty ^mem``) -Theorem mem_empty - `is_set_theory ^mem ⇒ ∀x. ¬(x <: ∅)` - (strip_tac >> imp_res_tac is_separation_sub >> - fs[empty_def,is_separation_def]) +Theorem mem_empty: + is_set_theory ^mem ⇒ ∀x. ¬(x <: ∅) +Proof + strip_tac >> imp_res_tac is_separation_sub >> + fs[empty_def,is_separation_def] +QED val unit_def = Define` unit ^mem x = x + x` val _ = Parse.overload_on("Unit",``unit ^mem``) -Theorem mem_unit - `is_set_theory ^mem ⇒ - ∀x y. x <: (Unit y) ⇔ x = y` - (strip_tac >> imp_res_tac is_upair_upair >> - fs[is_upair_def,unit_def]) - -Theorem unit_inj - `is_set_theory ^mem ⇒ - ∀x y. Unit x = Unit y ⇔ x = y` - (strip_tac >> +Theorem mem_unit: + is_set_theory ^mem ⇒ + ∀x y. x <: (Unit y) ⇔ x = y +Proof + strip_tac >> imp_res_tac is_upair_upair >> + fs[is_upair_def,unit_def] +QED + +Theorem unit_inj: + is_set_theory ^mem ⇒ + ∀x y. Unit x = Unit y ⇔ x = y +Proof + strip_tac >> imp_res_tac is_extensional >> fs[extensional_def,mem_unit] >> - metis_tac[]) + metis_tac[] +QED val one_def = Define` one ^mem = Unit ∅` val _ = Parse.overload_on("One",``one ^mem``) -Theorem mem_one - `is_set_theory ^mem ⇒ - ∀x. x <: One ⇔ x = ∅` - (strip_tac >> simp[mem_unit,one_def]) +Theorem mem_one: + is_set_theory ^mem ⇒ + ∀x. x <: One ⇔ x = ∅ +Proof + strip_tac >> simp[mem_unit,one_def] +QED val two_def = Define` two ^mem = ∅ + One` val _ = Parse.overload_on("Two",``two ^mem``) -Theorem mem_two - `is_set_theory ^mem ⇒ - ∀x. x <: Two ⇔ x = ∅ ∨ x = One` - (strip_tac >> simp[mem_upair,mem_one,two_def]) +Theorem mem_two: + is_set_theory ^mem ⇒ + ∀x. x <: Two ⇔ x = ∅ ∨ x = One +Proof + strip_tac >> simp[mem_upair,mem_one,two_def] +QED val pair_def = Define` pair ^mem x y = (Unit x) + (x + y)` val _ = Parse.overload_on(",",``pair ^mem``) -Theorem upair_inj - `is_set_theory ^mem ⇒ - ∀a b c d. a + b = c + d ⇔ a = c ∧ b = d ∨ a = d ∧ b = c` - (strip_tac >> +Theorem upair_inj: + is_set_theory ^mem ⇒ + ∀a b c d. a + b = c + d ⇔ a = c ∧ b = d ∨ a = d ∧ b = c +Proof + strip_tac >> imp_res_tac is_extensional >> fs[extensional_def,mem_upair] >> - metis_tac[]) - -Theorem unit_eq_upair - `is_set_theory ^mem ⇒ - ∀x y z. Unit x = y + z ⇔ x = y ∧ y = z` - (strip_tac >> + metis_tac[] +QED + +Theorem unit_eq_upair: + is_set_theory ^mem ⇒ + ∀x y z. Unit x = y + z ⇔ x = y ∧ y = z +Proof + strip_tac >> imp_res_tac is_extensional >> fs[extensional_def,mem_unit,mem_upair] >> - metis_tac[]) - -Theorem pair_inj - `is_set_theory ^mem ⇒ - ∀a b c d. (a,b) = (c,d) ⇔ a = c ∧ b = d` - (strip_tac >> fs[pair_def] >> rw[] >> + metis_tac[] +QED + +Theorem pair_inj: + is_set_theory ^mem ⇒ + ∀a b c d. (a,b) = (c,d) ⇔ a = c ∧ b = d +Proof + strip_tac >> fs[pair_def] >> rw[] >> simp[upair_inj,unit_inj,unit_eq_upair] >> - metis_tac[]) + metis_tac[] +QED val binary_union_def = Define` binary_union ^mem x y = union mem (upair mem x y)` val _ = Parse.overload_on("UNION",``binary_union ^mem``) -Theorem mem_binary_union - `is_set_theory ^mem ⇒ - ∀a x y. a <: (x ∪ y) ⇔ a <: x ∨ a <: y` - (strip_tac >> fs[binary_union_def,mem_union,mem_upair] >> - metis_tac[]) +Theorem mem_binary_union: + is_set_theory ^mem ⇒ + ∀a x y. a <: (x ∪ y) ⇔ a <: x ∨ a <: y +Proof + strip_tac >> fs[binary_union_def,mem_union,mem_upair] >> + metis_tac[] +QED val product_def = Define` product ^mem x y = @@ -213,14 +257,16 @@ val product_def = Define` val _ = Parse.overload_on("CROSS",``product ^mem``) -Theorem mem_product - `is_set_theory ^mem ⇒ - ∀a x y. a <: (x × y) ⇔ ∃b c. a = (b,c) ∧ b <: x ∧ c <: y` - (strip_tac >> fs[product_def] >> +Theorem mem_product: + is_set_theory ^mem ⇒ + ∀a x y. a <: (x × y) ⇔ ∃b c. a = (b,c) ∧ b <: x ∧ c <: y +Proof + strip_tac >> fs[product_def] >> simp[mem_sub,mem_power,mem_binary_union] >> rw[EQ_IMP_THM] >> TRY(metis_tac[]) >> rfs[pair_def,mem_upair] >> rw[] >> - rfs[mem_unit,mem_upair]) + rfs[mem_unit,mem_upair] +QED val relspace_def = Define` relspace ^mem x y = Pow (x × y)` @@ -250,33 +296,41 @@ val false_def = Define` val _ = Parse.overload_on("True",``true ^mem``) val _ = Parse.overload_on("False",``false ^mem``) -Theorem true_neq_false - `is_set_theory ^mem ⇒ True ≠ False` - (strip_tac >> +Theorem true_neq_false: + is_set_theory ^mem ⇒ True ≠ False +Proof + strip_tac >> imp_res_tac mem_one >> imp_res_tac mem_empty >> fs[true_def,false_def,is_set_theory_def,extensional_def,one_def] >> - metis_tac[]) + metis_tac[] +QED -Theorem mem_boolset - `is_set_theory ^mem ⇒ - ∀x. x <: boolset ⇔ ((x = True) ∨ (x = False))` - (strip_tac >> fs[mem_two,true_def,false_def]) +Theorem mem_boolset: + is_set_theory ^mem ⇒ + ∀x. x <: boolset ⇔ ((x = True) ∨ (x = False)) +Proof + strip_tac >> fs[mem_two,true_def,false_def] +QED val boolean_def = Define` boolean ^mem b = if b then True else False` val _ = Parse.overload_on("Boolean",``boolean ^mem``) -Theorem boolean_in_boolset - `is_set_theory ^mem ⇒ - ∀b. Boolean b <: boolset` - (strip_tac >> imp_res_tac mem_boolset >> - Cases >> simp[boolean_def]) +Theorem boolean_in_boolset: + is_set_theory ^mem ⇒ + ∀b. Boolean b <: boolset +Proof + strip_tac >> imp_res_tac mem_boolset >> + Cases >> simp[boolean_def] +QED -Theorem boolean_eq_true - `is_set_theory ^mem ⇒ ∀b. Boolean b = True ⇔ b` - (strip_tac >> rw[boolean_def,true_neq_false]) +Theorem boolean_eq_true: + is_set_theory ^mem ⇒ ∀b. Boolean b = True ⇔ b +Proof + strip_tac >> rw[boolean_def,true_neq_false] +QED val holds_def = Define` holds ^mem s x ⇔ s ' x = True` @@ -288,57 +342,70 @@ val abstract_def = Define` val _ = Parse.overload_on("Abstract",``abstract ^mem``) -Theorem apply_abstract - `is_set_theory ^mem ⇒ - ∀f x s t. x <: s ∧ f x <: t ⇒ (Abstract s t f) ' x = f x` - (strip_tac >> +Theorem apply_abstract: + is_set_theory ^mem ⇒ + ∀f x s t. x <: s ∧ f x <: t ⇒ (Abstract s t f) ' x = f x +Proof + strip_tac >> rw[apply_def,abstract_def] >> SELECT_ELIM_TAC >> - simp[mem_sub,mem_product,pair_inj]) + simp[mem_sub,mem_product,pair_inj] +QED -Theorem apply_abstract_matchable - `∀f x s t u. x <: s ∧ f x <: t ∧ is_set_theory ^mem ∧ f x = u ⇒ Abstract s t f ' x = u` - (metis_tac[apply_abstract]) +Theorem apply_abstract_matchable: + ∀f x s t u. x <: s ∧ f x <: t ∧ is_set_theory ^mem ∧ f x = u ⇒ Abstract s t f ' x = u +Proof + metis_tac[apply_abstract] +QED -Theorem apply_in_rng - `is_set_theory ^mem ⇒ +Theorem apply_in_rng: + is_set_theory ^mem ⇒ ∀f x s t. x <: s ∧ f <: Funspace s t ⇒ - f ' x <: t` - (strip_tac >> + f ' x <: t +Proof + strip_tac >> simp[funspace_def,mem_sub,relspace_def, mem_power,apply_def,mem_product,EXISTS_UNIQUE_THM] >> - rw[] >> res_tac >> SELECT_ELIM_TAC >> res_tac >> rfs[pair_inj] >> metis_tac[]) - -Theorem abstract_in_funspace - `is_set_theory ^mem ⇒ - ∀f s t. (∀x. x <: s ⇒ f x <: t) ⇒ Abstract s t f <: Funspace s t` - (strip_tac >> + rw[] >> res_tac >> SELECT_ELIM_TAC >> res_tac >> rfs[pair_inj] >> metis_tac[] +QED + +Theorem abstract_in_funspace: + is_set_theory ^mem ⇒ + ∀f s t. (∀x. x <: s ⇒ f x <: t) ⇒ Abstract s t f <: Funspace s t +Proof + strip_tac >> simp[funspace_def,relspace_def,abstract_def,mem_power,mem_product,mem_sub] >> - simp[EXISTS_UNIQUE_THM,pair_inj]) - -Theorem abstract_in_funspace_matchable - `is_set_theory ^mem ⇒ - ∀f s t fs. (∀x. x <: s ⇒ f x <: t) ∧ fs = Funspace s t ⇒ Abstract s t f <: fs` - (PROVE_TAC[abstract_in_funspace]) - -Theorem abstract_eq - `is_set_theory ^mem ⇒ + simp[EXISTS_UNIQUE_THM,pair_inj] +QED + +Theorem abstract_in_funspace_matchable: + is_set_theory ^mem ⇒ + ∀f s t fs. (∀x. x <: s ⇒ f x <: t) ∧ fs = Funspace s t ⇒ Abstract s t f <: fs +Proof + PROVE_TAC[abstract_in_funspace] +QED + +Theorem abstract_eq: + is_set_theory ^mem ⇒ ∀s t1 t2 f g. (∀x. x <: s ⇒ f x <: t1 ∧ g x <: t2 ∧ f x = g x) - ⇒ Abstract s t1 f = Abstract s t2 g` - (rw[] >> + ⇒ Abstract s t1 f = Abstract s t2 g +Proof + rw[] >> imp_res_tac is_extensional >> pop_assum mp_tac >> simp[extensional_def] >> disch_then kall_tac >> simp[abstract_def,mem_sub,mem_product] >> - metis_tac[pair_inj]) + metis_tac[pair_inj] +QED -Theorem in_funspace_abstract - `is_set_theory ^mem ⇒ +Theorem in_funspace_abstract: + is_set_theory ^mem ⇒ ∀z s t. z <: Funspace s t ⇒ - ∃f. z = Abstract s t f ∧ (∀x. x <: s ⇒ f x <: t)` - (rw[funspace_def,mem_sub,relspace_def,mem_power] >> + ∃f. z = Abstract s t f ∧ (∀x. x <: s ⇒ f x <: t) +Proof + rw[funspace_def,mem_sub,relspace_def,mem_power] >> qexists_tac`λx. @y. (x,y) <: z` >> conj_tac >- ( imp_res_tac is_extensional >> @@ -351,7 +418,8 @@ Theorem in_funspace_abstract fs[EXISTS_UNIQUE_THM] >> metis_tac[] ) >> rfs[EXISTS_UNIQUE_THM,mem_product] >> - metis_tac[pair_inj]) + metis_tac[pair_inj] +QED val axiom_of_choice = save_thm("axiom_of_choice",UNDISCH(prove( ``is_set_theory ^mem ⇒ @@ -387,58 +455,72 @@ val is_model_def = Define` is_infinite mem indset ∧ is_choice mem ch` -Theorem is_model_is_set_theory - `is_model M ⇒ is_set_theory ^mem` - (rw[is_model_def]) - -Theorem indset_inhabited - `is_infinite ^mem indset ⇒ ∃i. i <: indset` - (rw[is_infinite_def] >> imp_res_tac INFINITE_INHAB >> - fs[] >> metis_tac[]) - -Theorem funspace_inhabited - `is_set_theory ^mem ⇒ ∀s t. (∃x. x <: s) ∧ (∃x. x <: t) ⇒ ∃f. f <: Funspace s t` - (rw[] >> qexists_tac`Abstract s t (λx. @x. x <: t)` >> +Theorem is_model_is_set_theory: + is_model M ⇒ is_set_theory ^mem +Proof + rw[is_model_def] +QED + +Theorem indset_inhabited: + is_infinite ^mem indset ⇒ ∃i. i <: indset +Proof + rw[is_infinite_def] >> imp_res_tac INFINITE_INHAB >> + fs[] >> metis_tac[] +QED + +Theorem funspace_inhabited: + is_set_theory ^mem ⇒ ∀s t. (∃x. x <: s) ∧ (∃x. x <: t) ⇒ ∃f. f <: Funspace s t +Proof + rw[] >> qexists_tac`Abstract s t (λx. @x. x <: t)` >> match_mp_tac (MP_CANON abstract_in_funspace) >> - metis_tac[]) + metis_tac[] +QED val tuple_def = Define` (tuple0 ^mem [] = ∅) ∧ (tuple0 ^mem (a::as) = (a, tuple0 ^mem as))` val _ = Parse.overload_on("tuple",``tuple0 ^mem``) -Theorem pair_not_empty - `is_set_theory ^mem ⇒ (x,y) ≠ ∅` - (rw[] >> +Theorem pair_not_empty: + is_set_theory ^mem ⇒ (x,y) ≠ ∅ +Proof + rw[] >> imp_res_tac is_extensional >> fs[extensional_def,mem_empty] >> pop_assum kall_tac >> simp[pair_def,mem_upair] >> - metis_tac[]) - -Theorem tuple_empty - `is_set_theory ^mem ⇒ ∀ls. tuple ls = ∅ ⇔ ls = []` - (strip_tac >> Cases >> simp[tuple_def] >> - simp[pair_not_empty] ) - -Theorem tuple_inj - `is_set_theory ^mem ⇒ - ∀l1 l2. tuple l1 = tuple l2 ⇔ l1 = l2` - (strip_tac >> + metis_tac[] +QED + +Theorem tuple_empty: + is_set_theory ^mem ⇒ ∀ls. tuple ls = ∅ ⇔ ls = [] +Proof + strip_tac >> Cases >> simp[tuple_def] >> + simp[pair_not_empty] +QED + +Theorem tuple_inj: + is_set_theory ^mem ⇒ + ∀l1 l2. tuple l1 = tuple l2 ⇔ l1 = l2 +Proof + strip_tac >> Induct >> simp[tuple_def] >- metis_tac[tuple_empty] >> gen_tac >> Cases >> simp[tuple_def,pair_not_empty] >> - simp[pair_inj]) + simp[pair_inj] +QED val bigcross_def = Define` (bigcross0 ^mem [] = One) ∧ (bigcross0 ^mem (a::as) = a × (bigcross0 ^mem as))` val _ = Parse.overload_on("bigcross",``bigcross0 ^mem``) -Theorem mem_bigcross - `is_set_theory ^mem ⇒ - ∀ls x. (mem x (bigcross ls) ⇔ ∃xs. x = tuple xs ∧ LIST_REL mem xs ls)` - (strip_tac >> Induct >> +Theorem mem_bigcross: + is_set_theory ^mem ⇒ + ∀ls x. (mem x (bigcross ls) ⇔ ∃xs. x = tuple xs ∧ LIST_REL mem xs ls) +Proof + strip_tac >> Induct >> simp[bigcross_def,tuple_def,mem_one] >> - simp[mem_product,PULL_EXISTS,tuple_def]) + simp[mem_product,PULL_EXISTS,tuple_def] +QED val _ = export_theory() diff --git a/candle/set-theory/zfc/setModelScript.sml b/candle/set-theory/zfc/setModelScript.sml index 85c362c711..ea83eb2bc8 100644 --- a/candle/set-theory/zfc/setModelScript.sml +++ b/candle/set-theory/zfc/setModelScript.sml @@ -116,9 +116,10 @@ val FINITE_SET_THEORY_IMAGE = TAC_PROOF(([], first_assum (mp_tac o REFORM_RULE o SPECL[``(INR x):'a+num``,``(INR y):'a+num``,``(INR y'):'a+num``]) >> simp[]) -Theorem l_model_exists - `∃(P : α+num -> bool) (mem : α+num -> α+num -> bool). is_set_theory_pred P mem` - (qexists_tac`ISR` >> +Theorem l_model_exists: + ∃(P : α+num -> bool) (mem : α+num -> α+num -> bool). is_set_theory_pred P mem +Proof + qexists_tac`ISR` >> REWRITE_TAC[is_set_theory_pred_def] >> qexists_tac`λl1 l2. BIT (OUTR l1) (OUTR l2)` >> conj_tac >- (qexists_tac`INR 0` >> simp[]) >> @@ -330,7 +331,7 @@ Theorem l_model_exists qexists_tac`INR 0` >> simp[] ) >> qexists_tac`INR (LOG2 (OUTR x))` >> simp[BIT_LOG2,EVERY_GENLIST] - ) +QED val is_V_def = new_specification("is_V_def",["is_V"],REWRITE_RULE[is_set_theory_pred_def]l_model_exists) @@ -346,9 +347,10 @@ val V_mem_rep_def = val V_mem_def = Define`V_mem x y = V_mem_rep (dest_V x) (dest_V y)` -Theorem is_set_theory_V - `is_set_theory V_mem` - (simp[is_set_theory_def] >> +Theorem is_set_theory_V: + is_set_theory V_mem +Proof + simp[is_set_theory_def] >> conj_tac >- ( simp[extensional_def] >> simp[V_mem_def] >> @@ -408,7 +410,8 @@ Theorem is_set_theory_V y = z` by metis_tac[V_bij] >> asm_rewrite_tac[] >> disch_then (strip_assume_tac o REWRITE_RULE[V_bij] o Q.SPEC`dest_V d`) >> - metis_tac[V_bij] ) + metis_tac[V_bij] +QED val V_choice_exists = Q.prove( `∃ch. is_choice V_mem ch`, @@ -426,10 +429,12 @@ val V_indset_def = new_specification("V_indset_def",["V_indset"], METIS_PROVE[]``∃i:α V. (∃x:α V. is_inductive V_mem x) ⇒ is_inductive V_mem i``) -Theorem is_model_V - `(∃I:α V. is_inductive V_mem I) ⇒ - is_model (V_mem,V_indset:α V,V_choice)` - (simp[is_model_def,is_set_theory_V,V_choice_def,V_indset_def]) +Theorem is_model_V: + (∃I:α V. is_inductive V_mem I) ⇒ + is_model (V_mem,V_indset:α V,V_choice) +Proof + simp[is_model_def,is_set_theory_V,V_choice_def,V_indset_def] +QED val _ = print_theory_to_file "-" "setModel"; diff --git a/candle/set-theory/zfc/setSpecScript.sml b/candle/set-theory/zfc/setSpecScript.sml index 1dbc4f2823..b3eb43f5b9 100644 --- a/candle/set-theory/zfc/setSpecScript.sml +++ b/candle/set-theory/zfc/setSpecScript.sml @@ -65,25 +65,33 @@ val is_set_theory_def = Define` regular mem ∧ replacement mem` -Theorem separation_unique - `extensional ^mem ⇒ - ∀sub1 sub2. is_separation mem sub1 ∧ is_separation mem sub2 ⇒ sub1 = sub2` - (rw[is_separation_def,extensional_def,FUN_EQ_THM]) - -Theorem power_unique - `extensional ^mem ⇒ - ∀power1 power2. is_power mem power1 ∧ is_power mem power2 ⇒ power1 = power2` - (rw[is_power_def,extensional_def,FUN_EQ_THM]) - -Theorem union_unique - `extensional ^mem ⇒ - ∀union1 union2. is_union mem union1 ∧ is_union mem union2 ⇒ union1 = union2` - (rw[is_union_def,extensional_def,FUN_EQ_THM]) - -Theorem upair_unique - `extensional ^mem ⇒ - ∀upair1 upair2. is_upair mem upair1 ∧ is_upair mem upair2 ⇒ upair1 = upair2` - (rw[is_upair_def,extensional_def,FUN_EQ_THM]) +Theorem separation_unique: + extensional ^mem ⇒ + ∀sub1 sub2. is_separation mem sub1 ∧ is_separation mem sub2 ⇒ sub1 = sub2 +Proof + rw[is_separation_def,extensional_def,FUN_EQ_THM] +QED + +Theorem power_unique: + extensional ^mem ⇒ + ∀power1 power2. is_power mem power1 ∧ is_power mem power2 ⇒ power1 = power2 +Proof + rw[is_power_def,extensional_def,FUN_EQ_THM] +QED + +Theorem union_unique: + extensional ^mem ⇒ + ∀union1 union2. is_union mem union1 ∧ is_union mem union2 ⇒ union1 = union2 +Proof + rw[is_union_def,extensional_def,FUN_EQ_THM] +QED + +Theorem upair_unique: + extensional ^mem ⇒ + ∀upair1 upair2. is_upair mem upair1 ∧ is_upair mem upair2 ⇒ upair1 = upair2 +Proof + rw[is_upair_def,extensional_def,FUN_EQ_THM] +QED val sub_def = Define` sub ^mem = @sub. is_separation mem sub` @@ -97,29 +105,41 @@ val union_def = Define` val upair_def = Define` upair ^mem = @upair. is_upair mem upair` -Theorem is_extensional - `is_set_theory ^mem ⇒ extensional mem` - (rw[is_set_theory_def]) - -Theorem is_separation_sub - `is_set_theory ^mem ⇒ is_separation mem (sub mem)` - (rw[sub_def] >> SELECT_ELIM_TAC >> fsrw_tac[SATISFY_ss][is_set_theory_def]) - -Theorem is_power_power - `is_set_theory ^mem ⇒ is_power mem (power mem)` - (rw[power_def] >> SELECT_ELIM_TAC >> fsrw_tac[SATISFY_ss][is_set_theory_def]) - -Theorem is_union_union - `is_set_theory ^mem ⇒ is_union mem (union mem)` - (rw[union_def] >> SELECT_ELIM_TAC >> fsrw_tac[SATISFY_ss][is_set_theory_def]) - -Theorem is_upair_upair - `is_set_theory ^mem ⇒ is_upair mem (upair mem)` - (rw[upair_def] >> SELECT_ELIM_TAC >> fsrw_tac[SATISFY_ss][is_set_theory_def]) - -Theorem is_regular - `is_set_theory ^mem ⇒ regular mem` - (rw[is_set_theory_def]) +Theorem is_extensional: + is_set_theory ^mem ⇒ extensional mem +Proof + rw[is_set_theory_def] +QED + +Theorem is_separation_sub: + is_set_theory ^mem ⇒ is_separation mem (sub mem) +Proof + rw[sub_def] >> SELECT_ELIM_TAC >> fsrw_tac[SATISFY_ss][is_set_theory_def] +QED + +Theorem is_power_power: + is_set_theory ^mem ⇒ is_power mem (power mem) +Proof + rw[power_def] >> SELECT_ELIM_TAC >> fsrw_tac[SATISFY_ss][is_set_theory_def] +QED + +Theorem is_union_union: + is_set_theory ^mem ⇒ is_union mem (union mem) +Proof + rw[union_def] >> SELECT_ELIM_TAC >> fsrw_tac[SATISFY_ss][is_set_theory_def] +QED + +Theorem is_upair_upair: + is_set_theory ^mem ⇒ is_upair mem (upair mem) +Proof + rw[upair_def] >> SELECT_ELIM_TAC >> fsrw_tac[SATISFY_ss][is_set_theory_def] +QED + +Theorem is_regular: + is_set_theory ^mem ⇒ regular mem +Proof + rw[is_set_theory_def] +QED val _ = Parse.add_infix("suchthat",9,Parse.LEFT) val _ = Parse.overload_on("suchthat",``sub ^mem``) @@ -127,107 +147,135 @@ val _ = Parse.overload_on("Pow",``power ^mem``) val _ = Parse.overload_on("+",``upair ^mem``) val _ = Parse.overload_on("⋃",``union ^mem``) -Theorem mem_sub - `is_set_theory ^mem ⇒ ∀x s P. x <: (s suchthat P) ⇔ x <: s ∧ P x` - (strip_tac >> imp_res_tac is_separation_sub >> fs[is_separation_def]) - -Theorem mem_power - `is_set_theory ^mem ⇒ - ∀x y. x <: (Pow y) ⇔ (∀b. b <: x ⇒ b <: y)` - (strip_tac >> imp_res_tac is_power_power >> fs[is_power_def]) - -Theorem mem_union - `is_set_theory ^mem ⇒ - ∀x s. x <: ⋃ s ⇔ ∃a. x <: a ∧ a <: s` - (strip_tac >> imp_res_tac is_union_union >> fs[is_union_def]) - -Theorem mem_upair - `is_set_theory ^mem ⇒ ∀a x y. a <: (x + y) ⇔ a = x ∨ a = y` - (strip_tac >> imp_res_tac is_upair_upair >> fs[is_upair_def]) +Theorem mem_sub: + is_set_theory ^mem ⇒ ∀x s P. x <: (s suchthat P) ⇔ x <: s ∧ P x +Proof + strip_tac >> imp_res_tac is_separation_sub >> fs[is_separation_def] +QED + +Theorem mem_power: + is_set_theory ^mem ⇒ + ∀x y. x <: (Pow y) ⇔ (∀b. b <: x ⇒ b <: y) +Proof + strip_tac >> imp_res_tac is_power_power >> fs[is_power_def] +QED + +Theorem mem_union: + is_set_theory ^mem ⇒ + ∀x s. x <: ⋃ s ⇔ ∃a. x <: a ∧ a <: s +Proof + strip_tac >> imp_res_tac is_union_union >> fs[is_union_def] +QED + +Theorem mem_upair: + is_set_theory ^mem ⇒ ∀a x y. a <: (x + y) ⇔ a = x ∨ a = y +Proof + strip_tac >> imp_res_tac is_upair_upair >> fs[is_upair_def] +QED val empty_def = Define` empty ^mem = sub mem ARB (K F)` val _ = Parse.overload_on("∅",``empty ^mem``) -Theorem mem_empty - `is_set_theory ^mem ⇒ ∀x. ¬(x <: ∅)` - (strip_tac >> imp_res_tac is_separation_sub >> - fs[empty_def,is_separation_def]) - -Theorem not_empty - `is_set_theory ^mem ⇒ ∀x. ¬(x = ∅) ⇔ ∃y. y <: x` - (strip_tac >> imp_res_tac is_extensional >> - fs[empty_def,extensional_def,mem_sub]) - -Theorem eq_empty - `is_set_theory ^mem ⇒ ∀x. (x = ∅) ⇔ ∀y. ~(y <: x)` - (strip_tac >> imp_res_tac is_extensional >> - fs[empty_def,extensional_def,mem_sub]) +Theorem mem_empty: + is_set_theory ^mem ⇒ ∀x. ¬(x <: ∅) +Proof + strip_tac >> imp_res_tac is_separation_sub >> + fs[empty_def,is_separation_def] +QED + +Theorem not_empty: + is_set_theory ^mem ⇒ ∀x. ¬(x = ∅) ⇔ ∃y. y <: x +Proof + strip_tac >> imp_res_tac is_extensional >> + fs[empty_def,extensional_def,mem_sub] +QED + +Theorem eq_empty: + is_set_theory ^mem ⇒ ∀x. (x = ∅) ⇔ ∀y. ~(y <: x) +Proof + strip_tac >> imp_res_tac is_extensional >> + fs[empty_def,extensional_def,mem_sub] +QED val unit_def = Define` unit ^mem x = x + x` val _ = Parse.overload_on("Unit",``unit ^mem``) -Theorem mem_unit - `is_set_theory ^mem ⇒ - ∀x y. x <: (Unit y) ⇔ x = y` - (strip_tac >> imp_res_tac is_upair_upair >> - fs[is_upair_def,unit_def]) - -Theorem unit_inj - `is_set_theory ^mem ⇒ - ∀x y. Unit x = Unit y ⇔ x = y` - (strip_tac >> +Theorem mem_unit: + is_set_theory ^mem ⇒ + ∀x y. x <: (Unit y) ⇔ x = y +Proof + strip_tac >> imp_res_tac is_upair_upair >> + fs[is_upair_def,unit_def] +QED + +Theorem unit_inj: + is_set_theory ^mem ⇒ + ∀x y. Unit x = Unit y ⇔ x = y +Proof + strip_tac >> imp_res_tac is_extensional >> fs[extensional_def,mem_unit] >> - metis_tac[]) + metis_tac[] +QED val one_def = Define` one ^mem = Unit ∅` val _ = Parse.overload_on("One",``one ^mem``) -Theorem mem_one - `is_set_theory ^mem ⇒ - ∀x. x <: One ⇔ x = ∅` - (strip_tac >> simp[mem_unit,one_def]) +Theorem mem_one: + is_set_theory ^mem ⇒ + ∀x. x <: One ⇔ x = ∅ +Proof + strip_tac >> simp[mem_unit,one_def] +QED val two_def = Define` two ^mem = ∅ + One` val _ = Parse.overload_on("Two",``two ^mem``) -Theorem mem_two - `is_set_theory ^mem ⇒ - ∀x. x <: Two ⇔ x = ∅ ∨ x = One` - (strip_tac >> simp[mem_upair,mem_one,two_def]) +Theorem mem_two: + is_set_theory ^mem ⇒ + ∀x. x <: Two ⇔ x = ∅ ∨ x = One +Proof + strip_tac >> simp[mem_upair,mem_one,two_def] +QED val binary_inter_def = Define` binary_inter ^mem x y = (x suchthat λz. z <: y)` val _ = Parse.overload_on("INTER",``binary_inter ^mem``) -Theorem mem_binary_inter - `is_set_theory ^mem ⇒ - ∀x y z. x <: y ∩ z ⇔ x <: y ∧ x <: z` - (strip_tac >> simp[binary_inter_def,mem_sub]) +Theorem mem_binary_inter: + is_set_theory ^mem ⇒ + ∀x y z. x <: y ∩ z ⇔ x <: y ∧ x <: z +Proof + strip_tac >> simp[binary_inter_def,mem_sub] +QED val subset_def = Define` subset ^mem x y = ∀z. z <: x ⇒ z <: y` val _ = Parse.overload_on("SUBSET",``subset ^mem``) -Theorem subset_refl - `is_set_theory ^mem ⇒ - ∀x. x ⊆ x` - (strip_tac >> simp[subset_def]) +Theorem subset_refl: + is_set_theory ^mem ⇒ + ∀x. x ⊆ x +Proof + strip_tac >> simp[subset_def] +QED -Theorem subset_mem - `is_set_theory ^mem ⇒ - ∀x y z. x <: y ∧ y ⊆ z ⇒ x <: z` - (strip_tac >> simp[subset_def]) +Theorem subset_mem: + is_set_theory ^mem ⇒ + ∀x y z. x <: y ∧ y ⊆ z ⇒ x <: z +Proof + strip_tac >> simp[subset_def] +QED val psubset_def = Define` psubset ^mem x y = (x ⊆ y ∧ ~(x = y))` @@ -239,45 +287,55 @@ val pair_def = Define` val _ = Parse.overload_on(",",``pair ^mem``) -Theorem mem_pair - `is_set_theory ^mem ⇒ - ∀a x y. a <: (x,y) ⇔ a = Unit x ∨ a = (x + y)` - (strip_tac >> - simp[pair_def,mem_upair]) +Theorem mem_pair: + is_set_theory ^mem ⇒ + ∀a x y. a <: (x,y) ⇔ a = Unit x ∨ a = (x + y) +Proof + strip_tac >> + simp[pair_def,mem_upair] +QED -Theorem upair_inj - `is_set_theory ^mem ⇒ - ∀a b c d. a + b = c + d ⇔ a = c ∧ b = d ∨ a = d ∧ b = c` - (strip_tac >> +Theorem upair_inj: + is_set_theory ^mem ⇒ + ∀a b c d. a + b = c + d ⇔ a = c ∧ b = d ∨ a = d ∧ b = c +Proof + strip_tac >> imp_res_tac is_extensional >> fs[extensional_def,mem_upair] >> - metis_tac[]) + metis_tac[] +QED -Theorem unit_eq_upair - `is_set_theory ^mem ⇒ - ∀x y z. Unit x = y + z ⇔ x = y ∧ y = z` - (strip_tac >> +Theorem unit_eq_upair: + is_set_theory ^mem ⇒ + ∀x y z. Unit x = y + z ⇔ x = y ∧ y = z +Proof + strip_tac >> imp_res_tac is_extensional >> fs[extensional_def,mem_unit,mem_upair] >> - metis_tac[]) - -Theorem pair_inj - `is_set_theory ^mem ⇒ - ∀a b c d. (a,b) = (c,d) ⇔ a = c ∧ b = d` - (strip_tac >> fs[pair_def] >> rw[] >> + metis_tac[] +QED + +Theorem pair_inj: + is_set_theory ^mem ⇒ + ∀a b c d. (a,b) = (c,d) ⇔ a = c ∧ b = d +Proof + strip_tac >> fs[pair_def] >> rw[] >> simp[upair_inj,unit_inj,unit_eq_upair] >> - metis_tac[]) + metis_tac[] +QED val binary_union_def = Define` binary_union ^mem x y = ⋃ (upair mem x y)` val _ = Parse.overload_on("UNION",``binary_union ^mem``) -Theorem mem_binary_union - `is_set_theory ^mem ⇒ - ∀a x y. a <: (x ∪ y) ⇔ a <: x ∨ a <: y` - (strip_tac >> fs[binary_union_def,mem_union,mem_upair] >> - metis_tac[]) +Theorem mem_binary_union: + is_set_theory ^mem ⇒ + ∀a x y. a <: (x ∪ y) ⇔ a <: x ∨ a <: y +Proof + strip_tac >> fs[binary_union_def,mem_union,mem_upair] >> + metis_tac[] +QED val product_def = Define` product ^mem x y = @@ -286,40 +344,48 @@ val product_def = Define` val _ = Parse.overload_on("CROSS",``product ^mem``) -Theorem mem_product - `is_set_theory ^mem ⇒ - ∀a x y. a <: (x × y) ⇔ ∃b c. a = (b,c) ∧ b <: x ∧ c <: y` - (strip_tac >> fs[product_def] >> +Theorem mem_product: + is_set_theory ^mem ⇒ + ∀a x y. a <: (x × y) ⇔ ∃b c. a = (b,c) ∧ b <: x ∧ c <: y +Proof + strip_tac >> fs[product_def] >> simp[mem_sub,mem_power,mem_binary_union] >> rw[EQ_IMP_THM] >> TRY(metis_tac[]) >> rfs[pair_def,mem_upair] >> rw[] >> - rfs[mem_unit,mem_upair]) + rfs[mem_unit,mem_upair] +QED val relspace_def = Define` relspace ^mem x y = Pow (x × y)` val _ = Parse.overload_on("Relspace",``relspace ^mem``) -Theorem mem_relspace - `is_set_theory ^mem ⇒ +Theorem mem_relspace: + is_set_theory ^mem ⇒ ∀d r f. f <: Relspace d r ⇔ - f <: Pow (d × r)` - (rw[relspace_def]) - -Theorem relspace_pairs - `is_set_theory ^mem ⇒ - ∀d r f a. f <: Relspace d r ∧ a <: f ⇒ ∃x y. x <: d ∧ y <: r ∧ a = (x,y)` - (strip_tac >> + f <: Pow (d × r) +Proof + rw[relspace_def] +QED + +Theorem relspace_pairs: + is_set_theory ^mem ⇒ + ∀d r f a. f <: Relspace d r ∧ a <: f ⇒ ∃x y. x <: d ∧ y <: r ∧ a = (x,y) +Proof + strip_tac >> simp[relspace_def,mem_sub,mem_power,mem_product] >> - metis_tac[]) + metis_tac[] +QED -Theorem mem_rel - `is_set_theory ^mem ⇒ +Theorem mem_rel: + is_set_theory ^mem ⇒ ∀d r f. f <: Relspace d r ⇒ - ∀x y. (x,y) <: f ⇒ x <: d ∧ y <: r` - (strip_tac >> + ∀x y. (x,y) <: f ⇒ x <: d ∧ y <: r +Proof + strip_tac >> simp[relspace_def,mem_power,mem_product] >> - metis_tac[pair_inj]) + metis_tac[pair_inj] +QED val funspace_def = Define` funspace ^mem x y = @@ -328,18 +394,22 @@ val funspace_def = Define` val _ = Parse.overload_on("Funspace",``funspace ^mem``) -Theorem mem_funspace - `is_set_theory ^mem ⇒ +Theorem mem_funspace: + is_set_theory ^mem ⇒ ∀d r f. f <: Funspace d r ⇔ - f <: Relspace d r ∧ ∀x. x <: d ⇒ ∃!y. (x,y) <: f` - (rw[funspace_def,mem_sub]) - -Theorem funspace_pairs - `is_set_theory ^mem ⇒ - ∀d r f a. f <: Funspace d r ∧ a <: f ⇒ ∃x y. x <: d ∧ y <: r ∧ a = (x,y)` - (strip_tac >> + f <: Relspace d r ∧ ∀x. x <: d ⇒ ∃!y. (x,y) <: f +Proof + rw[funspace_def,mem_sub] +QED + +Theorem funspace_pairs: + is_set_theory ^mem ⇒ + ∀d r f a. f <: Funspace d r ∧ a <: f ⇒ ∃x y. x <: d ∧ y <: r ∧ a = (x,y) +Proof + strip_tac >> simp[funspace_def,mem_sub] >> - metis_tac[relspace_pairs]) + metis_tac[relspace_pairs] +QED val apply_def = Define` apply ^mem x y = @a. (y,a) <: x` @@ -351,23 +421,27 @@ val id_def = Define` val _ = Parse.overload_on("Id",``id ^mem``) -Theorem mem_id - `is_set_theory ^mem ⇒ - ∀d x y. (x,y) <: Id d ⇔ (y <: d ∧ x = y)` - (strip_tac >> +Theorem mem_id: + is_set_theory ^mem ⇒ + ∀d x y. (x,y) <: Id d ⇔ (y <: d ∧ x = y) +Proof + strip_tac >> simp[id_def,mem_sub,mem_product,pair_inj] >> rw[] >> EQ_TAC >> strip_tac >> - asm_rewrite_tac[]) + asm_rewrite_tac[] +QED -Theorem replacement - `is_set_theory ^mem ⇒ +Theorem replacement: + is_set_theory ^mem ⇒ ∀R. is_functional R ⇒ - ∀d. ∃r. ∀y. y <: r ⇔ ∃x. x <: d ∧ R x y` - (DISCH_TAC >> IMP_RES_TAC is_set_theory_def >> + ∀d. ∃r. ∀y. y <: r ⇔ ∃x. x <: d ∧ R x y +Proof + DISCH_TAC >> IMP_RES_TAC is_set_theory_def >> IMP_RES_THEN MP_TAC replacement_def >> - rw[]) + rw[] +QED val image_def = Define` image ^mem f d = @r. ∀y. y <: r ⇔ ∃x. x <: d ∧ f x = y` @@ -376,13 +450,15 @@ val _ = Parse.hide "''" val _ = Parse.add_infix("''",2000,Parse.LEFT) val _ = Parse.overload_on("''",``image ^mem``) -Theorem mem_image - `is_set_theory ^mem ⇒ - ∀f d y. y <: f '' d ⇔ ∃x. x <: d ∧ f x = y` - (REPEAT STRIP_TAC >> +Theorem mem_image: + is_set_theory ^mem ⇒ + ∀f d y. y <: f '' d ⇔ ∃x. x <: d ∧ f x = y +Proof + REPEAT STRIP_TAC >> IMP_RES_TAC replacement >> `is_functional (λx y. f x = y)` by simp[is_functional_def] >> - rw[image_def] >> SELECT_ELIM_TAC >> rw[replacement]) + rw[image_def] >> SELECT_ELIM_TAC >> rw[replacement] +QED val is_one_one_def = Define` is_one_one ^mem f d ⇔ ∀x y z. x <: d ∧ (x,z) <: f ∧ (y,z) <: f ⇒ x = y` @@ -399,35 +475,40 @@ val inverse_def = Define` val _ = Parse.overload_on("Inverse",``inverse ^mem``) -Theorem mem_inverse - `is_set_theory ^mem ⇒ - ∀f x y. (x,y) <: Inverse f ⇔ (y,x) <: f` - (strip_tac >> simp[inverse_def] >> rw[] >> +Theorem mem_inverse: + is_set_theory ^mem ⇒ + ∀f x y. (x,y) <: Inverse f ⇔ (y,x) <: f +Proof + strip_tac >> simp[inverse_def] >> rw[] >> SELECT_ELIM_TAC >> conj_tac >- ( qexists_tac`(⋃ (⋃ f) × ⋃ (⋃ f)) suchthat λa. ∃x y. a = (x,y) ∧ (y,x) <: f` >> simp[mem_sub,mem_product,mem_union,pair_inj] >> metis_tac[mem_pair,mem_unit,mem_upair,pair_inj] ) >> - metis_tac[pair_inj]) - -Theorem inverse_pairs - `is_set_theory ^mem ⇒ - ∀f a. a <: Inverse f ⇒ ∃y x. a = (y,x)` - (strip_tac >> simp[inverse_def] >> + metis_tac[pair_inj] +QED + +Theorem inverse_pairs: + is_set_theory ^mem ⇒ + ∀f a. a <: Inverse f ⇒ ∃y x. a = (y,x) +Proof + strip_tac >> simp[inverse_def] >> REPEAT gen_tac >> SELECT_ELIM_TAC >> conj_tac >- ( qexists_tac`(⋃ (⋃ f) × ⋃ (⋃ f)) suchthat λa. ∃x y. a = (x,y) ∧ (y,x) <: f` >> simp[mem_sub,mem_product,mem_union,pair_inj] >> metis_tac[mem_pair,mem_unit,mem_upair,pair_inj] ) >> - metis_tac[]) + metis_tac[] +QED (* Unless f is 1-1 and onto, Inverse f is not a function. *) -Theorem funspace_inverse - `is_set_theory ^mem ⇒ - ∀f d r. f <: Funspace d r ∧ is_11 f d ∧ is_Onto f r ⇒ Inverse f <: Funspace r d` - (strip_tac >> +Theorem funspace_inverse: + is_set_theory ^mem ⇒ + ∀f d r. f <: Funspace d r ∧ is_11 f d ∧ is_Onto f r ⇒ Inverse f <: Funspace r d +Proof + strip_tac >> simp[is_one_one_def,is_onto_def,mem_funspace,mem_relspace,mem_power,mem_product,EXISTS_UNIQUE_THM] >> REPEAT gen_tac >> strip_tac >> conj_tac >| @@ -436,33 +517,39 @@ Theorem funspace_inverse metis_tac[mem_inverse,pair_inj], simp[mem_inverse] >> metis_tac[pair_inj] - ]) + ] +QED -Theorem inverse_is_11_onto - `is_set_theory ^mem ⇒ - ∀f d r. f <: Funspace d r ∧ is_11 f d ∧ is_Onto f r ⇒ is_11 (Inverse f) r ∧ is_Onto (Inverse f) d` - (strip_tac >> +Theorem inverse_is_11_onto: + is_set_theory ^mem ⇒ + ∀f d r. f <: Funspace d r ∧ is_11 f d ∧ is_Onto f r ⇒ is_11 (Inverse f) r ∧ is_Onto (Inverse f) d +Proof + strip_tac >> simp[is_one_one_def,is_onto_def,mem_funspace,mem_relspace,mem_power,mem_product,EXISTS_UNIQUE_THM] >> REPEAT gen_tac >> strip_tac >> conj_tac >| [ simp[mem_inverse] >> metis_tac[pair_inj], simp[mem_inverse] - ]) + ] +QED -Theorem mem_funspace_pairs - `is_set_theory ^mem ⇒ - ∀f d r. f <: Funspace d r ⇒ ∀a. a <: f ⇒ ∃x y. a = (x,y)` - (strip_tac >> +Theorem mem_funspace_pairs: + is_set_theory ^mem ⇒ + ∀f d r. f <: Funspace d r ⇒ ∀a. a <: f ⇒ ∃x y. a = (x,y) +Proof + strip_tac >> simp[is_one_one_def,is_onto_def,mem_funspace,mem_relspace,mem_power,mem_product,EXISTS_UNIQUE_THM] >> - metis_tac[]) + metis_tac[] +QED val pop_tac = pop_assum (fn th => all_tac) -Theorem inverse_inverse_eq_id - `is_set_theory ^mem ⇒ - ∀f d r. f <: Funspace d r ∧ is_11 f d ∧ is_Onto f r ⇒ Inverse (Inverse f) = f` - (rw[] >> +Theorem inverse_inverse_eq_id: + is_set_theory ^mem ⇒ + ∀f d r. f <: Funspace d r ∧ is_11 f d ∧ is_Onto f r ⇒ Inverse (Inverse f) = f +Proof + rw[] >> `is_11 (Inverse f) r ∧ is_Onto (Inverse f) d` by metis_tac[inverse_is_11_onto] >> `Inverse f <: Funspace r d` by simp[funspace_inverse] >> `Inverse (Inverse f) <: Funspace d r` by simp[funspace_inverse] >> @@ -470,7 +557,8 @@ Theorem inverse_inverse_eq_id fs[extensional_def] >> pop_tac >> imp_res_tac mem_funspace_pairs >> - metis_tac[pair_inj,mem_inverse]) + metis_tac[pair_inj,mem_inverse] +QED val _ = Parse.overload_on("boolset",``Two``) @@ -483,33 +571,41 @@ val false_def = Define` val _ = Parse.overload_on("True",``true ^mem``) val _ = Parse.overload_on("False",``false ^mem``) -Theorem true_neq_false - `is_set_theory ^mem ⇒ True ≠ False` - (strip_tac >> +Theorem true_neq_false: + is_set_theory ^mem ⇒ True ≠ False +Proof + strip_tac >> imp_res_tac mem_one >> imp_res_tac mem_empty >> fs[true_def,false_def,is_set_theory_def,extensional_def,one_def] >> - metis_tac[]) + metis_tac[] +QED -Theorem mem_boolset - `is_set_theory ^mem ⇒ - ∀x. x <: boolset ⇔ ((x = True) ∨ (x = False))` - (strip_tac >> fs[mem_two,true_def,false_def]) +Theorem mem_boolset: + is_set_theory ^mem ⇒ + ∀x. x <: boolset ⇔ ((x = True) ∨ (x = False)) +Proof + strip_tac >> fs[mem_two,true_def,false_def] +QED val boolean_def = Define` boolean ^mem b = if b then True else False` val _ = Parse.overload_on("Boolean",``boolean ^mem``) -Theorem boolean_in_boolset - `is_set_theory ^mem ⇒ - ∀b. Boolean b <: boolset` - (strip_tac >> imp_res_tac mem_boolset >> - Cases >> simp[boolean_def]) +Theorem boolean_in_boolset: + is_set_theory ^mem ⇒ + ∀b. Boolean b <: boolset +Proof + strip_tac >> imp_res_tac mem_boolset >> + Cases >> simp[boolean_def] +QED -Theorem boolean_eq_true - `is_set_theory ^mem ⇒ ∀b. Boolean b = True ⇔ b` - (strip_tac >> rw[boolean_def,true_neq_false]) +Theorem boolean_eq_true: + is_set_theory ^mem ⇒ ∀b. Boolean b = True ⇔ b +Proof + strip_tac >> rw[boolean_def,true_neq_false] +QED val holds_def = Define` holds ^mem s x ⇔ s ' x = True` @@ -521,46 +617,56 @@ val suc_def = Define` val _ = Parse.overload_on("Suc",``suc ^mem``) -Theorem mem_suc - `is_set_theory ^mem ⇒ - ∀x y. x <: (Suc y) ⇔ x = y ∨ x <: y` - (strip_tac >> rw[suc_def,mem_binary_union,mem_unit] >> METIS_TAC[]) - -Theorem suc_not_empty - `is_set_theory ^mem ⇒ - ∀x. ~(∅ = Suc x)` - (strip_tac >> +Theorem mem_suc: + is_set_theory ^mem ⇒ + ∀x y. x <: (Suc y) ⇔ x = y ∨ x <: y +Proof + strip_tac >> rw[suc_def,mem_binary_union,mem_unit] >> METIS_TAC[] +QED + +Theorem suc_not_empty: + is_set_theory ^mem ⇒ + ∀x. ~(∅ = Suc x) +Proof + strip_tac >> imp_res_tac is_extensional >> fs[extensional_def,mem_empty] >> simp[suc_def,mem_binary_union,mem_unit] >> - metis_tac[]) + metis_tac[] +QED -Theorem not_mem_ident - `is_set_theory ^mem ⇒ - ∀x. ~(x <: x)` - (strip_tac >> +Theorem not_mem_ident: + is_set_theory ^mem ⇒ + ∀x. ~(x <: x) +Proof + strip_tac >> imp_res_tac is_regular >> gen_tac >> strip_tac >> fs[regular_def] >> first_assum (mp_tac o Q.SPEC`Unit x`) >> - simp[mem_unit]) + simp[mem_unit] +QED -Theorem not_mem_cycle - `is_set_theory ^mem ⇒ - ∀x y. ~(x <: y ∧ y <: x)` - (strip_tac >> +Theorem not_mem_cycle: + is_set_theory ^mem ⇒ + ∀x y. ~(x <: y ∧ y <: x) +Proof + strip_tac >> imp_res_tac is_regular >> REPEAT gen_tac >> strip_tac >> fs[regular_def] >> first_assum (mp_tac o Q.SPEC`x + y`) >> - metis_tac[mem_upair]) + metis_tac[mem_upair] +QED -Theorem suc_11 - `is_set_theory ^mem ⇒ - ∀x y. (Suc x = Suc y) ⇔ (x = y)` - (metis_tac[mem_suc,not_mem_cycle]) +Theorem suc_11: + is_set_theory ^mem ⇒ + ∀x y. (Suc x = Suc y) ⇔ (x = y) +Proof + metis_tac[mem_suc,not_mem_cycle] +QED val abstract_def = Define` @@ -568,52 +674,63 @@ val abstract_def = Define` val _ = Parse.overload_on("Abstract",``abstract ^mem``) -Theorem apply_abstract - `is_set_theory ^mem ⇒ - ∀f x s t. x <: s ∧ f x <: t ⇒ (Abstract s t f) ' x = f x` - (strip_tac >> +Theorem apply_abstract: + is_set_theory ^mem ⇒ + ∀f x s t. x <: s ∧ f x <: t ⇒ (Abstract s t f) ' x = f x +Proof + strip_tac >> rw[apply_def,abstract_def] >> SELECT_ELIM_TAC >> - simp[mem_sub,mem_product,pair_inj]) + simp[mem_sub,mem_product,pair_inj] +QED -Theorem apply_abstract_matchable - `∀f x s t u. x <: s ∧ f x <: t ∧ is_set_theory ^mem ∧ f x = u ⇒ Abstract s t f ' x = u` - (metis_tac[apply_abstract]) +Theorem apply_abstract_matchable: + ∀f x s t u. x <: s ∧ f x <: t ∧ is_set_theory ^mem ∧ f x = u ⇒ Abstract s t f ' x = u +Proof + metis_tac[apply_abstract] +QED -Theorem apply_in_rng - `is_set_theory ^mem ⇒ +Theorem apply_in_rng: + is_set_theory ^mem ⇒ ∀f x s t. x <: s ∧ f <: Funspace s t ⇒ - f ' x <: t` - (strip_tac >> + f ' x <: t +Proof + strip_tac >> simp[funspace_def,mem_sub,relspace_def, mem_power,apply_def,mem_product,EXISTS_UNIQUE_THM] >> - rw[] >> res_tac >> SELECT_ELIM_TAC >> res_tac >> rfs[pair_inj] >> metis_tac[]) + rw[] >> res_tac >> SELECT_ELIM_TAC >> res_tac >> rfs[pair_inj] >> metis_tac[] +QED -Theorem abstract_in_funspace - `is_set_theory ^mem ⇒ - ∀f s t. (∀x. x <: s ⇒ f x <: t) ⇒ Abstract s t f <: Funspace s t` - (strip_tac >> +Theorem abstract_in_funspace: + is_set_theory ^mem ⇒ + ∀f s t. (∀x. x <: s ⇒ f x <: t) ⇒ Abstract s t f <: Funspace s t +Proof + strip_tac >> simp[funspace_def,relspace_def,abstract_def,mem_power,mem_product,mem_sub] >> - simp[EXISTS_UNIQUE_THM,pair_inj]) + simp[EXISTS_UNIQUE_THM,pair_inj] +QED -Theorem abstract_eq - `is_set_theory ^mem ⇒ +Theorem abstract_eq: + is_set_theory ^mem ⇒ ∀s t1 t2 f g. (∀x. x <: s ⇒ f x <: t1 ∧ g x <: t2 ∧ f x = g x) - ⇒ Abstract s t1 f = Abstract s t2 g` - (rw[] >> + ⇒ Abstract s t1 f = Abstract s t2 g +Proof + rw[] >> imp_res_tac is_extensional >> pop_assum mp_tac >> simp[extensional_def] >> disch_then kall_tac >> simp[abstract_def,mem_sub,mem_product] >> - metis_tac[pair_inj]) + metis_tac[pair_inj] +QED -Theorem in_funspace_abstract - `is_set_theory ^mem ⇒ +Theorem in_funspace_abstract: + is_set_theory ^mem ⇒ ∀z s t. z <: Funspace s t ⇒ - ∃f. z = Abstract s t f ∧ (∀x. x <: s ⇒ f x <: t)` - (rw[funspace_def,mem_sub,relspace_def,mem_power] >> + ∃f. z = Abstract s t f ∧ (∀x. x <: s ⇒ f x <: t) +Proof + rw[funspace_def,mem_sub,relspace_def,mem_power] >> qexists_tac`λx. @y. (x,y) <: z` >> conj_tac >- ( imp_res_tac is_extensional >> @@ -626,37 +743,45 @@ Theorem in_funspace_abstract fs[EXISTS_UNIQUE_THM] >> metis_tac[] ) >> rfs[EXISTS_UNIQUE_THM,mem_product] >> - metis_tac[pair_inj]) + metis_tac[pair_inj] +QED -Theorem apply_eq_mem - `is_set_theory ^mem ⇒ +Theorem apply_eq_mem: + is_set_theory ^mem ⇒ ∀f d r. f <: Funspace d r ⇒ - ∀x. x <: d ⇒ ∀y. f ' x = y ⇔ (x,y) <: f` - (strip_tac >> simp[apply_def,mem_funspace,EXISTS_UNIQUE_THM] >> rw[] >> + ∀x. x <: d ⇒ ∀y. f ' x = y ⇔ (x,y) <: f +Proof + strip_tac >> simp[apply_def,mem_funspace,EXISTS_UNIQUE_THM] >> rw[] >> SELECT_ELIM_TAC >> conj_tac >- simp[] >> - metis_tac[]) - -Theorem id_funspace - `is_set_theory ^mem ⇒ - ∀d. Id d <: Funspace d d` - (strip_tac >> - simp[id_def,funspace_def,mem_sub,mem_relspace,mem_power,mem_product,pair_inj,EXISTS_UNIQUE_THM]) - -Theorem apply_id - `is_set_theory ^mem ⇒ - ∀d x. x <: d ⇒ Id d ' x = x` - (rw[] >> + metis_tac[] +QED + +Theorem id_funspace: + is_set_theory ^mem ⇒ + ∀d. Id d <: Funspace d d +Proof + strip_tac >> + simp[id_def,funspace_def,mem_sub,mem_relspace,mem_power,mem_product,pair_inj,EXISTS_UNIQUE_THM] +QED + +Theorem apply_id: + is_set_theory ^mem ⇒ + ∀d x. x <: d ⇒ Id d ' x = x +Proof + rw[] >> imp_res_tac id_funspace >> pop_assum (assume_tac o SPEC_ALL) >> imp_res_tac apply_eq_mem >> asm_rewrite_tac[] >> - simp[mem_id]) + simp[mem_id] +QED -Theorem apply_extensional - `is_set_theory ^mem ⇒ - ∀d r f g. f <: Funspace d r ∧ g <: Funspace d r ⇒ ((f = g) ⇔ ∀x. x <: d ⇒ f ' x = g ' x)` - (rw[] >> +Theorem apply_extensional: + is_set_theory ^mem ⇒ + ∀d r f g. f <: Funspace d r ∧ g <: Funspace d r ⇒ ((f = g) ⇔ ∀x. x <: d ⇒ f ' x = g ' x) +Proof + rw[] >> EQ_TAC >| [ strip_tac >> asm_rewrite_tac[], @@ -672,7 +797,8 @@ Theorem apply_extensional res_tac >> pop_assum mp_tac >> metis_tac[apply_eq_mem] - ]) + ] +QED val dep_funspace_def = Define` dep_funspace ^mem d f = @@ -681,13 +807,15 @@ val dep_funspace_def = Define` val _ = Parse.overload_on("Dep_funspace",``dep_funspace ^mem``) -Theorem mem_dep_funspace - `is_set_theory ^mem ⇒ +Theorem mem_dep_funspace: + is_set_theory ^mem ⇒ ∀f d g. g <: Dep_funspace d f ⇔ g <: Relspace d (⋃ (f '' d)) ∧ - ∀x. x <: d ⇒ (∃!y. (x,y) <: g) ∧ g ' x <: f x` - (rw[dep_funspace_def,mem_sub,mem_funspace] >> - METIS_TAC[]) + ∀x. x <: d ⇒ (∃!y. (x,y) <: g) ∧ g ' x <: f x +Proof + rw[dep_funspace_def,mem_sub,mem_funspace] >> + METIS_TAC[] +QED val dep_prodspace_def = Define` dep_prodspace ^mem d f = @@ -696,12 +824,14 @@ val dep_prodspace_def = Define` val _ = Parse.overload_on("Dep_prodspace",``dep_prodspace ^mem``) -Theorem mem_dep_prodspace - `is_set_theory ^mem ⇒ +Theorem mem_dep_prodspace: + is_set_theory ^mem ⇒ ∀f d r. r <: Dep_prodspace d f ⇔ r <: d × ⋃ (f '' d) ∧ - ∀x y. (x,y) <: r ⇒ x <: d ∧ y <: f x` - (rw[dep_prodspace_def,mem_sub]) + ∀x y. (x,y) <: r ⇒ x <: d ∧ y <: f x +Proof + rw[dep_prodspace_def,mem_sub] +QED val axiom_of_choice = save_thm("axiom_of_choice",UNDISCH(prove( ``is_set_theory ^mem ⇒ @@ -747,18 +877,24 @@ val is_model_def = Define` is_inductive mem indset ∧ is_choice mem ch` -Theorem is_model_is_set_theory - `is_model M ⇒ is_set_theory ^mem` - (rw[is_model_def]) - -Theorem indset_inhabited - `is_infinite ^mem indset ⇒ ∃i. i <: indset` - (rw[is_infinite_def] >> imp_res_tac INFINITE_INHAB >> - fs[] >> metis_tac[]) - -Theorem inductive_set_inhabited - `is_inductive ^mem indset ⇒ ∃i. i <: indset` - (metis_tac[is_inductive_def]) +Theorem is_model_is_set_theory: + is_model M ⇒ is_set_theory ^mem +Proof + rw[is_model_def] +QED + +Theorem indset_inhabited: + is_infinite ^mem indset ⇒ ∃i. i <: indset +Proof + rw[is_infinite_def] >> imp_res_tac INFINITE_INHAB >> + fs[] >> metis_tac[] +QED + +Theorem inductive_set_inhabited: + is_inductive ^mem indset ⇒ ∃i. i <: indset +Proof + metis_tac[is_inductive_def] +QED val num2indset_def = Define` (num2indset ^mem 0 = ∅) ∧ @@ -766,49 +902,60 @@ val num2indset_def = Define` val _ = Parse.overload_on("Num2indset",``num2indset ^mem``) -Theorem num2indset_in_indset - `is_inductive ^mem indset ⇒ ∀n. Num2indset n <: indset` - (simp[is_inductive_def] >> +Theorem num2indset_in_indset: + is_inductive ^mem indset ⇒ ∀n. Num2indset n <: indset +Proof + simp[is_inductive_def] >> strip_tac >> Induct >> - simp[num2indset_def]) + simp[num2indset_def] +QED -Theorem empty_num2indset - `is_set_theory ^mem ⇒ - ∀n. ∅ = Num2indset n ∨ ∅ <: Num2indset n` - (strip_tac >> +Theorem empty_num2indset: + is_set_theory ^mem ⇒ + ∀n. ∅ = Num2indset n ∨ ∅ <: Num2indset n +Proof + strip_tac >> Induct >> - simp[num2indset_def,mem_suc]) + simp[num2indset_def,mem_suc] +QED -Theorem full_mem_num2indset - `is_set_theory ^mem ⇒ - ∀n m. m < n ⇒ Num2indset m <: Num2indset n` - (strip_tac >> +Theorem full_mem_num2indset: + is_set_theory ^mem ⇒ + ∀n m. m < n ⇒ Num2indset m <: Num2indset n +Proof + strip_tac >> Induct >> simp[prim_recTheory.NOT_LESS_0,prim_recTheory.LESS_THM,num2indset_def,mem_suc] >> - metis_tac[]) + metis_tac[] +QED -Theorem mem_num2indset_is_num2indset - `is_set_theory ^mem ⇒ - ∀n a. a <: Num2indset n ⇒ ∃m. a = Num2indset m ∧ m < n` - (strip_tac >> +Theorem mem_num2indset_is_num2indset: + is_set_theory ^mem ⇒ + ∀n a. a <: Num2indset n ⇒ ∃m. a = Num2indset m ∧ m < n +Proof + strip_tac >> Induct >> simp[prim_recTheory.NOT_LESS_0,prim_recTheory.LESS_THM,num2indset_def,mem_empty,mem_suc] >> - metis_tac[]) + metis_tac[] +QED -Theorem mem_num2indset_is_num2indset_eq - `is_set_theory ^mem ⇒ - ∀n a. (a <: Num2indset n) = ∃m. a = Num2indset m ∧ m < n` - (metis_tac[mem_num2indset_is_num2indset,full_mem_num2indset] ) +Theorem mem_num2indset_is_num2indset_eq: + is_set_theory ^mem ⇒ + ∀n a. (a <: Num2indset n) = ∃m. a = Num2indset m ∧ m < n +Proof + metis_tac[mem_num2indset_is_num2indset,full_mem_num2indset] +QED val MAX_SUC = TAC_PROOF(([], ``∀a b. MAX (SUC a) (SUC b) = SUC (MAX a b)``), simp[arithmeticTheory.MAX_DEF]) -Theorem num2indset_11 - `is_set_theory ^mem ⇒ - ∀n m. (Num2indset n = Num2indset m) ⇔ (n = m)` - (strip_tac >> +Theorem num2indset_11: + is_set_theory ^mem ⇒ + ∀n m. (Num2indset n = Num2indset m) ⇔ (n = m) +Proof + strip_tac >> completeInduct_on `MAX n m` >> Cases >> Cases >> simp[num2indset_def,mem_suc,mem_empty,suc_not_empty,empty_num2indset] >> @@ -818,18 +965,22 @@ Theorem num2indset_11 first_assum (fn th => rewrite_tac[th]) >> rewrite_tac[prim_recTheory.LESS_SUC_REFL] >> strip_tac >> - simp[suc_11]) + simp[suc_11] +QED -Theorem num2indset_mem_less - `is_set_theory ^mem ⇒ - ∀n m. (Num2indset m <: Num2indset n) ⇔ (m < n)` - (strip_tac >> +Theorem num2indset_mem_less: + is_set_theory ^mem ⇒ + ∀n m. (Num2indset m <: Num2indset n) ⇔ (m < n) +Proof + strip_tac >> simp[mem_num2indset_is_num2indset_eq] >> - simp[num2indset_11]) + simp[num2indset_11] +QED -Theorem inductive_set_infinite - `is_set_theory ^mem ∧ is_inductive ^mem indset ⇒ is_infinite mem indset` - (rw[is_infinite_def] >> +Theorem inductive_set_infinite: + is_set_theory ^mem ∧ is_inductive ^mem indset ⇒ is_infinite mem indset +Proof + rw[is_infinite_def] >> match_mp_tac (REFORM_RULE INFINITE_SUBSET) >> qexists_tac`pred_set$IMAGE Num2indset UNIV` >> conj_tac >| [ @@ -839,52 +990,63 @@ Theorem inductive_set_infinite simp_tac (bool_ss ++ pred_setLib.PRED_SET_ss) [SUBSET_DEF] >> rw[] >> - simp[num2indset_in_indset] ]) + simp[num2indset_in_indset] ] +QED -Theorem funspace_inhabited - `is_set_theory ^mem ⇒ ∀s t. (∃x. x <: s) ∧ (∃x. x <: t) ⇒ ∃f. f <: Funspace s t` - (rw[] >> qexists_tac`Abstract s t (λx. @x. x <: t)` >> +Theorem funspace_inhabited: + is_set_theory ^mem ⇒ ∀s t. (∃x. x <: s) ∧ (∃x. x <: t) ⇒ ∃f. f <: Funspace s t +Proof + rw[] >> qexists_tac`Abstract s t (λx. @x. x <: t)` >> match_mp_tac (MP_CANON abstract_in_funspace) >> - metis_tac[]) + metis_tac[] +QED val tuple_def = Define` (tuple0 ^mem [] = ∅) ∧ (tuple0 ^mem (a::as) = (a, tuple0 ^mem as))` val _ = Parse.overload_on("tuple",``tuple0 ^mem``) -Theorem pair_not_empty - `is_set_theory ^mem ⇒ (x,y) ≠ ∅` - (rw[] >> +Theorem pair_not_empty: + is_set_theory ^mem ⇒ (x,y) ≠ ∅ +Proof + rw[] >> imp_res_tac is_extensional >> fs[extensional_def,mem_empty] >> pop_assum kall_tac >> simp[pair_def,mem_upair] >> - metis_tac[]) - -Theorem tuple_empty - `is_set_theory ^mem ⇒ ∀ls. tuple ls = ∅ ⇔ ls = []` - (strip_tac >> Cases >> simp[tuple_def] >> - simp[pair_not_empty] ) - -Theorem tuple_inj - `is_set_theory ^mem ⇒ - ∀l1 l2. tuple l1 = tuple l2 ⇔ l1 = l2` - (strip_tac >> + metis_tac[] +QED + +Theorem tuple_empty: + is_set_theory ^mem ⇒ ∀ls. tuple ls = ∅ ⇔ ls = [] +Proof + strip_tac >> Cases >> simp[tuple_def] >> + simp[pair_not_empty] +QED + +Theorem tuple_inj: + is_set_theory ^mem ⇒ + ∀l1 l2. tuple l1 = tuple l2 ⇔ l1 = l2 +Proof + strip_tac >> Induct >> simp[tuple_def] >- metis_tac[tuple_empty] >> gen_tac >> Cases >> simp[tuple_def,pair_not_empty] >> - simp[pair_inj]) + simp[pair_inj] +QED val bigcross_def = Define` (bigcross0 ^mem [] = One) ∧ (bigcross0 ^mem (a::as) = a × (bigcross0 ^mem as))` val _ = Parse.overload_on("bigcross",``bigcross0 ^mem``) -Theorem mem_bigcross - `is_set_theory ^mem ⇒ - ∀ls x. (mem x (bigcross ls) ⇔ ∃xs. x = tuple xs ∧ LIST_REL mem xs ls)` - (strip_tac >> Induct >> +Theorem mem_bigcross: + is_set_theory ^mem ⇒ + ∀ls x. (mem x (bigcross ls) ⇔ ∃xs. x = tuple xs ∧ LIST_REL mem xs ls) +Proof + strip_tac >> Induct >> simp[bigcross_def,tuple_def,mem_one] >> - simp[mem_product,PULL_EXISTS,tuple_def]) + simp[mem_product,PULL_EXISTS,tuple_def] +QED val _ = print_theory_to_file "-" "setSpec"; diff --git a/candle/standard/ml_kernel/ml_hol_initScript.sml b/candle/standard/ml_kernel/ml_hol_initScript.sml index 24cf621219..3b550f034e 100644 --- a/candle/standard/ml_kernel/ml_hol_initScript.sml +++ b/candle/standard/ml_kernel/ml_hol_initScript.sml @@ -11,11 +11,12 @@ val _ = new_theory"ml_hol_init" val EVAL_STATE_CONV = ((STRIP_QUANT_CONV o RAND_CONV o RAND_CONV o RAND_CONV) EVAL) THENC (SIMP_CONV (srw_ss()) []); -Theorem kernel_init_thm - `∃refs. !p. +Theorem kernel_init_thm: + ∃refs. !p. (HOL_STORE refs * GC) (st2heap (p : 'ffi ffi_proj) (candle_init_state ffi)) ∧ - STATE init_ctxt refs` - (`?refs. + STATE init_ctxt refs +Proof + `?refs. refs.the_type_constants = init_type_constants ∧ refs.the_term_constants = init_term_constants ∧ refs.the_axioms = init_axioms ∧ @@ -29,6 +30,7 @@ Theorem kernel_init_thm ((SIMP_CONV bool_ss [REFS_PRED_def]) THENC EVAL_STATE_CONV) INIT_HOL_STORE) \\ pop_assum drule \\ fs [] \\ disch_then (qspec_then `p` assume_tac) - \\ fs [st2heap_def]); + \\ fs [st2heap_def] +QED val _ = export_theory() diff --git a/candle/standard/ml_kernel/ml_hol_kernelProgScript.sml b/candle/standard/ml_kernel/ml_hol_kernelProgScript.sml index 7d3aa7c839..d93b1602ef 100644 --- a/candle/standard/ml_kernel/ml_hol_kernelProgScript.sml +++ b/candle/standard/ml_kernel/ml_hol_kernelProgScript.sml @@ -123,9 +123,9 @@ val res = translate holKernelTheory.type_subst_def; val res = translate alphavars_def; val res = translate holKernelPmatchTheory.raconv_def; -Theorem raconv_side - `!x y z. raconv_side x y z` - (ho_match_mp_tac holKernelTheory.raconv_ind +Theorem raconv_side = Q.prove(` + !x y z. raconv_side x y z`, + ho_match_mp_tac holKernelTheory.raconv_ind \\ ntac 4 (rw [Once (fetch "-" "raconv_side_def")])) |> update_precondition; diff --git a/candle/standard/monadic/holKernelProofScript.sml b/candle/standard/monadic/holKernelProofScript.sml index d5d170fc7e..a4e74a68c9 100644 --- a/candle/standard/monadic/holKernelProofScript.sml +++ b/candle/standard/monadic/holKernelProofScript.sml @@ -21,11 +21,13 @@ val _ = hide "state"; val _ = type_abbrev("M", ``: hol_refs -> ('a, hol_exn) exc # hol_refs``); -Theorem rev_assocd_thm - `rev_assocd = REV_ASSOCD` - (SIMP_TAC std_ss [FUN_EQ_THM] \\ Induct_on `x'` +Theorem rev_assocd_thm: + rev_assocd = REV_ASSOCD +Proof + SIMP_TAC std_ss [FUN_EQ_THM] \\ Induct_on `x'` \\ ONCE_REWRITE_TAC [rev_assocd_def] \\ SRW_TAC [] [REV_ASSOCD] - \\ Cases_on `h` \\ SRW_TAC [] [REV_ASSOCD]); + \\ Cases_on `h` \\ SRW_TAC [] [REV_ASSOCD] +QED val REPLICATE_GENLIST = rich_listTheory.REPLICATE_GENLIST @@ -250,18 +252,21 @@ val THM_term_ok_bool = Q.prove( \\ METIS_TAC [WELLTYPED_LEMMA]) (* TODO move *) -Theorem ALOOKUP_ALL_DISTINCT_MEM_EXISTS - `(?k. MEM (k,v) alist) /\ +Theorem ALOOKUP_ALL_DISTINCT_MEM_EXISTS: + (?k. MEM (k,v) alist) /\ ALL_DISTINCT (MAP FST alist) ==> - ?k. ALOOKUP alist k = SOME v` - (rw [] \\ qexists_tac `k` \\ metis_tac [ALOOKUP_ALL_DISTINCT_MEM]); + ?k. ALOOKUP alist k = SOME v +Proof + rw [] \\ qexists_tac `k` \\ metis_tac [ALOOKUP_ALL_DISTINCT_MEM] +QED -Theorem the_term_constants_TYPE - `STATE defs refs +Theorem the_term_constants_TYPE: + STATE defs refs ==> - EVERY (\(_, ty). TYPE defs ty) refs.the_term_constants` - (rw [STATE_def, TYPE_def, EVERY_MEM, MEM_FLAT, UNCURRY] + EVERY (\(_, ty). TYPE defs ty) refs.the_term_constants +Proof + rw [STATE_def, TYPE_def, EVERY_MEM, MEM_FLAT, UNCURRY] \\ imp_res_tac CONTEXT_ALL_DISTINCT \\ fs [CONTEXT_def] \\ drule extends_theory_ok \\ simp [init_theory_ok] @@ -271,7 +276,8 @@ Theorem the_term_constants_TYPE \\ match_mp_tac ALOOKUP_ALL_DISTINCT_MEM_EXISTS \\ fs [] \\ fs [MEM_FLAT] \\ qexists_tac `FST e` \\ fs [] - \\ asm_exists_tac \\ fs []); + \\ asm_exists_tac \\ fs [] +QED (* ------------------------------------------------------------------------- *) (* Verification of type functions *) @@ -302,50 +308,62 @@ val get_type_arity_thm = Q.prove( get_the_type_constants_def] \\ REPEAT STRIP_TAC \\ IMP_RES_TAC assoc_thm); -Theorem mk_vartype_thm - `!name s. +Theorem mk_vartype_thm: + !name s. STATE s.the_context s ⇒ - TYPE s.the_context (mk_vartype name)` - (SIMP_TAC (srw_ss()) [mk_vartype_def,TYPE_def,type_ok_def,STATE_def]); + TYPE s.the_context (mk_vartype name) +Proof + SIMP_TAC (srw_ss()) [mk_vartype_def,TYPE_def,type_ok_def,STATE_def] +QED -Theorem mk_type_thm - `!tyop args s z s'. +Theorem mk_type_thm: + !tyop args s z s'. STATE defs s /\ EVERY (TYPE defs) args /\ (mk_type (tyop,args) s = (z,s')) ==> (s' = s) /\ ((tyop = (strlit "fun")) /\ (LENGTH args = 2) ==> ?i. z = Success i) /\ - !i. (z = Success i) ==> TYPE defs i /\ (i = Tyapp tyop args)` - (SIMP_TAC std_ss [mk_type_def,try_def,st_ex_bind_def,otherwise_def] + !i. (z = Success i) ==> TYPE defs i /\ (i = Tyapp tyop args) +Proof + SIMP_TAC std_ss [mk_type_def,try_def,st_ex_bind_def,otherwise_def] \\ NTAC 3 STRIP_TAC \\ Cases_on `get_type_arity tyop s` \\ IMP_RES_TAC get_type_arity_thm \\ Cases_on `q` \\ FULL_SIMP_TAC (srw_ss()) [raise_Fail_def,st_ex_return_def] \\ SRW_TAC [] [st_ex_return_def] \\ IMP_RES_TAC TYPE_Tyapp - \\ fs[STATE_def] >> METIS_TAC[CONTEXT_fun]) + \\ fs[STATE_def] >> METIS_TAC[CONTEXT_fun] +QED -Theorem dest_type_thm - `!ty s z s'. +Theorem dest_type_thm: + !ty s z s'. STATE defs s /\ (dest_type ty s = (z,s')) /\ TYPE defs ty ==> (s' = s) /\ !i. (z = Success i) ==> ?n tys. (ty = Tyapp n tys) /\ (i = (n,tys)) /\ - EVERY (TYPE defs) tys` - (Cases \\ FULL_SIMP_TAC (srw_ss()) [dest_type_def,raise_Fail_def,st_ex_return_def] + EVERY (TYPE defs) tys +Proof + Cases \\ FULL_SIMP_TAC (srw_ss()) [dest_type_def,raise_Fail_def,st_ex_return_def] \\ FULL_SIMP_TAC std_ss [TYPE_def,EVERY_MEM] \\ SRW_TAC [] [] - >> fs[type_ok_def,EVERY_MAP,EVERY_MEM]) + >> fs[type_ok_def,EVERY_MAP,EVERY_MEM] +QED -Theorem dest_vartype_thm - `!ty s z s'. +Theorem dest_vartype_thm: + !ty s z s'. (dest_vartype ty s = (z,s')) ==> (s' = s) /\ - !i. (z = Success i) ==> (ty = Tyvar i)` - (Cases \\ FULL_SIMP_TAC (srw_ss()) - [dest_vartype_def,raise_Fail_def,st_ex_return_def]); - -Theorem is_type_thm - `!ty. is_type ty = ?s tys. ty = Tyapp s tys` - (Cases \\ SIMP_TAC (srw_ss()) [is_type_def]); - -Theorem is_vartype_thm - `!ty. is_vartype ty = ?s. ty = Tyvar s` - (Cases \\ SIMP_TAC (srw_ss()) [is_vartype_def]); + !i. (z = Success i) ==> (ty = Tyvar i) +Proof + Cases \\ FULL_SIMP_TAC (srw_ss()) + [dest_vartype_def,raise_Fail_def,st_ex_return_def] +QED + +Theorem is_type_thm: + !ty. is_type ty = ?s tys. ty = Tyapp s tys +Proof + Cases \\ SIMP_TAC (srw_ss()) [is_type_def] +QED + +Theorem is_vartype_thm: + !ty. is_vartype ty = ?s. ty = Tyvar s +Proof + Cases \\ SIMP_TAC (srw_ss()) [is_vartype_def] +QED val tyvars_thm = Q.prove( `!ty s. MEM s (holKernel$tyvars ty) = MEM s (holSyntax$tyvars ty)`, @@ -358,12 +376,13 @@ val tyvars_thm = Q.prove( \\ SIMP_TAC (srw_ss()) [Once itlist_def,FOLDR,MEM_union,MEM_LIST_UNION] \\ METIS_TAC []); -Theorem type_subst - `!i ty. +Theorem type_subst: + !i ty. (type_subst i ty = TYPE_SUBST i ty) /\ (EVERY (\(x,y). TYPE s x /\ TYPE s y) i /\ TYPE s ty ==> - TYPE s (type_subst i ty))` - (HO_MATCH_MP_TAC type_subst_ind \\ STRIP_TAC \\ Cases THEN1 + TYPE s (type_subst i ty)) +Proof + HO_MATCH_MP_TAC type_subst_ind \\ STRIP_TAC \\ Cases THEN1 (SIMP_TAC (srw_ss()) [Once type_subst_def] >> SIMP_TAC (srw_ss()) [Once type_subst_def] \\ Induct_on `i` \\ TRY Cases \\ ONCE_REWRITE_TAC [rev_assocd_def] @@ -375,15 +394,18 @@ Theorem type_subst TRY (match_mp_tac EQ_TRANS >> first_assum(match_exists_tac o concl)) >> rw[MAP_EQ_f] ) >> - fs[TYPE_def,type_ok_def,EVERY_MAP,EVERY_MEM]) + fs[TYPE_def,type_ok_def,EVERY_MAP,EVERY_MEM] +QED -Theorem mk_fun_ty_thm - `!ty1 ty2 s z s'. +Theorem mk_fun_ty_thm: + !ty1 ty2 s z s'. STATE defs s /\ EVERY (TYPE defs) [ty1;ty2] /\ (mk_fun_ty ty1 ty2 s = (z,s')) ==> (s' = s) /\ - ?i. (z = Success i) /\ (i = Tyapp (strlit "fun") [ty1;ty2]) /\ TYPE defs i` - (SIMP_TAC std_ss [mk_fun_ty_def] \\ REPEAT STRIP_TAC - \\ IMP_RES_TAC mk_type_thm \\ FULL_SIMP_TAC (srw_ss()) []); + ?i. (z = Success i) /\ (i = Tyapp (strlit "fun") [ty1;ty2]) /\ TYPE defs i +Proof + SIMP_TAC std_ss [mk_fun_ty_def] \\ REPEAT STRIP_TAC + \\ IMP_RES_TAC mk_type_thm \\ FULL_SIMP_TAC (srw_ss()) [] +QED (* ------------------------------------------------------------------------- *) (* Verification of term functions *) @@ -425,15 +447,16 @@ val term_type = Q.prove( imp_res_tac CONTEXT_std_sig >> fs[TYPE_def,type_ok_def,is_std_sig_def]) -Theorem type_of_has_type - `!tm refs ty refs'. +Theorem type_of_has_type: + !tm refs ty refs'. STATE defs refs /\ TERM defs tm /\ (type_of tm refs = (Success ty, refs')) ==> tm has_type ty /\ - (typeof tm = ty)` - (Induct \\ rpt gen_tac \\ once_rewrite_tac [type_of_def] \\ fs [] + (typeof tm = ty) +Proof + Induct \\ rpt gen_tac \\ once_rewrite_tac [type_of_def] \\ fs [] \\ fs [st_ex_return_def, st_ex_bind_def, raise_Fail_def] \\ rw [] \\ once_rewrite_tac [holSyntaxTheory.has_type_rules] \\ fs [TERM_def] @@ -462,7 +485,8 @@ Theorem type_of_has_type \\ every_case_tac \\ fs [] \\ rw [] \\ last_x_assum drule \\ disch_then drule \\ rw [] - \\ simp [holSyntaxTheory.has_type_rules]); + \\ simp [holSyntaxTheory.has_type_rules] +QED val type_of_thm = Q.prove( `!tm. TERM defs tm /\ STATE defs s ==> @@ -537,32 +561,40 @@ val raconv_thm = Q.prove( THEN1 (REPEAT STRIP_TAC \\ MATCH_MP_TAC TERM_Var \\ FULL_SIMP_TAC std_ss []) \\ REPEAT STRIP_TAC \\ FULL_SIMP_TAC std_ss []) -Theorem aconv_thm - `!tm1 tm2 env. +Theorem aconv_thm: + !tm1 tm2 env. STATE defs s /\ TERM defs tm1 /\ TERM defs tm2 ==> - (aconv tm1 tm2 = ACONV tm1 tm2)` - (SIMP_TAC std_ss [aconv_def,ACONV_def] \\ REPEAT STRIP_TAC + (aconv tm1 tm2 = ACONV tm1 tm2) +Proof + SIMP_TAC std_ss [aconv_def,ACONV_def] \\ REPEAT STRIP_TAC \\ IMP_RES_TAC (raconv_thm |> Q.SPECL [`t1`,`t2`,`[]`] |> SIMP_RULE std_ss [EVERY_DEF,MAP]) - \\ FULL_SIMP_TAC std_ss []); + \\ FULL_SIMP_TAC std_ss [] +QED -Theorem is_term_thm - `(is_var tm = ?n ty. tm = Var n ty) /\ +Theorem is_term_thm: + (is_var tm = ?n ty. tm = Var n ty) /\ (is_const tm = ?n ty. tm = Const n ty) /\ (is_abs tm = ?v x. tm = Abs v x) /\ - (is_comb tm = ?x y. tm = Comb x y)` - (Cases_on `tm` \\ EVAL_TAC \\ FULL_SIMP_TAC std_ss []); - -Theorem mk_var_thm - `STATE defs s /\ TYPE defs ty ==> TERM defs (mk_var(v,ty))` - (SIMP_TAC std_ss [mk_var_def] \\ METIS_TAC [TERM_Var]); - -Theorem mk_abs_thm - `!res. + (is_comb tm = ?x y. tm = Comb x y) +Proof + Cases_on `tm` \\ EVAL_TAC \\ FULL_SIMP_TAC std_ss [] +QED + +Theorem mk_var_thm: + STATE defs s /\ TYPE defs ty ==> TERM defs (mk_var(v,ty)) +Proof + SIMP_TAC std_ss [mk_var_def] \\ METIS_TAC [TERM_Var] +QED + +Theorem mk_abs_thm: + !res. TERM defs bvar /\ TERM defs bod /\ (mk_abs(bvar,bod) s = (res,s1)) ==> - (s1 = s) /\ !t. (res = Success t) ==> TERM defs t /\ (t = Abs bvar bod)` - (FULL_SIMP_TAC std_ss [mk_abs_def] \\ Cases_on `bvar` - \\ FULL_SIMP_TAC (srw_ss()) [st_ex_return_def,raise_Fail_def,IMP_TERM_Abs]); + (s1 = s) /\ !t. (res = Success t) ==> TERM defs t /\ (t = Abs bvar bod) +Proof + FULL_SIMP_TAC std_ss [mk_abs_def] \\ Cases_on `bvar` + \\ FULL_SIMP_TAC (srw_ss()) [st_ex_return_def,raise_Fail_def,IMP_TERM_Abs] +QED val mk_comb_thm = Q.prove( `TERM defs f /\ TERM defs a /\ STATE defs s /\ @@ -587,55 +619,67 @@ val mk_comb_thm = Q.prove( \\ FULL_SIMP_TAC std_ss [MAP] \\ METIS_TAC [IMP_TERM_Comb,STATE_def]); -Theorem dest_var_thm - `TERM defs v /\ STATE defs s ==> +Theorem dest_var_thm: + TERM defs v /\ STATE defs s ==> (dest_var v s = (res,s')) ==> - (s' = s) /\ !n ty. (res = Success (n,ty)) ==> TYPE defs ty` - (Cases_on `v` + (s' = s) /\ !n ty. (res = Success (n,ty)) ==> TYPE defs ty +Proof + Cases_on `v` \\ SIMP_TAC (srw_ss()) [holKernelTheory.dest_var_def,st_ex_return_def,Once EQ_SYM_EQ,raise_Fail_def] - \\ REPEAT STRIP_TAC \\ IMP_RES_TAC TERM); + \\ REPEAT STRIP_TAC \\ IMP_RES_TAC TERM +QED -Theorem dest_const_thm - `TERM defs v /\ STATE defs s ==> +Theorem dest_const_thm: + TERM defs v /\ STATE defs s ==> (dest_const v s = (res,s')) ==> - (s' = s) /\ !n ty. (res = Success (n,ty)) ==> TYPE defs ty` - (Cases_on `v` + (s' = s) /\ !n ty. (res = Success (n,ty)) ==> TYPE defs ty +Proof + Cases_on `v` \\ SIMP_TAC (srw_ss()) [dest_const_def,st_ex_return_def,Once EQ_SYM_EQ,raise_Fail_def] - \\ REPEAT STRIP_TAC \\ IMP_RES_TAC TERM); + \\ REPEAT STRIP_TAC \\ IMP_RES_TAC TERM +QED -Theorem dest_comb_thm - `TERM defs v /\ STATE defs s ==> +Theorem dest_comb_thm: + TERM defs v /\ STATE defs s ==> (dest_comb v s = (res,s')) ==> - (s' = s) /\ !x y. (res = Success (x,y)) ==> TERM defs x /\ TERM defs y` - (Cases_on `v` + (s' = s) /\ !x y. (res = Success (x,y)) ==> TERM defs x /\ TERM defs y +Proof + Cases_on `v` \\ SIMP_TAC (srw_ss()) [dest_comb_def,st_ex_return_def,Once EQ_SYM_EQ,raise_Fail_def] - \\ REPEAT STRIP_TAC \\ IMP_RES_TAC TERM); + \\ REPEAT STRIP_TAC \\ IMP_RES_TAC TERM +QED -Theorem dest_abs_thm - `TERM defs v /\ STATE defs s ==> +Theorem dest_abs_thm: + TERM defs v /\ STATE defs s ==> (dest_abs v s = (res,s')) ==> - (s' = s) /\ !x y. (res = Success (x,y)) ==> TERM defs x /\ TERM defs y` - (Cases_on `v` + (s' = s) /\ !x y. (res = Success (x,y)) ==> TERM defs x /\ TERM defs y +Proof + Cases_on `v` \\ SIMP_TAC (srw_ss()) [dest_abs_def,st_ex_return_def,Once EQ_SYM_EQ,raise_Fail_def] \\ REPEAT STRIP_TAC \\ IMP_RES_TAC Abs_Var \\ FULL_SIMP_TAC std_ss [] \\ IMP_RES_TAC TERM - \\ IMP_RES_TAC TERM_Var \\ FULL_SIMP_TAC std_ss []); + \\ IMP_RES_TAC TERM_Var \\ FULL_SIMP_TAC std_ss [] +QED -Theorem rator_thm - `TERM defs v /\ STATE defs s ==> +Theorem rator_thm: + TERM defs v /\ STATE defs s ==> (rator v s = (res,s')) ==> - (s' = s) /\ !x. (res = Success x) ==> TERM defs x` - (Cases_on `v` + (s' = s) /\ !x. (res = Success x) ==> TERM defs x +Proof + Cases_on `v` \\ SIMP_TAC (srw_ss()) [rator_def,st_ex_return_def,Once EQ_SYM_EQ,raise_Fail_def] - \\ REPEAT STRIP_TAC \\ IMP_RES_TAC TERM); + \\ REPEAT STRIP_TAC \\ IMP_RES_TAC TERM +QED -Theorem rand_thm - `TERM defs v /\ STATE defs s ==> +Theorem rand_thm: + TERM defs v /\ STATE defs s ==> (rand v s = (res,s')) ==> - (s' = s) /\ !x. (res = Success x) ==> TERM defs x` - (Cases_on `v` + (s' = s) /\ !x. (res = Success x) ==> TERM defs x +Proof + Cases_on `v` \\ SIMP_TAC (srw_ss()) [rand_def,st_ex_return_def,Once EQ_SYM_EQ,raise_Fail_def] - \\ REPEAT STRIP_TAC \\ IMP_RES_TAC TERM); + \\ REPEAT STRIP_TAC \\ IMP_RES_TAC TERM +QED val type_subst_bool = Q.prove( `type_subst i Bool = Bool`, @@ -677,19 +721,21 @@ val TERM_Const_type_subst = Q.prove( simp[TYPE_SUBST_compose] >> METIS_TAC[]) -Theorem mk_const_thm - `!name theta s z s'. +Theorem mk_const_thm: + !name theta s z s'. STATE defs s /\ EVERY (\(x,y). TYPE defs x /\ TYPE defs y) theta /\ (mk_const (name,theta) s = (z,s')) ==> (s' = s) /\ - !i. (z = Success i) ==> TERM defs i` - (SIMP_TAC std_ss [mk_const_def,try_def,st_ex_bind_def,otherwise_def] + !i. (z = Success i) ==> TERM defs i +Proof + SIMP_TAC std_ss [mk_const_def,try_def,st_ex_bind_def,otherwise_def] \\ NTAC 3 STRIP_TAC \\ Cases_on `get_const_type name s` \\ IMP_RES_TAC get_const_type_thm \\ Cases_on `q` \\ FULL_SIMP_TAC (srw_ss()) [raise_Fail_def,st_ex_return_def] \\ SRW_TAC [] [st_ex_return_def] \\ MATCH_MP_TAC TERM_Const_type_subst \\ FULL_SIMP_TAC std_ss [] \\ IMP_RES_TAC get_const_type_thm \\ FULL_SIMP_TAC (srw_ss()) [] - \\ IMP_RES_TAC TERM_Const); + \\ IMP_RES_TAC TERM_Const +QED val get_const_type_Equal = Q.prove( `STATE defs s ==> @@ -725,16 +771,17 @@ val mk_eq_lemma = Q.prove( \\ NTAC 50 (SIMP_TAC (srw_ss()) [Once type_subst_def,LET_DEF, Once mk_vartype_def, Once rev_assocd_def]) \\ SRW_TAC [] [] \\ METIS_TAC []); -Theorem mk_eq_thm - `TERM defs x /\ TERM defs y /\ STATE defs s ==> +Theorem mk_eq_thm: + TERM defs x /\ TERM defs y /\ STATE defs s ==> (mk_eq(x,y)s = (res,s')) ==> (s' = s) /\ (!t. (res = Failure t) ==> ((term_type x) <> (term_type y))) /\ !t. (res = Success t) ==> (t = Comb (Comb (Const (strlit "=") (Fun (term_type x) (Fun (term_type x) Bool))) x) y) /\ - TERM defs t` - (STRIP_TAC \\ SIMP_TAC std_ss [mk_eq_def,try_def,st_ex_bind_def, + TERM defs t +Proof + STRIP_TAC \\ SIMP_TAC std_ss [mk_eq_def,try_def,st_ex_bind_def, otherwise_def,mk_vartype_def] \\ `CONTEXT defs` by fs[STATE_def] \\ MP_TAC (type_of_thm |> SIMP_RULE std_ss [] |> Q.SPEC `x`) @@ -775,7 +822,8 @@ Theorem mk_eq_thm ``term_type (Comb x y)`` |> SIMP_CONV (srw_ss()) [Once term_type_def], ``type_of (Comb x y)`` |> SIMP_CONV (srw_ss()) [Once type_of_def], ``type_of (Const x y)`` |> SIMP_CONV (srw_ss()) [Once type_of_def], - st_ex_bind_def,dest_type_def]); + st_ex_bind_def,dest_type_def] +QED val TERM_Eq_x = Q.prove( `STATE defs s /\ TERM defs (Comb (Const (strlit "=") ty) x) ==> @@ -814,17 +862,19 @@ val Equal_type_IMP = Q.prove( fs[Once term_type_def] >> rw[] >> imp_res_tac term_type >> simp[]) -Theorem dest_eq_thm - `TERM defs tm /\ STATE defs s /\ (dest_eq tm s = (res, s')) ==> +Theorem dest_eq_thm: + TERM defs tm /\ STATE defs s /\ (dest_eq tm s = (res, s')) ==> (s' = s) /\ !t1 t2. (res = Success (t1,t2)) ==> TERM defs t1 /\ TERM defs t2 /\ - (tm = Comb (Comb (Equal (typeof t1)) t1) t2)` - (ONCE_REWRITE_TAC [EQ_SYM_EQ] \\ SIMP_TAC std_ss [dest_eq_def] + (tm = Comb (Comb (Equal (typeof t1)) t1) t2) +Proof + ONCE_REWRITE_TAC [EQ_SYM_EQ] \\ SIMP_TAC std_ss [dest_eq_def] \\ BasicProvers.EVERY_CASE_TAC \\ FULL_SIMP_TAC (srw_ss()) [raise_Fail_def,st_ex_return_def] \\ SRW_TAC [] [] \\ FULL_SIMP_TAC (srw_ss()) [st_ex_return_def] \\ IMP_RES_TAC TERM \\ FULL_SIMP_TAC std_ss [] \\ IMP_RES_TAC TERM \\ FULL_SIMP_TAC std_ss [] - \\ IMP_RES_TAC TERM_Eq_x); + \\ IMP_RES_TAC TERM_Eq_x +QED val VFREE_IN_IMP = Q.prove( `!y. TERM defs y /\ TYPE defs ty /\ STATE defs s /\ @@ -1075,15 +1125,16 @@ val type_of_state = Q.prove( \\ Cases_on `r` \\ FULL_SIMP_TAC (srw_ss()) [] \\ SRW_TAC [] []); -Theorem vsubst_thm - `EVERY (\(t1,t2). TERM defs t1 /\ TERM defs t2) theta /\ +Theorem vsubst_thm: + EVERY (\(t1,t2). TERM defs t1 /\ TERM defs t2) theta /\ TERM defs tm /\ STATE defs s /\ (vsubst theta tm s = (res, s')) ==> (s' = s) /\ !t. (res = Success t) ==> TERM defs t /\ (t = VSUBST theta tm) /\ (EVERY (\(p_1,p_2). ?x ty. (p_2 = Var x ty) /\ - (p_1) has_type ty) theta)` - (ONCE_REWRITE_TAC [EQ_SYM_EQ] \\ SIMP_TAC std_ss [vsubst_def] + (p_1) has_type ty) theta) +Proof + ONCE_REWRITE_TAC [EQ_SYM_EQ] \\ SIMP_TAC std_ss [vsubst_def] \\ Cases_on `theta = []` \\ FULL_SIMP_TAC (srw_ss()) [MAP,VSUBST_EMPTY,st_ex_return_def,st_ex_bind_def] \\ Q.PAT_ABBREV_TAC `test = (\(t,x) state. @@ -1128,13 +1179,16 @@ Theorem vsubst_thm \\ FULL_SIMP_TAC std_ss [TERM_def,typeof_def] \\ FULL_SIMP_TAC std_ss [WELLTYPED,term_type_Var] >> rfs[STATE_def] >> - rw[] >> METIS_TAC [WELLTYPED,term_ok_welltyped]) + rw[] >> METIS_TAC [WELLTYPED,term_ok_welltyped] +QED -Theorem inst_aux_Var - `inst_aux [] theta (Var v ty) state = - (Success (Var v (type_subst theta ty)),state)` - (SIMP_TAC (srw_ss()) [Once inst_aux_def,rev_assocd_thm,REV_ASSOCD, - LET_DEF,st_ex_return_def] \\ METIS_TAC []); +Theorem inst_aux_Var: + inst_aux [] theta (Var v ty) state = + (Success (Var v (type_subst theta ty)),state) +Proof + SIMP_TAC (srw_ss()) [Once inst_aux_def,rev_assocd_thm,REV_ASSOCD, + LET_DEF,st_ex_return_def] \\ METIS_TAC [] +QED val MEM_subtract = Q.prove( `!xs ys x. MEM x (subtract xs ys) <=> MEM x xs /\ ~MEM x ys`, @@ -1147,8 +1201,8 @@ val MEM_frees = Q.prove( \\ REPEAT STRIP_TAC \\ IMP_RES_TAC Abs_Var \\ FULL_SIMP_TAC std_ss [] \\ IMP_RES_TAC TERM \\ FULL_SIMP_TAC std_ss [MEM_union,MEM_subtract]); -Theorem inst_aux_thm - `!env theta tm s s' res. +Theorem inst_aux_thm: + !env theta tm s s' res. EVERY (\(t1,t2). TYPE defs t1 /\ TYPE defs t2) theta /\ EVERY (\(t1,t2). TERM defs t1 /\ TERM defs t2) env /\ TERM defs tm /\ STATE defs s /\ @@ -1157,8 +1211,9 @@ Theorem inst_aux_thm case res of | Success t => (INST_CORE env theta tm = Result t) | Failure (Clash v) => (INST_CORE env theta tm = Clash v) - | _ => F` - (HO_MATCH_MP_TAC inst_aux_ind \\ NTAC 4 STRIP_TAC \\ Cases_on `tm` + | _ => F +Proof + HO_MATCH_MP_TAC inst_aux_ind \\ NTAC 4 STRIP_TAC \\ Cases_on `tm` \\ FULL_SIMP_TAC (srw_ss()) [] THEN1 (simp[inst_aux_def,INST_CORE_def,rev_assocd_thm] >> @@ -1319,7 +1374,8 @@ Theorem inst_aux_thm \\ REPEAT STRIP_TAC \\ MATCH_MP_TAC TERM_Var \\ FULL_SIMP_TAC std_ss []) \\ FULL_SIMP_TAC std_ss [IS_RESULT_def,RESULT_def] >> BasicProvers.CASE_TAC >> fs[] >> - BasicProvers.CASE_TAC >> fs[]) + BasicProvers.CASE_TAC >> fs[] +QED val inst_lemma = Q.prove( `EVERY (\(t1,t2). TYPE defs t1 /\ TYPE defs t2) theta /\ @@ -1350,12 +1406,13 @@ val inst_lemma = Q.prove( \\ FULL_SIMP_TAC std_ss [MAP,RESULT_def,result_distinct,result_11] \\ Cases_on `res` \\ FULL_SIMP_TAC (srw_ss()) []) -Theorem inst_thm - `EVERY (\(t1,t2). TYPE defs t1 /\ TYPE defs t2) theta /\ +Theorem inst_thm: + EVERY (\(t1,t2). TYPE defs t1 /\ TYPE defs t2) theta /\ TERM defs tm /\ STATE defs s /\ (inst theta tm s = (res, s')) ==> - STATE defs s' /\ (res = Success (INST theta tm)) /\ TERM defs (INST theta tm)` - (ntac 2 STRIP_TAC \\ IMP_RES_TAC inst_lemma + STATE defs s' /\ (res = Success (INST theta tm)) /\ TERM defs (INST theta tm) +Proof + ntac 2 STRIP_TAC \\ IMP_RES_TAC inst_lemma \\ FULL_SIMP_TAC std_ss [TERM_def] >> imp_res_tac term_ok_welltyped \\ IMP_RES_TAC INST_CORE_LEMMA \\ fs[INST_def] @@ -1377,7 +1434,8 @@ Theorem inst_thm \\ disch_then(qspecl_then[`[]`,`theta`]mp_tac) \\ simp[] \\ FULL_SIMP_TAC std_ss [MEM_MAP,PULL_EXISTS,FORALL_PROD,EVERY_MEM] \\ FULL_SIMP_TAC std_ss [EVERY_MEM,TYPE_def,FORALL_PROD,MEM,IS_RESULT_def] - \\ METIS_TAC []) + \\ METIS_TAC [] +QED val freesin_IMP = Q.prove( `!rhs vars. @@ -1456,28 +1514,35 @@ val QSORT_type_vars_in_term = Q.prove( (* Verification of thm functions *) (* ------------------------------------------------------------------------- *) -Theorem dest_thm_thm - `THM defs th /\ STATE defs s /\ (dest_thm th = (asl, c)) ==> - EVERY (TERM defs) asl /\ TERM defs c` - (REPEAT STRIP_TAC \\ Cases_on `th` \\ IMP_RES_TAC THM - \\ FULL_SIMP_TAC std_ss [dest_thm_def] \\ METIS_TAC []); - -Theorem hyp_thm - `THM defs th /\ STATE defs s /\ (hyp th = asl) ==> - EVERY (TERM defs) asl` - (REPEAT STRIP_TAC \\ Cases_on `th` \\ IMP_RES_TAC THM - \\ FULL_SIMP_TAC std_ss [hyp_def] \\ METIS_TAC []); - -Theorem concl_thm - `THM defs th /\ STATE defs s /\ (concl th = c) ==> - TERM defs c` - (REPEAT STRIP_TAC \\ Cases_on `th` \\ IMP_RES_TAC THM - \\ FULL_SIMP_TAC std_ss [concl_def] \\ METIS_TAC []); - -Theorem REFL_thm - `TERM defs tm /\ STATE defs s /\ (REFL tm s = (res, s')) ==> - (s' = s) /\ !th. (res = Success th) ==> THM defs th` - (SIMP_TAC std_ss [REFL_def,st_ex_bind_def] \\ Cases_on `mk_eq(tm,tm) s` +Theorem dest_thm_thm: + THM defs th /\ STATE defs s /\ (dest_thm th = (asl, c)) ==> + EVERY (TERM defs) asl /\ TERM defs c +Proof + REPEAT STRIP_TAC \\ Cases_on `th` \\ IMP_RES_TAC THM + \\ FULL_SIMP_TAC std_ss [dest_thm_def] \\ METIS_TAC [] +QED + +Theorem hyp_thm: + THM defs th /\ STATE defs s /\ (hyp th = asl) ==> + EVERY (TERM defs) asl +Proof + REPEAT STRIP_TAC \\ Cases_on `th` \\ IMP_RES_TAC THM + \\ FULL_SIMP_TAC std_ss [hyp_def] \\ METIS_TAC [] +QED + +Theorem concl_thm: + THM defs th /\ STATE defs s /\ (concl th = c) ==> + TERM defs c +Proof + REPEAT STRIP_TAC \\ Cases_on `th` \\ IMP_RES_TAC THM + \\ FULL_SIMP_TAC std_ss [concl_def] \\ METIS_TAC [] +QED + +Theorem REFL_thm: + TERM defs tm /\ STATE defs s /\ (REFL tm s = (res, s')) ==> + (s' = s) /\ !th. (res = Success th) ==> THM defs th +Proof + SIMP_TAC std_ss [REFL_def,st_ex_bind_def] \\ Cases_on `mk_eq(tm,tm) s` \\ REPEAT STRIP_TAC \\ IMP_RES_TAC mk_eq_thm \\ Cases_on `q` \\ FULL_SIMP_TAC (srw_ss()) [st_ex_return_def] \\ Q.PAT_X_ASSUM `xxx = th` (ASSUME_TAC o GSYM) @@ -1487,13 +1552,15 @@ Theorem REFL_thm \\ simp[GSYM equation_def] \\ MATCH_MP_TAC(List.nth(CONJUNCTS proves_rules,8)) >> fs[CONTEXT_def,TERM_def] >> - METIS_TAC[extends_theory_ok,init_theory_ok]) + METIS_TAC[extends_theory_ok,init_theory_ok] +QED -Theorem TRANS_thm - `THM defs th1 /\ THM defs th2 /\ STATE defs s /\ +Theorem TRANS_thm: + THM defs th1 /\ THM defs th2 /\ STATE defs s /\ (TRANS th1 th2 s = (res, s')) ==> - (s' = s) /\ !th. (res = Success th) ==> THM defs th` - (Cases_on `th1` \\ Cases_on `th2` \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] + (s' = s) /\ !th. (res = Success th) ==> THM defs th +Proof + Cases_on `th1` \\ Cases_on `th2` \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] \\ SIMP_TAC std_ss [TRANS_def] \\ BasicProvers.EVERY_CASE_TAC \\ FULL_SIMP_TAC (srw_ss()) [raise_Fail_def] @@ -1520,13 +1587,15 @@ Theorem TRANS_thm ntac 2 (pop_assum(mp_tac o SYM)) >> simp[GSYM equation_def] >> rw[] >> match_mp_tac (MP_CANON trans_equation) >> - METIS_TAC[]) + METIS_TAC[] +QED -Theorem SYM_thm - `THM defs th /\ STATE defs s /\ +Theorem SYM_thm: + THM defs th /\ STATE defs s /\ (SYM th s = (res, s')) ==> - (s' = s) /\ !th. (res = Success th) ==> THM defs th` - (Cases_on`th`>>rw[EQ_SYM_EQ]>>fs[SYM_def]>> + (s' = s) /\ !th. (res = Success th) ==> THM defs th +Proof + Cases_on`th`>>rw[EQ_SYM_EQ]>>fs[SYM_def]>> every_case_tac >> fs[raise_Fail_def,st_ex_return_def] >> fs[THM_def] >> rw[] >> qmatch_assum_rename_tac`_ |- Comb (Comb (Const _ ty) _) _` >> @@ -1535,15 +1604,18 @@ Theorem SYM_thm imp_res_tac proves_term_ok >> rfs[term_ok_clauses] >> rw[] >> fs[codomain_def] >> rw[] >> rfs[term_ok_def,is_std_sig_def] ) >> - rw[] >> match_mp_tac sym >> rw[]) + rw[] >> match_mp_tac sym >> rw[] +QED -Theorem PROVE_HYP_thm - `THM defs th1 ∧ THM defs th2 ∧ STATE defs s ∧ +Theorem PROVE_HYP_thm: + THM defs th1 ∧ THM defs th2 ∧ STATE defs s ∧ (PROVE_HYP th1 th2 s = (res, s')) ⇒ - (s' = s) ∧ ∀th. (res = Success th) ⇒ THM defs th` - (Cases_on`th1`>>Cases_on`th2`>>rw[EQ_SYM_EQ]>> + (s' = s) ∧ ∀th. (res = Success th) ⇒ THM defs th +Proof + Cases_on`th1`>>Cases_on`th2`>>rw[EQ_SYM_EQ]>> fs[PROVE_HYP_def,st_ex_return_def,THM_def]>> - match_mp_tac proveHyp >> rw[]); + match_mp_tac proveHyp >> rw[] +QED val map_type_of = Q.prove( `∀ls s r s'. @@ -1568,21 +1640,26 @@ val map_type_of_state = Q.prove( every_case_tac >> fs[st_ex_return_def] >> rw[] >> METIS_TAC[type_of_state,PAIR,FST,SND]) -Theorem hypset_ok_list_to_hypset[simp] - `∀ls a. hypset_ok a ⇒ hypset_ok (list_to_hypset ls a)` - (Induct >> simp[list_to_hypset_def]) +Theorem hypset_ok_list_to_hypset[simp]: + ∀ls a. hypset_ok a ⇒ hypset_ok (list_to_hypset ls a) +Proof + Induct >> simp[list_to_hypset_def] +QED -Theorem MEM_list_to_hypset_imp - `∀ls a. MEM x (list_to_hypset ls a) ⇒ MEM x ls ∨ MEM x a` - (Induct >> rw[list_to_hypset_def] >> +Theorem MEM_list_to_hypset_imp: + ∀ls a. MEM x (list_to_hypset ls a) ⇒ MEM x ls ∨ MEM x a +Proof + Induct >> rw[list_to_hypset_def] >> res_tac >> simp[] >> - imp_res_tac MEM_term_union_imp >> fs[]) + imp_res_tac MEM_term_union_imp >> fs[] +QED -Theorem ALPHA_THM_thm - `THM defs th ∧ EVERY (TERM defs) h ∧ TERM defs c ∧ STATE defs s ∧ +Theorem ALPHA_THM_thm: + THM defs th ∧ EVERY (TERM defs) h ∧ TERM defs c ∧ STATE defs s ∧ (ALPHA_THM th (h,c) s = (res,s')) ⇒ - (s' = s) ∧ ∀th. (res = Success th) ⇒ THM defs th` - (Cases_on`th`>>simp[ALPHA_THM_def]>> + (s' = s) ∧ ∀th. (res = Success th) ⇒ THM defs th +Proof + Cases_on`th`>>simp[ALPHA_THM_def]>> IF_CASES_TAC>>strip_tac>>fs[raise_Fail_def]>> rpt var_eq_tac >> simp[] >> pop_assum mp_tac >> @@ -1619,13 +1696,15 @@ Theorem ALPHA_THM_thm fs[EVERY_MEM] >> rw[] >> fs[TERM_def] >> fs[MEM_MAP,PULL_EXISTS] >> - METIS_TAC[term_type,STATE_def,TERM_def,WELLTYPED_LEMMA,WELLTYPED,term_ok_welltyped]) + METIS_TAC[term_type,STATE_def,TERM_def,WELLTYPED_LEMMA,WELLTYPED,term_ok_welltyped] +QED -Theorem MK_COMB_thm - `THM defs th1 /\ THM defs th2 /\ STATE defs s /\ +Theorem MK_COMB_thm: + THM defs th1 /\ THM defs th2 /\ STATE defs s /\ (MK_COMB (th1,th2) s = (res, s')) ==> - (s' = s) /\ !th. (res = Success th) ==> THM defs th` - (Cases_on `th1` \\ Cases_on `th2` \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] + (s' = s) /\ !th. (res = Success th) ==> THM defs th +Proof + Cases_on `th1` \\ Cases_on `th2` \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] \\ SIMP_TAC std_ss [MK_COMB_def] \\ BasicProvers.EVERY_CASE_TAC \\ FULL_SIMP_TAC (srw_ss()) [raise_Fail_def] @@ -1663,13 +1742,15 @@ Theorem MK_COMB_thm rw[] >> MATCH_MP_TAC(List.nth(CONJUNCTS proves_rules,7)) >> qpat_x_assum`TERM x (Comb f1 x1)`mp_tac >> simp[TERM_Comb] >> strip_tac >> - fs[TERM_def] >> imp_res_tac term_ok_welltyped >> simp[]) + fs[TERM_def] >> imp_res_tac term_ok_welltyped >> simp[] +QED -Theorem ABS_thm - `TERM defs tm /\ THM defs th1 /\ STATE defs s /\ +Theorem ABS_thm: + TERM defs tm /\ THM defs th1 /\ STATE defs s /\ (ABS tm th1 s = (res, s')) ==> - (s' = s) /\ !th. (res = Success th) ==> THM defs th` - (Cases_on `th1` \\ SIMP_TAC std_ss [ABS_def] \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] + (s' = s) /\ !th. (res = Success th) ==> THM defs th +Proof + Cases_on `th1` \\ SIMP_TAC std_ss [ABS_def] \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] \\ Cases_on `t` \\ FULL_SIMP_TAC (srw_ss()) [raise_Fail_def] \\ Cases_on `t'` \\ FULL_SIMP_TAC (srw_ss()) [raise_Fail_def] \\ Cases_on `t` \\ FULL_SIMP_TAC (srw_ss()) [raise_Fail_def] @@ -1718,13 +1799,15 @@ Theorem ABS_thm imp_res_tac Equal_type_IMP >> reverse conj_tac >- METIS_TAC[equation_def] >> REPEAT STRIP_TAC \\ RES_TAC - \\ IMP_RES_TAC TERM \\ IMP_RES_TAC VFREE_IN_IMP) + \\ IMP_RES_TAC TERM \\ IMP_RES_TAC VFREE_IN_IMP +QED -Theorem BETA_thm - `TERM defs tm /\ STATE defs s /\ +Theorem BETA_thm: + TERM defs tm /\ STATE defs s /\ (BETA tm s = (res, s')) ==> - (s' = s) /\ !th. (res = Success th) ==> THM defs th` - (SIMP_TAC std_ss [BETA_def] \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] + (s' = s) /\ !th. (res = Success th) ==> THM defs th +Proof + SIMP_TAC std_ss [BETA_def] \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] \\ Cases_on `tm` \\ FULL_SIMP_TAC (srw_ss()) [raise_Fail_def] \\ Cases_on `t` \\ FULL_SIMP_TAC (srw_ss()) [raise_Fail_def] \\ SRW_TAC [] [st_ex_bind_def,st_ex_return_def] @@ -1748,13 +1831,15 @@ Theorem BETA_thm simp_tac std_ss [GSYM equation_def] >> MATCH_MP_TAC(List.nth(CONJUNCTS proves_rules,2)) >> fs[CONTEXT_def,TERM_def,TYPE_def] >> - METIS_TAC[extends_theory_ok,init_theory_ok]) + METIS_TAC[extends_theory_ok,init_theory_ok] +QED -Theorem ASSUME_thm - `TERM defs tm /\ STATE defs s /\ +Theorem ASSUME_thm: + TERM defs tm /\ STATE defs s /\ (ASSUME tm s = (res, s')) ==> - (s' = s) /\ !th. (res = Success th) ==> THM defs th` - (SIMP_TAC std_ss [ASSUME_def] \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] + (s' = s) /\ !th. (res = Success th) ==> THM defs th +Proof + SIMP_TAC std_ss [ASSUME_def] \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] \\ STRIP_TAC \\ MP_TAC (type_of_thm |> Q.SPEC `tm`) \\ FULL_SIMP_TAC std_ss [] \\ STRIP_TAC \\ FULL_SIMP_TAC std_ss [] \\ FULL_SIMP_TAC (srw_ss()) [st_ex_bind_def] @@ -1773,13 +1858,15 @@ Theorem ASSUME_thm fs[TERM_def] >> imp_res_tac term_ok_welltyped >> FULL_SIMP_TAC std_ss [WELLTYPED] - >> METIS_TAC[CONTEXT_def,extends_theory_ok,init_theory_ok]) + >> METIS_TAC[CONTEXT_def,extends_theory_ok,init_theory_ok] +QED -Theorem EQ_MP_thm - `THM defs th1 /\ THM defs th2 /\ STATE defs s /\ +Theorem EQ_MP_thm: + THM defs th1 /\ THM defs th2 /\ STATE defs s /\ (EQ_MP th1 th2 s = (res, s')) ==> - (s' = s) /\ !th. (res = Success th) ==> THM defs th` - (Cases_on `th1` \\ Cases_on `th2` \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] + (s' = s) /\ !th. (res = Success th) ==> THM defs th +Proof + Cases_on `th1` \\ Cases_on `th2` \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] \\ SIMP_TAC std_ss [EQ_MP_def] \\ BasicProvers.EVERY_CASE_TAC \\ FULL_SIMP_TAC (srw_ss()) [raise_Fail_def] @@ -1798,13 +1885,15 @@ Theorem EQ_MP_thm simp[GSYM equation_def] >> rw[] >> MATCH_MP_TAC(List.nth(CONJUNCTS proves_rules,4)) >> fs[TERM_Comb] >> - METIS_TAC[aconv_thm]) + METIS_TAC[aconv_thm] +QED -Theorem DEDUCT_ANTISYM_RULE_thm - `THM defs th1 /\ THM defs th2 /\ STATE defs s /\ +Theorem DEDUCT_ANTISYM_RULE_thm: + THM defs th1 /\ THM defs th2 /\ STATE defs s /\ (DEDUCT_ANTISYM_RULE th1 th2 s = (res, s')) ==> - (s' = s) /\ !th. (res = Success th) ==> THM defs th` - (Cases_on `th1` \\ Cases_on `th2` \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] + (s' = s) /\ !th. (res = Success th) ==> THM defs th +Proof + Cases_on `th1` \\ Cases_on `th2` \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] \\ SIMP_TAC std_ss [DEDUCT_ANTISYM_RULE_def,LET_DEF,st_ex_bind_def] \\ Cases_on `mk_eq (t,t') s` \\ STRIP_TAC \\ IMP_RES_TAC THM @@ -1824,7 +1913,8 @@ Theorem DEDUCT_ANTISYM_RULE_thm imp_res_tac term_type >> simp[GSYM equation_def] >> MATCH_MP_TAC(List.nth(CONJUNCTS proves_rules,3)) >> - simp[]) + simp[] +QED val image_lemma = Q.prove( `∀f l s g defs res s'. @@ -1847,12 +1937,13 @@ val image_lemma = Q.prove( rpt BasicProvers.VAR_EQ_TAC >> simp[] >> res_tac >> fs[]) -Theorem INST_TYPE_thm - `EVERY (\(t1,t2). TYPE defs t1 /\ TYPE defs t2) theta /\ +Theorem INST_TYPE_thm: + EVERY (\(t1,t2). TYPE defs t1 /\ TYPE defs t2) theta /\ THM defs th1 /\ STATE defs s /\ (INST_TYPE theta th1 s = (res, s')) ==> - STATE defs s' /\ !th. (res = Success th) ==> THM defs th` - (Cases_on `th1` \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] + STATE defs s' /\ !th. (res = Success th) ==> THM defs th +Proof + Cases_on `th1` \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] \\ SIMP_TAC std_ss [INST_TYPE_def,LET_DEF,st_ex_bind_def] \\ STRIP_TAC \\ IMP_RES_TAC THM \\ Cases_on `image (inst theta) l s` @@ -1876,7 +1967,8 @@ Theorem INST_TYPE_thm MATCH_MP_TAC(List.nth(CONJUNCTS proves_rules,6)) >> simp[EVERY_MAP] >> fs[EVERY_MEM,FORALL_PROD,TYPE_def] >> - METIS_TAC[]) + METIS_TAC[] +QED val image_lemma = Q.prove( `∀f l s g defs res s'. @@ -1899,12 +1991,13 @@ val image_lemma = Q.prove( rpt BasicProvers.VAR_EQ_TAC >> simp[] >> res_tac >> fs[]) -Theorem INST_thm - `EVERY (\(t1,t2). TERM defs t1 /\ TERM defs t2) theta /\ +Theorem INST_thm: + EVERY (\(t1,t2). TERM defs t1 /\ TERM defs t2) theta /\ THM defs th1 /\ STATE defs s /\ (INST theta th1 s = (res, s')) ==> - (s' = s) /\ !th. (res = Success th) ==> THM defs th` - (Cases_on `th1` \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] + (s' = s) /\ !th. (res = Success th) ==> THM defs th +Proof + Cases_on `th1` \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] \\ SIMP_TAC std_ss [holKernelTheory.INST_def,LET_DEF,st_ex_bind_def] \\ STRIP_TAC \\ IMP_RES_TAC THM \\ Cases_on `image (vsubst theta) l s` @@ -1926,39 +2019,47 @@ Theorem INST_thm MATCH_MP_TAC(List.nth(CONJUNCTS proves_rules,5)) >> simp[EVERY_MAP,MEM_MAP,PULL_EXISTS] >> fs[EVERY_MEM,FORALL_PROD,TERM_def] >> - METIS_TAC[]) + METIS_TAC[] +QED (* ------------------------------------------------------------------------- *) (* Verification of definition functions *) (* ------------------------------------------------------------------------- *) (* TODO move *) -Theorem ALL_DISTINCT_DISJOINT - `!xs ys. ALL_DISTINCT (xs ++ ys) ==> DISJOINT (set xs) (set ys)` - (Induct \\ rw []); - -Theorem TYPE_CONS_EXTEND - `STATE (d::defs) s /\ TYPE defs ty ==> TYPE (d::defs) ty` - (simp[STATE_def,TYPE_def] >> strip_tac >> +Theorem ALL_DISTINCT_DISJOINT: + !xs ys. ALL_DISTINCT (xs ++ ys) ==> DISJOINT (set xs) (set ys) +Proof + Induct \\ rw [] +QED + +Theorem TYPE_CONS_EXTEND: + STATE (d::defs) s /\ TYPE defs ty ==> TYPE (d::defs) ty +Proof + simp[STATE_def,TYPE_def] >> strip_tac >> match_mp_tac type_ok_extend >> HINT_EXISTS_TAC >> imp_res_tac CONTEXT_ALL_DISTINCT >> - Cases_on`d`>>fs[SUBMAP_FUNION]) + Cases_on`d`>>fs[SUBMAP_FUNION] +QED -Theorem TYPE_APPEND_EXTEND - `STATE (ds++defs) s /\ TYPE defs ty ==> TYPE (ds++defs) ty` - (simp [STATE_def, TYPE_def] \\ strip_tac +Theorem TYPE_APPEND_EXTEND: + STATE (ds++defs) s /\ TYPE defs ty ==> TYPE (ds++defs) ty +Proof + simp [STATE_def, TYPE_def] \\ strip_tac \\ match_mp_tac type_ok_extend \\ HINT_EXISTS_TAC \\ imp_res_tac CONTEXT_ALL_DISTINCT \\ fs [] \\ match_mp_tac SUBMAP_FUNION \\ fs [] \\ disj2_tac \\ once_rewrite_tac [DISJOINT_SYM] - \\ match_mp_tac ALL_DISTINCT_DISJOINT \\ fs []); + \\ match_mp_tac ALL_DISTINCT_DISJOINT \\ fs [] +QED -Theorem TERM_CONS_EXTEND - `STATE (d::defs) s /\ TERM defs tm ==> TERM (d::defs) tm` - (simp[STATE_def,TERM_def] >> strip_tac >> +Theorem TERM_CONS_EXTEND: + STATE (d::defs) s /\ TERM defs tm ==> TERM (d::defs) tm +Proof + simp[STATE_def,TERM_def] >> strip_tac >> match_mp_tac term_ok_extend >> map_every qexists_tac[`tysof(defs)`,`tmsof(defs)`] >> imp_res_tac CONTEXT_ALL_DISTINCT >> @@ -1966,11 +2067,13 @@ Theorem TERM_CONS_EXTEND match_mp_tac SUBMAP_FUNION >> fs[pred_setTheory.IN_DISJOINT] >> fs[ALL_DISTINCT_APPEND] >> - METIS_TAC[]) + METIS_TAC[] +QED -Theorem TERM_APPEND_EXTEND - `STATE (ds++defs) s /\ TERM defs tm ==> TERM (ds++defs) tm` - (simp [STATE_def, TERM_def] \\ strip_tac +Theorem TERM_APPEND_EXTEND: + STATE (ds++defs) s /\ TERM defs tm ==> TERM (ds++defs) tm +Proof + simp [STATE_def, TERM_def] \\ strip_tac \\ match_mp_tac term_ok_extend \\ qexists_tac `tysof(defs)` \\ qexists_tac `tmsof(defs)` @@ -1979,7 +2082,8 @@ Theorem TERM_APPEND_EXTEND \\ match_mp_tac SUBMAP_FUNION \\ fs [] \\ disj2_tac \\ once_rewrite_tac [DISJOINT_SYM] - \\ match_mp_tac ALL_DISTINCT_DISJOINT \\ fs []); + \\ match_mp_tac ALL_DISTINCT_DISJOINT \\ fs [] +QED val STRCAT_SHADOW_def = zDefine` STRCAT_SHADOW = STRCAT` @@ -2019,9 +2123,10 @@ val add_constants_thm = Q.prove( simp[ALL_DISTINCT_APPEND]) (* TODO move *) -Theorem tyvars_EQ_thm - `holKernel$tyvars = holSyntax$tyvars` - (fs [FUN_EQ_THM] +Theorem tyvars_EQ_thm: + holKernel$tyvars = holSyntax$tyvars +Proof + fs [FUN_EQ_THM] \\ recInduct tyvars_ind \\ rw [] \\ once_rewrite_tac [holSyntaxTheory.tyvars_def, holKernelTheory.tyvars_def] \\ fs [] \\ pop_assum mp_tac @@ -2035,21 +2140,25 @@ Theorem tyvars_EQ_thm \\ qid_spec_tac `xs` \\ qid_spec_tac `h'` \\ qid_spec_tac `t` - \\ Induct \\ rw [] \\ simp [itlist_def, LIST_INSERT_def, insert_def]); + \\ Induct \\ rw [] \\ simp [itlist_def, LIST_INSERT_def, insert_def] +QED (* TODO move, unless it already exists elsewhere *) -Theorem LIST_REL_MAP_EQ - `!r l. LIST_REL (\x y. x = f y) l r ==> (MAP f r = l)` - (Induct \\ rw []); - -Theorem new_specification_thm - `THM defs th /\ STATE defs s ==> +Theorem LIST_REL_MAP_EQ: + !r l. LIST_REL (\x y. x = f y) l r ==> (MAP f r = l) +Proof + Induct \\ rw [] +QED + +Theorem new_specification_thm: + THM defs th /\ STATE defs s ==> case new_specification th s of | (Failure exn, s') => (s' = s) | (Success th, s') => (?d. THM (d::defs) th /\ STATE (d::defs) s' /\ - !th. THM defs th ==> THM (d::defs) th)` - (Cases_on`th` >> + !th. THM defs th ==> THM (d::defs) th) +Proof + Cases_on`th` >> simp_tac std_ss [new_specification_def,GSYM STRCAT_SHADOW_def] >> simp[st_ex_bind_def,st_ex_return_def] >> rpt strip_tac >> @@ -2285,33 +2394,37 @@ Theorem new_specification_thm simp[MAP_EQ_f] >> fs[EVERY2_EVERY,EVERY_MEM,MEM_EL,PULL_EXISTS,UNCURRY] >> rfs[EL_ZIP,PULL_EXISTS] >> - METIS_TAC[term_ok_welltyped,WELLTYPED_LEMMA]) + METIS_TAC[term_ok_welltyped,WELLTYPED_LEMMA] +QED val _ = delete_const"STRCAT_SHADOW" -Theorem new_basic_definition_thm - `TERM defs tm /\ STATE defs s ==> +Theorem new_basic_definition_thm: + TERM defs tm /\ STATE defs s ==> case new_basic_definition tm s of | (Failure exn, s') => (s' = s) | (Success th, s') => (?d. THM (d::defs) th /\ STATE (d::defs) s' /\ - !th. THM defs th ==> THM (d::defs) th)` - (rw[] >> + !th. THM defs th ==> THM (d::defs) th) +Proof + rw[] >> simp[new_basic_definition_def,st_ex_bind_def] >> Cases_on`ASSUME tm s` >> imp_res_tac ASSUME_thm >> Cases_on`q`>>fs[] >> - imp_res_tac new_specification_thm ) + imp_res_tac new_specification_thm +QED -Theorem new_basic_type_definition_thm - `THM defs th /\ STATE defs s ==> +Theorem new_basic_type_definition_thm: + THM defs th /\ STATE defs s ==> case new_basic_type_definition tyname absname repname th s of | (Failure exn, s') => (s' = s) | (Success (th1,th2), s') => (?ds. THM (ds++defs) th1 /\ THM (ds++defs) th2 /\ STATE (ds++defs) s' /\ - !th. THM defs th ==> THM (ds++defs) th)` - (Cases_on `th` \\ SIMP_TAC (srw_ss()) + !th. THM defs th ==> THM (ds++defs) th) +Proof + Cases_on `th` \\ SIMP_TAC (srw_ss()) [new_basic_type_definition_def, Once st_ex_bind_def, st_ex_return_def, Once st_ex_ignore_bind_def, raise_Fail_def, @@ -2589,19 +2702,21 @@ Theorem new_basic_type_definition_thm \\ irule extends_proves \\ HINT_EXISTS_TAC \\ fs [] \\ fs [STATE_def, CONTEXT_def, Abbr`s2`, Abbr`s1`] \\ rw [] - \\ fs [extends_def, Once RTC_CASES1, init_ctxt_def]) + \\ fs [extends_def, Once RTC_CASES1, init_ctxt_def] +QED (* ------------------------------------------------------------------------- *) (* Verification of context extension functions *) (* ------------------------------------------------------------------------- *) -Theorem new_type_thm - `STATE defs s ⇒ +Theorem new_type_thm: + STATE defs s ⇒ case new_type (name,arity) s of | (Failure exn, s') => (s' = s) | (Success (), s') => (?d. STATE (d::defs) s' /\ - !th. THM defs th ==> THM (d::defs) th)` - (rw[new_type_def,st_ex_bind_def,add_type_def,can_def,get_type_arity_def, + !th. THM defs th ==> THM (d::defs) th) +Proof + rw[new_type_def,st_ex_bind_def,add_type_def,can_def,get_type_arity_def, get_the_type_constants_def,otherwise_def,st_ex_return_def,raise_Fail_def, st_ex_ignore_bind_def] >> BasicProvers.CASE_TAC >> @@ -2622,15 +2737,17 @@ Theorem new_type_thm \\ fs [STATE_def, CONTEXT_def] \\ rveq \\ CCONTR_TAC \\ fs [MEM_MAP] \\ PairCases_on `y` \\ fs [] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem new_constant_thm - `STATE defs s ∧ TYPE defs ty ⇒ +Theorem new_constant_thm: + STATE defs s ∧ TYPE defs ty ⇒ case new_constant (name,ty) s of | (Failure exn, s') => (s' = s) | (Success (), s') => (?d. STATE (d::defs) s' /\ - !th. THM defs th ==> THM (d::defs) th)` - (rw[new_constant_def,st_ex_bind_def] >> + !th. THM defs th ==> THM (d::defs) th) +Proof + rw[new_constant_def,st_ex_bind_def] >> qspecl_then[`[(name,ty)]`,`s`]mp_tac add_constants_thm >> Cases_on`add_constants [(name,ty)] s`>>simp[] >> Cases_on`q`>>simp[oneTheory.one] >> @@ -2650,15 +2767,17 @@ Theorem new_constant_thm \\ fs [STATE_def, CONTEXT_def] \\ rveq \\ conj_tac >- (CCONTR_TAC \\ fs [MEM_MAP] \\ metis_tac []) - \\ fs [TYPE_def]); + \\ fs [TYPE_def] +QED -Theorem new_axiom_thm - `STATE defs s ∧ TERM defs p ⇒ +Theorem new_axiom_thm: + STATE defs s ∧ TERM defs p ⇒ case new_axiom p s of | (Failure exn, s') => (s' = s) | (Success th, s') => (?d. THM (d::defs) th ∧ STATE (d::defs) s' /\ - !th. THM defs th ==> THM (d::defs) th)` - (rw[new_axiom_def,st_ex_bind_def] >> + !th. THM defs th ==> THM (d::defs) th) +Proof + rw[new_axiom_def,st_ex_bind_def] >> imp_res_tac type_of_thm >> rw[] >> qspecl_then[`(strlit "bool")`,`[]`,`s`]mp_tac mk_type_thm >> Cases_on`mk_type ((strlit "bool"),[]) s`>>simp[] >> @@ -2685,7 +2804,8 @@ Theorem new_axiom_thm \\ irule updates_proves \\ fs [] \\ simp [updates_cases] \\ reverse conj_asm2_tac >- fs [TERM_def] - \\ metis_tac [type_of_has_type]); + \\ metis_tac [type_of_has_type] +QED (* ------------------------------------------------------------------------- *) (* Removing clash exceptions *) @@ -2693,241 +2813,317 @@ Theorem new_axiom_thm (* Support theorems *) -Theorem map_not_clash_thm - `!f xs s. +Theorem map_not_clash_thm: + !f xs s. (!x s. f x s <> (Failure (Clash tm),refs)) ==> - map f xs s <> (Failure (Clash tm),refs)` - (recInduct map_ind \\ rw [] \\ once_rewrite_tac [map_def] + map f xs s <> (Failure (Clash tm),refs) +Proof + recInduct map_ind \\ rw [] \\ once_rewrite_tac [map_def] \\ fs [st_ex_bind_def, st_ex_return_def] - \\ every_case_tac \\ fs [] \\ metis_tac []); + \\ every_case_tac \\ fs [] \\ metis_tac [] +QED -Theorem forall_clash_thm - `!f l s. +Theorem forall_clash_thm: + !f l s. (!x s. f x s <> (Failure (Clash tm),refs)) ==> - forall f l s <> (Failure (Clash tm),refs)` - (recInduct forall_ind \\ rw [] \\ once_rewrite_tac [forall_def] + forall f l s <> (Failure (Clash tm),refs) +Proof + recInduct forall_ind \\ rw [] \\ once_rewrite_tac [forall_def] \\ fs [st_ex_bind_def, st_ex_return_def] - \\ every_case_tac \\ fs [] \\ metis_tac []); + \\ every_case_tac \\ fs [] \\ metis_tac [] +QED -Theorem image_clash_thm - `!f l s. +Theorem image_clash_thm: + !f l s. (!x s. f x s <> (Failure (Clash tm),refs)) ==> - image f l s <> (Failure (Clash tm),refs)` - (recInduct image_ind \\ rw [] \\ once_rewrite_tac [image_def] + image f l s <> (Failure (Clash tm),refs) +Proof + recInduct image_ind \\ rw [] \\ once_rewrite_tac [image_def] \\ rw [st_ex_bind_def, st_ex_return_def, raise_Fail_def] - \\ every_case_tac \\ fs [] \\ metis_tac []); + \\ every_case_tac \\ fs [] \\ metis_tac [] +QED (* Function specific theorems *) -Theorem dest_type_not_clash[simp] - `dest_type x y ≠ (Failure (Clash tm),refs)` - (Cases_on`x` \\ EVAL_TAC); +Theorem dest_type_not_clash[simp]: + dest_type x y ≠ (Failure (Clash tm),refs) +Proof + Cases_on`x` \\ EVAL_TAC +QED -Theorem mk_fun_ty_not_clash[simp] - `mk_fun_ty t a r ≠ (Failure(Clash tm),refs)` - (Cases_on`t` +Theorem mk_fun_ty_not_clash[simp]: + mk_fun_ty t a r ≠ (Failure(Clash tm),refs) +Proof + Cases_on`t` \\ rw [mk_fun_ty_def, mk_type_def, st_ex_bind_def, st_ex_return_def, raise_Fail_def, try_def, otherwise_def] - \\ fs [case_eq_thms, bool_case_eq, COND_RATOR]); + \\ fs [case_eq_thms, bool_case_eq, COND_RATOR] +QED -Theorem type_of_not_clash[simp] - `∀x y. type_of x y ≠ (Failure (Clash tm),refs)` - (recInduct type_of_ind +Theorem type_of_not_clash[simp]: + ∀x y. type_of x y ≠ (Failure (Clash tm),refs) +Proof + recInduct type_of_ind \\ rw[] \\ rw[Once type_of_def,st_ex_bind_def,raise_Fail_def,case_eq_thms] \\ CASE_TAC \\ fs[st_ex_return_def,case_eq_thms] \\ CCONTR_TAC \\ fs[pair_case_eq] \\ rw[] \\ fs[] \\ rfs[] - \\ every_case_tac \\ fs[] \\ rfs[]); - -Theorem mk_abs_not_clash[simp] - `mk_abs x y ≠ (Failure (Clash tm),refs)` - (Cases_on`x` \\ EVAL_TAC \\ CASE_TAC \\ fs[]); - -Theorem mk_comb_not_clash[simp] - `mk_comb x y ≠ (Failure (Clash tm),refs)` - (Cases_on`x` \\ rw[mk_comb_def,st_ex_bind_def,case_eq_thms] + \\ every_case_tac \\ fs[] \\ rfs[] +QED + +Theorem mk_abs_not_clash[simp]: + mk_abs x y ≠ (Failure (Clash tm),refs) +Proof + Cases_on`x` \\ EVAL_TAC \\ CASE_TAC \\ fs[] +QED + +Theorem mk_comb_not_clash[simp]: + mk_comb x y ≠ (Failure (Clash tm),refs) +Proof + Cases_on`x` \\ rw[mk_comb_def,st_ex_bind_def,case_eq_thms] \\ CCONTR_TAC \\ fs[] \\ rw[] \\ fs[] - \\ every_case_tac \\ fs[raise_Fail_def,st_ex_return_def]); - -Theorem mk_eq_not_clash[simp] - `mk_eq x y ≠ (Failure(Clash tm),refs)` - (Cases_on`x` \\ rw[mk_eq_def,st_ex_bind_def,try_def,otherwise_def,case_eq_thms] - \\ CCONTR_TAC \\ fs[st_ex_return_def,raise_Fail_def] \\ rw[]); - -Theorem ABS_not_clash[simp] - `ABS x y z ≠ (Failure (Clash tm),refs)` - (Cases_on`y` \\ rw [ABS_def, st_ex_return_def, st_ex_bind_def, raise_Fail_def] - \\ every_case_tac \\ fs [case_eq_thms] \\ CCONTR_TAC \\ fs []); - -Theorem MK_COMB_not_clash[simp] - `MK_COMB (a,b) c <> (Failure (Clash tm), refs)` - (Cases_on `a` \\ Cases_on `b` \\ rw [MK_COMB_def] + \\ every_case_tac \\ fs[raise_Fail_def,st_ex_return_def] +QED + +Theorem mk_eq_not_clash[simp]: + mk_eq x y ≠ (Failure(Clash tm),refs) +Proof + Cases_on`x` \\ rw[mk_eq_def,st_ex_bind_def,try_def,otherwise_def,case_eq_thms] + \\ CCONTR_TAC \\ fs[st_ex_return_def,raise_Fail_def] \\ rw[] +QED + +Theorem ABS_not_clash[simp]: + ABS x y z ≠ (Failure (Clash tm),refs) +Proof + Cases_on`y` \\ rw [ABS_def, st_ex_return_def, st_ex_bind_def, raise_Fail_def] + \\ every_case_tac \\ fs [case_eq_thms] \\ CCONTR_TAC \\ fs [] +QED + +Theorem MK_COMB_not_clash[simp]: + MK_COMB (a,b) c <> (Failure (Clash tm), refs) +Proof + Cases_on `a` \\ Cases_on `b` \\ rw [MK_COMB_def] \\ rw [raise_Fail_def, st_ex_return_def, st_ex_bind_def] \\ every_case_tac \\ fs [case_eq_thms] - \\ CCONTR_TAC \\ fs []); + \\ CCONTR_TAC \\ fs [] +QED -Theorem mk_type_not_clash[simp] - `!a b. mk_type a b <> (Failure (Clash tm), refs)` - (Cases \\ once_rewrite_tac [mk_type_def] +Theorem mk_type_not_clash[simp]: + !a b. mk_type a b <> (Failure (Clash tm), refs) +Proof + Cases \\ once_rewrite_tac [mk_type_def] \\ rw [st_ex_bind_def, st_ex_return_def, raise_Fail_def, try_def, otherwise_def] - \\ fs [case_eq_thms, bool_case_eq, COND_RATOR]); - -Theorem ASSUME_not_clash[simp] - `!a b. ASSUME a b <> (Failure (Clash tm), refs)` - (Cases \\ rw [ASSUME_def, st_ex_return_def, st_ex_bind_def, raise_Fail_def] - \\ rw [case_eq_thms, bool_case_eq, COND_RATOR]); - -Theorem BETA_not_clash[simp] - `BETA a b <> (Failure (Clash tm),refs)` - (strip_tac \\ Cases_on `a` + \\ fs [case_eq_thms, bool_case_eq, COND_RATOR] +QED + +Theorem ASSUME_not_clash[simp]: + !a b. ASSUME a b <> (Failure (Clash tm), refs) +Proof + Cases \\ rw [ASSUME_def, st_ex_return_def, st_ex_bind_def, raise_Fail_def] + \\ rw [case_eq_thms, bool_case_eq, COND_RATOR] +QED + +Theorem BETA_not_clash[simp]: + BETA a b <> (Failure (Clash tm),refs) +Proof + strip_tac \\ Cases_on `a` \\ fs [BETA_def, raise_Fail_def, st_ex_bind_def, st_ex_return_def] - \\ every_case_tac \\ fs [] \\ rw [] \\ fs []); + \\ every_case_tac \\ fs [] \\ rw [] \\ fs [] +QED -Theorem mk_const_not_clash[simp] - `mk_const (a,b) c <> (Failure (Clash tm),refs)` - (Cases_on`a` \\ once_rewrite_tac [mk_const_def] +Theorem mk_const_not_clash[simp]: + mk_const (a,b) c <> (Failure (Clash tm),refs) +Proof + Cases_on`a` \\ once_rewrite_tac [mk_const_def] \\ rw [st_ex_bind_def, st_ex_return_def, raise_Fail_def, try_def, otherwise_def, - case_eq_thms]); - -Theorem assoc_not_clash[simp] - `!a b c. assoc a b c <> (Failure (Clash tm),refs)` - (recInduct assoc_ind \\ rw [] \\ once_rewrite_tac [assoc_def] - \\ every_case_tac \\ fs [raise_Fail_def,st_ex_return_def]); - -Theorem get_const_type_not_clash[simp] - `get_const_type a b <> (Failure (Clash tm),refs)` - (Cases_on`a` \\ rw [get_const_type_def,st_ex_bind_def,case_eq_thms, get_the_term_constants_def]); - -Theorem DEDUCT_ANTISYM_RULE_not_clash[simp] - `DEDUCT_ANTISYM_RULE a b c <> (Failure (Clash tm),refs)` - (Cases_on `a` \\ Cases_on `b` \\ once_rewrite_tac [DEDUCT_ANTISYM_RULE_def] - \\ rw [st_ex_bind_def, st_ex_return_def, raise_Fail_def, case_eq_thms]); - -Theorem SYM_not_clash[simp] - `SYM a b <> (Failure (Clash tm),refs)` - (Cases_on `a` \\ EVAL_TAC \\ fs [raise_Fail_def, st_ex_return_def] - \\ every_case_tac \\ fs []); - -Theorem dest_comb_not_clash[simp] - `dest_comb a b <> (Failure (Clash tm),refs)` - (Cases_on`a` \\ EVAL_TAC); - -Theorem dest_eq_not_clash[simp] - `dest_eq a b <> (Failure (Clash tm),refs)` - (Cases_on`a` \\ EVAL_TAC \\ fs [raise_Fail_def, st_ex_return_def] - \\ every_case_tac \\ fs []); - -Theorem EQ_MP_not_clash[simp] - `EQ_MP a b c <> (Failure (Clash tm),refs)` - (Cases_on`a` \\ Cases_on`b` \\ rw [EQ_MP_def, raise_Fail_def, st_ex_return_def] - \\ every_case_tac \\ fs []); - -Theorem PROVE_HYP_not_clash[simp] - `PROVE_HYP a b c <> (Failure (Clash tm),refs)` - (Cases_on `a` \\ Cases_on `b` \\ rw [PROVE_HYP_def, st_ex_return_def]); - -Theorem REFL_not_clash[simp] - `REFL a b <> (Failure (Clash tm),refs)` - (rw [REFL_def, st_ex_bind_def, st_ex_return_def, case_eq_thms]); - -Theorem TRANS_not_clash[simp] - `TRANS a b c <> (Failure (Clash tm),refs)` - (Cases_on`a` \\ Cases_on `b` + case_eq_thms] +QED + +Theorem assoc_not_clash[simp]: + !a b c. assoc a b c <> (Failure (Clash tm),refs) +Proof + recInduct assoc_ind \\ rw [] \\ once_rewrite_tac [assoc_def] + \\ every_case_tac \\ fs [raise_Fail_def,st_ex_return_def] +QED + +Theorem get_const_type_not_clash[simp]: + get_const_type a b <> (Failure (Clash tm),refs) +Proof + Cases_on`a` \\ rw [get_const_type_def,st_ex_bind_def,case_eq_thms, get_the_term_constants_def] +QED + +Theorem DEDUCT_ANTISYM_RULE_not_clash[simp]: + DEDUCT_ANTISYM_RULE a b c <> (Failure (Clash tm),refs) +Proof + Cases_on `a` \\ Cases_on `b` \\ once_rewrite_tac [DEDUCT_ANTISYM_RULE_def] + \\ rw [st_ex_bind_def, st_ex_return_def, raise_Fail_def, case_eq_thms] +QED + +Theorem SYM_not_clash[simp]: + SYM a b <> (Failure (Clash tm),refs) +Proof + Cases_on `a` \\ EVAL_TAC \\ fs [raise_Fail_def, st_ex_return_def] + \\ every_case_tac \\ fs [] +QED + +Theorem dest_comb_not_clash[simp]: + dest_comb a b <> (Failure (Clash tm),refs) +Proof + Cases_on`a` \\ EVAL_TAC +QED + +Theorem dest_eq_not_clash[simp]: + dest_eq a b <> (Failure (Clash tm),refs) +Proof + Cases_on`a` \\ EVAL_TAC \\ fs [raise_Fail_def, st_ex_return_def] + \\ every_case_tac \\ fs [] +QED + +Theorem EQ_MP_not_clash[simp]: + EQ_MP a b c <> (Failure (Clash tm),refs) +Proof + Cases_on`a` \\ Cases_on`b` \\ rw [EQ_MP_def, raise_Fail_def, st_ex_return_def] + \\ every_case_tac \\ fs [] +QED + +Theorem PROVE_HYP_not_clash[simp]: + PROVE_HYP a b c <> (Failure (Clash tm),refs) +Proof + Cases_on `a` \\ Cases_on `b` \\ rw [PROVE_HYP_def, st_ex_return_def] +QED + +Theorem REFL_not_clash[simp]: + REFL a b <> (Failure (Clash tm),refs) +Proof + rw [REFL_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] +QED + +Theorem TRANS_not_clash[simp]: + TRANS a b c <> (Failure (Clash tm),refs) +Proof + Cases_on`a` \\ Cases_on `b` \\ rw [TRANS_def, st_ex_bind_def, st_ex_return_def, raise_Fail_def] \\ every_case_tac \\ fs [] \\ rw [] - \\ CCONTR_TAC \\ fs []); + \\ CCONTR_TAC \\ fs [] +QED -Theorem ALPHA_THM_not_clash[simp] - `!a b c d. ALPHA_THM a (b, c) d <> (Failure (Clash tm),refs)` - (recInduct ALPHA_THM_ind +Theorem ALPHA_THM_not_clash[simp]: + !a b c d. ALPHA_THM a (b, c) d <> (Failure (Clash tm),refs) +Proof + recInduct ALPHA_THM_ind \\ rw [ALPHA_THM_def, raise_Fail_def, st_ex_return_def, st_ex_bind_def] - \\ rw [case_eq_thms, bool_case_eq, COND_RATOR, map_not_clash_thm]); + \\ rw [case_eq_thms, bool_case_eq, COND_RATOR, map_not_clash_thm] +QED -Theorem add_constants_not_clash[simp] - `add_constants a b <> (Failure (Clash tm),refs)` - (Cases_on `a` \\ rw [add_constants_def, st_ex_bind_def, st_ex_return_def, +Theorem add_constants_not_clash[simp]: + add_constants a b <> (Failure (Clash tm),refs) +Proof + Cases_on `a` \\ rw [add_constants_def, st_ex_bind_def, st_ex_return_def, raise_Fail_def, get_the_term_constants_def, set_the_term_constants_def] - \\ every_case_tac \\ fs []); - -Theorem add_def_not_clash[simp] - `add_def a b <> (Failure (Clash tm),refs)` - (Cases_on `a` \\ EVAL_TAC); - -Theorem dest_var_not_clash[simp] - `dest_var a b <> (Failure (Clash tm),refs)` - (Cases_on `a` \\ EVAL_TAC \\ every_case_tac \\ fs [raise_Fail_def, st_ex_return_def]); - -Theorem new_specification_not_clash[simp] - `new_specification a b <> (Failure (Clash tm),refs)` - (Cases_on `a` \\ rw [new_specification_def, st_ex_bind_def, raise_Fail_def, + \\ every_case_tac \\ fs [] +QED + +Theorem add_def_not_clash[simp]: + add_def a b <> (Failure (Clash tm),refs) +Proof + Cases_on `a` \\ EVAL_TAC +QED + +Theorem dest_var_not_clash[simp]: + dest_var a b <> (Failure (Clash tm),refs) +Proof + Cases_on `a` \\ EVAL_TAC \\ every_case_tac \\ fs [raise_Fail_def, st_ex_return_def] +QED + +Theorem new_specification_not_clash[simp]: + new_specification a b <> (Failure (Clash tm),refs) +Proof + Cases_on `a` \\ rw [new_specification_def, st_ex_bind_def, raise_Fail_def, st_ex_return_def, case_eq_thms, bool_case_eq, COND_RATOR] \\ ho_match_mp_tac map_not_clash_thm \\ rw [] - \\ rw [case_eq_thms, bool_case_eq, COND_RATOR, ELIM_UNCURRY]); - -Theorem new_basic_definition_not_clash[simp] - `new_basic_definition a b <> (Failure (Clash tm),refs)` - (fs [new_basic_definition_def, st_ex_bind_def, case_eq_thms]); - -Theorem add_type_not_clash[simp] - `add_type (a,b) c <> (Failure (Clash tm),refs)` - (rw [add_type_def, st_ex_return_def, st_ex_bind_def, raise_Fail_def, can_def, + \\ rw [case_eq_thms, bool_case_eq, COND_RATOR, ELIM_UNCURRY] +QED + +Theorem new_basic_definition_not_clash[simp]: + new_basic_definition a b <> (Failure (Clash tm),refs) +Proof + fs [new_basic_definition_def, st_ex_bind_def, case_eq_thms] +QED + +Theorem add_type_not_clash[simp]: + add_type (a,b) c <> (Failure (Clash tm),refs) +Proof + rw [add_type_def, st_ex_return_def, st_ex_bind_def, raise_Fail_def, can_def, get_type_arity_def, get_the_type_constants_def, set_the_type_constants_def, otherwise_def] - \\ rw [case_eq_thms, bool_case_eq, COND_RATOR]); + \\ rw [case_eq_thms, bool_case_eq, COND_RATOR] +QED -Theorem new_basic_type_definition_not_clash[simp] - `new_basic_type_definition a b c d e <> (Failure (Clash tm),refs)` - (Cases_on `d` \\ rw [new_basic_type_definition_def, st_ex_bind_def, +Theorem new_basic_type_definition_not_clash[simp]: + new_basic_type_definition a b c d e <> (Failure (Clash tm),refs) +Proof + Cases_on `d` \\ rw [new_basic_type_definition_def, st_ex_bind_def, st_ex_return_def, raise_Fail_def, can_def, get_type_arity_def, get_the_type_constants_def, otherwise_def, try_def, case_eq_thms, bool_case_eq, - COND_RATOR, ELIM_UNCURRY]); + COND_RATOR, ELIM_UNCURRY] +QED -Theorem vsubst_not_clash[simp] - `vsubst x y s <> (Failure (Clash tm),refs)` - (rw [vsubst_def, st_ex_bind_def, st_ex_return_def, raise_Fail_def, +Theorem vsubst_not_clash[simp]: + vsubst x y s <> (Failure (Clash tm),refs) +Proof + rw [vsubst_def, st_ex_bind_def, st_ex_return_def, raise_Fail_def, ELIM_UNCURRY, case_eq_thms, bool_case_eq, COND_RATOR] \\ CCONTR_TAC \\ fs [] \\ rw [] \\ pop_assum mp_tac \\ fs [] - \\ ho_match_mp_tac forall_clash_thm \\ rw [case_eq_thms]); + \\ ho_match_mp_tac forall_clash_thm \\ rw [case_eq_thms] +QED -Theorem INST_not_clash[simp] - `INST theta x s <> (Failure (Clash tm),refs)` - (Cases_on `x` \\ rw [holKernelTheory.INST_def, st_ex_bind_def, st_ex_return_def, - case_eq_thms, image_clash_thm]); +Theorem INST_not_clash[simp]: + INST theta x s <> (Failure (Clash tm),refs) +Proof + Cases_on `x` \\ rw [holKernelTheory.INST_def, st_ex_bind_def, st_ex_return_def, + case_eq_thms, image_clash_thm] +QED (* TODO Prove for inst_aux *) (* -Theorem variant_same_ty - `!x z c d. +Theorem variant_same_ty: + !x z c d. variant x z = Var c d ==> - ?a b. z = Var a b /\ b = d` - (recInduct holSyntaxExtraTheory.variant_ind \\ rw [] + ?a b. z = Var a b /\ b = d +Proof + recInduct holSyntaxExtraTheory.variant_ind \\ rw [] \\ pop_assum mp_tac \\ simp [Once holSyntaxExtraTheory.variant_def] - \\ every_case_tac \\ fs []); + \\ every_case_tac \\ fs [] +QED -Theorem vsubst_same_Var[simp] - `vsubst_aux [(Var a b, Var c d)] (Var c d) = Var a b` - (once_rewrite_tac [vsubst_aux_def] \\ fs [] - \\ once_rewrite_tac [rev_assocd_def] \\ fs []); +Theorem vsubst_same_Var[simp]: + vsubst_aux [(Var a b, Var c d)] (Var c d) = Var a b +Proof + once_rewrite_tac [vsubst_aux_def] \\ fs [] + \\ once_rewrite_tac [rev_assocd_def] \\ fs [] +QED -Theorem inst_aux_clash_is_var - `!env tyin tm s f t. +Theorem inst_aux_clash_is_var: + !env tyin tm s f t. inst_aux env tyin tm s = (Failure (Clash f),t) ==> - ?a b. f = Var a b` - (recInduct inst_aux_ind \\ rw [] + ?a b. f = Var a b +Proof + recInduct inst_aux_ind \\ rw [] \\ pop_assum mp_tac \\ Cases_on `tm` \\ fs [] \\ once_rewrite_tac [inst_aux_def] \\ fs [] \\ simp [st_ex_return_def, st_ex_bind_def, raise_Fail_def] \\ simp [handle_Clash_def, raise_Clash_def, UNCURRY] \\ every_case_tac \\ fs [] \\ rw [] - \\ res_tac \\ fs []); + \\ res_tac \\ fs [] +QED val sizeof'_def = Define` sizeof' (Comb s t) = 1 + sizeof' s + sizeof' t ∧ @@ -2935,26 +3131,31 @@ val sizeof'_def = Define` sizeof' _ = 1n`; val _ = export_rewrites["sizeof'_def"]; -Theorem sizeof'_rev_assocd - `∀x l d. +Theorem sizeof'_rev_assocd: + ∀x l d. sizeof' d = sizeof' x ∧ EVERY (λp. sizeof' (FST p) = sizeof' (SND p)) l ⇒ - sizeof' (rev_assocd x l d) = sizeof' x` - (simp[rev_assocd_thm] - \\ Induct_on`l` \\ rw[holSyntaxLibTheory.REV_ASSOCD_def]); - -Theorem sizeof'_variant[simp] - `∀avoid tm. sizeof' (variant avoid tm) = sizeof' tm` - (recInduct holSyntaxExtraTheory.variant_ind + sizeof' (rev_assocd x l d) = sizeof' x +Proof + simp[rev_assocd_thm] + \\ Induct_on`l` \\ rw[holSyntaxLibTheory.REV_ASSOCD_def] +QED + +Theorem sizeof'_variant[simp]: + ∀avoid tm. sizeof' (variant avoid tm) = sizeof' tm +Proof + recInduct holSyntaxExtraTheory.variant_ind \\ rw[] \\ rw[Once holSyntaxExtraTheory.variant_def] - \\ CASE_TAC \\ fs[]); + \\ CASE_TAC \\ fs[] +QED -Theorem sizeof'_vsubst_aux - `∀tm ss. +Theorem sizeof'_vsubst_aux: + ∀tm ss. EVERY (λp. sizeof' (FST p) = sizeof' (SND p)) ss ⇒ - sizeof' (vsubst_aux ss tm) = sizeof' tm` - (Induct \\ rw[] + sizeof' (vsubst_aux ss tm) = sizeof' tm +Proof + Induct \\ rw[] \\ TRY ( rw[Once vsubst_aux_def] \\ DEP_REWRITE_TAC[sizeof'_rev_assocd] @@ -2965,15 +3166,17 @@ Theorem sizeof'_vsubst_aux first_x_assum match_mp_tac \\ simp[EVERY_FILTER] \\ fs[EVERY_MEM] - \\ NO_TAC)); + \\ NO_TAC) +QED -Theorem inst_aux_clash_is_var_in_env - `!n tm env tyin s f t. +Theorem inst_aux_clash_is_var_in_env: + !n tm env tyin s f t. sizeof' tm = n ∧ inst_aux env tyin tm s = (Failure (Clash f),t) ==> - ?a b. f = Var a b /\ MEM f (MAP SND env) /\ (∀y t. tm <> Abs y t)` - (gen_tac + ?a b. f = Var a b /\ MEM f (MAP SND env) /\ (∀y t. tm <> Abs y t) +Proof + gen_tac \\ completeInduct_on`n` \\ Induct \\ simp[Once inst_aux_def] @@ -3039,27 +3242,32 @@ Theorem inst_aux_clash_is_var_in_env \\ rw[] \\ strip_tac \\ fs[rev_assocd_thm,holSyntaxLibTheory.REV_ASSOCD_def] \\ rw[] - ); +QED -Theorem inst_aux_thm - `!env tyin tm s f t. +Theorem inst_aux_thm: + !env tyin tm s f t. env = [] ==> - inst_aux env tyin tm s <> (Failure (Clash f),t)` - (... - ); - -Theorem inst_not_clash[simp] - `inst x y z <> (Failure (Clash tm),refs)` - (fs [inst_def, st_ex_return_def, bool_case_eq, case_eq_thms, COND_RATOR] - \\ fs [inst_aux_thm]); - -Theorem INST_TYPE_not_clash[simp] - `INST_TYPE x y z <> (Failure (Clash tm),refs)` - (Cases_on `y` \\ fs [INST_TYPE_def, Once image_def] + inst_aux env tyin tm s <> (Failure (Clash f),t) +Proof + ... +QED + +Theorem inst_not_clash[simp]: + inst x y z <> (Failure (Clash tm),refs) +Proof + fs [inst_def, st_ex_return_def, bool_case_eq, case_eq_thms, COND_RATOR] + \\ fs [inst_aux_thm] +QED + +Theorem INST_TYPE_not_clash[simp]: + INST_TYPE x y z <> (Failure (Clash tm),refs) +Proof + Cases_on `y` \\ fs [INST_TYPE_def, Once image_def] \\ fs [st_ex_bind_def, st_ex_return_def] \\ every_case_tac \\ fs [] - \\ CCONTR_TAC \\ fs [] \\ rw [] \\ fs [image_clash_thm]); + \\ CCONTR_TAC \\ fs [] \\ rw [] \\ fs [image_clash_thm] +QED *) val _ = export_theory(); diff --git a/candle/standard/opentheory/compilation/ag32/proofs/readerProgProofScript.sml b/candle/standard/opentheory/compilation/ag32/proofs/readerProgProofScript.sml index 64ca114bfb..eabfab2cf8 100644 --- a/candle/standard/opentheory/compilation/ag32/proofs/readerProgProofScript.sml +++ b/candle/standard/opentheory/compilation/ag32/proofs/readerProgProofScript.sml @@ -36,15 +36,16 @@ val LENGTH_data = val _ = overload_on("reader_machine_config", ``ag32_machine_config (THE config.ffi_names) (LENGTH code) (LENGTH data)``); -Theorem target_state_rel_reader_start_asm_state - `SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ +Theorem target_state_rel_reader_start_asm_state: + SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ LENGTH inp ≤ stdin_size ∧ is_ag32_init_state (init_memory code data (THE config.ffi_names) (cl,inp)) ms ⇒ ∃n. target_state_rel ag32_target (init_asm_state code data (THE config.ffi_names) (cl,inp)) (FUNPOW Next n ms) ∧ ((FUNPOW Next n ms).io_events = ms.io_events) ∧ (∀x. x ∉ (ag32_startup_addresses) ⇒ - ((FUNPOW Next n ms).MEM x = ms.MEM x))` - (strip_tac + ((FUNPOW Next n ms).MEM x = ms.MEM x)) +Proof + strip_tac \\ drule (GEN_ALL init_asm_state_RTC_asm_step) \\ disch_then drule \\ simp_tac std_ss [] @@ -56,7 +57,8 @@ Theorem target_state_rel_reader_start_asm_state \\ qmatch_goalsub_abbrev_tac`_ ∉ md` \\ disch_then(qspec_then`md`assume_tac) \\ drule (GEN_ALL RTC_asm_step_ag32_target_state_rel_io_events) - \\ simp[EVAL``(ag32_init_asm_state m md).mem_domain``]); + \\ simp[EVAL``(ag32_init_asm_state m md).mem_domain``] +QED val reader_startup_clock_def = new_specification("reader_startup_clock_def",["reader_startup_clock"], @@ -76,14 +78,15 @@ val compile_correct_applied = |> Q.GEN`cbspace` |> Q.SPEC`0` |> Q.GEN`data_sp` |> Q.SPEC`0` -Theorem reader_installed - `SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ +Theorem reader_installed: + SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ LENGTH inp ≤ stdin_size ∧ is_ag32_init_state (init_memory code data (THE config.ffi_names) (cl,inp)) ms0 ⇒ installed code 0 data 0 config.ffi_names (basis_ffi cl fs) (heap_regs ag32_backend_config.stack_conf.reg_names) - (reader_machine_config) (FUNPOW Next (reader_startup_clock ms0 inp cl) ms0)` - (rewrite_tac[ffi_names, THE_DEF] + (reader_machine_config) (FUNPOW Next (reader_startup_clock ms0 inp cl) ms0) +Proof + rewrite_tac[ffi_names, THE_DEF] \\ strip_tac \\ irule ag32_installed \\ drule reader_startup_clock_def @@ -97,7 +100,8 @@ Theorem reader_installed \\ conj_tac >- (EVAL_TAC) \\ asm_exists_tac \\ simp[] - \\ fs[ffi_names]); + \\ fs[ffi_names] +QED val reader_machine_sem = compile_correct_applied @@ -115,8 +119,8 @@ val all_lines_stdin_fs = Q.prove ( lines_of (implode inp)`, EVAL_TAC); -Theorem reader_extract_writes - `wfcl cl /\ +Theorem reader_extract_writes: + wfcl cl /\ (LENGTH cl = 1) ==> let events = MAP get_output_io_event (reader_io_events cl (stdin_fs inp)) in @@ -133,8 +137,9 @@ Theorem reader_extract_writes (thyof refs.the_context, asl) |= c)) /\ refs.the_context extends init_ctxt /\ (out = explode (msg_success s refs.the_context)) /\ (err = "") - | _ => F` - (strip_tac \\ fs [] + | _ => F +Proof + strip_tac \\ fs [] \\ mp_tac (GEN_ALL (DISCH_ALL reader_output)) \\ disch_then (qspecl_then [`stdin_fs inp`, `cl`] mp_tac) \\ fs [wfFS_stdin_fs, STD_streams_stdin_fs, LENGTH_EQ_NUM_compute] @@ -210,10 +215,11 @@ Theorem reader_extract_writes \\ simp [AFUPDKEY_ALOOKUP] \\ simp [fsFFIPropsTheory.inFS_fname_def] \\ rw [OPTREL_def] - \\ CCONTR_TAC \\ fs [] \\ rw []); + \\ CCONTR_TAC \\ fs [] \\ rw [] +QED -Theorem reader_ag32_next - `SUM (MAP strlen cl) + LENGTH cl <= cline_size /\ +Theorem reader_ag32_next: + SUM (MAP strlen cl) + LENGTH cl <= cline_size /\ LENGTH inp <= stdin_size /\ wfcl cl /\ (LENGTH cl = 1) /\ @@ -226,8 +232,9 @@ Theorem reader_ag32_next (get_mem_word ms.MEM ms.PC = Encode (Jump (fAdd,0w,Imm 0w))) /\ outs ≼ MAP get_output_io_event (reader_io_events cl (stdin_fs inp)) /\ ((ms.R (n2w (reader_machine_config).ptr_reg) = 0w) ==> - (outs = MAP get_output_io_event (reader_io_events cl (stdin_fs inp))))` - (strip_tac + (outs = MAP get_output_io_event (reader_io_events cl (stdin_fs inp)))) +Proof + strip_tac \\ mp_tac (GEN_ALL reader_machine_sem) \\ disch_then (mp_tac o CONV_RULE (RESORT_FORALL_CONV rev)) \\ disch_then (qspec_then `cl` mp_tac) @@ -252,6 +259,7 @@ Theorem reader_ag32_next \\ strip_tac \\ goal_assum (first_assum o mp_then Any mp_tac) \\ goal_assum (first_assum o mp_then Any mp_tac) - \\ metis_tac []); + \\ metis_tac [] +QED val _ = export_theory(); diff --git a/candle/standard/opentheory/compilation/proofs/readerProgProofScript.sml b/candle/standard/opentheory/compilation/proofs/readerProgProofScript.sml index b5e9636001..b8a56585cc 100644 --- a/candle/standard/opentheory/compilation/proofs/readerProgProofScript.sml +++ b/candle/standard/opentheory/compilation/proofs/readerProgProofScript.sml @@ -64,8 +64,8 @@ val reader_code_def = Define ` val _ = Parse.hide "mem"; val mem = ``mem:'U->'U->bool``; -Theorem machine_code_sound - `input_exists fs cl /\ wfcl cl /\ wfFS fs /\ STD_streams fs +Theorem machine_code_sound: + input_exists fs cl /\ wfcl cl /\ wfFS fs /\ STD_streams fs ==> (installed_x64 reader_code (basis_ffi cl fs) mc ms ==> @@ -83,10 +83,12 @@ Theorem machine_code_sound MEM (Sequent asl c) s.thms /\ is_set_theory ^mem ==> - (thyof hol_refs.the_context, asl) |= c)` - (metis_tac [installed_x64_def, reader_code_def, reader_compiled_thm, PAIR, + (thyof hol_refs.the_context, asl) |= c) +Proof + metis_tac [installed_x64_def, reader_code_def, reader_compiled_thm, PAIR, FST, SND, reader_success_stderr, input_exists_def, - reader_sound]); + reader_sound] +QED val _ = export_theory (); diff --git a/candle/standard/opentheory/monadIO/readerIOProgScript.sml b/candle/standard/opentheory/monadIO/readerIOProgScript.sml index 66961e5c2f..a460389425 100644 --- a/candle/standard/opentheory/monadIO/readerIOProgScript.sml +++ b/candle/standard/opentheory/monadIO/readerIOProgScript.sml @@ -197,13 +197,14 @@ val EvalM_commandline_arguments = prove( (STATE_STORE,p:'ffi ffi_proj)``, metis_tac [commandline_INTRO,EvalM_arguments]); -Theorem EvalM_init_reader_wrap - `Eval env exp (UNIT_TYPE u) /\ +Theorem EvalM_init_reader_wrap: + Eval env exp (UNIT_TYPE u) /\ (nsLookup env.v (Short "init_reader_wrap") = SOME init_reader_wrap_v) ==> EvalM F env st (App Opapp [Var (Short "init_reader_wrap"); exp]) (MONAD (SUM_TYPE STRING_TYPE UNIT_TYPE) exc_ty (init_reader_wrap u)) - (HOL_STORE,p:'ffi ffi_proj)` - (ho_match_mp_tac EvalM_from_app \\ rw [] + (HOL_STORE,p:'ffi ffi_proj) +Proof + ho_match_mp_tac EvalM_from_app \\ rw [] >- (fs [init_reader_wrap_def, st_ex_bind_def, holKernelTheory.handle_Fail_def, st_ex_return_def] @@ -211,17 +212,20 @@ Theorem EvalM_init_reader_wrap \\ xapp_spec init_reader_wrap_spec \\ xsimpl \\ CONV_TAC SWAP_EXISTS_CONV - \\ qexists_tac `s` \\ xsimpl); + \\ qexists_tac `s` \\ xsimpl +QED -Theorem EvalM_holrefs_init_reader_wrap - `Eval env exp (UNIT_TYPE u) /\ +Theorem EvalM_holrefs_init_reader_wrap: + Eval env exp (UNIT_TYPE u) /\ nsLookup env.v (Short "init_reader_wrap") = SOME init_reader_wrap_v ==> EvalM F env st (App Opapp [Var (Short "init_reader_wrap"); exp]) (MONAD (SUM_TYPE STRING_TYPE UNIT_TYPE) HOL_EXN_TYPE - (holrefs (init_reader_wrap u))) (STATE_STORE, p:'ffi ffi_proj)` - (metis_tac [holrefs_INTRO, EvalM_init_reader_wrap]); + (holrefs (init_reader_wrap u))) (STATE_STORE, p:'ffi ffi_proj) +Proof + metis_tac [holrefs_INTRO, EvalM_init_reader_wrap] +QED val EvalM_readline_wrap = Q.prove ( `Eval env xv (PAIR_TYPE STRING_TYPE READER_STATE_TYPE x) /\ @@ -254,30 +258,34 @@ val EvalM_holrefs_readline_wrap = Q.prove ( (holrefs (readLine_wrap x))) (STATE_STORE, p:'ffi ffi_proj)`, metis_tac [holrefs_INTRO, EvalM_readline_wrap]); -Theorem EvalM_context - `Eval env uv (UNIT_TYPE u) /\ +Theorem EvalM_context: + Eval env uv (UNIT_TYPE u) /\ nsLookup env.v (Long "Kernel" (Short "context")) = SOME context_v ==> EvalM F env st (App Opapp [Var (Long "Kernel" (Short "context")); uv]) (MONAD (LIST_TYPE UPDATE_TYPE) HOL_EXN_TYPE (context u)) - (HOL_STORE, p:'ffi ffi_proj)` - (ho_match_mp_tac EvalM_from_app + (HOL_STORE, p:'ffi ffi_proj) +Proof + ho_match_mp_tac EvalM_from_app \\ rw [] >- (EVAL_TAC \\ fs []) \\ xapp_spec context_spec \\ xsimpl \\ CONV_TAC SWAP_EXISTS_CONV \\ qexists_tac `s` - \\ xsimpl); + \\ xsimpl +QED -Theorem EvalM_holrefs_context - `Eval env uv (UNIT_TYPE u) /\ +Theorem EvalM_holrefs_context: + Eval env uv (UNIT_TYPE u) /\ nsLookup env.v (Long "Kernel" (Short "context")) = SOME context_v ==> EvalM F env st (App Opapp [Var (Long "Kernel" (Short "context")); uv]) (MONAD (LIST_TYPE UPDATE_TYPE) HOL_EXN_TYPE (holrefs (context u))) - (STATE_STORE, p:'ffi ffi_proj)` - (metis_tac [holrefs_INTRO, EvalM_context]); + (STATE_STORE, p:'ffi ffi_proj) +Proof + metis_tac [holrefs_INTRO, EvalM_context] +QED (* ------------------------------------------------------------------------- *) (* Add access patterns *) @@ -303,9 +311,11 @@ val r = m_translate readLines_def val r = m_translate readFile_def val r = m_translate readMain_def -Theorem EVERY_TL - `!xs. EVERY P xs /\ xs <> [] ==> EVERY P (TL xs)` - (Induct \\ rw []); +Theorem EVERY_TL: + !xs. EVERY P xs /\ xs <> [] ==> EVERY P (TL xs) +Proof + Induct \\ rw [] +QED val readMain_side = Q.prove ( `wfcl st.cl ==> readmain_side st v`, (* wfcl on st.cl *) @@ -317,15 +327,16 @@ val readMain_side = Q.prove ( val readMain_spec = save_thm ("readMain_spec", cfMonadLib.mk_app_of_ArrowP (theorem "readmain_v_thm")); -Theorem readMain_spec_wp - `wfcl st.cl /\ +Theorem readMain_spec_wp: + wfcl st.cl /\ st.holrefs = init_refs ==> app (p:'ffi ffi_proj) readmain_v [Conv NONE []] (HOL_STORE st.holrefs * COMMANDLINE st.cl * MONAD_IO st.stdio) (POSTv uv. &UNIT_TYPE () uv * - STDIO (FST (SND (reader_main st.stdio st.holrefs (TL st.cl)))))` - (rw [] \\ xapp \\ xsimpl + STDIO (FST (SND (reader_main st.stdio st.holrefs (TL st.cl))))) +Proof + rw [] \\ xapp \\ xsimpl \\ simp [definition"STATE_STORE_def"] \\ CONV_TAC SWAP_EXISTS_CONV \\ qexists_tac `st` \\ xsimpl @@ -344,20 +355,22 @@ Theorem readMain_spec_wp \\ PairCases_on `r` \\ imp_res_tac readMain_correct \\ fs [] \\ qpat_x_assum `_ = init_refs` (assume_tac o GSYM) \\ fs [] - \\ xsimpl); + \\ xsimpl +QED (* ------------------------------------------------------------------------- *) (* whole_prog_spec *) (* ------------------------------------------------------------------------- *) -Theorem monadreader_wps - `hasFreeFD fs /\ +Theorem monadreader_wps: + hasFreeFD fs /\ wfcl cl ==> whole_prog_spec ^(fetch_v "readmain" (get_ml_prog_state())) cl fs (SOME (HOL_STORE init_refs)) - ((=) (FST (SND (reader_main fs init_refs (TL cl)))))` - (rw [whole_prog_spec_def] + ((=) (FST (SND (reader_main fs init_refs (TL cl))))) +Proof + rw [whole_prog_spec_def] \\ qmatch_goalsub_abbrev_tac `fs1 = _ with numchars := _` \\ qexists_tac `fs1` \\ fs [Abbr`fs1`] \\ reverse conj_tac @@ -373,7 +386,8 @@ Theorem monadreader_wps \\ CONV_TAC SWAP_EXISTS_CONV \\ qexists_tac `<| stdio := fs; cl := cl; holrefs := init_refs |>` \\ fs [MONAD_IO_def] - \\ xsimpl); + \\ xsimpl +QED val _ = add_user_heap_thm HOL_STORE_init_precond; diff --git a/candle/standard/opentheory/monadIO/readerIOProofScript.sml b/candle/standard/opentheory/monadIO/readerIOProofScript.sml index c3cda41bad..8796408fdd 100644 --- a/candle/standard/opentheory/monadIO/readerIOProofScript.sml +++ b/candle/standard/opentheory/monadIO/readerIOProofScript.sml @@ -15,48 +15,55 @@ val _ = new_theory "readerIOProof" (* Wrappers are ok *) (* ------------------------------------------------------------------------- *) -Theorem readLine_wrap_thm - `READER_STATE defs s /\ +Theorem readLine_wrap_thm: + READER_STATE defs s /\ STATE defs refs /\ readLine_wrap (l, s) refs = (res, refs') ==> ?ds x. res = Success x /\ STATE (ds ++ defs) refs' /\ - !s. x = INR s ==> READER_STATE (ds ++ defs) s` - (rw [readLine_wrap_def, handle_Fail_def, st_ex_bind_def, + !s. x = INR s ==> READER_STATE (ds ++ defs) s +Proof + rw [readLine_wrap_def, handle_Fail_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] \\ fs [] - \\ metis_tac [readLine_thm, APPEND_NIL]); + \\ metis_tac [readLine_thm, APPEND_NIL] +QED -Theorem init_reader_wrap_thm - `init_reader_wrap () init_refs = (res, refs') +Theorem init_reader_wrap_thm: + init_reader_wrap () init_refs = (res, refs') ==> ?defs x. res = Success x /\ - STATE defs refs'` - (rw [init_reader_wrap_def, handle_Fail_def, st_ex_bind_def, st_ex_return_def, + STATE defs refs' +Proof + rw [init_reader_wrap_def, handle_Fail_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] \\ fs [] - \\ metis_tac [init_reader_ok]); + \\ metis_tac [init_reader_ok] +QED (* ------------------------------------------------------------------------- *) (* Monadic I/O reader preserves invariants *) (* ------------------------------------------------------------------------- *) -Theorem ffi_msg_simp[simp] - `ffi_msg msg s = (Success (), s)` - (rw [ffi_msg_def, st_ex_return_def]); +Theorem ffi_msg_simp[simp]: + ffi_msg msg s = (Success (), s) +Proof + rw [ffi_msg_def, st_ex_return_def] +QED -Theorem readLines_thm - `!s lines res st st1 defs. +Theorem readLines_thm: + !s lines res st st1 defs. STATE defs st.holrefs /\ READER_STATE defs s /\ readLines s lines st = (res, st1) ==> ?ds x. res = Success () /\ - STATE (ds ++ defs) st1.holrefs` - (recInduct readLines_ind \\ rw [] + STATE (ds ++ defs) st1.holrefs +Proof + recInduct readLines_ind \\ rw [] \\ pop_assum mp_tac \\ simp [Once readLines_def] \\ fs [st_ex_return_def, st_ex_bind_def, liftM_def] @@ -85,14 +92,16 @@ Theorem readLines_thm \\ `STATE (ds++defs) c1.holrefs` by fs [Abbr `c1`] \\ first_x_assum drule \\ rpt (disch_then drule) \\ rw [] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem readMain_thm - `readMain () (c with holrefs := init_refs) = (res, c') +Theorem readMain_thm: + readMain () (c with holrefs := init_refs) = (res, c') ==> res = Success () /\ - ?ds. STATE ds c'.holrefs` - (rw [readMain_def, st_ex_bind_def, st_ex_return_def, case_eq_thms, + ?ds. STATE ds c'.holrefs +Proof + rw [readMain_def, st_ex_bind_def, st_ex_return_def, case_eq_thms, arguments_def, inputLinesFrom_def, print_err_def, print_def, bool_case_eq, COND_RATOR, liftM_def, readFile_def] \\ pop_assum mp_tac @@ -121,25 +130,28 @@ Theorem readMain_thm \\ rpt (disch_then drule) \\ rw [] \\ metis_tac []) \\ rw [] - \\ fs [EVAL ``?ds. STATE ds init_refs`` |> SIMP_RULE (srw_ss()) []]); + \\ fs [EVAL ``?ds. STATE ds init_refs`` |> SIMP_RULE (srw_ss()) []] +QED (* ------------------------------------------------------------------------- *) (* Monadic I/O reader satisfies I/O specification *) (* ------------------------------------------------------------------------- *) -Theorem readLine_wrap_correct - `readLine_wrap (line, s) refs = (res, refs_out) /\ +Theorem readLine_wrap_correct: + readLine_wrap (line, s) refs = (res, refs_out) /\ process_line s refs line = res_p ==> case res of Success (INL s) (* Error *) => res_p = (INR s, refs_out) | Success (INR s) (* Ok *) => res_p = (INL s, refs_out) - | _ => F (* Does not happen *)` - (rw [readLine_wrap_def, handle_Fail_def, st_ex_bind_def, st_ex_return_def, - process_line_def, case_eq_thms] \\ fs []); + | _ => F (* Does not happen *) +Proof + rw [readLine_wrap_def, handle_Fail_def, st_ex_bind_def, st_ex_return_def, + process_line_def, case_eq_thms] \\ fs [] +QED -Theorem readLine_EQ - `readLine_wrap (line, s) refs = (res1, t1) /\ +Theorem readLine_EQ: + readLine_wrap (line, s) refs = (res1, t1) /\ ~invalid_line line /\ readLine (unescape_ml (fix_fun_typ (str_prefix line))) s refs = (res2, t2) ==> @@ -147,16 +159,20 @@ Theorem readLine_EQ case res1 of Success (INL e) => res2 = Failure (Fail e) | Success (INR s) => res2 = Success s - | _ => F` - (rw [readLine_wrap_def, st_ex_bind_def, st_ex_return_def, handle_Fail_def, - case_eq_thms] \\ fs []); + | _ => F +Proof + rw [readLine_wrap_def, st_ex_bind_def, st_ex_return_def, handle_Fail_def, + case_eq_thms] \\ fs [] +QED -Theorem readLine_wrap_invalid_line - `invalid_line h ==> readLine_wrap (h, s) c = (Success (INR s), c)` - (rw [readLine_wrap_def, st_ex_return_def]); +Theorem readLine_wrap_invalid_line: + invalid_line h ==> readLine_wrap (h, s) c = (Success (INR s), c) +Proof + rw [readLine_wrap_def, st_ex_return_def] +QED -Theorem readLines_EQ - `!s line c res1 c_out res2 refs. +Theorem readLines_EQ: + !s line c res1 c_out res2 refs. readLines s line c = (res1, c_out) /\ readLines line s c.holrefs = (res2, refs) ==> @@ -166,8 +182,9 @@ Theorem readLines_EQ Success (s,_) => c_out.stdio = add_stdout c.stdio (msg_success s refs.the_context) | Failure (Fail e) => c_out.stdio = add_stderr c.stdio e - | _ => F` - (recInduct readLines_ind \\ rw [] + | _ => F +Proof + recInduct readLines_ind \\ rw [] \\ pop_assum mp_tac \\ simp [Once readerTheory.readLines_def] \\ pop_assum mp_tac \\ simp [Once readLines_def] \\ `!x. x with holrefs := x.holrefs = x` @@ -184,25 +201,29 @@ Theorem readLines_EQ \\ rpt (pairarg_tac \\ fs []) \\ rw [] \\ imp_res_tac readLine_wrap_invalid_line \\ fs [] \\ rw [] \\ imp_res_tac readLine_EQ \\ fs [] \\ rw [] - \\ first_x_assum drule \\ simp []); + \\ first_x_assum drule \\ simp [] +QED -Theorem readFile_correct - `readFile fname c = (res, c_out) /\ +Theorem readFile_correct: + readFile fname c = (res, c_out) /\ read_file c.stdio c.holrefs fname = (succ, fs, refs, fstate) ==> - res = Success () /\ fs = c_out.stdio /\ refs = c_out.holrefs` - (rw [readFile_def, read_file_def, st_ex_bind_def, st_ex_return_def, + res = Success () /\ fs = c_out.stdio /\ refs = c_out.holrefs +Proof + rw [readFile_def, read_file_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] \\ TRY (Cases_on `lines` \\ fs []) \\ fs [liftM_def, print_err_def, print_def, inputLinesFrom_def] \\ rw [] - \\ imp_res_tac readLines_EQ \\ fs [] \\ rfs []); + \\ imp_res_tac readLines_EQ \\ fs [] \\ rfs [] +QED -Theorem readMain_correct - `readMain () c = (res, c_out) /\ +Theorem readMain_correct: + readMain () c = (res, c_out) /\ reader_main c.stdio c.holrefs (TL c.cl) = (succ, fs, refs, fstate) ==> - res = Success () /\ fs = c_out.stdio` - (simp [readMain_def, st_ex_bind_def, case_eq_thms, arguments_def, liftM_def, + res = Success () /\ fs = c_out.stdio +Proof + simp [readMain_def, st_ex_bind_def, case_eq_thms, arguments_def, liftM_def, print_err_def, init_reader_wrap_def, handle_Fail_def, st_ex_return_def, st_ex_bind_def] \\ rpt (PURE_TOP_CASE_TAC \\ fs []) @@ -215,18 +236,20 @@ Theorem readMain_correct \\ Cases_on `read_file st.stdio st.holrefs h` \\ PairCases_on `r` \\ imp_res_tac readFile_correct) - \\ drule (GEN_ALL readFile_correct) \\ fs []); + \\ drule (GEN_ALL readFile_correct) \\ fs [] +QED (* ------------------------------------------------------------------------- *) (* Preserving the commandline is crucial *) (* ------------------------------------------------------------------------- *) -Theorem readLines_COMMANDLINE_pres - `!s line sr res tr. +Theorem readLines_COMMANDLINE_pres: + !s line sr res tr. readLines s line sr = (res, tr) ==> - tr.cl = sr.cl` - (recInduct readLines_ind + tr.cl = sr.cl +Proof + recInduct readLines_ind \\ gen_tac \\ Cases \\ strip_tac \\ rw [Once readLines_def, print_def, liftM_def, st_ex_bind_def, st_ex_return_def] @@ -235,16 +258,19 @@ Theorem readLines_COMMANDLINE_pres \\ qpat_x_assum `_ = (res,tr)` mp_tac \\ PURE_TOP_CASE_TAC \\ fs [] \\ rw [UNCURRY] \\ fs [] - \\ first_x_assum drule \\ fs []); + \\ first_x_assum drule \\ fs [] +QED -Theorem readMain_COMMANDLINE_pres - `readMain () c = (res, d) +Theorem readMain_COMMANDLINE_pres: + readMain () c = (res, d) ==> - c.cl = d.cl` - (simp [readMain_def, st_ex_bind_def, st_ex_return_def, case_eq_thms, + c.cl = d.cl +Proof + simp [readMain_def, st_ex_bind_def, st_ex_return_def, case_eq_thms, readFile_def, liftM_def, arguments_def, print_err_def] \\ rpt (PURE_TOP_CASE_TAC \\ fs []) \\ fs [ELIM_UNCURRY] \\ rw [] \\ fs [] - \\ drule readLines_COMMANDLINE_pres \\ fs []); + \\ drule readLines_COMMANDLINE_pres \\ fs [] +QED val _ = export_theory (); diff --git a/candle/standard/opentheory/prettyScript.sml b/candle/standard/opentheory/prettyScript.sml index c6b56c08e3..f03a376c9f 100644 --- a/candle/standard/opentheory/prettyScript.sml +++ b/candle/standard/opentheory/prettyScript.sml @@ -189,13 +189,15 @@ val collect_vars_def = Define ` (v::vs, b) | _ => ([], tm)`; -Theorem collect_vars_term_size - `term_size (SND (collect_vars tm)) <= term_size tm` - (Induct_on `tm` +Theorem collect_vars_term_size: + term_size (SND (collect_vars tm)) <= term_size tm +Proof + Induct_on `tm` \\ rw [Once collect_vars_def, term_size_def] \\ PURE_CASE_TAC \\ fs [] \\ TRY pairarg_tac \\ fs [] - \\ rw [term_size_def]); + \\ rw [term_size_def] +QED val dest_binary_def = Define ` dest_binary nm tm = @@ -208,21 +210,24 @@ val dest_binary_def = Define ` (l::ls, r) | _ => ([], tm)`; -Theorem dest_binary_term_size - `term_size (SND (dest_binary nm tm)) <= term_size tm` - (Induct_on `tm` +Theorem dest_binary_term_size: + term_size (SND (dest_binary nm tm)) <= term_size tm +Proof + Induct_on `tm` \\ rw [Once dest_binary_def, term_size_def] \\ PURE_CASE_TAC \\ fs [] \\ rw [term_size_def] \\ PURE_CASE_TAC \\ fs [] \\ rw [term_size_def] - \\ fs [UNCURRY]); + \\ fs [UNCURRY] +QED -Theorem dest_binary_MEM_term_size - `!nm tm ts t q. +Theorem dest_binary_MEM_term_size: + !nm tm ts t q. MEM t ts /\ dest_binary nm tm = (ts, q) ==> - term_size t < term_size tm` - (recInduct (theorem "dest_binary_ind") + term_size t < term_size tm +Proof + recInduct (theorem "dest_binary_ind") \\ rpt gen_tac \\ strip_tac \\ Induct \\ rw [Once dest_binary_def] @@ -233,7 +238,8 @@ Theorem dest_binary_MEM_term_size \\ rw [] \\ pairarg_tac \\ fs [] \\ rw [] \\ rw [term_size_def] - \\ res_tac \\ fs []); + \\ res_tac \\ fs [] +QED val dest_binder_def = Define ` dest_binder nm tm = @@ -246,16 +252,18 @@ val dest_binder_def = Define ` (v::vs, r) | _ => ([], tm)`; -Theorem dest_binder_term_size - `!nm tm vs b. dest_binder nm tm = (vs, b) ==> term_size b <= term_size tm` - (recInduct (theorem "dest_binder_ind") +Theorem dest_binder_term_size: + !nm tm vs b. dest_binder nm tm = (vs, b) ==> term_size b <= term_size tm +Proof + recInduct (theorem "dest_binder_ind") \\ rw [] \\ pop_assum mp_tac \\ simp [Once dest_binder_def] \\ rpt (PURE_TOP_CASE_TAC \\ fs []) \\ pairarg_tac \\ rw [term_size_def] - \\ fs []); + \\ fs [] +QED (* ------------------------------------------------------------------------- *) (* A pretty printer for terms. *) @@ -403,20 +411,22 @@ val thm2str_def = Define ` val _ = patternMatchesLib.ENABLE_PMATCH_CASES (); val PMATCH_ELIM_CONV = patternMatchesLib.PMATCH_ELIM_CONV; -Theorem is_binop_PMATCH - `!tm. +Theorem is_binop_PMATCH: + !tm. is_binop tm = case tm of Comb (Comb (Const con _) _) _ => (case fixity_of con of right _ => T | _ => F) - | _ => F` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) - \\ simp [is_binop_def]); - -Theorem is_binder_PMATCH - `!tm. + | _ => F +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) + \\ simp [is_binop_def] +QED + +Theorem is_binder_PMATCH: + !tm. is_binder tm = case tm of Comb (Const nm _) (Abs (Var _ _) _) => @@ -424,42 +434,50 @@ Theorem is_binder_PMATCH nm = strlit"Data.Bool.!" \/ nm = strlit"Data.Bool.?!" \/ nm = strlit"@" - | _ => F` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) - \\ simp [is_binder_def]); - -Theorem is_cond_PMATCH - `!tm. + | _ => F +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) + \\ simp [is_binder_def] +QED + +Theorem is_cond_PMATCH: + !tm. is_cond tm = case tm of Comb (Comb (Comb (Const con _) _) _) _ => con = strlit"Data.Bool.cond" - | _ => F` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) - \\ simp [is_cond_def]); - -Theorem is_neg_PMATCH - `!tm. + | _ => F +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) + \\ simp [is_cond_def] +QED + +Theorem is_neg_PMATCH: + !tm. is_neg tm = case tm of Comb (Const nm _) _ => nm = strlit"Data.Bool.~" - | _ => F` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) - \\ simp [is_neg_def]); - -Theorem collect_vars_PMATCH - `!tm. + | _ => F +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) + \\ simp [is_neg_def] +QED + +Theorem collect_vars_PMATCH: + !tm. collect_vars tm = case tm of Abs (Var v ty) r => let (vs, b) = collect_vars r in (v::vs, b) - | _ => ([], tm)` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) - \\ simp [Once collect_vars_def]); - -Theorem dest_binary_PMATCH - `!tm. + | _ => ([], tm) +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) + \\ simp [Once collect_vars_def] +QED + +Theorem dest_binary_PMATCH: + !tm. dest_binary nm tm = case tm of Comb (Comb (Const nm' _) l) r => @@ -468,12 +486,14 @@ Theorem dest_binary_PMATCH else let (ls, r) = dest_binary nm r in (l::ls, r) - | _ => ([], tm)` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) - \\ simp [Once dest_binary_def]); - -Theorem dest_binder_PMATCH - `!tm. + | _ => ([], tm) +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) + \\ simp [Once dest_binary_def] +QED + +Theorem dest_binder_PMATCH: + !tm. dest_binder nm tm = case tm of Comb (Const nm' _) (Abs (Var v _) b) => @@ -482,8 +502,10 @@ Theorem dest_binder_PMATCH else let (vs, r) = dest_binder nm b in (v::vs, r) - | _ => ([], tm)` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) - \\ simp [Once dest_binder_def]); + | _ => ([], tm) +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) + \\ simp [Once dest_binder_def] +QED val _ = export_theory (); diff --git a/candle/standard/opentheory/readerProgScript.sml b/candle/standard/opentheory/readerProgScript.sml index 5c30a11284..50623973d2 100644 --- a/candle/standard/opentheory/readerProgScript.sml +++ b/candle/standard/opentheory/readerProgScript.sml @@ -12,17 +12,21 @@ val _ = new_theory "readerProg" val _ = m_translation_extends "reader_commonProg" (* TODO: move *) -Theorem fastForwardFD_ADELKEY_same[simp] - `forwardFD fs fd n with infds updated_by ADELKEY fd = - fs with infds updated_by ADELKEY fd` - (fs [forwardFD_def, IO_fs_component_equality]); +Theorem fastForwardFD_ADELKEY_same[simp]: + forwardFD fs fd n with infds updated_by ADELKEY fd = + fs with infds updated_by ADELKEY fd +Proof + fs [forwardFD_def, IO_fs_component_equality] +QED (* TODO: move *) -Theorem validFileFD_forwardFD - `validFileFD fd (forwardFD fs x y).infds <=> validFileFD fd fs.infds` - (rw [forwardFD_def, validFileFD_def, AFUPDKEY_ALOOKUP] +Theorem validFileFD_forwardFD: + validFileFD fd (forwardFD fs x y).infds <=> validFileFD fd fs.infds +Proof + rw [forwardFD_def, validFileFD_def, AFUPDKEY_ALOOKUP] \\ PURE_TOP_CASE_TAC \\ fs [] - \\ rename1 `_ = SOME xx` \\ PairCases_on `xx` \\ rw []); + \\ rename1 `_ = SOME xx` \\ PairCases_on `xx` \\ rw [] +QED (* ------------------------------------------------------------------------- *) (* CakeML wrapper *) @@ -35,8 +39,8 @@ val _ = (append_prog o process_topdecs) ` else Inl (readline (unescape_ml (fix_fun_typ (str_prefix ln))) st0) handle Kernel.Fail e => Inr e`; -Theorem process_line_spec - `READER_STATE_TYPE st stv ∧ STRING_TYPE ln lnv +Theorem process_line_spec: + READER_STATE_TYPE st stv ∧ STRING_TYPE ln lnv ==> app (p: 'ffi ffi_proj) ^(fetch_v "process_line" (get_ml_prog_state())) [stv; lnv] @@ -44,8 +48,9 @@ Theorem process_line_spec (POSTv stv. HOL_STORE (SND(process_line st refs ln)) * &SUM_TYPE READER_STATE_TYPE STRING_TYPE - (FST(process_line st refs ln)) stv)` - (xcf "process_line" (get_ml_prog_state()) + (FST(process_line st refs ln)) stv) +Proof + xcf "process_line" (get_ml_prog_state()) \\ xlet_auto >- xsimpl \\ simp[process_line_def] \\ xif \\ fs [] @@ -74,7 +79,8 @@ Theorem process_line_spec \\ xlet_auto \\ xsimpl \\ xlet_auto \\ xsimpl \\ fs [] \\ xcon \\ xsimpl - \\ fs[SUM_TYPE_def] ); + \\ fs[SUM_TYPE_def] +QED val _ = (append_prog o process_topdecs) ` fun process_lines ins st0 = @@ -85,8 +91,8 @@ val _ = (append_prog o process_topdecs) ` Inl st1 => process_lines ins (next_line st1) | Inr e => TextIO.output TextIO.stdErr (line_fail st0 e))`; -Theorem process_lines_spec - `!n st stv refs. +Theorem process_lines_spec: + !n st stv refs. READER_STATE_TYPE st stv /\ INSTREAM fd fdv /\ fd <= maxFD /\ fd <> 1 /\ fd <> 2 /\ STD_streams fs /\ @@ -98,8 +104,9 @@ Theorem process_lines_spec (STDIO fs * HOL_STORE refs) (POSTv u. &UNIT_TYPE () u * - process_lines fd st refs fs (MAP implode (linesFD fs fd)))` - (Induct_on`linesFD fs fd` + process_lines fd st refs fs (MAP implode (linesFD fs fd))) +Proof + Induct_on`linesFD fs fd` >- ( rpt strip_tac \\ qpat_x_assum`[] = _`(assume_tac o SYM) @@ -186,7 +193,8 @@ Theorem process_lines_spec \\ SELECT_ELIM_TAC \\ (conj_tac >- metis_tac[STD_streams_stderr]) \\ rw[stdo_def,up_stdo_def,LENGTH_explode] - \\ xsimpl); + \\ xsimpl +QED (* Apply the reader on a list of lines. *) @@ -219,8 +227,8 @@ val _ = (append_prog o process_topdecs) ` handle TextIO.BadFileName => TextIO.output TextIO.stdErr (msg_bad_name file)`; -Theorem readLines_process_lines - `∀ls st refs res r fs. +Theorem readLines_process_lines: + ∀ls st refs res r fs. readLines ls st refs = (res,r) ⇒ ∃n. process_lines fd st refs fs ls = @@ -230,8 +238,9 @@ Theorem readLines_process_lines HOL_STORE r | (Failure (Fail e)) => STDIO (add_stderr (forwardFD fs fd n) e) * - HOL_STORE r` - (Induct \\ rw[process_lines_def] + HOL_STORE r +Proof + Induct \\ rw[process_lines_def] >- ( fs[Once readLines_def,st_ex_return_def] \\ rw[] ) \\ pop_assum mp_tac \\ simp[Once readLines_def, handle_Fail_def, raise_Fail_def, st_ex_bind_def] @@ -256,10 +265,11 @@ Theorem readLines_process_lines \\ CASE_TAC \\ fs [] \\ rw [] \\ fs [] \\ qspecl_then[`fs`,`fd`]strip_assume_tac lineForwardFD_forwardFD - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem readLines_process_list - `!ls s refs res r fs. +Theorem readLines_process_list: + !ls s refs res r fs. readLines ls s refs = (res,r) ⇒ ∃n. process_list fs s refs ls = @@ -268,16 +278,18 @@ Theorem readLines_process_list STDIO (add_stdout fs (msg_success s r.the_context)) * HOL_STORE r | (Failure (Fail e)) => STDIO (add_stderr fs e) * - HOL_STORE r` - (Induct \\ rw [process_list_def] + HOL_STORE r +Proof + Induct \\ rw [process_list_def] \\ pop_assum mp_tac \\ rw [Once readLines_def, st_ex_return_def, st_ex_bind_def, raise_Fail_def, handle_Fail_def] \\ fs [process_line_def] - \\ rpt (PURE_CASE_TAC \\ fs []) \\ rw []) + \\ rpt (PURE_CASE_TAC \\ fs []) \\ rw [] +QED -Theorem process_list_spec - `!ls lsv s sv fs refs. +Theorem process_list_spec: + !ls lsv s sv fs refs. STD_streams fs /\ LIST_TYPE STRING_TYPE ls lsv /\ READER_STATE_TYPE s sv @@ -285,8 +297,9 @@ Theorem process_list_spec app (p:'ffi ffi_proj) ^(fetch_v "process_list" (get_ml_prog_state ())) [lsv; sv] (STDIO fs * HOL_STORE refs) - (POSTv u. &UNIT_TYPE () u * process_list fs s refs ls)` - (Induct \\ rw [] + (POSTv u. &UNIT_TYPE () u * process_list fs s refs ls) +Proof + Induct \\ rw [] >- (fs [LIST_TYPE_def] \\ xcf "process_list" (get_ml_prog_state ()) @@ -357,10 +370,11 @@ Theorem process_list_spec \\ instantiate \\ CONV_TAC SWAP_EXISTS_CONV \\ qexists_tac `r` - \\ xsimpl); + \\ xsimpl +QED -Theorem read_stdin_spec - `UNIT_TYPE () uv /\ +Theorem read_stdin_spec: + UNIT_TYPE () uv /\ (?inp. stdin fs inp 0) ==> app (p: 'ffi ffi_proj) ^(fetch_v "read_stdin" (get_ml_prog_state())) [uv] @@ -368,8 +382,9 @@ Theorem read_stdin_spec (POSTv u. &UNIT_TYPE () u * STDIO (FST (read_stdin fs refs)) * - HOL_STORE (FST (SND (read_stdin fs refs))))` - (xcf "read_stdin" (get_ml_prog_state ()) + HOL_STORE (FST (SND (read_stdin fs refs)))) +Proof + xcf "read_stdin" (get_ml_prog_state ()) \\ reverse (Cases_on `STD_streams fs`) >- (fs [TextIOProofTheory.STDIO_def] \\ xpull) \\ fs [UNIT_TYPE_def] @@ -407,18 +422,20 @@ Theorem read_stdin_spec \\ disch_then (qspec_then `fastForwardFD fs 0` mp_tac) \\ rw [] \\ rpt CASE_TAC \\ fs [] \\ fs [stdin_def, all_lines_def, lines_of_def, strcat_thm] \\ rfs [] - \\ xsimpl); + \\ xsimpl +QED -Theorem read_file_spec - `FILENAME fnm fnv /\ hasFreeFD fs +Theorem read_file_spec: + FILENAME fnm fnv /\ hasFreeFD fs ==> app (p: 'ffi ffi_proj) ^(fetch_v "read_file" (get_ml_prog_state())) [fnv] (STDIO fs * HOL_STORE refs) (POSTv u. &UNIT_TYPE () u * STDIO (FST (read_file fs refs fnm)) * - HOL_STORE (FST (SND (read_file fs refs fnm))))` - (xcf "read_file" (get_ml_prog_state()) + HOL_STORE (FST (SND (read_file fs refs fnm)))) +Proof + xcf "read_file" (get_ml_prog_state()) \\ reverse (Cases_on `STD_streams fs`) >- (fs [TextIOProofTheory.STDIO_def] \\ xpull) \\ reverse (Cases_on`consistentFS fs`) @@ -516,7 +533,8 @@ Theorem read_file_spec (qspecl_then [`str1`,`"stderr"`,`openFileFS fnm fs ReadMode 0`] mp_tac) \\ xsimpl \\ fs [validFileFD_forwardFD] - \\ rw [validFileFD_def]); + \\ rw [validFileFD_def] +QED val _ = (append_prog o process_topdecs) ` fun reader_main u = @@ -529,8 +547,8 @@ val _ = (append_prog o process_topdecs) ` | _ => TextIO.output TextIO.stdErr msg_usage end`; -Theorem reader_main_spec - `(?s. init_reader () refs = (Success (), s)) /\ +Theorem reader_main_spec: + (?s. init_reader () refs = (Success (), s)) /\ input_exists fs cl ==> app (p:'ffi ffi_proj) ^(fetch_v "reader_main" (get_ml_prog_state())) @@ -538,8 +556,9 @@ Theorem reader_main_spec (COMMANDLINE cl * STDIO fs * HOL_STORE refs) (POSTv u. &UNIT_TYPE () u * - STDIO (FST (reader_main fs refs (TL cl))))` - (xcf "reader_main" (get_ml_prog_state()) + STDIO (FST (reader_main fs refs (TL cl)))) +Proof + xcf "reader_main" (get_ml_prog_state()) \\ reverse (Cases_on `STD_streams fs`) >- (fs [STDIO_def] \\ xpull) \\ reverse (Cases_on `wfcl cl`) @@ -590,19 +609,21 @@ Theorem reader_main_spec \\ xsimpl \\ CONV_TAC SWAP_EXISTS_CONV \\ qexists_tac `s` - \\ xsimpl \\ fs []); + \\ xsimpl \\ fs [] +QED (* ------------------------------------------------------------------------- *) (* whole_prog_spec *) (* ------------------------------------------------------------------------- *) -Theorem reader_whole_prog_spec - `input_exists fs cl +Theorem reader_whole_prog_spec: + input_exists fs cl ==> whole_prog_spec ^(fetch_v "reader_main" (get_ml_prog_state())) cl fs (SOME (HOL_STORE init_refs)) - ((=) (FST (reader_main fs init_refs (TL cl))))` - (rw [whole_prog_spec_def] + ((=) (FST (reader_main fs init_refs (TL cl)))) +Proof + rw [whole_prog_spec_def] \\ qmatch_goalsub_abbrev_tac `fs1 = _ with numchars := _` \\ qexists_tac `fs1` \\ fs [Abbr`fs1`] \\ reverse conj_tac @@ -620,7 +641,8 @@ Theorem reader_whole_prog_spec \\ CONV_TAC SWAP_EXISTS_CONV \\ qexists_tac `init_refs` \\ xsimpl \\ Cases_on `init_reader () init_refs` - \\ fs [init_reader_success]); + \\ fs [init_reader_success] +QED val _ = add_user_heap_thm HOL_STORE_init_precond; diff --git a/candle/standard/opentheory/readerProofScript.sml b/candle/standard/opentheory/readerProofScript.sml index 49a3ae2b70..f3961447cc 100644 --- a/candle/standard/opentheory/readerProofScript.sml +++ b/candle/standard/opentheory/readerProofScript.sml @@ -21,207 +21,291 @@ val case_eq_thms = save_thm ("case_eq_thms", (* TODO move *) -Theorem new_axiom_not_clash[simp] - `new_axiom ax s <> (Failure (Clash tm), t)` - (strip_tac +Theorem new_axiom_not_clash[simp]: + new_axiom ax s <> (Failure (Clash tm), t) +Proof + strip_tac \\ fs [new_axiom_def, st_ex_bind_def, st_ex_return_def, raise_Fail_def, case_eq_thms, bool_case_eq, COND_RATOR, get_the_axioms_def, - set_the_axioms_def] \\ rw [] \\ fs []); - -Theorem new_constant_not_clash[simp] - `new_constant (a,b) s <> (Failure (Clash tm), t)` - (rw [new_constant_def, st_ex_bind_def, st_ex_return_def, case_eq_thms]); - -Theorem new_type_not_clash[simp] - `new_type (a,b) s <> (Failure (Clash tm), t)` - (rw [new_type_def, st_ex_bind_def, st_ex_return_def, case_eq_thms]); - -Theorem dest_abs_not_clash[simp] - `dest_abs x s <> (Failure (Clash tm), t)` - (EVAL_TAC \\ PURE_CASE_TAC \\ fs []); + set_the_axioms_def] \\ rw [] \\ fs [] +QED + +Theorem new_constant_not_clash[simp]: + new_constant (a,b) s <> (Failure (Clash tm), t) +Proof + rw [new_constant_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] +QED + +Theorem new_type_not_clash[simp]: + new_type (a,b) s <> (Failure (Clash tm), t) +Proof + rw [new_type_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] +QED + +Theorem dest_abs_not_clash[simp]: + dest_abs x s <> (Failure (Clash tm), t) +Proof + EVAL_TAC \\ PURE_CASE_TAC \\ fs [] +QED (* ------------------------------------------------------------------------- *) (* Reader does not raise Clash *) (* ------------------------------------------------------------------------- *) -Theorem find_axiom_not_clash[simp] - `find_axiom (a,b) c <> (Failure (Clash tm),refs)` - (Cases_on `a` +Theorem find_axiom_not_clash[simp]: + find_axiom (a,b) c <> (Failure (Clash tm),refs) +Proof + Cases_on `a` \\ rw [find_axiom_def, st_ex_bind_def, raise_Fail_def, st_ex_return_def, case_eq_thms, axioms_def, get_the_axioms_def, bool_case_eq] - \\ PURE_CASE_TAC \\ fs []); - -Theorem pop_not_clash[simp] - `pop x y ≠ (Failure (Clash tm),refs)` - (EVAL_TAC \\ rw[] \\ EVAL_TAC); - -Theorem peek_not_clash[simp] - `peek x y <> (Failure (Clash tm),refs)` - (EVAL_TAC \\ rw [] \\ EVAL_TAC); - -Theorem getNum_not_clash[simp] - `getNum x y ≠ (Failure (Clash tm),refs)` - (Cases_on`x` \\ EVAL_TAC); - -Theorem getVar_not_clash[simp] - `getVar x y ≠ (Failure (Clash tm),refs)` - (Cases_on`x` \\ EVAL_TAC); - -Theorem getTerm_not_clash[simp] - `getTerm x y ≠ (Failure (Clash tm),refs)` - (Cases_on`x` \\ EVAL_TAC); - -Theorem getThm_not_clash[simp] - `getThm x y ≠ (Failure (Clash tm),refs)` - (Cases_on`x` \\ EVAL_TAC); - -Theorem getType_not_clash[simp] - `getType x y <> (Failure (Clash tm),refs)` - (Cases_on`x` \\ EVAL_TAC); - -Theorem getName_not_clash[simp] - `getName x y <> (Failure (Clash tm),refs)` - (Cases_on`x` \\ EVAL_TAC - \\ fs [st_ex_return_def] \\ CASE_TAC \\ fs []); - -Theorem getConst_not_clash[simp] - `getConst x y <> (Failure (Clash tm),refs)` - (Cases_on`x` \\ EVAL_TAC); - -Theorem getList_not_clash[simp] - `getList x y <> (Failure (Clash tm),refs)` - (Cases_on `x` \\ EVAL_TAC); - -Theorem getTypeOp_not_clash[simp] - `getTypeOp a b <> (Failure (Clash tm),refs)` - (Cases_on`a` \\ EVAL_TAC); - -Theorem getPair_not_clash[simp] - `getPair a b <> (Failure (Clash tm),refs)` - (Cases_on `a` \\ EVAL_TAC \\ Cases_on `l` \\ EVAL_TAC - \\ Cases_on `t` \\ EVAL_TAC \\ Cases_on `t'` \\ EVAL_TAC); - -Theorem getCns_not_clash[simp] - `getCns a b <> (Failure (Clash tm),refs)` - (Cases_on `a` \\ EVAL_TAC \\ every_case_tac \\ fs []); - -Theorem getNvs_not_clash[simp] - `getNvs a b <> (Failure (Clash tm),refs)` - (Cases_on `a` \\ EVAL_TAC + \\ PURE_CASE_TAC \\ fs [] +QED + +Theorem pop_not_clash[simp]: + pop x y ≠ (Failure (Clash tm),refs) +Proof + EVAL_TAC \\ rw[] \\ EVAL_TAC +QED + +Theorem peek_not_clash[simp]: + peek x y <> (Failure (Clash tm),refs) +Proof + EVAL_TAC \\ rw [] \\ EVAL_TAC +QED + +Theorem getNum_not_clash[simp]: + getNum x y ≠ (Failure (Clash tm),refs) +Proof + Cases_on`x` \\ EVAL_TAC +QED + +Theorem getVar_not_clash[simp]: + getVar x y ≠ (Failure (Clash tm),refs) +Proof + Cases_on`x` \\ EVAL_TAC +QED + +Theorem getTerm_not_clash[simp]: + getTerm x y ≠ (Failure (Clash tm),refs) +Proof + Cases_on`x` \\ EVAL_TAC +QED + +Theorem getThm_not_clash[simp]: + getThm x y ≠ (Failure (Clash tm),refs) +Proof + Cases_on`x` \\ EVAL_TAC +QED + +Theorem getType_not_clash[simp]: + getType x y <> (Failure (Clash tm),refs) +Proof + Cases_on`x` \\ EVAL_TAC +QED + +Theorem getName_not_clash[simp]: + getName x y <> (Failure (Clash tm),refs) +Proof + Cases_on`x` \\ EVAL_TAC + \\ fs [st_ex_return_def] \\ CASE_TAC \\ fs [] +QED + +Theorem getConst_not_clash[simp]: + getConst x y <> (Failure (Clash tm),refs) +Proof + Cases_on`x` \\ EVAL_TAC +QED + +Theorem getList_not_clash[simp]: + getList x y <> (Failure (Clash tm),refs) +Proof + Cases_on `x` \\ EVAL_TAC +QED + +Theorem getTypeOp_not_clash[simp]: + getTypeOp a b <> (Failure (Clash tm),refs) +Proof + Cases_on`a` \\ EVAL_TAC +QED + +Theorem getPair_not_clash[simp]: + getPair a b <> (Failure (Clash tm),refs) +Proof + Cases_on `a` \\ EVAL_TAC \\ Cases_on `l` \\ EVAL_TAC + \\ Cases_on `t` \\ EVAL_TAC \\ Cases_on `t'` \\ EVAL_TAC +QED + +Theorem getCns_not_clash[simp]: + getCns a b <> (Failure (Clash tm),refs) +Proof + Cases_on `a` \\ EVAL_TAC \\ every_case_tac \\ fs [] +QED + +Theorem getNvs_not_clash[simp]: + getNvs a b <> (Failure (Clash tm),refs) +Proof + Cases_on `a` \\ EVAL_TAC \\ PURE_CASE_TAC \\ rw [case_eq_thms, UNCURRY] - \\ CCONTR_TAC \\ fs []); + \\ CCONTR_TAC \\ fs [] +QED -Theorem getTms_not_clash[simp] - `getTms a b <> (Failure (Clash tm),refs)` - (Cases_on `a` \\ EVAL_TAC +Theorem getTms_not_clash[simp]: + getTms a b <> (Failure (Clash tm),refs) +Proof + Cases_on `a` \\ EVAL_TAC \\ PURE_CASE_TAC \\ rw [case_eq_thms, UNCURRY] - \\ CCONTR_TAC \\ fs []); + \\ CCONTR_TAC \\ fs [] +QED -Theorem getTys_not_clash[simp] - `getTys a b <> (Failure (Clash tm),refs)` - (Cases_on `a` \\ EVAL_TAC +Theorem getTys_not_clash[simp]: + getTys a b <> (Failure (Clash tm),refs) +Proof + Cases_on `a` \\ EVAL_TAC \\ PURE_CASE_TAC \\ rw [case_eq_thms, UNCURRY] - \\ CCONTR_TAC \\ fs []); + \\ CCONTR_TAC \\ fs [] +QED -Theorem BETA_CONV_not_clash[simp] - `BETA_CONV t s <> (Failure (Clash tm),r)` - (rw [BETA_CONV_def, handle_Fail_def, st_ex_bind_def, raise_Fail_def] +Theorem BETA_CONV_not_clash[simp]: + BETA_CONV t s <> (Failure (Clash tm),r) +Proof + rw [BETA_CONV_def, handle_Fail_def, st_ex_bind_def, raise_Fail_def] \\ PURE_CASE_TAC \\ rw [case_eq_thms, UNCURRY] - \\ CCONTR_TAC \\ fs [] \\ rw [] \\ fs []); + \\ CCONTR_TAC \\ fs [] \\ rw [] \\ fs [] +QED -Theorem readLine_not_clash[simp] - `readLine x y z ≠ (Failure (Clash tm),refs)` - (rw [readLine_def, st_ex_bind_def, st_ex_return_def, raise_Fail_def, +Theorem readLine_not_clash[simp]: + readLine x y z ≠ (Failure (Clash tm),refs) +Proof + rw [readLine_def, st_ex_bind_def, st_ex_return_def, raise_Fail_def, handle_Clash_def, handle_Fail_def, case_eq_thms, UNCURRY] \\ CCONTR_TAC \\ fs [] \\ rw [] \\ fs [case_eq_thms, map_not_clash_thm] \\ pop_assum mp_tac \\ fs [] - \\ rpt (PURE_CASE_TAC \\ fs [])); + \\ rpt (PURE_CASE_TAC \\ fs []) +QED -Theorem readLines_not_clash[simp] - `∀ls x y tm refs. readLines ls x y ≠ (Failure (Clash tm),refs)` - (recInduct readLines_ind \\ rw[] +Theorem readLines_not_clash[simp]: + ∀ls x y tm refs. readLines ls x y ≠ (Failure (Clash tm),refs) +Proof + recInduct readLines_ind \\ rw[] \\ rw [Once readLines_def, case_eq_thms, st_ex_bind_def, st_ex_return_def, handle_Fail_def, raise_Fail_def] \\ PURE_CASE_TAC \\ fs [case_eq_thms, bool_case_eq, COND_RATOR] \\ rw [] - \\ CCONTR_TAC \\ fs [] \\ rw [] \\ fs [] \\ metis_tac []); + \\ CCONTR_TAC \\ fs [] \\ rw [] \\ fs [] \\ metis_tac [] +QED (* ------------------------------------------------------------------------- *) (* reader_init does not raise Clash *) (* ------------------------------------------------------------------------- *) -Theorem mk_true_not_clash[simp] - `mk_true () refs <> (Failure (Clash tm), refs')` - (rw [mk_true_def, st_ex_bind_def, st_ex_return_def, case_eq_thms]); - -Theorem mk_univ_not_clash[simp] - `mk_univ ty refs <> (Failure (Clash tm), refs')` - (rw [mk_univ_def, st_ex_bind_def, st_ex_return_def, case_eq_thms]); - -Theorem mk_forall_not_clash[simp] - `mk_forall (v,p) refs <> (Failure (Clash tm), refs')` - (rw [mk_forall_def, st_ex_bind_def, st_ex_return_def, case_eq_thms]); - -Theorem mk_eta_ax_not_clash[simp] - `mk_eta_ax () refs <> (Failure (Clash tm), refs')` - (rw [mk_eta_ax_def, st_ex_bind_def, st_ex_return_def, case_eq_thms]); - -Theorem mk_conj_const_not_clash[simp] - `mk_conj_const () refs <> (Failure (Clash tm), refs')` - (rw [mk_conj_const_def, st_ex_bind_def, st_ex_return_def, case_eq_thms]); - -Theorem mk_conj_not_clash[simp] - `mk_conj (p,q) refs <> (Failure (Clash tm), refs')` - (rw [mk_conj_def, st_ex_bind_def, st_ex_return_def, case_eq_thms]); - -Theorem mk_imp_const_not_clash[simp] - `mk_imp_const () refs <> (Failure (Clash tm), refs')` - (rw [mk_imp_const_def, st_ex_bind_def, st_ex_return_def, case_eq_thms]); - -Theorem mk_imp_not_clash[simp] - `mk_imp (p,q) refs <> (Failure (Clash tm), refs')` - (rw [mk_imp_def, st_ex_bind_def, st_ex_return_def, case_eq_thms]); - -Theorem mk_select_ax_not_clash[simp] - `mk_select_ax () refs <> (Failure (Clash tm), refs')` - (rw [mk_select_ax_def, st_ex_bind_def, st_ex_return_def, case_eq_thms]); - -Theorem mk_ex_not_clash[simp] - `mk_ex ty refs <> (Failure (Clash tm), refs')` - (rw [mk_ex_def, st_ex_bind_def, st_ex_return_def, case_eq_thms]); - -Theorem mk_exists_not_clash[simp] - `mk_exists (v,p) refs <> (Failure (Clash tm), refs')` - (rw [mk_exists_def, st_ex_bind_def, st_ex_return_def, case_eq_thms]); - -Theorem mk_surj_not_clash[simp] - `mk_surj f a b refs <> (Failure (Clash tm), refs')` - (rw [mk_surj_def, st_ex_bind_def, st_ex_return_def, case_eq_thms]); - -Theorem mk_inj_not_clash[simp] - `mk_inj f a refs <> (Failure (Clash tm), refs')` - (rw [mk_inj_def, st_ex_bind_def, st_ex_return_def, case_eq_thms]); - -Theorem mk_false_not_clash[simp] - `mk_false () refs <> (Failure (Clash tm), refs')` - (rw [mk_false_def, st_ex_bind_def, st_ex_return_def, case_eq_thms]); - -Theorem mk_neg_const_not_clash[simp] - `mk_neg_const () refs <> (Failure (Clash tm), refs')` - (rw [mk_neg_const_def, st_ex_bind_def, st_ex_return_def, case_eq_thms]); - -Theorem mk_neg_not_clash[simp] - `mk_neg p refs <> (Failure (Clash tm), refs')` - (rw [mk_neg_def, st_ex_bind_def, st_ex_return_def, case_eq_thms]); - -Theorem mk_infinity_ax_not_clash[simp] - `mk_infinity_ax () refs <> (Failure (Clash tm), refs')` - (rw [mk_infinity_ax_def, st_ex_bind_def, st_ex_return_def, case_eq_thms]); - -Theorem init_reader_not_clash[simp] - `init_reader () refs <> (Failure (Clash tm), refs')` - (rw [init_reader_def, st_ex_bind_def, st_ex_return_def, case_eq_thms, - select_sym_def, ind_type_def]); +Theorem mk_true_not_clash[simp]: + mk_true () refs <> (Failure (Clash tm), refs') +Proof + rw [mk_true_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] +QED + +Theorem mk_univ_not_clash[simp]: + mk_univ ty refs <> (Failure (Clash tm), refs') +Proof + rw [mk_univ_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] +QED + +Theorem mk_forall_not_clash[simp]: + mk_forall (v,p) refs <> (Failure (Clash tm), refs') +Proof + rw [mk_forall_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] +QED + +Theorem mk_eta_ax_not_clash[simp]: + mk_eta_ax () refs <> (Failure (Clash tm), refs') +Proof + rw [mk_eta_ax_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] +QED + +Theorem mk_conj_const_not_clash[simp]: + mk_conj_const () refs <> (Failure (Clash tm), refs') +Proof + rw [mk_conj_const_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] +QED + +Theorem mk_conj_not_clash[simp]: + mk_conj (p,q) refs <> (Failure (Clash tm), refs') +Proof + rw [mk_conj_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] +QED + +Theorem mk_imp_const_not_clash[simp]: + mk_imp_const () refs <> (Failure (Clash tm), refs') +Proof + rw [mk_imp_const_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] +QED + +Theorem mk_imp_not_clash[simp]: + mk_imp (p,q) refs <> (Failure (Clash tm), refs') +Proof + rw [mk_imp_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] +QED + +Theorem mk_select_ax_not_clash[simp]: + mk_select_ax () refs <> (Failure (Clash tm), refs') +Proof + rw [mk_select_ax_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] +QED + +Theorem mk_ex_not_clash[simp]: + mk_ex ty refs <> (Failure (Clash tm), refs') +Proof + rw [mk_ex_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] +QED + +Theorem mk_exists_not_clash[simp]: + mk_exists (v,p) refs <> (Failure (Clash tm), refs') +Proof + rw [mk_exists_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] +QED + +Theorem mk_surj_not_clash[simp]: + mk_surj f a b refs <> (Failure (Clash tm), refs') +Proof + rw [mk_surj_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] +QED + +Theorem mk_inj_not_clash[simp]: + mk_inj f a refs <> (Failure (Clash tm), refs') +Proof + rw [mk_inj_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] +QED + +Theorem mk_false_not_clash[simp]: + mk_false () refs <> (Failure (Clash tm), refs') +Proof + rw [mk_false_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] +QED + +Theorem mk_neg_const_not_clash[simp]: + mk_neg_const () refs <> (Failure (Clash tm), refs') +Proof + rw [mk_neg_const_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] +QED + +Theorem mk_neg_not_clash[simp]: + mk_neg p refs <> (Failure (Clash tm), refs') +Proof + rw [mk_neg_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] +QED + +Theorem mk_infinity_ax_not_clash[simp]: + mk_infinity_ax () refs <> (Failure (Clash tm), refs') +Proof + rw [mk_infinity_ax_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] +QED + +Theorem init_reader_not_clash[simp]: + init_reader () refs <> (Failure (Clash tm), refs') +Proof + rw [init_reader_def, st_ex_bind_def, st_ex_return_def, case_eq_thms, + select_sym_def, ind_type_def] +QED (* ------------------------------------------------------------------------- *) (* Refinement invariants *) @@ -239,15 +323,17 @@ val OBJ_def = tDefine "OBJ" ` \\ Induct \\ rw [object_size_def] \\ res_tac \\ fs []); -Theorem OBJ_APPEND_EXTEND - `!defs obj d. +Theorem OBJ_APPEND_EXTEND: + !defs obj d. STATE (ds ++ defs) refs /\ (!th. THM defs th ==> THM (ds ++ defs) th) /\ OBJ defs obj ==> - OBJ (ds++defs) obj` - (recInduct (theorem"OBJ_ind") \\ rw [] \\ fs [OBJ_def, EVERY_MEM] - \\ metis_tac [TERM_APPEND_EXTEND, TYPE_APPEND_EXTEND]); + OBJ (ds++defs) obj +Proof + recInduct (theorem"OBJ_ind") \\ rw [] \\ fs [OBJ_def, EVERY_MEM] + \\ metis_tac [TERM_APPEND_EXTEND, TYPE_APPEND_EXTEND] +QED val READER_STATE_def = Define ` READER_STATE defs st <=> @@ -255,20 +341,24 @@ val READER_STATE_def = Define ` EVERY (OBJ defs) st.stack /\ (!n obj. lookup (Num n) st.dict = SOME obj ==> OBJ defs obj)` -Theorem READER_STATE_EXTEND - `READER_STATE defs st /\ +Theorem READER_STATE_EXTEND: + READER_STATE defs st /\ THM defs th ==> - READER_STATE defs (st with thms := th::st.thms)` - (rw [READER_STATE_def]); + READER_STATE defs (st with thms := th::st.thms) +Proof + rw [READER_STATE_def] +QED -Theorem READER_STATE_APPEND_EXTEND - `STATE (ds++defs) refs /\ +Theorem READER_STATE_APPEND_EXTEND: + STATE (ds++defs) refs /\ READER_STATE defs st /\ (!th. THM defs th ==> THM (ds++defs) th) ==> - READER_STATE (ds++defs) st` - (rw [READER_STATE_def] \\ metis_tac [OBJ_APPEND_EXTEND, EVERY_MEM]); + READER_STATE (ds++defs) st +Proof + rw [READER_STATE_def] \\ metis_tac [OBJ_APPEND_EXTEND, EVERY_MEM] +QED val READER_STATE_CONS_EXTEND = save_thm ("READER_STATE_CONS_EXTEND", READER_STATE_APPEND_EXTEND @@ -279,79 +369,92 @@ val READER_STATE_CONS_EXTEND = save_thm ("READER_STATE_CONS_EXTEND", (* Kernel function support theorems (TODO: move) *) (* ------------------------------------------------------------------------- *) -Theorem first_EVERY - `!Q xs x. EVERY P xs /\ first Q xs = SOME x ==> P x` - (recInduct first_ind \\ rw [] \\ pop_assum mp_tac +Theorem first_EVERY: + !Q xs x. EVERY P xs /\ first Q xs = SOME x ==> P x +Proof + recInduct first_ind \\ rw [] \\ pop_assum mp_tac \\ once_rewrite_tac [first_def] - \\ rw [case_eq_thms, PULL_EXISTS, bool_case_eq] \\ fs []); + \\ rw [case_eq_thms, PULL_EXISTS, bool_case_eq] \\ fs [] +QED (* TODO move to holKernelProof *) -Theorem axioms_thm - `STATE defs refs /\ +Theorem axioms_thm: + STATE defs refs /\ axioms () refs = (res, refs') ==> refs = refs' /\ - !axs. res = Success axs ==> EVERY (THM defs) axs` - (rw [axioms_def, get_the_axioms_def, STATE_def] + !axs. res = Success axs ==> EVERY (THM defs) axs +Proof + rw [axioms_def, get_the_axioms_def, STATE_def] \\ fs [EVERY_MAP, lift_tm_def, CONTEXT_def, EVERY_MEM, MEM_MAP] \\ rw [] \\ fs [THM_def] \\ match_mp_tac (last (CONJUNCTS proves_rules)) \\ conj_tac >- metis_tac [extends_theory_ok, init_theory_ok] \\ EVAL_TAC \\ fs [MEM_FLAT, MEM_MAP, PULL_EXISTS] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem find_axiom_thm - `STATE defs refs /\ +Theorem find_axiom_thm: + STATE defs refs /\ EVERY (TERM defs) ls /\ TERM defs tm /\ find_axiom (ls, tm) refs = (res, refs') ==> - refs = refs' /\ !thm. res = Success thm ==> THM defs thm` - (rw [find_axiom_def, st_ex_bind_def, st_ex_return_def, raise_Fail_def, + refs = refs' /\ !thm. res = Success thm ==> THM defs thm +Proof + rw [find_axiom_def, st_ex_bind_def, st_ex_return_def, raise_Fail_def, case_eq_thms, PULL_EXISTS] \\ TRY PURE_FULL_CASE_TAC \\ fs [] \\ rw [] - \\ metis_tac [axioms_thm, first_EVERY]); + \\ metis_tac [axioms_thm, first_EVERY] +QED -Theorem assoc_thm - `!s l refs res refs'. +Theorem assoc_thm: + !s l refs res refs'. assoc s l refs = (res, refs') ==> refs = refs' /\ - !t. res = Success t ==> ALOOKUP l s = SOME t` - (Induct_on `l` \\ once_rewrite_tac [assoc_def] + !t. res = Success t ==> ALOOKUP l s = SOME t +Proof + Induct_on `l` \\ once_rewrite_tac [assoc_def] \\ fs [raise_Fail_def, st_ex_return_def] \\ Cases \\ fs [] \\ rw [] \\ fs [] - \\ res_tac \\ fs []); + \\ res_tac \\ fs [] +QED (* TODO holKernelProof - move, or already exists? *) -Theorem assoc_state_thm - `!s l refs res refs'. assoc s l refs = (res, refs') ==> refs = refs'` - (Induct_on `l` \\ rw [] \\ pop_assum mp_tac +Theorem assoc_state_thm: + !s l refs res refs'. assoc s l refs = (res, refs') ==> refs = refs' +Proof + Induct_on `l` \\ rw [] \\ pop_assum mp_tac \\ rw [Once assoc_def, raise_Fail_def, st_ex_return_def, case_eq_thms, pair_CASE_def] - \\ res_tac); + \\ res_tac +QED (* TODO holKernelProof - move, or already exists? *) -Theorem assoc_ty_thm - `!s l refs res refs'. +Theorem assoc_ty_thm: + !s l refs res refs'. EVERY (TYPE defs o SND) l /\ assoc s l refs = (res, refs') ==> - !ty. res = Success ty ==> TYPE defs ty` - (Induct_on `l` \\ rw [] \\ pop_assum mp_tac + !ty. res = Success ty ==> TYPE defs ty +Proof + Induct_on `l` \\ rw [] \\ pop_assum mp_tac \\ rw [Once assoc_def, raise_Fail_def, st_ex_return_def, pair_CASE_def] - \\ res_tac \\ fs []); + \\ res_tac \\ fs [] +QED (* TODO holKernelProof - move, or already exists? *) -Theorem type_of_thm - `!tm refs res refs'. +Theorem type_of_thm: + !tm refs res refs'. STATE defs refs /\ TERM defs tm /\ type_of tm refs = (res, refs') ==> refs = refs' /\ - !ty. res = Success ty ==> TYPE defs ty /\ welltyped tm` - (Induct \\ rw [] + !ty. res = Success ty ==> TYPE defs ty /\ welltyped tm +Proof + Induct \\ rw [] \\ pop_assum mp_tac \\ rw [Once type_of_def, st_ex_return_def, st_ex_bind_def, raise_Fail_def, dest_type_def] @@ -362,239 +465,292 @@ Theorem type_of_thm \\ rpt (PURE_FULL_CASE_TAC \\ fs []) \\ rw [] \\ fs [] \\ rw [] \\ fs [] \\ res_tac \\ fs [] \\ rw [] \\ imp_res_tac assoc_thm - \\ rfs [term_ok_def, type_ok_def, STATE_def, CONTEXT_def] \\ fs []) + \\ rfs [term_ok_def, type_ok_def, STATE_def, CONTEXT_def] \\ fs [] +QED (* TODO holKernelProof - move, or already exists? *) -Theorem mk_comb_thm - `STATE defs refs /\ +Theorem mk_comb_thm: + STATE defs refs /\ TERM defs f /\ TERM defs a /\ mk_comb (f, a) refs = (res, refs') ==> - refs = refs' /\ !fa. res = Success fa ==> TERM defs fa` - (rw [mk_comb_def, st_ex_return_def, st_ex_bind_def, raise_Fail_def] + refs = refs' /\ !fa. res = Success fa ==> TERM defs fa +Proof + rw [mk_comb_def, st_ex_return_def, st_ex_bind_def, raise_Fail_def] \\ rpt (PURE_FULL_CASE_TAC \\ fs []) \\ rw [] \\ fs [] \\ imp_res_tac type_of_thm \\ fs [] \\ rfs [] \\ imp_res_tac type_of_has_type - \\ fs [TERM_def, TYPE_def, type_ok_def, term_ok_def]); + \\ fs [TERM_def, TYPE_def, type_ok_def, term_ok_def] +QED (* TODO holKernelProof - move, or already exists? *) -Theorem get_const_type_thm - `STATE defs refs /\ +Theorem get_const_type_thm: + STATE defs refs /\ get_const_type n refs = (res, refs') ==> - refs = refs' /\ !ty. res = Success ty ==> TYPE defs ty` - (rw [get_const_type_def, st_ex_bind_def, st_ex_return_def, + refs = refs' /\ !ty. res = Success ty ==> TYPE defs ty +Proof + rw [get_const_type_def, st_ex_bind_def, st_ex_return_def, get_the_term_constants_def] \\ imp_res_tac the_term_constants_TYPE \\ fs [ELIM_UNCURRY, GSYM o_DEF] - \\ metis_tac [assoc_state_thm, assoc_ty_thm]); + \\ metis_tac [assoc_state_thm, assoc_ty_thm] +QED (* TODO holKernelProof - move, or already exists? *) -Theorem tymatch_thm - `!tys1 tys2 sids. +Theorem tymatch_thm: + !tys1 tys2 sids. EVERY (TYPE defs) tys1 /\ EVERY (TYPE defs) tys2 /\ EVERY (\(t1,t2). TYPE defs t1 /\ TYPE defs t2) (FST sids) /\ tymatch tys1 tys2 sids = SOME (tys, _) ==> - EVERY (\(t1,t2). TYPE defs t1 /\ TYPE defs t2) tys` - (recInduct holSyntaxExtraTheory.tymatch_ind \\ rw [] + EVERY (\(t1,t2). TYPE defs t1 /\ TYPE defs t2) tys +Proof + recInduct holSyntaxExtraTheory.tymatch_ind \\ rw [] \\ pop_assum mp_tac \\ rw [Once tymatch_def] \\ fs [] \\ rpt (pairarg_tac \\ fs []) \\ fs [case_eq_thms, bool_case_eq] \\ rw [] - \\ metis_tac [TYPE_def, type_ok_def]); + \\ metis_tac [TYPE_def, type_ok_def] +QED (* TODO holKernelProof - move, or already exists? *) -Theorem match_type_thm - `TYPE defs ty1 /\ +Theorem match_type_thm: + TYPE defs ty1 /\ TYPE defs ty2 /\ match_type ty1 ty2 = SOME tys ==> - EVERY (\(t1,t2). TYPE defs t1 /\ TYPE defs t2) tys` - (rw [holSyntaxExtraTheory.match_type_def] + EVERY (\(t1,t2). TYPE defs t1 /\ TYPE defs t2) tys +Proof + rw [holSyntaxExtraTheory.match_type_def] \\ PairCases_on `z` \\ fs [] - \\ imp_res_tac tymatch_thm \\ rfs []); + \\ imp_res_tac tymatch_thm \\ rfs [] +QED (* TODO proven elsewhere *) -Theorem TERM_Comb - `TERM defs (Comb a b) ==> TERM defs a /\ TERM defs b` - (rw [TERM_def, term_ok_def]); - -Theorem TERM_Abs - `TERM defs (Abs v e) ==> TERM defs v /\ TERM defs e` - (rw [TERM_def] \\ fs [term_ok_def]); +Theorem TERM_Comb: + TERM defs (Comb a b) ==> TERM defs a /\ TERM defs b +Proof + rw [TERM_def, term_ok_def] +QED + +Theorem TERM_Abs: + TERM defs (Abs v e) ==> TERM defs v /\ TERM defs e +Proof + rw [TERM_def] \\ fs [term_ok_def] +QED (* ------------------------------------------------------------------------- *) (* Reader operations preserve invariants *) (* ------------------------------------------------------------------------- *) -Theorem next_line_thm - `READER_STATE defs s ==> READER_STATE defs (next_line s)` - (rw [READER_STATE_def, next_line_def]); +Theorem next_line_thm: + READER_STATE defs s ==> READER_STATE defs (next_line s) +Proof + rw [READER_STATE_def, next_line_def] +QED -Theorem getNum_thm - `getNum obj refs = (res, refs') ==> refs = refs'` - (Cases_on `obj` \\ rw [getNum_def, raise_Fail_def, st_ex_return_def] - \\ fs []); +Theorem getNum_thm: + getNum obj refs = (res, refs') ==> refs = refs' +Proof + Cases_on `obj` \\ rw [getNum_def, raise_Fail_def, st_ex_return_def] + \\ fs [] +QED -Theorem getName_thm - `getName obj refs = (res, refs') ==> refs = refs'` - (Cases_on `obj` \\ rw [getName_def, raise_Fail_def, st_ex_return_def] - \\ fs []); +Theorem getName_thm: + getName obj refs = (res, refs') ==> refs = refs' +Proof + Cases_on `obj` \\ rw [getName_def, raise_Fail_def, st_ex_return_def] + \\ fs [] +QED -Theorem getList_thm - `OBJ defs obj /\ +Theorem getList_thm: + OBJ defs obj /\ getList obj refs = (res, refs') ==> - refs = refs' /\ !ls. res = Success ls ==> EVERY (OBJ defs) ls` - (Cases_on `obj` \\ rw [getList_def, raise_Fail_def, st_ex_return_def] + refs = refs' /\ !ls. res = Success ls ==> EVERY (OBJ defs) ls +Proof + Cases_on `obj` \\ rw [getList_def, raise_Fail_def, st_ex_return_def] \\ fs [] - \\ metis_tac [OBJ_def]); + \\ metis_tac [OBJ_def] +QED -Theorem getTypeOp_thm - `getTypeOp obj refs = (res, refs') ==> refs = refs'` - (Cases_on `obj` \\ rw [getTypeOp_def, raise_Fail_def, st_ex_return_def] - \\ fs []); +Theorem getTypeOp_thm: + getTypeOp obj refs = (res, refs') ==> refs = refs' +Proof + Cases_on `obj` \\ rw [getTypeOp_def, raise_Fail_def, st_ex_return_def] + \\ fs [] +QED -Theorem getType_thm - `OBJ defs obj /\ +Theorem getType_thm: + OBJ defs obj /\ getType obj refs = (res, refs') ==> - refs = refs' /\ !ty. res = Success ty ==> TYPE defs ty` - (Cases_on `obj` \\ rw [getType_def, raise_Fail_def, st_ex_return_def] - \\ fs [OBJ_def]); - -Theorem map_getType_thm - `!xs refs res refs'. + refs = refs' /\ !ty. res = Success ty ==> TYPE defs ty +Proof + Cases_on `obj` \\ rw [getType_def, raise_Fail_def, st_ex_return_def] + \\ fs [OBJ_def] +QED + +Theorem map_getType_thm: + !xs refs res refs'. EVERY (OBJ defs) xs /\ map getType xs refs = (res, refs') ==> - refs = refs' /\ !tys. res = Success tys ==> EVERY (TYPE defs) tys` - (Induct \\ rw [Once map_def, st_ex_return_def, st_ex_bind_def] \\ fs [] + refs = refs' /\ !tys. res = Success tys ==> EVERY (TYPE defs) tys +Proof + Induct \\ rw [Once map_def, st_ex_return_def, st_ex_bind_def] \\ fs [] \\ fs [case_eq_thms] \\ rw [] \\ imp_res_tac getType_thm \\ fs [] - \\ res_tac \\ fs []); + \\ res_tac \\ fs [] +QED -Theorem getConst_thm - `getConst obj refs = (res, refs') ==> refs = refs'` - (Cases_on `obj` \\ rw [getConst_def, raise_Fail_def, st_ex_return_def] - \\ fs []); +Theorem getConst_thm: + getConst obj refs = (res, refs') ==> refs = refs' +Proof + Cases_on `obj` \\ rw [getConst_def, raise_Fail_def, st_ex_return_def] + \\ fs [] +QED -Theorem getVar_thm - `OBJ defs obj /\ +Theorem getVar_thm: + OBJ defs obj /\ getVar obj refs = (res, refs') ==> refs = refs' /\ - !n ty. res = Success (n, ty) ==> TERM defs (Var n ty) /\ TYPE defs ty` - (Cases_on `obj` \\ rw [getVar_def, raise_Fail_def, st_ex_return_def] - \\ fs [OBJ_def]); + !n ty. res = Success (n, ty) ==> TERM defs (Var n ty) /\ TYPE defs ty +Proof + Cases_on `obj` \\ rw [getVar_def, raise_Fail_def, st_ex_return_def] + \\ fs [OBJ_def] +QED -Theorem getTerm_thm - `OBJ defs obj /\ +Theorem getTerm_thm: + OBJ defs obj /\ getTerm obj refs = (res, refs') ==> - refs = refs' /\ !tm. res = Success tm ==> TERM defs tm` - (Cases_on `obj` \\ rw [getTerm_def, raise_Fail_def, st_ex_return_def] \\ fs [] - \\ fs [OBJ_def]); - -Theorem map_getTerm_thm - `!xs refs res refs'. + refs = refs' /\ !tm. res = Success tm ==> TERM defs tm +Proof + Cases_on `obj` \\ rw [getTerm_def, raise_Fail_def, st_ex_return_def] \\ fs [] + \\ fs [OBJ_def] +QED + +Theorem map_getTerm_thm: + !xs refs res refs'. EVERY (OBJ defs) xs /\ map getTerm xs refs = (res, refs') ==> - refs = refs' /\ !tms. res = Success tms ==> EVERY (TERM defs) tms` - (Induct \\ rw [Once map_def, st_ex_return_def, st_ex_bind_def, case_eq_thms] + refs = refs' /\ !tms. res = Success tms ==> EVERY (TERM defs) tms +Proof + Induct \\ rw [Once map_def, st_ex_return_def, st_ex_bind_def, case_eq_thms] \\ fs [] \\ imp_res_tac getTerm_thm \\ fs [] - \\ res_tac \\ fs []); + \\ res_tac \\ fs [] +QED -Theorem getThm_thm - `OBJ defs obj /\ +Theorem getThm_thm: + OBJ defs obj /\ getThm obj refs = (res, refs') ==> - refs = refs' /\ !thm. res = Success thm ==> THM defs thm` - (Cases_on `obj` \\ rw [getThm_def, raise_Fail_def, st_ex_return_def] - \\ fs [OBJ_def]); + refs = refs' /\ !thm. res = Success thm ==> THM defs thm +Proof + Cases_on `obj` \\ rw [getThm_def, raise_Fail_def, st_ex_return_def] + \\ fs [OBJ_def] +QED -Theorem pop_thm - `READER_STATE defs st /\ +Theorem pop_thm: + READER_STATE defs st /\ pop st refs = (res, refs') ==> refs = refs' /\ - !a st'. res = Success (a, st') ==> OBJ defs a /\ READER_STATE defs st'` - (rw [pop_def, raise_Fail_def, st_ex_return_def] + !a st'. res = Success (a, st') ==> OBJ defs a /\ READER_STATE defs st' +Proof + rw [pop_def, raise_Fail_def, st_ex_return_def] \\ PURE_FULL_CASE_TAC \\ fs [] \\ rw [] \\ fs [READER_STATE_def, state_component_equality] - \\ rw [] \\ res_tac); + \\ rw [] \\ res_tac +QED -Theorem peek_thm - `READER_STATE defs st /\ +Theorem peek_thm: + READER_STATE defs st /\ peek st refs = (res, refs') ==> - refs = refs' /\ !obj. res = Success obj ==> OBJ defs obj` - (rw [peek_def, raise_Fail_def, st_ex_return_def] - \\ PURE_FULL_CASE_TAC \\ fs [READER_STATE_def]); + refs = refs' /\ !obj. res = Success obj ==> OBJ defs obj +Proof + rw [peek_def, raise_Fail_def, st_ex_return_def] + \\ PURE_FULL_CASE_TAC \\ fs [READER_STATE_def] +QED -Theorem push_thm - `READER_STATE defs st /\ +Theorem push_thm: + READER_STATE defs st /\ OBJ defs obj ==> - READER_STATE defs (push obj st)` - (rw [push_def, READER_STATE_def]); + READER_STATE defs (push obj st) +Proof + rw [push_def, READER_STATE_def] +QED -Theorem push_push_thm - `READER_STATE defs st /\ +Theorem push_push_thm: + READER_STATE defs st /\ OBJ defs obj1 /\ OBJ defs obj2 ==> - READER_STATE defs (push obj1 (push obj2 st))` - (rw [push_def, READER_STATE_def]); + READER_STATE defs (push obj1 (push obj2 st)) +Proof + rw [push_def, READER_STATE_def] +QED -Theorem insert_dict_thm - `READER_STATE defs st /\ +Theorem insert_dict_thm: + READER_STATE defs st /\ OBJ defs obj ==> - READER_STATE defs (insert_dict (Num n) obj st)` - (rw [insert_dict_def, READER_STATE_def, lookup_insert] + READER_STATE defs (insert_dict (Num n) obj st) +Proof + rw [insert_dict_def, READER_STATE_def, lookup_insert] \\ PURE_FULL_CASE_TAC \\ fs [] - \\ res_tac); + \\ res_tac +QED -Theorem delete_dict_thm - `READER_STATE defs st +Theorem delete_dict_thm: + READER_STATE defs st ==> - READER_STATE defs (delete_dict (Num n) st)` - (rw [delete_dict_def, READER_STATE_def, lookup_delete] - \\ res_tac); + READER_STATE defs (delete_dict (Num n) st) +Proof + rw [delete_dict_def, READER_STATE_def, lookup_delete] + \\ res_tac +QED -Theorem getPair_thm - `OBJ defs obj /\ +Theorem getPair_thm: + OBJ defs obj /\ getPair obj refs = (res, refs') ==> - refs = refs' /\ !a b. res = Success (a, b) ==> OBJ defs a /\ OBJ defs b` - (Cases_on `obj` \\ EVAL_TAC \\ rw [] \\ pop_assum mp_tac + refs = refs' /\ !a b. res = Success (a, b) ==> OBJ defs a /\ OBJ defs b +Proof + Cases_on `obj` \\ EVAL_TAC \\ rw [] \\ pop_assum mp_tac \\ Cases_on `l` \\ EVAL_TAC \\ rw [] \\ pop_assum mp_tac \\ Cases_on `t` \\ EVAL_TAC \\ rw [] \\ pop_assum mp_tac - \\ Cases_on `t'` \\ EVAL_TAC \\ rw [] \\ fs []); + \\ Cases_on `t'` \\ EVAL_TAC \\ rw [] \\ fs [] +QED -Theorem getTys_thm - `STATE defs refs /\ +Theorem getTys_thm: + STATE defs refs /\ OBJ defs obj /\ getTys obj refs = (res, refs') ==> refs = refs' /\ !t ty. res = Success (t, ty) ==> - TYPE defs t /\ TYPE defs ty` - (Cases_on `obj` + TYPE defs t /\ TYPE defs ty +Proof + Cases_on `obj` \\ rw [getTys_def, st_ex_bind_def, st_ex_return_def, raise_Fail_def, UNCURRY, case_eq_thms, getPair_def] \\ map_every imp_res_tac [getPair_thm, getType_thm, getName_thm, mk_vartype_thm] \\ fs [] \\ rw [] - \\ metis_tac [mk_vartype_thm, STATE_def, SND, FST, PAIR]); + \\ metis_tac [mk_vartype_thm, STATE_def, SND, FST, PAIR] +QED -Theorem map_getTys_thm - `!xs refs res refs'. +Theorem map_getTys_thm: + !xs refs res refs'. STATE defs refs /\ EVERY (OBJ defs) xs /\ map getTys xs refs = (res, refs') @@ -603,30 +759,34 @@ Theorem map_getTys_thm !tys. res = Success tys ==> - EVERY (\(ty1,ty2). TYPE defs ty1 /\ TYPE defs ty2) tys` - (Induct \\ rw [] \\ pop_assum mp_tac + EVERY (\(ty1,ty2). TYPE defs ty1 /\ TYPE defs ty2) tys +Proof + Induct \\ rw [] \\ pop_assum mp_tac \\ rw [Once map_def, st_ex_bind_def, st_ex_return_def] \\ fs [] \\ fs [case_eq_thms] \\ rw [] \\ imp_res_tac getTys_thm \\ fs [] \\ rename1 `xx = _ ==> _` \\ PairCases_on `xx` \\ fs [] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem getTms_thm - `STATE defs refs /\ +Theorem getTms_thm: + STATE defs refs /\ OBJ defs obj /\ getTms obj refs = (res, refs') ==> refs = refs' /\ - !tm var. res = Success (tm, var) ==> TERM defs tm /\ TERM defs var` - (Cases_on `obj` + !tm var. res = Success (tm, var) ==> TERM defs tm /\ TERM defs var +Proof + Cases_on `obj` \\ fs [getTms_def, st_ex_bind_def, st_ex_return_def, raise_Fail_def, UNCURRY, case_eq_thms, PULL_EXISTS, getPair_def] \\ rw [] \\ map_every imp_res_tac [getPair_thm, getTerm_thm, getVar_thm, mk_var_thm] \\ fs [] - \\ metis_tac [FST, SND, PAIR]); + \\ metis_tac [FST, SND, PAIR] +QED -Theorem map_getTms_thm - `!xs refs res refs'. +Theorem map_getTms_thm: + !xs refs res refs'. STATE defs refs /\ EVERY (OBJ defs) xs /\ map getTms xs refs = (res, refs') @@ -635,58 +795,68 @@ Theorem map_getTms_thm !tmvs. res = Success tmvs ==> - EVERY (\(tm1,tm2). TERM defs tm1 /\ TERM defs tm2) tmvs` - (Induct \\ rw [] \\ pop_assum mp_tac + EVERY (\(tm1,tm2). TERM defs tm1 /\ TERM defs tm2) tmvs +Proof + Induct \\ rw [] \\ pop_assum mp_tac \\ rw [Once map_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] \\ fs [] \\ imp_res_tac getTms_thm \\ fs [ELIM_UNCURRY] - \\ metis_tac [FST, SND, PAIR, UNCURRY]); + \\ metis_tac [FST, SND, PAIR, UNCURRY] +QED -Theorem getNvs_thm - `STATE defs refs /\ +Theorem getNvs_thm: + STATE defs refs /\ OBJ defs obj /\ getNvs obj refs = (res, refs') ==> refs = refs' /\ - !tm1 tm2. res = Success (tm1, tm2) ==> TERM defs tm1 /\ TERM defs tm2` - (Cases_on `obj` + !tm1 tm2. res = Success (tm1, tm2) ==> TERM defs tm1 /\ TERM defs tm2 +Proof + Cases_on `obj` \\ rw [getNvs_def, st_ex_bind_def, st_ex_return_def, raise_Fail_def, UNCURRY, getPair_def, case_eq_thms] \\ map_every imp_res_tac [getPair_thm, getName_thm, getVar_thm, mk_var_thm] - \\ metis_tac [FST, SND, PAIR]); + \\ metis_tac [FST, SND, PAIR] +QED -Theorem map_getNvs_thm - `!xs refs res refs'. +Theorem map_getNvs_thm: + !xs refs res refs'. STATE defs refs /\ EVERY (OBJ defs) xs /\ map getNvs xs refs = (res, refs') ==> refs = refs' /\ !ts. res = Success ts ==> - EVERY (\(t1,t2). TERM defs t1 /\ TERM defs t2) ts` - (Induct + EVERY (\(t1,t2). TERM defs t1 /\ TERM defs t2) ts +Proof + Induct \\ rw [Once map_def, st_ex_return_def, st_ex_bind_def, case_eq_thms] \\ fs [] \\ imp_res_tac getNvs_thm \\ fs [ELIM_UNCURRY] - \\ metis_tac [FST, SND, PAIR]); + \\ metis_tac [FST, SND, PAIR] +QED -Theorem getCns_thm - `STATE defs refs /\ +Theorem getCns_thm: + STATE defs refs /\ TERM defs tm /\ getCns (tm, _) refs = (res, refs') ==> - refs = refs' /\ !a. res = Success a ==> OBJ defs a` - (rw [getCns_def, st_ex_bind_def, st_ex_return_def, UNCURRY, case_eq_thms] - \\ imp_res_tac dest_var_thm \\ fs [OBJ_def]); - -Theorem map_getCns_thm - `!xs refs res refs'. + refs = refs' /\ !a. res = Success a ==> OBJ defs a +Proof + rw [getCns_def, st_ex_bind_def, st_ex_return_def, UNCURRY, case_eq_thms] + \\ imp_res_tac dest_var_thm \\ fs [OBJ_def] +QED + +Theorem map_getCns_thm: + !xs refs res refs'. STATE defs refs /\ EVERY (TERM defs o FST) xs /\ map getCns xs refs = (res, refs') ==> - refs = refs' /\ !xs. res = Success xs ==> EVERY (OBJ defs) xs` - (Induct \\ rw [Once map_def, st_ex_return_def, st_ex_bind_def, case_eq_thms] + refs = refs' /\ !xs. res = Success xs ==> EVERY (OBJ defs) xs +Proof + Induct \\ rw [Once map_def, st_ex_return_def, st_ex_bind_def, case_eq_thms] \\ imp_res_tac getCns_thm \\ fs [ELIM_UNCURRY] - \\ metis_tac [FST, SND, PAIR]); + \\ metis_tac [FST, SND, PAIR] +QED (* imp_res_tac is not useful when the monadic functions are too deep *) fun drule_or_nil thm = @@ -694,14 +864,15 @@ fun drule_or_nil thm = (qexists_tac `[]` \\ fs [] \\ metis_tac []) (* TODO clean *) -Theorem BETA_CONV_thm - `STATE defs refs /\ +Theorem BETA_CONV_thm: + STATE defs refs /\ TERM defs tm /\ BETA_CONV tm refs = (res, refs') ==> refs = refs' /\ - !thm. res = Success thm ==> THM defs thm` - (Cases_on `tm` + !thm. res = Success thm ==> THM defs thm +Proof + Cases_on `tm` \\ rw [BETA_CONV_def, handle_Fail_def, raise_Fail_def, st_ex_bind_def, st_ex_return_def, case_eq_thms, UNCURRY, dest_comb_def, dest_abs_def] \\ every_case_tac \\ fs [] \\ rw [] @@ -717,21 +888,23 @@ Theorem BETA_CONV_thm (CONV_RULE (RESORT_FORALL_CONV rev))) \\ fs [] \\ rw [] \\ drule_or_nil BETA_thm \\ `EVERY (\(t1,t2). TERM defs t1 /\ TERM defs t2) [(t0,b)]` by fs [] - \\ drule_or_nil INST_thm); + \\ drule_or_nil INST_thm +QED (* ------------------------------------------------------------------------- *) (* Reader preserves invariants *) (* ------------------------------------------------------------------------- *) -Theorem readLine_thm - `STATE defs refs /\ +Theorem readLine_thm: + STATE defs refs /\ READER_STATE defs st /\ readLine line st refs = (res, refs') ==> ?ds. STATE (ds ++ defs) refs' /\ - !st'. res = Success st' ==> READER_STATE (ds ++ defs) st'` - (fs [readLine_def, st_ex_bind_def, st_ex_return_def, raise_Fail_def] + !st'. res = Success st' ==> READER_STATE (ds ++ defs) st' +Proof + fs [readLine_def, st_ex_bind_def, st_ex_return_def, raise_Fail_def] \\ IF_CASES_TAC \\ fs [] >- (* version *) (fs [case_eq_thms] \\ rw [] @@ -1087,18 +1260,20 @@ Theorem readLine_thm (* digits *) \\ every_case_tac \\ fs [] \\ rw [] \\ fs [] \\ qexists_tac `[]` \\ fs [] \\ rw [] - \\ irule push_thm \\ fs [OBJ_def]); + \\ irule push_thm \\ fs [OBJ_def] +QED -Theorem readLines_thm - `!lines st res refs refs' defs. +Theorem readLines_thm: + !lines st res refs refs' defs. STATE defs refs /\ READER_STATE defs st /\ readLines lines st refs = (res, refs') ==> ?ds. STATE (ds ++ defs) refs' /\ - !st' n. res = Success (st', n) ==> READER_STATE (ds ++ defs) st'` - (recInduct readLines_ind \\ rw [] \\ pop_assum mp_tac + !st' n. res = Success (st', n) ==> READER_STATE (ds ++ defs) st' +Proof + recInduct readLines_ind \\ rw [] \\ pop_assum mp_tac \\ once_rewrite_tac [readLines_def] \\ fs [st_ex_return_def, st_ex_bind_def] \\ CASE_TAC \\ fs [] >- (rw [] \\ qexists_tac `[]` \\ fs []) @@ -1110,47 +1285,53 @@ Theorem readLines_thm >- (fs [next_line_def, READER_STATE_def] \\ metis_tac []) \\ imp_res_tac next_line_thm \\ disch_then drule \\ rw [] - \\ asm_exists_tac \\ fs []); + \\ asm_exists_tac \\ fs [] +QED (* ------------------------------------------------------------------------- *) (* Axiom cooking *) (* ------------------------------------------------------------------------- *) -Theorem STATE_lemma - `STATE defs refs +Theorem STATE_lemma: + STATE defs refs ==> (!a b. TYPE defs a /\ TYPE defs b ==> TYPE defs (Fun a b)) /\ - TYPE defs Bool` - (simp [STATE_def, CONTEXT_def] + TYPE defs Bool +Proof + simp [STATE_def, CONTEXT_def] \\ strip_tac \\ sg `theory_ok (thyof refs.the_context)` >- metis_tac [init_theory_ok, extends_theory_ok] \\ fs [theory_ok_def, is_std_sig_def] - \\ rw [TYPE_def, type_ok_def]); + \\ rw [TYPE_def, type_ok_def] +QED -Theorem mk_true_thm - `STATE defs refs /\ +Theorem mk_true_thm: + STATE defs refs /\ mk_true () refs = (res, refs') ==> refs = refs' /\ - !tm. res = Success tm ==> TERM defs tm` - (rw [mk_true_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] + !tm. res = Success tm ==> TERM defs tm +Proof + rw [mk_true_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] \\ qmatch_asmsub_abbrev_tac `mk_abs (v,_)` \\ drule STATE_lemma \\ strip_tac \\ `TERM defs v` by fs [TERM_def, Abbr`v`, term_ok_def, mk_var_def, TYPE_def] \\ drule (GEN_ALL mk_abs_thm) \\ rpt (disch_then drule) \\ rw [] \\ drule (GEN_ALL mk_eq_thm) - \\ rpt (disch_then drule) \\ rw []); + \\ rpt (disch_then drule) \\ rw [] +QED -Theorem mk_univ_thm - `STATE defs refs /\ +Theorem mk_univ_thm: + STATE defs refs /\ TYPE defs ty /\ mk_univ ty refs = (res, refs') ==> refs = refs' /\ - !tm. res = Success tm ==> TERM defs tm` - (rw [mk_univ_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] + !tm. res = Success tm ==> TERM defs tm +Proof + rw [mk_univ_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] \\ drule STATE_lemma \\ strip_tac \\ first_x_assum (qspecl_then [`ty`, `Bool`] assume_tac) \\ rfs [] \\ drule (GEN_ALL mk_true_thm) @@ -1168,17 +1349,19 @@ Theorem mk_univ_thm \\ qpat_x_assum `TERM defs p` assume_tac \\ drule (GEN_ALL mk_abs_thm) \\ qpat_x_assum `TERM defs (Comb _ _)` assume_tac - \\ rpt (disch_then drule) \\ rw []); + \\ rpt (disch_then drule) \\ rw [] +QED -Theorem mk_forall_thm - `STATE defs refs /\ +Theorem mk_forall_thm: + STATE defs refs /\ TERM defs t2 /\ TERM defs t1 /\ mk_forall (t1, t2) refs = (res, refs') ==> refs = refs' /\ - !tm. res = Success tm ==> TERM defs tm` - (rw [mk_forall_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] + !tm. res = Success tm ==> TERM defs tm +Proof + rw [mk_forall_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] \\ drule (GEN_ALL type_of_thm) \\ rpt (disch_then drule) \\ rw [] \\ drule (GEN_ALL mk_univ_thm) @@ -1191,15 +1374,17 @@ Theorem mk_forall_thm \\ drule (GEN_ALL mk_comb_thm) \\ disch_then drule \\ qpat_x_assum `TERM defs (Abs _ _)` assume_tac - \\ rpt (disch_then drule) \\ rw []); + \\ rpt (disch_then drule) \\ rw [] +QED -Theorem mk_eta_ax_thm - `STATE defs refs /\ +Theorem mk_eta_ax_thm: + STATE defs refs /\ mk_eta_ax () refs = (res, refs') ==> refs = refs' /\ - !tm. res = Success tm ==> TERM defs tm` - (rw [mk_eta_ax_def, st_ex_bind_def, case_eq_thms, st_ex_return_def, mk_var_def] + !tm. res = Success tm ==> TERM defs tm +Proof + rw [mk_eta_ax_def, st_ex_bind_def, case_eq_thms, st_ex_return_def, mk_var_def] \\ qmatch_asmsub_abbrev_tac `mk_comb (t1, t2)` \\ drule STATE_lemma \\ strip_tac \\ qabbrev_tac `A = Tyvar (strlit"A")` @@ -1218,15 +1403,17 @@ Theorem mk_eta_ax_thm \\ drule (GEN_ALL mk_eq_thm) \\ qpat_x_assum `TERM defs t1` assume_tac \\ rpt (disch_then drule) \\ rw [] - \\ metis_tac [mk_forall_thm]); + \\ metis_tac [mk_forall_thm] +QED -Theorem mk_conj_const_thm - `STATE defs refs /\ +Theorem mk_conj_const_thm: + STATE defs refs /\ mk_conj_const () refs = (res, refs') ==> refs = refs' /\ - !tm. res = Success tm ==> TERM defs tm` - (rw [mk_conj_const_def, st_ex_bind_def, st_ex_return_def] + !tm. res = Success tm ==> TERM defs tm +Proof + rw [mk_conj_const_def, st_ex_bind_def, st_ex_return_def] \\ reverse (fs [case_eq_thms]) \\ drule STATE_lemma \\ strip_tac \\ first_assum (qspecl_then [`Bool`, `Bool`] assume_tac) @@ -1275,32 +1462,36 @@ Theorem mk_conj_const_thm \\ qpat_x_assum `TERM defs pv` assume_tac \\ drule (GEN_ALL mk_abs_thm) \\ qpat_x_assum `TERM defs (Abs _ _)` assume_tac - \\ rpt (disch_then drule) \\ rw []); + \\ rpt (disch_then drule) \\ rw [] +QED -Theorem mk_conj_thm - `STATE defs refs /\ +Theorem mk_conj_thm: + STATE defs refs /\ TERM defs t2 /\ TERM defs t1 /\ mk_conj (t1, t2) refs = (res, refs') ==> refs = refs' /\ - !tm. res = Success tm ==> TERM defs tm` - (rw [mk_conj_def, st_ex_bind_def, case_eq_thms] + !tm. res = Success tm ==> TERM defs tm +Proof + rw [mk_conj_def, st_ex_bind_def, case_eq_thms] \\ drule (GEN_ALL mk_conj_const_thm) \\ disch_then drule \\ rw [] \\ drule (GEN_ALL mk_comb_thm) \\ disch_then drule \\ qpat_x_assum `TERM defs c` kall_tac \\ rpt (disch_then drule) \\ rw [] - \\ metis_tac [mk_comb_thm]); + \\ metis_tac [mk_comb_thm] +QED -Theorem mk_imp_const_thm - `STATE defs refs /\ +Theorem mk_imp_const_thm: + STATE defs refs /\ mk_imp_const () refs = (res, refs') ==> refs = refs' /\ - !tm. res = Success tm ==> TERM defs tm` - (rw [mk_imp_const_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] + !tm. res = Success tm ==> TERM defs tm +Proof + rw [mk_imp_const_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] \\ drule STATE_lemma \\ strip_tac \\ qmatch_asmsub_abbrev_tac `mk_conj (pv, qv)` \\ `TERM defs qv /\ TERM defs pv` by @@ -1320,33 +1511,37 @@ Theorem mk_imp_const_thm \\ qpat_x_assum `TERM defs pv` assume_tac \\ drule (GEN_ALL mk_abs_thm) \\ qpat_x_assum `TERM defs (Abs _ _)` assume_tac - \\ rpt (disch_then drule) \\ rw []); + \\ rpt (disch_then drule) \\ rw [] +QED -Theorem mk_imp_thm - `STATE defs refs /\ +Theorem mk_imp_thm: + STATE defs refs /\ TERM defs t2 /\ TERM defs t1 /\ mk_imp (t1, t2) refs = (res, refs') ==> refs = refs' /\ - !tm. res = Success tm ==> TERM defs tm` - (rw [mk_imp_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] + !tm. res = Success tm ==> TERM defs tm +Proof + rw [mk_imp_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] \\ drule (GEN_ALL mk_imp_const_thm) \\ disch_then drule \\ rw [] \\ drule (GEN_ALL mk_comb_thm) \\ disch_then drule \\ qpat_x_assum `TERM defs imp` kall_tac \\ rpt (disch_then drule) \\ rw [] - \\ metis_tac [mk_comb_thm]); + \\ metis_tac [mk_comb_thm] +QED -Theorem mk_select_ax_thm - `STATE defs refs /\ +Theorem mk_select_ax_thm: + STATE defs refs /\ TERM defs select_const /\ mk_select_ax () refs = (res, refs') ==> refs = refs' /\ - !tm. res = Success tm ==> TERM defs tm` - (rw [mk_select_ax_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] + !tm. res = Success tm ==> TERM defs tm +Proof + rw [mk_select_ax_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] \\ qmatch_asmsub_abbrev_tac `mk_comb (pv, xv) refs` \\ drule STATE_lemma \\ strip_tac \\ qabbrev_tac `A = Tyvar (strlit"A")` @@ -1379,16 +1574,18 @@ Theorem mk_select_ax_thm \\ drule (GEN_ALL mk_forall_thm) \\ disch_then drule \\ qpat_x_assum `TERM defs pv` assume_tac - \\ rpt (disch_then drule) \\ rw []); + \\ rpt (disch_then drule) \\ rw [] +QED -Theorem mk_ex_thm - `STATE defs refs /\ +Theorem mk_ex_thm: + STATE defs refs /\ TYPE defs ty /\ mk_ex ty refs = (res, refs') ==> refs = refs' /\ - !tm. res = Success tm ==> TERM defs tm` - (rw [mk_ex_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] + !tm. res = Success tm ==> TERM defs tm +Proof + rw [mk_ex_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] \\ drule STATE_lemma \\ strip_tac \\ first_x_assum (qspecl_then [`ty`,`Bool`] assume_tac) \\ rfs [] \\ qmatch_asmsub_abbrev_tac `mk_comb (pv, xv) refs` @@ -1422,18 +1619,20 @@ Theorem mk_ex_thm \\ qpat_x_assum `TERM defs pv` assume_tac \\ drule (GEN_ALL mk_abs_thm) \\ qpat_x_assum `TERM defs all'` assume_tac - \\ rpt (disch_then drule) \\ rw []); + \\ rpt (disch_then drule) \\ rw [] +QED -Theorem mk_exists_thm - `STATE defs refs /\ +Theorem mk_exists_thm: + STATE defs refs /\ TERM defs t2 /\ TERM defs t1 /\ mk_exists (t1, t2) refs = (res, refs') ==> refs = refs' /\ - !tm. res = Success tm ==> TERM defs tm` - (rw [mk_exists_def, st_ex_bind_def, case_eq_thms] + !tm. res = Success tm ==> TERM defs tm +Proof + rw [mk_exists_def, st_ex_bind_def, case_eq_thms] \\ drule (GEN_ALL type_of_thm) \\ rpt (disch_then drule) \\ rw [] \\ drule (GEN_ALL mk_ex_thm) @@ -1446,18 +1645,20 @@ Theorem mk_exists_thm \\ drule (GEN_ALL mk_comb_thm) \\ disch_then drule \\ qpat_x_assum `TERM defs (Abs _ _)` assume_tac - \\ rpt (disch_then drule) \\ rw []); + \\ rpt (disch_then drule) \\ rw [] +QED -Theorem mk_surj_thm - `STATE defs refs /\ +Theorem mk_surj_thm: + STATE defs refs /\ TYPE defs d /\ TYPE defs c /\ TERM defs f /\ mk_surj f d c refs = (res, refs') ==> refs = refs' /\ - !tm. res = Success tm ==> TERM defs tm` - (rw [mk_surj_def, st_ex_bind_def, case_eq_thms, st_ex_return_def] + !tm. res = Success tm ==> TERM defs tm +Proof + rw [mk_surj_def, st_ex_bind_def, case_eq_thms, st_ex_return_def] \\ drule (GEN_ALL type_of_thm) \\ rpt (disch_then drule) \\ rw [] \\ qmatch_asmsub_abbrev_tac `mk_comb (f, xv) refs` @@ -1479,17 +1680,19 @@ Theorem mk_surj_thm \\ drule (GEN_ALL mk_forall_thm) \\ disch_then drule \\ qpat_x_assum `TERM defs yv` assume_tac - \\ rpt (disch_then drule) \\ rw []); + \\ rpt (disch_then drule) \\ rw [] +QED -Theorem mk_inj_thm - `STATE defs refs /\ +Theorem mk_inj_thm: + STATE defs refs /\ TYPE defs d /\ TERM defs f /\ mk_inj f d refs = (res, refs') ==> refs = refs' /\ - !tm. res = Success tm ==> TERM defs tm` - (rw [mk_inj_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] + !tm. res = Success tm ==> TERM defs tm +Proof + rw [mk_inj_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] \\ drule (GEN_ALL type_of_thm) \\ rpt (disch_then drule) \\ rw [] \\ qmatch_asmsub_abbrev_tac `mk_comb (f, xv) refs` @@ -1524,28 +1727,32 @@ Theorem mk_inj_thm \\ drule (GEN_ALL mk_forall_thm) \\ disch_then drule \\ qpat_x_assum `TERM defs xv` assume_tac - \\ rpt (disch_then drule) \\ rw []); + \\ rpt (disch_then drule) \\ rw [] +QED -Theorem mk_false_thm - `STATE defs refs /\ +Theorem mk_false_thm: + STATE defs refs /\ mk_false () refs = (res, refs') ==> refs = refs' /\ - !tm. res = Success tm ==> TERM defs tm` - (rw [mk_false_def, st_ex_bind_def, st_ex_return_def] + !tm. res = Success tm ==> TERM defs tm +Proof + rw [mk_false_def, st_ex_bind_def, st_ex_return_def] \\ drule STATE_lemma \\ strip_tac \\ qmatch_asmsub_abbrev_tac `mk_forall (p,_)` \\ `TERM defs p` by fs [Abbr`p`, TERM_def, TYPE_def, term_ok_def, mk_var_def] \\ drule (GEN_ALL mk_forall_thm) - \\ rpt (disch_then drule) \\ rw []); + \\ rpt (disch_then drule) \\ rw [] +QED -Theorem mk_neg_const_thm - `STATE defs refs /\ +Theorem mk_neg_const_thm: + STATE defs refs /\ mk_neg_const () refs = (res, refs') ==> refs = refs' /\ - !tm. res = Success tm ==> TERM defs tm` - (rw [mk_neg_const_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] + !tm. res = Success tm ==> TERM defs tm +Proof + rw [mk_neg_const_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] \\ drule STATE_lemma \\ strip_tac \\ drule (GEN_ALL mk_false_thm) \\ disch_then drule \\ rw [] @@ -1555,26 +1762,30 @@ Theorem mk_neg_const_thm \\ `TERM defs pv` by fs [Abbr`pv`, TERM_def, TYPE_def, term_ok_def, mk_var_def] \\ rpt (disch_then drule) \\ rw [] - \\ metis_tac [mk_abs_thm]); + \\ metis_tac [mk_abs_thm] +QED -Theorem mk_neg_thm - `STATE defs refs /\ +Theorem mk_neg_thm: + STATE defs refs /\ TERM defs p /\ mk_neg p refs = (res, refs') ==> refs = refs' /\ - !tm. res = Success tm ==> TERM defs tm` - (rw [mk_neg_def, st_ex_bind_def, case_eq_thms] - \\ metis_tac [mk_neg_const_thm, mk_comb_thm]); - -Theorem mk_infinity_ax_thm - `STATE defs refs /\ + !tm. res = Success tm ==> TERM defs tm +Proof + rw [mk_neg_def, st_ex_bind_def, case_eq_thms] + \\ metis_tac [mk_neg_const_thm, mk_comb_thm] +QED + +Theorem mk_infinity_ax_thm: + STATE defs refs /\ TYPE defs Ind /\ mk_infinity_ax () refs = (res, refs') ==> refs = refs' /\ - !tm. res = Success tm ==> TERM defs tm` - (rw [mk_infinity_ax_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] + !tm. res = Success tm ==> TERM defs tm +Proof + rw [mk_infinity_ax_def, st_ex_bind_def, st_ex_return_def, case_eq_thms] \\ drule STATE_lemma \\ strip_tac \\ first_x_assum (qspecl_then [`Ind`,`Ind`] assume_tac) \\ rfs [] \\ qmatch_asmsub_abbrev_tac `mk_surj f` @@ -1592,18 +1803,22 @@ Theorem mk_infinity_ax_thm \\ disch_then drule \\ ntac 2 (pop_assum kall_tac) \\ rpt (disch_then drule) \\ rw [] - \\ metis_tac [mk_exists_thm]); + \\ metis_tac [mk_exists_thm] +QED -Theorem init_reader_success - `init_reader () init_refs = (res, refs) ==> res = Success ()` - (EVAL_TAC \\ fs []); +Theorem init_reader_success: + init_reader () init_refs = (res, refs) ==> res = Success () +Proof + EVAL_TAC \\ fs [] +QED -Theorem init_reader_ok - `init_reader () init_refs = (res, refs) +Theorem init_reader_ok: + init_reader () init_refs = (res, refs) ==> res = Success () /\ - ?defs. STATE defs refs` - (simp [init_reader_success] + ?defs. STATE defs refs +Proof + simp [init_reader_success] \\ sg `STATE init_refs.the_context init_refs` >- (EVAL_TAC \\ rw []) \\ qmatch_asmsub_abbrev_tac `STATE defs` @@ -1674,20 +1889,23 @@ Theorem init_reader_ok \\ drule (GEN_ALL new_axiom_thm) \\ disch_then drule \\ fs [] \\ rw [] \\ fs [st_ex_return_def] \\ rw [] - \\ asm_exists_tac \\ fs []); + \\ asm_exists_tac \\ fs [] +QED -Theorem readLines_init_state_thm - `init_reader () init_refs = (r, ax_refs) /\ +Theorem readLines_init_state_thm: + init_reader () init_refs = (r, ax_refs) /\ readLines lines init_state ax_refs = (res, refs) ==> ?defs. STATE defs refs /\ - !st n . res = Success (st, n) ==> READER_STATE defs st` - (strip_tac + !st n . res = Success (st, n) ==> READER_STATE defs st +Proof + strip_tac \\ imp_res_tac init_reader_ok \\ sg `READER_STATE defs init_state` >- fs [init_state_def, READER_STATE_def, lookup_def] - \\ metis_tac [readLines_thm]); + \\ metis_tac [readLines_thm] +QED (* ------------------------------------------------------------------------- *) (* Program specification (shared) *) @@ -1752,23 +1970,27 @@ val reader_main_def = Define ` (* Specs imply that invariants are preserved. *) (* ------------------------------------------------------------------------- *) -Theorem READER_STATE_init_state - `READER_STATE defs init_state` - (rw [READER_STATE_def, init_state_def, STATE_def, lookup_def]); +Theorem READER_STATE_init_state: + READER_STATE defs init_state +Proof + rw [READER_STATE_def, init_state_def, STATE_def, lookup_def] +QED -Theorem process_line_inv - `STATE defs refs /\ +Theorem process_line_inv: + STATE defs refs /\ READER_STATE defs st /\ process_line st refs ln = (res, refs') ==> ?ds. STATE (ds++defs) refs' /\ - !s. res = INL s ==> READER_STATE (ds++defs) s` - (rw [process_line_def] + !s. res = INL s ==> READER_STATE (ds++defs) s +Proof + rw [process_line_def] >- (qexists_tac `[]` \\ fs []) \\ fs [case_eq_thms] \\ rw [] \\ fs [] \\ drule (GEN_ALL readLine_thm) - \\ rpt (disch_then drule) \\ rw []); + \\ rpt (disch_then drule) \\ rw [] +QED val flush_stdin_def = Define ` flush_stdin cl fs = @@ -1779,16 +2001,17 @@ val flush_stdin_def = Define ` val _ = export_rewrites ["flush_stdin_def"]; -Theorem reader_proves - `reader_main fs init_refs cl = (outp,refs,SOME s) +Theorem reader_proves: + reader_main fs init_refs cl = (outp,refs,SOME s) ==> (!asl c. MEM (Sequent asl c) s.thms ==> (thyof refs.the_context, asl) |- c) /\ outp = add_stdout (flush_stdin cl fs) (msg_success s refs.the_context) /\ - refs.the_context extends init_ctxt` - (rw [reader_main_def, case_eq_thms, read_file_def, read_stdin_def, + refs.the_context extends init_ctxt +Proof + rw [reader_main_def, case_eq_thms, read_file_def, read_stdin_def, bool_case_eq, PULL_EXISTS] \\ Cases_on `init_reader () init_refs` \\ fs [] \\ imp_res_tac init_reader_ok \\ rw [] @@ -1799,7 +2022,8 @@ Theorem reader_proves \\ first_x_assum (assume_tac o REWRITE_RULE [THM_def] o Q.GENL [`a`,`b`] o Q.SPEC `Sequent a b`) \\ fs [STATE_def, CONTEXT_def] \\ rveq - \\ fs [EQ_SYM_EQ]); + \\ fs [EQ_SYM_EQ] +QED (* ------------------------------------------------------------------------- *) (* Some things useful for the top-level soundness theorem, for instance: *) @@ -1816,30 +2040,33 @@ val input_exists_def = Define ` val _ = export_rewrites ["input_exists_def"]; -Theorem readLines_Fail_not_empty - `!ls st refs err refs'. +Theorem readLines_Fail_not_empty: + !ls st refs err refs'. readLines ls st refs = (Failure (Fail err), refs') ==> - err <> strlit""` - (recInduct readLines_ind + err <> strlit"" +Proof + recInduct readLines_ind \\ Cases >- rw [Once readLines_def, st_ex_return_def] \\ rw [] \\ simp [Once readLines_def] \\ rw [st_ex_return_def, st_ex_bind_def, handle_Fail_def, raise_Fail_def, - case_eq_thms, line_Fail_def, mlstringTheory.concat_def]); + case_eq_thms, line_Fail_def, mlstringTheory.concat_def] +QED val no_errors_def = Define ` no_errors fs fs' <=> get_file_content fs 2 = get_file_content fs' 2`; -Theorem reader_success_stderr - `input_exists fs cl /\ +Theorem reader_success_stderr: + input_exists fs cl /\ STD_streams fs /\ reader_main fs refs (TL cl) = (fs', refs', s) /\ no_errors fs fs' ==> - ?st. s = SOME st` - (rw [reader_main_def, read_stdin_def, read_file_def, case_eq_thms, + ?st. s = SOME st +Proof + rw [reader_main_def, read_stdin_def, read_file_def, case_eq_thms, no_errors_def, msg_bad_name_def, msg_usage_def] \\ pop_assum mp_tac \\ fs [case_eq_thms, bool_case_eq] \\ rw [] \\ fs [] @@ -1853,7 +2080,8 @@ Theorem reader_success_stderr \\ fs [mlstringTheory.concat_thm, msg_bad_name_def] \\ SELECT_ELIM_TAC \\ fs [] \\ imp_res_tac readLines_Fail_not_empty - \\ Cases_on `e` \\ fs []); + \\ Cases_on `e` \\ fs [] +QED val _ = export_theory(); diff --git a/candle/standard/opentheory/readerScript.sml b/candle/standard/opentheory/readerScript.sml index a5e9e9a573..55616662f7 100644 --- a/candle/standard/opentheory/readerScript.sml +++ b/candle/standard/opentheory/readerScript.sml @@ -687,94 +687,116 @@ val readLines_def = Define ` val _ = patternMatchesLib.ENABLE_PMATCH_CASES (); val PMATCH_ELIM_CONV = patternMatchesLib.PMATCH_ELIM_CONV; -Theorem getNum_PMATCH - `!obj. +Theorem getNum_PMATCH: + !obj. getNum obj = case obj of Num n => return n - | _ => failwith (strlit"getNum")` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [getNum_def]); + | _ => failwith (strlit"getNum") +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [getNum_def] +QED -Theorem getName_PMATCH - `!obj. +Theorem getName_PMATCH: + !obj. getName obj = case obj of Name n => return n - | _ => failwith (strlit"getName")` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [getName_def]); + | _ => failwith (strlit"getName") +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [getName_def] +QED -Theorem getList_PMATCH - `!obj. +Theorem getList_PMATCH: + !obj. getList obj = case obj of List n => return n - | _ => failwith (strlit"getList")` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [getList_def]); + | _ => failwith (strlit"getList") +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [getList_def] +QED -Theorem getTypeOp_PMATCH - `!obj. +Theorem getTypeOp_PMATCH: + !obj. getTypeOp obj = case obj of TypeOp n => return n - | _ => failwith (strlit"getTypeOp")` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [getTypeOp_def]); + | _ => failwith (strlit"getTypeOp") +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [getTypeOp_def] +QED -Theorem getType_PMATCH - `!obj. +Theorem getType_PMATCH: + !obj. getType obj = case obj of Type n => return n - | _ => failwith (strlit"getType")` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [getType_def]); + | _ => failwith (strlit"getType") +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [getType_def] +QED -Theorem getConst_PMATCH - `!obj. +Theorem getConst_PMATCH: + !obj. getConst obj = case obj of Const n => return n - | _ => failwith (strlit"getConst")` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [getConst_def]); + | _ => failwith (strlit"getConst") +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [getConst_def] +QED -Theorem getVar_PMATCH - `!obj. +Theorem getVar_PMATCH: + !obj. getVar obj = case obj of Var n => return n - | _ => failwith (strlit"getVar")` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [getVar_def]); + | _ => failwith (strlit"getVar") +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [getVar_def] +QED -Theorem getTerm_PMATCH - `!obj. +Theorem getTerm_PMATCH: + !obj. getTerm obj = case obj of Term n => return n - | _ => failwith (strlit"getTerm")` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [getTerm_def]); + | _ => failwith (strlit"getTerm") +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [getTerm_def] +QED -Theorem getThm_PMATCH - `!obj. +Theorem getThm_PMATCH: + !obj. getThm obj = case obj of Thm n => return n - | _ => failwith (strlit"getThm")` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [getThm_def]); + | _ => failwith (strlit"getThm") +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [getThm_def] +QED -Theorem getPair_PMATCH - `!obj. +Theorem getPair_PMATCH: + !obj. getPair obj = case obj of List [x;y] => return (x,y) - | _ => failwith (strlit"getPair")` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ fs [getPair_def] - \\ rpt (PURE_CASE_TAC \\ fs [getPair_def])); - -Theorem unescape_PMATCH - `!str. + | _ => failwith (strlit"getPair") +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ fs [getPair_def] + \\ rpt (PURE_CASE_TAC \\ fs [getPair_def]) +QED + +Theorem unescape_PMATCH: + !str. unescape str = case str of #"\\":: #"\\" ::cs => #"\\"::unescape cs | c1::c::cs => c1::unescape (c::cs) - | cs => cs` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [Once unescape_def]); + | cs => cs +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [Once unescape_def] +QED val _ = export_theory() diff --git a/candle/standard/opentheory/readerSoundnessScript.sml b/candle/standard/opentheory/readerSoundnessScript.sml index 4c5ad94578..32e608aa9e 100644 --- a/candle/standard/opentheory/readerSoundnessScript.sml +++ b/candle/standard/opentheory/readerSoundnessScript.sml @@ -9,8 +9,8 @@ val _ = new_theory "readerSoundness"; val _ = Parse.hide "mem"; val mem = ``mem:'U->'U-> bool``; -Theorem reader_sound - `reader_main fs init_refs cl = (outp,refs,SOME s) +Theorem reader_sound: + reader_main fs init_refs cl = (outp,refs,SOME s) ==> refs.the_context extends init_ctxt /\ outp = add_stdout (flush_stdin cl fs) (msg_success s refs.the_context) /\ @@ -18,9 +18,11 @@ Theorem reader_sound MEM (Sequent asl c) s.thms /\ is_set_theory ^mem ==> - (thyof refs.the_context, asl) |= c` - (strip_tac + (thyof refs.the_context, asl) |= c +Proof + strip_tac \\ drule (GEN_ALL reader_proves) \\ rw [] - \\ irule proves_sound \\ fs []); + \\ irule proves_sound \\ fs [] +QED val _ = export_theory (); diff --git a/candle/standard/opentheory/reader_commonProgScript.sml b/candle/standard/opentheory/reader_commonProgScript.sml index 3b75103b03..e31434f1d6 100644 --- a/candle/standard/opentheory/reader_commonProgScript.sml +++ b/candle/standard/opentheory/reader_commonProgScript.sml @@ -53,9 +53,9 @@ val r = translate pp_seq_def val r = translate interleave_def val r = translate pp_term_def -Theorem pp_term_side - `!x y. pp_term_side x y <=> T` - (recInduct pp_term_ind \\ rw [] +Theorem pp_term_side = Q.prove(` + !x y. pp_term_side x y <=> T`, + recInduct pp_term_ind \\ rw [] \\ rw [Once (fetch "-" "pp_term_side_def")] \\ TRY strip_tac \\ rw [] \\ fs [is_binop_def, is_binder_def, is_cond_def]) @@ -129,9 +129,9 @@ val r = translate state_to_string_def val r = translate s2i_def val r = m_translate readLine_def -Theorem readline_side - `!st1 l s. readline_side st1 l s <=> T` - (rw [fetch "-" "readline_side_def"] \\ intLib.COOPER_TAC) +Theorem readline_side = Q.prove(` + !st1 l s. readline_side st1 l s <=> T`, + rw [fetch "-" "readline_side_def"] \\ intLib.COOPER_TAC) |> update_precondition; val readline_spec = save_thm ("readline_spec", @@ -194,8 +194,8 @@ val _ = Q.prove ( (* Things needed by whole_prog_spec *) (* ------------------------------------------------------------------------- *) -Theorem HOL_STORE_init_precond - `HOL_STORE init_refs +Theorem HOL_STORE_init_precond: + HOL_STORE init_refs {Mem (1+(LENGTH(delta_refs++empty_refs++ratio_refs++stdin_refs++stdout_refs ++stderr_refs++init_type_constants_refs))) (Refv init_type_constants_v); @@ -211,8 +211,9 @@ Theorem HOL_STORE_init_precond ++stderr_refs++init_type_constants_refs ++init_term_constants_refs++init_axioms_refs ++init_context_refs))) - (Refv init_context_v)}` - (qmatch_goalsub_abbrev_tac`1 + l1` + (Refv init_context_v)} +Proof + qmatch_goalsub_abbrev_tac`1 + l1` \\ qmatch_goalsub_abbrev_tac`2 + l2` \\ qmatch_goalsub_abbrev_tac`3 + l3` \\ qmatch_goalsub_abbrev_tac`4 + l4` @@ -267,7 +268,8 @@ Theorem HOL_STORE_init_precond \\ qexists_tac`init_type_constants_v` \\ simp[init_type_constants_v_thm] \\ unabbrev_all_tac - \\ SPLIT_TAC ); + \\ SPLIT_TAC +QED (* ------------------------------------------------------------------------- *) (* Generate app theorem for 'context'. *) diff --git a/candle/standard/semantics/holAxiomsScript.sml b/candle/standard/semantics/holAxiomsScript.sml index 94e55b7f07..f6091d4c02 100644 --- a/candle/standard/semantics/holAxiomsScript.sml +++ b/candle/standard/semantics/holAxiomsScript.sml @@ -25,12 +25,13 @@ val _ = Parse.hide "mem"; val mem = ``mem:'U->'U->bool`` -Theorem eta_has_model - `is_set_theory ^mem ⇒ +Theorem eta_has_model: + is_set_theory ^mem ⇒ ∀ctxt. is_std_sig (sigof ctxt) ⇒ ∀i. i models (thyof ctxt) ⇒ - i models (thyof (mk_eta_ctxt ctxt))` - (rw[models_def,mk_eta_ctxt_def,conexts_of_upd_def] >> res_tac >> + i models (thyof (mk_eta_ctxt ctxt)) +Proof + rw[models_def,mk_eta_ctxt_def,conexts_of_upd_def] >> res_tac >> rw[satisfies_def] >> `is_structure (sigof ctxt) i v` by simp[is_structure_def] >> `term_ok (sigof ctxt) (Abs x (Comb g x) === g)` by ( @@ -60,14 +61,15 @@ Theorem eta_has_model rw[] ) >> rw[combinTheory.APPLY_UPDATE_THM] >> match_mp_tac (UNDISCH apply_abstract) >> - rw[]) + rw[] +QED val good_select_def = xDefine"good_select"` good_select0 ^mem select = (∀ty p x. x <: ty ⇒ select ty p <: ty ∧ (p x ⇒ p (select ty p)))` val _ = Parse.overload_on("good_select",``good_select0 ^mem``) -Theorem select_has_model_gen - `is_set_theory ^mem ⇒ +Theorem select_has_model_gen: + is_set_theory ^mem ⇒ ∀ctxt. (strlit "@") ∉ FDOM (tmsof ctxt) ∧ is_implies_sig (tmsof ctxt) ∧ @@ -81,8 +83,9 @@ Theorem select_has_model_gen i' models (thyof (mk_select_ctxt ctxt)) ∧ (tmaof i' (strlit "@") = (λls. Abstract (Funspace (HD ls) boolset) (HD ls) - (λp. select (HD ls) (Holds p))))` - (rw[good_select_def,models_def,mk_select_ctxt_def,conexts_of_upd_def,is_implies_sig_def,is_implies_interpretation_def] >> + (λp. select (HD ls) (Holds p)))) +Proof + rw[good_select_def,models_def,mk_select_ctxt_def,conexts_of_upd_def,is_implies_sig_def,is_implies_interpretation_def] >> qexists_tac`(tyaof i, (strlit "@" =+ λl. Abstract (Funspace (HD l) boolset) (HD l) (λp. select (HD l) (Holds p))) (tmaof i))` >> imp_res_tac is_std_interpretation_is_type >> @@ -181,7 +184,8 @@ Theorem select_has_model_gen metis_tac[]) >> simp[Abbr`fs`] >> metis_tac[]) >> - simp[combinTheory.APPLY_UPDATE_THM]) + simp[combinTheory.APPLY_UPDATE_THM] +QED val base_select_def = xDefine "base_select"` base_select0 ^mem ty p = @@ -190,10 +194,11 @@ val base_select_def = xDefine "base_select"` else ARB` val _ = Parse.overload_on("base_select",``base_select0 ^mem``) -Theorem good_select_base_select - `is_set_theory ^mem ⇒ - good_select base_select` - (rw[good_select_def,base_select_def] >> +Theorem good_select_base_select: + is_set_theory ^mem ⇒ + good_select base_select +Proof + rw[good_select_def,base_select_def] >> rw[]>> TRY(metis_tac[]) >> TRY ( qho_match_abbrev_tac`(case ($some Q) of NONE => R | SOME v => v) <: ty` >> @@ -205,10 +210,11 @@ Theorem good_select_base_select qho_match_abbrev_tac`Z ($some Q)` >> match_mp_tac optionTheory.some_intro >> simp[Abbr`Z`,Abbr`Q`,Abbr`R`] >> - metis_tac[] ) + metis_tac[] +QED -Theorem select_has_model - `is_set_theory ^mem ⇒ +Theorem select_has_model: + is_set_theory ^mem ⇒ ∀ctxt. (strlit "@") ∉ FDOM (tmsof ctxt) ∧ is_implies_sig (tmsof ctxt) ∧ @@ -218,13 +224,15 @@ Theorem select_has_model i models (thyof ctxt) ∧ is_implies_interpretation (tmaof i) ⇒ ∃i'. equal_on (sigof ctxt) i i' ∧ - i' models (thyof (mk_select_ctxt ctxt))` - (rw[] >> + i' models (thyof (mk_select_ctxt ctxt)) +Proof + rw[] >> qspec_then`ctxt`mp_tac(UNDISCH select_has_model_gen) >> simp[] >> disch_then(qspec_then`i`mp_tac) >> disch_then(qspec_then`base_select` mp_tac) >> - metis_tac[good_select_base_select]) + metis_tac[good_select_base_select] +QED val _ = Parse.temp_overload_on("h",``Var (strlit "f") (Fun Ind Ind)``) val _ = Parse.temp_overload_on("Exh",``Exists (strlit "f") (Fun Ind Ind)``) @@ -267,8 +275,8 @@ val apply_abstract_tac = rpt ( ( `tmsof sctx = tmsof (sigof sctx)` by simp[] >> pop_assum SUBST1_TAC >> rw[SIMP_RULE std_ss [] termsem_equation,boolean_in_boolset] -Theorem infinity_has_model_gen - `is_set_theory ^mem ⇒ +Theorem infinity_has_model_gen: + is_set_theory ^mem ⇒ ∀ctxt. theory_ok (thyof ctxt) ∧ DISJOINT (FDOM (tmsof ctxt)) {strlit "ONE_ONE";strlit "ONTO"} ∧ @@ -289,8 +297,9 @@ Theorem infinity_has_model_gen is_infinite ^mem inf ⇒ ∃i'. equal_on (sigof ctxt) i i' ∧ i' models (thyof (mk_infinity_ctxt ctxt)) ∧ - (tyaof i' (strlit "ind") [] = inf)` - (rw[models_def,is_implies_sig_def,is_and_sig_def,is_forall_sig_def,is_exists_sig_def,is_not_sig_def, + (tyaof i' (strlit "ind") [] = inf) +Proof + rw[models_def,is_implies_sig_def,is_and_sig_def,is_forall_sig_def,is_exists_sig_def,is_not_sig_def, is_implies_interpretation_def,is_and_interpretation_def,is_forall_interpretation_def,is_exists_interpretation_def,is_not_interpretation_def] >> `∃ctxt1 p. mk_infinity_ctxt ctxt = (NewAxiom p)::(NewType (strlit "ind") 0)::ctxt1` by simp[mk_infinity_ctxt_def] >> `mk_infinity_ctxt ctxt extends ctxt` by ( @@ -666,10 +675,11 @@ Theorem infinity_has_model_gen qpat_x_assum`INJ f X Y`mp_tac >> simp[INJ_DEF] ) >> metis_tac[]) >> - simp[combinTheory.APPLY_UPDATE_THM]) + simp[combinTheory.APPLY_UPDATE_THM] +QED -Theorem infinity_has_model - `is_set_theory ^mem ∧ (∃inf. is_infinite ^mem inf) ⇒ +Theorem infinity_has_model: + is_set_theory ^mem ∧ (∃inf. is_infinite ^mem inf) ⇒ ∀ctxt. theory_ok (thyof ctxt) ∧ DISJOINT (FDOM (tmsof ctxt)) {strlit"ONE_ONE";strlit"ONTO"} ∧ @@ -688,7 +698,9 @@ Theorem infinity_has_model is_exists_interpretation (tmaof i) ∧ is_not_interpretation (tmaof i) ⇒ ∃i'. equal_on (sigof ctxt) i i' ∧ - i' models (thyof (mk_infinity_ctxt ctxt))` - (metis_tac[infinity_has_model_gen]) + i' models (thyof (mk_infinity_ctxt ctxt)) +Proof + metis_tac[infinity_has_model_gen] +QED val _ = export_theory() diff --git a/candle/standard/semantics/holBoolScript.sml b/candle/standard/semantics/holBoolScript.sml index 57859b9db9..9666ac5b88 100644 --- a/candle/standard/semantics/holBoolScript.sml +++ b/candle/standard/semantics/holBoolScript.sml @@ -26,8 +26,8 @@ val _ = Parse.temp_overload_on("FAx",``Forall (strlit "x") A``) val sigs = [is_true_sig_def, is_false_sig_def, is_implies_sig_def, is_and_sig_def, is_or_sig_def, is_not_sig_def, is_forall_sig_def, is_exists_sig_def] -Theorem bool_sig_instances - `is_bool_sig sig ⇒ +Theorem bool_sig_instances: + is_bool_sig sig ⇒ instance (tmsof sig) (i:'U interpretation) (strlit "T") Bool = (K (tmaof i (strlit "T") [])) ∧ instance (tmsof sig) i (strlit "F") Bool = (K (tmaof i (strlit "F") [])) ∧ instance (tmsof sig) i (strlit "==>") (Fun Bool (Fun Bool Bool)) = (K (tmaof i (strlit "==>") [])) ∧ @@ -35,9 +35,11 @@ Theorem bool_sig_instances instance (tmsof sig) i (strlit "\\/") (Fun Bool (Fun Bool Bool)) = (K (tmaof i (strlit "\\/") [])) ∧ instance (tmsof sig) i (strlit "~") (Fun Bool Bool) = (K (tmaof i (strlit "~") [])) ∧ instance (tmsof sig) i (strlit "!") (Fun (Fun A Bool) Bool) = (λτ. tmaof i (strlit "!") [τ (strlit "A")]) ∧ - instance (tmsof sig) i (strlit "?") (Fun (Fun A Bool) Bool) = (λτ. tmaof i (strlit "?") [τ (strlit "A")])` - (rw[is_bool_sig_def] >> fs sigs >> imp_res_tac identity_instance >> rw[FUN_EQ_THM] >> - rpt AP_TERM_TAC >> rw[FUN_EQ_THM,tyvars_def] >> EVAL_TAC >> metis_tac[]) + instance (tmsof sig) i (strlit "?") (Fun (Fun A Bool) Bool) = (λτ. tmaof i (strlit "?") [τ (strlit "A")]) +Proof + rw[is_bool_sig_def] >> fs sigs >> imp_res_tac identity_instance >> rw[FUN_EQ_THM] >> + rpt AP_TERM_TAC >> rw[FUN_EQ_THM,tyvars_def] >> EVAL_TAC >> metis_tac[] +QED val Boolrel_def = xDefine"Boolrel"` Boolrel0 ^mem R = @@ -101,10 +103,12 @@ val is_bool_interpretation_def = xDefine"is_bool_interpretation"` is_not_interpretation (tmaof i)` val _ = Parse.overload_on("is_bool_interpretation",``is_bool_interpretation0 ^mem``) -Theorem boolrel_in_funspace - `is_set_theory ^mem ⇒ Boolrel R <: Funspace boolset (Funspace boolset boolset)` - (rw[Boolrel_def] >> match_mp_tac (UNDISCH abstract_in_funspace) >> rw[] >> - match_mp_tac (UNDISCH abstract_in_funspace) >> rw[boolean_in_boolset] ) +Theorem boolrel_in_funspace: + is_set_theory ^mem ⇒ Boolrel R <: Funspace boolset (Funspace boolset boolset) +Proof + rw[Boolrel_def] >> match_mp_tac (UNDISCH abstract_in_funspace) >> rw[] >> + match_mp_tac (UNDISCH abstract_in_funspace) >> rw[boolean_in_boolset] +QED val _ = export_rewrites["boolrel_in_funspace"] val Defs = [TrueDef_def, AndDef_def, ImpliesDef_def, ForallDef_def, ExistsDef_def, OrDef_def, FalseDef_def, NotDef_def] @@ -159,11 +163,12 @@ val apply_abstract_tac = rpt ( ( match_mp_tac (UNDISCH apply_in_rng) >> HINT_EXISTS_TAC >> rw[] -Theorem apply_boolrel - `is_set_theory ^mem ⇒ +Theorem apply_boolrel: + is_set_theory ^mem ⇒ ∀b1 b2 b3. b1 <: boolset ∧ b2 <: boolset ∧ (b3 = Boolean (R (b1 = True) (b2 = True))) ⇒ - Boolrel R ' b1 ' b2 = b3 ` - (rw[] >> + Boolrel R ' b1 ' b2 = b3 +Proof + rw[] >> `Boolrel R ' b1 = Abstract boolset boolset (λb2. Boolean (R (b1 = True) (b2 = True)))` by ( rw[Boolrel_def] >> match_mp_tac apply_abstract_matchable >> @@ -172,14 +177,16 @@ Theorem apply_boolrel rw[boolean_in_boolset] ) >> rw[] >> match_mp_tac apply_abstract_matchable >> - rw[boolean_in_boolset] ) + rw[boolean_in_boolset] +QED -Theorem bool_has_bool_interpretation - `is_set_theory ^mem ⇒ +Theorem bool_has_bool_interpretation: + is_set_theory ^mem ⇒ ∀ctxt i. theory_ok (thyof (mk_bool_ctxt ctxt)) ∧ i models (thyof (mk_bool_ctxt ctxt)) ⇒ - is_bool_interpretation i` - (rw[] >> + is_bool_interpretation i +Proof + rw[] >> simp[is_bool_interpretation_def] >> conj_asm1_tac >- fs[models_def] >> qabbrev_tac`ctx = mk_bool_ctxt ctxt` >> @@ -496,15 +503,17 @@ Theorem bool_has_bool_interpretation rpt (last_x_assum(qspec_then`τ`mp_tac)>>simp[]>>strip_tac) >> match_mp_tac (UNDISCH abstract_eq) >> simp[boolean_in_boolset,SIMP_RULE(srw_ss())[]apply_boolrel,combinTheory.APPLY_UPDATE_THM,mem_boolset,boolean_def] >> - rw[] >> rw[] >> fs[]) + rw[] >> rw[] >> fs[] +QED -Theorem extends_is_bool_interpretation - `is_set_theory ^mem ∧ +Theorem extends_is_bool_interpretation: + is_set_theory ^mem ∧ ctxt2 extends (mk_bool_ctxt ctxt) ∧ theory_ok (thyof (mk_bool_ctxt ctxt)) ∧ i models (thyof ctxt2) ⇒ - is_bool_interpretation i` - (strip_tac >> + is_bool_interpretation i +Proof + strip_tac >> `i models thyof (mk_bool_ctxt ctxt)` by ( `∃x y z. thyof (mk_bool_ctxt ctxt) = ((x,y),z)` by metis_tac[pairTheory.PAIR] >> simp[] >> @@ -517,10 +526,11 @@ Theorem extends_is_bool_interpretation rpt BasicProvers.VAR_EQ_TAC >> imp_res_tac extends_sub >> fs[] >> fs[theory_ok_def] ) >> - metis_tac[bool_has_bool_interpretation]) + metis_tac[bool_has_bool_interpretation] +QED -Theorem termsem_implies - `is_set_theory ^mem ⇒ +Theorem termsem_implies: + is_set_theory ^mem ⇒ ∀s i v p1 p2. is_valuation (tysof s) (tyaof i) v ∧ is_interpretation s i ∧ @@ -530,8 +540,9 @@ Theorem termsem_implies is_implies_sig (tmsof s) ∧ is_implies_interpretation (tmaof i) ⇒ termsem (tmsof s) i v (Implies p1 p2) = Boolean (termsem (tmsof s) i v p1 = True ⇒ - termsem (tmsof s) i v p2 = True)` - (rw[termsem_def,is_implies_sig_def,is_implies_interpretation_def] >> + termsem (tmsof s) i v p2 = True) +Proof + rw[termsem_def,is_implies_sig_def,is_implies_interpretation_def] >> qspecl_then[`tmsof s`,`i`,`strlit"==>"`]mp_tac instance_def >> simp[] >> disch_then(qspec_then`[]`mp_tac) >> simp[] >> disch_then kall_tac >> @@ -562,10 +573,11 @@ Theorem termsem_implies simp[] >> qexists_tac`s` >> simp[] >> imp_res_tac typesem_Bool >> simp[] ) >> - simp[boolean_in_boolset] ) + simp[boolean_in_boolset] +QED -Theorem termsem_forall - `is_set_theory ^mem ⇒ +Theorem termsem_forall: + is_set_theory ^mem ⇒ ∀s i v f y b. is_valuation (tysof s) (tyaof i) v ∧ is_interpretation s i ∧ @@ -574,8 +586,9 @@ Theorem termsem_forall is_forall_sig (tmsof s) ∧ is_forall_interpretation (tmaof i) ⇒ termsem (tmsof s) i v (Forall f y b) = Boolean (∀x. x <: typesem (tyaof i) (tyvof v) y ⇒ - termsem (tmsof s) i (tyvof v, ((f,y) =+ x) (tmvof v)) b = True)` - (rw[termsem_def,is_forall_sig_def,is_forall_interpretation_def] >> + termsem (tmsof s) i (tyvof v, ((f,y) =+ x) (tmvof v)) b = True) +Proof + rw[termsem_def,is_forall_sig_def,is_forall_interpretation_def] >> qspecl_then[`tmsof s`,`i`,`strlit"!"`]mp_tac instance_def >> simp[] >> disch_then(qspec_then`[y,Tyvar(strlit"A")]`mp_tac) >> simp[holSyntaxLibTheory.REV_ASSOCD] >> disch_then kall_tac >> @@ -610,10 +623,11 @@ Theorem termsem_forall match_mp_tac (UNDISCH termsem_typesem_matchable) >> simp[] >> qexists_tac`s` >> simp[] >> fs[is_valuation_def,is_term_valuation_def,combinTheory.APPLY_UPDATE_THM] >> - rw[] >> rw[] ) + rw[] >> rw[] +QED -Theorem termsem_exists - `is_set_theory ^mem ⇒ +Theorem termsem_exists: + is_set_theory ^mem ⇒ ∀s i v f y b. is_valuation (tysof s) (tyaof i) v ∧ is_interpretation s i ∧ @@ -622,8 +636,9 @@ Theorem termsem_exists is_exists_sig (tmsof s) ∧ is_exists_interpretation (tmaof i) ⇒ termsem (tmsof s) i v (Exists f y b) = Boolean (∃x. x <: typesem (tyaof i) (tyvof v) y ∧ - termsem (tmsof s) i (tyvof v, ((f,y) =+ x) (tmvof v)) b = True)` - (rw[termsem_def,is_exists_sig_def,is_exists_interpretation_def] >> + termsem (tmsof s) i (tyvof v, ((f,y) =+ x) (tmvof v)) b = True) +Proof + rw[termsem_def,is_exists_sig_def,is_exists_interpretation_def] >> qspecl_then[`tmsof s`,`i`,`strlit"?"`]mp_tac instance_def >> simp[] >> disch_then(qspec_then`[y,Tyvar(strlit"A")]`mp_tac) >> simp[holSyntaxLibTheory.REV_ASSOCD] >> disch_then kall_tac >> @@ -658,10 +673,11 @@ Theorem termsem_exists match_mp_tac (UNDISCH termsem_typesem_matchable) >> simp[] >> qexists_tac`s` >> simp[] >> fs[is_valuation_def,is_term_valuation_def,combinTheory.APPLY_UPDATE_THM] >> - rw[] >> rw[] ) + rw[] >> rw[] +QED -Theorem termsem_and - `is_set_theory ^mem ⇒ +Theorem termsem_and: + is_set_theory ^mem ⇒ ∀s i v p1 p2. is_valuation (tysof s) (tyaof i) v ∧ is_interpretation s i ∧ @@ -671,8 +687,9 @@ Theorem termsem_and is_and_sig (tmsof s) ∧ is_and_interpretation (tmaof i) ⇒ termsem (tmsof s) i v (And p1 p2) = Boolean (termsem (tmsof s) i v p1 = True ∧ - termsem (tmsof s) i v p2 = True)` - (rw[termsem_def,is_and_sig_def,is_and_interpretation_def] >> + termsem (tmsof s) i v p2 = True) +Proof + rw[termsem_def,is_and_sig_def,is_and_interpretation_def] >> qspecl_then[`tmsof s`,`i`,`strlit"/\\"`]mp_tac instance_def >> simp[] >> disch_then(qspec_then`[]`mp_tac) >> simp[] >> disch_then kall_tac >> @@ -703,10 +720,11 @@ Theorem termsem_and simp[] >> qexists_tac`s` >> simp[] >> imp_res_tac typesem_Bool >> simp[] ) >> - simp[boolean_in_boolset] ) + simp[boolean_in_boolset] +QED -Theorem termsem_not - `is_set_theory ^mem ⇒ +Theorem termsem_not: + is_set_theory ^mem ⇒ ∀s i v p1. is_valuation (tysof s) (tyaof i) v ∧ is_interpretation s i ∧ @@ -715,8 +733,9 @@ Theorem termsem_not typeof p1 = Bool ∧ is_not_sig (tmsof s) ∧ is_not_interpretation (tmaof i) ⇒ termsem (tmsof s) i v (Not p1) = - Boolean (termsem (tmsof s) i v p1 ≠ True)` - (rw[termsem_def,is_not_sig_def,is_not_interpretation_def] >> + Boolean (termsem (tmsof s) i v p1 ≠ True) +Proof + rw[termsem_def,is_not_sig_def,is_not_interpretation_def] >> qspecl_then[`tmsof s`,`i`,`strlit"~"`]mp_tac instance_def >> simp[] >> disch_then(qspec_then`[]`mp_tac) >> simp[] >> disch_then kall_tac >> @@ -732,6 +751,7 @@ Theorem termsem_not match_mp_tac (UNDISCH termsem_typesem_matchable) >> simp[] >> qexists_tac`s` >> simp[] >> - imp_res_tac typesem_Bool >> simp[] ) + imp_res_tac typesem_Bool >> simp[] +QED val _ = export_theory() diff --git a/candle/standard/semantics/holConsistencyScript.sml b/candle/standard/semantics/holConsistencyScript.sml index afdd67a585..92aad184dc 100644 --- a/candle/standard/semantics/holConsistencyScript.sml +++ b/candle/standard/semantics/holConsistencyScript.sml @@ -20,11 +20,12 @@ val consistent_theory_def = Define` (thy,[]) |- (Var (strlit"x") Bool === Var (strlit"x") Bool) ∧ ¬((thy,[]) |- (Var (strlit"x") Bool === Var (strlit"y") Bool))` -Theorem proves_consistent - `is_set_theory ^mem ⇒ +Theorem proves_consistent: + is_set_theory ^mem ⇒ ∀thy. theory_ok thy ∧ (∃i. i models thy) ⇒ - consistent_theory thy` - (rw[consistent_theory_def] >- ( + consistent_theory thy +Proof + rw[consistent_theory_def] >- ( match_mp_tac (List.nth(CONJUNCTS proves_rules,8)) >> simp[term_ok_def,type_ok_def] >> imp_res_tac theory_ok_sig >> @@ -52,11 +53,13 @@ Theorem proves_consistent impl_tac >- ( simp[term_ok_equation,is_structure_def] >> fs[models_def,theory_ok_def] ) >> - simp[Abbr`s`,Abbr`t`,termsem_def,boolean_eq_true,Abbr`v`,true_neq_false]) + simp[Abbr`s`,Abbr`t`,termsem_def,boolean_eq_true,Abbr`v`,true_neq_false] +QED -Theorem init_ctxt_has_model - `is_set_theory ^mem ⇒ ∃i. i models (thyof init_ctxt)` - (rw[models_def,init_ctxt_def,conexts_of_upd_def] >> +Theorem init_ctxt_has_model: + is_set_theory ^mem ⇒ ∃i. i models (thyof init_ctxt) +Proof + rw[models_def,init_ctxt_def,conexts_of_upd_def] >> rw[is_std_interpretation_def,is_std_type_assignment_def,EXISTS_PROD] >> qho_match_abbrev_tac`∃f g. P f g ∧ (Q f ∧ f x2 z2 = y2) ∧ (g interprets x3 on z3 as y3)` >> qexists_tac`λx. if x = strlit"fun" then (λls. Funspace (HD ls) (HD (TL ls))) else if x = x2 then (K y2) else ARB` >> @@ -71,22 +74,26 @@ Theorem init_ctxt_has_model match_mp_tac (UNDISCH abstract_in_funspace) >> rw[boolean_in_boolset] ) >> Cases_on`ls`>>fs[]>>Cases_on`t`>>fs[listTheory.LENGTH_NIL] >> match_mp_tac (UNDISCH funspace_inhabited) >> - metis_tac[]) + metis_tac[] +QED -Theorem min_hol_consistent - `is_set_theory ^mem ⇒ +Theorem min_hol_consistent: + is_set_theory ^mem ⇒ ∀ctxt. ctxt extends init_ctxt ∧ (∀p. MEM (NewAxiom p) ctxt ⇒ MEM (NewAxiom p) init_ctxt) ⇒ - consistent_theory (thyof ctxt)` - (strip_tac >> gen_tac >> strip_tac >> + consistent_theory (thyof ctxt) +Proof + strip_tac >> gen_tac >> strip_tac >> match_mp_tac (UNDISCH proves_consistent) >> - metis_tac[extends_theory_ok,extends_consistent,init_theory_ok,init_ctxt_has_model]) + metis_tac[extends_theory_ok,extends_consistent,init_theory_ok,init_ctxt_has_model] +QED val fhol_ctxt_def = Define` fhol_ctxt = mk_select_ctxt (mk_eta_ctxt (mk_bool_ctxt init_ctxt))` -Theorem fhol_extends_bool - `fhol_ctxt extends (mk_bool_ctxt init_ctxt)` - (rw[fhol_ctxt_def] >> +Theorem fhol_extends_bool: + fhol_ctxt extends (mk_bool_ctxt init_ctxt) +Proof + rw[fhol_ctxt_def] >> match_mp_tac extends_trans >> qexists_tac`mk_eta_ctxt (mk_bool_ctxt init_ctxt)` >> reverse conj_asm2_tac >- ( @@ -96,7 +103,8 @@ Theorem fhol_extends_bool `sigof init_ctxt = sigof (thyof init_ctxt)` by simp[] >> metis_tac[theory_ok_sig,init_theory_ok] ) >> match_mp_tac select_extends >> - EVAL_TAC ) + EVAL_TAC +QED fun tac extends_bool unfold = strip_tac >> gen_tac >> strip_tac >> @@ -141,53 +149,62 @@ fun tac extends_bool unfold = impl_tac >- fs[is_bool_interpretation_def] >> disch_then(qx_choose_then`i3`strip_assume_tac) -Theorem fhol_has_model - `is_set_theory ^mem ⇒ +Theorem fhol_has_model: + is_set_theory ^mem ⇒ ∀ctxt. ctxt extends fhol_ctxt ∧ (∀p. MEM (NewAxiom p) ctxt ⇒ MEM (NewAxiom p) fhol_ctxt) ⇒ - theory_ok (thyof ctxt) ∧ ∃i. i models thyof ctxt` - (tac fhol_extends_bool ALL_TAC >> + theory_ok (thyof ctxt) ∧ ∃i. i models thyof ctxt +Proof + tac fhol_extends_bool ALL_TAC >> fs[GSYM fhol_ctxt_def] >> qspecl_then[`fhol_ctxt`,`ctxt`]mp_tac(UNDISCH extends_consistent) >> simp[] >> - metis_tac[]) + metis_tac[] +QED -Theorem fhol_consistent - `is_set_theory ^mem ⇒ +Theorem fhol_consistent: + is_set_theory ^mem ⇒ ∀ctxt. ctxt extends fhol_ctxt ∧ (∀p. MEM (NewAxiom p) ctxt ⇒ MEM (NewAxiom p) fhol_ctxt) ⇒ - consistent_theory (thyof ctxt)` - (strip_tac >> gen_tac >> strip_tac >> + consistent_theory (thyof ctxt) +Proof + strip_tac >> gen_tac >> strip_tac >> match_mp_tac (UNDISCH proves_consistent) >> - metis_tac[fhol_has_model]) + metis_tac[fhol_has_model] +QED val hol_ctxt_def = Define` hol_ctxt = mk_infinity_ctxt fhol_ctxt` -Theorem hol_extends_fhol - `hol_ctxt extends fhol_ctxt` - (rw[hol_ctxt_def] >> +Theorem hol_extends_fhol: + hol_ctxt extends fhol_ctxt +Proof + rw[hol_ctxt_def] >> match_mp_tac infinity_extends >> reverse conj_tac >- EVAL_TAC >> match_mp_tac (MP_CANON extends_theory_ok) >> match_exists_tac (concl fhol_extends_bool) >> conj_tac >- ACCEPT_TAC fhol_extends_bool >> match_mp_tac (MP_CANON extends_theory_ok) >> - metis_tac[bool_extends_init,init_theory_ok]) + metis_tac[bool_extends_init,init_theory_ok] +QED -Theorem hol_extends_bool - `hol_ctxt extends (mk_bool_ctxt init_ctxt)` - (match_mp_tac extends_trans >> - metis_tac[hol_extends_fhol,fhol_extends_bool]) +Theorem hol_extends_bool: + hol_ctxt extends (mk_bool_ctxt init_ctxt) +Proof + match_mp_tac extends_trans >> + metis_tac[hol_extends_fhol,fhol_extends_bool] +QED -Theorem hol_has_model - `is_set_theory ^mem ∧ (∃inf. is_infinite ^mem inf) ⇒ +Theorem hol_has_model: + is_set_theory ^mem ∧ (∃inf. is_infinite ^mem inf) ⇒ ∀ctxt. ctxt extends hol_ctxt ∧ (∀p. MEM (NewAxiom p) ctxt ⇒ MEM (NewAxiom p) hol_ctxt) ⇒ - theory_ok (thyof ctxt) ∧ ∃i. i models thyof ctxt` - (tac hol_extends_bool (fs[hol_ctxt_def]) >> + theory_ok (thyof ctxt) ∧ ∃i. i models thyof ctxt +Proof + tac hol_extends_bool (fs[hol_ctxt_def]) >> assume_tac(UNDISCH(PROVE[]``is_infinite mem inf ⇒ ∃inf. is_infinite ^mem inf``)) >> qspec_then`mk_select_ctxt (mk_eta_ctxt (mk_bool_ctxt init_ctxt))`mp_tac (infinity_has_model |> ONCE_REWRITE_RULE[GSYM AND_IMP_INTRO] |> UNDISCH |> UNDISCH) >> @@ -215,16 +232,19 @@ Theorem hol_has_model disch_then(qx_choose_then`i4`strip_assume_tac) >> fs[GSYM hol_ctxt_def,GSYM fhol_ctxt_def] >> qspecl_then[`hol_ctxt`,`ctxt`]mp_tac(UNDISCH extends_consistent) >> simp[] >> - metis_tac[]) + metis_tac[] +QED -Theorem hol_consistent - `is_set_theory ^mem ∧ (∃inf. is_infinite ^mem inf) ⇒ +Theorem hol_consistent: + is_set_theory ^mem ∧ (∃inf. is_infinite ^mem inf) ⇒ ∀ctxt. ctxt extends hol_ctxt ∧ (∀p. MEM (NewAxiom p) ctxt ⇒ MEM (NewAxiom p) hol_ctxt) ⇒ - consistent_theory (thyof ctxt)` - (strip_tac >> gen_tac >> strip_tac >> + consistent_theory (thyof ctxt) +Proof + strip_tac >> gen_tac >> strip_tac >> match_mp_tac (UNDISCH proves_consistent) >> - metis_tac[hol_has_model]) + metis_tac[hol_has_model] +QED val _ = export_theory() diff --git a/candle/standard/semantics/holExtensionScript.sml b/candle/standard/semantics/holExtensionScript.sml index 93269f6a15..8f7b88286c 100644 --- a/candle/standard/semantics/holExtensionScript.sml +++ b/candle/standard/semantics/holExtensionScript.sml @@ -19,14 +19,15 @@ val sound_update_def = xDefine"sound_update"` i' models (thyof (upd::ctxt))` val _ = Parse.overload_on("sound_update",``sound_update0 ^mem``) -Theorem new_constant_correct - `is_set_theory ^mem ⇒ +Theorem new_constant_correct: + is_set_theory ^mem ⇒ ∀ctxt name ty. theory_ok (thyof ctxt) ∧ name ∉ (FDOM (tmsof ctxt)) ∧ type_ok (tysof ctxt) ty ⇒ - sound_update ctxt (NewConst name ty)` - (rw[] >> REWRITE_TAC[sound_update_def,equal_on_def] >> + sound_update ctxt (NewConst name ty) +Proof + rw[] >> REWRITE_TAC[sound_update_def,equal_on_def] >> gen_tac >> strip_tac >> qexists_tac`(tyaof i, (name =+ λl. @v. v <: typesem (tyaof i) ((K boolset) =++ @@ -63,10 +64,11 @@ Theorem new_constant_correct conj_tac >- (Cases_on`ctxt`>>fs[]) >> conj_tac >- fs[theory_ok_def] >> simp[equal_on_def] >> - metis_tac[]) + metis_tac[] +QED -Theorem new_specification_correct - `is_set_theory ^mem ⇒ +Theorem new_specification_correct: + is_set_theory ^mem ⇒ ∀ctxt eqs prop. theory_ok (thyof ctxt) ∧ (thyof ctxt, MAP (λ(s,t). Var s (typeof t) === t) eqs) |- prop ∧ @@ -78,8 +80,9 @@ Theorem new_specification_correct MEM (x,ty) (MAP (λ(s,t). (s,typeof t)) eqs)) ∧ (∀s. MEM s (MAP FST eqs) ⇒ s ∉ (FDOM (tmsof ctxt))) ∧ ALL_DISTINCT (MAP FST eqs) ⇒ - sound_update ctxt (ConstSpec eqs prop)` - (rw[] >> REWRITE_TAC[sound_update_def,equal_on_def] >> + sound_update ctxt (ConstSpec eqs prop) +Proof + rw[] >> REWRITE_TAC[sound_update_def,equal_on_def] >> gen_tac >> strip_tac >> qexists_tac`(tyaof i, (tmaof i) =++ @@ -295,33 +298,37 @@ Theorem new_specification_correct fs[EVERY_MAP,EVERY_MEM,FORALL_PROD,CLOSED_def,MEM_MAP,PULL_EXISTS] >> imp_res_tac theory_ok_sig >> fs[term_ok_equation] >> metis_tac[term_ok_welltyped] ) >> - rw[Abbr`v4`]) + rw[Abbr`v4`] +QED -Theorem new_definition_correct - `is_set_theory ^mem ⇒ +Theorem new_definition_correct: + is_set_theory ^mem ⇒ ∀ctxt name tm. theory_ok (thyof ctxt) ∧ term_ok (sigof ctxt) tm ∧ name ∉ FDOM (tmsof ctxt) ∧ CLOSED tm ∧ set (tvars tm) ⊆ set (tyvars (typeof tm)) - ⇒ sound_update ctxt (ConstDef name tm)` - (rw[] >> + ⇒ sound_update ctxt (ConstDef name tm) +Proof + rw[] >> ho_match_mp_tac (UNDISCH new_specification_correct) >> simp[] >> fs[SUBSET_DEF,CLOSED_def,vfree_in_equation] >> ho_match_mp_tac(proves_rules |> CONJUNCTS |> el 2) >> imp_res_tac theory_ok_sig >> fs[EQUATION_HAS_TYPE_BOOL,term_ok_equation,term_ok_def] >> imp_res_tac term_ok_welltyped >> - imp_res_tac term_ok_type_ok >> fs[]) + imp_res_tac term_ok_type_ok >> fs[] +QED -Theorem new_type_correct - `is_set_theory ^mem ⇒ +Theorem new_type_correct: + is_set_theory ^mem ⇒ ∀ctxt name arity. theory_ok (thyof ctxt) ∧ name ∉ FDOM (tysof ctxt) ⇒ - sound_update ctxt (NewType name arity)` - (rw[] >> REWRITE_TAC[sound_update_def,equal_on_def] >> + sound_update ctxt (NewType name arity) +Proof + rw[] >> REWRITE_TAC[sound_update_def,equal_on_def] >> gen_tac >> strip_tac >> qexists_tac`((name =+ (K boolset)) (tyaof i),tmaof i)` >> conj_tac >- ( @@ -367,11 +374,12 @@ Theorem new_type_correct conj_tac >- fs[theory_ok_def] >> rw[type_ok_def,combinTheory.APPLY_UPDATE_THM] >> imp_res_tac ALOOKUP_MEM >> - fs[MEM_MAP,EXISTS_PROD] >> metis_tac[]) + fs[MEM_MAP,EXISTS_PROD] >> metis_tac[] +QED val eqsh_def = new_definition("eqsh",``eqsh = $=``) -Theorem new_type_definition_correct - `is_set_theory ^mem ⇒ +Theorem new_type_definition_correct: + is_set_theory ^mem ⇒ ∀ctxt name pred abs rep witness. (thyof ctxt,[]) |- Comb pred witness ∧ CLOSED pred ∧ @@ -379,8 +387,9 @@ Theorem new_type_definition_correct abs ∉ (FDOM (tmsof ctxt)) ∧ rep ∉ (FDOM (tmsof ctxt)) ∧ abs ≠ rep ⇒ - sound_update ctxt (TypeDefn name pred abs rep)` - (rw[sound_update_def,equal_on_def,models_def,LET_THM] >> + sound_update ctxt (TypeDefn name pred abs rep) +Proof + rw[sound_update_def,equal_on_def,models_def,LET_THM] >> Q.PAT_ABBREV_TAC`tys' = tysof ctxt |+ X` >> Q.PAT_ABBREV_TAC`tms' = tmsof ctxt |+ X |+ Y` >> imp_res_tac WELLTYPED_LEMMA >> @@ -788,30 +797,34 @@ Theorem new_type_definition_correct `f ' (@v. v <: a) = True` by ( SELECT_ELIM_TAC >> conj_tac >- metis_tac[] >> simp[Abbr`a`,mem_sub,holds_def] ) >> - metis_tac[mem_boolset]) + metis_tac[mem_boolset] +QED val _ = delete_const"eqsh" -Theorem updates_consistent - `is_set_theory ^mem ⇒ +Theorem updates_consistent: + is_set_theory ^mem ⇒ ∀upd ctxt. upd updates ctxt ⇒ theory_ok (thyof ctxt) ∧ (∀p. upd ≠ NewAxiom p) ⇒ - sound_update ctxt upd` - (strip_tac >> + sound_update ctxt upd +Proof + strip_tac >> ho_match_mp_tac updates_ind >> conj_tac >- simp[] >> conj_tac >- metis_tac[update_distinct,new_constant_correct] >> conj_tac >- metis_tac[update_distinct,new_specification_correct] >> conj_tac >- metis_tac[update_distinct,new_type_correct] >> - metis_tac[update_distinct,new_type_definition_correct]) + metis_tac[update_distinct,new_type_definition_correct] +QED -Theorem extends_consistent - `is_set_theory ^mem ⇒ +Theorem extends_consistent: + is_set_theory ^mem ⇒ ∀ctxt1 ctxt2. ctxt2 extends ctxt1 ⇒ ∀i. theory_ok (thyof ctxt1) ∧ i models (thyof ctxt1) ∧ (∀p. MEM (NewAxiom p) ctxt2 ⇒ MEM (NewAxiom p) ctxt1) ⇒ - ∃i'. equal_on (sigof ctxt1) i i' ∧ i' models (thyof ctxt2)` - (rw[] >> + ∃i'. equal_on (sigof ctxt1) i i' ∧ i' models (thyof ctxt2) +Proof + rw[] >> Q.ISPEC_THEN `λctxt. theory_ok (thyof ctxt) ∧ ∃ls. ctxt = ls ++ ctxt1 ∧ @@ -857,6 +870,7 @@ Theorem extends_consistent disch_then(qspec_then`i`mp_tac) >> simp[equal_on_refl] >> strip_tac >> first_x_assum match_mp_tac >> - fs[EVERY_MEM]) + fs[EVERY_MEM] +QED val _ = export_theory() diff --git a/candle/standard/semantics/holSemanticsExtraScript.sml b/candle/standard/semantics/holSemanticsExtraScript.sml index cb98fdc5c0..02bdd32291 100644 --- a/candle/standard/semantics/holSemanticsExtraScript.sml +++ b/candle/standard/semantics/holSemanticsExtraScript.sml @@ -9,78 +9,92 @@ val _ = Parse.hide "mem"; val mem = ``mem:'U->'U->bool`` -Theorem is_std_interpretation_is_type - `is_std_interpretation i ⇒ is_std_type_assignment (FST i)` - (Cases_on`i` >> simp[is_std_interpretation_def]) +Theorem is_std_interpretation_is_type: + is_std_interpretation i ⇒ is_std_type_assignment (FST i) +Proof + Cases_on`i` >> simp[is_std_interpretation_def] +QED (* typesem *) -Theorem typesem_inhabited - `is_set_theory ^mem ⇒ +Theorem typesem_inhabited: + is_set_theory ^mem ⇒ ∀tyenv δ τ ty. is_type_valuation τ ∧ is_type_assignment tyenv δ ∧ type_ok tyenv ty ⇒ - inhabited (typesem δ τ ty)` - (strip_tac >> gen_tac >> ho_match_mp_tac typesem_ind >> + inhabited (typesem δ τ ty) +Proof + strip_tac >> gen_tac >> ho_match_mp_tac typesem_ind >> simp[typesem_def,is_type_valuation_def,type_ok_def] >> rw[is_type_assignment_def,FLOOKUP_DEF] >> fs[FEVERY_ALL_FLOOKUP,FLOOKUP_DEF] >> first_x_assum(qspec_then`name`mp_tac) >> simp[] >> disch_then match_mp_tac >> - simp[EVERY_MAP] >> fs[EVERY_MEM] >> metis_tac[]) + simp[EVERY_MAP] >> fs[EVERY_MEM] >> metis_tac[] +QED -Theorem typesem_Fun - `∀δ τ dom rng. +Theorem typesem_Fun: + ∀δ τ dom rng. is_std_type_assignment δ ⇒ typesem δ τ (Fun dom rng) = - Funspace (typesem δ τ dom) (typesem δ τ rng)` - (rw[is_std_type_assignment_def,typesem_def]) + Funspace (typesem δ τ dom) (typesem δ τ rng) +Proof + rw[is_std_type_assignment_def,typesem_def] +QED -Theorem typesem_Bool - `∀δ τ. +Theorem typesem_Bool: + ∀δ τ. is_std_type_assignment δ ⇒ - typesem δ τ Bool = boolset` - (rw[is_std_type_assignment_def,typesem_def]) + typesem δ τ Bool = boolset +Proof + rw[is_std_type_assignment_def,typesem_def] +QED -Theorem typesem_TYPE_SUBST - `∀tyin ty δ τ. +Theorem typesem_TYPE_SUBST: + ∀tyin ty δ τ. typesem δ τ (TYPE_SUBST tyin ty) = - typesem δ (λx. typesem δ τ (TYPE_SUBST tyin (Tyvar x))) ty` - (ho_match_mp_tac TYPE_SUBST_ind >> simp[typesem_def] >> + typesem δ (λx. typesem δ τ (TYPE_SUBST tyin (Tyvar x))) ty +Proof + ho_match_mp_tac TYPE_SUBST_ind >> simp[typesem_def] >> rw[] >> rpt AP_TERM_TAC >> - simp[MAP_MAP_o,MAP_EQ_f]) + simp[MAP_MAP_o,MAP_EQ_f] +QED -Theorem typesem_tyvars - `∀δ τ ty τ'. +Theorem typesem_tyvars: + ∀δ τ ty τ'. (∀x. MEM x (tyvars ty) ⇒ τ' x = τ x) ⇒ - typesem δ τ' ty = typesem δ τ ty` - (ho_match_mp_tac typesem_ind >> + typesem δ τ' ty = typesem δ τ ty +Proof + ho_match_mp_tac typesem_ind >> simp[tyvars_def,MEM_FOLDR_LIST_UNION,typesem_def] >> rw[] >> rpt AP_TERM_TAC >> rw[MAP_EQ_f] >> - metis_tac[]) + metis_tac[] +QED -Theorem typesem_consts - `∀δ τ ty δ'. +Theorem typesem_consts: + ∀δ τ ty δ'. (∀name args. (Tyapp name args) subtype ty ⇒ δ' name = δ name ∨ ∃vars. args = MAP Tyvar vars ∧ δ' name (MAP τ vars) = δ name (MAP τ vars)) - ⇒ typesem δ' τ ty = typesem δ τ ty` - (ho_match_mp_tac typesem_ind >> + ⇒ typesem δ' τ ty = typesem δ τ ty +Proof + ho_match_mp_tac typesem_ind >> conj_tac >- simp[typesem_def] >> rw[] >> simp[typesem_def] >> fs[subtype_Tyapp] >> first_assum(qspecl_then[`name`,`args`]mp_tac) >> impl_tac >- rw[] >> strip_tac >- ( rw[] >> AP_TERM_TAC >> simp[MAP_EQ_f] >> metis_tac[] ) >> - simp[MAP_MAP_o,combinTheory.o_DEF,typesem_def,ETA_AX]) + simp[MAP_MAP_o,combinTheory.o_DEF,typesem_def,ETA_AX] +QED (* termsem *) -Theorem termsem_typesem - `is_set_theory ^mem ⇒ +Theorem termsem_typesem: + is_set_theory ^mem ⇒ ∀sig i tm v δ τ tmenv. δ = FST i ∧ τ = FST v ∧ is_valuation (tysof sig) δ v ∧ @@ -88,8 +102,9 @@ Theorem termsem_typesem is_std_type_assignment δ ∧ term_ok sig tm ∧ tmenv = tmsof sig ⇒ - termsem tmenv i v tm <: typesem δ τ (typeof tm)` - (strip_tac >> ntac 2 Cases >> Induct + termsem tmenv i v tm <: typesem δ τ (typeof tm) +Proof + strip_tac >> ntac 2 Cases >> Induct >- ( Cases_on`v`>> simp[termsem_def,is_valuation_def,is_term_valuation_def,term_ok_def] ) @@ -133,20 +148,23 @@ Theorem termsem_typesem first_x_assum (qspec_then`vv`mp_tac) >> simp[Abbr`vv`] >> disch_then match_mp_tac >> Cases_on`v`>> fs[is_valuation_def,is_term_valuation_def] >> - rw[combinTheory.APPLY_UPDATE_THM] >> rw[]) + rw[combinTheory.APPLY_UPDATE_THM] >> rw[] +QED -Theorem termsem_typesem_matchable - `is_set_theory ^mem ⇒ +Theorem termsem_typesem_matchable: + is_set_theory ^mem ⇒ ∀sig i tm v δ τ tmenv ty. δ = tyaof i ∧ τ = tyvof v ∧ is_valuation (tysof sig) δ v ∧ is_interpretation sig i ∧ is_std_type_assignment δ ∧ term_ok sig tm ∧ tmenv = tmsof sig ∧ ty = typesem δ τ (typeof tm) ⇒ - termsem tmenv i v tm <: ty` - (PROVE_TAC[termsem_typesem]) + termsem tmenv i v tm <: ty +Proof + PROVE_TAC[termsem_typesem] +QED -Theorem termsem_consts - `∀tmsig i v tm i'. +Theorem termsem_consts: + ∀tmsig i v tm i'. welltyped tm ∧ (∀name ty. VFREE_IN (Const name ty) tm ⇒ instance tmsig i' name ty (tyvof v) = @@ -155,14 +173,16 @@ Theorem termsem_consts typesem (tyaof i') (tyvof v) (typeof t) = typesem (tyaof i ) (tyvof v) (typeof t)) ⇒ - termsem tmsig i' v tm = termsem tmsig i v tm` - (Induct_on`tm` >> simp[termsem_def] >> rw[] + termsem tmsig i' v tm = termsem tmsig i v tm +Proof + Induct_on`tm` >> simp[termsem_def] >> rw[] >- ( fs[subterm_Comb] >> metis_tac[]) >> simp[termsem_def] >> fsrw_tac[boolSimps.DNF_ss][subterm_Abs] >> - rpt AP_TERM_TAC >> simp[FUN_EQ_THM]) + rpt AP_TERM_TAC >> simp[FUN_EQ_THM] +QED val Equalsem = is_std_interpretation_def @@ -170,12 +190,13 @@ val Equalsem = |> strip_conj |> last |> strip_comb |> snd |> last -Theorem termsem_Equal - `is_set_theory ^mem ⇒ +Theorem termsem_Equal: + is_set_theory ^mem ⇒ ∀Γ i v ty. is_structure Γ i v ∧ type_ok (tysof Γ) ty ⇒ - termsem (tmsof Γ) i v (Equal ty) = ^Equalsem [typesem (FST i) (FST v) ty]` - (rw[termsem_def,LET_THM] >> fs[is_structure_def] >> + termsem (tmsof Γ) i v (Equal ty) = ^Equalsem [typesem (FST i) (FST v) ty] +Proof + rw[termsem_def,LET_THM] >> fs[is_structure_def] >> qspecl_then[`tmsof Γ`,`i`,`(strlit "=")`]mp_tac instance_def >> fs[is_std_sig_def]>> disch_then(qspec_then`[(ty,Tyvar(strlit "A"))]`mp_tac)>> simp[REV_ASSOCD] >> disch_then kall_tac >> @@ -193,18 +214,20 @@ Theorem termsem_Equal fs[is_std_interpretation_def,interprets_def] >> `MAP implode (STRING_SORT ["A"]) = [strlit "A"]` by simp[STRING_SORT_def,INORDER_INSERT_def,mlstringTheory.implode_def] >> - simp[] >> simp[Abbr`tt`,REV_ASSOCD]) + simp[] >> simp[Abbr`tt`,REV_ASSOCD] +QED (* equations *) -Theorem termsem_equation - `is_set_theory ^mem ⇒ +Theorem termsem_equation: + is_set_theory ^mem ⇒ ∀sig i v s t tmenv. is_structure sig i v ∧ term_ok sig (s === t) ∧ tmenv = tmsof sig - ⇒ termsem tmenv i v (s === t) = Boolean (termsem tmenv i v s = termsem tmenv i v t)` - (rw[] >> + ⇒ termsem tmenv i v (s === t) = Boolean (termsem tmenv i v s = termsem tmenv i v t) +Proof + rw[] >> `is_std_sig sig ∧ is_std_interpretation i` by fs[is_structure_def] >> fs[term_ok_equation] >> imp_res_tac term_ok_type_ok >> @@ -223,12 +246,13 @@ Theorem termsem_equation match_mp_tac (UNDISCH apply_abstract) >> unabbrev_all_tac >> simp[] >> metis_tac[termsem_typesem,boolean_in_boolset,is_structure_def] ) >> - unabbrev_all_tac >> simp[]) + unabbrev_all_tac >> simp[] +QED (* aconv *) -Theorem termsem_raconv - `∀env tp. RACONV env tp ⇒ +Theorem termsem_raconv: + ∀env tp. RACONV env tp ⇒ ∀Γ i v1 v2. (FST v1 = FST v2) ∧ (∀x1 ty1 x2 ty2. @@ -238,8 +262,9 @@ Theorem termsem_raconv EVERY (λ(x,y). welltyped x ∧ welltyped y ∧ typeof x = typeof y) env ∧ welltyped (FST tp) ∧ welltyped (SND tp) ⇒ - termsem Γ i v1 (FST tp) = termsem Γ i v2 (SND tp)` - (ho_match_mp_tac RACONV_strongind >> + termsem Γ i v1 (FST tp) = termsem Γ i v2 (SND tp) +Proof + ho_match_mp_tac RACONV_strongind >> rpt conj_tac >> simp[termsem_def] >> TRY (metis_tac[]) >> rpt gen_tac >> strip_tac >> @@ -252,47 +277,55 @@ Theorem termsem_raconv rw[FUN_EQ_THM] >> first_x_assum (match_mp_tac o MP_CANON) >> simp[ALPHAVARS_def,combinTheory.APPLY_UPDATE_THM] >> - rw[] >> fs[]) + rw[] >> fs[] +QED -Theorem termsem_aconv - `∀Γ i v t1 t2. ACONV t1 t2 ∧ welltyped t1 ∧ welltyped t2 ⇒ termsem Γ i v t1 = termsem Γ i v t2` - (rw[ACONV_def] >> +Theorem termsem_aconv: + ∀Γ i v t1 t2. ACONV t1 t2 ∧ welltyped t1 ∧ welltyped t2 ⇒ termsem Γ i v t1 = termsem Γ i v t2 +Proof + rw[ACONV_def] >> imp_res_tac termsem_raconv >> rfs[ALPHAVARS_def] >> - metis_tac[ACONV_def]) + metis_tac[ACONV_def] +QED (* semantics only depends on valuation of free variables *) -Theorem termsem_frees - `∀Γ i t v1 v2. +Theorem termsem_frees: + ∀Γ i t v1 v2. welltyped t ∧ FST v1 = FST v2 ∧ (∀x ty. VFREE_IN (Var x ty) t ⇒ SND v1 (x,ty) = SND v2 (x,ty)) - ⇒ termsem Γ i v1 t = termsem Γ i v2 t` - (ntac 2 gen_tac >> Induct >> + ⇒ termsem Γ i v1 t = termsem Γ i v2 t +Proof + ntac 2 gen_tac >> Induct >> simp[termsem_def] >- metis_tac[] >> rw[] >> rw[termsem_def] >> rpt AP_TERM_TAC >> rw[FUN_EQ_THM] >> first_x_assum match_mp_tac >> rw[combinTheory.APPLY_UPDATE_THM,FUN_EQ_THM] >> - first_x_assum match_mp_tac >> fs[]) + first_x_assum match_mp_tac >> fs[] +QED -Theorem typesem_frees - `∀ty τ1 τ2 δ. +Theorem typesem_frees: + ∀ty τ1 τ2 δ. (∀a. MEM a (tyvars ty) ⇒ τ1 a = τ2 a) ⇒ - typesem δ τ1 ty = typesem δ τ2 ty` - (ho_match_mp_tac type_ind >> + typesem δ τ1 ty = typesem δ τ2 ty +Proof + ho_match_mp_tac type_ind >> simp[tyvars_def,MEM_FOLDR_LIST_UNION,typesem_def,PULL_EXISTS] >> rw[] >> rpt AP_TERM_TAC >> simp[MAP_EQ_f] >> - fs[EVERY_MEM] >> metis_tac[]) + fs[EVERY_MEM] >> metis_tac[] +QED -Theorem termsem_tyfrees - `∀Γ i t v1 v2 tmenv. +Theorem termsem_tyfrees: + ∀Γ i t v1 v2 tmenv. term_ok Γ t ∧ SND v1 = SND v2 ∧ (∀a. MEM a (tvars t) ⇒ FST v1 a = FST v2 a) ∧ tmenv = tmsof Γ - ⇒ termsem tmenv i v1 t = termsem tmenv i v2 t` - (ntac 2 gen_tac >> Induct >> + ⇒ termsem tmenv i v1 t = termsem tmenv i v2 t +Proof + ntac 2 gen_tac >> Induct >> simp[termsem_def,tvars_def,term_ok_def] >- ( rw[] >> qmatch_abbrev_tac`instance (tmsof Γ) i name ty τ = X` >> @@ -313,12 +346,13 @@ Theorem termsem_tyfrees match_mp_tac typesem_tyvars >> metis_tac[tyvars_typeof_subset_tvars,SUBSET_DEF,term_ok_welltyped,WELLTYPED] ) >> rw[] >> rpt AP_TERM_TAC >> - unabbrev_all_tac >> rw[FUN_EQ_THM]) + unabbrev_all_tac >> rw[FUN_EQ_THM] +QED (* semantics of substitution *) -Theorem termsem_simple_subst - `∀tm ilist. +Theorem termsem_simple_subst: + ∀tm ilist. welltyped tm ∧ DISJOINT (set (bv_names tm)) {y | ∃ty u. VFREE_IN (Var y ty) u ∧ MEM u (MAP FST ilist)} ∧ (∀s s'. MEM (s',s) ilist ⇒ ∃x ty. s = Var x ty ∧ s' has_type ty) @@ -329,8 +363,9 @@ Theorem termsem_simple_subst (FST v, SND v =++ MAP ((dest_var ## termsem Γ i v) o (λ(s',s). (s,s'))) (REVERSE ilist)) - tm` - (Induct >> simp[termsem_def] >- ( + tm +Proof + Induct >> simp[termsem_def] >- ( simp[REV_ASSOCD_ALOOKUP,APPLY_UPDATE_LIST_ALOOKUP,rich_listTheory.MAP_REVERSE] >> rw[] >> BasicProvers.CASE_TAC >> rw[termsem_def] >- ( imp_res_tac ALOOKUP_FAILS >> @@ -393,10 +428,11 @@ Theorem termsem_simple_subst rw[combinTheory.APPLY_UPDATE_THM] >> imp_res_tac ALOOKUP_MEM >> fs[Abbr`ls`,MEM_MAP,FORALL_PROD,EXISTS_PROD] >> - metis_tac[welltyped_def]) + metis_tac[welltyped_def] +QED -Theorem termsem_VSUBST - ` ∀tm ilist. +Theorem termsem_VSUBST: + ∀tm ilist. welltyped tm ∧ (∀s s'. MEM (s',s) ilist ⇒ ∃x ty. s = Var x ty ∧ s' has_type ty) ⇒ ∀Γ i v. @@ -404,8 +440,9 @@ Theorem termsem_VSUBST termsem Γ i (FST v, SND v =++ MAP ((dest_var ## termsem Γ i v) o (λ(s',s). (s,s'))) - (REVERSE ilist)) tm` - (rw[] >> + (REVERSE ilist)) tm +Proof + rw[] >> Q.ISPECL_THEN[`{y | ∃ty u. VFREE_IN (Var y ty) u ∧ MEM u (MAP FST ilist)}`,`tm`]mp_tac fresh_term_def >> simp[] >> Q.PAT_ABBREV_TAC`fm = fresh_term X tm` >> strip_tac >> @@ -418,12 +455,13 @@ Theorem termsem_VSUBST `VSUBST ilist fm = simple_subst ilist fm` by metis_tac[VSUBST_simple_subst] >> rw[] >> - metis_tac[termsem_simple_subst,termsem_aconv]) + metis_tac[termsem_simple_subst,termsem_aconv] +QED (* semantics of instantiation *) -Theorem termsem_simple_inst - `∀Γ tm tyin tmenv. +Theorem termsem_simple_inst: + ∀Γ tm tyin tmenv. welltyped tm ∧ term_ok Γ tm ∧ ALL_DISTINCT (bv_names tm) ∧ DISJOINT (set (bv_names tm)) {x | ∃ty. VFREE_IN (Var x ty) tm} ∧ @@ -434,8 +472,9 @@ Theorem termsem_simple_inst termsem tmenv i ((λx. typesem (FST i) (FST v) (TYPE_SUBST tyin (Tyvar x))), (λ(x,ty). SND v (x, TYPE_SUBST tyin ty))) - tm` - (Cases >> Induct >> simp[termsem_def,term_ok_def] >- ( + tm +Proof + Cases >> Induct >> simp[termsem_def,term_ok_def] >- ( rw[] >> rw[TYPE_SUBST_compose] >> qmatch_abbrev_tac`instance sig int name (TYPE_SUBST i2 ty0) t1 = instance sig int name (TYPE_SUBST i1 ty0) t2` >> @@ -468,18 +507,20 @@ Theorem termsem_simple_inst match_mp_tac termsem_frees >> rw[] >> rw[combinTheory.APPLY_UPDATE_THM] >> - metis_tac[]) + metis_tac[] +QED -Theorem termsem_INST - `∀Γ tm tyin tmenv. +Theorem termsem_INST: + ∀Γ tm tyin tmenv. term_ok Γ tm ∧ tmenv = tmsof Γ ⇒ ∀i v. termsem tmenv i v (INST tyin tm) = termsem tmenv i ((λx. typesem (FST i) (FST v) (TYPE_SUBST tyin (Tyvar x))), (λ(x,ty). SND v (x, TYPE_SUBST tyin ty))) - tm` - (rw[] >> imp_res_tac term_ok_welltyped >> + tm +Proof + rw[] >> imp_res_tac term_ok_welltyped >> Q.ISPECL_THEN[`{x | ∃ty. VFREE_IN (Var x ty) tm}`,`tm`]mp_tac fresh_term_def >> simp[] >> Q.PAT_ABBREV_TAC`fm = fresh_term X tm` >> strip_tac >> @@ -494,17 +535,19 @@ Theorem termsem_INST `INST tyin fm = simple_inst tyin fm` by metis_tac[INST_simple_inst] >> rw[] >> - metis_tac[SIMP_RULE(srw_ss())[]termsem_simple_inst,termsem_aconv,term_ok_aconv]) + metis_tac[SIMP_RULE(srw_ss())[]termsem_simple_inst,termsem_aconv,term_ok_aconv] +QED (* extending the context doesn't change the semantics *) -Theorem termsem_extend - `∀tyenv tmenv tyenv' tmenv' tm. +Theorem termsem_extend: + ∀tyenv tmenv tyenv' tmenv' tm. tmenv ⊑ tmenv' ∧ term_ok (tyenv,tmenv) tm ⇒ ∀i v. termsem tmenv' i v tm = - termsem tmenv i v tm` - (ntac 4 gen_tac >> Induct >> simp[termsem_def,term_ok_def] >> + termsem tmenv i v tm +Proof + ntac 4 gen_tac >> Induct >> simp[termsem_def,term_ok_def] >> rw[] >> simp[termsem_def] >> qmatch_abbrev_tac`X = instance sig int name ty t` >> qspecl_then[`sig`,`int`,`name`,`ty`]mp_tac instance_def >> @@ -513,22 +556,27 @@ Theorem termsem_extend qmatch_abbrev_tac`instance sig int name ty t = X` >> qspecl_then[`sig`,`int`,`name`,`ty`]mp_tac instance_def >> imp_res_tac FLOOKUP_SUBMAP >> - fs[Abbr`sig`,Abbr`ty`]) - -Theorem is_valuation_reduce - `∀tyenv tyenv' δ v. tyenv ⊑ tyenv' ∧ is_valuation tyenv' δ v ⇒ - is_valuation tyenv δ v` - (rw[is_valuation_def,is_term_valuation_def] >> - metis_tac[type_ok_extend]) - -Theorem satisfies_extend - `∀tyenv tmenv tyenv' tmenv' tm i h c. + fs[Abbr`sig`,Abbr`ty`] +QED + +Theorem is_valuation_reduce: + ∀tyenv tyenv' δ v. tyenv ⊑ tyenv' ∧ is_valuation tyenv' δ v ⇒ + is_valuation tyenv δ v +Proof + rw[is_valuation_def,is_term_valuation_def] >> + metis_tac[type_ok_extend] +QED + +Theorem satisfies_extend: + ∀tyenv tmenv tyenv' tmenv' tm i h c. tmenv ⊑ tmenv' ∧ tyenv ⊑ tyenv' ∧ EVERY (term_ok (tyenv,tmenv)) (c::h) ∧ i satisfies ((tyenv,tmenv),h,c) ⇒ - i satisfies ((tyenv',tmenv'),h,c)` - (rw[satisfies_def] >> fs[EVERY_MEM] >> - metis_tac[term_ok_extend,termsem_extend,is_valuation_reduce]) + i satisfies ((tyenv',tmenv'),h,c) +Proof + rw[satisfies_def] >> fs[EVERY_MEM] >> + metis_tac[term_ok_extend,termsem_extend,is_valuation_reduce] +QED (* one interpretation being compatible with another in a signature *) @@ -537,45 +585,56 @@ val equal_on_def = Define` (∀name. name ∈ FDOM (tysof sig) ⇒ tyaof i' name = tyaof i name) ∧ (∀name. name ∈ FDOM (tmsof sig) ⇒ tmaof i' name = tmaof i name)` -Theorem equal_on_refl - `∀sig i. equal_on sig i i` - (rw[equal_on_def]) - -Theorem equal_on_sym - `∀sig i i'. equal_on sig i i' ⇒ equal_on sig i' i` - (rw[equal_on_def] >> PROVE_TAC[]) - -Theorem equal_on_trans - `∀sig i1 i2 i3. equal_on sig i1 i2 ∧ equal_on sig i2 i3 - ⇒ equal_on sig i1 i3` - (rw[equal_on_def] >> metis_tac[]) - -Theorem equal_on_interprets - `∀sig i1 i2 name args ty m. +Theorem equal_on_refl: + ∀sig i. equal_on sig i i +Proof + rw[equal_on_def] +QED + +Theorem equal_on_sym: + ∀sig i i'. equal_on sig i i' ⇒ equal_on sig i' i +Proof + rw[equal_on_def] >> PROVE_TAC[] +QED + +Theorem equal_on_trans: + ∀sig i1 i2 i3. equal_on sig i1 i2 ∧ equal_on sig i2 i3 + ⇒ equal_on sig i1 i3 +Proof + rw[equal_on_def] >> metis_tac[] +QED + +Theorem equal_on_interprets: + ∀sig i1 i2 name args ty m. equal_on sig i1 i2 ∧ tmaof i1 interprets name on args as m ∧ (FLOOKUP (tmsof sig) name = SOME ty) ∧ type_ok (tysof sig) ty ∧ (set (tyvars ty) = set args) ⇒ - tmaof i2 interprets name on args as m` - (rw[equal_on_def,interprets_def] >> + tmaof i2 interprets name on args as m +Proof + rw[equal_on_def,interprets_def] >> qsuff_tac`tmaof i2 name = tmaof i1 name` >- metis_tac[] >> first_x_assum match_mp_tac >> - fs[FLOOKUP_DEF]) + fs[FLOOKUP_DEF] +QED -Theorem equal_on_reduce - `∀ls ctxt i i'. equal_on (sigof (ls++ctxt)) i i' ∧ +Theorem equal_on_reduce: + ∀ls ctxt i i'. equal_on (sigof (ls++ctxt)) i i' ∧ DISJOINT (FDOM (tysof ls)) (FDOM (tysof ctxt)) ∧ DISJOINT (FDOM (tmsof ls)) (FDOM (tmsof ctxt)) - ⇒ equal_on (sigof ctxt) i i'` - (rw[equal_on_def]) + ⇒ equal_on (sigof ctxt) i i' +Proof + rw[equal_on_def] +QED (* semantics only depends on interpretation of things in the term's signature *) -Theorem typesem_sig - `∀ty τ δ δ' tyenv. type_ok tyenv ty ∧ (∀name. name ∈ FDOM tyenv ⇒ δ' name = δ name) ⇒ - typesem δ' τ ty = typesem δ τ ty` - (ho_match_mp_tac type_ind >> simp[typesem_def,type_ok_def] >> rw[] >> +Theorem typesem_sig: + ∀ty τ δ δ' tyenv. type_ok tyenv ty ∧ (∀name. name ∈ FDOM tyenv ⇒ δ' name = δ name) ⇒ + typesem δ' τ ty = typesem δ τ ty +Proof + ho_match_mp_tac type_ind >> simp[typesem_def,type_ok_def] >> rw[] >> qmatch_abbrev_tac`δ' name args1 = δ name args2` >> `args1 = args2` by ( unabbrev_all_tac >> @@ -584,14 +643,16 @@ Theorem typesem_sig metis_tac[] ) >> simp[] >> AP_THM_TAC >> first_x_assum match_mp_tac >> - fs[FLOOKUP_DEF]) + fs[FLOOKUP_DEF] +QED -Theorem termsem_sig - `∀tm Γ i v i' tmenv. +Theorem termsem_sig: + ∀tm Γ i v i' tmenv. is_std_sig Γ ∧ term_ok Γ tm ∧ tmenv = tmsof Γ ∧ equal_on Γ i i' ⇒ - termsem tmenv i' v tm = termsem tmenv i v tm` - (REWRITE_TAC[equal_on_def] >> + termsem tmenv i' v tm = termsem tmenv i v tm +Proof + REWRITE_TAC[equal_on_def] >> Induct >> simp[termsem_def] >- ( rw[term_ok_def] >> imp_res_tac instance_def >> @@ -621,77 +682,90 @@ Theorem termsem_sig metis_tac[term_ok_type_ok] ) >> simp[] >> rpt AP_TERM_TAC >> rw[FUN_EQ_THM] >> unabbrev_all_tac >> fs[] >> - fs[FORALL_PROD] >> res_tac >> fs[]) + fs[FORALL_PROD] >> res_tac >> fs[] +QED -Theorem satisfies_sig - `∀i i' sig h c. +Theorem satisfies_sig: + ∀i i' sig h c. is_std_sig sig ∧ EVERY (term_ok sig) (c::h) ∧ equal_on sig i i' ∧ i satisfies (sig,h,c) ⇒ - i' satisfies (sig,h,c)` - (rw[satisfies_def] >> + i' satisfies (sig,h,c) +Proof + rw[satisfies_def] >> qsuff_tac`termsem (tmsof sig) i v c = True` >- metis_tac[termsem_sig] >> first_x_assum match_mp_tac >> reverse conj_tac >- ( fs[EVERY_MEM] >> metis_tac[termsem_sig] ) >> fs[is_valuation_def] >> fs[is_term_valuation_def] >> - metis_tac[typesem_sig,equal_on_def]) + metis_tac[typesem_sig,equal_on_def] +QED (* valuations exist *) -Theorem term_valuation_exists - `is_set_theory ^mem ⇒ +Theorem term_valuation_exists: + is_set_theory ^mem ⇒ ∀tyenv δ τ. is_type_valuation τ ∧ is_type_assignment tyenv δ ⇒ - ∃σ. is_valuation tyenv δ (τ,σ)` - (rw[is_valuation_def,is_term_valuation_def] >> + ∃σ. is_valuation tyenv δ (τ,σ) +Proof + rw[is_valuation_def,is_term_valuation_def] >> qexists_tac`λ(x,ty). @v. v <: typesem δ τ ty` >> rw[] >> - metis_tac[typesem_inhabited]) + metis_tac[typesem_inhabited] +QED val is_type_valuation_exists = Q.prove( `is_set_theory ^mem ⇒ is_type_valuation (K boolset)`, simp[is_type_valuation_def] >> metis_tac[boolean_in_boolset]) |> UNDISCH -Theorem valuation_exists - `is_set_theory ^mem ⇒ +Theorem valuation_exists: + is_set_theory ^mem ⇒ ∀tyenv δ. is_type_assignment tyenv δ ⇒ - ∃v. is_valuation tyenv δ v` - (rw[is_valuation_def] >> + ∃v. is_valuation tyenv δ v +Proof + rw[is_valuation_def] >> qexists_tac`K boolset, λ(x,ty). @v. v <: typesem δ (K boolset) ty` >> conj_asm1_tac >- simp[is_type_valuation_exists] >> - fs[is_term_valuation_def] >> metis_tac[typesem_inhabited]) + fs[is_term_valuation_def] >> metis_tac[typesem_inhabited] +QED -Theorem extend_valuation_exists - `is_set_theory ^mem ⇒ +Theorem extend_valuation_exists: + is_set_theory ^mem ⇒ ∀tysig δ v tysig'. is_valuation tysig δ v ∧ tysig ⊑ tysig' ∧ is_type_assignment tysig' δ ⇒ ∃v'. is_valuation tysig' δ v' ∧ (tyvof v' = tyvof v) ∧ - (∀x ty. type_ok tysig ty ⇒ (tmvof v (x,ty) = tmvof v' (x,ty)))` - (rw[] >> simp[EXISTS_PROD] >> + (∀x ty. type_ok tysig ty ⇒ (tmvof v (x,ty) = tmvof v' (x,ty))) +Proof + rw[] >> simp[EXISTS_PROD] >> fs[is_valuation_def,is_term_valuation_def] >> qexists_tac`λ(x,ty). if type_ok tysig ty then tmvof v (x,ty) else @m. m <: typesem δ (tyvof v) ty` >> - rw[] >> metis_tac[typesem_inhabited]) - -Theorem is_type_valuation_UPDATE_LIST - `∀t ls. is_type_valuation t ∧ EVERY (inhabited o SND) ls ⇒ - is_type_valuation (t =++ ls)` - (rw[is_type_valuation_def,APPLY_UPDATE_LIST_ALOOKUP] >> + rw[] >> metis_tac[typesem_inhabited] +QED + +Theorem is_type_valuation_UPDATE_LIST: + ∀t ls. is_type_valuation t ∧ EVERY (inhabited o SND) ls ⇒ + is_type_valuation (t =++ ls) +Proof + rw[is_type_valuation_def,APPLY_UPDATE_LIST_ALOOKUP] >> BasicProvers.CASE_TAC >> rw[] >> imp_res_tac ALOOKUP_MEM >> - fs[EVERY_MEM,FORALL_PROD] >> metis_tac[]) + fs[EVERY_MEM,FORALL_PROD] >> metis_tac[] +QED (* identity instance *) -Theorem identity_instance - `∀tmenv (i:'U interpretation) name ty τ. FLOOKUP tmenv name = SOME ty ⇒ - instance tmenv i name ty = λτ. tmaof i name (MAP τ (MAP implode (STRING_SORT (MAP explode (tyvars ty)))))` - (rw[] >> +Theorem identity_instance: + ∀tmenv (i:'U interpretation) name ty τ. FLOOKUP tmenv name = SOME ty ⇒ + instance tmenv i name ty = λτ. tmaof i name (MAP τ (MAP implode (STRING_SORT (MAP explode (tyvars ty))))) +Proof + rw[] >> qspecl_then[`tmenv`,`i`,`name`,`ty`,`ty`,`[]`]mp_tac instance_def >> - rw[FUN_EQ_THM,typesem_def,combinTheory.o_DEF,ETA_AX]) + rw[FUN_EQ_THM,typesem_def,combinTheory.o_DEF,ETA_AX] +QED (* special cases of interprets *) @@ -700,46 +774,54 @@ val interprets_nil = save_thm("interprets_nil", interprets_def |> SPEC_ALL |> Q.GEN`vs` |> Q.SPEC`[]` |> SIMP_RULE (std_ss++listSimps.LIST_ss) [rwt] |> GEN_ALL) -Theorem interprets_one - `i interprets name on [v] as f ⇔ - (∀x. inhabited x ⇒ (i name [x] = f [x]))` - (rw[interprets_def,EQ_IMP_THM] >> +Theorem interprets_one: + i interprets name on [v] as f ⇔ + (∀x. inhabited x ⇒ (i name [x] = f [x])) +Proof + rw[interprets_def,EQ_IMP_THM] >> TRY ( first_x_assum match_mp_tac >> fs[is_type_valuation_def] ) >> first_x_assum(qspec_then`K x`mp_tac) >> simp[] >> disch_then match_mp_tac >> - rw[is_type_valuation_def] >> metis_tac[]) + rw[is_type_valuation_def] >> metis_tac[] +QED (* for models, reducing the context *) -Theorem is_type_assignment_reduce - `∀tyenv tyenv' δ. +Theorem is_type_assignment_reduce: + ∀tyenv tyenv' δ. tyenv ⊑ tyenv' ∧ is_type_assignment tyenv' δ ⇒ - is_type_assignment tyenv δ` - (rw[is_type_assignment_def] >> - imp_res_tac FEVERY_SUBMAP) - -Theorem is_term_assignment_reduce - `∀tmenv tmenv' δ γ. + is_type_assignment tyenv δ +Proof + rw[is_type_assignment_def] >> + imp_res_tac FEVERY_SUBMAP +QED + +Theorem is_term_assignment_reduce: + ∀tmenv tmenv' δ γ. tmenv ⊑ tmenv' ∧ is_term_assignment tmenv' δ γ ⇒ - is_term_assignment tmenv δ γ` - (rw[is_term_assignment_def] >> - imp_res_tac FEVERY_SUBMAP) - -Theorem is_interpretation_reduce - `∀i tyenv tmenv tyenv' tmenv'. + is_term_assignment tmenv δ γ +Proof + rw[is_term_assignment_def] >> + imp_res_tac FEVERY_SUBMAP +QED + +Theorem is_interpretation_reduce: + ∀i tyenv tmenv tyenv' tmenv'. tyenv ⊑ tyenv' ∧ tmenv ⊑ tmenv' ∧ is_interpretation (tyenv',tmenv') i ⇒ - is_interpretation (tyenv,tmenv) i` - (Cases >> rw[is_interpretation_def] >> + is_interpretation (tyenv,tmenv) i +Proof + Cases >> rw[is_interpretation_def] >> imp_res_tac is_type_assignment_reduce >> - imp_res_tac is_term_assignment_reduce) + imp_res_tac is_term_assignment_reduce +QED -Theorem is_valuation_extend_sig - `is_set_theory ^mem ⇒ +Theorem is_valuation_extend_sig: + is_set_theory ^mem ⇒ ∀tyenv tyenv' tyass v. is_valuation tyenv tyass v ∧ is_type_assignment tyenv' tyass ∧ @@ -747,18 +829,20 @@ Theorem is_valuation_extend_sig ∃v'. (tyvof v' = tyvof v) ∧ (∀ty. type_ok tyenv ty ⇒ ∀x. tmvof v' (x,ty) = tmvof v (x,ty)) ∧ - is_valuation tyenv' tyass v'` - (rw[is_valuation_def] >> + is_valuation tyenv' tyass v' +Proof + rw[is_valuation_def] >> fs[is_term_valuation_def] >> simp[EXISTS_PROD] >> qexists_tac`λp. if type_ok tyenv (SND p) then tmvof v p else @m. m <: typesem tyass (tyvof v) (SND p)` >> simp[] >> rw[] >> SELECT_ELIM_TAC >> simp[] >> match_mp_tac (UNDISCH typesem_inhabited) >> - metis_tac[]) + metis_tac[] +QED -Theorem satisfies_reduce - `is_set_theory ^mem ⇒ +Theorem satisfies_reduce: + is_set_theory ^mem ⇒ ∀i tyenv tmenv tyenv' tmenv' h c. is_std_sig (tyenv,tmenv) ∧ tyenv ⊑ tyenv' ∧ @@ -766,8 +850,9 @@ Theorem satisfies_reduce EVERY (term_ok (tyenv,tmenv)) (c::h) ∧ is_type_assignment tyenv' (tyaof i) ∧ i satisfies ((tyenv',tmenv'),h,c) ⇒ - i satisfies ((tyenv,tmenv),h,c)` - (rw[satisfies_def] >> + i satisfies ((tyenv,tmenv),h,c) +Proof + rw[satisfies_def] >> qspecl_then[`tyenv`,`tyenv'`,`tyaof i`,`v`]mp_tac (UNDISCH is_valuation_extend_sig) >> simp[] >> strip_tac >> first_x_assum(qspec_then`v'`mp_tac) >> simp[] >> @@ -786,23 +871,26 @@ Theorem satisfies_reduce imp_res_tac VFREE_IN_types_in >> fs[] ) >> impl_tac >- ( fs[EVERY_MEM] ) >> - simp[]) + simp[] +QED -Theorem models_reduce - `is_set_theory ^mem ⇒ +Theorem models_reduce: + is_set_theory ^mem ⇒ ∀i tyenv tmenv axs tyenv' tmenv' axs'. is_std_sig (tyenv,tmenv) ∧ tyenv ⊑ tyenv' ∧ tmenv ⊑ tmenv' ∧ (axs ⊆ axs') ∧ i models ((tyenv',tmenv'),axs') ∧ (∀p. p ∈ axs ⇒ (term_ok (tyenv,tmenv)) p) ⇒ - i models ((tyenv,tmenv),axs)` - (strip_tac >> + i models ((tyenv,tmenv),axs) +Proof + strip_tac >> Cases >> rw[models_def] >> imp_res_tac is_interpretation_reduce >> fs[SUBSET_DEF] >> match_mp_tac(MP_CANON satisfies_reduce) >> simp[] >> fs[is_interpretation_def] >> - metis_tac[]) + metis_tac[] +QED val _ = export_theory() diff --git a/candle/standard/semantics/holSoundnessScript.sml b/candle/standard/semantics/holSoundnessScript.sml index 1dbf3fa485..f5c78840c1 100644 --- a/candle/standard/semantics/holSoundnessScript.sml +++ b/candle/standard/semantics/holSoundnessScript.sml @@ -10,8 +10,8 @@ val _ = Parse.hide "mem"; val mem = ``mem:'U->'U-> bool`` -Theorem binary_inference_rule - `is_set_theory ^mem ⇒ +Theorem binary_inference_rule: + is_set_theory ^mem ⇒ ∀thy h1 h2 p1 p2 q. q has_type Bool ∧ term_ok (sigof thy) q ∧ (∀i v. is_structure (sigof thy) i v ∧ @@ -19,8 +19,9 @@ Theorem binary_inference_rule termsem (tmsof thy) i v p2 = True ⇒ termsem (tmsof thy) i v q = True) ∧ (thy,h1) |= p1 ∧ (thy,h2) |= p2 - ⇒ (thy, term_union h1 h2) |= q` - (strip_tac >> + ⇒ (thy, term_union h1 h2) |= q +Proof + strip_tac >> rpt gen_tac >> strip_tac >> fs[entails_def,EVERY_term_union] >> rw[] >> rpt (first_x_assum(qspec_then`i`mp_tac)>>rw[]) >> @@ -31,15 +32,17 @@ Theorem binary_inference_rule fs[EVERY_MEM] >> rw[] >> qmatch_assum_abbrev_tac`MEM t h` >> qspecl_then[`h1`,`h2`,`t`]mp_tac MEM_term_union >> simp[] >> strip_tac >> - metis_tac[MEM_term_union_imp,termsem_aconv,term_ok_welltyped]) + metis_tac[MEM_term_union_imp,termsem_aconv,term_ok_welltyped] +QED -Theorem ABS_correct - `is_set_theory ^mem ⇒ +Theorem ABS_correct: + is_set_theory ^mem ⇒ ∀thy x ty h l r. ¬EXISTS (VFREE_IN (Var x ty)) h ∧ type_ok (tysof thy) ty ∧ (thy,h) |= l === r - ⇒ (thy,h) |= Abs (Var x ty) l === Abs (Var x ty) r` - (rw[] >> fs[entails_def] >> + ⇒ (thy,h) |= Abs (Var x ty) l === Abs (Var x ty) r +Proof + rw[] >> fs[entails_def] >> imp_res_tac theory_ok_sig >> conj_asm1_tac >- fs[term_ok_equation,term_ok_def] >> conj_asm1_tac >- fs[EQUATION_HAS_TYPE_BOOL] >> rw[] >> @@ -70,20 +73,24 @@ Theorem ABS_correct qsuff_tac`termsem (tmsof (sigof thy)) i vv t = termsem (tmsof (sigof thy)) i v t`>-metis_tac[] >> match_mp_tac termsem_frees >> simp[Abbr`vv`,combinTheory.APPLY_UPDATE_THM] >> - rw[] >> metis_tac[term_ok_welltyped]) + rw[] >> metis_tac[term_ok_welltyped] +QED -Theorem ASSUME_correct - `∀thy p. +Theorem ASSUME_correct: + ∀thy p. theory_ok thy ∧ p has_type Bool ∧ term_ok (sigof thy) p - ⇒ (thy,[p]) |= p` - (rw[entails_def,satisfies_def]) + ⇒ (thy,[p]) |= p +Proof + rw[entails_def,satisfies_def] +QED -Theorem BETA_correct - `is_set_theory ^mem ⇒ +Theorem BETA_correct: + is_set_theory ^mem ⇒ ∀thy x ty t. theory_ok thy ∧ type_ok (tysof thy) ty ∧ term_ok (sigof thy) t ⇒ - (thy,[]) |= Comb (Abs (Var x ty) t) (Var x ty) === t` - (rw[] >> simp[entails_def] >> + (thy,[]) |= Comb (Abs (Var x ty) t) (Var x ty) === t +Proof + rw[] >> simp[entails_def] >> imp_res_tac theory_ok_sig >> imp_res_tac term_ok_welltyped >> conj_asm1_tac >- ( simp[term_ok_equation,term_ok_def] ) >> @@ -109,17 +116,19 @@ Theorem BETA_correct rw[combinTheory.APPLY_UPDATE_THM] >> metis_tac[]) >> simp[Abbr`f`,Abbr`e`] >> - rw[combinTheory.APPLY_UPDATE_ID]) + rw[combinTheory.APPLY_UPDATE_ID] +QED -Theorem DEDUCT_ANTISYM_correct - `is_set_theory ^mem ⇒ +Theorem DEDUCT_ANTISYM_correct: + is_set_theory ^mem ⇒ ∀thy h1 p1 h2 p2. (thy,h1) |= p1 ∧ (thy,h2) |= p2 ⇒ (thy, term_union (term_remove p2 h1) (term_remove p1 h2)) - |= p1 === p2` - (rw[] >> fs[entails_def] >> + |= p1 === p2 +Proof + rw[] >> fs[entails_def] >> imp_res_tac theory_ok_sig >> conj_asm1_tac >- ( simp[term_ok_equation] >> @@ -163,14 +172,16 @@ Theorem DEDUCT_ANTISYM_correct imp_res_tac termsem_typesem >> imp_res_tac WELLTYPED_LEMMA >> metis_tac[typesem_Bool]) >> - metis_tac[mem_boolset]) + metis_tac[mem_boolset] +QED -Theorem EQ_MP_correct - `is_set_theory ^mem ⇒ +Theorem EQ_MP_correct: + is_set_theory ^mem ⇒ ∀thy h1 h2 p q p'. (thy,h1) |= p === q ∧ (thy,h2) |= p' ∧ ACONV p p' ⇒ - (thy,term_union h1 h2) |= q` - (rw[] >> + (thy,term_union h1 h2) |= q +Proof + rw[] >> match_mp_tac (UNDISCH binary_inference_rule) >> map_every qexists_tac[`p === q`,`p'`] >> fs[entails_def,EQUATION_HAS_TYPE_BOOL] >> @@ -179,16 +190,18 @@ Theorem EQ_MP_correct conj_asm1_tac >- metis_tac[ACONV_TYPE,WELLTYPED,WELLTYPED_LEMMA] >> rw[] >> `term_ok (sigof thy) (p === q)` by metis_tac[term_ok_equation] >> imp_res_tac (UNDISCH termsem_equation) >> rfs[boolean_eq_true] >> - metis_tac[termsem_aconv,term_ok_welltyped]) + metis_tac[termsem_aconv,term_ok_welltyped] +QED -Theorem INST_correct - `is_set_theory ^mem ⇒ +Theorem INST_correct: + is_set_theory ^mem ⇒ ∀thy h c. (∀s s'. MEM (s',s) ilist ⇒ ∃x ty. (s = Var x ty) ∧ s' has_type ty ∧ term_ok (sigof thy) s') ∧ (thy, h) |= c - ⇒ (thy, term_image (VSUBST ilist) h) |= VSUBST ilist c` - (rw[entails_def,EVERY_MEM,satisfies_def] >> + ⇒ (thy, term_image (VSUBST ilist) h) |= VSUBST ilist c +Proof + rw[entails_def,EVERY_MEM,satisfies_def] >> TRY ( imp_res_tac MEM_term_image_imp >> rw[] ) >> TRY ( match_mp_tac term_ok_VSUBST >> metis_tac[] ) >> TRY ( match_mp_tac VSUBST_HAS_TYPE >> metis_tac[] ) >> @@ -214,15 +227,17 @@ Theorem INST_correct qspecl_then[`h`,`VSUBST ilist`,`t`]mp_tac MEM_term_image >> impl_tac >- rw[] >> strip_tac >> first_x_assum(fn th => first_assum (CHANGED_TAC o SUBST1_TAC o SYM o MATCH_MP th)) >> - metis_tac[MEM_term_image_imp,termsem_VSUBST,welltyped_def,VSUBST_WELLTYPED,termsem_aconv]) + metis_tac[MEM_term_image_imp,termsem_VSUBST,welltyped_def,VSUBST_WELLTYPED,termsem_aconv] +QED -Theorem INST_TYPE_correct - `is_set_theory ^mem ⇒ +Theorem INST_TYPE_correct: + is_set_theory ^mem ⇒ ∀thy h c. EVERY (type_ok (tysof thy)) (MAP FST tyin) ∧ (thy, h) |= c - ⇒ (thy, term_image (INST tyin) h) |= INST tyin c` - (rw[entails_def,EVERY_MAP,EVERY_MEM,satisfies_def] >> + ⇒ (thy, term_image (INST tyin) h) |= INST tyin c +Proof + rw[entails_def,EVERY_MAP,EVERY_MEM,satisfies_def] >> TRY ( match_mp_tac hypset_ok_term_image >> rw[] ) >> TRY ( imp_res_tac MEM_term_image_imp >> rw[] ) >> TRY ( match_mp_tac term_ok_INST >> fs[EVERY_MAP,EVERY_MEM] >> metis_tac[] ) >> @@ -249,15 +264,17 @@ Theorem INST_TYPE_correct impl_tac >- rw[] >> strip_tac >> first_x_assum(fn th => first_assum (CHANGED_TAC o SUBST1_TAC o SYM o MATCH_MP th)) >> metis_tac[MEM_term_image_imp,SIMP_RULE(srw_ss())[]termsem_INST, - welltyped_def,INST_WELLTYPED,termsem_aconv]) + welltyped_def,INST_WELLTYPED,termsem_aconv] +QED -Theorem MK_COMB_correct - `is_set_theory ^mem ⇒ +Theorem MK_COMB_correct: + is_set_theory ^mem ⇒ ∀thy h1 h2 l1 r1 l2 r2. (thy,h1) |= l1 === r1 ∧ (thy,h2) |= l2 === r2 ∧ welltyped (Comb l1 l2) - ⇒ (thy,term_union h1 h2) |= Comb l1 l2 === Comb r1 r2` - (rw[] >> + ⇒ (thy,term_union h1 h2) |= Comb l1 l2 === Comb r1 r2 +Proof + rw[] >> match_mp_tac (UNDISCH binary_inference_rule) >> map_every qexists_tac[`l1 === r1`,`l2 === r2`] >> fs[entails_def] >> @@ -270,14 +287,16 @@ Theorem MK_COMB_correct rw[] >> imp_res_tac (UNDISCH termsem_equation) >> rfs[boolean_eq_true] >> - rw[termsem_def]) + rw[termsem_def] +QED -Theorem REFL_correct - `is_set_theory ^mem ⇒ +Theorem REFL_correct: + is_set_theory ^mem ⇒ ∀thy t. theory_ok thy ∧ term_ok (sigof thy) t ⇒ - (thy,[]) |= t === t` - (rw[] >> + (thy,[]) |= t === t +Proof + rw[] >> simp[entails_def,EQUATION_HAS_TYPE_BOOL] >> imp_res_tac theory_ok_sig >> imp_res_tac term_ok_welltyped >> @@ -286,11 +305,13 @@ Theorem REFL_correct `is_structure (sigof thy) i v` by ( rw[is_structure_def] >> fs[models_def] ) >> imp_res_tac termsem_equation >> - rw[boolean_def]) + rw[boolean_def] +QED -Theorem proves_sound - `is_set_theory ^mem ⇒ ∀thyh c. thyh |- c ⇒ thyh |= c` - (strip_tac >> match_mp_tac proves_ind >> +Theorem proves_sound: + is_set_theory ^mem ⇒ ∀thyh c. thyh |- c ⇒ thyh |= c +Proof + strip_tac >> match_mp_tac proves_ind >> conj_tac >- metis_tac[ABS_correct] >> conj_tac >- metis_tac[ASSUME_correct] >> conj_tac >- metis_tac[BETA_correct] >> @@ -300,6 +321,7 @@ Theorem proves_sound conj_tac >- metis_tac[INST_TYPE_correct] >> conj_tac >- metis_tac[MK_COMB_correct] >> conj_tac >- metis_tac[REFL_correct] >> - rw[entails_def,theory_ok_def,models_def]) + rw[entails_def,theory_ok_def,models_def] +QED val _ = export_theory() diff --git a/candle/standard/syntax/holAxiomsSyntaxScript.sml b/candle/standard/syntax/holAxiomsSyntaxScript.sml index c34f78f465..42f20d0d86 100644 --- a/candle/standard/syntax/holAxiomsSyntaxScript.sml +++ b/candle/standard/syntax/holAxiomsSyntaxScript.sml @@ -17,13 +17,15 @@ val _ = Parse.temp_overload_on("g",``Var (strlit "f") (Fun A B)``) val mk_eta_ctxt_def = Define` mk_eta_ctxt ctxt = NewAxiom ((Abs x (Comb g x)) === g)::ctxt` -Theorem eta_extends - `∀ctxt. is_std_sig (sigof ctxt) ⇒ mk_eta_ctxt ctxt extends ctxt` - (rw[extends_def] >> +Theorem eta_extends: + ∀ctxt. is_std_sig (sigof ctxt) ⇒ mk_eta_ctxt ctxt extends ctxt +Proof + rw[extends_def] >> rw[Once RTC_CASES1] >> disj2_tac >> rw[Once RTC_CASES1] >> rw[mk_eta_ctxt_def] >> rw[updates_cases,EQUATION_HAS_TYPE_BOOL,term_ok_equation] >> - rw[term_ok_def,type_ok_def] >> fs[is_std_sig_def]) + rw[term_ok_def,type_ok_def] >> fs[is_std_sig_def] +QED val _ = Parse.overload_on("Select",``λty. Const (strlit "@") (Fun (Fun ty Bool) ty)``) val _ = Parse.temp_overload_on("P",``Var (strlit "P") (Fun A Bool)``) @@ -35,18 +37,20 @@ val mk_select_ctxt_def = Define` NewConst (strlit "@") (Fun (Fun A Bool) A) :: ctxt` -Theorem select_extends - `∀ctxt. is_std_sig (sigof ctxt) ∧ +Theorem select_extends: + ∀ctxt. is_std_sig (sigof ctxt) ∧ (strlit "@") ∉ FDOM (tmsof ctxt) ∧ (FLOOKUP (tmsof ctxt) (strlit "==>") = SOME (Fun Bool (Fun Bool Bool))) - ⇒ mk_select_ctxt ctxt extends ctxt` - (rw[extends_def] >> + ⇒ mk_select_ctxt ctxt extends ctxt +Proof + rw[extends_def] >> rw[Once RTC_CASES1] >> disj2_tac >> rw[Once RTC_CASES1] >> reverse(rw[mk_select_ctxt_def]) >- ( rw[updates_cases,type_ok_def] >> fs[is_std_sig_def] ) >> rw[updates_cases,term_ok_def,type_ok_def] >- ( rpt(simp[Once has_type_cases]) ) >> - fs[is_std_sig_def,FLOOKUP_UPDATE]) + fs[is_std_sig_def,FLOOKUP_UPDATE] +QED val _ = Parse.temp_overload_on("B",``Tyvar (strlit "B")``) val _ = Parse.overload_on("One_One",``λf. Comb (Const (strlit "ONE_ONE") (Fun (typeof f) Bool)) f``) @@ -78,8 +82,8 @@ val tyvar_inst_exists = Q.prove( qexists_tac`[(ty,Tyvar a)]` >> rw[REV_ASSOCD]) -Theorem infinity_extends - `∀ctxt. theory_ok (thyof ctxt) ∧ +Theorem infinity_extends: + ∀ctxt. theory_ok (thyof ctxt) ∧ DISJOINT (FDOM (tmsof ctxt)) (IMAGE strlit {"ONE_ONE";"ONTO"}) ∧ (strlit "ind") ∉ FDOM (tysof ctxt) ∧ (FLOOKUP (tmsof ctxt) (strlit "==>") = SOME (Fun Bool (Fun Bool Bool))) ∧ @@ -87,8 +91,9 @@ Theorem infinity_extends (FLOOKUP (tmsof ctxt) (strlit "!") = SOME (Fun (Fun A Bool) Bool)) ∧ (FLOOKUP (tmsof ctxt) (strlit "?") = SOME (Fun (Fun A Bool) Bool)) ∧ (FLOOKUP (tmsof ctxt) (strlit "~") = SOME (Fun Bool Bool)) - ⇒ mk_infinity_ctxt ctxt extends ctxt` - (rw[extends_def] >> + ⇒ mk_infinity_ctxt ctxt extends ctxt +Proof + rw[extends_def] >> imp_res_tac theory_ok_sig >> `ALOOKUP (type_list ctxt) (strlit "fun") = SOME 2` by fs[is_std_sig_def] >> `ALOOKUP (type_list ctxt) (strlit "bool") = SOME 0` by fs[is_std_sig_def] >> @@ -131,6 +136,7 @@ Theorem infinity_extends simp[term_ok_def,type_ok_def,welltyped_equation,EQUATION_HAS_TYPE_BOOL ,typeof_equation,term_ok_equation] >> simp[equation_def,tvars_def,tyvars_def] >> - PROVE_TAC[]) + PROVE_TAC[] +QED val _ = export_theory() diff --git a/candle/standard/syntax/holBoolSyntaxScript.sml b/candle/standard/syntax/holBoolSyntaxScript.sml index ec195d16a0..157f630f74 100644 --- a/candle/standard/syntax/holBoolSyntaxScript.sml +++ b/candle/standard/syntax/holBoolSyntaxScript.sml @@ -88,12 +88,13 @@ fun pull_tac () = BETA_TAC >> REWRITE_TAC[CONS_11] >> simp_tac bool_ss [] >> conj_asm2_tac -Theorem bool_extends - `∀ctxt. +Theorem bool_extends: + ∀ctxt. theory_ok (thyof ctxt) ∧ DISJOINT (FDOM (tmsof ctxt)) (IMAGE strlit {"T";"F";"==>";"/\\";"\\/";"~";"!";"?"}) ⇒ - mk_bool_ctxt ctxt extends ctxt` - (REWRITE_TAC(mk_bool_ctxt_def::Defs) >> + mk_bool_ctxt ctxt extends ctxt +Proof + REWRITE_TAC(mk_bool_ctxt_def::Defs) >> REWRITE_TAC[extends_def] >> ntac 2 strip_tac >> pull_tac() >- ConstDef_tac >> @@ -104,12 +105,15 @@ Theorem bool_extends pull_tac() >- ConstDef_tac >> pull_tac() >- ConstDef_tac >> pull_tac() >- ConstDef_tac >> - rw[Once RTC_CASES1]) + rw[Once RTC_CASES1] +QED -Theorem bool_extends_init - `mk_bool_ctxt init_ctxt extends init_ctxt` - (match_mp_tac bool_extends >> simp[init_theory_ok] >> - simp[init_ctxt_def]) +Theorem bool_extends_init: + mk_bool_ctxt init_ctxt extends init_ctxt +Proof + match_mp_tac bool_extends >> simp[init_theory_ok] >> + simp[init_ctxt_def] +QED (* signatures of Boolean constants *) @@ -144,19 +148,25 @@ val is_bool_sig_def = Define` is_forall_sig (tmsof sig) ∧ is_exists_sig (tmsof sig)` -Theorem bool_has_bool_sig - `∀ctxt. is_std_sig (sigof ctxt) - ⇒ is_bool_sig (sigof (mk_bool_ctxt ctxt))` - (rw[is_bool_sig_def] >- ( +Theorem bool_has_bool_sig: + ∀ctxt. is_std_sig (sigof ctxt) + ⇒ is_bool_sig (sigof (mk_bool_ctxt ctxt)) +Proof + rw[is_bool_sig_def] >- ( fs[is_std_sig_def,mk_bool_ctxt_def,FLOOKUP_UPDATE] ) >> - EVAL_TAC) - -Theorem is_bool_sig_std - `is_bool_sig sig ⇒ is_std_sig sig` (rw[is_bool_sig_def]) - -Theorem is_bool_sig_extends - `∀ctxt1 ctxt2. ctxt2 extends ctxt1 ⇒ is_bool_sig (sigof ctxt1) ⇒ is_bool_sig (sigof ctxt2)` - (ho_match_mp_tac extends_ind >> + EVAL_TAC +QED + +Theorem is_bool_sig_std: + is_bool_sig sig ⇒ is_std_sig sig +Proof +rw[is_bool_sig_def] +QED + +Theorem is_bool_sig_extends: + ∀ctxt1 ctxt2. ctxt2 extends ctxt1 ⇒ is_bool_sig (sigof ctxt1) ⇒ is_bool_sig (sigof ctxt2) +Proof + ho_match_mp_tac extends_ind >> REWRITE_TAC[GSYM AND_IMP_INTRO] >> ho_match_mp_tac updates_ind >> conj_tac >- rw[is_bool_sig_def] >> @@ -186,12 +196,13 @@ Theorem is_bool_sig_extends rw[FLOOKUP_UPDATE,FLOOKUP_FUNION] >> imp_res_tac ALOOKUP_MEM >> fs[MEM_MAP,FORALL_PROD] >> - metis_tac[] ) + metis_tac[] +QED (* Boolean terms are ok *) -Theorem bool_term_ok - `∀sig. is_bool_sig sig ⇒ +Theorem bool_term_ok: + ∀sig. is_bool_sig sig ⇒ term_ok sig True ∧ (∀p1 p2. term_ok sig (And p1 p2) ⇔ term_ok sig p1 ∧ term_ok sig p2 ∧ typeof p1 = Bool ∧ typeof p2 = Bool) ∧ (∀p1 p2. term_ok sig (Implies p1 p2) ⇔ term_ok sig p1 ∧ term_ok sig p2 ∧ typeof p1 = Bool ∧ typeof p2 = Bool) ∧ @@ -199,9 +210,11 @@ Theorem bool_term_ok (∀z ty p. term_ok sig (Exists z ty p) ⇔ type_ok (tysof sig) ty ∧ term_ok sig p ∧ typeof p = Bool) ∧ (∀p1 p2. term_ok sig (Or p1 p2) ⇔ term_ok sig p1 ∧ term_ok sig p2 ∧ typeof p1 = Bool ∧ typeof p2 = Bool) ∧ term_ok sig False ∧ - (∀p. term_ok sig (Not p) ⇔ term_ok sig p ∧ typeof p = Bool)` - (rw[] >> imp_res_tac is_bool_sig_std >> rw[term_ok_clauses] >> + (∀p. term_ok sig (Not p) ⇔ term_ok sig p ∧ typeof p = Bool) +Proof + rw[] >> imp_res_tac is_bool_sig_std >> rw[term_ok_clauses] >> rw[term_ok_def] >> fs[is_bool_sig_def] >> fs sigs >> rw[term_ok_clauses,tyvar_inst_exists] >> - PROVE_TAC[term_ok_welltyped]) + PROVE_TAC[term_ok_welltyped] +QED val _ = export_theory() diff --git a/candle/standard/syntax/holConservativeScript.sml b/candle/standard/syntax/holConservativeScript.sml index fbbd7a6a94..380eaf288f 100644 --- a/candle/standard/syntax/holConservativeScript.sml +++ b/candle/standard/syntax/holConservativeScript.sml @@ -30,23 +30,27 @@ val type_ok_subst = Q.prove ( qspec_tac(`tyvars ty`,`ls`) >> Induct >> simp[REV_ASSOCD] >> rw[]); -Theorem term_image_term_union -`!f h1 h2. +Theorem term_image_term_union: + !f h1 h2. (!t1 t2. ACONV t1 t2 ⇒ ACONV (f t1) (f t2)) ∧ hypset_ok h1 ∧ hypset_ok h2 ⇒ - term_image f (term_union h1 h2) = term_union (term_image f h1) (term_image f h2)` - (...); - -Theorem term_image_term_image -`!f g h. - term_image f (term_image g h) = term_image (f o g) h` - (gen_tac >> ho_match_mp_tac term_image_ind >> rw[] >> + term_image f (term_union h1 h2) = term_union (term_image f h1) (term_image f h2) +Proof + ... +QED + +Theorem term_image_term_image: + !f g h. + term_image f (term_image g h) = term_image (f o g) h +Proof + gen_tac >> ho_match_mp_tac term_image_ind >> rw[] >> simp[Once term_image_def,SimpRHS] >> BasicProvers.CASE_TAC >- simp[] >> fs[] >> rw[] >> (* likely not true without some hypset_ok hypotheses *) - ...) + ... +QED val term_image_term_remove = Q.prove ( `!x f tm tms. diff --git a/candle/standard/syntax/holSyntaxExtraScript.sml b/candle/standard/syntax/holSyntaxExtraScript.sml index bdcafa3594..9d96eed6c7 100644 --- a/candle/standard/syntax/holSyntaxExtraScript.sml +++ b/candle/standard/syntax/holSyntaxExtraScript.sml @@ -18,107 +18,134 @@ val type_ind = save_thm("type_ind", |> DISCH_ALL |> Q.GEN`P`) -Theorem type1_size_append - `∀l1 l2. type1_size (l1 ++ l2) = type1_size l1 + type1_size l2` - (Induct >> simp[type_size_def]) - -Theorem extends_ind - `∀P. (∀upd ctxt. upd updates ctxt ∧ P ctxt ⇒ P (upd::ctxt)) ⇒ - ∀ctxt1 ctxt2. ctxt2 extends ctxt1 ⇒ P ctxt1 ⇒ P ctxt2` - (gen_tac >> strip_tac >> +Theorem type1_size_append: + ∀l1 l2. type1_size (l1 ++ l2) = type1_size l1 + type1_size l2 +Proof + Induct >> simp[type_size_def] +QED + +Theorem extends_ind: + ∀P. (∀upd ctxt. upd updates ctxt ∧ P ctxt ⇒ P (upd::ctxt)) ⇒ + ∀ctxt1 ctxt2. ctxt2 extends ctxt1 ⇒ P ctxt1 ⇒ P ctxt2 +Proof + gen_tac >> strip_tac >> simp[extends_def] >> CONV_TAC SWAP_FORALL_CONV >> ho_match_mp_tac RTC_INDUCT >> rw[] >> first_x_assum match_mp_tac >> - rw[]) + rw[] +QED (* deconstructing variables *) -Theorem ALOOKUP_MAP_dest_var - `∀ls f x ty. +Theorem ALOOKUP_MAP_dest_var: + ∀ls f x ty. EVERY (λs. ∃x ty. s = Var x ty) (MAP FST ls) ⇒ ALOOKUP (MAP (dest_var ## f) ls) (x,ty) = - OPTION_MAP f (ALOOKUP ls (Var x ty))` - (Induct >> simp[] >> Cases >> simp[EVERY_MEM,EVERY_MAP] >> - rw[] >> fs[]) + OPTION_MAP f (ALOOKUP ls (Var x ty)) +Proof + Induct >> simp[] >> Cases >> simp[EVERY_MEM,EVERY_MAP] >> + rw[] >> fs[] +QED (* type substitution *) -Theorem TYPE_SUBST_NIL - `∀ty. TYPE_SUBST [] ty = ty` - (ho_match_mp_tac type_ind >> +Theorem TYPE_SUBST_NIL: + ∀ty. TYPE_SUBST [] ty = ty +Proof + ho_match_mp_tac type_ind >> rw[REV_ASSOCD,MAP_EQ_ID] >> - fs[EVERY_MEM]) + fs[EVERY_MEM] +QED val _ = export_rewrites["TYPE_SUBST_NIL"] -Theorem TYPE_SUBST_Bool - `∀tyin. TYPE_SUBST tyin Bool = Bool` (rw[TYPE_SUBST_def]) - -Theorem is_instance_refl - `∀ty. is_instance ty ty` - (rw[] >> qexists_tac`[]` >> rw[]) +Theorem TYPE_SUBST_Bool: + ∀tyin. TYPE_SUBST tyin Bool = Bool +Proof +rw[TYPE_SUBST_def] +QED + +Theorem is_instance_refl: + ∀ty. is_instance ty ty +Proof + rw[] >> qexists_tac`[]` >> rw[] +QED val _ = export_rewrites["is_instance_refl"] -Theorem swap_ff - `∀f g. (λ(x,y). (y,x)) o (f ## g) = (g ## f) o (λ(x,y). (y,x))` - (rw[FUN_EQ_THM,FORALL_PROD]) +Theorem swap_ff: + ∀f g. (λ(x,y). (y,x)) o (f ## g) = (g ## f) o (λ(x,y). (y,x)) +Proof + rw[FUN_EQ_THM,FORALL_PROD] +QED -Theorem ff_def - `∀f g. (f ## g) = λ(x,y). (f x, g y)` - (rw[FUN_EQ_THM,FORALL_PROD,PAIR_MAP_THM]) +Theorem ff_def: + ∀f g. (f ## g) = λ(x,y). (f x, g y) +Proof + rw[FUN_EQ_THM,FORALL_PROD,PAIR_MAP_THM] +QED -Theorem TYPE_SUBST_compose - `∀tyin1 ty tyin2. +Theorem TYPE_SUBST_compose: + ∀tyin1 ty tyin2. TYPE_SUBST tyin2 (TYPE_SUBST tyin1 ty) = - TYPE_SUBST ((MAP (TYPE_SUBST tyin2 ## I) tyin1) ++ tyin2) ty` - (ho_match_mp_tac TYPE_SUBST_ind >> + TYPE_SUBST ((MAP (TYPE_SUBST tyin2 ## I) tyin1) ++ tyin2) ty +Proof + ho_match_mp_tac TYPE_SUBST_ind >> rw[TYPE_SUBST_def,MAP_MAP_o,combinTheory.o_DEF,MAP_EQ_f] >> rw[REV_ASSOCD_ALOOKUP,ALOOKUP_APPEND] >> simp[MAP_MAP_o,swap_ff] >> simp[GSYM MAP_MAP_o] >> simp[ff_def,ALOOKUP_MAP] >> - BasicProvers.CASE_TAC >> simp[TYPE_SUBST_def,REV_ASSOCD_ALOOKUP]) + BasicProvers.CASE_TAC >> simp[TYPE_SUBST_def,REV_ASSOCD_ALOOKUP] +QED -Theorem TYPE_SUBST_tyvars - `∀ty tyin tyin'. +Theorem TYPE_SUBST_tyvars: + ∀ty tyin tyin'. (TYPE_SUBST tyin ty = TYPE_SUBST tyin' ty) ⇔ ∀x. MEM x (tyvars ty) ⇒ REV_ASSOCD (Tyvar x) tyin' (Tyvar x) = - REV_ASSOCD (Tyvar x) tyin (Tyvar x)` - (ho_match_mp_tac type_ind >> + REV_ASSOCD (Tyvar x) tyin (Tyvar x) +Proof + ho_match_mp_tac type_ind >> simp[tyvars_def] >> conj_tac >- metis_tac[] >> Induct >> simp[] >> gen_tac >> strip_tac >> fs[] >> rpt gen_tac >> EQ_TAC >> strip_tac >> fs[] >> - fs[MEM_LIST_UNION] >> metis_tac[]) + fs[MEM_LIST_UNION] >> metis_tac[] +QED (* Welltyped terms *) -Theorem WELLTYPED_LEMMA - `∀tm ty. tm has_type ty ⇒ (typeof tm = ty)` - (ho_match_mp_tac has_type_ind >> - simp[typeof_def,has_type_rules,codomain_def]) - -Theorem WELLTYPED - `∀tm. welltyped tm ⇔ tm has_type (typeof tm)` - (simp[welltyped_def] >> metis_tac[WELLTYPED_LEMMA]) - -Theorem WELLTYPED_CLAUSES - `(!n ty. welltyped(Var n ty)) /\ +Theorem WELLTYPED_LEMMA: + ∀tm ty. tm has_type ty ⇒ (typeof tm = ty) +Proof + ho_match_mp_tac has_type_ind >> + simp[typeof_def,has_type_rules,codomain_def] +QED + +Theorem WELLTYPED: + ∀tm. welltyped tm ⇔ tm has_type (typeof tm) +Proof + simp[welltyped_def] >> metis_tac[WELLTYPED_LEMMA] +QED + +Theorem WELLTYPED_CLAUSES: + (!n ty. welltyped(Var n ty)) /\ (!n ty. welltyped(Const n ty)) /\ (!s t. welltyped (Comb s t) <=> welltyped s /\ welltyped t /\ ?rty. typeof s = Fun (typeof t) rty) /\ - (!v t. welltyped (Abs v t) = ∃n ty. v = Var n ty ∧ welltyped t)` - (REPEAT STRIP_TAC THEN REWRITE_TAC[welltyped_def] THEN + (!v t. welltyped (Abs v t) = ∃n ty. v = Var n ty ∧ welltyped t) +Proof + REPEAT STRIP_TAC THEN REWRITE_TAC[welltyped_def] THEN rw[Once has_type_cases] >> - metis_tac[WELLTYPED,WELLTYPED_LEMMA]) + metis_tac[WELLTYPED,WELLTYPED_LEMMA] +QED val _ = export_rewrites["WELLTYPED_CLAUSES"] (* Alpha-equivalence *) -Theorem RACONV - `(RACONV env (Var x1 ty1,Var x2 ty2) <=> +Theorem RACONV: + (RACONV env (Var x1 ty1,Var x2 ty2) <=> ALPHAVARS env (Var x1 ty1,Var x2 ty2)) /\ (RACONV env (Var x1 ty1,Const x2 ty2) <=> F) /\ (RACONV env (Var x1 ty1,Comb l2 r2) <=> F) /\ @@ -137,21 +164,28 @@ Theorem RACONV (RACONV env (Abs v1 t1,Comb l2 r2) <=> F) /\ (RACONV env (Abs v1 t1,Abs v2 t2) <=> typeof v1 = typeof v2 /\ - RACONV (CONS (v1,v2) env) (t1,t2))` - (REPEAT CONJ_TAC THEN simp[Once RACONV_cases] >> metis_tac[]) - -Theorem RACONV_REFL - `∀t env. EVERY (UNCURRY $=) env ⇒ RACONV env (t,t)` - (Induct >> simp[RACONV,ALPHAVARS_REFL]) - -Theorem ACONV_REFL - `∀t. ACONV t t` - (simp[ACONV_def,RACONV_REFL]) + RACONV (CONS (v1,v2) env) (t1,t2)) +Proof + REPEAT CONJ_TAC THEN simp[Once RACONV_cases] >> metis_tac[] +QED + +Theorem RACONV_REFL: + ∀t env. EVERY (UNCURRY $=) env ⇒ RACONV env (t,t) +Proof + Induct >> simp[RACONV,ALPHAVARS_REFL] +QED + +Theorem ACONV_REFL: + ∀t. ACONV t t +Proof + simp[ACONV_def,RACONV_REFL] +QED val _ = export_rewrites["ACONV_REFL"] -Theorem RACONV_TRANS - `∀env tp. RACONV env tp ⇒ ∀vs t. LENGTH vs = LENGTH env ∧ RACONV (ZIP(MAP SND env,vs)) (SND tp,t) ⇒ RACONV (ZIP(MAP FST env,vs)) (FST tp, t)` - (ho_match_mp_tac RACONV_ind >> simp[RACONV] >> +Theorem RACONV_TRANS: + ∀env tp. RACONV env tp ⇒ ∀vs t. LENGTH vs = LENGTH env ∧ RACONV (ZIP(MAP SND env,vs)) (SND tp,t) ⇒ RACONV (ZIP(MAP FST env,vs)) (FST tp, t) +Proof + ho_match_mp_tac RACONV_ind >> simp[RACONV] >> conj_tac >- ( Induct >- simp[ALPHAVARS_def] >> Cases >> simp[ALPHAVARS_def] >> @@ -163,47 +197,60 @@ Theorem RACONV_TRANS conj_tac >- ( rw[] >> Cases_on`t`>>fs[RACONV] ) >> rw[] >> Cases_on`t`>>fs[RACONV]>>rw[]>> - metis_tac[LENGTH,ZIP]) - -Theorem ACONV_TRANS - `∀t1 t2 t3. ACONV t1 t2 ∧ ACONV t2 t3 ⇒ ACONV t1 t3` - (rw[ACONV_def] >> imp_res_tac RACONV_TRANS >> fs[LENGTH_NIL]) - -Theorem RACONV_SYM - `∀env tp. RACONV env tp ⇒ RACONV (MAP (λ(x,y). (y,x)) env) (SND tp,FST tp)` - (ho_match_mp_tac RACONV_ind >> simp[] >> + metis_tac[LENGTH,ZIP] +QED + +Theorem ACONV_TRANS: + ∀t1 t2 t3. ACONV t1 t2 ∧ ACONV t2 t3 ⇒ ACONV t1 t3 +Proof + rw[ACONV_def] >> imp_res_tac RACONV_TRANS >> fs[LENGTH_NIL] +QED + +Theorem RACONV_SYM: + ∀env tp. RACONV env tp ⇒ RACONV (MAP (λ(x,y). (y,x)) env) (SND tp,FST tp) +Proof + ho_match_mp_tac RACONV_ind >> simp[] >> conj_tac >- ( Induct >> simp[ALPHAVARS_def,RACONV] >> Cases >> simp[] >> rw[] >> res_tac >> fs[RACONV]) >> - simp[RACONV]) + simp[RACONV] +QED -Theorem ACONV_SYM - `∀t1 t2. ACONV t1 t2 ⇒ ACONV t2 t1` - (rw[ACONV_def] >> imp_res_tac RACONV_SYM >> fs[]) +Theorem ACONV_SYM: + ∀t1 t2. ACONV t1 t2 ⇒ ACONV t2 t1 +Proof + rw[ACONV_def] >> imp_res_tac RACONV_SYM >> fs[] +QED -Theorem ALPHAVARS_TYPE - `∀env s t. ALPHAVARS env (s,t) ∧ +Theorem ALPHAVARS_TYPE: + ∀env s t. ALPHAVARS env (s,t) ∧ EVERY (λ(x,y). welltyped x ∧ welltyped y ∧ (typeof x = typeof y)) env ∧ welltyped s ∧ welltyped t - ⇒ typeof s = typeof t` - (Induct >> simp[ALPHAVARS_def,FORALL_PROD] >> rw[] >> rw[]) + ⇒ typeof s = typeof t +Proof + Induct >> simp[ALPHAVARS_def,FORALL_PROD] >> rw[] >> rw[] +QED -Theorem RACONV_TYPE - `∀env p. RACONV env p +Theorem RACONV_TYPE: + ∀env p. RACONV env p ⇒ EVERY (λ(x,y). welltyped x ∧ welltyped y ∧ (typeof x = typeof y)) env ∧ welltyped (FST p) ∧ welltyped (SND p) - ⇒ typeof (FST p) = typeof (SND p)` - (ho_match_mp_tac RACONV_ind >> + ⇒ typeof (FST p) = typeof (SND p) +Proof + ho_match_mp_tac RACONV_ind >> simp[FORALL_PROD,typeof_def,WELLTYPED_CLAUSES] >> rw[] >> imp_res_tac ALPHAVARS_TYPE >> - fs[typeof_def,WELLTYPED_CLAUSES]) + fs[typeof_def,WELLTYPED_CLAUSES] +QED -Theorem ACONV_TYPE - `∀s t. ACONV s t ⇒ welltyped s ∧ welltyped t ⇒ (typeof s = typeof t)` - (rw[ACONV_def] >> imp_res_tac RACONV_TYPE >> fs[]) +Theorem ACONV_TYPE: + ∀s t. ACONV s t ⇒ welltyped s ∧ welltyped t ⇒ (typeof s = typeof t) +Proof + rw[ACONV_def] >> imp_res_tac RACONV_TYPE >> fs[] +QED (* subtypes *) @@ -221,9 +268,10 @@ val subtype_Tyapp = save_thm("subtype_Tyapp", |> SIMP_CONV(srw_ss()++boolSimps.DNF_ss) [Once relationTheory.RTC_CASES2,subtype1_cases]) -Theorem subtype_type_ok - `∀tysig ty1 ty2. type_ok tysig ty2 ∧ ty1 subtype ty2 ⇒ type_ok tysig ty1` - (gen_tac >> +Theorem subtype_type_ok: + ∀tysig ty1 ty2. type_ok tysig ty2 ∧ ty1 subtype ty2 ⇒ type_ok tysig ty1 +Proof + gen_tac >> (relationTheory.RTC_lifts_invariants |> Q.GEN`R` |> Q.ISPEC`inv subtype1` |> SIMP_RULE std_ss [relationTheory.inv_MOVES_OUT,relationTheory.inv_DEF] @@ -233,7 +281,8 @@ Theorem subtype_type_ok ONCE_REWRITE_TAC[GSYM AND_IMP_INTRO] >> CONV_TAC SWAP_FORALL_CONV >> gen_tac >> ho_match_mp_tac subtype1_ind >> - simp[type_ok_def,EVERY_MEM]) + simp[type_ok_def,EVERY_MEM] +QED (* subterms *) @@ -311,13 +360,17 @@ val term_lt_thm = Q.prove(` |> CONJUNCTS |> map GEN_ALL |> LIST_CONJ |> curry save_thm "term_lt_thm" -Theorem type_cmp_refl[simp] - `type_cmp t t = EQUAL` - (rw[type_cmp_def,TO_of_LinearOrder]) +Theorem type_cmp_refl[simp]: + type_cmp t t = EQUAL +Proof + rw[type_cmp_def,TO_of_LinearOrder] +QED -Theorem term_cmp_refl[simp] - `term_cmp t t = EQUAL` - (rw[term_cmp_def,TO_of_LinearOrder]) +Theorem term_cmp_refl[simp]: + term_cmp t t = EQUAL +Proof + rw[term_cmp_def,TO_of_LinearOrder] +QED val irreflexive_type_lt = Q.prove( `irreflexive type_lt`, @@ -409,16 +462,20 @@ val transitive_type_lt = Q.prove( `LENGTH args1 ≤ LENGTH l` by DECIDE_TAC >> simp[] >> simp[rich_listTheory.EL_TAKE]) -Theorem StrongLinearOrder_type_lt - `StrongLinearOrder type_lt` - (simp[StrongLinearOrder,StrongOrder,irreflexive_type_lt,trichotomous_type_lt] >> - metis_tac[transitive_type_lt,transitive_def]) - -Theorem TotOrd_type_cmp - `TotOrd type_cmp` - (rw[type_cmp_def] >> +Theorem StrongLinearOrder_type_lt: + StrongLinearOrder type_lt +Proof + simp[StrongLinearOrder,StrongOrder,irreflexive_type_lt,trichotomous_type_lt] >> + metis_tac[transitive_type_lt,transitive_def] +QED + +Theorem TotOrd_type_cmp: + TotOrd type_cmp +Proof + rw[type_cmp_def] >> match_mp_tac TotOrd_TO_of_Strong >> - ACCEPT_TAC StrongLinearOrder_type_lt) + ACCEPT_TAC StrongLinearOrder_type_lt +QED val irreflexive_term_lt = Q.prove( `irreflexive term_lt`, @@ -446,16 +503,20 @@ val transitive_term_lt = Q.prove( metis_tac[StrongLinearOrder_mlstring_lt,StrongLinearOrder_type_lt,StrongLinearOrder, StrongOrder,transitive_def]) -Theorem StrongLinearOrder_term_lt - `StrongLinearOrder term_lt` - (simp[StrongLinearOrder,StrongOrder,irreflexive_term_lt,trichotomous_term_lt] >> - metis_tac[transitive_term_lt,transitive_def]) - -Theorem TotOrd_term_cmp - `TotOrd term_cmp` - (rw[term_cmp_def] >> +Theorem StrongLinearOrder_term_lt: + StrongLinearOrder term_lt +Proof + simp[StrongLinearOrder,StrongOrder,irreflexive_term_lt,trichotomous_term_lt] >> + metis_tac[transitive_term_lt,transitive_def] +QED + +Theorem TotOrd_term_cmp: + TotOrd term_cmp +Proof + rw[term_cmp_def] >> match_mp_tac TotOrd_TO_of_Strong >> - ACCEPT_TAC StrongLinearOrder_term_lt) + ACCEPT_TAC StrongLinearOrder_term_lt +QED val StrongLinearOrder_irreflexive = Q.prove( `StrongLinearOrder R ⇒ irreflexive R`, @@ -469,14 +530,15 @@ val LLEX_irreflexive = Q.prove( val irreflexive_LLEX_type_lt = MATCH_MP LLEX_irreflexive (irreflexive_type_lt) -Theorem type_cmp_thm - `∀t1 t2. type_cmp t1 t2 = +Theorem type_cmp_thm: + ∀t1 t2. type_cmp t1 t2 = case (t1,t2) of | (Tyvar x1, Tyvar x2) => mlstring$compare x1 x2 | (Tyvar _, _) => LESS | (_, Tyvar _) => GREATER - | (Tyapp x1 a1, Tyapp x2 a2) => pair_cmp mlstring$compare (list_cmp type_cmp) (x1,a1) (x2,a2)` - (ho_match_mp_tac type_ind >> + | (Tyapp x1 a1, Tyapp x2 a2) => pair_cmp mlstring$compare (list_cmp type_cmp) (x1,a1) (x2,a2) +Proof + ho_match_mp_tac type_ind >> conj_tac >- ( gen_tac >> Cases >> simp[type_cmp_def,TO_of_LinearOrder,type_lt_thm, mlstring_lt_def] >> @@ -500,10 +562,11 @@ Theorem type_cmp_thm rfs [] >> fs [] >> every_case_tac >> - fs []); + fs [] +QED -Theorem type_cmp_ind - `∀P. +Theorem type_cmp_ind: + ∀P. (∀t1 t2. (∀x1 a1 x2 a2 x y. t1 = Tyapp x1 a1 ∧ @@ -511,17 +574,19 @@ Theorem type_cmp_ind MEM x a1 ∧ MEM y a2 ⇒ P x y) ⇒ P t1 t2) - ⇒ ∀t1 t2. P t1 t2` - (gen_tac >> strip_tac >> + ⇒ ∀t1 t2. P t1 t2 +Proof + gen_tac >> strip_tac >> ho_match_mp_tac type_ind >> rpt conj_tac >> TRY (gen_tac >> Cases >> rw[] >> NO_TAC) >> rpt gen_tac >> strip_tac >> gen_tac >> ho_match_mp_tac type_ind >> rw[] >> first_x_assum match_mp_tac >> simp[] >> - fs[EVERY_MEM]) + fs[EVERY_MEM] +QED -Theorem term_cmp_thm - `∀t1 t2. term_cmp t1 t2 = +Theorem term_cmp_thm: + ∀t1 t2. term_cmp t1 t2 = case (t1,t2) of | (Var x1 ty1, Var x2 ty2) => pair_cmp mlstring$compare type_cmp (x1,ty1) (x2,ty2) | (Var _ _, _) => LESS @@ -534,8 +599,9 @@ Theorem term_cmp_thm | (_, Comb _ _) => GREATER | (Abs s1 t1, Abs s2 t2) => pair_cmp term_cmp term_cmp (s1,t1) (s2,t2) | (Abs _ _, _) => LESS - | (_, Abs _ _) => GREATER` - (ho_match_mp_tac term_induction >> + | (_, Abs _ _) => GREATER +Proof + ho_match_mp_tac term_induction >> conj_tac >- ( ntac 2 gen_tac >> Cases >> simp[term_cmp_def,TO_of_LinearOrder,term_lt_thm, @@ -571,10 +637,11 @@ Theorem term_cmp_thm Cases >> fs[term_cmp_def,TO_of_LinearOrder,term_lt_thm]>> simp[GSYM term_cmp_def,MATCH_MP pair_cmp_lexTO (CONJ TotOrd_term_cmp TotOrd_term_cmp)] >> simp[term_cmp_def, TO_of_LinearOrder, - SYM(MATCH_MP TO_of_LinearOrder_LEX (CONJ irreflexive_term_lt irreflexive_term_lt))] ) + SYM(MATCH_MP TO_of_LinearOrder_LEX (CONJ irreflexive_term_lt irreflexive_term_lt))] +QED -Theorem term_cmp_ind - `∀P. +Theorem term_cmp_ind: + ∀P. (∀t1 t2. (∀x1 y1 x2 y2. t1 = Comb x1 y1 ∧ t2 = Comb x2 y2 ⇒ @@ -589,12 +656,14 @@ Theorem term_cmp_ind t1 = Abs x1 y1 ∧ t2 = Abs x2 y2 ⇒ P y1 y2) ⇒ P t1 t2) - ⇒ ∀t1 t2. P t1 t2` - (gen_tac >> strip_tac >> + ⇒ ∀t1 t2. P t1 t2 +Proof + gen_tac >> strip_tac >> ho_match_mp_tac term_induction >> rpt conj_tac >> TRY( ntac 2 gen_tac >> Cases >> simp[] >> NO_TAC ) >> - ntac 3 strip_tac >> Cases >> simp[]) + ntac 3 strip_tac >> Cases >> simp[] +QED (* alpha ordering *) @@ -612,9 +681,11 @@ val ordav_ALPHAVARS = Q.prove( fs[term_cmp_def,TO_of_LinearOrder] >> rpt(pop_assum mp_tac) >> rw[]) -Theorem ALPHAVARS_eq_ordav - `∀env t1 t2. ALPHAVARS env (t1,t2) ⇔ ordav env t1 t2 = EQUAL` - (metis_tac[ALPHAVARS_ordav,ordav_ALPHAVARS,pair_CASES,FST,SND]) +Theorem ALPHAVARS_eq_ordav: + ∀env t1 t2. ALPHAVARS env (t1,t2) ⇔ ordav env t1 t2 = EQUAL +Proof + metis_tac[ALPHAVARS_ordav,ordav_ALPHAVARS,pair_CASES,FST,SND] +QED val RACONV_orda = Q.prove( `∀env tp. RACONV env tp ⇒ orda env (FST tp) (SND tp) = EQUAL`, @@ -642,32 +713,41 @@ val orda_RACONV = Q.prove( qhdtm_x_assum`type_cmp`mp_tac >> rw[type_cmp_def,TO_of_LinearOrder]) -Theorem RACONV_eq_orda - `∀env t1 t2. RACONV env (t1,t2) ⇔ orda env t1 t2 = EQUAL` - (metis_tac[RACONV_orda,orda_RACONV,pair_CASES,FST,SND]) +Theorem RACONV_eq_orda: + ∀env t1 t2. RACONV env (t1,t2) ⇔ orda env t1 t2 = EQUAL +Proof + metis_tac[RACONV_orda,orda_RACONV,pair_CASES,FST,SND] +QED -Theorem ACONV_eq_orda - `∀t1 t2. ACONV t1 t2 = (orda [] t1 t2 = EQUAL)` - (rw[ACONV_def,RACONV_eq_orda]) +Theorem ACONV_eq_orda: + ∀t1 t2. ACONV t1 t2 = (orda [] t1 t2 = EQUAL) +Proof + rw[ACONV_def,RACONV_eq_orda] +QED -Theorem ordav_FILTER - `∀env x y. ordav env x y = +Theorem ordav_FILTER: + ∀env x y. ordav env x y = case FILTER (λ(x',y'). x' = x ∨ y' = y) env of | [] => term_cmp x y - | ((x',y')::_) => if x' = x then if y' = y then EQUAL else LESS else GREATER` - (ho_match_mp_tac ordav_ind >> simp[ordav_def] >> + | ((x',y')::_) => if x' = x then if y' = y then EQUAL else LESS else GREATER +Proof + ho_match_mp_tac ordav_ind >> simp[ordav_def] >> strip_assume_tac TotOrd_term_cmp >> - fs[TotOrd] >> rw[]) + fs[TotOrd] >> rw[] +QED -Theorem ordav_sym - `∀env v1 v2. flip_ord (ordav env v1 v2) = ordav (MAP (λ(x,y). (y,x)) env) v2 v1` - (ho_match_mp_tac ordav_ind >> simp[ordav_def] >> +Theorem ordav_sym: + ∀env v1 v2. flip_ord (ordav env v1 v2) = ordav (MAP (λ(x,y). (y,x)) env) v2 v1 +Proof + ho_match_mp_tac ordav_ind >> simp[ordav_def] >> conj_tac >- metis_tac[invert_comparison_def,TotOrd_term_cmp,TotOrd,cpn_nchotomy,cpn_distinct] >> - rw[]) + rw[] +QED -Theorem orda_sym - `∀env t1 t2. flip_ord (orda env t1 t2) = orda (MAP (λ(x,y). (y,x)) env) t2 t1` - (ho_match_mp_tac orda_ind >> +Theorem orda_sym: + ∀env t1 t2. flip_ord (orda env t1 t2) = orda (MAP (λ(x,y). (y,x)) env) t2 t1 +Proof + ho_match_mp_tac orda_ind >> rpt gen_tac >> rpt strip_tac >> ONCE_REWRITE_TAC[orda_def] >> IF_CASES_TAC >- rw[] >> @@ -677,13 +757,16 @@ Theorem orda_sym BasicProvers.CASE_TAC >> simp[ordav_sym] >> rw[] >> fs[] >> metis_tac[invert_comparison_def,TotOrd_type_cmp,TotOrd_term_cmp, - TotOrd,cpn_nchotomy,cpn_distinct] ) + TotOrd,cpn_nchotomy,cpn_distinct] +QED -Theorem antisymmetric_alpha_lt - `antisymmetric alpha_lt` - (rw[antisymmetric_def,alpha_lt_def] >> +Theorem antisymmetric_alpha_lt: + antisymmetric alpha_lt +Proof + rw[antisymmetric_def,alpha_lt_def] >> qspecl_then[`[]`,`x`,`y`]mp_tac orda_sym >> - simp[]) + simp[] +QED val orda_thm = Q.prove( `∀env t1 t2. orda env t1 t2 = ^(#3(dest_cond(rhs(concl(SPEC_ALL orda_def)))))`, @@ -817,74 +900,98 @@ val orda_lx_trans = Q.prove( [`t1`,`t2`,`t3`,`t4`,`t5`,`t6`]))) >> metis_tac[cpn_nchotomy,cpn_distinct]) -Theorem transitive_alpha_lt - `transitive alpha_lt` - (rw[transitive_def,alpha_lt_def] >> +Theorem transitive_alpha_lt: + transitive alpha_lt +Proof + rw[transitive_def,alpha_lt_def] >> qspecl_then[`[]`,`x`,`y`]mp_tac orda_lx_trans >> - simp[]) + simp[] +QED -Theorem alpha_lt_trans_ACONV - `∀x y z. +Theorem alpha_lt_trans_ACONV: + ∀x y z. (ACONV x y ∧ alpha_lt y z ⇒ alpha_lt x z) ∧ - (alpha_lt x y ∧ ACONV y z ⇒ alpha_lt x z)` - (rw[alpha_lt_def,ACONV_eq_orda] >> + (alpha_lt x y ∧ ACONV y z ⇒ alpha_lt x z) +Proof + rw[alpha_lt_def,ACONV_eq_orda] >> qspecl_then[`[]`,`x`,`y`]mp_tac orda_lx_trans >> - simp[]) + simp[] +QED -Theorem alpha_lt_not_refl[simp] - `∀x. ¬alpha_lt x x` - (metis_tac[alpha_lt_def,ACONV_eq_orda,cpn_distinct,ACONV_REFL]) +Theorem alpha_lt_not_refl[simp]: + ∀x. ¬alpha_lt x x +Proof + metis_tac[alpha_lt_def,ACONV_eq_orda,cpn_distinct,ACONV_REFL] +QED (* VFREE_IN lemmas *) -Theorem VFREE_IN_RACONV - `∀env p. RACONV env p +Theorem VFREE_IN_RACONV: + ∀env p. RACONV env p ⇒ ∀x ty. VFREE_IN (Var x ty) (FST p) ∧ ¬(∃y. MEM (Var x ty,y) env) ⇔ VFREE_IN (Var x ty) (SND p) ∧ - ¬(∃y. MEM (y,Var x ty) env)` - (ho_match_mp_tac RACONV_ind >> simp[VFREE_IN_def] >> + ¬(∃y. MEM (y,Var x ty) env) +Proof + ho_match_mp_tac RACONV_ind >> simp[VFREE_IN_def] >> reverse conj_tac >- metis_tac[] >> - Induct >> simp[ALPHAVARS_def,FORALL_PROD] >> rw[] >> metis_tac[]) - -Theorem VFREE_IN_ACONV - `∀s t x ty. ACONV s t ⇒ (VFREE_IN (Var x ty) s ⇔ VFREE_IN (Var x ty) t)` - (rw[ACONV_def] >> imp_res_tac VFREE_IN_RACONV >> fs[]) - -Theorem VFREE_IN_subterm - `∀t1 t2. VFREE_IN t1 t2 ⇒ t1 subterm t2` - (Induct_on`t2` >> simp[subterm_Comb,subterm_Abs] >> - metis_tac[]) + Induct >> simp[ALPHAVARS_def,FORALL_PROD] >> rw[] >> metis_tac[] +QED + +Theorem VFREE_IN_ACONV: + ∀s t x ty. ACONV s t ⇒ (VFREE_IN (Var x ty) s ⇔ VFREE_IN (Var x ty) t) +Proof + rw[ACONV_def] >> imp_res_tac VFREE_IN_RACONV >> fs[] +QED + +Theorem VFREE_IN_subterm: + ∀t1 t2. VFREE_IN t1 t2 ⇒ t1 subterm t2 +Proof + Induct_on`t2` >> simp[subterm_Comb,subterm_Abs] >> + metis_tac[] +QED (* hypset_ok *) -Theorem hypset_ok_nil[simp] - `hypset_ok []` (rw[hypset_ok_def]) - -Theorem hypset_ok_sing[simp] - `∀p. hypset_ok [p]` (rw[hypset_ok_def]) - -Theorem hypset_ok_cons - `hypset_ok (h::hs) ⇔ - EVERY (alpha_lt h) hs ∧ hypset_ok hs` - (rw[hypset_ok_def,MATCH_MP SORTED_EQ transitive_alpha_lt,EVERY_MEM]>> - metis_tac[]) - -Theorem hypset_ok_ALL_DISTINCT - `∀h. hypset_ok h ⇒ ALL_DISTINCT h` - (simp[hypset_ok_def] >> Induct >> +Theorem hypset_ok_nil[simp]: + hypset_ok [] +Proof +rw[hypset_ok_def] +QED + +Theorem hypset_ok_sing[simp]: + ∀p. hypset_ok [p] +Proof +rw[hypset_ok_def] +QED + +Theorem hypset_ok_cons: + hypset_ok (h::hs) ⇔ + EVERY (alpha_lt h) hs ∧ hypset_ok hs +Proof + rw[hypset_ok_def,MATCH_MP SORTED_EQ transitive_alpha_lt,EVERY_MEM]>> + metis_tac[] +QED + +Theorem hypset_ok_ALL_DISTINCT: + ∀h. hypset_ok h ⇒ ALL_DISTINCT h +Proof + simp[hypset_ok_def] >> Induct >> simp[MATCH_MP SORTED_EQ transitive_alpha_lt] >> rw[] >> strip_tac >> res_tac >> fs[alpha_lt_def] >> - metis_tac[cpn_distinct,ACONV_REFL,ACONV_eq_orda]) - -Theorem hypset_ok_eq - `∀h1 h2. hypset_ok h1 ∧ hypset_ok h2 ⇒ - ((h1 = h2) ⇔ (set h1 = set h2))` - (rw[EQ_IMP_THM] >> fs[EXTENSION] >> + metis_tac[cpn_distinct,ACONV_REFL,ACONV_eq_orda] +QED + +Theorem hypset_ok_eq: + ∀h1 h2. hypset_ok h1 ∧ hypset_ok h2 ⇒ + ((h1 = h2) ⇔ (set h1 = set h2)) +Proof + rw[EQ_IMP_THM] >> fs[EXTENSION] >> metis_tac[ hypset_ok_ALL_DISTINCT,PERM_ALL_DISTINCT, SORTED_PERM_EQ,hypset_ok_def, - transitive_alpha_lt, antisymmetric_alpha_lt]) + transitive_alpha_lt, antisymmetric_alpha_lt] +QED val hypset_ok_append = save_thm("hypset_ok_append", Q.ISPEC`alpha_lt` sortingTheory.SORTED_APPEND_IFF @@ -896,21 +1003,24 @@ val hypset_ok_el_less = save_thm("hypset_ok_el_less", (* term_union lemmas *) -Theorem term_union_idem[simp] - `∀ls. term_union ls ls = ls` - (Induct >- simp[term_union_def] >> - simp[Once term_union_def]) +Theorem term_union_idem[simp]: + ∀ls. term_union ls ls = ls +Proof + Induct >- simp[term_union_def] >> + simp[Once term_union_def] +QED -Theorem term_union_thm - `(∀l2. term_union [] l2 = l2) ∧ +Theorem term_union_thm: + (∀l2. term_union [] l2 = l2) ∧ (∀l1. term_union l1 [] = l1) ∧ (∀h1 t1 h2 t2. term_union (h1::t1) (h2::t2) = case orda [] h1 h2 of | EQUAL => h1::term_union t1 t2 | LESS => h1::term_union t1 (h2::t2) - | GREATER => h2::term_union (h1::t1) t2)` - (rw[] >- rw[term_union_def] >- ( + | GREATER => h2::term_union (h1::t1) t2) +Proof + rw[] >- rw[term_union_def] >- ( rw[term_union_def] >> BasicProvers.CASE_TAC ) >> map_every qid_spec_tac[`h2`,`t2`,`h1`,`t1`] >> @@ -919,20 +1029,24 @@ Theorem term_union_thm Induct >> simp[Once term_union_def] >> rw[] >> BasicProvers.CASE_TAC >> fs[] >> - BasicProvers.CASE_TAC >> fs[]) + BasicProvers.CASE_TAC >> fs[] +QED -Theorem MEM_term_union_imp - `∀l1 l2 x. MEM x (term_union l1 l2) ⇒ MEM x l1 ∨ MEM x l2` - (Induct >> simp[term_union_thm] >> +Theorem MEM_term_union_imp: + ∀l1 l2 x. MEM x (term_union l1 l2) ⇒ MEM x l1 ∨ MEM x l2 +Proof + Induct >> simp[term_union_thm] >> CONV_TAC(SWAP_FORALL_CONV) >> Induct >> simp[term_union_thm] >> rpt gen_tac >> BasicProvers.CASE_TAC >> rw[] >> fs[] >> - res_tac >> fs[]) - -Theorem hypset_ok_term_union[simp] - `∀l1 l2. hypset_ok l1 ∧ hypset_ok l2 ⇒ - hypset_ok (term_union l1 l2)` - (simp[hypset_ok_def] >> + res_tac >> fs[] +QED + +Theorem hypset_ok_term_union[simp]: + ∀l1 l2. hypset_ok l1 ∧ hypset_ok l2 ⇒ + hypset_ok (term_union l1 l2) +Proof + simp[hypset_ok_def] >> Induct >- simp[term_union_thm] >> qx_gen_tac`h1` >> Induct >- simp[term_union_thm] >> qx_gen_tac`h2` >> strip_tac >> @@ -953,16 +1067,20 @@ Theorem hypset_ok_term_union[simp] qspecl_then[`[]`,`h1`,`h2`]mp_tac orda_sym >> fs[alpha_lt_def] >> disch_then(assume_tac o SYM) >> qspecl_then[`[]`,`h2`,`h1`]mp_tac orda_lx_trans >> - simp[]) - -Theorem EVERY_term_union - `EVERY P l1 ∧ EVERY P l2 ⇒ EVERY P (term_union l1 l2)` - (metis_tac[EVERY_MEM,MEM_term_union_imp]) - -Theorem MEM_term_union - `∀h1 h2 t. hypset_ok h1 ∧ hypset_ok h2 ∧ (MEM t h1 ∨ MEM t h2) ⇒ - ∃y. MEM y (term_union h1 h2) ∧ ACONV t y` - (Induct >> simp[term_union_thm] >- + simp[] +QED + +Theorem EVERY_term_union: + EVERY P l1 ∧ EVERY P l2 ⇒ EVERY P (term_union l1 l2) +Proof + metis_tac[EVERY_MEM,MEM_term_union_imp] +QED + +Theorem MEM_term_union: + ∀h1 h2 t. hypset_ok h1 ∧ hypset_ok h2 ∧ (MEM t h1 ∨ MEM t h2) ⇒ + ∃y. MEM y (term_union h1 h2) ∧ ACONV t y +Proof + Induct >> simp[term_union_thm] >- (metis_tac[ACONV_REFL]) >> gen_tac >> Induct >> simp[term_union_thm] >- (metis_tac[ACONV_REFL]) >> @@ -971,61 +1089,71 @@ Theorem MEM_term_union fs[hypset_ok_cons] >> BasicProvers.CASE_TAC >> rw[] >> fs[GSYM ACONV_eq_orda] >> - metis_tac[MEM,ACONV_REFL,ACONV_SYM,hypset_ok_cons]) + metis_tac[MEM,ACONV_REFL,ACONV_SYM,hypset_ok_cons] +QED val term_union_sing_lt = Q.prove( `∀ys x. EVERY (λy. alpha_lt x y) ys ⇒ (term_union [x] ys = x::ys)`, Induct >> simp[term_union_thm] >> rw[] >> fs[] >> fs[alpha_lt_def]) -Theorem term_union_insert - `∀ys x zs. +Theorem term_union_insert: + ∀ys x zs. EVERY (λy. alpha_lt y x) ys ∧ EVERY (λz. alpha_lt x z) zs - ⇒ (term_union [x] (ys ++ zs) = ys ++ x::zs)` - (Induct >> simp[term_union_sing_lt] >> rw[] >> + ⇒ (term_union [x] (ys ++ zs) = ys ++ x::zs) +Proof + Induct >> simp[term_union_sing_lt] >> rw[] >> simp[term_union_thm] >> `orda [] x h = Greater` by ( fs[alpha_lt_def] >> qspecl_then[`[]`,`h`,`x`]mp_tac orda_sym >> simp[] ) >> - simp[]) + simp[] +QED -Theorem term_union_replace - `∀ys x x' zs. +Theorem term_union_replace: + ∀ys x x' zs. EVERY (λy. alpha_lt y x) ys ∧ ACONV x x' ∧ EVERY (λz. alpha_lt x z) zs ⇒ - term_union [x] (ys ++ x'::zs) = ys ++ x::zs` - (Induct >> rw[term_union_thm,ACONV_eq_orda,alpha_lt_def] >> + term_union [x] (ys ++ x'::zs) = ys ++ x::zs +Proof + Induct >> rw[term_union_thm,ACONV_eq_orda,alpha_lt_def] >> qspecl_then[`[]`,`h`,`x`]mp_tac orda_sym >> simp[] >> disch_then(assume_tac o SYM) >> simp[] >> - fs[GSYM ACONV_eq_orda, GSYM alpha_lt_def]) + fs[GSYM ACONV_eq_orda, GSYM alpha_lt_def] +QED -Theorem MEM_term_union_first - `∀h1 h2 t. hypset_ok h1 ∧ hypset_ok h2 ∧ MEM t h1 ⇒ MEM t (term_union h1 h2)` - (Induct >> simp[hypset_ok_cons] >> +Theorem MEM_term_union_first: + ∀h1 h2 t. hypset_ok h1 ∧ hypset_ok h2 ∧ MEM t h1 ⇒ MEM t (term_union h1 h2) +Proof + Induct >> simp[hypset_ok_cons] >> gen_tac >> Induct >> simp[term_union_thm] >> rw[hypset_ok_cons] >> BasicProvers.CASE_TAC >> rw[] >> disj2_tac >> first_x_assum match_mp_tac >> - rw[hypset_ok_cons]) + rw[hypset_ok_cons] +QED -Theorem term_union_insert_mem - `∀c h. hypset_ok h ∧ MEM c h ⇒ (term_union [c] h = h)` - (gen_tac >> Induct >> simp[hypset_ok_cons,term_union_thm] >> +Theorem term_union_insert_mem: + ∀c h. hypset_ok h ∧ MEM c h ⇒ (term_union [c] h = h) +Proof + gen_tac >> Induct >> simp[hypset_ok_cons,term_union_thm] >> rw[] >> fs[] >- ( `ACONV c c` by simp[] >> fs[ACONV_eq_orda] ) >> fs[EVERY_MEM] >> res_tac >> fs[alpha_lt_def] >> qspecl_then[`[]`,`h'`,`c`]mp_tac orda_sym >> simp[] >> disch_then(assume_tac o SYM) >> - rw[term_union_thm]) + rw[term_union_thm] +QED -Theorem term_union_insert_remove - `∀c h. hypset_ok h ∧ MEM c h ∧ ACONV c' c ⇒ (term_union [c] (term_remove c' h) = h)` - (gen_tac >> Induct >> simp[hypset_ok_cons] >> rw[] >> fs[] >- ( +Theorem term_union_insert_remove: + ∀c h. hypset_ok h ∧ MEM c h ∧ ACONV c' c ⇒ (term_union [c] (term_remove c' h) = h) +Proof + gen_tac >> Induct >> simp[hypset_ok_cons] >> rw[] >> fs[] >- ( simp[Once term_remove_def] >> fs[ACONV_eq_orda] >> Cases_on`h`>>simp[term_union_thm] >> fs[alpha_lt_def] ) >> @@ -1040,18 +1168,22 @@ Theorem term_union_insert_remove disch_then(assume_tac o SYM) >> rw[term_union_thm] >> match_mp_tac term_union_insert_mem >> - rw[]) + rw[] +QED (* term_remove *) -Theorem term_remove_nil[simp] - `∀a. term_remove a [] = []` - (rw[Once term_remove_def]) - -Theorem MEM_term_remove_imp - `∀ls x t. MEM t (term_remove x ls) ⇒ - MEM t ls ∧ (hypset_ok ls ⇒ ¬ACONV x t)` - (Induct >> simp[Once term_remove_def] >> rw[] >> +Theorem term_remove_nil[simp]: + ∀a. term_remove a [] = [] +Proof + rw[Once term_remove_def] +QED + +Theorem MEM_term_remove_imp: + ∀ls x t. MEM t (term_remove x ls) ⇒ + MEM t ls ∧ (hypset_ok ls ⇒ ¬ACONV x t) +Proof + Induct >> simp[Once term_remove_def] >> rw[] >> fs[hypset_ok_def, MATCH_MP SORTED_EQ transitive_alpha_lt, ACONV_eq_orda,EVERY_MEM,EXISTS_MEM] >> @@ -1062,65 +1194,83 @@ Theorem MEM_term_remove_imp simp[] >> disch_then(assume_tac o SYM) >> spose_not_then strip_assume_tac >> qspecl_then[`[]`,`x`,`h`]mp_tac orda_lx_trans >> - simp[] >> qexists_tac`t` >> simp[]) + simp[] >> qexists_tac`t` >> simp[] +QED -Theorem hypset_ok_term_remove[simp] - `∀ls. hypset_ok ls ⇒ ∀t. hypset_ok (term_remove t ls)` - (Induct >> simp[Once term_remove_def] >> +Theorem hypset_ok_term_remove[simp]: + ∀ls. hypset_ok ls ⇒ ∀t. hypset_ok (term_remove t ls) +Proof + Induct >> simp[Once term_remove_def] >> rw[] >> fs[hypset_ok_def] >> rw[] >> fs[MATCH_MP SORTED_EQ transitive_alpha_lt, EVERY_MEM,ACONV_eq_orda] >> rw[] >> imp_res_tac MEM_term_remove_imp >> - rfs[hypset_ok_def]) - -Theorem EVERY_term_remove - `EVERY P ls ⇒ EVERY P (term_remove t ls)` - (metis_tac[EVERY_MEM,MEM_term_remove_imp]) - -Theorem MEM_term_remove - `∀h x t. MEM t h ∧ ¬ACONV x t ∧ hypset_ok h - ⇒ MEM t (term_remove x h)` - (Induct >> simp[Once term_remove_def] >> + rfs[hypset_ok_def] +QED + +Theorem EVERY_term_remove: + EVERY P ls ⇒ EVERY P (term_remove t ls) +Proof + metis_tac[EVERY_MEM,MEM_term_remove_imp] +QED + +Theorem MEM_term_remove: + ∀h x t. MEM t h ∧ ¬ACONV x t ∧ hypset_ok h + ⇒ MEM t (term_remove x h) +Proof + Induct >> simp[Once term_remove_def] >> simp[hypset_ok_cons] >> rw[EVERY_MEM] >> - res_tac >> fs[alpha_lt_def,GSYM ACONV_eq_orda]) + res_tac >> fs[alpha_lt_def,GSYM ACONV_eq_orda] +QED -Theorem term_remove_exists - `∀c h. term_remove c h ≠ h ⇒ ∃c'. MEM c' h ∧ ACONV c c'` - (gen_tac >> Induct >> simp[] >> +Theorem term_remove_exists: + ∀c h. term_remove c h ≠ h ⇒ ∃c'. MEM c' h ∧ ACONV c c' +Proof + gen_tac >> Induct >> simp[] >> simp[Once term_remove_def] >> rw[] >> fs[] >> - fs[GSYM ACONV_eq_orda] >> metis_tac[]) + fs[GSYM ACONV_eq_orda] >> metis_tac[] +QED (* term_image *) -Theorem term_image_nil[simp] - `term_image f [] = []` - (simp[Once term_image_def]) +Theorem term_image_nil[simp]: + term_image f [] = [] +Proof + simp[Once term_image_def] +QED -Theorem MEM_term_image_imp - `∀ls f t. MEM t (term_image f ls) ⇒ ∃x. MEM x ls ∧ t = f x` - (Induct >> simp[Once term_image_def] >> rw[] >> fs[] >> +Theorem MEM_term_image_imp: + ∀ls f t. MEM t (term_image f ls) ⇒ ∃x. MEM x ls ∧ t = f x +Proof + Induct >> simp[Once term_image_def] >> rw[] >> fs[] >> imp_res_tac MEM_term_union_imp >> fs[] >> - metis_tac[]) - -Theorem hypset_ok_term_image - `∀ls f. hypset_ok ls ⇒ hypset_ok (term_image f ls)` - (Induct >> simp[Once term_image_def] >> rw[hypset_ok_cons]) - -Theorem MEM_term_image - `∀ls f t. MEM t ls ∧ hypset_ok ls ⇒ ∃y. MEM y (term_image f ls) ∧ ACONV (f t) y` - (Induct >> simp[Once term_image_def] >> rw[hypset_ok_cons] >> rw[] >> + metis_tac[] +QED + +Theorem hypset_ok_term_image: + ∀ls f. hypset_ok ls ⇒ hypset_ok (term_image f ls) +Proof + Induct >> simp[Once term_image_def] >> rw[hypset_ok_cons] +QED + +Theorem MEM_term_image: + ∀ls f t. MEM t ls ∧ hypset_ok ls ⇒ ∃y. MEM y (term_image f ls) ∧ ACONV (f t) y +Proof + Induct >> simp[Once term_image_def] >> rw[hypset_ok_cons] >> rw[] >> TRY(metis_tac[ACONV_REFL]) >- metis_tac[MEM_term_union,hypset_ok_sing,MEM,hypset_ok_term_image] >> first_x_assum(qspecl_then[`f`,`t`]mp_tac) >> rw[] >> - metis_tac[MEM_term_union,hypset_ok_sing,hypset_ok_term_image,ACONV_TRANS]) + metis_tac[MEM_term_union,hypset_ok_sing,hypset_ok_term_image,ACONV_TRANS] +QED (* VSUBST lemmas *) -Theorem VSUBST_HAS_TYPE - `∀tm ty ilist. +Theorem VSUBST_HAS_TYPE: + ∀tm ty ilist. tm has_type ty ∧ (∀s s'. MEM (s',s) ilist ⇒ ∃x ty. (s = Var x ty) ∧ s' has_type ty) - ⇒ (VSUBST ilist tm) has_type ty` - (Induct >> simp[VSUBST_def] + ⇒ (VSUBST ilist tm) has_type ty +Proof + Induct >> simp[VSUBST_def] >- ( map_every qx_gen_tac[`x`,`ty`,`tty`] >> Induct >> simp[REV_ASSOCD,FORALL_PROD] >> @@ -1136,22 +1286,26 @@ Theorem VSUBST_HAS_TYPE simp[Once has_type_cases] >> first_x_assum match_mp_tac >> simp[] >> simp[MEM_FILTER] >> rw[] >> TRY(metis_tac[]) >> - simp[Once has_type_cases])) + simp[Once has_type_cases]) +QED -Theorem VSUBST_WELLTYPED - `∀tm ty ilist. +Theorem VSUBST_WELLTYPED: + ∀tm ty ilist. welltyped tm ∧ (∀s s'. MEM (s',s) ilist ⇒ ∃x ty. (s = Var x ty) ∧ s' has_type ty) - ⇒ welltyped (VSUBST ilist tm)` - (metis_tac[VSUBST_HAS_TYPE,welltyped_def]) + ⇒ welltyped (VSUBST ilist tm) +Proof + metis_tac[VSUBST_HAS_TYPE,welltyped_def] +QED -Theorem VFREE_IN_VSUBST - `∀tm u uty ilist. +Theorem VFREE_IN_VSUBST: + ∀tm u uty ilist. welltyped tm ⇒ (VFREE_IN (Var u uty) (VSUBST ilist tm) ⇔ ∃y ty. VFREE_IN (Var y ty) tm ∧ - VFREE_IN (Var u uty) (REV_ASSOCD (Var y ty) ilist (Var y ty)))` - (Induct >> simp[VFREE_IN_def,VSUBST_def] >- metis_tac[] >> + VFREE_IN (Var u uty) (REV_ASSOCD (Var y ty) ilist (Var y ty))) +Proof + Induct >> simp[VFREE_IN_def,VSUBST_def] >- metis_tac[] >> map_every qx_gen_tac[`u`,`uty`,`ilist`] >> disch_then(qx_choosel_then[`b`,`bty`]strip_assume_tac) >> simp[] >> BasicProvers.VAR_EQ_TAC >> qmatch_assum_rename_tac`welltyped tm` >> @@ -1191,17 +1345,20 @@ Theorem VFREE_IN_VSUBST Q.ISPECL_THEN[`ilist`,`Var y ty`,`Var y ty`]mp_tac REV_ASSOCD_MEM >> strip_tac >> fs[] >> fs[VFREE_IN_def] >> - metis_tac[]) + metis_tac[] +QED -Theorem VSUBST_NIL[simp] - `∀tm. VSUBST [] tm = tm` - (ho_match_mp_tac term_induction >> - simp[VSUBST_def,REV_ASSOCD]) +Theorem VSUBST_NIL[simp]: + ∀tm. VSUBST [] tm = tm +Proof + ho_match_mp_tac term_induction >> + simp[VSUBST_def,REV_ASSOCD] +QED (* INST lemmas *) -Theorem INST_CORE_HAS_TYPE - `∀n tm env tyin. +Theorem INST_CORE_HAS_TYPE: + ∀n tm env tyin. welltyped tm ∧ (sizeof tm = n) ∧ (∀s s'. MEM (s,s') env ⇒ ∃x ty. (s = Var x ty) ∧ @@ -1217,8 +1374,9 @@ Theorem INST_CORE_HAS_TYPE tm' has_type (TYPE_SUBST tyin (typeof tm)) ∧ (∀u uty. VFREE_IN (Var u uty) tm' ⇔ ∃oty. VFREE_IN (Var u oty) tm ∧ - uty = TYPE_SUBST tyin oty))` - (gen_tac >> completeInduct_on`n` >> + uty = TYPE_SUBST tyin oty)) +Proof + gen_tac >> completeInduct_on`n` >> Induct >> simp[Once INST_CORE_def] >> TRY ( simp[Once INST_CORE_def] >> @@ -1326,31 +1484,39 @@ Theorem INST_CORE_HAS_TYPE BasicProvers.EVERY_CASE_TAC >> fs[] >> rpt BasicProvers.VAR_EQ_TAC >> fs[] >> simp[Once has_type_cases] >> - metis_tac[VARIANT_THM,term_11])) + metis_tac[VARIANT_THM,term_11]) +QED -Theorem INST_CORE_NIL_IS_RESULT - `∀tyin tm. welltyped tm ⇒ IS_RESULT (INST_CORE [] tyin tm)` - (rw[] >> +Theorem INST_CORE_NIL_IS_RESULT: + ∀tyin tm. welltyped tm ⇒ IS_RESULT (INST_CORE [] tyin tm) +Proof + rw[] >> qspecl_then[`sizeof tm`,`tm`,`[]`,`tyin`]mp_tac INST_CORE_HAS_TYPE >> - simp[] >> rw[] >> rw[] >> fs[REV_ASSOCD]) + simp[] >> rw[] >> rw[] >> fs[REV_ASSOCD] +QED -Theorem INST_HAS_TYPE - `∀tm ty tyin ty'. tm has_type ty ∧ ty' = TYPE_SUBST tyin ty ⇒ INST tyin tm has_type ty'` - (rw[INST_def] >> +Theorem INST_HAS_TYPE: + ∀tm ty tyin ty'. tm has_type ty ∧ ty' = TYPE_SUBST tyin ty ⇒ INST tyin tm has_type ty' +Proof + rw[INST_def] >> qspecl_then[`tyin`,`tm`]mp_tac INST_CORE_NIL_IS_RESULT >> rw[] >> qspecl_then[`sizeof tm`,`tm`,`[]`,`tyin`]mp_tac INST_CORE_HAS_TYPE >> `welltyped tm` by metis_tac[welltyped_def] >> fs[] >> - rw[] >> fs[] >> metis_tac[WELLTYPED_LEMMA]) + rw[] >> fs[] >> metis_tac[WELLTYPED_LEMMA] +QED -Theorem INST_WELLTYPED - `∀tm tyin. welltyped tm ⇒ welltyped (INST tyin tm)` - (metis_tac[INST_HAS_TYPE,WELLTYPED_LEMMA,WELLTYPED]) +Theorem INST_WELLTYPED: + ∀tm tyin. welltyped tm ⇒ welltyped (INST tyin tm) +Proof + metis_tac[INST_HAS_TYPE,WELLTYPED_LEMMA,WELLTYPED] +QED -Theorem INST_CORE_NIL - `∀env tyin tm. welltyped tm ∧ tyin = [] ∧ +Theorem INST_CORE_NIL: + ∀env tyin tm. welltyped tm ∧ tyin = [] ∧ (∀x ty. VFREE_IN (Var x ty) tm ⇒ REV_ASSOCD (Var x (TYPE_SUBST tyin ty)) env (Var x ty) = Var x ty) ⇒ - INST_CORE env tyin tm = Result tm` - (ho_match_mp_tac INST_CORE_ind >> + INST_CORE env tyin tm = Result tm +Proof + ho_match_mp_tac INST_CORE_ind >> simp[INST_CORE_def] >> rw[] >> fs[] >> Q.PAT_ABBREV_TAC`i1 = INST_CORE X [] tm` >> @@ -1359,133 +1525,170 @@ Theorem INST_CORE_NIL first_x_assum match_mp_tac >> simp[holSyntaxLibTheory.REV_ASSOCD] >> rw[] >> metis_tac[] ) >> - simp[]) + simp[] +QED -Theorem INST_nil - `welltyped tm ⇒ (INST [] tm = tm)` - (rw[INST_def,INST_CORE_def] >> +Theorem INST_nil: + welltyped tm ⇒ (INST [] tm = tm) +Proof + rw[INST_def,INST_CORE_def] >> qspecl_then[`[]`,`[]`,`tm`]mp_tac INST_CORE_NIL >> - simp[holSyntaxLibTheory.REV_ASSOCD]) + simp[holSyntaxLibTheory.REV_ASSOCD] +QED (* tyvars and tvars *) -Theorem tyvars_ALL_DISTINCT - `∀ty. ALL_DISTINCT (tyvars ty)` - (ho_match_mp_tac type_ind >> +Theorem tyvars_ALL_DISTINCT: + ∀ty. ALL_DISTINCT (tyvars ty) +Proof + ho_match_mp_tac type_ind >> rw[tyvars_def] >> Induct_on`l` >> simp[] >> - rw[ALL_DISTINCT_LIST_UNION]) + rw[ALL_DISTINCT_LIST_UNION] +QED val _ = export_rewrites["tyvars_ALL_DISTINCT"] -Theorem tvars_ALL_DISTINCT - `∀tm. ALL_DISTINCT (tvars tm)` - (Induct >> simp[tvars_def,ALL_DISTINCT_LIST_UNION]) +Theorem tvars_ALL_DISTINCT: + ∀tm. ALL_DISTINCT (tvars tm) +Proof + Induct >> simp[tvars_def,ALL_DISTINCT_LIST_UNION] +QED val _ = export_rewrites["tvars_ALL_DISTINCT"] -Theorem tyvars_TYPE_SUBST - `∀ty tyin. set (tyvars (TYPE_SUBST tyin ty)) = - { v | ∃x. MEM x (tyvars ty) ∧ MEM v (tyvars (REV_ASSOCD (Tyvar x) tyin (Tyvar x))) }` - (ho_match_mp_tac type_ind >> simp[tyvars_def] >> +Theorem tyvars_TYPE_SUBST: + ∀ty tyin. set (tyvars (TYPE_SUBST tyin ty)) = + { v | ∃x. MEM x (tyvars ty) ∧ MEM v (tyvars (REV_ASSOCD (Tyvar x) tyin (Tyvar x))) } +Proof + ho_match_mp_tac type_ind >> simp[tyvars_def] >> simp[EXTENSION,EVERY_MEM,MEM_FOLDR_LIST_UNION,PULL_EXISTS,MEM_MAP] >> rw[] >> - metis_tac[] ) + metis_tac[] +QED -Theorem tyvars_typeof_subset_tvars - `∀tm ty. tm has_type ty ⇒ set (tyvars ty) ⊆ set (tvars tm)` - (ho_match_mp_tac has_type_ind >> +Theorem tyvars_typeof_subset_tvars: + ∀tm ty. tm has_type ty ⇒ set (tyvars ty) ⊆ set (tvars tm) +Proof + ho_match_mp_tac has_type_ind >> simp[tvars_def] >> simp[SUBSET_DEF,MEM_LIST_UNION,tyvars_def] >> - metis_tac[]) + metis_tac[] +QED -Theorem tyvars_Tyapp_MAP_Tyvar - `∀x ls. ALL_DISTINCT ls ⇒ (tyvars (Tyapp x (MAP Tyvar ls)) = LIST_UNION [] ls)` - (simp[tyvars_def] >> +Theorem tyvars_Tyapp_MAP_Tyvar: + ∀x ls. ALL_DISTINCT ls ⇒ (tyvars (Tyapp x (MAP Tyvar ls)) = LIST_UNION [] ls) +Proof + simp[tyvars_def] >> Induct >> fs[tyvars_def,LIST_UNION_def] >> - rw[LIST_INSERT_def]) - -Theorem STRING_SORT_SET_TO_LIST_set_tvars - `∀tm. STRING_SORT (MAP explode (SET_TO_LIST (set (tvars tm)))) = - STRING_SORT (MAP explode (tvars tm))` - (gen_tac >> assume_tac(SPEC_ALL tvars_ALL_DISTINCT) >> + rw[LIST_INSERT_def] +QED + +Theorem STRING_SORT_SET_TO_LIST_set_tvars: + ∀tm. STRING_SORT (MAP explode (SET_TO_LIST (set (tvars tm)))) = + STRING_SORT (MAP explode (tvars tm)) +Proof + gen_tac >> assume_tac(SPEC_ALL tvars_ALL_DISTINCT) >> simp[STRING_SORT_EQ] >> match_mp_tac sortingTheory.PERM_MAP >> pop_assum mp_tac >> REWRITE_TAC[sortingTheory.ALL_DISTINCT_PERM_LIST_TO_SET_TO_LIST] >> - simp[sortingTheory.PERM_SYM]) + simp[sortingTheory.PERM_SYM] +QED -Theorem mlstring_sort_SET_TO_LIST_set_tvars - `mlstring_sort (SET_TO_LIST (set (tvars tm))) = mlstring_sort (tvars tm)` - (rw[mlstring_sort_def,STRING_SORT_SET_TO_LIST_set_tvars]) +Theorem mlstring_sort_SET_TO_LIST_set_tvars: + mlstring_sort (SET_TO_LIST (set (tvars tm))) = mlstring_sort (tvars tm) +Proof + rw[mlstring_sort_def,STRING_SORT_SET_TO_LIST_set_tvars] +QED (* Equations *) -Theorem EQUATION_HAS_TYPE_BOOL - `∀s t. (s === t) has_type Bool - ⇔ welltyped s ∧ welltyped t ∧ (typeof s = typeof t)` - (rw[equation_def] >> rw[Ntimes has_type_cases 3] >> - metis_tac[WELLTYPED_LEMMA,WELLTYPED]) - -Theorem welltyped_equation - `∀s t. welltyped (s === t) ⇔ s === t has_type Bool` - (simp[EQUATION_HAS_TYPE_BOOL] >> simp[equation_def]) - -Theorem typeof_equation - `welltyped (l === r) ⇒ (typeof (l === r)) = Bool` - (rw[welltyped_equation] >> imp_res_tac WELLTYPED_LEMMA >> rw[]) - -Theorem vfree_in_equation - `VFREE_IN v (s === t) ⇔ (v = Equal (typeof s)) ∨ VFREE_IN v s ∨ VFREE_IN v t` - (rw[equation_def,VFREE_IN_def] >> metis_tac[]) - -Theorem equation_intro - `(ty = typeof p) ⇒ (Comb (Comb (Equal ty) p) q = p === q)` - (rw[equation_def]) +Theorem EQUATION_HAS_TYPE_BOOL: + ∀s t. (s === t) has_type Bool + ⇔ welltyped s ∧ welltyped t ∧ (typeof s = typeof t) +Proof + rw[equation_def] >> rw[Ntimes has_type_cases 3] >> + metis_tac[WELLTYPED_LEMMA,WELLTYPED] +QED + +Theorem welltyped_equation: + ∀s t. welltyped (s === t) ⇔ s === t has_type Bool +Proof + simp[EQUATION_HAS_TYPE_BOOL] >> simp[equation_def] +QED + +Theorem typeof_equation: + welltyped (l === r) ⇒ (typeof (l === r)) = Bool +Proof + rw[welltyped_equation] >> imp_res_tac WELLTYPED_LEMMA >> rw[] +QED + +Theorem vfree_in_equation: + VFREE_IN v (s === t) ⇔ (v = Equal (typeof s)) ∨ VFREE_IN v s ∨ VFREE_IN v t +Proof + rw[equation_def,VFREE_IN_def] >> metis_tac[] +QED + +Theorem equation_intro: + (ty = typeof p) ⇒ (Comb (Comb (Equal ty) p) q = p === q) +Proof + rw[equation_def] +QED (* type_ok *) -Theorem type_ok_TYPE_SUBST - `∀s tyin ty. +Theorem type_ok_TYPE_SUBST: + ∀s tyin ty. type_ok s ty ∧ EVERY (type_ok s) (MAP FST tyin) - ⇒ type_ok s (TYPE_SUBST tyin ty)` - (gen_tac >> ho_match_mp_tac TYPE_SUBST_ind >> + ⇒ type_ok s (TYPE_SUBST tyin ty) +Proof + gen_tac >> ho_match_mp_tac TYPE_SUBST_ind >> simp[type_ok_def] >> rw[EVERY_MAP,EVERY_MEM] >> fs[FORALL_PROD] >> - metis_tac[REV_ASSOCD_MEM,type_ok_def]) - -Theorem type_ok_TYPE_SUBST_imp - `∀s tyin ty. type_ok s (TYPE_SUBST tyin ty) ⇒ - ∀x. MEM x (tyvars ty) ⇒ type_ok s (TYPE_SUBST tyin (Tyvar x))` - (gen_tac >> ho_match_mp_tac TYPE_SUBST_ind >> + metis_tac[REV_ASSOCD_MEM,type_ok_def] +QED + +Theorem type_ok_TYPE_SUBST_imp: + ∀s tyin ty. type_ok s (TYPE_SUBST tyin ty) ⇒ + ∀x. MEM x (tyvars ty) ⇒ type_ok s (TYPE_SUBST tyin (Tyvar x)) +Proof + gen_tac >> ho_match_mp_tac TYPE_SUBST_ind >> simp[tyvars_def,MEM_FOLDR_LIST_UNION,type_ok_def] >> rw[] >> - fs[EVERY_MAP,EVERY_MEM] >> metis_tac[]) + fs[EVERY_MAP,EVERY_MEM] >> metis_tac[] +QED (* term_ok *) -Theorem term_ok_welltyped - `∀sig t. term_ok sig t ⇒ welltyped t` - (Cases >> Induct >> simp[term_ok_def] >> rw[]) - -Theorem term_ok_type_ok - `∀sig t. is_std_sig sig ∧ term_ok sig t - ⇒ type_ok (FST sig) (typeof t)` - (Cases >> Induct >> simp[term_ok_def] >> rw[] >> - fs[is_std_sig_def,type_ok_def]) - -Theorem term_ok_equation - `is_std_sig sig ⇒ +Theorem term_ok_welltyped: + ∀sig t. term_ok sig t ⇒ welltyped t +Proof + Cases >> Induct >> simp[term_ok_def] >> rw[] +QED + +Theorem term_ok_type_ok: + ∀sig t. is_std_sig sig ∧ term_ok sig t + ⇒ type_ok (FST sig) (typeof t) +Proof + Cases >> Induct >> simp[term_ok_def] >> rw[] >> + fs[is_std_sig_def,type_ok_def] +QED + +Theorem term_ok_equation: + is_std_sig sig ⇒ (term_ok sig (s === t) ⇔ term_ok sig s ∧ term_ok sig t ∧ - typeof t = typeof s)` - (Cases_on`sig` >> rw[equation_def,term_ok_def] >> + typeof t = typeof s) +Proof + Cases_on`sig` >> rw[equation_def,term_ok_def] >> rw[EQ_IMP_THM] >> imp_res_tac term_ok_welltyped >> imp_res_tac term_ok_type_ok >> fs[is_std_sig_def,type_ok_def] >> qexists_tac`[(typeof s,Tyvar (strlit "A"))]` >> - rw[holSyntaxLibTheory.REV_ASSOCD_def]) + rw[holSyntaxLibTheory.REV_ASSOCD_def] +QED -Theorem term_ok_clauses - `is_std_sig sig ⇒ +Theorem term_ok_clauses: + is_std_sig sig ⇒ (term_ok sig (Var s ty) ⇔ type_ok (tysof sig) ty) ∧ (type_ok (tysof sig) (Tyvar a) ⇔ T) ∧ (type_ok (tysof sig) Bool ⇔ T) ∧ @@ -1493,22 +1696,25 @@ Theorem term_ok_clauses (term_ok sig (Comb t1 t2) ⇔ term_ok sig t1 ∧ term_ok sig t2 ∧ welltyped (Comb t1 t2)) ∧ (term_ok sig (Equal ty) ⇔ type_ok (tysof sig) ty) ∧ (term_ok sig (t1 === t2) ⇔ term_ok sig t1 ∧ term_ok sig t2 ∧ typeof t1 = typeof t2) ∧ - (term_ok sig (Abs (Var s ty) t) ⇔ type_ok (tysof sig) ty ∧ term_ok sig t)` - (rw[term_ok_def,type_ok_def,term_ok_equation] >> + (term_ok sig (Abs (Var s ty) t) ⇔ type_ok (tysof sig) ty ∧ term_ok sig t) +Proof + rw[term_ok_def,type_ok_def,term_ok_equation] >> fs[is_std_sig_def] >> TRY ( rw[EQ_IMP_THM] >> qexists_tac`[(ty,Tyvar(strlit"A"))]` >> EVAL_TAC >> NO_TAC) >> - metis_tac[]) + metis_tac[] +QED -Theorem term_ok_VSUBST - `∀sig tm ilist. +Theorem term_ok_VSUBST: + ∀sig tm ilist. term_ok sig tm ∧ (∀s s'. MEM (s',s) ilist ⇒ ∃x ty. s = Var x ty ∧ s' has_type ty ∧ term_ok sig s') ⇒ - term_ok sig (VSUBST ilist tm)` - (Cases >> Induct >> simp[VSUBST_def,term_ok_def] >- ( + term_ok sig (VSUBST ilist tm) +Proof + Cases >> Induct >> simp[VSUBST_def,term_ok_def] >- ( ntac 2 gen_tac >> Induct >> simp[REV_ASSOCD,term_ok_def] >> Cases >> simp[REV_ASSOCD] >> rw[term_ok_def] >> metis_tac[]) >- ( @@ -1520,17 +1726,19 @@ Theorem term_ok_VSUBST rw[term_ok_def] >> simp[] >> rw[term_ok_def] >> first_x_assum match_mp_tac >> rw[term_ok_def,MEM_FILTER] >> - simp[Once has_type_cases]) + simp[Once has_type_cases] +QED -Theorem term_ok_INST_CORE - `∀sig env tyin tm. +Theorem term_ok_INST_CORE: + ∀sig env tyin tm. term_ok sig tm ∧ EVERY (type_ok (FST sig)) (MAP FST tyin) ∧ (∀s s'. MEM (s,s') env ⇒ ∃x ty. s = Var x ty ∧ s' = Var x (TYPE_SUBST tyin ty)) ∧ IS_RESULT (INST_CORE env tyin tm) ⇒ - term_ok sig (RESULT (INST_CORE env tyin tm))` - (Cases >> ho_match_mp_tac INST_CORE_ind >> + term_ok sig (RESULT (INST_CORE env tyin tm)) +Proof + Cases >> ho_match_mp_tac INST_CORE_ind >> simp[term_ok_def,INST_CORE_def] >> rw[term_ok_def,type_ok_TYPE_SUBST] >- ( HINT_EXISTS_TAC >> rw[] >- @@ -1554,34 +1762,43 @@ Theorem term_ok_INST_CORE rw[term_ok_def] ) >> rw[] >> metis_tac[] ) >> - simp[welltyped_def] >> PROVE_TAC[]) + simp[welltyped_def] >> PROVE_TAC[] +QED -Theorem term_ok_INST - `∀sig tyin tm. +Theorem term_ok_INST: + ∀sig tyin tm. term_ok sig tm ∧ EVERY (type_ok (FST sig)) (MAP FST tyin) ⇒ - term_ok sig (INST tyin tm)` - (rw[INST_def] >> - metis_tac[INST_CORE_NIL_IS_RESULT,term_ok_welltyped,term_ok_INST_CORE,MEM]) - -Theorem term_ok_raconv - `∀env tp. RACONV env tp ⇒ + term_ok sig (INST tyin tm) +Proof + rw[INST_def] >> + metis_tac[INST_CORE_NIL_IS_RESULT,term_ok_welltyped,term_ok_INST_CORE,MEM] +QED + +Theorem term_ok_raconv: + ∀env tp. RACONV env tp ⇒ ∀sig. EVERY (λ(s,s'). welltyped s ∧ welltyped s' ∧ typeof s = typeof s' ∧ type_ok (FST sig) (typeof s)) env ⇒ - term_ok sig (FST tp) ∧ welltyped (SND tp) ⇒ term_ok sig (SND tp)` - (ho_match_mp_tac RACONV_strongind >> + term_ok sig (FST tp) ∧ welltyped (SND tp) ⇒ term_ok sig (SND tp) +Proof + ho_match_mp_tac RACONV_strongind >> rw[] >> Cases_on`sig`>>fs[term_ok_def] >- ( imp_res_tac ALPHAVARS_MEM >> fs[EVERY_MEM,FORALL_PROD] >> res_tac >> fs[] >> rw[] ) >> - rw[] >> fs[]) + rw[] >> fs[] +QED -Theorem term_ok_aconv - `∀sig t1 t2. ACONV t1 t2 ∧ term_ok sig t1 ∧ welltyped t2 ⇒ term_ok sig t2` - (rw[ACONV_def] >> imp_res_tac term_ok_raconv >> fs[]) +Theorem term_ok_aconv: + ∀sig t1 t2. ACONV t1 t2 ∧ term_ok sig t1 ∧ welltyped t2 ⇒ term_ok sig t2 +Proof + rw[ACONV_def] >> imp_res_tac term_ok_raconv >> fs[] +QED -Theorem term_ok_VFREE_IN - `∀sig t x. VFREE_IN x t ∧ term_ok sig t ⇒ term_ok sig x` - (gen_tac >> Induct >> simp[term_ok_def] >> metis_tac[]) +Theorem term_ok_VFREE_IN: + ∀sig t x. VFREE_IN x t ∧ term_ok sig t ⇒ term_ok sig x +Proof + gen_tac >> Induct >> simp[term_ok_def] >> metis_tac[] +QED (* de Bruijn terms, for showing alpha-equivalence respect by substitution and instantiation *) @@ -1630,18 +1847,21 @@ val dbVFREE_IN_def = Define` (dbVFREE_IN v (dbAbs ty t) ⇔ dbVFREE_IN v t)` val _ = export_rewrites["dbVFREE_IN_def"] -Theorem bind_not_free - `∀t n v. ¬dbVFREE_IN (UNCURRY dbVar v) t ⇒ bind v n t = t` - (Induct >> simp[] >> rw[]) +Theorem bind_not_free: + ∀t n v. ¬dbVFREE_IN (UNCURRY dbVar v) t ⇒ bind v n t = t +Proof + Induct >> simp[] >> rw[] +QED -Theorem bind_dbVSUBST - `∀tm v n ls. +Theorem bind_dbVSUBST: + ∀tm v n ls. (UNCURRY dbVar v) ∉ set (MAP SND ls) ∧ (∀k. dbVFREE_IN k tm ∧ MEM k (MAP SND ls) ⇒ ¬dbVFREE_IN (UNCURRY dbVar v) (REV_ASSOCD k ls k)) ⇒ - bind v n (dbVSUBST ls tm) = dbVSUBST ls (bind v n tm)` - (Induct >> simp[] >> + bind v n (dbVSUBST ls tm) = dbVSUBST ls (bind v n tm) +Proof + Induct >> simp[] >> CONV_TAC (RESORT_FORALL_CONV List.rev) >> rw[] >- ( `REV_ASSOCD (dbVar m t) ls (dbVar m t) = dbVar m t` by ( @@ -1650,31 +1870,37 @@ Theorem bind_dbVSUBST rw[] ) >> Induct_on`ls` >- simp[REV_ASSOCD] >> Cases >> simp[REV_ASSOCD] >> strip_tac >> - rw[] >> metis_tac[bind_not_free]) + rw[] >> metis_tac[bind_not_free] +QED -Theorem bind_dbVSUBST_cons - `∀tm z x n ls. +Theorem bind_dbVSUBST_cons: + ∀tm z x n ls. ¬dbVFREE_IN (UNCURRY dbVar z) (dbVSUBST ls (bind x n tm)) ⇒ - bind z n (dbVSUBST ((UNCURRY dbVar z,UNCURRY dbVar x)::ls) tm) = dbVSUBST ls (bind x n tm)` - (Induct >> simp[] >> + bind z n (dbVSUBST ((UNCURRY dbVar z,UNCURRY dbVar x)::ls) tm) = dbVSUBST ls (bind x n tm) +Proof + Induct >> simp[] >> CONV_TAC (RESORT_FORALL_CONV List.rev) >> rw[REV_ASSOCD] >>fs[] >- ( Cases_on`z`>>fs[] ) >> Cases_on`z`>>fs[] >- ( Cases_on`x`>>fs[] ) >> - match_mp_tac bind_not_free >> fs[] ) + match_mp_tac bind_not_free >> fs[] +QED -Theorem dbVSUBST_frees - `∀tm ls ls'. +Theorem dbVSUBST_frees: + ∀tm ls ls'. (∀k. dbVFREE_IN k tm ⇒ REV_ASSOCD k ls k = REV_ASSOCD k ls' k) ⇒ - dbVSUBST ls tm = dbVSUBST ls' tm` - (Induct >> simp[]) - -Theorem dbVFREE_IN_bind - `∀tm x v n b. dbVFREE_IN x (bind v n tm) ⇔ (x ≠ UNCURRY dbVar v) ∧ dbVFREE_IN x tm` - (Induct >> simp[] >> rw[] >- metis_tac[] + dbVSUBST ls tm = dbVSUBST ls' tm +Proof + Induct >> simp[] +QED + +Theorem dbVFREE_IN_bind: + ∀tm x v n b. dbVFREE_IN x (bind v n tm) ⇔ (x ≠ UNCURRY dbVar v) ∧ dbVFREE_IN x tm +Proof + Induct >> simp[] >> rw[] >- metis_tac[] >- ( Cases_on`x`>>fs[]>> Cases_on`v`>>fs[]>> @@ -1683,50 +1909,60 @@ Theorem dbVFREE_IN_bind Cases_on`x`>>fs[]>> Cases_on`v`>>fs[]) >> Cases_on`v`>>fs[]>> - Cases_on`x=dbVar q r`>>fs[]) + Cases_on`x=dbVar q r`>>fs[] +QED -Theorem dbVFREE_IN_VFREE_IN - `∀tm x. welltyped tm ⇒ (dbVFREE_IN (db x) (db tm) ⇔ VFREE_IN x tm)` - (Induct >> simp[VFREE_IN_def] >- ( +Theorem dbVFREE_IN_VFREE_IN: + ∀tm x. welltyped tm ⇒ (dbVFREE_IN (db x) (db tm) ⇔ VFREE_IN x tm) +Proof + Induct >> simp[VFREE_IN_def] >- ( ntac 2 gen_tac >> Cases >> simp[VFREE_IN_def] ) >- ( ntac 2 gen_tac >> Cases >> simp[VFREE_IN_def] ) >> simp[dbVFREE_IN_bind,PULL_EXISTS] >> - Cases >> simp[] >> metis_tac[] ) + Cases >> simp[] >> metis_tac[] +QED -Theorem MAP_db_FILTER_neq - `∀ls z ty. MAP (λ(x,y). (db x, db y)) (FILTER (λ(x,y). y ≠ Var z ty) ls) = FILTER (λ(x,y). y ≠ dbVar z ty) (MAP (λ(x,y). (db x, db y)) ls)` - (Induct >> simp[] >> +Theorem MAP_db_FILTER_neq: + ∀ls z ty. MAP (λ(x,y). (db x, db y)) (FILTER (λ(x,y). y ≠ Var z ty) ls) = FILTER (λ(x,y). y ≠ dbVar z ty) (MAP (λ(x,y). (db x, db y)) ls) +Proof + Induct >> simp[] >> Cases >> simp[] >> - rw[] >-( Cases_on`r`>>fs[] ) >> fs[]) + rw[] >-( Cases_on`r`>>fs[] ) >> fs[] +QED -Theorem REV_ASSOCD_MAP_db - `∀ls k ky. +Theorem REV_ASSOCD_MAP_db: + ∀ls k ky. (∀k v. MEM (v,k) ls ⇒ ∃x ty. k = Var x ty) ⇒ - REV_ASSOCD (dbVar k ky) (MAP (λ(x,y). (db x, db y)) ls) (dbVar k ky) = db (REV_ASSOCD (Var k ky) ls (Var k ky))` - (Induct >> simp[REV_ASSOCD] >> + REV_ASSOCD (dbVar k ky) (MAP (λ(x,y). (db x, db y)) ls) (dbVar k ky) = db (REV_ASSOCD (Var k ky) ls (Var k ky)) +Proof + Induct >> simp[REV_ASSOCD] >> Cases >> simp[REV_ASSOCD] >> rw[] >> fs[] >- ( Cases_on`r`>>fs[]>>rw[] ) >> `∃x ty. r = Var x ty` by metis_tac[] >> fs[] >> - metis_tac[]) + metis_tac[] +QED -Theorem dbVFREE_IN_dbVSUBST - `∀tm u uty ilist. +Theorem dbVFREE_IN_dbVSUBST: + ∀tm u uty ilist. dbVFREE_IN (dbVar u uty) (dbVSUBST ilist tm) ⇔ ∃y ty. dbVFREE_IN (dbVar y ty) tm ∧ dbVFREE_IN (dbVar u uty) - (REV_ASSOCD (dbVar y ty) ilist (dbVar y ty))` - (Induct >> simp[] >> rw[] >> metis_tac[]) + (REV_ASSOCD (dbVar y ty) ilist (dbVar y ty)) +Proof + Induct >> simp[] >> rw[] >> metis_tac[] +QED -Theorem VSUBST_dbVSUBST - `∀tm ilist. +Theorem VSUBST_dbVSUBST: + ∀tm ilist. welltyped tm ∧ (∀k v. MEM (v,k) ilist ⇒ welltyped v ∧ ∃x ty. k = Var x ty) ⇒ - db (VSUBST ilist tm) = dbVSUBST (MAP (λ(x,y). (db x, db y)) ilist) (db tm)` - (Induct >- ( + db (VSUBST ilist tm) = dbVSUBST (MAP (λ(x,y). (db x, db y)) ilist) (db tm) +Proof + Induct >- ( simp[VSUBST_def] >> ntac 2 gen_tac >> Induct >> simp[REV_ASSOCD] >> @@ -1825,7 +2061,8 @@ Theorem VSUBST_dbVSUBST match_mp_tac dbVSUBST_frees >> simp[Abbr`ilist'`,MAP_db_FILTER_neq,REV_ASSOCD_FILTER] >> rw[Abbr`x`] >> - fs[dbVFREE_IN_bind]) + fs[dbVFREE_IN_bind] +QED (* de Bruijn version of INST *) @@ -1837,27 +2074,32 @@ val dbINST_def = Define` dbINST tyin (dbAbs ty t) = dbAbs (TYPE_SUBST tyin ty) (dbINST tyin t)` val _ = export_rewrites["dbINST_def"] -Theorem dbINST_bind - `∀tm v n ls. +Theorem dbINST_bind: + ∀tm v n ls. (∀ty. dbVFREE_IN (dbVar (FST v) ty) tm ∧ (TYPE_SUBST ls ty = TYPE_SUBST ls (SND v)) ⇒ ty = SND v) - ⇒ dbINST ls (bind v n tm) = bind (FST v,TYPE_SUBST ls (SND v)) n (dbINST ls tm)` - (Induct >> simp[] >> + ⇒ dbINST ls (bind v n tm) = bind (FST v,TYPE_SUBST ls (SND v)) n (dbINST ls tm) +Proof + Induct >> simp[] >> Cases_on`v`>>simp[] >> rpt strip_tac >> BasicProvers.CASE_TAC >> fs[] >> - BasicProvers.CASE_TAC >> fs[]) - -Theorem dbVSUBST_nil - `∀tm. dbVSUBST [] tm = tm` - (Induct >> simp[REV_ASSOCD]) + BasicProvers.CASE_TAC >> fs[] +QED + +Theorem dbVSUBST_nil: + ∀tm. dbVSUBST [] tm = tm +Proof + Induct >> simp[REV_ASSOCD] +QED val _ = export_rewrites["dbVSUBST_nil"] -Theorem INST_CORE_dbINST - `∀tm tyin env tmi. +Theorem INST_CORE_dbINST: + ∀tm tyin env tmi. welltyped tm ∧ (∀s s'. MEM (s,s') env ⇒ ∃x ty. s = Var x ty ∧ s' = Var x (TYPE_SUBST tyin ty)) ∧ INST_CORE env tyin tm = Result tmi ⇒ - db tmi = dbINST tyin (db tm)` - (completeInduct_on`sizeof tm` >> Cases >> simp[] >- ( + db tmi = dbINST tyin (db tm) +Proof + completeInduct_on`sizeof tm` >> Cases >> simp[] >- ( strip_tac >> simp[INST_CORE_def] >> rw[] >> rw[] ) @@ -1968,18 +2210,21 @@ Theorem INST_CORE_dbINST strip_tac >> last_x_assum(qspecl_then[`z`,`ty2`]mp_tac) >> simp[] ) >> - simp[]) + simp[] +QED -Theorem INST_dbINST - `∀tm tyin. +Theorem INST_dbINST: + ∀tm tyin. welltyped tm ⇒ - db (INST tyin tm) = dbINST tyin (db tm)` - (rw[INST_def] >> + db (INST tyin tm) = dbINST tyin (db tm) +Proof + rw[INST_def] >> imp_res_tac INST_CORE_NIL_IS_RESULT >> pop_assum(qspec_then`tyin`strip_assume_tac) >> Cases_on`INST_CORE [] tyin tm`>>fs[] >> qspecl_then[`tm`,`tyin`,`[]`,`a`]mp_tac INST_CORE_dbINST >> - simp[]) + simp[] +QED (* conversion into de Bruijn given an environment of already bound variables *) @@ -1996,32 +2241,39 @@ val bind_list_aux_def = Define` bind_list_aux n (v::vs) tm = bind_list_aux (n+1) vs (bind v n tm)` val _ = export_rewrites["bind_list_aux_def"] -Theorem bind_list_aux_clauses - `(∀env m. bind_list_aux m env (dbBound n) = dbBound n) ∧ +Theorem bind_list_aux_clauses: + (∀env m. bind_list_aux m env (dbBound n) = dbBound n) ∧ (∀env m. bind_list_aux m env (dbConst x ty) = dbConst x ty) ∧ (∀env m t1 t2. bind_list_aux m env (dbComb t1 t2) = dbComb (bind_list_aux m env t1) (bind_list_aux m env t2)) ∧ - (∀env m ty tm. bind_list_aux m env (dbAbs ty tm) = dbAbs ty (bind_list_aux (m+1) env tm))` - (rpt conj_tac >> Induct >> simp[]) - -Theorem dbterm_bind - `∀tm env. dbterm env tm = bind_list_aux 0 env (db tm)` - (Induct >> simp[bind_list_aux_clauses] >> + (∀env m ty tm. bind_list_aux m env (dbAbs ty tm) = dbAbs ty (bind_list_aux (m+1) env tm)) +Proof + rpt conj_tac >> Induct >> simp[] +QED + +Theorem dbterm_bind: + ∀tm env. dbterm env tm = bind_list_aux 0 env (db tm) +Proof + Induct >> simp[bind_list_aux_clauses] >> gen_tac >> Q.SPEC_TAC(`0n`,`n`) >> Induct_on`env` >> simp[find_index_def] >> Cases >> simp[] >> - rw[] >> rw[bind_list_aux_clauses]) + rw[] >> rw[bind_list_aux_clauses] +QED -Theorem dbterm_db - `∀tm. dbterm [] tm = db tm` - (rw[dbterm_bind]) +Theorem dbterm_db: + ∀tm. dbterm [] tm = db tm +Proof + rw[dbterm_bind] +QED (* alpha-equivalence on de Bruijn terms *) -Theorem dbterm_RACONV - `∀t1 env1 t2 env2. welltyped t1 ∧ welltyped t2 ∧ dbterm env1 t1 = dbterm env2 t2 ∧ LENGTH env1 = LENGTH env2 ⇒ - RACONV (ZIP(MAP (UNCURRY Var) env1,MAP (UNCURRY Var) env2)) (t1,t2)` - (Induct >- ( +Theorem dbterm_RACONV: + ∀t1 env1 t2 env2. welltyped t1 ∧ welltyped t2 ∧ dbterm env1 t1 = dbterm env2 t2 ∧ LENGTH env1 = LENGTH env2 ⇒ + RACONV (ZIP(MAP (UNCURRY Var) env1,MAP (UNCURRY Var) env2)) (t1,t2) +Proof + Induct >- ( ntac 3 gen_tac >> simp[] >> Cases >> simp[RACONV] >> TRY (BasicProvers.CASE_TAC >> simp[] >> NO_TAC) >> @@ -2045,14 +2297,16 @@ Theorem dbterm_RACONV gen_tac >> Cases >> simp[RACONV] >- ( gen_tac >> BasicProvers.CASE_TAC >> simp[] ) >> - rw[] >> res_tac >> fs[]) + rw[] >> res_tac >> fs[] +QED -Theorem RACONV_dbterm - `∀env tp. RACONV env tp ⇒ +Theorem RACONV_dbterm: + ∀env tp. RACONV env tp ⇒ welltyped (FST tp) ∧ welltyped (SND tp) ∧ (∀vp. MEM vp env ⇒ (∃x ty. (FST vp = Var x ty)) ∧ (∃x ty. (SND vp = Var x ty))) - ⇒ dbterm (MAP (dest_var o FST) env) (FST tp) = dbterm (MAP (dest_var o SND) env) (SND tp)` - (ho_match_mp_tac RACONV_ind >> rw[] >> rw[] >> fs[PULL_EXISTS] >> rw[] >> + ⇒ dbterm (MAP (dest_var o FST) env) (FST tp) = dbterm (MAP (dest_var o SND) env) (SND tp) +Proof + ho_match_mp_tac RACONV_ind >> rw[] >> rw[] >> fs[PULL_EXISTS] >> rw[] >> TRY ( first_x_assum match_mp_tac >> rw[] >> rw[] >> NO_TAC ) >> @@ -2064,38 +2318,47 @@ Theorem RACONV_dbterm simp[] >> simp[Once find_index_shift_0] >> simp[Once find_index_shift_0,SimpRHS] >> - rpt BasicProvers.CASE_TAC >> fs[] >> rw[] >> fs[]) + rpt BasicProvers.CASE_TAC >> fs[] >> rw[] >> fs[] +QED -Theorem dbterm_ACONV - `∀t1 t2. welltyped t1 ∧ welltyped t2 ⇒ (ACONV t1 t2 ⇔ dbterm [] t1 = dbterm [] t2)` - (rw[ACONV_def,EQ_IMP_THM] >- ( +Theorem dbterm_ACONV: + ∀t1 t2. welltyped t1 ∧ welltyped t2 ⇒ (ACONV t1 t2 ⇔ dbterm [] t1 = dbterm [] t2) +Proof + rw[ACONV_def,EQ_IMP_THM] >- ( qspecl_then[`[]`,`t1,t2`]mp_tac RACONV_dbterm >> simp[] ) >> qspecl_then[`t1`,`[]`,`t2`,`[]`]mp_tac dbterm_RACONV >> - simp[]) + simp[] +QED -Theorem ACONV_db - `∀t1 t2. welltyped t1 ∧ welltyped t2 ⇒ (ACONV t1 t2 ⇔ db t1 = db t2)` - (metis_tac[dbterm_ACONV,dbterm_db]) +Theorem ACONV_db: + ∀t1 t2. welltyped t1 ∧ welltyped t2 ⇒ (ACONV t1 t2 ⇔ db t1 = db t2) +Proof + metis_tac[dbterm_ACONV,dbterm_db] +QED (* respect of alpha-equivalence by VSUBST and INST follows *) -Theorem ACONV_VSUBST - `∀t1 t2 ilist. +Theorem ACONV_VSUBST: + ∀t1 t2 ilist. welltyped t1 ∧ welltyped t2 ∧ (∀k v. MEM (v,k) ilist ⇒ ∃x ty. k = Var x ty ∧ v has_type ty) ∧ ACONV t1 t2 ⇒ - ACONV (VSUBST ilist t1) (VSUBST ilist t2)` - (rw[] >> + ACONV (VSUBST ilist t1) (VSUBST ilist t2) +Proof + rw[] >> imp_res_tac VSUBST_WELLTYPED >> rw[ACONV_db] >> - metis_tac[ACONV_db,VSUBST_dbVSUBST,welltyped_def]) + metis_tac[ACONV_db,VSUBST_dbVSUBST,welltyped_def] +QED -Theorem ACONV_INST - `∀t1 t2 tyin. welltyped t1 ∧ welltyped t2 ∧ ACONV t1 t2 ⇒ ACONV (INST tyin t1) (INST tyin t2)` - (rw[] >> +Theorem ACONV_INST: + ∀t1 t2 tyin. welltyped t1 ∧ welltyped t2 ∧ ACONV t1 t2 ⇒ ACONV (INST tyin t1) (INST tyin t2) +Proof + rw[] >> imp_res_tac INST_WELLTYPED >> rw[ACONV_db] >> imp_res_tac INST_dbINST >> - rfs[ACONV_db] ) + rfs[ACONV_db] +QED (* list of bound variable names in a term *) @@ -2126,12 +2389,13 @@ val simple_inst_def = Define` simple_inst tyin (Abs v t) = Abs (simple_inst tyin v) (simple_inst tyin t)` val _ = export_rewrites["simple_inst_def"] -Theorem VSUBST_simple_subst - `∀tm ilist. DISJOINT (set (bv_names tm)) {y | ∃ty u. VFREE_IN (Var y ty) u ∧ MEM u (MAP FST ilist)} ∧ +Theorem VSUBST_simple_subst: + ∀tm ilist. DISJOINT (set (bv_names tm)) {y | ∃ty u. VFREE_IN (Var y ty) u ∧ MEM u (MAP FST ilist)} ∧ (∀s s'. MEM (s',s) ilist ⇒ ∃x ty. s = Var x ty) ∧ welltyped tm - ⇒ VSUBST ilist tm = simple_subst ilist tm` - (Induct + ⇒ VSUBST ilist tm = simple_subst ilist tm +Proof + Induct >- simp[VSUBST_def] >- simp[VSUBST_def] >- ( @@ -2148,17 +2412,19 @@ Theorem VSUBST_simple_subst first_x_assum match_mp_tac >> simp[rich_listTheory.MAP_SND_FILTER_NEQ,MEM_FILTER,MEM_MAP,EXISTS_PROD] >> fs[MEM_MAP,EXISTS_PROD,IN_DISJOINT] >> - metis_tac[]) + metis_tac[] +QED -Theorem INST_CORE_simple_inst - `∀env tyin tm. +Theorem INST_CORE_simple_inst: + ∀env tyin tm. ALL_DISTINCT (bv_names tm ++ (MAP (FST o dest_var o SND) env)) ∧ DISJOINT (set(bv_names tm)) {x | ∃ty. VFREE_IN (Var x ty) tm} ∧ (∀s s'. MEM (s,s') env ⇒ ∃x ty. s = Var x ty ∧ s' = Var x (TYPE_SUBST tyin ty)) ∧ (∀x ty ty'. VFREE_IN (Var x ty) tm ∧ MEM (Var x ty') (MAP FST env) ⇒ ty' = ty) ∧ welltyped tm - ⇒ INST_CORE env tyin tm = Result (simple_inst tyin tm)` - (ho_match_mp_tac INST_CORE_ind >> + ⇒ INST_CORE env tyin tm = Result (simple_inst tyin tm) +Proof + ho_match_mp_tac INST_CORE_ind >> conj_tac >- ( simp[INST_CORE_def] >> rpt gen_tac >> strip_tac >> rw[] >> imp_res_tac (REWRITE_RULE[PROVE[]``A ∨ B ⇔ ¬B ⇒ A``]REV_ASSOCD_MEM) >> @@ -2198,26 +2464,30 @@ Theorem INST_CORE_simple_inst metis_tac[dest_var_def,FST] ) >> fs[MEM_MAP,FORALL_PROD,EXISTS_PROD] >> metis_tac[dest_var_def,FST] ) >> - fs[]) + fs[] +QED -Theorem INST_simple_inst - `∀tyin tm. +Theorem INST_simple_inst: + ∀tyin tm. ALL_DISTINCT (bv_names tm) ∧ DISJOINT (set (bv_names tm)) {x | ∃ty. VFREE_IN (Var x ty) tm} ∧ welltyped tm ⇒ - INST tyin tm = simple_inst tyin tm` - (rw[INST_def] >> + INST tyin tm = simple_inst tyin tm +Proof + rw[INST_def] >> qspecl_then[`[]`,`tyin`,`tm`]mp_tac INST_CORE_simple_inst >> - simp[]) + simp[] +QED -Theorem simple_subst_has_type - `∀tm ty. +Theorem simple_subst_has_type: + ∀tm ty. tm has_type ty ⇒ ∀subst. EVERY (λ(s',s). s' has_type typeof s) subst ⇒ - simple_subst subst tm has_type ty` - (ho_match_mp_tac has_type_ind >> + simple_subst subst tm has_type ty +Proof + ho_match_mp_tac has_type_ind >> simp[] >> rw[] >- ( simp[REV_ASSOCD_ALOOKUP] >> BasicProvers.CASE_TAC >- rw[Once has_type_cases] >> imp_res_tac ALOOKUP_MEM >> @@ -2227,11 +2497,14 @@ Theorem simple_subst_has_type >- ( rw[Once has_type_cases] >> metis_tac[] ) >> rw[Once has_type_cases] >> first_x_assum match_mp_tac >> - fs[EVERY_FILTER,EVERY_MEM]) + fs[EVERY_FILTER,EVERY_MEM] +QED -Theorem simple_inst_has_type - `∀tm tyin. welltyped tm ⇒ simple_inst tyin tm has_type (TYPE_SUBST tyin (typeof tm))` - (Induct >> rw[] >> rw[Once has_type_cases] >> fs[] >> metis_tac[] ) +Theorem simple_inst_has_type: + ∀tm tyin. welltyped tm ⇒ simple_inst tyin tm has_type (TYPE_SUBST tyin (typeof tm)) +Proof + Induct >> rw[] >> rw[Once has_type_cases] >> fs[] >> metis_tac[] +QED (* rename bound variables from a source of names *) @@ -2249,26 +2522,29 @@ val rename_bvars_def = Define` let (names,tm) = rename_bvars names ((s',dest_var v)::env) tm in (names, Abs (Var s' (typeof v)) tm))` -Theorem FST_rename_bvars - `∀names env tm. LENGTH (bv_names tm) ≤ LENGTH names ⇒ (FST (rename_bvars names env tm) = DROP (LENGTH (bv_names tm)) names)` - (ho_match_mp_tac (theorem"rename_bvars_ind") >> +Theorem FST_rename_bvars: + ∀names env tm. LENGTH (bv_names tm) ≤ LENGTH names ⇒ (FST (rename_bvars names env tm) = DROP (LENGTH (bv_names tm)) names) +Proof + ho_match_mp_tac (theorem"rename_bvars_ind") >> simp[rename_bvars_def] >> rw[UNCURRY] >> rw[] >> Cases_on`rename_bvars names env tm` >> fs[] >> fsrw_tac[ARITH_ss][] >> REWRITE_TAC[Once arithmeticTheory.ADD_SYM] >> match_mp_tac rich_listTheory.DROP_DROP >> - simp[]) + simp[] +QED -Theorem rename_bvars_RACONV - `∀names env tm. +Theorem rename_bvars_RACONV: + ∀names env tm. LENGTH (bv_names tm) ≤ LENGTH names ∧ DISJOINT (set (MAP FST env ++ names)) (set (MAP (FST o SND) env ++ bv_names tm)) ∧ DISJOINT (set (MAP FST env ++ names)) {x | ∃ty. VFREE_IN (Var x ty) tm} ∧ ALL_DISTINCT (MAP FST env ++ names) ∧ welltyped tm - ⇒ RACONV (MAP (λ(s',(s,ty)). (Var s ty, Var s' ty)) env) (tm, SND (rename_bvars names env tm))` - (ho_match_mp_tac (theorem"rename_bvars_ind") >> + ⇒ RACONV (MAP (λ(s',(s,ty)). (Var s ty, Var s' ty)) env) (tm, SND (rename_bvars names env tm)) +Proof + ho_match_mp_tac (theorem"rename_bvars_ind") >> simp[rename_bvars_def,RACONV] >> conj_tac >- ( gen_tac >> @@ -2317,32 +2593,39 @@ Theorem rename_bvars_RACONV first_x_assum match_mp_tac >> simp[] >> fs[IN_DISJOINT,ALL_DISTINCT_APPEND] >> - rfs[] >> metis_tac[]) + rfs[] >> metis_tac[] +QED -Theorem rename_bvars_ACONV - `∀names tm. +Theorem rename_bvars_ACONV: + ∀names tm. LENGTH (bv_names tm) ≤ LENGTH names ∧ ALL_DISTINCT names ∧ DISJOINT (set names) {x | MEM x (bv_names tm) ∨ ∃ty. VFREE_IN (Var x ty) tm} ∧ welltyped tm ⇒ - ACONV tm (SND (rename_bvars names [] tm))` - (rw[ACONV_def] >> + ACONV tm (SND (rename_bvars names [] tm)) +Proof + rw[ACONV_def] >> qspecl_then[`names`,`[]`,`tm`]mp_tac rename_bvars_RACONV >> simp[] >> disch_then match_mp_tac >> - fs[IN_DISJOINT] >> metis_tac[]) + fs[IN_DISJOINT] >> metis_tac[] +QED -Theorem rename_bvars_has_type - `∀names env tm ty. tm has_type ty ⇒ SND (rename_bvars names env tm) has_type ty` - (ho_match_mp_tac(theorem"rename_bvars_ind") >> +Theorem rename_bvars_has_type: + ∀names env tm ty. tm has_type ty ⇒ SND (rename_bvars names env tm) has_type ty +Proof + ho_match_mp_tac(theorem"rename_bvars_ind") >> srw_tac[][rename_bvars_def] >> rw[] >> fs[] >- fs[Once has_type_cases] >> qpat_x_assum`X has_type Y`mp_tac >> simp[Once has_type_cases] >> strip_tac >> - simp[Once has_type_cases] >> metis_tac[] ) + simp[Once has_type_cases] >> metis_tac[] +QED -Theorem rename_bvars_welltyped - `∀names env tm. welltyped tm ⇒ welltyped (SND (rename_bvars names env tm))` - (metis_tac[rename_bvars_has_type,welltyped_def]) +Theorem rename_bvars_welltyped: + ∀names env tm. welltyped tm ⇒ welltyped (SND (rename_bvars names env tm)) +Proof + metis_tac[rename_bvars_has_type,welltyped_def] +QED (* appropriate fresh term for using the simple functions above *) @@ -2354,22 +2637,27 @@ val fresh_def = new_specification("fresh_def",["fresh"], |> Q.GEN`s` |> SIMP_RULE(srw_ss())[SKOLEM_THM]) -Theorem fresh_union - `FINITE s ∧ FINITE t ⇒ fresh (s ∪ t) ∉ s ∧ fresh (s ∪ t) ∉ t` - (metis_tac[fresh_def,FINITE_UNION,IN_UNION]) +Theorem fresh_union: + FINITE s ∧ FINITE t ⇒ fresh (s ∪ t) ∉ s ∧ fresh (s ∪ t) ∉ t +Proof + metis_tac[fresh_def,FINITE_UNION,IN_UNION] +QED -Theorem fresh_names_exist - `∀s n. FINITE (s:string set) ⇒ ∃names. LENGTH names = n ∧ ALL_DISTINCT names ∧ DISJOINT (set names) s` - (gen_tac >> Induct >> strip_tac +Theorem fresh_names_exist: + ∀s n. FINITE (s:string set) ⇒ ∃names. LENGTH names = n ∧ ALL_DISTINCT names ∧ DISJOINT (set names) s +Proof + gen_tac >> Induct >> strip_tac >- (qexists_tac`[]`>>simp[]) >> rw[] >> fs[] >> qexists_tac`fresh (s ∪ set names)::names` >> - simp[fresh_union]) + simp[fresh_union] +QED -Theorem bv_names_rename_bvars - `∀names env tm. +Theorem bv_names_rename_bvars: + ∀names env tm. LENGTH (bv_names tm) ≤ LENGTH names ⇒ - bv_names (SND (rename_bvars names env tm)) = TAKE (LENGTH (bv_names tm)) names` - (ho_match_mp_tac(theorem"rename_bvars_ind")>> + bv_names (SND (rename_bvars names env tm)) = TAKE (LENGTH (bv_names tm)) names +Proof + ho_match_mp_tac(theorem"rename_bvars_ind")>> simp[rename_bvars_def] >> conj_tac >- ( rw[UNCURRY] >> @@ -2379,13 +2667,15 @@ Theorem bv_names_rename_bvars rw[] >> fs[] >> `LENGTH (bv_names tm') ≤ LENGTH names - LENGTH (bv_names tm)` by DECIDE_TAC >> fs[] >> simp[TAKE_SUM] ) >> - rw[UNCURRY]) + rw[UNCURRY] +QED (* various rewrites for FINITE sets to make this go through *) -Theorem FINITE_VFREE_IN - `∀tm. FINITE {x | ∃ty. VFREE_IN (Var x ty) tm}` - (Induct >> simp[] >- ( +Theorem FINITE_VFREE_IN: + ∀tm. FINITE {x | ∃ty. VFREE_IN (Var x ty) tm} +Proof + Induct >> simp[] >- ( qmatch_assum_abbrev_tac`FINITE s1` >> qpat_x_assum`FINITE s1`mp_tac >> qmatch_assum_abbrev_tac`FINITE s2` >> @@ -2398,12 +2688,14 @@ Theorem FINITE_VFREE_IN qmatch_abbrev_tac`FINITE b` >> qsuff_tac`b ⊆ a` >- metis_tac[SUBSET_FINITE] >> unabbrev_all_tac >> simp[SUBSET_DEF] >> - metis_tac[]) + metis_tac[] +QED val _ = export_rewrites["FINITE_VFREE_IN"] -Theorem FINITE_VFREE_IN_2 - `∀tm. FINITE {(x,ty) | VFREE_IN (Var x ty) tm}` - (Induct >> simp[] >- ( +Theorem FINITE_VFREE_IN_2: + ∀tm. FINITE {(x,ty) | VFREE_IN (Var x ty) tm} +Proof + Induct >> simp[] >- ( rw[] >> qmatch_abbrev_tac`FINITE x` >> qsuff_tac`∃y. x = {y}`>-metis_tac[FINITE_SING] >> @@ -2422,24 +2714,28 @@ Theorem FINITE_VFREE_IN_2 qmatch_abbrev_tac`FINITE b` >> qsuff_tac`b ⊆ a` >- metis_tac[SUBSET_FINITE] >> unabbrev_all_tac >> simp[SUBSET_DEF] >> - metis_tac[]) + metis_tac[] +QED val _ = export_rewrites["FINITE_VFREE_IN_2"] -Theorem FINITE_VFREE_IN_list - `∀ls. FINITE {x | ∃ty u. VFREE_IN (Var x ty) u ∧ MEM u ls}` - (Induct >> simp[] >> rw[] >> +Theorem FINITE_VFREE_IN_list: + ∀ls. FINITE {x | ∃ty u. VFREE_IN (Var x ty) u ∧ MEM u ls} +Proof + Induct >> simp[] >> rw[] >> qmatch_assum_abbrev_tac`FINITE s` >> qmatch_abbrev_tac`FINITE t` >> `t = s ∪ {x | ∃ty. VFREE_IN (Var x ty) h}` by ( simp[EXTENSION,Abbr`t`,Abbr`s`] >> metis_tac[] ) >> pop_assum SUBST1_TAC >> - simp[FINITE_UNION]) + simp[FINITE_UNION] +QED val _ = export_rewrites["FINITE_VFREE_IN_list"] -Theorem FINITE_MEM_Var - `∀ls. FINITE {(x,ty) | MEM (Var x ty) ls}` - (Induct >> simp[] >> +Theorem FINITE_MEM_Var: + ∀ls. FINITE {(x,ty) | MEM (Var x ty) ls} +Proof + Induct >> simp[] >> Cases >> simp[] >> qmatch_assum_abbrev_tac`FINITE P` >> qmatch_abbrev_tac`FINITE Q` >> @@ -2447,7 +2743,8 @@ Theorem FINITE_MEM_Var simp[Abbr`P`,Abbr`Q`,EXTENSION] >> metis_tac[] ) >> pop_assum SUBST1_TAC >> - simp[FINITE_INSERT] ) + simp[FINITE_INSERT] +QED val _ = export_rewrites["FINITE_MEM_Var"] val fresh_term_def = new_specification("fresh_term_def",["fresh_term"], @@ -2484,16 +2781,18 @@ val vfree_in_def = Define ` | Comb s t => vfree_in v s \/ vfree_in v t | _ => (tm = v)`; -Theorem vfree_in_thm - `!name ty y. (VFREE_IN (Var name ty) y = vfree_in (Var name ty) y)` - (ntac 2 gen_tac >> Induct >> simp[VFREE_IN_def,Once vfree_in_def] >> +Theorem vfree_in_thm: + !name ty y. (VFREE_IN (Var name ty) y = vfree_in (Var name ty) y) +Proof + ntac 2 gen_tac >> Induct >> simp[VFREE_IN_def,Once vfree_in_def] >> simp[Once vfree_in_def,SimpRHS] >> BasicProvers.CASE_TAC >> simp[Q.SPECL[`Var x1 ty1`,`Var x2 ty2`]vfree_in_def] >> simp[Q.SPECL[`Var x1 ty1`,`Const x2 ty2`]vfree_in_def] >> simp[Q.SPECL[`Var x1 ty1`,`Comb x2 ty2`]vfree_in_def] >> simp[Q.SPECL[`Var x1 ty1`,`Abs x2 ty2`]vfree_in_def] >> - METIS_TAC[]) + METIS_TAC[] +QED val variant_def = tDefine "variant" ` variant avoid v = @@ -2573,15 +2872,19 @@ val itlist_def = Define ` val union_def = Define ` union l1 l2 = itlist insert l1 l2`; -Theorem MEM_union - `!xs ys x. MEM x (union xs ys) <=> MEM x xs \/ MEM x ys` - (Induct \\ FULL_SIMP_TAC std_ss [union_def] +Theorem MEM_union: + !xs ys x. MEM x (union xs ys) <=> MEM x xs \/ MEM x ys +Proof + Induct \\ FULL_SIMP_TAC std_ss [union_def] \\ ONCE_REWRITE_TAC [itlist_def] \\ SRW_TAC [] [insert_def] - \\ METIS_TAC []); + \\ METIS_TAC [] +QED -Theorem EXISTS_union - `!xs ys. EXISTS P (union xs ys) <=> EXISTS P xs \/ EXISTS P ys` - (SIMP_TAC std_ss [EXISTS_MEM,MEM_MAP,MEM_union] \\ METIS_TAC []); +Theorem EXISTS_union: + !xs ys. EXISTS P (union xs ys) <=> EXISTS P xs \/ EXISTS P ys +Proof + SIMP_TAC std_ss [EXISTS_MEM,MEM_MAP,MEM_union] \\ METIS_TAC [] +QED val frees_def = Define ` frees tm = @@ -2591,15 +2894,17 @@ val frees_def = Define ` | Abs bv bod => subtract (frees bod) [bv] | Comb s t => union (frees s) (frees t)` -Theorem MEM_frees_EQ - `!a x. MEM x (frees a) = ?n ty. (x = Var n ty) /\ MEM (Var n ty) (frees a)` - (Induct \\ SIMP_TAC (srw_ss()) [Once frees_def,MEM_union] +Theorem MEM_frees_EQ: + !a x. MEM x (frees a) = ?n ty. (x = Var n ty) /\ MEM (Var n ty) (frees a) +Proof + Induct \\ SIMP_TAC (srw_ss()) [Once frees_def,MEM_union] THEN1 (SIMP_TAC (srw_ss()) [Once frees_def,MEM_union]) THEN1 (SIMP_TAC (srw_ss()) [Once frees_def,MEM_union]) \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] \\ SIMP_TAC (srw_ss()) [Once frees_def,MEM_union] THEN1 (METIS_TAC []) \\ SIMP_TAC (srw_ss()) [subtract_def,MEM_FILTER] - \\ REPEAT STRIP_TAC \\ EQ_TAC \\ REPEAT STRIP_TAC \\ METIS_TAC []); + \\ REPEAT STRIP_TAC \\ EQ_TAC \\ REPEAT STRIP_TAC \\ METIS_TAC [] +QED val variant_inst_thm = save_thm("variant_inst_thm",prove( ``!xs v x name a. @@ -2650,8 +2955,8 @@ val variant_inst_thm = save_thm("variant_inst_thm",prove( \\ RES_TAC \\ FULL_SIMP_TAC std_ss []) |> SIMP_RULE std_ss [] |> SPEC_ALL); -Theorem INST_CORE_Abs_thm - `∀v t env tyin. welltyped (Abs v t) ⇒ +Theorem INST_CORE_Abs_thm: + ∀v t env tyin. welltyped (Abs v t) ⇒ INST_CORE env tyin (Abs v t) = (let (x,ty) = dest_var v in let ty' = TYPE_SUBST tyin ty in @@ -2674,28 +2979,35 @@ Theorem INST_CORE_Abs_thm in if IS_RESULT tres' then Result (Abs (Var x' ty') (RESULT tres')) - else tres')))` - (rw[] >> simp[Once INST_CORE_def] >> rw[] >> + else tres'))) +Proof + rw[] >> simp[Once INST_CORE_def] >> rw[] >> unabbrev_all_tac >> fs[] >> rfs[GSYM INST_def] >> imp_res_tac INST_WELLTYPED >> - fs[variant_inst_thm] >> rw[] >> fs[]); + fs[variant_inst_thm] >> rw[] >> fs[] +QED (* provable terms are ok and of type bool *) -Theorem proves_theory_ok - `∀thyh c. thyh |- c ⇒ theory_ok (FST thyh)` - (ho_match_mp_tac proves_ind >> rw[]); +Theorem proves_theory_ok: + ∀thyh c. thyh |- c ⇒ theory_ok (FST thyh) +Proof + ho_match_mp_tac proves_ind >> rw[] +QED -Theorem theory_ok_sig - `∀thy. theory_ok thy ⇒ is_std_sig (sigof thy)` - (Cases >> rw[theory_ok_def]); +Theorem theory_ok_sig: + ∀thy. theory_ok thy ⇒ is_std_sig (sigof thy) +Proof + Cases >> rw[theory_ok_def] +QED -Theorem proves_term_ok - `∀thyh c. thyh |- c ⇒ +Theorem proves_term_ok: + ∀thyh c. thyh |- c ⇒ hypset_ok (SND thyh) ∧ - EVERY (λp. term_ok (sigof (FST thyh)) p ∧ p has_type Bool) (c::(SND thyh))` - (ho_match_mp_tac proves_strongind >> + EVERY (λp. term_ok (sigof (FST thyh)) p ∧ p has_type Bool) (c::(SND thyh)) +Proof + ho_match_mp_tac proves_strongind >> strip_tac >- ( rw[EQUATION_HAS_TYPE_BOOL] >> imp_res_tac proves_theory_ok >> @@ -2745,7 +3057,8 @@ Theorem proves_term_ok imp_res_tac term_ok_welltyped >> imp_res_tac theory_ok_sig >> rw[term_ok_equation,term_ok_def]) >> - rw[theory_ok_def]); + rw[theory_ok_def] +QED (* some derived rules *) @@ -2761,10 +3074,11 @@ val appThm_equation = save_thm("appThm_equation", proves_rules |> CONJUNCTS |> el 8 |> REWRITE_RULE[GSYM AND_IMP_INTRO]) -Theorem addAssum - `∀thy h c a. (thy,h) |- c ∧ term_ok (sigof thy) a ∧ (a has_type Bool) ⇒ - (thy,term_union [a] h) |- c` - (rw[] >> +Theorem addAssum: + ∀thy h c a. (thy,h) |- c ∧ term_ok (sigof thy) a ∧ (a has_type Bool) ⇒ + (thy,term_union [a] h) |- c +Proof + rw[] >> ho_match_mp_tac (MP_CANON eqMp_equation) >> map_every qexists_tac[`c`,`c`] >> simp[] >> qspecl_then[`a`,`thy`]mp_tac assume >> @@ -2784,7 +3098,8 @@ Theorem addAssum simp[Once term_remove_def,GSYM ACONV_eq_orda] ) >> rw[] >> imp_res_tac eqMp_equation >> - metis_tac[ACONV_REFL,term_union_idem]) + metis_tac[ACONV_REFL,term_union_idem] +QED (* inference system respects alpha-equivalence *) @@ -2892,24 +3207,27 @@ val proves_ACONV_lemma = Q.prove( metis_tac[ACONV_SYM] ) >> metis_tac[rich_listTheory.CONS_APPEND,APPEND_ASSOC]) -Theorem proves_ACONV - `∀thy h' c' h c. +Theorem proves_ACONV: + ∀thy h' c' h c. (thy,h) |- c ∧ welltyped c' ∧ ACONV c c' ∧ hypset_ok h' ∧ EVERY (λx. EXISTS (ACONV x) h') h ∧ EVERY (λx. term_ok (sigof thy) x ∧ x has_type Bool) h' - ⇒ (thy,h') |- c'` - (rw[] >> + ⇒ (thy,h') |- c' +Proof + rw[] >> qsuff_tac`(thy,h') |- c` >- metis_tac[proves_concl_ACONV] >> qpat_x_assum`welltyped c'`kall_tac >> qpat_x_assum`ACONV c c'`kall_tac >> - metis_tac[proves_ACONV_lemma,APPEND]) + metis_tac[proves_ACONV_lemma,APPEND] +QED (* more derived rules *) -Theorem sym_equation - `∀thyh p q. thyh |- p === q ⇒ thyh |- q === p` - (rpt strip_tac >> +Theorem sym_equation: + ∀thyh p q. thyh |- p === q ⇒ thyh |- q === p +Proof + rpt strip_tac >> imp_res_tac proves_theory_ok >> imp_res_tac proves_term_ok >> imp_res_tac theory_ok_sig >> @@ -2936,24 +3254,28 @@ Theorem sym_equation qpat_x_assum`typeof _ = typeof _`(assume_tac o SYM) >> simp[GSYM equation_def] >> fs[EQUATION_HAS_TYPE_BOOL] >> - metis_tac[eqMp_equation,term_union_thm,ACONV_REFL]) + metis_tac[eqMp_equation,term_union_thm,ACONV_REFL] +QED -Theorem sym - `∀thyh p q ty. +Theorem sym: + ∀thyh p q ty. thyh |- Comb (Comb (Equal ty) p) q ⇒ - thyh |- Comb (Comb (Equal ty) q) p` - (rw[] >> + thyh |- Comb (Comb (Equal ty) q) p +Proof + rw[] >> imp_res_tac proves_term_ok >> fs[] >> imp_res_tac term_ok_welltyped >> fs[] >> - metis_tac[equation_def,sym_equation]) + metis_tac[equation_def,sym_equation] +QED -Theorem trans_equation - `∀thy h1 h2 t1 t2a t2b t3. +Theorem trans_equation: + ∀thy h1 h2 t1 t2a t2b t3. (thy,h2) |- t2b === t3 ⇒ (thy,h1) |- t1 === t2a ⇒ ACONV t2a t2b ⇒ - (thy,term_union h1 h2) |- t1 === t3` - (rw[] >> + (thy,term_union h1 h2) |- t1 === t3 +Proof + rw[] >> imp_res_tac proves_theory_ok >> fs[] >> imp_res_tac theory_ok_sig >> imp_res_tac proves_term_ok >> @@ -2975,23 +3297,27 @@ Theorem trans_equation impl_tac >- ( simp[ACONV_def,RACONV,equation_def] >> simp[GSYM ACONV_def] ) >> - metis_tac[sym_equation]) + metis_tac[sym_equation] +QED -Theorem trans - `∀thy h1 h2 t1 t2a t2b t3 ty. +Theorem trans: + ∀thy h1 h2 t1 t2a t2b t3 ty. (thy,h2) |- Comb (Comb (Equal ty) t2b) t3 ⇒ (thy,h1) |- Comb (Comb (Equal ty) t1) t2a ⇒ ACONV t2a t2b ⇒ - (thy,term_union h1 h2) |- Comb (Comb (Equal ty) t1) t3` - (rw[] >> + (thy,term_union h1 h2) |- Comb (Comb (Equal ty) t1) t3 +Proof + rw[] >> imp_res_tac proves_term_ok >> fs[] >> imp_res_tac term_ok_welltyped >> fs[] >> - metis_tac[trans_equation,equation_def]) + metis_tac[trans_equation,equation_def] +QED -Theorem proveHyp - `∀thy h1 c1 h2 c2. (thy,h1) |- c1 ∧ (thy,h2) |- c2 ⇒ - (thy,term_union h2 (term_remove c2 h1)) |- c1` - (rw[] >> +Theorem proveHyp: + ∀thy h1 c1 h2 c2. (thy,h1) |- c1 ∧ (thy,h2) |- c2 ⇒ + (thy,term_union h2 (term_remove c2 h1)) |- c1 +Proof + rw[] >> imp_res_tac proves_term_ok >> imp_res_tac proves_theory_ok >> fs[] >> qspecl_then[`c2`,`c1`,`h2`,`h1`,`thy`]mp_tac deductAntisym_equation >> @@ -3013,106 +3339,130 @@ Theorem proveHyp TRY strip_tac >> imp_res_tac MEM_term_remove_imp >> TRY(fs[EVERY_MEM]>>NO_TAC) >> - metis_tac[MEM_term_union,hypset_ok_term_union,hypset_ok_term_remove,ACONV_REFL]) + metis_tac[MEM_term_union,hypset_ok_term_union,hypset_ok_term_remove,ACONV_REFL] +QED (* extension is transitive *) -Theorem extends_trans - `∀c1 c2 c3. c1 extends c2 ∧ c2 extends c3 ⇒ c1 extends c3` - (rw[extends_def] >> metis_tac[RTC_TRANSITIVE,transitive_def]) +Theorem extends_trans: + ∀c1 c2 c3. c1 extends c2 ∧ c2 extends c3 ⇒ c1 extends c3 +Proof + rw[extends_def] >> metis_tac[RTC_TRANSITIVE,transitive_def] +QED (* extensions have all distinct names *) -Theorem updates_ALL_DISTINCT - `∀upd ctxt. upd updates ctxt ⇒ +Theorem updates_ALL_DISTINCT: + ∀upd ctxt. upd updates ctxt ⇒ (ALL_DISTINCT (MAP FST (type_list ctxt)) ⇒ ALL_DISTINCT (MAP FST (type_list (upd::ctxt)))) ∧ (ALL_DISTINCT (MAP FST (const_list ctxt)) ⇒ - ALL_DISTINCT (MAP FST (const_list (upd::ctxt))))` - (ho_match_mp_tac updates_ind >> simp[] >> - rw[ALL_DISTINCT_APPEND,MAP_MAP_o,combinTheory.o_DEF,UNCURRY,ETA_AX]) - -Theorem extends_ALL_DISTINCT - `∀ctxt1 ctxt2. ctxt2 extends ctxt1 ⇒ + ALL_DISTINCT (MAP FST (const_list (upd::ctxt)))) +Proof + ho_match_mp_tac updates_ind >> simp[] >> + rw[ALL_DISTINCT_APPEND,MAP_MAP_o,combinTheory.o_DEF,UNCURRY,ETA_AX] +QED + +Theorem extends_ALL_DISTINCT: + ∀ctxt1 ctxt2. ctxt2 extends ctxt1 ⇒ (ALL_DISTINCT (MAP FST (type_list ctxt1)) ⇒ ALL_DISTINCT (MAP FST (type_list ctxt2))) ∧ (ALL_DISTINCT (MAP FST (const_list ctxt1)) ⇒ - ALL_DISTINCT (MAP FST (const_list ctxt2)))` - (simp[IMP_CONJ_THM,FORALL_AND_THM] >> conj_tac >> + ALL_DISTINCT (MAP FST (const_list ctxt2))) +Proof + simp[IMP_CONJ_THM,FORALL_AND_THM] >> conj_tac >> ho_match_mp_tac extends_ind >> - METIS_TAC[updates_ALL_DISTINCT]) - -Theorem init_ALL_DISTINCT - `ALL_DISTINCT (MAP FST (const_list init_ctxt)) ∧ - ALL_DISTINCT (MAP FST (type_list init_ctxt))` - (EVAL_TAC) - -Theorem updates_DISJOINT - `∀upd ctxt. + METIS_TAC[updates_ALL_DISTINCT] +QED + +Theorem init_ALL_DISTINCT: + ALL_DISTINCT (MAP FST (const_list init_ctxt)) ∧ + ALL_DISTINCT (MAP FST (type_list init_ctxt)) +Proof + EVAL_TAC +QED + +Theorem updates_DISJOINT: + ∀upd ctxt. upd updates ctxt ⇒ DISJOINT (FDOM (alist_to_fmap (consts_of_upd upd))) (FDOM (tmsof ctxt)) ∧ - DISJOINT (FDOM (alist_to_fmap (types_of_upd upd))) (FDOM (tysof ctxt))` - (ho_match_mp_tac updates_ind >> + DISJOINT (FDOM (alist_to_fmap (types_of_upd upd))) (FDOM (tysof ctxt)) +Proof + ho_match_mp_tac updates_ind >> simp[IN_DISJOINT] >> rw[] >> simp[MAP_MAP_o,combinTheory.o_DEF,UNCURRY,ETA_AX] >> - PROVE_TAC[]) + PROVE_TAC[] +QED -Theorem updates_upd_ALL_DISTINCT - `∀upd ctxt. upd updates ctxt ⇒ +Theorem updates_upd_ALL_DISTINCT: + ∀upd ctxt. upd updates ctxt ⇒ ALL_DISTINCT (MAP FST (consts_of_upd upd)) ∧ - ALL_DISTINCT (MAP FST (types_of_upd upd))` - (ho_match_mp_tac updates_ind >> rw[] >> - rw[MAP_MAP_o,combinTheory.o_DEF,UNCURRY,ETA_AX]) - -Theorem updates_upd_DISJOINT - `∀upd ctxt. upd updates ctxt ⇒ + ALL_DISTINCT (MAP FST (types_of_upd upd)) +Proof + ho_match_mp_tac updates_ind >> rw[] >> + rw[MAP_MAP_o,combinTheory.o_DEF,UNCURRY,ETA_AX] +QED + +Theorem updates_upd_DISJOINT: + ∀upd ctxt. upd updates ctxt ⇒ DISJOINT (set (MAP FST (types_of_upd upd))) (set (MAP FST (type_list ctxt))) ∧ - DISJOINT (set (MAP FST (consts_of_upd upd))) (set (MAP FST (const_list ctxt)))` - (ho_match_mp_tac updates_ind >> rw[IN_DISJOINT,MEM_MAP,FORALL_PROD,EXISTS_PROD,PULL_EXISTS,LET_THM] >> - metis_tac[]) + DISJOINT (set (MAP FST (consts_of_upd upd))) (set (MAP FST (const_list ctxt))) +Proof + ho_match_mp_tac updates_ind >> rw[IN_DISJOINT,MEM_MAP,FORALL_PROD,EXISTS_PROD,PULL_EXISTS,LET_THM] >> + metis_tac[] +QED (* signature extensions preserve ok *) -Theorem type_ok_extend - `∀t tyenv tyenv'. +Theorem type_ok_extend: + ∀t tyenv tyenv'. tyenv ⊑ tyenv' ∧ type_ok tyenv t ⇒ - type_ok tyenv' t` - (ho_match_mp_tac type_ind >> + type_ok tyenv' t +Proof + ho_match_mp_tac type_ind >> rw[type_ok_def,EVERY_MEM] >> res_tac >> - imp_res_tac FLOOKUP_SUBMAP) + imp_res_tac FLOOKUP_SUBMAP +QED -Theorem term_ok_extend - `∀t tyenv tmenv tyenv' tmenv'. +Theorem term_ok_extend: + ∀t tyenv tmenv tyenv' tmenv'. tyenv ⊑ tyenv' ∧ tmenv ⊑ tmenv' ∧ term_ok (tyenv,tmenv) t ⇒ - term_ok (tyenv',tmenv') t` - (Induct >> simp[term_ok_def] >> rw[] >> + term_ok (tyenv',tmenv') t +Proof + Induct >> simp[term_ok_def] >> rw[] >> imp_res_tac type_ok_extend >> imp_res_tac FLOOKUP_SUBMAP >> - metis_tac[]) + metis_tac[] +QED -Theorem term_ok_updates - `∀upd ctxt. upd updates ctxt ⇒ +Theorem term_ok_updates: + ∀upd ctxt. upd updates ctxt ⇒ term_ok (sigof (thyof ctxt)) tm ⇒ - term_ok (sigof (thyof (upd::ctxt))) tm` - (rw[] >> match_mp_tac term_ok_extend >> + term_ok (sigof (thyof (upd::ctxt))) tm +Proof + rw[] >> match_mp_tac term_ok_extend >> map_every qexists_tac[`tysof ctxt`,`tmsof ctxt`] >> simp[] >> conj_tac >> match_mp_tac finite_mapTheory.SUBMAP_FUNION >> - metis_tac[updates_DISJOINT,finite_mapTheory.SUBMAP_REFL,pred_setTheory.DISJOINT_SYM]) + metis_tac[updates_DISJOINT,finite_mapTheory.SUBMAP_REFL,pred_setTheory.DISJOINT_SYM] +QED -Theorem is_std_sig_extend - `∀tyenv tmenv tyenv' tmenv'. +Theorem is_std_sig_extend: + ∀tyenv tmenv tyenv' tmenv'. is_std_sig (tyenv,tmenv) ∧ tyenv ⊑ tyenv' ∧ tmenv ⊑ tmenv' ⇒ - is_std_sig (tyenv',tmenv')` - (rw[is_std_sig_def] >> imp_res_tac FLOOKUP_SUBMAP) + is_std_sig (tyenv',tmenv') +Proof + rw[is_std_sig_def] >> imp_res_tac FLOOKUP_SUBMAP +QED (* updates preserve ok *) -Theorem updates_theory_ok - `∀upd ctxt. upd updates ctxt ⇒ theory_ok (thyof ctxt) ⇒ theory_ok (thyof (upd::ctxt))` - (ho_match_mp_tac updates_ind >> +Theorem updates_theory_ok: + ∀upd ctxt. upd updates ctxt ⇒ theory_ok (thyof ctxt) ⇒ theory_ok (thyof (upd::ctxt)) +Proof + ho_match_mp_tac updates_ind >> strip_tac >- ( rw[conexts_of_upd_def] >> fs[theory_ok_def] >> @@ -3215,45 +3565,53 @@ Theorem updates_theory_ok unabbrev_all_tac >> simp[term_ok_equation,term_ok_def,type_ok_def,FLOOKUP_FUNION,FLOOKUP_UPDATE,EVERY_MAP] >> fs[is_std_sig_def] ) >> - metis_tac[term_ok_extend]) + metis_tac[term_ok_extend] +QED -Theorem extends_theory_ok - `∀ctxt1 ctxt2. ctxt2 extends ctxt1 ⇒ theory_ok (thyof ctxt1) ⇒ theory_ok (thyof ctxt2)` - (ho_match_mp_tac extends_ind >> metis_tac[updates_theory_ok]) +Theorem extends_theory_ok: + ∀ctxt1 ctxt2. ctxt2 extends ctxt1 ⇒ theory_ok (thyof ctxt1) ⇒ theory_ok (thyof ctxt2) +Proof + ho_match_mp_tac extends_ind >> metis_tac[updates_theory_ok] +QED (* init_ctxt ok *) -Theorem init_theory_ok - `theory_ok (thyof init_ctxt)` - (rw[theory_ok_def,init_ctxt_def,type_ok_def,FLOOKUP_UPDATE,conexts_of_upd_def] >> - rw[is_std_sig_def,FLOOKUP_UPDATE]) +Theorem init_theory_ok: + theory_ok (thyof init_ctxt) +Proof + rw[theory_ok_def,init_ctxt_def,type_ok_def,FLOOKUP_UPDATE,conexts_of_upd_def] >> + rw[is_std_sig_def,FLOOKUP_UPDATE] +QED (* is_std_sig is preserved *) -Theorem is_std_sig_extends - `∀ctxt1 ctxt2. ctxt2 extends ctxt1 ⇒ is_std_sig (sigof ctxt1) ⇒ is_std_sig (sigof ctxt2)` - (ho_match_mp_tac extends_ind >> +Theorem is_std_sig_extends: + ∀ctxt1 ctxt2. ctxt2 extends ctxt1 ⇒ is_std_sig (sigof ctxt1) ⇒ is_std_sig (sigof ctxt2) +Proof + ho_match_mp_tac extends_ind >> REWRITE_TAC[GSYM AND_IMP_INTRO] >> ho_match_mp_tac updates_ind >> srw_tac[][is_std_sig_def,FLOOKUP_UPDATE,FLOOKUP_FUNION] >> TRY BasicProvers.CASE_TAC >> imp_res_tac ALOOKUP_MEM >> fs[MEM_MAP,FORALL_PROD,EXISTS_PROD] >> - metis_tac[] ) + metis_tac[] +QED (* recover constant definition as a special case of specification *) val _ = Parse.overload_on("ConstDef",``λx t. ConstSpec [(x,t)] (Var x (typeof t) === t)``) -Theorem ConstDef_updates - `∀name tm ctxt. +Theorem ConstDef_updates: + ∀name tm ctxt. theory_ok (thyof ctxt) ∧ term_ok (sigof ctxt) tm ∧ name ∉ FDOM (tmsof ctxt) ∧ CLOSED tm ∧ set (tvars tm) ⊆ set (tyvars (typeof tm)) - ⇒ ConstDef name tm updates ctxt` - (rw[] >> + ⇒ ConstDef name tm updates ctxt +Proof + rw[] >> match_mp_tac(List.nth(CONJUNCTS updates_rules,2)) >> simp[EVERY_MAP] >> fs[SUBSET_DEF] >> simp[vfree_in_equation] >> fs[CLOSED_def] >> @@ -3261,33 +3619,39 @@ Theorem ConstDef_updates imp_res_tac term_ok_welltyped >> imp_res_tac theory_ok_sig >> imp_res_tac term_ok_type_ok >> - simp[EQUATION_HAS_TYPE_BOOL,term_ok_equation,term_ok_def]) + simp[EQUATION_HAS_TYPE_BOOL,term_ok_equation,term_ok_def] +QED (* lookups in extended contexts *) -Theorem FLOOKUP_tmsof_updates - `∀upd ctxt. upd updates ctxt ⇒ +Theorem FLOOKUP_tmsof_updates: + ∀upd ctxt. upd updates ctxt ⇒ FLOOKUP (tmsof (thyof ctxt)) name = SOME ty ⇒ - FLOOKUP (tmsof (thyof (upd::ctxt))) name = SOME ty` - (rw[finite_mapTheory.FLOOKUP_FUNION] >> + FLOOKUP (tmsof (thyof (upd::ctxt))) name = SOME ty +Proof + rw[finite_mapTheory.FLOOKUP_FUNION] >> BasicProvers.CASE_TAC >> imp_res_tac updates_DISJOINT >> fs[pred_setTheory.IN_DISJOINT,listTheory.MEM_MAP,pairTheory.EXISTS_PROD] >> - PROVE_TAC[alistTheory.ALOOKUP_MEM]) + PROVE_TAC[alistTheory.ALOOKUP_MEM] +QED -Theorem FLOOKUP_tysof_updates - `∀upd ctxt. upd updates ctxt ⇒ +Theorem FLOOKUP_tysof_updates: + ∀upd ctxt. upd updates ctxt ⇒ FLOOKUP (tysof (thyof ctxt)) name = SOME a ⇒ - FLOOKUP (tysof (thyof (upd::ctxt))) name = SOME a` - (rw[finite_mapTheory.FLOOKUP_FUNION] >> + FLOOKUP (tysof (thyof (upd::ctxt))) name = SOME a +Proof + rw[finite_mapTheory.FLOOKUP_FUNION] >> BasicProvers.CASE_TAC >> imp_res_tac updates_DISJOINT >> fs[pred_setTheory.IN_DISJOINT,listTheory.MEM_MAP,pairTheory.EXISTS_PROD] >> - PROVE_TAC[alistTheory.ALOOKUP_MEM]) + PROVE_TAC[alistTheory.ALOOKUP_MEM] +QED -Theorem FLOOKUP_tysof_extends - `∀ctxt2 ctxt1. ctxt1 extends ctxt2 ⇒ +Theorem FLOOKUP_tysof_extends: + ∀ctxt2 ctxt1. ctxt1 extends ctxt2 ⇒ (FLOOKUP (tysof (sigof ctxt2)) k = SOME v) ⇒ - (FLOOKUP (tysof (sigof ctxt1)) k = SOME v)` - (ho_match_mp_tac extends_ind + (FLOOKUP (tysof (sigof ctxt1)) k = SOME v) +Proof + ho_match_mp_tac extends_ind \\ REWRITE_TAC[GSYM o_DEF] \\ rw[ALOOKUP_APPEND] \\ CASE_TAC @@ -3295,13 +3659,15 @@ Theorem FLOOKUP_tysof_extends \\ rw[] \\ fs[] \\ imp_res_tac ALOOKUP_MEM \\ fs[MEM_MAP,EXISTS_PROD] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem FLOOKUP_tmsof_extends - `∀ctxt2 ctxt1. ctxt1 extends ctxt2 ⇒ +Theorem FLOOKUP_tmsof_extends: + ∀ctxt2 ctxt1. ctxt1 extends ctxt2 ⇒ (FLOOKUP (tmsof (sigof ctxt2)) k = SOME v) ⇒ - (FLOOKUP (tmsof (sigof ctxt1)) k = SOME v)` - (ho_match_mp_tac extends_ind + (FLOOKUP (tmsof (sigof ctxt1)) k = SOME v) +Proof + ho_match_mp_tac extends_ind \\ REWRITE_TAC[GSYM o_DEF] \\ rw[ALOOKUP_APPEND] \\ CASE_TAC @@ -3310,14 +3676,16 @@ Theorem FLOOKUP_tmsof_extends \\ imp_res_tac ALOOKUP_MEM \\ fs[MEM_MAP,EXISTS_PROD] \\ TRY(qpat_x_assum`_ = SOME _`mp_tac \\ rw[]) - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem extends_sub - `∀ctxt2 ctxt1. ctxt2 extends ctxt1 ⇒ +Theorem extends_sub: + ∀ctxt2 ctxt1. ctxt2 extends ctxt1 ⇒ tmsof ctxt1 ⊑ tmsof ctxt2 ∧ tysof ctxt1 ⊑ tysof ctxt2 ∧ - axsof ctxt1 ⊆ axsof ctxt2` - (simp[extends_def] >> + axsof ctxt1 ⊆ axsof ctxt2 +Proof + simp[extends_def] >> ho_match_mp_tac relationTheory.RTC_INDUCT >> simp[PULL_EXISTS] >> rpt gen_tac >> strip_tac >> @@ -3328,7 +3696,8 @@ Theorem extends_sub imp_res_tac updates_DISJOINT >> fs[] >> fs[finite_mapTheory.SUBMAP_DEF,pred_setTheory.IN_DISJOINT] >> metis_tac[] ) >> - metis_tac[pred_setTheory.SUBSET_UNION,pred_setTheory.SUBSET_TRANS]); + metis_tac[pred_setTheory.SUBSET_UNION,pred_setTheory.SUBSET_TRANS] +QED (* proofs still work in extended contexts *) @@ -3460,26 +3829,30 @@ val update_extension = Q.prove ( >- (Cases_on `ctxt` >> fs []))); -Theorem updates_proves - `∀upd ctxt. upd updates ctxt ⇒ +Theorem updates_proves: + ∀upd ctxt. upd updates ctxt ⇒ ∀h c. (thyof ctxt,h) |- c ⇒ - (thyof (upd::ctxt),h) |- c` - (metis_tac[update_extension]); + (thyof (upd::ctxt),h) |- c +Proof + metis_tac[update_extension] +QED -Theorem extends_proves - `!c2 c1. +Theorem extends_proves: + !c2 c1. c2 extends c1 ==> !h c. - (thyof c1,h) |- c ==> (thyof c2,h) |- c` - (Induct \\ rw [extends_def] + (thyof c1,h) |- c ==> (thyof c2,h) |- c +Proof + Induct \\ rw [extends_def] \\ fs [Once RTC_CASES1] \\ rw [] \\ fs [BETA_THM] \\ fs [GSYM extends_def] \\ first_x_assum drule \\ disch_then drule \\ rw [] \\ drule updates_proves - \\ disch_then drule \\ rw []); + \\ disch_then drule \\ rw [] +QED (* types occurring in a term *) @@ -3490,14 +3863,18 @@ val types_in_def = Define` types_in (Abs v t) = types_in v ∪ types_in t` val _ = export_rewrites["types_in_def"] -Theorem type_ok_types_in - `∀sig. is_std_sig sig ⇒ ∀tm ty. term_ok sig tm ∧ ty ∈ types_in tm ⇒ type_ok (tysof sig) ty` - (gen_tac >> strip_tac >> Induct >> simp[] >> rw[] >> - TRY (imp_res_tac term_ok_def >> NO_TAC) >> fs[term_ok_def]) +Theorem type_ok_types_in: + ∀sig. is_std_sig sig ⇒ ∀tm ty. term_ok sig tm ∧ ty ∈ types_in tm ⇒ type_ok (tysof sig) ty +Proof + gen_tac >> strip_tac >> Induct >> simp[] >> rw[] >> + TRY (imp_res_tac term_ok_def >> NO_TAC) >> fs[term_ok_def] +QED -Theorem VFREE_IN_types_in - `∀t2 t1. VFREE_IN t1 t2 ⇒ typeof t1 ∈ types_in t2` - (ho_match_mp_tac term_induction >> rw[] >> rw[]) +Theorem VFREE_IN_types_in: + ∀t2 t1. VFREE_IN t1 t2 ⇒ typeof t1 ∈ types_in t2 +Proof + ho_match_mp_tac term_induction >> rw[] >> rw[] +QED val Var_subterm_types_in = Q.prove( `∀t x ty. Var x ty subterm t ⇒ ty ∈ types_in t`, @@ -3509,10 +3886,11 @@ val Const_subterm_types_in = Q.prove( ho_match_mp_tac term_induction >> rw[subterm_Comb,subterm_Abs] >> metis_tac[]) -Theorem subterm_typeof_types_in - `∀t1 t2 name args. (Tyapp name args) subtype (typeof t1) ∧ t1 subterm t2 ∧ welltyped t2 ∧ name ≠ (strlit"fun") ⇒ - ∃ty2. Tyapp name args subtype ty2 ∧ ty2 ∈ types_in t2` - (ho_match_mp_tac term_induction >> +Theorem subterm_typeof_types_in: + ∀t1 t2 name args. (Tyapp name args) subtype (typeof t1) ∧ t1 subterm t2 ∧ welltyped t2 ∧ name ≠ (strlit"fun") ⇒ + ∃ty2. Tyapp name args subtype ty2 ∧ ty2 ∈ types_in t2 +Proof + ho_match_mp_tac term_induction >> conj_tac >- ( rw[] >> metis_tac[Var_subterm_types_in] ) >> conj_tac >- ( rw[] >> metis_tac[Const_subterm_types_in] ) >> conj_tac >- ( @@ -3545,7 +3923,8 @@ Theorem subterm_typeof_types_in simp[Once relationTheory.RTC_CASES_RTC_TWICE] >> ONCE_REWRITE_TAC[CONJ_COMM] >> first_assum(match_exists_tac o concl) >> simp[] >> - simp[subterm_Abs] ) + simp[subterm_Abs] +QED (* a type matching algorithm, based on the implementation in HOL4 *) @@ -3578,28 +3957,36 @@ val arities_match_def = tDefine"arities_match"` (WF_REL_TAC`measure (λx. type1_size (FST x) + type1_size (SND x))`) val arities_match_ind = theorem "arities_match_ind" -Theorem arities_match_length - `∀l1 l2. arities_match l1 l2 ⇒ (LENGTH l1 = LENGTH l2)` - (ho_match_mp_tac arities_match_ind >> simp[arities_match_def]) - -Theorem arities_match_nil[simp] - `(arities_match [] ls = (ls = [])) ∧ - (arities_match ls [] = (ls = []))` - (Cases_on`ls`>> simp[arities_match_def]) - -Theorem arities_match_Tyvar[simp] - `arities_match (Tyvar v::ps) (ty::obs) = arities_match ps obs` - (Cases_on`ty`>>simp[arities_match_def]) - -Theorem arities_match_append - `∀l1 l2 l3 l4. +Theorem arities_match_length: + ∀l1 l2. arities_match l1 l2 ⇒ (LENGTH l1 = LENGTH l2) +Proof + ho_match_mp_tac arities_match_ind >> simp[arities_match_def] +QED + +Theorem arities_match_nil[simp]: + (arities_match [] ls = (ls = [])) ∧ + (arities_match ls [] = (ls = [])) +Proof + Cases_on`ls`>> simp[arities_match_def] +QED + +Theorem arities_match_Tyvar[simp]: + arities_match (Tyvar v::ps) (ty::obs) = arities_match ps obs +Proof + Cases_on`ty`>>simp[arities_match_def] +QED + +Theorem arities_match_append: + ∀l1 l2 l3 l4. arities_match l1 l2 ∧ arities_match l3 l4 ⇒ - arities_match (l1++l3) (l2++l4)` - (ho_match_mp_tac arities_match_ind >> - simp[arities_match_def]) - -Theorem tymatch_SOME - `∀ps obs sids s' ids'. + arities_match (l1++l3) (l2++l4) +Proof + ho_match_mp_tac arities_match_ind >> + simp[arities_match_def] +QED + +Theorem tymatch_SOME: + ∀ps obs sids s' ids'. arities_match ps obs ∧ DISJOINT (set (MAP SND (FST sids))) (set (MAP Tyvar (SND sids))) ∧ (∀name. ¬MEM (Tyvar name,Tyvar name) (FST sids)) ∧ @@ -3610,8 +3997,9 @@ Theorem tymatch_SOME DISJOINT (set (MAP SND s')) (set (MAP Tyvar ids')) ∧ (∀name. ¬MEM (Tyvar name,Tyvar name) s') ∧ ALL_DISTINCT (MAP SND s') ∧ - (MAP (TYPE_SUBST s') ps = obs)` - (ho_match_mp_tac tymatch_ind >> + (MAP (TYPE_SUBST s') ps = obs) +Proof + ho_match_mp_tac tymatch_ind >> simp[tymatch_def,arities_match_def] >> conj_tac >- ( rpt gen_tac >> @@ -3684,15 +4072,17 @@ Theorem tymatch_SOME fs[APPEND_EQ_APPEND] >> rfs[] >> `LENGTH l = 0` by DECIDE_TAC >> - fs[LENGTH_NIL]) + fs[LENGTH_NIL] +QED val match_type_def = Define` match_type ty1 ty2 = OPTION_MAP FST (tymatch [ty1] [ty2] ([],[]))` -Theorem type_ok_arities_match - `∀tys ty1 ty2. - type_ok tys ty1 ∧ type_ok tys ty2 ⇒ arities_match [ty1] [ty2]` - (gen_tac >> ho_match_mp_tac type_ind >> simp[] >> +Theorem type_ok_arities_match: + ∀tys ty1 ty2. + type_ok tys ty1 ∧ type_ok tys ty2 ⇒ arities_match [ty1] [ty2] +Proof + gen_tac >> ho_match_mp_tac type_ind >> simp[] >> gen_tac >> strip_tac >> gen_tac >> Cases >> simp[arities_match_def] >> rw[type_ok_def] >> fs[] >> @@ -3706,15 +4096,18 @@ Theorem type_ok_arities_match gen_tac >> Cases >> rw[] >> `arities_match l t` by metis_tac[] >> `arities_match [h] [h']` by metis_tac[] >> - metis_tac[arities_match_append,APPEND]) + metis_tac[arities_match_append,APPEND] +QED -Theorem match_type_SOME - `∀ty1 ty2 s. arities_match [ty1] [ty2] ⇒ +Theorem match_type_SOME: + ∀ty1 ty2 s. arities_match [ty1] [ty2] ⇒ (match_type ty1 ty2 = SOME s) ⇒ - (TYPE_SUBST s ty1 = ty2)` - (rw[match_type_def] >> + (TYPE_SUBST s ty1 = ty2) +Proof + rw[match_type_def] >> qspecl_then[`[ty1]`,`[ty2]`,`[],[]`]mp_tac tymatch_SOME >> simp[] >> - Cases_on`z`>>simp[]) + Cases_on`z`>>simp[] +QED val _ = export_theory() diff --git a/candle/standard/syntax/holSyntaxScript.sml b/candle/standard/syntax/holSyntaxScript.sml index f19de059b5..a094242cdb 100644 --- a/candle/standard/syntax/holSyntaxScript.sml +++ b/candle/standard/syntax/holSyntaxScript.sml @@ -17,16 +17,20 @@ val _ = Parse.overload_on("Bool",``Tyapp (strlit "bool") []``) val domain_raw = Define ` domain ty = case ty of Tyapp n (x::xs) => x | _ => ty`; -Theorem domain_def[compute,simp] - `!t s. domain (Fun s t) = s` - (REPEAT STRIP_TAC \\ EVAL_TAC); +Theorem domain_def[compute,simp]: + !t s. domain (Fun s t) = s +Proof + REPEAT STRIP_TAC \\ EVAL_TAC +QED val codomain_raw = Define ` codomain ty = case ty of Tyapp n (y::x::xs) => x | _ => ty`; -Theorem codomain_def[compute,simp] - `!t s. codomain (Fun s t) = t` - (REPEAT STRIP_TAC \\ EVAL_TAC); +Theorem codomain_def[compute,simp]: + !t s. codomain (Fun s t) = t +Proof + REPEAT STRIP_TAC \\ EVAL_TAC +QED val _ = save_thm("domain_raw",domain_raw); val _ = save_thm("codomain_raw",codomain_raw); @@ -205,9 +209,10 @@ val CLOSED_def = Define` (* Producing a variant of a variable, guaranteed to not be free in a given term. *) -Theorem VFREE_IN_FINITE - `∀t. FINITE {x | VFREE_IN x t}` - (Induct >> simp[VFREE_IN_def] >- ( +Theorem VFREE_IN_FINITE: + ∀t. FINITE {x | VFREE_IN x t} +Proof + Induct >> simp[VFREE_IN_def] >- ( qmatch_abbrev_tac`FINITE z` >> qmatch_assum_abbrev_tac`FINITE x` >> qpat_x_assum`FINITE x`mp_tac >> @@ -219,22 +224,27 @@ Theorem VFREE_IN_FINITE qmatch_abbrev_tac`FINITE z` >> qsuff_tac`∃y. z = x DIFF y`>-metis_tac[FINITE_DIFF] >> simp[Abbr`z`,Abbr`x`,EXTENSION] >> - metis_tac[IN_SING]) + metis_tac[IN_SING] +QED -Theorem VFREE_IN_FINITE_ALT - `∀t ty. FINITE {x | VFREE_IN (Var (implode x) ty) t}` - (rw[] >> match_mp_tac (MP_CANON SUBSET_FINITE) >> +Theorem VFREE_IN_FINITE_ALT: + ∀t ty. FINITE {x | VFREE_IN (Var (implode x) ty) t} +Proof + rw[] >> match_mp_tac (MP_CANON SUBSET_FINITE) >> qexists_tac`IMAGE (λt. case t of Var x y => explode x) {x | VFREE_IN x t}` >> simp[VFREE_IN_FINITE,IMAGE_FINITE] >> simp[SUBSET_DEF] >> rw[] >> - HINT_EXISTS_TAC >> simp[explode_implode]) + HINT_EXISTS_TAC >> simp[explode_implode] +QED -Theorem PRIMED_NAME_EXISTS - `∃n. ¬(VFREE_IN (Var (implode (APPEND x (GENLIST (K #"'") n))) ty) t)` - (qspecl_then[`t`,`ty`]mp_tac VFREE_IN_FINITE_ALT >> +Theorem PRIMED_NAME_EXISTS: + ∃n. ¬(VFREE_IN (Var (implode (APPEND x (GENLIST (K #"'") n))) ty) t) +Proof + qspecl_then[`t`,`ty`]mp_tac VFREE_IN_FINITE_ALT >> disch_then(mp_tac o CONJ PRIMED_INFINITE) >> disch_then(mp_tac o MATCH_MP INFINITE_DIFF_FINITE) >> - simp[GSYM MEMBER_NOT_EMPTY] >> rw[] >> metis_tac[]) + simp[GSYM MEMBER_NOT_EMPTY] >> rw[] >> metis_tac[] +QED val LEAST_EXISTS = Q.prove( `(∃n:num. P n) ⇒ ∃k. P k ∧ ∀m. m < k ⇒ ¬(P m)`, @@ -251,9 +261,11 @@ val VARIANT_PRIMES_def = new_specification val VARIANT_def = Define` VARIANT t x ty = implode (APPEND x (GENLIST (K #"'") (VARIANT_PRIMES t x ty)))` -Theorem VARIANT_THM - `∀t x ty. ¬VFREE_IN (Var (VARIANT t x ty) ty) t` - (metis_tac[VARIANT_def,VARIANT_PRIMES_def]) +Theorem VARIANT_THM: + ∀t x ty. ¬VFREE_IN (Var (VARIANT t x ty) ty) t +Proof + metis_tac[VARIANT_def,VARIANT_PRIMES_def] +QED (* Substitution for type variables in a type. *) @@ -291,21 +303,25 @@ val sizeof_def = Define` sizeof (Abs v t) = 2 + sizeof t` val _ = export_rewrites["sizeof_def"] -Theorem SIZEOF_VSUBST - `∀t ilist. (∀s' s. MEM (s',s) ilist ⇒ ∃x ty. s' = Var x ty) - ⇒ sizeof (VSUBST ilist t) = sizeof t` - (Induct >> simp[VSUBST_def] >> rw[VSUBST_def] >> simp[] >- ( +Theorem SIZEOF_VSUBST: + ∀t ilist. (∀s' s. MEM (s',s) ilist ⇒ ∃x ty. s' = Var x ty) + ⇒ sizeof (VSUBST ilist t) = sizeof t +Proof + Induct >> simp[VSUBST_def] >> rw[VSUBST_def] >> simp[] >- ( Q.ISPECL_THEN[`ilist`,`Var m t`,`Var m t`]mp_tac REV_ASSOCD_MEM >> rw[] >> res_tac >> pop_assum SUBST1_TAC >> simp[] ) >- metis_tac[] >> simp[pairTheory.UNCURRY] >> rw[] >> simp[] >> first_x_assum match_mp_tac >> simp[MEM_FILTER] >> - rw[] >> res_tac >> fs[] ) - -Theorem sizeof_positive - `∀t. 0 < sizeof t` - (Induct >> simp[]) + rw[] >> res_tac >> fs[] +QED + +Theorem sizeof_positive: + ∀t. 0 < sizeof t +Proof + Induct >> simp[] +QED (* Instantiation of type variables in terms *) diff --git a/candle/syntax-lib/holSyntaxLibScript.sml b/candle/syntax-lib/holSyntaxLibScript.sml index 64b520db78..727f464bd2 100644 --- a/candle/syntax-lib/holSyntaxLibScript.sml +++ b/candle/syntax-lib/holSyntaxLibScript.sml @@ -11,51 +11,67 @@ val ALPHAVARS_def = Define` (tmp = tp) ∨ (FST tp ≠ FST tmp) ∧ (SND tp ≠ SND tmp) ∧ ALPHAVARS oenv tmp)` -Theorem ALPHAVARS_REFL - `∀env t. EVERY (UNCURRY $=) env ==> ALPHAVARS env (t,t)` - (Induct >> simp[ALPHAVARS_def,FORALL_PROD]) - -Theorem ALPHAVARS_MEM - `∀env tp. ALPHAVARS env tp ⇒ MEM tp env ∨ (FST tp = SND tp)` - (Induct >> simp[ALPHAVARS_def] >> rw[] >> res_tac >> simp[]) +Theorem ALPHAVARS_REFL: + ∀env t. EVERY (UNCURRY $=) env ==> ALPHAVARS env (t,t) +Proof + Induct >> simp[ALPHAVARS_def,FORALL_PROD] +QED + +Theorem ALPHAVARS_MEM: + ∀env tp. ALPHAVARS env tp ⇒ MEM tp env ∨ (FST tp = SND tp) +Proof + Induct >> simp[ALPHAVARS_def] >> rw[] >> res_tac >> simp[] +QED val REV_ASSOCD_def = Define` (REV_ASSOCD a [] d = d) ∧ (REV_ASSOCD a (p::t) d = if SND p = a then FST p else REV_ASSOCD a t d)` -Theorem REV_ASSOCD - `(∀a d. REV_ASSOCD a [] d = d) ∧ +Theorem REV_ASSOCD: + (∀a d. REV_ASSOCD a [] d = d) ∧ (∀a x y t d. REV_ASSOCD a ((x,y)::t) d = - if y = a then x else REV_ASSOCD a t d)` - (rw[REV_ASSOCD_def]) - -Theorem REV_ASSOCD_ALOOKUP - `∀ls x d. REV_ASSOCD x ls d = case ALOOKUP (MAP (λ(x,y). (y,x)) ls) x of NONE => d | SOME y => y` - (Induct >> simp[REV_ASSOCD] >> - Cases >> simp[REV_ASSOCD] >> rw[]) - -Theorem PRIMED_INFINITE - `INFINITE (IMAGE (λn. APPEND x (GENLIST (K #"'") n)) UNIV)` - (match_mp_tac (MP_CANON IMAGE_11_INFINITE) >> + if y = a then x else REV_ASSOCD a t d) +Proof + rw[REV_ASSOCD_def] +QED + +Theorem REV_ASSOCD_ALOOKUP: + ∀ls x d. REV_ASSOCD x ls d = case ALOOKUP (MAP (λ(x,y). (y,x)) ls) x of NONE => d | SOME y => y +Proof + Induct >> simp[REV_ASSOCD] >> + Cases >> simp[REV_ASSOCD] >> rw[] +QED + +Theorem PRIMED_INFINITE: + INFINITE (IMAGE (λn. APPEND x (GENLIST (K #"'") n)) UNIV) +Proof + match_mp_tac (MP_CANON IMAGE_11_INFINITE) >> simp[] >> Induct >- metis_tac[NULL_EQ,NULL_GENLIST] >> simp[GENLIST_CONS] >> qx_gen_tac`y` >> Cases_on`GENLIST (K #"'") y`>>simp[]>>rw[]>> - Cases_on`y`>>fs[GENLIST_CONS]) + Cases_on`y`>>fs[GENLIST_CONS] +QED -Theorem REV_ASSOCD_FILTER - `∀l a b d. +Theorem REV_ASSOCD_FILTER: + ∀l a b d. REV_ASSOCD a (FILTER (λ(y,x). P x) l) b = - if P a then REV_ASSOCD a l b else b` - (Induct >> simp[REV_ASSOCD,FORALL_PROD] >> - rw[] >> fs[FORALL_PROD,REV_ASSOCD] >> rw[] >> fs[]) - -Theorem REV_ASSOCD_MEM - `∀l x d. MEM (REV_ASSOCD x l d,x) l ∨ (REV_ASSOCD x l d = d)` - (Induct >> simp[REV_ASSOCD,FORALL_PROD] >>rw[]>>fs[]) - -Theorem tyvar_inst_exists - `∃i. ty = REV_ASSOCD tyvar i b` - (qexists_tac`[(ty,tyvar)]` >> rw[REV_ASSOCD]) + if P a then REV_ASSOCD a l b else b +Proof + Induct >> simp[REV_ASSOCD,FORALL_PROD] >> + rw[] >> fs[FORALL_PROD,REV_ASSOCD] >> rw[] >> fs[] +QED + +Theorem REV_ASSOCD_MEM: + ∀l x d. MEM (REV_ASSOCD x l d,x) l ∨ (REV_ASSOCD x l d = d) +Proof + Induct >> simp[REV_ASSOCD,FORALL_PROD] >>rw[]>>fs[] +QED + +Theorem tyvar_inst_exists: + ∃i. ty = REV_ASSOCD tyvar i b +Proof + qexists_tac`[(ty,tyvar)]` >> rw[REV_ASSOCD] +QED val _ = Hol_datatype`result = Clash of 'a | Result of 'a` @@ -75,82 +91,114 @@ val CLASH_def = Define` val _ = export_rewrites["IS_RESULT_def","IS_CLASH_def","RESULT_def","CLASH_def"] -Theorem NOT_IS_CLASH_IS_RESULT - `∀x. IS_CLASH x ⇔ ¬IS_RESULT x` - (Cases >> simp[]) - -Theorem RESULT_eq_suff - `x = Result y ⇒ RESULT x = y` - (Cases_on`x`>>simp[]) - -Theorem IS_CLASH_IMP - `!x. IS_CLASH x ==> !tm. ~(x = Result tm)` - (Cases \\ simp[]) - -Theorem NOT_IS_CLASH_IMP - `!x. ~IS_CLASH x ==> !tm. ~(x = Clash tm)` - (Cases \\ simp[]) - -Theorem IS_RESULT_IMP - `!x. IS_RESULT x ==> (!tm. ~(x = Clash tm))` - (Cases \\ simp[]) - -Theorem NOT_IS_RESULT_IMP_Clash - `!x. ~IS_RESULT x ==> ?var. x = Clash var` - (Cases \\ simp[]) - -Theorem IS_RESULT_IMP_Result - `!x. IS_RESULT x ==> ?res. x = Result res` - (Cases \\ simp[]) - -Theorem NOT_IS_CLASH_IMP_Result - `!x. ~IS_CLASH x ==> ?res. x = Result res` - (Cases \\ simp[]) +Theorem NOT_IS_CLASH_IS_RESULT: + ∀x. IS_CLASH x ⇔ ¬IS_RESULT x +Proof + Cases >> simp[] +QED + +Theorem RESULT_eq_suff: + x = Result y ⇒ RESULT x = y +Proof + Cases_on`x`>>simp[] +QED + +Theorem IS_CLASH_IMP: + !x. IS_CLASH x ==> !tm. ~(x = Result tm) +Proof + Cases \\ simp[] +QED + +Theorem NOT_IS_CLASH_IMP: + !x. ~IS_CLASH x ==> !tm. ~(x = Clash tm) +Proof + Cases \\ simp[] +QED + +Theorem IS_RESULT_IMP: + !x. IS_RESULT x ==> (!tm. ~(x = Clash tm)) +Proof + Cases \\ simp[] +QED + +Theorem NOT_IS_RESULT_IMP_Clash: + !x. ~IS_RESULT x ==> ?var. x = Clash var +Proof + Cases \\ simp[] +QED + +Theorem IS_RESULT_IMP_Result: + !x. IS_RESULT x ==> ?res. x = Result res +Proof + Cases \\ simp[] +QED + +Theorem NOT_IS_CLASH_IMP_Result: + !x. ~IS_CLASH x ==> ?res. x = Result res +Proof + Cases \\ simp[] +QED val LIST_INSERT_def = Define` LIST_INSERT x xs = if MEM x xs then xs else x::xs` -Theorem MEM_LIST_INSERT - `∀l x. set (LIST_INSERT x l) = x INSERT set l` - (Induct >> simp[LIST_INSERT_def] >> rw[] >> - rw[EXTENSION] >> metis_tac[]) +Theorem MEM_LIST_INSERT: + ∀l x. set (LIST_INSERT x l) = x INSERT set l +Proof + Induct >> simp[LIST_INSERT_def] >> rw[] >> + rw[EXTENSION] >> metis_tac[] +QED val LIST_UNION_def = Define` LIST_UNION xs ys = FOLDR LIST_INSERT ys xs` -Theorem MEM_LIST_UNION - `∀l1 l2. set (LIST_UNION l1 l2) = set l1 ∪ set l2` - (Induct >> fs[LIST_UNION_def,MEM_LIST_INSERT] >> - rw[EXTENSION] >> metis_tac[]) - -Theorem MEM_FOLDR_LIST_UNION - `∀ls x f b. MEM x (FOLDR (λx y. LIST_UNION (f x) y) b ls) ⇔ MEM x b ∨ ∃y. MEM y ls ∧ MEM x (f y)` - (Induct >> simp[MEM_LIST_UNION] >> metis_tac[]) - -Theorem ALL_DISTINCT_LIST_UNION - `∀l1 l2. ALL_DISTINCT l2 ⇒ ALL_DISTINCT (LIST_UNION l1 l2)` - (Induct >> fs[LIST_UNION_def,LIST_INSERT_def] >> rw[]) - -Theorem LIST_UNION_NIL - `∀l2. (LIST_UNION [] l2 = l2)` - (simp[LIST_UNION_def] ) +Theorem MEM_LIST_UNION: + ∀l1 l2. set (LIST_UNION l1 l2) = set l1 ∪ set l2 +Proof + Induct >> fs[LIST_UNION_def,MEM_LIST_INSERT] >> + rw[EXTENSION] >> metis_tac[] +QED + +Theorem MEM_FOLDR_LIST_UNION: + ∀ls x f b. MEM x (FOLDR (λx y. LIST_UNION (f x) y) b ls) ⇔ MEM x b ∨ ∃y. MEM y ls ∧ MEM x (f y) +Proof + Induct >> simp[MEM_LIST_UNION] >> metis_tac[] +QED + +Theorem ALL_DISTINCT_LIST_UNION: + ∀l1 l2. ALL_DISTINCT l2 ⇒ ALL_DISTINCT (LIST_UNION l1 l2) +Proof + Induct >> fs[LIST_UNION_def,LIST_INSERT_def] >> rw[] +QED + +Theorem LIST_UNION_NIL: + ∀l2. (LIST_UNION [] l2 = l2) +Proof + simp[LIST_UNION_def] +QED val _ = export_rewrites["LIST_UNION_NIL"] -Theorem set_LIST_UNION - `∀l1 l2. set (LIST_UNION l1 l2) = set l1 ∪ set l2` - (rw[EXTENSION,MEM_LIST_UNION]) +Theorem set_LIST_UNION: + ∀l1 l2. set (LIST_UNION l1 l2) = set l1 ∪ set l2 +Proof + rw[EXTENSION,MEM_LIST_UNION] +QED val _ = export_rewrites["set_LIST_UNION"] -Theorem LIST_UNION_NIL_2 - `∀ls. ALL_DISTINCT ls ⇒ LIST_UNION ls [] = ls` - (Induct >> simp[LIST_UNION_def,LIST_INSERT_def] >> - rw[] >> fs[] >> rfs[LIST_UNION_def]) - -Theorem LIST_UNION_same - `∀l1 l2. set l1 ⊆ set l2 ⇒ LIST_UNION l1 l2 = l2` - (Induct >> simp[LIST_UNION_def] >> +Theorem LIST_UNION_NIL_2: + ∀ls. ALL_DISTINCT ls ⇒ LIST_UNION ls [] = ls +Proof + Induct >> simp[LIST_UNION_def,LIST_INSERT_def] >> + rw[] >> fs[] >> rfs[LIST_UNION_def] +QED + +Theorem LIST_UNION_same: + ∀l1 l2. set l1 ⊆ set l2 ⇒ LIST_UNION l1 l2 = l2 +Proof + Induct >> simp[LIST_UNION_def] >> fs[pred_setTheory.SUBSET_DEF] >> - fs[LIST_UNION_def,LIST_INSERT_def]) + fs[LIST_UNION_def,LIST_INSERT_def] +QED val INORDER_INSERT_def = Define` INORDER_INSERT x xs = @@ -183,18 +231,21 @@ val ALL_DISTINCT_FOLDR_INORDER_INSERT = Q.prove( Induct \\ SIMP_TAC std_ss [ALL_DISTINCT,FOLDR] \\ REPEAT STRIP_TAC \\ MATCH_MP_TAC ALL_DISTINCT_INORDER_INSERT \\ FULL_SIMP_TAC std_ss []); -Theorem MEM_FOLDR_INORDER_INSERT - `!xs x. MEM x (FOLDR INORDER_INSERT [] xs) = MEM x xs` - (Induct \\ FULL_SIMP_TAC std_ss [FOLDR,INORDER_INSERT_def,MEM,MEM_APPEND, - MEM_FILTER] \\ METIS_TAC [stringTheory.string_lt_cases]); +Theorem MEM_FOLDR_INORDER_INSERT: + !xs x. MEM x (FOLDR INORDER_INSERT [] xs) = MEM x xs +Proof + Induct \\ FULL_SIMP_TAC std_ss [FOLDR,INORDER_INSERT_def,MEM,MEM_APPEND, + MEM_FILTER] \\ METIS_TAC [stringTheory.string_lt_cases] +QED val _ = export_rewrites["MEM_FOLDR_INORDER_INSERT"] val STRING_SORT_def = Define` STRING_SORT xs = FOLDR INORDER_INSERT [] xs` -Theorem PERM_STRING_SORT - `∀ls. ALL_DISTINCT ls ⇒ PERM ls (STRING_SORT ls)` - (Induct >> +Theorem PERM_STRING_SORT: + ∀ls. ALL_DISTINCT ls ⇒ PERM ls (STRING_SORT ls) +Proof + Induct >> simp[STRING_SORT_def] >> simp[INORDER_INSERT_def] >> fs[STRING_SORT_def] >> @@ -206,23 +257,29 @@ Theorem PERM_STRING_SORT match_mp_tac PERM_ALL_DISTINCT >> simp[ALL_DISTINCT_APPEND] >> simp[Abbr`A`,Abbr`B`,MEM_FILTER] >> - metis_tac[FILTER_ALL_DISTINCT,ALL_DISTINCT_PERM,string_lt_antisym,string_lt_cases,MEM_PERM] ) - -Theorem LENGTH_STRING_SORT - `∀ls. ALL_DISTINCT ls ⇒ (LENGTH (STRING_SORT ls) = LENGTH ls)` - (metis_tac[PERM_STRING_SORT,PERM_LENGTH]) + metis_tac[FILTER_ALL_DISTINCT,ALL_DISTINCT_PERM,string_lt_antisym,string_lt_cases,MEM_PERM] +QED + +Theorem LENGTH_STRING_SORT: + ∀ls. ALL_DISTINCT ls ⇒ (LENGTH (STRING_SORT ls) = LENGTH ls) +Proof + metis_tac[PERM_STRING_SORT,PERM_LENGTH] +QED val _ = export_rewrites["LENGTH_STRING_SORT"] -Theorem MEM_STRING_SORT - `∀ls. set (STRING_SORT ls) = set ls` - (Induct >> +Theorem MEM_STRING_SORT: + ∀ls. set (STRING_SORT ls) = set ls +Proof + Induct >> simp[STRING_SORT_def,INORDER_INSERT_def,EXTENSION,MEM_FILTER] >> - rw[] >> metis_tac[string_lt_cases]) + rw[] >> metis_tac[string_lt_cases] +QED val _ = export_rewrites["MEM_STRING_SORT"] -Theorem ALL_DISTINCT_STRING_SORT - `!xs. ALL_DISTINCT (STRING_SORT xs)` - (Induct +Theorem ALL_DISTINCT_STRING_SORT: + !xs. ALL_DISTINCT (STRING_SORT xs) +Proof + Induct >> FULL_SIMP_TAC std_ss [STRING_SORT_def,FOLDR,ALL_DISTINCT,INORDER_INSERT_def] >> FULL_SIMP_TAC std_ss [ALL_DISTINCT_APPEND,MEM_FILTER,MEM,MEM_APPEND, ALL_DISTINCT,stringTheory.string_lt_nonrefl] @@ -230,12 +287,14 @@ Theorem ALL_DISTINCT_STRING_SORT >> TRY (MATCH_MP_TAC FILTER_ALL_DISTINCT) >> FULL_SIMP_TAC std_ss [] >> METIS_TAC [stringTheory.string_lt_antisym,stringTheory.string_lt_trans, - stringTheory.string_lt_cases]); + stringTheory.string_lt_cases] +QED val _ = export_rewrites["ALL_DISTINCT_STRING_SORT"] -Theorem STRING_SORT_SORTED - `∀ls. SORTED $< (STRING_SORT ls)` - (Induct >> simp[STRING_SORT_def,INORDER_INSERT_def] >> +Theorem STRING_SORT_SORTED: + ∀ls. SORTED $< (STRING_SORT ls) +Proof + Induct >> simp[STRING_SORT_def,INORDER_INSERT_def] >> rw[] >> match_mp_tac SORTED_APPEND >> conj_asm1_tac >- METIS_TAC [string_lt_trans,relationTheory.transitive_def] >> simp[MEM_FILTER] >> fs[GSYM STRING_SORT_def] >> @@ -244,35 +303,43 @@ Theorem STRING_SORT_SORTED match_mp_tac SORTED_APPEND >> simp[SORTED_FILTER,MEM_FILTER] ) >> rw[] >> fs[relationTheory.transitive_def] >> - METIS_TAC[]) - -Theorem STRING_SORT_EQ - `∀l1 l2. ALL_DISTINCT l1 ∧ ALL_DISTINCT l2 ⇒ - (STRING_SORT l1 = STRING_SORT l2 ⇔ PERM l1 l2)` - (rw[] >> + METIS_TAC[] +QED + +Theorem STRING_SORT_EQ: + ∀l1 l2. ALL_DISTINCT l1 ∧ ALL_DISTINCT l2 ⇒ + (STRING_SORT l1 = STRING_SORT l2 ⇔ PERM l1 l2) +Proof + rw[] >> imp_res_tac PERM_STRING_SORT >> `transitive string_lt ∧ antisymmetric string_lt` by ( simp[relationTheory.transitive_def,relationTheory.antisymmetric_def] >> METIS_TAC[string_lt_trans,string_lt_antisym] ) >> `SORTED $< (STRING_SORT l1) ∧ SORTED $< (STRING_SORT l2)` by METIS_TAC[STRING_SORT_SORTED] >> - METIS_TAC[SORTED_PERM_EQ,PERM_REFL,PERM_SYM,PERM_TRANS]) + METIS_TAC[SORTED_PERM_EQ,PERM_REFL,PERM_SYM,PERM_TRANS] +QED -Theorem ALL_DISTINCT_LIST_UNION - `∀l1 l2. ALL_DISTINCT l2 ⇒ ALL_DISTINCT (LIST_UNION l1 l2)` - (Induct >> fs[LIST_UNION_def,LIST_INSERT_def] >> rw[]) +Theorem ALL_DISTINCT_LIST_UNION: + ∀l1 l2. ALL_DISTINCT l2 ⇒ ALL_DISTINCT (LIST_UNION l1 l2) +Proof + Induct >> fs[LIST_UNION_def,LIST_INSERT_def] >> rw[] +QED -Theorem set_MAP_implode_STRING_SORT_MAP_explode - `set (MAP implode (STRING_SORT (MAP explode ls))) = set ls` - (rw[EXTENSION,MEM_MAP,PULL_EXISTS,mlstringTheory.implode_explode]) +Theorem set_MAP_implode_STRING_SORT_MAP_explode: + set (MAP implode (STRING_SORT (MAP explode ls))) = set ls +Proof + rw[EXTENSION,MEM_MAP,PULL_EXISTS,mlstringTheory.implode_explode] +QED val mlstring_sort_def = Define` mlstring_sort ls = MAP implode (STRING_SORT (MAP explode ls))` -Theorem mlstring_sort_eq - `∀l1 l2. ALL_DISTINCT l1 ∧ ALL_DISTINCT l2 ⇒ - ((mlstring_sort l1 = mlstring_sort l2) ⇔ PERM l1 l2)` - (rw[mlstring_sort_def] >> +Theorem mlstring_sort_eq: + ∀l1 l2. ALL_DISTINCT l1 ∧ ALL_DISTINCT l2 ⇒ + ((mlstring_sort l1 = mlstring_sort l2) ⇔ PERM l1 l2) +Proof + rw[mlstring_sort_def] >> qspecl_then[`l1`,`l2`]mp_tac(MATCH_MP PERM_MAP_BIJ mlstringTheory.explode_BIJ) >> disch_then SUBST1_TAC >> imp_res_tac ALL_DISTINCT_MAP_explode >> @@ -280,6 +347,7 @@ Theorem mlstring_sort_eq first_x_assum(CHANGED_TAC o (SUBST1_TAC o SYM)) >> match_mp_tac INJ_MAP_EQ_IFF >> mp_tac mlstringTheory.implode_BIJ >> - simp[BIJ_DEF,INJ_DEF,MEM_MAP,PULL_EXISTS]) + simp[BIJ_DEF,INJ_DEF,MEM_MAP,PULL_EXISTS] +QED val _ = export_theory() diff --git a/characteristic/cfAppScript.sml b/characteristic/cfAppScript.sml index b9c4a58ca8..e1a6299b19 100644 --- a/characteristic/cfAppScript.sml +++ b/characteristic/cfAppScript.sml @@ -82,49 +82,54 @@ val app_def = Define ` app_basic p f x H (POSTv g. SEP_EXISTS H'. H' * cond (app p g xs H' Q))` -Theorem app_alt_ind - `!f xs x H Q. +Theorem app_alt_ind: + !f xs x H Q. xs <> [] ==> app (p:'ffi ffi_proj) f (xs ++ [x]) H Q = app (p:'ffi ffi_proj) f xs H - (POSTv g. SEP_EXISTS H'. H' * cond (app_basic p g x H' Q))` - (Induct_on `xs` \\ fs [] \\ rpt strip_tac \\ + (POSTv g. SEP_EXISTS H'. H' * cond (app_basic p g x H' Q)) +Proof + Induct_on `xs` \\ fs [] \\ rpt strip_tac \\ Cases_on `xs` \\ fs [app_def] -); +QED -Theorem app_alt_ind_w - `!f xs x H Q. +Theorem app_alt_ind_w: + !f xs x H Q. app (p:'ffi ffi_proj) f (xs ++ [x]) H Q ==> xs <> [] ==> app (p:'ffi ffi_proj) f xs H - (POSTv g. SEP_EXISTS H'. H' * cond (app_basic (p:'ffi ffi_proj) g x H' Q))` - (rpt strip_tac \\ fs [app_alt_ind] -) + (POSTv g. SEP_EXISTS H'. H' * cond (app_basic (p:'ffi ffi_proj) g x H' Q)) +Proof + rpt strip_tac \\ fs [app_alt_ind] +QED -Theorem app_ge_2_unfold - `!f x xs H Q. +Theorem app_ge_2_unfold: + !f x xs H Q. xs <> [] ==> app (p:'ffi ffi_proj) f (x::xs) H Q = - app_basic p f x H (POSTv g. SEP_EXISTS H'. H' * cond (app p g xs H' Q))` - (rpt strip_tac \\ Cases_on `xs` \\ fs [app_def] -); + app_basic p f x H (POSTv g. SEP_EXISTS H'. H' * cond (app p g xs H' Q)) +Proof + rpt strip_tac \\ Cases_on `xs` \\ fs [app_def] +QED -Theorem app_ge_2_unfold_extens - `!f x xs. +Theorem app_ge_2_unfold_extens: + !f x xs. xs <> [] ==> app (p:'ffi ffi_proj) f (x::xs) = - \H Q. app_basic p f x H (POSTv g. SEP_EXISTS H'. H' * cond (app p g xs H' Q))` - (rpt strip_tac \\ NTAC 2 (irule EQ_EXT \\ gen_tac) \\ fs [app_ge_2_unfold] -); + \H Q. app_basic p f x H (POSTv g. SEP_EXISTS H'. H' * cond (app p g xs H' Q)) +Proof + rpt strip_tac \\ NTAC 2 (irule EQ_EXT \\ gen_tac) \\ fs [app_ge_2_unfold] +QED (* Weaken-frame-gc for [app]; auxiliary lemma for [app_local] *) -Theorem app_wgframe - `!f xs H H1 H2 Q1 Q. +Theorem app_wgframe: + !f xs H H1 H2 Q1 Q. app (p:'ffi ffi_proj) f xs H1 Q1 ==> H ==>> (H1 * H2) ==> (Q1 *+ H2) ==+> (Q *+ GC) ==> - app p f xs H Q` - (NTAC 2 gen_tac \\ Q.SPEC_TAC (`f`, `f`) \\ + app p f xs H Q +Proof + NTAC 2 gen_tac \\ Q.SPEC_TAC (`f`, `f`) \\ Induct_on `xs` THEN1 (fs [app_def]) \\ rpt strip_tac \\ rename1 `x::xs` \\ Cases_on `xs = []` THEN1 ( @@ -140,21 +145,23 @@ Theorem app_wgframe qx_gen_tac `HR` \\ strip_tac \\ qexists_tac `HR * H2` \\ hsimpl \\ first_assum irule \\ instantiate \\ hsimpl ) -); +QED -Theorem app_weaken - `!f xs H Q Q'. +Theorem app_weaken: + !f xs H Q Q'. app (p:'ffi ffi_proj) f xs H Q ==> Q ==+> Q' ==> - app p f xs H Q'` - (rpt strip_tac \\ irule app_wgframe \\ instantiate \\ fs [SEP_IMPPOST_def] \\ + app p f xs H Q' +Proof + rpt strip_tac \\ irule app_wgframe \\ instantiate \\ fs [SEP_IMPPOST_def] \\ rpt (hsimpl \\ TRY hinst) \\ simp [GC_def] \\ hsimpl \\ gen_tac \\ qexists_tac `emp` \\ hsimpl \\ fs [] -); +QED -Theorem app_local - `!f xs. xs <> [] ==> is_local (app (p:'ffi ffi_proj) f xs)` - (rpt strip_tac \\ irule is_local_prove \\ rpt strip_tac \\ +Theorem app_local: + !f xs. xs <> [] ==> is_local (app (p:'ffi ffi_proj) f xs) +Proof + rpt strip_tac \\ irule is_local_prove \\ rpt strip_tac \\ Cases_on `xs` \\ fs [] \\ rename1 `x1::xs` \\ Cases_on `xs` \\ fs [] THEN1 ( @@ -172,7 +179,7 @@ Theorem app_local qx_gen_tac `H'` \\ strip_tac \\ qexists_tac `H' * H2` \\ hsimpl \\ irule app_wgframe \\ instantiate \\ hsimpl ) -); +QED (* [curried (p:'ffi ffi_proj) n f] states that [f] is curried [n] times *) val curried_def = Define ` @@ -188,18 +195,19 @@ val curried_def = Define ` app (p:'ffi ffi_proj) f (x::xs) H Q ==> app (p:'ffi ffi_proj) g xs H Q))`; -Theorem curried_ge_2_unfold - `!n f. +Theorem curried_ge_2_unfold: + !n f. n > 1 ==> curried (p:'ffi ffi_proj) n f = !x. app_basic p f x emp (POSTv g. cond (curried p (PRE n) g /\ !xs H Q. LENGTH xs = PRE n ==> - app p f (x::xs) H Q ==> app p g xs H Q))` - (rpt strip_tac \\ Cases_on `n` \\ fs [] \\ rename1 `SUC n > 1` \\ + app p f (x::xs) H Q ==> app p g xs H Q)) +Proof + rpt strip_tac \\ Cases_on `n` \\ fs [] \\ rename1 `SUC n > 1` \\ Cases_on `n` \\ fs [Once curried_def] -); +QED (* app_over_app / app_over_take *) @@ -245,11 +253,13 @@ val spec_def = Define ` (*------------------------------------------------------------------*) (* Relating [app] to [_ --> _] from the translator *) -Theorem app_basic_weaken - `(!x v. P x v ==> Q x v) ==> +Theorem app_basic_weaken: + (!x v. P x v ==> Q x v) ==> (app_basic p v v1 x P ==> - app_basic p v v1 x Q)` - (fs [app_basic_def] \\ metis_tac []); + app_basic p v v1 x Q) +Proof + fs [app_basic_def] \\ metis_tac [] +QED (* val evaluate_list_SING = Q.prove( @@ -268,8 +278,8 @@ val evaluate_list_raise_SING = Q.prove( SIMP_RULE std_ss [Once bigStepTheory.evaluate_cases]) \\ fs []); -Theorem app_basic_rel - `app_basic (p:'ffi ffi_proj) (f: v) (x: v) (H: hprop) (Q: res -> hprop) = +Theorem app_basic_rel: + app_basic (p:'ffi ffi_proj) (f: v) (x: v) (H: hprop) (Q: res -> hprop) = !(h_i: heap) (h_k: heap) (st: 'ffi state). SPLIT (st2heap p st) (h_i, h_k) ==> H h_i ==> ?env exp (r: res) (h_f: heap) (h_g: heap) (st': 'ffi state). @@ -278,8 +288,9 @@ Theorem app_basic_rel do_opapp [f;x] = SOME (env, exp) /\ case r of | Val v' => bigStep$evaluate F env st exp (st', Rval v') - | Exn e => bigStep$evaluate F env st exp (st', Rerr (Rraise e))` - (fs [app_basic_def,evaluate_ck_def,evaluate_list_SING,evaluate_list_raise_SING, + | Exn e => bigStep$evaluate F env st exp (st', Rerr (Rraise e)) +Proof + fs [app_basic_def,evaluate_ck_def,evaluate_list_SING,evaluate_list_raise_SING, funBigStepEquivTheory.functional_evaluate_list, bigClockTheory.big_clocked_unclocked_equiv,PULL_EXISTS] \\ rw [] \\ eq_tac \\ rw [] @@ -297,108 +308,134 @@ Theorem app_basic_rel \\ try_finally (rewrite_tac [CONJ_ASSOC] \\ once_rewrite_tac [CONJ_COMM] \\ asm_exists_tac \\ fs [] - \\ fs [st2heap_def] \\ asm_exists_tac \\ fs [])); + \\ fs [st2heap_def] \\ asm_exists_tac \\ fs []) +QED *) (* TODO: move to appropriate locations *) -Theorem FFI_part_NOT_IN_store2heap - `FFI_part x1 x2 x3 x4 ∉ store2heap refs` - (rw[store2heap_def,FFI_part_NOT_IN_store2heap_aux]); - -Theorem FFI_full_NOT_IN_store2heap - `FFI_full x1 ∉ store2heap refs` - (rw[store2heap_def,FFI_full_NOT_IN_store2heap_aux]); - -Theorem FFI_split_NOT_IN_store2heap - `FFI_split ∉ store2heap refs` - (rw[store2heap_def,FFI_split_NOT_IN_store2heap_aux]); - -Theorem store2heap_aux_MAPi - `∀n s. store2heap_aux n s = set (MAPi (λi v. Mem (n+i) v) s)` - (Induct_on`s` +Theorem FFI_part_NOT_IN_store2heap: + FFI_part x1 x2 x3 x4 ∉ store2heap refs +Proof + rw[store2heap_def,FFI_part_NOT_IN_store2heap_aux] +QED + +Theorem FFI_full_NOT_IN_store2heap: + FFI_full x1 ∉ store2heap refs +Proof + rw[store2heap_def,FFI_full_NOT_IN_store2heap_aux] +QED + +Theorem FFI_split_NOT_IN_store2heap: + FFI_split ∉ store2heap refs +Proof + rw[store2heap_def,FFI_split_NOT_IN_store2heap_aux] +QED + +Theorem store2heap_aux_MAPi: + ∀n s. store2heap_aux n s = set (MAPi (λi v. Mem (n+i) v) s) +Proof + Induct_on`s` \\ rw[store2heap_aux_def,o_DEF,ADD1] \\ rpt (AP_TERM_TAC ORELSE AP_THM_TAC) - \\ rw[FUN_EQ_THM]); - -Theorem store2heap_MAPi - `store2heap s = set (MAPi Mem s)` - (rw[store2heap_def,store2heap_aux_MAPi] - \\ srw_tac[ETA_ss][]); - -Theorem store2heap_aux_append_many - `∀s n x. + \\ rw[FUN_EQ_THM] +QED + +Theorem store2heap_MAPi: + store2heap s = set (MAPi Mem s) +Proof + rw[store2heap_def,store2heap_aux_MAPi] + \\ srw_tac[ETA_ss][] +QED + +Theorem store2heap_aux_append_many: + ∀s n x. store2heap_aux n (s ++ x) = - store2heap_aux (n + LENGTH s) x ∪ store2heap_aux n s` - (Induct \\ rw[store2heap_aux_def,ADD1,EXTENSION] - \\ metis_tac[]); - -Theorem store2heap_append_many - `∀s x. - store2heap (s ++ x) = store2heap s ∪ store2heap_aux (LENGTH s) x` - (rw[store2heap_def,store2heap_aux_append_many,UNION_COMM]); - -Theorem st2heap_with_refs_append - `st2heap p (st with refs := r1 ++ r2) = - st2heap p (st with refs := r1) ∪ store2heap_aux (LENGTH r1) r2` - (rw[st2heap_def,store2heap_append_many] - \\ metis_tac[UNION_COMM,UNION_ASSOC]); - -Theorem POSTv_cond - `(POSTv v. &f v) r h ⇔ ∃v. r = Val v ∧ f v ∧ h = ∅` - (rw[POSTv_def] - \\ Cases_on`r` \\ fs[cond_def,EQ_IMP_THM]); + store2heap_aux (n + LENGTH s) x ∪ store2heap_aux n s +Proof + Induct \\ rw[store2heap_aux_def,ADD1,EXTENSION] + \\ metis_tac[] +QED + +Theorem store2heap_append_many: + ∀s x. + store2heap (s ++ x) = store2heap s ∪ store2heap_aux (LENGTH s) x +Proof + rw[store2heap_def,store2heap_aux_append_many,UNION_COMM] +QED + +Theorem st2heap_with_refs_append: + st2heap p (st with refs := r1 ++ r2) = + st2heap p (st with refs := r1) ∪ store2heap_aux (LENGTH r1) r2 +Proof + rw[st2heap_def,store2heap_append_many] + \\ metis_tac[UNION_COMM,UNION_ASSOC] +QED + +Theorem POSTv_cond: + (POSTv v. &f v) r h ⇔ ∃v. r = Val v ∧ f v ∧ h = ∅ +Proof + rw[POSTv_def] + \\ Cases_on`r` \\ fs[cond_def,EQ_IMP_THM] +QED open terminationTheory evaluatePropsTheory val dec_clock_def = evaluateTheory.dec_clock_def val evaluate_empty_state_IMP = ml_translatorTheory.evaluate_empty_state_IMP (* -Theorem big_remove_clock - `∀c ck env s e s' r. +Theorem big_remove_clock: + ∀c ck env s e s' r. evaluate ck env s e (s',r) ∧ r ≠ Rerr (Rabort Rtimeout_error) ⇒ - evaluate F env (s with clock := c) e (s' with clock := c,r)` - (gen_tac \\ reverse Cases + evaluate F env (s with clock := c) e (s' with clock := c,r) +Proof + gen_tac \\ reverse Cases >- ( rw[] \\ imp_res_tac bigClockTheory.big_unclocked \\ `∀s. s = s with clock := s.clock` by simp[state_component_equality] \\ metis_tac[bigClockTheory.big_unclocked] ) \\ rw[bigClockTheory.big_clocked_unclocked_equiv] \\ - metis_tac[bigClockTheory.clocked_min_counter]); + metis_tac[bigClockTheory.clocked_min_counter] +QED *) -Theorem evaluate_refs_length_mono ` - (∀(s:'a state) env e s' r. +Theorem evaluate_refs_length_mono: + (∀(s:'a state) env e s' r. evaluate s env e = (s',r) ⇒ LENGTH s.refs ≤ LENGTH s'.refs) ∧ (∀(s:'a state) env v pes errv s' r. - evaluate_match s env v pes errv = (s',r) ⇒ LENGTH s.refs ≤ LENGTH s'.refs)` - (ho_match_mp_tac evaluate_ind + evaluate_match s env v pes errv = (s',r) ⇒ LENGTH s.refs ≤ LENGTH s'.refs) +Proof + ho_match_mp_tac evaluate_ind \\ rw[] \\ fs[evaluate_def] \\ every_case_tac \\ fs[] \\ rw[] \\ rfs[] \\ fs[dec_clock_def] \\ fs[semanticPrimitivesPropsTheory.do_app_cases] \\ rw[] \\ fs[semanticPrimitivesTheory.store_alloc_def,semanticPrimitivesTheory.store_assign_def] \\ rw[] - \\ every_case_tac >> fs[] >> rveq >> fs[]); + \\ every_case_tac >> fs[] >> rveq >> fs[] +QED (* -Theorem big_refs_length_mono - `evaluate ck env s exp (s',r) ⇒ LENGTH s.refs ≤ LENGTH s'.refs` - (Cases_on`ck` +Theorem big_refs_length_mono: + evaluate ck env s exp (s',r) ⇒ LENGTH s.refs ≤ LENGTH s'.refs +Proof + Cases_on`ck` \\ rw[funBigStepEquivTheory.functional_evaluate] \\ fs[bigClockTheory.big_clocked_unclocked_equiv,funBigStepEquivTheory.functional_evaluate] \\ imp_res_tac evaluate_refs_length_mono - \\ fs[]); + \\ fs[] +QED *) -Theorem SPLIT_st2heap_length_leq - `SPLIT (st2heap p s') (st2heap p s, h_g) ∧ +Theorem SPLIT_st2heap_length_leq: + SPLIT (st2heap p s') (st2heap p s, h_g) ∧ LENGTH s.refs ≤ LENGTH s'.refs ∧ s'.ffi = s.ffi ⇒ - s.refs ≼ s'.refs` - (rw[SPLIT_def,st2heap_def] + s.refs ≼ s'.refs +Proof + rw[SPLIT_def,st2heap_def] \\ `store2heap s'.refs = store2heap s.refs ∪ h_g` by ( fs[EXTENSION] \\ reverse Cases \\ fs[FFI_part_NOT_IN_store2heap] @@ -415,7 +452,8 @@ Theorem SPLIT_st2heap_length_leq \\ simp[EL_APPEND1] \\ fs[store2heap_MAPi,EXTENSION,MEM_MAPi] \\ first_x_assum(qspec_then`Mem n (EL n s.refs)`mp_tac) - \\ simp[]); + \\ simp[] +QED val forall_cases = Q.prove( `(!x. P x) <=> (!x1 x2. P (Mem x1 x2)) /\ @@ -519,11 +557,12 @@ val FFI_part_11 = Q.prove( \\ Cases_on `x3` \\ fs [] \\ fs [parts_ok_def] \\ imp_res_tac ALL_DISTINCT_FLAT_MEM_IMP \\ fs []); -Theorem SPLIT_st2heap_ffi - `SPLIT (st2heap p st') (st2heap p st, h_g) ⇒ +Theorem SPLIT_st2heap_ffi: + SPLIT (st2heap p st') (st2heap p st, h_g) ⇒ !n. FILTER (ffi_has_index_in [n]) st'.ffi.io_events = - FILTER (ffi_has_index_in [n]) st.ffi.io_events` - (PairCases_on `p` \\ strip_tac + FILTER (ffi_has_index_in [n]) st.ffi.io_events +Proof + PairCases_on `p` \\ strip_tac \\ reverse (Cases_on `parts_ok st.ffi (p0,p1) = parts_ok st'.ffi (p0,p1)`) THEN1 (reverse (Cases_on `parts_ok st.ffi (p0,p1)`) @@ -575,31 +614,35 @@ Theorem SPLIT_st2heap_ffi \\ strip_tac \\ rpt strip_tac \\ match_mp_tac FILTER_ffi_has_index_in_MEM - \\ fs [] \\ asm_exists_tac \\ fs []) + \\ fs [] \\ asm_exists_tac \\ fs [] +QED (* -Theorem SPLIT_st2heap_evaluate_ffi_same - `evaluate F env st exp (st',Rval res) ∧ +Theorem SPLIT_st2heap_evaluate_ffi_same: + evaluate F env st exp (st',Rval res) ∧ SPLIT (st2heap p st') (st2heap p st, h_g) ⇒ - st'.ffi = st.ffi` - (rw[] \\ imp_res_tac SPLIT_st2heap_ffi + st'.ffi = st.ffi +Proof + rw[] \\ imp_res_tac SPLIT_st2heap_ffi \\ fs[bigClockTheory.big_clocked_unclocked_equiv] \\ fs[funBigStepEquivTheory.functional_evaluate] \\ imp_res_tac evaluate_io_events_mono_imp \\ fs[io_events_mono_def] \\ `LENGTH st.ffi.io_events = LENGTH st'.ffi.io_events` by metis_tac [LENGTH_FILTER_EQ_IMP_LENGTH_EQ] - \\ metis_tac [IS_PREFIX_LENGTH_ANTI]); + \\ metis_tac [IS_PREFIX_LENGTH_ANTI] +QED *) (* -Theorem evaluate_imp_evaluate_empty_state - `evaluate F env s es (s',Rval r) ∧ s.refs ≼ s'.refs ∧ s'.ffi = s.ffi ∧ +Theorem evaluate_imp_evaluate_empty_state: + evaluate F env s es (s',Rval r) ∧ s.refs ≼ s'.refs ∧ s'.ffi = s.ffi ∧ t = empty_state with <| refs := s.refs |> ∧ t' = empty_state with <| refs := s'.refs |> ⇒ - evaluate F env t es (t',Rval r)` - (rw[Once bigClockTheory.big_clocked_unclocked_equiv] + evaluate F env t es (t',Rval r) +Proof + rw[Once bigClockTheory.big_clocked_unclocked_equiv] \\ fs[funBigStepEquivTheory.functional_evaluate] \\ drule (REWRITE_RULE[GSYM AND_IMP_INTRO]( INST_TYPE[beta|->oneSyntax.one_ty]( @@ -611,15 +654,17 @@ Theorem evaluate_imp_evaluate_empty_state \\ pop_assum SUBST_ALL_TAC \\ fs[GSYM funBigStepEquivTheory.functional_evaluate] \\ simp[bigClockTheory.big_clocked_unclocked_equiv] - \\ asm_exists_tac \\ fs[]); + \\ asm_exists_tac \\ fs[] +QED *) -Theorem Arrow_IMP_app_basic - `(Arrow a b) f v ==> +Theorem Arrow_IMP_app_basic: + (Arrow a b) f v ==> !x v1. a x v1 ==> - app_basic (p:'ffi ffi_proj) v v1 emp (POSTv v. &b (f x) v)` - (fs [app_basic_def,emp_def,cfHeapsBaseTheory.SPLIT_emp1, + app_basic (p:'ffi ffi_proj) v v1 emp (POSTv v. &b (f x) v) +Proof + fs [app_basic_def,emp_def,cfHeapsBaseTheory.SPLIT_emp1, ml_translatorTheory.Arrow_def,ml_translatorTheory.AppReturns_def,PULL_EXISTS] \\ fs [evaluate_ck_def, evaluate_to_heap_def] \\ rw [] \\ first_x_assum drule \\ strip_tac @@ -645,12 +690,14 @@ Theorem Arrow_IMP_app_basic \\ spose_not_then strip_assume_tac \\ imp_res_tac store2heap_IN_LENGTH \\ imp_res_tac store2heap_aux_IN_bound - \\ decide_tac); - -Theorem app_basic_IMP_Arrow - `(∀x v1. a x v1 ⇒ app_basic p v v1 emp (POSTv v. cond (b (f x) v))) ⇒ - Arrow a b f v` - (rw[app_basic_def,ml_translatorTheory.Arrow_def, + \\ decide_tac +QED + +Theorem app_basic_IMP_Arrow: + (∀x v1. a x v1 ⇒ app_basic p v v1 emp (POSTv v. cond (b (f x) v))) ⇒ + Arrow a b f v +Proof + rw[app_basic_def,ml_translatorTheory.Arrow_def, ml_translatorTheory.AppReturns_def,emp_def,SPLIT_emp1,evaluate_to_heap_def] \\ first_x_assum drule \\ fs[evaluate_ck_def] @@ -679,10 +726,13 @@ Theorem app_basic_IMP_Arrow FILTER (ffi_has_index_in [n]) st2.io_events` \\ `LENGTH st1.ffi.io_events = LENGTH st2.io_events` by metis_tac [LENGTH_FILTER_EQ_IMP_LENGTH_EQ] - \\ metis_tac [IS_PREFIX_LENGTH_ANTI]); - -Theorem Arrow_eq_app_basic - `Arrow a b f fv ⇔ (∀x xv. a x xv ⇒ app_basic p fv xv emp (POSTv v'. &b (f x) v'))` - (metis_tac[GEN_ALL Arrow_IMP_app_basic, GEN_ALL app_basic_IMP_Arrow]); + \\ metis_tac [IS_PREFIX_LENGTH_ANTI] +QED + +Theorem Arrow_eq_app_basic: + Arrow a b f fv ⇔ (∀x xv. a x xv ⇒ app_basic p fv xv emp (POSTv v'. &b (f x) v')) +Proof + metis_tac[GEN_ALL Arrow_IMP_app_basic, GEN_ALL app_basic_IMP_Arrow] +QED val _ = export_theory () diff --git a/characteristic/cfDivScript.sml b/characteristic/cfDivScript.sml index 4beaa5f33e..9afebc2b8d 100644 --- a/characteristic/cfDivScript.sml +++ b/characteristic/cfDivScript.sml @@ -4187,19 +4187,21 @@ Proof \\ rfs[store_assign_def,store_v_same_type_def,store_lookup_def] QED -Theorem do_app_SOME_ffi_same_oracle_state - `do_app (refs,ffi:'ffi ffi_state) op args = SOME ((refs',ffi'),r) +Theorem do_app_SOME_ffi_same_oracle_state: + do_app (refs,ffi:'ffi ffi_state) op args = SOME ((refs',ffi'),r) ⇒ do_app (refs,ffi with io_events := l) op args = - SOME ((refs',ffi' with io_events := l ++ DROP (LENGTH ffi.io_events) ffi'.io_events),r)` - (rw[] + SOME ((refs',ffi' with io_events := l ++ DROP (LENGTH ffi.io_events) ffi'.io_events),r) +Proof + rw[] \\ fs[semanticPrimitivesPropsTheory.do_app_cases] \\ rw[] \\ fs[] \\ fs[ffiTheory.call_FFI_def] \\ rpt(PURE_FULL_CASE_TAC >> fs[] >> rveq) \\ rveq \\ fs[ffiTheory.ffi_state_component_equality,DROP_LENGTH_NIL] \\ rfs[store_assign_def,store_v_same_type_def,store_lookup_def] - \\ fs[DROP_APPEND,DROP_LENGTH_NIL]); + \\ fs[DROP_APPEND,DROP_LENGTH_NIL] +QED Theorem evaluate_history_irrelevance: (!(st1:'ffi semanticPrimitives$state) env exp st st' res l. diff --git a/characteristic/cfFFITypeScript.sml b/characteristic/cfFFITypeScript.sml index 326ede3061..fd4c6da8eb 100644 --- a/characteristic/cfFFITypeScript.sml +++ b/characteristic/cfFFITypeScript.sml @@ -85,51 +85,65 @@ val Inner_def = zDefine ` (* injectivity *) -Theorem Num_11[simp] - `!n1 n2. Num n1 = Num n2 <=> n1 = n2` - (fs [Num_def,FUN_EQ_THM] \\ rw [] \\ eq_tac \\ rw [] - \\ pop_assum (qspec_then `iNum 1` mp_tac) \\ fs []); - -Theorem Str_11[simp] - `!n1 n2. Str n1 = Str n2 <=> n1 = n2` - (fs [Str_def,FUN_EQ_THM] \\ rw [] \\ eq_tac \\ rw [] - \\ pop_assum (qspec_then `iNum 1` mp_tac) \\ fs []); - -Theorem Cons_11[simp] - `!x1 x2 y1 y2. Cons x1 x2 = Cons y1 y2 <=> x1 = y1 /\ x2 = y2` - (rpt Cases +Theorem Num_11[simp]: + !n1 n2. Num n1 = Num n2 <=> n1 = n2 +Proof + fs [Num_def,FUN_EQ_THM] \\ rw [] \\ eq_tac \\ rw [] + \\ pop_assum (qspec_then `iNum 1` mp_tac) \\ fs [] +QED + +Theorem Str_11[simp]: + !n1 n2. Str n1 = Str n2 <=> n1 = n2 +Proof + fs [Str_def,FUN_EQ_THM] \\ rw [] \\ eq_tac \\ rw [] + \\ pop_assum (qspec_then `iNum 1` mp_tac) \\ fs [] +QED + +Theorem Cons_11[simp]: + !x1 x2 y1 y2. Cons x1 x2 = Cons y1 y2 <=> x1 = y1 /\ x2 = y2 +Proof + rpt Cases \\ fs [Cons_def,FUN_EQ_THM,ffi_app_def] \\ rw [] \\ eq_tac \\ rw [] THEN1 (pop_assum (qspec_then `iCons (iNum 0) x` mp_tac) \\ fs []) - THEN1 (pop_assum (qspec_then `iCons (iNum 1) x` mp_tac) \\ fs [])); + THEN1 (pop_assum (qspec_then `iCons (iNum 1) x` mp_tac) \\ fs []) +QED -Theorem List_11[simp] - `!xs ys. List xs = List ys <=> xs = ys` - (fs [List_def,FUN_EQ_THM] \\ rw [] \\ eq_tac \\ rw [] +Theorem List_11[simp]: + !xs ys. List xs = List ys <=> xs = ys +Proof + fs [List_def,FUN_EQ_THM] \\ rw [] \\ eq_tac \\ rw [] \\ fs [LIST_EQ_REWRITE] \\ rw [] THEN1 (pop_assum (qspec_then `iNum 1` mp_tac) \\ fs []) \\ Cases_on `EL x xs` \\ Cases_on `EL x ys` \\ fs [FUN_EQ_THM] \\ rw [] \\ first_x_assum (qspec_then `iCons (iNum x) x'` mp_tac) - \\ fs [ffi_app_def]); - -Theorem Stream_11[simp] - `!n1 n2. Stream n1 = Stream n2 <=> n1 = n2` - (fs [Stream_def,FUN_EQ_THM] \\ rw [] \\ eq_tac \\ rw [] - \\ pop_assum (qspec_then `iNum 1` mp_tac) \\ fs []); - -Theorem Fun_11[simp] - `Fun f1 = Fun f2 <=> f1 = f2` - (eq_tac \\ rw [] \\ fs [FUN_EQ_THM,Fun_def] \\ rw [] + \\ fs [ffi_app_def] +QED + +Theorem Stream_11[simp]: + !n1 n2. Stream n1 = Stream n2 <=> n1 = n2 +Proof + fs [Stream_def,FUN_EQ_THM] \\ rw [] \\ eq_tac \\ rw [] + \\ pop_assum (qspec_then `iNum 1` mp_tac) \\ fs [] +QED + +Theorem Fun_11[simp]: + Fun f1 = Fun f2 <=> f1 = f2 +Proof + eq_tac \\ rw [] \\ fs [FUN_EQ_THM,Fun_def] \\ rw [] \\ Cases_on `f1 x` \\ Cases_on `f2 x` \\ fs [FUN_EQ_THM] \\ rw [] - \\ first_x_assum (qspec_then `iCons x x'` mp_tac) \\ fs [ffi_app_def]); + \\ first_x_assum (qspec_then `iCons x x'` mp_tac) \\ fs [ffi_app_def] +QED -Theorem Inner_11[simp] - `!n1 n2. Inner n1 = Inner n2 <=> n1 = n2` - (fs [Inner_def,FUN_EQ_THM] \\ rw [] \\ eq_tac \\ rw [] - \\ pop_assum (qspec_then `iNum 1` mp_tac) \\ fs []); +Theorem Inner_11[simp]: + !n1 n2. Inner n1 = Inner n2 <=> n1 = n2 +Proof + fs [Inner_def,FUN_EQ_THM] \\ rw [] \\ eq_tac \\ rw [] + \\ pop_assum (qspec_then `iNum 1` mp_tac) \\ fs [] +QED (* distinctness *) @@ -173,8 +187,11 @@ val destStr_def = new_specification("destStr_def",["destStr"],prove(`` Stream_def,Fun_def,ffi_app_def])); val _ = export_rewrites ["destStr_def"]; -Theorem destStr_o_Str[simp] - `destStr o Str = SOME` (rw[FUN_EQ_THM]); +Theorem destStr_o_Str[simp]: + destStr o Str = SOME +Proof +rw[FUN_EQ_THM] +QED val destCons_def = new_specification("destCons_def",["destCons"],prove(`` ?destCons. diff --git a/characteristic/cfHeapsBaseScript.sml b/characteristic/cfHeapsBaseScript.sml index 4eef120137..d91d8df88d 100644 --- a/characteristic/cfHeapsBaseScript.sml +++ b/characteristic/cfHeapsBaseScript.sml @@ -25,35 +25,43 @@ val encode_pair_def = Define` val encode_list_def = Define` encode_list e l = List (MAP e l)`; -Theorem encode_list_11 - `!xs ys. +Theorem encode_list_11: + !xs ys. encode_list f xs = encode_list f ys /\ (!x y. f x = f y <=> x = y) ==> - xs = ys` - (Induct \\ Cases_on `ys` \\ fs [encode_list_def] \\ rw [] \\ fs []); + xs = ys +Proof + Induct \\ Cases_on `ys` \\ fs [encode_list_def] \\ rw [] \\ fs [] +QED val encode_option_def = Define` encode_option e NONE = List [] ∧ encode_option e (SOME x) = List [e x]`; -Theorem encode_option_11 - `∀x y. encode_option f x = encode_option f y ∧ (∀x y. f x = f y ⇔ x = y) ⇒ x = y` - (Cases \\ Cases \\ rw[encode_option_def] \\ metis_tac[]); +Theorem encode_option_11: + ∀x y. encode_option f x = encode_option f y ∧ (∀x y. f x = f y ⇔ x = y) ⇒ x = y +Proof + Cases \\ Cases \\ rw[encode_option_def] \\ metis_tac[] +QED val encode_bool_def = Define `encode_bool F = Num 0 ∧ encode_bool T = Num 1`; -Theorem encode_bool_11[simp] - `∀x y. encode_bool x = encode_bool y ⇔ x = y` - (Cases \\ Cases \\ rw[encode_bool_def]); +Theorem encode_bool_11[simp]: + ∀x y. encode_bool x = encode_bool y ⇔ x = y +Proof + Cases \\ Cases \\ rw[encode_bool_def] +QED val encode_int_def = Define` encode_int i = Cons (encode_bool (0 ≤ i)) (Num(Num(ABS i)))`; -Theorem encode_int_11[simp] - `∀x y. encode_int x = encode_int y ⇔ x = y` - (Cases \\ Cases \\ rw[encode_int_def]); +Theorem encode_int_11[simp]: + ∀x y. encode_int x = encode_int y ⇔ x = y +Proof + Cases \\ Cases \\ rw[encode_int_def] +QED val _ = Datatype ` ffi_result = FFIreturn (word8 list) 'ffi | FFIdiverge` @@ -280,206 +288,238 @@ val _ = add_infix ("~~>", 690, HOLgrammars.NONASSOC) (*------------------------------------------------------------------*) (** Low level lemmas about SPLIT and SPLIT3 *) -Theorem SPLIT3_of_SPLIT_emp3 - `!h h1 h2. SPLIT h (h1, h2) ==> SPLIT3 h (h1, h2, {})` - (SPLIT_TAC -) - -Theorem SPLIT3_of_SPLIT_emp2 - `!h h1 h3. SPLIT h (h1, h3) ==> SPLIT3 h (h1, {}, h3)` - (SPLIT_TAC -) - -Theorem SPLIT3_swap23 - `!h h1 h2 h3. SPLIT3 h (h1, h2, h3) ==> SPLIT3 h (h1, h3, h2)` - (SPLIT_TAC -) - -Theorem SPLIT_emp1 - `!h h'. SPLIT h ({}, h') = (h' = h)` - (SPLIT_TAC -) - -Theorem SPLIT_emp2 - `!h h'. SPLIT h (h', {}) = (h' = h)` - (SPLIT_TAC -) - -Theorem SPLIT3_emp1 - `!h h1 h2. SPLIT3 h ({}, h1, h2) = SPLIT h (h1, h2)` - (SPLIT_TAC -) - -Theorem SPLIT3_emp3 - `!h h1 h2. SPLIT3 h (h1,h2,{}) = SPLIT h (h1,h2)` - (SPLIT_TAC) - -Theorem SPLIT_of_SPLIT3_2u3 - `!h h1 h2 h3. SPLIT3 h (h1, h2, h3) ==> SPLIT h (h1, h2 UNION h3)` - (SPLIT_TAC -) +Theorem SPLIT3_of_SPLIT_emp3: + !h h1 h2. SPLIT h (h1, h2) ==> SPLIT3 h (h1, h2, {}) +Proof + SPLIT_TAC +QED + +Theorem SPLIT3_of_SPLIT_emp2: + !h h1 h3. SPLIT h (h1, h3) ==> SPLIT3 h (h1, {}, h3) +Proof + SPLIT_TAC +QED + +Theorem SPLIT3_swap23: + !h h1 h2 h3. SPLIT3 h (h1, h2, h3) ==> SPLIT3 h (h1, h3, h2) +Proof + SPLIT_TAC +QED + +Theorem SPLIT_emp1: + !h h'. SPLIT h ({}, h') = (h' = h) +Proof + SPLIT_TAC +QED + +Theorem SPLIT_emp2: + !h h'. SPLIT h (h', {}) = (h' = h) +Proof + SPLIT_TAC +QED + +Theorem SPLIT3_emp1: + !h h1 h2. SPLIT3 h ({}, h1, h2) = SPLIT h (h1, h2) +Proof + SPLIT_TAC +QED + +Theorem SPLIT3_emp3: + !h h1 h2. SPLIT3 h (h1,h2,{}) = SPLIT h (h1,h2) +Proof + SPLIT_TAC +QED + +Theorem SPLIT_of_SPLIT3_2u3: + !h h1 h2 h3. SPLIT3 h (h1, h2, h3) ==> SPLIT h (h1, h2 UNION h3) +Proof + SPLIT_TAC +QED (*------------------------------------------------------------------*) (** Additionnal properties of STAR *) -Theorem STARPOST_emp - `!Q. Q *+ emp = Q` - (strip_tac \\ fs [STARPOST_def] \\ metis_tac [SEP_CLAUSES] -); +Theorem STARPOST_emp: + !Q. Q *+ emp = Q +Proof + strip_tac \\ fs [STARPOST_def] \\ metis_tac [SEP_CLAUSES] +QED -Theorem SEP_IMP_frame_single_l - `!H' R. +Theorem SEP_IMP_frame_single_l: + !H' R. (emp ==>> H') ==> - (R ==>> H' * R)` - (rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] -); + (R ==>> H' * R) +Proof + rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] +QED -Theorem SEP_IMP_frame_single_r - `!H R. +Theorem SEP_IMP_frame_single_r: + !H R. (H ==>> emp) ==> - (H * R ==>> R)` - (rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] -); + (H * R ==>> R) +Proof + rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] +QED -Theorem SEP_IMP_cell_frame - `!H H' l v v'. +Theorem SEP_IMP_cell_frame: + !H H' l v v'. (v = v') /\ (H ==>> H') ==> - (H * l ~~>> v ==>> H' * l ~~>> v')` - (rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] -); + (H * l ~~>> v ==>> H' * l ~~>> v') +Proof + rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] +QED -Theorem SEP_IMP_cell_frame_single_l - `!H' l v v'. +Theorem SEP_IMP_cell_frame_single_l: + !H' l v v'. (v = v') /\ (emp ==>> H') ==> - (l ~~>> v ==>> H' * l ~~>> v')` - (rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] -); + (l ~~>> v ==>> H' * l ~~>> v') +Proof + rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] +QED -Theorem SEP_IMP_cell_frame_single_r - `!H l v v'. +Theorem SEP_IMP_cell_frame_single_r: + !H l v v'. (v = v') /\ (H ==>> emp) ==> - (H * l ~~>> v ==>> l ~~>> v')` - (rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] -); + (H * l ~~>> v ==>> l ~~>> v') +Proof + rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] +QED -Theorem SEP_IMP_cell_frame_single - `!H l v v'. +Theorem SEP_IMP_cell_frame_single: + !H l v v'. (v = v') /\ (emp ==>> emp) ==> - (l ~~>> v ==>> l ~~>> v')` - (fs [SEP_IMP_REFL] -); + (l ~~>> v ==>> l ~~>> v') +Proof + fs [SEP_IMP_REFL] +QED -Theorem SEP_IMP_REF_frame - `!H H' r v v'. +Theorem SEP_IMP_REF_frame: + !H H' r v v'. (v = v') /\ (H ==>> H') ==> - (H * r ~~> v ==>> H' * r ~~> v')` - (rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] -); + (H * r ~~> v ==>> H' * r ~~> v') +Proof + rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] +QED -Theorem SEP_IMP_REF_frame_single_l - `!H' r v v'. +Theorem SEP_IMP_REF_frame_single_l: + !H' r v v'. (v = v') /\ (emp ==>> H') ==> - (r ~~> v ==>> H' * r ~~> v')` - (rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] -); + (r ~~> v ==>> H' * r ~~> v') +Proof + rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] +QED -Theorem SEP_IMP_REF_frame_single_r - `!H r v v'. +Theorem SEP_IMP_REF_frame_single_r: + !H r v v'. (v = v') /\ (H ==>> emp) ==> - (H * r ~~> v ==>> r ~~> v')` - (rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] -); + (H * r ~~> v ==>> r ~~> v') +Proof + rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] +QED -Theorem SEP_IMP_REF_frame_single - `!H r v v'. +Theorem SEP_IMP_REF_frame_single: + !H r v v'. (v = v') /\ (emp ==>> emp) ==> - (r ~~> v ==>> r ~~> v')` - (fs [SEP_IMP_REFL] -); + (r ~~> v ==>> r ~~> v') +Proof + fs [SEP_IMP_REFL] +QED -Theorem SEP_IMP_ARRAY_frame - `!H H' a vl vl'. +Theorem SEP_IMP_ARRAY_frame: + !H H' a vl vl'. (vl = vl') /\ (H ==>> H') ==> - (H * ARRAY a vl ==>> H' * ARRAY a vl')` - (rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] -); + (H * ARRAY a vl ==>> H' * ARRAY a vl') +Proof + rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] +QED -Theorem SEP_IMP_ARRAY_frame_single_l - `!H' a vl vl'. +Theorem SEP_IMP_ARRAY_frame_single_l: + !H' a vl vl'. (vl = vl') /\ (emp ==>> H') ==> - (ARRAY a vl ==>> H' * ARRAY a vl')` - (rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] -); + (ARRAY a vl ==>> H' * ARRAY a vl') +Proof + rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] +QED -Theorem SEP_IMP_ARRAY_frame_single_r - `!H a vl vl'. +Theorem SEP_IMP_ARRAY_frame_single_r: + !H a vl vl'. (vl = vl') /\ (H ==>> emp) ==> - (H * ARRAY a vl ==>> ARRAY a vl')` - (rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] -); + (H * ARRAY a vl ==>> ARRAY a vl') +Proof + rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] +QED -Theorem SEP_IMP_ARRAY_frame_single - `!H a vl vl'. +Theorem SEP_IMP_ARRAY_frame_single: + !H a vl vl'. (vl = vl') /\ (emp ==>> emp) ==> - (ARRAY a vl ==>> ARRAY a vl')` - (fs [SEP_IMP_REFL] -); + (ARRAY a vl ==>> ARRAY a vl') +Proof + fs [SEP_IMP_REFL] +QED -Theorem SEP_IMP_W8ARRAY_frame - `!H H' a wl wl'. +Theorem SEP_IMP_W8ARRAY_frame: + !H H' a wl wl'. (wl = wl') /\ (H ==>> H') ==> - (H * W8ARRAY a wl ==>> H' * W8ARRAY a wl')` - (rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] -); + (H * W8ARRAY a wl ==>> H' * W8ARRAY a wl') +Proof + rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] +QED -Theorem SEP_IMP_W8ARRAY_frame_single_l - `!H' a wl wl'. +Theorem SEP_IMP_W8ARRAY_frame_single_l: + !H' a wl wl'. (wl = wl') /\ (emp ==>> H') ==> - (W8ARRAY a wl ==>> H' * W8ARRAY a wl')` - (rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] -); + (W8ARRAY a wl ==>> H' * W8ARRAY a wl') +Proof + rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] +QED -Theorem SEP_IMP_W8ARRAY_frame_single_r - `!H a wl wl'. +Theorem SEP_IMP_W8ARRAY_frame_single_r: + !H a wl wl'. (wl = wl') /\ (H ==>> emp) ==> - (H * W8ARRAY a wl ==>> W8ARRAY a wl')` - (rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] -); + (H * W8ARRAY a wl ==>> W8ARRAY a wl') +Proof + rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] +QED -Theorem SEP_IMP_W8ARRAY_frame_single - `!H a wl wl'. +Theorem SEP_IMP_W8ARRAY_frame_single: + !H a wl wl'. (wl = wl') /\ (emp ==>> emp) ==> - (W8ARRAY a wl ==>> W8ARRAY a wl')` - (fs [SEP_IMP_REFL] -); + (W8ARRAY a wl ==>> W8ARRAY a wl') +Proof + fs [SEP_IMP_REFL] +QED -Theorem SEP_IMP_IO_frame - `!H H' idx st u st' u'. +Theorem SEP_IMP_IO_frame: + !H H' idx st u st' u'. (st = st' /\ u = u') /\ (H ==>> H') ==> - (H * IO st u idx ==>> H' * IO st' u' idx)` - (rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] -); + (H * IO st u idx ==>> H' * IO st' u' idx) +Proof + rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] +QED -Theorem SEP_IMP_IO_frame_single_l - `!H' idx st u st' u'. +Theorem SEP_IMP_IO_frame_single_l: + !H' idx st u st' u'. (st = st' /\ u = u') /\ (emp ==>> H') ==> - (IO st u idx ==>> H' * IO st' u' idx)` - (rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] -); + (IO st u idx ==>> H' * IO st' u' idx) +Proof + rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] +QED -Theorem SEP_IMP_IO_frame_single_r - `!H idx st u st' u'. +Theorem SEP_IMP_IO_frame_single_r: + !H idx st u st' u'. (st = st' /\ u = u') /\ (H ==>> emp) ==> - (H * IO st u idx ==>> IO st' u' idx)` - (rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] -); + (H * IO st u idx ==>> IO st' u' idx) +Proof + rpt strip_tac \\ progress SEP_IMP_FRAME \\ fs [SEP_CLAUSES] +QED -Theorem SEP_IMP_IO_frame_single - `!idx st u st' u'. +Theorem SEP_IMP_IO_frame_single: + !idx st u st' u'. (st = st' /\ u = u') /\ (emp ==>> emp) ==> - (IO st u idx ==>> IO st' u' idx)` - (fs [SEP_IMP_REFL] -); + (IO st u idx ==>> IO st' u' idx) +Proof + fs [SEP_IMP_REFL] +QED (*------------------------------------------------------------------*) (** Normalization of STAR *) @@ -494,377 +534,441 @@ val rew_heap = full_simp_tac bool_ss rew_heap_thms (*------------------------------------------------------------------*) (* Workaround because of SEP_CLAUSES turning &F into SEP_F *) -Theorem SEP_F_to_cond - `SEP_F = &F` - (irule EQ_EXT \\ fs [SEP_F_def, cond_def] -); +Theorem SEP_F_to_cond: + SEP_F = &F +Proof + irule EQ_EXT \\ fs [SEP_F_def, cond_def] +QED (*------------------------------------------------------------------*) (** Properties of GC *) -Theorem GC_STAR_GC - `GC * GC = GC` - (fs [GC_def] \\ irule EQ_EXT \\ strip_tac \\ rew_heap \\ +Theorem GC_STAR_GC: + GC * GC = GC +Proof + fs [GC_def] \\ irule EQ_EXT \\ strip_tac \\ rew_heap \\ fs [SEP_EXISTS] \\ eq_tac \\ rpt strip_tac THENL [all_tac, qexists_tac `emp` \\ rew_heap] \\ metis_tac [] -) +QED (*------------------------------------------------------------------*) (* Unfolding + case split lemma for SEP_IMPPOST *) -Theorem SEP_IMPPOST_unfold - `!Q1 Q2. +Theorem SEP_IMPPOST_unfold: + !Q1 Q2. (Q1 ==+> Q2) <=> (!v. Q1 (Val v) ==>> Q2 (Val v)) /\ (!v. Q1 (Exn v) ==>> Q2 (Exn v)) /\ (!name conf bytes. Q1 (FFIDiv name conf bytes) ==>> Q2 (FFIDiv name conf bytes)) /\ - (!io. Q1 (Div io) ==>> Q2 (Div io))` - (rpt strip_tac \\ eq_tac \\ rpt strip_tac \\ fs [SEP_IMPPOST_def] \\ + (!io. Q1 (Div io) ==>> Q2 (Div io)) +Proof + rpt strip_tac \\ eq_tac \\ rpt strip_tac \\ fs [SEP_IMPPOST_def] \\ Cases \\ fs [] -); +QED (*------------------------------------------------------------------*) (** Extraction from H1 in H1 ==>> H2 *) -Theorem hpull_prop - `!H H' P. +Theorem hpull_prop: + !H H' P. (P ==> H ==>> H') ==> - (H * cond P ==>> H')` - (rpt strip_tac \\ fs [SEP_IMP_def, STAR_def, cond_def] \\ + (H * cond P ==>> H') +Proof + rpt strip_tac \\ fs [SEP_IMP_def, STAR_def, cond_def] \\ SPLIT_TAC -); +QED -Theorem hpull_prop_single - `!H' P. +Theorem hpull_prop_single: + !H' P. (P ==> emp ==>> H') ==> - (cond P ==>> H')` - (rpt strip_tac \\ fs [SEP_IMP_def, STAR_def, cond_def, emp_def] \\ + (cond P ==>> H') +Proof + rpt strip_tac \\ fs [SEP_IMP_def, STAR_def, cond_def, emp_def] \\ SPLIT_TAC -); +QED -Theorem hpull_exists_single - `!A H' J. +Theorem hpull_exists_single: + !A H' J. (!x. (J x) ==>> H') ==> - ($SEP_EXISTS J ==>> H')` - (rpt strip_tac \\ fs [SEP_IMP_def, STAR_def, SEP_EXISTS, emp_def] \\ + ($SEP_EXISTS J ==>> H') +Proof + rpt strip_tac \\ fs [SEP_IMP_def, STAR_def, SEP_EXISTS, emp_def] \\ SPLIT_TAC -); +QED -Theorem SEP_IMP_rew - `!H1 H2 H1' H2'. (H1 = H2) ==> (H1' = H2') ==> (H1 ==>> H1') = (H2 ==>> H2')` - (rew_heap -); +Theorem SEP_IMP_rew: + !H1 H2 H1' H2'. (H1 = H2) ==> (H1' = H2') ==> (H1 ==>> H1') = (H2 ==>> H2') +Proof + rew_heap +QED (*------------------------------------------------------------------*) (** Simplification in H2 on H1 ==>> H2 *) (** Lemmas *) -Theorem hsimpl_prop - `!H' H P. +Theorem hsimpl_prop: + !H' H P. P /\ (H' ==>> H) ==> - (H' ==>> H * cond P)` - (rpt strip_tac \\ fs [SEP_IMP_def, STAR_def, cond_def] \\ + (H' ==>> H * cond P) +Proof + rpt strip_tac \\ fs [SEP_IMP_def, STAR_def, cond_def] \\ SPLIT_TAC -); +QED -Theorem hsimpl_prop_single - `!H' P. +Theorem hsimpl_prop_single: + !H' P. P /\ (H' ==>> emp) ==> - (H' ==>> cond P)` - (rpt strip_tac \\ fs [SEP_IMP_def, STAR_def, cond_def, emp_def] \\ + (H' ==>> cond P) +Proof + rpt strip_tac \\ fs [SEP_IMP_def, STAR_def, cond_def, emp_def] \\ SPLIT_TAC -); +QED -Theorem hsimpl_exists_single - `!x H' J. +Theorem hsimpl_exists_single: + !x H' J. (H' ==>> J x) ==> - (H' ==>> $SEP_EXISTS J)` - (rpt strip_tac \\ fs [SEP_IMP_def, STAR_def, SEP_EXISTS, emp_def] \\ + (H' ==>> $SEP_EXISTS J) +Proof + rpt strip_tac \\ fs [SEP_IMP_def, STAR_def, SEP_EXISTS, emp_def] \\ SPLIT_TAC -); +QED -Theorem hsimpl_gc - `!H. H ==>> GC` - (fs [GC_def, SEP_IMP_def, SEP_EXISTS] \\ metis_tac [] -); +Theorem hsimpl_gc: + !H. H ==>> GC +Proof + fs [GC_def, SEP_IMP_def, SEP_EXISTS] \\ metis_tac [] +QED (*------------------------------------------------------------------*) (* Automatic rewrites for post-condition injections *) -Theorem POST_Val[simp] - `!Qv Qe Qf Qd v. POST Qv Qe Qf Qd (Val v) = Qv v` - (fs [POST_def] -); - -Theorem POST_Exn[simp] - `!Qv Qe Qf Qd v. POST Qv Qe Qf Qd (Exn v) = Qe v` - (fs [POST_def] -); - -Theorem POST_FFIDiv[simp] - `!Qv Qe Qf Qd name conf bytes. POST Qv Qe Qf Qd (FFIDiv name conf bytes) = Qf name conf bytes` - (fs [POST_def] -); - -Theorem POST_Div[simp] - `!Qv Qe Qf Qd io. POST Qv Qe Qf Qd (Div io) = &(Qd io)` - (fs [POST_def] -); - -Theorem POSTv_Val[simp] - `!Qv v. $POSTv Qv (Val v) = Qv v` - (fs [POSTv_def, POST_def] -); - -Theorem POSTv_Exn[simp] - `!Qv v. $POSTv Qv (Exn v) = &F` - (fs [POSTv_def, POST_def] -); - -Theorem POSTv_FFIDiv[simp] - `!Qv name conf bytes. $POSTv Qv (FFIDiv name conf bytes) = &F` - (fs [POSTv_def, POST_def] -); - -Theorem POSTv_Div[simp] - `!Qv io. $POSTv Qv (Div io) = &F` - (fs [POSTv_def, POST_def] -); - -Theorem POSTe_Val[simp] - `!Qe v. $POSTe Qe (Val v) = &F` - (fs [POSTe_def, POST_def] -); - -Theorem POSTe_Exn[simp] - `!Qe v. $POSTe Qe (Exn v) = Qe v` - (fs [POSTe_def, POST_def] -); - -Theorem POSTe_FFIDiv[simp] - `!Qe name conf bytes. $POSTe Qe (FFIDiv name conf bytes) = &F` - (fs [POSTe_def, POST_def] -); - -Theorem POSTe_Div[simp] - `!Qe io. $POSTe Qe (Div io) = &F` - (fs [POSTe_def, POST_def] -); - -Theorem POSTf_Val[simp] - `!Qf v. $POSTf Qf (Val v) = &F` - (fs [POSTf_def, POST_def] -); - -Theorem POSTf_Exn[simp] - `!Qf v. $POSTf Qf (Exn v) = &F` - (fs [POSTf_def, POST_def] -); - -Theorem POSTf_FFIDiv[simp] - `!Qf name conf bytes. $POSTf Qf (FFIDiv name conf bytes) = Qf name conf bytes` - (fs [POSTf_def, POST_def] -); - -Theorem POSTf_Div[simp] - `!Qf io. $POSTf Qf (Div io) = &F` - (fs [POSTf_def, POST_def] -); - -Theorem POSTd_Val[simp] - `!Qd v. $POSTd Qd (Val v) = &F` - (fs [POSTd_def, POST_def] -); - -Theorem POSTd_Exn[simp] - `!Qd v. $POSTd Qd (Exn v) = &F` - (fs [POSTd_def, POST_def] -); - -Theorem POSTd_FFIDiv[simp] - `!Qd name conf bytes. $POSTd Qd (FFIDiv name conf bytes) = &F` - (fs [POSTd_def, POST_def] -); - -Theorem POSTd_Div[simp] - `!Qd io. $POSTd Qd (Div io) = &(Qd io)` - (fs [POSTd_def, POST_def] -); - -Theorem POSTve_Val[simp] - `!Qv Qe v. POSTve Qv Qe (Val v) = Qv v` - (fs [POSTve_def, POST_def] -); - -Theorem POSTve_Exn[simp] - `!Qv Qe v. POSTve Qv Qe (Exn v) = Qe v` - (fs [POSTve_def, POST_def] -); - -Theorem POSTve_FFIDiv[simp] - `!Qv Qe name conf bytes. POSTve Qv Qe (FFIDiv name conf bytes) = &F` - (fs [POSTve_def, POST_def] -); - -Theorem POSTve_Div[simp] - `!Qv Qe io. POSTve Qv Qe (Div io) = &F` - (fs [POSTve_def, POST_def] -); - -Theorem POSTvd_Val[simp] - `!Qv Qd v. POSTvd Qv Qd (Val v) = Qv v` - (fs [POSTvd_def, POST_def] -); - -Theorem POSTvd_Exn[simp] - `!Qv Qd v. POSTvd Qv Qd (Exn v) = &F` - (fs [POSTvd_def, POST_def] -); - -Theorem POSTvd_FFIDiv[simp] - `!Qv Qd name conf bytes. POSTvd Qv Qd (FFIDiv name conf bytes) = &F` - (fs [POSTvd_def, POST_def] -); - -Theorem POSTvd_Div[simp] - `!Qv Qd io. POSTvd Qv Qd (Div io) = &(Qd io)` - (fs [POSTvd_def, POST_def] -); - -Theorem POSTed_Val[simp] - `!Qe Qd v. POSTed Qe Qd (Val v) = &F` - (fs [POSTed_def, POST_def] -); - -Theorem POSTed_Exn[simp] - `!Qe Qd v. POSTed Qe Qd (Exn v) = Qe v` - (fs [POSTed_def, POST_def] -); - -Theorem POSTed_FFIDiv[simp] - `!Qe Qd name conf bytes. POSTed Qe Qd (FFIDiv name conf bytes) = &F` - (fs [POSTed_def, POST_def] -); - -Theorem POSTed_Div[simp] - `!Qe Qd io. POSTed Qe Qd (Div io) = &(Qd io)` - (fs [POSTed_def, POST_def] -); +Theorem POST_Val[simp]: + !Qv Qe Qf Qd v. POST Qv Qe Qf Qd (Val v) = Qv v +Proof + fs [POST_def] +QED + +Theorem POST_Exn[simp]: + !Qv Qe Qf Qd v. POST Qv Qe Qf Qd (Exn v) = Qe v +Proof + fs [POST_def] +QED + +Theorem POST_FFIDiv[simp]: + !Qv Qe Qf Qd name conf bytes. POST Qv Qe Qf Qd (FFIDiv name conf bytes) = Qf name conf bytes +Proof + fs [POST_def] +QED + +Theorem POST_Div[simp]: + !Qv Qe Qf Qd io. POST Qv Qe Qf Qd (Div io) = &(Qd io) +Proof + fs [POST_def] +QED + +Theorem POSTv_Val[simp]: + !Qv v. $POSTv Qv (Val v) = Qv v +Proof + fs [POSTv_def, POST_def] +QED + +Theorem POSTv_Exn[simp]: + !Qv v. $POSTv Qv (Exn v) = &F +Proof + fs [POSTv_def, POST_def] +QED + +Theorem POSTv_FFIDiv[simp]: + !Qv name conf bytes. $POSTv Qv (FFIDiv name conf bytes) = &F +Proof + fs [POSTv_def, POST_def] +QED + +Theorem POSTv_Div[simp]: + !Qv io. $POSTv Qv (Div io) = &F +Proof + fs [POSTv_def, POST_def] +QED + +Theorem POSTe_Val[simp]: + !Qe v. $POSTe Qe (Val v) = &F +Proof + fs [POSTe_def, POST_def] +QED + +Theorem POSTe_Exn[simp]: + !Qe v. $POSTe Qe (Exn v) = Qe v +Proof + fs [POSTe_def, POST_def] +QED + +Theorem POSTe_FFIDiv[simp]: + !Qe name conf bytes. $POSTe Qe (FFIDiv name conf bytes) = &F +Proof + fs [POSTe_def, POST_def] +QED + +Theorem POSTe_Div[simp]: + !Qe io. $POSTe Qe (Div io) = &F +Proof + fs [POSTe_def, POST_def] +QED + +Theorem POSTf_Val[simp]: + !Qf v. $POSTf Qf (Val v) = &F +Proof + fs [POSTf_def, POST_def] +QED + +Theorem POSTf_Exn[simp]: + !Qf v. $POSTf Qf (Exn v) = &F +Proof + fs [POSTf_def, POST_def] +QED + +Theorem POSTf_FFIDiv[simp]: + !Qf name conf bytes. $POSTf Qf (FFIDiv name conf bytes) = Qf name conf bytes +Proof + fs [POSTf_def, POST_def] +QED + +Theorem POSTf_Div[simp]: + !Qf io. $POSTf Qf (Div io) = &F +Proof + fs [POSTf_def, POST_def] +QED + +Theorem POSTd_Val[simp]: + !Qd v. $POSTd Qd (Val v) = &F +Proof + fs [POSTd_def, POST_def] +QED + +Theorem POSTd_Exn[simp]: + !Qd v. $POSTd Qd (Exn v) = &F +Proof + fs [POSTd_def, POST_def] +QED + +Theorem POSTd_FFIDiv[simp]: + !Qd name conf bytes. $POSTd Qd (FFIDiv name conf bytes) = &F +Proof + fs [POSTd_def, POST_def] +QED + +Theorem POSTd_Div[simp]: + !Qd io. $POSTd Qd (Div io) = &(Qd io) +Proof + fs [POSTd_def, POST_def] +QED + +Theorem POSTve_Val[simp]: + !Qv Qe v. POSTve Qv Qe (Val v) = Qv v +Proof + fs [POSTve_def, POST_def] +QED + +Theorem POSTve_Exn[simp]: + !Qv Qe v. POSTve Qv Qe (Exn v) = Qe v +Proof + fs [POSTve_def, POST_def] +QED + +Theorem POSTve_FFIDiv[simp]: + !Qv Qe name conf bytes. POSTve Qv Qe (FFIDiv name conf bytes) = &F +Proof + fs [POSTve_def, POST_def] +QED + +Theorem POSTve_Div[simp]: + !Qv Qe io. POSTve Qv Qe (Div io) = &F +Proof + fs [POSTve_def, POST_def] +QED + +Theorem POSTvd_Val[simp]: + !Qv Qd v. POSTvd Qv Qd (Val v) = Qv v +Proof + fs [POSTvd_def, POST_def] +QED + +Theorem POSTvd_Exn[simp]: + !Qv Qd v. POSTvd Qv Qd (Exn v) = &F +Proof + fs [POSTvd_def, POST_def] +QED + +Theorem POSTvd_FFIDiv[simp]: + !Qv Qd name conf bytes. POSTvd Qv Qd (FFIDiv name conf bytes) = &F +Proof + fs [POSTvd_def, POST_def] +QED + +Theorem POSTvd_Div[simp]: + !Qv Qd io. POSTvd Qv Qd (Div io) = &(Qd io) +Proof + fs [POSTvd_def, POST_def] +QED + +Theorem POSTed_Val[simp]: + !Qe Qd v. POSTed Qe Qd (Val v) = &F +Proof + fs [POSTed_def, POST_def] +QED + +Theorem POSTed_Exn[simp]: + !Qe Qd v. POSTed Qe Qd (Exn v) = Qe v +Proof + fs [POSTed_def, POST_def] +QED + +Theorem POSTed_FFIDiv[simp]: + !Qe Qd name conf bytes. POSTed Qe Qd (FFIDiv name conf bytes) = &F +Proof + fs [POSTed_def, POST_def] +QED + +Theorem POSTed_Div[simp]: + !Qe Qd io. POSTed Qe Qd (Div io) = &(Qd io) +Proof + fs [POSTed_def, POST_def] +QED (* other lemmas about POSTv *) -Theorem POSTv_ignore - `(POSTv v. P) r h ⇔ ∃v. r = Val v ∧ P h` - (Cases_on `r` \\ rw[cond_def] -); +Theorem POSTv_ignore: + (POSTv v. P) r h ⇔ ∃v. r = Val v ∧ P h +Proof + Cases_on `r` \\ rw[cond_def] +QED (*------------------------------------------------------------------*) (* Lemmas for ==v> / ==e> / ==f> / ==d> / =~v> / =~e> *) -Theorem SEP_IMPPOSTv_POSTe_left - `!Qe Q. $POSTe Qe ==v> Q` - (fs [POSTe_def, SEP_IMPPOSTv_def, SEP_IMP_def, cond_def] -); - -Theorem SEP_IMPPOSTv_POSTf_left - `!Qf Q. $POSTf Qf ==v> Q` - (fs [POSTf_def, SEP_IMPPOSTv_def, SEP_IMP_def, cond_def] -); - -Theorem SEP_IMPPOSTv_POSTd_left - `!Qd Q. $POSTd Qd ==v> Q` - (fs [POSTd_def, SEP_IMPPOSTv_def, SEP_IMP_def, cond_def] -); - -Theorem SEP_IMPPOSTv_POSTed_left - `!Qe Qd Q. POSTed Qe Qd ==v> Q` - (fs [POSTed_def, SEP_IMPPOSTv_def, SEP_IMP_def, cond_def] -); - -Theorem SEP_IMPPOSTe_POSTv_left - `!Qv Q. $POSTv Qv ==e> Q` - (fs [POSTv_def, SEP_IMPPOSTe_def, SEP_IMP_def, cond_def] -); - -Theorem SEP_IMPPOSTe_POSTf_left - `!Qf Q. $POSTf Qf ==e> Q` - (fs [POSTf_def, SEP_IMPPOSTe_def, SEP_IMP_def, cond_def] -); - -Theorem SEP_IMPPOSTe_POSTd_left - `!Qd Q. $POSTd Qd ==e> Q` - (fs [POSTd_def, SEP_IMPPOSTe_def, SEP_IMP_def, cond_def] -); - -Theorem SEP_IMPPOSTe_POSTvd_left - `!Qv Qd Q. POSTvd Qv Qd ==e> Q` - (fs [POSTvd_def, SEP_IMPPOSTe_def, SEP_IMP_def, cond_def] -); - -Theorem SEP_IMPPOSTf_POSTv_left - `!Qv Q. $POSTv Qv ==f> Q` - (fs [POSTv_def, SEP_IMPPOSTf_def, SEP_IMP_def, cond_def] -); - -Theorem SEP_IMPPOSTf_POSTe_left - `!Qe Q. $POSTe Qe ==f> Q` - (fs [POSTe_def, SEP_IMPPOSTf_def, SEP_IMP_def, cond_def] -); - -Theorem SEP_IMPPOSTf_POSTd_left - `!Qd Q. $POSTd Qd ==f> Q` - (fs [POSTd_def, SEP_IMPPOSTf_def, SEP_IMP_def, cond_def] -); - -Theorem SEP_IMPPOSTf_POSTve_left - `!Qv Qe Q. POSTve Qv Qe ==f> Q` - (fs [POSTve_def, SEP_IMPPOSTf_def, SEP_IMP_def, cond_def] -); - -Theorem SEP_IMPPOSTf_POSTvd_left - `!Qv Qd Q. POSTvd Qv Qd ==f> Q` - (fs [POSTvd_def, SEP_IMPPOSTf_def, SEP_IMP_def, cond_def] -); - -Theorem SEP_IMPPOSTf_POSTed_left - `!Qe Qd Q. POSTed Qe Qd ==f> Q` - (fs [POSTed_def, SEP_IMPPOSTf_def, SEP_IMP_def, cond_def] -); - -Theorem SEP_IMPPOSTd_POSTv_left - `!Qv Q. $POSTv Qv ==d> Q` - (fs [POSTv_def, SEP_IMPPOSTd_def, SEP_IMP_def, cond_def] -); - -Theorem SEP_IMPPOSTd_POSTe_left - `!Qe Q. $POSTe Qe ==d> Q` - (fs [POSTe_def, SEP_IMPPOSTd_def, SEP_IMP_def, cond_def] -); - -Theorem SEP_IMPPOSTd_POSTf_left - `!Qf Q. $POSTf Qf ==d> Q` - (fs [POSTf_def, SEP_IMPPOSTd_def, SEP_IMP_def, cond_def] -); - -Theorem SEP_IMPPOSTd_POSTve_left - `!Qv Qe Q. POSTve Qv Qe ==d> Q` - (fs [POSTve_def, SEP_IMPPOSTd_def, SEP_IMP_def, cond_def] -); - -Theorem SEP_IMPPOSTv_inv_POSTv_left - `!Qv Q. $POSTv Qv =~v> Q` - (fs [POSTv_def, SEP_IMPPOSTv_inv_def, +Theorem SEP_IMPPOSTv_POSTe_left: + !Qe Q. $POSTe Qe ==v> Q +Proof + fs [POSTe_def, SEP_IMPPOSTv_def, SEP_IMP_def, cond_def] +QED + +Theorem SEP_IMPPOSTv_POSTf_left: + !Qf Q. $POSTf Qf ==v> Q +Proof + fs [POSTf_def, SEP_IMPPOSTv_def, SEP_IMP_def, cond_def] +QED + +Theorem SEP_IMPPOSTv_POSTd_left: + !Qd Q. $POSTd Qd ==v> Q +Proof + fs [POSTd_def, SEP_IMPPOSTv_def, SEP_IMP_def, cond_def] +QED + +Theorem SEP_IMPPOSTv_POSTed_left: + !Qe Qd Q. POSTed Qe Qd ==v> Q +Proof + fs [POSTed_def, SEP_IMPPOSTv_def, SEP_IMP_def, cond_def] +QED + +Theorem SEP_IMPPOSTe_POSTv_left: + !Qv Q. $POSTv Qv ==e> Q +Proof + fs [POSTv_def, SEP_IMPPOSTe_def, SEP_IMP_def, cond_def] +QED + +Theorem SEP_IMPPOSTe_POSTf_left: + !Qf Q. $POSTf Qf ==e> Q +Proof + fs [POSTf_def, SEP_IMPPOSTe_def, SEP_IMP_def, cond_def] +QED + +Theorem SEP_IMPPOSTe_POSTd_left: + !Qd Q. $POSTd Qd ==e> Q +Proof + fs [POSTd_def, SEP_IMPPOSTe_def, SEP_IMP_def, cond_def] +QED + +Theorem SEP_IMPPOSTe_POSTvd_left: + !Qv Qd Q. POSTvd Qv Qd ==e> Q +Proof + fs [POSTvd_def, SEP_IMPPOSTe_def, SEP_IMP_def, cond_def] +QED + +Theorem SEP_IMPPOSTf_POSTv_left: + !Qv Q. $POSTv Qv ==f> Q +Proof + fs [POSTv_def, SEP_IMPPOSTf_def, SEP_IMP_def, cond_def] +QED + +Theorem SEP_IMPPOSTf_POSTe_left: + !Qe Q. $POSTe Qe ==f> Q +Proof + fs [POSTe_def, SEP_IMPPOSTf_def, SEP_IMP_def, cond_def] +QED + +Theorem SEP_IMPPOSTf_POSTd_left: + !Qd Q. $POSTd Qd ==f> Q +Proof + fs [POSTd_def, SEP_IMPPOSTf_def, SEP_IMP_def, cond_def] +QED + +Theorem SEP_IMPPOSTf_POSTve_left: + !Qv Qe Q. POSTve Qv Qe ==f> Q +Proof + fs [POSTve_def, SEP_IMPPOSTf_def, SEP_IMP_def, cond_def] +QED + +Theorem SEP_IMPPOSTf_POSTvd_left: + !Qv Qd Q. POSTvd Qv Qd ==f> Q +Proof + fs [POSTvd_def, SEP_IMPPOSTf_def, SEP_IMP_def, cond_def] +QED + +Theorem SEP_IMPPOSTf_POSTed_left: + !Qe Qd Q. POSTed Qe Qd ==f> Q +Proof + fs [POSTed_def, SEP_IMPPOSTf_def, SEP_IMP_def, cond_def] +QED + +Theorem SEP_IMPPOSTd_POSTv_left: + !Qv Q. $POSTv Qv ==d> Q +Proof + fs [POSTv_def, SEP_IMPPOSTd_def, SEP_IMP_def, cond_def] +QED + +Theorem SEP_IMPPOSTd_POSTe_left: + !Qe Q. $POSTe Qe ==d> Q +Proof + fs [POSTe_def, SEP_IMPPOSTd_def, SEP_IMP_def, cond_def] +QED + +Theorem SEP_IMPPOSTd_POSTf_left: + !Qf Q. $POSTf Qf ==d> Q +Proof + fs [POSTf_def, SEP_IMPPOSTd_def, SEP_IMP_def, cond_def] +QED + +Theorem SEP_IMPPOSTd_POSTve_left: + !Qv Qe Q. POSTve Qv Qe ==d> Q +Proof + fs [POSTve_def, SEP_IMPPOSTd_def, SEP_IMP_def, cond_def] +QED + +Theorem SEP_IMPPOSTv_inv_POSTv_left: + !Qv Q. $POSTv Qv =~v> Q +Proof + fs [POSTv_def, SEP_IMPPOSTv_inv_def, SEP_IMPPOSTe_def, SEP_IMPPOSTf_def, SEP_IMPPOSTd_def, SEP_IMP_def, cond_def] -); +QED -Theorem SEP_IMPPOSTe_inv_POSTe_left - `!Qe Q. $POSTe Qe =~e> Q` - (fs [POSTe_def, SEP_IMPPOSTe_inv_def, +Theorem SEP_IMPPOSTe_inv_POSTe_left: + !Qe Q. $POSTe Qe =~e> Q +Proof + fs [POSTe_def, SEP_IMPPOSTe_inv_def, SEP_IMPPOSTv_def, SEP_IMPPOSTf_def, SEP_IMPPOSTd_def, SEP_IMP_def, cond_def] -); +QED val _ = export_theory() diff --git a/characteristic/cfHeapsScript.sml b/characteristic/cfHeapsScript.sml index e6df251534..bc3fe4f5f2 100644 --- a/characteristic/cfHeapsScript.sml +++ b/characteristic/cfHeapsScript.sml @@ -11,25 +11,27 @@ fun sing x = [x] (*------------------------------------------------------------------*) (* hchange: using a [H1 ==>> H2] theorem modulo frame rule *) -Theorem hchange_lemma' - `!H1 H1' H H' H2. +Theorem hchange_lemma': + !H1 H1' H H' H2. H1 ==>> H1' ==> H ==>> H1 * H2 /\ H1' * H2 ==>> H' ==> - H ==>> H'` - (rpt strip_tac \\ irule SEP_IMP_TRANS \\ qexists_tac `H1 * H2` \\ fs [] \\ + H ==>> H' +Proof + rpt strip_tac \\ irule SEP_IMP_TRANS \\ qexists_tac `H1 * H2` \\ fs [] \\ irule SEP_IMP_TRANS \\ qexists_tac `H1' * H2` \\ hsimpl \\ fs [] -) +QED -Theorem hchange_lemma - `!H1 H1' H H' H2. +Theorem hchange_lemma: + !H1 H1' H H' H2. H1 ==>> H1' /\ H ==>> H1 * H2 /\ H1' * H2 ==>> H' ==> - H ==>> H'` - (rpt strip_tac \\ irule SEP_IMP_TRANS \\ qexists_tac `H1 * H2` \\ fs [] \\ + H ==>> H' +Proof + rpt strip_tac \\ irule SEP_IMP_TRANS \\ qexists_tac `H1 * H2` \\ fs [] \\ irule SEP_IMP_TRANS \\ qexists_tac `H1' * H2` \\ hsimpl \\ fs [] -) +QED (*------------------------------------------------------------------*) (** Locality *) @@ -48,15 +50,17 @@ val is_local_def = Define ` (* Properties of [local] *) -Theorem local_elim - `!cf H Q. cf H Q ==> local cf H Q` - (fs [local_def] \\ rpt strip_tac \\ +Theorem local_elim: + !cf H Q. cf H Q ==> local cf H Q +Proof + fs [local_def] \\ rpt strip_tac \\ Q.LIST_EXISTS_TAC [`H`, `emp`, `Q`] \\ hsimpl \\ rew_heap -) +QED -Theorem local_local - `!cf. local (local cf) = local cf` - (qsuff_tac `!cf H Q. local (local cf) H Q = local cf H Q` +Theorem local_local: + !cf. local (local cf) = local cf +Proof + qsuff_tac `!cf H Q. local (local cf) H Q = local cf H Q` THEN1 (metis_tac []) \\ rpt strip_tac \\ eq_tac \\ fs [local_elim] \\ @@ -80,40 +84,44 @@ Theorem local_local qsuff_tac `SEP_IMP ((Q1 x * H2) * GC) ((Q x * GC) * GC)` THEN1 fs [AC STAR_ASSOC STAR_COMM] \\ match_mp_tac SEP_IMP_STAR \\ fs [SEP_IMP_REFL] -) - -Theorem local_is_local - `!F. is_local (local F) = T` - (metis_tac [is_local_def, local_local] -) - -Theorem is_local_prove - `!F. (!H Q. F H Q <=> local F H Q) ==> is_local F` - (rpt strip_tac \\ fs [is_local_def] \\ +QED + +Theorem local_is_local: + !F. is_local (local F) = T +Proof + metis_tac [is_local_def, local_local] +QED + +Theorem is_local_prove: + !F. (!H Q. F H Q <=> local F H Q) ==> is_local F +Proof + rpt strip_tac \\ fs [is_local_def] \\ NTAC 2 (irule EQ_EXT \\ gen_tac) \\ fs [] -); +QED -Theorem local_frame_gc - `!F H H1 H2 Q1 Q. +Theorem local_frame_gc: + !F H H1 H2 Q1 Q. is_local F ==> F H1 Q1 ==> H ==>> H1 * H2 ==> Q1 *+ H2 ==+> Q *+ GC ==> - F H Q` - (fs [is_local_def] \\ rpt strip_tac \\ + F H Q +Proof + fs [is_local_def] \\ rpt strip_tac \\ qpat_x_assum `_ = local _` (once_rewrite_tac o sing) \\ rewrite_tac [local_def] \\ rpt strip_tac \\ Q.LIST_EXISTS_TAC [`H1`, `H2`, `Q1`] \\ strip_tac \\ fs [SEP_IMP_def] -) +QED -Theorem local_frame - `!H1 H2 Q1 F H Q. +Theorem local_frame: + !H1 H2 Q1 F H Q. is_local F ==> F H1 Q1 ==> H ==>> H1 * H2 ==> Q1 *+ H2 ==+> Q ==> - F H Q` - (fs [is_local_def] \\ rpt strip_tac \\ + F H Q +Proof + fs [is_local_def] \\ rpt strip_tac \\ qpat_x_assum `_ = local _` (once_rewrite_tac o sing) \\ rewrite_tac [local_def] \\ rpt strip_tac \\ Q.LIST_EXISTS_TAC [`H1`, `H2`, `Q1`] \\ strip_tac @@ -123,92 +131,99 @@ Theorem local_frame first_assum (fn t => irule (MATCH_MP hchange_lemma' (Q.SPEC `x` t))) \\ QUANT_TAC [("x'", `x`, [])] \\ hsimpl \\ qexists_tac `emp` \\ hsimpl ) -) +QED -Theorem local_gc_pre_on - `!HG H' F H Q. +Theorem local_gc_pre_on: + !HG H' F H Q. is_local F ==> H ==>> HG * H' ==> F H' Q ==> - F H Q` - (rpt strip_tac \\ fs [is_local_def] \\ + F H Q +Proof + rpt strip_tac \\ fs [is_local_def] \\ qpat_x_assum `_ = local _` (once_rewrite_tac o sing) \\ fs [local_def] \\ rpt strip_tac \\ Q.LIST_EXISTS_TAC [`H'`, `HG`, `Q`] \\ rpt strip_tac THEN1 (once_rewrite_tac [STAR_COMM] \\ fs [SEP_IMP_def]) THEN1 (fs []) THEN1 hsimpl -) +QED -Theorem local_gc_post - `!Q' F H Q. +Theorem local_gc_post: + !Q' F H Q. is_local F ==> F H Q' ==> Q' ==+> Q *+ GC ==> - F H Q` - (rpt strip_tac \\ fs [is_local_def] \\ + F H Q +Proof + rpt strip_tac \\ fs [is_local_def] \\ qpat_x_assum `_ = local _` (once_rewrite_tac o sing) \\ fs [local_def] \\ rpt strip_tac \\ Q.LIST_EXISTS_TAC [`H`, `&T`, `Q'`] \\ rpt strip_tac THEN1 (fs [STAR_def, cond_def, SPLIT_emp2]) THEN1 (fs []) THEN1 (hsimpl \\ fs [SEP_IMPPOST_def, STARPOST_def]) -); +QED (* Extraction of premisses from [local] *) -Theorem local_intro_prop - `!F H P Q. +Theorem local_intro_prop: + !F H P Q. is_local F ==> (P ==> F H Q) ==> - F (H * cond P) Q` - (rpt strip_tac \\ fs [is_local_def] \\ + F (H * cond P) Q +Proof + rpt strip_tac \\ fs [is_local_def] \\ qpat_x_assum `_ = local _` (once_rewrite_tac o sing) \\ fs [local_def] \\ rpt strip_tac \\ Q.LIST_EXISTS_TAC [`H`, `emp`, `Q`] \\ rew_heap \\ rpt strip_tac \\ TRY (fs [STAR_def, cond_def] \\ SPLIT_TAC) \\ hsimpl -) +QED (** Extraction of existentials from [local] *) -Theorem local_extract_exists - `!F A J Q. +Theorem local_extract_exists: + !F A J Q. is_local F ==> (!x. F (J x) Q) ==> - F ($SEP_EXISTS J) Q` - (rpt strip_tac \\ fs [is_local_def] \\ + F ($SEP_EXISTS J) Q +Proof + rpt strip_tac \\ fs [is_local_def] \\ qpat_x_assum `_ = local _` (once_rewrite_tac o sing) \\ fs [local_def] \\ rpt strip_tac \\ fs [SEP_EXISTS] \\ rename1 `J x _` \\ Q.LIST_EXISTS_TAC [`J x`, `emp`, `Q`] \\ rpt strip_tac \\ rew_heap \\ hsimpl -) +QED (** Auxiliary lemmas for [hclean]. Mostly repackaging of previous lemmas *) -Theorem hclean_prop - `!F H P Q. +Theorem hclean_prop: + !F H P Q. is_local F /\ (P ==> F H Q) ==> - F (H * cond P) Q` - (fs [local_intro_prop] -) + F (H * cond P) Q +Proof + fs [local_intro_prop] +QED -Theorem hclean_prop_single - `!F P Q. +Theorem hclean_prop_single: + !F P Q. is_local F /\ (P ==> F emp Q) ==> - F (cond P) Q` - (qx_gen_tac `HF` \\ + F (cond P) Q +Proof + qx_gen_tac `HF` \\ qspecl_then [`HF`, `emp`] mp_tac local_intro_prop \\ rew_heap -) +QED -Theorem hclean_exists_single - `!F A J Q. +Theorem hclean_exists_single: + !F A J Q. is_local F /\ (!x. F (J x) Q) ==> - F ($SEP_EXISTS J) Q` - (fs [local_extract_exists] -) + F ($SEP_EXISTS J) Q +Proof + fs [local_extract_exists] +QED val _ = export_theory() diff --git a/characteristic/cfLetAutoScript.sml b/characteristic/cfLetAutoScript.sml index 60778ddc9f..5033ec733e 100644 --- a/characteristic/cfLetAutoScript.sml +++ b/characteristic/cfLetAutoScript.sml @@ -7,31 +7,58 @@ open preamble ml_translatorTheory cfTacticsLib set_sepTheory cfHeapsBaseTheory c val _ = new_theory "cfLetAuto"; (* Rewrite rules for the int_of_num & operator*) -Theorem INT_OF_NUM_ADD -`!(x:num) (y:num).(&x) + &y = &(x+y)` (rw[] >> intLib.ARITH_TAC); -Theorem INT_OF_NUM_TIMES -`!(x:num) (y:num).(&x) * &y = &(x*y)` (rw[] >> intLib.ARITH_TAC); -Theorem INT_OF_NUM_LE -`!(x:num) (y:num). (&x <= (&y):int) = (x <= y)` (rw[]); -Theorem INT_OF_NUM_LESS -`!(x:num) (y:num). (&x < (&y):int) = (x < y)` (rw[]); -Theorem INT_OF_NUM_GE -`!(x:num) (y:num). (&x >= (&y):int) = (x >= y)` (rw[] >> intLib.ARITH_TAC); -Theorem INT_OF_NUM_GREAT -`!(x:num) (y:num). (&x > (&y):int) = (x > y)` (rw[] >> intLib.ARITH_TAC); -Theorem INT_OF_NUM_EQ -`!(x:num) (y:num). (&x = (&y):int) = (x = y)` (rw[] >> intLib.ARITH_TAC); -Theorem INT_OF_NUM_SUBS -`!(x:num) (y:num) (z:num). (&x - (&y):int = &z) <=> (x - y = z) /\ y <= x` -(rw[] >> intLib.ARITH_TAC); -Theorem INT_OF_NUM_SUBS_2 -`!(x:num) (y:num). y <= x ==> (&x - (&y):int = &(x - y))` -(rw[] >> fs[int_arithTheory.INT_NUM_SUB]); +Theorem INT_OF_NUM_ADD: + !(x:num) (y:num).(&x) + &y = &(x+y) +Proof +rw[] >> intLib.ARITH_TAC +QED +Theorem INT_OF_NUM_TIMES: + !(x:num) (y:num).(&x) * &y = &(x*y) +Proof +rw[] >> intLib.ARITH_TAC +QED +Theorem INT_OF_NUM_LE: + !(x:num) (y:num). (&x <= (&y):int) = (x <= y) +Proof +rw[] +QED +Theorem INT_OF_NUM_LESS: + !(x:num) (y:num). (&x < (&y):int) = (x < y) +Proof +rw[] +QED +Theorem INT_OF_NUM_GE: + !(x:num) (y:num). (&x >= (&y):int) = (x >= y) +Proof +rw[] >> intLib.ARITH_TAC +QED +Theorem INT_OF_NUM_GREAT: + !(x:num) (y:num). (&x > (&y):int) = (x > y) +Proof +rw[] >> intLib.ARITH_TAC +QED +Theorem INT_OF_NUM_EQ: + !(x:num) (y:num). (&x = (&y):int) = (x = y) +Proof +rw[] >> intLib.ARITH_TAC +QED +Theorem INT_OF_NUM_SUBS: + !(x:num) (y:num) (z:num). (&x - (&y):int = &z) <=> (x - y = z) /\ y <= x +Proof +rw[] >> intLib.ARITH_TAC +QED +Theorem INT_OF_NUM_SUBS_2: + !(x:num) (y:num). y <= x ==> (&x - (&y):int = &(x - y)) +Proof +rw[] >> fs[int_arithTheory.INT_NUM_SUB] +QED (* TODO: move that *) -Theorem SPLIT_SUBSET -`SPLIT s (u, v) ==> u SUBSET s /\ v SUBSET s` -(rw[SPLIT_def] >> fs[SUBSET_UNION]); +Theorem SPLIT_SUBSET: + SPLIT s (u, v) ==> u SUBSET s /\ v SUBSET s +Proof +rw[SPLIT_def] >> fs[SUBSET_UNION] +QED (* Predicate stating that a heap is valid *) val HEAP_FROM_STATE_def = @@ -40,16 +67,20 @@ val HEAP_FROM_STATE_def = val VALID_HEAP_def = Define `VALID_HEAP s = ?(f : ffi ffi_proj) st. s SUBSET (st2heap f st)`; -Theorem VALID_HEAP_SUBSET -`VALID_HEAP s1 ==> s2 SUBSET s1 ==> VALID_HEAP s2` -(rw[VALID_HEAP_def] >> metis_tac[SUBSET_TRANS]); +Theorem VALID_HEAP_SUBSET: + VALID_HEAP s1 ==> s2 SUBSET s1 ==> VALID_HEAP s2 +Proof +rw[VALID_HEAP_def] >> metis_tac[SUBSET_TRANS] +QED (* A theorem to remove the pure facts from the heap predicates *) -Theorem HCOND_EXTRACT -`((&A * H) s <=> A /\ H s) /\ ((H * &A) s <=> H s /\ A) /\ ((H * &A * H') s <=> (H * H') s /\ A)` -(rw[] >-(fs[STAR_def, STAR_def, cond_def, SPLIT_def]) +Theorem HCOND_EXTRACT: + ((&A * H) s <=> A /\ H s) /\ ((H * &A) s <=> H s /\ A) /\ ((H * &A * H') s <=> (H * H') s /\ A) +Proof +rw[] >-(fs[STAR_def, STAR_def, cond_def, SPLIT_def]) >-(fs[STAR_def, STAR_def, cond_def, SPLIT_def]) >> -fs[STAR_def, STAR_def, cond_def, SPLIT_def] >> EQ_TAC >-(rw [] >-(instantiate) >> rw[]) >> rw[]); +fs[STAR_def, STAR_def, cond_def, SPLIT_def] >> EQ_TAC >-(rw [] >-(instantiate) >> rw[]) >> rw[] +QED (* Definitions and theorems used to compare two heap conditions *) val HPROP_INJ_def = Define `HPROP_INJ H1 H2 PF <=> @@ -59,10 +90,12 @@ val HPROP_INJ_def = Define `HPROP_INJ H1 H2 PF <=> (* val HPROP_FRAME_IMP_def = Define `HPROP_FRAME_IMP H1 H2 Frame <=> ?s. VALID_HEAP s /\ H1 s /\ (H2 * Frame) s`; -Theorem HPROP_FRAME_HCOND -`HPROP_FRAME_IMP H1 (&PF * H2) Frame <=> PF /\ HPROP_FRAME_IMP H1 H2 Frame` -(rw[HPROP_FRAME_IMP_def, GSYM STAR_ASSOC, HCOND_EXTRACT, GSYM RIGHT_EXISTS_AND_THM] >> -metis_tac[]); *) +Theorem HPROP_FRAME_HCOND: + HPROP_FRAME_IMP H1 (&PF * H2) Frame <=> PF /\ HPROP_FRAME_IMP H1 H2 Frame +Proof +rw[HPROP_FRAME_IMP_def, GSYM STAR_ASSOC, HCOND_EXTRACT, GSYM RIGHT_EXISTS_AND_THM] >> +metis_tac[] +QED *) (* The following lemmas aim to prove that a valid heap can not have one pointer pointing to two different values *) val PTR_MEM_LEM = Q.prove(`!s l xv H. (l ~~>> xv * H) s ==> Mem l xv IN s`, @@ -86,28 +119,34 @@ fs[UNION_DEF] >-(IMP_RES_TAC store2heap_IN_unique_key)>> IMP_RES_TAC Mem_NOT_IN_ffi2heap); -Theorem UNIQUE_PTRS -`!s. VALID_HEAP s ==> !l xv xv' H H'. (l ~~>> xv * H) s /\ (l ~~>> xv' * H') s ==> xv' = xv` -(rw[VALID_HEAP_def] >> +Theorem UNIQUE_PTRS: + !s. VALID_HEAP s ==> !l xv xv' H H'. (l ~~>> xv * H) s /\ (l ~~>> xv' * H') s ==> xv' = xv +Proof +rw[VALID_HEAP_def] >> IMP_RES_TAC HEAP_SUBSET_GC >> fs[GSYM STAR_ASSOC] >> -metis_tac[HEAP_FROM_STATE_def, UNIQUE_PTRS_HFS]); +metis_tac[HEAP_FROM_STATE_def, UNIQUE_PTRS_HFS] +QED -Theorem PTR_IN_HEAP -`!l xv H s. (REF (Loc l) xv * H) s ==> Mem l (Refv xv) IN s` -(fs[STAR_def, SPLIT_def] >> +Theorem PTR_IN_HEAP: + !l xv H s. (REF (Loc l) xv * H) s ==> Mem l (Refv xv) IN s +Proof +fs[STAR_def, SPLIT_def] >> fs[REF_def, SEP_EXISTS] >> fs[HCOND_EXTRACT] >> fs[cell_def, one_def] >> rw[] >> -last_x_assum (fn x => rw[GSYM x])); +last_x_assum (fn x => rw[GSYM x]) +QED fun prove_hprop_inj_tac thm = rw[HPROP_INJ_def, SEP_CLAUSES, GSYM STAR_ASSOC, HCOND_EXTRACT] >> metis_tac[thm]; -Theorem PTR_HPROP_INJ -`!l xv xv'. HPROP_INJ (l ~~>> xv) (l ~~>> xv') (xv' = xv)` -(prove_hprop_inj_tac UNIQUE_PTRS); +Theorem PTR_HPROP_INJ: + !l xv xv'. HPROP_INJ (l ~~>> xv) (l ~~>> xv') (xv' = xv) +Proof +prove_hprop_inj_tac UNIQUE_PTRS +QED (* Unicity results for pointers *) val solve_unique_refs = (rw[] >> qspec_then `s:heap` ASSUME_TAC UNIQUE_PTRS >> @@ -115,29 +154,41 @@ val solve_unique_refs = (rw[] >> qspec_then `s:heap` ASSUME_TAC UNIQUE_PTRS >> `!A H1 H2. (&A * H1 * H2) s <=> A /\ (H1 * H2) s` by metis_tac[HCOND_EXTRACT, STAR_COMM] >> POP_ASSUM (fn x => fs[x]) >> rw[] >> POP_ASSUM IMP_RES_TAC >> fs[]); -Theorem UNIQUE_REFS -`!s r xv xv' H H'. VALID_HEAP s ==> (r ~~> xv * H) s /\ (r ~~> xv' * H') s ==> xv' = xv` -(solve_unique_refs); - -Theorem UNIQUE_ARRAYS -`!s a av av' H H'. VALID_HEAP s ==> (ARRAY a av * H) s /\ (ARRAY a av' * H') s ==> av' = av` -(solve_unique_refs); - -Theorem UNIQUE_W8ARRAYS -`!s a av av' H H'. VALID_HEAP s ==> (W8ARRAY a av * H) s /\ (W8ARRAY a av' * H') s ==> av' = av` -(solve_unique_refs); - -Theorem REF_HPROP_INJ -`!r xv xv'. HPROP_INJ (REF r xv) (REF r xv') (xv' = xv)` -(prove_hprop_inj_tac UNIQUE_REFS); - -Theorem ARRAY_HPROP_INJ -`!a av av'. HPROP_INJ (ARRAY a av) (ARRAY a av') (av' = av)` -(prove_hprop_inj_tac UNIQUE_ARRAYS); - -Theorem W8ARRAY_HPROP_INJ -`!a av av'. HPROP_INJ (W8ARRAY a av) (W8ARRAY a av') (av' = av)` -(prove_hprop_inj_tac UNIQUE_W8ARRAYS); +Theorem UNIQUE_REFS: + !s r xv xv' H H'. VALID_HEAP s ==> (r ~~> xv * H) s /\ (r ~~> xv' * H') s ==> xv' = xv +Proof +solve_unique_refs +QED + +Theorem UNIQUE_ARRAYS: + !s a av av' H H'. VALID_HEAP s ==> (ARRAY a av * H) s /\ (ARRAY a av' * H') s ==> av' = av +Proof +solve_unique_refs +QED + +Theorem UNIQUE_W8ARRAYS: + !s a av av' H H'. VALID_HEAP s ==> (W8ARRAY a av * H) s /\ (W8ARRAY a av' * H') s ==> av' = av +Proof +solve_unique_refs +QED + +Theorem REF_HPROP_INJ: + !r xv xv'. HPROP_INJ (REF r xv) (REF r xv') (xv' = xv) +Proof +prove_hprop_inj_tac UNIQUE_REFS +QED + +Theorem ARRAY_HPROP_INJ: + !a av av'. HPROP_INJ (ARRAY a av) (ARRAY a av') (av' = av) +Proof +prove_hprop_inj_tac UNIQUE_ARRAYS +QED + +Theorem W8ARRAY_HPROP_INJ: + !a av av'. HPROP_INJ (W8ARRAY a av) (W8ARRAY a av') (av' = av) +Proof +prove_hprop_inj_tac UNIQUE_W8ARRAYS +QED (* A valid heap must have proper ffi partitions *) val NON_OVERLAP_FFI_PART_HFS = Q.prove( @@ -188,16 +239,18 @@ Cases_on `parts_ok st.ffi (proj, parts)` ) >> fs[]); -Theorem NON_OVERLAP_FFI_PART -`!s. VALID_HEAP s ==> +Theorem NON_OVERLAP_FFI_PART: + !s. VALID_HEAP s ==> !s1 u1 ns1 ts1 s2 u2 ns2 ts2. FFI_part s1 u1 ns1 ts1 IN s /\ FFI_part s2 u2 ns2 ts2 IN s /\ (?p. MEM p ns1 /\ MEM p ns2) ==> -s2 = s1 /\ u2 = u1 /\ ns2 = ns1 /\ ts2 = ts1` -(rpt (FIRST[GEN_TAC, DISCH_TAC]) >> +s2 = s1 /\ u2 = u1 /\ ns2 = ns1 /\ ts2 = ts1 +Proof +rpt (FIRST[GEN_TAC, DISCH_TAC]) >> fs[VALID_HEAP_def] >> `HEAP_FROM_STATE (st2heap f st)` by metis_tac[GSYM HEAP_FROM_STATE_def] >> IMP_RES_TAC SUBSET_DEF >> IMP_RES_TAC NON_OVERLAP_FFI_PART_HFS >> -rw[]); +rw[] +QED (* A minor lemma *) val FFI_PORT_IN_HEAP_LEM = Q.prove( @@ -205,30 +258,36 @@ val FFI_PORT_IN_HEAP_LEM = Q.prove( rw[one_def, STAR_def, SPLIT_def, IN_DEF, UNION_DEF] >> rw[]); (* Another important theorem *) -Theorem FRAME_UNIQUE_IO -`!s. VALID_HEAP s ==> +Theorem FRAME_UNIQUE_IO: + !s. VALID_HEAP s ==> !s1 u1 ns1 s2 u2 ns2 H1 H2. (IO s1 u1 ns1 * H1) s /\ (IO s2 u2 ns2 * H2) s ==> (?pn. MEM pn ns1 /\ MEM pn ns2) ==> -s2 = s1 /\ u2 = u1 /\ ns2 = ns1` -(rpt (FIRST[GEN_TAC, DISCH_TAC]) >> +s2 = s1 /\ u2 = u1 /\ ns2 = ns1 +Proof +rpt (FIRST[GEN_TAC, DISCH_TAC]) >> fs[IO_def, SEP_CLAUSES, SEP_EXISTS_THM] >> full_simp_tac (std_ss++sep_cond_ss) [cond_STAR] >> IMP_RES_TAC FFI_PORT_IN_HEAP_LEM >> IMP_RES_TAC NON_OVERLAP_FFI_PART >> -fs[]); - -Theorem IO_HPROP_INJ -`!s1 u1 ns1 s2 u2 ns2 H1 H2. (?pn. MEM pn ns1 /\ MEM pn ns2) ==> -HPROP_INJ (IO s1 u1 ns1) (IO s2 u2 ns2) (s2 = s1 /\ u2 = u1 /\ ns2 = ns1)` -(rw[HPROP_INJ_def] >> +fs[] +QED + +Theorem IO_HPROP_INJ: + !s1 u1 ns1 s2 u2 ns2 H1 H2. (?pn. MEM pn ns1 /\ MEM pn ns2) ==> +HPROP_INJ (IO s1 u1 ns1) (IO s2 u2 ns2) (s2 = s1 /\ u2 = u1 /\ ns2 = ns1) +Proof +rw[HPROP_INJ_def] >> fs[IO_def, GSYM STAR_ASSOC, SEP_CLAUSES, SEP_EXISTS_THM, HCOND_EXTRACT] >> -metis_tac[FFI_PORT_IN_HEAP_LEM, NON_OVERLAP_FFI_PART]); +metis_tac[FFI_PORT_IN_HEAP_LEM, NON_OVERLAP_FFI_PART] +QED (* Theorems and rewrites for REPLICATE and LIST_REL *) -Theorem APPEND_LENGTH_INEQ -`!l1 l2. LENGTH(l1) <= LENGTH(l1++l2) /\ LENGTH(l2) <= LENGTH(l1++l2)` -(Induct >-(strip_tac >> rw[]) >> rw[]); +Theorem APPEND_LENGTH_INEQ: + !l1 l2. LENGTH(l1) <= LENGTH(l1++l2) /\ LENGTH(l2) <= LENGTH(l1++l2) +Proof +Induct >-(strip_tac >> rw[]) >> rw[] +QED val REPLICATE_APPEND_RIGHT = Q.prove( `a++b = REPLICATE n x ==> b = REPLICATE (LENGTH b) x`, @@ -247,17 +306,21 @@ POP_ASSUM (fn x => fs[x]) >> POP_ASSUM (fn x => ALL_TAC) >> `a ++ REPLICATE (LENGTH b) x = REPLICATE (n − LENGTH b) x ++ REPLICATE (LENGTH b) x` by metis_tac[] >> fs[LENGTH_REPLICATE]); -Theorem REPLICATE_APPEND_DECOMPOSE -`a ++ b = REPLICATE n x <=> -a = REPLICATE (LENGTH a) x /\ b = REPLICATE (LENGTH b) x /\ LENGTH a + LENGTH b = n` -(EQ_TAC >-(rw[] >-(metis_tac[REPLICATE_APPEND_LEFT]) >-(metis_tac[REPLICATE_APPEND_RIGHT]) >> metis_tac [LENGTH_REPLICATE, LENGTH_APPEND]) >> metis_tac[REPLICATE_APPEND]); +Theorem REPLICATE_APPEND_DECOMPOSE: + a ++ b = REPLICATE n x <=> +a = REPLICATE (LENGTH a) x /\ b = REPLICATE (LENGTH b) x /\ LENGTH a + LENGTH b = n +Proof +EQ_TAC >-(rw[] >-(metis_tac[REPLICATE_APPEND_LEFT]) >-(metis_tac[REPLICATE_APPEND_RIGHT]) >> metis_tac [LENGTH_REPLICATE, LENGTH_APPEND]) >> metis_tac[REPLICATE_APPEND] +QED val REPLICATE_APPEND_DECOMPOSE_SYM = save_thm("REPLICATE_APPEND_DECOMPOSE_SYM", CONV_RULE(PATH_CONV "lr" SYM_CONV) REPLICATE_APPEND_DECOMPOSE); -Theorem REPLICATE_PLUS_ONE -`REPLICATE (n + 1) x = x::REPLICATE n x` -(`n+1 = SUC n` by rw[] >> rw[REPLICATE]); +Theorem REPLICATE_PLUS_ONE: + REPLICATE (n + 1) x = x::REPLICATE n x +Proof +`n+1 = SUC n` by rw[] >> rw[REPLICATE] +QED val LIST_REL_DECOMPOSE_RIGHT_recip = Q.prove( `!R. LIST_REL R (a ++ b) x ==> LIST_REL R a (TAKE (LENGTH a) x) /\ LIST_REL R b (DROP (LENGTH a) x)`, @@ -274,9 +337,11 @@ rpt strip_tac >> `x = TAKE (LENGTH a) x ++ DROP (LENGTH a) x` by rw[TAKE_DROP] >> metis_tac[rich_listTheory.EVERY2_APPEND_suff]); -Theorem LIST_REL_DECOMPOSE_RIGHT -`!R. LIST_REL R (a ++ b) x <=> LIST_REL R a (TAKE (LENGTH a) x) /\ LIST_REL R b (DROP (LENGTH a) x)` -(strip_tac >> metis_tac[LIST_REL_DECOMPOSE_RIGHT_recip, LIST_REL_DECOMPOSE_RIGHT_imp]); +Theorem LIST_REL_DECOMPOSE_RIGHT: + !R. LIST_REL R (a ++ b) x <=> LIST_REL R a (TAKE (LENGTH a) x) /\ LIST_REL R b (DROP (LENGTH a) x) +Proof +strip_tac >> metis_tac[LIST_REL_DECOMPOSE_RIGHT_recip, LIST_REL_DECOMPOSE_RIGHT_imp] +QED val LIST_REL_DECOMPOSE_LEFT_recip = Q.prove( `!R. LIST_REL R x (a ++ b) ==> LIST_REL R (TAKE (LENGTH a) x) a /\ LIST_REL R (DROP (LENGTH a) x) b`, @@ -293,25 +358,33 @@ rpt strip_tac >> `x = TAKE (LENGTH a) x ++ DROP (LENGTH a) x` by rw[TAKE_DROP] >> metis_tac[rich_listTheory.EVERY2_APPEND_suff]); -Theorem LIST_REL_DECOMPOSE_LEFT -`!R. LIST_REL R x (a ++ b) <=> LIST_REL R (TAKE (LENGTH a) x) a /\ LIST_REL R (DROP (LENGTH a) x) b` -(strip_tac >> metis_tac[LIST_REL_DECOMPOSE_LEFT_recip, LIST_REL_DECOMPOSE_LEFT_imp]); - -Theorem HEAD_TAIL -`l <> [] ==> HD l :: TL l = l` -(Cases_on `l:'a list` >> rw[listTheory.TL, listTheory.HD]); - -Theorem HEAD_TAIL_DECOMPOSE_RIGHT -`x::a = b <=> b <> [] /\ x = HD b /\ a = TL b` -(rw[] >> EQ_TAC +Theorem LIST_REL_DECOMPOSE_LEFT: + !R. LIST_REL R x (a ++ b) <=> LIST_REL R (TAKE (LENGTH a) x) a /\ LIST_REL R (DROP (LENGTH a) x) b +Proof +strip_tac >> metis_tac[LIST_REL_DECOMPOSE_LEFT_recip, LIST_REL_DECOMPOSE_LEFT_imp] +QED + +Theorem HEAD_TAIL: + l <> [] ==> HD l :: TL l = l +Proof +Cases_on `l:'a list` >> rw[listTheory.TL, listTheory.HD] +QED + +Theorem HEAD_TAIL_DECOMPOSE_RIGHT: + x::a = b <=> b <> [] /\ x = HD b /\ a = TL b +Proof +rw[] >> EQ_TAC >-(Cases_on `b:'a list` >-(rw[]) >> rw[listTheory.TL, listTheory.HD, HEAD_TAIL]) >> -rw[HEAD_TAIL]); +rw[HEAD_TAIL] +QED -Theorem HEAD_TAIL_DECOMPOSE_LEFT -`b = x::a <=> b <> [] /\ x = HD b /\ a = TL b` -(rw[] >> EQ_TAC +Theorem HEAD_TAIL_DECOMPOSE_LEFT: + b = x::a <=> b <> [] /\ x = HD b /\ a = TL b +Proof +rw[] >> EQ_TAC >-(Cases_on `b:'a list` >-(rw[]) >> rw[listTheory.TL, listTheory.HD, HEAD_TAIL]) >> -rw[HEAD_TAIL]); +rw[HEAD_TAIL] +QED val _ = hide "abs"; @@ -323,13 +396,17 @@ fun eqtype_unicity_thm_tac x = MP_TAC assum end; -Theorem EQTYPE_UNICITY_R -`!abs x y1 y2. EqualityType abs ==> abs x y1 ==> (abs x y2 <=> y2 = y1)` -(rpt strip_tac >> FIRST_ASSUM eqtype_unicity_thm_tac >> metis_tac[]); +Theorem EQTYPE_UNICITY_R: + !abs x y1 y2. EqualityType abs ==> abs x y1 ==> (abs x y2 <=> y2 = y1) +Proof +rpt strip_tac >> FIRST_ASSUM eqtype_unicity_thm_tac >> metis_tac[] +QED -Theorem EQTYPE_UNICITY_L -`!abs x1 x2 y. EqualityType abs ==> abs x1 y ==> (abs x2 y <=> x2 = x1)` -(rpt strip_tac >> FIRST_ASSUM eqtype_unicity_thm_tac >> metis_tac[]); +Theorem EQTYPE_UNICITY_L: + !abs x1 x2 y. EqualityType abs ==> abs x1 y ==> (abs x2 y <=> x2 = x1) +Proof +rpt strip_tac >> FIRST_ASSUM eqtype_unicity_thm_tac >> metis_tac[] +QED (* Theorems to use LIST_REL A "as a" refinement invariant *) val InjectiveRel_def = Define ` @@ -338,9 +415,10 @@ InjectiveRel A = !x1 y1 x2 y2. A x1 y1 /\ A x2 y2 ==> (x1 = x2 <=> y1 = y2)`; val EQTYPE_INJECTIVEREL = Q.prove(`EqualityType A ==> InjectiveRel A`, rw[InjectiveRel_def, EqualityType_def]); -Theorem LIST_REL_INJECTIVE_REL -`!A. InjectiveRel A ==> InjectiveRel (LIST_REL A)` -(rpt strip_tac >> SIMP_TAC list_ss [InjectiveRel_def] >> Induct_on `x1` +Theorem LIST_REL_INJECTIVE_REL: + !A. InjectiveRel A ==> InjectiveRel (LIST_REL A) +Proof +rpt strip_tac >> SIMP_TAC list_ss [InjectiveRel_def] >> Induct_on `x1` >-( rpt strip_tac >> fs[LIST_REL_NIL] >> @@ -352,24 +430,32 @@ rpt strip_tac >> fs[LIST_REL_def] >> Cases_on `x2` >-(fs[LIST_REL_NIL]) >> Cases_on `y2` >-(fs[LIST_REL_NIL]) >> rw[] >> fs[LIST_REL_def] >> -EQ_TAC >> (rw[] >-(metis_tac[InjectiveRel_def]) >> metis_tac[])); - -Theorem LIST_REL_INJECTIVE_EQTYPE -`!A. EqualityType A ==> InjectiveRel (LIST_REL A)` -(metis_tac[EQTYPE_INJECTIVEREL, LIST_REL_INJECTIVE_REL]); - -Theorem LIST_REL_UNICITY_RIGHT -`EqualityType A ==> LIST_REL A a b ==> (LIST_REL A a b' <=> b' = b)` -(metis_tac[EQTYPE_INJECTIVEREL, LIST_REL_INJECTIVE_EQTYPE, InjectiveRel_def]); - -Theorem LIST_REL_UNICITY_LEFT -`EqualityType A ==> LIST_REL A a b ==> (LIST_REL A a' b <=> a' = a)` -(metis_tac[EQTYPE_INJECTIVEREL, LIST_REL_INJECTIVE_EQTYPE, InjectiveRel_def]); +EQ_TAC >> (rw[] >-(metis_tac[InjectiveRel_def]) >> metis_tac[]) +QED + +Theorem LIST_REL_INJECTIVE_EQTYPE: + !A. EqualityType A ==> InjectiveRel (LIST_REL A) +Proof +metis_tac[EQTYPE_INJECTIVEREL, LIST_REL_INJECTIVE_REL] +QED + +Theorem LIST_REL_UNICITY_RIGHT: + EqualityType A ==> LIST_REL A a b ==> (LIST_REL A a b' <=> b' = b) +Proof +metis_tac[EQTYPE_INJECTIVEREL, LIST_REL_INJECTIVE_EQTYPE, InjectiveRel_def] +QED + +Theorem LIST_REL_UNICITY_LEFT: + EqualityType A ==> LIST_REL A a b ==> (LIST_REL A a' b <=> a' = a) +Proof +metis_tac[EQTYPE_INJECTIVEREL, LIST_REL_INJECTIVE_EQTYPE, InjectiveRel_def] +QED (* EqualityType proofs *) -Theorem EqualityType_PAIR_TYPE -`EqualityType A ==> EqualityType B ==> EqualityType (PAIR_TYPE A B)` -(rw[EqualityType_def] +Theorem EqualityType_PAIR_TYPE: + EqualityType A ==> EqualityType B ==> EqualityType (PAIR_TYPE A B) +Proof +rw[EqualityType_def] >-( Cases_on `x1` >> fs[PAIR_TYPE_def, no_closures_def] >> @@ -378,7 +464,8 @@ Theorem EqualityType_PAIR_TYPE Cases_on `x1` >> Cases_on `x2` >> fs[PAIR_TYPE_def, types_match_def, semanticPrimitivesTheory.ctor_same_type_def] >> -metis_tac[]); +metis_tac[] +QED val LIST_TYPE_no_closure = Q.prove( `!A x xv. EqualityType A ==> LIST_TYPE A x xv ==> no_closures xv`, @@ -420,39 +507,48 @@ types_match_tac >-(metis_tac[EqualityType_def])>> last_assum IMP_RES_TAC); -Theorem EqualityType_LIST_TYPE -`EqualityType A ==> EqualityType (LIST_TYPE A)` -(DISCH_TAC >> rw[EqualityType_def] +Theorem EqualityType_LIST_TYPE: + EqualityType A ==> EqualityType (LIST_TYPE A) +Proof +DISCH_TAC >> rw[EqualityType_def] >-(IMP_RES_TAC LIST_TYPE_no_closure) >-(IMP_RES_TAC LIST_TYPE_inj) >> -IMP_RES_TAC LIST_TYPE_types_match); +IMP_RES_TAC LIST_TYPE_types_match +QED (* Some theorems for rewrite rules with the refinement invariants *) (* Need to write the expand and retract theorems for UNIT_TYPE by hand - otherwise the retract theorem might introduce a variable, for example *) -Theorem UNIT_TYPE_RETRACT -`!v. v = Conv NONE [] <=> UNIT_TYPE () v` -(rw[UNIT_TYPE_def]); - -Theorem UNIT_TYPE_EXPAND -`!u v. UNIT_TYPE u v <=> u = () /\ v = Conv NONE []` -(rw[UNIT_TYPE_def]); - -Theorem NUM_INT_EQ -`(!x y v. INT x v ==> (NUM y v <=> x = &y)) /\ +Theorem UNIT_TYPE_RETRACT: + !v. v = Conv NONE [] <=> UNIT_TYPE () v +Proof +rw[UNIT_TYPE_def] +QED + +Theorem UNIT_TYPE_EXPAND: + !u v. UNIT_TYPE u v <=> u = () /\ v = Conv NONE [] +Proof +rw[UNIT_TYPE_def] +QED + +Theorem NUM_INT_EQ: + (!x y v. INT x v ==> (NUM y v <=> x = &y)) /\ (!x y v. NUM y v ==> (INT x v <=> x = &y)) /\ (!x v w. INT (&x) v ==> (NUM x w <=> w = v)) /\ -(!x v w. NUM x v ==> (INT (&x) w <=> w = v))` -(fs[INT_def, NUM_def] >> metis_tac[]); +(!x v w. NUM x v ==> (INT (&x) w <=> w = v)) +Proof +fs[INT_def, NUM_def] >> metis_tac[] +QED (* Some rules used to simplify arithmetic equations (not happy with that: write a conversion instead? *) val NUM_EQ_lem = Q.prove(`!(a1:num) (a2:num) (b:num). b <= a1 ==> b <= a2 ==> (a1 = a2 <=> a1 - b = a2 - b)`, rw[]); -Theorem NUM_EQ_SIMP1 -`a1 + (NUMERAL n1)*b = a2 + (NUMERAL n2)*b <=> -a1 + (NUMERAL n1 - (MIN (NUMERAL n1) (NUMERAL n2)))*b = a2 + (NUMERAL n2 - (MIN (NUMERAL n1) (NUMERAL n2)))*b` - (rw[MIN_DEF] +Theorem NUM_EQ_SIMP1: + a1 + (NUMERAL n1)*b = a2 + (NUMERAL n2)*b <=> +a1 + (NUMERAL n1 - (MIN (NUMERAL n1) (NUMERAL n2)))*b = a2 + (NUMERAL n2 - (MIN (NUMERAL n1) (NUMERAL n2)))*b +Proof + rw[MIN_DEF] >-( `b*NUMERAL n1 <= a1 + b*NUMERAL n1` by rw[] >> `b*NUMERAL n1 <= a2 + b*NUMERAL n2` by ( @@ -473,65 +569,88 @@ a1 + (NUMERAL n1 - (MIN (NUMERAL n1) (NUMERAL n2)))*b = a2 + (NUMERAL n2 - (MIN `b*NUMERAL n2 <= a1 + b*NUMERAL n1` by rw[] >> `b*NUMERAL n2 <= a2 + b*NUMERAL n2` by rw[] >> qspecl_then[`a1 + b * NUMERAL n1`, `a2 + b * NUMERAL n2`, `b * NUMERAL n2`]assume_tac NUM_EQ_lem >> - POP_ASSUM (fn x => rw[x])); - -Theorem NUM_EQ_SIMP2 -`(NUMERAL n1)*b + a1 = (NUMERAL n2)*b + a2 <=> -(NUMERAL n1 - (MIN (NUMERAL n1) (NUMERAL n2)))*b + a1 = (NUMERAL n2 - (MIN (NUMERAL n1) (NUMERAL n2)))*b + a2` -(rw[CONV_RULE (SIMP_CONV arith_ss []) NUM_EQ_SIMP1]); - -Theorem NUM_EQ_SIMP3 -`a1 + (NUMERAL n1)*b = (NUMERAL n2)*b + a2 <=> -a1 + (NUMERAL n1 - (MIN (NUMERAL n1) (NUMERAL n2)))*b = (NUMERAL n2 - (MIN (NUMERAL n1) (NUMERAL n2)))*b + a2` -(rw[CONV_RULE (SIMP_CONV arith_ss []) NUM_EQ_SIMP1]); - -Theorem NUM_EQ_SIMP4 -`(NUMERAL n1)*b + a1 = a2 + (NUMERAL n2)*b <=> -(NUMERAL n1 - (MIN (NUMERAL n1) (NUMERAL n2)))*b + a1 = (NUMERAL n2 - (MIN (NUMERAL n1) (NUMERAL n2)))*b + a2` -(rw[CONV_RULE (SIMP_CONV arith_ss []) NUM_EQ_SIMP1]); - -Theorem NUM_EQ_SIMP5 -`a1 + b = a2 + (NUMERAL n2)*b <=> -a1 + (1 - (MIN 1 (NUMERAL n2)))*b = a2 + (NUMERAL n2 - (MIN 1 (NUMERAL n2)))*b` -(`a1 + b = a1 + 1*b` by rw[] >> + POP_ASSUM (fn x => rw[x]) +QED + +Theorem NUM_EQ_SIMP2: + (NUMERAL n1)*b + a1 = (NUMERAL n2)*b + a2 <=> +(NUMERAL n1 - (MIN (NUMERAL n1) (NUMERAL n2)))*b + a1 = (NUMERAL n2 - (MIN (NUMERAL n1) (NUMERAL n2)))*b + a2 +Proof +rw[CONV_RULE (SIMP_CONV arith_ss []) NUM_EQ_SIMP1] +QED + +Theorem NUM_EQ_SIMP3: + a1 + (NUMERAL n1)*b = (NUMERAL n2)*b + a2 <=> +a1 + (NUMERAL n1 - (MIN (NUMERAL n1) (NUMERAL n2)))*b = (NUMERAL n2 - (MIN (NUMERAL n1) (NUMERAL n2)))*b + a2 +Proof +rw[CONV_RULE (SIMP_CONV arith_ss []) NUM_EQ_SIMP1] +QED + +Theorem NUM_EQ_SIMP4: + (NUMERAL n1)*b + a1 = a2 + (NUMERAL n2)*b <=> +(NUMERAL n1 - (MIN (NUMERAL n1) (NUMERAL n2)))*b + a1 = (NUMERAL n2 - (MIN (NUMERAL n1) (NUMERAL n2)))*b + a2 +Proof +rw[CONV_RULE (SIMP_CONV arith_ss []) NUM_EQ_SIMP1] +QED + +Theorem NUM_EQ_SIMP5: + a1 + b = a2 + (NUMERAL n2)*b <=> +a1 + (1 - (MIN 1 (NUMERAL n2)))*b = a2 + (NUMERAL n2 - (MIN 1 (NUMERAL n2)))*b +Proof +`a1 + b = a1 + 1*b` by rw[] >> POP_ASSUM (fn x => PURE_REWRITE_TAC [x]) >> -metis_tac[NUM_EQ_SIMP1]); - -Theorem NUM_EQ_SIMP6 -`a1 + (NUMERAL n1)*b = a2 + b <=> -a1 + (NUMERAL n1 - (MIN 1 (NUMERAL n1)))*b = a2 + (1 - (MIN 1 (NUMERAL n1)))*b` -(`a2 + b = a2 + 1*b` by rw[] >> +metis_tac[NUM_EQ_SIMP1] +QED + +Theorem NUM_EQ_SIMP6: + a1 + (NUMERAL n1)*b = a2 + b <=> +a1 + (NUMERAL n1 - (MIN 1 (NUMERAL n1)))*b = a2 + (1 - (MIN 1 (NUMERAL n1)))*b +Proof +`a2 + b = a2 + 1*b` by rw[] >> POP_ASSUM (fn x => PURE_REWRITE_TAC [x]) >> -metis_tac[NUM_EQ_SIMP1]); - -Theorem NUM_EQ_SIMP7 -`b + a1 = (NUMERAL n2)*b + a2 <=> -(1 - (MIN 1 (NUMERAL n2)))*b + a1 = (NUMERAL n2 - (MIN 1 (NUMERAL n2)))*b + a2` -(rw[CONV_RULE (SIMP_CONV arith_ss []) NUM_EQ_SIMP5]); - -Theorem NUM_EQ_SIMP8 -`(NUMERAL n1)*b + a1 = b + a2 <=> -(NUMERAL n1 - (MIN 1 (NUMERAL n1)))*b + a1 = (1 - (MIN 1 (NUMERAL n1)))*b + a2` -(rw[CONV_RULE (SIMP_CONV arith_ss []) NUM_EQ_SIMP6]); - -Theorem NUM_EQ_SIMP9 -`a1 + b = (NUMERAL n2)*b + a2 <=> -a1 + (1 - (MIN 1 (NUMERAL n2)))*b = (NUMERAL n2 - (MIN 1 (NUMERAL n2)))*b + a2` -(rw[CONV_RULE (SIMP_CONV arith_ss []) NUM_EQ_SIMP5]); - -Theorem NUM_EQ_SIMP10 -`b + a1 = a2 + (NUMERAL n2)*b <=> -(1 - (MIN 1 (NUMERAL n2)))*b + a1 = a2 + (NUMERAL n2 - (MIN 1 (NUMERAL n2)))*b` -(rw[CONV_RULE (SIMP_CONV arith_ss []) NUM_EQ_SIMP5]); - -Theorem NUM_EQ_SIMP11 -`a1 + (NUMERAL n1)*b = b + a2 <=> -a1 + (NUMERAL n1 - (MIN 1 (NUMERAL n1)))*b = (1 - (MIN 1 (NUMERAL n1)))*b + a2` -(rw[CONV_RULE (SIMP_CONV arith_ss []) NUM_EQ_SIMP6]); - -Theorem NUM_EQ_SIMP12 -`(NUMERAL n1)*b + a1 = a2 + b <=> -(NUMERAL n1 - (MIN 1 (NUMERAL n1)))*b + a1 = a2 + (1 - (MIN 1 (NUMERAL n1)))*b` -(rw[CONV_RULE (SIMP_CONV arith_ss []) NUM_EQ_SIMP6]); +metis_tac[NUM_EQ_SIMP1] +QED + +Theorem NUM_EQ_SIMP7: + b + a1 = (NUMERAL n2)*b + a2 <=> +(1 - (MIN 1 (NUMERAL n2)))*b + a1 = (NUMERAL n2 - (MIN 1 (NUMERAL n2)))*b + a2 +Proof +rw[CONV_RULE (SIMP_CONV arith_ss []) NUM_EQ_SIMP5] +QED + +Theorem NUM_EQ_SIMP8: + (NUMERAL n1)*b + a1 = b + a2 <=> +(NUMERAL n1 - (MIN 1 (NUMERAL n1)))*b + a1 = (1 - (MIN 1 (NUMERAL n1)))*b + a2 +Proof +rw[CONV_RULE (SIMP_CONV arith_ss []) NUM_EQ_SIMP6] +QED + +Theorem NUM_EQ_SIMP9: + a1 + b = (NUMERAL n2)*b + a2 <=> +a1 + (1 - (MIN 1 (NUMERAL n2)))*b = (NUMERAL n2 - (MIN 1 (NUMERAL n2)))*b + a2 +Proof +rw[CONV_RULE (SIMP_CONV arith_ss []) NUM_EQ_SIMP5] +QED + +Theorem NUM_EQ_SIMP10: + b + a1 = a2 + (NUMERAL n2)*b <=> +(1 - (MIN 1 (NUMERAL n2)))*b + a1 = a2 + (NUMERAL n2 - (MIN 1 (NUMERAL n2)))*b +Proof +rw[CONV_RULE (SIMP_CONV arith_ss []) NUM_EQ_SIMP5] +QED + +Theorem NUM_EQ_SIMP11: + a1 + (NUMERAL n1)*b = b + a2 <=> +a1 + (NUMERAL n1 - (MIN 1 (NUMERAL n1)))*b = (1 - (MIN 1 (NUMERAL n1)))*b + a2 +Proof +rw[CONV_RULE (SIMP_CONV arith_ss []) NUM_EQ_SIMP6] +QED + +Theorem NUM_EQ_SIMP12: + (NUMERAL n1)*b + a1 = a2 + b <=> +(NUMERAL n1 - (MIN 1 (NUMERAL n1)))*b + a1 = a2 + (1 - (MIN 1 (NUMERAL n1)))*b +Proof +rw[CONV_RULE (SIMP_CONV arith_ss []) NUM_EQ_SIMP6] +QED val _ = export_theory(); diff --git a/characteristic/cfMainScript.sml b/characteristic/cfMainScript.sml index 026753f4f1..c571e6d4b7 100644 --- a/characteristic/cfMainScript.sml +++ b/characteristic/cfMainScript.sml @@ -21,15 +21,16 @@ fun mk_main_call s = val fname = mk_var("fname",``:string``); val main_call = mk_main_call fname; -Theorem call_main_thm1 -`Decls env1 st1 prog env2 st2 ==> (* get this from the current ML prog state *) +Theorem call_main_thm1: + Decls env1 st1 prog env2 st2 ==> (* get this from the current ML prog state *) lookup_var fname env2 = SOME fv ==> (* get this by EVAL *) app p fv [Conv NONE []] P (POSTv uv. &UNIT_TYPE () uv * Q) ==> (* this should be the CF spec you prove for the "main" function *) SPLIT (st2heap p st2) (h1,h2) /\ P h1 ==> (* this might need simplification, but some of it may need to stay on the final theorem *) ∃st3. Decls env1 st1 (SNOC ^main_call prog) env2 st3 /\ - (?h3 h4. SPLIT3 (st2heap p st3) (h3,h2,h4) /\ Q h3)` - (rw[SNOC_APPEND,ml_progTheory.Decls_APPEND,PULL_EXISTS] + (?h3 h4. SPLIT3 (st2heap p st3) (h3,h2,h4) /\ Q h3) +Proof + rw[SNOC_APPEND,ml_progTheory.Decls_APPEND,PULL_EXISTS] \\ simp[ml_progTheory.Decls_def] \\ fs [terminationTheory.evaluate_decs_def,PULL_EXISTS, EVAL ``(pat_bindings (Pcon NONE []) [])``,pair_case_eq,result_case_eq] @@ -61,7 +62,8 @@ Theorem call_main_thm1 \\ asm_exists_tac \\ fs [terminationTheory.pmatch_def] \\ fs [ml_progTheory.merge_env_def] \\ fs [cfStoreTheory.st2heap_clock] - \\ asm_exists_tac \\ fs []); + \\ asm_exists_tac \\ fs [] +QED val prog_to_semantics_prog = Q.prove( `!init_env inp prog st c r env2 s2. @@ -132,18 +134,22 @@ val FFI_part_hprop_def = Define` FFI_part_hprop Q = (!h. Q h ==> (?s u ns us. FFI_part s u ns us IN h))`; -Theorem FFI_part_hprop_STAR - `FFI_part_hprop P \/ FFI_part_hprop Q ==> FFI_part_hprop (P * Q)` - (rw[FFI_part_hprop_def] +Theorem FFI_part_hprop_STAR: + FFI_part_hprop P \/ FFI_part_hprop Q ==> FFI_part_hprop (P * Q) +Proof + rw[FFI_part_hprop_def] \\ fs[set_sepTheory.STAR_def,SPLIT_def] \\ rw[] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem FFI_part_hprop_SEP_EXISTS - `(∀x. FFI_part_hprop (P x)) ⇒ FFI_part_hprop (SEP_EXISTS x. P x)` - (rw[FFI_part_hprop_def,SEP_EXISTS_THM] \\ res_tac); +Theorem FFI_part_hprop_SEP_EXISTS: + (∀x. FFI_part_hprop (P x)) ⇒ FFI_part_hprop (SEP_EXISTS x. P x) +Proof + rw[FFI_part_hprop_def,SEP_EXISTS_THM] \\ res_tac +QED -Theorem call_main_thm2 - `Decls env1 st1 prog env2 st2 ==> +Theorem call_main_thm2: + Decls env1 st1 prog env2 st2 ==> lookup_var fname env2 = SOME fv ==> app (proj1, proj2) fv [Conv NONE []] P (POSTv uv. &UNIT_TYPE () uv * Q) ==> FFI_part_hprop Q ==> @@ -152,8 +158,9 @@ Theorem call_main_thm2 ∃st3. semantics_prog st1 env1 (SNOC ^main_call prog) (Terminate Success st3.ffi.io_events) /\ (?h3 h4. SPLIT3 (st2heap (proj1, proj2) st3) (h3,h2,h4) /\ Q h3) /\ - call_FFI_rel^* st1.ffi st3.ffi` - (rw[] + call_FFI_rel^* st1.ffi st3.ffi +Proof + rw[] \\ qho_match_abbrev_tac`?st3. A st3 /\ B st3 /\ C st1 st3` \\ `?st3. Decls env1 st1 (SNOC ^main_call prog) env2 st3 /\ B st3 /\ C st1 st3` @@ -166,10 +173,11 @@ Theorem call_main_thm2 \\ drule (GEN_ALL call_main_thm1) \\ rpt (disch_then drule) \\ simp[] \\ strip_tac - \\ asm_exists_tac \\ simp[]); + \\ asm_exists_tac \\ simp[] +QED -Theorem call_main_thm2_ffidiv - `Decls env1 st1 prog env2 st2 ==> +Theorem call_main_thm2_ffidiv: + Decls env1 st1 prog env2 st2 ==> lookup_var fname env2 = SOME fv ==> app (proj1, proj2) fv [Conv NONE []] P (POSTf n. λ c b. Q n c b) ==> SPLIT (st2heap (proj1, proj2) st2) (h1,h2) /\ P h1 @@ -178,8 +186,9 @@ Theorem call_main_thm2_ffidiv semantics_prog st1 env1 (SNOC ^main_call prog) (Terminate (FFI_outcome(Final_event n c b FFI_diverged)) st3.ffi.io_events) /\ (?h3 h4. SPLIT3 (st2heap (proj1, proj2) st3) (h3,h2,h4) /\ Q n c b h3) /\ - call_FFI_rel^* st1.ffi st3.ffi` - (rw[] + call_FFI_rel^* st1.ffi st3.ffi +Proof + rw[] \\ qho_match_abbrev_tac`?st3 n c b. A st3 n c b /\ B st3 n c b /\ C st1 st3` \\ `?st3 st4 n c b. Decls env1 st1 prog env2 st3 /\ semantics_prog st3 (merge_env env2 env1) [(^main_call)] @@ -222,6 +231,7 @@ Theorem call_main_thm2_ffidiv \\ fs[evaluate_ck_def] \\ imp_res_tac evaluate_call_FFI_rel_imp \\ fs[] \\ metis_tac[RTC_RTC]) - >- (fs[cond_def])); + >- (fs[cond_def]) +QED val _ = export_theory() diff --git a/characteristic/cfNormaliseScript.sml b/characteristic/cfNormaliseScript.sml index fb0039cc1b..9702785203 100644 --- a/characteristic/cfNormaliseScript.sml +++ b/characteristic/cfNormaliseScript.sml @@ -26,11 +26,12 @@ val exp2v_def = Define ` exp2v env (Var name) = nsLookup env.v name /\ exp2v _ _ = NONE` -Theorem exp2v_evaluate - `!e env st v. exp2v env e = SOME v ==> - evaluate st env [e] = (st, Rval [v])` - (Induct \\ fs [exp2v_def, terminationTheory.evaluate_def] -); +Theorem exp2v_evaluate: + !e env st v. exp2v env e = SOME v ==> + evaluate st env [e] = (st, Rval [v]) +Proof + Induct \\ fs [exp2v_def, terminationTheory.evaluate_def] +QED val exp2v_list_def = Define ` exp2v_list env [] = SOME [] /\ @@ -42,10 +43,11 @@ val exp2v_list_def = Define ` | NONE => NONE | SOME vs => SOME (v :: vs)))`; -Theorem exp2v_list_evaluate - `!l lv env st. exp2v_list env l = SOME lv ==> - evaluate st env l = (st, Rval lv)` - (Induct +Theorem exp2v_list_evaluate: + !l lv env st. exp2v_list env l = SOME lv ==> + evaluate st env l = (st, Rval lv) +Proof + Induct THEN1 (fs [exp2v_list_def, terminationTheory.evaluate_def]) THEN1 ( rpt strip_tac \\ fs [exp2v_list_def] \\ @@ -53,15 +55,15 @@ Theorem exp2v_list_evaluate first_assum progress \\ progress exp2v_evaluate \\ Cases_on `l` \\ fs [terminationTheory.evaluate_def] ) -); +QED -Theorem evaluate_rcons - `!env st st' st'' l x lv v. +Theorem evaluate_rcons: + !env st st' st'' l x lv v. evaluate st env l = (st', Rval lv) /\ evaluate st' env [x] = (st'', Rval [v]) ==> - evaluate st env (l ++ [x]) = (st'', Rval (lv ++ [v]))` - - (Induct_on `l` + evaluate st env (l ++ [x]) = (st'', Rval (lv ++ [v])) +Proof + Induct_on `l` THEN1 ( rpt strip_tac \\ fs [terminationTheory.evaluate_def] ) @@ -82,34 +84,37 @@ Theorem evaluate_rcons simp [terminationTheory.evaluate_def] ) ) -); +QED -Theorem exp2v_list_REVERSE - `!l (st: 'ffi semanticPrimitives$state) lv env. exp2v_list env l = SOME lv ==> - evaluate st env (REVERSE l) = (st, Rval (REVERSE lv))` - (Induct \\ rpt gen_tac \\ disch_then (assume_tac o GSYM) \\ +Theorem exp2v_list_REVERSE: + !l (st: 'ffi semanticPrimitives$state) lv env. exp2v_list env l = SOME lv ==> + evaluate st env (REVERSE l) = (st, Rval (REVERSE lv)) +Proof + Induct \\ rpt gen_tac \\ disch_then (assume_tac o GSYM) \\ fs [exp2v_list_def, terminationTheory.evaluate_def] \\ every_case_tac \\ fs [] \\ rw [] \\ irule evaluate_rcons \\ metis_tac [exp2v_evaluate] -); +QED -Theorem exp2v_list_rcons - `!xs x l env. +Theorem exp2v_list_rcons: + !xs x l env. exp2v_list env (xs ++ [x]) = SOME l ==> ?xvs xv. l = xvs ++ [xv] /\ exp2v_list env xs = SOME xvs /\ - exp2v env x = SOME xv` - (Induct_on `xs` \\ fs [exp2v_list_def] \\ rpt strip_tac \\ + exp2v env x = SOME xv +Proof + Induct_on `xs` \\ fs [exp2v_list_def] \\ rpt strip_tac \\ every_case_tac \\ fs [] \\ first_assum progress \\ fs [] \\ rw [] -); +QED -Theorem exp2v_list_LENGTH - `!l lv env. exp2v_list env l = SOME lv ==> LENGTH l = LENGTH lv` - (Induct_on `l` \\ fs [exp2v_list_def] \\ rpt strip_tac \\ +Theorem exp2v_list_LENGTH: + !l lv env. exp2v_list env l = SOME lv ==> LENGTH l = LENGTH lv +Proof + Induct_on `l` \\ fs [exp2v_list_def] \\ rpt strip_tac \\ every_case_tac \\ res_tac \\ fs [] \\ rw [] -); +QED (* [dest_opapp]: destruct an n-ary application. *) val dest_opapp_def = Define ` @@ -451,12 +456,14 @@ val norm_state_rel_def = Define ` s1.defined_mods = s2.defined_mods` (* -Theorem full_normalise_correct - `env_rel (free_in e) env1 env2 /\ norm_state_rel s1 s2 /\ +Theorem full_normalise_correct: + env_rel (free_in e) env1 env2 /\ norm_state_rel s1 s2 /\ evaluate ck env1 s1 e1 (rs1,res1) /\ norm_exp_rel e1 e2 ==> ?rs2 res2. evaluate ck env2 s2 e2 (rs2,res2) /\ - norm_state_rel rs1 rs2 /\ norm_res_rel res1 res2` - (... ); TODO + norm_state_rel rs1 rs2 /\ norm_res_rel res1 res2 +Proof + ... +QED TODO *) val full_normalise_exp_def = Define ` diff --git a/characteristic/cfScript.sml b/characteristic/cfScript.sml index 020df6ba68..6959fff2f5 100644 --- a/characteristic/cfScript.sml +++ b/characteristic/cfScript.sml @@ -112,65 +112,71 @@ val letrec_pull_params_def = Define ` | SOME body' => (f, n::Fun_params body, body')) :: (letrec_pull_params funs)` -Theorem letrec_pull_params_names - `!funs P. +Theorem letrec_pull_params_names: + !funs P. MAP (\ (f,_,_). P f) (letrec_pull_params funs) = - MAP (\ (f,_,_). P f) funs` - (Induct \\ fs [letrec_pull_params_def] \\ rpt strip_tac \\ + MAP (\ (f,_,_). P f) funs +Proof + Induct \\ fs [letrec_pull_params_def] \\ rpt strip_tac \\ rename1 `ftuple::funs` \\ PairCases_on `ftuple` \\ fs [letrec_pull_params_def] \\ every_case_tac \\ fs [] -) +QED -Theorem letrec_pull_params_LENGTH - `!funs. LENGTH (letrec_pull_params funs) = LENGTH funs` - (Induct \\ fs [letrec_pull_params_def] \\ rpt strip_tac \\ +Theorem letrec_pull_params_LENGTH: + !funs. LENGTH (letrec_pull_params funs) = LENGTH funs +Proof + Induct \\ fs [letrec_pull_params_def] \\ rpt strip_tac \\ rename1 `ftuple::funs` \\ PairCases_on `ftuple` \\ fs [letrec_pull_params_def] \\ every_case_tac \\ fs [] -) +QED -Theorem letrec_pull_params_append - `!l l'. +Theorem letrec_pull_params_append: + !l l'. letrec_pull_params (l ++ l') = - letrec_pull_params l ++ letrec_pull_params l'` - (Induct \\ rpt strip_tac \\ fs [letrec_pull_params_def] \\ + letrec_pull_params l ++ letrec_pull_params l' +Proof + Induct \\ rpt strip_tac \\ fs [letrec_pull_params_def] \\ rename1 `ftuple::_` \\ PairCases_on `ftuple` \\ rename1 `(f,n,body)` \\ fs [letrec_pull_params_def] -) +QED -Theorem letrec_pull_params_cancel - `!funs. +Theorem letrec_pull_params_cancel: + !funs. MAP (\ (f,ns,body). (f, HD ns, naryFun (TL ns) body)) (letrec_pull_params funs) = - funs` - (Induct \\ rpt strip_tac \\ fs [letrec_pull_params_def] \\ + funs +Proof + Induct \\ rpt strip_tac \\ fs [letrec_pull_params_def] \\ rename1 `ftuple::_` \\ PairCases_on `ftuple` \\ rename1 `(f,n,body)` \\ fs [letrec_pull_params_def] \\ every_case_tac \\ fs [naryFun_def] \\ fs [Fun_params_Fun_body_repack] -) +QED -Theorem letrec_pull_params_nonnil_params - `!funs f ns body. +Theorem letrec_pull_params_nonnil_params: + !funs f ns body. MEM (f,ns,body) (letrec_pull_params funs) ==> - ns <> []` - (Induct \\ rpt strip_tac \\ fs [letrec_pull_params_def, MEM] \\ + ns <> [] +Proof + Induct \\ rpt strip_tac \\ fs [letrec_pull_params_def, MEM] \\ rename1 `ftuple::funs` \\ PairCases_on `ftuple` \\ rename1 `(f',n',body')::funs` \\ fs [letrec_pull_params_def] \\ every_case_tac \\ fs [naryFun_def] \\ metis_tac [] -) +QED -Theorem find_recfun_letrec_pull_params - `!funs f n ns body. +Theorem find_recfun_letrec_pull_params: + !funs f n ns body. find_recfun f (letrec_pull_params funs) = SOME (n::ns, body) ==> - find_recfun f funs = SOME (n, naryFun ns body)` - (Induct \\ fs [letrec_pull_params_def] + find_recfun f funs = SOME (n, naryFun ns body) +Proof + Induct \\ fs [letrec_pull_params_def] THEN1 (fs [Once find_recfun_def]) \\ rpt strip_tac \\ rename1 `ftuple::funs` \\ PairCases_on `ftuple` \\ rename1 `(f',n',body')` \\ fs [letrec_pull_params_def] \\ every_case_tac \\ pop_assum mp_tac \\ once_rewrite_tac [find_recfun_def] \\ fs [] \\ every_case_tac \\ rw [] \\ fs [naryFun_def, Fun_params_Fun_body_repack] -) +QED (*------------------------------------------------------------------*) (* The semantic counterpart of n-ary functions: n-ary closures @@ -201,12 +207,13 @@ val evaluate_to_heap_with_clock = prove( ``evaluate_to_heap (st with clock := ck) = evaluate_to_heap st``, fs [evaluate_to_heap_def,FUN_EQ_THM,evaluate_ck_def]); -Theorem app_one_naryClosure - `!env n ns x xs body H Q. +Theorem app_one_naryClosure: + !env n ns x xs body H Q. ns <> [] ==> xs <> [] ==> app (p:'ffi ffi_proj) (naryClosure env (n::ns) body) (x::xs) H Q ==> - app (p:'ffi ffi_proj) (naryClosure (env with v := nsBind n x env.v) ns body) xs H Q` - (rpt strip_tac \\ Cases_on `ns` \\ Cases_on `xs` \\ fs [] \\ + app (p:'ffi ffi_proj) (naryClosure (env with v := nsBind n x env.v) ns body) xs H Q +Proof + rpt strip_tac \\ Cases_on `ns` \\ Cases_on `xs` \\ fs [] \\ rename1 `app _ (naryClosure _ (n::n'::ns) _) (x::x'::xs) _ _` \\ Cases_on `xs` THENL [all_tac, rename1 `_::_::x''::xs`] \\ fs [app_def, naryClosure_def, naryFun_def] \\ @@ -227,13 +234,15 @@ Theorem app_one_naryClosure rename1 `SPLIT3 heap1 (h_f', h_k UNION h_g, h_g')` \\ `SPLIT3 heap1 (h_f', h_k, h_g UNION h_g')` by SPLIT_TAC \\ - asm_exists_tac \\ fs []); + asm_exists_tac \\ fs [] +QED -Theorem curried_naryClosure - `!env len ns body. +Theorem curried_naryClosure: + !env len ns body. ns <> [] ==> len = LENGTH ns ==> - curried (p:'ffi ffi_proj) len (naryClosure env ns body)` - (Induct_on `ns` \\ fs [naryClosure_def, naryFun_def] \\ Cases_on `ns` + curried (p:'ffi ffi_proj) len (naryClosure env ns body) +Proof + Induct_on `ns` \\ fs [naryClosure_def, naryFun_def] \\ Cases_on `ns` THEN1 (once_rewrite_tac [ONE] \\ fs [Once curried_def]) \\ rpt strip_tac \\ fs [naryClosure_def, naryFun_def] \\ rw [Once curried_def] \\ fs [app_basic_def] \\ rpt strip_tac \\ @@ -249,7 +258,8 @@ Theorem curried_naryClosure fs [LENGTH_CONS, PULL_EXISTS] \\ qexists_tac `st.clock` \\ fs [with_clock_self] \\ fs [GSYM naryFun_def, GSYM naryClosure_def] \\ rpt strip_tac \\ - irule app_one_naryClosure \\ fs []); + irule app_one_naryClosure \\ fs [] +QED (* [naryRecclosure] *) val naryRecclosure_def = Define ` @@ -260,30 +270,32 @@ val naryRecclosure_def = Define ` (* Properties of [naryRecclosure] *) -Theorem do_opapp_naryRecclosure - `!funs f n ns body x env env' exp. +Theorem do_opapp_naryRecclosure: + !funs f n ns body x env env' exp. find_recfun f (letrec_pull_params funs) = SOME (n::ns, body) ==> (do_opapp [naryRecclosure env (letrec_pull_params funs) f; x] = SOME (env', exp) <=> (ALL_DISTINCT (MAP (\ (f,_,_). f) funs) /\ env' = (env with v := nsBind n x (build_rec_env funs env env.v)) /\ - exp = naryFun ns body))` - (rpt strip_tac \\ progress find_recfun_letrec_pull_params \\ + exp = naryFun ns body)) +Proof + rpt strip_tac \\ progress find_recfun_letrec_pull_params \\ fs [naryRecclosure_def, do_opapp_def, letrec_pull_params_cancel] \\ - eq_tac \\ every_case_tac \\ fs []); + eq_tac \\ every_case_tac \\ fs [] +QED -Theorem app_one_naryRecclosure - `!funs f n ns body x xs env H Q. +Theorem app_one_naryRecclosure: + !funs f n ns body x xs env H Q. ns <> [] ==> xs <> [] ==> find_recfun f (letrec_pull_params funs) = SOME (n::ns, body) ==> (app (p:'ffi ffi_proj) (naryRecclosure env (letrec_pull_params funs) f) (x::xs) H Q ==> app (p:'ffi ffi_proj) (naryClosure (env with v := nsBind n x (build_rec_env funs env env.v)) - ns body) xs H Q)` - - (rpt strip_tac \\ Cases_on `ns` \\ Cases_on `xs` \\ fs [] \\ + ns body) xs H Q) +Proof + rpt strip_tac \\ Cases_on `ns` \\ Cases_on `xs` \\ fs [] \\ rename1 `SOME (n::n'::ns, _)` \\ rename1 `app _ _ (x::x'::xs)` \\ Cases_on `xs` THENL [all_tac, rename1 `_::_::x''::xs`] \\ fs [app_def, naryClosure_def, naryFun_def] \\ @@ -302,16 +314,17 @@ Theorem app_one_naryRecclosure rename1 `SPLIT3 heap1 (h_f', h_k UNION h_g, h_g')` \\ `SPLIT3 heap1 (h_f', h_k, h_g UNION h_g')` by SPLIT_TAC \\ - asm_exists_tac \\ fs []); + asm_exists_tac \\ fs [] +QED -Theorem curried_naryRecclosure - `!env funs f len ns body. +Theorem curried_naryRecclosure: + !env funs f len ns body. ALL_DISTINCT (MAP (\ (f,_,_). f) funs) ==> find_recfun f (letrec_pull_params funs) = SOME (ns, body) ==> len = LENGTH ns ==> - curried (p:'ffi ffi_proj) len (naryRecclosure env (letrec_pull_params funs) f)` - - (rpt strip_tac \\ Cases_on `ns` \\ fs [] + curried (p:'ffi ffi_proj) len (naryRecclosure env (letrec_pull_params funs) f) +Proof + rpt strip_tac \\ Cases_on `ns` \\ fs [] THEN1 ( fs [curried_def, semanticPrimitivesPropsTheory.find_recfun_ALOOKUP] \\ progress ALOOKUP_MEM \\ progress letrec_pull_params_nonnil_params \\ fs [] @@ -329,16 +342,19 @@ Theorem curried_naryRecclosure THEN1 (irule curried_naryClosure \\ fs []) THEN1 (irule app_one_naryRecclosure \\ fs [LENGTH_CONS] \\ metis_tac []) \\ fs [naryFun_def, naryClosure_def] \\ - fs [evaluate_ck_def, terminationTheory.evaluate_def, with_clock_self]); + fs [evaluate_ck_def, terminationTheory.evaluate_def, with_clock_self] +QED -Theorem letrec_pull_params_repack - `!funs f env. +Theorem letrec_pull_params_repack: + !funs f env. naryRecclosure env (letrec_pull_params funs) f = - Recclosure env funs f` - (Induct \\ rpt strip_tac \\ fs [naryRecclosure_def, letrec_pull_params_def] \\ + Recclosure env funs f +Proof + Induct \\ rpt strip_tac \\ fs [naryRecclosure_def, letrec_pull_params_def] \\ rename1 `ftuple::_` \\ PairCases_on `ftuple` \\ rename1 `(f,n,body)` \\ fs [letrec_pull_params_def] \\ every_case_tac \\ fs [naryFun_def] \\ - fs [Fun_params_Fun_body_repack]); + fs [Fun_params_Fun_body_repack] +QED (** Extending environments *) @@ -352,23 +368,26 @@ val extend_env_v_def = Define ` val extend_env_def = Define ` extend_env ns xvs (env:'v sem_env) = (env with v := extend_env_v ns xvs env.v)`; -Theorem extend_env_v_rcons - `!ns xvs n xv env_v. +Theorem extend_env_v_rcons: + !ns xvs n xv env_v. LENGTH ns = LENGTH xvs ==> extend_env_v (ns ++ [n]) (xvs ++ [xv]) env_v = - nsBind n xv (extend_env_v ns xvs env_v)` - (Induct \\ rpt strip_tac \\ first_assum (assume_tac o GSYM) \\ + nsBind n xv (extend_env_v ns xvs env_v) +Proof + Induct \\ rpt strip_tac \\ first_assum (assume_tac o GSYM) \\ fs [LENGTH_NIL, LENGTH_CONS, extend_env_v_def] -); +QED -Theorem extend_env_v_zip - `!ns xvs env_v. +Theorem extend_env_v_zip: + !ns xvs env_v. LENGTH ns = LENGTH xvs ==> - extend_env_v ns xvs env_v = nsAppend (alist_to_ns (ZIP (REVERSE ns, REVERSE xvs))) env_v` - (Induct \\ rpt strip_tac \\ first_assum (assume_tac o GSYM) \\ + extend_env_v ns xvs env_v = nsAppend (alist_to_ns (ZIP (REVERSE ns, REVERSE xvs))) env_v +Proof + Induct \\ rpt strip_tac \\ first_assum (assume_tac o GSYM) \\ fs [LENGTH_NIL, LENGTH_CONS, extend_env_v_def, GSYM ZIP_APPEND] \\ FULL_SIMP_TAC std_ss [Once (GSYM namespacePropsTheory.nsAppend_alist_to_ns),Once (GSYM (namespacePropsTheory.nsAppend_assoc))] \\ - Cases_on`env_v`>> EVAL_TAC); + Cases_on`env_v`>> EVAL_TAC +QED (* [build_rec_env_aux] *) val build_rec_env_aux_def = Define ` @@ -391,16 +410,17 @@ val build_rec_env_zip_aux = Q.prove ( fs [letrec_pull_params_repack] ); -Theorem build_rec_env_zip - `!funs env env_v. +Theorem build_rec_env_zip: + !funs env env_v. nsAppend (alist_to_ns (ZIP (MAP (\ (f,_,_). f) funs, MAP (\ (f,_,_). naryRecclosure env (letrec_pull_params funs) f) funs))) env_v = - build_rec_env funs env env_v` - (fs [build_rec_env_def, build_rec_env_zip_aux] -); + build_rec_env funs env env_v +Proof + fs [build_rec_env_def, build_rec_env_zip_aux] +QED (* [extend_env_rec] *) val extend_env_v_rec_def = Define ` @@ -411,15 +431,16 @@ val extend_env_rec_def = Define ` extend_env_rec rec_ns rec_xvs ns xvs (env:'v sem_env) = env with v := extend_env_v_rec rec_ns rec_xvs ns xvs env.v`; -Theorem extend_env_rec_build_rec_env - `!funs env env_v. +Theorem extend_env_rec_build_rec_env: + !funs env env_v. extend_env_v_rec (MAP (\ (f,_,_). f) funs) (MAP (\ (f,_,_). naryRecclosure env (letrec_pull_params funs) f) funs) [] [] env_v = - build_rec_env funs env env_v` - (rpt strip_tac \\ fs [extend_env_v_rec_def, extend_env_v_def, build_rec_env_zip] -); + build_rec_env funs env env_v +Proof + rpt strip_tac \\ fs [extend_env_v_rec_def, extend_env_v_def, build_rec_env_zip] +QED (*------------------------------------------------------------------*) (** Pattern matching. @@ -508,23 +529,24 @@ val v_of_pat_def = tDefine "v_of_pat" ` val v_of_pat_ind = fetch "-" "v_of_pat_ind"; -Theorem v_of_pat_list_length - `!envC pats insts wildcards vs rest. +Theorem v_of_pat_list_length: + !envC pats insts wildcards vs rest. v_of_pat_list envC pats insts wildcards = SOME (vs, rest, wrest) ==> - LENGTH pats = LENGTH vs` - (Induct_on `pats` \\ fs [v_of_pat_def] \\ rpt strip_tac \\ + LENGTH pats = LENGTH vs +Proof + Induct_on `pats` \\ fs [v_of_pat_def] \\ rpt strip_tac \\ every_case_tac \\ fs [] \\ rw [] \\ first_assum irule \\ instantiate -); +QED -Theorem v_of_pat_insts_length - `(!envC pat insts wildcards v insts_rest wildcards_rest. +Theorem v_of_pat_insts_length: + (!envC pat insts wildcards v insts_rest wildcards_rest. v_of_pat envC pat insts wildcards = SOME (v, insts_rest, wildcards_rest) ==> (LENGTH insts = LENGTH (pat_bindings pat []) + LENGTH insts_rest)) /\ (!envC pats insts wildcards vs insts_rest wildcards_rest. v_of_pat_list envC pats insts wildcards = SOME (vs, insts_rest, wildcards_rest) ==> - (LENGTH insts = LENGTH (pats_bindings pats []) + LENGTH insts_rest))` - - (HO_MATCH_MP_TAC v_of_pat_ind \\ rpt strip_tac \\ + (LENGTH insts = LENGTH (pats_bindings pats []) + LENGTH insts_rest)) +Proof + HO_MATCH_MP_TAC v_of_pat_ind \\ rpt strip_tac \\ fs [v_of_pat_def, pat_bindings_def, LENGTH_NIL] \\ rw [] THEN1 (every_case_tac \\ fs [LENGTH_NIL]) THEN1 (every_case_tac \\ fs []) @@ -538,30 +560,30 @@ Theorem v_of_pat_insts_length every_case_tac \\ fs [] \\ rw [] \\ once_rewrite_tac [semanticPrimitivesPropsTheory.pat_bindings_accum] \\ fs [] ) -); +QED -Theorem v_of_pat_wildcards_count - `(!envC pat insts wildcards v insts_rest wildcards_rest. +Theorem v_of_pat_wildcards_count: + (!envC pat insts wildcards v insts_rest wildcards_rest. v_of_pat envC pat insts wildcards = SOME (v, insts_rest, wildcards_rest) ==> (LENGTH wildcards = pat_wildcards pat + LENGTH wildcards_rest)) /\ (!envC pats insts wildcards vs insts_rest wildcards_rest. v_of_pat_list envC pats insts wildcards = SOME (vs, insts_rest, wildcards_rest) ==> - (LENGTH wildcards = pats_wildcards pats + LENGTH wildcards_rest))` - - (HO_MATCH_MP_TAC v_of_pat_ind \\ rpt strip_tac \\ + (LENGTH wildcards = pats_wildcards pats + LENGTH wildcards_rest)) +Proof + HO_MATCH_MP_TAC v_of_pat_ind \\ rpt strip_tac \\ fs [v_of_pat_def, pat_bindings_def, pat_wildcards_def, LENGTH_NIL] \\ rw [] \\ every_case_tac \\ fs [] \\ rw [] -); +QED -Theorem v_of_pat_extend_insts - `(!envC pat insts wildcards v rest wildcards_rest insts'. +Theorem v_of_pat_extend_insts: + (!envC pat insts wildcards v rest wildcards_rest insts'. v_of_pat envC pat insts wildcards = SOME (v, rest, wildcards_rest) ==> v_of_pat envC pat (insts ++ insts') wildcards = SOME (v, rest ++ insts', wildcards_rest)) /\ (!envC pats insts wildcards vs rest wildcards_rest insts'. v_of_pat_list envC pats insts wildcards = SOME (vs, rest, wildcards_rest) ==> - v_of_pat_list envC pats (insts ++ insts') wildcards = SOME (vs, rest ++ insts', wildcards_rest))` - - (HO_MATCH_MP_TAC v_of_pat_ind \\ rpt strip_tac \\ + v_of_pat_list envC pats (insts ++ insts') wildcards = SOME (vs, rest ++ insts', wildcards_rest)) +Proof + HO_MATCH_MP_TAC v_of_pat_ind \\ rpt strip_tac \\ try_finally (fs [v_of_pat_def]) THEN1 (fs [v_of_pat_def] \\ every_case_tac \\ fs []) THEN1 (fs [v_of_pat_def] \\ every_case_tac \\ fs []) @@ -575,17 +597,17 @@ Theorem v_of_pat_extend_insts ) ) THEN1 (fs [v_of_pat_def] \\ every_case_tac \\ fs [] \\ rw [] \\ fs []) -); +QED -Theorem v_of_pat_extend_wildcards - `(!envC pat insts wildcards v rest wildcards_rest wildcards'. +Theorem v_of_pat_extend_wildcards: + (!envC pat insts wildcards v rest wildcards_rest wildcards'. v_of_pat envC pat insts wildcards = SOME (v, rest, wildcards_rest) ==> v_of_pat envC pat insts (wildcards ++ wildcards') = SOME (v, rest, wildcards_rest ++ wildcards')) /\ (!envC pats insts wildcards vs rest wildcards_rest wildcards'. v_of_pat_list envC pats insts wildcards = SOME (vs, rest, wildcards_rest) ==> - v_of_pat_list envC pats insts (wildcards ++ wildcards') = SOME (vs, rest, wildcards_rest ++ wildcards'))` - - (HO_MATCH_MP_TAC v_of_pat_ind \\ rpt strip_tac \\ + v_of_pat_list envC pats insts (wildcards ++ wildcards') = SOME (vs, rest, wildcards_rest ++ wildcards')) +Proof + HO_MATCH_MP_TAC v_of_pat_ind \\ rpt strip_tac \\ try_finally (fs [v_of_pat_def]) THEN1 (fs [v_of_pat_def] \\ every_case_tac \\ fs []) THEN1 (fs [v_of_pat_def] \\ every_case_tac \\ fs []) @@ -598,10 +620,10 @@ Theorem v_of_pat_extend_wildcards ) ) THEN1 (fs [v_of_pat_def] \\ every_case_tac \\ fs [] \\ rw [] \\ fs []) -); +QED -Theorem v_of_pat_NONE_extend_insts - `(!envC pat insts wildcards insts'. +Theorem v_of_pat_NONE_extend_insts: + (!envC pat insts wildcards insts'. v_of_pat envC pat insts wildcards = NONE ==> LENGTH insts >= LENGTH (pat_bindings pat []) ==> LENGTH wildcards >= pat_wildcards pat ==> @@ -610,9 +632,9 @@ Theorem v_of_pat_NONE_extend_insts v_of_pat_list envC pats insts wildcards = NONE ==> LENGTH insts >= LENGTH (pats_bindings pats []) ==> LENGTH wildcards >= pats_wildcards pats ==> - v_of_pat_list envC pats (insts ++ insts') wildcards = NONE)` - - (HO_MATCH_MP_TAC v_of_pat_ind \\ rpt strip_tac \\ + v_of_pat_list envC pats (insts ++ insts') wildcards = NONE) +Proof + HO_MATCH_MP_TAC v_of_pat_ind \\ rpt strip_tac \\ try_finally ( fs [v_of_pat_def, pat_bindings_def, pat_wildcards_def] \\ every_case_tac \\ fs [] @@ -650,10 +672,10 @@ Theorem v_of_pat_NONE_extend_insts pop_assum (qspec_then `insts'` assume_tac) \\ fs [] \\ rw [] \\ fs [] ) ) -); +QED -Theorem v_of_pat_remove_rest_insts - `(!pat envC insts wildcards v rest wildcards_rest. +Theorem v_of_pat_remove_rest_insts: + (!pat envC insts wildcards v rest wildcards_rest. v_of_pat envC pat insts wildcards = SOME (v, rest, wildcards_rest) ==> ?insts'. insts = insts' ++ rest /\ @@ -664,9 +686,9 @@ Theorem v_of_pat_remove_rest_insts ?insts'. insts = insts' ++ rest /\ LENGTH insts' = LENGTH (pats_bindings pats []) /\ - v_of_pat_list envC pats insts' wildcards = SOME (vs, [], wildcards_rest))` - - (HO_MATCH_MP_TAC astTheory.pat_induction \\ rpt strip_tac \\ + v_of_pat_list envC pats insts' wildcards = SOME (vs, [], wildcards_rest)) +Proof + HO_MATCH_MP_TAC astTheory.pat_induction \\ rpt strip_tac \\ try_finally (fs [v_of_pat_def, pat_bindings_def]) THEN1 (fs [v_of_pat_def, pat_bindings_def] \\ every_case_tac \\ fs []) THEN1 (fs [v_of_pat_def, pat_bindings_def] \\ every_case_tac \\ fs []) @@ -703,17 +725,17 @@ Theorem v_of_pat_remove_rest_insts `rest' = insts_pats` by (metis_tac [APPEND_11_LENGTH]) \\ fs [] \\ rw [] \\ fs [] ) ) -); +QED -Theorem v_of_pat_insts_unique - `(!envC pat insts wildcards rest wildcards_rest v. +Theorem v_of_pat_insts_unique: + (!envC pat insts wildcards rest wildcards_rest v. v_of_pat envC pat insts wildcards = SOME (v, rest, wildcards_rest) ==> (!insts' wildcards'. v_of_pat envC pat insts' wildcards' = SOME (v, rest, wildcards_rest) <=> (insts' = insts /\ wildcards' = wildcards))) /\ (!envC pats insts wildcards rest wildcards_rest vs. v_of_pat_list envC pats insts wildcards = SOME (vs, rest, wildcards_rest) ==> - (!insts' wildcards'. v_of_pat_list envC pats insts' wildcards' = SOME (vs, rest, wildcards_rest) <=> (insts' = insts /\ wildcards' = wildcards)))` - - (HO_MATCH_MP_TAC v_of_pat_ind \\ rpt strip_tac \\ + (!insts' wildcards'. v_of_pat_list envC pats insts' wildcards' = SOME (vs, rest, wildcards_rest) <=> (insts' = insts /\ wildcards' = wildcards))) +Proof + HO_MATCH_MP_TAC v_of_pat_ind \\ rpt strip_tac \\ try_finally (fs [v_of_pat_def] \\ every_case_tac \\ fs []) THEN1 (fs [v_of_pat_def] \\ every_case_tac \\ fs [] \\ metis_tac []) THEN1 (fs [v_of_pat_def] \\ every_case_tac \\ fs [] \\ metis_tac []) @@ -727,7 +749,7 @@ Theorem v_of_pat_insts_unique reverse eq_tac THEN1 (rw []) \\ strip_tac \\ fs [v_of_pat_def] \\ every_case_tac \\ fs [] \\ rw [] \\ fs [] ) -); +QED (* [v_of_pat_norest]: Wrapper that checks that there are no remaining instantiations and wildcards instantiations @@ -739,27 +761,30 @@ val v_of_pat_norest_def = Define ` SOME (v, [], []) => SOME v | _ => NONE`; -Theorem v_of_pat_norest_insts_length - `!envC pat insts wildcards v. +Theorem v_of_pat_norest_insts_length: + !envC pat insts wildcards v. v_of_pat_norest envC pat insts wildcards = SOME v ==> - LENGTH insts = LENGTH (pat_bindings pat [])` - (rpt strip_tac \\ fs [v_of_pat_norest_def] \\ every_case_tac \\ fs [] \\ + LENGTH insts = LENGTH (pat_bindings pat []) +Proof + rpt strip_tac \\ fs [v_of_pat_norest_def] \\ every_case_tac \\ fs [] \\ rw [] \\ progress (fst (CONJ_PAIR v_of_pat_insts_length)) \\ fs [] -); +QED -Theorem v_of_pat_norest_wildcards_count - `!envC pat insts wildcards v. +Theorem v_of_pat_norest_wildcards_count: + !envC pat insts wildcards v. v_of_pat_norest envC pat insts wildcards = SOME v ==> - LENGTH wildcards = pat_wildcards pat` - (rpt strip_tac \\ fs [v_of_pat_norest_def] \\ every_case_tac \\ fs [] \\ + LENGTH wildcards = pat_wildcards pat +Proof + rpt strip_tac \\ fs [v_of_pat_norest_def] \\ every_case_tac \\ fs [] \\ rw [] \\ progress (fst (CONJ_PAIR v_of_pat_wildcards_count)) \\ fs [] -); +QED -Theorem v_of_pat_norest_insts_unique - `!envC pat insts wildcards v. +Theorem v_of_pat_norest_insts_unique: + !envC pat insts wildcards v. v_of_pat_norest envC pat insts wildcards = SOME v ==> - (!insts' wildcards'. v_of_pat_norest envC pat insts' wildcards' = SOME v <=> (insts' = insts /\ wildcards' = wildcards))` - (rpt strip_tac \\ fs [v_of_pat_norest_def] \\ + (!insts' wildcards'. v_of_pat_norest envC pat insts' wildcards' = SOME v <=> (insts' = insts /\ wildcards' = wildcards)) +Proof + rpt strip_tac \\ fs [v_of_pat_norest_def] \\ every_case_tac \\ fs [] \\ rw [] \\ try_finally ( CONV_TAC quantHeuristicsTools.OR_NOT_CONV \\ @@ -770,7 +795,7 @@ Theorem v_of_pat_norest_insts_unique (fst (CONJ_PAIR (v_of_pat_insts_unique))) \\ fs [] \\ eq_tac \\ rw [] \\ fs [] -); +QED (* Predicates that discriminate the patterns we want to deal with. [validate_pat] packs them all up. @@ -805,24 +830,29 @@ val validate_pat_def = Define ` from the semantics. *) -Theorem same_type_EQ_same_ctor[simp] - `same_type r r <=> same_ctor r r` - (Cases_on `r` \\ fs [same_type_def] \\ fs [same_ctor_def]); +Theorem same_type_EQ_same_ctor[simp]: + same_type r r <=> same_ctor r r +Proof + Cases_on `r` \\ fs [same_type_def] \\ fs [same_ctor_def] +QED -Theorem same_ctor_REFL[simp] - `same_ctor r r` - (fs [same_ctor_def]); +Theorem same_ctor_REFL[simp]: + same_ctor r r +Proof + fs [same_ctor_def] +QED -Theorem v_of_pat_pmatch - `(!envC s pat v env_v insts wildcards wildcards_rest. +Theorem v_of_pat_pmatch: + (!envC s pat v env_v insts wildcards wildcards_rest. v_of_pat envC pat insts wildcards = SOME (v, [], wildcards_rest) ==> pmatch envC s pat v env_v = Match (ZIP (pat_bindings pat [], REVERSE insts) ++ env_v)) /\ (!envC s pats vs env_v insts wildcards wildcards_rest. v_of_pat_list envC pats insts wildcards = SOME (vs, [], wildcards_rest) ==> pmatch_list envC s pats vs env_v = Match - (ZIP (pats_bindings pats [], REVERSE insts) ++ env_v))` - (HO_MATCH_MP_TAC pmatch_ind \\ rpt strip_tac \\ rw [] \\ + (ZIP (pats_bindings pats [], REVERSE insts) ++ env_v)) +Proof + HO_MATCH_MP_TAC pmatch_ind \\ rpt strip_tac \\ rw [] \\ try_finally ( fs [pmatch_def, v_of_pat_def, pat_bindings_def] \\ CHANGED_TAC every_case_tac \\ fs [] \\ @@ -856,20 +886,21 @@ Theorem v_of_pat_pmatch fs [GSYM ZIP_APPEND] \\ once_rewrite_tac [GSYM APPEND_ASSOC] \\ rpt (first_x_assum progress) \\ rw [] ) -); +QED -Theorem v_of_pat_norest_pmatch - `!envC s pat v env_v insts wildcards. +Theorem v_of_pat_norest_pmatch: + !envC s pat v env_v insts wildcards. v_of_pat_norest envC pat insts wildcards = SOME v ==> pmatch envC s pat v env_v = Match - (ZIP (pat_bindings pat [], REVERSE insts) ++ env_v)` - (rpt strip_tac \\ fs [v_of_pat_norest_def] \\ + (ZIP (pat_bindings pat [], REVERSE insts) ++ env_v) +Proof + rpt strip_tac \\ fs [v_of_pat_norest_def] \\ irule (fst (CONJ_PAIR v_of_pat_pmatch)) \\ every_case_tac \\ rw [] \\ instantiate -); +QED -Theorem pmatch_v_of_pat - `(!envC s pat v env_v env_v'. +Theorem pmatch_v_of_pat: + (!envC s pat v env_v env_v'. pmatch envC s pat v env_v = Match env_v' ==> pat_without_Pref pat ==> ?insts wildcards. @@ -880,8 +911,9 @@ Theorem pmatch_v_of_pat EVERY (\pat. pat_without_Pref pat) pats ==> ?insts wildcards. env_v' = ZIP (pats_bindings pats [], REVERSE insts) ++ env_v /\ - v_of_pat_list envC pats insts wildcards = SOME (vs, [], []))` - (HO_MATCH_MP_TAC pmatch_ind \\ rpt strip_tac \\ rw [] \\ + v_of_pat_list envC pats insts wildcards = SOME (vs, [], [])) +Proof + HO_MATCH_MP_TAC pmatch_ind \\ rpt strip_tac \\ rw [] \\ try_finally (fs [pmatch_def, v_of_pat_def, pat_bindings_def]) THEN1 ( qexists_tac `[]` \\ Q.REFINE_EXISTS_TAC `w::ws` \\ @@ -930,18 +962,19 @@ Theorem pmatch_v_of_pat (snd (CONJ_PAIR v_of_pat_extend_insts)) \\ fs [v_of_pat_def] ) -); +QED -Theorem pmatch_v_of_pat_norest - `!envC s pat v env_v env_v'. +Theorem pmatch_v_of_pat_norest: + !envC s pat v env_v env_v'. pmatch envC s pat v env_v = Match env_v' ==> pat_without_Pref pat ==> ?insts wildcards. env_v' = ZIP (pat_bindings pat [], REVERSE insts) ++ env_v /\ - v_of_pat_norest envC pat insts wildcards = SOME v` - (rpt strip_tac \\ progress (fst (CONJ_PAIR pmatch_v_of_pat)) \\ fs [] \\ + v_of_pat_norest envC pat insts wildcards = SOME v +Proof + rpt strip_tac \\ progress (fst (CONJ_PAIR pmatch_v_of_pat)) \\ fs [] \\ Q.LIST_EXISTS_TAC [`insts`, `wildcards`] \\ fs [v_of_pat_norest_def] -); +QED (* The nested ifs corresponding to a list of patterns *) @@ -967,10 +1000,11 @@ in ) end -Theorem cf_cases_local - `!v nomatch_exn rows env. - is_local (cf_cases v nomatch_exn rows env)` - (rpt strip_tac \\ +Theorem cf_cases_local: + !v nomatch_exn rows env. + is_local (cf_cases v nomatch_exn rows env) +Proof + rpt strip_tac \\ `cf_cases v nomatch_exn rows env = (\H Q. cf_cases v nomatch_exn rows env H Q)` by ( NTAC 2 (irule EQ_EXT \\ gen_tac) \\ fs [] \\ NO_TAC) \\ @@ -985,7 +1019,7 @@ Theorem cf_cases_local qx_gen_tac `p` \\ Cases_on `p` \\ fs [cf_cases_def] \\ CONV_TAC (RAND_CONV NETA_CONV) \\ fs [local_is_local] ) -); +QED (*------------------------------------------------------------------*) @@ -1002,20 +1036,24 @@ val htriple_valid_def = Define ` evaluate_to_heap st env e p heap r`; (* Not used, but interesting: app_basic as an instance of htriple_valid *) -Theorem app_basic_iff_htriple_valid - `∀env exp. do_opapp [fv; argv] = SOME (env,exp) ⇒ - (app_basic p fv argv H Q ⇔ htriple_valid p exp env H Q)` - (rw[EQ_IMP_THM,app_basic_def,htriple_valid_def] - \\ res_tac \\ rpt (asm_exists_tac \\ rw[])); - -Theorem app_basic_eq_htriple_valid - `app_basic (p:'ffi ffi_proj) (f: v) (x: v) H Q <=> +Theorem app_basic_iff_htriple_valid: + ∀env exp. do_opapp [fv; argv] = SOME (env,exp) ⇒ + (app_basic p fv argv H Q ⇔ htriple_valid p exp env H Q) +Proof + rw[EQ_IMP_THM,app_basic_def,htriple_valid_def] + \\ res_tac \\ rpt (asm_exists_tac \\ rw[]) +QED + +Theorem app_basic_eq_htriple_valid: + app_basic (p:'ffi ffi_proj) (f: v) (x: v) H Q <=> case do_opapp [f; x] of SOME (env, exp) => htriple_valid p exp env H Q - | NONE => ∀st h1 h2. SPLIT (st2heap p st) (h1,h2) ⇒ ¬ H h1` - (reverse CASE_TAC + | NONE => ∀st h1 h2. SPLIT (st2heap p st) (h1,h2) ⇒ ¬ H h1 +Proof + reverse CASE_TAC >- ( CASE_TAC \\ rw[app_basic_iff_htriple_valid] ) - \\ rw[app_basic_def] \\ metis_tac[]); + \\ rw[app_basic_def] \\ metis_tac[] +QED (* Soundness for relation [R] *) val sound_def = Define ` @@ -1035,9 +1073,10 @@ val star_split = Q.prove ( metis_tac [] ); -Theorem sound_local - `!e R. sound (p:'ffi ffi_proj) e R ==> sound (p:'ffi ffi_proj) e (\env. local (R env))` - (rpt strip_tac \\ rewrite_tac [sound_def, htriple_valid_def] \\ +Theorem sound_local: + !e R. sound (p:'ffi ffi_proj) e R ==> sound (p:'ffi ffi_proj) e (\env. local (R env)) +Proof + rpt strip_tac \\ rewrite_tac [sound_def, htriple_valid_def] \\ fs [local_def] \\ rpt strip_tac \\ res_tac \\ rename1 `(H_i * H_k) h_i` \\ rename1 `R env H_i Q_f` \\ rename1 `SEP_IMPPOST (Q_f *+ H_k) (Q *+ H_g)` \\ @@ -1051,12 +1090,14 @@ Theorem sound_local `?h_f h''_g. Q r h_f /\ H_g h''_g /\ SPLIT (h'_f UNION h'_k) (h_f, h''_g)` by metis_tac [star_split] \\ Q.LIST_EXISTS_TAC [`r`, `h_f`, `h'_g UNION h''_g`, `heap`] \\ fs [] \\ - SPLIT_TAC); + SPLIT_TAC +QED -Theorem sound_false - `!e. sound (p:'ffi ffi_proj) e (\env H Q. F)` - (rewrite_tac [sound_def] -); +Theorem sound_false: + !e. sound (p:'ffi ffi_proj) e (\env H Q. F) +Proof + rewrite_tac [sound_def] +QED val sound_local_false = Q.prove ( `!e. sound (p:'ffi ffi_proj) e (\env. local (\H Q. F))`, @@ -1160,18 +1201,21 @@ val app_rec_of_htriple_valid = Q.prove ( (*------------------------------------------------------------------*) (* Lemmas used in the soundness proof of FFI *) -Theorem SPLIT_SING_2 - `SPLIT s (x,{y}) <=> (s = y INSERT x) /\ ~(y IN x)` - (SPLIT_TAC); +Theorem SPLIT_SING_2: + SPLIT s (x,{y}) <=> (s = y INSERT x) /\ ~(y IN x) +Proof + SPLIT_TAC +QED val SUBSET_IN = Q.prove( `!s t x. s SUBSET t /\ x IN s ==> x IN t`, fs [SUBSET_DEF] \\ metis_tac []); -Theorem SPLIT_FFI_SET_IMP_DISJOINT - `SPLIT (st2heap p st) (c,{FFI_part s u ns ts}) ==> - !s1 ts1. ~(FFI_part s1 u ns ts1 IN c)` - (fs [SPLIT_def] \\ rw [] \\ fs [EXTENSION,st2heap_def,DISJOINT_DEF] +Theorem SPLIT_FFI_SET_IMP_DISJOINT: + SPLIT (st2heap p st) (c,{FFI_part s u ns ts}) ==> + !s1 ts1. ~(FFI_part s1 u ns ts1 IN c) +Proof + fs [SPLIT_def] \\ rw [] \\ fs [EXTENSION,st2heap_def,DISJOINT_DEF] \\ CCONTR_TAC \\ fs [] \\ `FFI_part s1 u ns ts1 IN ffi2heap p st.ffi /\ FFI_part s u ns ts IN ffi2heap p st.ffi` by @@ -1182,38 +1226,47 @@ Theorem SPLIT_FFI_SET_IMP_DISJOINT \\ CCONTR_TAC \\ fs [] \\ Cases_on `s = s1` \\ fs [] \\ Cases_on `ns` \\ fs [] - \\ metis_tac []); - -Theorem SPLIT_IMP_Mem_NOT_IN - `SPLIT (st2heap p st) ({Mem y xs},c) ==> - !ys. ~(Mem y ys IN c)` - (fs [SPLIT_def] \\ rw [] \\ fs [EXTENSION,st2heap_def] + \\ metis_tac [] +QED + +Theorem SPLIT_IMP_Mem_NOT_IN: + SPLIT (st2heap p st) ({Mem y xs},c) ==> + !ys. ~(Mem y ys IN c) +Proof + fs [SPLIT_def] \\ rw [] \\ fs [EXTENSION,st2heap_def] \\ CCONTR_TAC \\ fs [] \\ `Mem y ys ∈ store2heap st.refs` by metis_tac [Mem_NOT_IN_ffi2heap] \\ `Mem y xs ∈ store2heap st.refs` by metis_tac [Mem_NOT_IN_ffi2heap] - \\ imp_res_tac store2heap_IN_unique_key \\ fs []); - -Theorem FLOOKUP_FUPDATE_LIST - `!ns f. FLOOKUP (f |++ MAP (λn. (n,s)) ns) m = - if MEM m ns then SOME s else FLOOKUP f m` - (Induct \\ fs [FUPDATE_LIST] \\ rw [] \\ fs [] - \\ fs [FLOOKUP_DEF,FAPPLY_FUPDATE_THM]); - -Theorem ALL_DISTINCT_FLAT_MEM_IMP - `!p2. ALL_DISTINCT (FLAT p2) /\ MEM ns' p2 /\ MEM ns p2 /\ - MEM m ns' /\ MEM m ns ==> ns = ns'` - (Induct \\ fs [ALL_DISTINCT_APPEND] \\ rw [] \\ fs [] - \\ res_tac \\ fs [MEM_FLAT] \\ metis_tac []); - -Theorem ALL_DISTINCT_FLAT_FST_IMP - `!p2. ALL_DISTINCT (FLAT (MAP FST p2)) /\ - MEM (ns,u') p2 /\ MEM (ns,u) p2 /\ ns <> [] ==> u = u'` - (Induct \\ fs [ALL_DISTINCT_APPEND] \\ rw [] \\ fs [] + \\ imp_res_tac store2heap_IN_unique_key \\ fs [] +QED + +Theorem FLOOKUP_FUPDATE_LIST: + !ns f. FLOOKUP (f |++ MAP (λn. (n,s)) ns) m = + if MEM m ns then SOME s else FLOOKUP f m +Proof + Induct \\ fs [FUPDATE_LIST] \\ rw [] \\ fs [] + \\ fs [FLOOKUP_DEF,FAPPLY_FUPDATE_THM] +QED + +Theorem ALL_DISTINCT_FLAT_MEM_IMP: + !p2. ALL_DISTINCT (FLAT p2) /\ MEM ns' p2 /\ MEM ns p2 /\ + MEM m ns' /\ MEM m ns ==> ns = ns' +Proof + Induct \\ fs [ALL_DISTINCT_APPEND] \\ rw [] \\ fs [] + \\ res_tac \\ fs [MEM_FLAT] \\ metis_tac [] +QED + +Theorem ALL_DISTINCT_FLAT_FST_IMP: + !p2. ALL_DISTINCT (FLAT (MAP FST p2)) /\ + MEM (ns,u') p2 /\ MEM (ns,u) p2 /\ ns <> [] ==> u = u' +Proof + Induct \\ fs [ALL_DISTINCT_APPEND] \\ rw [] \\ fs [] \\ fs [MEM_FLAT,MEM_MAP,FORALL_PROD] \\ Cases_on `ns` \\ fs [] \\ first_x_assum (qspec_then `h` mp_tac) \\ fs [] \\ disch_then (qspec_then `h::t` mp_tac) \\ fs [] - \\ rw [] \\ fs []); + \\ rw [] \\ fs [] +QED (*------------------------------------------------------------------*) (* Definition of the [cf] functions, that generates the characteristic @@ -1856,9 +1909,10 @@ val cf_defs = [ (** Properties about [cf]. The main result is the proof of soundness, [cf_sound] *) -Theorem cf_local - `!e. is_local (cf (p:'ffi ffi_proj) e env)` - (Q.SPEC_TAC (`p`,`p`) \\ +Theorem cf_local: + !e. is_local (cf (p:'ffi ffi_proj) e env) +Proof + Q.SPEC_TAC (`p`,`p`) \\ recInduct cf_ind \\ rpt strip_tac \\ fs (local_local :: local_is_local :: cf_defs) THEN1 ( @@ -1869,7 +1923,7 @@ Theorem cf_local Cases_on `op` \\ fs [local_is_local] \\ every_case_tac \\ fs [local_is_local] ) -); +QED val cf_base_case_tac = HO_MATCH_MP_TAC sound_local \\ rewrite_tac [sound_def, htriple_valid_def, evaluate_to_heap_def] \\ @@ -2379,11 +2433,12 @@ fun add_to_clock qtm th g = th evaluate_match_add_to_clock_lemma g)) g; -Theorem lprefix_lub_subset - `lprefix_lub$lprefix_lub s l /\ s SUBSET t /\ +Theorem lprefix_lub_subset: + lprefix_lub$lprefix_lub s l /\ s SUBSET t /\ (!x. x IN t /\ ~(x IN s) ==> ?y. y IN s /\ LPREFIX x y) ==> - lprefix_lub$lprefix_lub t l` - (fs [lprefix_lubTheory.lprefix_lub_def] \\ rw [] + lprefix_lub$lprefix_lub t l +Proof + fs [lprefix_lubTheory.lprefix_lub_def] \\ rw [] THEN1 ( Cases_on `ll IN s` THEN1 (last_x_assum irule \\ rw []) @@ -2391,23 +2446,28 @@ Theorem lprefix_lub_subset \\ last_x_assum (qspec_then `y` mp_tac) \\ rw [] \\ irule LPREFIX_TRANS \\ instantiate) \\ last_x_assum irule \\ rw [] - \\ first_x_assum irule \\ fs [SUBSET_DEF]); - -Theorem LPREFIX_fromList_fromList - `LPREFIX (fromList x) (fromList y) = (x ≼ y)` - (rw [LPREFIX_def, from_toList]); - -Theorem isPREFIX_TRANS - `!x y z. x ≼ y /\ y ≼ z ==> x ≼ z` - (Induct_on `x` \\ Induct_on `y` \\ Induct_on `z` + \\ first_x_assum irule \\ fs [SUBSET_DEF] +QED + +Theorem LPREFIX_fromList_fromList: + LPREFIX (fromList x) (fromList y) = (x ≼ y) +Proof + rw [LPREFIX_def, from_toList] +QED + +Theorem isPREFIX_TRANS: + !x y z. x ≼ y /\ y ≼ z ==> x ≼ z +Proof + Induct_on `x` \\ Induct_on `y` \\ Induct_on `z` \\ fs [isPREFIX] \\ rw [] \\ last_x_assum irule - \\ instantiate); - -Theorem cf_sound - `!p e. sound (p:'ffi ffi_proj) e (cf (p:'ffi ffi_proj) e)` + \\ instantiate +QED - (recInduct cf_ind \\ rpt strip_tac \\ +Theorem cf_sound: + !p e. sound (p:'ffi ffi_proj) e (cf (p:'ffi ffi_proj) e) +Proof + recInduct cf_ind \\ rpt strip_tac \\ rewrite_tac cf_defs \\ fs [sound_local, sound_false] THEN1 (* Lit *) cf_base_case_tac @@ -3258,10 +3318,10 @@ Theorem cf_sound first_assum progress \\ fs [evaluate_to_heap_def, evaluate_ck_def] \\ metis_tac[] ) -); +QED -Theorem cf_sound' - `!e env H Q st. +Theorem cf_sound': + !e env H Q st. cf (p:'ffi ffi_proj) e env H Q ==> H (st2heap (p:'ffi ffi_proj) st) ==> ?r h_f h_g heap. SPLIT heap (h_f, h_g) /\ @@ -3280,15 +3340,17 @@ Theorem cf_sound' | Div io => (∀ck. ?st'. evaluate (st with clock := ck) env [e] = (st', Rerr (Rabort Rtimeout_error))) /\ - lprefix_lub$lprefix_lub (IMAGE (\ck. fromList (FST(evaluate (st with clock := ck) env [e])).ffi.io_events) UNIV) io` - (rpt strip_tac \\ qspecl_then [`(p:'ffi ffi_proj)`, `e`] assume_tac cf_sound \\ + lprefix_lub$lprefix_lub (IMAGE (\ck. fromList (FST(evaluate (st with clock := ck) env [e])).ffi.io_events) UNIV) io +Proof + rpt strip_tac \\ qspecl_then [`(p:'ffi ffi_proj)`, `e`] assume_tac cf_sound \\ fs [sound_def, evaluate_to_heap_def, evaluate_ck_def, htriple_valid_def] \\ `SPLIT (st2heap p st) (st2heap p st, {})` by SPLIT_TAC \\ res_tac \\ rename1 `SPLIT3 heap (h_f, {}, h_g)` \\ - `SPLIT heap (h_f, h_g)` by SPLIT_TAC \\ instantiate); + `SPLIT heap (h_f, h_g)` by SPLIT_TAC \\ instantiate +QED -Theorem cf_sound_local - `!e env H Q h i st. +Theorem cf_sound_local: + !e env H Q h i st. cf (p:'ffi ffi_proj) e env H Q ==> SPLIT (st2heap (p:'ffi ffi_proj) st) (h, i) ==> H h ==> @@ -3309,37 +3371,41 @@ Theorem cf_sound_local | Div io => (∀ck. ?st'. evaluate (st with clock := ck) env [e] = (st', Rerr (Rabort Rtimeout_error))) /\ - lprefix_lub$lprefix_lub (IMAGE (\ck. fromList (FST(evaluate (st with clock := ck) env [e])).ffi.io_events) UNIV) io` - (rpt strip_tac \\ + lprefix_lub$lprefix_lub (IMAGE (\ck. fromList (FST(evaluate (st with clock := ck) env [e])).ffi.io_events) UNIV) io +Proof + rpt strip_tac \\ `sound (p:'ffi ffi_proj) e (\env. (local (cf (p:'ffi ffi_proj) e env)))` by (match_mp_tac sound_local \\ fs [cf_sound]) \\ fs [sound_def, evaluate_to_heap_def, evaluate_ck_def, htriple_valid_def, st2heap_def] \\ `local (cf (p:'ffi ffi_proj) e env) H Q` by (fs [REWRITE_RULE [is_local_def] cf_local |> GSYM]) \\ - res_tac \\ progress SPLIT3_swap23 \\ instantiate); + res_tac \\ progress SPLIT3_swap23 \\ instantiate +QED -Theorem app_basic_of_cf - `!clos body x env env' v H Q. +Theorem app_basic_of_cf: + !clos body x env env' v H Q. do_opapp [clos; x] = SOME (env', body) ==> cf (p:'ffi ffi_proj) body env' H Q ==> - app_basic (p:'ffi ffi_proj) clos x H Q` - (rpt strip_tac \\ irule app_basic_of_htriple_valid \\ + app_basic (p:'ffi ffi_proj) clos x H Q +Proof + rpt strip_tac \\ irule app_basic_of_htriple_valid \\ progress (REWRITE_RULE [sound_def] cf_sound) \\ instantiate -); +QED -Theorem app_of_cf - `!ns env body xvs env' H Q. +Theorem app_of_cf: + !ns env body xvs env' H Q. ns <> [] ==> LENGTH xvs = LENGTH ns ==> cf (p:'ffi ffi_proj) body (extend_env ns xvs env) H Q ==> - app (p:'ffi ffi_proj) (naryClosure env ns body) xvs H Q` - (rpt strip_tac \\ irule app_of_htriple_valid \\ fs [] \\ + app (p:'ffi ffi_proj) (naryClosure env ns body) xvs H Q +Proof + rpt strip_tac \\ irule app_of_htriple_valid \\ fs [] \\ progress (REWRITE_RULE [sound_def] cf_sound) -); +QED -Theorem app_rec_of_cf - `!f params body funs xvs env H Q. +Theorem app_rec_of_cf: + !f params body funs xvs env H Q. params <> [] ==> LENGTH params = LENGTH xvs ==> ALL_DISTINCT (MAP (\ (f,_,_). f) funs) ==> @@ -3350,9 +3416,10 @@ Theorem app_rec_of_cf (MAP (\ (f,_,_). naryRecclosure env (letrec_pull_params funs) f) funs) params xvs env) H Q ==> - app (p:'ffi ffi_proj) (naryRecclosure env (letrec_pull_params funs) f) xvs H Q` - (rpt strip_tac \\ irule app_rec_of_htriple_valid \\ fs [] \\ + app (p:'ffi ffi_proj) (naryRecclosure env (letrec_pull_params funs) f) xvs H Q +Proof + rpt strip_tac \\ irule app_rec_of_htriple_valid \\ fs [] \\ progress (REWRITE_RULE [sound_def] cf_sound) -); +QED val _ = export_theory(); diff --git a/characteristic/cfStoreScript.sml b/characteristic/cfStoreScript.sml index c80d656fb0..9bf072ca51 100644 --- a/characteristic/cfStoreScript.sml +++ b/characteristic/cfStoreScript.sml @@ -58,24 +58,27 @@ val st2heap_def = Define ` (* Lemmas *) -Theorem store2heap_aux_append - `!s n x. +Theorem store2heap_aux_append: + !s n x. store2heap_aux n (s ++ [x]) = - (Mem (LENGTH s + n) x) INSERT store2heap_aux n s` - (Induct THENL [all_tac, Cases] \\ fs [store2heap_aux_def, INSERT_COMM] + (Mem (LENGTH s + n) x) INSERT store2heap_aux n s +Proof + Induct THENL [all_tac, Cases] \\ fs [store2heap_aux_def, INSERT_COMM] \\ fs [DECIDE ``(LENGTH s + 1) = SUC (LENGTH s)``] -) +QED -Theorem store2heap_append - `!s x. store2heap (s ++ [x]) = Mem (LENGTH s) x INSERT store2heap s` - (fs [store2heap_def, store2heap_aux_append] -) +Theorem store2heap_append: + !s x. store2heap (s ++ [x]) = Mem (LENGTH s) x INSERT store2heap s +Proof + fs [store2heap_def, store2heap_aux_append] +QED -Theorem store2heap_aux_suc - `!s n u v. +Theorem store2heap_aux_suc: + !s n u v. (Mem u v IN store2heap_aux n s) = - (Mem (SUC u) v IN store2heap_aux (SUC n) s)` - (Induct + (Mem (SUC u) v IN store2heap_aux (SUC n) s) +Proof + Induct THEN1 (strip_tac \\ fs [store2heap_def, store2heap_aux_def]) THEN1 ( Cases \\ @@ -83,33 +86,36 @@ Theorem store2heap_aux_suc pop_assum (qspecl_then [`n+1`, `u`, `v`] assume_tac) \\ fs [DECIDE ``SUC n + 1 = SUC (n + 1)``] ) -) +QED -Theorem store2heap_aux_IN_bound - `!s n u v. Mem u v IN store2heap_aux n s ==> (u >= n)` - (Induct THENL [all_tac, Cases] \\ fs [store2heap_aux_def] \\ +Theorem store2heap_aux_IN_bound: + !s n u v. Mem u v IN store2heap_aux n s ==> (u >= n) +Proof + Induct THENL [all_tac, Cases] \\ fs [store2heap_aux_def] \\ rpt strip_tac \\ fs [] \\ first_assum (qspecl_then [`n+1`, `u`, `v`] drule) \\ rw_tac arith_ss [] -) +QED -Theorem store2heap_alloc_disjoint - `!s x. ~ (Mem (LENGTH s) x IN (store2heap s))` - (Induct +Theorem store2heap_alloc_disjoint: + !s x. ~ (Mem (LENGTH s) x IN (store2heap s)) +Proof + Induct THEN1 (strip_tac \\ fs [store2heap_def, store2heap_aux_def]) THEN1 ( Cases \\ fs [store2heap_def, store2heap_aux_def] \\ rewrite_tac [ONE] \\ fs [GSYM store2heap_aux_suc] ) -) +QED -Theorem store2heap_IN_LENGTH - `!s r x. Mem r x IN (store2heap s) ==> r < LENGTH s` - (Induct THENL [all_tac, Cases] \\ +Theorem store2heap_IN_LENGTH: + !s r x. Mem r x IN (store2heap s) ==> r < LENGTH s +Proof + Induct THENL [all_tac, Cases] \\ fs [store2heap_def, store2heap_aux_def] \\ Cases_on `r` \\ fs [] \\ rewrite_tac [ONE] \\ rpt strip_tac \\ fs [GSYM store2heap_aux_suc] \\ metis_tac [] -) +QED val tac_store2heap_IN = Induct THENL [all_tac, Cases] \\ fs [store2heap_def, store2heap_aux_def] \\ @@ -119,46 +125,59 @@ val tac_store2heap_IN = qspecl_then [`s`, `1`, `0`, `x'`] drule store2heap_aux_IN_bound \\ rw_tac arith_ss [] -Theorem store2heap_IN_EL - `!s r x. Mem r x IN (store2heap s) ==> EL r s = x` - (tac_store2heap_IN -) +Theorem store2heap_IN_EL: + !s r x. Mem r x IN (store2heap s) ==> EL r s = x +Proof + tac_store2heap_IN +QED -Theorem store2heap_IN_unique_key - `!s r x. +Theorem store2heap_IN_unique_key: + !s r x. Mem r x IN (store2heap s) ==> - !x'. Mem r x' IN (store2heap s) ==> x = x'` - (tac_store2heap_IN -) - -Theorem Mem_NOT_IN_ffi2heap - `~(Mem rv x IN ffi2heap (p:'ffi ffi_proj) f)` - (PairCases_on `p` \\ fs [ffi2heap_def] \\ rw []); - -Theorem FFI_split_NOT_IN_store2heap_aux - `∀n s. FFI_split ∉ store2heap_aux n s` - (Induct_on `s` \\ fs [store2heap_aux_def]); - -Theorem FFI_part_NOT_IN_store2heap_aux - `∀n s. FFI_part x1 x2 x3 x4 ∉ store2heap_aux n s` - (Induct_on `s` \\ fs [store2heap_aux_def]); - -Theorem FFI_full_NOT_IN_store2heap_aux - `∀n s. FFI_full x1 ∉ store2heap_aux n s` - (Induct_on `s` \\ fs [store2heap_aux_def]); - -Theorem FFI_part_NOT_IN_store2heap - `!s. ~(FFI_split ∈ store2heap s) /\ + !x'. Mem r x' IN (store2heap s) ==> x = x' +Proof + tac_store2heap_IN +QED + +Theorem Mem_NOT_IN_ffi2heap: + ~(Mem rv x IN ffi2heap (p:'ffi ffi_proj) f) +Proof + PairCases_on `p` \\ fs [ffi2heap_def] \\ rw [] +QED + +Theorem FFI_split_NOT_IN_store2heap_aux: + ∀n s. FFI_split ∉ store2heap_aux n s +Proof + Induct_on `s` \\ fs [store2heap_aux_def] +QED + +Theorem FFI_part_NOT_IN_store2heap_aux: + ∀n s. FFI_part x1 x2 x3 x4 ∉ store2heap_aux n s +Proof + Induct_on `s` \\ fs [store2heap_aux_def] +QED + +Theorem FFI_full_NOT_IN_store2heap_aux: + ∀n s. FFI_full x1 ∉ store2heap_aux n s +Proof + Induct_on `s` \\ fs [store2heap_aux_def] +QED + +Theorem FFI_part_NOT_IN_store2heap: + !s. ~(FFI_split ∈ store2heap s) /\ ~(FFI_part x1 x2 x3 x4 ∈ store2heap s) /\ - ~(FFI_full y2 ∈ store2heap s)` - (fs [store2heap_def,FFI_part_NOT_IN_store2heap_aux, - FFI_full_NOT_IN_store2heap_aux,FFI_split_NOT_IN_store2heap_aux]); - -Theorem store2heap_LUPDATE - `!s r x y. + ~(FFI_full y2 ∈ store2heap s) +Proof + fs [store2heap_def,FFI_part_NOT_IN_store2heap_aux, + FFI_full_NOT_IN_store2heap_aux,FFI_split_NOT_IN_store2heap_aux] +QED + +Theorem store2heap_LUPDATE: + !s r x y. Mem r y IN (store2heap s) ==> - store2heap (LUPDATE x r s) = Mem r x INSERT ((store2heap s) DELETE Mem r y)` - (Induct \\ + store2heap (LUPDATE x r s) = Mem r x INSERT ((store2heap s) DELETE Mem r y) +Proof + Induct \\ fs [store2heap_def, store2heap_aux_def] \\ Cases_on `r` \\ qx_genl_tac [`v`, `x`, `y`] \\ qspecl_then [`s`, `1`, `0`, `y`] assume_tac store2heap_aux_IN_bound \\ @@ -181,11 +200,13 @@ Theorem store2heap_LUPDATE qpat_x_assum `_ IN _` mp_tac \\ rewrite_tac [ONE, GSYM store2heap_aux_suc] \\ rpt strip_tac \\ first_assum drule \\ - disch_then (qspecl_then [`x`, `Mem n'' s'`] assume_tac) \\ fs [])); - -Theorem st2heap_clock - `!st ck. st2heap (p:'ffi ffi_proj) (st with clock := ck) = st2heap p st` - (fs [st2heap_def] -); + disch_then (qspecl_then [`x`, `Mem n'' s'`] assume_tac) \\ fs []) +QED + +Theorem st2heap_clock: + !st ck. st2heap (p:'ffi ffi_proj) (st with clock := ck) = st2heap p st +Proof + fs [st2heap_def] +QED val _ = export_theory () diff --git a/characteristic/cfTacticsScript.sml b/characteristic/cfTacticsScript.sml index cc829ab7dd..f9bf04e8b6 100644 --- a/characteristic/cfTacticsScript.sml +++ b/characteristic/cfTacticsScript.sml @@ -10,127 +10,144 @@ open cfTacticsBaseLib cfHeapsLib val _ = new_theory "cfTactics" (* -Theorem xret_lemma - `!H Q. +Theorem xret_lemma: + !H Q. (H ==>> Q v * GC) ==> - local (\H' Q'. H' ==>> Q' v) H Q` - (rpt strip_tac \\ irule (Q.SPEC `GC` local_gc_pre_on) \\ + local (\H' Q'. H' ==>> Q' v) H Q +Proof + rpt strip_tac \\ irule (Q.SPEC `GC` local_gc_pre_on) \\ fs [local_is_local] \\ first_assum hchanges \\ hinst \\ irule local_elim \\ fs [] \\ hsimpl -)*) +QED*) -Theorem xret_lemma - `!H Q R. +Theorem xret_lemma: + !H Q R. H ==>> Q v * GC /\ R Q ==> - local (\H' Q'. H' ==>> Q' v /\ R Q') H Q` - (rpt strip_tac \\ irule (Q.SPEC `GC` local_gc_pre_on) \\ + local (\H' Q'. H' ==>> Q' v /\ R Q') H Q +Proof + rpt strip_tac \\ irule (Q.SPEC `GC` local_gc_pre_on) \\ fs [local_is_local] \\ first_assum hchanges \\ hinst \\ irule local_elim \\ fs [] \\ hsimpl -) +QED (* todo: does it even happen? *) -Theorem xret_lemma_unify - `!v H. local (\H' Q'. H' ==>> Q' v) H (\x. cond (x = v) * H)` - (rpt strip_tac \\ irule local_elim \\ fs [] \\ hsimpl -) +Theorem xret_lemma_unify: + !v H. local (\H' Q'. H' ==>> Q' v) H (\x. cond (x = v) * H) +Proof + rpt strip_tac \\ irule local_elim \\ fs [] \\ hsimpl +QED (* -Theorem xret_no_gc_lemma - `!v H Q. +Theorem xret_no_gc_lemma: + !v H Q. (H ==>> Q v) ==> - local (\H' Q'. H' ==>> Q' v) H Q` - (fs [local_elim] -) + local (\H' Q'. H' ==>> Q' v) H Q +Proof + fs [local_elim] +QED *) -Theorem xret_no_gc_lemma - `!v H Q R. +Theorem xret_no_gc_lemma: + !v H Q R. H ==>> Q v /\ R Q ==> - local (\H' Q'. H' ==>> Q' v /\ R Q') H Q` - (fs [local_elim] -) + local (\H' Q'. H' ==>> Q' v /\ R Q') H Q +Proof + fs [local_elim] +QED (*------------------------------------------------------------------*) (* Automatic rewrites *) -Theorem INT_Litv[simp] - `INT i (Litv (IntLit k)) = (i = k)` - (fs [INT_def] \\ eq_tac \\ fs [] -) - -Theorem NUM_Litv[simp] - `NUM n (Litv (IntLit k)) = (k = &n)` - (fs [NUM_def] \\ eq_tac \\ fs [] -) - -Theorem CHAR_Litv[simp] - `CHAR c (Litv (Char c')) = (c = c')` - (fs [CHAR_def] \\ eq_tac \\ fs [] -) - -Theorem STRING_Litv[simp] - `STRING_TYPE s (Litv (StrLit s')) = (s = strlit s')` - (Cases_on`s` \\ fs [STRING_TYPE_def] \\ eq_tac \\ fs [] -) - -Theorem WORD8_Litv[simp] - `WORD w (Litv (Word8 w')) = (w = w')` - (fs [WORD_def, w2w_def] \\ eq_tac \\ fs [] -) - -Theorem WORD64_Litv[simp] - `WORD w (Litv (Word64 w')) = (w = w')` - (fs [WORD_def, w2w_def] \\ eq_tac \\ fs [] -) - -Theorem UNIT_Conv[simp] - `UNIT_TYPE () (Conv NONE []) = T` - (fs [UNIT_TYPE_def] -) - -Theorem BOOL_T_Conv[simp] - `BOOL T (Conv (SOME (TypeStamp "True" bool_type_num)) []) = T` - (fs [BOOL_def, semanticPrimitivesTheory.Boolv_def] -) - -Theorem BOOL_F_Conv[simp] - `BOOL F (Conv (SOME (TypeStamp "False" bool_type_num)) []) = T` - (fs [BOOL_def, semanticPrimitivesTheory.Boolv_def] -) - -Theorem BOOL_Boolv[simp] - `BOOL b (Boolv bv) = (b = bv)` - (fs [BOOL_def, semanticPrimitivesTheory.Boolv_def] \\ +Theorem INT_Litv[simp]: + INT i (Litv (IntLit k)) = (i = k) +Proof + fs [INT_def] \\ eq_tac \\ fs [] +QED + +Theorem NUM_Litv[simp]: + NUM n (Litv (IntLit k)) = (k = &n) +Proof + fs [NUM_def] \\ eq_tac \\ fs [] +QED + +Theorem CHAR_Litv[simp]: + CHAR c (Litv (Char c')) = (c = c') +Proof + fs [CHAR_def] \\ eq_tac \\ fs [] +QED + +Theorem STRING_Litv[simp]: + STRING_TYPE s (Litv (StrLit s')) = (s = strlit s') +Proof + Cases_on`s` \\ fs [STRING_TYPE_def] \\ eq_tac \\ fs [] +QED + +Theorem WORD8_Litv[simp]: + WORD w (Litv (Word8 w')) = (w = w') +Proof + fs [WORD_def, w2w_def] \\ eq_tac \\ fs [] +QED + +Theorem WORD64_Litv[simp]: + WORD w (Litv (Word64 w')) = (w = w') +Proof + fs [WORD_def, w2w_def] \\ eq_tac \\ fs [] +QED + +Theorem UNIT_Conv[simp]: + UNIT_TYPE () (Conv NONE []) = T +Proof + fs [UNIT_TYPE_def] +QED + +Theorem BOOL_T_Conv[simp]: + BOOL T (Conv (SOME (TypeStamp "True" bool_type_num)) []) = T +Proof + fs [BOOL_def, semanticPrimitivesTheory.Boolv_def] +QED + +Theorem BOOL_F_Conv[simp]: + BOOL F (Conv (SOME (TypeStamp "False" bool_type_num)) []) = T +Proof + fs [BOOL_def, semanticPrimitivesTheory.Boolv_def] +QED + +Theorem BOOL_Boolv[simp]: + BOOL b (Boolv bv) = (b = bv) +Proof + fs [BOOL_def, semanticPrimitivesTheory.Boolv_def] \\ every_case_tac \\ fs [] -) +QED (*------------------------------------------------------------------*) (* Used for cleaning up after unfolding [build_cases] (in cf_match) *) -Theorem exists_v_of_pat_norest_length - `!envC pat insts v. +Theorem exists_v_of_pat_norest_length: + !envC pat insts v. (?insts wildcards. v_of_pat_norest envC pat insts wildcards = SOME v) <=> (?insts wildcards. LENGTH insts = LENGTH (pat_bindings pat []) /\ LENGTH wildcards = pat_wildcards pat /\ - v_of_pat_norest envC pat insts wildcards = SOME v)` - (rpt strip_tac \\ eq_tac \\ fs [] \\ rpt strip_tac \\ instantiate \\ + v_of_pat_norest envC pat insts wildcards = SOME v) +Proof + rpt strip_tac \\ eq_tac \\ fs [] \\ rpt strip_tac \\ instantiate \\ progress v_of_pat_norest_insts_length \\ progress v_of_pat_norest_wildcards_count \\ fs [] -); +QED -Theorem forall_v_of_pat_norest_length - `!envC pat insts v P. +Theorem forall_v_of_pat_norest_length: + !envC pat insts v P. (!insts wildcards. v_of_pat_norest envC pat insts wildcards = SOME v ==> P insts) <=> (!insts wildcards. LENGTH insts = LENGTH (pat_bindings pat []) ==> LENGTH wildcards = pat_wildcards pat ==> v_of_pat_norest envC pat insts wildcards = SOME v ==> - P insts)` - (rpt strip_tac \\ eq_tac \\ fs [] \\ rpt strip_tac \\ + P insts) +Proof + rpt strip_tac \\ eq_tac \\ fs [] \\ rpt strip_tac \\ progress v_of_pat_norest_insts_length \\ progress v_of_pat_norest_wildcards_count \\ first_assum progress -); +QED val BOOL_T = save_thm("BOOL_T", EVAL ``BOOL T (Conv (SOME (TypeStamp "True" 0)) [])``); diff --git a/characteristic/examples/cf_examplesScript.sml b/characteristic/examples/cf_examplesScript.sml index 5ee25e204c..b398b4689d 100644 --- a/characteristic/examples/cf_examplesScript.sml +++ b/characteristic/examples/cf_examplesScript.sml @@ -298,12 +298,13 @@ val bytearray_fromlist = process_topdecs val st = ml_progLib.add_prog bytearray_fromlist pick_name basis_st -Theorem list_length_spec - `!a l lv. +Theorem list_length_spec: + !a l lv. LIST_TYPE a l lv ==> app (p:'ffi ffi_proj) ^(fetch_v "length" st) [lv] - emp (POSTv v. & NUM (LENGTH l) v)` - (Induct_on `l` + emp (POSTv v. & NUM (LENGTH l) v) +Proof + Induct_on `l` THEN1 ( xcf "length" st \\ fs [LIST_TYPE_def] \\ xmatch \\ xret \\ xsimpl @@ -316,7 +317,7 @@ Theorem list_length_spec xapp \\ xsimpl \\ fs [NUM_def] \\ asm_exists_tac \\ fs [] \\ (* meh? *) fs [INT_def] \\ intLib.ARITH_TAC ) -) +QED val bytearray_fromlist_spec = Q.prove ( `!l lv. diff --git a/compiler/backend/ag32/ag32_memoryScript.sml b/compiler/backend/ag32/ag32_memoryScript.sml index 35aad4b3f4..53e57f289c 100644 --- a/compiler/backend/ag32/ag32_memoryScript.sml +++ b/compiler/backend/ag32/ag32_memoryScript.sml @@ -31,25 +31,30 @@ val set_mem_word_def = Define` ((a + 2w =+ (((23 >< 16) w):word8)) o ((a + 3w =+ (((31 >< 24) w):word8))))))`; -Theorem set_mem_word_neq ` - x ≠ k ∧ +Theorem set_mem_word_neq: + x ≠ k ∧ x +1w ≠ k ∧ x +2w ≠ k ∧ x +3w ≠ k ⇒ - set_mem_word x y m k = m k` - (EVAL_TAC>>fs[]); + set_mem_word x y m k = m k +Proof + EVAL_TAC>>fs[] +QED (* TODO: copied from stack_allocProofTheory *) -Theorem good_dimindex_32 - `(byte_aligned (w:word32) <=> - ((w && 3w) = 0w))` - (fs [alignmentTheory.byte_aligned_def,alignmentTheory.aligned_bitwise_and]); - -Theorem get_mem_word_set_mem_word - `byte_aligned a ∧ byte_aligned x ⇒ +Theorem good_dimindex_32: + (byte_aligned (w:word32) <=> + ((w && 3w) = 0w)) +Proof + fs [alignmentTheory.byte_aligned_def,alignmentTheory.aligned_bitwise_and] +QED + +Theorem get_mem_word_set_mem_word: + byte_aligned a ∧ byte_aligned x ⇒ (get_mem_word (set_mem_word a w m) x = - if a = x then w else get_mem_word m x)` - (rw[get_mem_word_def,set_mem_word_def]>> + if a = x then w else get_mem_word m x) +Proof + rw[get_mem_word_def,set_mem_word_def]>> fs[APPLY_UPDATE_THM] >- (rpt @@ -64,10 +69,11 @@ Theorem get_mem_word_set_mem_word (IF_CASES_TAC>- ( CCONTR_TAC>> pop_assum kall_tac>> blastLib.FULL_BBLAST_TAC))>> - blastLib.BBLAST_TAC)); + blastLib.BBLAST_TAC) +QED -Theorem get_mem_word_asm_write_bytearray_UNCHANGED_LT ` - (pc <+ a) ∧ +Theorem get_mem_word_asm_write_bytearray_UNCHANGED_LT: + (pc <+ a) ∧ (pc+1w <+ a) ∧ (pc+2w <+ a) ∧ (pc+3w <+ a) ∧ @@ -75,153 +81,197 @@ Theorem get_mem_word_asm_write_bytearray_UNCHANGED_LT ` ⇒ get_mem_word (asm_write_bytearray a ls m) pc = - get_mem_word m pc` - (rw[]>> + get_mem_word m pc +Proof + rw[]>> imp_res_tac asm_write_bytearray_unchanged>> - fs[get_mem_word_def]); + fs[get_mem_word_def] +QED -Theorem get_mem_word_UPDATE ` - pc ≠ k ∧ +Theorem get_mem_word_UPDATE: + pc ≠ k ∧ pc+1w ≠ k ∧ pc+2w ≠ k ∧ pc+3w ≠ k ⇒ get_mem_word ((k =+ v) m) pc = - get_mem_word m pc` - (rw[]>> + get_mem_word m pc +Proof + rw[]>> fs[get_mem_word_def] >> - fs[APPLY_UPDATE_THM]); - -Theorem get_mem_word_change_mem - `(∀k. k < 4 ⇒ (m1 (pc + n2w k) = m2 (pc + n2w k))) ⇒ - (get_mem_word m1 pc = get_mem_word m2 pc)` - (srw_tac[DNF_ss][get_mem_word_def, NUMERAL_LESS_THM]); - -Theorem dfn'Normal_PC - `(dfn'Normal x s).PC = s.PC + 4w` - (PairCases_on`x` + fs[APPLY_UPDATE_THM] +QED + +Theorem get_mem_word_change_mem: + (∀k. k < 4 ⇒ (m1 (pc + n2w k) = m2 (pc + n2w k))) ⇒ + (get_mem_word m1 pc = get_mem_word m2 pc) +Proof + srw_tac[DNF_ss][get_mem_word_def, NUMERAL_LESS_THM] +QED + +Theorem dfn'Normal_PC: + (dfn'Normal x s).PC = s.PC + 4w +Proof + PairCases_on`x` \\ rw[ag32Theory.dfn'Normal_def] \\ rw[ag32Theory.norm_def] \\ simp[ag32Theory.ALU_def] - \\ PURE_TOP_CASE_TAC \\ simp[ag32Theory.incPC_def]); + \\ PURE_TOP_CASE_TAC \\ simp[ag32Theory.incPC_def] +QED -Theorem dfn'Normal_MEM - `(dfn'Normal x s).MEM = s.MEM` - (PairCases_on`x` +Theorem dfn'Normal_MEM: + (dfn'Normal x s).MEM = s.MEM +Proof + PairCases_on`x` \\ rw[ag32Theory.dfn'Normal_def] \\ rw[ag32Theory.norm_def] \\ simp[ag32Theory.ALU_def] - \\ PURE_TOP_CASE_TAC \\ simp[ag32Theory.incPC_def]); + \\ PURE_TOP_CASE_TAC \\ simp[ag32Theory.incPC_def] +QED -Theorem dfn'JumpIfZero_PC - `((dfn'JumpIfZero (fSnd,Reg i,Imm w,Reg r) s).PC = +Theorem dfn'JumpIfZero_PC: + ((dfn'JumpIfZero (fSnd,Reg i,Imm w,Reg r) s).PC = if s.R r = 0w then s.PC + s.R i else s.PC + 4w) /\ ((dfn'JumpIfZero (fSnd,Imm v,Imm w,Reg r) s).PC = if s.R r = 0w then s.PC + sw2sw v else s.PC + 4w) /\ ((dfn'JumpIfZero (fSnd,Imm v,Imm w,Imm x) s).PC = - if sw2sw x = 0w:word32 then s.PC + sw2sw v else s.PC + 4w)` - (rw[ag32Theory.dfn'JumpIfZero_def,ag32Theory.ALU_def,ag32Theory.ri2word_def] - \\ simp[ag32Theory.incPC_def]); - -Theorem dfn'JumpIfZero_MEM - `(dfn'JumpIfZero x s).MEM = s.MEM` - (PairCases_on`x` + if sw2sw x = 0w:word32 then s.PC + sw2sw v else s.PC + 4w) +Proof + rw[ag32Theory.dfn'JumpIfZero_def,ag32Theory.ALU_def,ag32Theory.ri2word_def] + \\ simp[ag32Theory.incPC_def] +QED + +Theorem dfn'JumpIfZero_MEM: + (dfn'JumpIfZero x s).MEM = s.MEM +Proof + PairCases_on`x` \\ rw[ag32Theory.dfn'JumpIfZero_def] \\ simp[ag32Theory.incPC_def,ag32Theory.ALU_def] - \\ rpt (every_case_tac \\ fs [])); + \\ rpt (every_case_tac \\ fs []) +QED -Theorem dfn'JumpIfNotZero_PC - `((dfn'JumpIfNotZero (fSnd,Reg i,Imm w,Reg r) s).PC = +Theorem dfn'JumpIfNotZero_PC: + ((dfn'JumpIfNotZero (fSnd,Reg i,Imm w,Reg r) s).PC = if s.R r <> 0w then s.PC + s.R i else s.PC + 4w) /\ ((dfn'JumpIfNotZero (fSnd,Imm v,Imm w,Reg r) s).PC = if s.R r <> 0w then s.PC + sw2sw v else s.PC + 4w) /\ ((dfn'JumpIfNotZero (fSnd,Imm v,Imm w,Imm x) s).PC = - if sw2sw x <> 0w:word32 then s.PC + sw2sw v else s.PC + 4w)` - (rw[ag32Theory.dfn'JumpIfNotZero_def,ag32Theory.ALU_def,ag32Theory.ri2word_def] - \\ simp[ag32Theory.incPC_def]); - -Theorem dfn'JumpIfNotZero_MEM - `(dfn'JumpIfNotZero x s).MEM = s.MEM` - (PairCases_on`x` + if sw2sw x <> 0w:word32 then s.PC + sw2sw v else s.PC + 4w) +Proof + rw[ag32Theory.dfn'JumpIfNotZero_def,ag32Theory.ALU_def,ag32Theory.ri2word_def] + \\ simp[ag32Theory.incPC_def] +QED + +Theorem dfn'JumpIfNotZero_MEM: + (dfn'JumpIfNotZero x s).MEM = s.MEM +Proof + PairCases_on`x` \\ rw[ag32Theory.dfn'JumpIfNotZero_def] \\ simp[ag32Theory.incPC_def,ag32Theory.ALU_def] - \\ rpt (every_case_tac \\ fs [])); - -Theorem dfn'Interrupt_PC - `((dfn'Interrupt s).PC = s.PC + 4w)` - (rw[ag32Theory.dfn'Interrupt_def] - \\ simp[ag32Theory.incPC_def]); - -Theorem dfn'Interrupt_MEM - `((dfn'Interrupt s).MEM = s.MEM)` - (rw[ag32Theory.dfn'Interrupt_def,ag32Theory.incPC_def]); - -Theorem dfn'Jump_MEM - `((dfn'Jump x s).MEM = s.MEM)` - (PairCases_on`x` + \\ rpt (every_case_tac \\ fs []) +QED + +Theorem dfn'Interrupt_PC: + ((dfn'Interrupt s).PC = s.PC + 4w) +Proof + rw[ag32Theory.dfn'Interrupt_def] + \\ simp[ag32Theory.incPC_def] +QED + +Theorem dfn'Interrupt_MEM: + ((dfn'Interrupt s).MEM = s.MEM) +Proof + rw[ag32Theory.dfn'Interrupt_def,ag32Theory.incPC_def] +QED + +Theorem dfn'Jump_MEM: + ((dfn'Jump x s).MEM = s.MEM) +Proof + PairCases_on`x` \\ rw[ag32Theory.dfn'Jump_def,ag32Theory.ALU_def] - \\ every_case_tac \\ fs []); + \\ every_case_tac \\ fs [] +QED -Theorem dfn'LoadMEM_PC - `(dfn'LoadMEM x s).PC = s.PC + 4w` - (PairCases_on`x` +Theorem dfn'LoadMEM_PC: + (dfn'LoadMEM x s).PC = s.PC + 4w +Proof + PairCases_on`x` \\ rw[ag32Theory.dfn'LoadMEM_def] - \\ simp[ag32Theory.incPC_def]); + \\ simp[ag32Theory.incPC_def] +QED -Theorem dfn'LoadMEM_MEM - `(dfn'LoadMEM x s).MEM = s.MEM` - (PairCases_on`x` +Theorem dfn'LoadMEM_MEM: + (dfn'LoadMEM x s).MEM = s.MEM +Proof + PairCases_on`x` \\ rw[ag32Theory.dfn'LoadMEM_def] - \\ simp[ag32Theory.incPC_def]); + \\ simp[ag32Theory.incPC_def] +QED -Theorem dfn'StoreMEMByte_PC - `(dfn'StoreMEMByte x s).PC = s.PC + 4w` - (PairCases_on`x` +Theorem dfn'StoreMEMByte_PC: + (dfn'StoreMEMByte x s).PC = s.PC + 4w +Proof + PairCases_on`x` \\ rw[ag32Theory.dfn'StoreMEMByte_def] - \\ simp[ag32Theory.incPC_def]); + \\ simp[ag32Theory.incPC_def] +QED -Theorem dfn'LoadMEMByte_PC - `(dfn'LoadMEMByte x s).PC = s.PC + 4w` - (PairCases_on`x` +Theorem dfn'LoadMEMByte_PC: + (dfn'LoadMEMByte x s).PC = s.PC + 4w +Proof + PairCases_on`x` \\ rw[ag32Theory.dfn'LoadMEMByte_def] - \\ simp[ag32Theory.incPC_def]); + \\ simp[ag32Theory.incPC_def] +QED -Theorem dfn'LoadMEMByte_MEM - `(dfn'LoadMEMByte x s).MEM = s.MEM` - (PairCases_on`x` +Theorem dfn'LoadMEMByte_MEM: + (dfn'LoadMEMByte x s).MEM = s.MEM +Proof + PairCases_on`x` \\ rw[ag32Theory.dfn'LoadMEMByte_def] - \\ simp[ag32Theory.incPC_def]); + \\ simp[ag32Theory.incPC_def] +QED -Theorem dfn'Shift_PC - `(ag32$dfn'Shift x s).PC = s.PC + 4w` - (PairCases_on`x` +Theorem dfn'Shift_PC: + (ag32$dfn'Shift x s).PC = s.PC + 4w +Proof + PairCases_on`x` \\ rw[ag32Theory.dfn'Shift_def] - \\ simp[ag32Theory.incPC_def]); + \\ simp[ag32Theory.incPC_def] +QED -Theorem dfn'Shift_MEM - `(ag32$dfn'Shift x s).MEM = s.MEM` - (PairCases_on`x` +Theorem dfn'Shift_MEM: + (ag32$dfn'Shift x s).MEM = s.MEM +Proof + PairCases_on`x` \\ rw[ag32Theory.dfn'Shift_def] - \\ simp[ag32Theory.incPC_def]); + \\ simp[ag32Theory.incPC_def] +QED -Theorem dfn'LoadConstant_PC - `(ag32$dfn'LoadConstant x s).PC = s.PC + 4w` - (PairCases_on`x` +Theorem dfn'LoadConstant_PC: + (ag32$dfn'LoadConstant x s).PC = s.PC + 4w +Proof + PairCases_on`x` \\ rw[ag32Theory.dfn'LoadConstant_def] - \\ simp[ag32Theory.incPC_def]); + \\ simp[ag32Theory.incPC_def] +QED -Theorem dfn'LoadConstant_MEM - `(ag32$dfn'LoadConstant x s).MEM = s.MEM` - (PairCases_on`x` +Theorem dfn'LoadConstant_MEM: + (ag32$dfn'LoadConstant x s).MEM = s.MEM +Proof + PairCases_on`x` \\ rw[ag32Theory.dfn'LoadConstant_def] - \\ simp[ag32Theory.incPC_def]); + \\ simp[ag32Theory.incPC_def] +QED -Theorem dfn'JumpIfZero_MEM - `(ag32$dfn'JumpIfZero x s).MEM = s.MEM` - (PairCases_on`x` +Theorem dfn'JumpIfZero_MEM: + (ag32$dfn'JumpIfZero x s).MEM = s.MEM +Proof + PairCases_on`x` \\ rw[ag32Theory.dfn'JumpIfZero_def, ag32Theory.ALU_def] - \\ PURE_TOP_CASE_TAC \\ fs[ag32Theory.incPC_def] \\ rw[]); + \\ PURE_TOP_CASE_TAC \\ fs[ag32Theory.incPC_def] \\ rw[] +QED (* -- *) @@ -349,8 +399,8 @@ val ag32_ffi_return_def = Define` let s = dfn'Jump (fSnd, 0w, Reg 0w) s in s`; -Theorem ag32_ffi_return_thm - `(ag32_ffi_return s = +Theorem ag32_ffi_return_thm: + (ag32_ffi_return s = s with <| PC := s.R 0w; R := ((0w =+ s.PC + n2w (4 * LENGTH ag32_ffi_return_code)) ((1w =+ 0w) @@ -363,15 +413,17 @@ Theorem ag32_ffi_return_thm ((8w =+ 0w) s.R))))))))); io_events := SNOC s.MEM s.io_events; OverflowFlag := F; - CarryFlag := F |>)` - (rw[ag32_ffi_return_def] + CarryFlag := F |>) +Proof + rw[ag32_ffi_return_def] \\ rw[ag32Theory.dfn'Normal_def, ag32Theory.incPC_def, ag32Theory.ri2word_def, ag32Theory.norm_def, ag32Theory.ALU_def, ag32Theory.dfn'Interrupt_def, ag32Theory.dfn'Jump_def] \\ rw[ag32Theory.ag32_state_component_equality, APPLY_UPDATE_THM, FUN_EQ_THM] >- EVAL_TAC \\ rw[] \\ fs[] - \\ EVAL_TAC); + \\ EVAL_TAC +QED val ag32_ffi_copy_code_def = Define` ag32_ffi_copy_code = [ @@ -404,8 +456,8 @@ val ag32_ffi_copy_def = tDefine"ag32_ffi_copy"` \\ Cases_on`n` \\ fs[] \\ simp[ADD1, GSYM word_add_n2w]); -Theorem ag32_ffi_copy_thm - `∀s written. +Theorem ag32_ffi_copy_thm: + ∀s written. bytes_in_memory (s.R 3w) written s.MEM md ∧ (w2n (s.R 1w) = LENGTH written) ∧ DISJOINT md { w | s.R 5w <=+ w ∧ w <+ s.R 5w + n2w (LENGTH written) } ∧ w2n (s.R 5w) + LENGTH written < dimword(:32) ∧ @@ -418,8 +470,9 @@ Theorem ag32_ffi_copy_thm ((3w =+ r3) ((5w =+ r5) ((8w =+ r8) s.R)))); - MEM := asm_write_bytearray (s.R 5w) written s.MEM |>)` - (Induct_on`w2n (s.R 1w)` \\ rw[] + MEM := asm_write_bytearray (s.R 5w) written s.MEM |>) +Proof + Induct_on`w2n (s.R 1w)` \\ rw[] >- ( qpat_x_assum`0 = _`(assume_tac o SYM) \\ fs[read_bytearray_def, bytes_in_memory_def] \\ rw[] @@ -509,7 +562,8 @@ Theorem ag32_ffi_copy_thm \\ fs[word_lo_n2w, word_ls_n2w] \\ blastLib.BBLAST_TAC ) \\ irule mem_eq_imp_asm_write_bytearray_eq - \\ rw[APPLY_UPDATE_THM]); + \\ rw[APPLY_UPDATE_THM] +QED (* exit PC is ffi_code_start_offset @@ -599,8 +653,8 @@ val ag32_ffi_get_arg_count_main_def = Define` let s = dfn'StoreMEMByte (Reg 5w, Reg 3w) s in s`; -Theorem ag32_ffi_get_arg_count_main_thm - `(get_mem_word s.MEM (n2w startup_code_size) = n2w len) ∧ len < 256 * 256 +Theorem ag32_ffi_get_arg_count_main_thm: + (get_mem_word s.MEM (n2w startup_code_size) = n2w len) ∧ len < 256 * 256 ⇒ ∃r3 r5. (ag32_ffi_get_arg_count_main s = @@ -608,8 +662,9 @@ Theorem ag32_ffi_get_arg_count_main_thm MEM := asm_write_bytearray (s.R 3w) [n2w len; n2w (len DIV 256)] (((n2w (ffi_code_start_offset - 1)) =+ n2w (THE (ALOOKUP FFI_codes "get_arg_count"))) s.MEM); - R := ((3w =+ r3) ((5w =+ r5) s.R)) |>)` - (rw[ag32_ffi_get_arg_count_main_def] + R := ((3w =+ r3) ((5w =+ r5) s.R)) |>) +Proof + rw[ag32_ffi_get_arg_count_main_def] \\ rw[ag32Theory.dfn'StoreMEM_def, ag32Theory.dfn'LoadMEM_def, ag32Theory.ri2word_def, ag32Theory.dfn'LoadConstant_def, ag32Theory.dfn'StoreMEMByte_def, ag32Theory.incPC_def, ag32Theory.dfn'Normal_def, ag32Theory.norm_def, @@ -634,7 +689,8 @@ Theorem ag32_ffi_get_arg_count_main_thm rfs[]>> blastLib.FULL_BBLAST_TAC)>> IF_CASES_TAC>>fs[]>> - simp[word_extract_n2w,bitTheory.BITS_THM]); + simp[word_extract_n2w,bitTheory.BITS_THM] +QED val ag32_ffi_get_arg_count_def = Define` ag32_ffi_get_arg_count s = @@ -717,8 +773,8 @@ val ag32_ffi_get_arg_length_setup_def = Define` let s = dfn'LoadConstant(7w, F, n2w (4 * 8)) s in s`; -Theorem ag32_ffi_get_arg_length_setup_thm - `bytes_in_memory (s.R 3w) [l0; l1] s.MEM md ∧ n2w(ffi_code_start_offset - 1) ∉ md +Theorem ag32_ffi_get_arg_length_setup_thm: + bytes_in_memory (s.R 3w) [l0; l1] s.MEM md ∧ n2w(ffi_code_start_offset - 1) ∉ md ⇒ ∃ov cf. (ag32_ffi_get_arg_length_setup s = @@ -728,8 +784,9 @@ Theorem ag32_ffi_get_arg_length_setup_thm R := ((5w =+ n2w (startup_code_size + 4)) ((6w =+ n2w (256 * w2n l1 + w2n l0 + 1)) ((7w =+ n2w (4 * 8)) s.R))); - CarryFlag := cf; OverflowFlag := ov |>)` - (rw[ag32_ffi_get_arg_length_setup_def] + CarryFlag := cf; OverflowFlag := ov |>) +Proof + rw[ag32_ffi_get_arg_length_setup_def] \\ simp[ag32Theory.dfn'LoadMEMByte_def, ag32Theory.incPC_def, ag32Theory.dfn'Normal_def, ag32Theory.norm_def, ag32Theory.ALU_def, ag32Theory.ri2word_def, @@ -746,7 +803,8 @@ Theorem ag32_ffi_get_arg_length_setup_thm \\ qmatch_goalsub_abbrev_tac`w2w (A) + (w2w(B) <<8)` \\ simp[w2w_def,GSYM word_add_n2w] \\ fs[WORD_MUL_LSL] - \\ simp[GSYM word_mul_n2w]); + \\ simp[GSYM word_mul_n2w] +QED val ag32_ffi_get_arg_length_loop1_def = tDefine"ag32_ffi_get_arg_length_loop1"` ag32_ffi_get_arg_length_loop1 s = @@ -775,16 +833,17 @@ val ag32_ffi_get_arg_length_loop1_def = tDefine"ag32_ffi_get_arg_length_loop1"` \\ `¬(n'''' < n''' + 1)` by metis_tac[ADD_ASSOC,ADD_COMM] \\ fs[NOT_LESS]); -Theorem ag32_ffi_get_arg_length_loop1_thm - `ag32_ffi_get_arg_length_loop1 s = +Theorem ag32_ffi_get_arg_length_loop1_thm: + ag32_ffi_get_arg_length_loop1 s = case OLEAST n. s.MEM (s.R 5w + n2w n) = 0w of NONE => s | SOME n => s with <| PC := s.PC + n2w (4 * 4); R := ((8w =+ 0w) ((4w =+ s.R 4w + n2w (n+1)) - ((5w =+ s.R 5w + n2w (n+1)) s.R))) |>` - (reverse(rw[whileTheory.OLEAST_def]) + ((5w =+ s.R 5w + n2w (n+1)) s.R))) |> +Proof + reverse(rw[whileTheory.OLEAST_def]) >- ( rw[Once ag32_ffi_get_arg_length_loop1_def] \\ fs[] \\ metis_tac[] ) @@ -833,7 +892,8 @@ Theorem ag32_ffi_get_arg_length_loop1_thm \\ simp[] \\ disch_then kall_tac \\ simp[ag32Theory.ag32_state_component_equality] - \\ simp[FUN_EQ_THM, APPLY_UPDATE_THM, ADD1, GSYM word_add_n2w]); + \\ simp[FUN_EQ_THM, APPLY_UPDATE_THM, ADD1, GSYM word_add_n2w] +QED val ag32_ffi_get_arg_length_loop_def = tDefine"ag32_ffi_get_arg_length_loop"` ag32_ffi_get_arg_length_loop s0 = @@ -879,12 +939,13 @@ val get_next_mem_arg_def = tDefine"get_next_mem_arg"` val get_next_mem_arg_ind = theorem"get_next_mem_arg_ind"; -Theorem get_next_mem_arg_LEAST - `∀m a acc. get_next_mem_arg m a acc = +Theorem get_next_mem_arg_LEAST: + ∀m a acc. get_next_mem_arg m a acc = case OLEAST n. m (a + n2w n) = 0w of | NONE => (a, REVERSE acc) - | SOME n => (a + n2w n, REVERSE acc ++ (GENLIST (λn. m (a + n2w n)) n))` - (recInduct get_next_mem_arg_ind + | SOME n => (a + n2w n, REVERSE acc ++ (GENLIST (λn. m (a + n2w n)) n)) +Proof + recInduct get_next_mem_arg_ind \\ rw[] \\ simp[Once get_next_mem_arg_def] \\ Cases_on`m a = 0w` \\ fs[] @@ -922,7 +983,8 @@ Theorem get_next_mem_arg_LEAST \\ qmatch_goalsub_rename_tac`n2 = n1` \\ `¬(n1 + 1 < n2 + 1)` by metis_tac[word_add_n2w, WORD_ADD_ASSOC] \\ `¬(n2 < n1)` by metis_tac[] - \\ fs[]); + \\ fs[] +QED val get_mem_arg_def = Define` (get_mem_arg m a 0 = get_next_mem_arg m a []) ∧ @@ -930,8 +992,8 @@ val get_mem_arg_def = Define` let (a, _) = get_next_mem_arg m a [] in get_mem_arg m (a+1w) n)`; -Theorem ag32_ffi_get_arg_length_loop_thm - `(s.R 6w = n2w (index+1)) ∧ index ≤ cline_size ∧ +Theorem ag32_ffi_get_arg_length_loop_thm: + (s.R 6w = n2w (index+1)) ∧ index ≤ cline_size ∧ (s.R 7w = n2w (4 * 8)) ∧ (∃n. s.MEM (s.R 5w + n2w n) = 0w) ⇒ @@ -941,8 +1003,9 @@ Theorem ag32_ffi_get_arg_length_loop_thm R := ((8w =+ r8) ((4w =+ n2w (LENGTH (SND (get_mem_arg s.MEM (s.R 5w) index)) + 1)) ((6w =+ r6) - ((5w =+ r5) s.R)))) |>)` - (qid_spec_tac`s` + ((5w =+ r5) s.R)))) |>) +Proof + qid_spec_tac`s` \\ Induct_on`index` >- ( rw[] @@ -1006,7 +1069,8 @@ Theorem ag32_ffi_get_arg_length_loop_thm \\ AP_TERM_TAC \\ AP_TERM_TAC \\ simp[get_next_mem_arg_LEAST, whileTheory.OLEAST_def] - \\ IF_CASES_TAC \\ fs[]); + \\ IF_CASES_TAC \\ fs[] +QED val ag32_ffi_get_arg_length_store_def = Define` ag32_ffi_get_arg_length_store s = @@ -1017,8 +1081,8 @@ val ag32_ffi_get_arg_length_store_def = Define` let s = dfn'StoreMEMByte(Reg 4w, Reg 3w) s in s`; -Theorem ag32_ffi_get_arg_length_store_thm - `(s.R 4w = n2w (n+1)) ∧ +Theorem ag32_ffi_get_arg_length_store_thm: + (s.R 4w = n2w (n+1)) ∧ n < dimword(:32) ⇒ ∃r4 r3. @@ -1027,8 +1091,9 @@ Theorem ag32_ffi_get_arg_length_store_thm R := ((4w =+ r4) ((3w =+ r3) s.R)); MEM := (((s.R 3w) =+ (n2w n)) - (((s.R 3w + 1w) =+ (n2w (n DIV 256))) s.MEM)) |>)` - (rw[ag32_ffi_get_arg_length_store_def] + (((s.R 3w + 1w) =+ (n2w (n DIV 256))) s.MEM)) |>) +Proof + rw[ag32_ffi_get_arg_length_store_def] \\ simp[ag32Theory.dfn'Normal_def, ag32Theory.norm_def, ag32Theory.ri2word_def, ag32Theory.incPC_def, ag32Theory.ALU_def, ag32Theory.dfn'Shift_def, ag32Theory.shift_def, @@ -1049,7 +1114,8 @@ Theorem ag32_ffi_get_arg_length_store_thm qspecl_then [`n`,`8n`] mp_tac (INST_TYPE [alpha|->``:32``] n2w_DIV)>> simp[]>> blastLib.FULL_BBLAST_TAC) - \\ blastLib.FULL_BBLAST_TAC); + \\ blastLib.FULL_BBLAST_TAC +QED val ag32_ffi_get_arg_length_def = Define` ag32_ffi_get_arg_length s = @@ -1114,8 +1180,8 @@ val ag32_ffi_get_arg_setup_def = Define` let s = dfn'Normal(fAdd, 6w, Reg 6w, Reg 7w) s in s`; -Theorem ag32_ffi_get_arg_setup_thm - `bytes_in_memory (s.R 3w) [l0; l1] s.MEM md ∧ n2w(ffi_code_start_offset - 1) ∉ md +Theorem ag32_ffi_get_arg_setup_thm: + bytes_in_memory (s.R 3w) [l0; l1] s.MEM md ∧ n2w(ffi_code_start_offset - 1) ∉ md ⇒ ∃r7 ov cf. (ag32_ffi_get_arg_setup s = @@ -1125,8 +1191,9 @@ Theorem ag32_ffi_get_arg_setup_thm R := ((5w =+ n2w (startup_code_size + 4)) ((6w =+ n2w (256 * w2n l1 + w2n l0)) ((7w =+ r7) s.R))); - CarryFlag := cf; OverflowFlag := ov |>)` - (rw[ag32_ffi_get_arg_setup_def] + CarryFlag := cf; OverflowFlag := ov |>) +Proof + rw[ag32_ffi_get_arg_setup_def] \\ simp[ag32Theory.dfn'LoadMEMByte_def, ag32Theory.incPC_def, ag32Theory.dfn'Normal_def, ag32Theory.norm_def, ag32Theory.ALU_def, ag32Theory.ri2word_def, @@ -1145,7 +1212,8 @@ Theorem ag32_ffi_get_arg_setup_thm \\ qmatch_goalsub_abbrev_tac`w2w (A) + (w2w(B) <<8)` \\ simp[w2w_def,GSYM word_add_n2w] \\ fs[WORD_MUL_LSL] - \\ simp[GSYM word_mul_n2w]); + \\ simp[GSYM word_mul_n2w] +QED val ag32_ffi_get_arg_find1_def = tDefine"ag32_ffi_get_arg_find1"` ag32_ffi_get_arg_find1 s = @@ -1173,15 +1241,16 @@ val ag32_ffi_get_arg_find1_def = tDefine"ag32_ffi_get_arg_find1"` \\ `¬(n'''' < n''' + 1)` by metis_tac[ADD_ASSOC,ADD_COMM] \\ fs[NOT_LESS]); -Theorem ag32_ffi_get_arg_find1_thm - `ag32_ffi_get_arg_find1 s = +Theorem ag32_ffi_get_arg_find1_thm: + ag32_ffi_get_arg_find1 s = case OLEAST n. s.MEM (s.R 5w + n2w n) = 0w of NONE => s | SOME n => s with <| PC := s.PC + n2w (4 * 3); R := ((8w =+ 0w) - ((5w =+ s.R 5w + n2w (n+1)) s.R)) |>` - (reverse(rw[whileTheory.OLEAST_def]) + ((5w =+ s.R 5w + n2w (n+1)) s.R)) |> +Proof + reverse(rw[whileTheory.OLEAST_def]) >- ( rw[Once ag32_ffi_get_arg_find1_def] \\ fs[] \\ metis_tac[] ) @@ -1230,7 +1299,8 @@ Theorem ag32_ffi_get_arg_find1_thm \\ simp[] \\ disch_then kall_tac \\ simp[ag32Theory.ag32_state_component_equality] - \\ simp[FUN_EQ_THM, APPLY_UPDATE_THM, ADD1, GSYM word_add_n2w]); + \\ simp[FUN_EQ_THM, APPLY_UPDATE_THM, ADD1, GSYM word_add_n2w] +QED val ag32_ffi_get_arg_find_def = tDefine"ag32_ffi_get_arg_find"` ag32_ffi_get_arg_find s0 = @@ -1251,8 +1321,8 @@ val ag32_ffi_get_arg_find_def = tDefine"ag32_ffi_get_arg_find"` \\ Cases_on`s0.R 6w` \\ fs[] \\ Cases_on`n` \\ fs[ADD1, GSYM word_add_n2w]); -Theorem ag32_ffi_get_arg_find_thm - `(s.R 6w = n2w (index)) ∧ index ≤ cline_size ∧ +Theorem ag32_ffi_get_arg_find_thm: + (s.R 6w = n2w (index)) ∧ index ≤ cline_size ∧ (∃n. s.MEM (s.R 5w + n2w n) = 0w) ⇒ ∃r8 r6. @@ -1260,8 +1330,9 @@ Theorem ag32_ffi_get_arg_find_thm s with <| PC := s.PC + n2w (4 * LENGTH ag32_ffi_get_arg_find_code); R := ((8w =+ r8) ((5w =+ if 0 < index then FST (get_mem_arg s.MEM (s.R 5w) (index-1)) + 1w else s.R 5w) - ((6w =+ r6) s.R))) |>)` - (qid_spec_tac`s` + ((6w =+ r6) s.R))) |>) +Proof + qid_spec_tac`s` \\ Induct_on`index` >- ( rw[] @@ -1319,7 +1390,8 @@ Theorem ag32_ffi_get_arg_find_thm \\ Cases_on`index` \\ fs[get_mem_arg_def] \\ simp[UNCURRY] \\ simp[get_next_mem_arg_LEAST, whileTheory.OLEAST_def] - \\ IF_CASES_TAC \\ fs[]); + \\ IF_CASES_TAC \\ fs[] +QED val ag32_ffi_get_arg_store_def = tDefine"ag32_ffi_get_arg_store"` ag32_ffi_get_arg_store s = @@ -1375,8 +1447,8 @@ val ag32_ffi_get_arg_store_def = tDefine"ag32_ffi_get_arg_store"` \\ last_x_assum(qspec_then`n'''''+1`mp_tac) \\ simp[]); -Theorem ag32_ffi_get_arg_store_thm - `((OLEAST n. s.MEM (s.R 5w + n2w n) = 0w) = SOME n) ∧ +Theorem ag32_ffi_get_arg_store_thm: + ((OLEAST n. s.MEM (s.R 5w + n2w n) = 0w) = SOME n) ∧ (∀i. i ≤ n ⇒ s.R 5w + n2w i ≠ s.R 3w) ∧ Abbrev(w2n (s.R 3w) + n < dimword(:32)) ⇒ ∃r8 r5 r3. @@ -1385,8 +1457,9 @@ Theorem ag32_ffi_get_arg_store_thm R := ((8w =+ r8) ((5w =+ r5) ((3w =+ r3) s.R))); - MEM := asm_write_bytearray (s.R 3w) (GENLIST (λn. s.MEM (s.R 5w + n2w n)) n) s.MEM |>)` - (qid_spec_tac`s` + MEM := asm_write_bytearray (s.R 3w) (GENLIST (λn. s.MEM (s.R 5w + n2w n)) n) s.MEM |>) +Proof + qid_spec_tac`s` \\ Induct_on`n` \\ rw[] >- ( simp[Once ag32_ffi_get_arg_store_def] @@ -1541,7 +1614,8 @@ Theorem ag32_ffi_get_arg_store_thm \\ qpat_x_assum`Abbrev(bs = _)`kall_tac \\ simp[Abbr`bs'`] \\ irule mem_eq_imp_asm_write_bytearray_eq - \\ simp[Abbr`m'`,Abbr`m`,APPLY_UPDATE_THM]); + \\ simp[Abbr`m'`,Abbr`m`,APPLY_UPDATE_THM] +QED val ag32_ffi_get_arg_def = Define` ag32_ffi_get_arg s = @@ -1659,16 +1733,18 @@ val ag32_ffi_read_set_id_def = Define` let s = dfn'StoreMEMByte (Imm (n2w(THE(ALOOKUP FFI_codes "read"))), Reg 5w) s in s`; -Theorem ag32_ffi_read_set_id_thm - ` (ag32_ffi_read_set_id s = +Theorem ag32_ffi_read_set_id_thm: + (ag32_ffi_read_set_id s = s with <| PC := s.PC + 8w; R := ((5w =+ n2w (ffi_code_start_offset - 1)) s.R); - MEM := ((n2w (ffi_code_start_offset - 1)) =+ n2w (THE (ALOOKUP FFI_codes "read"))) s.MEM |>)` - (rw[ag32_ffi_read_set_id_def] + MEM := ((n2w (ffi_code_start_offset - 1)) =+ n2w (THE (ALOOKUP FFI_codes "read"))) s.MEM |>) +Proof + rw[ag32_ffi_read_set_id_def] \\ rw[ag32Theory.dfn'LoadConstant_def, ag32Theory.incPC_def] \\ rw[ag32Theory.dfn'StoreMEMByte_def, ag32Theory.ri2word_def, ag32Theory.incPC_def, APPLY_UPDATE_THM] - \\ EVAL_TAC); + \\ EVAL_TAC +QED val ag32_ffi_read_check_conf_def = Define` ag32_ffi_read_check_conf s = @@ -1706,8 +1782,8 @@ val ag32_ffi_read_check_conf_def = Define` let s = dfn'Normal (fEqual, 7w, Reg 2w, Imm 0w) s in let s = dfn'Normal (fAnd, 6w, Reg 6w, Reg 7w) s in s`; -Theorem ag32_ffi_read_check_conf_thm - `bytes_in_memory (s.R 1w) conf s.MEM md ∧ (w2n (s.R 2w) = LENGTH conf) +Theorem ag32_ffi_read_check_conf_thm: + bytes_in_memory (s.R 1w) conf s.MEM md ∧ (w2n (s.R 2w) = LENGTH conf) ⇒ ∃ov cf r1 r2 r7. (ag32_ffi_read_check_conf s = @@ -1718,8 +1794,9 @@ Theorem ag32_ffi_read_check_conf_thm ((7w =+ r7) s.R))))); PC := s.PC + n2w (4 * LENGTH ag32_ffi_read_check_conf_code); OverflowFlag := ov; - CarryFlag := cf |>)` - (rewrite_tac[ag32_ffi_read_check_conf_def] + CarryFlag := cf |>) +Proof + rewrite_tac[ag32_ffi_read_check_conf_def] \\ strip_tac \\ simp_tac (srw_ss()) [Q.SPECL[`fEqual`,`6w`]ag32Theory.dfn'Normal_def, @@ -1841,7 +1918,8 @@ Theorem ag32_ffi_read_check_conf_thm \\ simp[ADD1] \\ simp[word_lt_n2w] \\ qspecl_then[`31`,`n+3`]mp_tac bitTheory.NOT_BIT_GT_TWOEXP - \\ simp[]); + \\ simp[] +QED val ag32_ffi_read_load_lengths_def = Define` ag32_ffi_read_load_lengths s = @@ -1858,8 +1936,8 @@ val ag32_ffi_read_load_lengths_def = Define` let s = dfn'Normal (fSub, 7w, Reg 7w, Reg 5w) s in s`; -Theorem ag32_ffi_read_load_lengths_thm - `bytes_in_memory (s.R 3w) [n1; n0] s.MEM md ∧ +Theorem ag32_ffi_read_load_lengths_thm: + bytes_in_memory (s.R 3w) [n1; n0] s.MEM md ∧ (get_mem_word s.MEM (n2w stdin_offset) = n2w off) ∧ (get_mem_word s.MEM (n2w (stdin_offset + 4)) = n2w len) ∧ off ≤ len ∧ len ≤ stdin_size ⇒ @@ -1871,8 +1949,9 @@ Theorem ag32_ffi_read_load_lengths_thm ((1w =+ n2w(w22n[n1; n0])) s.R)))); PC := s.PC + n2w (4 * LENGTH ag32_ffi_read_load_lengths_code); OverflowFlag := ov; - CarryFlag := cf |>)` - (rewrite_tac[ag32_ffi_read_load_lengths_def] + CarryFlag := cf |>) +Proof + rewrite_tac[ag32_ffi_read_load_lengths_def] \\ strip_tac \\ simp_tac (srw_ss()) [ag32Theory.dfn'LoadMEMByte_def, ag32Theory.incPC_def, @@ -1965,7 +2044,8 @@ Theorem ag32_ffi_read_load_lengths_thm \\ DEP_REWRITE_TAC[GSYM WORD_ADD_XOR] \\ match_mp_tac (blastLib.BBLAST_PROVE ``w1 <+ 256w ==> (0w = (w1 && 256w * w2:word32))``) - \\ fs [WORD_LO]); + \\ fs [WORD_LO] +QED val ag32_ffi_read_check_length_def = Define` ag32_ffi_read_check_length s = @@ -1976,8 +2056,8 @@ val ag32_ffi_read_check_length_def = Define` let s = dfn'JumpIfZero (fAnd, Reg 4w, Reg 6w, Reg 8w) s in s`; -Theorem ag32_ffi_read_check_length_thm - `(s.R 1w = n2w n) ∧ (s.R 4w = n2w ltll) ∧ (s.R 6w = v2w [cnd]) +Theorem ag32_ffi_read_check_length_thm: + (s.R 1w = n2w n) ∧ (s.R 4w = n2w ltll) ∧ (s.R 6w = v2w [cnd]) ∧ ltll < dimword(:32) ∧ n < dimword(:32) ⇒ ∃r4 r6 r8 cf ov. @@ -1989,8 +2069,9 @@ Theorem ag32_ffi_read_check_length_thm ((6w =+ r6) ((4w =+ r4) s.R))); CarryFlag := cf; - OverflowFlag := ov |>)` - (strip_tac + OverflowFlag := ov |>) +Proof + strip_tac \\ simp[ag32_ffi_read_check_length_def] \\ simp[ag32Theory.dfn'Normal_def, ag32Theory.incPC_def, ag32Theory.ri2word_def, ag32Theory.norm_def, @@ -2017,7 +2098,8 @@ Theorem ag32_ffi_read_check_length_thm \\ qexists_tac`r6` \\ qmatch_goalsub_abbrev_tac`if 8w = _ then r8 else _` \\ qexists_tac`r8` - \\ rw[] \\ fs[]); + \\ rw[] \\ fs[] +QED val ag32_ffi_read_num_written_def = Define` ag32_ffi_read_num_written s = @@ -2041,8 +2123,8 @@ val ag32_ffi_read_num_written_def = Define` let s = dfn'LoadConstant (2w, F, 4w * 8w) s in s`; -Theorem ag32_ffi_read_num_written_thm - `bytes_in_memory (s.R 3w) (n1::n0::pad1::pad2::tll) s.MEM md ∧ +Theorem ag32_ffi_read_num_written_thm: + bytes_in_memory (s.R 3w) (n1::n0::pad1::pad2::tll) s.MEM md ∧ (s.R 1w = n2w n) ∧ (s.R 5w = n2w off) ∧ (s.R 7w = n2w lcmo) ∧ @@ -2061,8 +2143,9 @@ Theorem ag32_ffi_read_num_written_thm ((2w =+ 4w * 8w) ((1w =+ n2w k) s.R)))))); CarryFlag := cf; - OverflowFlag := ov |>)` - (rewrite_tac[ag32_ffi_read_num_written_def] + OverflowFlag := ov |>) +Proof + rewrite_tac[ag32_ffi_read_num_written_def] \\ strip_tac \\ simp_tac (srw_ss()) [Q.SPECL[]ag32Theory.dfn'StoreMEMByte_def, @@ -2199,7 +2282,8 @@ Theorem ag32_ffi_read_num_written_thm \\ match_mp_tac (blastLib.BBLAST_PROVE ``w <+ 256w:word32 /\ (k = w2w w) ==> ((7 >< 0) w = k:word8)``) \\ rewrite_tac [w2w_def,w2n_lsr,WORD_LO] - \\ fs [DIV_LT_X]); + \\ fs [DIV_LT_X] +QED val ag32_ffi_read_def = Define` ag32_ffi_read s = @@ -2376,8 +2460,8 @@ val ag32_ffi_write_set_id_def = Define` let s = dfn'StoreMEMByte (Imm (n2w(THE(ALOOKUP FFI_codes "write"))), Reg 5w) s in s`; -Theorem ag32_ffi_write_set_id_thm - `(s.PC = n2w (ffi_code_start_offset + ag32_ffi_write_entrypoint)) +Theorem ag32_ffi_write_set_id_thm: + (s.PC = n2w (ffi_code_start_offset + ag32_ffi_write_entrypoint)) ⇒ ∃cf ov r6. (ag32_ffi_write_set_id s = @@ -2385,8 +2469,9 @@ Theorem ag32_ffi_write_set_id_thm R := ((6w =+ r6) ((5w =+ (n2w (ffi_code_start_offset - 1))) s.R)); CarryFlag := cf; OverflowFlag := ov; - MEM := ((n2w (ffi_code_start_offset - 1)) =+ n2w (THE (ALOOKUP FFI_codes "write"))) s.MEM |>)` - (rw[ag32_ffi_write_set_id_def] + MEM := ((n2w (ffi_code_start_offset - 1)) =+ n2w (THE (ALOOKUP FFI_codes "write"))) s.MEM |>) +Proof + rw[ag32_ffi_write_set_id_def] \\ rw[ag32Theory.dfn'Jump_def, ag32Theory.ALU_def, ag32Theory.ri2word_def] \\ qmatch_goalsub_abbrev_tac`n2w off` \\ rw[ag32Theory.dfn'LoadConstant_def, ag32Theory.incPC_def] @@ -2397,7 +2482,8 @@ Theorem ag32_ffi_write_set_id_thm \\ rw[ag32Theory.ag32_state_component_equality, APPLY_UPDATE_THM, FUN_EQ_THM, Abbr`off`] \\ EVAL_TAC \\ rw[] - \\ metis_tac[]); + \\ metis_tac[] +QED val ag32_ffi_write_check_conf_def = Define` ag32_ffi_write_check_conf s = @@ -2438,8 +2524,8 @@ val ag32_ffi_write_check_conf_def = Define` let s = dfn'Normal (fAnd, 6w, Reg 6w, Reg 7w) s in s`; -Theorem ag32_ffi_write_check_conf_thm - `bytes_in_memory (s.R 1w) conf s.MEM md ∧ (w2n (s.R 2w) = LENGTH conf) +Theorem ag32_ffi_write_check_conf_thm: + bytes_in_memory (s.R 1w) conf s.MEM md ∧ (w2n (s.R 2w) = LENGTH conf) ⇒ ∃ov cf r1 r2 r7. (ag32_ffi_write_check_conf s = @@ -2450,8 +2536,9 @@ Theorem ag32_ffi_write_check_conf_thm ((7w =+ r7) s.R))))); PC := s.PC + n2w (4 * LENGTH ag32_ffi_write_check_conf_code); OverflowFlag := ov; - CarryFlag := cf |>)` - (rewrite_tac[ag32_ffi_write_check_conf_def] + CarryFlag := cf |>) +Proof + rewrite_tac[ag32_ffi_write_check_conf_def] \\ strip_tac \\ simp_tac (srw_ss()) [Q.SPECL[`fEqual`,`6w`]ag32Theory.dfn'Normal_def, @@ -2577,25 +2664,32 @@ Theorem ag32_ffi_write_check_conf_thm \\ simp[ADD1] \\ simp[word_lt_n2w] \\ qspecl_then[`31`,`n+3`]mp_tac bitTheory.NOT_BIT_GT_TWOEXP - \\ simp[]); - -Theorem ag32_ffi_write_check_conf_MEM - `(ag32_ffi_write_check_conf s).MEM = s.MEM` - (rw[ag32_ffi_write_check_conf_def, dfn'Normal_MEM, dfn'LoadMEMByte_MEM]); - -Theorem ag32_ffi_write_check_conf_PC - `(ag32_ffi_write_check_conf s).PC = s.PC + 140w` - (rw[ag32_ffi_write_check_conf_def, dfn'Normal_PC, dfn'LoadMEMByte_PC]); - -Theorem ag32_ffi_write_check_conf_R - `((ag32_ffi_write_check_conf s).R 3w = s.R 3w) ∧ - ((ag32_ffi_write_check_conf s).R 5w = s.R 5w)` - (rw[ag32_ffi_write_check_conf_def, + \\ simp[] +QED + +Theorem ag32_ffi_write_check_conf_MEM: + (ag32_ffi_write_check_conf s).MEM = s.MEM +Proof + rw[ag32_ffi_write_check_conf_def, dfn'Normal_MEM, dfn'LoadMEMByte_MEM] +QED + +Theorem ag32_ffi_write_check_conf_PC: + (ag32_ffi_write_check_conf s).PC = s.PC + 140w +Proof + rw[ag32_ffi_write_check_conf_def, dfn'Normal_PC, dfn'LoadMEMByte_PC] +QED + +Theorem ag32_ffi_write_check_conf_R: + ((ag32_ffi_write_check_conf s).R 3w = s.R 3w) ∧ + ((ag32_ffi_write_check_conf s).R 5w = s.R 5w) +Proof + rw[ag32_ffi_write_check_conf_def, ag32Theory.dfn'Normal_def, ag32Theory.ri2word_def, ag32Theory.incPC_def, ag32Theory.ALU_def, ag32Theory.norm_def, ag32Theory.dfn'LoadMEMByte_def, ag32Theory.dfn'Shift_def, ag32Theory.shift_def, ag32Theory.dfn'LoadConstant_def, ag32Theory.dfn'JumpIfZero_def, - APPLY_UPDATE_THM]); + APPLY_UPDATE_THM] +QED val ag32_ffi_write_load_noff_def = Define` ag32_ffi_write_load_noff s = @@ -2613,8 +2707,8 @@ val ag32_ffi_write_load_noff_def = Define` let s = dfn'Normal (fSub, 3w, Reg 3w, Imm 3w) s in s`; -Theorem ag32_ffi_write_load_noff_thm - `bytes_in_memory (s.R 3w) (n1::n0::off1::off0::tll) s.MEM md +Theorem ag32_ffi_write_load_noff_thm: + bytes_in_memory (s.R 3w) (n1::n0::off1::off0::tll) s.MEM md ⇒ ∃r8 ov cf. (ag32_ffi_write_load_noff s = @@ -2623,8 +2717,9 @@ Theorem ag32_ffi_write_load_noff_thm CarryFlag := cf; R := ((8w =+ r8) ((1w =+ n2w (w22n [n1; n0])) - ((7w =+ n2w (w22n [off1; off0])) s.R))) |>)` - (rewrite_tac[ag32_ffi_write_load_noff_def] + ((7w =+ n2w (w22n [off1; off0])) s.R))) |>) +Proof + rewrite_tac[ag32_ffi_write_load_noff_def] \\ strip_tac \\ simp_tac (srw_ss()) [Q.SPECL[`1w`]ag32Theory.dfn'LoadMEMByte_def, @@ -2717,25 +2812,32 @@ Theorem ag32_ffi_write_load_noff_thm \\ simp[GSYM word_mul_n2w, GSYM word_add_n2w] \\ match_mp_tac (blastLib.BBLAST_PROVE ``w1 <+ 256w ==> (0w = (w1 && 256w * w2:word32))``) - \\ fs [WORD_LO]); - -Theorem ag32_ffi_write_load_noff_MEM - `(ag32_ffi_write_load_noff s).MEM = s.MEM` - (rw[ag32_ffi_write_load_noff_def, dfn'Normal_MEM, dfn'LoadMEMByte_MEM, dfn'Shift_MEM]); - -Theorem ag32_ffi_write_load_noff_PC - `(ag32_ffi_write_load_noff s).PC = s.PC + 48w` - (rw[ag32_ffi_write_load_noff_def, dfn'Normal_PC, dfn'LoadMEMByte_PC, dfn'Shift_PC]); - -Theorem ag32_ffi_write_load_noff_R - `((ag32_ffi_write_load_noff s).R 3w = s.R 3w) ∧ - ((ag32_ffi_write_load_noff s).R 5w = s.R 5w)` - (rw[ag32_ffi_write_load_noff_def, + \\ fs [WORD_LO] +QED + +Theorem ag32_ffi_write_load_noff_MEM: + (ag32_ffi_write_load_noff s).MEM = s.MEM +Proof + rw[ag32_ffi_write_load_noff_def, dfn'Normal_MEM, dfn'LoadMEMByte_MEM, dfn'Shift_MEM] +QED + +Theorem ag32_ffi_write_load_noff_PC: + (ag32_ffi_write_load_noff s).PC = s.PC + 48w +Proof + rw[ag32_ffi_write_load_noff_def, dfn'Normal_PC, dfn'LoadMEMByte_PC, dfn'Shift_PC] +QED + +Theorem ag32_ffi_write_load_noff_R: + ((ag32_ffi_write_load_noff s).R 3w = s.R 3w) ∧ + ((ag32_ffi_write_load_noff s).R 5w = s.R 5w) +Proof + rw[ag32_ffi_write_load_noff_def, ag32Theory.dfn'Normal_def, ag32Theory.ri2word_def, ag32Theory.incPC_def, ag32Theory.ALU_def, ag32Theory.norm_def, ag32Theory.dfn'LoadMEMByte_def, ag32Theory.dfn'Shift_def, ag32Theory.shift_def, ag32Theory.dfn'LoadConstant_def, ag32Theory.dfn'JumpIfZero_def, - APPLY_UPDATE_THM]); + APPLY_UPDATE_THM] +QED val ag32_ffi_write_check_lengths_def = Define` ag32_ffi_write_check_lengths s = @@ -2751,8 +2853,8 @@ val ag32_ffi_write_check_lengths_def = Define` let s = dfn'JumpIfZero (fAnd, Reg 4w, Reg 6w, Reg 8w) s in s`; -Theorem ag32_ffi_write_check_lengths_thm - `(s.R 5w = n2w (ffi_code_start_offset - 1)) ∧ +Theorem ag32_ffi_write_check_lengths_thm: + (s.R 5w = n2w (ffi_code_start_offset - 1)) ∧ (s.R 4w = n2w ltll) ∧ (s.R 7w = n2w off) ∧ (s.R 1w = n2w n) ∧ (s.R 6w = v2w [cnd]) ∧ off < dimword(:16) ∧ n < dimword(:16) ∧ ltll < dimword (:32) ⇒ @@ -2766,8 +2868,9 @@ Theorem ag32_ffi_write_check_lengths_thm ((5w =+ n2w output_offset) ((6w =+ r6) s.R)))); CarryFlag := cf; - OverflowFlag := ov |>)` - (strip_tac + OverflowFlag := ov |>) +Proof + strip_tac \\ simp[ag32_ffi_write_check_lengths_def] \\ simp[ag32Theory.dfn'Normal_def, ag32Theory.ri2word_def, ag32Theory.norm_def, ag32Theory.ALU_def, ag32Theory.incPC_def, @@ -2799,34 +2902,41 @@ Theorem ag32_ffi_write_check_lengths_thm \\ qmatch_goalsub_abbrev_tac`if 8w = _ then r8 else _` \\ qexists_tac`r8` \\ rw[] \\ fs[] - \\ EVAL_TAC \\ simp[]); - -Theorem ag32_ffi_write_check_lengths_MEM - `(ag32_ffi_write_check_lengths s).MEM = s.MEM` - (rw[ag32_ffi_write_check_lengths_def, dfn'Normal_MEM, dfn'LoadConstant_MEM, - dfn'JumpIfZero_MEM]); - -Theorem ag32_ffi_write_check_lengths_PC - `(ag32_ffi_write_check_lengths s).PC ∈ + \\ EVAL_TAC \\ simp[] +QED + +Theorem ag32_ffi_write_check_lengths_MEM: + (ag32_ffi_write_check_lengths s).MEM = s.MEM +Proof + rw[ag32_ffi_write_check_lengths_def, dfn'Normal_MEM, dfn'LoadConstant_MEM, + dfn'JumpIfZero_MEM] +QED + +Theorem ag32_ffi_write_check_lengths_PC: + (ag32_ffi_write_check_lengths s).PC ∈ { s.PC + n2w (4 * LENGTH ag32_ffi_write_check_lengths_code ); - s.PC + n2w (4 * (LENGTH ag32_ffi_write_check_lengths_code + 33)) }` - (reverse ( + s.PC + n2w (4 * (LENGTH ag32_ffi_write_check_lengths_code + 33)) } +Proof + reverse ( rw[ag32_ffi_write_check_lengths_def, dfn'Normal_PC, dfn'LoadConstant_PC, ag32Theory.dfn'JumpIfZero_def, ag32Theory.ALU_def, ag32Theory.ri2word_def, ag32Theory.incPC_def ] ) >- EVAL_TAC \\ rw[ag32Theory.dfn'LoadConstant_def, ag32Theory.incPC_def, APPLY_UPDATE_THM] - \\ EVAL_TAC); + \\ EVAL_TAC +QED -Theorem ag32_ffi_write_check_lengths_R - `((ag32_ffi_write_check_lengths s).R 3w = s.R 3w) ∧ - ((ag32_ffi_write_check_lengths s).R 5w = s.R 5w - n2w ((ffi_code_start_offset - 1) - output_offset))` - (rw[ag32_ffi_write_check_lengths_def, +Theorem ag32_ffi_write_check_lengths_R: + ((ag32_ffi_write_check_lengths s).R 3w = s.R 3w) ∧ + ((ag32_ffi_write_check_lengths s).R 5w = s.R 5w - n2w ((ffi_code_start_offset - 1) - output_offset)) +Proof + rw[ag32_ffi_write_check_lengths_def, ag32Theory.dfn'Normal_def, ag32Theory.ri2word_def, ag32Theory.incPC_def, ag32Theory.ALU_def, ag32Theory.norm_def, ag32Theory.dfn'LoadConstant_def, ag32Theory.dfn'JumpIfZero_def, APPLY_UPDATE_THM] - \\ EVAL_TAC); + \\ EVAL_TAC +QED val ag32_ffi_write_write_header_def = Define` ag32_ffi_write_write_header s = @@ -2847,8 +2957,8 @@ val ag32_ffi_write_write_header_def = Define` let s = dfn'StoreMEMByte (Imm 0w, Reg 3w) s in s`; -Theorem ag32_ffi_write_write_header_thm - `(s.R 5w = n2w output_offset) ∧ +Theorem ag32_ffi_write_write_header_thm: + (s.R 5w = n2w output_offset) ∧ (LENGTH conf = 8) ∧ (w82n conf < 3) ∧ (s.R 2w = n2w (w82n conf)) ∧ (s.R 1w = n2w (w22n [n1; n0])) ∧ (s.R 3w ≠ n2w output_offset) ⇒ @@ -2861,8 +2971,9 @@ Theorem ag32_ffi_write_write_header_thm (((s.R 3w) =+ 0w) (asm_write_bytearray (n2w output_offset) (conf ++ [0w; 0w; n1; n0]) s.MEM)); OverflowFlag := ov; - CarryFlag := cf |>)` - (rewrite_tac[ag32_ffi_write_write_header_def] + CarryFlag := cf |>) +Proof + rewrite_tac[ag32_ffi_write_write_header_def] \\ strip_tac \\ simp_tac (srw_ss()) [Q.SPECL[]ag32Theory.dfn'StoreMEM_def, @@ -3056,11 +3167,13 @@ Theorem ag32_ffi_write_write_header_thm full_simp_tac std_ss [n2w_11] \\ rfs[] \\ fs[MarshallingTheory.w82n_def] \\ Cases_on`h` \\ fs[] \\ rveq \\ Cases_on`n'` \\ fs[]) - \\ simp[]); + \\ simp[] +QED -Theorem ag32_ffi_write_write_header_PC - `(ag32_ffi_write_write_header s).PC = s.PC + n2w(4 * LENGTH ag32_ffi_write_write_header_code)` - (rw[ag32_ffi_write_write_header_def] +Theorem ag32_ffi_write_write_header_PC: + (ag32_ffi_write_write_header s).PC = s.PC + n2w(4 * LENGTH ag32_ffi_write_write_header_code) +Proof + rw[ag32_ffi_write_write_header_def] \\ rw[Once ag32Theory.dfn'StoreMEMByte_def, ag32Theory.incPC_def] \\ rw[dfn'Normal_PC, dfn'Shift_PC, dfn'LoadConstant_PC] \\ rw[Once ag32Theory.dfn'StoreMEMByte_def, ag32Theory.incPC_def] @@ -3075,11 +3188,13 @@ Theorem ag32_ffi_write_write_header_PC \\ rw[dfn'Normal_PC, dfn'Shift_PC, dfn'LoadConstant_PC] \\ rw[Once ag32Theory.dfn'StoreMEM_def, ag32Theory.incPC_def] \\ rw[dfn'Normal_PC, dfn'Shift_PC, dfn'LoadConstant_PC] - \\ EVAL_TAC); + \\ EVAL_TAC +QED -Theorem ag32_ffi_write_write_header_R - `((ag32_ffi_write_write_header s).R 3w = s.R 3w)` - (rw[ag32_ffi_write_write_header_def] +Theorem ag32_ffi_write_write_header_R: + ((ag32_ffi_write_write_header s).R 3w = s.R 3w) +Proof + rw[ag32_ffi_write_write_header_def] \\ rw[Once ag32Theory.dfn'StoreMEMByte_def, ag32Theory.incPC_def] \\ rw[Once ag32Theory.dfn'Normal_def, ag32Theory.incPC_def, ag32Theory.norm_def, ag32Theory.ALU_def, APPLY_UPDATE_THM] \\ rw[Once ag32Theory.dfn'StoreMEMByte_def, ag32Theory.incPC_def] @@ -3096,7 +3211,8 @@ Theorem ag32_ffi_write_write_header_R \\ rw[Once ag32Theory.dfn'Normal_def, ag32Theory.incPC_def, ag32Theory.norm_def, ag32Theory.ALU_def, APPLY_UPDATE_THM] \\ rw[Once ag32Theory.dfn'StoreMEM_def, ag32Theory.incPC_def] \\ rw[Once ag32Theory.dfn'Normal_def, ag32Theory.incPC_def, ag32Theory.norm_def, ag32Theory.ALU_def, APPLY_UPDATE_THM] - \\ rw[ag32Theory.dfn'LoadConstant_def, ag32Theory.incPC_def, APPLY_UPDATE_THM]); + \\ rw[ag32Theory.dfn'LoadConstant_def, ag32Theory.incPC_def, APPLY_UPDATE_THM] +QED val ag32_ffi_write_num_written_def = Define` ag32_ffi_write_num_written s = @@ -3113,8 +3229,8 @@ val ag32_ffi_write_num_written_def = Define` let s = dfn'LoadConstant (2w, F, 4w * 9w) s in s`; -Theorem ag32_ffi_write_num_written_thm - `bytes_in_memory (s.R 3w) (0w::n0::off1::off0::tll) s.MEM md ∧ +Theorem ag32_ffi_write_num_written_thm: + bytes_in_memory (s.R 3w) (0w::n0::off1::off0::tll) s.MEM md ∧ (s.R 1w = n2w n) ∧ (k = MIN n output_buffer_size) ∧ n < dimword(:16) ⇒ ∃r8 cf ov. @@ -3126,8 +3242,9 @@ Theorem ag32_ffi_write_num_written_thm ((2w =+ 4w * 9w) ((1w =+ n2w k) s.R)))); CarryFlag := cf; - OverflowFlag := ov |>)` - (rewrite_tac[ag32_ffi_write_num_written_def] + OverflowFlag := ov |>) +Proof + rewrite_tac[ag32_ffi_write_num_written_def] \\ strip_tac \\ simp_tac (srw_ss()) [Q.SPECL[]ag32Theory.dfn'Normal_def, @@ -3214,7 +3331,8 @@ Theorem ag32_ffi_write_num_written_thm \\ match_mp_tac (blastLib.BBLAST_PROVE ``w <+ 256w:word32 /\ (k = w2w w) ==> ((7 >< 0) w = k:word8)``) \\ rewrite_tac [w2w_def,w2n_lsr,WORD_LO] - \\ fs [DIV_LT_X]); + \\ fs [DIV_LT_X] +QED val ag32_ffi_write_def = Define` ag32_ffi_write s = @@ -3341,12 +3459,13 @@ val mk_jump_ag32_code_def = Define` Encode(Jump (fSub, 5w, Reg 5w)); 0w]`; -Theorem EL_FLAT_MAP_mk_jump_ag32_code - `∀ls index. +Theorem EL_FLAT_MAP_mk_jump_ag32_code: + ∀ls index. (INDEX_OF nm ls = SOME index) ∧ k < 4 ⇒ (EL (4 * index + k) (FLAT (MAP (mk_jump_ag32_code nmns) ls)) = - EL k (mk_jump_ag32_code nmns nm))` - (Induct + EL k (mk_jump_ag32_code nmns nm)) +Proof + Induct >- ( rw[GSYM find_index_INDEX_OF, find_index_def] ) \\ rw[GSYM find_index_INDEX_OF, find_index_def] >- ( @@ -3359,7 +3478,8 @@ Theorem EL_FLAT_MAP_mk_jump_ag32_code \\ simp[EL_APPEND_EQN] \\ simp[Once mk_jump_ag32_code_def] \\ simp[Once mk_jump_ag32_code_def] - \\ simp[LEFT_ADD_DISTRIB]); + \\ simp[LEFT_ADD_DISTRIB] +QED val ccache_jump_ag32_code_def = Define` ccache_jump_ag32_code = [Encode (Jump (fSnd, 0w, Reg 0w)); 0w; 0w; 0w]`; @@ -3399,9 +3519,11 @@ val ag32_ffi_code_def = Define` val LENGTH_ag32_ffi_code = ``LENGTH ag32_ffi_code`` |> EVAL |> curry save_thm "LENGTH_ag32_ffi_code" -Theorem LENGTH_ag32_ffi_code_check - `4 * LENGTH ag32_ffi_code = length_ag32_ffi_code` - (simp[LENGTH_ag32_ffi_code] \\ EVAL_TAC); +Theorem LENGTH_ag32_ffi_code_check: + 4 * LENGTH ag32_ffi_code = length_ag32_ffi_code +Proof + simp[LENGTH_ag32_ffi_code] \\ EVAL_TAC +QED val code_start_offset_def = Define` code_start_offset num_ffis = diff --git a/compiler/backend/ag32/proofs/ag32_basis_ffiProofScript.sml b/compiler/backend/ag32/proofs/ag32_basis_ffiProofScript.sml index 64f95ab8ae..168ce50ca3 100644 --- a/compiler/backend/ag32/proofs/ag32_basis_ffiProofScript.sml +++ b/compiler/backend/ag32/proofs/ag32_basis_ffiProofScript.sml @@ -13,31 +13,36 @@ val _ = new_theory"ag32_basis_ffiProof"; (* TODO: move *) -Theorem INDEX_OF_IMP_EL - `!xs x index. (INDEX_OF x xs = SOME index) ==> (EL index xs = x)` - (rw [GSYM find_index_INDEX_OF] +Theorem INDEX_OF_IMP_EL: + !xs x index. (INDEX_OF x xs = SOME index) ==> (EL index xs = x) +Proof + rw [GSYM find_index_INDEX_OF] \\ imp_res_tac find_index_LESS_LENGTH \\ fs[] \\ imp_res_tac find_index_is_MEM \\ imp_res_tac find_index_MEM \\ first_x_assum (qspec_then `0` mp_tac) - \\ fs []); + \\ fs [] +QED -Theorem INDEX_OF_REVERSE - `ALL_DISTINCT ls ⇒ - INDEX_OF x (REVERSE ls) = OPTION_MAP (λn. LENGTH ls - 1 - n) (INDEX_OF x ls)` - (rw[GSYM find_index_INDEX_OF] +Theorem INDEX_OF_REVERSE: + ALL_DISTINCT ls ⇒ + INDEX_OF x (REVERSE ls) = OPTION_MAP (λn. LENGTH ls - 1 - n) (INDEX_OF x ls) +Proof + rw[GSYM find_index_INDEX_OF] \\ Cases_on`find_index x ls 0` >- ( fs[GSYM find_index_NOT_MEM] ) \\ imp_res_tac find_index_ALL_DISTINCT_REVERSE - \\ fs[]); + \\ fs[] +QED -Theorem bytes_in_memory_UPDATE_GT ` - k <+ (pc:word32) ∧ +Theorem bytes_in_memory_UPDATE_GT: + k <+ (pc:word32) ∧ LENGTH ls <= 2**31 ∧ ¬word_msb pc ∧ bytes_in_memory pc ls m dm ⇒ - bytes_in_memory pc ls ((k =+ v)m) dm` - (rw[]>> + bytes_in_memory pc ls ((k =+ v)m) dm +Proof + rw[]>> match_mp_tac bytes_in_memory_change_mem>> asm_exists_tac>>fs[APPLY_UPDATE_THM]>> ntac 2 strip_tac>> @@ -47,15 +52,17 @@ Theorem bytes_in_memory_UPDATE_GT ` fs[WORD_LS]>> DEP_REWRITE_TAC [w2n_add]>> fs[word_msb_n2w_numeric])>> - rw[]>>fs[WORD_LOWER_REFL]); + rw[]>>fs[WORD_LOWER_REFL] +QED -Theorem bytes_in_memory_UPDATE_LT ` - (w2n pc + (LENGTH ls) <= w2n (k:word32)) ∧ +Theorem bytes_in_memory_UPDATE_LT: + (w2n pc + (LENGTH ls) <= w2n (k:word32)) ∧ LENGTH ls <= 2**31 ∧ ¬word_msb pc ∧ bytes_in_memory pc ls m dm ⇒ - bytes_in_memory pc ls ((k =+ v)m) dm` - (rw[]>> + bytes_in_memory pc ls ((k =+ v)m) dm +Proof + rw[]>> match_mp_tac bytes_in_memory_change_mem>> asm_exists_tac>>fs[APPLY_UPDATE_THM]>> ntac 2 strip_tac>> @@ -64,16 +71,18 @@ Theorem bytes_in_memory_UPDATE_LT ` CCONTR_TAC>> pop_assum kall_tac>> pop_assum mp_tac>> DEP_REWRITE_TAC [w2n_add]>> - fs[word_msb_n2w_numeric]); + fs[word_msb_n2w_numeric] +QED -Theorem bytes_in_memory_asm_write_bytearray_LT ` - (w2n pc + (LENGTH ls) <= w2n (k:word32)) ∧ +Theorem bytes_in_memory_asm_write_bytearray_LT: + (w2n pc + (LENGTH ls) <= w2n (k:word32)) ∧ (w2n k + (LENGTH bs) < dimword(:32))∧ LENGTH ls <= 2**31 ∧ ¬word_msb pc ∧ bytes_in_memory pc ls m dm ⇒ - bytes_in_memory pc ls (asm_write_bytearray k bs m) dm` - (rw[]>> + bytes_in_memory pc ls (asm_write_bytearray k bs m) dm +Proof + rw[]>> match_mp_tac bytes_in_memory_change_mem>> asm_exists_tac>>fs[APPLY_UPDATE_THM]>> ntac 2 strip_tac>> @@ -84,18 +93,21 @@ Theorem bytes_in_memory_asm_write_bytearray_LT ` simp[]>> DISJ1_TAC>>simp[WORD_LO]>> DEP_REWRITE_TAC [w2n_add]>> - fs[word_msb_n2w_numeric]); + fs[word_msb_n2w_numeric] +QED -Theorem asm_write_bytearray_UPDATE ` - x ≠ pc ⇒ +Theorem asm_write_bytearray_UPDATE: + x ≠ pc ⇒ asm_write_bytearray a ls ((pc =+ v) m) x = - asm_write_bytearray a ls m x` - (rw[]>> + asm_write_bytearray a ls m x +Proof + rw[]>> match_mp_tac mem_eq_imp_asm_write_bytearray_eq >> - fs[APPLY_UPDATE_THM]); + fs[APPLY_UPDATE_THM] +QED -Theorem set_mem_word_asm_write_bytearray_commute_LT ` - (pc <+ a) ∧ +Theorem set_mem_word_asm_write_bytearray_commute_LT: + (pc <+ a) ∧ (pc+1w <+ a) ∧ (pc+2w <+ a) ∧ (pc+3w <+ a) ∧ @@ -103,21 +115,25 @@ Theorem set_mem_word_asm_write_bytearray_commute_LT ` ⇒ set_mem_word pc w (asm_write_bytearray a ls m) = - asm_write_bytearray a ls (set_mem_word pc w m)` - (rw[FUN_EQ_THM]>> + asm_write_bytearray a ls (set_mem_word pc w m) +Proof + rw[FUN_EQ_THM]>> imp_res_tac asm_write_bytearray_unchanged>> fs[set_mem_word_def]>> simp[APPLY_UPDATE_THM]>> rw[]>>fs[APPLY_UPDATE_THM]>> - metis_tac[asm_write_bytearray_UPDATE]); + metis_tac[asm_write_bytearray_UPDATE] +QED -Theorem asm_write_bytearray_append2 - `∀a l1 l2 m. +Theorem asm_write_bytearray_append2: + ∀a l1 l2 m. (asm_write_bytearray (a:word32) (l1 ++ l2) m = - asm_write_bytearray a l1 (asm_write_bytearray (a + n2w (LENGTH l1)) l2 m))` - (Induct_on`l1` \\ rw[asm_write_bytearray_def] + asm_write_bytearray a l1 (asm_write_bytearray (a + n2w (LENGTH l1)) l2 m)) +Proof + Induct_on`l1` \\ rw[asm_write_bytearray_def] \\ AP_TERM_TAC - \\ fs[ADD1,GSYM word_add_n2w]); + \\ fs[ADD1,GSYM word_add_n2w] +QED val _ = temp_overload_on("nxt", ``λmc n ms. FUNPOW mc.target.next n ms``); @@ -172,8 +188,8 @@ val interference_implemented_def = Define` (mc.target.get_byte (FUNPOW mc.target.next k ms) x = mc.target.get_byte ms x))`; -Theorem evaluate_Halt_FUNPOW_next - `∀mc (ffi:'ffi ffi_state) k ms t ms' ffi'. +Theorem evaluate_Halt_FUNPOW_next: + ∀mc (ffi:'ffi ffi_state) k ms t ms' ffi'. interference_implemented mc ffi_rel md ms ∧ ffi_rel ms ffi ∧ (evaluate mc ffi k ms = (Halt t, ms', ffi')) ⇒ ∃k'. (ms' = FUNPOW mc.target.next k' ms) ∧ @@ -181,8 +197,9 @@ Theorem evaluate_Halt_FUNPOW_next (∀x. x ∉ md ∪ mc.prog_addresses ⇒ (mc.target.get_byte ms' x = mc.target.get_byte ms x)) ∧ ((∀x. t ≠ FFI_outcome x) ⇒ (mc.target.get_pc ms' = mc.halt_pc)) ∧ (((mc.target.get_reg ms' mc.ptr_reg = 0w) ∧ (∀x. t ≠ FFI_outcome x)) - ⇒ (t = Success))` - (ho_match_mp_tac targetSemTheory.evaluate_ind + ⇒ (t = Success)) +Proof + ho_match_mp_tac targetSemTheory.evaluate_ind \\ rpt gen_tac \\ strip_tac \\ rpt gen_tac @@ -313,10 +330,11 @@ Theorem evaluate_Halt_FUNPOW_next \\ first_x_assum match_mp_tac \\ fs [] \\ fs [targetSemTheory.read_ffi_bytearrays_def] \\ imp_res_tac targetPropsTheory.read_ffi_bytearray_IMP_SUBSET_prog_addresses - \\ fs [SUBSET_DEF] \\ metis_tac [])); + \\ fs [SUBSET_DEF] \\ metis_tac []) +QED -Theorem machine_sem_Terminate_FUNPOW_next - `interference_implemented mc ffi_rel md ms ∧ +Theorem machine_sem_Terminate_FUNPOW_next: + interference_implemented mc ffi_rel md ms ∧ (ffi_rel ms st) ∧ machine_sem mc (st:'ffi ffi_state) ms (Terminate t io_events) ⇒ ∃k st'. @@ -324,29 +342,36 @@ Theorem machine_sem_Terminate_FUNPOW_next (∀x. x ∉ md ∪ mc.prog_addresses ⇒ (mc.target.get_byte (nxt mc k ms) x = mc.target.get_byte ms x)) ∧ ((∀x. t ≠ FFI_outcome x) ⇒ (mc.target.get_pc (nxt mc k ms) = mc.halt_pc)) ∧ ((mc.target.get_reg (nxt mc k ms) mc.ptr_reg = 0w) ∧ (∀x. t ≠ FFI_outcome x) - ⇒ (t = Success))` - (rw[targetSemTheory.machine_sem_def] + ⇒ (t = Success)) +Proof + rw[targetSemTheory.machine_sem_def] \\ imp_res_tac evaluate_Halt_FUNPOW_next - \\ rfs[] \\ PROVE_TAC[]); + \\ rfs[] \\ PROVE_TAC[] +QED -Theorem word_of_bytes_extract_bytes_le_32 - `word_of_bytes F 0w [(7 >< 0) w; (15 >< 8) w; (23 >< 16) w; (31 >< 24) w] = w : word32` - (rw[word_of_bytes_def] +Theorem word_of_bytes_extract_bytes_le_32: + word_of_bytes F 0w [(7 >< 0) w; (15 >< 8) w; (23 >< 16) w; (31 >< 24) w] = w : word32 +Proof + rw[word_of_bytes_def] \\ rw[set_byte_def,byte_index_def,word_slice_alt_def] - \\ blastLib.BBLAST_TAC); + \\ blastLib.BBLAST_TAC +QED -Theorem bytes_in_mem_bytes_in_memory - `∀a bs m md k. bytes_in_mem a bs m md k ⇔ bytes_in_memory a bs m (md DIFF k)` - (Induct_on`bs` \\ EVAL_TAC \\ rw[] - \\ rw[EQ_IMP_THM]); +Theorem bytes_in_mem_bytes_in_memory: + ∀a bs m md k. bytes_in_mem a bs m md k ⇔ bytes_in_memory a bs m (md DIFF k) +Proof + Induct_on`bs` \\ EVAL_TAC \\ rw[] + \\ rw[EQ_IMP_THM] +QED -Theorem read_bytearray_IMP_bytes_in_memory_WORD_LOWER - `∀p n m ba m' md. +Theorem read_bytearray_IMP_bytes_in_memory_WORD_LOWER: + ∀p n m ba m' md. (n = LENGTH ba) ∧ w2n p + n < dimword(:'a) ∧ (∀k. (p <=+ k ∧ k <+ p + n2w n) ⇒ k ∈ md ∧ (m k = SOME (m' k))) ∧ (read_bytearray (p:'a word) n m = SOME ba) ⇒ - bytes_in_memory p ba m' md` - (Induct_on`ba` \\ rw[] >- EVAL_TAC + bytes_in_memory p ba m' md +Proof + Induct_on`ba` \\ rw[] >- EVAL_TAC \\ simp[bytes_in_memory_def] \\ fs[read_bytearray_def, CaseEq"option"] \\ first_assum(qspec_then`p`mp_tac) @@ -362,21 +387,25 @@ Theorem read_bytearray_IMP_bytes_in_memory_WORD_LOWER \\ Cases \\ strip_tac \\ first_x_assum irule \\ simp[WORD_LOWER_EQ_REFL, word_ls_n2w] - \\ fs[word_lo_n2w, word_ls_n2w] \\ rfs[]); + \\ fs[word_lo_n2w, word_ls_n2w] \\ rfs[] +QED -Theorem bytes_in_memory_IMP_asm_write_bytearray - `!bs a m. bytes_in_memory a bs m md ==> (asm_write_bytearray a bs m = m)` - (rw [FUN_EQ_THM] +Theorem bytes_in_memory_IMP_asm_write_bytearray: + !bs a m. bytes_in_memory a bs m md ==> (asm_write_bytearray a bs m = m) +Proof + rw [FUN_EQ_THM] \\ irule asm_write_bytearray_id - \\ metis_tac [bytes_in_memory_EL]); + \\ metis_tac [bytes_in_memory_EL] +QED -Theorem IMP_word_list - `8 <= dimindex(:'a) ⇒ +Theorem IMP_word_list: + 8 <= dimindex(:'a) ⇒ ∀p ls m. (m = IMAGE (λk. (p + n2w k * (bytes_in_word:'a word), EL k ls)) (count (LENGTH ls))) ∧ w2n p + LENGTH ls * w2n (bytes_in_word:'a word) < dimword(:'a) - ⇒ word_list p ls m` - (strip_tac + ⇒ word_list p ls m +Proof + strip_tac \\ Induct_on`ls` \\ rw[word_list_def] >- EVAL_TAC \\ fs[] \\ first_x_assum(qspec_then`p + bytes_in_word`mp_tac) @@ -431,7 +460,8 @@ Theorem IMP_word_list \\ `dimindex(:'a) = 1 * dimindex(:'a)` by fs[] \\ pop_assum(CONV_TAC o LAND_CONV o REWR_CONV) \\ irule bitTheory.LESS_MULT_MONO2 - \\ simp[]); + \\ simp[] +QED (* Theorem align_eq_0_imp @@ -451,23 +481,27 @@ Theorem align_eq_0_imp \\ fs[MULT] *) -Theorem asm_step_target_configured - `asm_step c s1 i s2 ∧ target_configured s1 mc ⇒ - target_configured s2 mc` - (rw[asmSemTheory.asm_step_def] - \\ fs[targetSemTheory.target_configured_def]); +Theorem asm_step_target_configured: + asm_step c s1 i s2 ∧ target_configured s1 mc ⇒ + target_configured s2 mc +Proof + rw[asmSemTheory.asm_step_def] + \\ fs[targetSemTheory.target_configured_def] +QED -Theorem RTC_asm_step_target_configured - `RTC (λs1 s2. ∃i. asm_step c s1 i s2) s1 s2 ∧ +Theorem RTC_asm_step_target_configured: + RTC (λs1 s2. ∃i. asm_step c s1 i s2) s1 s2 ∧ target_configured s1 mc ⇒ - target_configured s2 mc` - (rw[] + target_configured s2 mc +Proof + rw[] \\ first_assum(mp_then (Pat`RTC`) mp_tac (GEN_ALL RTC_lifts_invariants)) \\ disch_then ho_match_mp_tac \\ rw[] - \\ metis_tac[asm_step_target_configured]); + \\ metis_tac[asm_step_target_configured] +QED -Theorem ag32_io_events_unchanged - `Decode ( +Theorem ag32_io_events_unchanged: + Decode ( let v : word32 = (31 >< 2) ms.PC : word30 @@ (0w:word2) in (ms.MEM (v + 3w) @@ ((ms.MEM (v + 2w) @@ @@ -475,8 +509,9 @@ Theorem ag32_io_events_unchanged ms.MEM (v + 0w)) : word16)) : word24))) ≠ Interrupt ⇒ - ((Next ms).io_events = ms.io_events) ` - (rw[ag32Theory.Next_def] + ((Next ms).io_events = ms.io_events) +Proof + rw[ag32Theory.Next_def] \\ rw[ag32Theory.Run_def] \\ PURE_CASE_TAC \\ fs[] \\ TRY(PairCases_on`p`) \\ rw[ @@ -497,13 +532,15 @@ Theorem ag32_io_events_unchanged ag32Theory.dfn'StoreMEM_def, ag32Theory.dfn'StoreMEMByte_def, ag32Theory.incPC_def] - \\ PURE_CASE_TAC \\ fs[] \\ rw[]); + \\ PURE_CASE_TAC \\ fs[] \\ rw[] +QED -Theorem ag32_enc_not_Interrupt - `4 * k < LENGTH (ag32_enc istr) ⇒ +Theorem ag32_enc_not_Interrupt: + 4 * k < LENGTH (ag32_enc istr) ⇒ let bs = DROP (4 * k) (ag32_enc istr) in - Decode (EL 3 bs @@ ((EL 2 bs @@ ((EL 1 bs @@ EL 0 bs) : word16)) : word24)) ≠ Interrupt` - (Cases_on`istr` + Decode (EL 3 bs @@ ((EL 2 bs @@ ((EL 1 bs @@ EL 0 bs) : word16)) : word24)) ≠ Interrupt +Proof + Cases_on`istr` \\ TRY(rename1`JumpCmp _ _ ri _` \\ Cases_on`ri`) \\ TRY(rename1`Inst i ` \\ Cases_on`i`) \\ TRY(rename1`Inst (Mem m _ ri) ` \\ Cases_on`m` \\ Cases_on`ri`) @@ -522,16 +559,18 @@ Theorem ag32_enc_not_Interrupt \\ qmatch_asmsub_rename_tac`4 * SUC (SUC k) < _` \\ Cases_on`k` \\ fs[ag32_targetProofTheory.concat_bytes, ag32_targetProofTheory.Decode_Encode] \\ qmatch_asmsub_rename_tac`4 * SUC (SUC (SUC k)) < _` - \\ Cases_on`k` \\ fs[ag32_targetProofTheory.concat_bytes, ag32_targetProofTheory.Decode_Encode]); + \\ Cases_on`k` \\ fs[ag32_targetProofTheory.concat_bytes, ag32_targetProofTheory.Decode_Encode] +QED -Theorem RTC_asm_step_ag32_target_state_rel_io_events - `target_state_rel ag32_target s1 ms ∧ +Theorem RTC_asm_step_ag32_target_state_rel_io_events: + target_state_rel ag32_target s1 ms ∧ RTC (λs1 s2. ∃i. asm_step ag32_config s1 i s2) s1 s2 ⇒ ∃n. target_state_rel ag32_target s2 (FUNPOW Next n ms) ∧ ((FUNPOW Next n ms).io_events = ms.io_events) ∧ - (∀x. x ∉ s1.mem_domain ⇒ ((FUNPOW Next n ms).MEM x = ms.MEM x))` - (once_rewrite_tac[CONJ_COMM] + (∀x. x ∉ s1.mem_domain ⇒ ((FUNPOW Next n ms).MEM x = ms.MEM x)) +Proof + once_rewrite_tac[CONJ_COMM] \\ rewrite_tac[GSYM AND_IMP_INTRO] \\ qid_spec_tac`ms` \\ simp[RIGHT_FORALL_IMP_THM] @@ -642,7 +681,8 @@ Theorem RTC_asm_step_ag32_target_state_rel_io_events \\ drule ag32_enc_not_Interrupt \\ simp[] \\ first_x_assum(qspec_then`0`mp_tac) - \\ simp[]); + \\ simp[] +QED val read_bytearray_IMP_domain = store_thm("read_bytearray_IMP_domain", (* replace uses with read_bytearray_IMP_mem_SOME *) ``!n a xs. @@ -656,20 +696,24 @@ val read_bytearray_IMP_domain = store_thm("read_bytearray_IMP_domain", (* replac (* -- *) -Theorem startup_asm_code_small_enough - `∀i. LENGTH (ag32_enc i) * LENGTH (startup_asm_code n cl bl) ≤ startup_code_size` - (gen_tac (* change startup_code_size definition if this does not go through *) +Theorem startup_asm_code_small_enough: + ∀i. LENGTH (ag32_enc i) * LENGTH (startup_asm_code n cl bl) ≤ startup_code_size +Proof + gen_tac (* change startup_code_size definition if this does not go through *) \\ qspec_then`i`mp_tac (Q.GEN`istr`ag32_enc_lengths) - \\ rw[LENGTH_startup_asm_code, startup_code_size_def]); + \\ rw[LENGTH_startup_asm_code, startup_code_size_def] +QED (* TODO: this is not true until exit is implemented -Theorem FFI_codes_covers_basis_ffi - `∀name st conf bytes. basis_ffi_oracle name st conf bytes ≠ Oracle_final FFI_failed ⇒ name ∈ set (MAP FST FFI_codes)` - (rw[basis_ffiTheory.basis_ffi_oracle_def] +Theorem FFI_codes_covers_basis_ffi: + ∀name st conf bytes. basis_ffi_oracle name st conf bytes ≠ Oracle_final FFI_failed ⇒ name ∈ set (MAP FST FFI_codes) +Proof + rw[basis_ffiTheory.basis_ffi_oracle_def] \\ pairarg_tac \\ fs[] \\ rveq \\ simp[FFI_codes_def] \\ pop_assum mp_tac - \\ rpt(IF_CASES_TAC \\ fs[])); + \\ rpt(IF_CASES_TAC \\ fs[]) +QED *) val get_output_io_event_def = Define` @@ -698,11 +742,12 @@ val get_ag32_io_event_def = Define` val is_ag32_init_state_def = ag32_targetTheory.is_ag32_init_state_def; -Theorem target_state_rel_ag32_init - `is_ag32_init_state m ms ⇒ +Theorem target_state_rel_ag32_init: + is_ag32_init_state m ms ⇒ target_state_rel ag32_target - (ag32_init_asm_state m md) ms` - (rw[asmPropsTheory.target_state_rel_def] + (ag32_init_asm_state m md) ms +Proof + rw[asmPropsTheory.target_state_rel_def] >- ( rw[ag32_targetTheory.ag32_target_def, ag32_targetTheory.ag32_ok_def] \\ fs[is_ag32_init_state_def] @@ -715,7 +760,8 @@ Theorem target_state_rel_ag32_init \\ ntac 2 (pop_assum mp_tac) \\ EVAL_TAC \\ rw[] \\ EVAL_TAC \\ rw[]) - >- ( pop_assum mp_tac \\ EVAL_TAC )); + >- ( pop_assum mp_tac \\ EVAL_TAC ) +QED val stdin_fs_def = Define` stdin_fs inp = @@ -732,9 +778,10 @@ val stdin_fs_def = Define` ; maxFD := 2 |>`; -Theorem wfFS_stdin_fs - `wfFS (stdin_fs inp)` - (rw[stdin_fs_def, fsFFIPropsTheory.wfFS_def] \\ rw[] +Theorem wfFS_stdin_fs: + wfFS (stdin_fs inp) +Proof + rw[stdin_fs_def, fsFFIPropsTheory.wfFS_def] \\ rw[] \\ rw[fsFFIPropsTheory.liveFS_def,fsFFIPropsTheory.consistentFS_def] \\ rw[fsFFIPropsTheory.live_numchars_def] \\ qmatch_goalsub_abbrev_tac`always P ll` @@ -745,15 +792,18 @@ Theorem wfFS_stdin_fs \\ conj_tac >- ( simp[Abbr`ll`] \\ simp[LGENLIST_EQ_CONS] ) \\ simp[Abbr`P`] - \\ EVAL_TAC); + \\ EVAL_TAC +QED -Theorem STD_streams_stdin_fs - `STD_streams (stdin_fs inp)` - (rw[fsFFIPropsTheory.STD_streams_def] +Theorem STD_streams_stdin_fs: + STD_streams (stdin_fs inp) +Proof + rw[fsFFIPropsTheory.STD_streams_def] \\ qexists_tac`0` \\ rw[stdin_fs_def] \\ rw[] - \\ rw[EQ_IMP_THM]); + \\ rw[EQ_IMP_THM] +QED val ag32_fs_ok_def = Define` ag32_fs_ok fs ⇔ @@ -808,8 +858,8 @@ val extract_writes_def = Define` FLAT (MAP (MAP (CHR o w2n) o THE) (FILTER IS_SOME (MAP (combin$C OPTION_BIND (extract_write fd)) oevents)))`; (* TODO: why is this proof so slow? make it faster? *) -Theorem extract_fs_extract_writes - `∀ls fs fs' off off' out rest. +Theorem extract_fs_extract_writes: + ∀ls fs fs' off off' out rest. (extract_fs fs ls = SOME fs') ∧ (* can only read/write up to output_buffer_size - this could be made more nuanced *) (fs.numchars = LGENLIST (K output_buffer_size) NONE) ∧ @@ -832,8 +882,8 @@ Theorem extract_fs_extract_writes (ALOOKUP fs'.infds fd = SOME (UStream nam, WriteMode, LENGTH out + LENGTH rest)) ∧ (ALOOKUP fs'.inode_tbl (UStream nam) = SOME (out ++ rest)) ⇒ - (extract_writes fd (MAP get_output_io_event ls) = rest)` - ( + (extract_writes fd (MAP get_output_io_event ls) = rest) +Proof Induct >- ( rw[basis_ffiTheory.extract_fs_def, extract_writes_def] @@ -1016,10 +1066,11 @@ Theorem extract_fs_extract_writes \\ first_x_assum irule \\ fs[fsFFIPropsTheory.inFS_fname_def] \\ rw[] \\ PURE_CASE_TAC \\ fs[] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem ag32_ffi_write_thm - `bytes_in_memory (s.R 1w) conf s.MEM md ∧ +Theorem ag32_ffi_write_thm: + bytes_in_memory (s.R 1w) conf s.MEM md ∧ bytes_in_memory (s.R 3w) bytes s.MEM md ∧ Abbrev(md = ag32_prog_addresses (LENGTH ffi_names) lc ld) ∧ LENGTH ffi_names ≤ LENGTH FFI_codes ∧ @@ -1031,8 +1082,8 @@ Theorem ag32_ffi_write_thm ag32_fs_ok fs ∧ (s.PC = n2w (ffi_code_start_offset + THE (ALOOKUP ffi_entrypoints "write"))) ⇒ - (ag32_ffi_write s = ag32_ffi_interfer ffi_names md (index, new_bytes, s))` - ( + (ag32_ffi_write s = ag32_ffi_interfer ffi_names md (index, new_bytes, s)) +Proof simp[ag32_ffi_interfer_def] \\ strip_tac \\ drule INDEX_OF_IMP_EL \\ strip_tac @@ -1568,10 +1619,11 @@ Theorem ag32_ffi_write_thm \\ drule bytes_in_memory_EL \\ disch_then(qspec_then`j + 4`mp_tac) \\ simp[EL_CONS,PRE_SUB1] - \\ simp[GSYM word_add_n2w]); + \\ simp[GSYM word_add_n2w] +QED -Theorem ag32_ffi_read_thm - `bytes_in_memory (s.R 1w) conf s.MEM md ∧ +Theorem ag32_ffi_read_thm: + bytes_in_memory (s.R 1w) conf s.MEM md ∧ bytes_in_memory (s.R 3w) bytes s.MEM md ∧ Abbrev(md = ag32_prog_addresses (LENGTH ffi_names) lc ld) ∧ LENGTH ffi_names ≤ LENGTH FFI_codes ∧ @@ -1583,8 +1635,9 @@ Theorem ag32_ffi_read_thm ag32_fs_ok fs ∧ ag32_stdin_implemented fs s.MEM ∧ (s.PC = n2w (ffi_code_start_offset + THE (ALOOKUP ffi_entrypoints "read"))) ⇒ - (ag32_ffi_read s = ag32_ffi_interfer ffi_names md (index, new_bytes, s))` - (simp[ag32_ffi_interfer_def] + (ag32_ffi_read s = ag32_ffi_interfer ffi_names md (index, new_bytes, s)) +Proof + simp[ag32_ffi_interfer_def] \\ strip_tac \\ drule INDEX_OF_IMP_EL \\ strip_tac \\ simp[ag32_ffi_read_def] @@ -2002,10 +2055,11 @@ Theorem ag32_ffi_read_thm \\ fs[word_ls_n2w, word_lo_n2w, memory_size_def] \\ rfs[EVAL``ffi_code_start_offset``] \\ qpat_x_assum`_ = _ MOD _`mp_tac - \\ simp[]); + \\ simp[] +QED -Theorem ag32_ffi_get_arg_count_thm - `bytes_in_memory (s.R 1w) conf s.MEM md ∧ +Theorem ag32_ffi_get_arg_count_thm: + bytes_in_memory (s.R 1w) conf s.MEM md ∧ bytes_in_memory (s.R 3w) bytes s.MEM md ∧ Abbrev(md = ag32_prog_addresses (LENGTH ffi_names) lc ld) ∧ LENGTH ffi_names ≤ LENGTH FFI_codes ∧ @@ -2017,8 +2071,9 @@ Theorem ag32_ffi_get_arg_count_thm ag32_cline_implemented cl s.MEM ∧ (s.PC = n2w (ffi_code_start_offset + THE (ALOOKUP ffi_entrypoints "get_arg_count"))) ⇒ - (ag32_ffi_get_arg_count s = ag32_ffi_interfer ffi_names md (index, new_bytes, s))` - (simp[ag32_ffi_interfer_def] + (ag32_ffi_get_arg_count s = ag32_ffi_interfer ffi_names md (index, new_bytes, s)) +Proof + simp[ag32_ffi_interfer_def] \\ strip_tac \\ drule INDEX_OF_IMP_EL \\ rw[ag32_ffi_get_arg_count_def] @@ -2037,16 +2092,18 @@ Theorem ag32_ffi_get_arg_count_thm \\ pop_assum kall_tac \\ simp[Abbr`A`] \\ simp[ag32_ffi_mem_update_def] - \\ fs[clFFITheory.ffi_get_arg_count_def]); + \\ fs[clFFITheory.ffi_get_arg_count_def] +QED -Theorem get_mem_arg_thm - `∀cl i a. +Theorem get_mem_arg_thm: + ∀cl i a. bytes_in_memory a (FLAT (MAP (SNOC 0w) cl)) m md ∧ i < LENGTH cl ∧ EVERY (EVERY ((<>)0w)) cl ⇒ get_mem_arg m a i = (a + n2w (SUM (MAP LENGTH (TAKE (i+1) cl)) + i), - EL i cl)` - (Induct \\ simp[] + EL i cl) +Proof + Induct \\ simp[] \\ gen_tac \\ Cases \\ simp[get_mem_arg_def] @@ -2093,10 +2150,11 @@ Theorem get_mem_arg_thm \\ Cases_on`l < LENGTH h` \\ fs[] \\ imp_res_tac bytes_in_memory_EL \\ fs[EVERY_MEM, MEM_EL] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem ag32_ffi_get_arg_length_thm - `bytes_in_memory (s.R 1w) conf s.MEM md ∧ +Theorem ag32_ffi_get_arg_length_thm: + bytes_in_memory (s.R 1w) conf s.MEM md ∧ bytes_in_memory (s.R 3w) bytes s.MEM md ∧ Abbrev(md = ag32_prog_addresses (LENGTH ffi_names) lc ld) ∧ LENGTH ffi_names ≤ LENGTH FFI_codes ∧ @@ -2108,8 +2166,9 @@ Theorem ag32_ffi_get_arg_length_thm ag32_cline_implemented cl s.MEM ∧ (s.PC = n2w (ffi_code_start_offset + THE (ALOOKUP ffi_entrypoints "get_arg_length"))) ⇒ - (ag32_ffi_get_arg_length s = ag32_ffi_interfer ffi_names md (index, new_bytes, s))` - (simp[ag32_ffi_interfer_def] + (ag32_ffi_get_arg_length s = ag32_ffi_interfer ffi_names md (index, new_bytes, s)) +Proof + simp[ag32_ffi_interfer_def] \\ strip_tac \\ drule INDEX_OF_IMP_EL \\ rw[ag32_ffi_get_arg_length_def] @@ -2191,10 +2250,11 @@ Theorem ag32_ffi_get_arg_length_thm \\ pop_assum kall_tac \\ simp[Abbr`A`] \\ simp[ag32_ffi_mem_update_def] - \\ simp[asm_write_bytearray_def, APPLY_UPDATE_THM]); + \\ simp[asm_write_bytearray_def, APPLY_UPDATE_THM] +QED -Theorem ag32_ffi_get_arg_thm - `bytes_in_memory (s.R 1w) conf s.MEM md ∧ +Theorem ag32_ffi_get_arg_thm: + bytes_in_memory (s.R 1w) conf s.MEM md ∧ bytes_in_memory (s.R 3w) bytes s.MEM md ∧ Abbrev(md = ag32_prog_addresses (LENGTH ffi_names) lc ld) ∧ LENGTH ffi_names ≤ LENGTH FFI_codes ∧ @@ -2206,8 +2266,9 @@ Theorem ag32_ffi_get_arg_thm ag32_cline_implemented cl s.MEM ∧ (s.PC = n2w (ffi_code_start_offset + THE (ALOOKUP ffi_entrypoints "get_arg"))) ⇒ - (ag32_ffi_get_arg s = ag32_ffi_interfer ffi_names md (index, new_bytes, s))` - (simp[ag32_ffi_interfer_def] + (ag32_ffi_get_arg s = ag32_ffi_interfer ffi_names md (index, new_bytes, s)) +Proof + simp[ag32_ffi_interfer_def] \\ strip_tac \\ drule INDEX_OF_IMP_EL \\ rw[ag32_ffi_get_arg_def] @@ -2429,10 +2490,11 @@ Theorem ag32_ffi_get_arg_thm \\ disch_then(qspec_then`j + strlen(EL ix cl) - 2`mp_tac) \\ simp[] \\ Cases_on`s.R 3w` \\ simp[word_add_n2w] - \\ simp[EL_CONS, PRE_SUB1]); + \\ simp[EL_CONS, PRE_SUB1] +QED -Theorem ag32_ffi_open_in_thm - `bytes_in_memory (s.R 1w) conf s.MEM md ∧ +Theorem ag32_ffi_open_in_thm: + bytes_in_memory (s.R 1w) conf s.MEM md ∧ bytes_in_memory (s.R 3w) bytes s.MEM md ∧ Abbrev(md = ag32_prog_addresses (LENGTH ffi_names) lc ld) ∧ LENGTH ffi_names ≤ LENGTH FFI_codes ∧ @@ -2444,8 +2506,9 @@ Theorem ag32_ffi_open_in_thm ag32_fs_ok fs ∧ (s.PC = n2w (ffi_code_start_offset + THE (ALOOKUP ffi_entrypoints "open_in"))) ⇒ - (ag32_ffi_open_in s = ag32_ffi_interfer ffi_names md (index, new_bytes, s))` - (simp[ag32_ffi_interfer_def] + (ag32_ffi_open_in s = ag32_ffi_interfer ffi_names md (index, new_bytes, s)) +Proof + simp[ag32_ffi_interfer_def] \\ strip_tac \\ drule INDEX_OF_IMP_EL \\ rw[ag32_ffi_open_in_def,ag32_ffi_fail_def] @@ -2508,10 +2571,11 @@ Theorem ag32_ffi_open_in_thm >> strip_tac>> drule bytes_in_memory_IMP_asm_write_bytearray>> - fs[Abbr`mm`,APPLY_UPDATE_THM]); + fs[Abbr`mm`,APPLY_UPDATE_THM] +QED -Theorem ag32_ffi_open_out_thm - `bytes_in_memory (s.R 1w) conf s.MEM md ∧ +Theorem ag32_ffi_open_out_thm: + bytes_in_memory (s.R 1w) conf s.MEM md ∧ bytes_in_memory (s.R 3w) bytes s.MEM md ∧ Abbrev(md = ag32_prog_addresses (LENGTH ffi_names) lc ld) ∧ LENGTH ffi_names ≤ LENGTH FFI_codes ∧ @@ -2523,8 +2587,9 @@ Theorem ag32_ffi_open_out_thm ag32_fs_ok fs ∧ (s.PC = n2w (ffi_code_start_offset + THE (ALOOKUP ffi_entrypoints "open_out"))) ⇒ - (ag32_ffi_open_out s = ag32_ffi_interfer ffi_names md (index, new_bytes, s))` - (simp[ag32_ffi_interfer_def] + (ag32_ffi_open_out s = ag32_ffi_interfer ffi_names md (index, new_bytes, s)) +Proof + simp[ag32_ffi_interfer_def] \\ strip_tac \\ drule INDEX_OF_IMP_EL \\ rw[ag32_ffi_open_out_def,ag32_ffi_fail_def] @@ -2587,10 +2652,11 @@ Theorem ag32_ffi_open_out_thm >> strip_tac>> drule bytes_in_memory_IMP_asm_write_bytearray>> - fs[Abbr`mm`,APPLY_UPDATE_THM]); + fs[Abbr`mm`,APPLY_UPDATE_THM] +QED -Theorem ag32_ffi_close_thm - `bytes_in_memory (s.R 1w) conf s.MEM md ∧ +Theorem ag32_ffi_close_thm: + bytes_in_memory (s.R 1w) conf s.MEM md ∧ bytes_in_memory (s.R 3w) bytes s.MEM md ∧ Abbrev(md = ag32_prog_addresses (LENGTH ffi_names) lc ld) ∧ LENGTH ffi_names ≤ LENGTH FFI_codes ∧ @@ -2602,8 +2668,9 @@ Theorem ag32_ffi_close_thm ag32_fs_ok fs ∧ (s.PC = n2w (ffi_code_start_offset + THE (ALOOKUP ffi_entrypoints "close"))) ⇒ - (ag32_ffi_close s = ag32_ffi_interfer ffi_names md (index, new_bytes, s))` - (simp[ag32_ffi_interfer_def] + (ag32_ffi_close s = ag32_ffi_interfer ffi_names md (index, new_bytes, s)) +Proof + simp[ag32_ffi_interfer_def] \\ strip_tac \\ drule INDEX_OF_IMP_EL \\ rw[ag32_ffi_close_def,ag32_ffi_fail_def] @@ -2666,10 +2733,11 @@ Theorem ag32_ffi_close_thm >> strip_tac>> drule bytes_in_memory_IMP_asm_write_bytearray>> - fs[Abbr`mm`,APPLY_UPDATE_THM]); + fs[Abbr`mm`,APPLY_UPDATE_THM] +QED -Theorem ag32_ffi__thm - `bytes_in_memory (s.R 1w) conf s.MEM md ∧ +Theorem ag32_ffi__thm: + bytes_in_memory (s.R 1w) conf s.MEM md ∧ bytes_in_memory (s.R 3w) bytes s.MEM md ∧ Abbrev(md = ag32_prog_addresses (LENGTH ffi_names) lc ld) ∧ LENGTH ffi_names ≤ LENGTH FFI_codes ∧ @@ -2679,8 +2747,9 @@ Theorem ag32_ffi__thm (INDEX_OF "" ffi_names = SOME index) ∧ (s.PC = n2w (ffi_code_start_offset + THE (ALOOKUP ffi_entrypoints ""))) ⇒ - (ag32_ffi_ s = ag32_ffi_interfer ffi_names md (index, bytes, s))` - (reverse (rw[ag32_ffi_interfer_def]) + (ag32_ffi_ s = ag32_ffi_interfer ffi_names md (index, bytes, s)) +Proof + reverse (rw[ag32_ffi_interfer_def]) >- (drule INDEX_OF_IMP_EL >> fs[]) >> simp[ag32_ffi__def] @@ -2688,23 +2757,27 @@ Theorem ag32_ffi__thm ag32Theory.norm_def, ag32Theory.ALU_def, ag32Theory.dfn'Interrupt_def, ag32Theory.dfn'Jump_def] \\ rw[ag32Theory.ag32_state_component_equality, APPLY_UPDATE_THM, FUN_EQ_THM] - \\ EVAL_TAC); + \\ EVAL_TAC +QED -Theorem ag32_fs_ok_stdin_fs - `ag32_fs_ok (stdin_fs inp)` - (rw[ag32_fs_ok_def, STD_streams_stdin_fs] +Theorem ag32_fs_ok_stdin_fs: + ag32_fs_ok (stdin_fs inp) +Proof + rw[ag32_fs_ok_def, STD_streams_stdin_fs] \\ rw[stdin_fs_def] - \\ fs[stdin_fs_def, CaseEq"bool"]); + \\ fs[stdin_fs_def, CaseEq"bool"] +QED -Theorem ag32_ffi_rel_write_mem_update - `(ffi_write conf bytes fs = SOME (FFIreturn new_bytes fs')) ∧ +Theorem ag32_ffi_rel_write_mem_update: + (ffi_write conf bytes fs = SOME (FFIreturn new_bytes fs')) ∧ (m ((n2w (ffi_code_start_offset - 1)):word32) = n2w (THE (ALOOKUP FFI_codes "write"))) ∧ ag32_fs_ok fs ⇒ (get_ag32_io_event (ag32_ffi_mem_update "write" conf bytes new_bytes m) - = get_output_io_event (IO_event "write" conf (ZIP (bytes,new_bytes))))` - (rw[] + = get_output_io_event (IO_event "write" conf (ZIP (bytes,new_bytes)))) +Proof + rw[] \\ imp_res_tac fsFFIPropsTheory.ffi_write_length \\ fs[fsFFITheory.ffi_write_def] \\ fs[CaseEq"list"] @@ -2784,12 +2857,14 @@ Theorem ag32_ffi_rel_write_mem_update \\ pop_assum SUBST1_TAC \\ DEP_REWRITE_TAC[asm_write_bytearray_EL] \\ simp[] - \\ simp[MIN_DEF, output_buffer_size_def]); + \\ simp[MIN_DEF, output_buffer_size_def] +QED -Theorem ag32_fs_ok_ffi_write - `(ffi_write conf bytes fs = SOME (FFIreturn bytes' fs')) ∧ ag32_fs_ok fs ⇒ - ag32_fs_ok fs'` - (rw[fsFFITheory.ffi_write_def,CaseEq"list"] +Theorem ag32_fs_ok_ffi_write: + (ffi_write conf bytes fs = SOME (FFIreturn bytes' fs')) ∧ ag32_fs_ok fs ⇒ + ag32_fs_ok fs' +Proof + rw[fsFFITheory.ffi_write_def,CaseEq"list"] \\ fs[ag32_fs_ok_def] \\ `STD_streams fs'` by ( @@ -2854,11 +2929,11 @@ Theorem ag32_fs_ok_ffi_write \\ simp[] \\ NO_TAC ) \\ TRY ( last_x_assum(qspecl_then[`0`,`ReadMode`,`inp`]mp_tac) - \\ simp[] \\ NO_TAC )); + \\ simp[] \\ NO_TAC ) +QED -Theorem ag32_stdin_implemented_ffi_write - ` - STD_streams fs ∧ +Theorem ag32_stdin_implemented_ffi_write: + STD_streams fs ∧ ag32_stdin_implemented fs m ∧ ffi_write conf bytes fs = SOME (FFIreturn bytes' fs') ∧ w2n (ms.R 3w) + LENGTH bytes' < 4294967296 ∧ @@ -2868,8 +2943,9 @@ Theorem ag32_stdin_implemented_ffi_write (ag32_ffi_mem_update "write" conf bytes bytes' (asm_write_bytearray (ms.R 3w) bytes' ((n2w (ffi_code_start_offset - 1) =+ - n2w (THE (ALOOKUP FFI_codes "write"))) m)))` - (rw[ag32_stdin_implemented_def] + n2w (THE (ALOOKUP FFI_codes "write"))) m))) +Proof + rw[ag32_stdin_implemented_def] \\ qexists_tac`off` \\ qexists_tac`inp` \\ simp[] @@ -2931,10 +3007,11 @@ Theorem ag32_stdin_implemented_ffi_write EVAL_TAC>>fs[]>> `5242880+2300 ≤ w2n (ms.R 3w)` suffices_by fs[]>> simp[]>> - fs[WORD_LS,EVAL``heap_start_offset``])); + fs[WORD_LS,EVAL``heap_start_offset``]) +QED -Theorem ag32_cline_implemented_ffi_write - `ag32_cline_implemented cl m ∧ +Theorem ag32_cline_implemented_ffi_write: + ag32_cline_implemented cl m ∧ w2n (ms.R 3w) + LENGTH bytes' < dimword(:32) ∧ n2w heap_start_offset <=+ ms.R 3w ∧ (ffi_write conf bytes fs = SOME (FFIreturn bytes' fs')) @@ -2943,8 +3020,9 @@ Theorem ag32_cline_implemented_ffi_write (ag32_ffi_mem_update "write" conf bytes bytes' (asm_write_bytearray (ms.R 3w) bytes' ((n2w (ffi_code_start_offset - 1) =+ - n2w (THE (ALOOKUP FFI_codes "write"))) m)))` - (simp[ag32_cline_implemented_def] + n2w (THE (ALOOKUP FFI_codes "write"))) m))) +Proof + simp[ag32_cline_implemented_def] \\ strip_tac \\ qmatch_goalsub_abbrev_tac`get_mem_word m'` \\ pop_assum mp_tac @@ -3040,17 +3118,19 @@ Theorem ag32_cline_implemented_ffi_write \\ rw[] \\ pop_assum mp_tac \\ EVAL_TAC - \\ fs[EVAL``cline_size``] ); + \\ fs[EVAL``cline_size``] +QED -Theorem ag32_ffi_rel_read_mem_update - `(ffi_read conf bytes fs = SOME (FFIreturn new_bytes fs')) ∧ +Theorem ag32_ffi_rel_read_mem_update: + (ffi_read conf bytes fs = SOME (FFIreturn new_bytes fs')) ∧ (m ((n2w (ffi_code_start_offset - 1)):word32) = n2w (THE (ALOOKUP FFI_codes "read"))) ∧ ag32_fs_ok fs ⇒ (get_ag32_io_event (ag32_ffi_mem_update "read" conf bytes new_bytes m) - = get_output_io_event (IO_event "read" conf (ZIP (bytes,new_bytes))))` - (rw[] + = get_output_io_event (IO_event "read" conf (ZIP (bytes,new_bytes)))) +Proof + rw[] \\ imp_res_tac fsFFIPropsTheory.ffi_read_length \\ fs[fsFFITheory.ffi_read_def] \\ fs[CaseEq"list"] @@ -3076,12 +3156,14 @@ Theorem ag32_ffi_rel_read_mem_update \\ rveq \\ fs[] \\ reverse(Cases_on`md` \\ fs[LUPDATE_def]) \\ rveq \\ fs[] \\ DEP_ONCE_REWRITE_TAC [set_mem_word_neq]>> fs[]>> - EVAL_TAC); + EVAL_TAC +QED -Theorem ag32_fs_ok_ffi_read - `(ffi_read conf bytes fs = SOME (FFIreturn bytes' fs')) ∧ ag32_fs_ok fs ⇒ - ag32_fs_ok fs'` - (rw[fsFFITheory.ffi_read_def,CaseEq"list"] +Theorem ag32_fs_ok_ffi_read: + (ffi_read conf bytes fs = SOME (FFIreturn bytes' fs')) ∧ ag32_fs_ok fs ⇒ + ag32_fs_ok fs' +Proof + rw[fsFFITheory.ffi_read_def,CaseEq"list"] \\ fs[ag32_fs_ok_def] \\ `STD_streams fs'` by ( @@ -3112,10 +3194,11 @@ Theorem ag32_fs_ok_ffi_read >- ( first_x_assum drule \\ rw[] \\ rw[] - \\ Cases_on`ino = ino'` \\ fs[])); + \\ Cases_on`ino = ino'` \\ fs[]) +QED -Theorem ag32_stdin_implemented_ffi_read - `ag32_fs_ok fs ∧ +Theorem ag32_stdin_implemented_ffi_read: + ag32_fs_ok fs ∧ ag32_stdin_implemented fs m ∧ ffi_read conf bytes fs = SOME (FFIreturn bytes' fs') ∧ w2n (ms.R 3w) + LENGTH bytes' < 4294967296 ∧ @@ -3126,8 +3209,9 @@ Theorem ag32_stdin_implemented_ffi_read (ag32_ffi_mem_update "read" conf bytes bytes' (asm_write_bytearray (ms.R 3w) bytes' ((n2w (ffi_code_start_offset - 1) =+ - n2w (THE (ALOOKUP FFI_codes "read"))) m)))` - (rw[]>>fs[fsFFITheory.ffi_read_def, fsFFITheory.read_def]>> + n2w (THE (ALOOKUP FFI_codes "read"))) m))) +Proof + rw[]>>fs[fsFFITheory.ffi_read_def, fsFFITheory.read_def]>> fs[CaseEq"list"]>> fs[OPTION_CHOICE_EQUALS_OPTION] \\ rveq \\ fs[] \\ rfs[] >- ( @@ -3215,10 +3299,11 @@ Theorem ag32_stdin_implemented_ffi_read `5242880+2300 ≤ w2n (ms.R 3w)` by fs[WORD_LS,EVAL``heap_start_offset``]>> fs[]>> - Cases_on`ms.R 3w` \\ fs[word_lo_n2w]); + Cases_on`ms.R 3w` \\ fs[word_lo_n2w] +QED -Theorem ag32_cline_implemented_ffi_read - `ag32_cline_implemented cl m ∧ +Theorem ag32_cline_implemented_ffi_read: + ag32_cline_implemented cl m ∧ w2n (ms.R 3w) + LENGTH bytes' < dimword(:32) ∧ n2w heap_start_offset <=+ ms.R 3w ∧ (ffi_read conf bytes fs = SOME (FFIreturn bytes' fs')) @@ -3227,8 +3312,9 @@ Theorem ag32_cline_implemented_ffi_read (ag32_ffi_mem_update "read" conf bytes bytes' (asm_write_bytearray (ms.R 3w) bytes' ((n2w (ffi_code_start_offset - 1) =+ - n2w (THE (ALOOKUP FFI_codes "read"))) m)))` - (simp[ag32_cline_implemented_def] + n2w (THE (ALOOKUP FFI_codes "read"))) m))) +Proof + simp[ag32_cline_implemented_def] \\ strip_tac \\ qmatch_goalsub_abbrev_tac`get_mem_word m'` \\ pop_assum mp_tac @@ -3311,32 +3397,38 @@ Theorem ag32_cline_implemented_ffi_read \\ rw[] \\ pop_assum mp_tac \\ EVAL_TAC - \\ fs[EVAL``cline_size``] ); + \\ fs[EVAL``cline_size``] +QED -Theorem ag32_fs_ok_ffi_open_in - `(ffi_open_in conf bytes fs = SOME (FFIreturn bytes' fs')) ∧ ag32_fs_ok fs ⇒ - ag32_fs_ok fs'` - (rw[fsFFITheory.ffi_open_in_def,CaseEq"list"] +Theorem ag32_fs_ok_ffi_open_in: + (ffi_open_in conf bytes fs = SOME (FFIreturn bytes' fs')) ∧ ag32_fs_ok fs ⇒ + ag32_fs_ok fs' +Proof + rw[fsFFITheory.ffi_open_in_def,CaseEq"list"] \\ fs[ag32_fs_ok_def] \\ fs[OPTION_CHOICE_EQUALS_OPTION] \\ rpt(pairarg_tac \\ fs[]) \\ rveq \\ fs[] - \\ fs[fsFFITheory.openFile_def]); + \\ fs[fsFFITheory.openFile_def] +QED -Theorem ag32_fs_ok_ffi_open_out - `(ffi_open_out conf bytes fs = SOME (FFIreturn bytes' fs')) ∧ ag32_fs_ok fs ⇒ - ag32_fs_ok fs'` - (rw[fsFFITheory.ffi_open_out_def,CaseEq"list"] +Theorem ag32_fs_ok_ffi_open_out: + (ffi_open_out conf bytes fs = SOME (FFIreturn bytes' fs')) ∧ ag32_fs_ok fs ⇒ + ag32_fs_ok fs' +Proof + rw[fsFFITheory.ffi_open_out_def,CaseEq"list"] \\ fs[ag32_fs_ok_def] \\ fs[OPTION_CHOICE_EQUALS_OPTION] \\ rpt(pairarg_tac \\ fs[]) \\ rveq \\ fs[] - \\ fs[fsFFITheory.openFile_truncate_def]); + \\ fs[fsFFITheory.openFile_truncate_def] +QED -Theorem ag32_fs_ok_ffi_close - `(ffi_close conf bytes fs = SOME (FFIreturn bytes' fs')) ∧ ag32_fs_ok fs ⇒ - ag32_fs_ok fs'` - (rw[fsFFITheory.ffi_close_def,CaseEq"list"] +Theorem ag32_fs_ok_ffi_close: + (ffi_close conf bytes fs = SOME (FFIreturn bytes' fs')) ∧ ag32_fs_ok fs ⇒ + ag32_fs_ok fs' +Proof + rw[fsFFITheory.ffi_close_def,CaseEq"list"] \\ fs[ag32_fs_ok_def] \\ fs[OPTION_CHOICE_EQUALS_OPTION] \\ rpt(pairarg_tac \\ fs[]) @@ -3345,10 +3437,11 @@ Theorem ag32_fs_ok_ffi_close \\ rveq \\ fs[] \\ simp[ALOOKUP_ADELKEY] \\ pairarg_tac \\ fs[] - \\ metis_tac[NOT_SOME_NONE]); + \\ metis_tac[NOT_SOME_NONE] +QED -Theorem ag32_stdin_implemented_ffi_open_in - `ag32_fs_ok fs ∧ +Theorem ag32_stdin_implemented_ffi_open_in: + ag32_fs_ok fs ∧ ag32_stdin_implemented fs m ∧ ffi_open_in conf bytes fs = SOME (FFIreturn bytes' fs') ∧ w2n (ms.R 3w) + LENGTH bytes' < 4294967296 ∧ @@ -3357,8 +3450,9 @@ Theorem ag32_stdin_implemented_ffi_open_in ag32_stdin_implemented fs' (asm_write_bytearray (ms.R 3w) bytes' ((n2w (ffi_code_start_offset - 1) =+ - n2w (THE (ALOOKUP FFI_codes "open_in"))) m))` - (rw[] + n2w (THE (ALOOKUP FFI_codes "open_in"))) m)) +Proof + rw[] \\ fs[fsFFITheory.ffi_open_in_def] \\ qhdtm_x_assum`OPTION_CHOICE`mp_tac \\ simp[OPTION_CHOICE_EQUALS_OPTION] @@ -3401,10 +3495,11 @@ Theorem ag32_stdin_implemented_ffi_open_in \\ fs[ag32_fs_ok_def] \\ imp_res_tac fsFFIPropsTheory.STD_streams_nextFD \\ simp[] - \\ fs[]); + \\ fs[] +QED -Theorem ag32_cline_implemented_ffi_open_in - `ag32_cline_implemented cl m ∧ +Theorem ag32_cline_implemented_ffi_open_in: + ag32_cline_implemented cl m ∧ w2n (ms.R 3w) + LENGTH bytes' < dimword(:32) ∧ n2w heap_start_offset <=+ ms.R 3w ∧ (ffi_open_in conf bytes fs = SOME (FFIreturn bytes' fs')) @@ -3412,8 +3507,9 @@ Theorem ag32_cline_implemented_ffi_open_in ag32_cline_implemented cl (asm_write_bytearray (ms.R 3w) bytes' ((n2w (ffi_code_start_offset - 1) =+ - n2w (THE (ALOOKUP FFI_codes "open_in"))) m))` - (simp[ag32_cline_implemented_def] + n2w (THE (ALOOKUP FFI_codes "open_in"))) m)) +Proof + simp[ag32_cline_implemented_def] \\ strip_tac \\ conj_tac >- ( @@ -3434,10 +3530,11 @@ Theorem ag32_cline_implemented_ffi_open_in \\ simp[SUM_MAP_PLUS] \\ simp[Q.ISPEC`λx. 1n`SUM_MAP_K |> SIMP_RULE(srw_ss())[]] \\ fs[EVAL``ffi_code_start_offset``] - \\ fs[MAP_MAP_o, o_DEF]); + \\ fs[MAP_MAP_o, o_DEF] +QED -Theorem ag32_stdin_implemented_ffi_open_out - `ag32_fs_ok fs ∧ +Theorem ag32_stdin_implemented_ffi_open_out: + ag32_fs_ok fs ∧ ag32_stdin_implemented fs m ∧ ffi_open_out conf bytes fs = SOME (FFIreturn bytes' fs') ∧ w2n (ms.R 3w) + LENGTH bytes' < 4294967296 ∧ @@ -3446,8 +3543,9 @@ Theorem ag32_stdin_implemented_ffi_open_out ag32_stdin_implemented fs' (asm_write_bytearray (ms.R 3w) bytes' ((n2w (ffi_code_start_offset - 1) =+ - n2w (THE (ALOOKUP FFI_codes "open_out"))) m))` - (rw[] + n2w (THE (ALOOKUP FFI_codes "open_out"))) m)) +Proof + rw[] \\ fs[fsFFITheory.ffi_open_out_def] \\ qhdtm_x_assum`OPTION_CHOICE`mp_tac \\ simp[OPTION_CHOICE_EQUALS_OPTION] @@ -3490,10 +3588,11 @@ Theorem ag32_stdin_implemented_ffi_open_out \\ fs[ag32_fs_ok_def] \\ imp_res_tac fsFFIPropsTheory.STD_streams_nextFD \\ simp[] - \\ fs[]); + \\ fs[] +QED -Theorem ag32_cline_implemented_ffi_open_out - `ag32_cline_implemented cl m ∧ +Theorem ag32_cline_implemented_ffi_open_out: + ag32_cline_implemented cl m ∧ w2n (ms.R 3w) + LENGTH bytes' < dimword(:32) ∧ n2w heap_start_offset <=+ ms.R 3w ∧ (ffi_open_out conf bytes fs = SOME (FFIreturn bytes' fs')) @@ -3501,8 +3600,9 @@ Theorem ag32_cline_implemented_ffi_open_out ag32_cline_implemented cl (asm_write_bytearray (ms.R 3w) bytes' ((n2w (ffi_code_start_offset - 1) =+ - n2w (THE (ALOOKUP FFI_codes "open_out"))) m))` - (simp[ag32_cline_implemented_def] + n2w (THE (ALOOKUP FFI_codes "open_out"))) m)) +Proof + simp[ag32_cline_implemented_def] \\ strip_tac \\ conj_tac >- ( @@ -3523,10 +3623,11 @@ Theorem ag32_cline_implemented_ffi_open_out \\ simp[SUM_MAP_PLUS] \\ simp[Q.ISPEC`λx. 1n`SUM_MAP_K |> SIMP_RULE(srw_ss())[]] \\ fs[EVAL``ffi_code_start_offset``] - \\ fs[MAP_MAP_o, o_DEF]); + \\ fs[MAP_MAP_o, o_DEF] +QED -Theorem ag32_stdin_implemented_ffi_close - `ag32_fs_ok fs ∧ +Theorem ag32_stdin_implemented_ffi_close: + ag32_fs_ok fs ∧ ag32_stdin_implemented fs m ∧ ffi_close conf bytes fs = SOME (FFIreturn bytes' fs') ∧ w2n (ms.R 3w) + LENGTH bytes' < 4294967296 ∧ @@ -3535,8 +3636,9 @@ Theorem ag32_stdin_implemented_ffi_close ag32_stdin_implemented fs' (asm_write_bytearray (ms.R 3w) bytes' ((n2w (ffi_code_start_offset - 1) =+ - n2w (THE (ALOOKUP FFI_codes "close"))) m))` - (rw[] + n2w (THE (ALOOKUP FFI_codes "close"))) m)) +Proof + rw[] \\ fs[fsFFITheory.ffi_close_def] \\ qhdtm_x_assum`OPTION_CHOICE`mp_tac \\ simp[OPTION_CHOICE_EQUALS_OPTION] @@ -3580,10 +3682,11 @@ Theorem ag32_stdin_implemented_ffi_close \\ simp[ALOOKUP_ADELKEY] \\ fs[ag32_fs_ok_def] \\ res_tac - \\ rfs[]); + \\ rfs[] +QED -Theorem ag32_cline_implemented_ffi_close - `ag32_cline_implemented cl m ∧ +Theorem ag32_cline_implemented_ffi_close: + ag32_cline_implemented cl m ∧ w2n (ms.R 3w) + LENGTH bytes' < dimword(:32) ∧ n2w heap_start_offset <=+ ms.R 3w ∧ (ffi_close conf bytes fs = SOME (FFIreturn bytes' fs')) @@ -3591,8 +3694,9 @@ Theorem ag32_cline_implemented_ffi_close ag32_cline_implemented cl (asm_write_bytearray (ms.R 3w) bytes' ((n2w (ffi_code_start_offset - 1) =+ - n2w (THE (ALOOKUP FFI_codes "close"))) m))` - (simp[ag32_cline_implemented_def] + n2w (THE (ALOOKUP FFI_codes "close"))) m)) +Proof + simp[ag32_cline_implemented_def] \\ strip_tac \\ conj_tac >- ( @@ -3613,10 +3717,11 @@ Theorem ag32_cline_implemented_ffi_close \\ simp[SUM_MAP_PLUS] \\ simp[Q.ISPEC`λx. 1n`SUM_MAP_K |> SIMP_RULE(srw_ss())[]] \\ fs[EVAL``ffi_code_start_offset``] - \\ fs[MAP_MAP_o, o_DEF]); + \\ fs[MAP_MAP_o, o_DEF] +QED -Theorem ag32_stdin_implemented_ffi_get_arg_count - `ag32_stdin_implemented fs m ∧ +Theorem ag32_stdin_implemented_ffi_get_arg_count: + ag32_stdin_implemented fs m ∧ ffi_get_arg_count conf bytes (cl:mlstring list) = SOME (FFIreturn bytes' cl') ∧ w2n (ms.R 3w) + LENGTH bytes' < 4294967296 ∧ n2w heap_start_offset <=+ ms.R 3w @@ -3624,8 +3729,9 @@ Theorem ag32_stdin_implemented_ffi_get_arg_count ag32_stdin_implemented fs (asm_write_bytearray (ms.R 3w) bytes' ((n2w (ffi_code_start_offset - 1) =+ - n2w (THE (ALOOKUP FFI_codes "get_arg_count"))) m))` - (rw[] + n2w (THE (ALOOKUP FFI_codes "get_arg_count"))) m)) +Proof + rw[] \\ fs[ag32_stdin_implemented_def] \\ conj_tac >- ( @@ -3646,10 +3752,11 @@ Theorem ag32_stdin_implemented_ffi_get_arg_count \\ fs[EVAL``stdin_size``] \\ fs[word_ls_n2w, word_lo_n2w] \\ DEP_REWRITE_TAC[bytes_in_memory_UPDATE_LT] - \\ fs[] \\ EVAL_TAC \\ fs[] ); + \\ fs[] \\ EVAL_TAC \\ fs[] +QED -Theorem ag32_cline_implemented_ffi_get_arg_count - `ag32_cline_implemented cl m ∧ +Theorem ag32_cline_implemented_ffi_get_arg_count: + ag32_cline_implemented cl m ∧ w2n (ms.R 3w) + LENGTH bytes' < dimword(:32) ∧ n2w heap_start_offset <=+ ms.R 3w ∧ (ffi_get_arg_count conf bytes cl = SOME (FFIreturn bytes' cl')) @@ -3657,8 +3764,9 @@ Theorem ag32_cline_implemented_ffi_get_arg_count ag32_cline_implemented cl' (asm_write_bytearray (ms.R 3w) bytes' ((n2w (ffi_code_start_offset - 1) =+ - n2w (THE (ALOOKUP FFI_codes "get_arg_count"))) m))` - (simp[ag32_cline_implemented_def] + n2w (THE (ALOOKUP FFI_codes "get_arg_count"))) m)) +Proof + simp[ag32_cline_implemented_def] \\ strip_tac \\ fs[clFFITheory.ffi_get_arg_count_def] \\ rveq \\ conj_tac @@ -3680,10 +3788,11 @@ Theorem ag32_cline_implemented_ffi_get_arg_count \\ simp[SUM_MAP_PLUS] \\ simp[Q.ISPEC`λx. 1n`SUM_MAP_K |> SIMP_RULE(srw_ss())[]] \\ fs[EVAL``ffi_code_start_offset``] - \\ fs[MAP_MAP_o, o_DEF]); + \\ fs[MAP_MAP_o, o_DEF] +QED -Theorem ag32_stdin_implemented_ffi_get_arg_length - `ag32_stdin_implemented fs m ∧ +Theorem ag32_stdin_implemented_ffi_get_arg_length: + ag32_stdin_implemented fs m ∧ ffi_get_arg_length conf bytes (cl:mlstring list) = SOME (FFIreturn bytes' cl') ∧ w2n (ms.R 3w) + LENGTH bytes' < 4294967296 ∧ n2w heap_start_offset <=+ ms.R 3w @@ -3691,8 +3800,9 @@ Theorem ag32_stdin_implemented_ffi_get_arg_length ag32_stdin_implemented fs (asm_write_bytearray (ms.R 3w) bytes' ((n2w (ffi_code_start_offset - 1) =+ - n2w (THE (ALOOKUP FFI_codes "get_arg_length"))) m))` - (rw[] + n2w (THE (ALOOKUP FFI_codes "get_arg_length"))) m)) +Proof + rw[] \\ fs[ag32_stdin_implemented_def] \\ conj_tac >- ( @@ -3713,10 +3823,11 @@ Theorem ag32_stdin_implemented_ffi_get_arg_length \\ fs[EVAL``stdin_size``] \\ fs[word_ls_n2w, word_lo_n2w] \\ DEP_REWRITE_TAC[bytes_in_memory_UPDATE_LT] - \\ fs[] \\ EVAL_TAC \\ fs[] ); + \\ fs[] \\ EVAL_TAC \\ fs[] +QED -Theorem ag32_cline_implemented_ffi_get_arg_length - `ag32_cline_implemented cl m ∧ +Theorem ag32_cline_implemented_ffi_get_arg_length: + ag32_cline_implemented cl m ∧ w2n (ms.R 3w) + LENGTH bytes' < dimword(:32) ∧ n2w heap_start_offset <=+ ms.R 3w ∧ (ffi_get_arg_length conf bytes cl = SOME (FFIreturn bytes' cl')) @@ -3724,8 +3835,9 @@ Theorem ag32_cline_implemented_ffi_get_arg_length ag32_cline_implemented cl' (asm_write_bytearray (ms.R 3w) bytes' ((n2w (ffi_code_start_offset - 1) =+ - n2w (THE (ALOOKUP FFI_codes "get_arg_length"))) m))` - (simp[ag32_cline_implemented_def] + n2w (THE (ALOOKUP FFI_codes "get_arg_length"))) m)) +Proof + simp[ag32_cline_implemented_def] \\ strip_tac \\ fs[clFFITheory.ffi_get_arg_length_def] \\ rveq \\ conj_tac @@ -3747,12 +3859,13 @@ Theorem ag32_cline_implemented_ffi_get_arg_length \\ simp[SUM_MAP_PLUS] \\ simp[Q.ISPEC`λx. 1n`SUM_MAP_K |> SIMP_RULE(srw_ss())[]] \\ fs[EVAL``ffi_code_start_offset``] - \\ fs[MAP_MAP_o, o_DEF]); + \\ fs[MAP_MAP_o, o_DEF] +QED (* TODO: many of these theorems could be deduplicated: the assumptions differing between them might not even be necessary *) -Theorem ag32_stdin_implemented_ffi_get_arg - `ag32_stdin_implemented fs m ∧ +Theorem ag32_stdin_implemented_ffi_get_arg: + ag32_stdin_implemented fs m ∧ ffi_get_arg conf bytes (cl:mlstring list) = SOME (FFIreturn bytes' cl') ∧ w2n (ms.R 3w) + LENGTH bytes' < 4294967296 ∧ n2w heap_start_offset <=+ ms.R 3w @@ -3760,8 +3873,9 @@ Theorem ag32_stdin_implemented_ffi_get_arg ag32_stdin_implemented fs (asm_write_bytearray (ms.R 3w) bytes' ((n2w (ffi_code_start_offset - 1) =+ - n2w (THE (ALOOKUP FFI_codes "get_arg"))) m))` - (rw[] + n2w (THE (ALOOKUP FFI_codes "get_arg"))) m)) +Proof + rw[] \\ fs[ag32_stdin_implemented_def] \\ conj_tac >- ( @@ -3782,10 +3896,11 @@ Theorem ag32_stdin_implemented_ffi_get_arg \\ fs[EVAL``stdin_size``] \\ fs[word_ls_n2w, word_lo_n2w] \\ DEP_REWRITE_TAC[bytes_in_memory_UPDATE_LT] - \\ fs[] \\ EVAL_TAC \\ fs[] ); + \\ fs[] \\ EVAL_TAC \\ fs[] +QED -Theorem ag32_cline_implemented_ffi_get_arg - `ag32_cline_implemented cl m ∧ +Theorem ag32_cline_implemented_ffi_get_arg: + ag32_cline_implemented cl m ∧ w2n (ms.R 3w) + LENGTH bytes' < dimword(:32) ∧ n2w heap_start_offset <=+ ms.R 3w ∧ (ffi_get_arg conf bytes cl = SOME (FFIreturn bytes' cl')) @@ -3793,8 +3908,9 @@ Theorem ag32_cline_implemented_ffi_get_arg ag32_cline_implemented cl' (asm_write_bytearray (ms.R 3w) bytes' ((n2w (ffi_code_start_offset - 1) =+ - n2w (THE (ALOOKUP FFI_codes "get_arg"))) m))` - (simp[ag32_cline_implemented_def] + n2w (THE (ALOOKUP FFI_codes "get_arg"))) m)) +Proof + simp[ag32_cline_implemented_def] \\ strip_tac \\ fs[clFFITheory.ffi_get_arg_def] \\ rveq \\ conj_tac @@ -3816,10 +3932,11 @@ Theorem ag32_cline_implemented_ffi_get_arg \\ simp[SUM_MAP_PLUS] \\ simp[Q.ISPEC`λx. 1n`SUM_MAP_K |> SIMP_RULE(srw_ss())[]] \\ fs[EVAL``ffi_code_start_offset``] - \\ fs[MAP_MAP_o, o_DEF]); + \\ fs[MAP_MAP_o, o_DEF] +QED -Theorem ag32_ffi_interfer_write - `ag32_ffi_rel ms ffi ∧ +Theorem ag32_ffi_interfer_write: + ag32_ffi_rel ms ffi ∧ (read_ffi_bytearrays (ag32_machine_config ffi_names lc ld) ms = (SOME conf, SOME bytes)) ∧ (call_FFI ffi "write" conf bytes = FFI_return ffi' bytes') ∧ (INDEX_OF "write" ffi_names = SOME index) ∧ ALL_DISTINCT ffi_names ∧ @@ -3840,8 +3957,9 @@ Theorem ag32_ffi_interfer_write (index,bytes',ms) = FUNPOW Next k ms) ∧ ag32_ffi_rel (FUNPOW Next k ms) ffi' ∧ ∀x. x ∉ ag32_ffi_mem_domain /\ x ∉ all_words (ms.R 3w) (LENGTH bytes) ⇒ - ((FUNPOW Next k ms).MEM x = ms.MEM x)` - (strip_tac + ((FUNPOW Next k ms).MEM x = ms.MEM x) +Proof + strip_tac \\ fs[targetSemTheory.read_ffi_bytearrays_def] \\ fs[targetSemTheory.read_ffi_bytearray_def] \\ fs[EVAL``(ag32_machine_config a b c).ptr2_reg``] @@ -4112,10 +4230,11 @@ Theorem ag32_ffi_interfer_write \\ fs[EVAL``output_buffer_size``] \\ qpat_x_assum`_ ∉ ag32_ffi_mem_domain`mp_tac \\ EVAL_TAC - \\ simp[]); + \\ simp[] +QED -Theorem ag32_ffi_interfer_read - `ag32_ffi_rel ms ffi ∧ (SND ffi.ffi_state = fs) ∧ +Theorem ag32_ffi_interfer_read: + ag32_ffi_rel ms ffi ∧ (SND ffi.ffi_state = fs) ∧ (read_ffi_bytearrays (ag32_machine_config ffi_names lc ld) ms = (SOME conf, SOME bytes)) ∧ (call_FFI ffi "read" conf bytes = FFI_return ffi' bytes') ∧ (INDEX_OF "read" ffi_names = SOME index) ∧ ALL_DISTINCT ffi_names ∧ @@ -4137,8 +4256,9 @@ Theorem ag32_ffi_interfer_read ag32_ffi_rel (FUNPOW Next k ms) ffi' ∧ ∀x. x ∉ ag32_ffi_mem_domain ∧ x ∉ all_words (ms.R 3w) (LENGTH bytes) ⇒ - ((FUNPOW Next k ms).MEM x = ms.MEM x)` - (strip_tac + ((FUNPOW Next k ms).MEM x = ms.MEM x) +Proof + strip_tac \\ fs[targetSemTheory.read_ffi_bytearrays_def] \\ fs[targetSemTheory.read_ffi_bytearray_def] \\ fs[EVAL``(ag32_machine_config a b c).ptr2_reg``] @@ -4385,10 +4505,11 @@ Theorem ag32_ffi_interfer_read \\ simp[APPLY_UPDATE_THM] \\ rw[IN_all_words] \\ qpat_x_assum`_ ∉ _`mp_tac - \\ EVAL_TAC); + \\ EVAL_TAC +QED -Theorem ag32_ffi_interfer_open_in - `ag32_ffi_rel ms ffi ∧ (SND ffi.ffi_state = fs) ∧ +Theorem ag32_ffi_interfer_open_in: + ag32_ffi_rel ms ffi ∧ (SND ffi.ffi_state = fs) ∧ (read_ffi_bytearrays (ag32_machine_config ffi_names lc ld) ms = (SOME conf, SOME bytes)) ∧ (call_FFI ffi "open_in" conf bytes = FFI_return ffi' bytes') ∧ (INDEX_OF "open_in" ffi_names = SOME index) ∧ ALL_DISTINCT ffi_names ∧ @@ -4410,8 +4531,9 @@ Theorem ag32_ffi_interfer_open_in ag32_ffi_rel (FUNPOW Next k ms) ffi' ∧ ∀x. x ∉ ag32_ffi_mem_domain ∧ x ∉ all_words (ms.R 3w) (LENGTH bytes) ⇒ - ((FUNPOW Next k ms).MEM x = ms.MEM x)` - (strip_tac + ((FUNPOW Next k ms).MEM x = ms.MEM x) +Proof + strip_tac \\ fs[targetSemTheory.read_ffi_bytearrays_def] \\ fs[targetSemTheory.read_ffi_bytearray_def] \\ fs[EVAL``(ag32_machine_config a b c).ptr2_reg``] @@ -4598,10 +4720,11 @@ Theorem ag32_ffi_interfer_open_in \\ qpat_x_assum`_ = w2n _`(assume_tac o SYM) \\ fs[] \\ rw[APPLY_UPDATE_THM] \\ qpat_x_assum`_ ∉ ag32_ffi_mem_domain`mp_tac - \\ EVAL_TAC); + \\ EVAL_TAC +QED -Theorem ag32_ffi_interfer_open_out - `ag32_ffi_rel ms ffi ∧ (SND ffi.ffi_state = fs) ∧ +Theorem ag32_ffi_interfer_open_out: + ag32_ffi_rel ms ffi ∧ (SND ffi.ffi_state = fs) ∧ (read_ffi_bytearrays (ag32_machine_config ffi_names lc ld) ms = (SOME conf, SOME bytes)) ∧ (call_FFI ffi "open_out" conf bytes = FFI_return ffi' bytes') ∧ (INDEX_OF "open_out" ffi_names = SOME index) ∧ ALL_DISTINCT ffi_names ∧ @@ -4623,8 +4746,9 @@ Theorem ag32_ffi_interfer_open_out ag32_ffi_rel (FUNPOW Next k ms) ffi' ∧ ∀x. x ∉ ag32_ffi_mem_domain ∧ x ∉ all_words (ms.R 3w) (LENGTH bytes) ⇒ - ((FUNPOW Next k ms).MEM x = ms.MEM x)` - (strip_tac + ((FUNPOW Next k ms).MEM x = ms.MEM x) +Proof + strip_tac \\ fs[targetSemTheory.read_ffi_bytearrays_def] \\ fs[targetSemTheory.read_ffi_bytearray_def] \\ fs[EVAL``(ag32_machine_config a b c).ptr2_reg``] @@ -4805,10 +4929,11 @@ Theorem ag32_ffi_interfer_open_out \\ qpat_x_assum`_ = w2n _`(assume_tac o SYM) \\ fs[] \\ rw[APPLY_UPDATE_THM] \\ qpat_x_assum`_ ∉ ag32_ffi_mem_domain`mp_tac - \\ EVAL_TAC); + \\ EVAL_TAC +QED -Theorem ag32_ffi_interfer_close - `ag32_ffi_rel ms ffi ∧ (SND ffi.ffi_state = fs) ∧ +Theorem ag32_ffi_interfer_close: + ag32_ffi_rel ms ffi ∧ (SND ffi.ffi_state = fs) ∧ (read_ffi_bytearrays (ag32_machine_config ffi_names lc ld) ms = (SOME conf, SOME bytes)) ∧ (call_FFI ffi "close" conf bytes = FFI_return ffi' bytes') ∧ (INDEX_OF "close" ffi_names = SOME index) ∧ ALL_DISTINCT ffi_names ∧ @@ -4830,8 +4955,9 @@ Theorem ag32_ffi_interfer_close ag32_ffi_rel (FUNPOW Next k ms) ffi' ∧ ∀x. x ∉ ag32_ffi_mem_domain ∧ x ∉ all_words (ms.R 3w) (LENGTH bytes) ⇒ - ((FUNPOW Next k ms).MEM x = ms.MEM x)` - (strip_tac + ((FUNPOW Next k ms).MEM x = ms.MEM x) +Proof + strip_tac \\ fs[targetSemTheory.read_ffi_bytearrays_def] \\ fs[targetSemTheory.read_ffi_bytearray_def] \\ fs[EVAL``(ag32_machine_config a b c).ptr2_reg``] @@ -5012,14 +5138,15 @@ Theorem ag32_ffi_interfer_close \\ qpat_x_assum`_ = w2n _`(assume_tac o SYM) \\ fs[] \\ rw[APPLY_UPDATE_THM] \\ qpat_x_assum`_ ∉ ag32_ffi_mem_domain`mp_tac - \\ EVAL_TAC); + \\ EVAL_TAC +QED val ag32_ffi_get_arg_count_entrypoint_thm = EVAL “ag32_ffi_get_arg_count_entrypoint” val ffi_code_start_offset_thm = EVAL “ffi_code_start_offset” -Theorem ag32_ffi_interfer_get_arg_count - `ag32_ffi_rel ms ffi ∧ +Theorem ag32_ffi_interfer_get_arg_count: + ag32_ffi_rel ms ffi ∧ (read_ffi_bytearrays (ag32_machine_config ffi_names lc ld) ms = (SOME conf, SOME bytes)) ∧ (call_FFI ffi "get_arg_count" conf bytes = FFI_return ffi' bytes') ∧ (INDEX_OF "get_arg_count" ffi_names = SOME index) ∧ ALL_DISTINCT ffi_names ∧ @@ -5041,8 +5168,9 @@ Theorem ag32_ffi_interfer_get_arg_count ag32_ffi_rel (FUNPOW Next k ms) ffi' ∧ ∀x. x ∉ ag32_ffi_mem_domain ∧ x ∉ all_words (ms.R 3w) (LENGTH bytes) ⇒ - ((FUNPOW Next k ms).MEM x = ms.MEM x)` - (strip_tac + ((FUNPOW Next k ms).MEM x = ms.MEM x) +Proof + strip_tac \\ fs[targetSemTheory.read_ffi_bytearrays_def] \\ fs[targetSemTheory.read_ffi_bytearray_def] \\ fs[EVAL``(ag32_machine_config a b c).ptr2_reg``] @@ -5223,15 +5351,17 @@ Theorem ag32_ffi_interfer_get_arg_count \\ simp[APPLY_UPDATE_THM] \\ rw[] \\ qpat_x_assum`_ ∉ ag32_ffi_mem_domain`mp_tac - \\ EVAL_TAC); + \\ EVAL_TAC +QED -Theorem cline_in_memory_has_n_args - `∀l cls a. +Theorem cline_in_memory_has_n_args: + ∀l cls a. bytes_in_memory a (FLAT (MAP (SNOC 0w) cls)) m md ∧ l ≤ LENGTH cls ∧ EVERY (EVERY ((<>)0w)) cls ⇒ - has_n_args m a l` - (Induct + has_n_args m a l +Proof + Induct >> simp[has_n_args_def] \\ Cases \\ simp[] \\ rw[bytes_in_memory_APPEND] @@ -5242,10 +5372,11 @@ Theorem cline_in_memory_has_n_args \\ fs[SNOC_APPEND, bytes_in_memory_APPEND, bytes_in_memory_def] \\ imp_res_tac bytes_in_memory_EL \\ simp[] - \\ fs[EVERY_MEM, MEM_EL, DISJ_EQ_IMP]); + \\ fs[EVERY_MEM, MEM_EL, DISJ_EQ_IMP] +QED -Theorem ag32_ffi_interfer_get_arg_length - `ag32_ffi_rel ms ffi ∧ +Theorem ag32_ffi_interfer_get_arg_length: + ag32_ffi_rel ms ffi ∧ (read_ffi_bytearrays (ag32_machine_config ffi_names lc ld) ms = (SOME conf, SOME bytes)) ∧ (call_FFI ffi "get_arg_length" conf bytes = FFI_return ffi' bytes') ∧ (INDEX_OF "get_arg_length" ffi_names = SOME index) ∧ ALL_DISTINCT ffi_names ∧ @@ -5267,8 +5398,9 @@ Theorem ag32_ffi_interfer_get_arg_length ag32_ffi_rel (FUNPOW Next k ms) ffi' ∧ ∀x. x ∉ ag32_ffi_mem_domain ∧ x ∉ all_words (ms.R 3w) (LENGTH bytes) ⇒ - ((FUNPOW Next k ms).MEM x = ms.MEM x)` - (strip_tac + ((FUNPOW Next k ms).MEM x = ms.MEM x) +Proof + strip_tac \\ fs[targetSemTheory.read_ffi_bytearrays_def] \\ fs[targetSemTheory.read_ffi_bytearray_def] \\ fs[EVAL``(ag32_machine_config a b c).ptr2_reg``] @@ -5493,10 +5625,11 @@ Theorem ag32_ffi_interfer_get_arg_length \\ simp[APPLY_UPDATE_THM] \\ rw[] \\ qpat_x_assum`_ ∉ ag32_ffi_mem_domain`mp_tac - \\ EVAL_TAC); + \\ EVAL_TAC +QED -Theorem ag32_ffi_interfer_get_arg - `ag32_ffi_rel ms ffi ∧ +Theorem ag32_ffi_interfer_get_arg: + ag32_ffi_rel ms ffi ∧ (read_ffi_bytearrays (ag32_machine_config ffi_names lc ld) ms = (SOME conf, SOME bytes)) ∧ (call_FFI ffi "get_arg" conf bytes = FFI_return ffi' bytes') ∧ (INDEX_OF "get_arg" ffi_names = SOME index) ∧ ALL_DISTINCT ffi_names ∧ @@ -5518,8 +5651,9 @@ Theorem ag32_ffi_interfer_get_arg ag32_ffi_rel (FUNPOW Next k ms) ffi' ∧ ∀x. x ∉ ag32_ffi_mem_domain ∧ x ∉ all_words (ms.R 3w) (LENGTH bytes) ⇒ - ((FUNPOW Next k ms).MEM x = ms.MEM x)` - (strip_tac + ((FUNPOW Next k ms).MEM x = ms.MEM x) +Proof + strip_tac \\ fs[targetSemTheory.read_ffi_bytearrays_def] \\ fs[targetSemTheory.read_ffi_bytearray_def] \\ fs[EVAL``(ag32_machine_config a b c).ptr2_reg``] @@ -5823,10 +5957,11 @@ Theorem ag32_ffi_interfer_get_arg \\ simp[APPLY_UPDATE_THM] \\ rw[] \\ qpat_x_assum`_ ∉ ag32_ffi_mem_domain`mp_tac - \\ EVAL_TAC); + \\ EVAL_TAC +QED -Theorem ag32_ffi_interfer_ - `ag32_ffi_rel ms ffi ∧ +Theorem ag32_ffi_interfer_: + ag32_ffi_rel ms ffi ∧ (read_ffi_bytearrays (ag32_machine_config ffi_names lc ld) ms = (SOME conf, SOME bytes)) ∧ (call_FFI ffi "" conf bytes = FFI_return ffi' bytes') ∧ (INDEX_OF "" ffi_names = SOME index) ∧ ALL_DISTINCT ffi_names ∧ @@ -5848,8 +5983,9 @@ Theorem ag32_ffi_interfer_ ag32_ffi_rel (FUNPOW Next k ms) ffi' ∧ ∀x. x ∉ ag32_ffi_mem_domain ∧ x ∉ all_words (ms.R 3w) (LENGTH bytes) ⇒ - ((FUNPOW Next k ms).MEM x = ms.MEM x)` - (strip_tac + ((FUNPOW Next k ms).MEM x = ms.MEM x) +Proof + strip_tac \\ fs[targetSemTheory.read_ffi_bytearrays_def] \\ fs[targetSemTheory.read_ffi_bytearray_def] \\ fs[EVAL``(ag32_machine_config a b c).ptr2_reg``] @@ -5965,22 +6101,25 @@ Theorem ag32_ffi_interfer_ \\ conj_tac >- ( simp[Abbr`ms1`,ag32Theory.ag32_state_component_equality]>> simp[APPLY_UPDATE_THM,FUN_EQ_THM]) - \\ simp[Abbr`ms1`]); + \\ simp[Abbr`ms1`] +QED -Theorem SUBSET_ffi_names_IMP_LENGTH_LESS_EQ - `set ffi_names ⊆ set (MAP FST ffi_exitpcs) ∧ ALL_DISTINCT ffi_names - ⇒ LENGTH ffi_names ≤ LENGTH FFI_codes` - (rw[ffi_exitpcs_def, FFI_codes_def] +Theorem SUBSET_ffi_names_IMP_LENGTH_LESS_EQ: + set ffi_names ⊆ set (MAP FST ffi_exitpcs) ∧ ALL_DISTINCT ffi_names + ⇒ LENGTH ffi_names ≤ LENGTH FFI_codes +Proof + rw[ffi_exitpcs_def, FFI_codes_def] \\ drule ALL_DISTINCT_CARD_LIST_TO_SET \\ disch_then(SUBST1_TAC o SYM) \\ qmatch_asmsub_abbrev_tac`_ ⊆ t` \\ Q.ISPEC_THEN`t`mp_tac CARD_SUBSET \\ impl_tac >- simp[Abbr`t`] \\ disch_then drule - \\ simp[Abbr`t`] ); + \\ simp[Abbr`t`] +QED -Theorem ag32_good_init_state - `SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ +Theorem ag32_good_init_state: + SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ LENGTH inp ≤ stdin_size ∧ set ffi_names ⊆ set (MAP FST ffi_exitpcs) ∧ ALL_DISTINCT ffi_names ∧ code_start_offset (LENGTH ffi_names) + LENGTH code + 4 * LENGTH data < memory_size ∧ @@ -6004,8 +6143,9 @@ Theorem ag32_good_init_state ∪ {w | n2w (code_start_offset (LENGTH ffi_names) + LENGTH code) <=+ w ∧ w <+ n2w(code_start_offset (LENGTH ffi_names) + LENGTH code + 4 * LENGTH data) }) io_regs - cc_regs` - (strip_tac + cc_regs +Proof + strip_tac \\ imp_res_tac SUBSET_ffi_names_IMP_LENGTH_LESS_EQ \\ simp[targetSemTheory.good_init_state_def,RIGHT_EXISTS_AND_THM] \\ drule (GEN_ALL init_asm_state_RTC_asm_step) @@ -6341,11 +6481,12 @@ Theorem ag32_good_init_state \\ Cases_on`q` \\ fs[] >- metis_tac[] \\ qmatch_asmsub_rename_tac`SUC (SUC (SUC q)) < _` \\ Cases_on`q` \\ fs[] >- metis_tac[] ) - \\ fs[memory_size_def]); + \\ fs[memory_size_def] +QED (* TODO more things can be pulled out of here *) -Theorem ag32_installed - `SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ +Theorem ag32_installed: + SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ LENGTH inp ≤ stdin_size ∧ set ffi_names ⊆ set (MAP FST ffi_exitpcs) ∧ ALL_DISTINCT ffi_names ∧ code_start_offset (LENGTH ffi_names) + LENGTH code + 4 * LENGTH data < memory_size ∧ @@ -6361,8 +6502,9 @@ Theorem ag32_installed installed code 0 data 0 (SOME ffi_names) (basis_ffi cl fs) (heap_regs ag32_backend_config.stack_conf.reg_names) (ag32_machine_config ffi_names (LENGTH code) (LENGTH data)) - (FUNPOW Next startup_clock ms0)` - (disch_then assume_tac + (FUNPOW Next startup_clock ms0) +Proof + disch_then assume_tac \\ CONV_TAC(PATH_CONV"llr"EVAL) \\ simp[targetSemTheory.installed_def] \\ simp[word_list_exists_def, set_sepTheory.SEP_CLAUSES, word_list_def] @@ -6506,10 +6648,11 @@ Theorem ag32_installed \\ pop_assum SUBST_ALL_TAC \\ simp [GSYM word_add_n2w] \\ irule init_memory_data - \\ fs [Abbr `hi`, memory_size_def, Abbr `low`]); + \\ fs [Abbr `hi`, memory_size_def, Abbr `low`] +QED -Theorem ag32_halted - `∀ms. +Theorem ag32_halted: + ∀ms. SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ LENGTH inp ≤ stdin_size ∧ LENGTH ffi_names ≤ LENGTH FFI_codes ∧ @@ -6520,8 +6663,9 @@ Theorem ag32_halted ∀k. ((FUNPOW Next k ms).io_events = ms.io_events) ∧ ((FUNPOW Next k ms).PC = ms.PC) ∧ ((FUNPOW Next k ms).MEM = ms.MEM) ∧ - (∀w. w ≠ 0w ⇒ ((FUNPOW Next k ms).R w = ms.R w))` - (gen_tac \\ strip_tac \\ rveq + (∀w. w ≠ 0w ⇒ ((FUNPOW Next k ms).R w = ms.R w)) +Proof + gen_tac \\ strip_tac \\ rveq \\ Induct >- rw[] \\ simp[FUNPOW_SUC] \\ qmatch_goalsub_abbrev_tac`ms1.io_events` @@ -6581,7 +6725,8 @@ Theorem ag32_halted \\ simp[ag32Theory.Run_def, ag32Theory.dfn'Jump_def] \\ simp[ag32Theory.ALU_def, ag32Theory.ri2word_def] \\ strip_tac - \\ simp[Abbr`ms1`, APPLY_UPDATE_THM]); + \\ simp[Abbr`ms1`, APPLY_UPDATE_THM] +QED fun ffi_tac ag32_ffi_interfer_xxx @@ -6692,8 +6837,8 @@ fun ffi_tac \\ Cases_on`x` \\ fs[word_add_n2w] \\ fs[word_ls_n2w, word_lo_n2w] \\ rfs[]; -Theorem ag32_interference_implemented - `SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ +Theorem ag32_interference_implemented: + SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ LENGTH inp ≤ stdin_size ∧ set ffi_names ⊆ set (MAP FST ffi_exitpcs) ∧ ALL_DISTINCT ffi_names ∧ code_start_offset (LENGTH ffi_names) + LENGTH code + 4 * LENGTH data < memory_size ∧ @@ -6704,8 +6849,9 @@ Theorem ag32_interference_implemented interference_implemented (ag32_machine_config ffi_names (LENGTH code) (LENGTH data)) (ag32_ffi_rel) - (ag32_ffi_mem_domain) ms` - (rw[interference_implemented_def] + (ag32_ffi_mem_domain) ms +Proof + rw[interference_implemented_def] \\ simp[EVAL``(ag32_machine_config _ _ _).target.next``] \\ simp[EVAL``(ag32_machine_config _ _ _).target.get_byte``] \\ simp[EVAL``(ag32_machine_config _ _ _).target.get_pc``] @@ -7113,10 +7259,11 @@ Theorem ag32_interference_implemented \\ Cases_on`EL ffi_index ffi_names = "get_arg_length"` \\ fs[] >- ffi_tac ag32_ffi_interfer_get_arg_length ``ag32_ffi_get_arg_length_code`` \\ Cases_on`EL ffi_index ffi_names = "open_out"` \\ fs[] - >- ffi_tac ag32_ffi_interfer_open_out ``ag32_ffi_open_out_code``); + >- ffi_tac ag32_ffi_interfer_open_out ``ag32_ffi_open_out_code`` +QED -Theorem ag32_next - `SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ wfcl cl ∧ +Theorem ag32_next: + SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ wfcl cl ∧ LENGTH inp ≤ stdin_size ∧ set ffi_names ⊆ set (MAP FST ffi_exitpcs) ∧ ALL_DISTINCT ffi_names ∧ code_start_offset (LENGTH ffi_names) + LENGTH code + 4 * LENGTH data < memory_size ∧ @@ -7134,8 +7281,9 @@ Theorem ag32_next (get_mem_word ms.MEM ms.PC = Encode (Jump (fAdd,0w,Imm 0w))) ∧ outs ≼ MAP get_output_io_event io_events ∧ ((ms.R (n2w (ag32_machine_config ffi_names (LENGTH code) (LENGTH data)).ptr_reg) = 0w) ⇒ - (outs = MAP get_output_io_event io_events))` - (rw[] + (outs = MAP get_output_io_event io_events)) +Proof + rw[] \\ fs[semanticsPropsTheory.extend_with_resource_limit_def] \\ qmatch_asmsub_abbrev_tac`machine_sem mc st ms` \\ `∃b. machine_sem mc st ms b` by metis_tac[targetPropsTheory.machine_sem_total] @@ -7584,6 +7732,7 @@ Theorem ag32_next >- ( fs[IS_PREFIX_APPEND] \\ fs[markerTheory.Abbrev_def] ) \\ strip_tac \\ fs[] \\ Cases_on`x` \\ fs[] - \\ fs[markerTheory.Abbrev_def]); + \\ fs[markerTheory.Abbrev_def] +QED val _ = export_theory(); diff --git a/compiler/backend/ag32/proofs/ag32_configProofScript.sml b/compiler/backend/ag32/proofs/ag32_configProofScript.sml index f7ec79729e..0493d4bcd8 100644 --- a/compiler/backend/ag32/proofs/ag32_configProofScript.sml +++ b/compiler/backend/ag32/proofs/ag32_configProofScript.sml @@ -21,9 +21,10 @@ val names_tac = \\ REWRITE_TAC[SUBSET_DEF] \\ EVAL_TAC \\ rpt strip_tac \\ rveq \\ EVAL_TAC -Theorem ag32_backend_config_ok ` - backend_config_ok ag32_backend_config` - (simp[backend_config_ok_def]>>rw[]>>TRY(EVAL_TAC>>NO_TAC) +Theorem ag32_backend_config_ok: + backend_config_ok ag32_backend_config +Proof + simp[backend_config_ok_def]>>rw[]>>TRY(EVAL_TAC>>NO_TAC) \\ fs[ag32_backend_config_def,asmTheory.offset_ok_def, alignmentTheory.aligned_0,tlookup_bij_iff] \\ fs[ag32_backend_config_def,ag32_targetTheory.ag32_config_def,asmTheory.offset_ok_def, @@ -39,11 +40,13 @@ Theorem ag32_backend_config_ok ` \\ rveq \\ fs [] \\ EVAL_TAC) \\ fs[stack_removeTheory.max_stack_alloc_def] \\ EVAL_TAC>>fs[] - \\ fs [bitTheory.BIT_def,bitTheory.BITS_THM,LESS_DIV_EQ_ZERO]); + \\ fs [bitTheory.BIT_def,bitTheory.BITS_THM,LESS_DIV_EQ_ZERO] +QED -Theorem ag32_machine_config_ok - `is_ag32_machine_config mc ⇒ mc_conf_ok mc` - (rw[lab_to_targetProofTheory.mc_conf_ok_def,is_ag32_machine_config_def] +Theorem ag32_machine_config_ok: + is_ag32_machine_config mc ⇒ mc_conf_ok mc +Proof + rw[lab_to_targetProofTheory.mc_conf_ok_def,is_ag32_machine_config_def] >- EVAL_TAC >- simp[ag32_encoder_correct] >- EVAL_TAC @@ -52,14 +55,17 @@ Theorem ag32_machine_config_ok >- EVAL_TAC >- EVAL_TAC >- metis_tac[asmPropsTheory.encoder_correct_def, - asmPropsTheory.target_ok_def,ag32_encoder_correct]); + asmPropsTheory.target_ok_def,ag32_encoder_correct] +QED -Theorem ag32_init_ok - `is_ag32_machine_config mc ⇒ - mc_init_ok ag32_backend_config mc` - (rw[mc_init_ok_def] +Theorem ag32_init_ok: + is_ag32_machine_config mc ⇒ + mc_init_ok ag32_backend_config mc +Proof + rw[mc_init_ok_def] \\ fs[is_ag32_machine_config_def] - \\ EVAL_TAC); + \\ EVAL_TAC +QED val is_ag32_machine_config_mc = ag32_init_ok |> concl |> dest_imp |> #1 diff --git a/compiler/backend/ag32/proofs/ag32_ffi_codeProofScript.sml b/compiler/backend/ag32/proofs/ag32_ffi_codeProofScript.sml index 276f9bf4a8..8af7081460 100644 --- a/compiler/backend/ag32/proofs/ag32_ffi_codeProofScript.sml +++ b/compiler/backend/ag32/proofs/ag32_ffi_codeProofScript.sml @@ -9,11 +9,13 @@ val _ = new_theory"ag32_ffi_codeProof"; (* TODO: move *) -Theorem byte_aligned_imp - `byte_aligned (x:word32) ⇒ - (((((31 >< 2) x):word30) @@ (0w:word2)) = x)` - (rw[alignmentTheory.byte_aligned_def, alignmentTheory.aligned_def, alignmentTheory.align_def] - \\ blastLib.FULL_BBLAST_TAC); +Theorem byte_aligned_imp: + byte_aligned (x:word32) ⇒ + (((((31 >< 2) x):word30) @@ (0w:word2)) = x) +Proof + rw[alignmentTheory.byte_aligned_def, alignmentTheory.aligned_def, alignmentTheory.align_def] + \\ blastLib.FULL_BBLAST_TAC +QED (* -- *) @@ -96,13 +98,14 @@ fun next_tac n = \\ simp[ag32Theory.Run_def] end -Theorem ag32_ffi_return_code_thm - `(∀k. k < LENGTH ag32_ffi_return_code ⇒ +Theorem ag32_ffi_return_code_thm: + (∀k. k < LENGTH ag32_ffi_return_code ⇒ (get_mem_word s.MEM (s.PC + n2w (4 * k)) = Encode (EL k ag32_ffi_return_code))) ∧ byte_aligned s.PC ⇒ - ∃k. (FUNPOW Next k s = ag32_ffi_return s)` - (rw[ag32_ffi_return_def] + ∃k. (FUNPOW Next k s = ag32_ffi_return s) +Proof + rw[ag32_ffi_return_def] \\ rw[Once EXISTS_NUM] \\ disj2_tac \\ rw[FUNPOW] \\ rw[ag32Theory.Next_def] \\ qmatch_goalsub_abbrev_tac`pc + 2w` @@ -140,10 +143,11 @@ Theorem ag32_ffi_return_code_thm \\ disch_then kall_tac \\ simp[ag32_targetProofTheory.Decode_Encode] \\ simp[ag32Theory.Run_def] - \\ simp[Once EXISTS_NUM]); + \\ simp[Once EXISTS_NUM] +QED -Theorem ag32_ffi_copy_code_thm - `∀s. +Theorem ag32_ffi_copy_code_thm: + ∀s. (∀k. k < LENGTH ag32_ffi_copy_code ⇒ (get_mem_word s.MEM (s.PC + n2w (4 * k)) = Encode (EL k ag32_ffi_copy_code))) @@ -153,8 +157,9 @@ Theorem ag32_ffi_copy_code_thm ∧ DISJOINT { s.R 5w + n2w k | k | k < w2n (s.R 1w) } { s.PC + n2w k | k | k DIV 4 < LENGTH ag32_ffi_copy_code } ⇒ - ∃k. (FUNPOW Next k s = ag32_ffi_copy s)` - (Induct_on`w2n(s.R 1w)` \\ rw[] + ∃k. (FUNPOW Next k s = ag32_ffi_copy s) +Proof + Induct_on`w2n(s.R 1w)` \\ rw[] >- ( simp[Once ag32_ffi_copy_def] \\ Cases_on`s.R 1w` \\ fs[] \\ rw[] @@ -363,7 +368,8 @@ Theorem ag32_ffi_copy_code_thm \\ rw[] \\ `k + 1 > simp[]); +Theorem v2w_EQ0: + v2w [b] = (0w : word32) ⇔ ~b +Proof + Cases_on ‘b’ >> simp[] +QED fun r3_unchanged i = let @@ -484,8 +492,8 @@ val combined = combined0 instn gmw val _ = temp_overload_on ("align4", “λw:word32. (((31 >< 2) w) : 30 word @@ (0w : 2 word)) : word32”); -Theorem ag32_ffi_read_num_written_code_thm - `s.R 3w ∉ +Theorem ag32_ffi_read_num_written_code_thm: + s.R 3w ∉ { s.PC + n2w k | k | k DIV 4 < LENGTH ag32_ffi_read_num_written_code } ∧ align4 (w2w (n2w stdin_offset : 23 word)) ∉ { s.PC + n2w k | k | k DIV 4 < LENGTH ag32_ffi_read_num_written_code } ∧ @@ -494,9 +502,9 @@ Theorem ag32_ffi_read_num_written_code_thm Encode (EL k ag32_ffi_read_num_written_code)) ∧ byte_aligned s.PC ⇒ - ∃k. FUNPOW Next k s = ag32_ffi_read_num_written s` - - (strip_tac >> + ∃k. FUNPOW Next k s = ag32_ffi_read_num_written s +Proof + strip_tac >> assume_tac (EVAL “LENGTH ag32_ffi_read_num_written_code”) >> fs[] >> instn 0 >> drule_then assume_tac byte_aligned_imp >> @@ -552,16 +560,18 @@ Theorem ag32_ffi_read_num_written_code_thm ‘s7.PC = s.PC + 28w’ by simp[Abbr‘s7’] >> simp0[Once LET_THM] >> instn 7 >> gmw 7 >> EVERY (List.tabulate(10, fn i => combined (i + 8))) >> - qexists_tac `0` >> simp[]); + qexists_tac `0` >> simp[] +QED -Theorem ag32_ffi_write_set_id_code_thm - `(∀k. k < LENGTH ag32_ffi_write_set_id_code ⇒ +Theorem ag32_ffi_write_set_id_code_thm: + (∀k. k < LENGTH ag32_ffi_write_set_id_code ⇒ (get_mem_word s.MEM (s.PC + n2w (4 * k)) = Encode (EL k ag32_ffi_write_set_id_code))) ∧ byte_aligned s.PC ⇒ - ∃k. (FUNPOW Next k s = ag32_ffi_write_set_id s)` - (rw[ag32_ffi_write_set_id_def] + ∃k. (FUNPOW Next k s = ag32_ffi_write_set_id s) +Proof + rw[ag32_ffi_write_set_id_def] \\ rw[Once EXISTS_NUM] \\ disj2_tac \\ rw[FUNPOW] \\ rw[ag32Theory.Next_def] \\ drule byte_aligned_imp \\ rw[] @@ -651,40 +661,47 @@ Theorem ag32_ffi_write_set_id_code_thm \\ disch_then kall_tac \\ simp[ag32_targetProofTheory.Decode_Encode] \\ simp[ag32Theory.Run_def] - \\ rw[Once EXISTS_NUM]); + \\ rw[Once EXISTS_NUM] +QED -Theorem ag32_ffi_write_check_conf_code_thm - `(∀k. k < LENGTH ag32_ffi_write_check_conf_code ⇒ +Theorem ag32_ffi_write_check_conf_code_thm: + (∀k. k < LENGTH ag32_ffi_write_check_conf_code ⇒ (get_mem_word s.MEM (s.PC + n2w (4 * k)) = Encode (EL k ag32_ffi_write_check_conf_code))) ∧ byte_aligned s.PC ⇒ - ∃k. (FUNPOW Next k s = ag32_ffi_write_check_conf s)` - (first_tac + ∃k. (FUNPOW Next k s = ag32_ffi_write_check_conf s) +Proof + first_tac \\ EVERY (List.tabulate(34, next_tac o (curry(op +)1))) - \\ rw[Once EXISTS_NUM]); + \\ rw[Once EXISTS_NUM] +QED -Theorem ag32_ffi_write_load_noff_code_thm - `(∀k. k < LENGTH ag32_ffi_write_load_noff_code ⇒ +Theorem ag32_ffi_write_load_noff_code_thm: + (∀k. k < LENGTH ag32_ffi_write_load_noff_code ⇒ (get_mem_word s.MEM (s.PC + n2w (4 * k)) = Encode (EL k ag32_ffi_write_load_noff_code))) ∧ byte_aligned s.PC ⇒ - ∃k. (FUNPOW Next k s = ag32_ffi_write_load_noff s)` - (first_tac + ∃k. (FUNPOW Next k s = ag32_ffi_write_load_noff s) +Proof + first_tac \\ EVERY (List.tabulate(11, next_tac o (curry(op +)1))) - \\ rw[Once EXISTS_NUM]); + \\ rw[Once EXISTS_NUM] +QED -Theorem ag32_ffi_write_check_lengths_code_thm - `(∀k. k < LENGTH ag32_ffi_write_check_lengths_code ⇒ +Theorem ag32_ffi_write_check_lengths_code_thm: + (∀k. k < LENGTH ag32_ffi_write_check_lengths_code ⇒ (get_mem_word s.MEM (s.PC + n2w (4 * k)) = Encode (EL k ag32_ffi_write_check_lengths_code))) ∧ byte_aligned s.PC ⇒ - ∃k. (FUNPOW Next k s = ag32_ffi_write_check_lengths s)` - (first_tac + ∃k. (FUNPOW Next k s = ag32_ffi_write_check_lengths s) +Proof + first_tac \\ EVERY (List.tabulate(9, next_tac o (curry(op +)1))) - \\ rw[Once EXISTS_NUM]); + \\ rw[Once EXISTS_NUM] +QED -Theorem ag32_ffi_write_write_header_code_thm - `(∀k. k < LENGTH ag32_ffi_write_write_header_code ⇒ +Theorem ag32_ffi_write_write_header_code_thm: + (∀k. k < LENGTH ag32_ffi_write_write_header_code ⇒ (get_mem_word s.MEM (s.PC + n2w (4 * k)) = Encode (EL k ag32_ffi_write_write_header_code))) ∧ (s.PC = @@ -695,8 +712,9 @@ Theorem ag32_ffi_write_write_header_code_thm + 4 * (LENGTH ag32_ffi_write_check_lengths_code))) ∧ (s.R 5w = n2w output_offset) ⇒ - ∃k. (FUNPOW Next k s = ag32_ffi_write_write_header s)` - (rw[ag32_ffi_write_write_header_def] + ∃k. (FUNPOW Next k s = ag32_ffi_write_write_header s) +Proof + rw[ag32_ffi_write_write_header_def] \\ rw[Once EXISTS_NUM] \\ disj2_tac \\ rw[FUNPOW] \\ rw[ag32Theory.Next_def] \\ qmatch_goalsub_abbrev_tac`pc + 2w` @@ -1255,10 +1273,11 @@ Theorem ag32_ffi_write_write_header_code_thm \\ simp_tac(srw_ss())[ag32_ffi_write_write_header_code_def] \\ simp[ag32_targetProofTheory.Decode_Encode] \\ simp[ag32Theory.Run_def] - \\ simp[Once EXISTS_NUM]); + \\ simp[Once EXISTS_NUM] +QED -Theorem ag32_ffi_write_num_written_code_thm - `(∀k. k < LENGTH ag32_ffi_write_num_written_code ⇒ +Theorem ag32_ffi_write_num_written_code_thm: + (∀k. k < LENGTH ag32_ffi_write_num_written_code ⇒ (get_mem_word s.MEM (s.PC + n2w (4 * k)) = Encode (EL k ag32_ffi_write_num_written_code))) ∧ byte_aligned s.PC @@ -1266,8 +1285,9 @@ Theorem ag32_ffi_write_num_written_code_thm ∧ (∀k. k DIV 4 < LENGTH ag32_ffi_write_num_written_code ⇒ s.R 3w + 1w ≠ s.PC + n2w k) ∧ (∀k. k DIV 4 < LENGTH ag32_ffi_write_num_written_code ⇒ s.R 3w + 2w ≠ s.PC + n2w k) ⇒ - ∃k. (FUNPOW Next k s = ag32_ffi_write_num_written s)` - (strip_tac + ∃k. (FUNPOW Next k s = ag32_ffi_write_num_written s) +Proof + strip_tac \\ simp[ag32_ffi_write_num_written_def] \\ qmatch_goalsub_abbrev_tac`COND (t1.PC = t0.PC + 4w)` \\ simp[Once EXISTS_NUM] \\ disj2_tac \\ simp[FUNPOW] @@ -1512,10 +1532,11 @@ Theorem ag32_ffi_write_num_written_code_thm \\ simp[ag32_ffi_write_num_written_code_def] \\ disch_then kall_tac \\ simp[ag32Theory.Run_def] - \\ simp[Once EXISTS_NUM]); + \\ simp[Once EXISTS_NUM] +QED -Theorem ag32_ffi_write_code_thm - `(∀k. k < LENGTH ag32_ffi_write_code ⇒ +Theorem ag32_ffi_write_code_thm: + (∀k. k < LENGTH ag32_ffi_write_code ⇒ (get_mem_word s.MEM (s.PC + n2w (4 * k)) = Encode (EL k ag32_ffi_write_code))) ∧ (s.PC = n2w (ffi_code_start_offset + ag32_ffi_write_entrypoint)) ∧ @@ -1528,8 +1549,9 @@ Theorem ag32_ffi_write_code_thm DISJOINT md { w | n2w startup_code_size <=+ w ∧ w <+ n2w heap_start_offset } (* ∧ md ⊆ { w | w | r0 <+ w ∧ r0 + w <=+ r0 + n2w memory_size }*) ⇒ - ∃k. (FUNPOW Next k s = ag32_ffi_write s)` - (rw[] + ∃k. (FUNPOW Next k s = ag32_ffi_write s) +Proof + rw[] \\ simp[ag32_ffi_write_def] \\ mp_tac ag32_ffi_write_set_id_code_thm \\ impl_tac @@ -2241,47 +2263,56 @@ Theorem ag32_ffi_write_code_thm \\ rpt(qpat_x_assum`FUNPOW Next _ _ = _`(assume_tac o SYM)) \\ fs[] \\ simp[GSYM FUNPOW_ADD] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem ag32_ffi_read_set_id_code_thm - `(∀k. k < LENGTH ag32_ffi_read_set_id_code ⇒ +Theorem ag32_ffi_read_set_id_code_thm: + (∀k. k < LENGTH ag32_ffi_read_set_id_code ⇒ get_mem_word s.MEM (s.PC + n2w (4 * k)) = Encode (EL k ag32_ffi_read_set_id_code)) ∧ byte_aligned s.PC ⇒ - ∃k. FUNPOW Next k s = ag32_ffi_read_set_id s` - (first_tac + ∃k. FUNPOW Next k s = ag32_ffi_read_set_id s +Proof + first_tac \\ EVERY (List.tabulate(1, next_tac o (curry(op +)1))) - \\ rw[Once EXISTS_NUM]); + \\ rw[Once EXISTS_NUM] +QED -Theorem ag32_ffi_read_check_conf_code_thm - `(∀k. k < LENGTH ag32_ffi_read_check_conf_code ⇒ +Theorem ag32_ffi_read_check_conf_code_thm: + (∀k. k < LENGTH ag32_ffi_read_check_conf_code ⇒ (get_mem_word s.MEM (s.PC + n2w (4 * k)) = Encode (EL k ag32_ffi_read_check_conf_code))) ∧ byte_aligned s.PC ⇒ - ∃k. (FUNPOW Next k s = ag32_ffi_read_check_conf s)` - (first_tac + ∃k. (FUNPOW Next k s = ag32_ffi_read_check_conf s) +Proof + first_tac \\ EVERY (List.tabulate(32, next_tac o (curry(op +)1))) - \\ rw[Once EXISTS_NUM]); + \\ rw[Once EXISTS_NUM] +QED -Theorem ag32_ffi_read_load_lengths_code_thm - `(∀k. k < LENGTH ag32_ffi_read_load_lengths_code ⇒ +Theorem ag32_ffi_read_load_lengths_code_thm: + (∀k. k < LENGTH ag32_ffi_read_load_lengths_code ⇒ (get_mem_word s.MEM (s.PC + n2w (4 * k)) = Encode (EL k ag32_ffi_read_load_lengths_code))) ∧ byte_aligned s.PC ⇒ - ∃k. (FUNPOW Next k s = ag32_ffi_read_load_lengths s)` - (first_tac + ∃k. (FUNPOW Next k s = ag32_ffi_read_load_lengths s) +Proof + first_tac \\ EVERY (List.tabulate(10, next_tac o (curry(op +)1))) - \\ rw[Once EXISTS_NUM]); + \\ rw[Once EXISTS_NUM] +QED -Theorem ag32_ffi_read_check_length_code_thm - `(∀k. k < LENGTH ag32_ffi_read_check_length_code ⇒ +Theorem ag32_ffi_read_check_length_code_thm: + (∀k. k < LENGTH ag32_ffi_read_check_length_code ⇒ (get_mem_word s.MEM (s.PC + n2w (4 * k)) = Encode (EL k ag32_ffi_read_check_length_code))) ∧ byte_aligned s.PC ⇒ - ∃k. (FUNPOW Next k s = ag32_ffi_read_check_length s)` - (first_tac + ∃k. (FUNPOW Next k s = ag32_ffi_read_check_length s) +Proof + first_tac \\ EVERY (List.tabulate(4, next_tac o (curry(op +)1))) - \\ rw[Once EXISTS_NUM]); + \\ rw[Once EXISTS_NUM] +QED val ffi_code_start_offset_thm = EVAL “ffi_code_start_offset” val ag32_ffi_read_entrypoint_thm = EVAL “ag32_ffi_read_entrypoint” @@ -2314,10 +2345,12 @@ val asm_write_bytearray_avoiding = Q.prove( fun glAbbrs i = EVERY (List.tabulate(i, fn j => glAbbr (i - j))) -Theorem w22n_bound - `∀b1 b2. w22n [b1; b2] < 65536` - (rw[MarshallingTheory.w22n_def] >> - map_every (fn q => Q.ISPEC_THEN q mp_tac w2n_lt) [‘b1’, ‘b2’] >> simp[]); +Theorem w22n_bound: + ∀b1 b2. w22n [b1; b2] < 65536 +Proof + rw[MarshallingTheory.w22n_def] >> + map_every (fn q => Q.ISPEC_THEN q mp_tac w2n_lt) [‘b1’, ‘b2’] >> simp[] +QED val ltSUC = Q.prove( ‘x < SUC y ⇔ x = 0 ∨ ∃x0. x = SUC x0 ∧ x0 < y’, @@ -2333,13 +2366,15 @@ val word_add_o = Q.prove( -Theorem bytes_in_memory_GENLIST - `∀sz base f. +Theorem bytes_in_memory_GENLIST: + ∀sz base f. bytes_in_memory base (GENLIST (m o word_add base o n2w) sz) m md ⇔ - ∀a. a < sz ⇒ base + n2w a ∈ md` - (Induct >> simp[bytes_in_memory_def, GENLIST_CONS] >> + ∀a. a < sz ⇒ base + n2w a ∈ md +Proof + Induct >> simp[bytes_in_memory_def, GENLIST_CONS] >> simp[ltSUC, PULL_EXISTS, DISJ_IMP_THM, FORALL_AND_THM, ADD1, - GSYM word_add_n2w, CONJ_ASSOC, n2w_o_SUC, word_add_o]); + GSYM word_add_n2w, CONJ_ASSOC, n2w_o_SUC, word_add_o] +QED val WORD_ADD_CANCEL_LBARE = Q.prove( ‘y ≤ x ⇒ (n2w x = n2w y + z ⇔ z = n2w (x - y))’, @@ -2373,8 +2408,8 @@ fun simpem [] = raise Fail "" | simpem (th::ths) = simpem (map (SIMP_RULE (srw_ss()) [th]) ths) val stupid = DISCH_ALL (simpem w2ns) -Theorem ag32_ffi_read_code_thm - `(∀k. k < LENGTH ag32_ffi_read_code ⇒ +Theorem ag32_ffi_read_code_thm: + (∀k. k < LENGTH ag32_ffi_read_code ⇒ (get_mem_word s.MEM (s.PC + n2w (4 * k)) = Encode (EL k ag32_ffi_read_code))) ∧ (s.PC = n2w (ffi_code_start_offset + ag32_ffi_read_entrypoint)) ∧ @@ -2391,9 +2426,9 @@ Theorem ag32_ffi_read_code_thm DISJOINT md { s.PC + n2w k | k | k DIV 4 < LENGTH ag32_ffi_read_code } ∧ DISJOINT md { w | n2w startup_code_size <=+ w ∧ w <+ n2w heap_start_offset } ⇒ - ∃k. (FUNPOW Next k s = ag32_ffi_read s)` - - (simp0[ag32_ffi_read_def] >> strip_tac >> + ∃k. (FUNPOW Next k s = ag32_ffi_read s) +Proof + simp0[ag32_ffi_read_def] >> strip_tac >> ‘s.R 3w ∈ md’ by (qpat_assum ‘bytes_in_memory (s.R 3w) _ _ _’ (mp_then (Pos hd) mp_tac bytes_in_memory_in_domain) >> @@ -2773,7 +2808,8 @@ Theorem ag32_ffi_read_code_thm mp_tac (MATCH_MP i1 th) >> mp_tac (MATCH_MP i2 th)))) >> simp[startup_code_size_def, heap_start_offset_def, word_add_n2w, word_lo_n2w, word_ls_n2w, ffi_code_start_offset_thm, - length_ag32_ffi_code_def]); + length_ag32_ffi_code_def] +QED val instn = instn0 (LIST_CONJ [ag32_ffi_get_arg_count_code_def, ag32_ffi_get_arg_count_main_code_def, @@ -2795,8 +2831,8 @@ val gmw = gmw0 (fn i => insthyp last_x_assum 4 (fn j => 4 * i + j)) val combined = combined0 instn gmw -Theorem ag32_ffi_get_arg_count_code_thm - `s.R 3w ∉ +Theorem ag32_ffi_get_arg_count_code_thm: + s.R 3w ∉ { s.PC + n2w k | k | k DIV 4 < LENGTH ag32_ffi_get_arg_count_code } ∧ (∀k. k < LENGTH ag32_ffi_get_arg_count_code ⇒ (get_mem_word s.MEM (s.PC + n2w (4 * k)) = @@ -2804,8 +2840,9 @@ Theorem ag32_ffi_get_arg_count_code_thm byte_aligned s.PC ∧ (s.PC = n2w (ffi_code_start_offset + ag32_ffi_get_arg_count_entrypoint)) ⇒ - ∃k. (FUNPOW Next k s = ag32_ffi_get_arg_count s)` - (rw[ffi_code_start_offset_thm, ag32_ffi_get_arg_count_entrypoint_thm] >> + ∃k. (FUNPOW Next k s = ag32_ffi_get_arg_count s) +Proof + rw[ffi_code_start_offset_thm, ag32_ffi_get_arg_count_entrypoint_thm] >> assume_tac (EVAL “LENGTH ag32_ffi_get_arg_count_code”) >> fs[] >> instn 0 >> simp0 [ag32_ffi_get_arg_count_def, ag32_ffi_get_arg_count_main_def] >> @@ -2845,7 +2882,8 @@ Theorem ag32_ffi_get_arg_count_code_thm EVERY (List.tabulate(5, fn j => qspec_then [QUOTE ("4 * (k + 8) + " ^ Int.toString j)] mp_tac th))) >> - simp[div_lemma] >> simp[LEFT_ADD_DISTRIB, word_add_n2w]); + simp[div_lemma] >> simp[LEFT_ADD_DISTRIB, word_add_n2w] +QED val instn = instn0 ag32_ffi_get_arg_length_setup_code_def @@ -2854,16 +2892,17 @@ val gmw = gmw0 (fn i => insthyp last_x_assum 4 (fn j => 4 * i + j)) val combined = combined0 instn gmw -Theorem ag32_ffi_get_arg_length_setup_code_thm - `w2w (n2w (ffi_code_start_offset − 1) : 23 word) ∉ +Theorem ag32_ffi_get_arg_length_setup_code_thm: + w2w (n2w (ffi_code_start_offset − 1) : 23 word) ∉ { s.PC + n2w k | k | k DIV 4 < LENGTH ag32_ffi_get_arg_length_setup_code } ∧ (∀k. k < LENGTH ag32_ffi_get_arg_length_setup_code ⇒ get_mem_word s.MEM (s.PC + n2w (4 * k)) = Encode (EL k ag32_ffi_get_arg_length_setup_code)) ∧ byte_aligned s.PC ⇒ - ∃k. FUNPOW Next k s = ag32_ffi_get_arg_length_setup s` - (rw[ffi_code_start_offset_thm] >> + ∃k. FUNPOW Next k s = ag32_ffi_get_arg_length_setup s +Proof + rw[ffi_code_start_offset_thm] >> assume_tac (EVAL “LENGTH ag32_ffi_get_arg_length_setup_code”) >> fs[] >> instn 0 >> simp0[ag32_ffi_get_arg_length_setup_def] >> @@ -2872,7 +2911,8 @@ Theorem ag32_ffi_get_arg_length_setup_code_thm ntac 2 (pop_assum kall_tac) >> EVERY (List.tabulate(10, fn j => (combined (j + 1)))) >> - qexists_tac `0` >> simp[]); + qexists_tac `0` >> simp[] +QED val ag32_ffi_get_arg_length_loop1_code_def = Define‘ ag32_ffi_get_arg_length_loop1_code = @@ -2884,15 +2924,15 @@ val instn = instn0 ag32_ffi_get_arg_length_loop1_code_def) val combined = combined0 instn gmw -Theorem ag32_ffi_get_arg_length_loop1_code_thm - `s.MEM (s.R 5w + n2w zoff) = 0w ∧ +Theorem ag32_ffi_get_arg_length_loop1_code_thm: + s.MEM (s.R 5w + n2w zoff) = 0w ∧ (∀k. k < LENGTH ag32_ffi_get_arg_length_loop1_code ⇒ get_mem_word s.MEM (s.PC + n2w (4 * k)) = Encode (EL k ag32_ffi_get_arg_length_loop1_code)) ∧ byte_aligned s.PC ⇒ - ∃k. FUNPOW Next k s = ag32_ffi_get_arg_length_loop1 s` - - (assume_tac (EVAL “LENGTH ag32_ffi_get_arg_length_loop1_code”) >> + ∃k. FUNPOW Next k s = ag32_ffi_get_arg_length_loop1 s +Proof + assume_tac (EVAL “LENGTH ag32_ffi_get_arg_length_loop1_code”) >> map_every qid_spec_tac [‘s’, ‘zoff’] >> Induct >> simp[] >> rw[] >> instn 0 >> simp0[Once ag32_ffi_get_arg_length_loop1_def] >> drule_then assume_tac byte_aligned_imp >> @@ -2910,7 +2950,8 @@ Theorem ag32_ffi_get_arg_length_loop1_code_thm EVERY (List.tabulate(3, fn j => combined (j + 1))) >> Cases_on ‘s3.R 8w = 0w’ >> simp0[] >- (qexists_tac `0` >> simp[]) >> rnwc_next 4 >> rfs[] >> - first_x_assum irule >> glAbbrs 4 >> fs[ADD1, GSYM word_add_n2w]); + first_x_assum irule >> glAbbrs 4 >> fs[ADD1, GSYM word_add_n2w] +QED val loop_code_def' = Q.prove( ‘ag32_ffi_get_arg_length_loop_code = @@ -2934,15 +2975,15 @@ val has_n_args_def = Define‘ has_n_args mem (a + n2w off + 1w) n) ’; -Theorem ag32_ffi_get_arg_length_loop_code_thm - `has_n_args s.MEM (s.R 5w) argc ∧ w2n (s.R 6w) ≤ argc ∧ +Theorem ag32_ffi_get_arg_length_loop_code_thm: + has_n_args s.MEM (s.R 5w) argc ∧ w2n (s.R 6w) ≤ argc ∧ (∀k. k < LENGTH ag32_ffi_get_arg_length_loop_code ⇒ get_mem_word s.MEM (s.PC + n2w (4 * k)) = Encode (EL k ag32_ffi_get_arg_length_loop_code)) ∧ byte_aligned s.PC ⇒ - ∃k. FUNPOW Next k s = ag32_ffi_get_arg_length_loop s` - - (‘∃cnt. w2n (s.R 6w) = cnt’ by simp[] >> + ∃k. FUNPOW Next k s = ag32_ffi_get_arg_length_loop s +Proof + ‘∃cnt. w2n (s.R 6w) = cnt’ by simp[] >> pop_assum mp_tac >> map_every qid_spec_tac [‘argc’, ‘s’, ‘cnt’] >> Induct >> rw[] >> assume_tac (EVAL “LENGTH ag32_ffi_get_arg_length_loop_code”) >> fs[] >> @@ -2984,7 +3025,8 @@ Theorem ag32_ffi_get_arg_length_loop_code_thm rnwc_next 8 >> first_x_assum irule >> glAbbrs 8 >> reverse conj_tac >- (goal_assum drule >> simp[GSYM word_add_n2w]) >> Q.ISPEC_THEN ‘s.R 6w’ mp_tac ranged_word_nchotomy >> strip_tac >> fs[] >> - simp[WORD_LITERAL_ADD]); + simp[WORD_LITERAL_ADD] +QED (* ag32_ffi_get_arg_length *) @@ -3002,10 +3044,12 @@ val (ag32_ffi_get_arg_length_store_SPEC, ag32_ffi_get_arg_length_store_decomp_def) = ag32_decompile ag32_ffi_get_arg_length_store_code_def -Theorem ag32_ffi_get_arg_length_store_decomp_thm - `FST(ag32_ffi_get_arg_length_store_decomp (s,md)) = ag32_ffi_get_arg_length_store s` - (rw[ag32_ffi_get_arg_length_store_decomp_def] - \\ rw[ag32_ffi_get_arg_length_store_def]); +Theorem ag32_ffi_get_arg_length_store_decomp_thm: + FST(ag32_ffi_get_arg_length_store_decomp (s,md)) = ag32_ffi_get_arg_length_store s +Proof + rw[ag32_ffi_get_arg_length_store_decomp_def] + \\ rw[ag32_ffi_get_arg_length_store_def] +QED val ag32_ffi_get_arg_length_store_FUNPOW_Next = let val th = ag32_ffi_get_arg_length_store_SPEC @@ -3028,10 +3072,12 @@ val ag32_ffi_get_arg_length_FUNPOW_Next = let ag32_ffi_return_code_def,APPEND] in FUNPOW_Next_from_SPEC code_def th end; -Theorem ag32_ffi_get_arg_length_setup_decomp_thm - `FST(ag32_ffi_get_arg_length_setup_decomp (s,md)) = ag32_ffi_get_arg_length_setup s` - (rw[ag32_ffi_get_arg_length_setup_decomp_def] - \\ rw[ag32_ffi_get_arg_length_setup_def]); +Theorem ag32_ffi_get_arg_length_setup_decomp_thm: + FST(ag32_ffi_get_arg_length_setup_decomp (s,md)) = ag32_ffi_get_arg_length_setup s +Proof + rw[ag32_ffi_get_arg_length_setup_decomp_def] + \\ rw[ag32_ffi_get_arg_length_setup_def] +QED Theorem ag32_ffi_get_arg_length_loop_decomp_thm `∀s. FST(ag32_ffi_get_arg_length_loop_decomp (s,md)) = ag32_ffi_get_arg_length_loop s` @@ -3053,8 +3099,8 @@ Theorem ag32_ffi_get_arg_length_loop_decomp_thm \\ simp[ag32Theory.ALU_def, ag32Theory.ri2word_def, ag32Theory.incPC_def] *) -Theorem ag32_ffi_get_arg_length_code_thm - `(∀k. k < LENGTH ag32_ffi_get_arg_length_code ⇒ +Theorem ag32_ffi_get_arg_length_code_thm: + (∀k. k < LENGTH ag32_ffi_get_arg_length_code ⇒ (get_mem_word s.MEM (s.PC + n2w (4 * k)) = Encode (EL k ag32_ffi_get_arg_length_code))) ∧ byte_aligned s.PC ∧ @@ -3070,8 +3116,9 @@ Theorem ag32_ffi_get_arg_length_code_thm has_n_args ((n2w(ffi_code_start_offset - 1) =+ n2w(THE(ALOOKUP FFI_codes "get_arg_length"))) s.MEM) (n2w (startup_code_size + 4)) (w2n l0 + (256 * w2n l1) + 1) ⇒ - ∃k. (FUNPOW Next k s = ag32_ffi_get_arg_length s)` - (rw[ag32_ffi_get_arg_length_def] + ∃k. (FUNPOW Next k s = ag32_ffi_get_arg_length s) +Proof + rw[ag32_ffi_get_arg_length_def] \\ mp_tac ag32_ffi_get_arg_length_setup_code_thm \\ impl_tac >- ( @@ -3258,7 +3305,8 @@ Theorem ag32_ffi_get_arg_length_code_thm \\ qpat_x_assum`FUNPOW _ _ _ = s2`(SUBST1_TAC o SYM) \\ qpat_x_assum`FUNPOW _ _ _ = s1`(SUBST1_TAC o SYM) \\ simp_tac(srw_ss())[GSYM FUNPOW_ADD] - \\ metis_tac[]); + \\ metis_tac[] +QED (* ag32_ffi_get_arg *) @@ -3289,16 +3337,19 @@ val ag32_ffi_get_arg_FUNPOW_Next = let ag32_ffi_return_code_def,APPEND] in FUNPOW_Next_from_SPEC code_def th end; -Theorem ag32_ffi_get_arg_setup_decomp_thm - `FST(ag32_ffi_get_arg_setup_decomp (s,md)) = ag32_ffi_get_arg_setup s` - (rw[ag32_ffi_get_arg_setup_decomp_def] - \\ rw[ag32_ffi_get_arg_setup_def]); +Theorem ag32_ffi_get_arg_setup_decomp_thm: + FST(ag32_ffi_get_arg_setup_decomp (s,md)) = ag32_ffi_get_arg_setup s +Proof + rw[ag32_ffi_get_arg_setup_decomp_def] + \\ rw[ag32_ffi_get_arg_setup_def] +QED -Theorem ag32_ffi_get_arg_find_decomp1_thm - `∀s. +Theorem ag32_ffi_get_arg_find_decomp1_thm: + ∀s. (∃n. s.MEM (s.R 5w + n2w n) = 0w) ⇒ - (ag32_ffi_get_arg_find_decomp1 s = ag32_ffi_get_arg_find1 s)` - (recInduct ag32_ffi_get_arg_find1_ind + (ag32_ffi_get_arg_find_decomp1 s = ag32_ffi_get_arg_find1 s) +Proof + recInduct ag32_ffi_get_arg_find1_ind \\ rw[] \\ rw[Once ag32_ffi_get_arg_find_decomp_def] \\ fs[] >- ( @@ -3334,11 +3385,13 @@ Theorem ag32_ffi_get_arg_find_decomp1_thm \\ Cases_on`s.R 5w` \\ fs[word_add_n2w] \\ last_x_assum(SUBST1_TAC o SYM) \\ AP_TERM_TAC - \\ simp[]); + \\ simp[] +QED -Theorem ag32_ffi_get_arg_find_decomp_thm - `∀s. (∃n. s.MEM (s.R 5w + n2w n) = 0w) ⇒ (FST(ag32_ffi_get_arg_find_decomp (s,md)) = ag32_ffi_get_arg_find s)` - (recInduct ag32_ffi_get_arg_find_ind +Theorem ag32_ffi_get_arg_find_decomp_thm: + ∀s. (∃n. s.MEM (s.R 5w + n2w n) = 0w) ⇒ (FST(ag32_ffi_get_arg_find_decomp (s,md)) = ag32_ffi_get_arg_find s) +Proof + recInduct ag32_ffi_get_arg_find_ind \\ rw[] \\ rw[Once ag32_ffi_get_arg_find_decomp_def] >- rw[Once ag32_ffi_get_arg_find_def] @@ -3371,14 +3424,16 @@ Theorem ag32_ffi_get_arg_find_decomp_thm \\ DEP_REWRITE_TAC[ag32_ffi_get_arg_find_decomp1_thm] \\ simp[ag32Theory.dfn'JumpIfZero_def] \\ simp[ag32Theory.ALU_def, ag32Theory.ri2word_def, ag32Theory.incPC_def] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem ag32_ffi_get_arg_store_decomp_thm - `∀s. +Theorem ag32_ffi_get_arg_store_decomp_thm: + ∀s. (∃n. s.MEM (s.R 5w + n2w n) = 0w ∧ ∀i. i ≤ n ⇒ s.R 3w ≠ s.R 5w + n2w i) ⇒ - FST(ag32_ffi_get_arg_store_decomp (s,md)) = ag32_ffi_get_arg_store s` - (recInduct ag32_ffi_get_arg_store_ind + FST(ag32_ffi_get_arg_store_decomp (s,md)) = ag32_ffi_get_arg_store s +Proof + recInduct ag32_ffi_get_arg_store_ind \\ rw[] \\ rw[Once ag32_ffi_get_arg_store_decomp_def] >- ( @@ -3415,25 +3470,29 @@ Theorem ag32_ffi_get_arg_store_decomp_thm \\ first_x_assum drule \\ strip_tac \\ first_x_assum drule - \\ simp[]); + \\ simp[] +QED -Theorem ag32_ffi_get_arg_find_decomp1_pre' - `∀off s. - s.MEM (s.R 5w + n2w off) = 0w ⇒ ag32_ffi_get_arg_find_decomp1_pre s` - (Induct >> simp[Once ag32_ffi_get_arg_find_decomp_def] >> +Theorem ag32_ffi_get_arg_find_decomp1_pre': + ∀off s. + s.MEM (s.R 5w + n2w off) = 0w ⇒ ag32_ffi_get_arg_find_decomp1_pre s +Proof + Induct >> simp[Once ag32_ffi_get_arg_find_decomp_def] >> simp[ag32Theory.dfn'JumpIfZero_def, ag32Theory.ri2word_def, ag32Theory.ALU_def, ag32Theory.dfn'Normal_def, ag32Theory.norm_def, ag32Theory.incPC_def, ag32Theory.dfn'LoadMEMByte_def, ag32Theory.dfn'JumpIfNotZero_def, combinTheory.UPDATE_def] >> qx_gen_tac ‘s’ >> strip_tac >> Cases_on ‘w2w (s.MEM (s.R 5w)) = (0w : word32)’ >> simp[] >> - first_x_assum irule >> simp[] >> fs[ADD1, GSYM word_add_n2w]); + first_x_assum irule >> simp[] >> fs[ADD1, GSYM word_add_n2w] +QED -Theorem ag32_ffi_get_arg_find_decomp_pre' - `∀c md s. +Theorem ag32_ffi_get_arg_find_decomp_pre': + ∀c md s. has_n_args s.MEM (s.R 5w) c ∧ w2n (s.R 6w) ≤ c ⇒ - ag32_ffi_get_arg_find_decomp_pre (s,md)` - (Induct >> simp[Once ag32_ffi_get_arg_find_decomp_def] >> + ag32_ffi_get_arg_find_decomp_pre (s,md) +Proof + Induct >> simp[Once ag32_ffi_get_arg_find_decomp_def] >> simp[has_n_args_def, PULL_EXISTS] >> rpt strip_tac >> Cases_on ‘s.R 6w = 0w’ >> simp[] >> simp[ag32Theory.dfn'JumpIfZero_def, ag32Theory.ri2word_def, @@ -3455,11 +3514,13 @@ Theorem ag32_ffi_get_arg_find_decomp_pre' reverse conj_tac >- simp[Abbr‘s1’, GSYM word_add_n2w] >> simp[Abbr‘s1’] >> Q.ISPEC_THEN ‘s.R 6w’ mp_tac ranged_word_nchotomy >> rw[] >> fs[] >> - simp[WORD_LITERAL_ADD]); + simp[WORD_LITERAL_ADD] +QED -Theorem SND_ag32_ffi_get_arg_find_decomp - `∀p. (∃n. (FST p).MEM ((FST p).R 5w + n2w n) = 0w) ⇒ SND (ag32_ffi_get_arg_find_decomp p) = SND p` - (simp[FORALL_PROD] +Theorem SND_ag32_ffi_get_arg_find_decomp: + ∀p. (∃n. (FST p).MEM ((FST p).R 5w + n2w n) = 0w) ⇒ SND (ag32_ffi_get_arg_find_decomp p) = SND p +Proof + simp[FORALL_PROD] \\ recInduct ag32_ffi_get_arg_find_ind \\ rw[] \\ rw[Once ag32_ffi_get_arg_find_decomp_def] @@ -3490,7 +3551,8 @@ Theorem SND_ag32_ffi_get_arg_find_decomp \\ qexists_tac`n + dimword(:32) -1 - x` \\ last_x_assum(SUBST1_TAC o SYM) \\ AP_TERM_TAC - \\ simp[] ); + \\ simp[] +QED val ag32_ffi_get_arg_setup_decomp_thm' = Q.prove( ‘ag32_ffi_get_arg_setup_decomp (s,md) = (ag32_ffi_get_arg_setup s, md)’, @@ -3515,14 +3577,15 @@ val ag32_ffi_get_arg_setup_decomp_pre' = “ag32_ffi_get_arg_setup_decomp_pre(s,md)” |> EQT_ELIM |> DISCH_ALL end -Theorem ag32_ffi_get_arg_store_decomp_pre' - `∀n md s. +Theorem ag32_ffi_get_arg_store_decomp_pre': + ∀n md s. (s.MEM (s.R 5w + n2w n) = 0w) ∧ (∀i. i ≤ n ⇒ s.R 3w ≠ s.R 5w + n2w i) ∧ (∀i. i ≤ n ⇒ s.R 3w + n2w i ∈ md) ⇒ - ag32_ffi_get_arg_store_decomp_pre (s,md)` - (Induct >> simp[Once ag32_ffi_get_arg_store_decomp_def] + ag32_ffi_get_arg_store_decomp_pre (s,md) +Proof + Induct >> simp[Once ag32_ffi_get_arg_store_decomp_def] >- ( rw[ag32Theory.dfn'LoadMEMByte_def, ag32Theory.incPC_def, APPLY_UPDATE_THM, ag32Theory.ri2word_def] ) @@ -3553,10 +3616,11 @@ Theorem ag32_ffi_get_arg_store_decomp_pre' \\ fs[ADD1, GSYM word_add_n2w] \\ rw[] \\ last_x_assum(qspec_then`n+1`mp_tac) - \\ simp[GSYM word_add_n2w]); + \\ simp[GSYM word_add_n2w] +QED -Theorem ag32_ffi_get_arg_code_thm - `(∀k. k < LENGTH ag32_ffi_get_arg_code ⇒ +Theorem ag32_ffi_get_arg_code_thm: + (∀k. k < LENGTH ag32_ffi_get_arg_code ⇒ (get_mem_word s.MEM (s.PC + n2w (4 * k)) = Encode (EL k ag32_ffi_get_arg_code))) ∧ byte_aligned s.PC ∧ @@ -3573,8 +3637,9 @@ Theorem ag32_ffi_get_arg_code_thm (∀i. i ≤ n ⇒ s.R 3w ≠ start + n2w i) ∧ (∀i. i ≤ n ⇒ s.R 3w + n2w i ∉ {s.PC + n2w k | k | k < 4 * LENGTH ag32_ffi_get_arg_code })) ⇒ - ∃k. (FUNPOW Next k s = ag32_ffi_get_arg s)` - (simp[ag32_ffi_get_arg_def] + ∃k. (FUNPOW Next k s = ag32_ffi_get_arg s) +Proof + simp[ag32_ffi_get_arg_def] \\ strip_tac \\ qabbrev_tac`fmd = COMPL {s.PC + n2w k | k | k < 4 * LENGTH ag32_ffi_get_arg_code }` \\ qspec_then`fmd`mp_tac(GSYM (Q.GEN`md`ag32_ffi_get_arg_setup_decomp_thm)) @@ -3669,7 +3734,8 @@ Theorem ag32_ffi_get_arg_code_thm \\ irule ag32_ffi_get_arg_find_decomp_pre' \\ qexists_tac`SUC index` \\ simp[Abbr`s1`, APPLY_UPDATE_THM] - \\ fs[EVAL``cline_size``]); + \\ fs[EVAL``cline_size``] +QED (* ag32_ffi_open_in *) @@ -3700,16 +3766,17 @@ val ag32_ffi_open_in_FUNPOW_Next = let val ag32_ffi_open_in_entrypoint_thm = EVAL “ag32_ffi_open_in_entrypoint” -Theorem ag32_ffi_open_in_code_thm - `(∀k. k < LENGTH ag32_ffi_open_in_code ⇒ +Theorem ag32_ffi_open_in_code_thm: + (∀k. k < LENGTH ag32_ffi_open_in_code ⇒ get_mem_word s.MEM (s.PC + n2w (4 * k)) = Encode (EL k ag32_ffi_open_in_code)) ∧ byte_aligned s.PC ∧ (s.PC = n2w (ffi_code_start_offset + ag32_ffi_open_in_entrypoint)) ∧ s.R 3w ∉ { s.PC + n2w n | n < 4 * LENGTH ag32_ffi_open_in_code} ⇒ - ∃k. (FUNPOW Next k s = ag32_ffi_open_in s)` - (strip_tac >> + ∃k. (FUNPOW Next k s = ag32_ffi_open_in s) +Proof + strip_tac >> irule ag32_ffi_open_in_FUNPOW_Next \\ fs [] >> assume_tac (EVAL “LENGTH ag32_ffi_open_in_code”) >> simp[] >> @@ -3723,7 +3790,8 @@ Theorem ag32_ffi_open_in_code_thm simp[Abbr‘n’, ag32_ffi_open_in_entrypoint_thm, DIV_LT_X, word_add_n2w] >> reverse conj_tac >- intLib.ARITH_TAC >> rfs[ag32_ffi_open_in_entrypoint_thm, ffi_code_start_offset_thm, - word_add_n2w] >> fs[]); + word_add_n2w] >> fs[] +QED (* ag32_ffi_open_out *) @@ -3753,16 +3821,17 @@ val ag32_ffi_open_out_fail_FUNPOW_Next = let in REWRITE_RULE [ag32_ffi_open_out_intro] th end; val ag32_ffi_open_out_entrypoint_thm = EVAL “ag32_ffi_open_out_entrypoint” -Theorem ag32_ffi_open_out_code_thm - `(∀k. k < LENGTH ag32_ffi_open_out_code ⇒ +Theorem ag32_ffi_open_out_code_thm: + (∀k. k < LENGTH ag32_ffi_open_out_code ⇒ (get_mem_word s.MEM (s.PC + n2w (4 * k)) = Encode (EL k ag32_ffi_open_out_code))) ∧ byte_aligned s.PC ∧ (s.PC = n2w (ffi_code_start_offset + ag32_ffi_open_out_entrypoint)) ∧ s.R 3w ∉ {s.PC + n2w n | n < 4 * LENGTH ag32_ffi_open_out_code} ⇒ - ∃k. (FUNPOW Next k s = ag32_ffi_open_out s)` - (strip_tac >> + ∃k. (FUNPOW Next k s = ag32_ffi_open_out s) +Proof + strip_tac >> irule ag32_ffi_open_out_fail_FUNPOW_Next >> assume_tac (EVAL “LENGTH ag32_ffi_open_out_code”) >> fs [ag32_ffi_open_out_entrypoint_thm, ffi_code_start_offset_thm] >> @@ -3775,7 +3844,8 @@ Theorem ag32_ffi_open_out_code_thm simp[Abbr‘n’, DIV_LT_X, word_add_n2w] >> reverse conj_tac >- intLib.ARITH_TAC >> rfs[ag32_ffi_open_out_entrypoint_thm, ffi_code_start_offset_thm, - word_add_n2w]); + word_add_n2w] +QED (* ag32_ffi_close *) @@ -3804,16 +3874,17 @@ val ag32_ffi_close_fail_FUNPOW_Next = let ag32_ffi_return_def,ag32_ffi_fail_def]) in REWRITE_RULE [ag32_ffi_close_intro] th end -Theorem ag32_ffi_close_code_thm - `(∀k. k < LENGTH ag32_ffi_close_code ⇒ +Theorem ag32_ffi_close_code_thm: + (∀k. k < LENGTH ag32_ffi_close_code ⇒ (get_mem_word s.MEM (s.PC + n2w (4 * k)) = Encode (EL k ag32_ffi_close_code))) ∧ byte_aligned s.PC ∧ (s.PC = n2w (ffi_code_start_offset + ag32_ffi_close_entrypoint)) ∧ s.R 3w ∉ { s.PC + n2w n | n < 4 * LENGTH ag32_ffi_close_code} ⇒ - ∃k. (FUNPOW Next k s = ag32_ffi_close s)` - (strip_tac + ∃k. (FUNPOW Next k s = ag32_ffi_close s) +Proof + strip_tac \\ irule ag32_ffi_close_fail_FUNPOW_Next \\ simp [EVAL ``LENGTH ag32_ffi_close_code``] \\ fs [theorem "ag32_ffi_close_fail_decomp_pre_def", @@ -3831,18 +3902,20 @@ Theorem ag32_ffi_close_code_thm \\ qexists_tac `{n2w n; s.R 3w}` \\ rfs [Abbr `n`, DIV_LT_X] \\ rw [word_add_n2w, DISJ_EQ_IMP] - \\ strip_tac \\ fs []); + \\ strip_tac \\ fs [] +QED (* ag32_ffi_ *) -Theorem ag32_ffi__code_thm - `(∀k. k < LENGTH ag32_ffi__code ⇒ +Theorem ag32_ffi__code_thm: + (∀k. k < LENGTH ag32_ffi__code ⇒ (get_mem_word s.MEM (s.PC + n2w (4 * k)) = Encode (EL k ag32_ffi__code))) ∧ byte_aligned s.PC ⇒ - ∃k. (FUNPOW Next k s = ag32_ffi_ s)` - (rw[ag32_ffi__def] + ∃k. (FUNPOW Next k s = ag32_ffi_ s) +Proof + rw[ag32_ffi__def] \\ rw[Once EXISTS_NUM] \\ disj2_tac \\ rw[FUNPOW] \\ rw[ag32Theory.Next_def] \\ qmatch_goalsub_abbrev_tac`pc + 2w` @@ -3857,14 +3930,15 @@ Theorem ag32_ffi__code_thm \\ simp[ag32_ffi__code_def, ag32Theory.Run_def] \\ EVERY (List.tabulate(1, next_tac o (curry(op +)1))) \\ rw[Once EXISTS_NUM] - \\ simp[EVAL``EL 1 ag32_ffi__code``]); + \\ simp[EVAL``EL 1 ag32_ffi__code``] +QED val ag32_ffi__entrypoint_thm = EVAL “ag32_ffi__entrypoint” (* mk_jump_ag32 *) -Theorem mk_jump_ag32_code_thm - `(s.PC = n2w (ffi_jumps_offset + ffi_offset * (LENGTH ffi_names - (index + 1)))) ∧ +Theorem mk_jump_ag32_code_thm: + (s.PC = n2w (ffi_jumps_offset + ffi_offset * (LENGTH ffi_names - (index + 1)))) ∧ (INDEX_OF nm ffi_names = SOME index) ∧ (ALOOKUP ffi_entrypoints nm = SOME epc) ∧ (∀k. k < 4 ⇒ @@ -3876,8 +3950,9 @@ Theorem mk_jump_ag32_code_thm s with <| PC := n2w (ffi_code_start_offset + epc) ; R := ((5w =+ r5) s.R) ; CarryFlag := cf - ; OverflowFlag := ov |>)` - (rw[] + ; OverflowFlag := ov |>) +Proof + rw[] \\ rw[Once EXISTS_NUM] \\ disj2_tac \\ simp[FUNPOW] \\ simp[ag32Theory.Next_def] \\ qmatch_goalsub_abbrev_tac`pc + 2w` @@ -3972,6 +4047,7 @@ Theorem mk_jump_ag32_code_thm \\ simp[LEFT_ADD_DISTRIB, LEFT_SUB_DISTRIB] \\ qpat_x_assum`_ = SOME epc`mp_tac \\ EVAL_TAC - \\ rpt(IF_CASES_TAC \\ simp[])); + \\ rpt(IF_CASES_TAC \\ simp[]) +QED val _ = export_theory(); diff --git a/compiler/backend/ag32/proofs/ag32_machine_configScript.sml b/compiler/backend/ag32/proofs/ag32_machine_configScript.sml index b988d0afd8..c19bfc5ae5 100644 --- a/compiler/backend/ag32/proofs/ag32_machine_configScript.sml +++ b/compiler/backend/ag32/proofs/ag32_machine_configScript.sml @@ -107,25 +107,30 @@ val ag32_machine_config_def = Define` ffi_interfer := K (ag32_ffi_interfer ffi_names md) |>` -Theorem is_ag32_machine_config_ag32_machine_config - `is_ag32_machine_config (ag32_machine_config a b c)` (EVAL_TAC); +Theorem is_ag32_machine_config_ag32_machine_config: + is_ag32_machine_config (ag32_machine_config a b c) +Proof +EVAL_TAC +QED val ag32_ffi_mem_domain_def = Define` ag32_ffi_mem_domain = { w | n2w startup_code_size <=+ (w:word32) ∧ w <+ n2w ffi_code_start_offset }`; -Theorem ag32_ffi_mem_domain_DISJOINT_prog_addresses - `num_ffis ≤ LENGTH FFI_codes ∧ +Theorem ag32_ffi_mem_domain_DISJOINT_prog_addresses: + num_ffis ≤ LENGTH FFI_codes ∧ code_start_offset num_ffis + lc + ld ≤ memory_size ⇒ - DISJOINT (ag32_ffi_mem_domain) (ag32_prog_addresses num_ffis lc ld)` - (EVAL_TAC + DISJOINT (ag32_ffi_mem_domain) (ag32_prog_addresses num_ffis lc ld) +Proof + EVAL_TAC \\ strip_tac \\ simp[IN_DISJOINT, PULL_FORALL] \\ rpt Cases \\ fs[LEFT_ADD_DISTRIB] \\ fs[word_lo_n2w, word_ls_n2w, word_add_n2w] - \\ rfs[]); + \\ rfs[] +QED val _ = export_theory(); diff --git a/compiler/backend/ag32/proofs/ag32_memoryProofScript.sml b/compiler/backend/ag32/proofs/ag32_memoryProofScript.sml index 30ec604f00..6094c45b84 100644 --- a/compiler/backend/ag32/proofs/ag32_memoryProofScript.sml +++ b/compiler/backend/ag32/proofs/ag32_memoryProofScript.sml @@ -14,11 +14,12 @@ val _ = new_theory"ag32_memoryProof"; (* TODO: move *) -Theorem get_byte_word_of_bytes - `good_dimindex(:'a) ⇒ +Theorem get_byte_word_of_bytes: + good_dimindex(:'a) ⇒ i < LENGTH ls ∧ LENGTH ls ≤ w2n (bytes_in_word:'a word) ⇒ - (get_byte (n2w i) (word_of_bytes be (0w:'a word) ls) be = EL i ls)` - (strip_tac + (get_byte (n2w i) (word_of_bytes be (0w:'a word) ls) be = EL i ls) +Proof + strip_tac \\ `∃k. dimindex(:'a) DIV 8 = 2 ** k` by( fs[labPropsTheory.good_dimindex_def] \\ TRY(qexists_tac`2` \\ EVAL_TAC \\ NO_TAC) @@ -30,15 +31,17 @@ Theorem get_byte_word_of_bytes \\ fs[labPropsTheory.good_dimindex_def] \\ rfs[]) \\ rw[] \\ DEP_REWRITE_TAC[data_to_word_memoryProofTheory.get_byte_bytes_to_word] - \\ rw[]); + \\ rw[] +QED -Theorem get_byte_EL_words_of_bytes - `∀be ls. +Theorem get_byte_EL_words_of_bytes: + ∀be ls. i < LENGTH ls ∧ w2n (bytes_in_word:'a word) * LENGTH ls ≤ dimword(:'a) ∧ good_dimindex(:'a) ⇒ (get_byte (n2w i : α word) (EL (w2n (byte_align ((n2w i):α word)) DIV (w2n (bytes_in_word:α word))) - (words_of_bytes be ls)) be = EL i ls)` - (completeInduct_on`i` + (words_of_bytes be ls)) be = EL i ls) +Proof + completeInduct_on`i` \\ Cases_on`ls` \\ rw[words_of_bytes_def] \\ qmatch_goalsub_abbrev_tac`MAX 1 bw` @@ -108,16 +111,18 @@ Theorem get_byte_EL_words_of_bytes \\ simp[] \\ disch_then(qspecl_then[`be`,`DROP (bw-1)t`]mp_tac) \\ impl_tac >- fs[ADD1] - \\ simp[EL_DROP]); + \\ simp[EL_DROP] +QED -Theorem get_mem_word_get_byte_gen - `(∀x. r0 + n2w (4 * (LENGTH ll + k)) <=+ x ∧ x <+ r0 + n2w (4 * (LENGTH ll + k) + 4) +Theorem get_mem_word_get_byte_gen: + (∀x. r0 + n2w (4 * (LENGTH ll + k)) <=+ x ∧ x <+ r0 + n2w (4 * (LENGTH ll + k) + 4) ⇒ (m x = get_byte x (EL (w2n (byte_align x - r0) DIV 4) (ll ++ ls ++ lr)) F)) ∧ (LENGTH ll = off) ∧ k < LENGTH ls ∧ byte_aligned r0 ∧ (4 * (off + k)) < dimword(:31) ∧ w2n r0 + (4 * (off + k) + 4) < dimword(:32) - ⇒ (get_mem_word m (r0 + n2w (4 * (off + k))) = EL k ls)` - (rw[get_mem_word_def] + ⇒ (get_mem_word m (r0 + n2w (4 * (off + k))) = EL k ls) +Proof + rw[get_mem_word_def] \\ ntac 4 ( qmatch_goalsub_abbrev_tac`m x` \\ first_assum(qspec_then`x`mp_tac) @@ -173,16 +178,18 @@ Theorem get_mem_word_get_byte_gen \\ strip_tac \\ simp[Abbr`a`] ) \\ simp[EL_APPEND_EQN] \\ simp[get_byte_def, byte_index_def] - \\ blastLib.BBLAST_TAC); + \\ blastLib.BBLAST_TAC +QED val get_mem_word_get_byte = get_mem_word_get_byte_gen |> Q.GEN`r0` |> Q.SPEC`0w` |> SIMP_RULE(srw_ss())[EVAL``byte_aligned 0w``] |> curry save_thm "get_mem_word_get_byte"; -Theorem ag32_enc_lengths - `LENGTH (ag32_enc istr) ∈ {4;8;12;16}` - (Cases_on`istr` +Theorem ag32_enc_lengths: + LENGTH (ag32_enc istr) ∈ {4;8;12;16} +Proof + Cases_on`istr` \\ TRY(rename1`JumpCmp _ _ ri _` \\ Cases_on`ri`) \\ TRY(rename1`Inst i ` \\ Cases_on`i`) \\ TRY(rename1`Inst (Mem m _ ri) ` \\ Cases_on`m` \\ Cases_on`ri`) @@ -192,17 +199,19 @@ Theorem ag32_enc_lengths ag32_targetTheory.ag32_constant_def, ag32_targetTheory.ag32_jump_constant_def, ag32_targetTheory.ag32_encode_def, - ag32_targetTheory.ag32_encode1_def]); + ag32_targetTheory.ag32_encode1_def] +QED -Theorem bytes_in_memory_get_byte_words - `∀ls ll a. +Theorem bytes_in_memory_get_byte_words: + ∀ls ll a. (∀k. k ∈ all_words a (LENGTH ls) ⇒ (m k = get_byte k (EL (w2n (byte_align k) DIV 4) (ll ++ words_of_bytes be ls ++ lr)) be)) ∧ (a = n2w (4 * LENGTH ll)) ∧ (all_words a (LENGTH ls) ⊆ md) ∧ 4 * (LENGTH ll) < dimword(:31) ∧ 4 * LENGTH ls ≤ dimword(:32) ⇒ - bytes_in_memory (a:word32) ls m md` - (rw[] + bytes_in_memory (a:word32) ls m md +Proof + rw[] \\ irule asmPropsTheory.read_bytearray_IMP_bytes_in_memory \\ simp[] \\ fs[SUBSET_DEF] \\ qexists_tac`SOME o m` @@ -270,7 +279,8 @@ Theorem bytes_in_memory_get_byte_words \\ qspecl_then[`be`,`ls`]mp_tac(INST_TYPE[alpha|->``:32``]get_byte_EL_words_of_bytes) \\ simp[bytes_in_word_def] \\ impl_tac >- EVAL_TAC - \\ rw[]); + \\ rw[] +QED val get_byte_repl = Q.prove(` n+m < dimword(:32) ∧ @@ -284,9 +294,10 @@ val get_byte_repl = Q.prove(` (* -- *) -Theorem byte_aligned_code_start_offset - `byte_aligned (n2w(code_start_offset num_ffis) : word32)` - (rw[code_start_offset_def] +Theorem byte_aligned_code_start_offset: + byte_aligned (n2w(code_start_offset num_ffis) : word32) +Proof + rw[code_start_offset_def] \\ `ffi_offset = 4 * w2n (bytes_in_word:word32)` by EVAL_TAC \\ pop_assum SUBST1_TAC \\ simp[GSYM word_add_n2w] @@ -295,11 +306,13 @@ Theorem byte_aligned_code_start_offset \\ impl_tac >- EVAL_TAC \\ simp[GSYM word_add_n2w, GSYM word_mul_n2w] \\ rw[Abbr`a`] - \\ EVAL_TAC); + \\ EVAL_TAC +QED -Theorem LENGTH_startup_code ` - LENGTH (startup_code f c d) ≤ startup_code_size` - (simp[startup_code_def,LENGTH_FLAT,SUM_MAP_K,MAP_MAP_o,o_DEF]>> +Theorem LENGTH_startup_code: + LENGTH (startup_code f c d) ≤ startup_code_size +Proof + simp[startup_code_def,LENGTH_FLAT,SUM_MAP_K,MAP_MAP_o,o_DEF]>> `15*16 ≤ startup_code_size` by EVAL_TAC>> match_mp_tac LESS_EQ_TRANS>> HINT_EXISTS_TAC>> @@ -309,16 +322,20 @@ Theorem LENGTH_startup_code ` match_mp_tac SUM_MAP_BOUND>> rw[]>>qspec_then`x`mp_tac (Q.GEN`istr`ag32_enc_lengths)>> rw[]>>fs[]) >> - simp[]); + simp[] +QED -Theorem LENGTH_ag32_enc_MOD_4 - `LENGTH (ag32_enc i) MOD 4 = 0` - (qspec_then`i`mp_tac(Q.GEN`istr`ag32_enc_lengths) - \\ rw[] \\ rw[]); +Theorem LENGTH_ag32_enc_MOD_4: + LENGTH (ag32_enc i) MOD 4 = 0 +Proof + qspec_then`i`mp_tac(Q.GEN`istr`ag32_enc_lengths) + \\ rw[] \\ rw[] +QED -Theorem LENGTH_startup_code_MOD_4 ` - LENGTH (startup_code f c d) MOD 4 = 0` - (simp[startup_code_def,LENGTH_FLAT,SUM_MAP_K,MAP_MAP_o,o_DEF]>> +Theorem LENGTH_startup_code_MOD_4: + LENGTH (startup_code f c d) MOD 4 = 0 +Proof + simp[startup_code_def,LENGTH_FLAT,SUM_MAP_K,MAP_MAP_o,o_DEF]>> DEP_ONCE_REWRITE_TAC [SUM_MOD]>> simp[MAP_MAP_o,o_DEF]>> qmatch_goalsub_abbrev_tac`MAP ff _`>> @@ -326,17 +343,20 @@ Theorem LENGTH_startup_code_MOD_4 ` (fs[Abbr`ff`,FUN_EQ_THM]>> rw[]>>qspec_then`x`mp_tac (Q.GEN`istr`ag32_enc_lengths)>> rw[]>>fs[])>> - simp[Q.ISPEC`λx. 0n`SUM_MAP_K |> SIMP_RULE (srw_ss())[]]); + simp[Q.ISPEC`λx. 0n`SUM_MAP_K |> SIMP_RULE (srw_ss())[]] +QED val sz = (rconc (EVAL``LENGTH ag32_ffi_code + cline_size DIV 4 + stdin_size DIV 4 + heap_size DIV 4 + startup_code_size DIV 4 + (output_buffer_size + 16) DIV 4 + 3``)); -Theorem LENGTH_init_memory_words - `SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ LENGTH inp ≤ stdin_size ⇒ +Theorem LENGTH_init_memory_words: + SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ LENGTH inp ≤ stdin_size ⇒ (LENGTH (init_memory_words c d f cl inp) = LENGTH d + LENGTH (ag32_ffi_jumps f) + LENGTH c DIV 4 + MIN 1 (LENGTH c MOD 4) + - ^(sz))` ((* adjust as necessary *) + ^(sz)) +Proof +(* adjust as necessary *) simp[init_memory_words_def] >> strip_tac>> simp[LENGTH_ag32_ffi_code]>> @@ -365,17 +385,19 @@ Theorem LENGTH_init_memory_words match_mp_tac (DECIDE``a ≤ b ⇒ (a+(b-a) = b:num)``)>> simp[LENGTH_startup_code])>> pop_assum mp_tac>>simp[]>>EVAL_TAC>> - simp[Abbr`codel`]); + simp[Abbr`codel`] +QED val lem = Q.prove(` (m MOD 4 = 0) ∧ n < m ⇒ n DIV 4 < m DIV 4`, intLib.ARITH_TAC); -Theorem init_memory_startup - `∀code data ffis n. +Theorem init_memory_startup: + ∀code data ffis n. n < LENGTH (startup_code (LENGTH ffis) (LENGTH code) (LENGTH data)) ⇒ - (init_memory code data ffis inputs (n2w n) = EL n (startup_code (LENGTH ffis) (LENGTH code) (LENGTH data)))` - (Cases_on`inputs` + (init_memory code data ffis inputs (n2w n) = EL n (startup_code (LENGTH ffis) (LENGTH code) (LENGTH data))) +Proof + Cases_on`inputs` \\ ntac 5 strip_tac \\ simp[init_memory_def] \\ qmatch_goalsub_abbrev_tac`EL n sc` @@ -404,15 +426,17 @@ Theorem init_memory_startup \\ fs[] ) >> match_mp_tac lem>> - fs[LENGTH_startup_code_MOD_4]); + fs[LENGTH_startup_code_MOD_4] +QED -Theorem init_memory_code - `∀code data ffis n. +Theorem init_memory_code: + ∀code data ffis n. SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ LENGTH inp ≤ stdin_size ∧ code_start_offset (LENGTH ffis) + (LENGTH code) + 4 * LENGTH data < memory_size ∧ n < LENGTH code ⇒ - (init_memory code data ffis (cl,inp) (n2w n + n2w (code_start_offset (LENGTH ffis))) = EL n code)` - (ntac 5 strip_tac + (init_memory code data ffis (cl,inp) (n2w n + n2w (code_start_offset (LENGTH ffis))) = EL n code) +Proof + ntac 5 strip_tac \\ simp[init_memory_def] \\ simp[word_add_n2w] \\ simp[init_memory_words_def] >> @@ -475,11 +499,12 @@ Theorem init_memory_code fs[EVAL``code_start_offset f``]>> fs[memory_size_def])>> DEP_REWRITE_TAC [get_byte_EL_words_of_bytes |> INST_TYPE [alpha|->``:32``] |> SIMP_RULE (srw_ss()) [bytes_in_word_def]]>> - EVAL_TAC>>fs[memory_size_def]); + EVAL_TAC>>fs[memory_size_def] +QED (* TODO - clean it up a bit (it repeats a lot) *) -Theorem init_memory_data - `SUM (MAP strlen cl) + LENGTH cl <= cline_size /\ +Theorem init_memory_data: + SUM (MAP strlen cl) + LENGTH cl <= cline_size /\ LENGTH inp <= stdin_size /\ code_start_offset (LENGTH ffis) + (LENGTH code) + 4 * LENGTH data < memory_size /\ @@ -492,8 +517,9 @@ Theorem init_memory_data init_memory code data ffis (cl,inp) (n2w (4 * (k + low DIV 4)) + 1w); init_memory code data ffis (cl,inp) (n2w (4 * (k + low DIV 4)) + 2w); init_memory code data ffis (cl,inp) (n2w (4 * (k + low DIV 4)) + 3w)] = - EL k data` - (rw [] + EL k data +Proof + rw [] \\ qabbrev_tac `low = LENGTH code + code_start_offset (LENGTH ffis)` \\ simp [init_memory_def] \\ simp [word_add_n2w] @@ -620,16 +646,18 @@ Theorem init_memory_data \\ intLib.ARITH_TAC) \\ pop_assum (SUBST_ALL_TAC) \\ simp[set_byte_def,get_byte_def,byte_index_def,word_slice_alt_def] - \\ blastLib.FULL_BBLAST_TAC); + \\ blastLib.FULL_BBLAST_TAC +QED -Theorem init_memory_halt - `(pc = n2w (ffi_jumps_offset + (LENGTH f + 1) * ffi_offset)) ∧ +Theorem init_memory_halt: + (pc = n2w (ffi_jumps_offset + (LENGTH f + 1) * ffi_offset)) ∧ LENGTH f ≤ LENGTH FFI_codes ∧ SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ LENGTH inp ≤ stdin_size ⇒ (get_mem_word (init_memory c d f (cl,inp)) pc = - Encode (Jump (fAdd, 0w, Imm 0w)))` - (simp[FFI_codes_def] + Encode (Jump (fAdd, 0w, Imm 0w))) +Proof + simp[FFI_codes_def] \\ strip_tac \\ qpat_x_assum`pc = _`(assume_tac o ONCE_REWRITE_RULE[GSYM markerTheory.Abbrev_def]) \\ qspecl_then[`c`,`d`,`f`,`cl`,`inp`]mp_tac init_memory_words_def @@ -682,16 +710,18 @@ Theorem init_memory_halt \\ simp[Abbr`pc`] \\ EVAL_TAC \\ simp[] ) - \\ simp[Abbr`ls`, halt_jump_ag32_code_def]); + \\ simp[Abbr`ls`, halt_jump_ag32_code_def] +QED -Theorem init_memory_ccache - `(pc = n2w (ffi_jumps_offset + (LENGTH f + 0) * ffi_offset)) ∧ +Theorem init_memory_ccache: + (pc = n2w (ffi_jumps_offset + (LENGTH f + 0) * ffi_offset)) ∧ LENGTH f ≤ LENGTH FFI_codes ∧ SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ LENGTH inp ≤ stdin_size ⇒ (get_mem_word (init_memory c d f (cl,inp)) pc = - Encode (Jump (fSnd, 0w, Reg 0w)))` - (simp[FFI_codes_def] + Encode (Jump (fSnd, 0w, Reg 0w))) +Proof + simp[FFI_codes_def] \\ strip_tac \\ qpat_x_assum`pc = _`(assume_tac o ONCE_REWRITE_RULE[GSYM markerTheory.Abbrev_def]) \\ qspecl_then[`c`,`d`,`f`,`cl`,`inp`]mp_tac init_memory_words_def @@ -744,14 +774,16 @@ Theorem init_memory_ccache \\ simp[Abbr`pc`] \\ EVAL_TAC \\ simp[] ) - \\ simp[Abbr`ls`, ccache_jump_ag32_code_def]); + \\ simp[Abbr`ls`, ccache_jump_ag32_code_def] +QED -Theorem init_memory_startup_bytes_in_memory - `i < LENGTH sc ∧ +Theorem init_memory_startup_bytes_in_memory: + i < LENGTH sc ∧ (sc = startup_asm_code (LENGTH ffis) (n2w (LENGTH code)) (n2w (4 * (LENGTH data)))) ⇒ bytes_in_memory (n2w (SUM (MAP (LENGTH o ag32_enc) (TAKE i sc)))) (ag32_enc (EL i sc)) - (init_memory code data ffis inputs) ag32_startup_addresses` - (rw[] + (init_memory code data ffis inputs) ag32_startup_addresses +Proof + rw[] \\ qmatch_asmsub_abbrev_tac`i < LENGTH sc` \\ qmatch_goalsub_abbrev_tac`bytes_in_memory a _ m` \\ `∃ll lr. @@ -840,7 +872,8 @@ Theorem init_memory_startup_bytes_in_memory word_ls_n2w, word_lo_n2w] \\ simp[EVAL``heap_start_offset``, EVAL``startup_code_size``] \\ fs[Abbr`ls`, LENGTH_TAKE_EQ] \\ rfs[] - \\ fs[Abbr`sc`, LENGTH_startup_asm_code]); + \\ fs[Abbr`sc`, LENGTH_startup_asm_code] +QED val init_asm_state_def = Define` init_asm_state code data ffis input = @@ -1010,8 +1043,8 @@ val hide_def = Define` hide x = x` *) -Theorem init_asm_state_asm_step - `∀code data ffis cl inp. +Theorem init_asm_state_asm_step: + ∀code data ffis cl inp. SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ LENGTH inp ≤ stdin_size ∧ LENGTH ffis ≤ LENGTH FFI_codes ∧ @@ -1053,8 +1086,9 @@ Theorem init_asm_state_asm_step ds) ∧ (∀k. k < 4 * LENGTH data + 4 ⇒ (final_st.mem (ds + n2w k) = - (im (cl,inp)) (ds + n2w k)))` - (ntac 6 strip_tac + (im (cl,inp)) (ds + n2w k))) +Proof + ntac 6 strip_tac \\ qho_match_abbrev_tac`LET (λtr. (_ tr) ∧ P (_ tr)) _` \\ rewrite_tac[startup_asm_code_def] \\ simp[] @@ -1204,10 +1238,11 @@ Theorem init_asm_state_asm_step fs[memory_size_def]) \\ rpt (IF_CASES_TAC >- (rveq>>fs[WORD_LO])) - \\ simp[]); + \\ simp[] +QED -Theorem init_asm_state_RTC_asm_step - `∀code data ffis cl inp. +Theorem init_asm_state_RTC_asm_step: + ∀code data ffis cl inp. SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ LENGTH inp ≤ stdin_size ∧ LENGTH ffis ≤ LENGTH FFI_codes ∧ @@ -1243,8 +1278,9 @@ Theorem init_asm_state_RTC_asm_step = ds) ∧ (∀k. k < 4 * LENGTH data + 4 ⇒ (iasmstate.mem (ds + n2w k) = - im (cl,inp) (ds + n2w k)))` - (ntac 5 strip_tac>> + im (cl,inp) (ds + n2w k))) +Proof + ntac 5 strip_tac>> disch_then assume_tac>> qspecl_then [`code`,`data`,`ffis`,`cl`,`inp`] mp_tac init_asm_state_asm_step>> simp[]>> @@ -1257,6 +1293,7 @@ Theorem init_asm_state_RTC_asm_step \\ drule NRC_RTC \\ fs[LAST_MAP_SND_steps_FOLDL, init_asm_state_def] \\ fs[ag32_targetTheory.ag32_target_def] - \\ rfs[]); + \\ rfs[] +QED val _ = export_theory(); diff --git a/compiler/backend/ag32/proofs/ag32_progScript.sml b/compiler/backend/ag32/proofs/ag32_progScript.sml index ec7ac8ba05..e03428d3aa 100644 --- a/compiler/backend/ag32/proofs/ag32_progScript.sml +++ b/compiler/backend/ag32/proofs/ag32_progScript.sml @@ -157,12 +157,13 @@ val lemma = ``p (ag32_proj' y s) ==> (?u v. SPLIT (ag32_proj s) (u,v) /\ p u /\ (\v. v = ag32_proj'' y s) v)``; -Theorem AG32_SPEC_SEMANTICS - `SPEC AG32_MODEL p {} q = +Theorem AG32_SPEC_SEMANTICS: + SPEC AG32_MODEL p {} q = !y s seq. p (ag32_proj' y s) /\ rel_sequence (λx y. y = Next x) seq s ==> ?k. q (ag32_proj' y (seq k)) /\ - (ag32_proj'' y s = ag32_proj'' y (seq k))` - (simp_tac std_ss [GSYM RUN_EQ_SPEC,RUN_def,AG32_MODEL_def,STAR_def,SEP_REFINE_def] + (ag32_proj'' y s = ag32_proj'' y (seq k)) +Proof + simp_tac std_ss [GSYM RUN_EQ_SPEC,RUN_def,AG32_MODEL_def,STAR_def,SEP_REFINE_def] \\ rpt strip_tac \\ reverse eq_tac \\ rpt strip_tac THEN1 (full_simp_tac bool_ss [SPLIT_ag32_proj_EXISTS] \\ metis_tac []) \\ fs [PULL_EXISTS] @@ -172,12 +173,14 @@ Theorem AG32_SPEC_SEMANTICS \\ disch_then (qspec_then `(\v. v = ag32_proj'' y s)` mp_tac) \\ fs [] \\ rw [] \\ full_simp_tac bool_ss [SPLIT_ag32_proj_EXISTS] - \\ imp_res_tac ag32_proj''_11 \\ qexists_tac `i` \\ metis_tac []); - -Theorem aD_STAR_ag32_proj - `(aD md * p) (ag32_proj' (fs,ms,pc) s) <=> - md SUBSET ms /\ p (ag32_proj' (fs,ms DIFF md,pc) s)` - (simp_tac std_ss [aS_def,aM_def,aP_def,aB_def,EQ_STAR,INSERT_SUBSET,cond_STAR, + \\ imp_res_tac ag32_proj''_11 \\ qexists_tac `i` \\ metis_tac [] +QED + +Theorem aD_STAR_ag32_proj: + (aD md * p) (ag32_proj' (fs,ms,pc) s) <=> + md SUBSET ms /\ p (ag32_proj' (fs,ms DIFF md,pc) s) +Proof + simp_tac std_ss [aS_def,aM_def,aP_def,aB_def,EQ_STAR,INSERT_SUBSET,cond_STAR, EMPTY_SUBSET,IN_ag32_proj,GSYM DELETE_DEF,aD_def,SEP_CLAUSES,SEP_EXISTS_THM] \\ eq_tac \\ rw [] THEN1 @@ -198,10 +201,11 @@ Theorem aD_STAR_ag32_proj \\ Cases \\ fs [] \\ rw [] \\ fs [SUBSET_DEF,PULL_EXISTS] \\ Cases_on `c IN md` \\ fs []) \\ fs [SUBSET_DEF] \\ rw [] \\ fs [PULL_EXISTS] - \\ res_tac \\ fs [IN_ag32_proj]); + \\ res_tac \\ fs [IN_ag32_proj] +QED -Theorem STAR_ag32_proj - `((aS t * p) (ag32_proj' (fs,ms,pc) s) <=> +Theorem STAR_ag32_proj: + ((aS t * p) (ag32_proj' (fs,ms,pc) s) <=> (t = s) /\ fs /\ p (ag32_proj' (F,ms,pc) s)) /\ ((aM b y * p) (ag32_proj' (fs,ms,pc) s) <=> (y = s.MEM b) /\ b IN ms /\ p (ag32_proj' (fs,ms DELETE b,pc) s)) /\ @@ -210,14 +214,16 @@ Theorem STAR_ag32_proj ((aP q * p) (ag32_proj' (fs,ms,pc) s) <=> (q = s.PC) /\ pc /\ p (ag32_proj' (fs,ms,F) s)) /\ ((cond g * p) (ag32_proj' (fs,ms,pc) s) <=> - g /\ p (ag32_proj' (fs,ms,pc) s))` - (simp [aD_STAR_ag32_proj] + g /\ p (ag32_proj' (fs,ms,pc) s)) +Proof + simp [aD_STAR_ag32_proj] \\ simp_tac std_ss [aS_def,aM_def,aP_def,aB_def,EQ_STAR,INSERT_SUBSET,cond_STAR, EMPTY_SUBSET,IN_ag32_proj,GSYM DELETE_DEF,aD_def,SEP_CLAUSES,SEP_EXISTS_THM] \\ Cases_on `t = s` \\ asm_simp_tac bool_ss [DELETE_ag32_proj] \\ Cases_on `y = s.MEM b` \\ asm_simp_tac bool_ss [DELETE_ag32_proj] \\ Cases_on `q = s.PC` \\ asm_simp_tac bool_ss [DELETE_ag32_proj] - \\ asm_simp_tac std_ss [AC CONJ_COMM CONJ_ASSOC]); + \\ asm_simp_tac std_ss [AC CONJ_COMM CONJ_ASSOC] +QED val CODE_POOL_ag32_proj_LEMMA = prove( ``!x y z. (x = (z INSERT y)) <=> (z INSERT y) SUBSET x /\ @@ -260,9 +266,11 @@ val IMP_AG32_SPEC_LEMMA = prove( \\ qexists_tac `SUC 0` \\ metis_tac [PAIR,optionTheory.SOME_11]); val _ = wordsLib.guess_lengths(); -Theorem BYTES_TO_WORD_LEMMA - `!w. (31 >< 24) w @@ (23 >< 16) w @@ (15 >< 8) w @@ (7 >< 0) w = w` - (SRW_TAC [wordsLib.WORD_EXTRACT_ss] []); +Theorem BYTES_TO_WORD_LEMMA: + !w. (31 >< 24) w @@ (23 >< 16) w @@ (15 >< 8) w @@ (7 >< 0) w = w +Proof + SRW_TAC [wordsLib.WORD_EXTRACT_ss] [] +QED val IMP_AG32_SPEC = save_thm("IMP_AG32_SPEC", (ONCE_REWRITE_RULE [STAR_COMM] o REWRITE_RULE [AG32_SPEC_CODE] o @@ -272,19 +280,22 @@ val IMP_AG32_SPEC = save_thm("IMP_AG32_SPEC", val mem_unchanged_def = Define ` mem_unchanged md m1 m2 = (!a. ~(a IN md) ==> m1 a = m2 a)`; -Theorem mem_unchanged_same[simp] - `mem_unchanged md m m` - (fs [mem_unchanged_def]); +Theorem mem_unchanged_same[simp]: + mem_unchanged md m m +Proof + fs [mem_unchanged_def] +QED -Theorem ANY_AG32_SPEC_LEMMA - `!w ast. +Theorem ANY_AG32_SPEC_LEMMA: + !w ast. ast = Decode w ==> mem_unchanged md (Run ast s).MEM s.MEM ==> SPEC AG32_MODEL (aS s * aD md * aPC p) {(p,w)} - (aS (Run ast s) * aD md * aP (Run ast s).PC)` - (fs [Next_def,mem_unchanged_def] + (aS (Run ast s) * aD md * aP (Run ast s).PC) +Proof + fs [Next_def,mem_unchanged_def] \\ rw [aPC_def] \\ match_mp_tac IMP_AG32_SPEC \\ simp [SEP_CLAUSES,SEP_EXISTS_THM] @@ -307,18 +318,20 @@ Theorem ANY_AG32_SPEC_LEMMA \\ rveq \\ fs [Next_def] \\ Cases \\ fs [IN_ag32_proj] \\ Cases_on `c IN ms` \\ fs [] - \\ metis_tac [SUBSET_DEF]); + \\ metis_tac [SUBSET_DEF] +QED -Theorem ANY_AG32_SPEC - `!w ast. +Theorem ANY_AG32_SPEC: + !w ast. ast = Decode w ==> (aligned 2 s.PC ==> aligned 2 (Run ast s).PC) /\ mem_unchanged md (Run ast s).MEM s.MEM ==> SPEC AG32_MODEL (aS s * aD md * aPC p) {(p,w)} - (aS (Run ast s) * aD md * aPC (Run ast s).PC)` - (rw [] + (aS (Run ast s) * aD md * aPC (Run ast s).PC) +Proof + rw [] \\ drule (SIMP_RULE std_ss [] ANY_AG32_SPEC_LEMMA) \\ fs [aPC_def,STAR_ASSOC,SPEC_MOVE_COND] \\ Cases_on `aligned 2 (Run (Decode w) s).PC` \\ fs [SEP_CLAUSES] @@ -327,16 +340,19 @@ Theorem ANY_AG32_SPEC \\ once_rewrite_tac [GSYM AG32_SPEC_CODE] \\ once_rewrite_tac [STAR_COMM] \\ fs [AG32_SPEC_SEMANTICS,FORALL_PROD] - \\ fs [STAR_ag32_proj,GSYM STAR_ASSOC,aPC_def]); - -Theorem SPEC_AG32_FIX_POST_PC - `SPEC AG32_MODEL (aS s * aD md * aPC p) c (post s.PC) ==> - SPEC AG32_MODEL (aS s * aD md * aPC p) c (post p)` - (Cases_on `p = s.PC` \\ fs [] + \\ fs [STAR_ag32_proj,GSYM STAR_ASSOC,aPC_def] +QED + +Theorem SPEC_AG32_FIX_POST_PC: + SPEC AG32_MODEL (aS s * aD md * aPC p) c (post s.PC) ==> + SPEC AG32_MODEL (aS s * aD md * aPC p) c (post p) +Proof + Cases_on `p = s.PC` \\ fs [] \\ once_rewrite_tac [GSYM AG32_SPEC_CODE] \\ once_rewrite_tac [STAR_COMM] \\ fs [AG32_SPEC_SEMANTICS,FORALL_PROD] - \\ fs [STAR_ag32_proj,GSYM STAR_ASSOC,aPC_def]); + \\ fs [STAR_ag32_proj,GSYM STAR_ASSOC,aPC_def] +QED (* SPEC implies FUNPOW Next *) @@ -344,12 +360,13 @@ val code_set_def = Define ` code_set a [] = {} /\ code_set a (i::is) = (a:word32,i) INSERT code_set (a+4w) is`; -Theorem IN_code_set - `!a xs p x. +Theorem IN_code_set: + !a xs p x. LENGTH xs < 2**30 ==> ((p,x) IN code_set a xs <=> - ?i. p = a + n2w (4 * i) /\ x = EL i xs /\ i < LENGTH xs)` - (Induct_on `xs` \\ fs [code_set_def] \\ rw [] + ?i. p = a + n2w (4 * i) /\ x = EL i xs /\ i < LENGTH xs) +Proof + Induct_on `xs` \\ fs [code_set_def] \\ rw [] \\ reverse (Cases_on `p = a`) \\ fs [] THEN1 (eq_tac \\ rw [] THEN1 (qexists_tac `i+1` @@ -363,12 +380,13 @@ Theorem IN_code_set \\ Cases_on `x = h` \\ fs [] THEN1 (qexists_tac `0` \\ fs []) \\ eq_tac \\ rw [] - \\ `(4 * i + 4) < 4294967296` by fs [] \\ fs []); + \\ `(4 * i + 4) < 4294967296` by fs [] \\ fs [] +QED val get_mem_word_def = ag32_memoryTheory.get_mem_word_def -Theorem SPEC_IMP_FUNPOW_Next - `SPEC AG32_MODEL +Theorem SPEC_IMP_FUNPOW_Next: + SPEC AG32_MODEL (aS s * aD md * aPC s.PC) (code_set a (MAP Encode instr_list)) (aS s1 * aD md1 * other) @@ -379,8 +397,9 @@ Theorem SPEC_IMP_FUNPOW_Next Encode (EL k instr_list))) /\ byte_aligned s.PC /\ DISJOINT md { a + n2w k | k | k DIV 4 < LENGTH instr_list } ==> - ∃k. FUNPOW Next k s = s1` - (fs [alignmentTheory.byte_aligned_def] + ∃k. FUNPOW Next k s = s1 +Proof + fs [alignmentTheory.byte_aligned_def] \\ once_rewrite_tac [GSYM AG32_SPEC_CODE] \\ once_rewrite_tac [STAR_COMM] \\ fs [AG32_SPEC_SEMANTICS,FORALL_PROD] @@ -438,6 +457,7 @@ Theorem SPEC_IMP_FUNPOW_Next \\ strip_tac \\ fs [get_mem_word_def,addressTheory.word_arith_lemma1] \\ rpt (pop_assum kall_tac) - \\ blastLib.BBLAST_TAC); + \\ blastLib.BBLAST_TAC +QED val () = export_theory() diff --git a/compiler/backend/arm6/proofs/arm6_configProofScript.sml b/compiler/backend/arm6/proofs/arm6_configProofScript.sml index 54190df78f..ea430a2ea1 100644 --- a/compiler/backend/arm6/proofs/arm6_configProofScript.sml +++ b/compiler/backend/arm6/proofs/arm6_configProofScript.sml @@ -22,9 +22,10 @@ val names_tac = \\ REWRITE_TAC[SUBSET_DEF] \\ EVAL_TAC \\ rpt strip_tac \\ rveq \\ EVAL_TAC -Theorem arm6_backend_config_ok ` - backend_config_ok arm6_backend_config` - (simp[backend_config_ok_def]>>rw[]>>TRY(EVAL_TAC>>NO_TAC) +Theorem arm6_backend_config_ok: + backend_config_ok arm6_backend_config +Proof + simp[backend_config_ok_def]>>rw[]>>TRY(EVAL_TAC>>NO_TAC) >> TRY(fs[arm6_backend_config_def]>>NO_TAC) >- (EVAL_TAC>> blastLib.FULL_BBLAST_TAC) >> TRY(EVAL_TAC >> fs[armTheory.EncodeARMImmediate_def,Once armTheory.EncodeARMImmediate_aux_def]>>NO_TAC) @@ -45,11 +46,13 @@ Theorem arm6_backend_config_ok ` \\ NTAC 16 (simp [Once armTheory.EncodeARMImmediate_aux_def] \\ rw [boolTheory.COND_RAND]) - \\ blastLib.FULL_BBLAST_TAC); + \\ blastLib.FULL_BBLAST_TAC +QED -Theorem arm6_machine_config_ok - `is_arm6_machine_config mc ⇒ mc_conf_ok mc` - (rw[lab_to_targetProofTheory.mc_conf_ok_def,is_arm6_machine_config_def] +Theorem arm6_machine_config_ok: + is_arm6_machine_config mc ⇒ mc_conf_ok mc +Proof + rw[lab_to_targetProofTheory.mc_conf_ok_def,is_arm6_machine_config_def] >- EVAL_TAC >- simp[arm6_targetProofTheory.arm6_encoder_correct] >- EVAL_TAC @@ -57,14 +60,17 @@ Theorem arm6_machine_config_ok >- EVAL_TAC >- EVAL_TAC >- EVAL_TAC - >- metis_tac[asmPropsTheory.encoder_correct_def,asmPropsTheory.target_ok_def,arm6_encoder_correct]); + >- metis_tac[asmPropsTheory.encoder_correct_def,asmPropsTheory.target_ok_def,arm6_encoder_correct] +QED -Theorem arm6_init_ok - `is_arm6_machine_config mc ⇒ - mc_init_ok arm6_backend_config mc` - (rw[mc_init_ok_def] \\ +Theorem arm6_init_ok: + is_arm6_machine_config mc ⇒ + mc_init_ok arm6_backend_config mc +Proof + rw[mc_init_ok_def] \\ fs[is_arm6_machine_config_def] \\ - EVAL_TAC); + EVAL_TAC +QED val is_arm6_machine_config_mc = arm6_init_ok |> concl |> dest_imp |> #1 diff --git a/compiler/backend/arm8/proofs/arm8_configProofScript.sml b/compiler/backend/arm8/proofs/arm8_configProofScript.sml index b4748273c9..a3806bc55a 100644 --- a/compiler/backend/arm8/proofs/arm8_configProofScript.sml +++ b/compiler/backend/arm8/proofs/arm8_configProofScript.sml @@ -22,9 +22,10 @@ val names_tac = \\ REWRITE_TAC[SUBSET_DEF] \\ EVAL_TAC \\ rpt strip_tac \\ rveq \\ EVAL_TAC -Theorem arm8_backend_config_ok ` - backend_config_ok arm8_backend_config` - (simp[backend_config_ok_def]>>rw[]>>TRY(EVAL_TAC>>NO_TAC) +Theorem arm8_backend_config_ok: + backend_config_ok arm8_backend_config +Proof + simp[backend_config_ok_def]>>rw[]>>TRY(EVAL_TAC>>NO_TAC) >- fs[arm8_backend_config_def] >- (EVAL_TAC>> blastLib.FULL_BBLAST_TAC) >- names_tac @@ -46,11 +47,13 @@ Theorem arm8_backend_config_ok ` match_mp_tac bitTheory.NOT_BIT_GT_TWOEXP>>fs[])>> pop_assum mp_tac>> pop_assum mp_tac>>EVAL_TAC>> - blastLib.BBLAST_PROVE_TAC); + blastLib.BBLAST_PROVE_TAC +QED -Theorem arm8_machine_config_ok - `is_arm8_machine_config mc ⇒ mc_conf_ok mc` - (rw[lab_to_targetProofTheory.mc_conf_ok_def,is_arm8_machine_config_def] +Theorem arm8_machine_config_ok: + is_arm8_machine_config mc ⇒ mc_conf_ok mc +Proof + rw[lab_to_targetProofTheory.mc_conf_ok_def,is_arm8_machine_config_def] >- EVAL_TAC >- simp[arm8_targetProofTheory.arm8_encoder_correct] >- EVAL_TAC @@ -58,14 +61,17 @@ Theorem arm8_machine_config_ok >- EVAL_TAC >- EVAL_TAC >- EVAL_TAC - >- metis_tac[asmPropsTheory.encoder_correct_def,asmPropsTheory.target_ok_def,arm8_encoder_correct]); + >- metis_tac[asmPropsTheory.encoder_correct_def,asmPropsTheory.target_ok_def,arm8_encoder_correct] +QED -Theorem arm8_init_ok - `is_arm8_machine_config mc ⇒ - mc_init_ok arm8_backend_config mc` - (rw[mc_init_ok_def] \\ +Theorem arm8_init_ok: + is_arm8_machine_config mc ⇒ + mc_init_ok arm8_backend_config mc +Proof + rw[mc_init_ok_def] \\ fs[is_arm8_machine_config_def] \\ - EVAL_TAC); + EVAL_TAC +QED val is_arm8_machine_config_mc = arm8_init_ok |> concl |> dest_imp |> #1 diff --git a/compiler/backend/backendScript.sml b/compiler/backend/backendScript.sml index 11b09d01a0..b8ce6c7ee3 100644 --- a/compiler/backend/backendScript.sml +++ b/compiler/backend/backendScript.sml @@ -147,9 +147,10 @@ val to_target_def = Define` attach_bitmaps c.word_conf.bitmaps (lab_to_target$compile c.lab_conf p)`; -Theorem compile_eq_to_target - `compile = to_target` - (srw_tac[][FUN_EQ_THM,compile_def,compile_tap_def, +Theorem compile_eq_to_target: + compile = to_target +Proof + srw_tac[][FUN_EQ_THM,compile_def,compile_tap_def, to_target_def, to_lab_def, to_stack_def, @@ -161,7 +162,8 @@ Theorem compile_eq_to_target to_pat_def, to_flat_def] >> unabbrev_all_tac >> - rpt (CHANGED_TAC (srw_tac[][] >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> rev_full_simp_tac(srw_ss())[]))); + rpt (CHANGED_TAC (srw_tac[][] >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> rev_full_simp_tac(srw_ss())[])) +QED val prim_config_def = Define` prim_config = @@ -229,9 +231,10 @@ val from_source_def = Define` let c = c with source_conf := c' in from_flat c p`; -Theorem compile_eq_from_source - `compile = from_source` - (srw_tac[][FUN_EQ_THM,compile_def,compile_tap_def, +Theorem compile_eq_from_source: + compile = from_source +Proof + srw_tac[][FUN_EQ_THM,compile_def,compile_tap_def, from_source_def, from_lab_def, from_stack_def, @@ -243,7 +246,8 @@ Theorem compile_eq_from_source from_pat_def, from_flat_def] >> unabbrev_all_tac >> - rpt (CHANGED_TAC (srw_tac[][] >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> rev_full_simp_tac(srw_ss())[]))); + rpt (CHANGED_TAC (srw_tac[][] >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> rev_full_simp_tac(srw_ss())[])) +QED val to_livesets_def = Define` to_livesets (c:α backend$config) p = @@ -289,9 +293,10 @@ val from_livesets_def = Define` let c = c with word_to_word_conf updated_by (λc. c with col_oracle := col) in from_word c p` -Theorem compile_oracle ` - from_livesets (to_livesets c p) = compile c p` - (srw_tac[][FUN_EQ_THM, +Theorem compile_oracle: + from_livesets (to_livesets c p) = compile c p +Proof + srw_tac[][FUN_EQ_THM, to_data_def, to_bvi_def, to_bvl_def, @@ -327,14 +332,16 @@ Theorem compile_oracle ` rpt(pairarg_tac>>fs[])>> fs[word_to_wordTheory.compile_single_def,word_allocTheory.word_alloc_def]>> rveq>>fs[]>> - BasicProvers.EVERY_CASE_TAC>>fs[]); + BasicProvers.EVERY_CASE_TAC>>fs[] +QED -Theorem to_livesets_invariant ` - wc.reg_alg = c.word_to_word_conf.reg_alg ⇒ +Theorem to_livesets_invariant: + wc.reg_alg = c.word_to_word_conf.reg_alg ⇒ to_livesets (c with word_to_word_conf:=wc) p = let (rcm,c,p) = to_livesets c p in - (rcm,c with word_to_word_conf:=wc,p)` - (srw_tac[][FUN_EQ_THM, + (rcm,c with word_to_word_conf:=wc,p) +Proof + srw_tac[][FUN_EQ_THM, to_data_def, to_bvi_def, to_bvl_def, @@ -342,10 +349,11 @@ Theorem to_livesets_invariant ` to_pat_def, to_flat_def,to_livesets_def] >> unabbrev_all_tac>>fs[]>> - rpt(rfs[]>>fs[])); + rpt(rfs[]>>fs[]) +QED -Theorem to_data_change_config - `to_data c1 prog = (c1',prog') ⇒ +Theorem to_data_change_config: + to_data c1 prog = (c1',prog') ⇒ c2.source_conf = c1.source_conf ∧ c2.clos_conf = c1.clos_conf ∧ c2.bvl_conf = c1.bvl_conf @@ -354,10 +362,12 @@ Theorem to_data_change_config (c2 with <| source_conf := c1'.source_conf; clos_conf := c1'.clos_conf; bvl_conf := c1'.bvl_conf |>, - prog')` - (rw[to_data_def,to_bvi_def,to_bvl_def,to_clos_def,to_pat_def,to_flat_def] + prog') +Proof + rw[to_data_def,to_bvi_def,to_bvl_def,to_clos_def,to_pat_def,to_flat_def] \\ rpt (pairarg_tac \\ fs[]) \\ rw[] \\ fs[] \\ rfs[] \\ rveq \\ fs[] \\ rfs[] \\ rveq \\ fs[] - \\ simp[config_component_equality]); + \\ simp[config_component_equality] +QED (* val compile_explorer_def = Define` diff --git a/compiler/backend/backend_commonScript.sml b/compiler/backend/backend_commonScript.sml index c23eebedab..7922858894 100644 --- a/compiler/backend/backend_commonScript.sml +++ b/compiler/backend/backend_commonScript.sml @@ -99,8 +99,11 @@ val bvl_num_stubs_def = Define` val bvl_to_bvi_namespaces_def = Define` bvl_to_bvi_namespaces = 3n`; -Theorem bvl_num_stub_MOD - `bvl_num_stubs MOD bvl_to_bvi_namespaces = 0` (EVAL_TAC); +Theorem bvl_num_stub_MOD: + bvl_num_stubs MOD bvl_to_bvi_namespaces = 0 +Proof +EVAL_TAC +QED (* shift values, per dimindex(:α) *) val word_shift_def = Define ` diff --git a/compiler/backend/bvi_letScript.sml b/compiler/backend/bvi_letScript.sml index 6ab2209dd5..0dd7199088 100644 --- a/compiler/backend/bvi_letScript.sml +++ b/compiler/backend/bvi_letScript.sml @@ -54,9 +54,11 @@ val delete_var_def = Define ` (delete_var ((Var n):bvi$exp) = Op (Const 0) []) /\ (delete_var x = x)`; -Theorem exp2_size_APPEND - `!xs ys. exp2_size (xs++ys) = exp2_size xs + exp2_size ys` - (Induct \\ fs [exp_size_def]); +Theorem exp2_size_APPEND: + !xs ys. exp2_size (xs++ys) = exp2_size xs + exp2_size ys +Proof + Induct \\ fs [exp_size_def] +QED val compile_def = tDefine "compile" ` (compile env d [] = []) /\ @@ -97,16 +99,20 @@ val compile_def = tDefine "compile" ` val compile_ind = theorem"compile_ind"; -Theorem compile_length[simp] - `!n d xs. LENGTH (compile n d xs) = LENGTH xs` - (HO_MATCH_MP_TAC compile_ind \\ REPEAT STRIP_TAC +Theorem compile_length[simp]: + !n d xs. LENGTH (compile n d xs) = LENGTH xs +Proof + HO_MATCH_MP_TAC compile_ind \\ REPEAT STRIP_TAC \\ FULL_SIMP_TAC (srw_ss()) [compile_def,ADD1,LET_DEF] - \\ every_case_tac \\ SRW_TAC [] [] \\ DECIDE_TAC); - -Theorem compile_HD_SING - `[HD (compile n d [x])] = compile n d [x]` - (MP_TAC (Q.SPECL [`n`,`d`,`[x]`] compile_length) - \\ Cases_on `compile n d [x]` \\ fs [LENGTH_NIL]); + \\ every_case_tac \\ SRW_TAC [] [] \\ DECIDE_TAC +QED + +Theorem compile_HD_SING: + [HD (compile n d [x])] = compile n d [x] +Proof + MP_TAC (Q.SPECL [`n`,`d`,`[x]`] compile_length) + \\ Cases_on `compile n d [x]` \\ fs [LENGTH_NIL] +QED val compile_exp_def = Define ` compile_exp x = case compile [] 0 [x] of (y::_) => y | _ => Var 0 (* impossible *)`; diff --git a/compiler/backend/bvi_tailrecScript.sml b/compiler/backend/bvi_tailrecScript.sml index e55c9d4256..c82008a8f3 100644 --- a/compiler/backend/bvi_tailrecScript.sml +++ b/compiler/backend/bvi_tailrecScript.sml @@ -15,9 +15,11 @@ val PMATCH_ELIM_CONV = patternMatchesLib.PMATCH_ELIM_CONV; val dummy_def = Define `dummy = bvi$Var 1234567890`; -Theorem MEM_exp_size_imp - `∀xs a. MEM a xs ⇒ bvi$exp_size a < exp2_size xs` - (Induct \\ rw [bviTheory.exp_size_def] \\ res_tac \\ fs []); +Theorem MEM_exp_size_imp: + ∀xs a. MEM a xs ⇒ bvi$exp_size a < exp2_size xs +Proof + Induct \\ rw [bviTheory.exp_size_def] \\ res_tac \\ fs [] +QED (* TODO defined in bviSemTheory, should be moved to bviTheory? On the other hand: its use here is temporary. @@ -30,27 +32,31 @@ val is_rec_def = Define ` (is_rec _ _ ⇔ F) `; -Theorem is_rec_PMATCH - `!expr. is_rec name expr = +Theorem is_rec_PMATCH: + !expr. is_rec name expr = case expr of Call _ d _ NONE => d = SOME name - | _ => F` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) + | _ => F +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ fs [is_rec_def] \\ rename1 `Call _ _ _ hdl` - \\ Cases_on `hdl` \\ fs [is_rec_def]); + \\ Cases_on `hdl` \\ fs [is_rec_def] +QED val is_const_def = Define ` (is_const (Const i) <=> small_int i) /\ (is_const _ <=> F)`; -Theorem is_const_PMATCH - `!op. is_const op = +Theorem is_const_PMATCH: + !op. is_const op = case op of Const i => small_int i - | _ => F` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) - \\ Cases \\ rw [is_const_def]); + | _ => F +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) + \\ Cases \\ rw [is_const_def] +QED val _ = export_rewrites ["is_const_def"]; @@ -82,15 +88,17 @@ val from_op_def = Define ` else Noop `; -Theorem from_op_PMATCH - `!op. +Theorem from_op_PMATCH: + !op. from_op op = case op of Add => Plus | Mult => Times | ListAppend => Append - | _ => Noop` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [from_op_def]); + | _ => Noop +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [from_op_def] +QED val from_op_thm = save_thm("from_op_thm[simp]", map (fn tm => EVAL ``from_op ^tm``) @@ -104,8 +112,8 @@ val op_eq_def = Define ` (op_eq Append (Op op xs) <=> op = ListAppend) /\ (op_eq _ _ <=> F)`; -Theorem op_eq_PMATCH - `!a expr. +Theorem op_eq_PMATCH: + !a expr. op_eq a expr = case expr of Op op xs => @@ -114,15 +122,19 @@ Theorem op_eq_PMATCH | Times => op = Mult | Append => op = ListAppend | _ => F) - | _ => F` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ Cases \\ rw [op_eq_def]); + | _ => F +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ Cases \\ rw [op_eq_def] +QED -Theorem op_eq_to_op[simp] - `∀iop op xs. +Theorem op_eq_to_op[simp]: + ∀iop op xs. op_eq iop (Op op xs) ⇔ - op = to_op iop ∧ iop ≠ Noop` - (Cases \\ Cases \\ fs [op_eq_def, to_op_def]); + op = to_op iop ∧ iop ≠ Noop +Proof + Cases \\ Cases \\ fs [op_eq_def, to_op_def] +QED val apply_op_def = Define ` apply_op op e1 e2 = Op (to_op op) [e1; e2] @@ -140,28 +152,32 @@ val index_of_def = Define ` (index_of _ = NONE) `; -Theorem index_of_PMATCH - `!expr. +Theorem index_of_PMATCH: + !expr. index_of expr = case expr of Var i => SOME i - | _ => NONE` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [index_of_def]); + | _ => NONE +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [index_of_def] +QED val args_from_def = Define ` (args_from (bvi$Call t (SOME d) as hdl) = SOME (t, d, as, hdl)) ∧ (args_from _ = NONE) `; -Theorem args_from_PMATCH - `!expr. +Theorem args_from_PMATCH: + !expr. args_from expr = case expr of Call t (SOME d) as hdl => SOME (t,d,as,hdl) - | _ => NONE` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [args_from_def] + | _ => NONE +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [args_from_def] \\ rename1 `Call _ nm _ _` - \\ Cases_on `nm` \\ rw [args_from_def]); + \\ Cases_on `nm` \\ rw [args_from_def] +QED val get_bin_args_def = Define ` get_bin_args op = @@ -169,22 +185,26 @@ val get_bin_args_def = Define ` | bvi$Op _ [e1; e2] => SOME (e1, e2) | _ => NONE`; -Theorem get_bin_args_PMATCH - `!op. +Theorem get_bin_args_PMATCH: + !op. get_bin_args op = case op of Op _ [e1; e2] => SOME (e1,e2) - | _ => NONE` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [get_bin_args_def]); + | _ => NONE +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [get_bin_args_def] +QED -Theorem exp_size_get_bin_args - `∀x x1 x2. +Theorem exp_size_get_bin_args: + ∀x x1 x2. get_bin_args x = SOME (x1, x2) ⇒ - exp_size x1 + exp_size x2 < exp_size x` - (Induct + exp_size x1 + exp_size x2 < exp_size x +Proof + Induct \\ rw [get_bin_args_def, exp_size_def] \\ every_case_tac - \\ fs [exp_size_def]); + \\ fs [exp_size_def] +QED val opbinargs_def = Define ` opbinargs opr exp = if ~op_eq opr exp then NONE else get_bin_args exp`; @@ -208,15 +228,17 @@ val is_arith_def = Define ` | Mult => T | _ => F`; -Theorem is_arith_PMATCH - `!op. +Theorem is_arith_PMATCH: + !op. is_arith op = case op of Add => T | Sub => T | Mult => T - | _ => F` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [is_arith_def]); + | _ => F +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [is_arith_def] +QED val is_rel_def = Define ` is_rel op = @@ -227,16 +249,18 @@ val is_rel_def = Define ` | GreaterEq => T | _ => F`; -Theorem is_rel_PMATCH - `!op. +Theorem is_rel_PMATCH: + !op. is_rel op = case op of Less => T | LessEq => T | Greater => T | GreaterEq => T - | _ => F` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [is_rel_def]); + | _ => F +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [is_rel_def] +QED val term_ok_int_def = tDefine "term_ok_int" ` (term_ok_int ts expr = @@ -273,15 +297,17 @@ val term_ok_any_def = tDefine "term_ok_any" ` \\ imp_res_tac exp_size_get_bin_args \\ fs [bviTheory.exp_size_def, closLangTheory.op_size_def]); -Theorem is_op_thms - `~is_arith (Cons 0) /\ ~is_arith ListAppend /\ +Theorem is_op_thms: + ~is_arith (Cons 0) /\ ~is_arith ListAppend /\ ~is_rel (Cons 0) /\ ~is_rel ListAppend /\ (!op. op <> ListAppend /\ is_arith op <=> is_arith op) /\ (!op. op <> ListAppend /\ ~is_arith op /\ is_rel op <=> is_rel op) /\ (!op. ~is_arith op /\ ~is_rel op /\ op = Cons 0 <=> op = Cons 0) /\ - (!op. op <> ListAppend /\ op = Cons 0 <=> op = Cons 0)` - (rw [is_arith_def, is_rel_def] \\ fs [] - \\ Cases_on `op` \\ fs []); + (!op. op <> ListAppend /\ op = Cons 0 <=> op = Cons 0) +Proof + rw [is_arith_def, is_rel_def] \\ fs [] + \\ Cases_on `op` \\ fs [] +QED val term_ok_any_ind = save_thm ("term_ok_any_ind", theorem "term_ok_any_ind" |> SIMP_RULE (srw_ss()) [is_op_thms]); @@ -289,8 +315,8 @@ val term_ok_any_ind = save_thm ("term_ok_any_ind", (* TODO the translator does not accept this with the induction theorem above (yet): -Theorem term_ok_any_PMATCH - `term_ok_any ts list expr = +Theorem term_ok_any_PMATCH: + term_ok_any ts list expr = case expr of Var i => if ~list then i < LENGTH ts else if i < LENGTH ts then EL i ts = List @@ -304,8 +330,10 @@ Theorem term_ok_any_PMATCH else if ~list /\ is_rel op then term_ok_int ts x /\ term_ok_int ts y else if op = Cons 0 then term_ok_any ts T x /\ term_ok_any ts F y else F) - | _ => F` - (Cases_on `expr` \\ once_rewrite_tac [term_ok_any_def] \\ fs []); + | _ => F +Proof + Cases_on `expr` \\ once_rewrite_tac [term_ok_any_def] \\ fs [] +QED *) val term_ok_def = Define ` @@ -344,14 +372,16 @@ val decide_ty_def = Define ` (decide_ty List List = List) /\ (decide_ty _ _ = Any)`; -Theorem decide_ty_PMATCH - `!ty1 ty2. +Theorem decide_ty_PMATCH: + !ty1 ty2. decide_ty ty1 ty2 = case (ty1,ty2) of (Int, Int) => Int | (List, List) => List - | _ => Any` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ Cases \\ rw [decide_ty_def]); + | _ => Any +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ Cases \\ rw [decide_ty_def] +QED val _ = export_rewrites ["decide_ty_def"] @@ -378,8 +408,8 @@ val arg_ty_def = Define ` arg_ty ListAppend = List /\ arg_ty _ = Any`; -Theorem arg_ty_PMATCH - `!op. +Theorem arg_ty_PMATCH: + !op. arg_ty op = case op of Add => Int @@ -393,8 +423,10 @@ Theorem arg_ty_PMATCH | GreaterEq => Int | ListAppend => List | Const i => if small_int i then Int else Any - | _ => Any` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [arg_ty_def]); + | _ => Any +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [arg_ty_def] +QED val op_ty_def = Define ` (op_ty Add = Int) /\ @@ -407,8 +439,8 @@ val op_ty_def = Define ` (op_ty (Const i) = if small_int i then Int else Any) /\ (op_ty _ = Any)`; -Theorem op_ty_PMATCH - `!op. +Theorem op_ty_PMATCH: + !op. op_ty op = case op of Add => Int @@ -419,8 +451,10 @@ Theorem op_ty_PMATCH | ListAppend => List | Cons tag => if tag = cons_tag \/ tag = nil_tag then List else Any | Const i => if small_int i then Int else Any - | _ => Any` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [op_ty_def]); + | _ => Any +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) \\ Cases \\ rw [op_ty_def] +QED (* Gather information about expressions: @@ -524,8 +558,8 @@ val rewrite_def = Define ` NONE => (F, apply_op opr (Var acc) exp) | SOME (xs, f) => (T, push_call next opr acc xs (args_from f)))` -Theorem rewrite_PMATCH - `!loc next opr acc ts expr. +Theorem rewrite_PMATCH: + !loc next opr acc ts expr. rewrite loc next opr acc ts expr = case expr of Var n => (F, Var n) @@ -550,9 +584,11 @@ Theorem rewrite_PMATCH | SOME exp => dtcase opbinargs opr exp of NONE => (F, apply_op opr (Var acc) exp) - | SOME (xs, f) => (T, push_call next opr acc xs (args_from f))` - (CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) - \\ recInduct (theorem "rewrite_ind") \\ rw [rewrite_def]); + | SOME (xs, f) => (T, push_call next opr acc xs (args_from f)) +Proof + CONV_TAC (DEPTH_CONV PMATCH_ELIM_CONV) + \\ recInduct (theorem "rewrite_ind") \\ rw [rewrite_def] +QED (* --- Top-level expression check --- *) @@ -575,12 +611,18 @@ val has_rec_def = tDefine "has_rec" ` val has_rec1_def = Define `has_rec1 loc x = has_rec loc [x]`; val test1_tm = ``Let [] (Call 0 (SOME 0) [] NONE)`` -Theorem has_rec_test1 - `has_rec1 0 ^test1_tm <=> F` (EVAL_TAC); +Theorem has_rec_test1: + has_rec1 0 ^test1_tm <=> F +Proof +EVAL_TAC +QED val test2_tm = ``Op Add [Call 0 (SOME 0) [] NONE; Var 0]`` -Theorem has_rec_test2 - `has_rec1 0 ^test2_tm <=> T` (EVAL_TAC); +Theorem has_rec_test2: + has_rec1 0 ^test2_tm <=> T +Proof +EVAL_TAC +QED val check_exp_def = Define ` check_exp loc arity exp = @@ -624,41 +666,51 @@ val compile_prog_def = Define ` (n, (loc, arity, exp_aux)::(next, arity + 1, exp_opt)::ys)) `; -Theorem scan_expr_not_nil[simp] - `!x. scan_expr ts loc [x] <> []` - (Induct \\ rw [scan_expr_def] +Theorem scan_expr_not_nil[simp]: + !x. scan_expr ts loc [x] <> [] +Proof + Induct \\ rw [scan_expr_def] \\ rpt (pairarg_tac \\ fs []) - \\ every_case_tac \\ fs []); + \\ every_case_tac \\ fs [] +QED -Theorem LENGTH_scan_expr[simp] - `∀ts loc xs. LENGTH (scan_expr ts loc xs) = LENGTH xs` - (recInduct (theorem"scan_expr_ind") \\ rw [scan_expr_def] +Theorem LENGTH_scan_expr[simp]: + ∀ts loc xs. LENGTH (scan_expr ts loc xs) = LENGTH xs +Proof + recInduct (theorem"scan_expr_ind") \\ rw [scan_expr_def] \\ rpt (pairarg_tac \\ fs []) - \\ every_case_tac \\ fs []); - -Theorem scan_expr_SING[simp] - `[HD (scan_expr ts loc [x])] = scan_expr ts loc [x]` - (`LENGTH (scan_expr ts loc [x]) = LENGTH [x]` by fs [] - \\ Cases_on `scan_expr ts loc [x]` \\ fs []); - -Theorem scan_expr_HD_SING[simp] - `HD (scan_expr ts loc [x]) = y ⇔ scan_expr ts loc [x] = [y]` - (`LENGTH (scan_expr ts loc [x]) = LENGTH [x]` by fs [] - \\ Cases_on `scan_expr ts loc [x]` \\ fs []); - -Theorem check_exp_SOME_simp[simp] - `check_exp loc arity exp = SOME op <=> + \\ every_case_tac \\ fs [] +QED + +Theorem scan_expr_SING[simp]: + [HD (scan_expr ts loc [x])] = scan_expr ts loc [x] +Proof + `LENGTH (scan_expr ts loc [x]) = LENGTH [x]` by fs [] + \\ Cases_on `scan_expr ts loc [x]` \\ fs [] +QED + +Theorem scan_expr_HD_SING[simp]: + HD (scan_expr ts loc [x]) = y ⇔ scan_expr ts loc [x] = [y] +Proof + `LENGTH (scan_expr ts loc [x]) = LENGTH [x]` by fs [] + \\ Cases_on `scan_expr ts loc [x]` \\ fs [] +QED + +Theorem check_exp_SOME_simp[simp]: + check_exp loc arity exp = SOME op <=> ?ts ty r. has_rec1 loc exp /\ scan_expr (REPLICATE arity Any) loc [exp] = [(ts,ty,r,SOME op)] /\ - ty = op_type op` - (simp [check_exp_def] + ty = op_type op +Proof + simp [check_exp_def] \\ `LENGTH (scan_expr (REPLICATE arity Any) loc [exp]) = LENGTH [exp]` by fs [] \\ TOP_CASE_TAC \\ fs [] \\ PairCases_on `h` \\ fs [] \\ TOP_CASE_TAC \\ fs [] - \\ metis_tac []); + \\ metis_tac [] +QED (* --- Test rewriting --- *) @@ -677,11 +729,17 @@ val opt_tm = `` NONE)))`` val aux_tm = ``Let [Var 0; Op (Const 1) []] ^opt_tm`` -Theorem fac_check_exp - `check_exp 0 1 ^fac_tm = SOME Times` (EVAL_TAC); +Theorem fac_check_exp: + check_exp 0 1 ^fac_tm = SOME Times +Proof +EVAL_TAC +QED -Theorem fac_compile_exp - `compile_exp 0 1 1 ^fac_tm = SOME (^aux_tm, ^opt_tm)` (EVAL_TAC); +Theorem fac_compile_exp: + compile_exp 0 1 1 ^fac_tm = SOME (^aux_tm, ^opt_tm) +Proof +EVAL_TAC +QED val rev_tm = `` Let [Op (Const 0) []] @@ -706,10 +764,16 @@ val opt_tm = `` val aux_tm = ``Let [Var 0; Op (Cons 0) []] ^opt_tm`` -Theorem rev_check_exp - `check_exp 444 1 ^rev_tm = SOME Append` (EVAL_TAC); - -Theorem rev_compile_exp - `compile_exp 444 445 1 ^rev_tm = SOME (^aux_tm, ^opt_tm)` (EVAL_TAC); +Theorem rev_check_exp: + check_exp 444 1 ^rev_tm = SOME Append +Proof +EVAL_TAC +QED + +Theorem rev_compile_exp: + compile_exp 444 445 1 ^rev_tm = SOME (^aux_tm, ^opt_tm) +Proof +EVAL_TAC +QED val _ = export_theory(); diff --git a/compiler/backend/bvi_to_dataScript.sml b/compiler/backend/bvi_to_dataScript.sml index 74ca6c4fe7..cfb11a0add 100644 --- a/compiler/backend/bvi_to_dataScript.sml +++ b/compiler/backend/bvi_to_dataScript.sml @@ -11,7 +11,8 @@ val _ = patternMatchesLib.ENABLE_PMATCH_CASES(); (* compilation from BVI to dataLang *) -Theorem op_space_reset_pmatch `! op. +Theorem op_space_reset_pmatch: + ! op. op_space_reset op = case op of Add => T @@ -32,30 +33,36 @@ Theorem op_space_reset_pmatch `! op. | CopyByte new_flag => new_flag | ConfigGC => T | FFI _ => T - | _ => F` - (rpt strip_tac + | _ => F +Proof + rpt strip_tac >> CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) - >> Cases_on `op` >> fs[op_space_reset_def]); + >> Cases_on `op` >> fs[op_space_reset_def] +QED -Theorem op_requires_names_eqn - `∀op. op_requires_names op = +Theorem op_requires_names_eqn: + ∀op. op_requires_names op = (op_space_reset op ∨ (dtcase op of | FFI n => T | Install => T | CopyByte new_flag => T - | _ => F))` - (Cases>>fs[op_requires_names_def]); + | _ => F)) +Proof + Cases>>fs[op_requires_names_def] +QED -Theorem op_requires_names_pmatch - `∀op. op_requires_names op = +Theorem op_requires_names_pmatch: + ∀op. op_requires_names op = (op_space_reset op ∨ (case op of | FFI n => T | Install => T | CopyByte new_flag => T - | _ => F))` - (rpt strip_tac >> + | _ => F)) +Proof + rpt strip_tac >> CONV_TAC(RAND_CONV(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV)) >> - fs[op_requires_names_eqn]); + fs[op_requires_names_eqn] +QED val iAssign_def = Define ` iAssign n1 op vs live env = @@ -132,11 +139,13 @@ val compile_LESS_EQ_lemma = Q.prove( \\ SIMP_TAC std_ss [compile_def] \\ SRW_TAC [] [] \\ FULL_SIMP_TAC (srw_ss()) [] \\ SRW_TAC [] [] \\ DECIDE_TAC); -Theorem compile_LESS_EQ - `!n env tail live xs c vs new_var. - (compile n env tail live xs = (c,vs,new_var)) ==> n <= new_var` - (REPEAT STRIP_TAC \\ MP_TAC (SPEC_ALL compile_LESS_EQ_lemma) - \\ FULL_SIMP_TAC std_ss []); +Theorem compile_LESS_EQ: + !n env tail live xs c vs new_var. + (compile n env tail live xs = (c,vs,new_var)) ==> n <= new_var +Proof + REPEAT STRIP_TAC \\ MP_TAC (SPEC_ALL compile_LESS_EQ_lemma) + \\ FULL_SIMP_TAC std_ss [] +QED val compile_LENGTH_lemma = Q.prove( `!n env tail live xs. @@ -145,17 +154,21 @@ val compile_LENGTH_lemma = Q.prove( \\ SIMP_TAC std_ss [compile_def] \\ SRW_TAC [] [] \\ FULL_SIMP_TAC (srw_ss()) [] \\ SRW_TAC [] []); -Theorem compile_LENGTH - `!n env tail live xs c vs new_var. - (compile n env tail live xs = (c,vs,new_var)) ==> (LENGTH vs = LENGTH xs)` - (REPEAT STRIP_TAC \\ MP_TAC (SPEC_ALL compile_LENGTH_lemma) - \\ FULL_SIMP_TAC std_ss []); - -Theorem compile_SING_IMP - `(compile n env tail live [x] = (c,vs,new_var)) ==> ?t. vs = [t]` - (REPEAT STRIP_TAC \\ IMP_RES_TAC compile_LENGTH +Theorem compile_LENGTH: + !n env tail live xs c vs new_var. + (compile n env tail live xs = (c,vs,new_var)) ==> (LENGTH vs = LENGTH xs) +Proof + REPEAT STRIP_TAC \\ MP_TAC (SPEC_ALL compile_LENGTH_lemma) + \\ FULL_SIMP_TAC std_ss [] +QED + +Theorem compile_SING_IMP: + (compile n env tail live [x] = (c,vs,new_var)) ==> ?t. vs = [t] +Proof + REPEAT STRIP_TAC \\ IMP_RES_TAC compile_LENGTH \\ Cases_on `vs` \\ FULL_SIMP_TAC (srw_ss()) [] - \\ Cases_on `t` \\ FULL_SIMP_TAC (srw_ss()) []); + \\ Cases_on `t` \\ FULL_SIMP_TAC (srw_ss()) [] +QED (* combine dataLang optimisations *) diff --git a/compiler/backend/bvl_constScript.sml b/compiler/backend/bvl_constScript.sml index 6be7cbbb4b..acb9ab90d3 100644 --- a/compiler/backend/bvl_constScript.sml +++ b/compiler/backend/bvl_constScript.sml @@ -22,14 +22,16 @@ val dest_simple_def = Define ` (dest_simple _ = NONE)`; val _ = export_rewrites["dest_simple_def"]; -Theorem dest_simple_pmatch ` - ∀op. dest_simple op = +Theorem dest_simple_pmatch: + ∀op. dest_simple op = case op of bvl$Op (Const i) [] => SOME i - | _ => NONE` - (rpt strip_tac + | _ => NONE +Proof + rpt strip_tac >> rpt(CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac) - >> fs[dest_simple_def]); + >> fs[dest_simple_def] +QED val case_op_const_def = Define ` case_op_const exp = @@ -38,14 +40,16 @@ val case_op_const_def = Define ` | _ => NONE ` -Theorem case_op_const_pmatch ` - ∀exp. case_op_const exp = +Theorem case_op_const_pmatch: + ∀exp. case_op_const exp = case exp of | (Op op [x1; Op (Const n2) []]) => SOME (op, x1, n2) - | _ => NONE` - (rpt strip_tac + | _ => NONE +Proof + rpt strip_tac >> rpt(CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac) - >> fs[case_op_const_def]); + >> fs[case_op_const_def] +QED val SmartOp_flip_def = Define ` SmartOp_flip op x1 x2 = @@ -57,19 +61,19 @@ val SmartOp_flip_def = Define ` | _ => (op, x1, x2) ` -Theorem SmartOp_flip_pmatch ` - !op x1 x2. SmartOp_flip op x1 x2 = +Theorem SmartOp_flip_pmatch: + !op x1 x2. SmartOp_flip op x1 x2 = case (dest_simple x1) of | (SOME i) => if MEM op [Add; Mult] then (op, x2, x1) else if op = Sub then (Add, x2, Op (Const (-i)) []) else (op, x1, x2) | _ => (op, x1, x2) -` - (rpt strip_tac +Proof + rpt strip_tac >> rpt(CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac) >> fs[SmartOp_flip_def] -); +QED local val SmartOp2_quotation = ` SmartOp2 (op, x1:bvl$exp, x2:bvl$exp) = @@ -197,15 +201,16 @@ val SmartOp_def = Define ` | [x1; x2] => SmartOp2 (SmartOp_flip op x1 x2) | _ => Op op xs` -Theorem SmartOp_pmatch ` - !op xs. SmartOp op xs = +Theorem SmartOp_pmatch: + !op xs. SmartOp op xs = case xs of | [x1;x2] => SmartOp2 (SmartOp_flip op x1 x2) - | _ => Op op xs` - (rpt strip_tac + | _ => Op op xs +Proof + rpt strip_tac >> rpt(CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac) >> fs[SmartOp_def] -) +QED val extract_def = Define ` (extract ((Var n):bvl$exp) ys = SOME ((Var (n + LENGTH ys + 1)):bvl$exp)) /\ @@ -214,16 +219,18 @@ val extract_def = Define ` if NULL xs then SOME (Op (Cons t) []) else NONE) /\ (extract _ _ = NONE)` -Theorem extract_pmatch ` - ∀op ys. extract op ys = +Theorem extract_pmatch: + ∀op ys. extract op ys = case op of (Var n):bvl$exp => SOME ((Var (n + LENGTH ys + 1)):bvl$exp) | Op (Const i) xs => SOME (Op (Const i) []) | Op (Cons t) [] => SOME (Op (Cons t) []) - | _ => NONE` - (rpt strip_tac + | _ => NONE +Proof + rpt strip_tac >> rpt(CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac) - >> fs[extract_def]); + >> fs[extract_def] +QED val extract_list_def = Define ` (extract_list [] = []) /\ @@ -233,14 +240,17 @@ val delete_var_def = Define ` (delete_var ((Var n):bvl$exp) = Op (Const 0) []) /\ (delete_var x = x)`; -Theorem delete_var_pmatch `!op. +Theorem delete_var_pmatch: + !op. delete_var op = case op of Var n => Op (Const 0) [] - | x => x` - (rpt strip_tac + | x => x +Proof + rpt strip_tac >> rpt(CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac) - >> fs[delete_var_def]) + >> fs[delete_var_def] +QED val compile_def = tDefine "compile" ` (compile env [] = []) /\ @@ -273,16 +283,20 @@ val compile_def = tDefine "compile" ` val compile_ind = theorem"compile_ind"; -Theorem compile_length[simp] - `!n xs. LENGTH (compile n xs) = LENGTH xs` - (HO_MATCH_MP_TAC compile_ind \\ REPEAT STRIP_TAC +Theorem compile_length[simp]: + !n xs. LENGTH (compile n xs) = LENGTH xs +Proof + HO_MATCH_MP_TAC compile_ind \\ REPEAT STRIP_TAC \\ FULL_SIMP_TAC (srw_ss()) [compile_def,ADD1,LET_DEF] - \\ every_case_tac \\ SRW_TAC [] [] \\ DECIDE_TAC); + \\ every_case_tac \\ SRW_TAC [] [] \\ DECIDE_TAC +QED -Theorem compile_HD_SING - `[HD (compile n [x])] = compile n [x]` - (MP_TAC (Q.SPECL [`n`,`[x]`] compile_length) - \\ Cases_on `compile n [x]` \\ fs [LENGTH_NIL]); +Theorem compile_HD_SING: + [HD (compile n [x])] = compile n [x] +Proof + MP_TAC (Q.SPECL [`n`,`[x]`] compile_length) + \\ Cases_on `compile n [x]` \\ fs [LENGTH_NIL] +QED val compile_exp_def = Define ` compile_exp x = dtcase compile [] [x] of (y::_) => y | _ => Var 0 (* impossible *)`; diff --git a/compiler/backend/bvl_handleScript.sml b/compiler/backend/bvl_handleScript.sml index 28237ab8ff..f372fc957f 100644 --- a/compiler/backend/bvl_handleScript.sml +++ b/compiler/backend/bvl_handleScript.sml @@ -85,14 +85,17 @@ val dest_Seq_def = Define ` (dest_Seq (Let [e1;e2] (Var 1)) = SOME (e1,e2)) /\ (dest_Seq _ = NONE)` -Theorem dest_Seq_pmatch `∀exp. +Theorem dest_Seq_pmatch: + ∀exp. dest_Seq exp = case exp of Let [e1;e2] (Var 1) => SOME (e1,e2) - | _ => NONE` - (rpt strip_tac + | _ => NONE +Proof + rpt strip_tac >> rpt(CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac) - >> fs[dest_Seq_def]) + >> fs[dest_Seq_def] +QED val compile_seqs_def = tDefine "compile_seqs" ` compile_seqs cut_size e acc = @@ -115,17 +118,21 @@ val compile_any_def = Define ` else compile_exp cut_size arity e`; -Theorem compile_length[simp] - `!l n xs. LENGTH (FST (compile l n xs)) = LENGTH xs` - (HO_MATCH_MP_TAC compile_ind \\ REPEAT STRIP_TAC +Theorem compile_length[simp]: + !l n xs. LENGTH (FST (compile l n xs)) = LENGTH xs +Proof + HO_MATCH_MP_TAC compile_ind \\ REPEAT STRIP_TAC \\ fs [compile_def,ADD1,LET_DEF] - \\ rpt (pairarg_tac \\ fs []) \\ rw [OptionalLetLet_def]); + \\ rpt (pairarg_tac \\ fs []) \\ rw [OptionalLetLet_def] +QED -Theorem compile_sing - `compile l n [x] = (dx,lx,s) ==> ?y. dx = [y]` - (`LENGTH (FST (compile l n [x])) = LENGTH [x]` by fs [] +Theorem compile_sing: + compile l n [x] = (dx,lx,s) ==> ?y. dx = [y] +Proof + `LENGTH (FST (compile l n [x])) = LENGTH [x]` by fs [] \\ rpt strip_tac \\ full_simp_tac std_ss [LENGTH] - \\ Cases_on `dx` \\ fs [LENGTH_NIL]); + \\ Cases_on `dx` \\ fs [LENGTH_NIL] +QED val compile_seqs_compute = save_thm("compile_seqs_compute", LIST_CONJ [ diff --git a/compiler/backend/bvl_inlineScript.sml b/compiler/backend/bvl_inlineScript.sml index 897e8ba720..bc91516723 100644 --- a/compiler/backend/bvl_inlineScript.sml +++ b/compiler/backend/bvl_inlineScript.sml @@ -112,16 +112,20 @@ val tick_inline_all_def = Define ` val tick_compile_prog_def = Define ` tick_compile_prog limit cs prog = tick_inline_all limit cs prog []` -Theorem LENGTH_tick_inline - `!cs xs. LENGTH (tick_inline cs xs) = LENGTH xs` - (recInduct tick_inline_ind \\ REPEAT STRIP_TAC - \\ fs [Once tick_inline_def,LET_DEF] \\ rw [] \\ every_case_tac \\ fs []); - -Theorem HD_tick_inline[simp] - `[HD (tick_inline cs [x])] = tick_inline cs [x]` - (`LENGTH (tick_inline cs [x]) = LENGTH [x]` by SRW_TAC [] [LENGTH_tick_inline] +Theorem LENGTH_tick_inline: + !cs xs. LENGTH (tick_inline cs xs) = LENGTH xs +Proof + recInduct tick_inline_ind \\ REPEAT STRIP_TAC + \\ fs [Once tick_inline_def,LET_DEF] \\ rw [] \\ every_case_tac \\ fs [] +QED + +Theorem HD_tick_inline[simp]: + [HD (tick_inline cs [x])] = tick_inline cs [x] +Proof + `LENGTH (tick_inline cs [x]) = LENGTH [x]` by SRW_TAC [] [LENGTH_tick_inline] \\ Cases_on `tick_inline cs [x]` \\ FULL_SIMP_TAC std_ss [LENGTH] - \\ Cases_on `t` \\ FULL_SIMP_TAC std_ss [LENGTH,HD] \\ `F` by DECIDE_TAC); + \\ Cases_on `t` \\ FULL_SIMP_TAC std_ss [LENGTH,HD] \\ `F` by DECIDE_TAC +QED (* remove_ticks -- a function that removes Ticks *) @@ -148,15 +152,19 @@ val remove_ticks_def = tDefine "remove_ticks" ` [Call 0 dest (remove_ticks xs)])` (WF_REL_TAC `measure exp1_size`); -Theorem LENGTH_remove_ticks[simp] - `!xs. LENGTH (remove_ticks xs) = LENGTH xs` - (recInduct (theorem "remove_ticks_ind") \\ fs [remove_ticks_def]); +Theorem LENGTH_remove_ticks[simp]: + !xs. LENGTH (remove_ticks xs) = LENGTH xs +Proof + recInduct (theorem "remove_ticks_ind") \\ fs [remove_ticks_def] +QED -Theorem remove_ticks_SING[simp] - `[HD (remove_ticks [r])] = remove_ticks [r]` - (qsuff_tac `?a. remove_ticks [r] = [a]` \\ rw[] \\ fs [] +Theorem remove_ticks_SING[simp]: + [HD (remove_ticks [r])] = remove_ticks [r] +Proof + qsuff_tac `?a. remove_ticks [r] = [a]` \\ rw[] \\ fs [] \\ `LENGTH (remove_ticks [r]) = LENGTH [r]` by fs [LENGTH_remove_ticks] - \\ Cases_on `remove_ticks [r]` \\ fs []); + \\ Cases_on `remove_ticks [r]` \\ fs [] +QED (* let_op -- a function that optimises Let [...] (Op op [Var ...]) *) diff --git a/compiler/backend/bvl_to_bviScript.sml b/compiler/backend/bvl_to_bviScript.sml index b70b0e7a7a..cdb4515305 100644 --- a/compiler/backend/bvl_to_bviScript.sml +++ b/compiler/backend/bvl_to_bviScript.sml @@ -25,14 +25,17 @@ val destLet_def = Define ` (destLet ((Let xs b):bvl$exp) = (xs,b)) /\ (destLet _ = ([],Var 0))`; -Theorem destLet_pmatch `∀exp. +Theorem destLet_pmatch: + ∀exp. destLet exp = case exp of Let xs b => (xs,b) - | _ => ([],Var 0)` - (rpt strip_tac + | _ => ([],Var 0) +Proof + rpt strip_tac >> rpt(CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac) - >> fs[destLet_def]) + >> fs[destLet_def] +QED val large_int = ``268435457:int`` (* 2**28-1 *) @@ -320,14 +323,18 @@ val compile_exps_LENGTH_lemma = Q.prove( \\ SIMP_TAC std_ss [compile_exps_def] \\ SRW_TAC [] [] \\ FULL_SIMP_TAC (srw_ss()) [] \\ SRW_TAC [] [] \\ DECIDE_TAC); -Theorem compile_exps_LENGTH - `(compile_exps n xs = (ys,aux,n1)) ==> (LENGTH ys = LENGTH xs)` - (REPEAT STRIP_TAC \\ MP_TAC (SPEC_ALL compile_exps_LENGTH_lemma) \\ fs []) - -Theorem compile_exps_SING - `(compile_exps n [x] = (c,aux,n1)) ==> ?y. c = [y]` - (REPEAT STRIP_TAC \\ IMP_RES_TAC compile_exps_LENGTH - \\ Cases_on `c` \\ fs [LENGTH_NIL]); +Theorem compile_exps_LENGTH: + (compile_exps n xs = (ys,aux,n1)) ==> (LENGTH ys = LENGTH xs) +Proof + REPEAT STRIP_TAC \\ MP_TAC (SPEC_ALL compile_exps_LENGTH_lemma) \\ fs [] +QED + +Theorem compile_exps_SING: + (compile_exps n [x] = (c,aux,n1)) ==> ?y. c = [y] +Proof + REPEAT STRIP_TAC \\ IMP_RES_TAC compile_exps_LENGTH + \\ Cases_on `c` \\ fs [LENGTH_NIL] +QED val compile_single_def = Define ` compile_single n (name,arg_count,exp) = diff --git a/compiler/backend/closLangScript.sml b/compiler/backend/closLangScript.sml index 5817c5944f..a118493acc 100644 --- a/compiler/backend/closLangScript.sml +++ b/compiler/backend/closLangScript.sml @@ -90,10 +90,12 @@ val _ = Datatype ` val exp_size_def = definition"exp_size_def"; -Theorem exp1_size_lemma - `!fns n x. MEM (n,x) fns ==> exp_size x < exp1_size fns` - (Induct \\ fs [FORALL_PROD,exp_size_def] \\ REPEAT STRIP_TAC - \\ RES_TAC \\ SRW_TAC [] [] \\ DECIDE_TAC); +Theorem exp1_size_lemma: + !fns n x. MEM (n,x) fns ==> exp_size x < exp1_size fns +Proof + Induct \\ fs [FORALL_PROD,exp_size_def] \\ REPEAT STRIP_TAC + \\ RES_TAC \\ SRW_TAC [] [] \\ DECIDE_TAC +QED val pure_op_def = Define ` pure_op op ⇔ diff --git a/compiler/backend/clos_annotateScript.sml b/compiler/backend/clos_annotateScript.sml index b3849560ff..735a2c7c3f 100644 --- a/compiler/backend/clos_annotateScript.sml +++ b/compiler/backend/clos_annotateScript.sml @@ -93,30 +93,40 @@ val alt_free_LENGTH_LEMMA = Q.prove( \\ rw []) |> SIMP_RULE std_ss [] |> SPEC_ALL; -Theorem alt_free_LENGTH - `!xs ys l. (alt_free xs = (ys,l)) ==> (LENGTH ys = LENGTH xs)` - (REPEAT STRIP_TAC \\ MP_TAC alt_free_LENGTH_LEMMA \\ fs []); - -Theorem alt_free_SING - `(alt_free [x] = (ys,l)) ==> ?y. ys = [y]` - (REPEAT STRIP_TAC \\ IMP_RES_TAC alt_free_LENGTH - \\ Cases_on `ys` \\ fs [LENGTH_NIL]); - -Theorem LENGTH_FST_alt_free - `LENGTH (FST (alt_free fns)) = LENGTH fns` - (Cases_on `alt_free fns` \\ fs [] \\ IMP_RES_TAC alt_free_LENGTH); - -Theorem HD_FST_alt_free - `[HD (FST (alt_free [x1]))] = FST (alt_free [x1])` - (Cases_on `alt_free [x1]` \\ fs [] - \\ imp_res_tac alt_free_SING \\ fs[]); - -Theorem alt_free_CONS - `FST (alt_free (x::xs)) = HD (FST (alt_free [x])) :: FST (alt_free xs)` - (Cases_on `xs` \\ fs [alt_free_def,SING_HD,LENGTH_FST_alt_free,LET_DEF] +Theorem alt_free_LENGTH: + !xs ys l. (alt_free xs = (ys,l)) ==> (LENGTH ys = LENGTH xs) +Proof + REPEAT STRIP_TAC \\ MP_TAC alt_free_LENGTH_LEMMA \\ fs [] +QED + +Theorem alt_free_SING: + (alt_free [x] = (ys,l)) ==> ?y. ys = [y] +Proof + REPEAT STRIP_TAC \\ IMP_RES_TAC alt_free_LENGTH + \\ Cases_on `ys` \\ fs [LENGTH_NIL] +QED + +Theorem LENGTH_FST_alt_free: + LENGTH (FST (alt_free fns)) = LENGTH fns +Proof + Cases_on `alt_free fns` \\ fs [] \\ IMP_RES_TAC alt_free_LENGTH +QED + +Theorem HD_FST_alt_free: + [HD (FST (alt_free [x1]))] = FST (alt_free [x1]) +Proof + Cases_on `alt_free [x1]` \\ fs [] + \\ imp_res_tac alt_free_SING \\ fs[] +QED + +Theorem alt_free_CONS: + FST (alt_free (x::xs)) = HD (FST (alt_free [x])) :: FST (alt_free xs) +Proof + Cases_on `xs` \\ fs [alt_free_def,SING_HD,LENGTH_FST_alt_free,LET_DEF] \\ Cases_on `alt_free [x]` \\ fs [] \\ Cases_on `alt_free (h::t)` \\ fs [SING_HD] - \\ IMP_RES_TAC alt_free_SING \\ fs []); + \\ IMP_RES_TAC alt_free_SING \\ fs [] +QED (* shift renames variables to use only those in the annotations *) @@ -189,23 +199,27 @@ val shift_def = tDefine "shift" ` val shift_ind = theorem "shift_ind"; -Theorem shift_LENGTH_LEMMA - `!xs m l i. LENGTH (shift xs m l i) = LENGTH xs` - (recInduct shift_ind \\ REPEAT STRIP_TAC - \\ fs [shift_def,LET_DEF,ADD1,AC ADD_COMM ADD_ASSOC]) +Theorem shift_LENGTH_LEMMA: + !xs m l i. LENGTH (shift xs m l i) = LENGTH xs +Proof + recInduct shift_ind \\ REPEAT STRIP_TAC + \\ fs [shift_def,LET_DEF,ADD1,AC ADD_COMM ADD_ASSOC] +QED -Theorem shift_SING - `!ys. (shift [x] m l i = ys) ==> ?y. ys = [y]` - (fs [] \\ MP_TAC (Q.SPEC `[x]` shift_LENGTH_LEMMA |> SPEC_ALL) +Theorem shift_SING = Q.prove(` + !ys. (shift [x] m l i = ys) ==> ?y. ys = [y]`, + fs [] \\ MP_TAC (Q.SPEC `[x]` shift_LENGTH_LEMMA |> SPEC_ALL) \\ Cases_on `shift [x] m l i` \\ fs [LENGTH_NIL]) |> SIMP_RULE std_ss []; -Theorem shift_CONS - `shift ((x:closLang$exp)::xs) m l i = +Theorem shift_CONS: + shift ((x:closLang$exp)::xs) m l i = let c1 = shift [x] m l i in let c2 = shift xs m l i in - (HD c1 :: c2:closLang$exp list)` - (Cases_on `xs` \\ fs [shift_def,LET_DEF,SING_HD,shift_LENGTH_LEMMA]); + (HD c1 :: c2:closLang$exp list) +Proof + Cases_on `xs` \\ fs [shift_def,LET_DEF,SING_HD,shift_LENGTH_LEMMA] +QED Theorem HD_shift[simp]: LENGTH (shift [x] m l i) = 1 ∧ diff --git a/compiler/backend/clos_callScript.sml b/compiler/backend/clos_callScript.sml index 77f6ae80a4..370a40dff6 100644 --- a/compiler/backend/clos_callScript.sml +++ b/compiler/backend/clos_callScript.sml @@ -71,30 +71,40 @@ val free_LENGTH_LEMMA = Q.prove( \\ SRW_TAC [] [] \\ DECIDE_TAC) |> SIMP_RULE std_ss [] |> SPEC_ALL; -Theorem free_LENGTH - `!xs ys l. (free xs = (ys,l)) ==> (LENGTH ys = LENGTH xs)` - (REPEAT STRIP_TAC \\ MP_TAC free_LENGTH_LEMMA \\ fs []); - -Theorem free_SING - `(free [x] = (ys,l)) ==> ?y. ys = [y]` - (REPEAT STRIP_TAC \\ IMP_RES_TAC free_LENGTH - \\ Cases_on `ys` \\ fs [LENGTH_NIL]); - -Theorem LENGTH_FST_free - `LENGTH (FST (free fns)) = LENGTH fns` - (Cases_on `free fns` \\ fs [] \\ IMP_RES_TAC free_LENGTH); - -Theorem HD_FST_free - `[HD (FST (free [x1]))] = FST (free [x1])` - (Cases_on `free [x1]` \\ fs [] - \\ imp_res_tac free_SING \\ fs[]); - -Theorem free_CONS - `FST (free (x::xs)) = HD (FST (free [x])) :: FST (free xs)` - (Cases_on `xs` \\ fs [free_def,SING_HD,LENGTH_FST_free,LET_DEF] +Theorem free_LENGTH: + !xs ys l. (free xs = (ys,l)) ==> (LENGTH ys = LENGTH xs) +Proof + REPEAT STRIP_TAC \\ MP_TAC free_LENGTH_LEMMA \\ fs [] +QED + +Theorem free_SING: + (free [x] = (ys,l)) ==> ?y. ys = [y] +Proof + REPEAT STRIP_TAC \\ IMP_RES_TAC free_LENGTH + \\ Cases_on `ys` \\ fs [LENGTH_NIL] +QED + +Theorem LENGTH_FST_free: + LENGTH (FST (free fns)) = LENGTH fns +Proof + Cases_on `free fns` \\ fs [] \\ IMP_RES_TAC free_LENGTH +QED + +Theorem HD_FST_free: + [HD (FST (free [x1]))] = FST (free [x1]) +Proof + Cases_on `free [x1]` \\ fs [] + \\ imp_res_tac free_SING \\ fs[] +QED + +Theorem free_CONS: + FST (free (x::xs)) = HD (FST (free [x])) :: FST (free xs) +Proof + Cases_on `xs` \\ fs [free_def,SING_HD,LENGTH_FST_free,LET_DEF] \\ Cases_on `free [x]` \\ fs [] \\ Cases_on `free (h::t)` \\ fs [SING_HD] -\\ IMP_RES_TAC free_SING \\ fs []); +\\ IMP_RES_TAC free_SING \\ fs [] +QED val closed_def = Define ` closed x = isEmpty (db_to_set (SND (free [x])))` @@ -215,27 +225,35 @@ val compile_def = Define ` compile F x = (x,(LN,[])) /\ compile T x = let (xs,g) = calls x (LN,[]) in (xs,g)` -Theorem calls_length - `∀xs g0 ys g. calls xs g0 = (ys,g) ⇒ LENGTH ys = LENGTH xs` - (ho_match_mp_tac (fetch "-" "calls_ind") +Theorem calls_length: + ∀xs g0 ys g. calls xs g0 = (ys,g) ⇒ LENGTH ys = LENGTH xs +Proof + ho_match_mp_tac (fetch "-" "calls_ind") \\ rw[calls_def] \\ rw[] \\ rpt(pairarg_tac \\ fs[]) \\ rw[] - \\ every_case_tac \\ fs[] \\ rw[]); - -Theorem calls_sing - `∀x g0 ys g. calls [x] g0 = (ys,g) ⇒ ?y. ys = [y]` - (rw [] \\ imp_res_tac calls_length \\ fs [] - \\ Cases_on `ys` \\ fs [LENGTH_NIL] ); - -Theorem compile_LENGTH - `compile x y = (a,b) ⇒ LENGTH y = LENGTH a` - (Cases_on`x` \\ rw[compile_def] \\ pairarg_tac \\ fs[] - \\ imp_res_tac calls_length \\ rw[]); - -Theorem compile_nil - `clos_call$compile x [] = (a,g,b) ⇒ a =[] ∧ g = LN ∧ b = []` - (Cases_on`x` \\ rw[compile_def] - \\ pairarg_tac \\ fs[] \\ fs[calls_def] \\ rw[]); + \\ every_case_tac \\ fs[] \\ rw[] +QED + +Theorem calls_sing: + ∀x g0 ys g. calls [x] g0 = (ys,g) ⇒ ?y. ys = [y] +Proof + rw [] \\ imp_res_tac calls_length \\ fs [] + \\ Cases_on `ys` \\ fs [LENGTH_NIL] +QED + +Theorem compile_LENGTH: + compile x y = (a,b) ⇒ LENGTH y = LENGTH a +Proof + Cases_on`x` \\ rw[compile_def] \\ pairarg_tac \\ fs[] + \\ imp_res_tac calls_length \\ rw[] +QED + +Theorem compile_nil: + clos_call$compile x [] = (a,g,b) ⇒ a =[] ∧ g = LN ∧ b = [] +Proof + Cases_on`x` \\ rw[compile_def] + \\ pairarg_tac \\ fs[] \\ fs[calls_def] \\ rw[] +QED val selftest = let (* example code *) diff --git a/compiler/backend/clos_fvsScript.sml b/compiler/backend/clos_fvsScript.sml index 5c306819df..bd167c6c2a 100644 --- a/compiler/backend/clos_fvsScript.sml +++ b/compiler/backend/clos_fvsScript.sml @@ -51,8 +51,10 @@ val remove_fvs_def = tDefine "remove_fvs" ` val compile_def = Define` compile exps = remove_fvs 0 exps`; -Theorem LENGTH_remove_fvs - `!fvs xs. LENGTH (remove_fvs fvs xs) = LENGTH xs` - (recInduct (fetch "-" "remove_fvs_ind") \\ simp [remove_fvs_def] \\ rw []); +Theorem LENGTH_remove_fvs: + !fvs xs. LENGTH (remove_fvs fvs xs) = LENGTH xs +Proof + recInduct (fetch "-" "remove_fvs_ind") \\ simp [remove_fvs_def] \\ rw [] +QED val _ = export_theory(); diff --git a/compiler/backend/clos_knownScript.sml b/compiler/backend/clos_knownScript.sml index 439af581eb..598707e901 100644 --- a/compiler/backend/clos_knownScript.sml +++ b/compiler/backend/clos_knownScript.sml @@ -106,15 +106,19 @@ val get_size_aux_ind = theorem "get_size_aux_ind"; val get_size_def = Define `get_size e = get_size_aux [e]`; -Theorem get_size_sc_aux_correct - `!xs limit n. get_size_sc_aux limit xs = limit - get_size_aux xs` - (`!xs limit n. get_size_sc_aux limit xs = n ==> n = limit - get_size_aux xs` suffices_by metis_tac [] +Theorem get_size_sc_aux_correct: + !xs limit n. get_size_sc_aux limit xs = limit - get_size_aux xs +Proof + `!xs limit n. get_size_sc_aux limit xs = n ==> n = limit - get_size_aux xs` suffices_by metis_tac [] \\ ho_match_mp_tac get_size_aux_ind - \\ simp [get_size_sc_aux_def, get_size_aux_def]); + \\ simp [get_size_sc_aux_def, get_size_aux_def] +QED -Theorem get_size_sc_SOME - `!exp limit n. get_size_sc limit exp = SOME n ==> get_size exp = n` - (simp [get_size_sc_def, get_size_def, get_size_sc_aux_correct]); +Theorem get_size_sc_SOME: + !exp limit n. get_size_sc limit exp = SOME n ==> get_size exp = n +Proof + simp [get_size_sc_def, get_size_def, get_size_sc_aux_correct] +QED val free_def = tDefine "free" ` (free [] = ([],Empty)) /\ @@ -181,30 +185,40 @@ val free_LENGTH_LEMMA = Q.prove( \\ SRW_TAC [] [] \\ DECIDE_TAC) |> SIMP_RULE std_ss [] |> SPEC_ALL; -Theorem free_LENGTH - `!xs ys l. (free xs = (ys,l)) ==> (LENGTH ys = LENGTH xs)` - (REPEAT STRIP_TAC \\ MP_TAC free_LENGTH_LEMMA \\ fs []); - -Theorem free_SING - `(free [x] = (ys,l)) ==> ?y. ys = [y]` - (REPEAT STRIP_TAC \\ IMP_RES_TAC free_LENGTH - \\ Cases_on `ys` \\ fs [LENGTH_NIL]); - -Theorem LENGTH_FST_free - `LENGTH (FST (free fns)) = LENGTH fns` - (Cases_on `free fns` \\ fs [] \\ IMP_RES_TAC free_LENGTH); - -Theorem HD_FST_free - `[HD (FST (free [x1]))] = FST (free [x1])` - (Cases_on `free [x1]` \\ fs [] - \\ imp_res_tac free_SING \\ fs[]); - -Theorem free_CONS - `FST (free (x::xs)) = HD (FST (free [x])) :: FST (free xs)` - (Cases_on `xs` \\ fs [free_def,SING_HD,LENGTH_FST_free,LET_DEF] +Theorem free_LENGTH: + !xs ys l. (free xs = (ys,l)) ==> (LENGTH ys = LENGTH xs) +Proof + REPEAT STRIP_TAC \\ MP_TAC free_LENGTH_LEMMA \\ fs [] +QED + +Theorem free_SING: + (free [x] = (ys,l)) ==> ?y. ys = [y] +Proof + REPEAT STRIP_TAC \\ IMP_RES_TAC free_LENGTH + \\ Cases_on `ys` \\ fs [LENGTH_NIL] +QED + +Theorem LENGTH_FST_free: + LENGTH (FST (free fns)) = LENGTH fns +Proof + Cases_on `free fns` \\ fs [] \\ IMP_RES_TAC free_LENGTH +QED + +Theorem HD_FST_free: + [HD (FST (free [x1]))] = FST (free [x1]) +Proof + Cases_on `free [x1]` \\ fs [] + \\ imp_res_tac free_SING \\ fs[] +QED + +Theorem free_CONS: + FST (free (x::xs)) = HD (FST (free [x])) :: FST (free xs) +Proof + Cases_on `xs` \\ fs [free_def,SING_HD,LENGTH_FST_free,LET_DEF] \\ Cases_on `free [x]` \\ fs [] \\ Cases_on `free (h::t)` \\ fs [SING_HD] -\\ IMP_RES_TAC free_SING \\ fs []); +\\ IMP_RES_TAC free_SING \\ fs [] +QED *) val closed_def = Define ` @@ -311,7 +325,8 @@ val merge_tup_def = tDefine "merge_tup" ` disch_then (qspec_then `tag` mp_tac) >> simp[]) (* TODO: this function seems to throw the translator into an infinite loop -Theorem merge_tup_pmatch `!tup. +Theorem merge_tup_pmatch: + !tup. merge_tup tup = case tup of (Impossible,y) => y @@ -322,17 +337,21 @@ Theorem merge_tup_pmatch `!tup. | (Clos m1 n1,Clos m2 n2) => if m1 = m2 ∧ n1 = n2 then Clos m1 n1 else Other | (Int i,Int j) => if i = j then Int i else Other - | _ => Other` - (rpt strip_tac + | _ => Other +Proof + rpt strip_tac >> rpt(CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac) - >> fs[merge_tup_def] >> metis_tac []); + >> fs[merge_tup_def] >> metis_tac [] +QED *) -Theorem merge_alt ` - ∀x y.merge x y = merge_tup (x,y)` - (HO_MATCH_MP_TAC (fetch "-" "merge_ind")>>rw[merge_tup_def,MAP2_MAP]>> +Theorem merge_alt: + ∀x y.merge x y = merge_tup (x,y) +Proof + HO_MATCH_MP_TAC (fetch "-" "merge_ind")>>rw[merge_tup_def,MAP2_MAP]>> match_mp_tac LIST_EQ>>rw[EL_ZIP,EL_MAP]>> - first_x_assum match_mp_tac>>metis_tac[MEM_EL]) + first_x_assum match_mp_tac>>metis_tac[MEM_EL] +QED val known_op_def = Define ` (known_op (Global n) as g = @@ -361,7 +380,8 @@ val known_op_def = Define ` | _ => (Other,g)) /\ (known_op op as g = (Other,g))` -Theorem known_op_pmatch `!op as g. +Theorem known_op_pmatch: + !op as g. known_op op as g = case op of Global n => @@ -388,10 +408,12 @@ known_op op as g = | Impossible::xs => (Impossible,g) | _ :: Impossible :: xs => (Impossible,g) | _ => (Other,g)) - | _ => (Other,g)` - (rpt strip_tac + | _ => (Other,g) +Proof + rpt strip_tac >> rpt(CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac) - >> fs[known_op_def]) + >> fs[known_op_def] +QED val EL_MEM_LEMMA = Q.prove( `!xs i x. i < LENGTH xs /\ (x = EL i xs) ==> MEM x xs`, @@ -415,14 +437,17 @@ val isGlobal_def = Define` (isGlobal (Global _) ⇔ T) ∧ (isGlobal _ ⇔ F)`; -Theorem isGlobal_pmatch `!op. +Theorem isGlobal_pmatch: + !op. isGlobal op = case op of Global _ => T - | _ => F` - (rpt strip_tac + | _ => F +Proof + rpt strip_tac >> rpt(CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac) - >> fs[isGlobal_def]) + >> fs[isGlobal_def] +QED val gO_destApx_def = Define` (gO_destApx (Int i) = gO_Int i) ∧ @@ -489,12 +514,14 @@ val decide_inline_def = Define ` | _ => inlD_Nothing `; -Theorem decide_inline_LetInline - `!c fapx lopt arity body. - decide_inline c fapx lopt arity = inlD_LetInline body ==> 0 < c.inline_factor` - (rpt strip_tac +Theorem decide_inline_LetInline: + !c fapx lopt arity body. + decide_inline c fapx lopt arity = inlD_LetInline body ==> 0 < c.inline_factor +Proof + rpt strip_tac \\ Cases_on `fapx` \\ fs [decide_inline_def, bool_case_eq] - \\ spose_not_then assume_tac \\ fs []); + \\ spose_not_then assume_tac \\ fs [] +QED val known_def = tDefine "known" ` (known c [] vs (g:val_approx spt) = ([],g)) /\ @@ -594,27 +621,35 @@ val known_def = tDefine "known" ` val known_ind = theorem "known_ind"; -Theorem known_LENGTH - `∀limit es vs g. LENGTH (FST (known limit es vs g)) = LENGTH es` - (recInduct known_ind >> simp[known_def] >> rpt strip_tac >> +Theorem known_LENGTH: + ∀limit es vs g. LENGTH (FST (known limit es vs g)) = LENGTH es +Proof + recInduct known_ind >> simp[known_def] >> rpt strip_tac >> rpt (pairarg_tac >> fs[]) >> rw [] >> CASE_TAC >> CASE_TAC >> fs [] >> - rpt (pairarg_tac >> fs [])); - -Theorem known_LENGTH_EQ_E - `known limit es vs g0 = (alist, g) ⇒ LENGTH alist = LENGTH es` - (metis_tac[FST, known_LENGTH]); - -Theorem known_sing - `∀limit e vs g. ∃e' a g'. known limit [e] vs g = ([(e',a)], g')` - (rpt strip_tac >> Cases_on `known limit [e] vs g` >> + rpt (pairarg_tac >> fs []) +QED + +Theorem known_LENGTH_EQ_E: + known limit es vs g0 = (alist, g) ⇒ LENGTH alist = LENGTH es +Proof + metis_tac[FST, known_LENGTH] +QED + +Theorem known_sing: + ∀limit e vs g. ∃e' a g'. known limit [e] vs g = ([(e',a)], g') +Proof + rpt strip_tac >> Cases_on `known limit [e] vs g` >> rename1 `known limit [e] vs g = (res,g')` >> qspecl_then [`limit`, `[e]`, `vs`, `g`] mp_tac known_LENGTH >> simp[] >> - Cases_on `res` >> simp[LENGTH_NIL] >> metis_tac[pair_CASES]) - -Theorem known_sing_EQ_E - `∀limit e vs g0 all g. known limit [e] vs g0 = (all, g) ⇒ ∃e' apx. all = [(e',apx)]` - (metis_tac[PAIR_EQ, known_sing]); + Cases_on `res` >> simp[LENGTH_NIL] >> metis_tac[pair_CASES] +QED + +Theorem known_sing_EQ_E: + ∀limit e vs g0 all g. known limit [e] vs g0 = (all, g) ⇒ ∃e' apx. all = [(e',apx)] +Proof + metis_tac[PAIR_EQ, known_sing] +QED val compile_def = Define ` compile NONE exps = (NONE, exps) /\ diff --git a/compiler/backend/clos_labelsScript.sml b/compiler/backend/clos_labelsScript.sml index 3c1360237d..5fc09aaf9e 100644 --- a/compiler/backend/clos_labelsScript.sml +++ b/compiler/backend/clos_labelsScript.sml @@ -107,8 +107,10 @@ val compile_def = Define` let ds = add_code_locs ds (MAP (SND o SND) prog) in MAP (λ(n,args,exp). (n, args, HD(remove_dests ds [exp]))) prog`; -Theorem LENGTH_remove_dests - `!dests xs. LENGTH (remove_dests dests xs) = LENGTH xs` - (recInduct (fetch "-" "remove_dests_ind") \\ simp [remove_dests_def] \\ rw []); +Theorem LENGTH_remove_dests: + !dests xs. LENGTH (remove_dests dests xs) = LENGTH xs +Proof + recInduct (fetch "-" "remove_dests_ind") \\ simp [remove_dests_def] \\ rw [] +QED val _ = export_theory(); diff --git a/compiler/backend/clos_letopScript.sml b/compiler/backend/clos_letopScript.sml index 768656af13..fce17338eb 100644 --- a/compiler/backend/clos_letopScript.sml +++ b/compiler/backend/clos_letopScript.sml @@ -58,9 +58,11 @@ val let_op_def = tDefine "let_op" ` val let_op_ind = theorem "let_op_ind"; -Theorem LENGTH_let_op - `!xs. LENGTH (let_op xs) = LENGTH xs` - (recInduct let_op_ind \\ simp [let_op_def] - \\ rw [] \\ CASE_TAC \\ simp []); +Theorem LENGTH_let_op: + !xs. LENGTH (let_op xs) = LENGTH xs +Proof + recInduct let_op_ind \\ simp [let_op_def] + \\ rw [] \\ CASE_TAC \\ simp [] +QED val _ = export_theory(); diff --git a/compiler/backend/clos_mtiScript.sml b/compiler/backend/clos_mtiScript.sml index 8901e5d670..7dbc5aa47b 100644 --- a/compiler/backend/clos_mtiScript.sml +++ b/compiler/backend/clos_mtiScript.sml @@ -39,15 +39,17 @@ val collect_args_more = Q.prove ( res_tac >> decide_tac); -Theorem collect_args_zero - `!max_app num_args e e'. +Theorem collect_args_zero: + !max_app num_args e e'. collect_args max_app num_args e = (0, e') ⇒ - num_args = 0` - (ho_match_mp_tac collect_args_ind >> + num_args = 0 +Proof + ho_match_mp_tac collect_args_ind >> srw_tac[][collect_args_def] >> srw_tac[][collect_args_def] >> - full_simp_tac(srw_ss())[]); + full_simp_tac(srw_ss())[] +QED val collect_apps_def = Define ` (collect_apps max_app args (App tra NONE e es) = @@ -143,18 +145,21 @@ val intro_multi_def = tDefine "intro_multi" ` val intro_multi_ind = theorem "intro_multi_ind"; -Theorem intro_multi_length - `!max_app es. LENGTH (intro_multi max_app es) = LENGTH es` - (recInduct intro_multi_ind >> +Theorem intro_multi_length: + !max_app es. LENGTH (intro_multi max_app es) = LENGTH es +Proof + recInduct intro_multi_ind >> srw_tac[][intro_multi_def] >> Cases_on `intro_multi max_app [e1]` >> full_simp_tac(srw_ss())[] >> every_case_tac >> - full_simp_tac(srw_ss())[]); + full_simp_tac(srw_ss())[] +QED -Theorem intro_multi_sing - `!e max_app. ?e'. intro_multi max_app [e] = [e']` - (Induct_on `e` >> +Theorem intro_multi_sing: + !e max_app. ?e'. intro_multi max_app [e] = [e'] +Proof + Induct_on `e` >> srw_tac[][intro_multi_def] >> TRY (rename1 `App _ loc e es` >> Cases_on `loc`) >> TRY (rename1 `Fn _ loc vars num_args e` >> Cases_on `loc` >> Cases_on `vars`) >> @@ -163,14 +168,16 @@ Theorem intro_multi_sing srw_tac[][intro_multi_def] >> TRY (Cases_on `collect_args max_app num_args e`) >> TRY (Cases_on `collect_apps max_app es e`) >> - full_simp_tac(srw_ss())[]); + full_simp_tac(srw_ss())[] +QED -Theorem collect_args_idem - `!max_app num_args e num_args' e'. +Theorem collect_args_idem: + !max_app num_args e num_args' e'. collect_args max_app num_args e = (num_args', e') ⇒ - collect_args max_app num_args' (HD (intro_multi max_app [e'])) = (num_args', (HD (intro_multi max_app [e'])))` - (ho_match_mp_tac collect_args_ind >> + collect_args max_app num_args' (HD (intro_multi max_app [e'])) = (num_args', (HD (intro_multi max_app [e']))) +Proof + ho_match_mp_tac collect_args_ind >> srw_tac[][collect_args_def, intro_multi_def] >> srw_tac[][collect_args_def, intro_multi_def] >> full_simp_tac(srw_ss())[NOT_LESS_EQUAL] @@ -184,14 +191,16 @@ Theorem collect_args_idem srw_tac[][collect_args_def, intro_multi_def]) >- (rename1 `Letrec _ locopt fvsopt` >> Cases_on `locopt` >> Cases_on `fvsopt` >> - rw[intro_multi_def, collect_args_def])); + rw[intro_multi_def, collect_args_def]) +QED -Theorem collect_apps_idem - `!max_app args e args' e'. +Theorem collect_apps_idem: + !max_app args e args' e'. collect_apps max_app args e = (args', e') ⇒ - collect_apps max_app (intro_multi max_app args') (HD (intro_multi max_app [e'])) = (intro_multi max_app args', (HD (intro_multi max_app [e'])))` - (ho_match_mp_tac collect_apps_ind >> + collect_apps max_app (intro_multi max_app args') (HD (intro_multi max_app [e'])) = (intro_multi max_app args', (HD (intro_multi max_app [e']))) +Proof + ho_match_mp_tac collect_apps_ind >> srw_tac[][collect_apps_def, intro_multi_def] >> srw_tac[][collect_apps_def, intro_multi_def] >> full_simp_tac(srw_ss())[NOT_LESS_EQUAL] @@ -210,11 +219,13 @@ Theorem collect_apps_idem rename1 `Letrec _ locopt fvsopt` >> Cases_on `locopt` >> Cases_on `fvsopt` >> simp[collect_apps_def, intro_multi_def] - ]); + ] +QED -Theorem intro_multi_idem - `!max_app e. intro_multi max_app (intro_multi max_app e) = intro_multi max_app e` - (ho_match_mp_tac intro_multi_ind >> +Theorem intro_multi_idem: + !max_app e. intro_multi max_app (intro_multi max_app e) = intro_multi max_app e +Proof + ho_match_mp_tac intro_multi_ind >> srw_tac[][intro_multi_def] >> srw_tac[][intro_multi_def] >- metis_tac [intro_multi_sing, HD] @@ -243,13 +254,17 @@ Theorem intro_multi_idem metis_tac [intro_multi_sing, HD, collect_args_idem, PAIR_EQ, FST, SND]) >- metis_tac [intro_multi_sing, HD] >- metis_tac [intro_multi_sing, HD] - >- metis_tac [intro_multi_sing, HD]); + >- metis_tac [intro_multi_sing, HD] +QED val compile_def = Define` compile F max_app exps = exps /\ compile T max_app exps = intro_multi max_app exps` -Theorem compile_nil[simp] - `compile do_mti max_app [] = []` (Cases_on`do_mti` \\ EVAL_TAC); +Theorem compile_nil[simp]: + compile do_mti max_app [] = [] +Proof +Cases_on`do_mti` \\ EVAL_TAC +QED val _ = export_theory() diff --git a/compiler/backend/clos_numberScript.sml b/compiler/backend/clos_numberScript.sml index 48746c7e36..f72172824e 100644 --- a/compiler/backend/clos_numberScript.sml +++ b/compiler/backend/clos_numberScript.sml @@ -63,11 +63,13 @@ val renumber_code_locs_def = tDefine "renumber_code_locs" ` val renumber_code_locs_ind = theorem"renumber_code_locs_ind"; -Theorem renumber_code_locs_length - `(∀x y. LENGTH (SND (renumber_code_locs_list x y)) = LENGTH y) ∧ - (∀(x:num)(y:closLang$exp). T)` - (ho_match_mp_tac renumber_code_locs_ind >> +Theorem renumber_code_locs_length: + (∀x y. LENGTH (SND (renumber_code_locs_list x y)) = LENGTH y) ∧ + (∀(x:num)(y:closLang$exp). T) +Proof + ho_match_mp_tac renumber_code_locs_ind >> simp[renumber_code_locs_def,UNCURRY] >> rw[] >> - METIS_TAC[PAIR,FST,SND]); + METIS_TAC[PAIR,FST,SND] +QED val _ = export_theory() diff --git a/compiler/backend/clos_ticksScript.sml b/compiler/backend/clos_ticksScript.sml index 0dafadb0d0..0860c8aa7c 100644 --- a/compiler/backend/clos_ticksScript.sml +++ b/compiler/backend/clos_ticksScript.sml @@ -47,8 +47,10 @@ val remove_ticks_def = tDefine "remove_ticks" ` val remove_ticks_ind = theorem "remove_ticks_ind"; -Theorem LENGTH_remove_ticks - `!(es:closLang$exp list). LENGTH (remove_ticks es) = LENGTH es` - (recInduct remove_ticks_ind \\ fs [remove_ticks_def]); +Theorem LENGTH_remove_ticks: + !(es:closLang$exp list). LENGTH (remove_ticks es) = LENGTH es +Proof + recInduct remove_ticks_ind \\ fs [remove_ticks_def] +QED val _ = export_theory(); diff --git a/compiler/backend/clos_to_bvlScript.sml b/compiler/backend/clos_to_bvlScript.sml index 92f2a9682c..7a688c814f 100644 --- a/compiler/backend/clos_to_bvlScript.sml +++ b/compiler/backend/clos_to_bvlScript.sml @@ -64,9 +64,11 @@ val _ = EVAL``clos_tag_shift nil_tag = nil_tag`` |> EQT_ELIM |> curry save_thm"clos_tag_shift_nil_tag[simp]"; val _ = EVAL``clos_tag_shift cons_tag = cons_tag`` |> EQT_ELIM |> curry save_thm"clos_tag_shift_cons_tag[simp]"; -Theorem clos_tag_shift_inj - `clos_tag_shift n1 = clos_tag_shift n2 ⇒ n1 = n2` - (EVAL_TAC >> rw[] >> simp[]) +Theorem clos_tag_shift_inj: + clos_tag_shift n1 = clos_tag_shift n2 ⇒ n1 = n2 +Proof + EVAL_TAC >> rw[] >> simp[] +QED val num_added_globals_def = Define `num_added_globals = 1n`; @@ -87,7 +89,8 @@ val compile_op_def = Define` compile_op x = x` val _ = export_rewrites["compile_op_def"]; -Theorem compile_op_pmatch `∀op. +Theorem compile_op_pmatch: + ∀op. compile_op op = case op of Cons tag => Cons (clos_tag_shift tag) @@ -99,10 +102,12 @@ Theorem compile_op_pmatch `∀op. | DerefByteVec => DerefByte | SetGlobal n => SetGlobal (n + num_added_globals) | Global n => Global (n + num_added_globals) - | x => x` - (rpt strip_tac + | x => x +Proof + rpt strip_tac >> rpt(CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac) - >> fs[compile_op_def]); + >> fs[compile_op_def] +QED val mk_const_def = Define ` mk_const n : bvl$exp = Op (Const (&n)) []`; @@ -128,42 +133,52 @@ val build_aux_def = Define ` (build_aux i [] aux = (i:num,aux)) /\ (build_aux i ((x:num#bvl$exp)::xs) aux = build_aux (i+2) xs ((i,x) :: aux))`; -Theorem build_aux_LENGTH - `!l n aux n1 t. - (build_aux n l aux = (n1,t)) ==> (n1 = n + 2 * LENGTH l)` - (Induct \\ fs [build_aux_def] \\ REPEAT STRIP_TAC \\ RES_TAC \\ DECIDE_TAC); +Theorem build_aux_LENGTH: + !l n aux n1 t. + (build_aux n l aux = (n1,t)) ==> (n1 = n + 2 * LENGTH l) +Proof + Induct \\ fs [build_aux_def] \\ REPEAT STRIP_TAC \\ RES_TAC \\ DECIDE_TAC +QED -Theorem build_aux_MOVE - `!xs n aux n1 aux1. +Theorem build_aux_MOVE: + !xs n aux n1 aux1. (build_aux n xs aux = (n1,aux1)) <=> - ?aux2. (build_aux n xs [] = (n1,aux2)) /\ (aux1 = aux2 ++ aux)` - (Induct THEN1 (fs [build_aux_def] \\ METIS_TAC []) + ?aux2. (build_aux n xs [] = (n1,aux2)) /\ (aux1 = aux2 ++ aux) +Proof + Induct THEN1 (fs [build_aux_def] \\ METIS_TAC []) \\ ONCE_REWRITE_TAC [build_aux_def] \\ POP_ASSUM (fn th => ONCE_REWRITE_TAC [th]) - \\ fs [PULL_EXISTS]); + \\ fs [PULL_EXISTS] +QED -Theorem build_aux_acc - `!k n aux. ?aux1. SND (build_aux n k aux) = aux1 ++ aux` - (METIS_TAC[build_aux_MOVE,SND,PAIR]); +Theorem build_aux_acc: + !k n aux. ?aux1. SND (build_aux n k aux) = aux1 ++ aux +Proof + METIS_TAC[build_aux_MOVE,SND,PAIR] +QED -Theorem build_aux_MEM - `!c n aux n7 aux7. +Theorem build_aux_MEM: + !c n aux n7 aux7. (build_aux n c aux = (n7,aux7)) ==> - !k. k < LENGTH c ==> ?d. MEM (n + 2*k,d) aux7` - (Induct \\ fs [build_aux_def] \\ REPEAT STRIP_TAC + !k. k < LENGTH c ==> ?d. MEM (n + 2*k,d) aux7 +Proof + Induct \\ fs [build_aux_def] \\ REPEAT STRIP_TAC \\ FIRST_X_ASSUM (MP_TAC o Q.SPECL [`n+2`,`(n,h)::aux`]) \\ fs [] \\ REPEAT STRIP_TAC \\ Cases_on `k` \\ fs [] THEN1 (MP_TAC (Q.SPECL [`c`,`n+2`,`(n,h)::aux`] build_aux_acc) \\ fs [] \\ REPEAT STRIP_TAC \\ fs [] \\ METIS_TAC []) - \\ RES_TAC \\ fs [ADD1,LEFT_ADD_DISTRIB] \\ METIS_TAC []); + \\ RES_TAC \\ fs [ADD1,LEFT_ADD_DISTRIB] \\ METIS_TAC [] +QED -Theorem build_aux_APPEND1 - `!xs x n aux. +Theorem build_aux_APPEND1: + !xs x n aux. build_aux n (xs ++ [x]) aux = let (n1,aux1) = build_aux n xs aux in - (n1+2,(n1,x)::aux1)` - (Induct \\ fs [build_aux_def,LET_DEF]); + (n1+2,(n1,x)::aux1) +Proof + Induct \\ fs [build_aux_def,LET_DEF] +QED val recc_Let_def = Define ` recc_Let n num_args i = @@ -419,11 +434,12 @@ val pair_lem2 = Q.prove ( PairCases_on `z` >> rw []); -Theorem compile_exps_acc - `!max_app xs aux. +Theorem compile_exps_acc: + !max_app xs aux. let (c,aux1) = compile_exps max_app xs aux in - (LENGTH c = LENGTH xs) /\ ?ys. aux1 = ys ++ aux` - (recInduct compile_exps_ind \\ REPEAT STRIP_TAC + (LENGTH c = LENGTH xs) /\ ?ys. aux1 = ys ++ aux +Proof + recInduct compile_exps_ind \\ REPEAT STRIP_TAC \\ fs [compile_exps_def] \\ SRW_TAC [] [] \\ fs [LET_DEF,ADD1] \\ fs [] \\ BasicProvers.EVERY_CASE_TAC \\ rfs [] \\ fs [pair_lem1] >> @@ -431,42 +447,51 @@ Theorem compile_exps_acc fs [pair_lem2] >> rfs [compile_exps_def, LET_THM] >> fs [pair_lem1, pair_lem2] >> - metis_tac [build_aux_acc, APPEND_ASSOC]); + metis_tac [build_aux_acc, APPEND_ASSOC] +QED -Theorem compile_exps_LENGTH - `(compile_exps max_app xs aux = (c,aux1)) ==> (LENGTH c = LENGTH xs)` - (REPEAT STRIP_TAC +Theorem compile_exps_LENGTH: + (compile_exps max_app xs aux = (c,aux1)) ==> (LENGTH c = LENGTH xs) +Proof + REPEAT STRIP_TAC \\ ASSUME_TAC (Q.SPECL [`max_app`,`xs`,`aux`] compile_exps_acc) - \\ rfs [LET_DEF]); + \\ rfs [LET_DEF] +QED -Theorem compile_exps_SING - `(compile_exps max_app [x] aux = (c,aux1)) ==> ?d. c = [d]` - (REPEAT STRIP_TAC +Theorem compile_exps_SING: + (compile_exps max_app [x] aux = (c,aux1)) ==> ?d. c = [d] +Proof + REPEAT STRIP_TAC \\ ASSUME_TAC (Q.SPECL [`max_app`,`[x]`,`aux`] compile_exps_acc) \\ rfs [LET_DEF] - \\ Cases_on `c` \\ fs [] \\ Cases_on `t` \\ fs []); + \\ Cases_on `c` \\ fs [] \\ Cases_on `t` \\ fs [] +QED -Theorem compile_exps_CONS - `!max_app xs x aux. +Theorem compile_exps_CONS: + !max_app xs x aux. compile_exps max_app (x::xs) aux = (let (c1,aux1) = compile_exps max_app [x] aux in let (c2,aux2) = compile_exps max_app xs aux1 in - (c1 ++ c2,aux2))` - (Cases_on `xs` \\ fs[compile_exps_def] \\ fs [LET_DEF] - \\ CONV_TAC (DEPTH_CONV PairRules.PBETA_CONV) \\ fs []); - -Theorem compile_exps_SNOC - `!xs x aux max_app. + (c1 ++ c2,aux2)) +Proof + Cases_on `xs` \\ fs[compile_exps_def] \\ fs [LET_DEF] + \\ CONV_TAC (DEPTH_CONV PairRules.PBETA_CONV) \\ fs [] +QED + +Theorem compile_exps_SNOC: + !xs x aux max_app. compile_exps max_app (SNOC x xs) aux = (let (c1,aux1) = compile_exps max_app xs aux in let (c2,aux2) = compile_exps max_app [x] aux1 in - (c1 ++ c2,aux2))` - (Induct THEN1 + (c1 ++ c2,aux2)) +Proof + Induct THEN1 (fs [compile_exps_def,LET_DEF] \\ CONV_TAC (DEPTH_CONV PairRules.PBETA_CONV) \\ fs []) \\ fs [SNOC_APPEND] \\ ONCE_REWRITE_TAC [compile_exps_CONS] \\ ASM_SIMP_TAC std_ss [compile_exps_def,LET_DEF,APPEND_NIL] - \\ CONV_TAC (DEPTH_CONV PairRules.PBETA_CONV) \\ fs []); + \\ CONV_TAC (DEPTH_CONV PairRules.PBETA_CONV) \\ fs [] +QED val _ = Datatype` config = <| next_loc : num @@ -505,17 +530,21 @@ val code_merge_def = tDefine "code_merge" ` y1::code_merge xs ys1` (WF_REL_TAC `measure (\(xs,ys). LENGTH xs + LENGTH ys)` \\ rw []); -Theorem code_split_NULL - `!ts1 ts2 ts3 xs ys. +Theorem code_split_NULL: + !ts1 ts2 ts3 xs ys. (xs,ys) = code_split ts1 ts2 ts3 /\ ts2 <> [] /\ ts3 <> [] ==> - xs <> [] /\ ys <> []` - (Induct \\ fs [code_split_def] \\ rw [] \\ first_x_assum drule \\ fs []); + xs <> [] /\ ys <> [] +Proof + Induct \\ fs [code_split_def] \\ rw [] \\ first_x_assum drule \\ fs [] +QED -Theorem code_split_LENGTH - `!ts1 ts2 ts3 xs ys. +Theorem code_split_LENGTH: + !ts1 ts2 ts3 xs ys. (xs,ys) = code_split ts1 ts2 ts3 ==> - LENGTH xs + LENGTH ys = LENGTH ts1 + LENGTH ts2 + LENGTH ts3` - (Induct \\ fs [code_split_def] \\ rw [] \\ first_x_assum drule \\ fs []); + LENGTH xs + LENGTH ys = LENGTH ts1 + LENGTH ts2 + LENGTH ts3 +Proof + Induct \\ fs [code_split_def] \\ rw [] \\ first_x_assum drule \\ fs [] +QED val code_sort_def = tDefine "code_sort" ` (code_sort [] = []) /\ diff --git a/compiler/backend/data_liveScript.sml b/compiler/backend/data_liveScript.sml index 7fdb8c4990..7e4c406816 100644 --- a/compiler/backend/data_liveScript.sml +++ b/compiler/backend/data_liveScript.sml @@ -43,7 +43,8 @@ val is_pure_def = Define ` (is_pure ConfigGC = F) /\ (is_pure _ = T)` -Theorem is_pure_pmatch `!op. +Theorem is_pure_pmatch: + !op. is_pure op = case op of SetGlobalsPtr => F @@ -77,10 +78,12 @@ Theorem is_pure_pmatch `!op. | FP_uop _ => F | FP_bop _ => F | ConfigGC => F - | _ => T` - (rpt strip_tac + | _ => T +Proof + rpt strip_tac >> CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) - >> every_case_tac >> fs[is_pure_def]); + >> every_case_tac >> fs[is_pure_def] +QED val compile_def = Define ` (compile Skip live = (Skip,live)) /\ diff --git a/compiler/backend/data_spaceScript.sml b/compiler/backend/data_spaceScript.sml index 1b9f4bcedb..50fc069e83 100644 --- a/compiler/backend/data_spaceScript.sml +++ b/compiler/backend/data_spaceScript.sml @@ -23,7 +23,8 @@ val op_space_req_def = Define ` (op_space_req _ _ = 0)`; (* -Theorem op_space_req_pmatch `!op l. +Theorem op_space_req_pmatch: + !op l. op_space_req op l = case op of Cons _ => if l = 0n then 0 else l+1 @@ -35,10 +36,12 @@ Theorem op_space_req_pmatch `!op l. | WordFromWord b => (if b then 0 else 3) | FP_uop _ => 3 | FP_bop _ => 3 - | _ => 0` - (rpt strip_tac + | _ => 0 +Proof + rpt strip_tac >> CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) - >> every_case_tac >> fs[op_space_req_def]); + >> every_case_tac >> fs[op_space_req_def] +QED *) val pMakeSpace_def = Define ` @@ -72,7 +75,8 @@ val space_def = Define ` INL (If n (pMakeSpace (space c2)) (pMakeSpace (space c3)))) /\ (space c = INL c)`; -Theorem space_pmatch `∀c. +Theorem space_pmatch: + ∀c. space c = case c of | MakeSpace k names => INR (k,names,Skip) @@ -99,11 +103,13 @@ Theorem space_pmatch `∀c. | _ => INL (Seq d1 (pMakeSpace x2)))) | If n c2 c3 => INL (If n (pMakeSpace (space c2)) (pMakeSpace (space c3))) - | c => INL c` - (rpt strip_tac + | c => INL c +Proof + rpt strip_tac >> rpt(CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac >> TRY(PURE_REWRITE_TAC [LET_DEF] >> BETA_TAC)) - >> fs[space_def]); + >> fs[space_def] +QED val compile_def = Define ` compile c = pMakeSpace (space c)`; diff --git a/compiler/backend/data_to_wordScript.sml b/compiler/backend/data_to_wordScript.sml index f08a3b72a4..7dba7541ca 100644 --- a/compiler/backend/data_to_wordScript.sml +++ b/compiler/backend/data_to_wordScript.sml @@ -1000,17 +1000,23 @@ val arg3_def = Define ` val arg4_def = Define ` arg4 vs f x = dtcase vs of | [v1;v2;v3;v4] => f v1 v2 v3 v4 | _ => x`; -Theorem arg2_pmatch - `arg2 vs f x = case vs of | [v1;v2] => f v1 v2 | _ => x` - (CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) \\ fs [arg2_def]); - -Theorem arg3_pmatch - `arg3 vs f x = case vs of | [v1;v2;v3] => f v1 v2 v3 | _ => x` - (CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) \\ fs [arg3_def]); - -Theorem arg4_pmatch - `arg4 vs f x = case vs of | [v1;v2;v3;v4] => f v1 v2 v3 v4 | _ => x` - (CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) \\ fs [arg4_def]); +Theorem arg2_pmatch: + arg2 vs f x = case vs of | [v1;v2] => f v1 v2 | _ => x +Proof + CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) \\ fs [arg2_def] +QED + +Theorem arg3_pmatch: + arg3 vs f x = case vs of | [v1;v2;v3] => f v1 v2 v3 | _ => x +Proof + CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) \\ fs [arg3_def] +QED + +Theorem arg4_pmatch: + arg4 vs f x = case vs of | [v1;v2;v3;v4] => f v1 v2 v3 v4 | _ => x +Proof + CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) \\ fs [arg4_def] +QED val assign_defs = ref ([]:thm list); fun assign_Define q = let @@ -2140,13 +2146,17 @@ val stubs_def = Define` (Dummy_location,0,Skip) ] ++ generated_bignum_stubs Bignum_location`; -Theorem check_stubs_length - `word_num_stubs + LENGTH (stubs (:α) c) = data_num_stubs` - (EVAL_TAC); - -Theorem check_LongDiv_location - `LongDiv_location = word_bignum$div_location` - (EVAL_TAC); +Theorem check_stubs_length: + word_num_stubs + LENGTH (stubs (:α) c) = data_num_stubs +Proof + EVAL_TAC +QED + +Theorem check_LongDiv_location: + LongDiv_location = word_bignum$div_location +Proof + EVAL_TAC +QED val compile_def = Define ` compile data_conf word_conf asm_conf prog = diff --git a/compiler/backend/db_varsScript.sml b/compiler/backend/db_varsScript.sml index ccf34bda71..ca71fa14d6 100644 --- a/compiler/backend/db_varsScript.sml +++ b/compiler/backend/db_varsScript.sml @@ -18,20 +18,24 @@ val mk_Union_def = Define ` if t2 = Empty then t1 else Union t1 t2`; -Theorem mk_Union_Empty[simp] - `mk_Union Empty A = A ∧ mk_Union A Empty = A` - (rw[mk_Union_def]); +Theorem mk_Union_Empty[simp]: + mk_Union Empty A = A ∧ mk_Union A Empty = A +Proof + rw[mk_Union_def] +QED val list_mk_Union_def = Define ` (list_mk_Union [] = Empty) /\ (list_mk_Union (x::xs) = mk_Union x (list_mk_Union xs))`; -Theorem FOLDR_mk_Union_UNZIP - `FOLDR (λ(x,l) (ts,frees). (x::ts, mk_Union l frees)) ([], A) l = +Theorem FOLDR_mk_Union_UNZIP: + FOLDR (λ(x,l) (ts,frees). (x::ts, mk_Union l frees)) ([], A) l = let (ts, fvs) = UNZIP l in - (ts, list_mk_Union (fvs ++ [A]))` - (Induct_on `l` >> simp[list_mk_Union_def] >> - rename1 `UNZIP ll` >> Cases_on `UNZIP ll` >> full_simp_tac(srw_ss())[FORALL_PROD]); + (ts, list_mk_Union (fvs ++ [A])) +Proof + Induct_on `l` >> simp[list_mk_Union_def] >> + rename1 `UNZIP ll` >> Cases_on `UNZIP ll` >> full_simp_tac(srw_ss())[FORALL_PROD] +QED val db_to_set_acc_def = Define ` (db_to_set_acc (n:num) (Empty:db_var_set) s = s) /\ @@ -41,16 +45,20 @@ val db_to_set_acc_def = Define ` (db_to_set_acc n (Union v1 v2) s = db_to_set_acc n v1 (db_to_set_acc n v2 s))`; -Theorem wf_db_to_set_acc - `∀s n a. wf a ⇒ wf (db_to_set_acc n s a)` - (Induct \\ EVAL_TAC \\ rw[wf_insert]); +Theorem wf_db_to_set_acc: + ∀s n a. wf a ⇒ wf (db_to_set_acc n s a) +Proof + Induct \\ EVAL_TAC \\ rw[wf_insert] +QED val db_to_set_def = Define ` db_to_set db = db_to_set_acc 0 db LN`; -Theorem wf_db_to_set - `∀db. wf (db_to_set db)` - (rw[db_to_set_def,wf_db_to_set_acc,wf_def]); +Theorem wf_db_to_set: + ∀db. wf (db_to_set db) +Proof + rw[db_to_set_def,wf_db_to_set_acc,wf_def] +QED val vars_to_list_def = Define ` vars_to_list db = MAP FST (toAList (db_to_set db))` @@ -68,51 +76,69 @@ val has_var_def = Define ` (has_var n (Union d1 d2) <=> has_var n d1 \/ has_var n d2)`; val _ = export_rewrites["has_var_def"]; -Theorem has_var_mk_Union[simp] - `has_var n (mk_Union l1 l2) <=> has_var n l1 \/ has_var n l2` - (SRW_TAC [] [mk_Union_def,has_var_def]); +Theorem has_var_mk_Union[simp]: + has_var n (mk_Union l1 l2) <=> has_var n l1 \/ has_var n l2 +Proof + SRW_TAC [] [mk_Union_def,has_var_def] +QED -Theorem has_var_list_mk_Union[simp] - `!ls. has_var n (list_mk_Union ls) <=> EXISTS (has_var n) ls` - (Induct \\ fs [list_mk_Union_def,has_var_mk_Union,has_var_def]); +Theorem has_var_list_mk_Union[simp]: + !ls. has_var n (list_mk_Union ls) <=> EXISTS (has_var n) ls +Proof + Induct \\ fs [list_mk_Union_def,has_var_mk_Union,has_var_def] +QED -Theorem lookup_db_to_set_acc - `!d n k s. +Theorem lookup_db_to_set_acc: + !d n k s. lookup n (db_to_set_acc k d s) = - if has_var (n + k) d then SOME () else lookup n s` - (Induct \\ fs [has_var_def,db_to_set_acc_def,AC ADD_COMM ADD_ASSOC] + if has_var (n + k) d then SOME () else lookup n s +Proof + Induct \\ fs [has_var_def,db_to_set_acc_def,AC ADD_COMM ADD_ASSOC] \\ SRW_TAC [] [] \\ fs [lookup_insert] - \\ SRW_TAC [] [] \\ `F` by DECIDE_TAC) - -Theorem lookup_db_to_set - `has_var n d = (lookup n (db_to_set d) = SOME ())` - (fs [lookup_db_to_set_acc,db_to_set_def,lookup_def]); - -Theorem lookup_db_to_set_Shift - `lookup n (db_to_set (Shift k s)) = lookup (n+k) (db_to_set s)` - (rw[db_to_set_def,db_to_set_acc_def] - \\ rw[lookup_db_to_set_acc,lookup_def]); - -Theorem MEM_vars_to_list - `MEM n (vars_to_list d) = has_var n d` - (fs [vars_to_list_def,MEM_MAP,EXISTS_PROD,MEM_toAList] - \\ fs [lookup_db_to_set]); + \\ SRW_TAC [] [] \\ `F` by DECIDE_TAC +QED + +Theorem lookup_db_to_set: + has_var n d = (lookup n (db_to_set d) = SOME ()) +Proof + fs [lookup_db_to_set_acc,db_to_set_def,lookup_def] +QED + +Theorem lookup_db_to_set_Shift: + lookup n (db_to_set (Shift k s)) = lookup (n+k) (db_to_set s) +Proof + rw[db_to_set_def,db_to_set_acc_def] + \\ rw[lookup_db_to_set_acc,lookup_def] +QED + +Theorem MEM_vars_to_list: + MEM n (vars_to_list d) = has_var n d +Proof + fs [vars_to_list_def,MEM_MAP,EXISTS_PROD,MEM_toAList] + \\ fs [lookup_db_to_set] +QED val has_var_FOLDL_Union = Q.prove( `!vs n s. has_var n (FOLDL (\s1 v. Union (Var v) s1) s vs) <=> MEM n vs \/ has_var n s`, Induct \\ fs [] \\ rw [] \\ fs [] \\ eq_tac \\ rw [] \\ fs []); -Theorem MEM_vars_from_list - `!vs n. has_var n (vars_from_list vs) <=> MEM n vs` - (fs [vars_from_list_def,has_var_FOLDL_Union]); - -Theorem has_var_vars_flatten[simp] - `has_var n (vars_flatten d) = has_var n d` - (fs [vars_flatten_def,MEM_vars_from_list,MEM_vars_to_list]); - -Theorem ALL_DISTINCT_vars_to_list - `ALL_DISTINCT (vars_to_list d)` - (fs [vars_to_list_def,ALL_DISTINCT_MAP_FST_toAList]); +Theorem MEM_vars_from_list: + !vs n. has_var n (vars_from_list vs) <=> MEM n vs +Proof + fs [vars_from_list_def,has_var_FOLDL_Union] +QED + +Theorem has_var_vars_flatten[simp]: + has_var n (vars_flatten d) = has_var n d +Proof + fs [vars_flatten_def,MEM_vars_from_list,MEM_vars_to_list] +QED + +Theorem ALL_DISTINCT_vars_to_list: + ALL_DISTINCT (vars_to_list d) +Proof + fs [vars_to_list_def,ALL_DISTINCT_MAP_FST_toAList] +QED val _ = export_theory(); diff --git a/compiler/backend/displayLangScript.sml b/compiler/backend/displayLangScript.sml index fc59a0a44f..69f5e33d88 100644 --- a/compiler/backend/displayLangScript.sml +++ b/compiler/backend/displayLangScript.sml @@ -35,9 +35,11 @@ val trace_to_json_def = Define` * the top level of a trace. *) (trace_to_json None = Null)`; -Theorem MEM_sExp_size - `!es a. MEM a es ==> sExp_size a < sExp1_size es` - (Induct \\ fs [] \\ rw [sExp_size_def] \\ fs [] \\ res_tac \\ fs []); +Theorem MEM_sExp_size: + !es a. MEM a es ==> sExp_size a < sExp1_size es +Proof + Induct \\ fs [] \\ rw [sExp_size_def] \\ fs [] \\ res_tac \\ fs [] +QED (* Converts a display expression to JSON *) val display_to_json_def = tDefine"display_to_json" ` diff --git a/compiler/backend/exportScript.sml b/compiler/backend/exportScript.sml index cd1710262b..bfe4848eb2 100644 --- a/compiler/backend/exportScript.sml +++ b/compiler/backend/exportScript.sml @@ -88,11 +88,13 @@ val all_bytes_def = Define ` val all_bytes_eq = save_thm("all_bytes_eq",EVAL ``all_bytes``); -Theorem byte_to_string_eq - `!b. byte_to_string b = sub all_bytes (w2n b)` - (Cases_on `b` \\ once_rewrite_tac [EQ_SYM_EQ] +Theorem byte_to_string_eq: + !b. byte_to_string b = sub all_bytes (w2n b) +Proof + Cases_on `b` \\ once_rewrite_tac [EQ_SYM_EQ] \\ rewrite_tac [all_bytes_def,mlvectorTheory.sub_def] \\ full_simp_tac std_ss [w2n_n2w,EVAL ``dimword (:8)``] - \\ full_simp_tac std_ss [listTheory.EL_GENLIST]); + \\ full_simp_tac std_ss [listTheory.EL_GENLIST] +QED val _ = export_theory (); diff --git a/compiler/backend/flatLangScript.sml b/compiler/backend/flatLangScript.sml index a0189f48d7..24f2dd5fb5 100644 --- a/compiler/backend/flatLangScript.sml +++ b/compiler/backend/flatLangScript.sml @@ -115,31 +115,38 @@ val _ = Datatype` val exp_size_def = definition"exp_size_def"; -Theorem exp6_size_APPEND[simp] - `flatLang$exp6_size (e ++ e2) = exp6_size e + exp6_size e2` - (Induct_on`e`>>simp[exp_size_def]) - -Theorem exp6_size_REVERSE[simp] - `flatLang$exp6_size (REVERSE es) = exp6_size es` - (Induct_on`es`>>simp[exp_size_def]) - -Theorem exp_size_MAP - `(!xs. exp6_size (MAP SND xs) < exp3_size xs + 1) /\ - (!xs. exp6_size (MAP (SND o SND) xs) < exp1_size xs + 1)` - (conj_tac +Theorem exp6_size_APPEND[simp]: + flatLang$exp6_size (e ++ e2) = exp6_size e + exp6_size e2 +Proof + Induct_on`e`>>simp[exp_size_def] +QED + +Theorem exp6_size_REVERSE[simp]: + flatLang$exp6_size (REVERSE es) = exp6_size es +Proof + Induct_on`es`>>simp[exp_size_def] +QED + +Theorem exp_size_MAP: + (!xs. exp6_size (MAP SND xs) < exp3_size xs + 1) /\ + (!xs. exp6_size (MAP (SND o SND) xs) < exp1_size xs + 1) +Proof + conj_tac >- (Induct \\ rw [exp_size_def] \\ PairCases_on `h` \\ fs [exp_size_def]) \\ Induct \\ rw [exp_size_def] - \\ PairCases_on `h` \\ fs [exp_size_def]) + \\ PairCases_on `h` \\ fs [exp_size_def] +QED -Theorem exp_size_MEM - `(!xs x. MEM x xs ==> exp_size x < exp6_size xs) /\ +Theorem exp_size_MEM: + (!xs x. MEM x xs ==> exp_size x < exp6_size xs) /\ (!xs x. MEM x xs ==> exp_size (SND (SND x)) < exp1_size xs) /\ - (!xs x. MEM x xs ==> exp_size (SND x) < exp3_size xs)` - (conj_tac + (!xs x. MEM x xs ==> exp_size (SND x) < exp3_size xs) +Proof + conj_tac >- (Induct \\ rw [exp_size_def] @@ -150,7 +157,8 @@ Theorem exp_size_MEM \\ rw [exp_size_def] \\ PairCases_on `h` \\ fs [exp_size_def] \\ res_tac - \\ decide_tac); + \\ decide_tac +QED val _ = Datatype` dec = diff --git a/compiler/backend/flat_elimScript.sml b/compiler/backend/flat_elimScript.sml index 83ba8b7b59..a73a1d75ef 100644 --- a/compiler/backend/flat_elimScript.sml +++ b/compiler/backend/flat_elimScript.sml @@ -84,21 +84,23 @@ val dest_GlobalVarLookup_def = Define ` dest_GlobalVarLookup _ = NONE ` -Theorem exp_size_map_snd - `∀ p_es . exp6_size (MAP SND p_es) ≤ exp3_size p_es` - (Induct >> rw[exp_size_def] >> +Theorem exp_size_map_snd: + ∀ p_es . exp6_size (MAP SND p_es) ≤ exp3_size p_es +Proof + Induct >> rw[exp_size_def] >> Cases_on `exp6_size (MAP SND p_es) = exp3_size p_es` >> `exp_size (SND h) ≤ exp5_size h` by (Cases_on `h` >> rw[exp_size_def]) >> rw[] -); +QED -Theorem exp_size_map_snd_snd - `∀ vv_es . exp6_size (MAP (λ x . SND (SND x)) vv_es) ≤ exp1_size vv_es` - (Induct >> rw[exp_size_def] >> +Theorem exp_size_map_snd_snd: + ∀ vv_es . exp6_size (MAP (λ x . SND (SND x)) vv_es) ≤ exp1_size vv_es +Proof + Induct >> rw[exp_size_def] >> Cases_on `exp6_size (MAP (λ x . SND (SND x)) vv_es) = exp1_size vv_es` >> `exp_size (SND (SND h)) ≤ exp2_size h` by (Cases_on `h` >> Cases_on `r` >> rw[exp_size_def]) >> rw[] -); +QED val find_loc_def = tDefine "find_loc" ` (find_loc ((Raise _ er):flatLang$exp) = find_loc er) ∧ diff --git a/compiler/backend/flat_exh_matchScript.sml b/compiler/backend/flat_exh_matchScript.sml index 46e5014740..da66c27dde 100644 --- a/compiler/backend/flat_exh_matchScript.sml +++ b/compiler/backend/flat_exh_matchScript.sml @@ -135,14 +135,18 @@ val compile_exps_def = tDefine "compile_exps" ` val _ = map delete_const ["e2sz","p2sz","l2sz","f2sz","e2sz_UNION"] val _ = delete_binding "e2sz_ind" -Theorem compile_exps_LENGTH - `!ctors xs. LENGTH (compile_exps ctors xs) = LENGTH xs` - (ho_match_mp_tac (theorem "compile_exps_ind") \\ rw [compile_exps_def]); - -Theorem compile_exps_SING[simp] - `compile_exps ctors [x] <> []` - (strip_tac \\ pop_assum (mp_tac o Q.AP_TERM `LENGTH`) - \\ fs [compile_exps_LENGTH]); +Theorem compile_exps_LENGTH: + !ctors xs. LENGTH (compile_exps ctors xs) = LENGTH xs +Proof + ho_match_mp_tac (theorem "compile_exps_ind") \\ rw [compile_exps_def] +QED + +Theorem compile_exps_SING[simp]: + compile_exps ctors [x] <> [] +Proof + strip_tac \\ pop_assum (mp_tac o Q.AP_TERM `LENGTH`) + \\ fs [compile_exps_LENGTH] +QED val compile_exp_def = Define ` compile_exp ctors exp = HD (compile_exps ctors [exp])`; diff --git a/compiler/backend/flat_reorder_matchScript.sml b/compiler/backend/flat_reorder_matchScript.sml index ed2c058f09..b688b124d2 100644 --- a/compiler/backend/flat_reorder_matchScript.sml +++ b/compiler/backend/flat_reorder_matchScript.sml @@ -49,10 +49,12 @@ val const_cons_sep_MEM= Q.store_thm("const_cons_sep_MEM", Induct_on `pes` \\ rw [const_cons_sep_def] \\ METIS_TAC [MEM]) -Theorem const_cons_fst_MEM - `MEM x (const_cons_fst pes) ==> MEM x pes` - (rw [const_cons_fst_def] - \\ METIS_TAC [MEM, const_cons_sep_MEM]) +Theorem const_cons_fst_MEM: + MEM x (const_cons_fst pes) ==> MEM x pes +Proof + rw [const_cons_fst_def] + \\ METIS_TAC [MEM, const_cons_sep_MEM] +QED (* example: @@ -106,30 +108,38 @@ val compile_def = tDefine "compile" ` val compile_ind = theorem"compile_ind"; -Theorem compile_length[simp] - `! es. LENGTH (compile es) = LENGTH es` - (ho_match_mp_tac compile_ind - \\ rw [compile_def]); +Theorem compile_length[simp]: + ! es. LENGTH (compile es) = LENGTH es +Proof + ho_match_mp_tac compile_ind + \\ rw [compile_def] +QED -Theorem compile_sing - `! e. ?e2. compile [e] = [e2]` - (rw [] +Theorem compile_sing: + ! e. ?e2. compile [e] = [e2] +Proof + rw [] \\ qspec_then `[e]` mp_tac compile_length - \\ simp_tac(std_ss++listSimps.LIST_ss)[LENGTH_EQ_NUM_compute]); + \\ simp_tac(std_ss++listSimps.LIST_ss)[LENGTH_EQ_NUM_compute] +QED val compile_nil = save_thm ("compile_nil[simp]", EVAL ``compile []``); -Theorem compile_not_nil[simp] - `compile [x] <> []` - (strip_tac \\ pop_assum (mp_tac o Q.AP_TERM `LENGTH`) - \\ fs [compile_length]); - -Theorem compile_cons - `! e es. compile (e::es) = HD (compile [e]) :: (compile es)` - (rw [] +Theorem compile_not_nil[simp]: + compile [x] <> [] +Proof + strip_tac \\ pop_assum (mp_tac o Q.AP_TERM `LENGTH`) + \\ fs [compile_length] +QED + +Theorem compile_cons: + ! e es. compile (e::es) = HD (compile [e]) :: (compile es) +Proof + rw [] \\ Cases_on `es` \\ rw [compile_def] - \\ METIS_TAC [compile_sing, HD]) + \\ METIS_TAC [compile_sing, HD] +QED val compile_decs_def = Define ` (compile_decs [] = []) /\ diff --git a/compiler/backend/flat_to_patScript.sml b/compiler/backend/flat_to_patScript.sml index f76e4a08b2..a60a358c39 100644 --- a/compiler/backend/flat_to_patScript.sml +++ b/compiler/backend/flat_to_patScript.sml @@ -19,11 +19,13 @@ val isBool_def = Define` dtcase e of Con _ t [] => (b ⇒ t = true_tag) ∧ (¬b ⇒ t = false_tag) | _ => F`; val _ = export_rewrites["isBool_def"]; -Theorem isBool_pmatch - `isBool b e = - case e of Con _ t [] => (b ⇒ t = true_tag) ∧ (¬b ⇒ t = false_tag) | _ => F` - (CONV_TAC (RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) \\ - CASE_TAC \\ simp[]); +Theorem isBool_pmatch: + isBool b e = + case e of Con _ t [] => (b ⇒ t = true_tag) ∧ (¬b ⇒ t = false_tag) | _ => F +Proof + CONV_TAC (RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) \\ + CASE_TAC \\ simp[] +QED val sIf_def = Define ` sIf tra e1 e2 e3 = @@ -34,18 +36,21 @@ val sIf_def = Define ` | Con _ t [] => if t = true_tag then e2 else e3 | _ => If tra e1 e2 e3)`; -Theorem sIf_pmatch `!e1 e2 e3. +Theorem sIf_pmatch: + !e1 e2 e3. sIf t e1 e2 e3 = if isBool T e2 ∧ isBool F e3 then e1 else (case e1 of | Con _ t [] => if t = true_tag then e2 else e3 - | _ => If t e1 e2 e3)` - (rpt strip_tac + | _ => If t e1 e2 e3) +Proof + rpt strip_tac >> every_case_tac >- fs[sIf_def] - >- (CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac >> fs[sIf_def])); + >- (CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac >> fs[sIf_def]) +QED val _ = Define ` pure_op_op op ⇔ @@ -107,9 +112,11 @@ val pure_def = Define ` ∧ (pure_list (e::es) ⇔ pure e ∧ pure_list es)`; -Theorem pure_list_EVERY - `∀ls. pure_list ls ⇔ EVERY pure ls` - (Induct >> simp[pure_def]) +Theorem pure_list_EVERY: + ∀ls. pure_list ls ⇔ EVERY pure ls +Proof + Induct >> simp[pure_def] +QED val _ = export_rewrites["pure_list_EVERY"] val ground_def = Define ` @@ -141,13 +148,15 @@ val ground_def = Define ` val _ = export_rewrites["pure_op_op_def","pure_op_def","pure_def","ground_def"]; -Theorem ground_list_EVERY - `∀n ls. ground_list n ls ⇔ EVERY (ground n) ls` - (gen_tac >> Induct >> simp[]) +Theorem ground_list_EVERY: + ∀n ls. ground_list n ls ⇔ EVERY (ground n) ls +Proof + gen_tac >> Induct >> simp[] +QED val _ = export_rewrites["ground_list_EVERY"] -Theorem pure_op_op_eqn ` - pure_op_op op = +Theorem pure_op_op_eqn: + pure_op_op op = dtcase op of Opref => F | Opapp => F @@ -170,12 +179,14 @@ Theorem pure_op_op_eqn ` | GlobalVarAlloc _ => F | GlobalVarInit _ => F | FFI _ => F - | _ => T` - (Cases_on`op`>>fs[]>> - Cases_on`o'`>>fs[]) + | _ => T +Proof + Cases_on`op`>>fs[]>> + Cases_on`o'`>>fs[] +QED -Theorem pure_op_op_pmatch ` - pure_op_op op = +Theorem pure_op_op_pmatch: + pure_op_op op = case op of Opref => F | Opapp => F @@ -198,10 +209,12 @@ Theorem pure_op_op_pmatch ` | GlobalVarAlloc _ => F | GlobalVarInit _ => F | FFI _ => F - | _ => T` - (PURE_ONCE_REWRITE_TAC [pure_op_op_eqn] + | _ => T +Proof + PURE_ONCE_REWRITE_TAC [pure_op_op_eqn] >> CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) - >> REFL_TAC) + >> REFL_TAC +QED val sLet_def = Define ` sLet t e1 e2 = @@ -213,17 +226,19 @@ val sLet_def = Define ` else Seq t e1 e2 else Let t e1 e2`; -Theorem sLet_pmatch - `sLet t e1 e2 = +Theorem sLet_pmatch: + sLet t e1 e2 = case e2 of | Var_local _ 0 => e1 | _ => if ground 0 e2 then if pure e1 then e2 else Seq t e1 e2 - else Let t e1 e2` - (CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) \\ - CASE_TAC \\ rw[sLet_def]); + else Let t e1 e2 +Proof + CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) \\ + CASE_TAC \\ rw[sLet_def] +QED (* bind elements 0..k of the variable n in reverse order above e (first element * becomes most recently bound) *) @@ -371,16 +386,22 @@ val compile_def = Define` compile_exp [] exp :: compile decs ∧ compile (_::decs) = compile decs`; -Theorem compile_funs_map - `∀funs bvs. compile_funs bvs funs = MAP (λ(f,x,e). compile_exp (SOME x::bvs) e) funs` - (Induct>>simp[pairTheory.FORALL_PROD]) +Theorem compile_funs_map: + ∀funs bvs. compile_funs bvs funs = MAP (λ(f,x,e). compile_exp (SOME x::bvs) e) funs +Proof + Induct>>simp[pairTheory.FORALL_PROD] +QED -Theorem compile_exps_map - `∀es. compile_exps a es = MAP (compile_exp a) es` - (Induct >> simp[compile_exp_def]) +Theorem compile_exps_map: + ∀es. compile_exps a es = MAP (compile_exp a) es +Proof + Induct >> simp[compile_exp_def] +QED -Theorem compile_exps_reverse - `compile_exps a (REVERSE ls) = REVERSE (compile_exps a ls)` - (rw[compile_exps_map,rich_listTheory.MAP_REVERSE]) +Theorem compile_exps_reverse: + compile_exps a (REVERSE ls) = REVERSE (compile_exps a ls) +Proof + rw[compile_exps_map,rich_listTheory.MAP_REVERSE] +QED val _ = export_theory() diff --git a/compiler/backend/flat_uncheck_ctorsScript.sml b/compiler/backend/flat_uncheck_ctorsScript.sml index e5e222f9ee..cd393b2b45 100644 --- a/compiler/backend/flat_uncheck_ctorsScript.sml +++ b/compiler/backend/flat_uncheck_ctorsScript.sml @@ -57,34 +57,43 @@ val compile_def = tDefine "compile" ` val compile_ind = theorem"compile_ind"; -Theorem compile_length[simp] - `! es. LENGTH (compile es) = LENGTH es` - (ho_match_mp_tac compile_ind - \\ rw [compile_def]); +Theorem compile_length[simp]: + ! es. LENGTH (compile es) = LENGTH es +Proof + ho_match_mp_tac compile_ind + \\ rw [compile_def] +QED -Theorem compile_sing - `! e. ?e2. compile [e] = [e2]` - (rw [] +Theorem compile_sing: + ! e. ?e2. compile [e] = [e2] +Proof + rw [] \\ qspec_then `[e]` mp_tac compile_length - \\ simp_tac(std_ss++listSimps.LIST_ss)[LENGTH_EQ_NUM_compute]); + \\ simp_tac(std_ss++listSimps.LIST_ss)[LENGTH_EQ_NUM_compute] +QED val compile_nil = save_thm ("compile_nil[simp]", EVAL ``compile []``); -Theorem compile_not_nil[simp] - `compile [x] <> []` - (strip_tac \\ pop_assum (mp_tac o Q.AP_TERM `LENGTH`) - \\ fs [compile_length]); +Theorem compile_not_nil[simp]: + compile [x] <> [] +Proof + strip_tac \\ pop_assum (mp_tac o Q.AP_TERM `LENGTH`) + \\ fs [compile_length] +QED -Theorem compile_cons - `! e es. compile (e::es) = HD (compile [e]) :: (compile es)` - (rw [] +Theorem compile_cons: + ! e es. compile (e::es) = HD (compile [e]) :: (compile es) +Proof + rw [] \\ Cases_on `es` \\ rw [compile_def] - \\ METIS_TAC [compile_sing, HD]); + \\ METIS_TAC [compile_sing, HD] +QED -Theorem compile_append - `!es es2. compile (es:flatLang$exp list ++ es2) = compile es ++ compile es2` - (Induct >> +Theorem compile_append: + !es es2. compile (es:flatLang$exp list ++ es2) = compile es ++ compile es2 +Proof + Induct >> rw [compile_def] >> Cases_on `es` >> rw [compile_def] >> @@ -92,17 +101,22 @@ Theorem compile_append Cases_on `es2` >> rw [] >> Cases_on `h` >> - rw [compile_def]); + rw [compile_def] +QED -Theorem compile_reverse - `!es. compile (REVERSE es) = REVERSE (compile es:flatLang$exp list)` - (ho_match_mp_tac compile_ind >> - rw [compile_def, compile_append]); +Theorem compile_reverse: + !es. compile (REVERSE es) = REVERSE (compile es:flatLang$exp list) +Proof + ho_match_mp_tac compile_ind >> + rw [compile_def, compile_append] +QED -Theorem compile_HD_sing - `[HD (compile [e])] = compile [e:flatLang$exp]` - (qspec_then`e`strip_assume_tac compile_sing - \\ fs[]); +Theorem compile_HD_sing: + [HD (compile [e])] = compile [e:flatLang$exp] +Proof + qspec_then`e`strip_assume_tac compile_sing + \\ fs[] +QED val compile_decs = Define ` (compile_decs [] = []) ∧ diff --git a/compiler/backend/gc/copying_gcScript.sml b/compiler/backend/gc/copying_gcScript.sml index 89a2228b2a..8733a04db1 100644 --- a/compiler/backend/gc/copying_gcScript.sml +++ b/compiler/backend/gc/copying_gcScript.sml @@ -226,27 +226,31 @@ val gc_move_list_thm = Q.prove( val APPEND_NIL_LEMMA = METIS_PROVE [APPEND_NIL] ``?xs1. xs = xs ++ xs1:'a list`` -Theorem gc_move_ALT - `gc_move (ys,xs,a,n,heap,c,limit) = +Theorem gc_move_ALT: + gc_move (ys,xs,a,n,heap,c,limit) = let (ys,xs1,x) = gc_move (ys,[],a,n,heap,c,limit) in - (ys,xs++xs1,x)` - (Cases_on `ys` \\ simp_tac (srw_ss()) [gc_move_def] \\ rpt strip_tac + (ys,xs++xs1,x) +Proof + Cases_on `ys` \\ simp_tac (srw_ss()) [gc_move_def] \\ rpt strip_tac \\ Cases_on `heap_lookup n' heap` \\ simp_tac (srw_ss()) [LET_DEF] \\ Cases_on `x` \\ simp_tac (srw_ss()) [LET_DEF] \\ CONV_TAC (DEPTH_CONV PairRules.PBETA_CONV) - \\ full_simp_tac std_ss []); + \\ full_simp_tac std_ss [] +QED -Theorem gc_move_list_ALT - `!ys xs a n heap c limit ys3 xs3 a3 n3 heap3 c3. +Theorem gc_move_list_ALT: + !ys xs a n heap c limit ys3 xs3 a3 n3 heap3 c3. gc_move_list (ys,xs,a,n,heap,c,limit) = let (ys,xs1,x) = gc_move_list (ys,[],a,n,heap,c,limit) in - (ys,xs++xs1,x)` - (Induct \\ simp_tac std_ss [gc_move_list_def,LET_DEF,APPEND_NIL] + (ys,xs++xs1,x) +Proof + Induct \\ simp_tac std_ss [gc_move_list_def,LET_DEF,APPEND_NIL] \\ simp_tac std_ss [Once gc_move_ALT,LET_DEF] \\ pop_assum (fn th => once_rewrite_tac [th]) \\ full_simp_tac std_ss [LET_DEF] \\ rpt strip_tac \\ CONV_TAC (DEPTH_CONV PairRules.PBETA_CONV) - \\ full_simp_tac std_ss [APPEND_ASSOC]); + \\ full_simp_tac std_ss [APPEND_ASSOC] +QED val gc_move_list_APPEND_lemma = Q.prove( `!ys xs a n heap c limit ys3 xs3 a3 n3 heap3 c3. @@ -344,14 +348,15 @@ val gc_inv_init = Q.prove( \\ full_simp_tac (srw_ss()) [heaps_similar_REFL,heap_map_EMPTY,FLOOKUP_DEF] \\ full_simp_tac (srw_ss()) [BIJ_DEF,INJ_DEF,SURJ_DEF]); -Theorem full_gc_thm - `roots_ok roots heap /\ heap_ok (heap:('a,'b) heap_element list) limit ==> +Theorem full_gc_thm: + roots_ok roots heap /\ heap_ok (heap:('a,'b) heap_element list) limit ==> ?heap2 a2 heap3. (full_gc (roots:'a heap_address list,heap,limit) = (ADDR_MAP (heap_map1 heap3) roots,heap2,a2,T)) /\ (!ptr u. MEM (Pointer ptr u) roots ==> ptr IN FDOM (heap_map 0 heap3)) /\ - gc_inv (heap2,[],a2,limit - a2,heap3,T,limit) heap roots` - (simp_tac std_ss [Once (GSYM gc_inv_init)] + gc_inv (heap2,[],a2,limit - a2,heap3,T,limit) heap roots +Proof + simp_tac std_ss [Once (GSYM gc_inv_init)] \\ rpt strip_tac \\ full_simp_tac std_ss [full_gc_def] \\ mp_tac (Q.SPECL [`roots`,`[]`,`0`,`limit`,`heap`,`T`] gc_move_list_thm |> Q.INST [`h1`|->`[]`,`heap0`|->`heap`,`roots0`|->`roots`]) \\ full_simp_tac std_ss [gc_inv_init] \\ match_mp_tac IMP_IMP \\ strip_tac THEN1 @@ -374,7 +379,8 @@ Theorem full_gc_thm THEN1 (full_simp_tac std_ss [gc_inv_def,APPEND_NIL] \\ decide_tac) \\ match_mp_tac ADDR_MAP_EQ \\ full_simp_tac std_ss [] \\ rpt strip_tac \\ res_tac - \\ full_simp_tac std_ss [SUBMAP_DEF,heap_map1_def]); + \\ full_simp_tac std_ss [SUBMAP_DEF,heap_map1_def] +QED val heap_lookup_IMP_heap_addresses = Q.prove( `!xs n x j. (heap_lookup j xs = SOME x) ==> n + j IN heap_addresses n xs`, @@ -384,21 +390,24 @@ val heap_lookup_IMP_heap_addresses = Q.prove( \\ `n + el_length h + (j - el_length h) = n + j` by decide_tac \\ metis_tac []) |> Q.SPECL [`xs`,`0`] |> SIMP_RULE std_ss [] |> GEN_ALL; -Theorem full_gc_LENGTH - `roots_ok roots heap /\ heap_ok (heap:('a,'b) heap_element list) limit ==> +Theorem full_gc_LENGTH: + roots_ok roots heap /\ heap_ok (heap:('a,'b) heap_element list) limit ==> ?roots2 heap2 a2. (full_gc (roots:'a heap_address list,heap,limit) = - (roots2,heap2,heap_length heap2,T))` - (rpt strip_tac \\ mp_tac full_gc_thm \\ full_simp_tac std_ss [] - \\ rpt strip_tac \\ full_simp_tac std_ss [gc_inv_def,APPEND_NIL]); - -Theorem full_gc_ok - `roots_ok roots heap /\ heap_ok (heap:('a,'b) heap_element list) limit ==> + (roots2,heap2,heap_length heap2,T)) +Proof + rpt strip_tac \\ mp_tac full_gc_thm \\ full_simp_tac std_ss [] + \\ rpt strip_tac \\ full_simp_tac std_ss [gc_inv_def,APPEND_NIL] +QED + +Theorem full_gc_ok: + roots_ok roots heap /\ heap_ok (heap:('a,'b) heap_element list) limit ==> ?roots2 heap2 a2. (full_gc (roots:'a heap_address list,heap,limit) = (roots2,heap2,a2,T)) /\ a2 <= limit /\ roots_ok roots2 (heap2 ++ heap_expand (limit - a2)) /\ - heap_ok (heap2 ++ heap_expand (limit - a2)) limit` - (rpt strip_tac \\ mp_tac full_gc_thm \\ full_simp_tac std_ss [] \\ strip_tac + heap_ok (heap2 ++ heap_expand (limit - a2)) limit +Proof + rpt strip_tac \\ mp_tac full_gc_thm \\ full_simp_tac std_ss [] \\ strip_tac \\ full_simp_tac std_ss [] \\ full_simp_tac std_ss [gc_inv_def] \\ full_simp_tac std_ss [APPEND_NIL] \\ strip_tac THEN1 decide_tac \\ simp_tac std_ss [roots_ok_def,heap_ok_def] @@ -436,17 +445,19 @@ Theorem full_gc_ok \\ qpat_x_assum `!i j:num. bbb` (mp_tac o Q.SPECL [`y`,`ptr`]) \\ full_simp_tac std_ss [] \\ strip_tac \\ match_mp_tac isSome_heap_looukp_IMP_APPEND \\ full_simp_tac std_ss [] - \\ full_simp_tac (srw_ss()) [isSomeDataElement_def]); + \\ full_simp_tac (srw_ss()) [isSomeDataElement_def] +QED -Theorem full_gc_related - `roots_ok roots heap /\ heap_ok (heap:('a,'b) heap_element list) limit ==> +Theorem full_gc_related: + roots_ok roots heap /\ heap_ok (heap:('a,'b) heap_element list) limit ==> ?heap2 a2 f. (full_gc (roots:'a heap_address list,heap,limit) = (ADDR_MAP (FAPPLY f) roots,heap2,a2,T)) /\ (FDOM f = reachable_addresses roots heap) /\ (heap_length heap2 = heap_length (heap_filter (FDOM f) heap)) /\ - gc_related f heap (heap2 ++ heap_expand (limit - a2))` - (strip_tac \\ mp_tac full_gc_thm \\ asm_simp_tac std_ss [] + gc_related f heap (heap2 ++ heap_expand (limit - a2)) +Proof + strip_tac \\ mp_tac full_gc_thm \\ asm_simp_tac std_ss [] \\ rpt strip_tac \\ full_simp_tac std_ss [] \\ qexists_tac `heap_map 0 heap3` \\ `(FAPPLY (heap_map 0 heap3)) = heap_map1 heap3` by (full_simp_tac std_ss [heap_map1_def,FUN_EQ_THM]) @@ -501,15 +512,17 @@ Theorem full_gc_related by full_simp_tac std_ss [FLOOKUP_DEF] \\ res_tac \\ full_simp_tac (srw_ss()) [APPEND_NIL] \\ imp_res_tac heap_lookup_LESS \\ imp_res_tac heap_lookup_EXTEND - \\ full_simp_tac std_ss [] \\ metis_tac []); + \\ full_simp_tac std_ss [] \\ metis_tac [] +QED (* Lemmas about ok and a *) -Theorem gc_move_ok - `(gc_move (x,h2,a,n,heap,c,limit) = (x',h2',a',n',heap',T)) ==> +Theorem gc_move_ok: + (gc_move (x,h2,a,n,heap,c,limit) = (x',h2',a',n',heap',T)) ==> c /\ - ((a = b + heap_length h2) ==> (a' = b + heap_length h2'))` - (simp_tac std_ss [Once EQ_SYM_EQ] \\ Cases_on `x` + ((a = b + heap_length h2) ==> (a' = b + heap_length h2')) +Proof + simp_tac std_ss [Once EQ_SYM_EQ] \\ Cases_on `x` \\ full_simp_tac std_ss [gc_move_def] \\ Cases_on `heap_lookup n'' heap` \\ full_simp_tac (srw_ss()) [] \\ Cases_on `x` \\ full_simp_tac (srw_ss()) [LET_DEF] @@ -519,14 +532,16 @@ Theorem gc_move_ok \\ rpt (pop_assum mp_tac) \\ once_rewrite_tac [EQ_SYM_EQ] \\ full_simp_tac std_ss [] \\ full_simp_tac (srw_ss()) [heap_length_APPEND,heap_length_def, - el_length_def,ADD_ASSOC]); + el_length_def,ADD_ASSOC] +QED -Theorem gc_move_list_ok - `!xs h2 a n heap c limit xs' h2' a' n' heap' c'. +Theorem gc_move_list_ok: + !xs h2 a n heap c limit xs' h2' a' n' heap' c'. (gc_move_list (xs,h2,a,n,heap,c,limit) = (xs',h2',a',n',heap',T)) ==> c /\ - ((a = b + heap_length h2) ==> (a' = b + heap_length h2'))` - (Induct \\ simp_tac std_ss [gc_move_list_def] \\ rpt strip_tac + ((a = b + heap_length h2) ==> (a' = b + heap_length h2')) +Proof + Induct \\ simp_tac std_ss [gc_move_list_def] \\ rpt strip_tac THENL [all_tac, pop_assum mp_tac] \\ pop_assum mp_tac \\ `? x' h2' a' n' heap' c'. gc_move (h,h2,a,n,heap,c,limit) = @@ -540,7 +555,8 @@ Theorem gc_move_list_ok \\ Cases_on `c1` \\ simp_tac std_ss [] \\ `c'` by metis_tac [] \\ pop_assum mp_tac \\ Cases_on `c'` \\ simp_tac std_ss [] \\ once_rewrite_tac [EQ_SYM_EQ] \\ simp_tac std_ss [] \\ res_tac - \\ imp_res_tac gc_move_ok \\ metis_tac []); + \\ imp_res_tac gc_move_ok \\ metis_tac [] +QED val th = fetch "-" "gc_move_loop_ind" |> Q.SPEC `(\(h1,h2,a,n,heap,c,limit). @@ -568,65 +584,77 @@ val th = MP th lemma |> SIMP_RULE std_ss [] val gc_move_loop_ok = save_thm("gc_move_loop_ok",th); -Theorem gc_move_list_IMP_LENGTH - `!l5 h a n heap c k xs ys a1 xs1 heap1 c1. +Theorem gc_move_list_IMP_LENGTH: + !l5 h a n heap c k xs ys a1 xs1 heap1 c1. (gc_move_list (l5,h,a,n,heap,c,k) = - (xs,ys,a1,xs1,heap1,c1)) ==> (LENGTH xs = LENGTH l5)` - (Induct \\ fs [gc_move_list_def,LET_THM] \\ rw [] + (xs,ys,a1,xs1,heap1,c1)) ==> (LENGTH xs = LENGTH l5) +Proof + Induct \\ fs [gc_move_list_def,LET_THM] \\ rw [] \\ pairarg_tac \\ fs[] \\ pairarg_tac \\ fs[] \\ rw [] - \\ res_tac \\ fs []); + \\ res_tac \\ fs [] +QED -Theorem full_gc_IMP_LENGTH - `(full_gc (xs,heap,limit) = (roots2,heap2,h,T)) ==> - (LENGTH roots2 = LENGTH xs)` - (fs [full_gc_def,LET_THM] +Theorem full_gc_IMP_LENGTH: + (full_gc (xs,heap,limit) = (roots2,heap2,h,T)) ==> + (LENGTH roots2 = LENGTH xs) +Proof + fs [full_gc_def,LET_THM] \\ rpt (pairarg_tac \\ fs []) \\ rw [] - \\ imp_res_tac gc_move_list_IMP_LENGTH \\ fs []); + \\ imp_res_tac gc_move_list_IMP_LENGTH \\ fs [] +QED -Theorem gc_move_IMP_isDataElement - `!l5 h a n heap c k xs ys a1 xs1 heap1 c1. +Theorem gc_move_IMP_isDataElement: + !l5 h a n heap c k xs ys a1 xs1 heap1 c1. EVERY isDataElement h /\ (gc_move (l5,h,a,n,heap,c,k) = (xs,ys,a1,xs1,heap1,c1)) ==> - EVERY isDataElement ys` - (Cases \\ fs [gc_move_def] + EVERY isDataElement ys +Proof + Cases \\ fs [gc_move_def] \\ rw [] \\ every_case_tac \\ fs [] - \\ pairarg_tac \\ fs [] \\ rw [] \\ fs [isDataElement_def]); + \\ pairarg_tac \\ fs [] \\ rw [] \\ fs [isDataElement_def] +QED -Theorem gc_move_list_IMP_isDataElement - `!l5 h a n heap c k xs ys a1 xs1 heap1 c1. +Theorem gc_move_list_IMP_isDataElement: + !l5 h a n heap c k xs ys a1 xs1 heap1 c1. EVERY isDataElement h /\ (gc_move_list (l5,h,a,n,heap,c,k) = (xs,ys,a1,xs1,heap1,c1)) ==> - EVERY isDataElement ys` - (Induct \\ fs [gc_move_list_def,LET_THM] \\ rw [] + EVERY isDataElement ys +Proof + Induct \\ fs [gc_move_list_def,LET_THM] \\ rw [] \\ pairarg_tac \\ fs[] \\ pairarg_tac \\ fs[] \\ rw [] \\ imp_res_tac gc_move_IMP_isDataElement - \\ res_tac \\ fs []); + \\ res_tac \\ fs [] +QED -Theorem gc_move_loop_IMP_isDataElement - `!h1 h2 a n heap c limit h1' a' n' heap' c'. +Theorem gc_move_loop_IMP_isDataElement: + !h1 h2 a n heap c limit h1' a' n' heap' c'. EVERY isDataElement h1 /\ EVERY isDataElement h2 /\ (gc_move_loop (h1,h2,a,n,heap,c,limit) = (h1',a',n',heap',T)) ==> - EVERY isDataElement h1'` - (recInduct (fetch "-" "gc_move_loop_ind") \\ rw [] + EVERY isDataElement h1' +Proof + recInduct (fetch "-" "gc_move_loop_ind") \\ rw [] \\ fs [gc_move_loop_def] \\ every_case_tac \\ fs [] \\ rpt (pairarg_tac \\ fs []) \\ rfs [] \\ fs [isDataElement_def] \\ imp_res_tac gc_move_loop_ok \\ fs [] \\ imp_res_tac gc_move_list_IMP_isDataElement \\ fs [] - \\ Cases_on `h2'` \\ fs [isDataElement_def]); - -Theorem full_gc_IMP_isDataElement - `(full_gc (roots,heap,limit) = (roots1,heap1,a,T)) ==> - EVERY isDataElement heap1` - (fs [full_gc_def] + \\ Cases_on `h2'` \\ fs [isDataElement_def] +QED + +Theorem full_gc_IMP_isDataElement: + (full_gc (roots,heap,limit) = (roots1,heap1,a,T)) ==> + EVERY isDataElement heap1 +Proof + fs [full_gc_def] \\ rpt (pairarg_tac \\ fs []) \\ strip_tac \\ rveq \\ fs [] \\ imp_res_tac gc_move_list_IMP_isDataElement \\ fs [] - \\ imp_res_tac gc_move_loop_IMP_isDataElement \\ fs []); + \\ imp_res_tac gc_move_loop_IMP_isDataElement \\ fs [] +QED val _ = export_theory(); diff --git a/compiler/backend/gc/gc_sharedScript.sml b/compiler/backend/gc/gc_sharedScript.sml index 7f10998663..1b82769cbd 100644 --- a/compiler/backend/gc/gc_sharedScript.sml +++ b/compiler/backend/gc/gc_sharedScript.sml @@ -58,28 +58,38 @@ val el_length_def = Define ` (el_length (ForwardPointer n d l) = l+1) /\ (el_length (DataElement xs l data) = l+1)`; -Theorem el_length_NOT_0 - `!el. el_length el <> 0` - (Cases \\ fs [el_length_def]); - -Theorem el_length_GT_0 - `!el. 1 <= el_length el` - (Cases \\ fs [el_length_def]); +Theorem el_length_NOT_0: + !el. el_length el <> 0 +Proof + Cases \\ fs [el_length_def] +QED + +Theorem el_length_GT_0: + !el. 1 <= el_length el +Proof + Cases \\ fs [el_length_def] +QED val heap_length_def = Define ` heap_length heap = SUM (MAP el_length heap)`; -Theorem heap_length_NIL[simp] - `heap_length [] = 0` - (fs [heap_length_def]); +Theorem heap_length_NIL[simp]: + heap_length [] = 0 +Proof + fs [heap_length_def] +QED -Theorem heap_length_GTE - `!heap. 0 <= heap_length heap` - (fs [heap_length_def]) +Theorem heap_length_GTE: + !heap. 0 <= heap_length heap +Proof + fs [heap_length_def] +QED -Theorem heap_length_APPEND - `heap_length (xs ++ ys) = heap_length xs + heap_length ys` - (SRW_TAC [] [heap_length_def,SUM_APPEND]); +Theorem heap_length_APPEND: + heap_length (xs ++ ys) = heap_length xs + heap_length ys +Proof + SRW_TAC [] [heap_length_def,SUM_APPEND] +QED val heap_lookup_def = Define ` (heap_lookup a [] = NONE) /\ @@ -87,23 +97,29 @@ val heap_lookup_def = Define ` if a = 0 then SOME x else if a < el_length x then NONE else heap_lookup (a - el_length x) xs)`; -Theorem heap_lookup_MEM - `!heap n x. (heap_lookup n heap = SOME x) ==> MEM x heap` - (Induct \\ full_simp_tac std_ss [heap_lookup_def] \\ SRW_TAC [] [] - \\ res_tac \\ full_simp_tac std_ss []); +Theorem heap_lookup_MEM: + !heap n x. (heap_lookup n heap = SOME x) ==> MEM x heap +Proof + Induct \\ full_simp_tac std_ss [heap_lookup_def] \\ SRW_TAC [] [] + \\ res_tac \\ full_simp_tac std_ss [] +QED -Theorem MEM_IMP_heap_lookup - `!xs x. MEM x xs ==> ?j. (heap_lookup j xs = SOME x)` - (Induct \\ full_simp_tac std_ss [MEM,heap_lookup_def] +Theorem MEM_IMP_heap_lookup: + !xs x. MEM x xs ==> ?j. (heap_lookup j xs = SOME x) +Proof + Induct \\ full_simp_tac std_ss [MEM,heap_lookup_def] \\ SRW_TAC [] [] \\ res_tac THEN1 metis_tac [] \\ qexists_tac `j + el_length h` \\ full_simp_tac std_ss [] \\ SRW_TAC [] [] - \\ Cases_on `h` \\ full_simp_tac std_ss [el_length_def] \\ `F` by decide_tac); + \\ Cases_on `h` \\ full_simp_tac std_ss [el_length_def] \\ `F` by decide_tac +QED -Theorem heap_lookup_LESS - `!xs n. (heap_lookup n xs = SOME x) ==> n < heap_length xs` - (Induct \\ full_simp_tac std_ss [heap_lookup_def] \\ SRW_TAC [] [] +Theorem heap_lookup_LESS: + !xs n. (heap_lookup n xs = SOME x) ==> n < heap_length xs +Proof + Induct \\ full_simp_tac std_ss [heap_lookup_def] \\ SRW_TAC [] [] \\ res_tac \\ Cases_on `h` \\ full_simp_tac (srw_ss()) - [heap_length_def,el_length_def] \\ decide_tac); + [heap_length_def,el_length_def] \\ decide_tac +QED val heap_split_def = Define ` (heap_split a [] = if a = 0 then SOME ([],[]) else NONE) /\ @@ -115,13 +131,15 @@ val heap_split_def = Define ` | SOME (h1,h2) => SOME (el::h1,h2))`; -Theorem heap_lookup_SPLIT - `!heap n x. (heap_lookup n heap = SOME x) ==> - ?ha hb. (heap = ha ++ x::hb) /\ (n = heap_length ha)` - (Induct \\ full_simp_tac std_ss [heap_lookup_def] \\ SRW_TAC [] [] +Theorem heap_lookup_SPLIT: + !heap n x. (heap_lookup n heap = SOME x) ==> + ?ha hb. (heap = ha ++ x::hb) /\ (n = heap_length ha) +Proof + Induct \\ full_simp_tac std_ss [heap_lookup_def] \\ SRW_TAC [] [] THEN1 (Q.LIST_EXISTS_TAC [`[]`,`heap`] \\ full_simp_tac (srw_ss()) [heap_length_def]) \\ res_tac \\ Q.LIST_EXISTS_TAC [`h::ha`,`hb`] - \\ full_simp_tac (srw_ss()) [heap_length_def] \\ decide_tac); + \\ full_simp_tac (srw_ss()) [heap_length_def] \\ decide_tac +QED val heap_drop_def = Define ` heap_drop n (heap:('a,'b) heap_element list) = @@ -135,14 +153,15 @@ val heap_take_def = Define ` | NONE => ARB | SOME (h1,h2) => h1` -Theorem heap_split_heap_length - `!heap h1 h2 a. +Theorem heap_split_heap_length: + !heap h1 h2 a. (heap_split a heap = SOME (h1,h2)) ==> (heap_length h1 = a) /\ (heap_length (h1 ++ h2) = heap_length heap) /\ - (h1 ++ h2 = heap)` - (Induct + (h1 ++ h2 = heap) +Proof + Induct \\ fs [heap_split_def] \\ rpt gen_tac \\ IF_CASES_TAC @@ -159,7 +178,8 @@ Theorem heap_split_heap_length \\ first_x_assum drule \\ fs [] \\ strip_tac - \\ fs [heap_length_def]); + \\ fs [heap_length_def] +QED val heap_segment_def = Define ` heap_segment (a, b) heap = @@ -171,14 +191,15 @@ val heap_segment_def = Define ` | NONE => NONE | SOME (h2,h3) => SOME (h1,h2,h3)`; -Theorem heap_segment_IMP - `!heap a b h1 h2 h3. +Theorem heap_segment_IMP: + !heap a b h1 h2 h3. (heap_segment (a,b) heap = SOME (h1,h2,h3)) ==> (h1 ++ h2 ++ h3 = heap) /\ (heap_length h1 = a) /\ (heap_length (h1 ++ h2) = b) /\ - (heap_length h3 = (heap_length heap - b))` - (rpt gen_tac + (heap_length h3 = (heap_length heap - b)) +Proof + rpt gen_tac \\ fs [heap_segment_def] \\ Cases_on `heap_split a heap` \\ fs [] \\ Cases_on `x` \\ fs [] @@ -193,7 +214,8 @@ Theorem heap_segment_IMP \\ strip_tac \\ strip_tac \\ rveq \\ fs [] - \\ fs [heap_length_APPEND]); + \\ fs [heap_length_APPEND] +QED val heap_restrict_def = Define ` heap_restrict start end (heap:('a,'b) heap_element list) = @@ -242,25 +264,30 @@ val gc_forward_ptr_def = Define ` let (xs,ok) = gc_forward_ptr (a - el_length x) xs ptr d ok in (x::xs,ok))`; -Theorem gc_forward_ptr_ok - `!heap n a c x. (gc_forward_ptr n heap a d c = (x,T)) ==> c` - (Induct \\ simp_tac std_ss [Once gc_forward_ptr_def] \\ rpt strip_tac +Theorem gc_forward_ptr_ok: + !heap n a c x. (gc_forward_ptr n heap a d c = (x,T)) ==> c +Proof + Induct \\ simp_tac std_ss [Once gc_forward_ptr_def] \\ rpt strip_tac \\ Cases_on `n = 0` \\ full_simp_tac std_ss [] \\ Cases_on `n < el_length h` \\ full_simp_tac std_ss [] \\ Cases_on `gc_forward_ptr (n - el_length h) heap a d c` \\ full_simp_tac std_ss [LET_DEF] \\ Cases_on `r` - \\ full_simp_tac std_ss [] \\ res_tac); - -Theorem gc_forward_ptr_thm - `!ha. gc_forward_ptr (heap_length ha) (ha ++ DataElement ys l d::hb) a u c = - (ha ++ ForwardPointer a u l::hb,c)` - (Induct \\ full_simp_tac (srw_ss()) [gc_forward_ptr_def,heap_length_def,APPEND, + \\ full_simp_tac std_ss [] \\ res_tac +QED + +Theorem gc_forward_ptr_thm: + !ha. gc_forward_ptr (heap_length ha) (ha ++ DataElement ys l d::hb) a u c = + (ha ++ ForwardPointer a u l::hb,c) +Proof + Induct \\ full_simp_tac (srw_ss()) [gc_forward_ptr_def,heap_length_def,APPEND, el_length_def,isDataElement_def,LET_DEF] \\ SRW_TAC [] [] - \\ Cases_on `h` \\ full_simp_tac std_ss [el_length_def] \\ decide_tac); + \\ Cases_on `h` \\ full_simp_tac std_ss [el_length_def] \\ decide_tac +QED -(*Theorem gc_forward_ptr_ok - `!heap n a ok x. (gc_forward_ptr n heap a d ok = (x,T)) ==> ok` - (Induct +(*Theorem gc_forward_ptr_ok: + !heap n a ok x. (gc_forward_ptr n heap a d ok = (x,T)) ==> ok +Proof + Induct >- simp [gc_forward_ptr_def] \\ once_rewrite_tac [gc_forward_ptr_def] \\ ntac 5 strip_tac @@ -274,7 +301,8 @@ Theorem gc_forward_ptr_thm \\ DISCH_TAC \\ fs [] \\ qpat_x_assum `!n a ok x. _` (qspecl_then [`n - el_length h`,`a`,`ok`,`xs`] assume_tac) - \\ fs []);*) + \\ fs [] +QED*) val heap_expand_def = Define ` heap_expand n = if n = 0 then [] else [Unused (n-1)]`; @@ -297,22 +325,28 @@ val ADDR_MAP_def = Define ` (ADDR_MAP f (Data x::xs) = Data x :: ADDR_MAP f xs) /\ (ADDR_MAP f (Pointer a d::xs) = Pointer (f a) d :: ADDR_MAP f xs)`; -Theorem ADDR_MAP_EQ - `!xs. (!p d. MEM (Pointer p d) xs ==> (f p = g p)) ==> - (ADDR_MAP f xs = ADDR_MAP g xs)` - (Induct \\ TRY (Cases_on `h`) \\ full_simp_tac (srw_ss()) [ADDR_MAP_def] - \\ metis_tac []); - -Theorem ADDR_MAP_LENGTH - `!xs f. LENGTH xs = LENGTH (ADDR_MAP f xs)` - (Induct \\ fs [ADDR_MAP_def] - \\ Cases \\ fs [ADDR_MAP_def]); - -Theorem ADDR_MAP_APPEND - `!h1 h2 f. - ADDR_MAP f (h1 ++ h2) = ADDR_MAP f h1 ++ ADDR_MAP f h2` - (Induct >- fs [ADDR_MAP_def] - \\ Cases \\ fs [ADDR_MAP_def]); +Theorem ADDR_MAP_EQ: + !xs. (!p d. MEM (Pointer p d) xs ==> (f p = g p)) ==> + (ADDR_MAP f xs = ADDR_MAP g xs) +Proof + Induct \\ TRY (Cases_on `h`) \\ full_simp_tac (srw_ss()) [ADDR_MAP_def] + \\ metis_tac [] +QED + +Theorem ADDR_MAP_LENGTH: + !xs f. LENGTH xs = LENGTH (ADDR_MAP f xs) +Proof + Induct \\ fs [ADDR_MAP_def] + \\ Cases \\ fs [ADDR_MAP_def] +QED + +Theorem ADDR_MAP_APPEND: + !h1 h2 f. + ADDR_MAP f (h1 ++ h2) = ADDR_MAP f h1 ++ ADDR_MAP f h2 +Proof + Induct >- fs [ADDR_MAP_def] + \\ Cases \\ fs [ADDR_MAP_def] +QED val ADDR_APPLY_def = Define ` (ADDR_APPLY f (Pointer x d) = Pointer (f x) d) /\ @@ -339,11 +373,13 @@ val heaps_similar_def = Define ` (el_length h = el_length h0) /\ isDataElement h0 else (h = h0)) heap0 heap` -Theorem IN_heap_map_IMP - `!heap n k. n IN FDOM (heap_map k heap) ==> k <= n` - (Induct \\ TRY (Cases_on `h`) \\ full_simp_tac (srw_ss()) [heap_map_def] +Theorem IN_heap_map_IMP: + !heap n k. n IN FDOM (heap_map k heap) ==> k <= n +Proof + Induct \\ TRY (Cases_on `h`) \\ full_simp_tac (srw_ss()) [heap_map_def] \\ rpt strip_tac \\ res_tac - \\ full_simp_tac (srw_ss()) [heap_length_def,el_length_def] \\ decide_tac); + \\ full_simp_tac (srw_ss()) [heap_length_def,el_length_def] \\ decide_tac +QED val NOT_IN_heap_map = save_thm("NOT_IN_heap_map", Q.prove( `!ha n. ~(n + heap_length ha IN FDOM (heap_map n (ha ++ DataElement ys l d::hb)))`, @@ -355,59 +391,73 @@ val NOT_IN_heap_map = save_thm("NOT_IN_heap_map", Q.prove( \\ res_tac \\ full_simp_tac (srw_ss()) [el_length_def,ADD_ASSOC] \\ res_tac \\ decide_tac) |> Q.SPECL [`ha`,`0`] |> SIMP_RULE std_ss []) -Theorem isSomeDataOrForward_lemma - `!ha ptr. +Theorem isSomeDataOrForward_lemma: + !ha ptr. isSomeDataOrForward (heap_lookup ptr (ha ++ DataElement ys l d::hb)) <=> - isSomeDataOrForward (heap_lookup ptr (ha ++ [ForwardPointer a u l] ++ hb))` - (Induct \\ full_simp_tac std_ss [APPEND,heap_lookup_def] + isSomeDataOrForward (heap_lookup ptr (ha ++ [ForwardPointer a u l] ++ hb)) +Proof + Induct \\ full_simp_tac std_ss [APPEND,heap_lookup_def] \\ SRW_TAC [] [] \\ full_simp_tac std_ss [] - \\ EVAL_TAC \\ full_simp_tac std_ss [el_length_def]); + \\ EVAL_TAC \\ full_simp_tac std_ss [el_length_def] +QED -Theorem heaps_similar_IMP_heap_length - `!xs ys. heaps_similar xs ys ==> (heap_length xs = heap_length ys)` - (Induct \\ Cases_on `ys` +Theorem heaps_similar_IMP_heap_length: + !xs ys. heaps_similar xs ys ==> (heap_length xs = heap_length ys) +Proof + Induct \\ Cases_on `ys` \\ full_simp_tac (srw_ss()) [heaps_similar_def,heap_length_def] \\ rpt strip_tac \\ Cases_on `isForwardPointer h` - \\ full_simp_tac std_ss []); + \\ full_simp_tac std_ss [] +QED -Theorem heap_similar_Data_IMP - `heaps_similar heap0 (ha ++ DataElement ys l d::hb) ==> +Theorem heap_similar_Data_IMP: + heaps_similar heap0 (ha ++ DataElement ys l d::hb) ==> ?ha0 hb0. (heap0 = ha0 ++ DataElement ys l d::hb0) /\ - (heap_length ha = heap_length ha0)` - (rpt strip_tac \\ full_simp_tac std_ss [heaps_similar_def] + (heap_length ha = heap_length ha0) +Proof + rpt strip_tac \\ full_simp_tac std_ss [heaps_similar_def] \\ imp_res_tac LIST_REL_SPLIT2 \\ fs[isForwardPointer_def] \\ Q.LIST_EXISTS_TAC [`ys1`,`xs`] \\ full_simp_tac std_ss [] \\ `heaps_similar ys1 ha` by full_simp_tac std_ss [heaps_similar_def] - \\ full_simp_tac std_ss [heaps_similar_IMP_heap_length]); + \\ full_simp_tac std_ss [heaps_similar_IMP_heap_length] +QED -Theorem heaps_similar_lemma - `!ha heap0. +Theorem heaps_similar_lemma: + !ha heap0. heaps_similar heap0 (ha ++ DataElement ys l d::hb) ==> - heaps_similar heap0 (ha ++ [ForwardPointer (heap_length (h1 ++ h2)) u l] ++ hb)` - (full_simp_tac std_ss [heaps_similar_def] \\ rpt strip_tac + heaps_similar heap0 (ha ++ [ForwardPointer (heap_length (h1 ++ h2)) u l] ++ hb) +Proof + full_simp_tac std_ss [heaps_similar_def] \\ rpt strip_tac \\ imp_res_tac LIST_REL_SPLIT2 \\ fs[] \\ full_simp_tac std_ss [APPEND,GSYM APPEND_ASSOC] \\ match_mp_tac EVERY2_APPEND_suff \\ fs[isForwardPointer_def,el_length_def] - \\ rw[el_length_def,isDataElement_def]); + \\ rw[el_length_def,isDataElement_def] +QED -Theorem heap_lookup_PREFIX - `!xs. (heap_lookup (heap_length xs) (xs ++ x::ys) = SOME x)` - (Induct \\ full_simp_tac (srw_ss()) [heap_lookup_def,APPEND,heap_length_def] +Theorem heap_lookup_PREFIX: + !xs. (heap_lookup (heap_length xs) (xs ++ x::ys) = SOME x) +Proof + Induct \\ full_simp_tac (srw_ss()) [heap_lookup_def,APPEND,heap_length_def] \\ SRW_TAC [] [] \\ Cases_on `h` - \\ full_simp_tac std_ss [el_length_def] \\ decide_tac); - -Theorem heap_lookup_EXTEND - `!xs n ys x. (heap_lookup n xs = SOME x) ==> - (heap_lookup n (xs ++ ys) = SOME x)` - (Induct \\ full_simp_tac (srw_ss()) [heap_lookup_def] \\ SRW_TAC [] []); - -Theorem heap_map_APPEND - `!xs n ys. (heap_map n (xs ++ ys)) = - FUNION (heap_map n xs) (heap_map (n + heap_length xs) ys)` - (Induct \\ TRY (Cases_on `h`) \\ full_simp_tac (srw_ss()) + \\ full_simp_tac std_ss [el_length_def] \\ decide_tac +QED + +Theorem heap_lookup_EXTEND: + !xs n ys x. (heap_lookup n xs = SOME x) ==> + (heap_lookup n (xs ++ ys) = SOME x) +Proof + Induct \\ full_simp_tac (srw_ss()) [heap_lookup_def] \\ SRW_TAC [] [] +QED + +Theorem heap_map_APPEND: + !xs n ys. (heap_map n (xs ++ ys)) = + FUNION (heap_map n xs) (heap_map (n + heap_length xs) ys) +Proof + Induct \\ TRY (Cases_on `h`) \\ full_simp_tac (srw_ss()) [APPEND,heap_map_def,FUNION_DEF,FUNION_FEMPTY_1,heap_length_def,ADD_ASSOC] - \\ full_simp_tac std_ss [FUNION_FUPDATE_1,el_length_def,ADD_ASSOC]); + \\ full_simp_tac std_ss [FUNION_FUPDATE_1,el_length_def,ADD_ASSOC] +QED val FDOM_heap_map = save_thm("FDOM_heap_map", Q.prove( `!xs n. ~(n + heap_length xs IN FDOM (heap_map n xs))`, @@ -417,31 +467,38 @@ val FDOM_heap_map = save_thm("FDOM_heap_map", Q.prove( \\ TRY decide_tac \\ metis_tac []) |> Q.SPECL [`xs`,`0`] |> SIMP_RULE std_ss []); -Theorem heap_addresses_APPEND - `!xs ys n. heap_addresses n (xs ++ ys) = - heap_addresses n xs UNION heap_addresses (n + heap_length xs) ys` - (Induct \\ full_simp_tac (srw_ss()) [APPEND,heap_addresses_def,heap_length_def] - \\ full_simp_tac (srw_ss()) [EXTENSION,DISJ_ASSOC,ADD_ASSOC]); - -Theorem LESS_IMP_heap_lookup - `!xs j ys. j < heap_length xs ==> (heap_lookup j (xs ++ ys) = heap_lookup j xs)` - (Induct \\ full_simp_tac (srw_ss()) [heap_length_def,heap_lookup_def] +Theorem heap_addresses_APPEND: + !xs ys n. heap_addresses n (xs ++ ys) = + heap_addresses n xs UNION heap_addresses (n + heap_length xs) ys +Proof + Induct \\ full_simp_tac (srw_ss()) [APPEND,heap_addresses_def,heap_length_def] + \\ full_simp_tac (srw_ss()) [EXTENSION,DISJ_ASSOC,ADD_ASSOC] +QED + +Theorem LESS_IMP_heap_lookup: + !xs j ys. j < heap_length xs ==> (heap_lookup j (xs ++ ys) = heap_lookup j xs) +Proof + Induct \\ full_simp_tac (srw_ss()) [heap_length_def,heap_lookup_def] \\ SRW_TAC [] [] \\ `j - el_length h < SUM (MAP el_length xs)` by decide_tac - \\ full_simp_tac std_ss []); + \\ full_simp_tac std_ss [] +QED -Theorem NOT_LESS_IMP_heap_lookup - `!xs j ys. ~(j < heap_length xs) ==> - (heap_lookup j (xs ++ ys) = heap_lookup (j - heap_length xs) ys)` - (Induct \\ full_simp_tac (srw_ss()) [heap_length_def,heap_lookup_def] +Theorem NOT_LESS_IMP_heap_lookup: + !xs j ys. ~(j < heap_length xs) ==> + (heap_lookup j (xs ++ ys) = heap_lookup (j - heap_length xs) ys) +Proof + Induct \\ full_simp_tac (srw_ss()) [heap_length_def,heap_lookup_def] \\ SRW_TAC [] [SUB_PLUS] THEN1 (Cases_on `h` \\ full_simp_tac std_ss [el_length_def] \\ `F` by decide_tac) - THEN1 (Cases_on `h` \\ full_simp_tac std_ss [el_length_def] \\ `F` by decide_tac)); + THEN1 (Cases_on `h` \\ full_simp_tac std_ss [el_length_def] \\ `F` by decide_tac) +QED -Theorem heap_similar_Data_IMP_DataOrForward - `!heap0 heap1 ptr. +Theorem heap_similar_Data_IMP_DataOrForward: + !heap0 heap1 ptr. heaps_similar heap0 heap1 /\ isSomeDataElement (heap_lookup ptr heap0) ==> - isSomeDataOrForward (heap_lookup ptr heap1)` - (Induct \\ Cases_on `heap1` \\ full_simp_tac (srw_ss()) [heaps_similar_def] + isSomeDataOrForward (heap_lookup ptr heap1) +Proof + Induct \\ Cases_on `heap1` \\ full_simp_tac (srw_ss()) [heaps_similar_def] \\ full_simp_tac std_ss [heap_lookup_def] THEN1 (full_simp_tac (srw_ss()) [isSomeDataElement_def,isSomeDataOrForward_def]) \\ rpt GEN_TAC \\ Cases_on `ptr = 0` \\ full_simp_tac std_ss [] THEN1 @@ -452,46 +509,61 @@ Theorem heap_similar_Data_IMP_DataOrForward \\ strip_tac \\ `(el_length h = el_length h')` by metis_tac [] \\ full_simp_tac std_ss [] \\ SRW_TAC [] [] \\ full_simp_tac std_ss [] THEN1 full_simp_tac std_ss [isSomeDataElement_def] - \\ full_simp_tac std_ss [] \\ res_tac); - -Theorem FILTER_LEMMA - `!heap. (FILTER isForwardPointer heap = []) ==> - (FILTER (\h. ~isForwardPointer h) heap = heap)` - (Induct \\ full_simp_tac (srw_ss()) [] \\ SRW_TAC [] []); - -Theorem heaps_similar_REFL - `!xs. (FILTER isForwardPointer xs = []) ==> heaps_similar xs xs` - (Induct \\ full_simp_tac (srw_ss()) [heaps_similar_def] \\ SRW_TAC [] []); - -Theorem heap_map_EMPTY - `!xs n. (FILTER isForwardPointer xs = []) ==> (FDOM (heap_map n xs) = {})` - (Induct \\ TRY (Cases_on `h`) - \\ full_simp_tac (srw_ss()) [heap_map_def,isForwardPointer_def]); - -Theorem MEM_ADDR_MAP - `!xs f ptr u. MEM (Pointer ptr u) (ADDR_MAP f xs) ==> - ?y. MEM (Pointer y u) xs /\ (f y = ptr)` - (Induct \\ TRY (Cases_on `h`) \\ full_simp_tac (srw_ss()) [ADDR_MAP_def] - \\ rpt strip_tac \\ full_simp_tac std_ss [] \\ res_tac \\ metis_tac []); - -Theorem heap_length_heap_expand - `!n. heap_length (heap_expand n) = n` - (Cases \\ EVAL_TAC \\ full_simp_tac (srw_ss()) [el_length_def,ADD1,SUM_ACC_DEF]); - -Theorem EVERY_isDataElement_IMP_LEMMA - `!heap2. EVERY isDataElement heap2 ==> (FILTER isForwardPointer heap2 = [])` - (Induct \\ full_simp_tac (srw_ss()) [isDataElement_def] \\ rpt strip_tac - \\ full_simp_tac (srw_ss()) [isForwardPointer_def]); - -Theorem isSome_heap_looukp_IMP_APPEND - `!xs ptr. isSomeDataElement (heap_lookup ptr xs) ==> - isSomeDataElement (heap_lookup ptr (xs ++ ys))` - (full_simp_tac std_ss [isSomeDataElement_def] \\ rpt strip_tac + \\ full_simp_tac std_ss [] \\ res_tac +QED + +Theorem FILTER_LEMMA: + !heap. (FILTER isForwardPointer heap = []) ==> + (FILTER (\h. ~isForwardPointer h) heap = heap) +Proof + Induct \\ full_simp_tac (srw_ss()) [] \\ SRW_TAC [] [] +QED + +Theorem heaps_similar_REFL: + !xs. (FILTER isForwardPointer xs = []) ==> heaps_similar xs xs +Proof + Induct \\ full_simp_tac (srw_ss()) [heaps_similar_def] \\ SRW_TAC [] [] +QED + +Theorem heap_map_EMPTY: + !xs n. (FILTER isForwardPointer xs = []) ==> (FDOM (heap_map n xs) = {}) +Proof + Induct \\ TRY (Cases_on `h`) + \\ full_simp_tac (srw_ss()) [heap_map_def,isForwardPointer_def] +QED + +Theorem MEM_ADDR_MAP: + !xs f ptr u. MEM (Pointer ptr u) (ADDR_MAP f xs) ==> + ?y. MEM (Pointer y u) xs /\ (f y = ptr) +Proof + Induct \\ TRY (Cases_on `h`) \\ full_simp_tac (srw_ss()) [ADDR_MAP_def] + \\ rpt strip_tac \\ full_simp_tac std_ss [] \\ res_tac \\ metis_tac [] +QED + +Theorem heap_length_heap_expand: + !n. heap_length (heap_expand n) = n +Proof + Cases \\ EVAL_TAC \\ full_simp_tac (srw_ss()) [el_length_def,ADD1,SUM_ACC_DEF] +QED + +Theorem EVERY_isDataElement_IMP_LEMMA: + !heap2. EVERY isDataElement heap2 ==> (FILTER isForwardPointer heap2 = []) +Proof + Induct \\ full_simp_tac (srw_ss()) [isDataElement_def] \\ rpt strip_tac + \\ full_simp_tac (srw_ss()) [isForwardPointer_def] +QED + +Theorem isSome_heap_looukp_IMP_APPEND: + !xs ptr. isSomeDataElement (heap_lookup ptr xs) ==> + isSomeDataElement (heap_lookup ptr (xs ++ ys)) +Proof + full_simp_tac std_ss [isSomeDataElement_def] \\ rpt strip_tac \\ imp_res_tac heap_lookup_LESS \\ imp_res_tac LESS_IMP_heap_lookup - \\ full_simp_tac (srw_ss()) []); + \\ full_simp_tac (srw_ss()) [] +QED -Theorem heap_split_APPEND_if - `!h1 n h2. heap_split n (h1 ++ h2) = +Theorem heap_split_APPEND_if: + !h1 n h2. heap_split n (h1 ++ h2) = if n < heap_length h1 then case heap_split n h1 of NONE => NONE @@ -499,17 +571,21 @@ Theorem heap_split_APPEND_if else case heap_split (n - heap_length h1) h2 of NONE => NONE - | SOME(h1',h2') => SOME(h1++h1',h2')` - (Induct >> fs[heap_split_def] >> rpt strip_tac + | SOME(h1',h2') => SOME(h1++h1',h2') +Proof + Induct >> fs[heap_split_def] >> rpt strip_tac >- (Cases_on `heap_split n h2` >> fs[] >> Cases_on `x` >> fs[]) >> IF_CASES_TAC >- (fs[heap_length_def] >> Cases_on `h` >> fs[el_length_def]) >> IF_CASES_TAC >- fs[heap_length_def] >> IF_CASES_TAC >- (fs[heap_length_def] >> every_case_tac >> fs[]) - >> fs[heap_length_def] >> every_case_tac >> fs[]); + >> fs[heap_length_def] >> every_case_tac >> fs[] +QED -Theorem heap_split_0[simp] - `heap_split 0 h = SOME ([],h)` - (Cases_on `h` \\ fs [heap_split_def]); +Theorem heap_split_0[simp]: + heap_split 0 h = SOME ([],h) +Proof + Cases_on `h` \\ fs [heap_split_def] +QED (* --- *) @@ -533,27 +609,35 @@ val reachable_addresses_def = Define ` reachable_addresses roots heap y = ?t x. MEM (Pointer x t) roots /\ RTC (gc_edge heap) x y` -Theorem heap_addresses_LESS_heap_length - `∀heap n k. k ∈ heap_addresses n heap ⇒ k < n + heap_length heap` - (Induct \\ fs [heap_addresses_def,heap_length_def] +Theorem heap_addresses_LESS_heap_length: + ∀heap n k. k ∈ heap_addresses n heap ⇒ k < n + heap_length heap +Proof + Induct \\ fs [heap_addresses_def,heap_length_def] \\ rw [] THEN1 (Cases_on `h` \\ fs [el_length_def]) - \\ res_tac \\ fs []); - -Theorem heap_addresses_LESS - `∀heap n k. k ∈ heap_addresses n heap ==> n <= k` - (Induct \\ fs [heap_addresses_def,heap_length_def] - \\ rw [] \\ fs [] \\ res_tac \\ fs []); - -Theorem FINITE_heap_addresses - `!xs n. FINITE (heap_addresses n xs)` - (Induct \\ fs [heap_addresses_def]); - -Theorem CARD_heap_addresses - `!xs n. CARD (heap_addresses n xs) = LENGTH xs` - (Induct \\ fs [heap_addresses_def] + \\ res_tac \\ fs [] +QED + +Theorem heap_addresses_LESS: + ∀heap n k. k ∈ heap_addresses n heap ==> n <= k +Proof + Induct \\ fs [heap_addresses_def,heap_length_def] + \\ rw [] \\ fs [] \\ res_tac \\ fs [] +QED + +Theorem FINITE_heap_addresses: + !xs n. FINITE (heap_addresses n xs) +Proof + Induct \\ fs [heap_addresses_def] +QED + +Theorem CARD_heap_addresses: + !xs n. CARD (heap_addresses n xs) = LENGTH xs +Proof + Induct \\ fs [heap_addresses_def] \\ fs [CARD_INSERT,FINITE_heap_addresses] \\ rw [] \\ imp_res_tac heap_addresses_LESS \\ fs [] - \\ Cases_on `h` \\ fs [el_length_def]); + \\ Cases_on `h` \\ fs [el_length_def] +QED val heap_filter_aux_def = Define ` (heap_filter_aux n P [] = []) /\ @@ -563,10 +647,12 @@ val heap_filter_aux_def = Define ` val heap_filter_def = Define ` heap_filter = heap_filter_aux 0`; -Theorem heap_filter_EMPTY - `!heap. heap_filter ∅ heap = []` - (fs [heap_filter_def] \\ qspec_tac (`0n`,`n`) - \\ Induct_on `heap` \\ fs [heap_filter_aux_def]); +Theorem heap_filter_EMPTY: + !heap. heap_filter ∅ heap = [] +Proof + fs [heap_filter_def] \\ qspec_tac (`0n`,`n`) + \\ Induct_on `heap` \\ fs [heap_filter_aux_def] +QED val heap_length_heap_filter_INSERT = prove( ``!heap. @@ -601,15 +687,16 @@ val heap_lookup_IMP_heap_filter = prove( \\ fs [LESS_EQ_EXISTS] \\ rveq \\ fs [] \\ fs [heap_filter_aux_ADD_SING]); -Theorem heap_length_heap_filter_eq - `!s t f heap heap2. +Theorem heap_length_heap_filter_eq: + !s t f heap heap2. BIJ f s t /\ FINITE s /\ FINITE t /\ (!i. i IN s ==> ?xs xs2 l d d. (heap_lookup i heap = SOME (DataElement xs l d)) /\ (heap_lookup (f i) heap2 = SOME (DataElement xs2 l d))) ==> - (heap_length (heap_filter t heap2) = heap_length (heap_filter s heap))` - (strip_tac + (heap_length (heap_filter t heap2) = heap_length (heap_filter s heap)) +Proof + strip_tac \\ Cases_on `FINITE s` \\ fs [] \\ pop_assum mp_tac \\ qspec_tac (`s`,`s`) @@ -629,7 +716,8 @@ Theorem heap_length_heap_filter_eq \\ first_x_assum (qspec_then `e` mp_tac) \\ fs [] \\ strip_tac \\ fs [] \\ imp_res_tac heap_lookup_IMP_heap_filter - \\ fs [] \\ EVAL_TAC); + \\ fs [] \\ EVAL_TAC +QED val heap_length_heap_filter_aux = prove( ``!n heap x. @@ -643,24 +731,30 @@ val heap_length_heap_filter_aux = prove( \\ rpt (AP_TERM_TAC ORELSE AP_THM_TAC) \\ rw [EXTENSION] \\ eq_tac \\ rw [] \\ fs []); -Theorem heap_length_heap_filter - `!heap. +Theorem heap_length_heap_filter: + !heap. heap_length (heap_filter (heap_addresses 0 heap) heap) = - heap_length heap` - (fs [heap_filter_def] - \\ metis_tac [heap_length_heap_filter_aux,UNION_EMPTY]); + heap_length heap +Proof + fs [heap_filter_def] + \\ metis_tac [heap_length_heap_filter_aux,UNION_EMPTY] +QED -Theorem heap_filter_aux_APPEND - `!xs ys n s. +Theorem heap_filter_aux_APPEND: + !xs ys n s. heap_filter_aux n s (xs ++ ys) = - heap_filter_aux n s xs ++ heap_filter_aux (n + heap_length xs) s ys` - (Induct \\ fs [heap_filter_aux_def,heap_length_def]); - -Theorem heap_filter_aux_heap_addresses_UNION - `!xs n s. heap_filter_aux n (heap_addresses n xs UNION s) xs = xs` - (Induct \\ fs [heap_filter_aux_def,heap_addresses_def] \\ rw [] + heap_filter_aux n s xs ++ heap_filter_aux (n + heap_length xs) s ys +Proof + Induct \\ fs [heap_filter_aux_def,heap_length_def] +QED + +Theorem heap_filter_aux_heap_addresses_UNION: + !xs n s. heap_filter_aux n (heap_addresses n xs UNION s) xs = xs +Proof + Induct \\ fs [heap_filter_aux_def,heap_addresses_def] \\ rw [] \\ `(n INSERT heap_addresses (n + el_length h) xs) ∪ s = heap_addresses (n + el_length h) xs ∪ (n INSERT s)` by - (fs [EXTENSION] \\ metis_tac []) \\ fs []); + (fs [EXTENSION] \\ metis_tac []) \\ fs [] +QED val _ = export_theory(); diff --git a/compiler/backend/gc/gen_gcScript.sml b/compiler/backend/gc/gen_gcScript.sml index 08f2788237..7aa171b8e1 100644 --- a/compiler/backend/gc/gen_gcScript.sml +++ b/compiler/backend/gc/gen_gcScript.sml @@ -71,8 +71,8 @@ val gc_move_list_def = Define ` let (xs,state) = gc_move_list conf state xs in (x::xs,state))`; -Theorem gc_move_list_IMP - `!xs xs' state state'. +Theorem gc_move_list_IMP: + !xs xs' state state'. (gc_move_list conf state xs = (xs',state')) ==> (state.h1 = state'.h1) /\ (state.r3 = state'.r3) /\ @@ -80,8 +80,8 @@ Theorem gc_move_list_IMP (state.r1 = state'.r1) /\ (IS_PREFIX state'.h2 state.h2) /\ (IS_SUFFIX state'.r4 state.r4) - ` - (Induct +Proof + Induct \\ fs [gc_move_list_def,LET_THM] \\ ntac 5 strip_tac \\ pairarg_tac @@ -92,7 +92,8 @@ Theorem gc_move_list_IMP \\ drule gc_move_IMP \\ strip_tac \\ fs [IS_SUFFIX_compute] - \\ metis_tac [IS_PREFIX_TRANS]); + \\ metis_tac [IS_PREFIX_TRANS] +QED val gc_move_data_def = tDefine "gc_move_data" ` (gc_move_data conf state = @@ -271,26 +272,30 @@ val heap_length_CONS = prove( ``!x xs. heap_length (x::xs) = el_length x + heap_length xs``, fs [heap_length_def]); -Theorem heap_lookup_LENGTH - `!xs x ys l. (heap_length xs = l) ==> (heap_lookup l (xs ++ x::ys) = SOME x)` - (Induct +Theorem heap_lookup_LENGTH: + !xs x ys l. (heap_length xs = l) ==> (heap_lookup l (xs ++ x::ys) = SOME x) +Proof + Induct >- fs [heap_length_def,heap_lookup_def] \\ fs [heap_length_CONS] - \\ fs [heap_lookup_def,el_length_NOT_0]); + \\ fs [heap_lookup_def,el_length_NOT_0] +QED -Theorem heap_lookup_APPEND - `!j xs ys. +Theorem heap_lookup_APPEND: + !j xs ys. heap_lookup j (xs ++ ys) = if j < heap_length xs then heap_lookup j xs - else heap_lookup (j - heap_length xs) ys` - (Induct_on `xs` + else heap_lookup (j - heap_length xs) ys +Proof + Induct_on `xs` \\ fs [heap_length_def,heap_lookup_def] \\ rpt strip_tac \\ IF_CASES_TAC \\ fs [] >- (rw [] \\ fs [el_length_NOT_0]) \\ IF_CASES_TAC \\ fs [] - \\ IF_CASES_TAC \\ fs []); + \\ IF_CASES_TAC \\ fs [] +QED val IMP_if_equal = prove( ``!b1 b2 x1 x2 y1 y2. @@ -323,8 +328,8 @@ val heaps_similar_lemma = prove( \\ fs[isForwardPointer_def,el_length_def] \\ rw[el_length_def,isDataElement_def]); -Theorem gc_move_thm - `!x state. +Theorem gc_move_thm: + !x state. gc_inv conf state heap0 roots0 /\ (!ptr u. (x = Pointer ptr u) ==> isSomeDataOrForward (heap_lookup ptr state.heap) /\ @@ -336,8 +341,9 @@ Theorem gc_move_thm (!ptr. isSomeDataOrForward (heap_lookup ptr state.heap) = isSomeDataOrForward (heap_lookup ptr state'.heap)) /\ ((heap_map 0 state.heap) SUBMAP (heap_map 0 state'.heap)) /\ - gc_inv conf state' heap0 roots0` - (Cases_on `x` + gc_inv conf state' heap0 roots0 +Proof + Cases_on `x` \\ fs [gc_move_def,ADDR_APPLY_def] \\ rpt strip_tac \\ fs [isSomeDataOrForward_def,isSomeForwardPointer_def,isSomeDataElement_def] @@ -725,13 +731,15 @@ Theorem gc_move_thm \\ unabbrev_all_tac \\ fs [gc_state_component_equality] \\ rpt strip_tac \\ res_tac - \\ simp []); + \\ simp [] +QED -Theorem gc_move_ALT - `gc_move conf state y = +Theorem gc_move_ALT: + gc_move conf state y = let (y', state') = gc_move conf (state with <| h2 := []; r4 := [] |>) y in - (y', state' with <| h2 := state.h2 ++ state'.h2; r4 := state'.r4 ++ state.r4 |>)` - (reverse (Cases_on `y`) \\ fs [gc_move_def] + (y', state' with <| h2 := state.h2 ++ state'.h2; r4 := state'.r4 ++ state.r4 |>) +Proof + reverse (Cases_on `y`) \\ fs [gc_move_def] THEN1 fs [LET_THM,gc_state_component_equality] \\ fs [] \\ TRY (BasicProvers.TOP_CASE_TAC) @@ -742,7 +750,8 @@ Theorem gc_move_ALT \\ rw [] \\ unabbrev_all_tac \\ pairarg_tac \\ fs [] - \\ fs [gc_state_component_equality]); + \\ fs [gc_state_component_equality] +QED val gc_move_list_thm = prove( ``!xs state. @@ -783,12 +792,13 @@ val gc_move_list_thm = prove( \\ fs [SUBMAP_DEF,heap_map1_def] \\ metis_tac []); -Theorem gc_move_list_ALT - `!ys state. +Theorem gc_move_list_ALT: + !ys state. gc_move_list conf state ys = let (ys', state') = gc_move_list conf (state with <| h2 := []; r4 := [] |>) ys in - (ys',state' with <| h2 := state.h2 ++ state'.h2; r4 := state'.r4 ++ state.r4 |>)` - (once_rewrite_tac [EQ_SYM_EQ] + (ys',state' with <| h2 := state.h2 ++ state'.h2; r4 := state'.r4 ++ state.r4 |>) +Proof + once_rewrite_tac [EQ_SYM_EQ] \\ Induct THEN1 fs [gc_move_list_def,LET_DEF,gc_state_component_equality] \\ once_rewrite_tac [gc_move_list_def] @@ -800,7 +810,8 @@ Theorem gc_move_list_ALT \\ qpat_x_assum `!x._` (fn th => once_rewrite_tac [GSYM th]) \\ fs [] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] - \\ rw [] \\ fs []); + \\ rw [] \\ fs [] +QED val gc_move_list_APPEND_lemma = prove( ``!ys state. @@ -829,17 +840,20 @@ val GREATER_IMP_heap_lookup = prove( (heap_lookup j (xs ++ ys) = heap_lookup (j - heap_length xs) ys)``, fs [heap_length_APPEND,NOT_LESS_IMP_heap_lookup]); -Theorem heap_lookup_IMP_MEM - `!x n y. (heap_lookup n x = SOME y) ==> MEM y x` - (Induct +Theorem heap_lookup_IMP_MEM: + !x n y. (heap_lookup n x = SOME y) ==> MEM y x +Proof + Induct \\ once_rewrite_tac [heap_lookup_def] \\ fs [] - \\ rw [] \\ res_tac \\ fs []); + \\ rw [] \\ res_tac \\ fs [] +QED -Theorem heaps_similar_lemma - `!h1 h2 ptr. +Theorem heaps_similar_lemma: + !h1 h2 ptr. heaps_similar h1 h2 /\ isSomeDataElement (heap_lookup ptr h1) ==> - isSomeDataOrForward (heap_lookup ptr h2)` - (Induct + isSomeDataOrForward (heap_lookup ptr h2) +Proof + Induct \\ once_rewrite_tac [heap_lookup_def] \\ fs [isSomeDataElement_def,PULL_EXISTS] \\ rpt strip_tac @@ -851,13 +865,16 @@ Theorem heaps_similar_lemma \\ fs [isSomeForwardPointer_def] \\ Cases_on `isForwardPointer h` \\ fs [] \\ Cases_on `h` \\ fs [isForwardPointer_def]) - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem BIJ_IMP_FLOOKUP_SOME - `!s h j. +Theorem BIJ_IMP_FLOOKUP_SOME: + !s h j. BIJ (heap_map1 h) (FDOM (heap_map 0 h)) s /\ j IN s ==> - ?i. FLOOKUP (heap_map 0 h) i = SOME j` - (fs [heap_map1_def,BIJ_DEF,SURJ_DEF,FLOOKUP_DEF]); + ?i. FLOOKUP (heap_map 0 h) i = SOME j +Proof + fs [heap_map1_def,BIJ_DEF,SURJ_DEF,FLOOKUP_DEF] +QED val heap_lookup_IMP_heap_addresses_GEN = prove( ``!xs n x j. (heap_lookup j xs = SOME x) ==> n + j IN heap_addresses n xs``, @@ -916,28 +933,31 @@ val pointers_ok = prove( \\ `isSomeDataElement (heap_lookup ptr heap0)` by metis_tac [heap_lookup_IMP_MEM] \\ imp_res_tac heaps_similar_lemma \\ fs []); -Theorem IMP_reachable_addresses - `!i ptr u xs l d. +Theorem IMP_reachable_addresses: + !i ptr u xs l d. reachable_addresses roots0 heap0 i /\ MEM (Pointer ptr u) xs /\ (heap_lookup i heap0 = SOME (DataElement xs l d)) ==> - reachable_addresses roots0 heap0 ptr` - (fs [reachable_addresses_def] \\ rw [] \\ asm_exists_tac \\ fs [] + reachable_addresses roots0 heap0 ptr +Proof + fs [reachable_addresses_def] \\ rw [] \\ asm_exists_tac \\ fs [] \\ once_rewrite_tac [RTC_CASES_RTC_TWICE] \\ asm_exists_tac \\ fs [] \\ match_mp_tac RTC_SINGLE \\ fs [gc_edge_def] - \\ asm_exists_tac \\ fs []); + \\ asm_exists_tac \\ fs [] +QED -Theorem gc_move_data_thm - `!conf state. +Theorem gc_move_data_thm: + !conf state. gc_inv conf state heap0 roots0 /\ (state.r3 = []) /\ (state.r2 = []) ==> ?state'. (gc_move_data conf state = state') /\ ((heap_map 0 state.heap) SUBMAP (heap_map 0 state'.heap)) /\ gc_inv conf state' heap0 roots0 /\ - (state'.h2 = []) /\ (state'.r3 = []) /\ (state'.r2 = [])` - (recInduct (theorem "gc_move_data_ind") + (state'.h2 = []) /\ (state'.r3 = []) /\ (state'.r2 = []) +Proof + recInduct (theorem "gc_move_data_ind") \\ rpt strip_tac \\ once_rewrite_tac [gc_move_data_def] \\ Cases_on `state.h2` \\ fs [] @@ -1057,10 +1077,11 @@ Theorem gc_move_data_thm \\ simp [] \\ strip_tac \\ `is_final conf state'' j = is_final conf state' j` by (unabbrev_all_tac \\ fs [is_final_def,heap_length_def,el_length_def,SUM_APPEND]) - \\ simp [] \\ fs []); + \\ simp [] \\ fs [] +QED -Theorem gc_move_refs_lemma - `!state l n b xs' t state'. +Theorem gc_move_refs_lemma: + !state l n b xs' t state'. gc_inv conf state heap0 roots0 /\ (state.r2 = DataElement l n b::t) /\ (gc_move_list conf state l = (xs',state')) /\ @@ -1070,8 +1091,9 @@ Theorem gc_move_refs_lemma ==> gc_inv conf (state' with <|r3 := state'.r3 ++ [DataElement xs' n b]; r2 := t|>) - heap0 roots0` - (rpt strip_tac + heap0 roots0 +Proof + rpt strip_tac \\ drule gc_move_list_thm \\ disch_then (qspec_then `l` mp_tac) \\ fs [] @@ -1152,18 +1174,20 @@ Theorem gc_move_refs_lemma \\ once_rewrite_tac [CONS_APPEND] \\ fs [heap_length_heap_expand,heap_length_APPEND] \\ fs [heap_length_def]) - \\ simp [] \\ fs []); + \\ simp [] \\ fs [] +QED -Theorem gc_move_refs_thm - `!conf state. +Theorem gc_move_refs_thm: + !conf state. gc_inv conf state heap0 roots0 ==> ?state'. (gc_move_refs conf state = state') /\ ((heap_map 0 state.heap) SUBMAP (heap_map 0 state'.heap)) /\ gc_inv conf state' heap0 roots0 /\ (state'.r3 = []) /\ (state'.r2 = []) /\ - (0 < heap_length state.r3 ==> heap_length state.r1 < heap_length state'.r1)` - (recInduct (theorem "gc_move_refs_ind") + (0 < heap_length state.r3 ==> heap_length state.r1 < heap_length state'.r1) +Proof + recInduct (theorem "gc_move_refs_ind") \\ rpt strip_tac \\ once_rewrite_tac [gc_move_refs_def] \\ Cases_on `state.r2` \\ fs [] @@ -1228,7 +1252,8 @@ Theorem gc_move_refs_thm \\ fs []) \\ fs [] \\ drule gc_move_refs_lemma - \\ ntac 3 (disch_then drule) \\ fs []); + \\ ntac 3 (disch_then drule) \\ fs [] +QED val gc_move_list_heap_length = prove( ``!conf state state' xs ys. @@ -1319,8 +1344,8 @@ val reachable_addresses_gc_inv_r4 = prove( \\ rfs [heap_lookup_def] \\ rveq \\ fs [] \\ rw [] \\ asm_exists_tac \\ fs []); -Theorem gc_move_loop_thm - `!conf state clock. +Theorem gc_move_loop_thm: + !conf state clock. conf.limit <= clock + heap_length state.h1 + heap_length state.r1 /\ (state.r2 = []) /\ (state.r3 = []) /\ gc_inv conf state heap roots0 ==> @@ -1331,8 +1356,9 @@ Theorem gc_move_loop_thm (state'.h2 = []) /\ (state'.r4 = []) /\ (state'.r3 = []) /\ - (state'.r2 = [])` - (recInduct (theorem "gc_move_loop_ind") + (state'.r2 = []) +Proof + recInduct (theorem "gc_move_loop_ind") \\ rpt strip_tac \\ once_rewrite_tac [gc_move_loop_def] \\ Cases_on `state.r4` \\ fs [] @@ -1458,13 +1484,15 @@ Theorem gc_move_loop_thm \\ rw [] \\ drule pointers_ok \\ fs [] \\ rw [] THEN1 metis_tac [] - \\ imp_res_tac reachable_addresses_gc_inv_r4 \\ fs []); + \\ imp_res_tac reachable_addresses_gc_inv_r4 \\ fs [] +QED -Theorem gc_inv_init - `heap_ok heap conf.limit ==> +Theorem gc_inv_init: + heap_ok heap conf.limit ==> gc_inv conf (empty_state with <| heap := heap; n := conf.limit; - ok := (heap_length heap = conf.limit) |>) heap roots` - (fs [heap_ok_def,gc_inv_def,empty_state_def,LET_THM] + ok := (heap_length heap = conf.limit) |>) heap roots +Proof + fs [heap_ok_def,gc_inv_def,empty_state_def,LET_THM] \\ rw [] >- fs [FILTER_LEMMA] >- res_tac @@ -1473,10 +1501,11 @@ Theorem gc_inv_init \\ fs [heap_expand_def] \\ rw [heap_lookup_def] \\ imp_res_tac heap_map_EMPTY - \\ fs [FLOOKUP_DEF]); + \\ fs [FLOOKUP_DEF] +QED -Theorem gen_gc_thm - `!conf roots heap. +Theorem gen_gc_thm: + !conf roots heap. roots_ok roots heap /\ heap_ok heap conf.limit ==> ?state. (gen_gc conf (roots,heap) = @@ -1486,8 +1515,9 @@ Theorem gen_gc_thm (state.h2 = []) /\ (state.r4 = []) /\ (state.r3 = []) /\ - (state.r2 = [])` - (rpt strip_tac + (state.r2 = []) +Proof + rpt strip_tac \\ imp_res_tac gc_inv_init \\ first_x_assum (qspec_then `roots` assume_tac) \\ fs [gen_gc_def] @@ -1515,13 +1545,16 @@ Theorem gen_gc_thm \\ metis_tac []) \\ fs [heap_ok_def] \\ fs [heap_map1_def,SUBMAP_DEF] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem LESS_IMP_heap_lookup - `!xs j ys. j < heap_length xs ==> (heap_lookup j (xs ++ ys) = heap_lookup j xs)` - (Induct \\ full_simp_tac (srw_ss()) [heap_length_def,heap_lookup_def] +Theorem LESS_IMP_heap_lookup: + !xs j ys. j < heap_length xs ==> (heap_lookup j (xs ++ ys) = heap_lookup j xs) +Proof + Induct \\ full_simp_tac (srw_ss()) [heap_length_def,heap_lookup_def] \\ SRW_TAC [] [] \\ `j - el_length h < SUM (MAP el_length xs)` by decide_tac - \\ full_simp_tac std_ss []); + \\ full_simp_tac std_ss [] +QED val heap_lookup_IMP_heap_addresses = save_thm("heap_lookup_IMP_heap_addresses", heap_lookup_IMP_heap_addresses_GEN @@ -1529,17 +1562,19 @@ val heap_lookup_IMP_heap_addresses = save_thm("heap_lookup_IMP_heap_addresses", |> SIMP_RULE std_ss [] |> GEN_ALL); -Theorem gen_gc_LENGTH - `roots_ok roots heap /\ +Theorem gen_gc_LENGTH: + roots_ok roots heap /\ heap_ok (heap:('a,'b) heap_element list) conf.limit ==> ?roots' state. (gen_gc conf (roots:'a heap_address list,heap) = - (roots',state))` - (rw [] + (roots',state)) +Proof + rw [] \\ imp_res_tac gen_gc_thm \\ fs [] \\ rpt strip_tac - \\ fs [gen_gc_def,gc_inv_def,LET_THM]); + \\ fs [gen_gc_def,gc_inv_def,LET_THM] +QED val heap_lookup_AND_APPEND_IMP = prove( ``!xs n ys d d1. @@ -1610,8 +1645,8 @@ val heap_lookup_PREPEND_EXTEND = prove( \\ fs [APPEND] \\ fs [heap_lookup_CONS_IMP]); -Theorem gen_gc_ok - `!conf roots heap. +Theorem gen_gc_ok: + !conf roots heap. roots_ok roots heap /\ heap_ok (heap:('a,'b) heap_element list) conf.limit ==> ?state roots' heap'. (heap' = state.h1 ++ heap_expand state.n ++ state.r1) /\ @@ -1620,8 +1655,9 @@ Theorem gen_gc_ok state.ok /\ (state.a = heap_length state.h1) /\ roots_ok roots' heap' /\ - heap_ok heap' conf.limit` - (rpt strip_tac + heap_ok heap' conf.limit +Proof + rpt strip_tac \\ drule gen_gc_thm \\ disch_then drule \\ strip_tac @@ -1679,7 +1715,8 @@ Theorem gen_gc_ok \\ res_tac \\ rfs [] \\ rveq \\ res_tac - \\ fs [isSomeDataElement_def]); + \\ fs [isSomeDataElement_def] +QED val IN_heap_addresses_LESS = prove( ``!heap n k. n IN heap_addresses k heap ==> k <= n /\ n < k + heap_length heap``, @@ -1691,13 +1728,15 @@ val IN_heap_addresses_LESS = prove( \\ qspec_then `h` assume_tac el_length_NOT_0 \\ decide_tac); -Theorem heap_lookup_EXTEND - `!xs n ys x. (heap_lookup n xs = SOME x) ==> - (heap_lookup n (xs ++ ys) = SOME x)` - (Induct \\ full_simp_tac (srw_ss()) [heap_lookup_def] \\ SRW_TAC [] []); +Theorem heap_lookup_EXTEND: + !xs n ys x. (heap_lookup n xs = SOME x) ==> + (heap_lookup n (xs ++ ys) = SOME x) +Proof + Induct \\ full_simp_tac (srw_ss()) [heap_lookup_def] \\ SRW_TAC [] [] +QED -Theorem gen_gc_related - `!conf roots heap. +Theorem gen_gc_related: + !conf roots heap. roots_ok roots heap /\ heap_ok (heap:('a,'b) heap_element list) conf.limit ==> ?state f. (gen_gc conf (roots:'a heap_address list,heap) = @@ -1705,8 +1744,9 @@ Theorem gen_gc_related (FDOM f = reachable_addresses roots heap) /\ (heap_length (state.h1 ++ state.r1) = heap_length (heap_filter (FDOM f) heap)) /\ - gc_related f heap (state.h1 ++ heap_expand state.n ++ state.r1)` - (rpt strip_tac + gc_related f heap (state.h1 ++ heap_expand state.n ++ state.r1) +Proof + rpt strip_tac \\ drule gen_gc_thm \\ disch_then drule \\ strip_tac \\ fs [] @@ -1799,20 +1839,24 @@ Theorem gen_gc_related \\ fs [] \\ rpt var_eq_tac \\ fs [] \\ qpat_assum `!ptr d. _ ==> _ ` (qspecl_then [`ptr`, `u`] assume_tac) - \\ fs []); + \\ fs [] +QED -Theorem gc_forward_ptr_ok - `!heap n a d c x. (gc_forward_ptr n heap a d c = (x,T)) ==> c` - (Cases_on `c` \\ fs [] +Theorem gc_forward_ptr_ok: + !heap n a d c x. (gc_forward_ptr n heap a d c = (x,T)) ==> c +Proof + Cases_on `c` \\ fs [] \\ Induct \\ simp_tac std_ss [Once gc_forward_ptr_def] \\ rpt strip_tac \\ every_case_tac \\ fs [] \\ fs [] - \\ pairarg_tac \\ fs [] \\ rfs []); + \\ pairarg_tac \\ fs [] \\ rfs [] +QED -Theorem gc_move_ok - `(gc_move conf state x = (x',state')) /\ state'.ok ==> state.ok` - (Cases_on `x` +Theorem gc_move_ok: + (gc_move conf state x = (x',state')) /\ state'.ok ==> state.ok +Proof + Cases_on `x` \\ fs [gc_move_def] \\ Cases_on `heap_lookup n state.heap` \\ fs [] @@ -1825,76 +1869,93 @@ Theorem gc_move_ok \\ TRY pairarg_tac \\ fs [gc_state_component_equality] \\ rpt var_eq_tac - \\ imp_res_tac gc_forward_ptr_ok); + \\ imp_res_tac gc_forward_ptr_ok +QED -Theorem gc_move_list_ok - `!xs xs' state state'. +Theorem gc_move_list_ok: + !xs xs' state state'. (gc_move_list conf state xs = (xs',state')) /\ state'.ok ==> - state.ok` - (Induct \\ fs [gc_move_list_def] + state.ok +Proof + Induct \\ fs [gc_move_list_def] \\ rw [] \\ rpt (pairarg_tac \\ fs []) \\ rveq - \\ res_tac \\ fs [] \\ imp_res_tac gc_move_ok); + \\ res_tac \\ fs [] \\ imp_res_tac gc_move_ok +QED -Theorem gc_move_data_ok - `!conf s. (gc_move_data conf s).ok ==> s.ok` - (recInduct (fetch "-" "gc_move_data_ind") \\ rw [] +Theorem gc_move_data_ok: + !conf s. (gc_move_data conf s).ok ==> s.ok +Proof + recInduct (fetch "-" "gc_move_data_ind") \\ rw [] \\ pop_assum mp_tac \\ once_rewrite_tac [gc_move_data_def] \\ rpt (CASE_TAC \\ simp_tac (srw_ss()) [LET_THM]) \\ pairarg_tac \\ fs [] \\ strip_tac \\ res_tac - \\ imp_res_tac gc_move_list_ok); - -Theorem gc_move_data_h2 - `!conf s. (gc_move_data conf s).ok ==> - ((gc_move_data conf s).h2 = [])` - (recInduct (fetch "-" "gc_move_data_ind") \\ rw [] + \\ imp_res_tac gc_move_list_ok +QED + +Theorem gc_move_data_h2: + !conf s. (gc_move_data conf s).ok ==> + ((gc_move_data conf s).h2 = []) +Proof + recInduct (fetch "-" "gc_move_data_ind") \\ rw [] \\ pop_assum mp_tac \\ once_rewrite_tac [gc_move_data_def] \\ rpt (CASE_TAC \\ simp_tac (srw_ss()) [LET_THM]) \\ asm_rewrite_tac [] \\ ntac 2 (pop_assum mp_tac) \\ simp_tac bool_ss [APPEND,GSYM APPEND_ASSOC] - \\ pairarg_tac \\ fs [] \\ rpt strip_tac \\ res_tac); + \\ pairarg_tac \\ fs [] \\ rpt strip_tac \\ res_tac +QED -Theorem gc_move_refs_ok - `!conf s. (gc_move_refs conf s).ok ==> s.ok` - (recInduct (fetch "-" "gc_move_refs_ind") \\ rw [] +Theorem gc_move_refs_ok: + !conf s. (gc_move_refs conf s).ok ==> s.ok +Proof + recInduct (fetch "-" "gc_move_refs_ind") \\ rw [] \\ pop_assum mp_tac \\ once_rewrite_tac [gc_move_refs_def] \\ rpt (CASE_TAC \\ simp_tac (srw_ss()) [LET_THM]) \\ pairarg_tac \\ fs [] \\ strip_tac \\ res_tac - \\ imp_res_tac gc_move_list_ok); + \\ imp_res_tac gc_move_list_ok +QED -Theorem gc_move_loop_ok - `!conf s c. (gc_move_loop conf s c).ok ==> s.ok` - (recInduct (fetch "-" "gc_move_loop_ind") \\ rw [] +Theorem gc_move_loop_ok: + !conf s c. (gc_move_loop conf s c).ok ==> s.ok +Proof + recInduct (fetch "-" "gc_move_loop_ind") \\ rw [] \\ pop_assum mp_tac \\ once_rewrite_tac [gc_move_loop_def] \\ every_case_tac \\ fs [] \\ strip_tac \\ res_tac \\ imp_res_tac gc_move_refs_ok - \\ imp_res_tac gc_move_data_ok \\ fs []); + \\ imp_res_tac gc_move_data_ok \\ fs [] +QED -Theorem gc_move_list_length - `!xs xs' state state'. +Theorem gc_move_list_length: + !xs xs' state state'. (gc_move_list conf state xs = (xs',state')) ==> - (LENGTH xs' = LENGTH xs)` - (Induct \\ fs [gc_move_list_def] + (LENGTH xs' = LENGTH xs) +Proof + Induct \\ fs [gc_move_list_def] \\ rw [] \\ rpt (pairarg_tac \\ fs []) \\ rveq - \\ res_tac \\ fs []); + \\ res_tac \\ fs [] +QED -Theorem gen_gc_LENGTH - `(gen_gc c (xs,heap) = (ys,s)) ==> (LENGTH ys = LENGTH xs)` - (fs [gen_gc_def] +Theorem gen_gc_LENGTH: + (gen_gc c (xs,heap) = (ys,s)) ==> (LENGTH ys = LENGTH xs) +Proof + fs [gen_gc_def] \\ rpt (pairarg_tac \\ fs []) \\ imp_res_tac gc_move_list_length - \\ rw [] \\ fs []); + \\ rw [] \\ fs [] +QED -Theorem gen_gc_a - `(gen_gc c (xs,heap) = (ys,s1)) /\ s1.ok /\ +Theorem gen_gc_a: + (gen_gc c (xs,heap) = (ys,s1)) /\ s1.ok /\ roots_ok xs heap /\ heap_ok heap c.limit ==> - (s1.a = heap_length s1.h1)` - (strip_tac \\ imp_res_tac gen_gc_thm - \\ fs [] \\ rveq \\ fs [] \\ fs [gc_inv_def]); + (s1.a = heap_length s1.h1) +Proof + strip_tac \\ imp_res_tac gen_gc_thm + \\ fs [] \\ rveq \\ fs [] \\ fs [gc_inv_def] +QED val _ = export_theory(); diff --git a/compiler/backend/gc/gen_gc_partialScript.sml b/compiler/backend/gc/gen_gc_partialScript.sml index cbb29202f5..61a0145d1b 100644 --- a/compiler/backend/gc/gen_gc_partialScript.sml +++ b/compiler/backend/gc/gen_gc_partialScript.sml @@ -35,16 +35,17 @@ val gc_move_def = Define ` | SOME (ForwardPointer ptr _ l) => (Pointer ptr d,state) | _ => (Pointer ptr d, state with <| ok := F |>)))`; -Theorem gc_move_IMP - `!x x' state state1. +Theorem gc_move_IMP: + !x x' state state1. (gc_move conf state x = (x',state1)) ==> (state1.old = state.old) /\ (state1.h1 = state.h1) /\ (state1.r4 = state.r4) /\ (state1.r3 = state.r3) /\ (state1.r2 = state.r2) /\ - (state1.r1 = state.r1)` - (Cases + (state1.r1 = state.r1) +Proof + Cases \\ fs [gc_move_def] \\ ntac 3 strip_tac \\ IF_CASES_TAC >- fs [gc_state_component_equality] @@ -55,7 +56,8 @@ Theorem gc_move_IMP \\ Cases_on `x` \\ fs [LET_THM,gc_state_component_equality] \\ rpt (pairarg_tac \\ fs []) - \\ fs [gc_state_component_equality]); + \\ fs [gc_state_component_equality] +QED val gc_move_list_def = Define ` (gc_move_list conf state [] = ([], state)) /\ @@ -64,8 +66,8 @@ val gc_move_list_def = Define ` let (xs,state) = gc_move_list conf state xs in (x::xs,state))`; -Theorem gc_move_list_IMP - `!xs xs' state state1. +Theorem gc_move_list_IMP: + !xs xs' state state1. (gc_move_list conf state xs = (xs',state1)) ==> (LENGTH xs = LENGTH xs') /\ (state1.old = state.old) /\ @@ -73,8 +75,9 @@ Theorem gc_move_list_IMP (state1.r4 = state.r4) /\ (state1.r3 = state.r3) /\ (state1.r2 = state.r2) /\ - (state1.r1 = state.r1)` - (Induct + (state1.r1 = state.r1) +Proof + Induct \\ fs [gc_move_list_def,LET_THM] \\ ntac 5 strip_tac \\ pairarg_tac @@ -83,7 +86,8 @@ Theorem gc_move_list_IMP \\ pairarg_tac \\ fs [] \\ rpt var_eq_tac \\ drule gc_move_IMP - \\ metis_tac []); + \\ metis_tac [] +QED val gc_move_data_def = tDefine "gc_move_data" ` (gc_move_data conf state = @@ -105,16 +109,16 @@ val gc_move_data_def = tDefine "gc_move_data" ` \\ fs [] \\ decide_tac) -Theorem gc_move_data_IMP - `!conf state state1. +Theorem gc_move_data_IMP: + !conf state state1. (gc_move_data conf state = state1) ==> (state1.old = state.old) /\ (state1.r1 = state.r1) /\ (state1.r2 = state.r2) /\ (state1.r3 = state.r3) /\ (state1.r4 = state.r4) -` - (recInduct (fetch "-" "gc_move_data_ind") +Proof + recInduct (fetch "-" "gc_move_data_ind") \\ rpt gen_tac \\ strip_tac \\ once_rewrite_tac [gc_move_data_def] @@ -124,7 +128,8 @@ Theorem gc_move_data_IMP \\ pairarg_tac \\ fs [] \\ rfs [] \\ drule gc_move_list_IMP - \\ strip_tac \\ fs []); + \\ strip_tac \\ fs [] +QED val gc_move_ref_list_def = Define ` (gc_move_ref_list conf state [] = ([], state)) /\ @@ -365,9 +370,11 @@ val all_old_ptrs_def = Define ` ?u. MEM (Pointer ptr u) xs /\ (ptr < conf.gen_start ∨ conf.refs_start ≤ ptr)` -Theorem has_old_ptr_simp[simp] - `has_old_ptr conf [DataElement xs x1 x2] = all_old_ptrs conf xs` - (fs [has_old_ptr_def,FUN_EQ_THM,all_old_ptrs_def]); +Theorem has_old_ptr_simp[simp]: + has_old_ptr conf [DataElement xs x1 x2] = all_old_ptrs conf xs +Proof + fs [has_old_ptr_def,FUN_EQ_THM,all_old_ptrs_def] +QED val sim_inv_def = Define ` sim_inv conf (heap0:('a,'b) heap_element list) (state:('a,'b)gc_state) <=> @@ -379,26 +386,32 @@ val sim_inv_def = Define ` has_old_ptr conf (state.heap ++ state.h1 ++ state.h2 ++ state.r1) SUBSET has_old_ptr conf heap0`; -Theorem heap_length_to_gen_heap_list[simp] - `!h2. heap_length (to_gen_heap_list conf h2) = heap_length h2` - (rewrite_tac [to_gen_heap_list_def] +Theorem heap_length_to_gen_heap_list[simp]: + !h2. heap_length (to_gen_heap_list conf h2) = heap_length h2 +Proof + rewrite_tac [to_gen_heap_list_def] \\ Induct \\ fs [heap_length_def] \\ Cases \\ fs [to_gen_heap_element_def] - \\ fs [el_length_def]); + \\ fs [el_length_def] +QED -Theorem el_length_not_zero[simp] - `!x. el_length x <> 0` - (Cases \\ EVAL_TAC \\ fs []); +Theorem el_length_not_zero[simp]: + !x. el_length x <> 0 +Proof + Cases \\ EVAL_TAC \\ fs [] +QED -Theorem heap_split_length - `!h1 h2. heap_split (heap_length h1) (h1 ++ h2) = SOME (h1,h2)` - (Induct +Theorem heap_split_length: + !h1 h2. heap_split (heap_length h1) (h1 ++ h2) = SOME (h1,h2) +Proof + Induct THEN1 (fs [heap_length_def,heap_split_def] \\ Cases_on `h2` \\ fs [heap_split_def]) \\ fs [heap_length_def] \\ fs [GSYM heap_length_def] - \\ fs [heap_split_def]); + \\ fs [heap_split_def] +QED val heap_segment_length = prove( ``heap_segment (heap_length h1, heap_length h1 + heap_length h2) @@ -550,92 +563,111 @@ val gc_move_simulation = prove( \\ fs [GSYM heap_length_def] \\ rw [] \\ fs [] \\ metis_tac []); -Theorem gc_forward_ptr_heap_length ` - !n h m a ok h' ok'. (gc_forward_ptr n h m a ok = (h',ok')) ==> (heap_length h = heap_length h')` - (Induct_on `h` +Theorem gc_forward_ptr_heap_length: + !n h m a ok h' ok'. (gc_forward_ptr n h m a ok = (h',ok')) ==> (heap_length h = heap_length h') +Proof + Induct_on `h` >> rpt strip_tac >> qpat_x_assum `gc_forward_ptr _ _ _ _ _ = _` (assume_tac o GSYM) >> fs[gc_forward_ptr_def,heap_length_def] >> every_case_tac >> fs[el_length_def] >> Cases_on `gc_forward_ptr (n − el_length h') h m a ok` - >> fs[] >> metis_tac[]); + >> fs[] >> metis_tac[] +QED -Theorem gc_move_heap_length - `(gc_move conf state h = (x,state')) ==> (heap_length state.heap = heap_length state'.heap)` - (Cases_on `h` +Theorem gc_move_heap_length: + (gc_move conf state h = (x,state')) ==> (heap_length state.heap = heap_length state'.heap) +Proof + Cases_on `h` >> rpt strip_tac >> first_x_assum (assume_tac o GSYM) >> fs[gc_move_def] >> every_case_tac >> fs[pairTheory.ELIM_UNCURRY] >> rfs[] - >> metis_tac[pair_CASES,gc_forward_ptr_heap_length,FST]); + >> metis_tac[pair_CASES,gc_forward_ptr_heap_length,FST] +QED -Theorem gc_move_list_heap_length - `!h x state state'. (gc_move_list conf state h = (x,state')) ==> (heap_length state.heap = heap_length state'.heap)` - (Induct_on `h` +Theorem gc_move_list_heap_length: + !h x state state'. (gc_move_list conf state h = (x,state')) ==> (heap_length state.heap = heap_length state'.heap) +Proof + Induct_on `h` >> rpt strip_tac >> first_x_assum (assume_tac o GSYM) >> fs[gc_move_list_def] >> ntac 2 (pairarg_tac >> fs[]) - >> metis_tac[gc_move_heap_length]); + >> metis_tac[gc_move_heap_length] +QED -Theorem gc_move_ref_list_heap_length - `!h x state state'. +Theorem gc_move_ref_list_heap_length: + !h x state state'. (gc_move_ref_list conf state h = (x,state')) - ==> (heap_length state.heap = heap_length state'.heap)` - (Induct >- fs[gc_move_ref_list_def] >> Cases + ==> (heap_length state.heap = heap_length state'.heap) +Proof + Induct >- fs[gc_move_ref_list_def] >> Cases >> rpt strip_tac >> first_x_assum (assume_tac o GSYM) >> fs[gc_move_ref_list_def] >> ntac 2 (pairarg_tac >> fs[]) - >> metis_tac[gc_move_list_heap_length]); + >> metis_tac[gc_move_list_heap_length] +QED -Theorem gc_move_ok' - `(gc_move conf state x = (x',state')) /\ state'.ok ==> state.ok` - (Cases_on `x` +Theorem gc_move_ok': + (gc_move conf state x = (x',state')) /\ state'.ok ==> state.ok +Proof + Cases_on `x` \\ fs [gc_move_def] \\ every_case_tac \\ fs [] \\ strip_tac \\ fs [] \\ rveq \\ fs [] \\ pairarg_tac \\ fs [] \\ rveq \\ fs [] \\ rveq \\ fs [] - \\ imp_res_tac gc_forward_ptr_ok); + \\ imp_res_tac gc_forward_ptr_ok +QED -Theorem gc_move_ok - `(gc_move conf state x = (x',state')) /\ state'.ok /\ (!ptr' u. (x = Pointer ptr' u) ==> ptr' < heap_length state.heap) ==> state.ok` - (rw [] \\ imp_res_tac gc_move_ok'); +Theorem gc_move_ok: + (gc_move conf state x = (x',state')) /\ state'.ok /\ (!ptr' u. (x = Pointer ptr' u) ==> ptr' < heap_length state.heap) ==> state.ok +Proof + rw [] \\ imp_res_tac gc_move_ok' +QED -Theorem gc_move_list_ok' - `!xs xs' state state'. +Theorem gc_move_list_ok': + !xs xs' state state'. (gc_move_list conf state xs = (xs',state')) /\ state'.ok ==> - state.ok` - (Induct \\ fs [gc_move_list_def] + state.ok +Proof + Induct \\ fs [gc_move_list_def] \\ rw [] \\ rpt (pairarg_tac \\ fs []) \\ rveq - \\ res_tac \\ imp_res_tac gc_move_ok'); + \\ res_tac \\ imp_res_tac gc_move_ok' +QED -Theorem gc_move_list_ok - `!xs xs' state state'. +Theorem gc_move_list_ok: + !xs xs' state state'. (gc_move_list conf state xs = (xs',state')) /\ state'.ok /\ (∀ptr' u. MEM (Pointer ptr' u) xs ⇒ ptr' < heap_length state.heap) ==> - state.ok` - (rw [] \\ imp_res_tac gc_move_list_ok'); + state.ok +Proof + rw [] \\ imp_res_tac gc_move_list_ok' +QED -Theorem gc_move_ref_list_ok' - `!xs xs' state state'. +Theorem gc_move_ref_list_ok': + !xs xs' state state'. (gc_move_ref_list conf state xs = (xs',state')) /\ state'.ok ==> - state.ok` - (Induct \\ fs [gc_move_ref_list_def] + state.ok +Proof + Induct \\ fs [gc_move_ref_list_def] \\ Cases \\ fs [gc_move_ref_list_def] \\ rw [] \\ rpt (pairarg_tac \\ fs []) \\ rveq - \\ res_tac \\ imp_res_tac gc_move_list_ok'); + \\ res_tac \\ imp_res_tac gc_move_list_ok' +QED -Theorem gc_move_data_ok' - `!conf state state'. +Theorem gc_move_data_ok': + !conf state state'. (gc_move_data conf state = state') /\ state'.ok ==> - state.ok` - (recInduct (fetch "-" "gc_move_data_ind") + state.ok +Proof + recInduct (fetch "-" "gc_move_data_ind") \\ rpt gen_tac \\ strip_tac \\ once_rewrite_tac [gc_move_data_def] \\ gen_tac \\ TOP_CASE_TAC \\ IF_CASES_TAC @@ -647,7 +679,8 @@ Theorem gc_move_data_ok' \\ simp_tac (srw_ss()) [] \\ CCONTR_TAC \\ qpat_x_assum `!x._` mp_tac \\ fs [] \\ CCONTR_TAC \\ fs [] - \\ imp_res_tac gc_move_list_ok' \\ fs []); + \\ imp_res_tac gc_move_list_ok' \\ fs [] +QED val gc_move_list_simulation = prove( ``!ptr ptr' state state' ptr1' state1'. @@ -692,23 +725,29 @@ val gc_move_list_APPEND = prove( \\ rw [] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ res_tac \\ fs [] \\ rveq \\ fs []); -Theorem heap_restrict_NIL[simp] - `heap_restrict gen_start refs_start [] = []` - (rewrite_tac [heap_restrict_def] +Theorem heap_restrict_NIL[simp]: + heap_restrict gen_start refs_start [] = [] +Proof + rewrite_tac [heap_restrict_def] \\ fs [heap_segment_def] \\ fs [heap_split_def] \\ every_case_tac \\ fs [] - \\ fs [heap_split_def] \\ rveq \\ fs []); - -Theorem to_gen_heap_NIL[simp] - `to_gen_heap conf [] = []` - (rewrite_tac [to_gen_heap_def] - \\ fs [heap_restrict_def,to_gen_heap_list_def]); - -Theorem to_gen_heap_list_NIL[simp] - `to_gen_heap_list conf [] = []` - (rewrite_tac [to_gen_heap_list_def] - \\ fs []); + \\ fs [heap_split_def] \\ rveq \\ fs [] +QED + +Theorem to_gen_heap_NIL[simp]: + to_gen_heap conf [] = [] +Proof + rewrite_tac [to_gen_heap_def] + \\ fs [heap_restrict_def,to_gen_heap_list_def] +QED + +Theorem to_gen_heap_list_NIL[simp]: + to_gen_heap_list conf [] = [] +Proof + rewrite_tac [to_gen_heap_list_def] + \\ fs [] +QED val gc_move_data_r1 = prove( ``!refs state conf. @@ -1146,10 +1185,11 @@ val f_old_ptrs_def = Define ` {a | isSomeDataElement (heap_lookup a heap) /\ (a < conf.gen_start \/ conf.refs_start <= a)}`; -Theorem f_old_ptrs_finite[simp] - `!heap conf. - FINITE (f_old_ptrs conf heap)` - (rpt strip_tac +Theorem f_old_ptrs_finite[simp]: + !heap conf. + FINITE (f_old_ptrs conf heap) +Proof + rpt strip_tac \\ match_mp_tac (MP_CANON SUBSET_FINITE) \\ qexists_tac `{a | isSomeDataElement (heap_lookup a heap)}` \\ reverse CONJ_TAC @@ -1183,7 +1223,8 @@ Theorem f_old_ptrs_finite[simp] \\ fs [heap_lookup_def,isSomeDataElement_def] \\ CCONTR_TAC \\ fs [] - \\ imp_res_tac heap_lookup_LESS); + \\ imp_res_tac heap_lookup_LESS +QED val f_old_ptrs_finite_open = save_thm("f_old_ptrs_finite_open[simp]", f_old_ptrs_finite |> SIMP_RULE std_ss [f_old_ptrs_def]); @@ -1217,11 +1258,12 @@ val roots_ok_CONS = prove( roots_ok t heap``, metis_tac [CONS_APPEND,roots_ok_APPEND]); -Theorem isSomeDataElement_to_gen_heap_list[simp] - `!n heap. +Theorem isSomeDataElement_to_gen_heap_list[simp]: + !n heap. isSomeDataElement (heap_lookup n (to_gen_heap_list conf heap)) - = isSomeDataElement (heap_lookup n heap)` - (rewrite_tac [to_gen_heap_list_def] + = isSomeDataElement (heap_lookup n heap) +Proof + rewrite_tac [to_gen_heap_list_def] \\ Induct_on `heap` >- fs [heap_lookup_def,isSomeDataElement_def] \\ Cases \\ strip_tac @@ -1231,7 +1273,8 @@ Theorem isSomeDataElement_to_gen_heap_list[simp] \\ simp [] \\ IF_CASES_TAC \\ fs [el_length_def] - \\ fs [isSomeDataElement_def])); + \\ fs [isSomeDataElement_def]) +QED val isSomeDataElement_to_gen_heap_element = save_thm("isSomeDataElement_to_gen_heap_element", isSomeDataElement_to_gen_heap_list |> SIMP_RULE std_ss [to_gen_heap_list_def]); @@ -1424,11 +1467,13 @@ val new_f_FAPPLY = prove( \\ fs [FUNION_DEF,f_old_ptrs_def] \\ fs [FUN_FMAP_DEF]); -Theorem isSomeDataElement_heap_lookup_heap_expand[simp] - `~isSomeDataElement (heap_lookup x (heap_expand n))` - (rewrite_tac [heap_expand_def] +Theorem isSomeDataElement_heap_lookup_heap_expand[simp]: + ~isSomeDataElement (heap_lookup x (heap_expand n)) +Proof + rewrite_tac [heap_expand_def] \\ Cases_on `n` \\ fs [] - \\ fs [heap_lookup_def,isSomeDataElement_def]); + \\ fs [heap_lookup_def,isSomeDataElement_def] +QED val heap_lookup_heap_expand = isSomeDataElement_heap_lookup_heap_expand |> SIMP_RULE std_ss [isSomeDataElement_def]; @@ -1607,9 +1652,11 @@ val gc_move_refs_isForwardPointer = prove( \\ simp [FILTER] \\ fs [isForwardPointer_def] \\ res_tac); -Theorem el_length_to_gen_heap_element[simp] - `el_length (to_gen_heap_element conf h) = el_length h` - (Cases_on `h` \\ fs [to_gen_heap_element_def,el_length_def]); +Theorem el_length_to_gen_heap_element[simp]: + el_length (to_gen_heap_element conf h) = el_length h +Proof + Cases_on `h` \\ fs [to_gen_heap_element_def,el_length_def] +QED val to_gen_heap_element_isSomeData = prove( ``!xs n. @@ -2026,8 +2073,8 @@ val IMP_gen_inv = prove( \\ asm_exists_tac \\ fs [] \\ asm_exists_tac \\ fs []); -Theorem partial_gc_related - `roots_ok roots heap /\ +Theorem partial_gc_related: + roots_ok roots heap /\ heap_ok (heap:('a,'b) heap_element list) conf.limit /\ heap_gen_ok heap conf ==> @@ -2039,8 +2086,8 @@ Theorem partial_gc_related (state.old ++ state.h1 ++ heap_expand state.n ++ state.r1) conf.limit) /\ gc_related f heap (state.old ++ state.h1 ++ heap_expand state.n ++ state.r1) /\ state.ok - ` - (rpt strip_tac +Proof + rpt strip_tac \\ `gen_inv conf heap` by (match_mp_tac IMP_gen_inv \\ fs []) \\ fs [gen_inv_def] \\ Cases_on `partial_gc conf (roots,heap)` \\ fs [] @@ -2717,33 +2764,40 @@ Theorem partial_gc_related \\ simp [Once MEM_SPLIT] \\ strip_tac \\ fs [] - \\ simp [to_gen_heap_address_def]); + \\ simp [to_gen_heap_address_def] +QED -Theorem gc_move_list_length - `!xs xs' state state'. +Theorem gc_move_list_length: + !xs xs' state state'. (gc_move_list conf state xs = (xs',state')) ==> - (LENGTH xs' = LENGTH xs)` - (Induct \\ fs [gc_move_list_def] + (LENGTH xs' = LENGTH xs) +Proof + Induct \\ fs [gc_move_list_def] \\ rw [] \\ rpt (pairarg_tac \\ fs []) \\ rveq - \\ res_tac \\ fs []); + \\ res_tac \\ fs [] +QED -Theorem gc_move_ref_list_length - `!xs xs' state state'. +Theorem gc_move_ref_list_length: + !xs xs' state state'. (gc_move_ref_list conf state xs = (xs',state')) ==> - (LENGTH xs' = LENGTH xs)` - (Induct THEN1 fs [gc_move_ref_list_def] + (LENGTH xs' = LENGTH xs) +Proof + Induct THEN1 fs [gc_move_ref_list_def] \\ Cases \\ fs [gc_move_ref_list_def] \\ rw [] \\ rpt (pairarg_tac \\ fs []) \\ rveq - \\ res_tac \\ fs []); + \\ res_tac \\ fs [] +QED -Theorem gc_move_ref_list_heap_length' - `!xs xs' state state'. +Theorem gc_move_ref_list_heap_length': + !xs xs' state state'. (gc_move_ref_list conf state xs = (xs',state')) ==> - (heap_length xs' = heap_length xs)` - (Induct THEN1 fs [gc_move_ref_list_def] + (heap_length xs' = heap_length xs) +Proof + Induct THEN1 fs [gc_move_ref_list_def] \\ Cases \\ fs [gc_move_ref_list_def] \\ rw [] \\ rpt (pairarg_tac \\ fs []) \\ rveq - \\ res_tac \\ fs [heap_length_def,el_length_def]); + \\ res_tac \\ fs [heap_length_def,el_length_def] +QED val has_bad_ref_def = Define ` has_bad_ref c s <=> @@ -2858,11 +2912,12 @@ val heap_segment_gc_forward_ptr = prove( \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,heap_split_APPEND_if] \\ fs []); -Theorem gc_move_inv - `!xs xs' s1 s2. +Theorem gc_move_inv: + !xs xs' s1 s2. (gc_move c s1 xs = (xs',s2)) /\ s2.ok ==> - simple_rel c s1 s2` - (Cases \\ fs [gc_move_def,simple_rel_def] + simple_rel c s1 s2 +Proof + Cases \\ fs [gc_move_def,simple_rel_def] \\ rpt gen_tac \\ every_case_tac \\ fs [] \\ strip_tac \\ rveq \\ fs [] \\ TRY (fs [has_bad_ref_def,balanced_state_def] \\ NO_TAC) @@ -2900,13 +2955,15 @@ Theorem gc_move_inv \\ CCONTR_TAC \\ fs [GSYM IMP_DISJ_THM] \\ pop_assum drule \\ fs [] \\ drule (GEN_ALL gc_forward_ptr_lookup_DataElement) - \\ disch_then drule \\ fs []); + \\ disch_then drule \\ fs [] +QED -Theorem gc_move_list_inv - `!xs xs' s1 s2. +Theorem gc_move_list_inv: + !xs xs' s1 s2. (gc_move_list c s1 xs = (xs',s2)) /\ s2.ok ==> - simple_rel c s1 s2` - (Induct THEN1 (fs [gc_move_list_def,simple_rel_def]) + simple_rel c s1 s2 +Proof + Induct THEN1 (fs [gc_move_list_def,simple_rel_def]) \\ fs [gc_move_list_def] \\ rpt gen_tac \\ every_case_tac \\ fs [] \\ rpt (pairarg_tac \\ fs []) \\ strip_tac \\ rveq @@ -2914,13 +2971,15 @@ Theorem gc_move_list_inv \\ drule gc_move_inv \\ fs [] \\ strip_tac \\ res_tac \\ fs [] - \\ imp_res_tac simple_rel_trans); + \\ imp_res_tac simple_rel_trans +QED -Theorem gc_move_ref_list_inv - `!xs xs' s1 s2. +Theorem gc_move_ref_list_inv: + !xs xs' s1 s2. (gc_move_ref_list c s1 xs = (xs',s2)) /\ s2.ok ==> - simple_rel c s1 s2` - (Induct THEN1 (fs [gc_move_ref_list_def,simple_rel_def]) + simple_rel c s1 s2 +Proof + Induct THEN1 (fs [gc_move_ref_list_def,simple_rel_def]) \\ fs [gc_move_ref_list_def] \\ rpt gen_tac \\ every_case_tac \\ fs [] \\ Cases_on `h` \\ fs [gc_move_ref_list_def] @@ -2929,13 +2988,15 @@ Theorem gc_move_ref_list_inv \\ imp_res_tac gc_move_ref_list_ok' \\ drule gc_move_list_inv \\ fs [] \\ strip_tac \\ res_tac \\ fs [] - \\ imp_res_tac simple_rel_trans); + \\ imp_res_tac simple_rel_trans +QED -Theorem gc_move_data_inv - `!c s1 s2. +Theorem gc_move_data_inv: + !c s1 s2. (gen_gc_partial$gc_move_data c s1 = s2) /\ s2.ok ==> - simple_rel c s1 s2` - (recInduct (fetch "-" "gc_move_data_ind") + simple_rel c s1 s2 +Proof + recInduct (fetch "-" "gc_move_data_ind") \\ rpt gen_tac \\ strip_tac \\ once_rewrite_tac [gc_move_data_def] \\ rpt (TOP_CASE_TAC \\ fs [simple_rel_refl]) @@ -2957,20 +3018,23 @@ Theorem gc_move_data_inv \\ fs [GSYM heap_length_def,heap_length_heap_expand] \\ conj_tac THEN1 (fs [balanced_state_def,heap_length_def,el_length_def,SUM_APPEND]) - \\ simp [has_bad_ref_def] \\ metis_tac []); + \\ simp [has_bad_ref_def] \\ metis_tac [] +QED -Theorem LIST_REL_similar_data_IMP - `!xs ys. LIST_REL (similar_data cc) xs ys ==> +Theorem LIST_REL_similar_data_IMP: + !xs ys. LIST_REL (similar_data cc) xs ys ==> (heap_length xs = heap_length ys) /\ (heap_length (FILTER isDataElement xs) = - heap_length (FILTER isDataElement ys))` - (Induct \\ Cases_on `ys` \\ fs [heap_length_def] + heap_length (FILTER isDataElement ys)) +Proof + Induct \\ Cases_on `ys` \\ fs [heap_length_def] \\ rw[] \\ res_tac \\ fs [] \\ Cases_on `h` \\ Cases_on `h'` \\ fs [similar_data_def,isDataElement_def] - \\ rveq \\ fs [] \\ fs [el_length_def]); + \\ rveq \\ fs [] \\ fs [el_length_def] +QED -Theorem partial_gc_IMP - `(partial_gc c (roots,heap) = (roots1,state1)) /\ state1.ok ==> +Theorem partial_gc_IMP: + (partial_gc c (roots,heap) = (roots1,state1)) /\ state1.ok ==> (state1.a = c.gen_start + heap_length state1.h1) /\ (LENGTH roots1 = LENGTH roots) /\ (heap_length state1.old = c.gen_start) /\ @@ -2985,8 +3049,9 @@ Theorem partial_gc_IMP EVERY2 (similar_data c) refs state1.r1 /\ (!xs l d. MEM (DataElement xs l d) state1.h1 /\ c.isRef d ==> - ?xs l d. MEM (DataElement xs l d) curr /\ c.isRef d)` - (fs [partial_gc_def] \\ CASE_TAC \\ fs [] + ?xs l d. MEM (DataElement xs l d) curr /\ c.isRef d) +Proof + fs [partial_gc_def] \\ CASE_TAC \\ fs [] THEN1 (CCONTR_TAC \\ rw [] \\ fs [] \\ rveq \\ fs []) \\ CASE_TAC \\ CASE_TAC \\ rpt (pairarg_tac \\ fs []) \\ strip_tac \\ rveq \\ fs [] @@ -3066,6 +3131,7 @@ Theorem partial_gc_IMP \\ every_case_tac \\ fs [] \\ drule heap_segment_IMP \\ once_rewrite_tac [EQ_SYM_EQ] - \\ strip_tac \\ fs [FILTER_APPEND,heap_length_APPEND]); + \\ strip_tac \\ fs [FILTER_APPEND,heap_length_APPEND] +QED val _ = export_theory(); diff --git a/compiler/backend/lab_filterScript.sml b/compiler/backend/lab_filterScript.sml index 7af44142bc..f89c33044e 100644 --- a/compiler/backend/lab_filterScript.sml +++ b/compiler/backend/lab_filterScript.sml @@ -14,8 +14,10 @@ val filter_skip_def = Define ` (filter_skip (Section n xs :: rest) = Section n (FILTER not_skip xs) :: filter_skip rest)`; -Theorem filter_skip_MAP - `∀ls. filter_skip ls = MAP (λx. case x of Section n xs => Section n (FILTER not_skip xs)) ls` - (Induct \\ simp[filter_skip_def] \\ Cases \\ simp[filter_skip_def]); +Theorem filter_skip_MAP: + ∀ls. filter_skip ls = MAP (λx. case x of Section n xs => Section n (FILTER not_skip xs)) ls +Proof + Induct \\ simp[filter_skip_def] \\ Cases \\ simp[filter_skip_def] +QED val _ = export_theory(); diff --git a/compiler/backend/lab_to_targetScript.sml b/compiler/backend/lab_to_targetScript.sml index 7cd88eee78..3847f7853e 100644 --- a/compiler/backend/lab_to_targetScript.sml +++ b/compiler/backend/lab_to_targetScript.sml @@ -201,11 +201,13 @@ val pad_code_def = Define ` (pad_code nop ((Section n xs)::ys) = Section n (pad_section nop xs []) :: pad_code nop ys)` -Theorem pad_code_MAP - `pad_code nop = - MAP (λx. Section (Section_num x) (pad_section nop (Section_lines x) []))` - (simp[FUN_EQ_THM] \\ Induct \\ simp[pad_code_def] - \\ Cases \\ simp[pad_code_def]); +Theorem pad_code_MAP: + pad_code nop = + MAP (λx. Section (Section_num x) (pad_section nop (Section_lines x) [])) +Proof + simp[FUN_EQ_THM] \\ Induct \\ simp[pad_code_def] + \\ Cases \\ simp[pad_code_def] +QED val sec_length_def = Define ` (sec_length [] k = k) /\ @@ -265,10 +267,12 @@ val prog_to_bytes_def = Define ` val prog_to_bytes_ind = theorem"prog_to_bytes_ind"; -Theorem prog_to_bytes_MAP - `∀ls. prog_to_bytes ls = FLAT - (MAP (FLAT o MAP line_bytes o Section_lines) ls)` - (ho_match_mp_tac prog_to_bytes_ind \\ rw[prog_to_bytes_def]); +Theorem prog_to_bytes_MAP: + ∀ls. prog_to_bytes ls = FLAT + (MAP (FLAT o MAP line_bytes o Section_lines) ls) +Proof + ho_match_mp_tac prog_to_bytes_ind \\ rw[prog_to_bytes_def] +QED (* compile labels *) diff --git a/compiler/backend/mips/proofs/mips_configProofScript.sml b/compiler/backend/mips/proofs/mips_configProofScript.sml index b46ac24cfb..03befa0080 100644 --- a/compiler/backend/mips/proofs/mips_configProofScript.sml +++ b/compiler/backend/mips/proofs/mips_configProofScript.sml @@ -22,9 +22,10 @@ val names_tac = \\ REWRITE_TAC[SUBSET_DEF] \\ EVAL_TAC \\ rpt strip_tac \\ rveq \\ EVAL_TAC -Theorem mips_backend_config_ok ` - backend_config_ok mips_backend_config` - (simp[backend_config_ok_def]>>rw[]>>TRY(EVAL_TAC>>NO_TAC) +Theorem mips_backend_config_ok: + backend_config_ok mips_backend_config +Proof + simp[backend_config_ok_def]>>rw[]>>TRY(EVAL_TAC>>NO_TAC) >- fs[mips_backend_config_def] >- (EVAL_TAC>> blastLib.FULL_BBLAST_TAC) >- names_tac @@ -38,11 +39,13 @@ Theorem mips_backend_config_ok ` \\ fs[stack_removeTheory.max_stack_alloc_def] \\ EVAL_TAC>>fs[] \\ match_mp_tac bitTheory.NOT_BIT_GT_TWOEXP - \\ fs[]) + \\ fs[] +QED -Theorem mips_machine_config_ok - `is_mips_machine_config mc ⇒ mc_conf_ok mc` - (rw[lab_to_targetProofTheory.mc_conf_ok_def,is_mips_machine_config_def] +Theorem mips_machine_config_ok: + is_mips_machine_config mc ⇒ mc_conf_ok mc +Proof + rw[lab_to_targetProofTheory.mc_conf_ok_def,is_mips_machine_config_def] >- EVAL_TAC >- simp[mips_targetProofTheory.mips_encoder_correct] >- EVAL_TAC @@ -50,14 +53,17 @@ Theorem mips_machine_config_ok >- EVAL_TAC >- EVAL_TAC >- EVAL_TAC - >- metis_tac[asmPropsTheory.encoder_correct_def,asmPropsTheory.target_ok_def,mips_encoder_correct]); + >- metis_tac[asmPropsTheory.encoder_correct_def,asmPropsTheory.target_ok_def,mips_encoder_correct] +QED -Theorem mips_init_ok - `is_mips_machine_config mc ⇒ - mc_init_ok mips_backend_config mc` - (rw[mc_init_ok_def] \\ +Theorem mips_init_ok: + is_mips_machine_config mc ⇒ + mc_init_ok mips_backend_config mc +Proof + rw[mc_init_ok_def] \\ fs[is_mips_machine_config_def] \\ - EVAL_TAC); + EVAL_TAC +QED val is_mips_machine_config_mc = mips_init_ok |> concl |> dest_imp |> #1 diff --git a/compiler/backend/patLangScript.sml b/compiler/backend/patLangScript.sml index 4ea47a466c..cf8a268094 100644 --- a/compiler/backend/patLangScript.sml +++ b/compiler/backend/patLangScript.sml @@ -33,12 +33,16 @@ val _ = Datatype` (*TODO: Verify that the introduction of traces wont mess exp_sizes *) val exp_size_def = definition"exp_size_def"; -Theorem exp1_size_APPEND[simp] - `patLang$exp1_size (e ++ e2) = exp1_size e + exp1_size e2` - (Induct_on`e`>>simp[exp_size_def]) +Theorem exp1_size_APPEND[simp]: + patLang$exp1_size (e ++ e2) = exp1_size e + exp1_size e2 +Proof + Induct_on`e`>>simp[exp_size_def] +QED -Theorem exp1_size_REVERSE[simp] - `patLang$exp1_size (REVERSE es) = exp1_size es` - (Induct_on`es`>>simp[exp_size_def]) +Theorem exp1_size_REVERSE[simp]: + patLang$exp1_size (REVERSE es) = exp1_size es +Proof + Induct_on`es`>>simp[exp_size_def] +QED val _ = export_theory() diff --git a/compiler/backend/presLangScript.sml b/compiler/backend/presLangScript.sml index b52a75f705..24bb70bf04 100644 --- a/compiler/backend/presLangScript.sml +++ b/compiler/backend/presLangScript.sml @@ -45,19 +45,23 @@ val num_to_hex_def = Define ` (* num_to_hex "implements" words$word_to_hex_string in a simple way that the translator can handle. these lemmas check that is true. *) -Theorem num_to_hex_digit_eq - `!i. i < 16 ==> num_to_hex_digit i = [HEX i]` - (CONV_TAC (REPEATC (numLib.BOUNDED_FORALL_CONV EVAL)) - \\ simp []); - -Theorem num_to_hex_eq - `num_to_hex (w2n w) = words$word_to_hex_string w` - (simp [wordsTheory.word_to_hex_string_def, wordsTheory.w2s_def] +Theorem num_to_hex_digit_eq: + !i. i < 16 ==> num_to_hex_digit i = [HEX i] +Proof + CONV_TAC (REPEATC (numLib.BOUNDED_FORALL_CONV EVAL)) + \\ simp [] +QED + +Theorem num_to_hex_eq: + num_to_hex (w2n w) = words$word_to_hex_string w +Proof + simp [wordsTheory.word_to_hex_string_def, wordsTheory.w2s_def] \\ Q.SPEC_TAC (`w2n w`, `n`) \\ measureInduct_on `I n` \\ simp [Once numposrepTheory.n2l_def, ASCIInumbersTheory.n2s_def] \\ simp [Once num_to_hex_def, num_to_hex_digit_eq] - \\ (PURE_CASE_TAC \\ simp[ASCIInumbersTheory.n2s_def])); + \\ (PURE_CASE_TAC \\ simp[ASCIInumbersTheory.n2s_def]) +QED val display_word_to_hex_string_def = Define ` display_word_to_hex_string w = diff --git a/compiler/backend/proofs/backendProofScript.sml b/compiler/backend/proofs/backendProofScript.sml index caf68a114c..f7844efd83 100644 --- a/compiler/backend/proofs/backendProofScript.sml +++ b/compiler/backend/proofs/backendProofScript.sml @@ -28,21 +28,25 @@ val _ = Parse.set_grammar_ancestry (* TODO: move/rephrase *) -Theorem byte_aligned_mult - `good_dimindex (:'a) ==> - byte_aligned (a + bytes_in_word * n2w i) = byte_aligned (a:'a word)` - (fs [alignmentTheory.byte_aligned_def,labPropsTheory.good_dimindex_def] +Theorem byte_aligned_mult: + good_dimindex (:'a) ==> + byte_aligned (a + bytes_in_word * n2w i) = byte_aligned (a:'a word) +Proof + fs [alignmentTheory.byte_aligned_def,labPropsTheory.good_dimindex_def] \\ rw [] \\ fs [bytes_in_word_def,word_mul_n2w] \\ once_rewrite_tac [MULT_COMM] - \\ rewrite_tac [GSYM (EVAL ``2n**2``),GSYM (EVAL ``2n**3``), aligned_add_pow]); + \\ rewrite_tac [GSYM (EVAL ``2n**2``),GSYM (EVAL ``2n**3``), aligned_add_pow] +QED -Theorem byte_aligned_MOD ` - good_dimindex (:'a) ⇒ +Theorem byte_aligned_MOD: + good_dimindex (:'a) ⇒ ∀x:'a word.x ∈ byte_aligned ⇒ - w2n x MOD (dimindex (:'a) DIV 8) = 0` - (rw[IN_DEF]>> + w2n x MOD (dimindex (:'a) DIV 8) = 0 +Proof + rw[IN_DEF]>> fs [aligned_w2n, alignmentTheory.byte_aligned_def]>> - rfs[labPropsTheory.good_dimindex_def] \\ rfs []); + rfs[labPropsTheory.good_dimindex_def] \\ rfs [] +QED (* -- *) @@ -77,22 +81,28 @@ val backend_config_ok_def = Define` c.lab_conf.asm_conf.valid_imm (INL Sub) (n2w (n * (dimindex (:α) DIV 8))) ∧ c.lab_conf.asm_conf.valid_imm (INL Add) (n2w (n * (dimindex (:α) DIV 8))))`; -Theorem backend_config_ok_with_bvl_conf_updated[simp] - `(f cc.bvl_conf).next_name2 = cc.bvl_conf.next_name2 ⇒ - (backend_config_ok (cc with bvl_conf updated_by f) ⇔ backend_config_ok cc)` - (rw[backend_config_ok_def]); +Theorem backend_config_ok_with_bvl_conf_updated[simp]: + (f cc.bvl_conf).next_name2 = cc.bvl_conf.next_name2 ⇒ + (backend_config_ok (cc with bvl_conf updated_by f) ⇔ backend_config_ok cc) +Proof + rw[backend_config_ok_def] +QED -Theorem backend_config_ok_with_word_to_word_conf_updated[simp] - `backend_config_ok (cc with word_to_word_conf updated_by f) ⇔ backend_config_ok cc` - (rw[backend_config_ok_def]); +Theorem backend_config_ok_with_word_to_word_conf_updated[simp]: + backend_config_ok (cc with word_to_word_conf updated_by f) ⇔ backend_config_ok cc +Proof + rw[backend_config_ok_def] +QED -Theorem backend_config_ok_call_empty_ffi[simp] - `backend_config_ok (cc with +Theorem backend_config_ok_call_empty_ffi[simp]: + backend_config_ok (cc with data_conf updated_by (λc. c with call_empty_ffi updated_by x)) = - backend_config_ok cc` - (fs [backend_config_ok_def,data_to_wordTheory.conf_ok_def, + backend_config_ok cc +Proof + fs [backend_config_ok_def,data_to_wordTheory.conf_ok_def, data_to_wordTheory.shift_length_def, - data_to_wordTheory.max_heap_limit_def]); + data_to_wordTheory.max_heap_limit_def] +QED val mc_init_ok_def = Define` mc_init_ok c mc ⇔ @@ -111,20 +121,26 @@ val mc_init_ok_def = Define` ¬MEM (case mc.target.config.link_reg of NONE => 0 | SOME n => n) mc.callee_saved_regs ∧ c.lab_conf.asm_conf = mc.target.config` -Theorem mc_init_ok_with_bvl_conf_updated[simp] - `mc_init_ok (cc with bvl_conf updated_by f) mc ⇔ mc_init_ok cc mc` - (rw[mc_init_ok_def]); +Theorem mc_init_ok_with_bvl_conf_updated[simp]: + mc_init_ok (cc with bvl_conf updated_by f) mc ⇔ mc_init_ok cc mc +Proof + rw[mc_init_ok_def] +QED -Theorem mc_init_ok_with_word_to_word_conf_updated[simp] - `mc_init_ok (cc with word_to_word_conf updated_by f) mc ⇔ mc_init_ok cc mc` - (rw[mc_init_ok_def]); +Theorem mc_init_ok_with_word_to_word_conf_updated[simp]: + mc_init_ok (cc with word_to_word_conf updated_by f) mc ⇔ mc_init_ok cc mc +Proof + rw[mc_init_ok_def] +QED -Theorem mc_init_ok_call_empty_ffi[simp] - `mc_init_ok (cc with +Theorem mc_init_ok_call_empty_ffi[simp]: + mc_init_ok (cc with data_conf updated_by (λc. c with call_empty_ffi updated_by x)) = - mc_init_ok cc` - (fs [mc_init_ok_def,data_to_wordTheory.conf_ok_def, - data_to_wordTheory.shift_length_def,FUN_EQ_THM]); + mc_init_ok cc +Proof + fs [mc_init_ok_def,data_to_wordTheory.conf_ok_def, + data_to_wordTheory.shift_length_def,FUN_EQ_THM] +QED val heap_regs_def = Define` heap_regs reg_names = @@ -157,9 +173,10 @@ val _ = temp_overload_on("code_locs",``closProps$code_locs``); (* TODO re-define syntax_ok on terms of things in closPropsTheory * (invent new properties), and prove elsewhere * that the pat_to_clos compiler satisfies these things.*) -Theorem syntax_ok_pat_to_clos - `!e. clos_mtiProof$syntax_ok [pat_to_clos$compile e]` - (ho_match_mp_tac pat_to_closTheory.compile_ind +Theorem syntax_ok_pat_to_clos: + !e. clos_mtiProof$syntax_ok [pat_to_clos$compile e] +Proof + ho_match_mp_tac pat_to_closTheory.compile_ind \\ rw [pat_to_closTheory.compile_def, clos_mtiProofTheory.syntax_ok_def, pat_to_closTheory.CopyByteStr_def, @@ -171,31 +188,37 @@ Theorem syntax_ok_pat_to_clos \\ rw [clos_mtiProofTheory.syntax_ok_def, Once clos_mtiProofTheory.syntax_ok_cons, clos_mtiProofTheory.syntax_ok_REVERSE, - clos_mtiProofTheory.syntax_ok_MAP]); + clos_mtiProofTheory.syntax_ok_MAP] +QED -Theorem syntax_ok_MAP_pat_to_clos - `!xs. clos_mtiProof$syntax_ok (MAP pat_to_clos_compile xs)` - (Induct \\ fs [clos_mtiProofTheory.syntax_ok_def] +Theorem syntax_ok_MAP_pat_to_clos: + !xs. clos_mtiProof$syntax_ok (MAP pat_to_clos_compile xs) +Proof + Induct \\ fs [clos_mtiProofTheory.syntax_ok_def] \\ once_rewrite_tac [clos_mtiProofTheory.syntax_ok_cons] - \\ fs [syntax_ok_pat_to_clos]); + \\ fs [syntax_ok_pat_to_clos] +QED -Theorem syntax_ok_IMP_obeys_max_app - `!e3. 0 < m /\ clos_mtiProof$syntax_ok e3 ==> EVERY (obeys_max_app m) e3` - (ho_match_mp_tac clos_mtiProofTheory.syntax_ok_ind \\ rpt strip_tac \\ fs [] +Theorem syntax_ok_IMP_obeys_max_app: + !e3. 0 < m /\ clos_mtiProof$syntax_ok e3 ==> EVERY (obeys_max_app m) e3 +Proof + ho_match_mp_tac clos_mtiProofTheory.syntax_ok_ind \\ rpt strip_tac \\ fs [] \\ pop_assum mp_tac \\ once_rewrite_tac [clos_mtiProofTheory.syntax_ok_def] \\ fs [] \\ fs [EVERY_MEM,MEM_MAP,FORALL_PROD,PULL_EXISTS] - \\ rw [] \\ res_tac); + \\ rw [] \\ res_tac +QED (* TODO: move these *) -Theorem compile_common_syntax - `!cf e3 cf1 e4. +Theorem compile_common_syntax: + !cf e3 cf1 e4. clos_to_bvl$compile_common cf e3 = (cf1,e4) ==> (EVERY no_Labels e3 ==> EVERY no_Labels (MAP (SND o SND) e4)) /\ (0 < cf.max_app /\ clos_mtiProof$syntax_ok e3 ==> EVERY (obeys_max_app cf.max_app) (MAP (SND o SND) e4)) /\ - every_Fn_SOME (MAP (SND o SND) e4)` - (fs [clos_to_bvlTheory.compile_common_def] + every_Fn_SOME (MAP (SND o SND) e4) +Proof + fs [clos_to_bvlTheory.compile_common_def] \\ rpt gen_tac \\ rpt (pairarg_tac \\ fs []) \\ strip_tac \\ rveq \\ fs [] \\ rw [] THEN1 (* no_Labels *) @@ -266,14 +289,16 @@ Theorem compile_common_syntax \\ match_mp_tac clos_labelsProofTheory.every_Fn_SOME_labs \\ match_mp_tac clos_annotateProofTheory.every_Fn_SOME_ann \\ fs [closPropsTheory.every_Fn_SOME_APPEND] - \\ match_mp_tac clos_to_bvlProofTheory.chain_exps_every_Fn_SOME \\ fs []); + \\ match_mp_tac clos_to_bvlProofTheory.chain_exps_every_Fn_SOME \\ fs [] +QED -Theorem compile_common_code_locs - `!c es c1 xs. +Theorem compile_common_code_locs: + !c es c1 xs. clos_to_bvl$compile_common c (MAP pat_to_clos_compile es) = (c1,xs) ==> BIGUNION (set (MAP closProps$get_code_labels (MAP (SND ∘ SND) xs))) ⊆ - set (MAP FST xs) ∪ set (code_locs (MAP (SND ∘ SND) xs))` - (rpt strip_tac + set (MAP FST xs) ∪ set (code_locs (MAP (SND ∘ SND) xs)) +Proof + rpt strip_tac \\ drule compile_common_syntax \\ fs [EVERY_MAP,compile_no_Labels] \\ strip_tac @@ -299,29 +324,32 @@ Theorem compile_common_code_locs MEM_MAP, PULL_EXISTS] \\ metis_tac[] ) \\ rename [`clos_labels$compile input`] \\ fs [closPropsTheory.BIGUNION_MAP_code_locs_SND_SND] - \\ metis_tac [clos_labelsProofTheory.compile_any_dests_SUBSET_code_locs]); + \\ metis_tac [clos_labelsProofTheory.compile_any_dests_SUBSET_code_locs] +QED (* -- *) val _ = temp_overload_on("esgc_free",``patProps$esgc_free``); val _ = temp_overload_on("elist_globals",``flatProps$elist_globals``); val _ = temp_overload_on("set_globals",``flatProps$set_globals``); -Theorem word_list_exists_imp - `dm = stack_removeProof$addresses a n /\ +Theorem word_list_exists_imp: + dm = stack_removeProof$addresses a n /\ dimindex (:'a) DIV 8 * n < dimword (:'a) ∧ good_dimindex (:'a) ⇒ - word_list_exists a n (fun2set (m1,dm:'a word set))` - (metis_tac [stack_removeProofTheory.word_list_exists_addresses]); + word_list_exists a n (fun2set (m1,dm:'a word set)) +Proof + metis_tac [stack_removeProofTheory.word_list_exists_addresses] +QED -Theorem compile_correct - `compile (c:'a config) prog = SOME (bytes,bitmaps,c') ⇒ +Theorem compile_correct: + compile (c:'a config) prog = SOME (bytes,bitmaps,c') ⇒ let (s,env) = THE (prim_sem_env (ffi:'ffi ffi_state)) in ¬semantics_prog s env prog Fail ∧ backend_config_ok c ∧ lab_to_targetProof$mc_conf_ok mc ∧ mc_init_ok c mc ∧ installed bytes cbspace bitmaps data_sp c'.ffi_names ffi (heap_regs c.stack_conf.reg_names) mc ms ⇒ machine_sem (mc:(α,β,γ) machine_config) ffi ms ⊆ - extend_with_resource_limit (semantics_prog s env prog)` - - (srw_tac[][compile_eq_from_source,from_source_def,backend_config_ok_def,heap_regs_def] >> + extend_with_resource_limit (semantics_prog s env prog) +Proof + srw_tac[][compile_eq_from_source,from_source_def,backend_config_ok_def,heap_regs_def] >> `c.lab_conf.asm_conf = mc.target.config` by fs[mc_init_ok_def] >> `c'.ffi_names = SOME mc.ffi_names` by fs[targetSemTheory.installed_def] >> drule(GEN_ALL(MATCH_MP SWAP_IMP source_to_flatProofTheory.compile_semantics)) >> @@ -1950,6 +1978,7 @@ Theorem compile_correct \\ simp_tac std_ss [] \\ disch_then(SUBST_ALL_TAC o SYM) \\ fs[full_make_init_compile, Abbr`lab_st`] - \\ fs[EVAL``(lab_to_targetProof$make_init a b c d e f g h i j k l m).compile``]); + \\ fs[EVAL``(lab_to_targetProof$make_init a b c d e f g h i j k l m).compile``] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/bvi_letProofScript.sml b/compiler/backend/proofs/bvi_letProofScript.sml index e5aefd3e2b..1f865fb9b3 100644 --- a/compiler/backend/proofs/bvi_letProofScript.sml +++ b/compiler/backend/proofs/bvi_letProofScript.sml @@ -16,11 +16,13 @@ val env_rel_def = Define ` v_rel a x y (x::e1) (y::e2) /\ env_rel rest d e1 e2) /\ (env_rel _ _ _ _ = F)` -Theorem env_rel_length - `!ax env env2. env_rel ax d env env2 ==> LENGTH env <= LENGTH env2` - (Induct \\ Cases_on `env` \\ Cases_on `env2` \\ fs [env_rel_def] +Theorem env_rel_length: + !ax env env2. env_rel ax d env env2 ==> LENGTH env <= LENGTH env2 +Proof + Induct \\ Cases_on `env` \\ Cases_on `env2` \\ fs [env_rel_def] \\ rw [] \\ Cases_on `d` \\ fs [] - \\ imp_res_tac (METIS_PROVE [] ``x=y ==> LENGTH x = LENGTH y``) \\ fs []); + \\ imp_res_tac (METIS_PROVE [] ``x=y ==> LENGTH x = LENGTH y``) \\ fs [] +QED val env_rel_LLOOKUP_NONE = Q.prove( `!ax env env2 n d. @@ -45,14 +47,16 @@ val env_rel_LOOKUP_SOME = Q.prove( \\ first_x_assum match_mp_tac \\ Cases_on `h'` \\ fs [env_rel_def]); -Theorem evaluate_delete_var_Rerr_SING - `!x s r e env2. +Theorem evaluate_delete_var_Rerr_SING: + !x s r e env2. evaluate ([x],env2,s) = (Rerr e,r) /\ e <> Rabort Rtype_error ==> - evaluate ([delete_var x],env2,s) = (Rerr e,r)` - (Cases \\ fs [delete_var_def] + evaluate ([delete_var x],env2,s) = (Rerr e,r) +Proof + Cases \\ fs [delete_var_def] \\ fs [evaluate_def,do_app_def] \\ rw [] - \\ CCONTR_TAC \\ fs [] \\ rw []); + \\ CCONTR_TAC \\ fs [] \\ rw [] +QED val evaluate_delete_var_Rerr = Q.prove( `!xs s r e env2. @@ -95,39 +99,50 @@ val evaluate_delete_var_Rval = Q.prove( \\ imp_res_tac evaluate_SING_IMP \\ rw [] \\ fs [] \\ fs [v_rel_def,env_rel_def,LLOOKUP_def]); -Theorem evaluate_SNOC_Rval - `evaluate (SNOC x y,env,s) = (Rval a,r) ==> +Theorem evaluate_SNOC_Rval: + evaluate (SNOC x y,env,s) = (Rval a,r) ==> ?a1 a2 r1. a = SNOC a1 a2 /\ LENGTH y = LENGTH a2 /\ evaluate (y,env,s) = (Rval a2,r1) /\ - evaluate ([x],env,r1) = (Rval [a1],r)` - (fs [evaluate_SNOC] + evaluate ([x],env,r1) = (Rval [a1],r) +Proof + fs [evaluate_SNOC] \\ every_case_tac \\ fs [] \\ imp_res_tac evaluate_SING_IMP \\ rw [] - \\ imp_res_tac evaluate_IMP_LENGTH \\ fs []); + \\ imp_res_tac evaluate_IMP_LENGTH \\ fs [] +QED -Theorem compile_CONS - `compile ax d (x::xs) = compile ax d [x] ++ compile ax d xs` - (Cases_on `xs` \\ fs [compile_def]); +Theorem compile_CONS: + compile ax d (x::xs) = compile ax d [x] ++ compile ax d xs +Proof + Cases_on `xs` \\ fs [compile_def] +QED -Theorem compile_APPEND - `!xs ys ax d. compile ax d (xs ++ ys) = compile ax d xs ++ compile ax d ys` - (Induct \\ fs [compile_def] - \\ once_rewrite_tac [compile_CONS] \\ fs []); +Theorem compile_APPEND: + !xs ys ax d. compile ax d (xs ++ ys) = compile ax d xs ++ compile ax d ys +Proof + Induct \\ fs [compile_def] + \\ once_rewrite_tac [compile_CONS] \\ fs [] +QED -Theorem IMP_COMM - `(b1 ==> b2 ==> b3) <=> (b2 ==> b1 ==> b3)` - (metis_tac []); +Theorem IMP_COMM: + (b1 ==> b2 ==> b3) <=> (b2 ==> b1 ==> b3) +Proof + metis_tac [] +QED -Theorem exp_size_APPEND - `!xs ys. exp2_size (xs ++ ys) = exp2_size xs + exp2_size ys` - (Induct \\ fs [bviTheory.exp_size_def]); +Theorem exp_size_APPEND: + !xs ys. exp2_size (xs ++ ys) = exp2_size xs + exp2_size ys +Proof + Induct \\ fs [bviTheory.exp_size_def] +QED -Theorem env_rel_MAP - `!ax env1 env2 d a. +Theorem env_rel_MAP: + !ax env1 env2 d a. env_rel ax d env1 env2 ==> - env_rel (MAP ($+ (LENGTH a)) ax) (d + LENGTH a) env1 (a ++ env2)` - (Induct \\ fs [env_rel_def] + env_rel (MAP ($+ (LENGTH a)) ax) (d + LENGTH a) env1 (a ++ env2) +Proof + Induct \\ fs [env_rel_def] THEN1 (once_rewrite_tac [EQ_SYM_EQ] \\ Induct_on `a` \\ fs [ADD1]) \\ Cases_on `env1` \\ Cases_on `env2` \\ fs [env_rel_def] \\ fs [v_rel_def] \\ rw [env_rel_def] \\ Cases_on `a` @@ -140,15 +155,17 @@ Theorem env_rel_MAP \\ first_x_assum match_mp_tac \\ fs []) \\ fs [LLOOKUP_EQ_EL,ADD_CLAUSES] \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,APPEND] - \\ fs [EL_APPEND2]); + \\ fs [EL_APPEND2] +QED -Theorem evaluate_env_rel - `!xs env1 (s1:('c,'ffi) bviSem$state) ax env2 res s2 ys d. +Theorem evaluate_env_rel: + !xs env1 (s1:('c,'ffi) bviSem$state) ax env2 res s2 ys d. (evaluate (xs,env1,s1) = (res,s2)) /\ env_rel ax d env1 env2 /\ res <> Rerr (Rabort Rtype_error) ==> - (evaluate (compile ax d xs,env2,s1) = (res,s2))` - (strip_tac \\ completeInduct_on `exp2_size xs` + (evaluate (compile ax d xs,env2,s1) = (res,s2)) +Proof + strip_tac \\ completeInduct_on `exp2_size xs` \\ rw [] \\ fs [PULL_FORALL] \\ Cases_on `xs` \\ fs[compile_def,evaluate_def] \\ reverse (Cases_on `t`) \\ fs [] THEN1 @@ -272,32 +289,38 @@ Theorem evaluate_env_rel \\ fs [] \\ drule evaluate_delete_var_Rval \\ rpt (disch_then drule) \\ strip_tac \\ fs [] \\ fs [AND_IMP_INTRO] \\ first_x_assum match_mp_tac \\ fs [bviTheory.exp_size_def] - \\ asm_exists_tac \\ fs []); + \\ asm_exists_tac \\ fs [] +QED val compile_thm = save_thm("compile_thm", evaluate_env_rel |> Q.SPECL [`xs`,`env`,`s1`,`[]`,`env`,`res`,`s2`,`ys`,`0`] |> GEN_ALL |> SIMP_RULE (srw_ss()) [env_rel_def]) -Theorem evaluate_compile_exp - `evaluate ([d],env,s) = (r,t) /\ +Theorem evaluate_compile_exp: + evaluate ([d],env,s) = (r,t) /\ r <> Rerr (Rabort Rtype_error) ==> - evaluate ([bvi_let$compile_exp d],env,s) = (r,t)` - (fs [compile_exp_def] + evaluate ([bvi_let$compile_exp d],env,s) = (r,t) +Proof + fs [compile_exp_def] \\ `LENGTH (compile [] 0 [d]) = LENGTH [d]` by fs [compile_length] \\ Cases_on `compile [] 0 [d]` \\ fs [LENGTH_NIL] \\ rw [] - \\ imp_res_tac compile_thm \\ rfs []); + \\ imp_res_tac compile_thm \\ rfs [] +QED -Theorem dest_var_code_labels[simp] - `∀x. get_code_labels (delete_var x) = get_code_labels x` - (recInduct bvi_letTheory.delete_var_ind +Theorem dest_var_code_labels[simp]: + ∀x. get_code_labels (delete_var x) = get_code_labels x +Proof + recInduct bvi_letTheory.delete_var_ind \\ rw[bvi_letTheory.delete_var_def] - \\ EVAL_TAC); + \\ EVAL_TAC +QED -Theorem compile_code_labels - `∀x y z. BIGUNION (set (MAP get_code_labels (bvi_let$compile x y z))) = - BIGUNION (set (MAP get_code_labels z)) ` - (recInduct bvi_letTheory.compile_ind +Theorem compile_code_labels: + ∀x y z. BIGUNION (set (MAP get_code_labels (bvi_let$compile x y z))) = + BIGUNION (set (MAP get_code_labels z)) +Proof + recInduct bvi_letTheory.compile_ind \\ rw[bvi_letTheory.compile_def] \\ TRY PURE_CASE_TAC \\ fs[] \\ TRY PURE_CASE_TAC \\ fs[] @@ -305,14 +328,17 @@ Theorem compile_code_labels \\ fsrw_tac[ETA_ss][MAP_MAP_o, o_DEF] \\ drule APPEND_FRONT_LAST \\ disch_then(fn th => CONV_TAC(RAND_CONV(ONCE_REWRITE_CONV[GSYM th]))) - \\ simp[]); + \\ simp[] +QED -Theorem compile_exp_code_labels[simp] - `∀x. get_code_labels (bvi_let$compile_exp x) = get_code_labels x` - (rw[bvi_letTheory.compile_exp_def] +Theorem compile_exp_code_labels[simp]: + ∀x. get_code_labels (bvi_let$compile_exp x) = get_code_labels x +Proof + rw[bvi_letTheory.compile_exp_def] \\ simp[Once(GSYM bvi_letTheory.compile_HD_SING)] \\ specl_args_of_then``bvi_let$compile``compile_code_labels mp_tac \\ simp[] - \\ simp[Once(GSYM bvi_letTheory.compile_HD_SING)]); + \\ simp[Once(GSYM bvi_letTheory.compile_HD_SING)] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/bvi_tailrecProofScript.sml b/compiler/backend/proofs/bvi_tailrecProofScript.sml index bf54077f3c..3f87673be8 100644 --- a/compiler/backend/proofs/bvi_tailrecProofScript.sml +++ b/compiler/backend/proofs/bvi_tailrecProofScript.sml @@ -21,70 +21,92 @@ val s = mk_var("s", type_of ``bviSem$evaluate`` |> strip_fun |> snd |> dest_prod |> snd |> type_subst [alpha|->``:num#'c``,beta|->``:'ffi``]); -Theorem get_bin_args_SOME[simp] - `∀exp q. get_bin_args exp = SOME q +Theorem get_bin_args_SOME[simp]: + ∀exp q. get_bin_args exp = SOME q ⇔ - ∃e1 e2 op. q = (e1, e2) ∧ exp = Op op [e1; e2]` - (Cases \\ rw [get_bin_args_def] + ∃e1 e2 op. q = (e1, e2) ∧ exp = Op op [e1; e2] +Proof + Cases \\ rw [get_bin_args_def] \\ rw[bvlPropsTheory.case_eq_thms] - \\ rw[EQ_IMP_THM]); + \\ rw[EQ_IMP_THM] +QED -Theorem opbinargs_SOME[simp] - `!exp opr. opbinargs opr exp = SOME q +Theorem opbinargs_SOME[simp]: + !exp opr. opbinargs opr exp = SOME q <=> - opr <> Noop /\ ?x y. q = (x, y) /\ exp = Op (to_op opr) [x;y]` - (Cases \\ Cases \\ fs [opbinargs_def, to_op_def, op_eq_def] - \\ rw [EQ_IMP_THM]); - -Theorem decide_ty_simp1[simp] - `(decide_ty ty1 ty2 = Int <=> ty1 = Int /\ ty2 = Int) /\ - (decide_ty ty1 ty2 = List <=> ty1 = List /\ ty2 = List)` - (Cases_on `ty1` \\ Cases_on `ty2` \\ fs [decide_ty_def]); - -Theorem list_to_v_simp[simp] - `!xs. v_to_list (list_to_v xs) = SOME xs` - (Induct \\ fs [bvlSemTheory.v_to_list_def, bvlSemTheory.list_to_v_def]); - -Theorem to_op_11[simp] - `to_op op1 = to_op op2 <=> op1 = op2` - (Cases_on `op1` \\ Cases_on `op2` \\ rw [to_op_def]); - -Theorem to_op_eq_simp[simp] - `(to_op x = Add <=> (x = Plus)) /\ + opr <> Noop /\ ?x y. q = (x, y) /\ exp = Op (to_op opr) [x;y] +Proof + Cases \\ Cases \\ fs [opbinargs_def, to_op_def, op_eq_def] + \\ rw [EQ_IMP_THM] +QED + +Theorem decide_ty_simp1[simp]: + (decide_ty ty1 ty2 = Int <=> ty1 = Int /\ ty2 = Int) /\ + (decide_ty ty1 ty2 = List <=> ty1 = List /\ ty2 = List) +Proof + Cases_on `ty1` \\ Cases_on `ty2` \\ fs [decide_ty_def] +QED + +Theorem list_to_v_simp[simp]: + !xs. v_to_list (list_to_v xs) = SOME xs +Proof + Induct \\ fs [bvlSemTheory.v_to_list_def, bvlSemTheory.list_to_v_def] +QED + +Theorem to_op_11[simp]: + to_op op1 = to_op op2 <=> op1 = op2 +Proof + Cases_on `op1` \\ Cases_on `op2` \\ rw [to_op_def] +QED + +Theorem to_op_eq_simp[simp]: + (to_op x = Add <=> (x = Plus)) /\ (to_op x = Mult <=> (x = Times)) /\ (to_op x = Mod <=> (x = Noop)) /\ (to_op x = ListAppend <=> (x = Append)) /\ (Add = to_op x <=> (x = Plus)) /\ (Mult = to_op x <=> (x = Times)) /\ (ListAppend = to_op x <=> (x = Append)) /\ - (Mod = to_op x <=> (x = Noop))` - (Cases_on`x` \\ rw[to_op_def]); + (Mod = to_op x <=> (x = Noop)) +Proof + Cases_on`x` \\ rw[to_op_def] +QED -Theorem op_eq_simp[simp] - `(op_eq Plus x <=> (?xs. x = Op Add xs)) /\ +Theorem op_eq_simp[simp]: + (op_eq Plus x <=> (?xs. x = Op Add xs)) /\ (op_eq Times x <=> (?xs. x = Op Mult xs)) /\ - (op_eq Append x <=> (?xs. x = Op ListAppend xs))` - (Cases_on`x` \\ rw[op_eq_def]); - -Theorem scan_expr_EVERY_SING[simp] - `EVERY P (scan_expr ts loc [x]) ⇔ P (HD (scan_expr ts loc [x]))` - (`LENGTH (scan_expr ts loc [x]) = 1` by fs [] - \\ Cases_on `scan_expr ts loc [x]` \\ fs []); - -Theorem try_update_LENGTH[simp] - `LENGTH (try_update ty idx ts) = LENGTH ts` - (Cases_on `idx` \\ rw [try_update_def]); - -Theorem update_context_LENGTH[simp] - `LENGTH (update_context ty ts x y) = LENGTH ts` - (rw [update_context_def, try_update_LENGTH]); - -Theorem decide_ty_simp[simp] - `decide_ty ty1 ty2 = ty3 /\ ty3 <> Any <=> - ty1 = ty3 /\ ty2 = ty3 /\ ty3 <> Any` - (Cases_on `ty1` \\ Cases_on `ty2` + (op_eq Append x <=> (?xs. x = Op ListAppend xs)) +Proof + Cases_on`x` \\ rw[op_eq_def] +QED + +Theorem scan_expr_EVERY_SING[simp]: + EVERY P (scan_expr ts loc [x]) ⇔ P (HD (scan_expr ts loc [x])) +Proof + `LENGTH (scan_expr ts loc [x]) = 1` by fs [] + \\ Cases_on `scan_expr ts loc [x]` \\ fs [] +QED + +Theorem try_update_LENGTH[simp]: + LENGTH (try_update ty idx ts) = LENGTH ts +Proof + Cases_on `idx` \\ rw [try_update_def] +QED + +Theorem update_context_LENGTH[simp]: + LENGTH (update_context ty ts x y) = LENGTH ts +Proof + rw [update_context_def, try_update_LENGTH] +QED + +Theorem decide_ty_simp[simp]: + decide_ty ty1 ty2 = ty3 /\ ty3 <> Any <=> + ty1 = ty3 /\ ty2 = ty3 /\ ty3 <> Any +Proof + Cases_on `ty1` \\ Cases_on `ty2` \\ fs [decide_ty_def] \\ rw [EQ_IMP_THM] - \\ Cases_on `ty3` \\ fs []); + \\ Cases_on `ty3` \\ fs [] +QED val ty_rel_def = Define ` ty_rel = LIST_REL @@ -97,27 +119,30 @@ val assoc_op_ty_thms = { nchotomy = assoc_op_nchotomy, case_def = assoc_op_case_ val assoc_op_cases = prove_case_eq_thm assoc_op_ty_thms val case_eq_thms = CONJ v_ty_cases (CONJ assoc_op_cases bviPropsTheory.case_eq_thms) -Theorem list_to_v_imp - `!x xs. v_to_list x = SOME xs ==> list_to_v xs = x` - (recInduct bvlSemTheory.v_to_list_ind +Theorem list_to_v_imp: + !x xs. v_to_list x = SOME xs ==> list_to_v xs = x +Proof + recInduct bvlSemTheory.v_to_list_ind \\ rw [bvlSemTheory.v_to_list_def] \\ fs [case_eq_thms] \\ rw [] - \\ fs [bvlSemTheory.list_to_v_def]); + \\ fs [bvlSemTheory.list_to_v_def] +QED val s1 = mk_var("s", type_of ``bviSem$evaluate`` |> strip_fun |> snd |> dest_prod |> snd |> type_subst [alpha|->``:'c``,beta|->``:'ffi``]); -Theorem term_ok_int_SING - `!ts exp env ^s1 r t. +Theorem term_ok_int_SING: + !ts exp env ^s1 r t. term_ok_int ts exp /\ ty_rel env ts /\ evaluate ([exp], env, s) = (r, t) ==> s = t /\ ?v. r = Rval [v] /\ (!^s1. evaluate ([exp], env, s) = (r, s)) /\ - ?k. v = Number k` - (recInduct term_ok_int_ind \\ rw [] \\ Cases_on `expr` + ?k. v = Number k +Proof + recInduct term_ok_int_ind \\ rw [] \\ Cases_on `expr` \\ qhdtm_x_assum `term_ok_int` mp_tac \\ once_rewrite_tac [term_ok_int_def] \\ fs [case_elim_thms, case_eq_thms, pair_case_eq, bool_case_eq] \\ rw [] @@ -138,18 +163,20 @@ Theorem term_ok_int_SING \\ rw [] \\ fs [] \\ imp_res_tac evaluate_SING_IMP \\ fs [] \\ rw [] \\ res_tac \\ rw [] \\ fs [] - \\ fs [bvl_to_bvi_id]); + \\ fs [bvl_to_bvi_id] +QED -Theorem term_ok_any_SING - `(!ts list exp env ^s1 r t. +Theorem term_ok_any_SING: + (!ts list exp env ^s1 r t. term_ok_any ts list exp /\ ty_rel env ts /\ evaluate ([exp], env, s) = (r, t) ==> s = t /\ ?v. r = Rval [v] /\ (!^s1. evaluate ([exp], env, s) = (r, s)) /\ - (list ==> ?ys. v_to_list v = SOME ys))` - (recInduct term_ok_any_ind \\ rw [] + (list ==> ?ys. v_to_list v = SOME ys)) +Proof + recInduct term_ok_any_ind \\ rw [] \\ qhdtm_x_assum `term_ok_any` mp_tac \\ once_rewrite_tac [term_ok_any_def] \\ fs [] \\ TRY PURE_TOP_CASE_TAC \\ fs [] \\ rw [] \\ fs [] @@ -191,10 +218,11 @@ Theorem term_ok_any_SING \\ res_tac \\ fs [] \\ rw [] \\ fs [do_app_def, do_app_aux_def, bvlSemTheory.do_app_def] \\ rw [] \\ fs [bvl_to_bvi_id] - \\ fs [bvlSemTheory.v_to_list_def] \\ EVAL_TAC); + \\ fs [bvlSemTheory.v_to_list_def] \\ EVAL_TAC +QED -Theorem term_ok_SING - `!ts ty exp env ^s1 r t. +Theorem term_ok_SING: + !ts ty exp env ^s1 r t. term_ok ts ty exp /\ ty_rel env ts /\ evaluate ([exp], env, s) = (r, t) ==> @@ -204,9 +232,11 @@ Theorem term_ok_SING case ty of Int => ?k. v = Number k | List => ?ys. v_to_list v = SOME ys - | _ => T` - (rw [term_ok_def, case_elim_thms, case_eq_thms] \\ every_case_tac \\ fs [] - \\ metis_tac [term_ok_int_SING, term_ok_any_SING]); + | _ => T +Proof + rw [term_ok_def, case_elim_thms, case_eq_thms] \\ every_case_tac \\ fs [] + \\ metis_tac [term_ok_int_SING, term_ok_any_SING] +QED val op_id_val_def = Define ` op_id_val Plus = Number 0 /\ @@ -215,17 +245,19 @@ val op_id_val_def = Define ` op_id_val Noop = Number 6333 `; -Theorem scan_expr_not_Noop - `∀exp ts loc tt ty r ok op. +Theorem scan_expr_not_Noop: + ∀exp ts loc tt ty r ok op. scan_expr ts loc [exp] = [(tt, ty, r, SOME op)] ⇒ - op ≠ Noop` - (Induct + op ≠ Noop +Proof + Induct \\ rw [scan_expr_def] \\ rpt (pairarg_tac \\ fs []) \\ rw [] \\ fs[bvlPropsTheory.case_eq_thms] \\ fs [from_op_def] \\ rveq \\ rfs [case_eq_thms, bool_case_eq] \\ fs [] - \\ metis_tac []); + \\ metis_tac [] +QED val env_rel_def = Define ` env_rel ty opt acc env1 env2 <=> @@ -284,10 +316,11 @@ val code_rel_find_code_NONE = Q.prove ( \\ CASE_TAC \\ fs [] \\ rw [] \\ pairarg_tac \\ fs []); -Theorem code_rel_domain - `∀c1 c2. - code_rel c1 c2 ⇒ domain c1 ⊆ domain c2` - (simp [code_rel_def, SUBSET_DEF] +Theorem code_rel_domain: + ∀c1 c2. + code_rel c1 c2 ⇒ domain c1 ⊆ domain c2 +Proof + simp [code_rel_def, SUBSET_DEF] \\ CCONTR_TAC \\ fs [] \\ Cases_on `lookup x c1` >- fs [lookup_NONE_domain] @@ -297,14 +330,16 @@ Theorem code_rel_domain \\ first_x_assum drule \\ fs [compile_exp_def] \\ CASE_TAC \\ fs [] \\ rw [] - \\ pairarg_tac \\ fs []); + \\ pairarg_tac \\ fs [] +QED -Theorem evaluate_let_wrap - `∀x op vs ^s1 r t. +Theorem evaluate_let_wrap: + ∀x op vs ^s1 r t. op ≠ Noop ⇒ evaluate ([let_wrap (LENGTH vs) (id_from_op op) x], vs, s) = - evaluate ([x], vs ++ [op_id_val op] ++ vs, s)` - (rw [] + evaluate ([x], vs ++ [op_id_val op] ++ vs, s) +Proof + rw [] \\ `LENGTH vs + 0 ≤ LENGTH vs` by fs [] \\ drule (GEN_ALL (ISPEC s1 (Q.GEN `st` (SPEC_ALL evaluate_genlist_vars)))) \\ disch_then (qspec_then `s` mp_tac) @@ -313,17 +348,19 @@ Theorem evaluate_let_wrap \\ simp [pair_case_eq, case_eq_thms, case_elim_thms, PULL_EXISTS, bool_case_eq] \\ Cases_on `op` \\ EVAL_TAC \\ rw [] \\ AP_TERM_TAC - \\ fs [state_component_equality]); + \\ fs [state_component_equality] +QED -Theorem evaluate_complete_ind - `∀P. +Theorem evaluate_complete_ind: + ∀P. (∀xs s. (∀ys t. exp2_size ys < exp2_size xs ∧ t.clock ≤ s.clock ∨ t.clock < s.clock ⇒ P ys t) ⇒ P xs s) ⇒ - ∀(xs: bvi$exp list) ^s. P xs s` - (rpt strip_tac + ∀(xs: bvi$exp list) ^s. P xs s +Proof + rpt strip_tac \\ `∃sz. exp2_size xs = sz` by fs [] \\ `∃ck0. s.clock = ck0` by fs [] \\ ntac 2 (pop_assum mp_tac) @@ -338,33 +375,40 @@ Theorem evaluate_complete_ind \\ last_x_assum match_mp_tac \\ rpt strip_tac \\ simp [] - \\ fs [LESS_OR_EQ]); + \\ fs [LESS_OR_EQ] +QED -Theorem EVERY_LAST1 - `!xs y. EVERY P xs /\ LAST1 xs = SOME y ==> P y` - (ho_match_mp_tac LAST1_ind \\ rw [LAST1_def] \\ fs []); +Theorem EVERY_LAST1: + !xs y. EVERY P xs /\ LAST1 xs = SOME y ==> P y +Proof + ho_match_mp_tac LAST1_ind \\ rw [LAST1_def] \\ fs [] +QED -Theorem scan_expr_LENGTH - `∀ts loc xs ys. +Theorem scan_expr_LENGTH: + ∀ts loc xs ys. scan_expr ts loc xs = ys ⇒ - EVERY (λy. LENGTH (FST y) = LENGTH ts) ys` - (ho_match_mp_tac scan_expr_ind + EVERY (λy. LENGTH (FST y) = LENGTH ts) ys +Proof + ho_match_mp_tac scan_expr_ind \\ rw [scan_expr_def] \\ fs [] \\ rpt (pairarg_tac \\ fs []) \\ TRY (PURE_CASE_TAC \\ fs [case_eq_thms, case_elim_thms, pair_case_eq]) \\ rw [try_update_LENGTH] \\ fs [LAST1_def, case_eq_thms] \\ rw [] \\ fs [] \\ imp_res_tac EVERY_LAST1 \\ fs [] - \\ Cases_on `op` \\ fs [arg_ty_def, update_context_def, check_op_def]); + \\ Cases_on `op` \\ fs [arg_ty_def, update_context_def, check_op_def] +QED -Theorem ty_rel_decide_ty - `∀ts tt env. +Theorem ty_rel_decide_ty: + ∀ts tt env. (ty_rel env ts ∨ ty_rel env tt) ∧ LENGTH ts = LENGTH tt ⇒ - ty_rel env (MAP2 decide_ty ts tt)` - (Induct \\ rw [] \\ fs [] + ty_rel env (MAP2 decide_ty ts tt) +Proof + Induct \\ rw [] \\ fs [] \\ Cases_on `tt` \\ rfs [ty_rel_def] \\ EVAL_TAC \\ fs [] \\ rveq - \\ Cases_on `h` \\ fs [] \\ Cases_on `h'` \\ simp [decide_ty_def]); + \\ Cases_on `h` \\ fs [] \\ Cases_on `h'` \\ simp [decide_ty_def] +QED val ty_rel_APPEND = Q.prove ( `∀env ts ws vs. @@ -374,13 +418,15 @@ val ty_rel_APPEND = Q.prove ( >- (fs [ty_rel_def, LIST_REL_EL_EQN]) \\ fs [ty_rel_def, LIST_REL_APPEND_EQ]); -Theorem LAST1_thm - `!xs. LAST1 xs = NONE <=> xs = []` - (Induct \\ rw [LAST1_def] - \\ Cases_on `xs` \\ fs [LAST1_def]); +Theorem LAST1_thm: + !xs. LAST1 xs = NONE <=> xs = [] +Proof + Induct \\ rw [LAST1_def] + \\ Cases_on `xs` \\ fs [LAST1_def] +QED -Theorem try_update_EL - `n < LENGTH ts ==> +Theorem try_update_EL: + n < LENGTH ts ==> EL n (try_update ty idx ts) = case idx of NONE => EL n ts @@ -392,14 +438,16 @@ Theorem try_update_EL else if EL n ts = Any \/ EL n ts = ty then ty else - EL n ts` - (Cases_on `idx` + EL n ts +Proof + Cases_on `idx` \\ rw [try_update_def] \\ fs [EL_LENGTH_APPEND, EL_APPEND1, EL_TAKE, EL_APPEND2, EL_DROP] - \\ `n = x` by fs [] \\ fs []); + \\ `n = x` by fs [] \\ fs [] +QED -Theorem try_update_twice - `n < LENGTH ts ==> +Theorem try_update_twice: + n < LENGTH ts ==> EL n (try_update ty idx1 (try_update ty idx2 ts)) = case (idx1, idx2) of (NONE, NONE) => EL n ts @@ -414,23 +462,28 @@ Theorem try_update_twice | (SOME a, SOME b) => if n <> a /\ n <> b then EL n ts else if EL n ts = Any then ty - else EL n ts` - (rw [] \\ rpt (PURE_TOP_CASE_TAC \\ fs []) + else EL n ts +Proof + rw [] \\ rpt (PURE_TOP_CASE_TAC \\ fs []) \\ fs [try_update_EL] - \\ rpt (PURE_CASE_TAC \\ fs [])); + \\ rpt (PURE_CASE_TAC \\ fs []) +QED -Theorem index_of_simp[simp] - `index_of exp = SOME n <=> exp = Var n` - (Cases_on `exp` \\ rw [index_of_def]); +Theorem index_of_simp[simp]: + index_of exp = SOME n <=> exp = Var n +Proof + Cases_on `exp` \\ rw [index_of_def] +QED -Theorem scan_expr_ty_rel - `∀ts loc xs env ys s vs t. +Theorem scan_expr_ty_rel: + ∀ts loc xs env ys s vs t. ty_rel env ts ∧ scan_expr ts loc xs = ys ∧ evaluate (xs, env, s) = (Rval vs, t) ⇒ EVERY (ty_rel env o FST) ys ∧ - ty_rel vs (MAP (FST o SND) ys)` - (ho_match_mp_tac scan_expr_ind + ty_rel vs (MAP (FST o SND) ys) +Proof + ho_match_mp_tac scan_expr_ind \\ fs [scan_expr_def] \\ rpt conj_tac \\ rpt gen_tac @@ -532,31 +585,35 @@ Theorem scan_expr_ty_rel \\ rpt (PURE_TOP_CASE_TAC \\ fs []) \\ rveq \\ fs [evaluate_def, bool_case_eq, pair_case_eq, case_eq_thms, case_elim_thms] \\ rveq \\ fs [] \\ rveq \\ rfs [] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem check_op_thm - `check_op ts opr loc exp = SOME expr ==> +Theorem check_op_thm: + check_op ts opr loc exp = SOME expr ==> ?x y. is_rec loc x /\ term_ok ts (op_type opr) y /\ expr = Op (to_op opr) [y; x] /\ - (exp = Op (to_op opr) [x; y] \/ exp = Op (to_op opr) [y; x])` - (rw [check_op_def, opbinargs_def] \\ CCONTR_TAC \\ fs [] \\ rw [] + (exp = Op (to_op opr) [x; y] \/ exp = Op (to_op opr) [y; x]) +Proof + rw [check_op_def, opbinargs_def] \\ CCONTR_TAC \\ fs [] \\ rw [] \\ Cases_on `opr` \\ fs [try_swap_def, opbinargs_def, get_bin_args_def, apply_op_def, op_type_def, term_ok_def, case_eq_thms, IS_SOME_EXISTS, case_elim_thms] \\ rw [] \\ fs [to_op_def] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem rewrite_scan_expr - `!loc next op acc ts exp tt ty p exp2 r opr. +Theorem rewrite_scan_expr: + !loc next op acc ts exp tt ty p exp2 r opr. rewrite loc next op acc ts exp = (p,exp2) /\ op <> Noop /\ scan_expr ts loc [exp] = [(tt, ty, r, opr)] ==> case opr of SOME op1 => op = op1 ==> p - | NONE => ~p` - (recInduct rewrite_ind + | NONE => ~p +Proof + recInduct rewrite_ind \\ rw [rewrite_def, scan_expr_def] \\ fs [] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ rpt (PURE_TOP_CASE_TAC \\ fs []) @@ -564,23 +621,26 @@ Theorem rewrite_scan_expr \\ imp_res_tac check_op_thm \\ fs [] \\ rw [] \\ fs [to_op_def, is_const_def] \\ TRY (Cases_on `opr` \\ fs []) - \\ fs [opbinargs_def, get_bin_args_def, from_op_def, to_op_def]); + \\ fs [opbinargs_def, get_bin_args_def, from_op_def, to_op_def] +QED -Theorem scan_expr_op_type - `!ts loc xs ys. +Theorem scan_expr_op_type: + !ts loc xs ys. scan_expr ts loc xs = ys ==> EVERY (\(tt,ty,r,opr). case opr of SOME op => ty <> Any ==> op_type op = ty - | NONE => T) ys` - (recInduct scan_expr_ind \\ rw [scan_expr_def] \\ fs [] + | NONE => T) ys +Proof + recInduct scan_expr_ind \\ rw [scan_expr_def] \\ fs [] \\ rpt (pairarg_tac \\ fs []) \\ rw [] \\ fs [case_elim_thms] \\ rw [] \\ fs [] \\ rw [] \\ Cases_on `op` \\ fs [op_type_def, from_op_def] \\ fs [get_bin_args_def, arg_ty_def, check_op_def, opbinargs_def] \\ rpt (PURE_TOP_CASE_TAC \\ fs []) - \\ Cases_on `ty1` \\ Cases_on `ty2` \\ rfs [decide_ty_def]); + \\ Cases_on `ty1` \\ Cases_on `ty2` \\ rfs [decide_ty_def] +QED val optimized_code_def = Define ` optimized_code loc arity exp n c op = @@ -590,17 +650,20 @@ val optimized_code_def = Define ` lookup loc c = SOME (arity, exp_aux) ∧ lookup n c = SOME (arity + 1, exp_opt)`; -Theorem code_rel_subspt - `code_rel c1 x1 ∧ subspt x1 x2 ⇒ code_rel c1 x2` - (rw[code_rel_def] +Theorem code_rel_subspt: + code_rel c1 x1 ∧ subspt x1 x2 ⇒ code_rel c1 x2 +Proof + rw[code_rel_def] \\ fs[subspt_lookup] \\ first_x_assum drule \\ disch_then(qspec_then`op`mp_tac) - \\ rw[] \\ qexists_tac`n` \\ rw[]); + \\ rw[] \\ qexists_tac`n` \\ rw[] +QED -Theorem compile_prog_LENGTH - `∀n prog. LENGTH (SND (bvi_tailrec$compile_prog n prog)) ≥ LENGTH prog` - (recInduct compile_prog_ind +Theorem compile_prog_LENGTH: + ∀n prog. LENGTH (SND (bvi_tailrec$compile_prog n prog)) ≥ LENGTH prog +Proof + recInduct compile_prog_ind \\ conj_tac >- fs [compile_prog_def] \\ rw [] @@ -610,7 +673,8 @@ Theorem compile_prog_LENGTH \\ pairarg_tac \\ fs []) \\ PairCases_on `x` \\ fs [compile_prog_def] - \\ pairarg_tac \\ fs []); + \\ pairarg_tac \\ fs [] +QED val free_names_def = Define ` free_names n (name: num) ⇔ ∀k. n + bvl_to_bvi_namespaces*k ≠ name @@ -634,15 +698,16 @@ val compile_exp_next_addr = Q.prove ( \\ every_case_tac \\ pairarg_tac \\ fs []); -Theorem compile_prog_untouched - `∀next prog prog2 loc exp arity. +Theorem compile_prog_untouched: + ∀next prog prog2 loc exp arity. free_names next loc ∧ lookup loc (fromAList prog) = SOME (arity, exp) ∧ check_exp loc arity exp = NONE ∧ compile_exp loc next arity exp = NONE ∧ compile_prog next prog = (next1, prog2) ⇒ - lookup loc (fromAList prog2) = SOME (arity, exp)` - (ho_match_mp_tac compile_prog_ind \\ rw [] + lookup loc (fromAList prog2) = SOME (arity, exp) +Proof + ho_match_mp_tac compile_prog_ind \\ rw [] \\ fs [fromAList_def, lookup_def] \\ Cases_on `loc' = loc` \\ rw [] >- @@ -665,7 +730,8 @@ Theorem compile_prog_untouched \\ fs [fromAList_def, lookup_insert] \\ first_x_assum drule \\ disch_then drule - \\ rw [fromAList_def, lookup_insert, is_free_name]); + \\ rw [fromAList_def, lookup_insert, is_free_name] +QED val EVERY_free_names_SUCSUC = Q.prove ( `∀xs. @@ -676,8 +742,8 @@ val EVERY_free_names_SUCSUC = Q.prove ( \\ strip_tac \\ imp_res_tac more_free_names); -Theorem compile_prog_touched - `∀next prog prog2 loc exp arity. +Theorem compile_prog_touched: + ∀next prog prog2 loc exp arity. ALL_DISTINCT (MAP FST prog) ∧ EVERY (free_names next o FST) prog ∧ free_names next loc ∧ @@ -687,8 +753,9 @@ Theorem compile_prog_touched ∃k. ∀exp_aux exp_opt. compile_exp loc (next + bvl_to_bvi_namespaces * k) arity exp = SOME (exp_aux, exp_opt) ⇒ lookup loc (fromAList prog2) = SOME (arity, exp_aux) ∧ - lookup (next + bvl_to_bvi_namespaces * k) (fromAList prog2) = SOME (arity + 1, exp_opt)` - (ho_match_mp_tac compile_prog_ind \\ rw [] + lookup (next + bvl_to_bvi_namespaces * k) (fromAList prog2) = SOME (arity + 1, exp_opt) +Proof + ho_match_mp_tac compile_prog_ind \\ rw [] \\ fs [fromAList_def, lookup_def] \\ pop_assum mp_tac \\ simp [compile_prog_def] @@ -725,7 +792,8 @@ Theorem compile_prog_touched \\ disch_then drule \\ rw [] \\ qexists_tac `k + 1` \\ fs [] \\ simp [LEFT_ADD_DISTRIB] - \\ fs[backend_commonTheory.bvl_to_bvi_namespaces_def]); + \\ fs[backend_commonTheory.bvl_to_bvi_namespaces_def] +QED val check_exp_NONE_compile_exp = Q.prove ( `check_exp loc arity exp = NONE ⇒ compile_exp loc next arity exp = NONE`, @@ -746,34 +814,39 @@ val EVERY_free_names_thm = Q.prove ( \\ imp_res_tac ALOOKUP_MEM \\ first_x_assum (qspec_then `(loc, x)` mp_tac) \\ rw []); -Theorem compile_prog_code_rel - `compile_prog next prog = (next1, prog2) ∧ +Theorem compile_prog_code_rel: + compile_prog next prog = (next1, prog2) ∧ ALL_DISTINCT (MAP FST prog) ∧ EVERY (free_names next o FST) prog ⇒ - code_rel (fromAList prog) (fromAList prog2)` - (rw [code_rel_def] + code_rel (fromAList prog) (fromAList prog2) +Proof + rw [code_rel_def] \\ imp_res_tac EVERY_free_names_thm >- metis_tac [check_exp_NONE_compile_exp, compile_prog_untouched] \\ drule compile_prog_touched \\ rpt (disch_then drule) \\ rw [] \\ qexists_tac `bvl_to_bvi_namespaces * k + next` \\ fs [] \\ `0 < bvl_to_bvi_namespaces` by EVAL_TAC - \\ simp[ADD_MODULUS]); + \\ simp[ADD_MODULUS] +QED -Theorem compile_prog_next_mono - `∀n xs n1 ys. compile_prog n xs = (n1,ys) ⇒ ∃k. n1 = n + bvl_to_bvi_namespaces * k` - (recInduct compile_prog_ind +Theorem compile_prog_next_mono: + ∀n xs n1 ys. compile_prog n xs = (n1,ys) ⇒ ∃k. n1 = n + bvl_to_bvi_namespaces * k +Proof + recInduct compile_prog_ind \\ rw[compile_prog_def] \\ rpt(pairarg_tac \\ fs[bvlPropsTheory.case_eq_thms]) \\ rveq \\ fs[] \\ TRY(qexists_tac`0` \\ simp[] \\ NO_TAC) \\ TRY(qexists_tac`k` \\ simp[] \\ NO_TAC) - \\ TRY(qexists_tac`k+1` \\ simp[] \\ NO_TAC)); - -Theorem compile_prog_MEM - `compile_prog n xs = (n1,ys) /\ MEM e (MAP FST ys) ==> - MEM e (MAP FST xs) \/ (n <= e /\ e < n1 /\ (∃k. e = n + k * bvl_to_bvi_namespaces))` - (qspec_tac (`e`,`e`) + \\ TRY(qexists_tac`k+1` \\ simp[] \\ NO_TAC) +QED + +Theorem compile_prog_MEM: + compile_prog n xs = (n1,ys) /\ MEM e (MAP FST ys) ==> + MEM e (MAP FST xs) \/ (n <= e /\ e < n1 /\ (∃k. e = n + k * bvl_to_bvi_namespaces)) +Proof + qspec_tac (`e`,`e`) \\ qspec_tac (`n1`,`n1`) \\ qspec_tac (`ys`,`ys`) \\ qspec_tac (`n`,`n`) @@ -801,7 +874,8 @@ Theorem compile_prog_MEM >- metis_tac [] \\ fs [] \\ rpt disj2_tac - \\ qexists_tac`k'' + 1` \\ simp[]); + \\ qexists_tac`k'' + 1` \\ simp[] +QED val compile_prog_intro = Q.prove ( `∀xs n ys n1 name. @@ -826,12 +900,13 @@ val compile_prog_intro = Q.prove ( \\ rpt strip_tac \\ rveq \\ fs [] \\ metis_tac [is_free_name,more_free_names]); -Theorem compile_prog_ALL_DISTINCT - `compile_prog n xs = (n1,ys) /\ ALL_DISTINCT (MAP FST xs) /\ +Theorem compile_prog_ALL_DISTINCT: + compile_prog n xs = (n1,ys) /\ ALL_DISTINCT (MAP FST xs) /\ EVERY (free_names n o FST) xs ==> ALL_DISTINCT (MAP FST ys) /\ - EVERY (free_names n1 o FST) ys` - (qspec_tac (`n1`,`n1`) + EVERY (free_names n1 o FST) ys +Proof + qspec_tac (`n1`,`n1`) \\ qspec_tac (`ys`,`ys`) \\ qspec_tac (`n`,`n`) \\ qspec_tac (`xs`,`xs`) @@ -880,7 +955,8 @@ Theorem compile_prog_ALL_DISTINCT \\ drule (GEN_ALL compile_prog_MEM) \\ disch_then drule \\ simp [MEM_MAP] - \\ metis_tac [compile_prog_intro, more_free_names]); + \\ metis_tac [compile_prog_intro, more_free_names] +QED val namespace_rel_def = Define` namespace_rel (c1:'a spt) (c2:'a spt) ⇔ @@ -922,23 +998,30 @@ val state_rel_def = Define` input_condition next prog) ∧ (∀n. n ∈ domain t.code ∧ in_ns_2 n ⇒ n < FST(FST(s.compile_oracle 0)))`; -Theorem state_rel_const - `state_rel s t ⇒ +Theorem state_rel_const: + state_rel s t ⇒ t.refs = s.refs ∧ t.clock = s.clock ∧ t.global = s.global ∧ - t.ffi = s.ffi` (rw[state_rel_def]); - -Theorem state_rel_with_clock - `state_rel s t ⇒ state_rel (s with clock := k) (t with clock := k)` - (rw[state_rel_def]); - -Theorem state_rel_code_rel - `state_rel s t ⇒ code_rel s.code t.code` - (rw[state_rel_def]); - -Theorem code_rel_union - `code_rel x y ∧ code_rel t s ∧ + t.ffi = s.ffi +Proof +rw[state_rel_def] +QED + +Theorem state_rel_with_clock: + state_rel s t ⇒ state_rel (s with clock := k) (t with clock := k) +Proof + rw[state_rel_def] +QED + +Theorem state_rel_code_rel: + state_rel s t ⇒ code_rel s.code t.code +Proof + rw[state_rel_def] +QED + +Theorem code_rel_union: + code_rel x y ∧ code_rel t s ∧ (* (∀a. a ∉ domain x ∧ a ∈ domain s ⇒ a ∉ domain y) ∧ (∀a. a ∉ domain x ∧ a ∈ domain y ⇒ a ∉ domain s) @@ -946,27 +1029,32 @@ Theorem code_rel_union DISJOINT (domain s) (domain y) (* DISJOINT (domain s DIFF domain t) (domain y DIFF domain x) *) ⇒ - code_rel (union x t) (union y s)` - (rw[code_rel_def,lookup_union] + code_rel (union x t) (union y s) +Proof + rw[code_rel_def,lookup_union] \\ fs[bvlPropsTheory.case_eq_thms] \\ fs[IN_DISJOINT,IN_DIFF,domain_lookup] \\ res_tac \\ TRY(qexists_tac`n` \\ simp[]) - \\ metis_tac[option_nchotomy,NOT_SOME_NONE]); + \\ metis_tac[option_nchotomy,NOT_SOME_NONE] +QED -Theorem namespace_rel_union - `namespace_rel x y ∧ namespace_rel t s ∧ +Theorem namespace_rel_union: + namespace_rel x y ∧ namespace_rel t s ∧ DISJOINT (domain s) (domain y) ⇒ - namespace_rel (union x t) (union y s)` - (rw[namespace_rel_def,domain_union,IN_DISJOINT] - \\ metis_tac[]); - -Theorem compile_prog_namespace_rel - `compile_prog next prog = (next1,prog2) ∧ in_ns_2 next ∧ bvl_num_stubs ≤ next ∧ + namespace_rel (union x t) (union y s) +Proof + rw[namespace_rel_def,domain_union,IN_DISJOINT] + \\ metis_tac[] +QED + +Theorem compile_prog_namespace_rel: + compile_prog next prog = (next1,prog2) ∧ in_ns_2 next ∧ bvl_num_stubs ≤ next ∧ EVERY ($~ o in_ns_2 o FST) (FILTER ((<=) bvl_num_stubs o FST) prog) ⇒ - namespace_rel (fromAList prog) (fromAList prog2)` - (rw[namespace_rel_def,EVERY_MEM,domain_fromAList,MEM_MAP,PULL_EXISTS,MEM_FILTER] \\ + namespace_rel (fromAList prog) (fromAList prog2) +Proof + rw[namespace_rel_def,EVERY_MEM,domain_fromAList,MEM_MAP,PULL_EXISTS,MEM_FILTER] \\ imp_res_tac compile_prog_MEM \\ fs[MEM_MAP,PULL_EXISTS] \\ res_tac \\ fs[] @@ -974,16 +1062,18 @@ Theorem compile_prog_namespace_rel \\ CCONTR_TAC \\ fs[] >|[metis_tac[],ALL_TAC,metis_tac[]] \\ qpat_x_assum`FST _ = _`(assume_tac o SYM) \\ fs[] \\ last_x_assum drule - \\ rpt(qpat_x_assum`_ + _ = FST _`(assume_tac o SYM) \\ fs[])); + \\ rpt(qpat_x_assum`_ + _ = FST _`(assume_tac o SYM) \\ fs[]) +QED -Theorem state_rel_do_app_aux - `do_app_aux op vs s = res ∧ +Theorem state_rel_do_app_aux: + do_app_aux op vs s = res ∧ state_rel s t ∧ op ≠ Install ∧ (∀n. op ≠ Label n) ⇒ ∃res'. do_app_aux op vs t = res' ∧ - OPTREL (OPTREL ($= ### state_rel)) res res'` - (simp[do_app_aux_def] \\ strip_tac + OPTREL (OPTREL ($= ### state_rel)) res res' +Proof + simp[do_app_aux_def] \\ strip_tac \\ Cases_on`res` \\ fs[] >- ( fs[case_eq_thms,OPTREL_def] @@ -991,16 +1081,18 @@ Theorem state_rel_do_app_aux \\ imp_res_tac state_rel_const \\ fs[case_eq_thms] \\ rveq \\ fs[OPTREL_def,quotient_pairTheory.PAIR_REL_THM] - \\ fs[state_rel_def]); + \\ fs[state_rel_def] +QED -Theorem state_rel_do_app - `bviSem$do_app op vs s = Rval (r,s') ∧ +Theorem state_rel_do_app: + bviSem$do_app op vs s = Rval (r,s') ∧ state_rel s t ∧ op ≠ Install ∧ (∀n. op ≠ Label n) ⇒ ∃t'. bviSem$do_app op vs t = Rval (r,t') ∧ - state_rel s' t'` - (rw[do_app_def] + state_rel s' t' +Proof + rw[do_app_def] \\ imp_res_tac state_rel_do_app_aux \\ fs[] \\ first_x_assum(qspec_then`vs`strip_assume_tac) \\ fs[case_eq_thms,OPTREL_def] \\ rw[] \\ rfs[] @@ -1011,14 +1103,16 @@ Theorem state_rel_do_app \\ fs[bvlSemTheory.do_app_def,case_eq_thms,bvl_to_bvi_id] \\ rveq \\ fs[bvl_to_bvi_id] \\ fs[do_app_aux_def] - \\ fs[state_rel_def,bvl_to_bvi_def,bvi_to_bvl_def]); + \\ fs[state_rel_def,bvl_to_bvi_def,bvi_to_bvl_def] +QED -Theorem state_rel_do_app_err - `bviSem$do_app op vs s = Rerr e ∧ +Theorem state_rel_do_app_err: + bviSem$do_app op vs s = Rerr e ∧ state_rel s t ∧ op ≠ Install ∧ (∀n. op ≠ Label n) ⇒ - bviSem$do_app op vs t = Rerr e` - (rw[do_app_def] + bviSem$do_app op vs t = Rerr e +Proof + rw[do_app_def] \\ imp_res_tac state_rel_do_app_aux \\ fs[] \\ first_x_assum(qspec_then`vs`strip_assume_tac) \\ fs[case_eq_thms,OPTREL_def] \\ rw[] \\ rfs[] @@ -1026,97 +1120,122 @@ Theorem state_rel_do_app_err \\ fs[bvi_to_bvl_def] \\ fs[bvlSemTheory.do_app_def] \\ TOP_CASE_TAC \\ fs[] - \\ fs[case_eq_thms,do_app_aux_def]); + \\ fs[case_eq_thms,do_app_aux_def] +QED -Theorem do_app_to_op_state - `bviSem$do_app (to_op op) vs s = Rval (r,t) ⇒ t = s` - (rw[] +Theorem do_app_to_op_state: + bviSem$do_app (to_op op) vs s = Rval (r,t) ⇒ t = s +Proof + rw[] \\ Cases_on`op` \\ fs[to_op_def,do_app_def,do_app_aux_def,bvlSemTheory.do_app_def] \\ fs[case_eq_thms] \\ rw[bvl_to_bvi_id] - \\ rw[bvl_to_bvi_id]); - -Theorem scan_expr_check_op - `scan_expr ts loc [Op op xs] = [(tt, ty, r, SOME opr)] ==> - IS_SOME (check_op ts opr loc (Op op xs))` - (once_rewrite_tac [scan_expr_def] \\ rw [] \\ fs [] + \\ rw[bvl_to_bvi_id] +QED + +Theorem scan_expr_check_op: + scan_expr ts loc [Op op xs] = [(tt, ty, r, SOME opr)] ==> + IS_SOME (check_op ts opr loc (Op op xs)) +Proof + once_rewrite_tac [scan_expr_def] \\ rw [] \\ fs [] \\ pop_assum mp_tac \\ rpt (PURE_CASE_TAC \\ fs []) \\ rw [] - \\ fs [get_bin_args_def, check_op_def]); - -Theorem from_op_to_op[simp] - `from_op (to_op opr) = opr` - (Cases_on `opr` \\ fs [from_op_def, to_op_def]); - -Theorem scan_expr_op_same - `scan_expr ts loc [Op op xs] = [(tt, ty, r, SOME opr)] ==> - op = to_op opr` - (once_rewrite_tac [scan_expr_def] + \\ fs [get_bin_args_def, check_op_def] +QED + +Theorem from_op_to_op[simp]: + from_op (to_op opr) = opr +Proof + Cases_on `opr` \\ fs [from_op_def, to_op_def] +QED + +Theorem scan_expr_op_same: + scan_expr ts loc [Op op xs] = [(tt, ty, r, SOME opr)] ==> + op = to_op opr +Proof + once_rewrite_tac [scan_expr_def] \\ rw [check_op_def, opbinargs_def, get_bin_args_def, case_elim_thms, case_eq_thms, bool_case_eq, IS_SOME_EXISTS] - \\ Cases_on `op` \\ fs []); + \\ Cases_on `op` \\ fs [] +QED -Theorem term_ok_int_extend - `!ts exp extra. - term_ok_int ts exp ==> term_ok_int (ts ++ extra) exp` - (recInduct term_ok_int_ind \\ rw [] +Theorem term_ok_int_extend: + !ts exp extra. + term_ok_int ts exp ==> term_ok_int (ts ++ extra) exp +Proof + recInduct term_ok_int_ind \\ rw [] \\ pop_assum mp_tac \\ once_rewrite_tac [term_ok_int_def] \\ fs [] \\ rpt (PURE_TOP_CASE_TAC \\ fs []) - \\ rw [EL_APPEND1]); + \\ rw [EL_APPEND1] +QED -Theorem term_ok_any_extend - `!ts list exp extra. - term_ok_any ts list exp ==> term_ok_any (ts ++ extra) list exp` - (recInduct term_ok_any_ind \\ rw [] +Theorem term_ok_any_extend: + !ts list exp extra. + term_ok_any ts list exp ==> term_ok_any (ts ++ extra) list exp +Proof + recInduct term_ok_any_ind \\ rw [] \\ pop_assum mp_tac \\ once_rewrite_tac [term_ok_any_def] \\ fs [] \\ rpt (PURE_TOP_CASE_TAC \\ fs []) \\ rw [EL_APPEND1] - \\ metis_tac [term_ok_int_extend]); - -Theorem term_ok_extend - `!ts ty exp extra. - term_ok ts ty exp ==> term_ok (ts ++ extra) ty exp` - (rw [term_ok_def] \\ CASE_TAC \\ fs [] - \\ metis_tac [term_ok_any_extend, term_ok_int_extend]); - -Theorem decide_ty_imp - `decide_ty ty1 ty2 <> Any ==> ty1 <> Any /\ ty2 <> Any` - (Cases_on `ty1` \\ Cases_on `ty2` \\ fs [decide_ty_def]); - -Theorem op_type_simp - `(List = op_type op <=> op = Append) /\ + \\ metis_tac [term_ok_int_extend] +QED + +Theorem term_ok_extend: + !ts ty exp extra. + term_ok ts ty exp ==> term_ok (ts ++ extra) ty exp +Proof + rw [term_ok_def] \\ CASE_TAC \\ fs [] + \\ metis_tac [term_ok_any_extend, term_ok_int_extend] +QED + +Theorem decide_ty_imp: + decide_ty ty1 ty2 <> Any ==> ty1 <> Any /\ ty2 <> Any +Proof + Cases_on `ty1` \\ Cases_on `ty2` \\ fs [decide_ty_def] +QED + +Theorem op_type_simp: + (List = op_type op <=> op = Append) /\ (Any = op_type op <=> op = Noop) /\ - (Int = op_type op <=> op = Plus \/ op = Times)` - (Cases_on `op` \\ rw [op_type_def]); + (Int = op_type op <=> op = Plus \/ op = Times) +Proof + Cases_on `op` \\ rw [op_type_def] +QED -Theorem scan_expr_Op - `scan_expr ts loc [Op op xs] = [(tt, ty, r, SOME opr)] /\ +Theorem scan_expr_Op: + scan_expr ts loc [Op op xs] = [(tt, ty, r, SOME opr)] /\ rewrite loc n op1 acc ts (Op op xs) = (lr, x) ==> op = to_op opr /\ - (op1 = opr <=> lr)` - (rw [scan_expr_def, rewrite_def, case_elim_thms, case_eq_thms, IS_SOME_EXISTS] + (op1 = opr <=> lr) +Proof + rw [scan_expr_def, rewrite_def, case_elim_thms, case_eq_thms, IS_SOME_EXISTS] \\ Cases_on `op` \\ fs [] \\ CCONTR_TAC \\ fs [] \\ rw [] \\ fs [] \\ TRY (Cases_on `op1`) \\ fs [check_op_def, try_swap_def, opbinargs_def, get_bin_args_def, IS_SOME_EXISTS, case_eq_thms, case_elim_thms] \\ rw [] \\ fs [] - \\ fs [apply_op_def]) + \\ fs [apply_op_def] +QED -Theorem is_rec_term_ok - `!exp ts loc ty. +Theorem is_rec_term_ok: + !exp ts loc ty. (is_rec loc exp ==> ~term_ok ts ty exp) /\ - (term_ok ts ty exp ==> ~is_rec loc exp)` - (Cases \\ simp [is_rec_def, term_ok_def] + (term_ok ts ty exp ==> ~is_rec loc exp) +Proof + Cases \\ simp [is_rec_def, term_ok_def] \\ once_rewrite_tac [term_ok_int_def, term_ok_any_def] \\ fs [] \\ rw [] - \\ FULL_CASE_TAC \\ fs []); + \\ FULL_CASE_TAC \\ fs [] +QED -Theorem op_type_lem[simp] - `op <> Noop <=> op_type op <> Any` - (Cases_on `op` \\ fs [op_type_def]); +Theorem op_type_lem[simp]: + op <> Noop <=> op_type op <> Any +Proof + Cases_on `op` \\ fs [op_type_def] +QED -Theorem evaluate_rewrite_tail - `∀xs ^s env1 r t opt s' acc env2 loc ts ty. +Theorem evaluate_rewrite_tail: + ∀xs ^s env1 r t opt s' acc env2 loc ts ty. evaluate (xs, env1, s) = (r, t) ∧ env_rel ty opt acc env1 env2 ∧ state_rel s s' /\ @@ -1140,8 +1259,9 @@ Theorem evaluate_rewrite_tail evaluate ([apply_op op (Var acc) (HD xs)], env2, s') = (rrr,t2) /\ state_rel t t1 /\ - state_rel t t2)` - (ho_match_mp_tac evaluate_complete_ind + state_rel t t2) +Proof + ho_match_mp_tac evaluate_complete_ind \\ ntac 2 (rpt gen_tac \\ strip_tac) \\ Cases_on `xs` \\ fs [] >- (fs [evaluate_def] \\ rw []) @@ -2015,10 +2135,11 @@ Theorem evaluate_rewrite_tail \\ rw [] \\ fs [] \\ fs [list_to_v_imp] \\ fs [bvl_to_bvi_id]) - \\ Cases_on `h` \\ fs []); + \\ Cases_on `h` \\ fs [] +QED -Theorem evaluate_compile_prog - `input_condition next prog ∧ +Theorem evaluate_compile_prog: + input_condition next prog ∧ (∀n next cfg prog. co n = ((next,cfg),prog) ⇒ input_condition next prog) ∧ (∀n. MEM n (MAP FST (SND (compile_prog next prog))) ∧ in_ns_2 n ⇒ n < FST (FST (co 0))) ∧ evaluate ([Call 0 (SOME start) [] NONE], [], @@ -2029,8 +2150,9 @@ Theorem evaluate_compile_prog ([Call 0 (SOME start) [] NONE], [], initial_state ffi0 (fromAList (SND (compile_prog next prog))) (mk_co co) cc k) = (r, s2) ∧ - state_rel s s2` - (rw [] + state_rel s s2 +Proof + rw [] \\ qmatch_asmsub_abbrev_tac `(es,env,st1)` \\ `env_rel ty F 0 env env` by fs [env_rel_def] \\ qabbrev_tac `ts: v_ty list = []` @@ -2052,17 +2174,19 @@ Theorem evaluate_compile_prog \\ asm_exists_tac \\ fs[] ) \\ drule evaluate_rewrite_tail \\ disch_then (qspec_then `F` drule) - \\ rpt (disch_then drule) \\ fs []); + \\ rpt (disch_then drule) \\ fs [] +QED -Theorem compile_prog_semantics - `input_condition n prog ∧ +Theorem compile_prog_semantics: + input_condition n prog ∧ (∀k n cfg prog. co k = ((n,cfg),prog) ⇒ input_condition n prog) ∧ (∀k. MEM k (MAP FST prog2) ∧ in_ns_2 k ⇒ k < FST(FST (co 0))) ∧ SND (compile_prog n prog) = prog2 ∧ semantics ffi (fromAList prog) co (mk_cc cc) start ≠ ffi$Fail ⇒ semantics ffi (fromAList prog) co (mk_cc cc) start = - semantics ffi (fromAList prog2) (mk_co co) cc start` - (simp [GSYM AND_IMP_INTRO] + semantics ffi (fromAList prog2) (mk_co co) cc start +Proof + simp [GSYM AND_IMP_INTRO] \\ ntac 4 strip_tac \\ fs[AND_IMP_INTRO] \\ simp [Ntimes semantics_def 2] @@ -2200,17 +2324,19 @@ Theorem compile_prog_semantics \\ strip_tac \\ imp_res_tac state_rel_const \\ conj_tac \\ rw [] - \\ qexists_tac `k` \\ fs []); + \\ qexists_tac `k` \\ fs [] +QED -Theorem compile_prog_labels - `!next1 code1 next2 code2. +Theorem compile_prog_labels: + !next1 code1 next2 code2. compile_prog next1 code1 = (next2, code2) ==> set (MAP FST code1) UNION { next1 + k * bvl_to_bvi_namespaces | k | next1 + k * bvl_to_bvi_namespaces < next2 } = set (MAP FST code2) /\ - next1 <= next2` - (recInduct bvi_tailrecTheory.compile_prog_ind + next1 <= next2 +Proof + recInduct bvi_tailrecTheory.compile_prog_ind \\ rw [bvi_tailrecTheory.compile_prog_def] \\ fs [] \\ pop_assum mp_tac \\ fs [CaseEq"prod", CaseEq"option"] @@ -2227,20 +2353,24 @@ Theorem compile_prog_labels \\ `0n < bvl_to_bvi_namespaces` by fs [backend_commonTheory.bvl_to_bvi_namespaces_def] \\ match_mp_tac (GEN_ALL (DECIDE ``0n < z /\ x + z <= y ==> x < y``)) \\ asm_exists_tac \\ fs []) - \\ qexists_tac `k + 1` \\ fs [LEFT_ADD_DISTRIB]); + \\ qexists_tac `k + 1` \\ fs [LEFT_ADD_DISTRIB] +QED -Theorem compile_prog_keeps_names - `∀next xs next' ys. compile_prog next xs = (next',ys) ∧ MEM x (MAP FST xs) ⇒ MEM x (MAP FST ys)` - (recInduct bvi_tailrecTheory.compile_prog_ind +Theorem compile_prog_keeps_names: + ∀next xs next' ys. compile_prog next xs = (next',ys) ∧ MEM x (MAP FST xs) ⇒ MEM x (MAP FST ys) +Proof + recInduct bvi_tailrecTheory.compile_prog_ind \\ rw[bvi_tailrecTheory.compile_prog_def] \\ rpt(pairarg_tac \\ fs[]) - \\ fs[CaseEq"option",CaseEq"prod"] \\ rveq \\ fs[]); + \\ fs[CaseEq"option",CaseEq"prod"] \\ rveq \\ fs[] +QED -Theorem get_code_labels_rewrite - `∀loc next op arity foo exp bar exp_opt. +Theorem get_code_labels_rewrite: + ∀loc next op arity foo exp bar exp_opt. rewrite loc next op arity foo exp = (bar, exp_opt) ⇒ - get_code_labels exp_opt ⊆ next INSERT get_code_labels exp` - (recInduct bvi_tailrecTheory.rewrite_ind + get_code_labels exp_opt ⊆ next INSERT get_code_labels exp +Proof + recInduct bvi_tailrecTheory.rewrite_ind \\ rw[bvi_tailrecTheory.rewrite_def] \\ simp[] \\ rpt (pairarg_tac \\ fs[]) \\ rveq \\ fs[] \\ fs[CaseEq"option"] \\ rveq @@ -2261,33 +2391,39 @@ Theorem get_code_labels_rewrite \\ fs[PULL_EXISTS, closLangTheory.assign_get_code_label_def] \\ TRY(EVAL_TAC \\ rw[] \\ NO_TAC) \\ fsrw_tac[DNF_ss][PULL_EXISTS] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem get_code_labels_let_wrap[simp] - `∀a b c. get_code_labels (let_wrap a b c) = get_code_labels b ∪ get_code_labels c` - (rw[bvi_tailrecTheory.let_wrap_def, MAP_GENLIST, o_DEF] +Theorem get_code_labels_let_wrap[simp]: + ∀a b c. get_code_labels (let_wrap a b c) = get_code_labels b ∪ get_code_labels c +Proof + rw[bvi_tailrecTheory.let_wrap_def, MAP_GENLIST, o_DEF] \\ rw[EXTENSION, MEM_GENLIST] - \\ rw[EQ_IMP_THM] \\ rw[] \\ fs[]); + \\ rw[EQ_IMP_THM] \\ rw[] \\ fs[] +QED -Theorem get_code_labels_compile_exp - `∀loc next arity exp exp_aux exp_opt. +Theorem get_code_labels_compile_exp: + ∀loc next arity exp exp_aux exp_opt. compile_exp loc next arity exp = SOME (exp_aux, exp_opt) ⇒ - get_code_labels exp_aux ∪ get_code_labels exp_opt ⊆ next INSERT get_code_labels exp` - (simp[bvi_tailrecTheory.compile_exp_def,CaseEq"option"] + get_code_labels exp_aux ∪ get_code_labels exp_opt ⊆ next INSERT get_code_labels exp +Proof + simp[bvi_tailrecTheory.compile_exp_def,CaseEq"option"] \\ rpt gen_tac \\ strip_tac \\ pairarg_tac \\ fs[] \\ rveq \\ drule get_code_labels_rewrite \\ simp[] \\ strip_tac \\ Cases_on`op` \\ simp[bvi_tailrecTheory.id_from_op_def, closLangTheory.assign_get_code_label_def] - \\ EVAL_TAC); + \\ EVAL_TAC +QED -Theorem compile_prog_good_code_labels - `∀n c n2 c2. +Theorem compile_prog_good_code_labels: + ∀n c n2 c2. bvi_tailrec$compile_prog n c = (n2,c2) ∧ BIGUNION (set (MAP (get_code_labels o SND o SND) c)) ⊆ all ∧ set (MAP FST p) ⊆ all ∧ { n + k * bvl_to_bvi_namespaces | k | n + k * bvl_to_bvi_namespaces < n2 } ⊆ all ⇒ - BIGUNION (set (MAP (get_code_labels o SND o SND) c2)) ⊆ all` - (recInduct bvi_tailrecTheory.compile_prog_ind + BIGUNION (set (MAP (get_code_labels o SND o SND) c2)) ⊆ all +Proof + recInduct bvi_tailrecTheory.compile_prog_ind \\ simp[bvi_tailrecTheory.compile_prog_def] \\ rpt gen_tac \\ strip_tac \\ rpt gen_tac \\ strip_tac @@ -2311,6 +2447,7 @@ Theorem compile_prog_good_code_labels \\ reverse conj_tac >- metis_tac[] \\ gen_tac \\ rpt(first_x_assum(qspec_then`SUC k`mp_tac)) - \\ simp[ADD1,LEFT_ADD_DISTRIB]); + \\ simp[ADD1,LEFT_ADD_DISTRIB] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/bvi_to_dataProofScript.sml b/compiler/backend/proofs/bvi_to_dataProofScript.sml index 7439b1f4f1..8077ef42c5 100644 --- a/compiler/backend/proofs/bvi_to_dataProofScript.sml +++ b/compiler/backend/proofs/bvi_to_dataProofScript.sml @@ -106,12 +106,14 @@ val find_code_lemma = Q.prove( \\ `?t1 t2. a = SNOC t1 t2` by METIS_TAC [SNOC_CASES] \\ FULL_SIMP_TAC std_ss [FRONT_SNOC,LENGTH_SNOC,ADD1,MAP_SNOC]); -Theorem optimise_correct - `!c s. FST (evaluate (c,s)) <> SOME (Rerr(Rabort Rtype_error)) /\ +Theorem optimise_correct: + !c s. FST (evaluate (c,s)) <> SOME (Rerr(Rabort Rtype_error)) /\ FST (evaluate (c,s)) <> NONE ==> - (evaluate (optimise c,s) = evaluate (c,s))` - (full_simp_tac(srw_ss())[optimise_def] \\ REPEAT STRIP_TAC \\ Cases_on `evaluate (c,s)` \\ full_simp_tac(srw_ss())[] - \\ METIS_TAC [simp_correct,data_liveProofTheory.compile_correct,data_spaceProofTheory.compile_correct,FST]); + (evaluate (optimise c,s) = evaluate (c,s)) +Proof + full_simp_tac(srw_ss())[optimise_def] \\ REPEAT STRIP_TAC \\ Cases_on `evaluate (c,s)` \\ full_simp_tac(srw_ss())[] + \\ METIS_TAC [simp_correct,data_liveProofTheory.compile_correct,data_spaceProofTheory.compile_correct,FST] +QED val compile_RANGE_lemma = Q.prove( `!n env tail live xs. @@ -1521,29 +1523,32 @@ val compile_exp_lemma = compile_correct |> SIMP_RULE std_ss [LENGTH,GSYM compile_exp_def,option_case_NONE_F, PULL_EXISTS,EVERY_DEF]; -Theorem compile_exp_correct - `^(compile_exp_lemma |> concl |> dest_imp |> fst) ==> +Theorem compile_exp_correct: + ^(compile_exp_lemma |> concl |> dest_imp |> fst) ==> ∃t2 prog vs next_var r. evaluate (compile_exp n exp,t1) = (SOME r,t2) /\ - state_rel s2 t2 /\ res_list (data_to_bvi_result r) = res` - (REPEAT STRIP_TAC \\ MP_TAC compile_exp_lemma \\ full_simp_tac(srw_ss())[] + state_rel s2 t2 /\ res_list (data_to_bvi_result r) = res +Proof + REPEAT STRIP_TAC \\ MP_TAC compile_exp_lemma \\ full_simp_tac(srw_ss())[] \\ REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[compile_exp_def,LET_DEF] \\ MP_TAC (Q.SPECL [`prog`,`t1`] optimise_correct) \\ full_simp_tac(srw_ss())[] \\ impl_tac >- (rpt strip_tac >> full_simp_tac(srw_ss())[data_to_bvi_result_def]) - \\ srw_tac[][COUNT_LIST_GENLIST]); + \\ srw_tac[][COUNT_LIST_GENLIST] +QED val state_rel_dec_clock = Q.prove( `state_rel s1 t1 ⇒ state_rel (dec_clock 1 s1) (dec_clock t1)`, srw_tac[][state_rel_def,bviSemTheory.dec_clock_def,dataSemTheory.dec_clock_def]) -Theorem compile_part_evaluate - `evaluate ([Call 0 (SOME start) [] NONE],[],s1) = (res,s2) ∧ +Theorem compile_part_evaluate: + evaluate ([Call 0 (SOME start) [] NONE],[],s1) = (res,s2) ∧ res ≠ Rerr (Rabort Rtype_error) ∧ state_rel s1 t1 ∧ isEmpty t1.locals ∧ (∀x. res = Rerr (Rraise x) ⇒ jump_exc t1 ≠ NONE) ⇒ ∃r t2. evaluate ((Call NONE (SOME start) [] NONE),t1) = (SOME r,t2) ∧ - state_rel s2 t2 ∧ res_list (data_to_bvi_result r) = res` - (srw_tac[][bviSemTheory.evaluate_def,dataSemTheory.evaluate_def + state_rel s2 t2 ∧ res_list (data_to_bvi_result r) = res +Proof + srw_tac[][bviSemTheory.evaluate_def,dataSemTheory.evaluate_def ,get_vars_def,find_code_def,dataSemTheory.find_code_def] \\ Cases_on`lookup start s1.code` \\ full_simp_tac(srw_ss())[] @@ -1577,38 +1582,46 @@ Theorem compile_part_evaluate by (EVAL_TAC >> simp[dataSemTheory.state_component_equality]) \\ pop_assum SUBST1_TAC >> simp[] \\ every_case_tac - \\ full_simp_tac(srw_ss())[]); + \\ full_simp_tac(srw_ss())[] +QED -Theorem MAP_FST_compile_prog[simp] - `∀prog. MAP FST (compile_prog prog) = MAP FST prog` - (simp[compile_prog_def,MAP_MAP_o,MAP_EQ_f,FORALL_PROD,compile_part_def]); +Theorem MAP_FST_compile_prog[simp]: + ∀prog. MAP FST (compile_prog prog) = MAP FST prog +Proof + simp[compile_prog_def,MAP_MAP_o,MAP_EQ_f,FORALL_PROD,compile_part_def] +QED -Theorem compile_prog_evaluate - `evaluate ([Call 0 (SOME start) [] NONE],[], +Theorem compile_prog_evaluate: + evaluate ([Call 0 (SOME start) [] NONE],[], initial_state ffi0 (fromAList prog) co (λcfg prog. cc cfg (compile_prog prog)) k) = (r,s) ∧ r ≠ Rerr (Rabort Rtype_error) ∧ (∀x. r ≠ Rerr (Rraise x)) ⇒ ∃r2 s2. evaluate (Call NONE (SOME start) [] NONE, initial_state ffi0 (fromAList (compile_prog prog)) ((I ## compile_prog) o co) cc k) = (SOME r2,s2) ∧ - state_rel s s2 ∧ res_list (data_to_bvi_result r2) = r` - (srw_tac[][] + state_rel s s2 ∧ res_list (data_to_bvi_result r2) = r +Proof + srw_tac[][] \\ match_mp_tac (GEN_ALL compile_part_evaluate) \\ asm_exists_tac >> simp[] \\ simp[initial_state_def,state_rel_def] \\ simp[code_rel_def,wf_fromAList,domain_fromAList,lookup_fromAList] - \\ simp[compile_prog_def,ALOOKUP_MAP,compile_part_thm]); + \\ simp[compile_prog_def,ALOOKUP_MAP,compile_part_thm] +QED -Theorem FST_compile_part[simp] - `FST (compile_part a) = (FST a)` - (PairCases_on`a` \\ EVAL_TAC); +Theorem FST_compile_part[simp]: + FST (compile_part a) = (FST a) +Proof + PairCases_on`a` \\ EVAL_TAC +QED (* observational semantics *) -Theorem compile_prog_semantics - `semantics (ffi0:'ffi ffi_state) (fromAList prog) co (λcfg prog. cc cfg (compile_prog prog)) start ≠ Fail ⇒ +Theorem compile_prog_semantics: + semantics (ffi0:'ffi ffi_state) (fromAList prog) co (λcfg prog. cc cfg (compile_prog prog)) start ≠ Fail ⇒ semantics ffi0 (fromAList (compile_prog prog)) ((I ## compile_prog) o co) cc start = - semantics ffi0 (fromAList prog) co (λcfg prog. cc cfg (compile_prog prog)) start` - (simp[bviSemTheory.semantics_def] + semantics ffi0 (fromAList prog) co (λcfg prog. cc cfg (compile_prog prog)) start +Proof + simp[bviSemTheory.semantics_def] \\ IF_CASES_TAC >> full_simp_tac(srw_ss())[] \\ DEEP_INTRO_TAC some_intro >> simp[] \\ conj_tac @@ -1698,17 +1711,21 @@ Theorem compile_prog_semantics >- (conj_tac >> spose_not_then strip_assume_tac >> full_simp_tac(srw_ss())[] \\ last_x_assum(qspec_then`k`mp_tac)>>simp[]) \\ strip_tac >> simp[] - \\ full_simp_tac(srw_ss())[state_rel_def]); + \\ full_simp_tac(srw_ss())[state_rel_def] +QED -Theorem get_code_labels_iAssign[simp] - `∀a b c d e. get_code_labels (iAssign a b c d e) = closLang$assign_get_code_label b` - (rw[bvi_to_dataTheory.iAssign_def] - \\ EVAL_TAC); +Theorem get_code_labels_iAssign[simp]: + ∀a b c d e. get_code_labels (iAssign a b c d e) = closLang$assign_get_code_label b +Proof + rw[bvi_to_dataTheory.iAssign_def] + \\ EVAL_TAC +QED -Theorem get_code_labels_compile - `∀a b c d e. get_code_labels (FST (compile a b c d e)) ⊆ - BIGUNION (set (MAP get_code_labels e)) ` - (recInduct bvi_to_dataTheory.compile_ind +Theorem get_code_labels_compile: + ∀a b c d e. get_code_labels (FST (compile a b c d e)) ⊆ + BIGUNION (set (MAP get_code_labels e)) +Proof + recInduct bvi_to_dataTheory.compile_ind \\ rw[bvi_to_dataTheory.compile_def] \\ rpt(pairarg_tac \\ fs[]) \\ fs[SUBSET_DEF] @@ -1720,11 +1737,13 @@ Theorem get_code_labels_compile \\ qmatch_asmsub_abbrev_tac`mk_ticks a b` \\ qspecl_then[`a`,`b`]mp_tac dataPropsTheory.get_code_labels_mk_ticks \\ simp[SUBSET_DEF] - \\ disch_then drule \\ rw[Abbr`b`,Abbr`a`]); + \\ disch_then drule \\ rw[Abbr`b`,Abbr`a`] +QED -Theorem compile_prog_good_code_labels - `∀p. good_code_labels p ⇒ good_code_labels (bvi_to_data$compile_prog p)` - (simp[bvi_to_dataTheory.compile_prog_def] +Theorem compile_prog_good_code_labels: + ∀p. good_code_labels p ⇒ good_code_labels (bvi_to_data$compile_prog p) +Proof + simp[bvi_to_dataTheory.compile_prog_def] \\ simp[dataPropsTheory.good_code_labels_def, MAP_MAP_o, o_DEF, LAMBDA_PROD] \\ simp[bvi_to_dataTheory.compile_part_def] \\ simp[FST_triple] @@ -1749,6 +1768,7 @@ Theorem compile_prog_good_code_labels \\ qspecl_then[`a`,`b`,`c`,`d`,`e`]mp_tac get_code_labels_compile \\ simp[SUBSET_DEF,Abbr`c`] \\ disch_then drule - \\ simp[Abbr`e`]); + \\ simp[Abbr`e`] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/bvl_constProofScript.sml b/compiler/backend/proofs/bvl_constProofScript.sml index 5c254c817d..63c1c1b5ac 100644 --- a/compiler/backend/proofs/bvl_constProofScript.sml +++ b/compiler/backend/proofs/bvl_constProofScript.sml @@ -20,10 +20,12 @@ val env_rel_def = Define ` v_rel (:'c) (:'ffi) a x y (x::e1) (y::e2) /\ env_rel (:'c) (:'ffi) rest e1 e2) /\ (env_rel _ _ _ _ _ = F)` -Theorem env_rel_length - `!ax env env2. env_rel (:'c) (:'ffi) ax env env2 ==> LENGTH env2 = LENGTH env` - (Induct \\ Cases_on `env` \\ Cases_on `env2` \\ fs [env_rel_def] - \\ Cases \\ fs [env_rel_def]); +Theorem env_rel_length: + !ax env env2. env_rel (:'c) (:'ffi) ax env env2 ==> LENGTH env2 = LENGTH env +Proof + Induct \\ Cases_on `env` \\ Cases_on `env2` \\ fs [env_rel_def] + \\ Cases \\ fs [env_rel_def] +QED val env_rel_LLOOKUP_NONE = Q.prove( `!ax env env2 n. @@ -45,14 +47,16 @@ val env_rel_LOOKUP_SOME = Q.prove( \\ first_x_assum match_mp_tac \\ Cases_on `h'` \\ fs [env_rel_def]); -Theorem evaluate_delete_var_Rerr_SING - `!x s r e env2. +Theorem evaluate_delete_var_Rerr_SING: + !x s r e env2. evaluate ([x],env2,s) = (Rerr e,r) /\ e <> Rabort Rtype_error ==> - evaluate ([bvl_const$delete_var x],env2,s) = (Rerr e,r)` - (Cases \\ fs [delete_var_def] + evaluate ([bvl_const$delete_var x],env2,s) = (Rerr e,r) +Proof + Cases \\ fs [delete_var_def] \\ fs [evaluate_def,do_app_def] \\ rw [] - \\ CCONTR_TAC \\ fs [] \\ rw []); + \\ CCONTR_TAC \\ fs [] \\ rw [] +QED val evaluate_delete_var_Rerr = Q.prove( `!xs s r e env2. @@ -99,12 +103,14 @@ val evaluate_delete_var_Rval = Q.prove( \\ fs [v_rel_def,NULL_EQ,evaluate_def,do_app_def] \\ every_case_tac \\ fs []); -Theorem evaluate_EQ_NIL - `bvlSem$evaluate (xs,env,s) = (Rval [],t) <=> xs = [] /\ s = t` - (mp_tac (Q.SPECL [`xs`,`env`,`s`] evaluate_LENGTH) +Theorem evaluate_EQ_NIL: + bvlSem$evaluate (xs,env,s) = (Rval [],t) <=> xs = [] /\ s = t +Proof + mp_tac (Q.SPECL [`xs`,`env`,`s`] evaluate_LENGTH) \\ every_case_tac \\ fs [] \\ rw [] \\ TRY eq_tac \\ fs [] \\ rw [] \\ fs [LENGTH_NIL] - \\ CCONTR_TAC \\ fs [] \\ fs [evaluate_def]); + \\ CCONTR_TAC \\ fs [] \\ fs [evaluate_def] +QED val dest_simple_eq = prove( ``dest_simple h = SOME y <=> (h = Op (Const y) [])``, @@ -180,27 +186,28 @@ val SmartOp2_thm = prove( \\ eq_tac \\ fs []); -Theorem SmartOp_thm - `evaluate ([Op op xs],env,s) = (res,s2) /\ +Theorem SmartOp_thm: + evaluate ([Op op xs],env,s) = (res,s2) /\ res ≠ Rerr (Rabort Rtype_error) ==> - evaluate ([SmartOp op xs],env,s) = (res,s2)` - - (simp [SmartOp_def] \\ + evaluate ([SmartOp op xs],env,s) = (res,s2) +Proof + simp [SmartOp_def] \\ every_case_tac \\ rename1 `Op op [x1; x2]` \\ Cases_on `SmartOp_flip op x1 x2` \\ Cases_on `r` \\ rename1 `SmartOp_flip op x1 x2 = (op', x1', x2')` \\ metis_tac [SmartOp_flip_thm, SmartOp2_thm] -) +QED -Theorem evaluate_env_rel - `!xs env1 (s1:('c,'ffi) bvlSem$state) ax env2 res s2 ys. +Theorem evaluate_env_rel: + !xs env1 (s1:('c,'ffi) bvlSem$state) ax env2 res s2 ys. (evaluate (xs,env1,s1) = (res,s2)) /\ env_rel (:'c) (:'ffi) ax env1 env2 /\ res <> Rerr (Rabort Rtype_error) ==> - (evaluate (compile ax xs,env2,s1) = (res,s2))` - (recInduct evaluate_ind \\ REPEAT STRIP_TAC + (evaluate (compile ax xs,env2,s1) = (res,s2)) +Proof + recInduct evaluate_ind \\ REPEAT STRIP_TAC \\ FULL_SIMP_TAC std_ss [compile_def,evaluate_def,compile_HD_SING] THEN1 (`?y0. compile ax [x] = [y0]` by @@ -255,46 +262,56 @@ Theorem evaluate_env_rel \\ fs [env_rel_def]) \\ TRY (match_mp_tac SmartOp_thm) \\ fs [evaluate_def] \\ every_case_tac \\ fs [] \\ rw [] \\ fs [] - \\ res_tac \\ fs [] \\ rw [] \\ fs [] \\ rw [] \\ fs []); + \\ res_tac \\ fs [] \\ rw [] \\ fs [] \\ rw [] \\ fs [] +QED val compile_thm = save_thm("compile_thm", evaluate_env_rel |> Q.SPECL [`xs`,`env`,`s1`,`[]`,`env`] |> GEN_ALL |> SIMP_RULE std_ss [env_rel_def]) -Theorem evaluate_compile_exp - `evaluate ([d],env,s) = (r,t) /\ +Theorem evaluate_compile_exp: + evaluate ([d],env,s) = (r,t) /\ r <> Rerr (Rabort Rtype_error) ==> - evaluate ([bvl_const$compile_exp d],env,s) = (r,t)` - (fs [compile_exp_def] + evaluate ([bvl_const$compile_exp d],env,s) = (r,t) +Proof + fs [compile_exp_def] \\ `LENGTH (compile [] [d]) = LENGTH [d]` by fs [compile_length] \\ Cases_on `compile [] [d]` \\ fs [LENGTH_NIL] \\ rw [] - \\ imp_res_tac compile_thm \\ rfs []); + \\ imp_res_tac compile_thm \\ rfs [] +QED -Theorem delete_var_code_labels[simp] - `∀x. get_code_labels (bvl_const$delete_var x) = get_code_labels x` - (recInduct bvl_constTheory.delete_var_ind +Theorem delete_var_code_labels[simp]: + ∀x. get_code_labels (bvl_const$delete_var x) = get_code_labels x +Proof + recInduct bvl_constTheory.delete_var_ind \\ rw[bvl_constTheory.delete_var_def] - \\ EVAL_TAC); - -Theorem dest_simple_SOME_code_labels - `∀x y. dest_simple x = SOME y ⇒ get_code_labels x = {}` - (recInduct bvl_constTheory.dest_simple_ind - \\ rw[NULL_EQ] \\ EVAL_TAC); - -Theorem SmartOp2_code_labels[simp] - `get_code_labels (SmartOp2 (op,x1,x2)) = - closLang$assign_get_code_label op ∪ get_code_labels x1 ∪ get_code_labels x2` - (rw[bvl_constTheory.SmartOp2_def, closLangTheory.assign_get_code_label_def] + \\ EVAL_TAC +QED + +Theorem dest_simple_SOME_code_labels: + ∀x y. dest_simple x = SOME y ⇒ get_code_labels x = {} +Proof + recInduct bvl_constTheory.dest_simple_ind + \\ rw[NULL_EQ] \\ EVAL_TAC +QED + +Theorem SmartOp2_code_labels[simp]: + get_code_labels (SmartOp2 (op,x1,x2)) = + closLang$assign_get_code_label op ∪ get_code_labels x1 ∪ get_code_labels x2 +Proof + rw[bvl_constTheory.SmartOp2_def, closLangTheory.assign_get_code_label_def] \\ rpt(PURE_CASE_TAC \\ simp[closLangTheory.assign_get_code_label_def]) \\ imp_res_tac dest_simple_SOME_code_labels \\ fs[] \\ fs[bvl_constTheory.case_op_const_def, CaseEq"option", CaseEq"closLang$op", CaseEq"bvl$exp", CaseEq"list", NULL_EQ] \\ rveq \\ fs[closLangTheory.assign_get_code_label_def,bvlTheory.Bool_def] - \\ simp[EXTENSION] \\ metis_tac[]); + \\ simp[EXTENSION] \\ metis_tac[] +QED -Theorem SmartOp_code_labels[simp] - `get_code_labels (SmartOp op xs) = closLang$assign_get_code_label op ∪ BIGUNION (set (MAP get_code_labels xs))` - (rw[bvl_constTheory.SmartOp_def] +Theorem SmartOp_code_labels[simp]: + get_code_labels (SmartOp op xs) = closLang$assign_get_code_label op ∪ BIGUNION (set (MAP get_code_labels xs)) +Proof + rw[bvl_constTheory.SmartOp_def] \\ PURE_CASE_TAC \\ simp[] \\ PURE_CASE_TAC \\ simp[] \\ PURE_CASE_TAC \\ simp[] @@ -302,23 +319,27 @@ Theorem SmartOp_code_labels[simp] \\ PURE_TOP_CASE_TAC \\ fs[] >- ( rw[EXTENSION] \\ metis_tac[] ) \\ imp_res_tac dest_simple_SOME_code_labels - \\ rw[closLangTheory.assign_get_code_label_def]); + \\ rw[closLangTheory.assign_get_code_label_def] +QED -Theorem MEM_extract_list_code_labels - `∀xs x. MEM (SOME x) (extract_list xs) ⇒ get_code_labels x = {}` - (Induct +Theorem MEM_extract_list_code_labels: + ∀xs x. MEM (SOME x) (extract_list xs) ⇒ get_code_labels x = {} +Proof + Induct \\ rw[bvl_constTheory.extract_list_def] \\ res_tac \\ fs[] \\ Cases_on`h` \\ fs[bvl_constTheory.extract_def] \\ rename1`Op op l` \\ Cases_on`op` \\ fs[bvl_constTheory.extract_def] \\ rw[] - \\ EVAL_TAC); + \\ EVAL_TAC +QED -Theorem compile_code_labels - `∀x y. BIGUNION (set (MAP get_code_labels (bvl_const$compile x y))) ⊆ +Theorem compile_code_labels: + ∀x y. BIGUNION (set (MAP get_code_labels (bvl_const$compile x y))) ⊆ BIGUNION (set (MAP get_code_labels y)) ∪ - BIGUNION (set (MAP (get_code_labels o THE) (FILTER IS_SOME x)))` - (recInduct bvl_constTheory.compile_ind + BIGUNION (set (MAP (get_code_labels o THE) (FILTER IS_SOME x))) +Proof + recInduct bvl_constTheory.compile_ind \\ rw[bvl_constTheory.compile_def] \\ fsrw_tac[DNF_ss][SUBSET_DEF] \\ fs[Once(GSYM bvl_constTheory.compile_HD_SING)] @@ -341,13 +362,16 @@ Theorem compile_code_labels \\ reverse(fs[MEM_MAP, PULL_EXISTS, MEM_FILTER, IS_SOME_EXISTS]) >- metis_tac[] \\ imp_res_tac MEM_extract_list_code_labels - \\ fs[])); + \\ fs[]) +QED -Theorem compile_exp_code_labels - `∀e. get_code_labels (bvl_const$compile_exp e) ⊆ get_code_labels e` - (rw[bvl_constTheory.compile_exp_def] +Theorem compile_exp_code_labels: + ∀e. get_code_labels (bvl_const$compile_exp e) ⊆ get_code_labels e +Proof + rw[bvl_constTheory.compile_exp_def] \\ rw[Once(GSYM bvl_constTheory.compile_HD_SING)] \\ specl_args_of_then``bvl_const$compile``compile_code_labels mp_tac - \\ rw[] \\ fs[Once(GSYM bvl_constTheory.compile_HD_SING)]); + \\ rw[] \\ fs[Once(GSYM bvl_constTheory.compile_HD_SING)] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/bvl_handleProofScript.sml b/compiler/backend/proofs/bvl_handleProofScript.sml index 5bd0c4cc06..123c5ee4bf 100644 --- a/compiler/backend/proofs/bvl_handleProofScript.sml +++ b/compiler/backend/proofs/bvl_handleProofScript.sml @@ -7,9 +7,11 @@ val _ = new_theory"bvl_handleProof"; val _ = set_grammar_ancestry["bvlSem","bvl_handle","bvlProps"]; -Theorem evaluate_SmartLet[simp] - `bvlSem$evaluate ([SmartLet xs x],env,s) = evaluate ([Let xs x],env,s)` - (rw [SmartLet_def] \\ fs [NULL_EQ,evaluate_def]); +Theorem evaluate_SmartLet[simp]: + bvlSem$evaluate ([SmartLet xs x],env,s) = evaluate ([Let xs x],env,s) +Proof + rw [SmartLet_def] \\ fs [NULL_EQ,evaluate_def] +QED val let_ok_def = Define ` (let_ok (Let xs b) <=> EVERY isVar xs /\ bVarBound (LENGTH xs) [b]) /\ @@ -50,47 +52,58 @@ val env_rel_def = Define ` env_rel l env env1 = LIST_RELi (\i v1 v2. has_var i l ==> v1 = v2) env env1` -Theorem env_rel_mk_Union - `!env env1. env_rel (mk_Union lx ly) env env1 <=> - env_rel lx env env1 /\ env_rel ly env env1` - (fs [LIST_RELi_EL_EQN,env_rel_def] \\ metis_tac []); - -Theorem env_rel_length - `env_rel l env env1 ==> LENGTH env1 = LENGTH env` - (fs [LIST_RELi_EL_EQN,env_rel_def]); - -Theorem env_rel_MAPi - `env_rel l1 env (MAPi (\i v. if has_var i l1 then v else Number 0) env)` - (fs [LIST_RELi_EL_EQN,env_rel_def]); - -Theorem IMP_EL_SING - `k = LENGTH xs ==> EL k (xs ++ [x] ++ ys) = x` - (rw [] \\ fs [] \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,APPEND] - \\ fs [EL_APPEND2]); - -Theorem ALOOKUP_MAPi_SWAP - `!z n k xs. +Theorem env_rel_mk_Union: + !env env1. env_rel (mk_Union lx ly) env env1 <=> + env_rel lx env env1 /\ env_rel ly env env1 +Proof + fs [LIST_RELi_EL_EQN,env_rel_def] \\ metis_tac [] +QED + +Theorem env_rel_length: + env_rel l env env1 ==> LENGTH env1 = LENGTH env +Proof + fs [LIST_RELi_EL_EQN,env_rel_def] +QED + +Theorem env_rel_MAPi: + env_rel l1 env (MAPi (\i v. if has_var i l1 then v else Number 0) env) +Proof + fs [LIST_RELi_EL_EQN,env_rel_def] +QED + +Theorem IMP_EL_SING: + k = LENGTH xs ==> EL k (xs ++ [x] ++ ys) = x +Proof + rw [] \\ fs [] \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,APPEND] + \\ fs [EL_APPEND2] +QED + +Theorem ALOOKUP_MAPi_SWAP = Q.prove(` + !z n k xs. n <> k ==> ALOOKUP (MAPi (λi x. (x,i+z)) (xs ++ [k])) n = - ALOOKUP (MAPi (λi x. (x,i+z)) xs) n` - (Induct_on `xs` \\ fs [o_DEF,ADD1]) |> Q.SPEC `0` |> SIMP_RULE std_ss []; + ALOOKUP (MAPi (λi x. (x,i+z)) xs) n`, + Induct_on `xs` \\ fs [o_DEF,ADD1]) |> Q.SPEC `0` |> SIMP_RULE std_ss []; -Theorem ALOOKUP_MAPi_APPEND2 - `!z xs k. +Theorem ALOOKUP_MAPi_APPEND2 = Q.prove(` + !z xs k. ~MEM k xs ==> - ALOOKUP (MAPi (λi x. (x,i+z)) (xs ++ [k])) k = SOME (LENGTH xs + z)` - (Induct_on `xs` \\ fs [o_DEF,ADD1]) |> Q.SPEC `0` |> SIMP_RULE std_ss []; + ALOOKUP (MAPi (λi x. (x,i+z)) (xs ++ [k])) k = SOME (LENGTH xs + z)`, + Induct_on `xs` \\ fs [o_DEF,ADD1]) |> Q.SPEC `0` |> SIMP_RULE std_ss []; -Theorem IS_SOME_lookup_db_to_set - `!n. IS_SOME (lookup n (db_to_set l)) = has_var n l` - (fs [db_varsTheory.lookup_db_to_set,IS_SOME_EXISTS]); +Theorem IS_SOME_lookup_db_to_set: + !n. IS_SOME (lookup n (db_to_set l)) = has_var n l +Proof + fs [db_varsTheory.lookup_db_to_set,IS_SOME_EXISTS] +QED -Theorem evaluate_LetLet - `(∀env2 extra. +Theorem evaluate_LetLet: + (∀env2 extra. env_rel l1 env env2 ==> evaluate ([y],env2 ++ extra,s1) = res) /\ env_rel l1 env env1 ==> - evaluate ([LetLet (LENGTH env) (db_to_set l1) y],env1 ++ extra,s1) = res` - (fs [LetLet_def] \\ rw [o_DEF] \\ fs [Once evaluate_def] + evaluate ([LetLet (LENGTH env) (db_to_set l1) y],env1 ++ extra,s1) = res +Proof + fs [LetLet_def] \\ rw [o_DEF] \\ fs [Once evaluate_def] \\ qabbrev_tac `qs = (FILTER (λn. has_var n l1) (GENLIST I (LENGTH env)))` \\ `evaluate (MAP Var qs,env1 ++ extra,s1) = @@ -141,11 +154,14 @@ Theorem evaluate_LetLet \\ fs [MEM_FILTER,MEM_GENLIST,ALOOKUP_NONE,o_DEF,MAPi_ID] \\ NO_TAC) \\ fs [] \\ reverse (Cases_on `has_var (LENGTH env) l1`) \\ fs [] \\ fs [evaluate_def,do_app_def,MAPi_def,MAPi_APPEND] - \\ fs [EL_APPEND2] \\ match_mp_tac IMP_EL_SING \\ fs []); + \\ fs [EL_APPEND2] \\ match_mp_tac IMP_EL_SING \\ fs [] +QED -Theorem env_rel_refl - `env_rel l env env` - (fs [LIST_RELi_EL_EQN,env_rel_def]); +Theorem env_rel_refl: + env_rel l env env +Proof + fs [LIST_RELi_EL_EQN,env_rel_def] +QED val opt_lemma = Q.prove( `x = y <=> (x = SOME () <=> y = SOME ())`, @@ -166,25 +182,29 @@ val OptionalLetLet_IMP = Q.prove( \\ rewrite_tac [GSYM db_varsTheory.lookup_db_to_set] \\ fs []); -Theorem OptionalLetLet_limit - `(ys,l,s',nr') = OptionalLetLet e (LENGTH env) lx s1 limit nr /\ - env_rel l env env1 ==> env_rel lx env env1` - (rw [OptionalLetLet_def,GSYM db_varsTheory.vars_to_list_def, - GSYM db_varsTheory.vars_flatten_def,env_rel_def] \\ fs []); - -Theorem OptionalLetLet_nr - `(ys,l,s',nr') = OptionalLetLet e (LENGTH env) lx s1 limit nr ==> - nr' = nr` - (rw [OptionalLetLet_def,GSYM db_varsTheory.vars_to_list_def, - GSYM db_varsTheory.vars_flatten_def,env_rel_def] \\ fs []); - -Theorem compile_correct - `!xs env s1 ys env1 res s2 extra l s nr. +Theorem OptionalLetLet_limit: + (ys,l,s',nr') = OptionalLetLet e (LENGTH env) lx s1 limit nr /\ + env_rel l env env1 ==> env_rel lx env env1 +Proof + rw [OptionalLetLet_def,GSYM db_varsTheory.vars_to_list_def, + GSYM db_varsTheory.vars_flatten_def,env_rel_def] \\ fs [] +QED + +Theorem OptionalLetLet_nr: + (ys,l,s',nr') = OptionalLetLet e (LENGTH env) lx s1 limit nr ==> + nr' = nr +Proof + rw [OptionalLetLet_def,GSYM db_varsTheory.vars_to_list_def, + GSYM db_varsTheory.vars_flatten_def,env_rel_def] \\ fs [] +QED + +Theorem compile_correct = Q.prove(` + !xs env s1 ys env1 res s2 extra l s nr. compile limit (LENGTH env) xs = (ys,l,s,nr) /\ env_rel l env env1 /\ (evaluate (xs,env,s1) = (res,s2)) /\ res <> Rerr(Rabort Rtype_error) ==> (evaluate (ys,env1 ++ extra,s1) = (res,s2)) /\ - (nr ==> !e. res <> Rerr (Rraise e))` - (SIMP_TAC std_ss [Once EQ_SYM_EQ] + (nr ==> !e. res <> Rerr (Rraise e))`, + SIMP_TAC std_ss [Once EQ_SYM_EQ] \\ recInduct evaluate_ind \\ rpt conj_tac \\ rpt gen_tac \\ strip_tac \\ FULL_SIMP_TAC std_ss [compile_def,evaluate_def] \\ fs [LET_THM] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [env_rel_mk_Union] @@ -292,25 +312,29 @@ Theorem compile_correct val _ = save_thm("compile_correct",compile_correct); -Theorem compile_correct - `(evaluate ([x],env,s1) = (res,s2)) /\ res <> Rerr(Rabort Rtype_error) /\ +Theorem compile_correct: + (evaluate ([x],env,s1) = (res,s2)) /\ res <> Rerr(Rabort Rtype_error) /\ k = LENGTH env ==> - (evaluate ([compile_exp l k x],env,s1) = (res,s2))` - (fs [compile_exp_def] + (evaluate ([compile_exp l k x],env,s1) = (res,s2)) +Proof + fs [compile_exp_def] \\ Cases_on `compile l (LENGTH env) [bvl_const$compile_exp x]` \\ PairCases_on `r` \\ rw [] \\ drule bvl_constProofTheory.evaluate_compile_exp \\ fs [] \\ rw [] \\ drule compile_sing \\ rw [] - \\ drule compile_correct \\ fs []); - -Theorem dest_Seq_thm - `!x. dest_Seq x = SOME (y0,y1) <=> - x = Let [y0;y1] (Var 1)` - (ho_match_mp_tac dest_Seq_ind \\ fs [] \\ rw [] \\ EVAL_TAC - \\ rw [] \\ eq_tac \\ rw []); - -Theorem compile_seqs_correct - `!l x acc s1 s2 s3 res res3. + \\ drule compile_correct \\ fs [] +QED + +Theorem dest_Seq_thm: + !x. dest_Seq x = SOME (y0,y1) <=> + x = Let [y0;y1] (Var 1) +Proof + ho_match_mp_tac dest_Seq_ind \\ fs [] \\ rw [] \\ EVAL_TAC + \\ rw [] \\ eq_tac \\ rw [] +QED + +Theorem compile_seqs_correct: + !l x acc s1 s2 s3 res res3. evaluate ([x],[],s1) = (res,s2) /\ (!y r. acc = SOME y /\ res = Rval r ==> res3 <> Rerr (Rabort Rtype_error) /\ @@ -318,8 +342,9 @@ Theorem compile_seqs_correct res <> Rerr (Rabort Rtype_error) ==> evaluate ([compile_seqs l x acc],[],s1) = if acc = NONE then (res,s2) else - case res of Rval _ => (res3,s3) | _ => (res,s2)` - (HO_MATCH_MP_TAC compile_seqs_ind \\ rpt strip_tac + case res of Rval _ => (res3,s3) | _ => (res,s2) +Proof + HO_MATCH_MP_TAC compile_seqs_ind \\ rpt strip_tac \\ once_rewrite_tac [compile_seqs_def] \\ Cases_on `dest_Seq x` \\ fs [] THEN1 @@ -348,93 +373,121 @@ Theorem compile_seqs_correct \\ strip_tac \\ rveq \\ fs [] \\ rveq \\ fs [] \\ qpat_x_assum `!x1 x2 x3 x4. _` kall_tac \\ first_x_assum drule \\ fs [] - \\ Cases_on `acc` \\ fs []); + \\ Cases_on `acc` \\ fs [] +QED -Theorem compile_any_correct - `(evaluate ([x],env,s1) = (res,s2)) /\ res <> Rerr(Rabort Rtype_error) /\ +Theorem compile_any_correct: + (evaluate ([x],env,s1) = (res,s2)) /\ res <> Rerr(Rabort Rtype_error) /\ k = LENGTH env ==> - (evaluate ([compile_any split_seq l k x],env,s1) = (res,s2))` - (rw [compile_any_def,compile_correct] \\ fs [LENGTH_NIL] \\ rw [] + (evaluate ([compile_any split_seq l k x],env,s1) = (res,s2)) +Proof + rw [compile_any_def,compile_correct] \\ fs [LENGTH_NIL] \\ rw [] \\ drule compile_seqs_correct - \\ disch_then (qspecl_then [`l`,`NONE`] mp_tac) \\ fs []); - -Theorem compile_IMP_LENGTH - `compile l n xs = (ys,l1,s1) ==> LENGTH ys = LENGTH xs` - (rw [] \\ mp_tac (SPEC_ALL compile_length) \\ asm_simp_tac std_ss []); - -Theorem bVarBound_CONS - `bVarBound m [x] /\ bVarBound m xs ==> bVarBound m (x::xs)` - (Cases_on `xs` \\ fs []); - -Theorem bVarBound_MEM - `bVarBound n xs <=> !x. MEM x xs ==> bVarBound n [x]` - (fs [Once bVarBound_EVERY,EVERY_MEM]); - -Theorem bEvery_MEM - `bEvery p xs = !x. MEM x xs ==> bEvery p [x]` - (fs [Once bEvery_EVERY,EVERY_MEM]); - -Theorem bVarBound_LESS_EQ - `!m xs n. bVarBound m xs /\ m <= n ==> bVarBound n xs` - (HO_MATCH_MP_TAC bVarBound_ind \\ rw [] \\ fs []); - -Theorem ALOOKUP_MAPi - `!xs i x. - ALOOKUP (MAPi (λi x. (x,i)) xs) n = SOME x ==> x < LENGTH xs` - (HO_MATCH_MP_TAC SNOC_INDUCT \\ rw [] + \\ disch_then (qspecl_then [`l`,`NONE`] mp_tac) \\ fs [] +QED + +Theorem compile_IMP_LENGTH: + compile l n xs = (ys,l1,s1) ==> LENGTH ys = LENGTH xs +Proof + rw [] \\ mp_tac (SPEC_ALL compile_length) \\ asm_simp_tac std_ss [] +QED + +Theorem bVarBound_CONS: + bVarBound m [x] /\ bVarBound m xs ==> bVarBound m (x::xs) +Proof + Cases_on `xs` \\ fs [] +QED + +Theorem bVarBound_MEM: + bVarBound n xs <=> !x. MEM x xs ==> bVarBound n [x] +Proof + fs [Once bVarBound_EVERY,EVERY_MEM] +QED + +Theorem bEvery_MEM: + bEvery p xs = !x. MEM x xs ==> bEvery p [x] +Proof + fs [Once bEvery_EVERY,EVERY_MEM] +QED + +Theorem bVarBound_LESS_EQ: + !m xs n. bVarBound m xs /\ m <= n ==> bVarBound n xs +Proof + HO_MATCH_MP_TAC bVarBound_ind \\ rw [] \\ fs [] +QED + +Theorem ALOOKUP_MAPi: + !xs i x. + ALOOKUP (MAPi (λi x. (x,i)) xs) n = SOME x ==> x < LENGTH xs +Proof + HO_MATCH_MP_TAC SNOC_INDUCT \\ rw [] \\ fs [SNOC_APPEND,MAPi_APPEND,ALOOKUP_APPEND] - \\ every_case_tac \\ fs []); - -Theorem bVarBound_SmartLet[simp] - `bVarBound m [SmartLet x xs] = bVarBound m [Let x xs]` - (rw [SmartLet_def] \\ fs [NULL_EQ]); - -Theorem bVarBound_LetLet - `bVarBound m [y] /\ n <= m ==> bVarBound m [LetLet n (l1:num_set) y]` - (fs [LetLet_def] \\ strip_tac + \\ every_case_tac \\ fs [] +QED + +Theorem bVarBound_SmartLet[simp]: + bVarBound m [SmartLet x xs] = bVarBound m [Let x xs] +Proof + rw [SmartLet_def] \\ fs [NULL_EQ] +QED + +Theorem bVarBound_LetLet: + bVarBound m [y] /\ n <= m ==> bVarBound m [LetLet n (l1:num_set) y] +Proof + fs [LetLet_def] \\ strip_tac \\ once_rewrite_tac [bVarBound_MEM] \\ fs [MEM_MAP,MEM_GENLIST,PULL_EXISTS,MEM_FILTER] \\ reverse conj_tac THEN1 (match_mp_tac bVarBound_LESS_EQ \\ asm_exists_tac \\ fs []) \\ rw [] \\ every_case_tac \\ fs [] \\ qabbrev_tac `xs = FILTER (λn. IS_SOME (lookup n l1)) (GENLIST I n)` - \\ imp_res_tac ALOOKUP_MAPi \\ fs []); - -Theorem bVarBound_OptionalLetLet - `bVarBound m [e] /\ n <= m ==> - bVarBound m (FST (OptionalLetLet e n l s limit nr))` - (rw [OptionalLetLet_def,bVarBound_LetLet]); - -Theorem bVarBound_compile - `∀l n xs m. n ≤ m ⇒ bVarBound m (FST (compile l n xs))` - (ho_match_mp_tac compile_ind \\ rw [] \\ fs [compile_def] + \\ imp_res_tac ALOOKUP_MAPi \\ fs [] +QED + +Theorem bVarBound_OptionalLetLet: + bVarBound m [e] /\ n <= m ==> + bVarBound m (FST (OptionalLetLet e n l s limit nr)) +Proof + rw [OptionalLetLet_def,bVarBound_LetLet] +QED + +Theorem bVarBound_compile: + ∀l n xs m. n ≤ m ⇒ bVarBound m (FST (compile l n xs)) +Proof + ho_match_mp_tac compile_ind \\ rw [] \\ fs [compile_def] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ imp_res_tac compile_sing \\ rw [] \\ res_tac \\ imp_res_tac bVarBound_CONS \\ fs [] \\ TRY (first_x_assum match_mp_tac) \\ fs [] \\ imp_res_tac compile_IMP_LENGTH \\ fs [] \\ imp_res_tac bVarBound_LetLet \\ fs [] - \\ match_mp_tac bVarBound_OptionalLetLet \\ fs []); - -Theorem compile_IMP_bVarBound - `compile l n xs = (ys,l2,s2) ==> bVarBound n ys` - (rw [] \\ mp_tac (Q.INST [`m`|->`n`] (SPEC_ALL bVarBound_compile)) \\ fs []); - -Theorem compile_exp_bVarBound - `bVarBound n [compile_exp l n x]` - (fs [compile_exp_def] + \\ match_mp_tac bVarBound_OptionalLetLet \\ fs [] +QED + +Theorem compile_IMP_bVarBound: + compile l n xs = (ys,l2,s2) ==> bVarBound n ys +Proof + rw [] \\ mp_tac (Q.INST [`m`|->`n`] (SPEC_ALL bVarBound_compile)) \\ fs [] +QED + +Theorem compile_exp_bVarBound: + bVarBound n [compile_exp l n x] +Proof + fs [compile_exp_def] \\ Cases_on `compile l n [bvl_const$compile_exp x]` \\ Cases_on `r` \\ fs [] \\ drule compile_IMP_bVarBound \\ drule compile_IMP_LENGTH \\ Cases_on `q` \\ fs [] - \\ Cases_on `t` \\ fs []); + \\ Cases_on `t` \\ fs [] +QED -Theorem compile_seqs_bVarBound - `!l x acc. +Theorem compile_seqs_bVarBound: + !l x acc. (!y. acc = SOME y ==> bVarBound 0 [y]) ==> - bVarBound 0 [compile_seqs l x acc]` - (HO_MATCH_MP_TAC compile_seqs_ind \\ rw [] + bVarBound 0 [compile_seqs l x acc] +Proof + HO_MATCH_MP_TAC compile_seqs_ind \\ rw [] \\ once_rewrite_tac [compile_seqs_def] \\ Cases_on `dest_Seq x` \\ fs [] THEN1 @@ -442,25 +495,33 @@ Theorem compile_seqs_bVarBound \\ match_mp_tac bVarBound_LESS_EQ \\ asm_exists_tac \\ fs []) \\ rename1 `dest_Seq x = SOME y` \\ PairCases_on `y` - \\ fs [] \\ first_x_assum match_mp_tac \\ fs []); - -Theorem bEvery_CONS - `bEvery p [x] /\ bEvery p xs ==> bEvery p (x::xs)` - (Cases_on `xs` \\ fs []); - -Theorem handle_ok_Var_Const_list - `EVERY (\x. ?v i. x = Var v \/ x = Op (Const i) []) xs ==> handle_ok xs` - (Induct_on `xs` \\ fs [handle_ok_def,PULL_EXISTS] \\ rw [] - \\ Cases_on `xs` \\ fs [handle_ok_def]); - -Theorem handle_ok_SmartLet - `handle_ok [SmartLet xs x] <=> handle_ok xs /\ handle_ok [x]` - (rw [SmartLet_def,handle_ok_def] \\ fs [NULL_EQ,LENGTH_NIL,handle_ok_def]); - -Theorem handle_ok_OptionalLetLet - `handle_ok [e] /\ bVarBound n [e] ==> - handle_ok (FST (OptionalLetLet e n lx s l nr))` - (rw [OptionalLetLet_def] \\ fs [handle_ok_def] + \\ fs [] \\ first_x_assum match_mp_tac \\ fs [] +QED + +Theorem bEvery_CONS: + bEvery p [x] /\ bEvery p xs ==> bEvery p (x::xs) +Proof + Cases_on `xs` \\ fs [] +QED + +Theorem handle_ok_Var_Const_list: + EVERY (\x. ?v i. x = Var v \/ x = Op (Const i) []) xs ==> handle_ok xs +Proof + Induct_on `xs` \\ fs [handle_ok_def,PULL_EXISTS] \\ rw [] + \\ Cases_on `xs` \\ fs [handle_ok_def] +QED + +Theorem handle_ok_SmartLet: + handle_ok [SmartLet xs x] <=> handle_ok xs /\ handle_ok [x] +Proof + rw [SmartLet_def,handle_ok_def] \\ fs [NULL_EQ,LENGTH_NIL,handle_ok_def] +QED + +Theorem handle_ok_OptionalLetLet: + handle_ok [e] /\ bVarBound n [e] ==> + handle_ok (FST (OptionalLetLet e n lx s l nr)) +Proof + rw [OptionalLetLet_def] \\ fs [handle_ok_def] \\ reverse conj_tac THEN1 (fs [LetLet_def,handle_ok_SmartLet] \\ match_mp_tac handle_ok_Var_Const_list @@ -472,11 +533,13 @@ Theorem handle_ok_OptionalLetLet \\ fs [MEM_GENLIST,PULL_EXISTS] \\ rw [] \\ every_case_tac \\ fs [] \\ imp_res_tac ALOOKUP_MAPi \\ fs []) - \\ match_mp_tac bVarBound_LESS_EQ \\ asm_exists_tac \\ fs []); + \\ match_mp_tac bVarBound_LESS_EQ \\ asm_exists_tac \\ fs [] +QED -Theorem compile_handle_ok - `∀l n xs. handle_ok (FST (compile l n xs))` - (ho_match_mp_tac compile_ind \\ rw [] +Theorem compile_handle_ok: + ∀l n xs. handle_ok (FST (compile l n xs)) +Proof + ho_match_mp_tac compile_ind \\ rw [] \\ fs [compile_def,handle_ok_def] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ imp_res_tac compile_sing \\ rw [] \\ res_tac @@ -503,22 +566,26 @@ Theorem compile_handle_ok \\ rpt (pop_assum kall_tac) \\ match_mp_tac handle_ok_Var_Const_list \\ fs [EVERY_GENLIST] - \\ rw [] \\ every_case_tac \\ fs []); + \\ rw [] \\ every_case_tac \\ fs [] +QED -Theorem compile_exp_handle_ok - `handle_ok [compile_exp l n x]` - (fs [bvl_handleTheory.compile_exp_def] +Theorem compile_exp_handle_ok: + handle_ok [compile_exp l n x] +Proof + fs [bvl_handleTheory.compile_exp_def] \\ Cases_on `compile l n [bvl_const$compile_exp x]` \\ fs [] \\ PairCases_on `r` \\ imp_res_tac bvl_handleTheory.compile_sing \\ fs [] \\ qspecl_then [`l`,`n`,`[bvl_const$compile_exp x]`] mp_tac compile_handle_ok - \\ fs []); + \\ fs [] +QED -Theorem compile_seqs_handle_ok - `!l x acc. +Theorem compile_seqs_handle_ok: + !l x acc. (!y. acc = SOME y ==> handle_ok [y] /\ bVarBound 0 [y]) ==> - handle_ok [compile_seqs l x acc]` - (HO_MATCH_MP_TAC compile_seqs_ind \\ rw [] + handle_ok [compile_seqs l x acc] +Proof + HO_MATCH_MP_TAC compile_seqs_ind \\ rw [] \\ once_rewrite_tac [compile_seqs_def] \\ Cases_on `dest_Seq x` \\ fs [] THEN1 @@ -527,63 +594,78 @@ Theorem compile_seqs_handle_ok \\ fs [let_ok_def]) \\ rename1 `dest_Seq x = SOME y` \\ PairCases_on `y` \\ fs [] \\ first_x_assum match_mp_tac \\ fs [] - \\ match_mp_tac compile_seqs_bVarBound \\ fs []); - -Theorem compile_any_handle_ok - `handle_ok [compile_any split_seq l n x]` - (rw [compile_any_def,compile_exp_handle_ok] - \\ match_mp_tac compile_seqs_handle_ok \\ fs []); - -Theorem handle_ok_CONS - `!x xs. handle_ok (x::xs) <=> handle_ok [x] /\ handle_ok xs` - (Cases_on `xs` \\ fs [handle_ok_def]); - -Theorem handle_ok_EVERY - `!xs. handle_ok xs <=> EVERY (\x. handle_ok [x]) xs` - (Induct \\ fs [handle_ok_def] \\ simp [Once handle_ok_CONS] \\ fs []); - -Theorem LetLet_code_labels[simp] - `get_code_labels (LetLet x y z) = get_code_labels z` - (rw[bvl_handleTheory.LetLet_def] + \\ match_mp_tac compile_seqs_bVarBound \\ fs [] +QED + +Theorem compile_any_handle_ok: + handle_ok [compile_any split_seq l n x] +Proof + rw [compile_any_def,compile_exp_handle_ok] + \\ match_mp_tac compile_seqs_handle_ok \\ fs [] +QED + +Theorem handle_ok_CONS: + !x xs. handle_ok (x::xs) <=> handle_ok [x] /\ handle_ok xs +Proof + Cases_on `xs` \\ fs [handle_ok_def] +QED + +Theorem handle_ok_EVERY: + !xs. handle_ok xs <=> EVERY (\x. handle_ok [x]) xs +Proof + Induct \\ fs [handle_ok_def] \\ simp [Once handle_ok_CONS] \\ fs [] +QED + +Theorem LetLet_code_labels[simp]: + get_code_labels (LetLet x y z) = get_code_labels z +Proof + rw[bvl_handleTheory.LetLet_def] \\ rw[bvl_handleTheory.SmartLet_def, MAP_MAP_o, o_DEF, MAP_GENLIST] \\ rw[Once EXTENSION, MEM_FILTER, MEM_MAP, MEM_GENLIST, PULL_EXISTS, PULL_FORALL] \\ rw[EQ_IMP_THM] \\ rpt(pop_assum mp_tac) \\ TOP_CASE_TAC \\ fs[] - \\ EVAL_TAC); - -Theorem compile_code_labels - `∀a b c. BIGUNION (set (MAP get_code_labels (FST (bvl_handle$compile a b c)))) ⊆ - BIGUNION (set (MAP get_code_labels c))` - (recInduct bvl_handleTheory.compile_ind + \\ EVAL_TAC +QED + +Theorem compile_code_labels: + ∀a b c. BIGUNION (set (MAP get_code_labels (FST (bvl_handle$compile a b c)))) ⊆ + BIGUNION (set (MAP get_code_labels c)) +Proof + recInduct bvl_handleTheory.compile_ind \\ rw[bvl_handleTheory.compile_def] \\ rpt (pairarg_tac \\ fs[]) \\ imp_res_tac bvl_handleTheory.compile_sing \\ rveq \\ fs[NULL_EQ] \\ rw[bvl_handleTheory.OptionalLetLet_def] \\ fs[] \\ fsrw_tac[DNF_ss][SUBSET_DEF] - \\ EVAL_TAC); + \\ EVAL_TAC +QED -Theorem compile_exp_code_labels - `∀a b c. get_code_labels (compile_exp a b c) ⊆ get_code_labels c ` - (rw[bvl_handleTheory.compile_exp_def] +Theorem compile_exp_code_labels: + ∀a b c. get_code_labels (compile_exp a b c) ⊆ get_code_labels c +Proof + rw[bvl_handleTheory.compile_exp_def] \\ Cases_on`bvl_handle$compile a b [compile_exp c]` \\ PairCases_on`r` \\ imp_res_tac bvl_handleTheory.compile_sing \\ rveq \\ fs[] \\ pop_assum mp_tac \\ specl_args_of_then``bvl_handle$compile``compile_code_labels mp_tac \\ rw[] \\ fs[] - \\ metis_tac[bvl_constProofTheory.compile_exp_code_labels, SUBSET_TRANS]); + \\ metis_tac[bvl_constProofTheory.compile_exp_code_labels, SUBSET_TRANS] +QED -Theorem compile_seqs_code_labels - `!cut e acc. +Theorem compile_seqs_code_labels: + !cut e acc. get_code_labels (compile_seqs cut e acc) SUBSET get_code_labels e UNION - (case acc of NONE => {} | SOME r => get_code_labels r)` - (ho_match_mp_tac bvl_handleTheory.compile_seqs_ind \\ rw [] + (case acc of NONE => {} | SOME r => get_code_labels r) +Proof + ho_match_mp_tac bvl_handleTheory.compile_seqs_ind \\ rw [] \\ rw [Once bvl_handleTheory.compile_seqs_def] \\ rpt (PURE_TOP_CASE_TAC \\ fs []) \\ rw [] \\ fs [dest_Seq_thm] \\ rw [] - \\ metis_tac [compile_exp_code_labels, SUBSET_UNION, SUBSET_TRANS, UNION_SUBSET]); + \\ metis_tac [compile_exp_code_labels, SUBSET_UNION, SUBSET_TRANS, UNION_SUBSET] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/bvl_inlineProofScript.sml b/compiler/backend/proofs/bvl_inlineProofScript.sml index af556bebee..b3dca71c9b 100644 --- a/compiler/backend/proofs/bvl_inlineProofScript.sml +++ b/compiler/backend/proofs/bvl_inlineProofScript.sml @@ -76,13 +76,14 @@ val do_app_lemma = prove( \\ qpat_x_assum `r = _` (assume_tac o GSYM) \\ fs [] \\ impl_tac THEN1 fs [domain_map] \\ fs []); -Theorem evaluate_remove_ticks - `!k xs env s (t:('c,'ffi) bvlSem$state) res s'. +Theorem evaluate_remove_ticks: + !k xs env s (t:('c,'ffi) bvlSem$state) res s'. state_rel t s /\ s.clock = k /\ evaluate (remove_ticks xs,env,s) = (res,s') ==> ?ck t'. evaluate (xs,env,t with clock := t.clock + ck) = (res,t') /\ - state_rel t' s'` - (strip_tac \\ completeInduct_on `k` \\ fs [PULL_FORALL,AND_IMP_INTRO] + state_rel t' s' +Proof + strip_tac \\ completeInduct_on `k` \\ fs [PULL_FORALL,AND_IMP_INTRO] \\ recInduct remove_ticks_ind \\ rw [] THEN1 (* NIL *) (fs [evaluate_def,remove_ticks_def] \\ rveq @@ -272,7 +273,8 @@ Theorem evaluate_remove_ticks \\ disch_then (qspec_then `ticks+ck'` assume_tac) \\ rw [] \\ qexists_tac `ticks + ck+ck'` \\ fs [dec_clock_def] \\ qsuff_tac `t'.clock <> 0` \\ rpt strip_tac \\ fs [] - \\ fs [state_rel_def]); + \\ fs [state_rel_def] +QED val evaluate_remove_ticks_thm = evaluate_remove_ticks @@ -288,8 +290,8 @@ val remove_ticks_co_def = Define ` remove_ticks_co = (I ## MAP (I ## I ## (λx. HD (remove_ticks [x]))))`; -Theorem evaluate_compile_prog - `evaluate ([Call 0 (SOME start) []], [], +Theorem evaluate_compile_prog: + evaluate ([Call 0 (SOME start) []], [], initial_state ffi0 (map (I ## (λx. HD (remove_ticks [x]))) prog) (remove_ticks_co ∘ co) cc k) = (r, s) ⇒ @@ -297,8 +299,9 @@ Theorem evaluate_compile_prog evaluate ([Call 0 (SOME start) []], [], initial_state ffi0 prog co (remove_ticks_cc cc) (k + ck)) = (r, s2) ∧ - s2.ffi = s.ffi` - (strip_tac \\ fs [remove_ticks_co_def,remove_ticks_cc_def] + s2.ffi = s.ffi +Proof + strip_tac \\ fs [remove_ticks_co_def,remove_ticks_cc_def] \\ drule (ONCE_REWRITE_RULE [CONJ_COMM] (REWRITE_RULE [CONJ_ASSOC] evaluate_remove_ticks_thm)) \\ disch_then (qspec_then `initial_state ffi0 prog co @@ -306,18 +309,20 @@ Theorem evaluate_compile_prog k` mp_tac) \\ impl_tac THEN1 fs [state_rel_def] \\ strip_tac \\ fs [] - \\ qexists_tac `ck` \\ fs [state_rel_def]); + \\ qexists_tac `ck` \\ fs [state_rel_def] +QED val FST_EQ_LEMMA = prove( ``FST x = y <=> ?y1. x = (y,y1)``, Cases_on `x` \\ fs []); -Theorem semantics_remove_ticks - `semantics ffi (map (I ## (λx. HD (remove_ticks [x]))) prog) +Theorem semantics_remove_ticks: + semantics ffi (map (I ## (λx. HD (remove_ticks [x]))) prog) (remove_ticks_co ∘ co) cc start = - semantics (ffi:'b ffi_state) prog co (remove_ticks_cc cc) start` - (simp [Once semantics_def] + semantics (ffi:'b ffi_state) prog co (remove_ticks_cc cc) start +Proof + simp [Once semantics_def] \\ IF_CASES_TAC \\ fs [] THEN1 (simp [semantics_def] \\ IF_CASES_TAC \\ fs [FST_EQ_LEMMA] @@ -538,7 +543,8 @@ Theorem semantics_remove_ticks |> SIMP_RULE(srw_ss())[inc_clock_def], SND,ADD_SYM]) \\ fs [IS_PREFIX_APPEND] - \\ simp [EL_APPEND1]); + \\ simp [EL_APPEND1] +QED val remove_ticks_CONS = prove( ``!xs x. remove_ticks (x::xs) = @@ -603,14 +609,16 @@ val in_state_rel_def = Define ` ?exp2. lookup k t.code = SOME (arity,exp2) /\ exp_rel s.code [exp] [exp2])`; -Theorem subspt_exp_rel - `!s1 s2 xs ys. subspt s1 s2 /\ exp_rel s1 xs ys ==> exp_rel s2 xs ys` - (qsuff_tac `!s1 xs ys. exp_rel s1 xs ys ==> !s2. subspt s1 s2 ==> exp_rel s2 xs ys` +Theorem subspt_exp_rel: + !s1 s2 xs ys. subspt s1 s2 /\ exp_rel s1 xs ys ==> exp_rel s2 xs ys +Proof + qsuff_tac `!s1 xs ys. exp_rel s1 xs ys ==> !s2. subspt s1 s2 ==> exp_rel s2 xs ys` THEN1 metis_tac [] \\ ho_match_mp_tac exp_rel_ind \\ rw [] \\ once_rewrite_tac [exp_rel_cases] \\ fs [] \\ fs [subspt_def,domain_lookup,PULL_EXISTS] - \\ res_tac \\ fs [] \\ metis_tac []); + \\ res_tac \\ fs [] \\ metis_tac [] +QED val tick_inline_all_acc = prove( ``!limit cs t aux. @@ -622,15 +630,17 @@ val tick_inline_all_acc = prove( \\ pop_assum (fn th => once_rewrite_tac [th]) \\ fs [] \\ pairarg_tac \\ fs []); -Theorem tick_inline_all_names - `!limit cs t aux cs1 xs aux. +Theorem tick_inline_all_names: + !limit cs t aux cs1 xs aux. tick_inline_all limit cs t aux = (cs1,xs) ==> - MAP FST (REVERSE aux) ++ MAP FST t = MAP FST xs` - (Induct_on `t` \\ fs [tick_inline_all_def,FORALL_PROD] + MAP FST (REVERSE aux) ++ MAP FST t = MAP FST xs +Proof + Induct_on `t` \\ fs [tick_inline_all_def,FORALL_PROD] \\ once_rewrite_tac [tick_inline_all_acc] \\ fs [] \\ rpt strip_tac \\ pairarg_tac \\ fs [] \\ rveq \\ fs [] - \\ res_tac \\ fs[]); + \\ res_tac \\ fs[] +QED val tick_compile_prog_IMP = prove( ``tick_compile_prog limit q0 ((k,prog)::t) = (cs1,prog1) ==> @@ -656,13 +666,14 @@ val tick_inline_all_domain = prove( \\ fs [] \\ pairarg_tac \\ fs [] \\ rw [] \\ res_tac \\ fs [MAP,SUBSET_DEF] \\ metis_tac []); -Theorem tick_compile_prog_res_range - `!in1 limit in2 c cs0 cs1. +Theorem tick_compile_prog_res_range: + !in1 limit in2 c cs0 cs1. tick_compile_prog limit cs0 in1 = (cs1,in2) /\ ALL_DISTINCT (MAP FST in1) /\ subspt cs0 c /\ domain c INTER set (MAP FST in1) = EMPTY ==> - subspt cs1 (union c (fromAList in2))` - (Induct \\ fs [tick_compile_prog_def] + subspt cs1 (union c (fromAList in2)) +Proof + Induct \\ fs [tick_compile_prog_def] THEN1 (fs [tick_inline_all_def,fromAList_def]) \\ fs [FORALL_PROD] \\ fs [tick_inline_all_def,fromAList_def] @@ -702,7 +713,8 @@ Theorem tick_compile_prog_res_range \\ fs [subspt_lookup] \\ fs [lookup_union,fromAList_def,lookup_insert] \\ rw [] \\ fs[domain_lookup] - \\ rw [] \\ fs []); + \\ rw [] \\ fs [] +QED val exp_rel_swap_lemma = prove( ``!x1 x2 x3. exp_rel x1 x2 x3 ==> @@ -711,10 +723,12 @@ val exp_rel_swap_lemma = prove( \\ once_rewrite_tac [exp_rel_cases] \\ fs [] \\ res_tac \\ metis_tac []); -Theorem exp_rel_swap - `!x1 x2 x3 y1. - (!k. lookup k x1 = lookup k y1) ==> exp_rel x1 x2 x3 = exp_rel y1 x2 x3` - (metis_tac [exp_rel_swap_lemma]); +Theorem exp_rel_swap: + !x1 x2 x3 y1. + (!k. lookup k x1 = lookup k y1) ==> exp_rel x1 x2 x3 = exp_rel y1 x2 x3 +Proof + metis_tac [exp_rel_swap_lemma] +QED val exp_rel_rw = prove( ``exp_rel (union (union src_code (insert p1 (p2,p3) LN)) (fromAList in1)) @@ -725,15 +739,16 @@ val exp_rel_rw = prove( \\ Cases_on `lookup k src_code` \\ fs [] \\ CCONTR_TAC \\ fs []); -Theorem exp_rel_tick_inline - `!cs0 xs. +Theorem exp_rel_tick_inline: + !cs0 xs. (∀k arity v. lookup k cs0 = SOME (arity,v) ⇒ ∃exp. lookup k src_code = SOME (arity,exp) ∧ exp_rel src_code [exp] [v]) ==> - exp_rel src_code xs (tick_inline cs0 xs)` - (ho_match_mp_tac tick_inline_ind \\ fs [tick_inline_def] \\ rw [] + exp_rel src_code xs (tick_inline cs0 xs) +Proof + ho_match_mp_tac tick_inline_ind \\ fs [tick_inline_def] \\ rw [] \\ once_rewrite_tac [exp_rel_cases] \\ fs [] THEN1 (sg `?y1 ys. tick_inline cs0 (y::xs) = y1::ys` \\ fs [] @@ -744,7 +759,8 @@ Theorem exp_rel_tick_inline \\ Cases_on `lookup x cs0` \\ fs [] \\ rename1 `_ = SOME aa` \\ PairCases_on `aa` \\ res_tac \\ fs [] - \\ qexists_tac `aa1` \\ fs []); + \\ qexists_tac `aa1` \\ fs [] +QED val tick_compile_prog_IMP_exp_rel = prove( ``!limit cs0 in1 cs1 in2 k arity exp src_code. @@ -879,13 +895,14 @@ val in_do_app_lemma = prove( \\ fs [in_state_rel_def] \\ imp_res_tac do_app_const \\ fs []); -Theorem evaluate_inline - `!es env s1 res t1 s2 es2. +Theorem evaluate_inline: + !es env s1 res t1 s2 es2. in_state_rel limit s1 t1 /\ exp_rel s1.code es es2 /\ evaluate (es,env,s1) = (res,s2) /\ res ≠ Rerr (Rabort Rtype_error) ==> ?t2. evaluate (es2,env,t1) = (res,t2) /\ - in_state_rel limit s2 t2` - (recInduct evaluate_ind \\ rw [] \\ fs [] + in_state_rel limit s2 t2 +Proof + recInduct evaluate_ind \\ rw [] \\ fs [] \\ fs [evaluate_def] \\ rveq \\ fs [] \\ qpat_x_assum `exp_rel _ _ _` mp_tac \\ once_rewrite_tac [exp_rel_cases] \\ fs [] \\ rw [] @@ -992,15 +1009,18 @@ Theorem evaluate_inline \\ strip_tac \\ fs [ADD1] \\ `FST (evaluate ([y],args,dec_clock (ticks + 1) t2)) <> Rerr (Rabort Rtype_error)` by fs [] - \\ drule evaluate_expand_env \\ fs []); + \\ drule evaluate_expand_env \\ fs [] +QED -Theorem exp_rel_refl - `!cs xs. exp_rel cs xs xs` - (ho_match_mp_tac tick_inline_ind \\ rw [] +Theorem exp_rel_refl: + !cs xs. exp_rel cs xs xs +Proof + ho_match_mp_tac tick_inline_ind \\ rw [] \\ once_rewrite_tac [exp_rel_cases] \\ fs [] \\ Cases_on `dest` \\ fs [] \\ Cases_on `lookup x cs` \\ fs [] - \\ Cases_on `x'` \\ fs []); + \\ Cases_on `x'` \\ fs [] +QED val in_co_def = Define ` in_co limit co = (λn. @@ -1010,11 +1030,13 @@ val in_co_def = Define ` in (cfg,progs)))`; -Theorem MAP_FST_tick_inline_all - `!limit cs prog. - MAP FST (SND (tick_inline_all limit cs prog [])) = MAP FST prog` - (rw[] \\ Cases_on `tick_inline_all limit cs prog []` - \\ imp_res_tac tick_inline_all_names \\ fs []); +Theorem MAP_FST_tick_inline_all: + !limit cs prog. + MAP FST (SND (tick_inline_all limit cs prog [])) = MAP FST prog +Proof + rw[] \\ Cases_on `tick_inline_all limit cs prog []` + \\ imp_res_tac tick_inline_all_names \\ fs [] +QED val exp_rel_rw = prove( ``~MEM x (MAP FST prog) ==> @@ -1374,10 +1396,12 @@ val let_state_rel_alt = let_state_rel_def val let_state_rel_def = let_state_rel_def |> SIMP_RULE (srw_ss()) [state_component_equality,GSYM CONJ_ASSOC]; -Theorem HD_let_op[simp] - `[HD (let_op [x])] = let_op [x]` - (Cases_on `x` \\ simp_tac std_ss [let_op_def] \\ fs [] - \\ CASE_TAC \\ fs []); +Theorem HD_let_op[simp]: + [HD (let_op [x])] = let_op [x] +Proof + Cases_on `x` \\ simp_tac std_ss [let_op_def] \\ fs [] + \\ CASE_TAC \\ fs [] +QED val let_op_sing_thm = prove( ``let_op_sing x = HD (let_op [x])``, @@ -1411,10 +1435,12 @@ val var_list_IMP_evaluate = prove( |> SIMP_RULE std_ss [APPEND,LENGTH]) \\ asm_exists_tac \\ fs []); -Theorem LENGTH_let_op - `!xs. LENGTH (let_op xs) = LENGTH xs` - (ho_match_mp_tac let_op_ind \\ rw [let_op_def] - \\ CASE_TAC \\ fs []); +Theorem LENGTH_let_op: + !xs. LENGTH (let_op xs) = LENGTH xs +Proof + ho_match_mp_tac let_op_ind \\ rw [let_op_def] + \\ CASE_TAC \\ fs [] +QED val do_app_lemma = prove( ``let_state_rel q4 l4 s1 t1 ==> @@ -1461,12 +1487,13 @@ val do_app_lemma = prove( \\ qpat_x_assum `t1 = _` (assume_tac o GSYM) \\ fs [] \\ impl_tac THEN1 fs [domain_map] \\ fs []); -Theorem evaluate_let_op - `!es env s1 res t1 s2. +Theorem evaluate_let_op: + !es env s1 res t1 s2. let_state_rel q4 l4 s1 t1 /\ evaluate (es,env,s1) = (res,s2) /\ res ≠ Rerr (Rabort Rtype_error) ==> - ?t2. evaluate (let_op es,env,t1) = (res,t2) /\ let_state_rel q4 l4 s2 t2` - (recInduct evaluate_ind \\ rw [] \\ fs [let_op_def] + ?t2. evaluate (let_op es,env,t1) = (res,t2) /\ let_state_rel q4 l4 s2 t2 +Proof + recInduct evaluate_ind \\ rw [] \\ fs [let_op_def] \\ fs [evaluate_def] THEN1 (once_rewrite_tac [evaluate_CONS] @@ -1545,7 +1572,8 @@ Theorem evaluate_let_op \\ qexists_tac `t9` \\ fs [] \\ once_rewrite_tac [EQ_SYM_EQ] \\ match_mp_tac bvl_handleProofTheory.compile_any_correct \\ fs [] - \\ fs [let_op_sing_thm,HD_let_op])); + \\ fs [let_op_sing_thm,HD_let_op]) +QED val let_op_cc_def = Define ` let_op_cc q4 l4 cc = @@ -1833,9 +1861,11 @@ val map_fromAList_HASH = prove( \\ rpt (AP_TERM_TAC ORELSE AP_THM_TAC) \\ fs [FUN_EQ_THM,FORALL_PROD]); -Theorem map_fromAList - `!xs f. map f (fromAList xs) = fromAList (MAP (I ## f) xs)` - (Induct \\ fs [fromAList_def,fromAList_def,FORALL_PROD,map_insert]); +Theorem map_fromAList: + !xs f. map f (fromAList xs) = fromAList (MAP (I ## f) xs) +Proof + Induct \\ fs [fromAList_def,fromAList_def,FORALL_PROD,map_insert] +QED val ticks = semantics_remove_ticks @@ -1880,24 +1910,28 @@ val MAP_optimise = prove( (MAP (I ## I ## (λx. HD (remove_ticks [x]))) prog)``, Induct \\ fs [FORALL_PROD,optimise_def,let_opt_def]); -Theorem state_cc_compile_inc_eq - `(state_cc (compile_inc limit o1 o2) cc) = - (in_cc limit (remove_ticks_cc (let_op_cc o1 o2 cc)))` - (fs [state_cc_def,compile_inc_def,in_cc_def,FUN_EQ_THM,remove_ticks_cc_def, +Theorem state_cc_compile_inc_eq: + (state_cc (compile_inc limit o1 o2) cc) = + (in_cc limit (remove_ticks_cc (let_op_cc o1 o2 cc))) +Proof + fs [state_cc_def,compile_inc_def,in_cc_def,FUN_EQ_THM,remove_ticks_cc_def, let_op_cc_def] \\ rw [] \\ rpt (pairarg_tac \\ fs []) \\ rveq - \\ fs [MAP_optimise]); - -Theorem state_co_compile_inc_eq - `(state_co (compile_inc limit o1 o2) co) = - ((I ## MAP (I ## let_opt o1 o2)) o remove_ticks_co ∘ in_co limit co)` - (fs [state_co_def,compile_inc_def,in_co_def,FUN_EQ_THM,remove_ticks_co_def] + \\ fs [MAP_optimise] +QED + +Theorem state_co_compile_inc_eq: + (state_co (compile_inc limit o1 o2) co) = + ((I ## MAP (I ## let_opt o1 o2)) o remove_ticks_co ∘ in_co limit co) +Proof + fs [state_co_def,compile_inc_def,in_co_def,FUN_EQ_THM,remove_ticks_co_def] \\ rw [] \\ rpt (pairarg_tac \\ fs []) \\ rveq - \\ fs [MAP_optimise]); + \\ fs [MAP_optimise] +QED -Theorem compile_prog_semantics - `compile_prog limit o1 o2 prog = (s1,prog1) /\ +Theorem compile_prog_semantics: + compile_prog limit o1 o2 prog = (s1,prog1) /\ FST (FST (co 0)) = s1 /\ ALL_DISTINCT (MAP FST prog) ⇒ semantics ffi (fromAList prog) co (state_cc (compile_inc limit o1 o2) cc) @@ -1905,8 +1939,9 @@ Theorem compile_prog_semantics semantics ffi (fromAList prog1) (state_co (compile_inc limit o1 o2) co) cc start = semantics ffi (fromAList prog) co (state_cc (compile_inc limit o1 o2) cc) - start` - (fs [state_cc_compile_inc_eq,state_co_compile_inc_eq] + start +Proof + fs [state_cc_compile_inc_eq,state_co_compile_inc_eq] \\ fs [compile_prog_def,compile_inc_def] \\ pairarg_tac \\ fs [] \\ rw [] \\ rveq \\ fs [MAP_optimise] @@ -1914,41 +1949,53 @@ Theorem compile_prog_semantics (REWRITE_RULE [CONJ_ASSOC,AND_IMP_INTRO] inline_ticks))) \\ fs [] \\ disch_then (assume_tac o GSYM) \\ fs [] \\ drule (GEN_ALL lets) - \\ fs [] \\ disch_then (assume_tac o GSYM) \\ fs []); + \\ fs [] \\ disch_then (assume_tac o GSYM) \\ fs [] +QED -Theorem handle_ok_optimise - `!prog. bvl_handleProof$handle_ok (MAP (SND ∘ SND ∘ optimise b i) prog)` - (Induct \\ fs [bvl_handleProofTheory.handle_ok_def,FORALL_PROD] +Theorem handle_ok_optimise: + !prog. bvl_handleProof$handle_ok (MAP (SND ∘ SND ∘ optimise b i) prog) +Proof + Induct \\ fs [bvl_handleProofTheory.handle_ok_def,FORALL_PROD] \\ once_rewrite_tac [bvl_handleProofTheory.handle_ok_CONS] \\ fs [] - \\ fs [bvl_handleProofTheory.compile_any_handle_ok,optimise_def]); - -Theorem compile_prog_handle_ok - `compile_prog l b i prog = (inlines,prog3) ==> - bvl_handleProof$handle_ok (MAP (SND o SND) prog3)` - (fs [compile_prog_def,compile_inc_def] + \\ fs [bvl_handleProofTheory.compile_any_handle_ok,optimise_def] +QED + +Theorem compile_prog_handle_ok: + compile_prog l b i prog = (inlines,prog3) ==> + bvl_handleProof$handle_ok (MAP (SND o SND) prog3) +Proof + fs [compile_prog_def,compile_inc_def] \\ pairarg_tac \\ fs [] \\ rw [] - \\ fs [MAP_MAP_o,handle_ok_optimise]); - -Theorem MAP_FST_MAP_optimise[simp] - `MAP FST (MAP (optimise x y) z) = MAP FST z` - (Induct_on`z` \\ fs[FORALL_PROD,optimise_def]); - -Theorem compile_prog_names - `compile_prog l b i prog = (inlines,prog3) ==> - MAP FST prog3 = MAP FST prog` - (fs [compile_prog_def,compile_inc_def] \\ pairarg_tac \\ fs [] + \\ fs [MAP_MAP_o,handle_ok_optimise] +QED + +Theorem MAP_FST_MAP_optimise[simp]: + MAP FST (MAP (optimise x y) z) = MAP FST z +Proof + Induct_on`z` \\ fs[FORALL_PROD,optimise_def] +QED + +Theorem compile_prog_names: + compile_prog l b i prog = (inlines,prog3) ==> + MAP FST prog3 = MAP FST prog +Proof + fs [compile_prog_def,compile_inc_def] \\ pairarg_tac \\ fs [] \\ fs [tick_compile_prog_def] \\ imp_res_tac tick_inline_all_names \\ rw [] - \\ rw[] \\ fs[]); - -Theorem var_list_code_labels_imp - `∀n x y. var_list n x y ⇒ BIGUNION (set (MAP get_code_labels x)) = {}` - (recInduct bvl_inlineTheory.var_list_ind - \\ rw[bvl_inlineTheory.var_list_def] \\ fs[]); - -Theorem let_op_code_labels - `∀x. BIGUNION (set (MAP get_code_labels (let_op x))) = BIGUNION (set (MAP get_code_labels x))` - (recInduct bvl_inlineTheory.let_op_ind + \\ rw[] \\ fs[] +QED + +Theorem var_list_code_labels_imp: + ∀n x y. var_list n x y ⇒ BIGUNION (set (MAP get_code_labels x)) = {} +Proof + recInduct bvl_inlineTheory.var_list_ind + \\ rw[bvl_inlineTheory.var_list_def] \\ fs[] +QED + +Theorem let_op_code_labels: + ∀x. BIGUNION (set (MAP get_code_labels (let_op x))) = BIGUNION (set (MAP get_code_labels x)) +Proof + recInduct bvl_inlineTheory.let_op_ind \\ rw[bvl_inlineTheory.let_op_def] \\ full_simp_tac std_ss [Once(GSYM HD_let_op)] \\ fs[] \\ PURE_CASE_TAC \\ fs[] @@ -1957,30 +2004,36 @@ Theorem let_op_code_labels \\ imp_res_tac var_list_code_labels_imp \\ fs[] \\ rveq \\ fs[] \\ simp[EXTENSION] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem let_op_sing_code_labels[simp] - `get_code_labels (let_op_sing x) = get_code_labels x` - (rw[bvl_inlineTheory.let_op_sing_def] +Theorem let_op_sing_code_labels[simp]: + get_code_labels (let_op_sing x) = get_code_labels x +Proof + rw[bvl_inlineTheory.let_op_sing_def] \\ simp_tac std_ss [Once(GSYM HD_let_op)] \\ simp[] \\ specl_args_of_then``bvl_inline$let_op``let_op_code_labels mp_tac \\ simp_tac std_ss [Once(GSYM HD_let_op)] - \\ rw[]); + \\ rw[] +QED -Theorem remove_ticks_code_labels - `∀x. +Theorem remove_ticks_code_labels: + ∀x. BIGUNION (set (MAP get_code_labels (remove_ticks x))) = - BIGUNION (set (MAP get_code_labels x))` - (recInduct bvl_inlineTheory.remove_ticks_ind + BIGUNION (set (MAP get_code_labels x)) +Proof + recInduct bvl_inlineTheory.remove_ticks_ind \\ rw[bvl_inlineTheory.remove_ticks_def] - \\ FULL_SIMP_TAC std_ss [Once (GSYM bvl_inlineTheory.remove_ticks_SING)] \\ fs[]); + \\ FULL_SIMP_TAC std_ss [Once (GSYM bvl_inlineTheory.remove_ticks_SING)] \\ fs[] +QED -Theorem optimise_get_code_labels - `∀x y z. +Theorem optimise_get_code_labels: + ∀x y z. get_code_labels (SND (SND (optimise x y z))) ⊆ - get_code_labels (SND (SND z))` - (rpt gen_tac \\ PairCases_on`z` + get_code_labels (SND (SND z)) +Proof + rpt gen_tac \\ PairCases_on`z` \\ reverse(rw[bvl_inlineTheory.optimise_def, bvl_handleTheory.compile_any_def, bvl_handleTheory.compile_exp_def]) >- ( specl_args_of_then``bvl_handle$compile``bvl_handleProofTheory.compile_code_labels mp_tac @@ -2006,14 +2059,16 @@ Theorem optimise_get_code_labels \\ qspec_then `[z2]` assume_tac remove_ticks_code_labels \\ fs [] \\ rfs [] \\ pop_assum (SUBST1_TAC o GSYM) \\ qspecl_then [`y`,`let_op_sing h`,`NONE`] - assume_tac bvl_handleProofTheory.compile_seqs_code_labels \\ fs []); + assume_tac bvl_handleProofTheory.compile_seqs_code_labels \\ fs [] +QED -Theorem tick_inline_code_labels - `!cs xs. +Theorem tick_inline_code_labels: + !cs xs. BIGUNION (set (MAP get_code_labels (tick_inline cs xs))) SUBSET BIGUNION (set (MAP get_code_labels xs)) UNION - BIGUNION (set (MAP (get_code_labels o SND) (toList cs)))` - (ho_match_mp_tac bvl_inlineTheory.tick_inline_ind + BIGUNION (set (MAP (get_code_labels o SND) (toList cs))) +Proof + ho_match_mp_tac bvl_inlineTheory.tick_inline_ind \\ rw [bvl_inlineTheory.tick_inline_def] \\ TRY (qmatch_goalsub_rename_tac `_ (HD (tick_inline cs [x])) SUBSET _` @@ -2034,17 +2089,19 @@ Theorem tick_inline_code_labels \\ Cases_on `tick_inline cs [x2]` \\ pop_assum (mp_tac o Q.AP_TERM `LENGTH`) \\ Cases_on `tick_inline cs [x3]` \\ pop_assum (mp_tac o Q.AP_TERM `LENGTH`) \\ rw [bvl_inlineTheory.LENGTH_tick_inline] - \\ fs [SUBSET_DEF] \\ rw [] \\ metis_tac []); + \\ fs [SUBSET_DEF] \\ rw [] \\ metis_tac [] +QED -Theorem tick_inline_all_code_labels - `!limit cs xs aux cs1 xs1. +Theorem tick_inline_all_code_labels: + !limit cs xs aux cs1 xs1. tick_inline_all limit cs xs aux = (cs1, xs1) ==> BIGUNION (set (MAP (get_code_labels o SND o SND) xs1)) SUBSET BIGUNION (set (MAP (get_code_labels o SND o SND) xs)) UNION BIGUNION (set (MAP (get_code_labels o SND o SND) aux)) UNION - BIGUNION (set (MAP (get_code_labels o SND) (toList cs)))` - (ho_match_mp_tac bvl_inlineTheory.tick_inline_all_ind + BIGUNION (set (MAP (get_code_labels o SND) (toList cs))) +Proof + ho_match_mp_tac bvl_inlineTheory.tick_inline_all_ind \\ rw [bvl_inlineTheory.tick_inline_all_def] \\ fs [MAP_REVERSE] \\ Cases_on `tick_inline cs [e1]` @@ -2059,13 +2116,15 @@ Theorem tick_inline_all_code_labels \\ FULL_CASE_TAC \\ fs [] \\ rw [] \\ fs [] \\ res_tac \\ fs [] \\ fs [Abbr `s3`, MEM_MAP, MEM_toList, PULL_EXISTS] - \\ metis_tac [PAIR, FST, SND]); + \\ metis_tac [PAIR, FST, SND] +QED -Theorem compile_prog_get_code_labels - `bvl_inline$compile_prog x y z p = (inlines,q) ⇒ +Theorem compile_prog_get_code_labels: + bvl_inline$compile_prog x y z p = (inlines,q) ⇒ BIGUNION (set (MAP (get_code_labels o SND o SND) q)) ⊆ - BIGUNION (set (MAP (get_code_labels o SND o SND) p))` - (rw[bvl_inlineTheory.compile_prog_def, bvl_inlineTheory.compile_inc_def, bvl_inlineTheory.tick_compile_prog_def] + BIGUNION (set (MAP (get_code_labels o SND o SND) p)) +Proof + rw[bvl_inlineTheory.compile_prog_def, bvl_inlineTheory.compile_inc_def, bvl_inlineTheory.tick_compile_prog_def] \\ pairarg_tac \\ fs[] \\ rveq \\ simp[MAP_MAP_o, o_DEF] \\ match_mp_tac SUBSET_TRANS @@ -2078,6 +2137,7 @@ Theorem compile_prog_get_code_labels \\ rw[SUBSET_DEF] \\ metis_tac[]) \\ imp_res_tac tick_inline_all_code_labels - \\ fs [o_DEF, toList_def, toListA_def]); + \\ fs [o_DEF, toList_def, toListA_def] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/bvl_jumpProofScript.sml b/compiler/backend/proofs/bvl_jumpProofScript.sml index 27a6e6e05e..054f7511a4 100644 --- a/compiler/backend/proofs/bvl_jumpProofScript.sml +++ b/compiler/backend/proofs/bvl_jumpProofScript.sml @@ -29,23 +29,27 @@ val evaluate_JumpList = Q.prove( \\ fs[] \\ fs[NOT_LESS] \\ IMP_RES_TAC EL_APPEND2 \\ fs [EL_APPEND2]); -Theorem evaluate_Jump - `(evaluate ([x],env,s) = (Rval [Number (&n)],t)) /\ +Theorem evaluate_Jump: + (evaluate ([x],env,s) = (Rval [Number (&n)],t)) /\ n < LENGTH xs ==> (evaluate ([Jump x xs],env,s) = - evaluate ([EL n xs],Number (&n) :: env,t))` - (fs[evaluate_def,Jump_def] \\ REPEAT STRIP_TAC + evaluate ([EL n xs],Number (&n) :: env,t)) +Proof + fs[evaluate_def,Jump_def] \\ REPEAT STRIP_TAC \\ IMP_RES_TAC evaluate_JumpList - \\ POP_ASSUM (ASSUME_TAC o Q.SPECL [`t`,`0`]) \\ fs[]); + \\ POP_ASSUM (ASSUME_TAC o Q.SPECL [`t`,`0`]) \\ fs[] +QED -Theorem bvl_get_code_labels_JumpList - `∀n xs. get_code_labels (JumpList n xs) = BIGUNION (set (MAP get_code_labels xs))` - (recInduct bvl_jumpTheory.JumpList_ind +Theorem bvl_get_code_labels_JumpList: + ∀n xs. get_code_labels (JumpList n xs) = BIGUNION (set (MAP get_code_labels xs)) +Proof + recInduct bvl_jumpTheory.JumpList_ind \\ rw[] \\ rw[Once bvl_jumpTheory.JumpList_def, closLangTheory.assign_get_code_label_def] \\ fs[LENGTH_EQ_NUM_compute] \\ Q.ISPECL_THEN[`LENGTH xs DIV 2`,`xs`] ((fn th => CONV_TAC(RAND_CONV(ONCE_REWRITE_CONV[th]))) o SYM)TAKE_DROP - \\ simp[]); + \\ simp[] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/bvl_to_bviProofScript.sml b/compiler/backend/proofs/bvl_to_bviProofScript.sml index ca81df49a8..6b20cfa4aa 100644 --- a/compiler/backend/proofs/bvl_to_bviProofScript.sml +++ b/compiler/backend/proofs/bvl_to_bviProofScript.sml @@ -38,13 +38,17 @@ val adjust_bv_def = tDefine "adjust_bv" ` val adjust_bv_ind = theorem"adjust_bv_ind"; -Theorem adjust_bv_Unit[simp] - `adjust_bv x Unit = Unit` - (EVAL_TAC); +Theorem adjust_bv_Unit[simp]: + adjust_bv x Unit = Unit +Proof + EVAL_TAC +QED -Theorem adjust_bv_Boolv[simp] - `adjust_bv x (Boolv b) = Boolv b` - (Cases_on`b`>>EVAL_TAC) +Theorem adjust_bv_Boolv[simp]: + adjust_bv x (Boolv b) = Boolv b +Proof + Cases_on`b`>>EVAL_TAC +QED val aux_code_installed_def = Define ` (aux_code_installed [] t <=> T) /\ @@ -59,11 +63,13 @@ val aux_code_installed_APPEND = Q.prove( aux_code_installed ys code`, Induct \\ fs[APPEND,aux_code_installed_def,FORALL_PROD] \\ METIS_TAC []); -Theorem aux_code_installed_subspt - `!x c1 c2. aux_code_installed x c1 /\ subspt c1 c2 ==> - aux_code_installed x c2` - (Induct \\ fs [aux_code_installed_def,subspt_lookup,FORALL_PROD] - \\ rw [] \\ fs [] \\ res_tac \\ fs []); +Theorem aux_code_installed_subspt: + !x c1 c2. aux_code_installed x c1 /\ subspt c1 c2 ==> + aux_code_installed x c2 +Proof + Induct \\ fs [aux_code_installed_def,subspt_lookup,FORALL_PROD] + \\ rw [] \\ fs [] \\ res_tac \\ fs [] +QED val _ = temp_overload_on("in_ns_0",``λn. n MOD bvl_to_bvi_namespaces = 0``); val _ = temp_overload_on("in_ns_1",``λn. n MOD bvl_to_bvi_namespaces = 1``); @@ -114,12 +120,14 @@ val state_rel_def = Define ` aux_code_installed (append aux1) t.code /\ handle_ok [exp])`; -Theorem state_rel_FLOOKUP_byteArray - `!b s t m l n. state_rel b s t /\ FLOOKUP s.refs n = SOME (ByteArray m l) - ==> FLOOKUP t.refs (b n) = SOME (ByteArray m l)` - (rpt strip_tac >> fs[state_rel_def] +Theorem state_rel_FLOOKUP_byteArray: + !b s t m l n. state_rel b s t /\ FLOOKUP s.refs n = SOME (ByteArray m l) + ==> FLOOKUP t.refs (b n) = SOME (ByteArray m l) +Proof + rpt strip_tac >> fs[state_rel_def] >> rpt(first_x_assum(qspec_then `n` assume_tac)) - >> rfs[]); + >> rfs[] +QED val bv_ok_def = tDefine "bv_ok" ` (bv_ok (refs: num |-> v ref) (RefPtr r) <=> r IN FDOM refs) /\ @@ -137,13 +145,17 @@ val bv_ok_SUBSET_IMP = Q.prove( HO_MATCH_MP_TAC bv_ok_ind \\ full_simp_tac(srw_ss())[bv_ok_def] \\ full_simp_tac(srw_ss())[SUBSET_DEF,EVERY_MEM]); -Theorem bv_ok_Unit[simp] - `bv_ok refs Unit` - (EVAL_TAC) +Theorem bv_ok_Unit[simp]: + bv_ok refs Unit +Proof + EVAL_TAC +QED -Theorem bv_ok_Boolv[simp] - `bv_ok refs (Boolv b)` - (EVAL_TAC) +Theorem bv_ok_Boolv[simp]: + bv_ok refs (Boolv b) +Proof + EVAL_TAC +QED val bv_ok_IMP_adjust_bv_eq = Q.prove( `!b2 a1 b3. @@ -184,16 +196,20 @@ val v_to_list_ok = Q.prove( simp[v_to_list_def,bv_ok_def] >> srw_tac[][] >> every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][]); -Theorem list_to_v_ok - `!xs. EVERY (bv_ok refs) xs ==> bv_ok refs (list_to_v xs)` - (Induct \\ rw [list_to_v_def, bv_ok_def]); +Theorem list_to_v_ok: + !xs. EVERY (bv_ok refs) xs ==> bv_ok refs (list_to_v xs) +Proof + Induct \\ rw [list_to_v_def, bv_ok_def] +QED -Theorem list_to_v_ok_APPEND - `!xs ys. +Theorem list_to_v_ok_APPEND: + !xs ys. bv_ok refs (list_to_v xs) /\ bv_ok refs (list_to_v ys) ==> - bv_ok refs (list_to_v (xs ++ ys))` - (Induct \\ rw [list_to_v_def, bv_ok_def]); + bv_ok refs (list_to_v (xs ++ ys)) +Proof + Induct \\ rw [list_to_v_def, bv_ok_def] +QED val do_app_ok_lemma = Q.prove( `state_ok r /\ EVERY (bv_ok r.refs) a /\ @@ -380,15 +396,17 @@ val do_app_ok_lemma = Q.prove( \\ Q.ISPEC_THEN`r.refs`match_mp_tac bv_ok_SUBSET_IMP \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[SUBSET_DEF,FLOOKUP_DEF])); -Theorem do_app_ok - `state_ok r /\ EVERY (bv_ok r.refs) a /\ +Theorem do_app_ok: + state_ok r /\ EVERY (bv_ok r.refs) a /\ (do_app op a r = Rval (q,t)) ==> state_ok t /\ bv_ok t.refs q /\ - (EVERY (bv_ok r.refs) env ==> EVERY (bv_ok t.refs) env)` - (STRIP_TAC \\ IMP_RES_TAC do_app_ok_lemma \\ full_simp_tac(srw_ss())[] + (EVERY (bv_ok r.refs) env ==> EVERY (bv_ok t.refs) env) +Proof + STRIP_TAC \\ IMP_RES_TAC do_app_ok_lemma \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[EVERY_MEM] \\ REPEAT STRIP_TAC \\ RES_TAC \\ IMP_RES_TAC do_app_refs_SUBSET - \\ IMP_RES_TAC bv_ok_SUBSET_IMP); + \\ IMP_RES_TAC bv_ok_SUBSET_IMP +QED val _ = print "Proved do_app_ok_lemma\n" val dec_clock_inc_clock = prove( @@ -396,17 +414,19 @@ val dec_clock_inc_clock = prove( inc_clock (c-1) (t: ('c,'ffi) bviSem$state)``, EVAL_TAC \\ fs [bviSemTheory.state_component_equality]); -Theorem find_code_bv_ok - `bvlSem$find_code dest vs s = SOME (args,e2) /\ - EVERY (bv_ok (refs : num |-> bvlSem$v ref)) vs ==> EVERY (bv_ok refs) args` - (Cases_on `dest` \\ fs [bvlSemTheory.find_code_def] +Theorem find_code_bv_ok: + bvlSem$find_code dest vs s = SOME (args,e2) /\ + EVERY (bv_ok (refs : num |-> bvlSem$v ref)) vs ==> EVERY (bv_ok refs) args +Proof + Cases_on `dest` \\ fs [bvlSemTheory.find_code_def] \\ fs [case_eq_thms] \\ rw [] \\ fs [] \\ `?v xs. vs = SNOC v xs` by metis_tac [SNOC_CASES] \\ full_simp_tac std_ss [FRONT_SNOC,LAST_SNOC] - \\ fs [SNOC_APPEND,EVERY_APPEND]); + \\ fs [SNOC_APPEND,EVERY_APPEND] +QED -Theorem evaluate_ok - `!xs env s res t. +Theorem evaluate_ok: + !xs env s res t. (evaluate (xs,env,s) = (res,t)) /\ state_ok s /\ EVERY (bv_ok s.refs) env ==> state_ok t /\ @@ -414,8 +434,9 @@ Theorem evaluate_ok | Rval vs => EVERY (bv_ok t.refs) vs | Rerr(Rraise v) => bv_ok t.refs v | _ => T) /\ - EVERY (bv_ok t.refs) env` - (recInduct bvlSemTheory.evaluate_ind \\ rpt strip_tac + EVERY (bv_ok t.refs) env +Proof + recInduct bvlSemTheory.evaluate_ind \\ rpt strip_tac \\ fs[bvlSemTheory.evaluate_def] \\ rw [] \\ fs [] \\ fs [case_eq_thms] \\ rveq \\ fs [] \\ imp_res_tac evaluate_SING \\ fs[] \\ rveq \\ fs [] @@ -433,7 +454,8 @@ Theorem evaluate_ok \\ rfs [] \\ drule (GEN_ALL find_code_bv_ok) \\ fs [] \\ disch_then drule \\ rw [] \\ fs [] \\ rfs [] - \\ drule (GEN_ALL evaluate_IMP_bv_ok) \\ fs [dec_clock_def]); + \\ drule (GEN_ALL evaluate_IMP_bv_ok) \\ fs [dec_clock_def] +QED (* semantics lemmas *) @@ -593,14 +615,15 @@ val evaluate_AllocGlobal_code = Q.prove( \\ AP_THM_TAC \\ AP_TERM_TAC \\ intLib.COOPER_TAC); -Theorem evaluate_ListLength_code - `!lv vs n. +Theorem evaluate_ListLength_code: + !lv vs n. lookup ListLength_location s.code = SOME (2,SND ListLength_code) /\ v_to_list lv = SOME vs ==> ∃p1 c. evaluate ([SND ListLength_code],[lv;Number (&n)],inc_clock c s) = - (Rval [Number (&(n + LENGTH vs))],s)` - (HO_MATCH_MP_TAC v_to_list_ind \\ rw [] \\ fs [v_to_list_def] \\ rveq + (Rval [Number (&(n + LENGTH vs))],s) +Proof + HO_MATCH_MP_TAC v_to_list_ind \\ rw [] \\ fs [v_to_list_def] \\ rveq \\ fs [ListLength_code_def] THEN1 (fs [bviSemTheory.evaluate_def,EVAL ``Boolv T``, EVAL ``bviSem$do_app (TagLenEq nil_tag 0) [Block nil_tag []] s``] @@ -620,10 +643,11 @@ Theorem evaluate_ListLength_code (unabbrev_all_tac \\ fs [bviSemTheory.state_component_equality, bviSemTheory.dec_clock_def] \\ fs [inc_clock_def]) \\ fs [] \\ pop_assum kall_tac - \\ `(1 + &n) = (&(n + 1)):int` by intLib.COOPER_TAC \\ fs []); + \\ `(1 + &n) = (&(n + 1)):int` by intLib.COOPER_TAC \\ fs [] +QED -Theorem evaluate_FromListByte_code - `∀lv vs n bs (s:('c,'ffi) bviSem$state). +Theorem evaluate_FromListByte_code: + ∀lv vs n bs (s:('c,'ffi) bviSem$state). v_to_list lv = SOME (MAP (Number o $&) vs) ∧ LENGTH vs ≤ LENGTH bs ∧ lookup FromListByte_location s.code = SOME (3,SND FromListByte_code) ∧ EVERY (λn. n < 256) vs ∧ @@ -631,8 +655,9 @@ Theorem evaluate_FromListByte_code ⇒ ∃c. evaluate ([SND FromListByte_code],[lv;Number (&n);RefPtr p],inc_clock c s) = - (Rval [RefPtr p], s with refs := s.refs |+ (p,ByteArray fl (TAKE n bs ++ (MAP n2w vs))))` - (ho_match_mp_tac v_to_list_ind \\ rw[] \\ fs[v_to_list_def] \\ rveq + (Rval [RefPtr p], s with refs := s.refs |+ (p,ByteArray fl (TAKE n bs ++ (MAP n2w vs)))) +Proof + ho_match_mp_tac v_to_list_ind \\ rw[] \\ fs[v_to_list_def] \\ rveq \\ rfs[FromListByte_code_def] >- ( simp[iEval_def,iEvalOp_def,do_app_aux_def,bEvalOp_def, @@ -664,10 +689,11 @@ Theorem evaluate_FromListByte_code \\ fs[Abbr`n1`,Abbr`n2`,state_component_equality] \\ simp[Abbr`refs`,fmap_eq_flookup,FLOOKUP_UPDATE] \\ rw[] \\ rw[LIST_EQ_REWRITE,EL_TAKE,EL_LUPDATE] - \\ rw[EL_TAKE,EL_APPEND1,EL_APPEND2]); + \\ rw[EL_TAKE,EL_APPEND1,EL_APPEND2] +QED -Theorem evaluate_SumListLength_code - `∀lv ps wss n. +Theorem evaluate_SumListLength_code: + ∀lv ps wss n. lookup SumListLength_location s.code = SOME (2,SND SumListLength_code) ∧ v_to_list lv = SOME (MAP RefPtr ps) ∧ MAP (FLOOKUP s.refs) ps = MAP (SOME o ByteArray T) wss @@ -675,8 +701,9 @@ Theorem evaluate_SumListLength_code ∃c. evaluate ([SND SumListLength_code],[lv;Number(&n)],inc_clock c s) = - (Rval [Number (&(n + LENGTH (FLAT wss)))],s)` - (recInduct v_to_list_ind \\ rw[v_to_list_def] + (Rval [Number (&(n + LENGTH (FLAT wss)))],s) +Proof + recInduct v_to_list_ind \\ rw[v_to_list_def] \\ fs[SumListLength_code_def] >- ( rw[evaluate_def,iEvalOp_def,do_app_aux_def,bEvalOp_def,bvl_to_bvi_id] @@ -702,10 +729,11 @@ Theorem evaluate_SumListLength_code \\ rename1`&LENGTH ls + &n` \\ disch_then(qspec_then`LENGTH ls + n`(qx_choose_then`c`strip_assume_tac)) \\ qexists_tac`c+1` - \\ fs[inc_clock_def,dec_clock_def,integerTheory.INT_ADD]); + \\ fs[inc_clock_def,dec_clock_def,integerTheory.INT_ADD] +QED -Theorem evaluate_ConcatByte_code - `∀lv ps wss (s:('c,'ffi) bviSem$state) ds1 ds2 n. +Theorem evaluate_ConcatByte_code: + ∀lv ps wss (s:('c,'ffi) bviSem$state) ds1 ds2 n. lookup SumListLength_location s.code = SOME (2,SND SumListLength_code) ∧ lookup ConcatByte_location s.code = SOME (3,SND ConcatByte_code) ∧ v_to_list lv = SOME (MAP RefPtr ps) ∧ dst ∉ set ps ∧ @@ -716,8 +744,9 @@ Theorem evaluate_ConcatByte_code ∃c. evaluate ([SND ConcatByte_code],[lv;Number(&n);RefPtr dst],inc_clock c s) = - (Rval [RefPtr dst], s with refs := s.refs |+ (dst, ByteArray T (ds1++FLAT wss)))` - (recInduct v_to_list_ind + (Rval [RefPtr dst], s with refs := s.refs |+ (dst, ByteArray T (ds1++FLAT wss))) +Proof + recInduct v_to_list_ind \\ rw[v_to_list_def] \\ rw[ConcatByte_code_def] >- ( @@ -753,7 +782,8 @@ Theorem evaluate_ConcatByte_code \\ disch_then(qspec_then`ds1 ++ ws`mp_tac) \\ simp[] \\ disch_then(qx_choose_then`c`strip_assume_tac) \\ qexists_tac`c+1` - \\ fs[inc_clock_def,dec_clock_def,state_component_equality,Abbr`refs`]); + \\ fs[inc_clock_def,dec_clock_def,state_component_equality,Abbr`refs`] +QED (* compiler correctness *) @@ -821,10 +851,12 @@ val compile_string_thm = Q.prove( |> Q.GENL[`str`,`ls`,`ptr`,`s`,`env`] |> INST_TYPE[alpha|->``:'c``,beta|->``:'ffi``]; -Theorem HD_APPEND3 - `0 < LENGTH (l1 ++ l2) ⇒ HD (l1 ++ l2 ++ l3) = HD (l1 ++ l2)` - (Cases_on`l1` \\ simp[] \\ - Cases_on`l2` \\ simp[]); +Theorem HD_APPEND3: + 0 < LENGTH (l1 ++ l2) ⇒ HD (l1 ++ l2 ++ l3) = HD (l1 ++ l2) +Proof + Cases_on`l1` \\ simp[] \\ + Cases_on`l2` \\ simp[] +QED val iEval_bVarBound = Q.prove( `!(n:num) xs n vs (s:('c,'ffi) bviSem$state) env. @@ -1034,20 +1066,24 @@ val do_eq_adjust = Q.prove( do_eq t2.refs (adjust_bv b2 x1) (adjust_bv b2 x2) = Eq_val b`, metis_tac [do_eq_adjust_lemma]); -Theorem list_to_v_adjust - `!xs. - list_to_v (MAP (adjust_bv b) xs) = adjust_bv b (list_to_v xs)` - (Induct \\ rw [list_to_v_def, adjust_bv_def]); +Theorem list_to_v_adjust: + !xs. + list_to_v (MAP (adjust_bv b) xs) = adjust_bv b (list_to_v xs) +Proof + Induct \\ rw [list_to_v_def, adjust_bv_def] +QED -Theorem list_to_v_adjust_APPEND - `!xs ys. +Theorem list_to_v_adjust_APPEND: + !xs ys. list_to_v (MAP (adjust_bv b) xs) = adjust_bv b (list_to_v xs) /\ list_to_v (MAP (adjust_bv b) xs) = adjust_bv b (list_to_v xs) ==> list_to_v (MAP (adjust_bv b) (xs ++ ys)) = - adjust_bv b (list_to_v (xs ++ ys))` - (Induct + adjust_bv b (list_to_v (xs ++ ys)) +Proof + Induct >- (Induct_on `ys` \\ rw [] \\ fs [adjust_bv_def, list_to_v_def]) - \\ rw [list_to_v_def, adjust_bv_def] \\ fs []); + \\ rw [list_to_v_def, adjust_bv_def] \\ fs [] +QED val do_app_adjust = Q.prove( `state_rel b2 s5 t2 /\ @@ -1280,8 +1316,8 @@ val do_app_adjust = Q.prove( \\ fs [adjust_bv_def,MAP_EQ_f,bvl_to_bvi_id] \\ rveq \\ rw [] \\ fs [adjust_bv_def,MAP_EQ_f,bvl_to_bvi_id] \\ NO_TAC)); -Theorem eval_ind_alt - `∀P. +Theorem eval_ind_alt: + ∀P. (∀env s. P ([],env,s)) ∧ (∀x y xs env s. (∀v3 s1 v1. @@ -1327,8 +1363,9 @@ Theorem eval_ind_alt ¬(s.clock < ticks + 1) ⇒ P ([exp],args,dec_clock (ticks + 1) s)) ∧ P (xs,env,s1) ⇒ P ([Call ticks dest xs],env,s1)) ⇒ - ∀v v1 v2. P (v,v1,v2:('c,'ffi) bvlSem$state)` - (rpt strip_tac + ∀v v1 v2. P (v,v1,v2:('c,'ffi) bvlSem$state) +Proof + rpt strip_tac \\ HO_MATCH_MP_TAC (MP_CANON WF_INDUCTION_THM) \\ WF_REL_TAC `(inv_image (measure I LEX measure exp1_size) (\(xs,env,s). (s.clock,xs)))` @@ -1343,17 +1380,20 @@ Theorem eval_ind_alt \\ rw [] \\ first_x_assum match_mp_tac \\ fs [] \\ imp_res_tac bvlSemTheory.evaluate_clock \\ fs [LESS_OR_EQ,bvlTheory.exp_size_def] - \\ fs [bvlSemTheory.dec_clock_def]); + \\ fs [bvlSemTheory.dec_clock_def] +QED -Theorem EVERY_isVar_evaluate_Rval_MEM - `!l env a s r. +Theorem EVERY_isVar_evaluate_Rval_MEM: + !l env a s r. EVERY isVar l /\ bvlSem$evaluate (l,env,s) = (Rval a,r) ==> - EVERY (\x. MEM x env) a /\ s = r` - (Induct \\ fs [bvlSemTheory.evaluate_def] + EVERY (\x. MEM x env) a /\ s = r +Proof + Induct \\ fs [bvlSemTheory.evaluate_def] \\ Cases_on `h` \\ fs[isVar_def] \\ Cases_on `l` \\ fs [bvlSemTheory.evaluate_def] \\ rw [] \\ every_case_tac \\ fs [] \\ rveq \\ fs [] \\ res_tac \\ fs [] \\ rveq - \\ fs [MEM_EL] \\ asm_exists_tac \\ fs []); + \\ fs [MEM_EL] \\ asm_exists_tac \\ fs [] +QED val do_app_Ref = Q.prove( `do_app Ref vs s = @@ -1366,15 +1406,16 @@ val do_app_Ref = Q.prove( fs [iEvalOp_def,do_app_aux_def,bEvalOp_def,LET_THM] \\ every_case_tac \\ fs []); -Theorem state_rel_add_bytearray - `state_rel b2 s5 (t2:('c,'ffi) bviSem$state) ∧ +Theorem state_rel_add_bytearray: + state_rel b2 s5 (t2:('c,'ffi) bviSem$state) ∧ state_ok s5 ∧ pp ∉ FDOM s5.refs ∧ qq ∉ FDOM t2.refs ⇒ state_rel ((pp =+ qq) b2) (s5 with refs := s5.refs |+ (pp,ByteArray fl ws)) - (t2 with refs := t2.refs |+ (qq,ByteArray fl ws))` - (strip_tac + (t2 with refs := t2.refs |+ (qq,ByteArray fl ws)) +Proof + strip_tac \\ fs[state_rel_def,FLOOKUP_UPDATE] \\ conj_tac >- ( match_mp_tac INJ_EXTEND \\ fs[] ) \\ conj_tac @@ -1412,7 +1453,8 @@ Theorem state_rel_add_bytearray \\ fs[state_ok_def,EVERY_MEM] \\ res_tac \\ fs[] \\ rw[] - \\ metis_tac[INJ_DEF] ); + \\ metis_tac[INJ_DEF] +QED val iEval_bVarBound_extra = prove( ``∀n xs n vs s env d. @@ -1430,28 +1472,33 @@ val MAP_Word_11 = prove( ``!ns ns'. MAP Word64 ns = MAP Word64 ns' <=> ns' = ns``, Induct \\ Cases_on `ns'` \\ fs [] \\ rw [] \\ eq_tac \\ rw []); -Theorem IMP_v_to_bytes - `!v1 ns. +Theorem IMP_v_to_bytes: + !v1 ns. v_to_list v1 = SOME (MAP (Number ∘ $& ∘ w2n) ns) ==> - v_to_bytes (adjust_bv b2 v1) = SOME ns` - (fs [v_to_bytes_def,v_to_list_adjust,MAP_MAP_o,o_DEF,adjust_bv_def,MAP_Num_11]); + v_to_bytes (adjust_bv b2 v1) = SOME ns +Proof + fs [v_to_bytes_def,v_to_list_adjust,MAP_MAP_o,o_DEF,adjust_bv_def,MAP_Num_11] +QED -Theorem IMP_v_to_words - `v_to_list v2 = SOME (MAP Word64 ns') ==> - v_to_words (adjust_bv b2 v2) = SOME ns'` - (fs [v_to_words_def,v_to_list_adjust,MAP_MAP_o,o_DEF,adjust_bv_def,MAP_Word_11] - \\ CONV_TAC (DEPTH_CONV ETA_CONV) \\ fs [MAP_Word_11]); +Theorem IMP_v_to_words: + v_to_list v2 = SOME (MAP Word64 ns') ==> + v_to_words (adjust_bv b2 v2) = SOME ns' +Proof + fs [v_to_words_def,v_to_list_adjust,MAP_MAP_o,o_DEF,adjust_bv_def,MAP_Word_11] + \\ CONV_TAC (DEPTH_CONV ETA_CONV) \\ fs [MAP_Word_11] +QED val sorted_lt_append = Q.ISPEC`prim_rec$<`SORTED_APPEND |> SIMP_RULE std_ss [transitive_LESS] -Theorem aux_code_installed_sublist - `∀aux ls. +Theorem aux_code_installed_sublist: + ∀aux ls. IS_SUBLIST ls aux ∧ ALL_DISTINCT (MAP FST ls) ⇒ - aux_code_installed aux (fromAList ls)` - (Induct >> simp[aux_code_installed_def] >> + aux_code_installed aux (fromAList ls) +Proof + Induct >> simp[aux_code_installed_def] >> qx_gen_tac`p`>>PairCases_on`p`>> Cases >> simp[IS_SUBLIST] >> strip_tac >- ( simp[aux_code_installed_def,lookup_fromAList] >> @@ -1474,51 +1521,66 @@ Theorem aux_code_installed_sublist BasicProvers.CASE_TAC >> imp_res_tac ALOOKUP_MEM >> full_simp_tac(srw_ss())[MEM_MAP,PULL_EXISTS,EXISTS_PROD] >> - METIS_TAC[PAIR]); + METIS_TAC[PAIR] +QED -Theorem compile_exps_aux_sorted - `∀n es c aux n1. compile_exps n es = (c,aux,n1) ⇒ +Theorem compile_exps_aux_sorted: + ∀n es c aux n1. compile_exps n es = (c,aux,n1) ⇒ SORTED $< (MAP FST (append aux)) ∧ EVERY (λx. ∃n. x = num_stubs + nss * n + 1) (MAP FST (append aux)) ∧ - EVERY (between (num_stubs + nss * n) (num_stubs + nss * n1)) (MAP FST (append aux)) ∧ n ≤ n1` - (ho_match_mp_tac compile_exps_ind >> + EVERY (between (num_stubs + nss * n) (num_stubs + nss * n1)) (MAP FST (append aux)) ∧ n ≤ n1 +Proof + ho_match_mp_tac compile_exps_ind >> simp[compile_exps_def] >> srw_tac[][] >> rpt (pairarg_tac >> full_simp_tac(srw_ss())[]) >> srw_tac[][compile_aux_def] >> rpt ((sorted_lt_append |> match_mp_tac) >> full_simp_tac(srw_ss())[] >> srw_tac[][] ) >> fs[EVERY_MEM,between_def,backend_commonTheory.bvl_to_bvi_namespaces_def] >> - srw_tac[][] >> res_tac >> (decide_tac ORELSE metis_tac[ADD_COMM,ADD_ASSOC])); + srw_tac[][] >> res_tac >> (decide_tac ORELSE metis_tac[ADD_COMM,ADD_ASSOC]) +QED val in_ns_def = Define`in_ns k n ⇔ n MOD nss = k`; -Theorem nss_in_ns[simp] - `in_ns k nss ⇔ k = 0` - (rw[in_ns_def,backend_commonTheory.bvl_to_bvi_namespaces_def]); +Theorem nss_in_ns[simp]: + in_ns k nss ⇔ k = 0 +Proof + rw[in_ns_def,backend_commonTheory.bvl_to_bvi_namespaces_def] +QED -Theorem mult_nss_in_ns[simp] - `in_ns k (m * nss) ⇔ k = 0` - (rw[in_ns_def,backend_commonTheory.bvl_to_bvi_namespaces_def]); +Theorem mult_nss_in_ns[simp]: + in_ns k (m * nss) ⇔ k = 0 +Proof + rw[in_ns_def,backend_commonTheory.bvl_to_bvi_namespaces_def] +QED -Theorem mult_nss_in_ns_1[simp] - `in_ns k (m * nss + 1) ⇔ k = 1` - (rw[in_ns_def,backend_commonTheory.bvl_to_bvi_namespaces_def]); +Theorem mult_nss_in_ns_1[simp]: + in_ns k (m * nss + 1) ⇔ k = 1 +Proof + rw[in_ns_def,backend_commonTheory.bvl_to_bvi_namespaces_def] +QED -Theorem mult_nss_in_ns_2[simp] - `in_ns k (m * nss + 2) ⇔ k = 2` - (rw[in_ns_def,backend_commonTheory.bvl_to_bvi_namespaces_def]); +Theorem mult_nss_in_ns_2[simp]: + in_ns k (m * nss + 2) ⇔ k = 2 +Proof + rw[in_ns_def,backend_commonTheory.bvl_to_bvi_namespaces_def] +QED -Theorem in_ns_1_add_1 - `in_ns 0 x ⇒ in_ns 1 (x + 1)` - (rw[in_ns_def,backend_commonTheory.bvl_to_bvi_namespaces_def] +Theorem in_ns_1_add_1: + in_ns 0 x ⇒ in_ns 1 (x + 1) +Proof + rw[in_ns_def,backend_commonTheory.bvl_to_bvi_namespaces_def] \\ qspecl_then[`3`,`x`,`1`]mp_tac(Q.GENL[`n`,`x`,`k`]MOD_LIFT_PLUS_IFF) - \\ simp[]); + \\ simp[] +QED val ODD_num_stubs = EVAL``in_ns 0 num_stubs``; -Theorem in_ns_add_num_stubs[simp] - `in_ns k (num_stubs + x) ⇔ in_ns k x` - (assume_tac ODD_num_stubs \\ fs[in_ns_def] \\ +Theorem in_ns_add_num_stubs[simp]: + in_ns k (num_stubs + x) ⇔ in_ns k x +Proof + assume_tac ODD_num_stubs \\ fs[in_ns_def] \\ qspecl_then[`nss`,`num_stubs`,`num_stubs MOD nss`,`x`]mp_tac ADD_MOD \\ - impl_keep_tac >- EVAL_TAC \\ simp[]); + impl_keep_tac >- EVAL_TAC \\ simp[] +QED val compile_list_imp = Q.prove( `∀n prog code n' name arity exp. @@ -1574,8 +1636,8 @@ val in_ns_0_simp = prove( fs [in_ns_def] \\ EVAL_TAC \\ `0 < nss` by EVAL_TAC \\ fs [EVAL ``nss``]); -Theorem compile_inc_lemma - `compile_inc next1 prog1 = (next2,prog2) ==> +Theorem compile_inc_lemma: + compile_inc next1 prog1 = (next2,prog2) ==> (ALL_DISTINCT (MAP FST prog1) ==> ALL_DISTINCT (MAP FST prog2)) /\ next1 <= next2 /\ (!p. MEM (num_stubs + p * nss) (MAP FST prog2) ==> @@ -1583,8 +1645,9 @@ Theorem compile_inc_lemma (!p. MEM p (MAP FST prog2) ==> if in_ns 0 p then (?q. num_stubs + q * nss = p) else in_ns 1 p /\ num_stubs + nss * next1 <= p /\ - p < num_stubs + nss * next2)` - (fs [compile_inc_def] + p < num_stubs + nss * next2) +Proof + fs [compile_inc_def] \\ rpt (pairarg_tac \\ fs []) \\ strip_tac \\ rveq \\ fs [] \\ rpt (pop_assum mp_tac) \\ qid_spec_tac `next1` @@ -1616,32 +1679,39 @@ Theorem compile_inc_lemma \\ fs [EVERY_MEM] \\ res_tac \\ fs [between_def] \\ rveq \\ fs [EVAL ``nss``] \\ rw [] \\ fs [] - \\ asm_exists_tac \\ fs []); + \\ asm_exists_tac \\ fs [] +QED -Theorem compile_inc_next - `compile_inc next1 prog1 = (next2,prog2) ==> - next1 <= next2` - (rw [] \\ drule compile_inc_lemma \\ rw []); +Theorem compile_inc_next: + compile_inc next1 prog1 = (next2,prog2) ==> + next1 <= next2 +Proof + rw [] \\ drule compile_inc_lemma \\ rw [] +QED -Theorem compile_inc_DISTINCT - `compile_inc next1 prog1 = (next2,prog2) /\ +Theorem compile_inc_DISTINCT: + compile_inc next1 prog1 = (next2,prog2) /\ ALL_DISTINCT (MAP FST prog1) ==> - ALL_DISTINCT (MAP FST prog2)` - (rw [] \\ drule compile_inc_lemma \\ rw []); + ALL_DISTINCT (MAP FST prog2) +Proof + rw [] \\ drule compile_inc_lemma \\ rw [] +QED -Theorem compile_inc_next_range - `compile_inc next1 prog1 = (next2,prog2) /\ +Theorem compile_inc_next_range: + compile_inc next1 prog1 = (next2,prog2) /\ MEM x (MAP FST prog2) ==> if in_ns_1 x then num_stubs + nss * next1 <= x /\ x < num_stubs + nss * next2 - else in_ns_0 x /\ num_stubs <= x /\ MEM ((x - num_stubs) DIV nss) (MAP FST prog1)` - (rpt strip_tac + else in_ns_0 x /\ num_stubs <= x /\ MEM ((x - num_stubs) DIV nss) (MAP FST prog1) +Proof + rpt strip_tac \\ drule (GEN_ALL compile_inc_lemma) \\ rpt strip_tac \\ first_x_assum drule \\ Cases_on `in_ns 1 x` \\ fs [in_ns_def] \\ rw [] \\ first_x_assum match_mp_tac - \\ fs [EVAL ``nss``,ONCE_REWRITE_RULE [MULT_COMM] MULT_DIV]); + \\ fs [EVAL ``nss``,ONCE_REWRITE_RULE [MULT_COMM] MULT_DIV] +QED val not_in_ns_1 = prove( ``~(in_ns_1 (num_stubs + name * nss))``, @@ -3265,16 +3335,17 @@ val _ = save_thm("compile_exps_correct",compile_exps_correct); (* composed compiler correctness *) -Theorem compile_single_evaluate - `evaluate ([Call 0 (SOME start) []],[],s1) = (res,s2) ∧ +Theorem compile_single_evaluate: + evaluate ([Call 0 (SOME start) []],[],s1) = (res,s2) ∧ state_rel b1 s1 t1 ∧ IS_SOME t1.global ∧ state_ok s1 ∧ res ≠ Rerr (Rabort Rtype_error) ⇒ ∃ck b2 t2. evaluate ([Call 0 (SOME (num_stubs + nss * start))[] NONE],[],inc_clock ck t1) = (map_result (MAP (adjust_bv b2)) (adjust_bv b2) res,t2) ∧ - state_rel b2 s2 (t2:('c,'ffi) bviSem$state)` - (srw_tac[][] >> + state_rel b2 s2 (t2:('c,'ffi) bviSem$state) +Proof + srw_tac[][] >> full_simp_tac(srw_ss())[bvlSemTheory.evaluate_def] >> full_simp_tac(srw_ss())[find_code_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> @@ -3304,7 +3375,8 @@ Theorem compile_single_evaluate simp[] >> imp_res_tac bvi_letProofTheory.evaluate_compile_exp >> rfs[] >> Cases_on`res`>>simp[] >- METIS_TAC[] >> - Cases_on`e`>>simp[] >> METIS_TAC[]); + Cases_on`e`>>simp[] >> METIS_TAC[] +QED val evaluate_REPLICATE_0 = Q.prove( `!n. evaluate (REPLICATE n (Op (Const 0) []),env,s) = @@ -3314,8 +3386,8 @@ val evaluate_REPLICATE_0 = Q.prove( \\ fs [evaluate_def,REPLICATE,do_app_def,do_app_aux_def] \\ fs [EVAL ``small_enough_int 0``]); -Theorem bvi_stubs_evaluate - `∀kk start ffi0 code k. +Theorem bvi_stubs_evaluate: + ∀kk start ffi0 code k. 0 < k ∧ num_stubs ≤ start ⇒ let t0 = <| global := SOME 0 ; ffi := ffi0 @@ -3330,8 +3402,9 @@ Theorem bvi_stubs_evaluate evaluate ([Call 0 (SOME InitGlobals_location) [] NONE],[], initial_state ffi0 (fromAList (stubs start kk ++ code)) co cc (k+1)) = let (r,s) = evaluate ([Call 0 (SOME start) [] NONE],[],t0) in - ((case r of Rerr(Rraise v) => Rval [v] | _ => r), s)` - (srw_tac[][bviSemTheory.evaluate_def,find_code_def, + ((case r of Rerr(Rraise v) => Rval [v] | _ => r), s) +Proof + srw_tac[][bviSemTheory.evaluate_def,find_code_def, lookup_fromAList,ALOOKUP_APPEND] >> srw_tac[][Once stubs_def] >> TRY (pop_assum(assume_tac o CONV_RULE EVAL)>>full_simp_tac(srw_ss())[]>>NO_TAC) >> @@ -3360,10 +3433,11 @@ Theorem bvi_stubs_evaluate \\ IF_CASES_TAC \\ fs [] \\ rveq \\ fs [] \\ CASE_TAC \\ fs [] \\ CASE_TAC \\ fs [] \\ rveq \\ fs [] - \\ CASE_TAC \\ fs [] \\ rveq \\ fs []); + \\ CASE_TAC \\ fs [] \\ rveq \\ fs [] +QED -Theorem compile_list_distinct_locs - `∀n prog code_app code n'. +Theorem compile_list_distinct_locs: + ∀n prog code_app code n'. ALL_DISTINCT (MAP FST prog) ∧ compile_list n prog = (code_app,n') ∧ code = append code_app @@ -3375,8 +3449,9 @@ Theorem compile_list_distinct_locs MAP (λn. num_stubs + nss * n) (MAP FST prog) ∧ (* redundant, but useful *) EVERY ($<= num_stubs) (MAP FST code) ∧ EVERY (λn. ¬ in_ns 2 (n - num_stubs)) (MAP FST code) ∧ - n ≤ n'` - (Induct_on`prog`>>simp[compile_list_def]>> + n ≤ n' +Proof + Induct_on`prog`>>simp[compile_list_def]>> qx_gen_tac`p`>>PairCases_on`p`>> rpt gen_tac >> strip_tac >> pairarg_tac >> full_simp_tac(srw_ss())[] >> @@ -3428,10 +3503,11 @@ Theorem compile_list_distinct_locs `MEM (FST x) l2` by METIS_TAC[] >> pop_assum mp_tac >> unabbrev_all_tac >> simp[MEM_MAP,EXISTS_PROD] >> - fs[backend_commonTheory.bvl_to_bvi_namespaces_def]); + fs[backend_commonTheory.bvl_to_bvi_namespaces_def] +QED -Theorem compile_prog_evaluate - `compile_prog start n prog = (start', prog', n') ∧ +Theorem compile_prog_evaluate: + compile_prog start n prog = (start', prog', n') ∧ evaluate ([Call 0 (SOME start) []],[], initial_state ffi0 (fromAList prog) co (state_cc compile_inc cc) k) = (r,s) ∧ 0 < k ∧ @@ -3446,8 +3522,9 @@ Theorem compile_prog_evaluate initial_state ffi0 (fromAList prog') (state_co compile_inc co) cc (k+ck)) = (map_result (MAP (adjust_bv b2)) (adjust_bv b2) (case r of Rerr(Rraise v) => Rval [v] | _ => r),s2) ∧ - state_rel b2 s (s2:('c,'ffi) bviSem$state)` -((* + state_rel b2 s (s2:('c,'ffi) bviSem$state) +Proof +(* theorems to compose: bvi_stubs_evaluate compile_single_evaluate @@ -3576,10 +3653,11 @@ Theorem compile_prog_evaluate fsrw_tac[ARITH_ss][inc_clock_def] >> Cases_on`r`>>full_simp_tac(srw_ss())[]>> TRY(Cases_on`e`)>>full_simp_tac(srw_ss())[] >> - PROVE_TAC[ADD_ASSOC,ADD_COMM]); + PROVE_TAC[ADD_ASSOC,ADD_COMM] +QED -Theorem compile_prog_semantics - `compile_prog start n prog = (start', prog', n') ∧ +Theorem compile_prog_semantics: + compile_prog start n prog = (start', prog', n') ∧ ALL_DISTINCT (MAP FST prog) ∧ handle_ok (MAP (SND o SND) prog) ∧ (∀n. EVERY ((λe. handle_ok [e]) o SND o SND) (SND (co n))) ∧ @@ -3587,8 +3665,9 @@ Theorem compile_prog_semantics semantics (ffi0:'ffi ffi_state) (fromAList prog) co (state_cc compile_inc cc) start ≠ Fail ⇒ semantics ffi0 (fromAList prog') (state_co compile_inc co) cc start' = - semantics ffi0 (fromAList prog) co (state_cc compile_inc cc) start` - (simp[GSYM AND_IMP_INTRO] >> ntac 5 strip_tac >> + semantics ffi0 (fromAList prog) co (state_cc compile_inc cc) start +Proof + simp[GSYM AND_IMP_INTRO] >> ntac 5 strip_tac >> simp[bvlSemTheory.semantics_def] >> IF_CASES_TAC >> full_simp_tac(srw_ss())[] >> DEEP_INTRO_TAC some_intro >> simp[] >> @@ -3773,15 +3852,17 @@ Theorem compile_prog_semantics |> Q.SPEC`s with clock := k` |> SIMP_RULE(srw_ss())[bviPropsTheory.inc_clock_def], SND,ADD_SYM]) >> - full_simp_tac(srw_ss())[IS_PREFIX_APPEND] >> simp[EL_APPEND1]); + full_simp_tac(srw_ss())[IS_PREFIX_APPEND] >> simp[EL_APPEND1] +QED -Theorem compile_prog_distinct_locs - `compile_prog start n prog = (k,prog1,n1) /\ ALL_DISTINCT (MAP FST prog) ==> +Theorem compile_prog_distinct_locs: + compile_prog start n prog = (k,prog1,n1) /\ ALL_DISTINCT (MAP FST prog) ==> ALL_DISTINCT (MAP FST prog1) /\ EVERY (between (nss * n + num_stubs) (nss * n1 + num_stubs)) (FILTER (λn. in_ns 1 (n − num_stubs)) (MAP FST prog1)) /\ - EVERY (λn. ¬in_ns 2 (n - num_stubs)) (MAP FST prog1)` - (fs [compile_prog_def] \\ pairarg_tac \\ fs [] \\ strip_tac \\ rveq + EVERY (λn. ¬in_ns 2 (n - num_stubs)) (MAP FST prog1) +Proof + fs [compile_prog_def] \\ pairarg_tac \\ fs [] \\ strip_tac \\ rveq \\ drule (compile_list_distinct_locs |> SIMP_RULE std_ss []) \\ disch_then drule \\ fs [ALL_DISTINCT_APPEND] \\ rw [] THEN1 EVAL_TAC @@ -3791,7 +3872,8 @@ Theorem compile_prog_distinct_locs \\ CCONTR_TAC \\ fs [] \\ fs [EVERY_MEM] \\ res_tac \\ rveq \\ pop_assum mp_tac \\ EVAL_TAC) - \\ fs [FILTER_APPEND] \\ EVAL_TAC); + \\ fs [FILTER_APPEND] \\ EVAL_TAC +QED val ODD_lemma = prove( ``ODD (2 * n + k) = ODD k``, @@ -3811,12 +3893,13 @@ val full_co_def = Define ` let cut = c.exp_cut in bvi_tailrecProof$mk_co (state_co compile_inc (state_co (compile_inc limit split cut) co))` -Theorem compile_prog_avoids_nss_2 - `compile_prog start f prog = (loc,code,new_state) /\ +Theorem compile_prog_avoids_nss_2: + compile_prog start f prog = (loc,code,new_state) /\ ALL_DISTINCT (MAP FST prog) /\ k MOD nss = 2 /\ MEM k (MAP FST code) ==> - k ≤ num_stubs` - (fs [compile_prog_def] \\ pairarg_tac \\ fs [] + k ≤ num_stubs +Proof + fs [compile_prog_def] \\ pairarg_tac \\ fs [] \\ rw [] \\ fs [] THEN1 (pop_assum mp_tac \\ EVAL_TAC \\ rw []) \\ imp_res_tac (compile_list_distinct_locs |> SIMP_RULE std_ss []) @@ -3829,10 +3912,11 @@ Theorem compile_prog_avoids_nss_2 \\ `(p MOD nss + num_stubs MOD nss) MOD nss = (p + num_stubs) MOD nss` by (match_mp_tac MOD_PLUS \\ EVAL_TAC) \\ fs [EVAL ``num_stubs MOD nss``] - \\ `0 < nss` by EVAL_TAC \\ fs []); + \\ `0 < nss` by EVAL_TAC \\ fs [] +QED -Theorem compile_semantics - `compile start c prog = (start', prog', inlines, n1, n2) ∧ +Theorem compile_semantics: + compile start c prog = (start', prog', inlines, n1, n2) ∧ FST (FST (co 0)) = inlines /\ FST (SND (FST (co 0))) = n1 /\ FST (SND (SND (FST (co 0)))) = n2 /\ @@ -3842,8 +3926,9 @@ Theorem compile_semantics semantics (ffi0:'ffi ffi_state) (fromAList prog) co (full_cc c cc) start ≠ Fail ⇒ semantics ffi0 (fromAList prog') (full_co c co) cc start' = - semantics ffi0 (fromAList prog) co (full_cc c cc) start` - (rw [full_cc_def,full_co_def] + semantics ffi0 (fromAList prog) co (full_cc c cc) start +Proof + rw [full_cc_def,full_co_def] \\ drule (bvl_inlineProofTheory.compile_prog_semantics |> ONCE_REWRITE_RULE [bvi_letProofTheory.IMP_COMM] |> GEN_ALL) \\ fs [] \\ fs [compile_def] @@ -3928,11 +4013,12 @@ Theorem compile_semantics \\ IF_CASES_TAC >- ( ntac 2 (pop_assum mp_tac) \\ EVAL_TAC \\ rw[] ) \\ strip_tac - \\ rpt(qpat_x_assum`in_ns _ _`mp_tac) \\ EVAL_TAC \\ rw[]); + \\ rpt(qpat_x_assum`in_ns _ _`mp_tac) \\ EVAL_TAC \\ rw[] +QED (* -- old version of the above proof -- -Theorem compile_semantics - `compile start c prog = (start', prog', n1, n2) ∧ +Theorem compile_semantics: + compile start c prog = (start', prog', n1, n2) ∧ ALL_DISTINCT (MAP FST prog) ∧ c.next_name2 = num_stubs + 2 + x * nss ∧ (∀n. EVERY ((λe. handle_ok [e]) o SND o SND) (SND (co n))) ∧ @@ -3940,8 +4026,9 @@ Theorem compile_semantics semantics (ffi0:'ffi ffi_state) romAList prog) co (state_cc compile_inc cc) start ≠ Fail ⇒ semantics ffi0 (fromAList prog') (state_co compile_inc co) cc start' = - semantics ffi0 (fromAList prog) co (state_cc compile_inc cc) start` - (srw_tac[][compile_def] + semantics ffi0 (fromAList prog) co (state_cc compile_inc cc) start +Proof + srw_tac[][compile_def] \\ fs [LET_THM] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ drule (GEN_ALL compile_prog_semantics) @@ -3974,17 +4061,19 @@ Theorem compile_semantics \\ disch_then drule \\ simp [bvi_tailrecTheory.compile_prog_def] \\ disch_then (qspecl_then [`loc`,`ffi0`] mp_tac) - \\ metis_tac [bvl_inlineProofTheory.compile_prog_semantics,PAIR,FST,SND]); + \\ metis_tac [bvl_inlineProofTheory.compile_prog_semantics,PAIR,FST,SND] +QED *) -Theorem compile_distinct_names - ` bvl_to_bvi$compile n0 c p2 = (k,p3,n1,n2) /\ +Theorem compile_distinct_names: + bvl_to_bvi$compile n0 c p2 = (k,p3,n1,n2) /\ ALL_DISTINCT (MAP FST p2) /\ c.next_name2 = bvl_num_stubs + 2 + n02 * nss ==> EVERY (λn. data_num_stubs ≤ n) (MAP FST p3) /\ - ALL_DISTINCT (MAP FST p3)` - (fs[bvl_to_bviTheory.compile_def]>> + ALL_DISTINCT (MAP FST p3) +Proof + fs[bvl_to_bviTheory.compile_def]>> strip_tac>> rpt (pairarg_tac>>fs[]>>rveq>>fs[])>> drule (GEN_ALL compile_prog_distinct_locs) >> @@ -4033,14 +4122,16 @@ Theorem compile_distinct_names \\ fs[GSYM append_def] \\ res_tac \\ pop_assum mp_tac - \\ EVAL_TAC \\ rw[]); + \\ EVAL_TAC \\ rw[] +QED -Theorem ALL_DISTINCT_MAP_FST_SND_full_co - `ALL_DISTINCT (MAP FST (SND (co n))) ∧ +Theorem ALL_DISTINCT_MAP_FST_SND_full_co: + ALL_DISTINCT (MAP FST (SND (co n))) ∧ (FST (SND (SND (FST (co n)))) MOD bvl_to_bvi_namespaces = 2) ⇒ - ALL_DISTINCT (MAP FST (SND (full_co c co n)))` - (rw[full_co_def, bvi_tailrecProofTheory.mk_co_def, UNCURRY, backendPropsTheory.FST_state_co] + ALL_DISTINCT (MAP FST (SND (full_co c co n))) +Proof + rw[full_co_def, bvi_tailrecProofTheory.mk_co_def, UNCURRY, backendPropsTheory.FST_state_co] \\ qmatch_goalsub_abbrev_tac`bvi_tailrec$compile_prog m xs` \\ Cases_on`bvi_tailrec$compile_prog m xs` \\ drule bvi_tailrecProofTheory.compile_prog_ALL_DISTINCT @@ -4067,41 +4158,49 @@ Theorem ALL_DISTINCT_MAP_FST_SND_full_co \\ qpat_x_assum`_ MOD _ = _`mp_tac \\ qpat_x_assum`_ MOD _ = _`mp_tac \\ EVAL_TAC \\ simp[] ) - \\ simp[]); + \\ simp[] +QED -Theorem destLet_code_labels - `destLet x = (y,z) ⇒ - BIGUNION (set (MAP get_code_labels y)) ∪ get_code_labels z ⊆ get_code_labels x` - (Cases_on`x` +Theorem destLet_code_labels: + destLet x = (y,z) ⇒ + BIGUNION (set (MAP get_code_labels y)) ∪ get_code_labels z ⊆ get_code_labels x +Proof + Cases_on`x` \\ rw[bvl_to_bviTheory.destLet_def] - \\ fs[bvl_to_bviTheory.destLet_def]); + \\ fs[bvl_to_bviTheory.destLet_def] +QED -Theorem compile_int_code_labels[simp] - `∀i. get_code_labels (compile_int i) = {}` - (recInduct bvl_to_bviTheory.compile_int_ind +Theorem compile_int_code_labels[simp]: + ∀i. get_code_labels (compile_int i) = {} +Proof + recInduct bvl_to_bviTheory.compile_int_ind \\ rw[] \\ rw[Once bvl_to_bviTheory.compile_int_def] - \\ rw[closLangTheory.assign_get_code_label_def]); + \\ rw[closLangTheory.assign_get_code_label_def] +QED -Theorem compile_op_code_labels - `get_code_labels (compile_op op c) ⊆ +Theorem compile_op_code_labels: + get_code_labels (compile_op op c) ⊆ BIGUNION (set (MAP get_code_labels c)) ∪ IMAGE (λn. bvl_num_stubs + n * bvl_to_bvi_namespaces) (closLang$assign_get_code_label op) ∪ - set (MAP FST (bvl_to_bvi$stubs x y))` - (simp[bvl_to_bviTheory.compile_op_def, bvl_to_bviTheory.stubs_def, SUBSET_DEF] + set (MAP FST (bvl_to_bvi$stubs x y)) +Proof + simp[bvl_to_bviTheory.compile_op_def, bvl_to_bviTheory.stubs_def, SUBSET_DEF] \\ every_case_tac \\ fs[closLangTheory.assign_get_code_label_def, REPLICATE_GENLIST, PULL_EXISTS, MAPi_GENLIST, MEM_GENLIST] - \\ rw[] \\ fsrw_tac[DNF_ss][PULL_EXISTS] \\ metis_tac[]); + \\ rw[] \\ fsrw_tac[DNF_ss][PULL_EXISTS] \\ metis_tac[] +QED -Theorem compile_exps_get_code_labels - `∀n xs ys aux m. +Theorem compile_exps_get_code_labels: + ∀n xs ys aux m. bvl_to_bvi$compile_exps n xs = (ys,aux,m) ⇒ BIGUNION (set (MAP get_code_labels ys)) ∪ BIGUNION (set (MAP (get_code_labels o SND o SND) (append aux))) ⊆ IMAGE (λk. bvl_num_stubs + (k * bvl_to_bvi_namespaces)) (BIGUNION (set (MAP get_code_labels xs))) ∪ { bvl_num_stubs + (k * bvl_to_bvi_namespaces + 1) | k | n ≤ k ∧ k < m } ∪ - set (MAP FST (bvl_to_bvi$stubs x y))` - (recInduct bvl_to_bviTheory.compile_exps_ind + set (MAP FST (bvl_to_bvi$stubs x y)) +Proof + recInduct bvl_to_bviTheory.compile_exps_ind \\ rw[bvl_to_bviTheory.compile_exps_def] \\ rpt (pairarg_tac \\ fs[]) \\ rveq \\ fs[] \\ imp_res_tac destLet_code_labels \\ fs[NULL_EQ] @@ -4162,12 +4261,14 @@ Theorem compile_exps_get_code_labels \\ metis_tac[LESS_LESS_EQ_TRANS, LESS_TRANS, LESS_EQ_TRANS, LESS_EQ_LESS_TRANS, DECIDE``n < n+1n``]) >- ( Cases_on`dest` \\ fs[] \\ rw[] \\ res_tac \\ fs[] - \\ metis_tac[LESS_LESS_EQ_TRANS, LESS_TRANS, LESS_EQ_TRANS, LESS_EQ_LESS_TRANS, DECIDE``n < n+1n``])); + \\ metis_tac[LESS_LESS_EQ_TRANS, LESS_TRANS, LESS_EQ_TRANS, LESS_EQ_LESS_TRANS, DECIDE``n < n+1n``]) +QED -Theorem compile_exps_aux_contains - `∀n es c aux n1. compile_exps n es = (c,aux,n1) ⇒ - { bvl_num_stubs + (k * bvl_to_bvi_namespaces + 1) | k | n ≤ k ∧ k < n1 } ⊆ set (MAP FST (append aux))` - (ho_match_mp_tac bvl_to_bviTheory.compile_exps_ind +Theorem compile_exps_aux_contains: + ∀n es c aux n1. compile_exps n es = (c,aux,n1) ⇒ + { bvl_num_stubs + (k * bvl_to_bvi_namespaces + 1) | k | n ≤ k ∧ k < n1 } ⊆ set (MAP FST (append aux)) +Proof + ho_match_mp_tac bvl_to_bviTheory.compile_exps_ind \\ rw[bvl_to_bviTheory.compile_exps_def] \\ rpt (pairarg_tac \\ fs[]) \\ rveq \\ fs[] \\ fs[SUBSET_DEF, PULL_EXISTS] \\ rw[] @@ -4202,15 +4303,17 @@ Theorem compile_exps_aux_contains \\ Cases_on`k < n3` >- metis_tac[] \\ fs[NOT_LESS] \\ `k = n3` by decide_tac \\ rveq \\ fs[] - \\ fs[bvl_to_bviTheory.compile_aux_def] )); + \\ fs[bvl_to_bviTheory.compile_aux_def] ) +QED -Theorem compile_single_get_code_labels - `∀n p code m. compile_single n p = (code, m) ⇒ +Theorem compile_single_get_code_labels: + ∀n p code m. compile_single n p = (code, m) ⇒ BIGUNION (set (MAP (get_code_labels o SND o SND) (append code))) ⊆ IMAGE (λk. bvl_num_stubs + k * bvl_to_bvi_namespaces) (get_code_labels (SND(SND p))) ∪ set (MAP FST (append code)) ∪ - set (MAP FST (bvl_to_bvi$stubs x y))` - (rw[] + set (MAP FST (bvl_to_bvi$stubs x y)) +Proof + rw[] \\ PairCases_on`p` \\ fs[bvl_to_bviTheory.compile_single_def] \\ pairarg_tac \\ fs[] \\ rveq \\ fs[] @@ -4222,17 +4325,19 @@ Theorem compile_single_get_code_labels \\ fs[SUBSET_DEF, PULL_EXISTS] \\ strip_tac \\ drule compile_exps_aux_contains \\ fsrw_tac[DNF_ss][SUBSET_DEF] \\ rw[] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem compile_list_get_code_labels - `∀n p code m. compile_list n p = (code,m) ⇒ +Theorem compile_list_get_code_labels: + ∀n p code m. compile_list n p = (code,m) ⇒ n ≤ m ∧ BIGUNION (set (MAP (get_code_labels o SND o SND) (append code))) ⊆ set (MAP FST (append code)) ∪ IMAGE (λk. bvl_num_stubs + k * bvl_to_bvi_namespaces) (BIGUNION (set (MAP (get_code_labels o SND o SND) p))) ∪ - set (MAP FST (bvl_to_bvi$stubs x y))` - (Induct_on`p` + set (MAP FST (bvl_to_bvi$stubs x y)) +Proof + Induct_on`p` \\ rw[bvl_to_bviTheory.compile_list_def] >- (EVAL_TAC \\ rw[]) \\ pairarg_tac \\ fs[] @@ -4262,16 +4367,18 @@ Theorem compile_list_get_code_labels \\ fs[bvl_to_bviTheory.compile_single_def] \\ pairarg_tac \\ fs[] \\ imp_res_tac compile_exps_aux_sorted - \\ metis_tac[LESS_LESS_EQ_TRANS,LESS_EQ_LESS_TRANS,LESS_TRANS,LESS_EQ_TRANS] )); + \\ metis_tac[LESS_LESS_EQ_TRANS,LESS_EQ_LESS_TRANS,LESS_TRANS,LESS_EQ_TRANS] ) +QED -Theorem compile_prog_get_code_labels - `∀s n p t q m. +Theorem compile_prog_get_code_labels: + ∀s n p t q m. bvl_to_bvi$compile_prog s n p = (t,q,m) ⇒ BIGUNION (set (MAP (get_code_labels o SND o SND) q)) ⊆ bvl_num_stubs + s * bvl_to_bvi_namespaces INSERT set (MAP FST q) ∪ - IMAGE (λk. bvl_num_stubs + (k * bvl_to_bvi_namespaces)) (BIGUNION (set (MAP (get_code_labels o SND o SND) p))) ` - (rw[bvl_to_bviTheory.compile_prog_def] + IMAGE (λk. bvl_num_stubs + (k * bvl_to_bvi_namespaces)) (BIGUNION (set (MAP (get_code_labels o SND o SND) p))) +Proof + rw[bvl_to_bviTheory.compile_prog_def] \\ pairarg_tac \\ fs[] \\ rveq \\ simp[] \\ drule (GEN_ALL compile_list_get_code_labels) @@ -4284,15 +4391,17 @@ Theorem compile_prog_get_code_labels \\ simp[bvl_to_bviTheory.stubs_def] \\ rpt conj_tac \\ CONV_TAC(LAND_CONV EVAL) \\ simp[] \\ EVAL_TAC - \\ simp[]); + \\ simp[] +QED -Theorem compile_list_code_labels_domain - `∀n p code m. compile_list n p = (code,m) ⇒ +Theorem compile_list_code_labels_domain: + ∀n p code m. compile_list n p = (code,m) ⇒ n ≤ m ∧ set (MAP FST (append code)) = IMAGE (λk. bvl_num_stubs + k * bvl_to_bvi_namespaces) (set (MAP FST p)) ∪ - { bvl_num_stubs + k * bvl_to_bvi_namespaces + 1 | k | n ≤ k ∧ k < m }` - (Induct_on`p` + { bvl_num_stubs + k * bvl_to_bvi_namespaces + 1 | k | n ≤ k ∧ k < m } +Proof + Induct_on`p` \\ rw[bvl_to_bviTheory.compile_list_def] >- (EVAL_TAC \\ rw[]) \\ pairarg_tac \\ fs[] @@ -4316,20 +4425,23 @@ Theorem compile_list_code_labels_domain \\ rw[EQ_IMP_THM] \\ fs[between_def] \\ res_tac \\ fs[backend_commonTheory.bvl_to_bvi_namespaces_def] \\ rveq \\ fs[EVAL``bvl_num_stubs``] \\ rw[] - \\ Cases_on`n1 ≤ k` \\ fs[]); + \\ Cases_on`n1 ≤ k` \\ fs[] +QED -Theorem compile_prog_code_labels_domain - `∀s n p t q m. +Theorem compile_prog_code_labels_domain: + ∀s n p t q m. bvl_to_bvi$compile_prog s n p = (t,q,m) ⇒ set (MAP FST q) = IMAGE (λk. bvl_num_stubs + k * bvl_to_bvi_namespaces) (set (MAP FST p)) ∪ { bvl_num_stubs + k * bvl_to_bvi_namespaces + 1 | k | n ≤ k ∧ k < m } ∪ - set (MAP FST (bvl_to_bvi$stubs x y))` - (rw[bvl_to_bviTheory.compile_prog_def] + set (MAP FST (bvl_to_bvi$stubs x y)) +Proof + rw[bvl_to_bviTheory.compile_prog_def] \\ pairarg_tac \\ fs[] \\ rveq \\ simp[] \\ drule compile_list_code_labels_domain \\ rw[] \\ rw[bvl_to_bviTheory.stubs_def] - \\ metis_tac[UNION_ASSOC, UNION_COMM]); + \\ metis_tac[UNION_ASSOC, UNION_COMM] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/clos_annotateProofScript.sml b/compiler/backend/proofs/clos_annotateProofScript.sml index 773a644f7d..88093aa887 100644 --- a/compiler/backend/proofs/clos_annotateProofScript.sml +++ b/compiler/backend/proofs/clos_annotateProofScript.sml @@ -20,14 +20,16 @@ val EVERY2_EL = LIST_REL_EL_EQN |> SPEC_ALL |> EQ_IMP_RULE |> fst val alt_fv_def = Define ` alt_fv n xs = has_var n (SND (alt_free xs))`; -Theorem alt_free_thm - `!xs. +Theorem alt_free_thm: + !xs. let (ys,l) = alt_free xs in - !n. (alt_fv n xs = has_var n l)` - (fs [alt_fv_def,UNCURRY]); + !n. (alt_fv n xs = has_var n l) +Proof + fs [alt_fv_def,UNCURRY] +QED -Theorem alt_fv - `(∀n. alt_fv n [] ⇔ F) ∧ +Theorem alt_fv: + (∀n. alt_fv n [] ⇔ F) ∧ (∀y xs x n. alt_fv n (x::y::xs) ⇔ alt_fv n [x] ∨ alt_fv n (y::xs)) ∧ (∀v0 v n. alt_fv n [Var v0 v] ⇔ n = v) ∧ (∀x3 x2 x1 v1 n. @@ -55,17 +57,22 @@ Theorem alt_fv EXISTS (λ(num_args,x). alt_fv (n + num_args + LENGTH fns) [x]) fns ∨ alt_fv (n + LENGTH fns) [x1]) ∧ (∀x2 x1 v9 n. alt_fv n [Handle v9 x1 x2] ⇔ alt_fv n [x1] ∨ alt_fv (n + 1) [x2]) ∧ - ∀xs v10 ticks n dest. alt_fv n [Call v10 ticks dest xs] ⇔ alt_fv n xs` - (rw [alt_fv_def,alt_free_def] + ∀xs v10 ticks n dest. alt_fv n [Call v10 ticks dest xs] ⇔ alt_fv n xs +Proof + rw [alt_fv_def,alt_free_def] \\ rpt (pairarg_tac \\ fs []) \\ Cases_on `has_var (n + LENGTH fns) l2` \\ fs [] \\ fs [EXISTS_MAP,UNCURRY] \\ fs [] \\ TRY (rw [] \\ fs [EXISTS_MEM,EVERY_MEM] \\ res_tac \\ fs [] \\ NO_TAC) \\ AP_THM_TAC \\ AP_TERM_TAC - \\ fs [FUN_EQ_THM,FORALL_PROD]); + \\ fs [FUN_EQ_THM,FORALL_PROD] +QED -Theorem alt_fv_nil[simp] - `alt_fv v [] ⇔ F` (rw[alt_fv]) +Theorem alt_fv_nil[simp]: + alt_fv v [] ⇔ F +Proof +rw[alt_fv] +QED val alt_fv1_def = Define`alt_fv1 v e = alt_fv v [e]`; val alt_fv1_intro = save_thm("alt_fv1_intro[simp]",GSYM alt_fv1_def) @@ -73,14 +80,18 @@ val alt_fv1_thm = alt_fv |> SIMP_RULE (srw_ss())[] |> curry save_thm "alt_fv1_thm" -Theorem alt_fv_cons[simp] - `alt_fv v (x::xs) ⇔ alt_fv1 v x ∨ alt_fv v xs` - (Cases_on `xs` \\ fs [alt_fv]); +Theorem alt_fv_cons[simp]: + alt_fv v (x::xs) ⇔ alt_fv1 v x ∨ alt_fv v xs +Proof + Cases_on `xs` \\ fs [alt_fv] +QED -Theorem alt_fv_REPLICATE[simp] - `alt_fv n (REPLICATE m e) ⇔ 0 < m ∧ alt_fv1 n e` - (Induct_on `m` >> simp[REPLICATE, alt_fv,alt_fv1_thm] >> - simp[] >> metis_tac[]); +Theorem alt_fv_REPLICATE[simp]: + alt_fv n (REPLICATE m e) ⇔ 0 < m ∧ alt_fv1 n e +Proof + Induct_on `m` >> simp[REPLICATE, alt_fv,alt_fv1_thm] >> + simp[] >> metis_tac[] +QED (* value relation *) @@ -148,15 +159,19 @@ val v_rel_simp = let ``v_rel y (Recclosure x1 x2 x3 x4 x5)``] |> LIST_CONJ end |> curry save_thm "v_rel_simp"; -Theorem v_rel_Boolv[simp] - `(v_rel x (Boolv b) ⇔ (x = Boolv b)) ∧ - (v_rel (Boolv b) x ⇔ (x = Boolv b))` - (Cases_on`b`>>EVAL_TAC>>ntac 2(simp[Once v_rel_cases])) +Theorem v_rel_Boolv[simp]: + (v_rel x (Boolv b) ⇔ (x = Boolv b)) ∧ + (v_rel (Boolv b) x ⇔ (x = Boolv b)) +Proof + Cases_on`b`>>EVAL_TAC>>ntac 2(simp[Once v_rel_cases]) +QED -Theorem v_rel_Unit[simp] - `(v_rel x Unit ⇔ (x = Unit)) ∧ - (v_rel Unit x ⇔ (x = Unit))` - (EVAL_TAC>>ntac 2(simp[Once v_rel_cases])) +Theorem v_rel_Unit[simp]: + (v_rel x Unit ⇔ (x = Unit)) ∧ + (v_rel Unit x ⇔ (x = Unit)) +Proof + EVAL_TAC>>ntac 2(simp[Once v_rel_cases]) +QED val env_ok_def = v_rel_cases |> CONJUNCT2 @@ -233,38 +248,50 @@ val state_rel_def = Define ` (shift (FST (alt_free [c])) 0 arity LN = [c2]) /\ (FLOOKUP t.code name = SOME (arity,c2)))` -Theorem state_rel_max_app - `state_rel s t ⇒ s.max_app = t.max_app` - (rw[state_rel_def]); +Theorem state_rel_max_app: + state_rel s t ⇒ s.max_app = t.max_app +Proof + rw[state_rel_def] +QED (* some syntactic properties of the compiler *) -Theorem MAP_FST_compile[simp] - `MAP FST (clos_annotate$compile p) = MAP FST p` - (rw[compile_def,MAP_MAP_o,o_DEF,UNCURRY,ETA_AX]); +Theorem MAP_FST_compile[simp]: + MAP FST (clos_annotate$compile p) = MAP FST p +Proof + rw[compile_def,MAP_MAP_o,o_DEF,UNCURRY,ETA_AX] +QED -Theorem REVERSE_compile - `REVERSE (clos_annotate$compile ls) = compile (REVERSE ls)` - (rw[compile_def,MAP_REVERSE]); +Theorem REVERSE_compile: + REVERSE (clos_annotate$compile ls) = compile (REVERSE ls) +Proof + rw[compile_def,MAP_REVERSE] +QED -Theorem ALOOKUP_compile - `ALOOKUP (clos_annotate$compile ls) = +Theorem ALOOKUP_compile: + ALOOKUP (clos_annotate$compile ls) = OPTION_MAP (λ(args,e). (args, HD (annotate args [e]))) - o (ALOOKUP ls)` - (rw[GSYM ALOOKUP_MAP] - \\ rw[FUN_EQ_THM,compile_def,LAMBDA_PROD]); + o (ALOOKUP ls) +Proof + rw[GSYM ALOOKUP_MAP] + \\ rw[FUN_EQ_THM,compile_def,LAMBDA_PROD] +QED -Theorem compile_append - `clos_annotate$compile (p1 ++ p2) = compile p1 ++ compile p2` - (rw[clos_annotateTheory.compile_def]); +Theorem compile_append: + clos_annotate$compile (p1 ++ p2) = compile p1 ++ compile p2 +Proof + rw[clos_annotateTheory.compile_def] +QED (* semantic functions respect relation *) -Theorem list_to_v_v_rel - `!xs ys. LIST_REL v_rel xs ys ==> v_rel (list_to_v xs) (list_to_v ys)` - (Induct +Theorem list_to_v_v_rel: + !xs ys. LIST_REL v_rel xs ys ==> v_rel (list_to_v xs) (list_to_v ys) +Proof + Induct >- rw [LIST_REL_EL_EQN, v_rel_simp, list_to_v_def] - \\ rw [] \\ fs [v_rel_simp, list_to_v_def]); + \\ rw [] \\ fs [v_rel_simp, list_to_v_def] +QED val v_to_list = Q.prove( `!h h'. @@ -348,9 +375,10 @@ val do_app_err_thm = Q.prove( \\ fs[state_rel_def] \\ first_x_assum drule \\ strip_tac \\ fs[] \\ rveq \\ rfs[]); -Theorem v_to_bytes - `v_rel x y ==> (v_to_bytes x) = (v_to_bytes y)` - (rw[v_to_bytes_def] +Theorem v_to_bytes: + v_rel x y ==> (v_to_bytes x) = (v_to_bytes y) +Proof + rw[v_to_bytes_def] \\ DEEP_INTRO_TAC some_intro \\ rw[OPTREL_def] \\ DEEP_INTRO_TAC some_intro \\ rw[] @@ -359,11 +387,13 @@ Theorem v_to_bytes \\ fs[EVERY2_MAP,v_rel_Number] \\ fsrw_tac[ETA_ss][EQ_SYM_EQ,quotient_listTheory.LIST_REL_EQ] \\ fs[LIST_EQ_REWRITE,EL_MAP,LIST_REL_EL_EQN] \\ rfs[EL_MAP] - \\ METIS_TAC[EL_MAP,o_DEF]); + \\ METIS_TAC[EL_MAP,o_DEF] +QED -Theorem v_to_words - `v_rel x y ==> (v_to_words x) = (v_to_words y)` - (rw[v_to_words_def] +Theorem v_to_words: + v_rel x y ==> (v_to_words x) = (v_to_words y) +Proof + rw[v_to_words_def] \\ DEEP_INTRO_TAC some_intro \\ rw[OPTREL_def] \\ DEEP_INTRO_TAC some_intro \\ rw[] @@ -372,7 +402,8 @@ Theorem v_to_words \\ fs[EVERY2_MAP,v_rel_Number] \\ fsrw_tac[ETA_ss][EQ_SYM_EQ,quotient_listTheory.LIST_REL_EQ] \\ fs[LIST_EQ_REWRITE,EL_MAP,LIST_REL_EL_EQN] \\ rfs[EL_MAP] - \\ METIS_TAC[EL_MAP,o_DEF]); + \\ METIS_TAC[EL_MAP,o_DEF] +QED Theorem do_install_thm: state_rel s1 t1 /\ LIST_REL v_rel xs ys /\ @@ -478,19 +509,23 @@ val FOLDR_mk_Union = prove( Induct \\ fs [FORALL_PROD]); (* -Theorem MAPi_MAPi - `!xs. MAPi f (MAPi g xs) = MAPi (\i x. f i (g i x)) xs` - (...); +Theorem MAPi_MAPi: + !xs. MAPi f (MAPi g xs) = MAPi (\i x. f i (g i x)) xs +Proof + ... +QED *) -Theorem evaluate_shift_REPLICATE_const_0[simp] - `evaluate (shift (REPLICATE n (clos_annotate$const_0 v8)) m l i,env,t1) = - (Rval (REPLICATE n (Number 0)),t1)` - (Induct_on `n` \\ fs [REPLICATE,shift_def] +Theorem evaluate_shift_REPLICATE_const_0[simp]: + evaluate (shift (REPLICATE n (clos_annotate$const_0 v8)) m l i,env,t1) = + (Rval (REPLICATE n (Number 0)),t1) +Proof + Induct_on `n` \\ fs [REPLICATE,shift_def] \\ once_rewrite_tac [shift_CONS] \\ fs [EVAL ``shift [clos_annotate$const_0 t] a2 a3 a4``] \\ once_rewrite_tac [evaluate_CONS] - \\ fs [EVAL ``evaluate ([Op v8 (Const 0) []],env,t1)``]); + \\ fs [EVAL ``evaluate ([Op v8 (Const 0) []],env,t1)``] +QED val no_overlap_has_var_IMP = prove( ``!n l2 x. clos_annotate$no_overlap n l2 /\ has_var x l2 ==> n <= x``, @@ -1193,23 +1228,29 @@ val annotate_correct = save_thm("annotate_correct", (* more correctness properties *) -Theorem every_Fn_vs_SOME_shift[simp] - `∀a b c d. every_Fn_vs_SOME (shift a b c d)` - (ho_match_mp_tac shift_ind >> srw_tac[][shift_def] >> srw_tac[][] >> +Theorem every_Fn_vs_SOME_shift[simp]: + ∀a b c d. every_Fn_vs_SOME (shift a b c d) +Proof + ho_match_mp_tac shift_ind >> srw_tac[][shift_def] >> srw_tac[][] >> rpt(qpat_x_assum`Abbrev _`(strip_assume_tac o SYM o REWRITE_RULE[markerTheory.Abbrev_def])) >> imp_res_tac shift_SING >> full_simp_tac(srw_ss())[Once every_Fn_vs_SOME_EVERY] >> srw_tac[][] >> simp[MAP_MAP_o,o_DEF,UNCURRY,EVERY_MAP] >> simp[EVERY_MEM,FORALL_PROD] >> - simp[Once every_Fn_vs_SOME_EVERY]); + simp[Once every_Fn_vs_SOME_EVERY] +QED -Theorem every_Fn_vs_SOME_annotate[simp] - `every_Fn_vs_SOME (annotate n es)` (srw_tac[][annotate_def]); +Theorem every_Fn_vs_SOME_annotate[simp]: + every_Fn_vs_SOME (annotate n es) +Proof +srw_tac[][annotate_def] +QED -Theorem every_Fn_SOME_shift[simp] - `∀a b c d. every_Fn_SOME (shift a b c d) ⇔ every_Fn_SOME a` - (ho_match_mp_tac shift_ind >> srw_tac[][shift_def] >> srw_tac[][] >> +Theorem every_Fn_SOME_shift[simp]: + ∀a b c d. every_Fn_SOME (shift a b c d) ⇔ every_Fn_SOME a +Proof + ho_match_mp_tac shift_ind >> srw_tac[][shift_def] >> srw_tac[][] >> rpt(qpat_x_assum`Abbrev _`(strip_assume_tac o SYM o REWRITE_RULE[markerTheory.Abbrev_def])) >> imp_res_tac shift_SING >> full_simp_tac(srw_ss())[Once every_Fn_SOME_EVERY] >> @@ -1218,15 +1259,19 @@ Theorem every_Fn_SOME_shift[simp] simp[EVERY_MEM,FORALL_PROD] >> simp[Once every_Fn_SOME_EVERY] >> ONCE_REWRITE_TAC[every_Fn_SOME_EVERY] >> - simp[EVERY_MAP,EVERY_MEM,FORALL_PROD]); + simp[EVERY_MAP,EVERY_MEM,FORALL_PROD] +QED -Theorem every_Fn_SOME_const_0[simp] - `every_Fn_SOME [clos_annotate$const_0 t]` - (EVAL_TAC ); +Theorem every_Fn_SOME_const_0[simp]: + every_Fn_SOME [clos_annotate$const_0 t] +Proof + EVAL_TAC +QED -Theorem every_Fn_SOME_alt_free - `∀es. every_Fn_SOME es ⇒ every_Fn_SOME (FST (alt_free es))` - (ho_match_mp_tac alt_free_ind >> +Theorem every_Fn_SOME_alt_free: + ∀es. every_Fn_SOME es ⇒ every_Fn_SOME (FST (alt_free es)) +Proof + ho_match_mp_tac alt_free_ind >> rw[alt_free_def] \\ rpt(pairarg_tac \\ fs[]) \\ imp_res_tac alt_free_SING >> fs[] \\ simp[MAP_MAP_o,UNCURRY,o_DEF] >> rveq >> @@ -1236,10 +1281,14 @@ Theorem every_Fn_SOME_alt_free ONCE_REWRITE_TAC[every_Fn_SOME_EVERY] >> fs[EVERY_MAP,EVERY_GENLIST] >> rw[EVERY_MEM,FORALL_PROD] >> res_tac - \\ metis_tac[alt_free_SING,HD,FST,PAIR,MEM]); + \\ metis_tac[alt_free_SING,HD,FST,PAIR,MEM] +QED -Theorem every_Fn_SOME_annotate - `every_Fn_SOME es ⇒ every_Fn_SOME (annotate n es)` (rw[annotate_def,every_Fn_SOME_alt_free]); +Theorem every_Fn_SOME_annotate: + every_Fn_SOME es ⇒ every_Fn_SOME (annotate n es) +Proof +rw[annotate_def,every_Fn_SOME_alt_free] +QED val IF_MAP_EQ = MAP_EQ_f |> SPEC_ALL |> EQ_IMP_RULE |> snd; @@ -1252,8 +1301,11 @@ val shift_code_locs = Q.prove( \\ ONCE_REWRITE_TAC [code_locs_map] \\ AP_TERM_TAC \\ MATCH_MP_TAC IF_MAP_EQ \\ full_simp_tac(srw_ss())[FORALL_PROD]); -Theorem code_locs_const_0[simp] - `code_locs [clos_annotate$const_0 t] = []` (EVAL_TAC); +Theorem code_locs_const_0[simp]: + code_locs [clos_annotate$const_0 t] = [] +Proof +EVAL_TAC +QED val alt_free_code_locs = Q.prove( `!xs. set (code_locs (FST (alt_free xs))) ⊆ set (code_locs xs)`, @@ -1294,29 +1346,36 @@ val alt_free_code_locs_distinct = Q.prove( \\ metis_tac[SUBSET_DEF,alt_free_code_locs,FST] ) \\ metis_tac[SUBSET_DEF,alt_free_code_locs,FST,alt_free_SING,HD]); -Theorem annotate_code_locs - `!n ls. set (code_locs (annotate n ls)) ⊆ set (code_locs ls) ∧ - (ALL_DISTINCT (code_locs ls) ⇒ ALL_DISTINCT (code_locs (annotate n ls)))` - (srw_tac[][annotate_def,shift_code_locs,alt_free_code_locs,alt_free_code_locs_distinct]); +Theorem annotate_code_locs: + !n ls. set (code_locs (annotate n ls)) ⊆ set (code_locs ls) ∧ + (ALL_DISTINCT (code_locs ls) ⇒ ALL_DISTINCT (code_locs (annotate n ls))) +Proof + srw_tac[][annotate_def,shift_code_locs,alt_free_code_locs,alt_free_code_locs_distinct] +QED -Theorem EVERY_shift_sing - `EVERY f (shift [y] x1 x2 x3) <=> f (HD (shift [y] x1 x2 x3))` - (`?t. shift [y] x1 x2 x3 = [t]` by metis_tac [shift_SING] \\ fs []); +Theorem EVERY_shift_sing: + EVERY f (shift [y] x1 x2 x3) <=> f (HD (shift [y] x1 x2 x3)) +Proof + `?t. shift [y] x1 x2 x3 = [t]` by metis_tac [shift_SING] \\ fs [] +QED -Theorem shift_obeys_max_app - `!xs m l i. +Theorem shift_obeys_max_app: + !xs m l i. EVERY (obeys_max_app n) xs ==> - EVERY (obeys_max_app n) (shift xs m l i)` - (ho_match_mp_tac shift_ind \\ rw [shift_def] + EVERY (obeys_max_app n) (shift xs m l i) +Proof + ho_match_mp_tac shift_ind \\ rw [shift_def] \\ fs [EVERY_shift_sing,shift_LENGTH_LEMMA] \\ fs [EVERY_MEM,FORALL_PROD,MEM_MAP,PULL_EXISTS] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem alt_free_obeys_max_app - `!xs m l i. +Theorem alt_free_obeys_max_app: + !xs m l i. EVERY (obeys_max_app n) xs ==> - EVERY (obeys_max_app n) (FST (alt_free xs))` - (ho_match_mp_tac alt_free_ind \\ rw [alt_free_def] + EVERY (obeys_max_app n) (FST (alt_free xs)) +Proof + ho_match_mp_tac alt_free_ind \\ rw [alt_free_def] \\ rpt (pairarg_tac \\ fs []) \\ imp_res_tac alt_free_SING \\ rveq \\ fs [] \\ rw [] THEN1 (rpt (pop_assum kall_tac) @@ -1328,29 +1387,35 @@ Theorem alt_free_obeys_max_app *) \\ fs [EVERY_MEM,FORALL_PROD,MEM_MAP,PULL_EXISTS] \\ rw [] \\ pairarg_tac \\ fs [] \\ res_tac \\ fs [] \\ rfs [] - \\ imp_res_tac alt_free_SING \\ fs []); + \\ imp_res_tac alt_free_SING \\ fs [] +QED -Theorem annotate_obeys_max_app - `!n xs. EVERY (obeys_max_app m) xs ==> - EVERY (obeys_max_app m) (annotate n xs)` - (rw [annotate_def] +Theorem annotate_obeys_max_app: + !n xs. EVERY (obeys_max_app m) xs ==> + EVERY (obeys_max_app m) (annotate n xs) +Proof + rw [annotate_def] \\ match_mp_tac shift_obeys_max_app - \\ match_mp_tac alt_free_obeys_max_app \\ fs []); + \\ match_mp_tac alt_free_obeys_max_app \\ fs [] +QED -Theorem shift_no_Labels - `!xs m l i. +Theorem shift_no_Labels: + !xs m l i. EVERY no_Labels xs ==> - EVERY no_Labels (shift xs m l i)` - (ho_match_mp_tac shift_ind \\ rw [shift_def] + EVERY no_Labels (shift xs m l i) +Proof + ho_match_mp_tac shift_ind \\ rw [shift_def] \\ fs [EVERY_shift_sing,shift_LENGTH_LEMMA] \\ fs [EVERY_MEM,FORALL_PROD,MEM_MAP,PULL_EXISTS] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem alt_free_no_Labels - `!xs m l i. +Theorem alt_free_no_Labels: + !xs m l i. EVERY no_Labels xs ==> - EVERY no_Labels (FST (alt_free xs))` - (ho_match_mp_tac alt_free_ind \\ rw [alt_free_def] + EVERY no_Labels (FST (alt_free xs)) +Proof + ho_match_mp_tac alt_free_ind \\ rw [alt_free_def] \\ rpt (pairarg_tac \\ fs []) \\ imp_res_tac alt_free_SING \\ rveq \\ fs [] \\ rw [] THEN1 (rpt (pop_assum kall_tac) @@ -1362,25 +1427,31 @@ Theorem alt_free_no_Labels *) \\ fs [EVERY_MEM,FORALL_PROD,MEM_MAP,PULL_EXISTS] \\ rw [] \\ pairarg_tac \\ fs [] \\ res_tac \\ fs [] \\ rfs [] - \\ imp_res_tac alt_free_SING \\ fs []); + \\ imp_res_tac alt_free_SING \\ fs [] +QED -Theorem annotate_no_Labels - `!n xs. EVERY no_Labels xs ==> - EVERY no_Labels (annotate n xs)` - (rw [annotate_def] +Theorem annotate_no_Labels: + !n xs. EVERY no_Labels xs ==> + EVERY no_Labels (annotate n xs) +Proof + rw [annotate_def] \\ match_mp_tac shift_no_Labels - \\ match_mp_tac alt_free_no_Labels \\ fs []); + \\ match_mp_tac alt_free_no_Labels \\ fs [] +QED -Theorem code_locs_REP_const_0 - `code_locs (REPLICATE n (const_0 t)) = []` - (`n = LENGTH (GENLIST ARB n)` by simp[] +Theorem code_locs_REP_const_0: + code_locs (REPLICATE n (const_0 t)) = [] +Proof + `n = LENGTH (GENLIST ARB n)` by simp[] \\ pop_assum SUBST1_TAC \\ rw[GSYM MAP_K_REPLICATE] - \\ rw[code_locs_map, FLAT_EQ_NIL, EVERY_MAP]); + \\ rw[code_locs_map, FLAT_EQ_NIL, EVERY_MAP] +QED -Theorem code_locs_alt_free - `!xs r1 r2. alt_free xs = (r1,r2) ==> set (code_locs r1) ⊆ set (code_locs xs)` - (ho_match_mp_tac clos_annotateTheory.alt_free_ind +Theorem code_locs_alt_free: + !xs r1 r2. alt_free xs = (r1,r2) ==> set (code_locs r1) ⊆ set (code_locs xs) +Proof + ho_match_mp_tac clos_annotateTheory.alt_free_ind \\ fs [clos_annotateTheory.alt_free_def] \\ rw [] \\ rpt (pairarg_tac \\ fs []) \\ fs [] \\ rveq \\ fs [] @@ -1399,31 +1470,36 @@ Theorem code_locs_alt_free \\ pairarg_tac \\ fs[] \\ imp_res_tac alt_free_SING \\ rw[] \\ fs[] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem code_locs_shift - `!xs k1 k2 k3. code_locs (shift xs k1 k2 k3) = code_locs xs` - (ho_match_mp_tac clos_annotateTheory.shift_ind +Theorem code_locs_shift: + !xs k1 k2 k3. code_locs (shift xs k1 k2 k3) = code_locs xs +Proof + ho_match_mp_tac clos_annotateTheory.shift_ind \\ fs [clos_annotateTheory.shift_def,closPropsTheory.code_locs_def] \\ rw[code_locs_append] \\ rw[code_locs_map] \\ AP_TERM_TAC - \\ simp[MAP_MAP_o, MAP_EQ_f, FORALL_PROD] \\ rw[]); + \\ simp[MAP_MAP_o, MAP_EQ_f, FORALL_PROD] \\ rw[] +QED -Theorem code_locs_annotate - `!n xs. set (code_locs (annotate n xs)) ⊆ set (code_locs xs)` - (rw [clos_annotateTheory.annotate_def] +Theorem code_locs_annotate: + !n xs. set (code_locs (annotate n xs)) ⊆ set (code_locs xs) +Proof + rw [clos_annotateTheory.annotate_def] \\ Cases_on `alt_free xs` \\ fs [] \\ drule code_locs_alt_free - \\ fs [code_locs_shift]); + \\ fs [code_locs_shift] +QED (* semantics preservation *) val compile_inc_def = Define ` compile_inc (e,aux) = (annotate 0 e,clos_annotate$compile aux)`; -Theorem semantics_annotate - `semantics (ffi:'ffi ffi_state) max_app (alist_to_fmap prog) co +Theorem semantics_annotate: + semantics (ffi:'ffi ffi_state) max_app (alist_to_fmap prog) co (pure_cc compile_inc cc) xs <> Fail ==> every_Fn_vs_NONE xs /\ every_Fn_vs_NONE (MAP (SND o SND) prog) /\ @@ -1432,8 +1508,9 @@ Theorem semantics_annotate semantics (ffi:'ffi ffi_state) max_app (alist_to_fmap (compile prog)) (pure_co compile_inc ∘ co) cc (annotate 0 xs) = semantics (ffi:'ffi ffi_state) max_app (alist_to_fmap prog) - co (pure_cc compile_inc cc) xs` - (strip_tac + co (pure_cc compile_inc cc) xs +Proof + strip_tac \\ ho_match_mp_tac IMP_semantics_eq \\ fs [] \\ fs [eval_sim_def] \\ rw [] \\ drule (annotate_correct |> GEN_ALL) \\ fs [] @@ -1464,25 +1541,29 @@ Theorem semantics_annotate \\ qexists_tac `0` \\ fs [] \\ fs [state_rel_def] \\ Cases_on `res1` \\ fs [] - \\ Cases_on `e` \\ fs []); + \\ Cases_on `e` \\ fs [] +QED (* more syntactic properties *) -Theorem call_dests_shift[simp] - `∀a b c d. app_call_dests opt (shift a b c d) = app_call_dests opt a` - (recInduct clos_annotateTheory.shift_ind +Theorem call_dests_shift[simp]: + ∀a b c d. app_call_dests opt (shift a b c d) = app_call_dests opt a +Proof + recInduct clos_annotateTheory.shift_ind \\ rw[clos_annotateTheory.shift_def, closPropsTheory.app_call_dests_def, closPropsTheory.app_call_dests_append] \\ fs[] \\ AP_THM_TAC \\ AP_TERM_TAC \\ rw[closPropsTheory.app_call_dests_map] \\ AP_TERM_TAC \\ AP_TERM_TAC - \\ rw[MAP_MAP_o, MAP_EQ_f, FORALL_PROD]); + \\ rw[MAP_MAP_o, MAP_EQ_f, FORALL_PROD] +QED -Theorem no_Labels_ann - `!xs. +Theorem no_Labels_ann: + !xs. EVERY no_Labels (MAP (SND o SND) xs) ==> - EVERY no_Labels (MAP (SND ∘ SND) (clos_annotate$compile xs))` - (fs [EVERY_MEM,FORALL_PROD,MEM_MAP,PULL_EXISTS,clos_annotateTheory.compile_def] + EVERY no_Labels (MAP (SND ∘ SND) (clos_annotate$compile xs)) +Proof + fs [EVERY_MEM,FORALL_PROD,MEM_MAP,PULL_EXISTS,clos_annotateTheory.compile_def] \\ rw [] \\ res_tac \\ fs [] \\ rename [`(x1,x2,x3)`] \\ `?t. annotate x2 [x3] = [t]` by @@ -1492,13 +1573,15 @@ Theorem no_Labels_ann \\ metis_tac [clos_annotateTheory.shift_SING]) \\ fs [] \\ qspecl_then [`x2`,`[x3]`] mp_tac annotate_no_Labels - \\ fs []); + \\ fs [] +QED -Theorem obeys_max_app_ann - `!xs. +Theorem obeys_max_app_ann: + !xs. EVERY (obeys_max_app m) (MAP (SND o SND) xs) ==> - EVERY (obeys_max_app m) (MAP (SND ∘ SND) (clos_annotate$compile xs))` - (fs [EVERY_MEM,FORALL_PROD,MEM_MAP,PULL_EXISTS,clos_annotateTheory.compile_def] + EVERY (obeys_max_app m) (MAP (SND ∘ SND) (clos_annotate$compile xs)) +Proof + fs [EVERY_MEM,FORALL_PROD,MEM_MAP,PULL_EXISTS,clos_annotateTheory.compile_def] \\ rw [] \\ res_tac \\ fs [] \\ rename [`(x1,x2,x3)`] \\ `?t. annotate x2 [x3] = [t]` by @@ -1508,25 +1591,30 @@ Theorem obeys_max_app_ann \\ metis_tac [clos_annotateTheory.shift_SING]) \\ fs [] \\ qspecl_then [`x2`,`[x3]`] mp_tac annotate_obeys_max_app - \\ fs []); + \\ fs [] +QED -Theorem HD_annotate_SING - `[HD (annotate x [y])] = annotate x [y]` - (rw[clos_annotateTheory.annotate_def] +Theorem HD_annotate_SING: + [HD (annotate x [y])] = annotate x [y] +Proof + rw[clos_annotateTheory.annotate_def] \\ once_rewrite_tac[GSYM clos_annotateTheory.HD_FST_alt_free] - \\ rw[clos_annotateTheory.HD_shift]); + \\ rw[clos_annotateTheory.HD_shift] +QED -Theorem every_Fn_SOME_ann - `!xs. +Theorem every_Fn_SOME_ann: + !xs. every_Fn_SOME (MAP (SND o SND) xs) ==> - every_Fn_SOME (MAP (SND ∘ SND) (clos_annotate$compile xs))` - (fs [EVERY_MEM,FORALL_PROD,MEM_MAP,PULL_EXISTS,clos_annotateTheory.compile_def] + every_Fn_SOME (MAP (SND ∘ SND) (clos_annotate$compile xs)) +Proof + fs [EVERY_MEM,FORALL_PROD,MEM_MAP,PULL_EXISTS,clos_annotateTheory.compile_def] \\ rw [] \\ res_tac \\ fs [] \\ fs [MAP_MAP_o,o_DEF,UNCURRY] \\ Induct_on `xs` \\ fs [] \\ once_rewrite_tac [closPropsTheory.every_Fn_SOME_APPEND |> Q.INST [`l1`|->`x::[]`] |> SIMP_RULE std_ss [APPEND]] \\ fs [] \\ rw [] \\ fs [HD_annotate_SING] - \\ match_mp_tac every_Fn_SOME_annotate \\ fs []); + \\ match_mp_tac every_Fn_SOME_annotate \\ fs [] +QED val _ = export_theory() diff --git a/compiler/backend/proofs/clos_callProofScript.sml b/compiler/backend/proofs/clos_callProofScript.sml index 11903a5497..f3b290f49a 100644 --- a/compiler/backend/proofs/clos_callProofScript.sml +++ b/compiler/backend/proofs/clos_callProofScript.sml @@ -28,21 +28,27 @@ val v_size_lemma = Q.prove( Induct_on `vl` >> dsimp[v_size_def] >> rpt strip_tac >> res_tac >> simp[]); -Theorem code_locs_GENLIST_Var[simp] - `∀n t i. code_locs (GENLIST_Var t i n) = []` - (Induct \\ simp[code_locs_def,Once GENLIST_Var_def,code_locs_append]); +Theorem code_locs_GENLIST_Var[simp]: + ∀n t i. code_locs (GENLIST_Var t i n) = [] +Proof + Induct \\ simp[code_locs_def,Once GENLIST_Var_def,code_locs_append] +QED -Theorem fv_GENLIST_Var_tra - `∀n tra i. fv v (GENLIST_Var tra i n) ⇔ v < n` - (Induct \\ simp[fv_def,Once GENLIST_Var_def,SNOC_APPEND]); +Theorem fv_GENLIST_Var_tra: + ∀n tra i. fv v (GENLIST_Var tra i n) ⇔ v < n +Proof + Induct \\ simp[fv_def,Once GENLIST_Var_def,SNOC_APPEND] +QED -Theorem evaluate_GENLIST_Var_tra - `∀n tr i. +Theorem evaluate_GENLIST_Var_tra: + ∀n tr i. evaluate (GENLIST_Var tr i n,env,s) = if n ≤ LENGTH env then (Rval (TAKE n env),s) - else (Rerr (Rabort Rtype_error),s)` - (Induct \\ rw[Once GENLIST_Var_def,evaluate_def,evaluate_append] \\ - simp[TAKE_EL_SNOC,ADD1]); + else (Rerr (Rabort Rtype_error),s) +Proof + Induct \\ rw[Once GENLIST_Var_def,evaluate_def,evaluate_append] \\ + simp[TAKE_EL_SNOC,ADD1] +QED val evaluate_add_clock = evaluate_add_to_clock @@ -110,13 +116,17 @@ val subg_def = Define` (∀k v. ALOOKUP (SND g0) k = SOME v ⇒ ALOOKUP (SND g1) k = SOME v) ∧ ALL_DISTINCT (MAP FST (SND g1))`; -Theorem subg_refl - `∀g. ALL_DISTINCT (MAP FST (SND g)) ⇒ subg g g` - (rw[subg_def]); +Theorem subg_refl: + ∀g. ALL_DISTINCT (MAP FST (SND g)) ⇒ subg g g +Proof + rw[subg_def] +QED -Theorem subg_trans - `∀g1 g2 g3. subg g1 g2 ∧ subg g2 g3 ⇒ subg g1 g3` - (rw[subg_def] \\ metis_tac[subspt_trans,IS_SUFFIX_TRANS]); +Theorem subg_trans: + ∀g1 g2 g3. subg g1 g2 ∧ subg g2 g3 ⇒ subg g1 g3 +Proof + rw[subg_def] \\ metis_tac[subspt_trans,IS_SUFFIX_TRANS] +QED val wfg'_def = Define` wfg' g ⇔ @@ -138,17 +148,20 @@ val ALL_DISTINCT_MAP_FST_ADD1 = prove( ALL_DISTINCT (MAP FST xs)``, Induct \\ fs [MEM_MAP]); -Theorem make_g_wfg - `make_g d code = SOME g ==> wfg g` - (rw [make_g_def,wfg_def] \\ fs [MAP_MAP_o,o_DEF] +Theorem make_g_wfg: + make_g d code = SOME g ==> wfg g +Proof + rw [make_g_def,wfg_def] \\ fs [MAP_MAP_o,o_DEF] \\ fs [ALL_DISTINCT_MAP_FST_ADD1,ALL_DISTINCT_MAP_FST_toAList] \\ fs [EXTENSION,MEM_MAP,ADD1,EXISTS_PROD,MEM_toAList,domain_lookup] - \\ fs [PULL_EXISTS]); + \\ fs [PULL_EXISTS] +QED -Theorem make_g_subg - `make_g cfg (FEMPTY |++ aux) = SOME new /\ wfg (cfg,aux) ==> - subg (cfg,aux) new` - (rw [] \\ imp_res_tac make_g_wfg \\ fs [wfg_def,subg_def] +Theorem make_g_subg: + make_g cfg (FEMPTY |++ aux) = SOME new /\ wfg (cfg,aux) ==> + subg (cfg,aux) new +Proof + rw [] \\ imp_res_tac make_g_wfg \\ fs [wfg_def,subg_def] \\ fs [make_g_def] \\ rveq \\ fs [FDOM_FUPDATE_LIST] \\ rw[] \\ match_mp_tac ALOOKUP_ALL_DISTINCT_MEM \\ fs[] @@ -159,13 +172,15 @@ Theorem make_g_subg \\ fs[MEM_MAP, PULL_EXISTS, MEM_toAList, EXISTS_PROD] \\ imp_res_tac ALOOKUP_MEM \\ fsrw_tac[DNF_ss][EXTENSION, MEM_MAP, PULL_EXISTS, EXISTS_PROD, EQ_IMP_THM] - \\ res_tac \\ fs[ADD1, domain_lookup]); + \\ res_tac \\ fs[ADD1, domain_lookup] +QED -Theorem make_g_make_g_eq - `!x1 x2 y1 y2 g0 g1. +Theorem make_g_make_g_eq: + !x1 x2 y1 y2 g0 g1. FST g0 = FST g1 /\ subg g0 g1 /\ - make_g x1 x2 = SOME g0 /\ make_g y1 y2 = SOME g1 ==> g0 = g1` - (fs [make_g_def,subg_def] \\ rw [MAP_EQ_f] + make_g x1 x2 = SOME g0 /\ make_g y1 y2 = SOME g1 ==> g0 = g1 +Proof + fs [make_g_def,subg_def] \\ rw [MAP_EQ_f] \\ rename [`MEM kk _`] \\ PairCases_on `kk` \\ `lookup kk0 x1 = SOME kk1` by fs [MEM_toAList] @@ -180,16 +195,18 @@ Theorem make_g_make_g_eq \\ pop_assum match_mp_tac \\ fs [] \\ Cases_on `ALOOKUP (MAP (λk. (FST k + 1,THE (FLOOKUP x2 (FST k + 1)))) l1) (kk0 + 1)` \\ fs [] - \\ imp_res_tac ALOOKUP_MEM \\ fs [MEM_MAP]); + \\ imp_res_tac ALOOKUP_MEM \\ fs [MEM_MAP] +QED -Theorem make_g_IMP_subg - `make_g (r0:num_set) code = SOME g0 /\ +Theorem make_g_IMP_subg: + make_g (r0:num_set) code = SOME g0 /\ DISJOINT (FDOM code) (set (MAP FST progs1)) /\ ALL_DISTINCT (MAP FST progs1) /\ make_g r1 (code |++ progs1) = SOME g1 /\ subspt r0 r1 /\ set (MAP FST progs1) SUBSET IMAGE SUC (domain r1) ==> - subg (r1,progs1 ⧺ SND g0) g1` - (rw [] \\ imp_res_tac make_g_wfg + subg (r1,progs1 ⧺ SND g0) g1 +Proof + rw [] \\ imp_res_tac make_g_wfg \\ fs [make_g_def] \\ rveq \\ fs [] \\ fs [subg_def,wfg_def] \\ fs [ALOOKUP_APPEND,option_case_eq] \\ strip_tac \\ Cases_on `ALOOKUP progs1 k` \\ fs [] THEN1 @@ -210,7 +227,8 @@ Theorem make_g_IMP_subg \\ fs [flookup_update_list_some] \\ rfs [alookup_distinct_reverse] \\ rveq \\ fs [flookup_fupdate_list] - \\ fs [alookup_distinct_reverse]); + \\ fs [alookup_distinct_reverse] +QED val recclosure_wf_def = Define` recclosure_wf loc fns ⇔ @@ -251,16 +269,20 @@ val env_rel_def = Define` x < LENGTH env1 ∧ x < LENGTH env2 ∧ R (EL x env1) (EL x env2)`; -Theorem env_rel_mono[mono] - `(∀x y. MEM x env1 ∧ MEM y env2 ∧ R x y ⇒ R' x y) ⇒ +Theorem env_rel_mono[mono]: + (∀x y. MEM x env1 ∧ MEM y env2 ∧ R x y ⇒ R' x y) ⇒ env_rel R env1 env2 a es ⇒ - env_rel R' env1 env2 a es` - (rw[env_rel_def,MEM_EL,PULL_EXISTS,LIST_REL_EL_EQN]); + env_rel R' env1 env2 a es +Proof + rw[env_rel_def,MEM_EL,PULL_EXISTS,LIST_REL_EL_EQN] +QED -Theorem env_rel_cong[defncong] - `(∀x y. MEM x env1 ∧ MEM y env2 ⇒ (R x y ⇔ R' x y)) - ⇒ env_rel R env1 env2 a es = env_rel R' env1 env2 a es` - (rw[env_rel_def,MEM_EL,PULL_EXISTS,EQ_IMP_THM,LIST_REL_EL_EQN]); +Theorem env_rel_cong[defncong]: + (∀x y. MEM x env1 ∧ MEM y env2 ⇒ (R x y ⇔ R' x y)) + ⇒ env_rel R env1 env2 a es = env_rel R' env1 env2 a es +Proof + rw[env_rel_def,MEM_EL,PULL_EXISTS,EQ_IMP_THM,LIST_REL_EL_EQN] +QED val v_rel_def = tDefine"v_rel"` (v_rel g l code (Number i) v ⇔ v = Number i) ∧ @@ -328,90 +350,115 @@ val state_rel_def = Define` fmap_rel (ref_rel (v_rel g l t.code)) s.refs t.refs ∧ s.code = FEMPTY ∧ correct_l l g`; -Theorem state_rel_max_app - `state_rel g l s t ⇒ s.max_app = t.max_app` - (rw[state_rel_def]); +Theorem state_rel_max_app: + state_rel g l s t ⇒ s.max_app = t.max_app +Proof + rw[state_rel_def] +QED -Theorem state_rel_clock - `state_rel g l s t ⇒ s.clock = t.clock` - (rw[state_rel_def]); +Theorem state_rel_clock: + state_rel g l s t ⇒ s.clock = t.clock +Proof + rw[state_rel_def] +QED -Theorem state_rel_with_clock - `state_rel g l s t ⇒ state_rel g l (s with clock := k) (t with clock := k)` - (rw[state_rel_def]); +Theorem state_rel_with_clock: + state_rel g l s t ⇒ state_rel g l (s with clock := k) (t with clock := k) +Proof + rw[state_rel_def] +QED -Theorem state_rel_flookup_refs - `state_rel g l s t ∧ FLOOKUP s.refs k = SOME v ⇒ - ∃v'. FLOOKUP t.refs k = SOME v' ∧ ref_rel (v_rel g l t.code) v v'` - (rw[state_rel_def,fmap_rel_OPTREL_FLOOKUP] - \\ first_x_assum(qspec_then`k`mp_tac) \\ rw[OPTREL_def]); +Theorem state_rel_flookup_refs: + state_rel g l s t ∧ FLOOKUP s.refs k = SOME v ⇒ + ∃v'. FLOOKUP t.refs k = SOME v' ∧ ref_rel (v_rel g l t.code) v v' +Proof + rw[state_rel_def,fmap_rel_OPTREL_FLOOKUP] + \\ first_x_assum(qspec_then`k`mp_tac) \\ rw[OPTREL_def] +QED (* syntactic properties of compiler *) -Theorem FST_code_list[simp] - `∀loc fns g. FST (code_list loc fns g) = FST g` - (ho_match_mp_tac code_list_ind - \\ rw[code_list_def]); +Theorem FST_code_list[simp]: + ∀loc fns g. FST (code_list loc fns g) = FST g +Proof + ho_match_mp_tac code_list_ind + \\ rw[code_list_def] +QED -Theorem SND_insert_each[simp] - `∀p n g. SND (insert_each p n g) = SND g` - (ho_match_mp_tac insert_each_ind - \\ rw[insert_each_def]); +Theorem SND_insert_each[simp]: + ∀p n g. SND (insert_each p n g) = SND g +Proof + ho_match_mp_tac insert_each_ind + \\ rw[insert_each_def] +QED -Theorem calls_list_MAPi - `∀loc tra n. calls_list tra n loc = MAPi (λi p. (FST p, Call (tra§n+i§0) 0 (loc+2*i+1) (GENLIST_Var (tra§n+i) 1 (FST p))))` - (simp[FUN_EQ_THM] +Theorem calls_list_MAPi: + ∀loc tra n. calls_list tra n loc = MAPi (λi p. (FST p, Call (tra§n+i§0) 0 (loc+2*i+1) (GENLIST_Var (tra§n+i) 1 (FST p)))) +Proof + simp[FUN_EQ_THM] \\ CONV_TAC(RESORT_FORALL_CONV(List.rev)) \\ Induct \\ simp[calls_list_def] \\ Cases \\ simp[calls_list_def] \\ simp[o_DEF,ADD1,LEFT_ADD_DISTRIB] \\ rw[] \\ AP_THM_TAC \\ AP_TERM_TAC - \\ simp[FUN_EQ_THM]); + \\ simp[FUN_EQ_THM] +QED -Theorem calls_list_length[simp] - `LENGTH (calls_list t n p fns) = LENGTH fns` - (rw[calls_list_MAPi]); +Theorem calls_list_length[simp]: + LENGTH (calls_list t n p fns) = LENGTH fns +Proof + rw[calls_list_MAPi] +QED -Theorem domain_FST_insert_each - `∀p n g. domain (FST (insert_each p n g)) = set (GENLIST (λi. 2 * i + p) n) ∪ domain (FST g)` - (ho_match_mp_tac insert_each_ind +Theorem domain_FST_insert_each: + ∀p n g. domain (FST (insert_each p n g)) = set (GENLIST (λi. 2 * i + p) n) ∪ domain (FST g) +Proof + ho_match_mp_tac insert_each_ind \\ rw[insert_each_def,GENLIST_CONS,o_DEF,ADD1,LEFT_ADD_DISTRIB] \\ simp[EXTENSION,MEM_GENLIST] - \\ metis_tac[ADD_ASSOC,ADD_COMM]); + \\ metis_tac[ADD_ASSOC,ADD_COMM] +QED -Theorem SND_code_list_change - `∀loc fns g g'. SND g = SND g' ⇒ - SND (code_list loc fns g) = SND (code_list loc fns g')` - (ho_match_mp_tac code_list_ind +Theorem SND_code_list_change: + ∀loc fns g g'. SND g = SND g' ⇒ + SND (code_list loc fns g) = SND (code_list loc fns g') +Proof + ho_match_mp_tac code_list_ind \\ rw[code_list_def] \\ Cases_on`g'` \\ rw[code_list_def] - \\ fs[FORALL_PROD]); + \\ fs[FORALL_PROD] +QED -Theorem MAP_FST_code_list - `∀loc fns g. +Theorem MAP_FST_code_list: + ∀loc fns g. MAP FST (SND (code_list loc fns g)) = - REVERSE (GENLIST (λi. loc + i*2 + 1) (LENGTH fns)) ++ MAP FST (SND g)` - (ho_match_mp_tac code_list_ind + REVERSE (GENLIST (λi. loc + i*2 + 1) (LENGTH fns)) ++ MAP FST (SND g) +Proof + ho_match_mp_tac code_list_ind \\ rw[code_list_def] \\ rw[GENLIST_CONS,MAP_REVERSE] \\ rw[o_DEF,ADD1] \\ AP_THM_TAC \\ AP_TERM_TAC - \\ rw[FUN_EQ_THM]); + \\ rw[FUN_EQ_THM] +QED -Theorem SND_code_list_ZIP - `∀loc fns g. SND (code_list loc fns g) = - REVERSE(ZIP (GENLIST ($+ (loc+1) o $* 2) (LENGTH fns), fns)) ++ (SND g)` - (ho_match_mp_tac code_list_ind +Theorem SND_code_list_ZIP: + ∀loc fns g. SND (code_list loc fns g) = + REVERSE(ZIP (GENLIST ($+ (loc+1) o $* 2) (LENGTH fns), fns)) ++ (SND g) +Proof + ho_match_mp_tac code_list_ind \\ rw[code_list_def,GENLIST_CONS] - \\ simp[REVERSE_ZIP,o_DEF,ADD1,LEFT_ADD_DISTRIB]); + \\ simp[REVERSE_ZIP,o_DEF,ADD1,LEFT_ADD_DISTRIB] +QED -Theorem ALOOKUP_code_list - `∀loc fns g k. +Theorem ALOOKUP_code_list: + ∀loc fns g k. ALOOKUP (SND (code_list loc fns g)) k = case some i. i < LENGTH fns ∧ k = loc + 2*i+1 of | SOME i => SOME (EL i fns) - | NONE => ALOOKUP (SND g) k` - (rw[SND_code_list_ZIP,ALOOKUP_APPEND] + | NONE => ALOOKUP (SND g) k +Proof + rw[SND_code_list_ZIP,ALOOKUP_APPEND] \\ DEP_REWRITE_TAC[alookup_distinct_reverse] \\ conj_asm1_tac >- simp[MAP_ZIP,ALL_DISTINCT_GENLIST] @@ -423,35 +470,43 @@ Theorem ALOOKUP_code_list \\ drule (GEN_ALL ALOOKUP_ALL_DISTINCT_MEM) \\ simp[MEM_ZIP,PULL_EXISTS] \\ imp_res_tac ALOOKUP_MEM \\ fs[MEM_ZIP] - \\ DEEP_INTRO_TAC some_intro \\ rw[]); + \\ DEEP_INTRO_TAC some_intro \\ rw[] +QED -Theorem insert_each_subspt - `∀p n g. subspt (FST g) (FST (insert_each p n g))` - (ho_match_mp_tac insert_each_ind +Theorem insert_each_subspt: + ∀p n g. subspt (FST g) (FST (insert_each p n g)) +Proof + ho_match_mp_tac insert_each_ind \\ rw[insert_each_def] \\ fs[subspt_def,lookup_insert] - \\ rw[] \\ fs[domain_lookup]); + \\ rw[] \\ fs[domain_lookup] +QED -Theorem code_list_IS_SUFFIX - `∀loc fns g. IS_SUFFIX (SND (code_list loc fns g)) (SND g)` - (ho_match_mp_tac code_list_ind - \\ rw[code_list_def] \\ fs[IS_SUFFIX_APPEND]); +Theorem code_list_IS_SUFFIX: + ∀loc fns g. IS_SUFFIX (SND (code_list loc fns g)) (SND g) +Proof + ho_match_mp_tac code_list_ind + \\ rw[code_list_def] \\ fs[IS_SUFFIX_APPEND] +QED -Theorem calls_subspt - `∀xs g0 ys g. calls xs g0 = (ys,g) ⇒ subspt (FST g0) (FST g)` - (ho_match_mp_tac calls_ind +Theorem calls_subspt: + ∀xs g0 ys g. calls xs g0 = (ys,g) ⇒ subspt (FST g0) (FST g) +Proof + ho_match_mp_tac calls_ind \\ rw[calls_def] \\ rw[] \\ rpt(pairarg_tac \\ fs[]) \\ rw[] \\ every_case_tac \\ fs[] \\ rw[] - \\ metis_tac[subspt_trans,insert_each_subspt]); + \\ metis_tac[subspt_trans,insert_each_subspt] +QED -Theorem calls_code_subset - `∀xs g0 ys g. calls xs g0 = (ys,g) ⇒ +Theorem calls_code_subset: + ∀xs g0 ys g. calls xs g0 = (ys,g) ⇒ IMAGE SUC (domain (FST g0)) SUBSET IMAGE SUC (domain (FST g)) /\ set (MAP FST (SND g0)) SUBSET set (MAP FST (SND g)) /\ set (MAP FST (SND g)) SUBSET - IMAGE SUC (domain (FST g)) UNION set (MAP FST (SND g0))` - (ho_match_mp_tac calls_ind + IMAGE SUC (domain (FST g)) UNION set (MAP FST (SND g0)) +Proof + ho_match_mp_tac calls_ind \\ rw[calls_def] \\ rw[] \\ rpt(pairarg_tac \\ fs[]) \\ rw[] \\ every_case_tac \\ fs[] \\ rw[] @@ -476,36 +531,42 @@ Theorem calls_code_subset \\ `LENGTH (MAP FST fns) = LENGTH fns` by fs [] \\ full_simp_tac std_ss [LENGTH_ZIP] \\ metis_tac []) - \\ metis_tac [EVAL ``SUC 0n``]); + \\ metis_tac [EVAL ``SUC 0n``] +QED -Theorem calls_IS_SUFFIX - `∀xs g0 ys g. calls xs g0 = (ys,g) ⇒ IS_SUFFIX (SND g) (SND g0)` - (ho_match_mp_tac calls_ind +Theorem calls_IS_SUFFIX: + ∀xs g0 ys g. calls xs g0 = (ys,g) ⇒ IS_SUFFIX (SND g) (SND g0) +Proof + ho_match_mp_tac calls_ind \\ rw[calls_def] \\ rw[] \\ rpt(pairarg_tac \\ fs[]) \\ rw[] \\ every_case_tac \\ fs[] \\ rw[] - \\ metis_tac[IS_SUFFIX_TRANS,IS_SUFFIX_CONS,code_list_IS_SUFFIX]); + \\ metis_tac[IS_SUFFIX_TRANS,IS_SUFFIX_CONS,code_list_IS_SUFFIX] +QED -Theorem calls_add_SUC_code_locs - `∀xs g0 ys g. calls xs g0 = (ys,g) ⇒ +Theorem calls_add_SUC_code_locs: + ∀xs g0 ys g. calls xs g0 = (ys,g) ⇒ set (MAP FST (SND g)) ⊆ - set (MAP FST (SND g0)) ∪ IMAGE SUC (set (code_locs xs))` - (ho_match_mp_tac calls_ind + set (MAP FST (SND g0)) ∪ IMAGE SUC (set (code_locs xs)) +Proof + ho_match_mp_tac calls_ind \\ rw[calls_def,code_locs_def] \\ rpt (pairarg_tac \\ fs[]) \\ rw[] \\ every_case_tac \\ fs[] \\ rw[] \\ imp_res_tac calls_length \\ fs[MAP_FST_code_list,LIST_TO_SET_GENLIST] \\ fs[SUBSET_DEF,PULL_EXISTS,ADD1] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem calls_ALL_DISTINCT - `∀xs g0 ys g. +Theorem calls_ALL_DISTINCT: + ∀xs g0 ys g. calls xs g0 = (ys,g) ∧ ALL_DISTINCT (MAP FST (SND g0)) ∧ ALL_DISTINCT (code_locs xs) ∧ DISJOINT (IMAGE SUC (set (code_locs xs))) (set (MAP FST (SND g0))) - ⇒ ALL_DISTINCT (MAP FST (SND g))` - (ho_match_mp_tac calls_ind + ⇒ ALL_DISTINCT (MAP FST (SND g)) +Proof + ho_match_mp_tac calls_ind \\ rw[calls_def] \\ rw[] \\ rpt(pairarg_tac \\ fs[]) \\ rw[] \\ fs[code_locs_def] @@ -557,26 +618,30 @@ Theorem calls_ALL_DISTINCT \\ fs[IN_DISJOINT,MEM_GENLIST] \\ fs[MAP_FST_code_list,MEM_GENLIST,PULL_EXISTS] \\ rfs[GSYM ADD1] - \\ metis_tac[numTheory.INV_SUC,DECIDE``2 * i + SUC loc = SUC (2*i+loc)``]); + \\ metis_tac[numTheory.INV_SUC,DECIDE``2 * i + SUC loc = SUC (2*i+loc)``] +QED -Theorem compile_ALL_DISTINCT - `compile do_call x = (y,g,aux) ∧ +Theorem compile_ALL_DISTINCT: + compile do_call x = (y,g,aux) ∧ ALL_DISTINCT (code_locs x) ⇒ - ALL_DISTINCT (MAP FST aux)` - (Cases_on`do_call` \\ rw[compile_def] \\ rw[] + ALL_DISTINCT (MAP FST aux) +Proof + Cases_on`do_call` \\ rw[compile_def] \\ rw[] \\ pairarg_tac \\ fs[] \\ drule calls_ALL_DISTINCT - \\ rw[]); + \\ rw[] +QED -Theorem calls_subg - `∀xs g0 ys g. +Theorem calls_subg: + ∀xs g0 ys g. calls xs g0 = (ys,g) ∧ ALL_DISTINCT (MAP FST (SND g0)) ∧ ALL_DISTINCT (code_locs xs) ∧ DISJOINT (IMAGE SUC (set (code_locs xs))) (set (MAP FST (SND g0))) - ⇒ subg g0 g` - (simp[subg_def] + ⇒ subg g0 g +Proof + simp[subg_def] \\ rpt gen_tac \\ strip_tac \\ REWRITE_TAC[CONJ_ASSOC] \\ reverse conj_asm2_tac @@ -591,12 +656,14 @@ Theorem calls_subg \\ imp_res_tac ALOOKUP_MEM \\ fs[MEM_MAP,PULL_EXISTS] \\ res_tac \\ fs[] - \\ metis_tac[FST]); + \\ metis_tac[FST] +QED -Theorem calls_domain - `∀xs g0 ys g. calls xs g0 = (ys,g) ⇒ - domain (FST g) ⊆ domain (FST g0) ∪ IMAGE PRE (set (MAP FST (SND g)))` - (ho_match_mp_tac calls_ind +Theorem calls_domain: + ∀xs g0 ys g. calls xs g0 = (ys,g) ⇒ + domain (FST g) ⊆ domain (FST g0) ∪ IMAGE PRE (set (MAP FST (SND g))) +Proof + ho_match_mp_tac calls_ind \\ rw[calls_def] \\ rpt(pairarg_tac \\ fs[]) \\ rw[] \\ fs[SUBSET_DEF] \\ rw[] @@ -606,29 +673,35 @@ Theorem calls_domain \\ imp_res_tac calls_length \\ fs[IS_SUFFIX_APPEND] \\ fs[] \\ fs[MAP_FST_code_list,MEM_GENLIST,PULL_EXISTS,GSYM ADD1,domain_FST_insert_each] - \\ metis_tac[numTheory.INV_SUC,prim_recTheory.PRE,EVAL``PRE 1``]); + \\ metis_tac[numTheory.INV_SUC,prim_recTheory.PRE,EVAL``PRE 1``] +QED -Theorem wfg'_insert_each - `∀n g loc. wfg' g ⇒ wfg' (insert_each loc n g)` - (Induct \\ Cases \\ rw[insert_each_def] +Theorem wfg'_insert_each: + ∀n g loc. wfg' g ⇒ wfg' (insert_each loc n g) +Proof + Induct \\ Cases \\ rw[insert_each_def] \\ first_x_assum match_mp_tac \\ fs[wfg'_def,SUBSET_DEF,IN_EVEN] - \\ metis_tac[EVEN_ADD,EVAL``EVEN 2``]); + \\ metis_tac[EVEN_ADD,EVAL``EVEN 2``] +QED -Theorem wfg'_code_list - `∀ls g loc. +Theorem wfg'_code_list: + ∀ls g loc. wfg' g ∧ set (GENLIST (λi. loc + 2 * i) (LENGTH ls)) ⊆ domain (FST g) - ⇒ wfg' (code_list loc ls g)` - (rw[wfg'_def,SUBSET_DEF,MEM_GENLIST,MAP_FST_code_list] + ⇒ wfg' (code_list loc ls g) +Proof + rw[wfg'_def,SUBSET_DEF,MEM_GENLIST,MAP_FST_code_list] >- ( fs[ADD1,PULL_EXISTS] \\ metis_tac[ADD_ASSOC] ) - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem closed_Fn - `closed (Fn t loco vs args e) ⇔ - ∀v. has_var v (SND (free [e])) ⇒ v < args` - (rw[closed_def] +Theorem closed_Fn: + closed (Fn t loco vs args e) ⇔ + ∀v. has_var v (SND (free [e])) ⇒ v < args +Proof + rw[closed_def] \\ qspec_then`[e]`mp_tac free_thm \\ simp[] \\ pairarg_tac \\ fs[] \\ rw[] @@ -647,21 +720,25 @@ Theorem closed_Fn \\ rw[] \\ Cases_on`lookup (args+n) (db_to_set l)` \\ rw[] \\ Cases_on `x` \\ fs[GSYM lookup_db_to_set] - \\ res_tac \\ fs[]); + \\ res_tac \\ fs[] +QED -Theorem closed_Fn_fv - `closed (Fn t loco vs args e) ⇔ - ∀v. fv v [e] ⇒ v < args` - (rw[closed_Fn] +Theorem closed_Fn_fv: + closed (Fn t loco vs args e) ⇔ + ∀v. fv v [e] ⇒ v < args +Proof + rw[closed_Fn] \\ qspec_then`[e]`mp_tac free_thm - \\ simp[] \\ pairarg_tac \\ fs[]); + \\ simp[] \\ pairarg_tac \\ fs[] +QED -Theorem calls_wfg' - `∀xs g0 ys g. +Theorem calls_wfg': + ∀xs g0 ys g. calls xs g0 = (ys,g) ∧ every_Fn_SOME xs ∧ wfg' g0 ⇒ - wfg' g` - (ho_match_mp_tac calls_ind + wfg' g +Proof + ho_match_mp_tac calls_ind \\ rw[calls_def] \\ rw[] \\ fs[code_locs_def] \\ rpt (pairarg_tac \\ fs[]) \\ every_case_tac \\ fs[] \\ rw[] @@ -686,17 +763,19 @@ Theorem calls_wfg' \\ rw[] \\ first_x_assum match_mp_tac \\ qmatch_abbrev_tac`lookup k d = SOME _` \\ `k ∈ domain d` suffices_by simp[domain_lookup] - \\ simp[Abbr`d`,domain_FST_insert_each]); + \\ simp[Abbr`d`,domain_FST_insert_each] +QED -Theorem calls_wfg - `∀xs g0 ys g. +Theorem calls_wfg: + ∀xs g0 ys g. calls xs g0 = (ys,g) ∧ ALL_DISTINCT (code_locs xs) ∧ DISJOINT (IMAGE SUC (set (code_locs xs))) (set (MAP FST (SND g0))) ∧ every_Fn_SOME xs ∧ wfg g0 ⇒ - wfg g` - (rw[] + wfg g +Proof + rw[] \\ `wfg' g0` by fs[wfg_def,SET_EQ_SUBSET,wfg'_def] \\ imp_res_tac calls_wfg' \\ imp_res_tac calls_domain @@ -707,12 +786,14 @@ Theorem calls_wfg \\ fs[SUBSET_DEF,IS_SUFFIX_APPEND] \\ rw[] \\ res_tac \\ rw[] \\ res_tac \\ rw[] \\ fs[] - \\ rw[] \\ rfs[]); + \\ rw[] \\ rfs[] +QED -Theorem calls_fv1_subset - `∀xs g0 ys g. calls xs g0 = (ys,g) ⇒ - LIST_REL (λx y. (combin$C fv1) y ⊆ (combin$C fv1) x) xs ys` - (ho_match_mp_tac calls_ind +Theorem calls_fv1_subset: + ∀xs g0 ys g. calls xs g0 = (ys,g) ⇒ + LIST_REL (λx y. (combin$C fv1) y ⊆ (combin$C fv1) x) xs ys +Proof + ho_match_mp_tac calls_ind \\ rw[calls_def] \\ rpt (pairarg_tac \\ fs[]) \\ imp_res_tac calls_length @@ -733,44 +814,52 @@ Theorem calls_fv1_subset \\ fs[fv_exists,EXISTS_MEM,MEM_EL,PULL_EXISTS] \\ rfs[EL_ZIP] \\ fs[EL_MAP] \\ simp[UNCURRY] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem calls_fv_imp - `calls xs g0 = (ys,g) ∧ fv v ys ⇒ fv v xs` - (rw[] \\ imp_res_tac calls_fv1_subset +Theorem calls_fv_imp: + calls xs g0 = (ys,g) ∧ fv v ys ⇒ fv v xs +Proof + rw[] \\ imp_res_tac calls_fv1_subset \\ fs[LIST_REL_EL_EQN,fv_exists,EXISTS_MEM,MEM_EL,SUBSET_DEF,IN_DEF] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem FST_insert_each_same - `∀p n g0 g0'. - FST g0 = FST g0' ⇒ FST (insert_each p n g0) = FST (insert_each p n g0')` - (ho_match_mp_tac insert_each_ind +Theorem FST_insert_each_same: + ∀p n g0 g0'. + FST g0 = FST g0' ⇒ FST (insert_each p n g0) = FST (insert_each p n g0') +Proof + ho_match_mp_tac insert_each_ind \\ rw[insert_each_def] \\ fs[FORALL_PROD] - \\ Cases_on`g0'` \\ fs[insert_each_def]); + \\ Cases_on`g0'` \\ fs[insert_each_def] +QED -Theorem code_list_replace_SND - `∀loc fns g0 g g0' ls. +Theorem code_list_replace_SND: + ∀loc fns g0 g g0' ls. code_list loc fns g0 = g ∧ FST g0 = FST g0' ∧ SND g = ls ++ SND g0 ⇒ - code_list loc fns g0' = (FST g, ls ++ SND g0')` - (ho_match_mp_tac code_list_ind + code_list loc fns g0' = (FST g, ls ++ SND g0') +Proof + ho_match_mp_tac code_list_ind \\ rw[code_list_def] \\ fs[] \\ rw[] \\ Cases_on`g0'` \\ fs[code_list_def] \\ fs[FORALL_PROD] \\ qmatch_asmsub_abbrev_tac`SND (code_list l2 fns g)` \\ qispl_then[`l2`,`fns`,`g`]strip_assume_tac code_list_IS_SUFFIX - \\ fs[IS_SUFFIX_APPEND,Abbr`g`] \\ fs[] \\ rw[] \\ fs[]); + \\ fs[IS_SUFFIX_APPEND,Abbr`g`] \\ fs[] \\ rw[] \\ fs[] +QED -Theorem calls_replace_SND - `∀xs g0 ys g g0' ls. +Theorem calls_replace_SND: + ∀xs g0 ys g g0' ls. calls xs g0 = (ys,g) ∧ FST g0 = FST g0' ∧ SND g = ls ++ SND g0 ⇒ - calls xs g0' = (ys,(FST g,ls ++ SND g0'))` - (ho_match_mp_tac calls_ind + calls xs g0' = (ys,(FST g,ls ++ SND g0')) +Proof + ho_match_mp_tac calls_ind \\ rw[calls_def] \\ fs[] \\ rpt(pairarg_tac \\ fs[]) \\ rveq \\ fs[] @@ -824,7 +913,8 @@ Theorem calls_replace_SND \\ first_x_assum(qspec_then`g0'`mp_tac) \\ simp[] \\ imp_res_tac calls_IS_SUFFIX \\ fs[IS_SUFFIX_APPEND] \\ (strip_tac ORELSE spose_not_then strip_assume_tac) \\ rveq \\ fs[] \\ rveq \\ fs[] - \\ metis_tac[SND,FST,PAIR,APPEND_ASSOC,CONS_11,IS_SOME_DEF]); + \\ metis_tac[SND,FST,PAIR,APPEND_ASSOC,CONS_11,IS_SOME_DEF] +QED val insert_each'_def = Define` (insert_each' gt p 0 g = g) ∧ @@ -833,12 +923,13 @@ val insert_each'_def = Define` val insert_each'_ind = theorem"insert_each'_ind"; -Theorem wfg_insert_each' - `∀gt p n g. +Theorem wfg_insert_each': + ∀gt p n g. wfg g ∧ DISJOINT (set (GENLIST (λi. p+2*i) n)) (domain (FST g)) - ⇒ wfg (insert_each' gt p n g)` - (ho_match_mp_tac insert_each'_ind + ⇒ wfg (insert_each' gt p n g) +Proof + ho_match_mp_tac insert_each'_ind \\ rw[insert_each'_def] \\ first_x_assum match_mp_tac \\ fs[wfg_def,GSYM ADD1] @@ -847,36 +938,43 @@ Theorem wfg_insert_each' \\ rw[] \\ first_assum (qspec_then`0`mp_tac) \\ first_x_assum (qspec_then`SUC i`mp_tac) - \\ simp[ADD1,LEFT_ADD_DISTRIB]); + \\ simp[ADD1,LEFT_ADD_DISTRIB] +QED -Theorem FST_insert_each' - `∀gt p n g. FST (insert_each' gt p n g) = FST (insert_each p n g)` - (ho_match_mp_tac insert_each'_ind +Theorem FST_insert_each': + ∀gt p n g. FST (insert_each' gt p n g) = FST (insert_each p n g) +Proof + ho_match_mp_tac insert_each'_ind \\ rw[insert_each'_def,insert_each_def] \\ match_mp_tac FST_insert_each_same - \\ rw[]); + \\ rw[] +QED -Theorem MAP_FST_insert_each' - `∀gt p n g. +Theorem MAP_FST_insert_each': + ∀gt p n g. MAP FST (SND (insert_each' gt p n g)) = REVERSE (GENLIST (λi. p + i * 2 + 1) n) ++ - MAP FST (SND g)` - (ho_match_mp_tac insert_each'_ind + MAP FST (SND g) +Proof + ho_match_mp_tac insert_each'_ind \\ rw[insert_each'_def,GENLIST_CONS,o_DEF,ADD1,LEFT_ADD_DISTRIB] \\ AP_THM_TAC \\ AP_TERM_TAC - \\ simp[FUN_EQ_THM]); + \\ simp[FUN_EQ_THM] +QED -Theorem SND_insert_each' - `∀gt p n g. SND (insert_each' gt p n g) = - REVERSE (GENLIST (λi. (2*i+p+1,THE(ALOOKUP gt (2*i+p+1)))) n) ++ SND g` - (ho_match_mp_tac insert_each'_ind +Theorem SND_insert_each': + ∀gt p n g. SND (insert_each' gt p n g) = + REVERSE (GENLIST (λi. (2*i+p+1,THE(ALOOKUP gt (2*i+p+1)))) n) ++ SND g +Proof + ho_match_mp_tac insert_each'_ind \\ rw[insert_each'_def] \\ rw[GENLIST_CONS,o_DEF,ADD1] \\ AP_THM_TAC \\ AP_TERM_TAC - \\ simp[FUN_EQ_THM,LEFT_ADD_DISTRIB]); + \\ simp[FUN_EQ_THM,LEFT_ADD_DISTRIB] +QED -Theorem calls_el_sing - `∀xs g0 ys g i. +Theorem calls_el_sing: + ∀xs g0 ys g i. calls xs g0 = (ys,g) ∧ i < LENGTH xs ∧ ALL_DISTINCT (MAP FST (SND g0)) ∧ @@ -889,8 +987,9 @@ Theorem calls_el_sing subg g0 ga ∧ subg ga gb ∧ subg gb g ∧ wfg ga ∧ wfg gb ∧ DISJOINT (IMAGE SUC (set (code_locs [EL i xs]))) (set (MAP FST (SND ga))) ∧ set (MAP FST (SND ga)) ⊆ set (MAP FST (SND g0)) ∪ IMAGE SUC (set (code_locs (TAKE i xs))) ∧ - (set (code_locs [EL i xs]) DIFF (domain (FST gb))) ⊆ (set (code_locs xs) DIFF (domain (FST g)))` - (ho_match_mp_tac calls_ind \\ rw[] + (set (code_locs [EL i xs]) DIFF (domain (FST gb))) ⊆ (set (code_locs xs) DIFF (domain (FST g))) +Proof + ho_match_mp_tac calls_ind \\ rw[] \\ imp_res_tac calls_length \\ fs[quantHeuristicsTheory.LIST_LENGTH_2] \\ TRY ( @@ -956,7 +1055,8 @@ Theorem calls_el_sing \\ first_assum(part_match_exists_tac(last o strip_conj) o concl) \\ rw[] \\ match_mp_tac calls_subg \\ asm_exists_tac \\ fs[] - \\ fs[code_locs_def,ALL_DISTINCT_APPEND]); + \\ fs[code_locs_def,ALL_DISTINCT_APPEND] +QED fun pairmaparg_tac (g as (asl,w)) = (tryfind @@ -972,10 +1072,12 @@ fun pairmaparg_tac (g as (asl,w)) = (fn tm => Cases_on [ANTIQUOTE (rand tm)]))) (w::asl)) g -Theorem insert_each_pair_arg - `insert_each x y (p,q) = (FST (insert_each x y (p,q')), q)` - (Cases_on`insert_each x y (p,q)` \\ rw[] - \\ metis_tac[SND_insert_each, SND, FST_insert_each_same, FST]); +Theorem insert_each_pair_arg: + insert_each x y (p,q) = (FST (insert_each x y (p,q')), q) +Proof + Cases_on`insert_each x y (p,q)` \\ rw[] + \\ metis_tac[SND_insert_each, SND, FST_insert_each_same, FST] +QED val calls_acc_0 = Q.prove( `!xs tmp x r. @@ -1056,19 +1158,22 @@ val calls_acc_0 = Q.prove( \\ `q'' = q` by metis_tac[FST_code_list, FST] \\ fs[] )); -Theorem calls_acc - `!xs d old res d1 aux. +Theorem calls_acc: + !xs d old res d1 aux. calls xs (d, []) = (res, d1, aux) ==> - calls xs (d, old) = (res, d1, aux ++ old)` - (rw[] + calls xs (d, old) = (res, d1, aux ++ old) +Proof + rw[] \\ qspecl_then[`xs`,`d,old`,`[]`,`old`]mp_tac calls_acc_0 - \\ simp[]); + \\ simp[] +QED (* properties of value relation *) -Theorem v_rel_exists - `∀v1. wfv g l code v1 ⇒ ∃v2. v_rel g l code v1 v2` - (ho_match_mp_tac v_ind +Theorem v_rel_exists: + ∀v1. wfv g l code v1 ⇒ ∃v2. v_rel g l code v1 v2 +Proof + ho_match_mp_tac v_ind \\ rw[v_rel_def] >- ( simp[exists_list_GENLIST] @@ -1096,13 +1201,15 @@ Theorem v_rel_exists \\ asm_exists_tac \\ fs[EVERY_MEM,MEM_EL,LIST_REL_EL_EQN,PULL_EXISTS,env_rel_def] \\ simp[exists_list_GENLIST] - \\ metis_tac[SKOLEM_THM] )); + \\ metis_tac[SKOLEM_THM] ) +QED -Theorem v_rel_subg - `∀g l code v1 v2 g' l'. +Theorem v_rel_subg: + ∀g l code v1 v2 g' l'. v_rel g l code v1 v2 ∧ subg g g' ∧ l ⊆ l' ⇒ - v_rel g' l' code v1 v2` - (ho_match_mp_tac v_rel_ind + v_rel g' l' code v1 v2 +Proof + ho_match_mp_tac v_rel_ind \\ rw[v_rel_def,env_rel_def,recclosure_rel_def] \\ Cases_on`LENGTH env1 = LENGTH env2` \\ fsrw_tac[ETA_ss][PULL_FORALL,PULL_EXISTS] @@ -1126,25 +1233,30 @@ Theorem v_rel_subg \\ rveq \\ fs[] \\ CASE_TAC \\ fs[] \\ rfs[] \\ fs[EXISTS_MEM,EXISTS_PROD] - \\ metis_tac[subg_trans,SUBSET_DEF,MEM_EL]); + \\ metis_tac[subg_trans,SUBSET_DEF,MEM_EL] +QED -Theorem code_includes_subg - `subg g1 g2 ⇒ code_includes (SND g2) code ⇒ code_includes (SND g1) code` - (rw[subg_def,code_includes_def,IS_SUFFIX_APPEND] +Theorem code_includes_subg: + subg g1 g2 ⇒ code_includes (SND g2) code ⇒ code_includes (SND g1) code +Proof + rw[subg_def,code_includes_def,IS_SUFFIX_APPEND] \\ first_x_assum match_mp_tac \\ rw[ALOOKUP_APPEND] \\ BasicProvers.CASE_TAC \\ imp_res_tac ALOOKUP_MEM \\ rfs[ALL_DISTINCT_APPEND,MEM_MAP,PULL_EXISTS] \\ res_tac \\ fs[] - \\ metis_tac[FST]); + \\ metis_tac[FST] +QED -Theorem code_includes_ALOOKUP - `code_includes al code ∧ ALOOKUP al loc = SOME r ⇒ FLOOKUP code loc = SOME r` - (rw[code_includes_def]); +Theorem code_includes_ALOOKUP: + code_includes al code ∧ ALOOKUP al loc = SOME r ⇒ FLOOKUP code loc = SOME r +Proof + rw[code_includes_def] +QED -Theorem dest_closure_v_rel_lookup - `dest_closure max_app (SOME loc) v1 env1 = SOME x ∧ +Theorem dest_closure_v_rel_lookup: + dest_closure max_app (SOME loc) v1 env1 = SOME x ∧ v_rel g l code v1 v2 ∧ LIST_REL (v_rel g l code) env1 env2 ∧ wfg g ∧ loc ∈ domain (FST g) ∧ loc ∉ l ⇒ @@ -1156,8 +1268,9 @@ Theorem dest_closure_v_rel_lookup dest_closure max_app (SOME loc) v2 env2 = SOME (Full_app (Call (tra§i§0) 0 (loc+1) (GENLIST_Var (tra§i) 1 (LENGTH env1))) (env2++l1') []) ∧ - code_includes (SND (code_list (loc - 2*n) (ZIP (MAP FST xs,ls)) g1)) code` - (rw[dest_closure_def] + code_includes (SND (code_list (loc - 2*n) (ZIP (MAP FST xs,ls)) g1)) code +Proof + rw[dest_closure_def] \\ every_case_tac \\ fs[v_rel_def,recclosure_rel_def] \\ rw[] \\ fs[check_loc_def] \\ rw[] \\ rpt(pairarg_tac \\ fs[]) \\ rveq \\ rfs[] @@ -1206,10 +1319,11 @@ Theorem dest_closure_v_rel_lookup \\ simp[calls_list_MAPi] \\ rw[] \\ qexists_tac`g0` - \\ simp[]); + \\ simp[] +QED -Theorem dest_closure_v_rel - `dest_closure max_app loco v1 env1 = SOME x1 ∧ +Theorem dest_closure_v_rel: + dest_closure max_app loco v1 env1 = SOME x1 ∧ v_rel g l code v1 v2 ∧ LIST_REL (v_rel g l code) env1 env2 ⇒ @@ -1228,8 +1342,9 @@ Theorem dest_closure_v_rel LIST_REL (v_rel g l code) rest1 rest2 ∧ recclosure_rel g l code loc fns1 fns2 ∧ i < LENGTH fns1 ∧ - EL i fns1 = (n,e1))` - (rw[dest_closure_def] + EL i fns1 = (n,e1)) +Proof + rw[dest_closure_def] \\ Cases_on`v1` \\ fs[v_rel_def] \\ rveq \\ fs[] \\ imp_res_tac LIST_REL_LENGTH \\ fs[] @@ -1297,12 +1412,14 @@ Theorem dest_closure_v_rel \\ fs[EXISTS_MEM,PULL_EXISTS,MEM_EL] \\ qx_gen_tac`x` \\ first_x_assum(qspecl_then[`x`,`n`]mp_tac) - \\ simp[]); + \\ simp[] +QED -Theorem dest_closure_partial_wfv - `dest_closure max_app loco v env = SOME (Partial_app x) ∧ - EVERY (wfv g l code) env ∧ wfv g l code v ⇒ wfv g l code x` - (rw[dest_closure_def] +Theorem dest_closure_partial_wfv: + dest_closure max_app loco v env = SOME (Partial_app x) ∧ + EVERY (wfv g l code) env ∧ wfv g l code v ⇒ wfv g l code x +Proof + rw[dest_closure_def] \\ every_case_tac \\ fs[] \\ rw[] \\ rpt(pairarg_tac \\ fs[]) @@ -1311,17 +1428,19 @@ Theorem dest_closure_partial_wfv qmatch_asmsub_rename_tac`Recclosure lopt`) \\ Cases_on`lopt` \\ fs[] \\ rveq \\ fsrw_tac[ETA_ss][] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem dest_closure_full_wfv - `dest_closure max_app loco v env = SOME (Full_app e args rest) ∧ +Theorem dest_closure_full_wfv: + dest_closure max_app loco v env = SOME (Full_app e args rest) ∧ wfv g l code v ∧ EVERY (wfv g l code) env ⇒ ∃ys g01 loc fns1 fns2 i. EVERY (wfv g l code) args ∧ EVERY (wfv g l code) rest ∧ recclosure_rel g l code loc fns1 fns2 ∧ - SND (EL i fns1) = e ∧ i < LENGTH fns1` - (rw[dest_closure_def] + SND (EL i fns1) = e ∧ i < LENGTH fns1 +Proof + rw[dest_closure_def] \\ every_case_tac \\ fs[] \\ rw[] \\ rpt(pairarg_tac \\ fs[]) \\ every_case_tac \\ fs[] \\ rw[] @@ -1336,15 +1455,17 @@ Theorem dest_closure_full_wfv \\ simp[PULL_EXISTS] \\ TRY ( rw[] \\ asm_exists_tac \\ fs[]) \\ fs[NOT_LESS_EQUAL] - \\ metis_tac[PAIR,SND,EL,HD]); + \\ metis_tac[PAIR,SND,EL,HD] +QED -Theorem env_rel_DROP - `env_rel R (DROP x l1) (DROP x l2) x es ∧ +Theorem env_rel_DROP: + env_rel R (DROP x l1) (DROP x l2) x es ∧ LIST_REL R (TAKE x l1) (TAKE x l2) ∧ x ≤ LENGTH l1 ∧ x ≤ LENGTH l2 ⇒ - env_rel R l1 l2 0 es` - (strip_tac \\ fs[env_rel_def] + env_rel R l1 l2 0 es +Proof + strip_tac \\ fs[env_rel_def] \\ IF_CASES_TAC \\ fs[] >- ( metis_tac[EVERY2_APPEND_suff,TAKE_DROP] ) \\ fs[LIST_REL_EL_EQN,EL_TAKE,EXISTS_MEM,PULL_EXISTS] @@ -1356,14 +1477,16 @@ Theorem env_rel_DROP \\ pairarg_tac \\ fs[] \\ disch_then(qspec_then`p`mp_tac) \\ simp[] \\ strip_tac - \\ rfs[EL_DROP]); + \\ rfs[EL_DROP] +QED -Theorem env_rel_DROP_args - `env_rel R (DROP n l1) (DROP n l2) a [(n,e)] ∧ +Theorem env_rel_DROP_args: + env_rel R (DROP n l1) (DROP n l2) a [(n,e)] ∧ LIST_REL R (TAKE n l1) (TAKE n l2) ∧ n ≤ LENGTH l1 ∧ n ≤ LENGTH l2 ⇒ - env_rel R l1 l2 a [(0,e)]` - (simp[env_rel_def] + env_rel R l1 l2 a [(0,e)] +Proof + simp[env_rel_def] \\ IF_CASES_TAC \\ fs[] >- metis_tac[TAKE_DROP,EVERY2_APPEND_suff] \\ strip_tac @@ -1374,10 +1497,11 @@ Theorem env_rel_DROP_args \\ strip_tac \\ first_x_assum drule \\ simp[] \\ strip_tac - \\ rfs[EL_DROP]); + \\ rfs[EL_DROP] +QED -Theorem subg_insert_each' - `!gb fns1 es g1. +Theorem subg_insert_each': + !gb fns1 es g1. subg gb (FST new_g,l ++ SND (insert_each' g1 loc (LENGTH fns1) g)) /\ SND new_g = l ++ SND g /\ LENGTH fns1 = LENGTH es ∧ wfg g ∧ @@ -1386,8 +1510,9 @@ Theorem subg_insert_each' (∀i. i < LENGTH fns1 ⇒ ALOOKUP g1 (2*i+loc+1) = SOME (FST (EL i fns1), EL i es)) ==> subg (FST new_g,l ++ SND (insert_each' g1 loc (LENGTH fns1) g)) - (code_list loc (ZIP (MAP FST fns1,es)) new_g)` - (Cases_on `new_g` \\ fs [] \\ PairCases_on `g` \\ fs [] + (code_list loc (ZIP (MAP FST fns1,es)) new_g) +Proof + Cases_on `new_g` \\ fs [] \\ PairCases_on `g` \\ fs [] \\ rw [] \\ rveq \\ fs [subg_def] \\ fs[ALL_DISTINCT_APPEND,MAP_FST_code_list,MEM_GENLIST,PULL_EXISTS, wfg_def,ALL_DISTINCT_GENLIST,IN_DISJOINT] @@ -1443,16 +1568,18 @@ Theorem subg_insert_each' \\ rveq \\ rfs[EL_GENLIST,MEM_MAP,PULL_EXISTS] \\ res_tac \\ fs[ADD1] - \\ metis_tac[ADD_ASSOC,ADD_COMM]); + \\ metis_tac[ADD_ASSOC,ADD_COMM] +QED val code_includes_SUBMAP = prove( ``code_includes x y1 /\ y1 SUBMAP y2 ==> code_includes x y2``, fs [code_includes_def,SUBMAP_DEF,FLOOKUP_DEF] \\ metis_tac []); -Theorem wfv_subg - `∀g l code v g' l' code'. - wfv g l code v ∧ code SUBMAP code' ∧ subg g g' ∧ l ⊆ l' ⇒ wfv g' l' code' v` - (ho_match_mp_tac wfv_ind \\ rw[] +Theorem wfv_subg: + ∀g l code v g' l' code'. + wfv g l code v ∧ code SUBMAP code' ∧ subg g g' ∧ l ⊆ l' ⇒ wfv g' l' code' v +Proof + ho_match_mp_tac wfv_ind \\ rw[] \\ fsrw_tac[ETA_ss][] \\ fs[EVERY_MEM] \\ fs[recclosure_rel_def] @@ -1461,12 +1588,14 @@ Theorem wfv_subg \\ qexists_tac`g0`\\fs[] \\ CASE_TAC \\ fs[SUBSET_DEF] \\ rveq \\ fs[] - \\ metis_tac[subg_trans,code_includes_SUBMAP]); + \\ metis_tac[subg_trans,code_includes_SUBMAP] +QED -Theorem wfv_SUBMAP - `!g1 l1 code v code1. - wfv g1 l1 code v /\ code SUBMAP code1 ==> wfv g1 l1 code1 v` - (ho_match_mp_tac wfv_ind \\ rw[] +Theorem wfv_SUBMAP: + !g1 l1 code v code1. + wfv g1 l1 code v /\ code SUBMAP code1 ==> wfv g1 l1 code1 v +Proof + ho_match_mp_tac wfv_ind \\ rw[] \\ fsrw_tac[ETA_ss][] \\ fs[EVERY_MEM] \\ fs[recclosure_rel_def] @@ -1475,25 +1604,31 @@ Theorem wfv_SUBMAP \\ qexists_tac`g0`\\fs[] \\ CASE_TAC \\ fs[SUBSET_DEF] \\ rveq \\ fs[] - \\ metis_tac[subg_trans,code_includes_SUBMAP]); + \\ metis_tac[subg_trans,code_includes_SUBMAP] +QED -Theorem EVERY_wfv_SUBMAP - `EVERY (wfv g1 l1 code) env /\ code SUBMAP code1 ==> - EVERY (wfv g1 l1 code1) env` - (fs [EVERY_MEM] \\ metis_tac [wfv_SUBMAP]); +Theorem EVERY_wfv_SUBMAP: + EVERY (wfv g1 l1 code) env /\ code SUBMAP code1 ==> + EVERY (wfv g1 l1 code1) env +Proof + fs [EVERY_MEM] \\ metis_tac [wfv_SUBMAP] +QED -Theorem wfv_state_SUBMAP - `!g1 l1 code s code1. +Theorem wfv_state_SUBMAP: + !g1 l1 code s code1. wfv_state g1 l1 code s /\ code SUBMAP code1 ==> - wfv_state g1 l1 code1 s` - (rw[wfv_state_def, EVERY_MEM, FEVERY_ALL_FLOOKUP] + wfv_state g1 l1 code1 s +Proof + rw[wfv_state_def, EVERY_MEM, FEVERY_ALL_FLOOKUP] \\ metis_tac[OPTION_ALL_MONO, wfv_SUBMAP, every_refv_def, - MONO_EVERY, ref_nchotomy]); + MONO_EVERY, ref_nchotomy] +QED -Theorem v_rel_SUBMAP - `!g1 l1 code v1 v2 code1. - v_rel g1 l1 code v1 v2 /\ code SUBMAP code1 ==> v_rel g1 l1 code1 v1 v2` - (ho_match_mp_tac v_rel_ind \\ rw[] +Theorem v_rel_SUBMAP: + !g1 l1 code v1 v2 code1. + v_rel g1 l1 code v1 v2 /\ code SUBMAP code1 ==> v_rel g1 l1 code1 v1 v2 +Proof + ho_match_mp_tac v_rel_ind \\ rw[] \\ fsrw_tac[ETA_ss][v_rel_def] \\ fs [MEM_EL,PULL_EXISTS,PULL_FORALL,AND_IMP_INTRO] \\ fs[env_rel_def, recclosure_rel_def, LIST_REL_EL_EQN] @@ -1502,35 +1637,44 @@ Theorem v_rel_SUBMAP qexists_tac`g0` \\ fs[] \\ rpt(pairarg_tac \\ fs[]) \\ rw[] \\ rfs[] ) - \\ metis_tac[code_includes_SUBMAP]); + \\ metis_tac[code_includes_SUBMAP] +QED -Theorem LIST_REL_v_rel_SUBMAP - `!g1 l1 code v1 v2 code1. +Theorem LIST_REL_v_rel_SUBMAP: + !g1 l1 code v1 v2 code1. LIST_REL (v_rel g1 l1 code) v1 v2 /\ code SUBMAP code1 ==> - LIST_REL (v_rel g1 l1 code1) v1 v2` - (metis_tac[LIST_REL_mono, v_rel_SUBMAP]); + LIST_REL (v_rel g1 l1 code1) v1 v2 +Proof + metis_tac[LIST_REL_mono, v_rel_SUBMAP] +QED -Theorem env_rel_SUBMAP - `!code code' g1 l1 env1 env2 n vars. +Theorem env_rel_SUBMAP: + !code code' g1 l1 env1 env2 n vars. env_rel (v_rel g1 l1 code) env1 env2 n vars /\ code SUBMAP code' ==> - env_rel (v_rel g1 l1 code') env1 env2 n vars` - (rw[env_rel_def, EXISTS_MEM, PULL_EXISTS, UNCURRY] - \\ metis_tac[LIST_REL_mono, v_rel_SUBMAP]); + env_rel (v_rel g1 l1 code') env1 env2 n vars +Proof + rw[env_rel_def, EXISTS_MEM, PULL_EXISTS, UNCURRY] + \\ metis_tac[LIST_REL_mono, v_rel_SUBMAP] +QED (* semantic functions respect relation *) -Theorem v_rel_Unit[simp] - `v_rel g1 l1 code Unit Unit` - (EVAL_TAC \\ fs []); +Theorem v_rel_Unit[simp]: + v_rel g1 l1 code Unit Unit +Proof + EVAL_TAC \\ fs [] +QED -Theorem v_to_list_thm - `!h h' x. +Theorem v_to_list_thm: + !h h' x. v_to_list h = SOME x /\ v_rel g1 l1 code h h' ==> - ?x'. v_to_list h' = SOME x' /\ LIST_REL (v_rel g1 l1 code) x x'` - (recInduct v_to_list_ind \\ rw [] \\ fs [v_to_list_def] \\ rw [] + ?x'. v_to_list h' = SOME x' /\ LIST_REL (v_rel g1 l1 code) x x' +Proof + recInduct v_to_list_ind \\ rw [] \\ fs [v_to_list_def] \\ rw [] \\ fs [v_rel_def,v_to_list_def] \\ rw [] \\ every_case_tac \\ fs [] \\ rw [] \\ fs [] - \\ res_tac \\ fs [] \\ rw []); + \\ res_tac \\ fs [] \\ rw [] +QED val v_rel_IMP_v_to_bytes_lemma = prove( ``!x y c g code. @@ -1560,76 +1704,92 @@ val v_rel_IMP_v_to_words_lemma = prove( \\ Cases_on `h'` \\ fs [v_rel_def] \\ Cases_on `h` \\ fs [v_rel_def]); -Theorem v_to_bytes_thm - `!h h' x. +Theorem v_to_bytes_thm: + !h h' x. v_to_bytes h = SOME x /\ v_rel g1 l1 code h h' ==> - v_to_bytes h' = SOME x` - (rw [v_to_bytes_def] \\ drule v_rel_IMP_v_to_bytes_lemma \\ fs [] - \\ rw [] \\ fs []); + v_to_bytes h' = SOME x +Proof + rw [v_to_bytes_def] \\ drule v_rel_IMP_v_to_bytes_lemma \\ fs [] + \\ rw [] \\ fs [] +QED -Theorem v_to_words_thm - `!h h' x. +Theorem v_to_words_thm: + !h h' x. v_to_words h = SOME x /\ v_rel g1 l1 code h h' ==> - v_to_words h' = SOME x` - (rw [v_to_words_def] \\ drule v_rel_IMP_v_to_words_lemma \\ fs [] - \\ rw [] \\ fs []); + v_to_words h' = SOME x +Proof + rw [v_to_words_def] \\ drule v_rel_IMP_v_to_words_lemma \\ fs [] + \\ rw [] \\ fs [] +QED -Theorem v_to_list_wfv - `!h x. v_to_list h = SOME x /\ wfv g1 l1 code h ==> EVERY (wfv g1 l1 code) x` - (recInduct v_to_list_ind \\ rw [] \\ fs [v_to_list_def] \\ rw [] +Theorem v_to_list_wfv: + !h x. v_to_list h = SOME x /\ wfv g1 l1 code h ==> EVERY (wfv g1 l1 code) x +Proof + recInduct v_to_list_ind \\ rw [] \\ fs [v_to_list_def] \\ rw [] \\ every_case_tac \\ fs [] \\ rw [] \\ fs [] - \\ res_tac \\ fs [] \\ rw []); + \\ res_tac \\ fs [] \\ rw [] +QED -Theorem wfv_Boolv - `wfv g1 l1 code (Boolv b) /\ wfv g1 l1 code Unit` - (Cases_on `b` \\ EVAL_TAC); +Theorem wfv_Boolv: + wfv g1 l1 code (Boolv b) /\ wfv g1 l1 code Unit +Proof + Cases_on `b` \\ EVAL_TAC +QED -Theorem vrel_list_to_v - `!xs1 xs2 ys1 ys2. +Theorem vrel_list_to_v: + !xs1 xs2 ys1 ys2. LIST_REL (v_rel g l code) xs1 xs2 /\ LIST_REL (v_rel g l code) ys1 ys2 /\ v_rel g l code (list_to_v xs1) (list_to_v xs2) /\ v_rel g l code (list_to_v ys1) (list_to_v ys2) ==> - v_rel g l code (list_to_v (xs1 ++ ys1)) (list_to_v (xs2 ++ ys2))` - (Induct >- rw [list_to_v_def] \\ gen_tac - \\ Induct \\ rw [list_to_v_def] \\ fs [v_rel_def]); + v_rel g l code (list_to_v (xs1 ++ ys1)) (list_to_v (xs2 ++ ys2)) +Proof + Induct >- rw [list_to_v_def] \\ gen_tac + \\ Induct \\ rw [list_to_v_def] \\ fs [v_rel_def] +QED -Theorem vrel_v2l_l2v - `!x y xs ys. +Theorem vrel_v2l_l2v: + !x y xs ys. v_rel g l code x y /\ v_to_list x = SOME xs /\ v_to_list y = SOME ys ==> - v_rel g l code (list_to_v xs) (list_to_v ys)` - (ho_match_mp_tac v_to_list_ind \\ rw [v_to_list_def, v_rel_def] + v_rel g l code (list_to_v xs) (list_to_v ys) +Proof + ho_match_mp_tac v_to_list_ind \\ rw [v_to_list_def, v_rel_def] \\ fs [list_to_v_def] \\ rveq \\ fs [v_to_list_def] \\ rveq \\ fs [list_to_v_def, case_eq_thms, v_rel_def] \\ rveq \\ fs [list_to_v_def, v_rel_def] - \\ res_tac); + \\ res_tac +QED -Theorem wfv_v2l_l2v - `!x y xs ys. wfv g l code x /\ v_to_list x = SOME xs ==> - wfv g l code (list_to_v xs)` - (ho_match_mp_tac v_to_list_ind \\ rw [v_to_list_def, wfv_def] +Theorem wfv_v2l_l2v: + !x y xs ys. wfv g l code x /\ v_to_list x = SOME xs ==> + wfv g l code (list_to_v xs) +Proof + ho_match_mp_tac v_to_list_ind \\ rw [v_to_list_def, wfv_def] \\ fs [list_to_v_def, case_eq_thms] - \\ rw [list_to_v_def]); + \\ rw [list_to_v_def] +QED -Theorem wfv_v2l - `!x y xs ys. +Theorem wfv_v2l: + !x y xs ys. wfv g l code x /\ wfv g l code y /\ v_to_list x = SOME xs /\ v_to_list y = SOME ys ==> - ?z. wfv g l code z /\ v_to_list z = SOME (xs ++ ys)` - (ho_match_mp_tac v_to_list_ind \\ rw [v_to_list_def] \\ fs [] + ?z. wfv g l code z /\ v_to_list z = SOME (xs ++ ys) +Proof + ho_match_mp_tac v_to_list_ind \\ rw [v_to_list_def] \\ fs [] >- metis_tac [] \\ fs [case_eq_thms] \\ rw [] \\ first_x_assum drule \\ disch_then drule \\ fs [] \\ rw [] \\ Cases_on `z` \\ fs [v_to_list_def] \\ qexists_tac `Block cons_tag [h; Block n l']` - \\ fs [wfv_def, v_to_list_def]); + \\ fs [wfv_def, v_to_list_def] +QED -Theorem do_app_thm - `case do_app op (REVERSE a) (r:(abs_calls_state # 'c,'ffi) closSem$state) of +Theorem do_app_thm: + case do_app op (REVERSE a) (r:(abs_calls_state # 'c,'ffi) closSem$state) of Rerr (Rraise _) => F | Rerr (Rabort e) => (e = Rtype_error \/ @@ -1641,8 +1801,9 @@ Theorem do_app_thm wfv_state g1 l1 t.code s /\ wfv g1 l1 t.code w) /\ (LIST_REL (v_rel g1 l1 t.code) a v /\ state_rel g1 l1 r t ==> ?w' s'. (do_app op (REVERSE v) t = Rval (w',s')) /\ - v_rel g1 l1 t.code w w' /\ state_rel g1 l1 s s')` - (reverse CASE_TAC THEN1 + v_rel g1 l1 t.code w w' /\ state_rel g1 l1 s s') +Proof + reverse CASE_TAC THEN1 (pop_assum mp_tac \\ Cases_on `op` \\ Cases_on `REVERSE a` \\ simp[do_app_def, case_eq_thms, bool_case_eq, pair_case_eq, CaseEq"ffi$ffi_result"] @@ -1736,26 +1897,31 @@ Theorem do_app_thm \\ pop_assum mp_tac \\ rw [] \\ fs [] \\ pop_assum mp_tac \\ rpt (pop_assum kall_tac) - \\ Induct_on `a` \\ fs []); + \\ Induct_on `a` \\ fs [] +QED -Theorem NOT_IN_domain_FST_g - `ALL_DISTINCT (code_locs xs ++ code_locs ys) ⇒ +Theorem NOT_IN_domain_FST_g: + ALL_DISTINCT (code_locs xs ++ code_locs ys) ⇒ calls ys g' = (e2,g) ⇒ wfg g' ⇒ MEM x (code_locs xs) ⇒ x ∉ domain (FST g') ⇒ - x ∉ domain (FST g)` - (rw [] \\ imp_res_tac calls_domain + x ∉ domain (FST g) +Proof + rw [] \\ imp_res_tac calls_domain \\ fs [SUBSET_DEF,DISJOINT_DEF,EXTENSION] \\ rw [] \\ CCONTR_TAC \\ fs [] \\ res_tac \\ rveq \\ fs [] \\ drule calls_add_SUC_code_locs \\ fs [SUBSET_DEF] \\ asm_exists_tac \\ fs [] \\ CCONTR_TAC \\ fs [] \\ rfs [wfg_def,SUBSET_DEF,EXTENSION] \\ rveq \\ fs [] - \\ fs [ALL_DISTINCT_APPEND] \\ res_tac); + \\ fs [ALL_DISTINCT_APPEND] \\ res_tac +QED -Theorem v_rel_Boolv[simp] - `v_rel g1 l1 code (Boolv b) v <=> (v = Boolv b)` - (Cases_on `b` \\ Cases_on `v` \\ fs [v_rel_def,Boolv_def]); +Theorem v_rel_Boolv[simp]: + v_rel g1 l1 code (Boolv b) v <=> (v = Boolv b) +Proof + Cases_on `b` \\ Cases_on `v` \\ fs [v_rel_def,Boolv_def] +QED val env_rel_Op_Install = prove( ``env_rel r env env2 0 [(0,Op v6 Install e1)] <=> @@ -1788,36 +1954,42 @@ val co_ok_def = Define ` ALL_DISTINCT (MAP FST aux1) /\ co_ok (code |++ aux1) (shift_seq 1 co) (shift_seq 1 full_gs) (k-1n)` -Theorem co_ok_IMP_full_gs_eq_shift_seq - `∀k code co g full_gs. +Theorem co_ok_IMP_full_gs_eq_shift_seq: + ∀k code co g full_gs. co_ok code co full_gs (k+1) ==> - FST (FST (shift_seq k co 0)) = FST (full_gs k)` - (Induct \\ simp [Once co_ok_def] + FST (FST (shift_seq k co 0)) = FST (full_gs k) +Proof + Induct \\ simp [Once co_ok_def] \\ rw [] \\ rpt (pairarg_tac \\ fs []) THEN1 (Cases_on `full_gs 0` \\ fs [shift_seq_def] \\ fs [make_g_def] \\ rveq \\ fs [shift_seq_def]) \\ fs [ADD1] \\ first_x_assum drule - \\ fs [shift_seq_def]); + \\ fs [shift_seq_def] +QED -Theorem co_ok_IMP_wfg_full_gs - `∀k code co g full_gs. co_ok code co full_gs (k+1) ==> wfg (full_gs k)` - (Induct \\ simp [Once co_ok_def] +Theorem co_ok_IMP_wfg_full_gs: + ∀k code co g full_gs. co_ok code co full_gs (k+1) ==> wfg (full_gs k) +Proof + Induct \\ simp [Once co_ok_def] \\ rw [] \\ rpt (pairarg_tac \\ fs []) \\ imp_res_tac make_g_wfg \\ fs [ADD1] \\ res_tac - \\ fs [shift_seq_def]); + \\ fs [shift_seq_def] +QED -Theorem co_ok_IMP_make_g - `∀k code co g full_gs. +Theorem co_ok_IMP_make_g: + ∀k code co g full_gs. co_ok code co full_gs (k+1) ==> - ?x1 x2. make_g x1 x2 = SOME (full_gs k)` - (Induct \\ simp [Once co_ok_def] + ?x1 x2. make_g x1 x2 = SOME (full_gs k) +Proof + Induct \\ simp [Once co_ok_def] \\ rw [] \\ rpt (pairarg_tac \\ fs []) \\ fs [ADD1] \\ res_tac \\ fs [shift_seq_def] - \\ asm_exists_tac \\ fs []); + \\ asm_exists_tac \\ fs [] +QED val code_inv_def = Define ` code_inv g1_opt (s_code:num |-> num # closLang$exp) s_cc s_co t_code t_cc t_co <=> @@ -1839,14 +2011,16 @@ val code_inv_def = Define` ^dummy_code_inv g1_opt s_code s_cc s_co t_code t_cc t_co ⇔ (s_code = FEMPTY)`; -Theorem SUBMAP_FUPDATE_LIST - `!f xs. ALL_DISTINCT (MAP FST xs) ∧ DISJOINT (FDOM f) (set (MAP FST xs)) ⇒ f SUBMAP (f |++ xs)` - (Induct_on`xs` \\ simp[FORALL_PROD] \\ rw[FUPDATE_LIST_THM] +Theorem SUBMAP_FUPDATE_LIST: + !f xs. ALL_DISTINCT (MAP FST xs) ∧ DISJOINT (FDOM f) (set (MAP FST xs)) ⇒ f SUBMAP (f |++ xs) +Proof + Induct_on`xs` \\ simp[FORALL_PROD] \\ rw[FUPDATE_LIST_THM] \\ simp[FUPDATE_FUPDATE_LIST_COMMUTES] \\ match_mp_tac SUBMAP_TRANS \\ res_tac \\ asm_exists_tac \\ fs[] - \\ fs[FDOM_FUPDATE_LIST]); + \\ fs[FDOM_FUPDATE_LIST] +QED val includes_state_def = Define ` includes_state g1 s_compile_oracle <=> @@ -1858,8 +2032,8 @@ val includes_state_def = Define` ^dummy_includes_state g1_s compile_oracle ⇔ T`; (* -Theorem code_rel_state_rel_install - `code_inv (SOME g1) +Theorem code_rel_state_rel_install = Q.prove(` + code_inv (SOME g1) r.code r.compile r.compile_oracle t.code t.compile t.compile_oracle /\ includes_state g1 (shift_seq 1 r.compile_oracle) /\ state_rel g1 l1 r t /\ @@ -1887,8 +2061,8 @@ Theorem code_rel_state_rel_install (t.code |++ aux1) t.compile (shift_seq 1 t.compile_oracle) /\ r.compile_oracle 1 = ((FST g5,other),exp5,aux5) /\ t.code SUBMAP (t.code |++ aux1) /\ - code_includes (SND g5) (t.code |++ aux1)` - (strip_tac \\ fs [code_inv_def] + code_includes (SND g5) (t.code |++ aux1)`, + strip_tac \\ fs [code_inv_def] \\ Cases_on `calls exp' (full_gs 0)` \\ fs [] \\ imp_res_tac calls_sing \\ rveq \\ fs [] \\ PairCases_on `progs` \\ fs [] @@ -1987,56 +2161,70 @@ Theorem code_rel_state_rel_install \\ fs [MEM_toAList,SUBSET_DEF,PULL_EXISTS,ADD1,FLOOKUP_DEF,domain_lookup]) |> GEN_ALL; *) -Theorem fv_GENLIST_Var_alt - `∀n i tra. fv v (GENLIST_Var tra i n) ⇔ v < n` - (Induct \\ rw [] \\ once_rewrite_tac [GENLIST_Var_def] \\ fs [fv1_thm]); +Theorem fv_GENLIST_Var_alt: + ∀n i tra. fv v (GENLIST_Var tra i n) ⇔ v < n +Proof + Induct \\ rw [] \\ once_rewrite_tac [GENLIST_Var_def] \\ fs [fv1_thm] +QED -Theorem env_rel_env_exists - `!vars. EVERY (wfv g1 l1 code) env ==> +Theorem env_rel_env_exists: + !vars. EVERY (wfv g1 l1 code) env ==> ?env5. env_rel (v_rel g1 l1 code) env env5 0 vars /\ - LENGTH env5 = LENGTH env` - (strip_tac \\ Induct_on `env` + LENGTH env5 = LENGTH env +Proof + strip_tac \\ Induct_on `env` THEN1 (fs [env_rel_def] \\ metis_tac []) \\ rw [] \\ res_tac \\ fs [] \\ imp_res_tac v_rel_exists \\ qexists_tac `v2::env5` - \\ fs [env_rel_def]); + \\ fs [env_rel_def] +QED -Theorem evaluate_includes_state - `!xs env s res s1 g1. +Theorem evaluate_includes_state: + !xs env s res s1 g1. includes_state g1 s1.compile_oracle /\ closSem$evaluate (xs,env,s) = (res,s1) ==> - includes_state g1 s.compile_oracle` - (rw [] \\ drule closPropsTheory.evaluate_code \\ rw [] + includes_state g1 s.compile_oracle +Proof + rw [] \\ drule closPropsTheory.evaluate_code \\ rw [] \\ fs [includes_state_def,shift_seq_def] \\ rw [] - \\ qexists_tac `k+n` \\ fs []); + \\ qexists_tac `k+n` \\ fs [] +QED -Theorem evaluate_app_includes_state - `!xs env s res s1 g1. +Theorem evaluate_app_includes_state: + !xs env s res s1 g1. includes_state g1 s1.compile_oracle /\ closSem$evaluate_app loco x vs s = (res,s1) ==> - includes_state g1 s.compile_oracle` - (rw [] \\ drule closPropsTheory.evaluate_app_code \\ rw [] + includes_state g1 s.compile_oracle +Proof + rw [] \\ drule closPropsTheory.evaluate_app_code \\ rw [] \\ fs [includes_state_def,shift_seq_def] \\ rw [] - \\ qexists_tac `k+n` \\ fs []); + \\ qexists_tac `k+n` \\ fs [] +QED -Theorem evaluate_app_mono - `evaluate_app x y z s1 = (vs,s2) ⇒ s1.code ⊑ s2.code` - (strip_tac \\ imp_res_tac evaluate_app_code \\ fs[] - \\ match_mp_tac SUBMAP_FUPDATE_LIST \\ fs[]); +Theorem evaluate_app_mono: + evaluate_app x y z s1 = (vs,s2) ⇒ s1.code ⊑ s2.code +Proof + strip_tac \\ imp_res_tac evaluate_app_code \\ fs[] + \\ match_mp_tac SUBMAP_FUPDATE_LIST \\ fs[] +QED -Theorem calls_pure - `∀xs g es g1. - EVERY pure xs /\ calls xs g = (es,g1) ==> EVERY pure es` - (ho_match_mp_tac calls_ind +Theorem calls_pure: + ∀xs g es g1. + EVERY pure xs /\ calls xs g = (es,g1) ==> EVERY pure es +Proof + ho_match_mp_tac calls_ind \\ rw[calls_def] \\ fs[] \\ rpt(pairarg_tac \\ fs[]) \\ rw[] \\ imp_res_tac calls_sing \\ fs[closLangTheory.pure_def] - \\ fsrw_tac[ETA_ss][bool_case_eq,closLangTheory.pure_def]); + \\ fsrw_tac[ETA_ss][bool_case_eq,closLangTheory.pure_def] +QED -Theorem calls_pure_sing - `pure x1 /\ calls [x1] g = ([e1],g1) ==> pure e1` - (metis_tac[calls_pure,calls_sing,HD,EVERY_DEF]); +Theorem calls_pure_sing: + pure x1 /\ calls [x1] g = ([e1],g1) ==> pure e1 +Proof + metis_tac[calls_pure,calls_sing,HD,EVERY_DEF] +QED (* compiler correctness *) @@ -4023,14 +4211,15 @@ val code_locs_code_list_ALL_DISTINCT = Q.prove(` (* All code_locs come from the original code, and therefore, are all even *) -Theorem calls_code_locs_MEM - `∀xs g0 ys g. calls xs g0 = (ys,g) ⇒ +Theorem calls_code_locs_MEM: + ∀xs g0 ys g. calls xs g0 = (ys,g) ⇒ ∀x. (MEM x (code_locs ys) ∨ MEM x (code_locs (MAP (SND o SND) (SND g)))) ⇒ (MEM x (code_locs xs) ∨ - MEM x (code_locs (MAP (SND o SND) (SND g0))))` - (ho_match_mp_tac calls_ind>>rw[]>> + MEM x (code_locs (MAP (SND o SND) (SND g0)))) +Proof + ho_match_mp_tac calls_ind>>rw[]>> fs[calls_def,code_locs_def]>> rpt(pairarg_tac>>fs[])>> rpt var_eq_tac>>fs[code_locs_def,code_locs_append]>> @@ -4042,14 +4231,16 @@ Theorem calls_code_locs_MEM TRY(metis_tac[])>> fs[code_locs_append,code_locs_code_list_MEM]>> imp_res_tac calls_length>>fs[MAP_ZIP]>> - metis_tac[]); + metis_tac[] +QED (* the all distinctness of code_locs is preserved *) -Theorem calls_code_locs_ALL_DISTINCT - `∀xs g0 ys g. calls xs g0 = (ys,g) ⇒ +Theorem calls_code_locs_ALL_DISTINCT: + ∀xs g0 ys g. calls xs g0 = (ys,g) ⇒ ALL_DISTINCT (code_locs xs ++ code_locs (MAP (SND o SND) (SND g0))) ⇒ - ALL_DISTINCT (code_locs ys ++ code_locs (MAP (SND o SND) (SND g)))` - (ho_match_mp_tac calls_ind>> + ALL_DISTINCT (code_locs ys ++ code_locs (MAP (SND o SND) (SND g))) +Proof + ho_match_mp_tac calls_ind>> rw[calls_def,code_locs_def]>> EVAL_TAC>>fs[]>> rpt(pairarg_tac>>fs[])>> @@ -4063,22 +4254,24 @@ Theorem calls_code_locs_ALL_DISTINCT fs[code_locs_def,code_locs_append,Once code_locs_cons,code_locs_calls_list,ALL_DISTINCT_APPEND,code_locs_code_list_ALL_DISTINCT,code_locs_code_list_MEM]>> imp_res_tac calls_length>>fs[MAP_ZIP]>> rw[]>> - metis_tac[]); + metis_tac[] +QED val extra_code_assum_def = Define ` extra_code_assum prog g0 co = ∀n m. MEM n (code_locs prog) ∧ n ∉ domain g0 ⇒ n ∉ domain (FST (FST (co m)))`; -Theorem semantics_calls - `semantics (ffi:'ffi ffi_state) max_app FEMPTY co cc x <> Fail ==> +Theorem semantics_calls: + semantics (ffi:'ffi ffi_state) max_app FEMPTY co cc x <> Fail ==> compile T x = (y,g0,aux) /\ every_Fn_SOME x ∧ every_Fn_vs_NONE x /\ ALL_DISTINCT (code_locs x) /\ FST (FST (co 0)) = g0 /\ extra_code_assum x g0 co /\ code_inv NONE FEMPTY cc co (FEMPTY |++ aux) cc1 co1 ==> semantics (ffi:'ffi ffi_state) max_app (FEMPTY |++ aux) co1 cc1 y = - semantics (ffi:'ffi ffi_state) max_app FEMPTY co cc x` - (strip_tac + semantics (ffi:'ffi ffi_state) max_app FEMPTY co cc x +Proof + strip_tac \\ ho_match_mp_tac IMP_semantics_eq \\ fs [] \\ fs [eval_sim_def] \\ rw [] \\ fs [compile_def] @@ -4158,10 +4351,11 @@ Theorem semantics_calls \\ match_mp_tac calls_ALL_DISTINCT \\ asm_exists_tac \\ fs []) \\ conj_tac THEN1 (fs [code_inv_def] \\ metis_tac []) - \\ fs [includes_state_def] \\ qexists_tac `0` \\ fs []); + \\ fs [includes_state_def] \\ qexists_tac `0` \\ fs [] +QED -Theorem semantics_compile - `semantics ffi max_app FEMPTY co cc x ≠ Fail ∧ +Theorem semantics_compile: + semantics ffi max_app FEMPTY co cc x ≠ Fail ∧ compile do_call x = (y,g1,aux) ∧ (if do_call then syntax_ok x ∧ FST (FST (co 0)) = g1 ∧ @@ -4171,13 +4365,15 @@ Theorem semantics_compile co1 = state_co (CURRY I) co) ⇒ semantics ffi max_app (FEMPTY |++ aux) co1 cc1 y = - semantics ffi max_app FEMPTY co cc x` - (reverse(Cases_on`do_call`) + semantics ffi max_app FEMPTY co cc x +Proof + reverse(Cases_on`do_call`) \\ rw[compile_def] \\ fs[FUPDATE_LIST_THM] >- ( match_mp_tac semantics_CURRY_I \\ fs[] ) \\ irule semantics_calls - \\ fs[compile_def, syntax_ok_def]); + \\ fs[compile_def, syntax_ok_def] +QED (* lemmas to help proving co_ok *) @@ -4199,33 +4395,38 @@ val nth_code_def = Define ` nth_code (code |++ aux') (shift_seq 1 co) k` (* TODO: move *) -Theorem FUNION_FEMPTY_FUPDATE_LIST - `DISJOINT (FDOM code) (set (MAP FST aux)) ==> - FUNION code (FEMPTY |++ aux) = code |++ aux` - (rw [fmap_EXT] \\ fs [FDOM_FUPDATE_LIST,FUNION_DEF] +Theorem FUNION_FEMPTY_FUPDATE_LIST: + DISJOINT (FDOM code) (set (MAP FST aux)) ==> + FUNION code (FEMPTY |++ aux) = code |++ aux +Proof + rw [fmap_EXT] \\ fs [FDOM_FUPDATE_LIST,FUNION_DEF] \\ fs [IN_DISJOINT] THEN1 (`~MEM x (MAP FST aux)` by metis_tac [] \\ fs [FUPDATE_LIST_APPLY_NOT_MEM]) \\ `~(x ∈ FDOM code)` by metis_tac [] \\ fs [] - \\ match_mp_tac FUPDATE_SAME_LIST_APPLY \\ fs []); + \\ match_mp_tac FUPDATE_SAME_LIST_APPLY \\ fs [] +QED -Theorem ALL_DISTINCT_make_gs - `!i code co2. +Theorem ALL_DISTINCT_make_gs: + !i code co2. IS_SOME (make_gs code co2 i) ==> - ALL_DISTINCT (MAP FST (SND (THE (make_gs code co2 i))))` - (Induct \\ fs [make_gs_def] \\ rw [] THEN1 + ALL_DISTINCT (MAP FST (SND (THE (make_gs code co2 i)))) +Proof + Induct \\ fs [make_gs_def] \\ rw [] THEN1 (Cases_on `make_g (FST (FST (co2 0))) code` \\ fs [] \\ imp_res_tac make_g_wfg \\ fs [wfg_def]) - \\ rpt (pairarg_tac \\ fs [])); + \\ rpt (pairarg_tac \\ fs []) +QED (* -Theorem ALOOKUP_make_gs - `!i v code co2. +Theorem ALOOKUP_make_gs: + !i v code co2. (∀k. IS_SOME (make_gs code co2 k)) /\ ALOOKUP (SND (THE (make_gs code co2 0))) k = SOME v ⇒ - ALOOKUP (SND (THE (make_gs code co2 i))) k = SOME v` - (Induct \\ fs [] \\ fs [make_gs_def] \\ rw [] + ALOOKUP (SND (THE (make_gs code co2 i))) k = SOME v +Proof + Induct \\ fs [] \\ fs [make_gs_def] \\ rw [] \\ rpt (pairarg_tac \\ fs []) \\ first_x_assum match_mp_tac \\ conj_tac THEN1 @@ -4244,19 +4445,22 @@ Theorem ALOOKUP_make_gs \\ fs [MEM_MAP,FLOOKUP_FUNION] \\ qexists_tac `k'` \\ fs [] \\ rveq \\ fs [] - \\ ... (* this proof needs a slightly different approach *)); + \\ ... (* this proof needs a slightly different approach *) +QED *) -Theorem FST_THE_make_gs - `!k code co2. +Theorem FST_THE_make_gs: + !k code co2. IS_SOME (make_gs code co2 k) ==> - FST (THE (make_gs code co2 k)) = FST (FST (co2 k))` - (Induct \\ fs [make_gs_def,make_g_def] \\ rw [] - \\ rpt (pairarg_tac \\ fs []) \\ fs [shift_seq_def,ADD1]); + FST (THE (make_gs code co2 k)) = FST (FST (co2 k)) +Proof + Induct \\ fs [make_gs_def,make_g_def] \\ rw [] + \\ rpt (pairarg_tac \\ fs []) \\ fs [shift_seq_def,ADD1] +QED (* -Theorem IMP_co_ok - `!code co2 k. +Theorem IMP_co_ok: + !code co2 k. (!i. let (cfg,exp,aux) = co2 i in let (g',exp',aux') = compile_inc (FST cfg) (exp,aux) in FST (FST (co2 (i+1))) = g' /\ @@ -4266,8 +4470,9 @@ Theorem IMP_co_ok IMAGE SUC (domain (FST cfg)) ⊆ FDOM (nth_code code co2 i) /\ DISJOINT (FDOM (nth_code code co2 i)) (set (MAP FST aux')) /\ DISJOINT (set (code_locs exp)) (domain (FST cfg))) ==> - co_ok code co2 (THE o make_gs code co2) k` - (Induct_on `k` \\ simp [Once co_ok_def] + co_ok code co2 (THE o make_gs code co2) k +Proof + Induct_on `k` \\ simp [Once co_ok_def] \\ rw [] \\ rpt (pairarg_tac \\ fs []) \\ simp [Once make_gs_def] @@ -4334,42 +4539,50 @@ Theorem IMP_co_ok \\ rpt (pairarg_tac \\ fs []) \\ fs [compile_inc_def] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] - \\ imp_res_tac calls_subspt \\ fs []); + \\ imp_res_tac calls_subspt \\ fs [] +QED *) (* Preservation of some label properties every_Fn_SOME xs ∧ every_Fn_vs_NONE xs *) -Theorem every_Fn_GENLIST_Var - `∀n i t. every_Fn_SOME (GENLIST_Var t i n) ∧ - every_Fn_vs_NONE (GENLIST_Var t i n)` - (Induct \\ rw[] \\ rw[Once GENLIST_Var_def] \\ +Theorem every_Fn_GENLIST_Var: + ∀n i t. every_Fn_SOME (GENLIST_Var t i n) ∧ + every_Fn_vs_NONE (GENLIST_Var t i n) +Proof + Induct \\ rw[] \\ rw[Once GENLIST_Var_def] \\ simp[Once every_Fn_vs_NONE_EVERY,Once every_Fn_SOME_EVERY,EVERY_SNOC] - \\ simp[GSYM every_Fn_vs_NONE_EVERY,GSYM every_Fn_SOME_EVERY]); + \\ simp[GSYM every_Fn_vs_NONE_EVERY,GSYM every_Fn_SOME_EVERY] +QED -Theorem every_Fn_calls_list - `∀ls n i t. every_Fn_SOME (MAP SND (calls_list t i n ls)) ∧ - every_Fn_vs_NONE (MAP SND (calls_list t i n ls))` - (Induct>>fs[calls_list_def,FORALL_PROD]>> +Theorem every_Fn_calls_list: + ∀ls n i t. every_Fn_SOME (MAP SND (calls_list t i n ls)) ∧ + every_Fn_vs_NONE (MAP SND (calls_list t i n ls)) +Proof + Induct>>fs[calls_list_def,FORALL_PROD]>> simp[Once every_Fn_vs_NONE_EVERY,Once every_Fn_SOME_EVERY,EVERY_SNOC,every_Fn_GENLIST_Var] \\ - simp[GSYM every_Fn_vs_NONE_EVERY,GSYM every_Fn_SOME_EVERY]) + simp[GSYM every_Fn_vs_NONE_EVERY,GSYM every_Fn_SOME_EVERY] +QED -Theorem every_Fn_code_list - `∀ls n rest. +Theorem every_Fn_code_list: + ∀ls n rest. (every_Fn_SOME (MAP (SND o SND) (SND (code_list n ls rest))) ⇔ every_Fn_SOME (MAP SND ls) ∧ every_Fn_SOME (MAP (SND o SND) (SND rest))) ∧ (every_Fn_vs_NONE (MAP (SND o SND) (SND (code_list n ls rest))) ⇔ every_Fn_vs_NONE (MAP SND ls) ∧ - every_Fn_vs_NONE (MAP (SND o SND) (SND rest)))` - (Induct>>fs[code_list_def,FORALL_PROD]>> - rw[EQ_IMP_THM]>>fs[Once every_Fn_SOME_EVERY,Once every_Fn_vs_NONE_EVERY]) + every_Fn_vs_NONE (MAP (SND o SND) (SND rest))) +Proof + Induct>>fs[code_list_def,FORALL_PROD]>> + rw[EQ_IMP_THM]>>fs[Once every_Fn_SOME_EVERY,Once every_Fn_vs_NONE_EVERY] +QED -Theorem calls_preserves_every_Fn_SOME - `∀xs g0 ys g. calls xs g0 = (ys,g) ⇒ +Theorem calls_preserves_every_Fn_SOME: + ∀xs g0 ys g. calls xs g0 = (ys,g) ⇒ every_Fn_SOME xs ∧ every_Fn_SOME (MAP (SND o SND) (SND g0)) ⇒ - every_Fn_SOME ys ∧ every_Fn_SOME (MAP (SND o SND) (SND g))` - (ho_match_mp_tac calls_ind>> + every_Fn_SOME ys ∧ every_Fn_SOME (MAP (SND o SND) (SND g)) +Proof + ho_match_mp_tac calls_ind>> (* There is a bad automatic rewrite somewhere *) rpt strip_tac>> fs[calls_def]>> @@ -4380,13 +4593,15 @@ Theorem calls_preserves_every_Fn_SOME simp[Once every_Fn_SOME_EVERY]>> simp[GSYM every_Fn_SOME_EVERY]>> imp_res_tac calls_length>> - fs[MAP_ZIP]); + fs[MAP_ZIP] +QED -Theorem calls_preserves_every_Fn_vs_NONE - `∀xs g0 ys g. calls xs g0 = (ys,g) ⇒ +Theorem calls_preserves_every_Fn_vs_NONE: + ∀xs g0 ys g. calls xs g0 = (ys,g) ⇒ every_Fn_vs_NONE xs ∧ every_Fn_vs_NONE (MAP (SND o SND) (SND g0)) ⇒ - every_Fn_vs_NONE ys ∧ every_Fn_vs_NONE (MAP (SND o SND) (SND g))` - (ho_match_mp_tac calls_ind>> + every_Fn_vs_NONE ys ∧ every_Fn_vs_NONE (MAP (SND o SND) (SND g)) +Proof + ho_match_mp_tac calls_ind>> (* There is a bad automatic rewrite somewhere *) rpt strip_tac>> fs[calls_def]>> @@ -4397,7 +4612,8 @@ Theorem calls_preserves_every_Fn_vs_NONE simp[Once every_Fn_vs_NONE_EVERY]>> simp[GSYM every_Fn_vs_NONE_EVERY]>> imp_res_tac calls_length>> - fs[MAP_ZIP]); + fs[MAP_ZIP] +QED (* val tm = ``closLang$Let [Op (Const 0) []; Op (Const 0) []] @@ -4418,70 +4634,88 @@ val res4 = EVAL``evaluate ([^ctm2],[],<|clock := 2; code := (alist_to_fmap ^ctab val state_syntax_def = Define ` state_syntax f ((g,xs):calls_state) = EVERY (\(x1,x2,x3). f x3) xs`; -Theorem state_syntax_insert_each - `!k1 loc g. - state_syntax f (insert_each loc k1 g) = state_syntax f g` - (Induct \\ Cases_on `g` \\ fs [insert_each_def,state_syntax_def]); +Theorem state_syntax_insert_each: + !k1 loc g. + state_syntax f (insert_each loc k1 g) = state_syntax f g +Proof + Induct \\ Cases_on `g` \\ fs [insert_each_def,state_syntax_def] +QED -Theorem state_syntax_code_list - `!n xs g. +Theorem state_syntax_code_list: + !n xs g. state_syntax f (code_list n xs g) <=> - state_syntax f g /\ EVERY f (MAP SND xs)` - (Induct_on `xs` \\ fs [FORALL_PROD,code_list_def,state_syntax_def] - \\ rw [] \\ eq_tac \\ rw []); + state_syntax f g /\ EVERY f (MAP SND xs) +Proof + Induct_on `xs` \\ fs [FORALL_PROD,code_list_def,state_syntax_def] + \\ rw [] \\ eq_tac \\ rw [] +QED -Theorem obeys_max_app_GENLIST_Var - `!n l w. EVERY (obeys_max_app k) (GENLIST_Var n l w)` - (Induct_on `w` \\ once_rewrite_tac [GENLIST_Var_def] \\ rw []); +Theorem obeys_max_app_GENLIST_Var: + !n l w. EVERY (obeys_max_app k) (GENLIST_Var n l w) +Proof + Induct_on `w` \\ once_rewrite_tac [GENLIST_Var_def] \\ rw [] +QED -Theorem obeys_max_app_calls_list - `!t k1 loc fns. EVERY (obeys_max_app k) (MAP SND (calls_list t k1 loc fns))` - (Induct_on `fns` \\ fs [FORALL_PROD,calls_list_def,obeys_max_app_GENLIST_Var]); +Theorem obeys_max_app_calls_list: + !t k1 loc fns. EVERY (obeys_max_app k) (MAP SND (calls_list t k1 loc fns)) +Proof + Induct_on `fns` \\ fs [FORALL_PROD,calls_list_def,obeys_max_app_GENLIST_Var] +QED -Theorem calls_obeys_max_app - `!xs g ys g1. +Theorem calls_obeys_max_app: + !xs g ys g1. calls xs g = (ys,g1) /\ state_syntax (obeys_max_app k) g /\ EVERY (obeys_max_app k) xs ==> - EVERY (obeys_max_app k) ys /\ state_syntax (obeys_max_app k) g1` - (ho_match_mp_tac calls_ind \\ rpt strip_tac \\ fs [calls_def] \\ rveq \\ fs [] + EVERY (obeys_max_app k) ys /\ state_syntax (obeys_max_app k) g1 +Proof + ho_match_mp_tac calls_ind \\ rpt strip_tac \\ fs [calls_def] \\ rveq \\ fs [] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] \\ imp_res_tac calls_sing \\ rveq \\ fs [] \\ imp_res_tac calls_length \\ fs [] \\ fs [bool_case_eq] \\ rveq \\ fs [obeys_max_app_GENLIST_Var] \\ fs [state_syntax_def,state_syntax_insert_each] \\ fs [state_syntax_code_list,MAP_ZIP,obeys_max_app_calls_list] - \\ rename [`SND g5`] \\ PairCases_on `g5` \\ fs [state_syntax_def]); + \\ rename [`SND g5`] \\ PairCases_on `g5` \\ fs [state_syntax_def] +QED -Theorem no_Labels_GENLIST_Var - `!n l w. EVERY no_Labels (GENLIST_Var n l w)` - (Induct_on `w` \\ once_rewrite_tac [GENLIST_Var_def] \\ rw []); +Theorem no_Labels_GENLIST_Var: + !n l w. EVERY no_Labels (GENLIST_Var n l w) +Proof + Induct_on `w` \\ once_rewrite_tac [GENLIST_Var_def] \\ rw [] +QED -Theorem no_Labels_calls_list - `!t k1 loc fns. EVERY no_Labels (MAP SND (calls_list t k1 loc fns))` - (Induct_on `fns` \\ fs [FORALL_PROD,calls_list_def,no_Labels_GENLIST_Var]); +Theorem no_Labels_calls_list: + !t k1 loc fns. EVERY no_Labels (MAP SND (calls_list t k1 loc fns)) +Proof + Induct_on `fns` \\ fs [FORALL_PROD,calls_list_def,no_Labels_GENLIST_Var] +QED -Theorem calls_no_Labels - `!xs g ys g1. +Theorem calls_no_Labels: + !xs g ys g1. calls xs g = (ys,g1) /\ state_syntax no_Labels g /\ EVERY no_Labels xs ==> - EVERY no_Labels ys /\ state_syntax no_Labels g1` - (ho_match_mp_tac calls_ind \\ rpt strip_tac \\ fs [calls_def] \\ rveq \\ fs [] + EVERY no_Labels ys /\ state_syntax no_Labels g1 +Proof + ho_match_mp_tac calls_ind \\ rpt strip_tac \\ fs [calls_def] \\ rveq \\ fs [] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] \\ imp_res_tac calls_sing \\ rveq \\ fs [] \\ imp_res_tac calls_length \\ fs [] \\ fs [bool_case_eq] \\ rveq \\ fs [no_Labels_GENLIST_Var] \\ fs [state_syntax_def,state_syntax_insert_each] \\ fs [state_syntax_code_list,MAP_ZIP,no_Labels_calls_list] - \\ rename [`SND g5`] \\ PairCases_on `g5` \\ fs [state_syntax_def]); + \\ rename [`SND g5`] \\ PairCases_on `g5` \\ fs [state_syntax_def] +QED (* names *) (* -Theorem app_call_dests_GENLIST_Var - `!t i num_args. app_call_dests opt (GENLIST_Var t i num_args) = {}` - (Induct_on `num_args` +Theorem app_call_dests_GENLIST_Var: + !t i num_args. app_call_dests opt (GENLIST_Var t i num_args) = {} +Proof + Induct_on `num_args` \\ once_rewrite_tac [clos_callTheory.GENLIST_Var_def] - \\ fs [app_call_dests_append]); + \\ fs [app_call_dests_append] +QED val pure_code_locs = Q.store_thm("pure_code_locs", (* DUPLCATED! clos_annotate *) `!xs. pure xs ==> code_locs [xs] = [] /\ @@ -4494,27 +4728,31 @@ val pure_code_locs = Q.store_thm("pure_code_locs", (* DUPLCATED! clos_annotate * \\ simp[FLAT_EQ_NIL, EVERY_MAP, EVERY_MEM] \\ ...); -Theorem call_dests_code_list_SUBSET - `!xs n g. +Theorem call_dests_code_list_SUBSET: + !xs n g. call_dests (MAP SND xs) ⊆ set (MAP FST (SND g)) /\ call_dests (MAP (λx. SND (SND x)) (SND g)) ⊆ set (MAP FST (SND g)) ==> call_dests (MAP (λx. SND (SND x)) (SND (code_list n xs g))) ⊆ - set (MAP FST (SND (code_list n xs g)))` - (Induct \\ fs [FORALL_PROD] THEN1 (EVAL_TAC \\ fs []) + set (MAP FST (SND (code_list n xs g))) +Proof + Induct \\ fs [FORALL_PROD] THEN1 (EVAL_TAC \\ fs []) \\ fs [code_list_def] \\ rw [] \\ first_x_assum match_mp_tac \\ fs [] \\ rpt (pop_assum mp_tac) \\ once_rewrite_tac [app_call_dests_cons] \\ fs [] - \\ fs [SUBSET_DEF]); + \\ fs [SUBSET_DEF] +QED -Theorem code_locs_MAP_SND_calls_list - `!t x y fns. code_locs (MAP SND (calls_list t x y fns)) = []` - (Induct_on `fns` \\ fs [calls_list_def,FORALL_PROD] +Theorem code_locs_MAP_SND_calls_list: + !t x y fns. code_locs (MAP SND (calls_list t x y fns)) = [] +Proof + Induct_on `fns` \\ fs [calls_list_def,FORALL_PROD] \\ once_rewrite_tac [code_locs_cons] - \\ fs [code_locs_def]); + \\ fs [code_locs_def] +QED -Theorem calls_locs - `!known_code g call_code g1. +Theorem calls_locs: + !known_code g call_code g1. calls known_code g = (call_code,g1) /\ call_dests known_code = ∅ /\ call_dests (MAP (SND ∘ SND) (SND g)) ⊆ set (MAP FST (SND g)) ==> @@ -4526,9 +4764,10 @@ Theorem calls_locs app_dests call_code UNION app_dests (MAP (SND ∘ SND) (SND g1)) ⊆ app_dests known_code UNION app_dests (MAP (SND ∘ SND) (SND g)) ∧ set (code_locs call_code) ∪ set (code_locs (MAP (SND ∘ SND) (SND g1))) = - set (code_locs known_code) ∪ set (code_locs (MAP (SND ∘ SND) (SND g)))` - - (...); + set (code_locs known_code) ∪ set (code_locs (MAP (SND ∘ SND) (SND g))) +Proof + ... +QED (* @@ -4594,20 +4833,22 @@ Theorem calls_locs *) -Theorem call_compile_locs - `clos_call$compile b known_code = (call_code,g,aux) /\ +Theorem call_compile_locs: + clos_call$compile b known_code = (call_code,g,aux) /\ call_dests known_code = ∅ ==> call_dests call_code ∪ call_dests (MAP (SND ∘ SND) aux) ⊆ set (MAP FST aux) /\ app_dests call_code ∪ app_dests (MAP (SND ∘ SND) aux) ⊆ app_dests known_code /\ set (code_locs call_code) ∪ set (code_locs (MAP (SND ∘ SND) aux)) = - set (code_locs known_code)` - (reverse (Cases_on `b`) \\ fs [clos_callTheory.compile_def] + set (code_locs known_code) +Proof + reverse (Cases_on `b`) \\ fs [clos_callTheory.compile_def] THEN1 (strip_tac \\ rveq \\ fs [closPropsTheory.code_locs_def]) \\ pairarg_tac \\ fs [] \\ strip_tac \\ rveq \\ fs [] - \\ drule calls_locs \\ fs [EVAL ``(code_locs [])``]); + \\ drule calls_locs \\ fs [EVAL ``(code_locs [])``] +QED *) val _ = export_theory(); diff --git a/compiler/backend/proofs/clos_fvsProofScript.sml b/compiler/backend/proofs/clos_fvsProofScript.sml index 922205f904..ad7499aac6 100644 --- a/compiler/backend/proofs/clos_fvsProofScript.sml +++ b/compiler/backend/proofs/clos_fvsProofScript.sml @@ -5,34 +5,46 @@ open preamble closLangTheory clos_fvsTheory closSemTheory closPropsTheory; val _ = new_theory "clos_fvsProof"; -Theorem LENGTH_remove_fvs - `!fvs xs. LENGTH (remove_fvs fvs xs) = LENGTH xs` - (recInduct remove_fvs_ind \\ simp [remove_fvs_def] \\ rw [] ); - -Theorem remove_fvs_SING - `!x. ?y. remove_fvs fvs [x] = [y]` - (Induct \\ fs [remove_fvs_def] \\ rw[]); - -Theorem HD_remove_fvs_SING[simp] - `!x. [HD (remove_fvs fvs [x])] = remove_fvs fvs [x]` - (strip_tac \\ strip_assume_tac (Q.SPEC `x` remove_fvs_SING) \\ simp []); - -Theorem EVERY_remove_fvs_SING - `EVERY P (remove_fvs fvs [x]) ⇔ P (HD (remove_fvs fvs [x]))` - (strip_assume_tac(SPEC_ALL remove_fvs_SING) \\ rw[]); +Theorem LENGTH_remove_fvs: + !fvs xs. LENGTH (remove_fvs fvs xs) = LENGTH xs +Proof + recInduct remove_fvs_ind \\ simp [remove_fvs_def] \\ rw [] +QED + +Theorem remove_fvs_SING: + !x. ?y. remove_fvs fvs [x] = [y] +Proof + Induct \\ fs [remove_fvs_def] \\ rw[] +QED + +Theorem HD_remove_fvs_SING[simp]: + !x. [HD (remove_fvs fvs [x])] = remove_fvs fvs [x] +Proof + strip_tac \\ strip_assume_tac (Q.SPEC `x` remove_fvs_SING) \\ simp [] +QED + +Theorem EVERY_remove_fvs_SING: + EVERY P (remove_fvs fvs [x]) ⇔ P (HD (remove_fvs fvs [x])) +Proof + strip_assume_tac(SPEC_ALL remove_fvs_SING) \\ rw[] +QED val code_rel_def = Define ` code_rel fvs e1 e2 <=> e2 = remove_fvs fvs e1`; -Theorem code_rel_IMP_LENGTH - `!xs ys. code_rel fvs xs ys ==> LENGTH xs = LENGTH ys` - (fs [code_rel_def, LENGTH_remove_fvs]); +Theorem code_rel_IMP_LENGTH: + !xs ys. code_rel fvs xs ys ==> LENGTH xs = LENGTH ys +Proof + fs [code_rel_def, LENGTH_remove_fvs] +QED -Theorem code_rel_CONS_CONS - `code_rel fvs (x1::x2::xs) (y1::y2::ys) ==> - code_rel fvs [x1] [y1] /\ code_rel fvs (x2::xs) (y2::ys)` - (simp [code_rel_def, remove_fvs_def]); +Theorem code_rel_CONS_CONS: + code_rel fvs (x1::x2::xs) (y1::y2::ys) ==> + code_rel fvs [x1] [y1] /\ code_rel fvs (x2::xs) (y2::ys) +Proof + simp [code_rel_def, remove_fvs_def] +QED (* value relation *) @@ -134,41 +146,48 @@ val v_rel_IMP_v_to_words = prove( (* *) -Theorem lookup_vars_lemma - `!vs env1 env2. LIST_REL v_rel env1 env2 ==> +Theorem lookup_vars_lemma: + !vs env1 env2. LIST_REL v_rel env1 env2 ==> case lookup_vars vs env1 of | NONE => lookup_vars vs env2 = NONE - | SOME l1 => ?l2. LIST_REL v_rel l1 l2 /\ lookup_vars vs env2 = SOME l2` - (Induct_on `vs` \\ fs [lookup_vars_def] + | SOME l1 => ?l2. LIST_REL v_rel l1 l2 /\ lookup_vars vs env2 = SOME l2 +Proof + Induct_on `vs` \\ fs [lookup_vars_def] \\ rpt strip_tac \\ imp_res_tac LIST_REL_LENGTH \\ rw [] \\ res_tac \\ Cases_on `lookup_vars vs env1` \\ fs [] - \\ fs [LIST_REL_EL_EQN]); + \\ fs [LIST_REL_EL_EQN] +QED -Theorem find_code_lemma - `!s t p args. state_rel s t ==> +Theorem find_code_lemma: + !s t p args. state_rel s t ==> find_code p args s.code = NONE /\ - find_code p args t.code = NONE` - (fs [state_rel_def, find_code_def]); + find_code p args t.code = NONE +Proof + fs [state_rel_def, find_code_def] +QED -Theorem dest_closure_SOME_IMP - `dest_closure max_app loc_opt f2 xs = SOME x ==> +Theorem dest_closure_SOME_IMP: + dest_closure max_app loc_opt f2 xs = SOME x ==> (?loc arg_env clo_env num_args e. f2 = Closure loc arg_env clo_env num_args e) \/ - (?loc arg_env clo_env fns i. f2 = Recclosure loc arg_env clo_env fns i)` - (fs [dest_closure_def,case_eq_thms] \\ rw [] \\ fs []); + (?loc arg_env clo_env fns i. f2 = Recclosure loc arg_env clo_env fns i) +Proof + fs [dest_closure_def,case_eq_thms] \\ rw [] \\ fs [] +QED -Theorem dest_closure_SOME_Full_app - `v_rel f1 f2 /\ v_rel a1 a2 /\ LIST_REL v_rel args1 args2 /\ +Theorem dest_closure_SOME_Full_app: + v_rel f1 f2 /\ v_rel a1 a2 /\ LIST_REL v_rel args1 args2 /\ dest_closure max_app loc_opt f1 (a1::args1) = SOME (Full_app exp1 env1 rest_args1) ==> ?exp2 env2 rest_args2. code_rel (LENGTH env1) [exp1] [exp2] /\ LIST_REL v_rel env1 env2 /\ LIST_REL v_rel rest_args1 rest_args2 /\ - dest_closure max_app loc_opt f2 (a2::args2) = SOME (Full_app exp2 env2 rest_args2)` - (rpt strip_tac + dest_closure max_app loc_opt f2 (a2::args2) = SOME (Full_app exp2 env2 rest_args2) +Proof + rpt strip_tac \\ imp_res_tac dest_closure_SOME_IMP \\ rveq \\ fs [] \\ rveq \\ imp_res_tac LIST_REL_LENGTH @@ -201,7 +220,8 @@ Theorem dest_closure_SOME_Full_app \\ irule EVERY2_TAKE \\ irule EVERY2_APPEND_suff \\ simp []) \\ irule EVERY2_DROP - \\ irule EVERY2_APPEND_suff \\ simp []); + \\ irule EVERY2_APPEND_suff \\ simp [] +QED val do_app_lemma = prove( ``state_rel s t /\ LIST_REL v_rel xs ys ==> @@ -220,8 +240,8 @@ val do_app_lemma = prove( (* evaluate level correctness *) -Theorem evaluate_remove_fvs - `(!xs env1 (s1:('c,'ffi) closSem$state) res1 s2 ys env2 t1. +Theorem evaluate_remove_fvs: + (!xs env1 (s1:('c,'ffi) closSem$state) res1 s2 ys env2 t1. evaluate (xs, env1, s1) = (res1, s2) /\ LIST_REL v_rel env1 env2 /\ state_rel s1 t1 /\ code_rel (LENGTH env1) xs ys ==> @@ -236,8 +256,9 @@ Theorem evaluate_remove_fvs ?res2 t2. evaluate_app loc_opt f2 args2 t1 = (res2, t2) /\ result_rel (LIST_REL v_rel) v_rel res1 res2 /\ - state_rel s2 t2)` - (ho_match_mp_tac (evaluate_ind |> Q.SPEC `\(x1,x2,x3). P0 x1 x2 x3` + state_rel s2 t2) +Proof + ho_match_mp_tac (evaluate_ind |> Q.SPEC `\(x1,x2,x3). P0 x1 x2 x3` |> Q.GEN `P0` |> SIMP_RULE std_ss [FORALL_PROD]) \\ conj_tac >- ( @@ -476,29 +497,33 @@ Theorem evaluate_remove_fvs \\ unabbrev_all_tac \\ simp [] \\ impl_tac THEN1 fs [dec_clock_def, state_rel_def] \\ strip_tac \\ fs [] - \\ fs [case_eq_thms] \\ rveq \\ fs []) + \\ fs [case_eq_thms] \\ rveq \\ fs [] +QED -Theorem remove_fvs_correct - `!xs env1 (s1:('c,'ffi) closSem$state) res1 s2 env2 t1. +Theorem remove_fvs_correct: + !xs env1 (s1:('c,'ffi) closSem$state) res1 s2 env2 t1. evaluate (xs, env1, s1) = (res1, s2) /\ LIST_REL v_rel env1 env2 /\ state_rel s1 t1 ==> ?res2 t2. evaluate (remove_fvs (LENGTH env1) xs, env2, t1) = (res2, t2) /\ result_rel (LIST_REL v_rel) v_rel res1 res2 /\ - state_rel s2 t2` - (rpt strip_tac \\ drule (CONJUNCT1 evaluate_remove_fvs) \\ simp [code_rel_def]) + state_rel s2 t2 +Proof + rpt strip_tac \\ drule (CONJUNCT1 evaluate_remove_fvs) \\ simp [code_rel_def] +QED (* preservation of observational semantics *) -Theorem semantics_compile - `semantics (ffi:'ffi ffi_state) max_app FEMPTY +Theorem semantics_compile: + semantics (ffi:'ffi ffi_state) max_app FEMPTY co (pure_cc compile_inc cc) xs <> Fail ==> (!n. SND (SND (co n)) = []) /\ 1 <= max_app ==> semantics (ffi:'ffi ffi_state) max_app FEMPTY (pure_co compile_inc o co) cc (clos_fvs$compile xs) = semantics (ffi:'ffi ffi_state) max_app FEMPTY - co (pure_cc compile_inc cc) xs` - (strip_tac + co (pure_cc compile_inc cc) xs +Proof + strip_tac \\ ho_match_mp_tac IMP_semantics_eq \\ fs [] \\ fs [eval_sim_def] \\ rw [] \\ drule remove_fvs_correct @@ -512,13 +537,15 @@ Theorem semantics_compile \\ qexists_tac `0` \\ simp [] \\ fs [state_rel_def] \\ Cases_on `res1` \\ fs [] - \\ Cases_on `e` \\ fs []) + \\ Cases_on `e` \\ fs [] +QED (* syntactic properties *) -Theorem code_locs_remove_fvs[simp] - `!fvs xs. code_locs (remove_fvs fvs xs) = code_locs xs` - (ho_match_mp_tac remove_fvs_ind \\ rw [] +Theorem code_locs_remove_fvs[simp]: + !fvs xs. code_locs (remove_fvs fvs xs) = code_locs xs +Proof + ho_match_mp_tac remove_fvs_ind \\ rw [] \\ fs [code_locs_def,remove_fvs_def] THEN1 (`?y. remove_fvs fvs [x] = [y]` by metis_tac [remove_fvs_SING] @@ -526,13 +553,15 @@ Theorem code_locs_remove_fvs[simp] THEN1 (every_case_tac \\ fs [code_locs_def] ) \\ fs[code_locs_map] \\ AP_TERM_TAC - \\ simp[MAP_MAP_o, MAP_EQ_f, FORALL_PROD]); + \\ simp[MAP_MAP_o, MAP_EQ_f, FORALL_PROD] +QED -Theorem fv_max_remove_fvs - `∀fvs xs. +Theorem fv_max_remove_fvs: + ∀fvs xs. every_Fn_vs_NONE xs ⇒ - (∀v. fv v (remove_fvs fvs xs) ⇒ v < fvs)` - (recInduct remove_fvs_ind + (∀v. fv v (remove_fvs fvs xs) ⇒ v < fvs) +Proof + recInduct remove_fvs_ind \\ rw[remove_fvs_def] \\ fs[fv1_thm] \\ full_simp_tac std_ss [fv1_def, HD_remove_fvs_SING] \\ fs[LENGTH_remove_fvs] @@ -548,11 +577,13 @@ Theorem fv_max_remove_fvs \\ fs[EVERY_MAP, LAMBDA_PROD] \\ fs[EVERY_MEM, FORALL_PROD] \\ res_tac ) - \\ rw[]); + \\ rw[] +QED -Theorem remove_fvs_every_Fn_SOME[simp] - `∀fvs es. every_Fn_SOME (remove_fvs fvs es) ⇔ every_Fn_SOME es` - (recInduct remove_fvs_ind +Theorem remove_fvs_every_Fn_SOME[simp]: + ∀fvs es. every_Fn_SOME (remove_fvs fvs es) ⇔ every_Fn_SOME es +Proof + recInduct remove_fvs_ind \\ rw[remove_fvs_def] >- ( fs[Once every_Fn_SOME_EVERY] @@ -565,11 +596,13 @@ Theorem remove_fvs_every_Fn_SOME[simp] \\ fs[EVERY_MEM,UNCURRY,MEM_MAP,PULL_EXISTS,FORALL_PROD] \\ simp[Once every_Fn_SOME_EVERY, SimpRHS] \\ simp[EVERY_MEM,MEM_MAP,PULL_EXISTS,FORALL_PROD] - \\ metis_tac[])); + \\ metis_tac[]) +QED -Theorem remove_fvs_every_Fn_vs_NONE[simp] - `∀fvs es. every_Fn_vs_NONE (remove_fvs fvs es) ⇔ every_Fn_vs_NONE es` - (recInduct remove_fvs_ind +Theorem remove_fvs_every_Fn_vs_NONE[simp]: + ∀fvs es. every_Fn_vs_NONE (remove_fvs fvs es) ⇔ every_Fn_vs_NONE es +Proof + recInduct remove_fvs_ind \\ rw[remove_fvs_def] >- ( fs[Once every_Fn_vs_NONE_EVERY] @@ -582,27 +615,33 @@ Theorem remove_fvs_every_Fn_vs_NONE[simp] \\ fs[EVERY_MEM,UNCURRY,MEM_MAP,PULL_EXISTS,FORALL_PROD] \\ simp[Once every_Fn_vs_NONE_EVERY, SimpRHS] \\ simp[EVERY_MEM,MEM_MAP,PULL_EXISTS,FORALL_PROD] - \\ metis_tac[])); + \\ metis_tac[]) +QED -Theorem remove_fvs_set_globals[simp] - `∀fvs x. MAP set_globals (remove_fvs fvs x) = MAP set_globals x` - (recInduct remove_fvs_ind +Theorem remove_fvs_set_globals[simp]: + ∀fvs x. MAP set_globals (remove_fvs fvs x) = MAP set_globals x +Proof + recInduct remove_fvs_ind \\ rw[remove_fvs_def] \\ fs[] \\ simp[elist_globals_FOLDR] >- EVAL_TAC \\ AP_TERM_TAC \\ simp[MAP_MAP_o, MAP_EQ_f, FORALL_PROD] - \\ rw[] \\ res_tac \\ fs[]); + \\ rw[] \\ res_tac \\ fs[] +QED -Theorem set_globals_HD_remove_fvs_SING[simp] - `set_globals (HD (remove_fvs fvs [x])) = set_globals x` - (strip_assume_tac(SPEC_ALL remove_fvs_SING) +Theorem set_globals_HD_remove_fvs_SING[simp]: + set_globals (HD (remove_fvs fvs [x])) = set_globals x +Proof + strip_assume_tac(SPEC_ALL remove_fvs_SING) \\ first_assum(mp_tac o Q.AP_TERM`MAP set_globals`) - \\ rw[]); + \\ rw[] +QED -Theorem remove_fvs_esgc_free[simp] - `∀fvs x. EVERY (esgc_free) (remove_fvs fvs x) ⇔ EVERY esgc_free x` - (recInduct remove_fvs_ind +Theorem remove_fvs_esgc_free[simp]: + ∀fvs x. EVERY (esgc_free) (remove_fvs fvs x) ⇔ EVERY esgc_free x +Proof + recInduct remove_fvs_ind \\ rw[remove_fvs_def, EVERY_remove_fvs_SING] \\ simp[elist_globals_FOLDR] \\ AP_THM_TAC @@ -610,33 +649,43 @@ Theorem remove_fvs_esgc_free[simp] \\ AP_THM_TAC \\ AP_TERM_TAC \\ AP_TERM_TAC - \\ simp[MAP_MAP_o, o_DEF, UNCURRY]); - -Theorem remove_fvs_elist_globals[simp] - `elist_globals (remove_fvs fvs xs) = elist_globals xs` - (rw[elist_globals_FOLDR]); - -Theorem EVERY_remove_fvs_sing - `EVERY f (remove_fvs n [y]) <=> f (HD (remove_fvs n [y]))` - (`?t. remove_fvs n [y] = [t]` by metis_tac [remove_fvs_SING] \\ fs []); - -Theorem remove_fvs_no_Labels - `!n xs. EVERY no_Labels (remove_fvs n xs) = EVERY no_Labels xs` - (ho_match_mp_tac remove_fvs_ind \\ rw [remove_fvs_def] + \\ simp[MAP_MAP_o, o_DEF, UNCURRY] +QED + +Theorem remove_fvs_elist_globals[simp]: + elist_globals (remove_fvs fvs xs) = elist_globals xs +Proof + rw[elist_globals_FOLDR] +QED + +Theorem EVERY_remove_fvs_sing: + EVERY f (remove_fvs n [y]) <=> f (HD (remove_fvs n [y])) +Proof + `?t. remove_fvs n [y] = [t]` by metis_tac [remove_fvs_SING] \\ fs [] +QED + +Theorem remove_fvs_no_Labels: + !n xs. EVERY no_Labels (remove_fvs n xs) = EVERY no_Labels xs +Proof + ho_match_mp_tac remove_fvs_ind \\ rw [remove_fvs_def] \\ fs [EVERY_remove_fvs_sing] \\ fs [EVERY_MEM,MEM_MAP,FORALL_PROD,PULL_EXISTS] - \\ rw [] \\ eq_tac \\ rw [] \\ res_tac); + \\ rw [] \\ eq_tac \\ rw [] \\ res_tac +QED -Theorem remove_fvs_obeys_max_app - `!n xs. EVERY (obeys_max_app k) (remove_fvs n xs) = EVERY (obeys_max_app k) xs` - (ho_match_mp_tac remove_fvs_ind \\ rw [remove_fvs_def] +Theorem remove_fvs_obeys_max_app: + !n xs. EVERY (obeys_max_app k) (remove_fvs n xs) = EVERY (obeys_max_app k) xs +Proof + ho_match_mp_tac remove_fvs_ind \\ rw [remove_fvs_def] \\ fs [EVERY_remove_fvs_sing] \\ fs [EVERY_MEM,MEM_MAP,FORALL_PROD,PULL_EXISTS,LENGTH_remove_fvs] - \\ rw [] \\ eq_tac \\ rw [] \\ res_tac); + \\ rw [] \\ eq_tac \\ rw [] \\ res_tac +QED -Theorem get_code_labels_remove_fvs[simp] - `∀n es. MAP get_code_labels (remove_fvs n es) = MAP get_code_labels es` - (recInduct clos_fvsTheory.remove_fvs_ind +Theorem get_code_labels_remove_fvs[simp]: + ∀n es. MAP get_code_labels (remove_fvs n es) = MAP get_code_labels es +Proof + recInduct clos_fvsTheory.remove_fvs_ind \\ rw[clos_fvsTheory.remove_fvs_def] \\ fs[closLangTheory.assign_get_code_label_def] \\ AP_TERM_TAC \\ AP_TERM_TAC @@ -644,6 +693,7 @@ Theorem get_code_labels_remove_fvs[simp] \\ simp[MAP_MAP_o, MAP_EQ_f, FORALL_PROD] \\ rw[] \\ first_x_assum drule - \\ rw[] \\ fs[]); + \\ rw[] \\ fs[] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/clos_knownProofScript.sml b/compiler/backend/proofs/clos_knownProofScript.sml index 71a3bcb59b..5727fd0a0c 100644 --- a/compiler/backend/proofs/clos_knownProofScript.sml +++ b/compiler/backend/proofs/clos_knownProofScript.sml @@ -47,23 +47,26 @@ val result_case_eq = (* simple properties of constants from clos_known: i.e., merge and known *) -Theorem known_op_changed_globals - `!opn aenv g0 a g. +Theorem known_op_changed_globals: + !opn aenv g0 a g. known_op opn aenv g0 = (a, g) ==> !i. i ∈ domain g /\ (i ∈ domain g0 ==> lookup i g <> lookup i g0) ==> - i ∈ SET_OF_BAG (op_gbag opn)` - (rpt gen_tac \\ Cases_on `opn` + i ∈ SET_OF_BAG (op_gbag opn) +Proof + rpt gen_tac \\ Cases_on `opn` \\ simp [known_op_def, case_eq_thms, op_gbag_def, pair_case_eq, bool_case_eq, va_case_eq] \\ rw [] - \\ fs [lookup_insert, bool_case_eq]) + \\ fs [lookup_insert, bool_case_eq] +QED -Theorem known_changed_globals - `!c xs aenv g0 alist g. +Theorem known_changed_globals: + !c xs aenv g0 alist g. known c xs aenv g0 = (alist, g) ==> !i. i ∈ domain g ∧ (i ∈ domain g0 ==> lookup i g <> lookup i g0) ==> - i ∈ SET_OF_BAG (elist_globals xs)` - (ho_match_mp_tac known_ind \\ simp [known_def] \\ rpt strip_tac + i ∈ SET_OF_BAG (elist_globals xs) +Proof + ho_match_mp_tac known_ind \\ simp [known_def] \\ rpt strip_tac \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] THEN1 metis_tac [] THEN1 metis_tac [] @@ -78,13 +81,15 @@ Theorem known_changed_globals \\ fs [inlD_case_eq] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [bool_case_eq] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem known_unchanged_globals - `!c xs aenv g0 eas1 g1. +Theorem known_unchanged_globals: + !c xs aenv g0 eas1 g1. known c xs aenv g0 = (eas1, g1) /\ - elist_globals xs = {||} ==> g0 = g1` - (ho_match_mp_tac known_ind + elist_globals xs = {||} ==> g0 = g1 +Proof + ho_match_mp_tac known_ind \\ simp [known_def] \\ rpt strip_tac \\ rpt (pairarg_tac \\ fs []) \\ rveq @@ -93,35 +98,41 @@ Theorem known_unchanged_globals case_eq_thms, va_case_eq, op_gbag_def]) THEN1 (fs [inlD_case_eq] \\ rpt (pairarg_tac \\ fs []) - \\ fs [bool_case_eq])); + \\ fs [bool_case_eq]) +QED -Theorem known_op_changed_globals_alt - `!opn aenv g0 a g. +Theorem known_op_changed_globals_alt: + !opn aenv g0 a g. known_op opn aenv g0 = (a, g) ==> - BAG_OF_SET (domain g) ≤ BAG_OF_SET (domain g0) ⊎ (op_gbag opn)` - (rpt gen_tac \\ Cases_on `opn` + BAG_OF_SET (domain g) ≤ BAG_OF_SET (domain g0) ⊎ (op_gbag opn) +Proof + rpt gen_tac \\ Cases_on `opn` \\ simp [known_op_def, case_eq_thms, op_gbag_def, pair_case_eq, bool_case_eq, va_case_eq] \\ rw [] \\ fs [lookup_insert, bool_case_eq] \\ fs [BAG_OF_SET, SUB_BAG, BAG_INN, BAG_UNION, GREATER_EQ, BAG_INSERT] - \\ rw []) + \\ rw [] +QED -Theorem known_op_changed_globals_alt_set - `!opn aenv g0 a g. +Theorem known_op_changed_globals_alt_set: + !opn aenv g0 a g. known_op opn aenv g0 = (a, g) ==> - domain g ⊆ domain g0 ∪ SET_OF_BAG (op_gbag opn)` - (rw [] + domain g ⊆ domain g0 ∪ SET_OF_BAG (op_gbag opn) +Proof + rw [] \\ imp_res_tac known_op_changed_globals_alt \\ imp_res_tac SUB_BAG_SET - \\ fs [SET_OF_BAG_UNION]) + \\ fs [SET_OF_BAG_UNION] +QED -Theorem known_changed_globals_alt - `!c xs aenv g0 alist g. +Theorem known_changed_globals_alt: + !c xs aenv g0 alist g. known c xs aenv g0 = (alist, g) ==> - BAG_OF_SET (domain g) ≤ BAG_OF_SET (domain g0) ⊎ (elist_globals xs)` - (ho_match_mp_tac known_ind \\ simp [known_def] \\ rpt strip_tac + BAG_OF_SET (domain g) ≤ BAG_OF_SET (domain g0) ⊎ (elist_globals xs) +Proof + ho_match_mp_tac known_ind \\ simp [known_def] \\ rpt strip_tac \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] \\ fsrw_tac [bagLib.SBAG_SOLVE_ss] [] THEN1 @@ -130,33 +141,40 @@ Theorem known_changed_globals_alt \\ fs [inlD_case_eq] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] \\ fs [bool_case_eq] - \\ fsrw_tac [bagLib.SBAG_SOLVE_ss] []); + \\ fsrw_tac [bagLib.SBAG_SOLVE_ss] [] +QED -Theorem known_changed_globals_alt_set - `!c xs aenv g0 alist g. +Theorem known_changed_globals_alt_set: + !c xs aenv g0 alist g. known c xs aenv g0 = (alist, g) ==> - domain g ⊆ domain g0 ∪ SET_OF_BAG (elist_globals xs)` - (rw [] + domain g ⊆ domain g0 ∪ SET_OF_BAG (elist_globals xs) +Proof + rw [] \\ imp_res_tac known_changed_globals_alt \\ imp_res_tac SUB_BAG_SET - \\ fs [SET_OF_BAG_UNION]); + \\ fs [SET_OF_BAG_UNION] +QED (* Take the first n expression lists returned by the compile oracle. *) val first_n_exps_def = Define ` first_n_exps co n = GENLIST (FST o SND o co) n`; -Theorem first_n_exps_shift_seq - `!co n k. first_n_exps co (n + k) = first_n_exps co k ++ first_n_exps (shift_seq k co) n` - (Induct_on `n` +Theorem first_n_exps_shift_seq: + !co n k. first_n_exps co (n + k) = first_n_exps co k ++ first_n_exps (shift_seq k co) n +Proof + Induct_on `n` \\ rpt strip_tac \\ fs [first_n_exps_def] \\ REWRITE_TAC [Q.prove (`k + SUC n = SUC (k + n)`, decide_tac)] \\ fs [GENLIST] - \\ fs [shift_seq_def]) + \\ fs [shift_seq_def] +QED -Theorem MEM_first_n_exps - `!k n. k < n ==> !co. MEM (FST (SND (co k))) (first_n_exps co n)` - (rw [first_n_exps_def, MEM_GENLIST] \\ metis_tac []); +Theorem MEM_first_n_exps: + !k n. k < n ==> !co. MEM (FST (SND (co k))) (first_n_exps co n) +Proof + rw [first_n_exps_def, MEM_GENLIST] \\ metis_tac [] +QED (* All globals set in the program and in code returned by the compile oracle are unique. *) @@ -164,23 +182,27 @@ val unique_set_globals_def = Define ` unique_set_globals es co <=> !n. BAG_ALL_DISTINCT (elist_globals (es ++ FLAT (first_n_exps co n)))`; -Theorem unique_set_globals_shift_seq - `!es co. unique_set_globals es co ==> !k. unique_set_globals es (shift_seq k co)` - (fs [unique_set_globals_def] +Theorem unique_set_globals_shift_seq: + !es co. unique_set_globals es co ==> !k. unique_set_globals es (shift_seq k co) +Proof + fs [unique_set_globals_def] \\ rpt strip_tac \\ pop_assum (qspec_then `n + k` assume_tac) \\ fs [first_n_exps_shift_seq] \\ fs [elist_globals_append] - \\ fs [BAG_ALL_DISTINCT_BAG_UNION]); - -Theorem unique_set_globals_evaluate - `!es xs env s1 s2 res. unique_set_globals xs s1.compile_oracle /\ - evaluate (es,env,s1) = (res, s2) ==> unique_set_globals xs s2.compile_oracle` - (rpt strip_tac \\ imp_res_tac evaluate_code \\ fs [] - \\ simp [unique_set_globals_shift_seq]); - -Theorem unique_set_globals_subexps - `(unique_set_globals (x1::x2::xs) co ==> + \\ fs [BAG_ALL_DISTINCT_BAG_UNION] +QED + +Theorem unique_set_globals_evaluate: + !es xs env s1 s2 res. unique_set_globals xs s1.compile_oracle /\ + evaluate (es,env,s1) = (res, s2) ==> unique_set_globals xs s2.compile_oracle +Proof + rpt strip_tac \\ imp_res_tac evaluate_code \\ fs [] + \\ simp [unique_set_globals_shift_seq] +QED + +Theorem unique_set_globals_subexps: + (unique_set_globals (x1::x2::xs) co ==> unique_set_globals [x1] co /\ unique_set_globals (x2::xs) co) /\ (unique_set_globals [If t x1 x2 x3] co ==> unique_set_globals [x1] co /\ unique_set_globals [x2] co /\ unique_set_globals [x3] co) /\ @@ -201,26 +223,34 @@ Theorem unique_set_globals_subexps (unique_set_globals [Tick t x1] co ==> unique_set_globals [x1] co) /\ (unique_set_globals [Call t ticks dest xs] co ==> - unique_set_globals xs co)` - (rpt strip_tac + unique_set_globals xs co) +Proof + rpt strip_tac \\ fs [unique_set_globals_def] \\ fs [elist_globals_append] - \\ fs [BAG_ALL_DISTINCT_BAG_UNION]); + \\ fs [BAG_ALL_DISTINCT_BAG_UNION] +QED val unique_set_globals_subexps = GEN_ALL unique_set_globals_subexps; -Theorem unique_set_globals_IMP_es_distinct_elist_globals - `!es co. unique_set_globals es co ==> BAG_ALL_DISTINCT (elist_globals es)` - (simp [unique_set_globals_def, elist_globals_append, BAG_ALL_DISTINCT_BAG_UNION]); +Theorem unique_set_globals_IMP_es_distinct_elist_globals: + !es co. unique_set_globals es co ==> BAG_ALL_DISTINCT (elist_globals es) +Proof + simp [unique_set_globals_def, elist_globals_append, BAG_ALL_DISTINCT_BAG_UNION] +QED -Theorem set_globals_empty_unique_set_globals - `set_globals e = {||} ==> (unique_set_globals [e] co <=> unique_set_globals [] co)` - (simp [unique_set_globals_def]); +Theorem set_globals_empty_unique_set_globals: + set_globals e = {||} ==> (unique_set_globals [e] co <=> unique_set_globals [] co) +Proof + simp [unique_set_globals_def] +QED -Theorem nil_unique_set_globals - `unique_set_globals es co ==> unique_set_globals [] co` - (simp [unique_set_globals_def] - \\ simp [elist_globals_append, BAG_ALL_DISTINCT_BAG_UNION]); +Theorem nil_unique_set_globals: + unique_set_globals es co ==> unique_set_globals [] co +Proof + simp [unique_set_globals_def] + \\ simp [elist_globals_append, BAG_ALL_DISTINCT_BAG_UNION] +QED (* Value approximation is sgc free *) @@ -241,17 +271,19 @@ val val_approx_sgc_free_def = save_thm( "val_approx_sgc_free_def[simp]", val_approx_sgc_free_def |> SIMP_RULE (srw_ss() ++ ETA_ss) []); -Theorem val_approx_sgc_free_merge - `!a1 a2. val_approx_sgc_free a1 /\ val_approx_sgc_free a2 ==> - val_approx_sgc_free (merge a1 a2)` - (ho_match_mp_tac merge_ind \\ simp [] +Theorem val_approx_sgc_free_merge: + !a1 a2. val_approx_sgc_free a1 /\ val_approx_sgc_free a2 ==> + val_approx_sgc_free (merge a1 a2) +Proof + ho_match_mp_tac merge_ind \\ simp [] \\ rpt strip_tac \\ IF_CASES_TAC \\ fs [] \\ rveq \\ fs [EVERY_MEM] \\ simp [MAP2_MAP, MEM_MAP, PULL_EXISTS] \\ simp [MEM_ZIP, PULL_EXISTS] \\ fs [MEM_EL] - \\ metis_tac []); + \\ metis_tac [] +QED val globals_approx_sgc_free_def = Define ` globals_approx_sgc_free g <=> @@ -280,50 +312,64 @@ val val_approx_val_simps = save_thm("val_approx_val_simps[simp]",LIST_CONJ [ prove(``val_approx_val Impossible v <=> F``, simp [val_approx_val_cases]) ]); -Theorem val_approx_val_merge_I_lemma - `!a1 v. val_approx_val a1 v ==> !a2. val_approx_val (merge a1 a2) v` - (ho_match_mp_tac val_approx_val_ind +Theorem val_approx_val_merge_I_lemma: + !a1 v. val_approx_val a1 v ==> !a2. val_approx_val (merge a1 a2) v +Proof + ho_match_mp_tac val_approx_val_ind \\ rw [] \\ Cases_on `a2` \\ fs [] \\ TRY (IF_CASES_TAC \\ fs [] \\ rveq) THEN1 fs [LIST_REL_EL_EQN, MAP2_MAP, EL_MAP, EL_ZIP] THEN1 (fs [LIST_REL_EL_EQN] \\ rfs [] \\ rw [] \\ res_tac - \\ first_x_assum (qspec_then `Impossible` assume_tac) \\ fs [])); + \\ first_x_assum (qspec_then `Impossible` assume_tac) \\ fs []) +QED -Theorem val_approx_val_merge_I - `!a1 v a2. +Theorem val_approx_val_merge_I: + !a1 v a2. val_approx_val a1 v \/ val_approx_val a2 v ==> - val_approx_val (merge a1 a2) v` - (metis_tac [val_approx_val_merge_I_lemma, merge_comm]); + val_approx_val (merge a1 a2) v +Proof + metis_tac [val_approx_val_merge_I_lemma, merge_comm] +QED -Theorem evaluate_IMP_shift_seq - `!es env s0 res s. +Theorem evaluate_IMP_shift_seq: + !es env s0 res s. closSem$evaluate (es, env, s0) = (res, s) ==> - ?k. s.compile_oracle = shift_seq k s0.compile_oracle` - (metis_tac [evaluate_code]); - -Theorem shift_seq_zero[simp] - `!co. shift_seq 0 co = co` - (simp [shift_seq_def, ETA_THM]); - -Theorem shift_seq_add[simp] - `!co k1 k2. shift_seq k2 (shift_seq k1 co) = shift_seq (k1 + k2) co` - (simp [shift_seq_def]); - -Theorem do_install_IMP_shift_seq - `do_install xs s0 = (res, s) ==> - ?k. s.compile_oracle = shift_seq k s0.compile_oracle` - (rpt strip_tac \\ fs [do_install_def] + ?k. s.compile_oracle = shift_seq k s0.compile_oracle +Proof + metis_tac [evaluate_code] +QED + +Theorem shift_seq_zero[simp]: + !co. shift_seq 0 co = co +Proof + simp [shift_seq_def, ETA_THM] +QED + +Theorem shift_seq_add[simp]: + !co k1 k2. shift_seq k2 (shift_seq k1 co) = shift_seq (k1 + k2) co +Proof + simp [shift_seq_def] +QED + +Theorem do_install_IMP_shift_seq: + do_install xs s0 = (res, s) ==> + ?k. s.compile_oracle = shift_seq k s0.compile_oracle +Proof + rpt strip_tac \\ fs [do_install_def] \\ fs [case_eq_thms] \\ TRY (qexists_tac `0` \\ simp [] \\ NO_TAC) \\ pairarg_tac \\ fs [] \\ fs [bool_case_eq, case_eq_thms, pair_case_eq] \\ TRY (qexists_tac `0` \\ simp [] \\ NO_TAC) - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem evaluate_app_IMP_shift_seq - `evaluate_app lopt f args s0 = (res, s) ==> - ?k. s.compile_oracle = shift_seq k s0.compile_oracle` - (metis_tac [evaluate_app_code]); +Theorem evaluate_app_IMP_shift_seq: + evaluate_app lopt f args s0 = (res, s) ==> + ?k. s.compile_oracle = shift_seq k s0.compile_oracle +Proof + metis_tac [evaluate_app_code] +QED val state_globals_approx_def = Define ` state_globals_approx s g <=> @@ -331,34 +377,46 @@ val state_globals_approx_def = Define ` get_global k s.globals = SOME (SOME v) /\ lookup k g = SOME a ==> val_approx_val a v `; -Theorem state_globals_approx_clock_fupd[simp] - `state_globals_approx (s with clock updated_by f) g ⇔ - state_globals_approx s g` - (simp[state_globals_approx_def]); - -Theorem state_globals_approx_dec_clock[simp] - `state_globals_approx (dec_clock n s) g ⇔ state_globals_approx s g` - (simp[dec_clock_def]); - -Theorem state_globals_approx_refsfupd[simp] - `state_globals_approx (s with refs updated_by f) g ⇔ - state_globals_approx s g` - (simp[state_globals_approx_def]); - -Theorem state_globals_approx_ffifupd[simp] - `state_globals_approx (s with ffi updated_by f) g ⇔ - state_globals_approx s g` - (simp[state_globals_approx_def]); - -Theorem state_globals_approx_codeupd[simp] - `state_globals_approx (s with code updated_by f) g ⇔ - state_globals_approx s g` - (simp[state_globals_approx_def]); - -Theorem state_globals_approx_coupd[simp] - `state_globals_approx (s with compile_oracle updated_by f) g ⇔ - state_globals_approx s g` - (simp[state_globals_approx_def]); +Theorem state_globals_approx_clock_fupd[simp]: + state_globals_approx (s with clock updated_by f) g ⇔ + state_globals_approx s g +Proof + simp[state_globals_approx_def] +QED + +Theorem state_globals_approx_dec_clock[simp]: + state_globals_approx (dec_clock n s) g ⇔ state_globals_approx s g +Proof + simp[dec_clock_def] +QED + +Theorem state_globals_approx_refsfupd[simp]: + state_globals_approx (s with refs updated_by f) g ⇔ + state_globals_approx s g +Proof + simp[state_globals_approx_def] +QED + +Theorem state_globals_approx_ffifupd[simp]: + state_globals_approx (s with ffi updated_by f) g ⇔ + state_globals_approx s g +Proof + simp[state_globals_approx_def] +QED + +Theorem state_globals_approx_codeupd[simp]: + state_globals_approx (s with code updated_by f) g ⇔ + state_globals_approx s g +Proof + simp[state_globals_approx_def] +QED + +Theorem state_globals_approx_coupd[simp]: + state_globals_approx (s with compile_oracle updated_by f) g ⇔ + state_globals_approx s g +Proof + simp[state_globals_approx_def] +QED (* Mapped globals *) @@ -375,37 +433,46 @@ val mglobals_extend_def = Define` ∀k v. get_global k g2 = SOME (SOME v) ∧ k ∉ mgs ⇒ get_global k g1 = SOME (SOME v)` -Theorem mglobals_extend_refl[simp] - `mglobals_extend s gs s` - (simp[mglobals_extend_def]); - -Theorem mglobals_extend_trans - `!s0 s1 s2 g1 g2. mglobals_extend s0 g1 s1 ∧ mglobals_extend s1 g2 s2 ⇒ - mglobals_extend s0 (g1 ∪ g2) s2` - (simp[mglobals_extend_def, SUBSET_DEF] >> metis_tac[]); - -Theorem mglobals_extend_SUBSET - `!s0 s g1 g2. mglobals_extend s0 g1 s ∧ g1 ⊆ g2 ⇒ mglobals_extend s0 g2 s` - (simp[mglobals_extend_def, SUBSET_DEF] >> metis_tac[]); - -Theorem subspt_better_definedg - `!sp1 sp2 sp3. subspt sp1 sp3 ∧ better_definedg sp1 sp2 ∧ better_definedg sp2 sp3 ⇒ - subspt sp1 sp2` - (simp[subspt_def, better_definedg_def] >> rpt strip_tac >> +Theorem mglobals_extend_refl[simp]: + mglobals_extend s gs s +Proof + simp[mglobals_extend_def] +QED + +Theorem mglobals_extend_trans: + !s0 s1 s2 g1 g2. mglobals_extend s0 g1 s1 ∧ mglobals_extend s1 g2 s2 ⇒ + mglobals_extend s0 (g1 ∪ g2) s2 +Proof + simp[mglobals_extend_def, SUBSET_DEF] >> metis_tac[] +QED + +Theorem mglobals_extend_SUBSET: + !s0 s g1 g2. mglobals_extend s0 g1 s ∧ g1 ⊆ g2 ⇒ mglobals_extend s0 g2 s +Proof + simp[mglobals_extend_def, SUBSET_DEF] >> metis_tac[] +QED + +Theorem subspt_better_definedg: + !sp1 sp2 sp3. subspt sp1 sp3 ∧ better_definedg sp1 sp2 ∧ better_definedg sp2 sp3 ⇒ + subspt sp1 sp2 +Proof + simp[subspt_def, better_definedg_def] >> rpt strip_tac >> spose_not_then assume_tac >> `k ∈ domain sp2 ∧ k ∈ domain sp3` by metis_tac [] >> `∃v1 v2 v3. lookup k sp1 = SOME v1 ∧ lookup k sp2 = SOME v2 ∧ lookup k sp3 = SOME v3` by metis_tac[domain_lookup] >> `v3 = v1` by metis_tac[SOME_11] >> rveq >> `v1 ◁ v2 ∧ v2 ◁ v1` by metis_tac[THE_DEF] >> - metis_tac[subapprox_antisym]) + metis_tac[subapprox_antisym] +QED -Theorem subspt_known_elist_globals - `∀c es1 as1 g0 al1 g1 es2 as2 al2 g2. +Theorem subspt_known_elist_globals: + ∀c es1 as1 g0 al1 g1 es2 as2 al2 g2. known c es1 as1 g0 = (al1, g1) ∧ known c es2 as2 g1 = (al2, g2) ∧ subspt g0 g2 ∧ BAG_DISJOINT (elist_globals es1) (elist_globals es2) ⇒ - subspt g0 g1 ∧ subspt g1 g2` - (rpt gen_tac >> strip_tac >> + subspt g0 g1 ∧ subspt g1 g2 +Proof + rpt gen_tac >> strip_tac >> `subspt g0 g1` by metis_tac[known_better_definedg, subspt_better_definedg] >> simp[] >> fs[subspt_def] >> rpt (gen_tac ORELSE disch_then strip_assume_tac) >> @@ -415,14 +482,16 @@ Theorem subspt_known_elist_globals `k ∈ SET_OF_BAG (elist_globals es2)` by metis_tac[known_changed_globals] >> Cases_on `k ∈ domain g0` >- metis_tac[] >> `k ∈ SET_OF_BAG (elist_globals es1)` by metis_tac[known_changed_globals] >> - fs[BAG_DISJOINT, DISJOINT_DEF, EXTENSION] >> metis_tac[]) + fs[BAG_DISJOINT, DISJOINT_DEF, EXTENSION] >> metis_tac[] +QED -Theorem subspt_known_op_elist_globals - `∀c es as1 g0 al1 g1 opn as2 g2 a. +Theorem subspt_known_op_elist_globals: + ∀c es as1 g0 al1 g1 opn as2 g2 a. known c es as1 g0 = (al1,g1) ∧ known_op opn as2 g1 = (a,g2) ∧ subspt g0 g2 ∧ BAG_DISJOINT (op_gbag opn) (elist_globals es) ⇒ - subspt g0 g1 ∧ subspt g1 g2` - (rpt gen_tac >> strip_tac >> + subspt g0 g1 ∧ subspt g1 g2 +Proof + rpt gen_tac >> strip_tac >> `subspt g0 g1` by metis_tac[known_better_definedg, subspt_better_definedg, known_op_better_definedg] >> simp[] >> @@ -433,15 +502,17 @@ Theorem subspt_known_op_elist_globals `k ∈ SET_OF_BAG (op_gbag opn)` by metis_tac[known_op_changed_globals] >> Cases_on `k ∈ domain g0` >- metis_tac[] >> `k ∈ SET_OF_BAG (elist_globals es)` by metis_tac[known_changed_globals] >> - fs[BAG_DISJOINT, DISJOINT_DEF, EXTENSION] >> metis_tac[]) + fs[BAG_DISJOINT, DISJOINT_DEF, EXTENSION] >> metis_tac[] +QED (* fv_max *) val fv_max_def = Define `fv_max n xs = !v. fv v xs ==> v < n`; -Theorem fv_alt - `!n xs. fv n xs <=> has_var n (SND (free xs))` - (ho_match_mp_tac fv_ind \\ rw [] +Theorem fv_alt: + !n xs. fv n xs <=> has_var n (SND (free xs)) +Proof + ho_match_mp_tac fv_ind \\ rw [] \\ simp [free_def] \\ rpt (pairarg_tac \\ fs []) \\ TRY (simp [Once fv1_def, fv_def] \\ NO_TAC) @@ -458,14 +529,17 @@ Theorem fv_alt \\ fs [EXISTS_MAP] \\ fs [EXISTS_MEM] \\ rpt (pairarg_tac \\ fs []) - \\ asm_exists_tac \\ simp [])); + \\ asm_exists_tac \\ simp []) +QED -Theorem fv1_alt - `fv1 n x = has_var n (SND (free [x]))` - (once_rewrite_tac [fv1_def] \\ metis_tac [fv_alt]); +Theorem fv1_alt: + fv1 n x = has_var n (SND (free [x])) +Proof + once_rewrite_tac [fv1_def] \\ metis_tac [fv_alt] +QED -Theorem fv_max_rw - `(fv_max n [] <=> T) /\ +Theorem fv_max_rw: + (fv_max n [] <=> T) /\ (fv_max n (x::y::xs) <=> fv_max n [x] /\ fv_max n (y::xs)) /\ (fv_max n [Var tr v] <=> v < n) /\ (fv_max n [If tr x1 x2 x3] <=> fv_max n [x1] /\ fv_max n [x2] /\ fv_max n [x3]) /\ @@ -479,8 +553,9 @@ Theorem fv_max_rw EVERY (\(num_args, x). fv_max (n + num_args + LENGTH fns) [x]) fns /\ fv_max (n + LENGTH fns) [x1]) /\ (fv_max n [Handle tr x1 x2] <=> fv_max n [x1] /\ fv_max (n + 1) [x2]) /\ - (fv_max n [Call tr ticks dest xs] <=> fv_max n xs)` - (rpt conj_tac \\ fs [fv_max_def] + (fv_max n [Call tr ticks dest xs] <=> fv_max n xs) +Proof + rpt conj_tac \\ fs [fv_max_def] \\ dsimp [Once fv1_def, fv_def] THEN1 (eq_tac \\ rw [] @@ -511,30 +586,40 @@ Theorem fv_max_rw (eq_tac \\ rw [] THEN1 (first_x_assum (qspec_then `v - 1` assume_tac) \\ Cases_on `v < 1` \\ fs []) - THEN1 (first_x_assum (qspec_then `v + 1` assume_tac) \\ fs []))) - -Theorem fv_max_mk_Ticks[simp] - `!t trc i e. fv_max n [mk_Ticks t trc i e] <=> fv_max n [e]` - (Induct_on `i` \\ simp [mk_Ticks_alt, fv_max_rw]); - -Theorem fv_max_cons - `fv_max n (h::t) <=> fv_max n [h] /\ fv_max n t` - (simp [fv_max_def] \\ eq_tac \\ rw [] \\ res_tac); - -Theorem fv_max_append[simp] - `!xs ys n. fv_max n (xs ++ ys) <=> fv_max n xs /\ fv_max n ys` - (Induct \\ simp [fv_max_rw] \\ metis_tac [fv_max_cons]); - -Theorem fv_max_less - `!m n xs. fv_max m xs /\ m <= n ==> fv_max n xs` - (simp [fv_max_def] \\ rw [] \\ res_tac \\ fs []); - -Theorem known_op_correct_approx - `!opn args g0 a g vs s0 v s. + THEN1 (first_x_assum (qspec_then `v + 1` assume_tac) \\ fs [])) +QED + +Theorem fv_max_mk_Ticks[simp]: + !t trc i e. fv_max n [mk_Ticks t trc i e] <=> fv_max n [e] +Proof + Induct_on `i` \\ simp [mk_Ticks_alt, fv_max_rw] +QED + +Theorem fv_max_cons: + fv_max n (h::t) <=> fv_max n [h] /\ fv_max n t +Proof + simp [fv_max_def] \\ eq_tac \\ rw [] \\ res_tac +QED + +Theorem fv_max_append[simp]: + !xs ys n. fv_max n (xs ++ ys) <=> fv_max n xs /\ fv_max n ys +Proof + Induct \\ simp [fv_max_rw] \\ metis_tac [fv_max_cons] +QED + +Theorem fv_max_less: + !m n xs. fv_max m xs /\ m <= n ==> fv_max n xs +Proof + simp [fv_max_def] \\ rw [] \\ res_tac \\ fs [] +QED + +Theorem known_op_correct_approx: + !opn args g0 a g vs s0 v s. known_op opn args g0 = (a, g) /\ do_app opn vs s0 = Rval (v, s) /\ LIST_REL val_approx_val args vs /\ state_globals_approx s0 g0 ==> - state_globals_approx s g /\ val_approx_val a v` - (rpt gen_tac + state_globals_approx s g /\ val_approx_val a v +Proof + rpt gen_tac \\ `?this_is_case. this_is_case opn` by (qexists_tac `K T` \\ fs []) \\ Cases_on `opn` \\ simp [known_op_def, do_app_def, case_eq_thms, va_case_eq, bool_case_eq, @@ -563,19 +648,23 @@ Theorem known_op_correct_approx (rveq \\ fs [LIST_REL_EL_EQN]) THEN1 (fs [CaseEq"ffi_result"] \\ rveq - \\ fs [state_globals_approx_def] \\ metis_tac [])); + \\ fs [state_globals_approx_def] \\ metis_tac []) +QED -Theorem ssgc_free_co_shift_seq - `ssgc_free s ==> !k. ssgc_free (s with compile_oracle := shift_seq k s.compile_oracle)` - (simp [PULL_FORALL] \\ gen_tac +Theorem ssgc_free_co_shift_seq: + ssgc_free s ==> !k. ssgc_free (s with compile_oracle := shift_seq k s.compile_oracle) +Proof + simp [PULL_FORALL] \\ gen_tac \\ simp [ssgc_free_def] \\ strip_tac \\ rpt conj_tac \\ fs [] - \\ rpt gen_tac \\ strip_tac \\ fs [shift_seq_def] \\ res_tac \\ simp []); + \\ rpt gen_tac \\ strip_tac \\ fs [shift_seq_def] \\ res_tac \\ simp [] +QED -Theorem ssgc_free_do_install - `!s. ssgc_free s ==> +Theorem ssgc_free_do_install: + !s. ssgc_free s ==> ssgc_free (s with <|compile_oracle := shift_seq 1 (s.compile_oracle); - code := s.code |++ SND (SND (s.compile_oracle 0))|>)` - (gen_tac \\ simp [ssgc_free_def] \\ strip_tac \\ rpt conj_tac + code := s.code |++ SND (SND (s.compile_oracle 0))|>) +Proof + gen_tac \\ simp [ssgc_free_def] \\ strip_tac \\ rpt conj_tac THEN1 (`?exp aux. SND (s.compile_oracle 0) = (exp, aux)` by (Cases_on `SND (s.compile_oracle 0)` \\ simp []) \\ res_tac \\ simp [] @@ -588,15 +677,17 @@ Theorem ssgc_free_do_install \\ rveq \\ fs [MAP_APPEND, elist_globals_append]) THEN1 (rw [] \\ res_tac) - THEN1 (simp [shift_seq_def] \\ rw [] \\ res_tac)); + THEN1 (simp [shift_seq_def] \\ rw [] \\ res_tac) +QED -Theorem do_install_ssgc - `!vs s0 es s1. do_install vs s0 = (Rval es, s1) /\ ssgc_free s0 ==> +Theorem do_install_ssgc: + !vs s0 es s1. do_install vs s0 = (Rval es, s1) /\ ssgc_free s0 ==> ssgc_free s1 /\ EVERY esgc_free es /\ es ≠ [] /\ s1.compile_oracle = shift_seq 1 s0.compile_oracle /\ first_n_exps s0.compile_oracle 1 = [es] /\ - mglobals_extend s0.globals EMPTY s1.globals` - (rpt gen_tac \\ strip_tac + mglobals_extend s0.globals EMPTY s1.globals +Proof + rpt gen_tac \\ strip_tac \\ fs [do_install_def, case_eq_thms] \\ pairarg_tac \\ fs [] \\ fs [case_eq_thms, bool_case_eq, pair_case_eq] @@ -606,7 +697,8 @@ Theorem do_install_ssgc \\ pop_assum kall_tac \\ fs [ssgc_free_def] \\ Cases_on `SND (s0.compile_oracle 0)` - \\ res_tac \\ rfs []); + \\ res_tac \\ rfs [] +QED val value_ind = TypeBase.induction_of ``:closSem$v`` @@ -614,16 +706,17 @@ val value_ind = |> SIMP_RULE (srw_ss()) [] |> UNDISCH |> CONJUNCT1 |> DISCH_ALL |> Q.GEN `P` -Theorem do_app_ssgc - `!opn args s0 res. +Theorem do_app_ssgc: + !opn args s0 res. do_app opn args s0 = res /\ EVERY vsgc_free args /\ ssgc_free s0 ==> (!v s. res = Rval (v, s) ==> vsgc_free v /\ ssgc_free s /\ s.compile_oracle = s0.compile_oracle /\ mglobals_extend s0.globals (SET_OF_BAG (op_gbag opn)) s.globals) /\ - (!v. res = Rerr (Rraise v) ==> vsgc_free v)` - (gen_tac >> + (!v. res = Rerr (Rraise v) ==> vsgc_free v) +Proof + gen_tac >> `?this_is_case. this_is_case = opn` by metis_tac [] >> Cases_on `opn` >> simp[do_app_def, case_eq_thms, op_gbag_def, PULL_EXISTS, bool_case_eq, @@ -710,14 +803,16 @@ Theorem do_app_ssgc >- (first_x_assum match_mp_tac >> fs[]) >- (first_x_assum match_mp_tac >> fs[] >> metis_tac[]) >- (first_x_assum match_mp_tac >> fs[] >> metis_tac[])) - >> dsimp[]); + >> dsimp[] +QED -Theorem dest_closure_Full_sgc_free - `dest_closure max_app loc_opt f (arg0::args) = +Theorem dest_closure_Full_sgc_free: + dest_closure max_app loc_opt f (arg0::args) = SOME (Full_app fbody env rest_args) /\ vsgc_free f /\ vsgc_free arg0 /\ EVERY vsgc_free args ==> - set_globals fbody = {||} /\ EVERY vsgc_free env /\ EVERY vsgc_free rest_args` - (rpt gen_tac \\ strip_tac + set_globals fbody = {||} /\ EVERY vsgc_free env /\ EVERY vsgc_free rest_args +Proof + rpt gen_tac \\ strip_tac \\ imp_res_tac dest_closure_is_closure \\ imp_res_tac dest_closure_full_length \\ rename [`is_closure f`] @@ -738,7 +833,8 @@ Theorem dest_closure_Full_sgc_free \\ simp [EVERY_REVERSE, EVERY_GENLIST, elist_globals_append] \\ conj_tac THEN1 (irule EVERY_TAKE \\ simp [EVERY_REVERSE]) - THEN1 (irule EVERY_DROP \\ simp [EVERY_REVERSE])); + THEN1 (irule EVERY_DROP \\ simp [EVERY_REVERSE]) +QED val say = say0 "evaluate_changed_globals_0"; @@ -1031,39 +1127,48 @@ val evaluate_app_changed_globals = save_thm( "evaluate_app_changed_globals", CONJUNCT2 evaluate_changed_globals_0); -Theorem mk_Ticks_set_globals[simp] - `!t tc n exp. set_globals (mk_Ticks t tc n exp) = set_globals exp` - (Induct_on `n` \\ simp [mk_Ticks_alt]); +Theorem mk_Ticks_set_globals[simp]: + !t tc n exp. set_globals (mk_Ticks t tc n exp) = set_globals exp +Proof + Induct_on `n` \\ simp [mk_Ticks_alt] +QED val gapprox_disjoint_def = Define ` gapprox_disjoint g xs <=> DISJOINT (domain g) (SET_OF_BAG (elist_globals xs))`; -Theorem gapprox_disjoint_rw - `(gapprox_disjoint g (x::y::xs) <=> +Theorem gapprox_disjoint_rw: + (gapprox_disjoint g (x::y::xs) <=> gapprox_disjoint g [x] /\ gapprox_disjoint g (y::xs)) /\ (gapprox_disjoint g [Op tr opn xs] <=> - gapprox_disjoint g xs /\ DISJOINT (domain g) (SET_OF_BAG (op_gbag opn)))` - (simp [gapprox_disjoint_def, SET_OF_BAG_UNION, DISJOINT_SYM, AC CONJ_ASSOC CONJ_COMM]) + gapprox_disjoint g xs /\ DISJOINT (domain g) (SET_OF_BAG (op_gbag opn))) +Proof + simp [gapprox_disjoint_def, SET_OF_BAG_UNION, DISJOINT_SYM, AC CONJ_ASSOC CONJ_COMM] +QED val oracle_gapprox_disjoint_def = Define ` oracle_gapprox_disjoint g co <=> !n. gapprox_disjoint g (FST (SND (co n)))`; -Theorem oracle_gapprox_disjoint_shift_seq - `oracle_gapprox_disjoint g co ==> - !k. oracle_gapprox_disjoint g (shift_seq k co)` - (fs [oracle_gapprox_disjoint_def, shift_seq_def]); +Theorem oracle_gapprox_disjoint_shift_seq: + oracle_gapprox_disjoint g co ==> + !k. oracle_gapprox_disjoint g (shift_seq k co) +Proof + fs [oracle_gapprox_disjoint_def, shift_seq_def] +QED -Theorem oracle_gapprox_disjoint_evaluate - `!g s0 es env res s1. +Theorem oracle_gapprox_disjoint_evaluate: + !g s0 es env res s1. oracle_gapprox_disjoint g s0.compile_oracle /\ evaluate (es, env, s0) = (res, s1) ==> - oracle_gapprox_disjoint g s1.compile_oracle` - (rw [] \\ imp_res_tac evaluate_code \\ simp [oracle_gapprox_disjoint_shift_seq]); - -Theorem oracle_gapprox_disjoint_first_n_exps - `!g co. oracle_gapprox_disjoint g co <=> - !n. gapprox_disjoint g (FLAT (first_n_exps co n))` - (rpt gen_tac + oracle_gapprox_disjoint g s1.compile_oracle +Proof + rw [] \\ imp_res_tac evaluate_code \\ simp [oracle_gapprox_disjoint_shift_seq] +QED + +Theorem oracle_gapprox_disjoint_first_n_exps: + !g co. oracle_gapprox_disjoint g co <=> + !n. gapprox_disjoint g (FLAT (first_n_exps co n)) +Proof + rpt gen_tac \\ simp [first_n_exps_def, oracle_gapprox_disjoint_def, gapprox_disjoint_def] \\ eq_tac THEN1 @@ -1074,19 +1179,23 @@ Theorem oracle_gapprox_disjoint_first_n_exps \\ simp [DISJOINT_SYM]) \\ rw [] \\ pop_assum (qspec_then `SUC n` assume_tac) - \\ fs [GENLIST, SNOC_APPEND, elist_globals_append, SET_OF_BAG_UNION, DISJOINT_SYM]); + \\ fs [GENLIST, SNOC_APPEND, elist_globals_append, SET_OF_BAG_UNION, DISJOINT_SYM] +QED -Theorem mk_Ticks_esgc_free[simp] - `!t tc n exp. esgc_free (mk_Ticks t tc n exp) <=> esgc_free exp` - (Induct_on `n` \\ fs [mk_Ticks_alt]); +Theorem mk_Ticks_esgc_free[simp]: + !t tc n exp. esgc_free (mk_Ticks t tc n exp) <=> esgc_free exp +Proof + Induct_on `n` \\ fs [mk_Ticks_alt] +QED -Theorem known_op_preserves_esgc_free - `!opn args g0 a g. +Theorem known_op_preserves_esgc_free: + !opn args g0 a g. known_op opn args g0 = (a, g) /\ EVERY val_approx_sgc_free args /\ globals_approx_sgc_free g0 ==> - val_approx_sgc_free a /\ globals_approx_sgc_free g` - (rpt gen_tac \\ strip_tac + val_approx_sgc_free a /\ globals_approx_sgc_free g +Proof + rpt gen_tac \\ strip_tac \\ Cases_on `opn` \\ fs [known_op_def] \\ rveq \\ fs [] THEN1 (fs [bool_case_eq, case_eq_thms] \\ rveq \\ fs [] @@ -1097,17 +1206,22 @@ Theorem known_op_preserves_esgc_free \\ metis_tac [val_approx_sgc_free_merge]) THEN1 (fs [case_eq_thms, va_case_eq, bool_case_eq] \\ rveq \\ fs [] \\ imp_res_tac integerTheory.NUM_POSINT_EXISTS \\ fs [] - \\ fs [EVERY_EL])); - -Theorem elist_globals_empty - `!es. elist_globals es = {||} <=> - !e. MEM e es ==> set_globals e = {||}` - (Induct \\ fs [] \\ rw [] \\ eq_tac \\ rw [] \\ fs []); - -Theorem clos_gen_noinline_val_approx_sgc_free - `!n i fns. EVERY val_approx_sgc_free (clos_gen_noinline n i fns)` - (ho_match_mp_tac clos_gen_noinline_ind - \\ rw [] \\ fs [clos_gen_noinline_def]); + \\ fs [EVERY_EL]) +QED + +Theorem elist_globals_empty: + !es. elist_globals es = {||} <=> + !e. MEM e es ==> set_globals e = {||} +Proof + Induct \\ fs [] \\ rw [] \\ eq_tac \\ rw [] \\ fs [] +QED + +Theorem clos_gen_noinline_val_approx_sgc_free: + !n i fns. EVERY val_approx_sgc_free (clos_gen_noinline n i fns) +Proof + ho_match_mp_tac clos_gen_noinline_ind + \\ rw [] \\ fs [clos_gen_noinline_def] +QED val loptrel_def = Define` loptrel fv numargs lopt1 lopt2 ⇔ @@ -1122,23 +1236,27 @@ val loptrel_def = Define` | _ => F `; -Theorem decide_inline_LetInline_IMP_Clos - `!c fapx lopt arity body. +Theorem decide_inline_LetInline_IMP_Clos: + !c fapx lopt arity body. decide_inline c fapx lopt arity = inlD_LetInline body ==> - ?m s. fapx = Clos m arity body s` - (rpt strip_tac - \\ Cases_on `fapx` \\ fs [decide_inline_def, bool_case_eq]); + ?m s. fapx = Clos m arity body s +Proof + rpt strip_tac + \\ Cases_on `fapx` \\ fs [decide_inline_def, bool_case_eq] +QED -Theorem decide_inline_LetInline_IMP_Clos_lopt - `!c fapx lopt arity body. +Theorem decide_inline_LetInline_IMP_Clos_lopt: + !c fapx lopt arity body. decide_inline c fapx lopt arity = inlD_LetInline body ==> ?m s. fapx = Clos m arity body s /\ - (lopt = NONE \/ lopt = SOME m)` - (rpt strip_tac - \\ Cases_on `fapx` \\ fs [decide_inline_def, bool_case_eq]); + (lopt = NONE \/ lopt = SOME m) +Proof + rpt strip_tac + \\ Cases_on `fapx` \\ fs [decide_inline_def, bool_case_eq] +QED -Theorem known_preserves_esgc_free_0 - `!c es aenv g0 eas1 g. +Theorem known_preserves_esgc_free_0: + !c es aenv g0 eas1 g. known c es aenv g0 = (eas1, g) /\ EVERY esgc_free es /\ EVERY val_approx_sgc_free aenv /\ @@ -1146,8 +1264,9 @@ Theorem known_preserves_esgc_free_0 elist_globals (MAP FST eas1) ≤ elist_globals es /\ EVERY esgc_free (MAP FST eas1) /\ EVERY val_approx_sgc_free (MAP SND eas1) /\ - globals_approx_sgc_free g` - (ho_match_mp_tac known_ind + globals_approx_sgc_free g +Proof + ho_match_mp_tac known_ind \\ rpt conj_tac \\ rpt (gen_tac ORELSE disch_then strip_assume_tac) \\ fs [known_def] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ imp_res_tac known_sing_EQ_E \\ fs [] \\ rveq \\ fs [] @@ -1187,36 +1306,42 @@ Theorem known_preserves_esgc_free_0 \\ unabbrev_all_tac \\ imp_res_tac known_sing_EQ_E \\ fs [] \\ rveq - \\ first_x_assum drule \\ fs [])); + \\ first_x_assum drule \\ fs []) +QED -Theorem known_preserves_esgc_free - `!c es aenv g0 eas1 g. +Theorem known_preserves_esgc_free: + !c es aenv g0 eas1 g. known c es aenv g0 = (eas1, g) /\ EVERY esgc_free es /\ EVERY val_approx_sgc_free aenv /\ globals_approx_sgc_free g0 ==> EVERY esgc_free (MAP FST eas1) /\ EVERY val_approx_sgc_free (MAP SND eas1) /\ - globals_approx_sgc_free g` - (rpt gen_tac \\ rpt (disch_then strip_assume_tac) - \\ metis_tac [known_preserves_esgc_free_0]); - -Theorem known_elglobals_dont_grow - `!c es aenv g0 eas1 g. + globals_approx_sgc_free g +Proof + rpt gen_tac \\ rpt (disch_then strip_assume_tac) + \\ metis_tac [known_preserves_esgc_free_0] +QED + +Theorem known_elglobals_dont_grow: + !c es aenv g0 eas1 g. known c es aenv g0 = (eas1, g) /\ EVERY esgc_free es /\ EVERY val_approx_sgc_free aenv /\ globals_approx_sgc_free g0 ==> - elist_globals (MAP FST eas1) ≤ elist_globals es` - (rpt gen_tac \\ rpt (disch_then strip_assume_tac) - \\ metis_tac [known_preserves_esgc_free_0]); - -Theorem known_preserves_pure - `!c es aenv g0 eas1 g. + elist_globals (MAP FST eas1) ≤ elist_globals es +Proof + rpt gen_tac \\ rpt (disch_then strip_assume_tac) + \\ metis_tac [known_preserves_esgc_free_0] +QED + +Theorem known_preserves_pure: + !c es aenv g0 eas1 g. known c es aenv g0 = (eas1, g) /\ EVERY pure es ==> - EVERY pure (MAP FST eas1)` - (ho_match_mp_tac known_ind + EVERY pure (MAP FST eas1) +Proof + ho_match_mp_tac known_ind \\ simp [known_def] \\ rpt strip_tac \\ rpt (pairarg_tac \\ fs []) @@ -1224,36 +1349,43 @@ Theorem known_preserves_pure \\ fs [] \\ rveq \\ fs [closLangTheory.pure_def] \\ every_case_tac - \\ fs [closLangTheory.pure_def, closLangTheory.pure_op_def, ETA_THM]); + \\ fs [closLangTheory.pure_def, closLangTheory.pure_op_def, ETA_THM] +QED -Theorem evaluate_mk_Ticks_rw - `!t tc n exp env (s:('c,'ffi) closSem$state). +Theorem evaluate_mk_Ticks_rw: + !t tc n exp env (s:('c,'ffi) closSem$state). evaluate ([mk_Ticks t tc n exp], env, s) = if s.clock < n then (Rerr (Rabort Rtimeout_error), s with clock := 0) - else evaluate ([exp], env, dec_clock n s)` - (Induct_on `n` + else evaluate ([exp], env, dec_clock n s) +Proof + Induct_on `n` THEN1 simp [mk_Ticks_alt, dec_clock_def] \\ rw [] \\ fs [mk_Ticks_alt, evaluate_def, dec_clock_def, ADD1] - \\ IF_CASES_TAC \\ simp [state_component_equality]) + \\ IF_CASES_TAC \\ simp [state_component_equality] +QED -Theorem evaluate_mk_Ticks_IMP - `!t tc n exp env (s0:('c,'ffi) closSem$state) res s. +Theorem evaluate_mk_Ticks_IMP: + !t tc n exp env (s0:('c,'ffi) closSem$state) res s. evaluate ([mk_Ticks t tc n exp], env, s0) = (res, s) ==> (res = Rerr (Rabort Rtimeout_error) /\ s = s0 with clock := 0) \/ - (evaluate ([exp], env, dec_clock n s0) = (res, s))` - (Induct_on `n` \\ rpt strip_tac + (evaluate ([exp], env, dec_clock n s0) = (res, s)) +Proof + Induct_on `n` \\ rpt strip_tac THEN1 (fs [mk_Ticks_alt, dec_clock_def]) \\ fs [mk_Ticks_alt] \\ res_tac \\ fs [evaluate_def] - \\ fs [bool_case_eq, dec_clock_def, ADD1, state_component_equality]); + \\ fs [bool_case_eq, dec_clock_def, ADD1, state_component_equality] +QED -Theorem clos_gen_noinline_eq - `!n c fns. +Theorem clos_gen_noinline_eq: + !n c fns. clos_gen_noinline n c fns = - GENLIST (λi. ClosNoInline (2 * (i+c) + n) (FST (EL i fns))) (LENGTH fns)` - (Induct_on`fns`>>fs[FORALL_PROD,clos_gen_noinline_def,GENLIST_CONS]>>rw[]>> - simp[o_DEF,ADD1]) + GENLIST (λi. ClosNoInline (2 * (i+c) + n) (FST (EL i fns))) (LENGTH fns) +Proof + Induct_on`fns`>>fs[FORALL_PROD,clos_gen_noinline_def,GENLIST_CONS]>>rw[]>> + simp[o_DEF,ADD1] +QED val letrec_case_eq = Q.prove(` !limit loc fns. @@ -1271,17 +1403,20 @@ val every_var_def = Define ` (every_var P (Union d1 d2) <=> every_var P d1 /\ every_var P d2) `; -Theorem every_var_mk_Union[simp] - `every_var P (mk_Union d1 d2) <=> every_var P d1 /\ every_var P d2` - (simp [mk_Union_def] \\ rpt (IF_CASES_TAC \\ simp [every_var_def])); +Theorem every_var_mk_Union[simp]: + every_var P (mk_Union d1 d2) <=> every_var P d1 /\ every_var P d2 +Proof + simp [mk_Union_def] \\ rpt (IF_CASES_TAC \\ simp [every_var_def]) +QED -Theorem decide_inline_LetInline_IMP_Clos_fv_max - `!c fapx lopt arity body. +Theorem decide_inline_LetInline_IMP_Clos_fv_max: + !c fapx lopt arity body. decide_inline c fapx lopt arity = inlD_LetInline body ==> ?m s. fapx = Clos m arity body s /\ - fv_max arity [body]` - (rpt strip_tac + fv_max arity [body] +Proof + rpt strip_tac \\ Cases_on `fapx` \\ fs [decide_inline_def, bool_case_eq] \\ fs [fv_max_def, fv1_alt] \\ rpt strip_tac \\ rveq \\ fs [closed_def, free_def] @@ -1291,14 +1426,16 @@ Theorem decide_inline_LetInline_IMP_Clos_fv_max \\ rename1 `v < arity` \\ Cases_on `v < arity` \\ simp [] \\ first_x_assum (qspec_then `v - arity` mp_tac) - \\ simp []); + \\ simp [] +QED -Theorem known_preserves_fv_max - `!c es aenv g0 eas1 g n. +Theorem known_preserves_fv_max: + !c es aenv g0 eas1 g n. known c es aenv g0 = (eas1, g) /\ fv_max n es ==> - fv_max n (MAP FST eas1)` - (ho_match_mp_tac known_ind + fv_max n (MAP FST eas1) +Proof + ho_match_mp_tac known_ind \\ simp [known_def, fv_max_rw] \\ rpt strip_tac \\ rpt (pairarg_tac \\ fs []) @@ -1329,7 +1466,8 @@ Theorem known_preserves_fv_max \\ rveq \\ fs [] \\ first_x_assum drule \\ simp [] \\ strip_tac \\ fs [EVERY_MEM] - \\ first_x_assum drule \\ simp [])); + \\ first_x_assum drule \\ simp []) +QED (* oracle_gapprox_subspt *) val oracle_gapprox_subspt_def = Define ` @@ -1337,10 +1475,11 @@ val oracle_gapprox_subspt_def = Define ` !n. subspt (FST (FST (co n))) (FST (FST (co (SUC n)))) `; -Theorem oracle_gapprox_subspt_add - `oracle_gapprox_subspt co <=> - !(n:num) k. subspt (FST (FST (co n))) (FST (FST (co (n + k))))` - (eq_tac \\ rw [] +Theorem oracle_gapprox_subspt_add: + oracle_gapprox_subspt co <=> + !(n:num) k. subspt (FST (FST (co n))) (FST (FST (co (n + k)))) +Proof + eq_tac \\ rw [] THEN1 (Induct_on `k` \\ fs [oracle_gapprox_subspt_def] @@ -1349,33 +1488,42 @@ Theorem oracle_gapprox_subspt_add \\ metis_tac [subspt_trans]) \\ rw [oracle_gapprox_subspt_def] \\ first_x_assum (qspecl_then [`n`, `1`] mp_tac) - \\ simp [ADD1]); - -Theorem oracle_gapprox_subspt_alt - `!co n k. oracle_gapprox_subspt co /\ n <= k ==> - subspt (FST (FST (co n))) (FST (FST (co k)))` - (rw [oracle_gapprox_subspt_add] - \\ imp_res_tac LESS_EQ_ADD_EXISTS \\ rveq \\ simp []); - -Theorem oracle_gapprox_subspt_shift_seq - `oracle_gapprox_subspt co ==> !k. oracle_gapprox_subspt (shift_seq k co)` - (rw [] \\ simp [oracle_gapprox_subspt_def, shift_seq_def] - \\ fs [oracle_gapprox_subspt_alt]); - -Theorem oracle_gapprox_subspt_evaluate - `!s0 xs env s0 res s. + \\ simp [ADD1] +QED + +Theorem oracle_gapprox_subspt_alt: + !co n k. oracle_gapprox_subspt co /\ n <= k ==> + subspt (FST (FST (co n))) (FST (FST (co k))) +Proof + rw [oracle_gapprox_subspt_add] + \\ imp_res_tac LESS_EQ_ADD_EXISTS \\ rveq \\ simp [] +QED + +Theorem oracle_gapprox_subspt_shift_seq: + oracle_gapprox_subspt co ==> !k. oracle_gapprox_subspt (shift_seq k co) +Proof + rw [] \\ simp [oracle_gapprox_subspt_def, shift_seq_def] + \\ fs [oracle_gapprox_subspt_alt] +QED + +Theorem oracle_gapprox_subspt_evaluate: + !s0 xs env s0 res s. oracle_gapprox_subspt s0.compile_oracle /\ closSem$evaluate (xs, env, s0) = (res, s) ==> - oracle_gapprox_subspt s.compile_oracle` - (rw [] \\ imp_res_tac evaluate_code \\ simp [oracle_gapprox_subspt_shift_seq]); + oracle_gapprox_subspt s.compile_oracle +Proof + rw [] \\ imp_res_tac evaluate_code \\ simp [oracle_gapprox_subspt_shift_seq] +QED (* oracle_state_sgc_free *) val oracle_state_sgc_free_def = Define ` oracle_state_sgc_free co = !n. globals_approx_sgc_free (FST (FST (co n)))`; -Theorem oracle_state_sgc_free_shift_seq - `!co. oracle_state_sgc_free co ==> !n. oracle_state_sgc_free (shift_seq n co)` - (rpt strip_tac \\ fs [oracle_state_sgc_free_def, shift_seq_def]) +Theorem oracle_state_sgc_free_shift_seq: + !co. oracle_state_sgc_free co ==> !n. oracle_state_sgc_free (shift_seq n co) +Proof + rpt strip_tac \\ fs [oracle_state_sgc_free_def, shift_seq_def] +QED val next_g_def = Define ` next_g (s:(val_approx num_map#'c,'ffi) closSem$state) = @@ -1386,8 +1534,8 @@ val next_g_def = Define ` val mglobals_disjoint_def = Define ` mglobals_disjoint s xs <=> DISJOINT (mapped_globals s) (SET_OF_BAG (elist_globals xs))`; -Theorem mglobals_disjoint_rw - `(mglobals_disjoint s (x::y::xs) <=> +Theorem mglobals_disjoint_rw: + (mglobals_disjoint s (x::y::xs) <=> mglobals_disjoint s [x] /\ mglobals_disjoint s (y::xs)) /\ (mglobals_disjoint s [Let tr xs x] <=> mglobals_disjoint s xs /\ mglobals_disjoint s [x]) /\ @@ -1406,89 +1554,104 @@ Theorem mglobals_disjoint_rw (mglobals_disjoint s [App tr lopt x1 xs] <=> mglobals_disjoint s [x1] /\ mglobals_disjoint s xs) /\ (mglobals_disjoint s [Letrec tr lopt vs fns x1] <=> - mglobals_disjoint s (MAP SND fns) /\ mglobals_disjoint s [x1])` - (simp [mglobals_disjoint_def, SET_OF_BAG_UNION, DISJOINT_SYM, AC CONJ_ASSOC CONJ_COMM]) + mglobals_disjoint s (MAP SND fns) /\ mglobals_disjoint s [x1]) +Proof + simp [mglobals_disjoint_def, SET_OF_BAG_UNION, DISJOINT_SYM, AC CONJ_ASSOC CONJ_COMM] +QED (**) -Theorem known_changed_globals_cases - `!c xs aenv g0 alist g. +Theorem known_changed_globals_cases: + !c xs aenv g0 alist g. known c xs aenv g0 = (alist,g) ==> - !k a. lookup k g = SOME a ==> lookup k g0 = SOME a \/ k ∈ SET_OF_BAG (elist_globals xs)` - (rw [] \\ drule known_changed_globals \\ strip_tac - \\ fs [domain_lookup, PULL_EXISTS] \\ metis_tac []); - -Theorem known_op_changed_globals_cases - `!opn aenv g0 ea g. + !k a. lookup k g = SOME a ==> lookup k g0 = SOME a \/ k ∈ SET_OF_BAG (elist_globals xs) +Proof + rw [] \\ drule known_changed_globals \\ strip_tac + \\ fs [domain_lookup, PULL_EXISTS] \\ metis_tac [] +QED + +Theorem known_op_changed_globals_cases: + !opn aenv g0 ea g. known_op opn aenv g0 = (ea,g) ==> - !k a. lookup k g = SOME a ==> lookup k g0 = SOME a \/ k ∈ SET_OF_BAG (op_gbag opn)` - (rw [] \\ drule known_op_changed_globals \\ strip_tac - \\ fs [domain_lookup, PULL_EXISTS] \\ metis_tac []); + !k a. lookup k g = SOME a ==> lookup k g0 = SOME a \/ k ∈ SET_OF_BAG (op_gbag opn) +Proof + rw [] \\ drule known_op_changed_globals \\ strip_tac + \\ fs [domain_lookup, PULL_EXISTS] \\ metis_tac [] +QED -Theorem state_globals_approx_known_mglobals_disjoint - `!c xs aenv g0 eas g s. +Theorem state_globals_approx_known_mglobals_disjoint: + !c xs aenv g0 eas g s. known c xs aenv g0 = (eas, g) /\ mglobals_disjoint s.globals xs /\ state_globals_approx s g0 ==> - state_globals_approx s g` - (rw [] \\ simp [state_globals_approx_def] \\ rw [] + state_globals_approx s g +Proof + rw [] \\ simp [state_globals_approx_def] \\ rw [] \\ drule known_changed_globals_cases \\ disch_then drule \\ strip_tac THEN1 metis_tac [state_globals_approx_def] \\ fs [mglobals_disjoint_def, mapped_globals_def, DISJOINT_ALT, PULL_EXISTS] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem mglobals_disjoint_evaluate - `!s0 xs ys env res s. +Theorem mglobals_disjoint_evaluate: + !s0 xs ys env res s. evaluate (ys, env, s0) = (res, s) /\ ssgc_free s0 /\ EVERY vsgc_free env /\ EVERY esgc_free ys /\ unique_set_globals (xs ++ ys) s0.compile_oracle /\ mglobals_disjoint s0.globals xs ==> - mglobals_disjoint s.globals xs` - (rw [mglobals_disjoint_def, mapped_globals_def, DISJOINT_ALT, PULL_EXISTS] + mglobals_disjoint s.globals xs +Proof + rw [mglobals_disjoint_def, mapped_globals_def, DISJOINT_ALT, PULL_EXISTS] \\ drule evaluate_changed_globals \\ simp [] \\ strip_tac \\ fs [mglobals_extend_def, mapped_globals_def] \\ first_x_assum drule \\ strip_tac \\ spose_not_then assume_tac \\ fs [unique_set_globals_def, BAG_ALL_DISTINCT_BAG_UNION, elist_globals_append] - \\ metis_tac [BAG_DISJOINT_BAG_IN]) + \\ metis_tac [BAG_DISJOINT_BAG_IN] +QED -Theorem known_changed_globals_cases - `!c xs aenv g0 alist g. +Theorem known_changed_globals_cases: + !c xs aenv g0 alist g. known c xs aenv g0 = (alist,g) ==> - !k a. lookup k g = SOME a ==> lookup k g0 = SOME a \/ k ∈ SET_OF_BAG (elist_globals xs)` - (rw [] \\ drule known_changed_globals \\ strip_tac - \\ fs [domain_lookup, PULL_EXISTS] \\ metis_tac []); + !k a. lookup k g = SOME a ==> lookup k g0 = SOME a \/ k ∈ SET_OF_BAG (elist_globals xs) +Proof + rw [] \\ drule known_changed_globals \\ strip_tac + \\ fs [domain_lookup, PULL_EXISTS] \\ metis_tac [] +QED val gapprox_extend_def = Define ` gapprox_extend g1 gd g2 <=> !i. i ∈ domain g2 ∧ (i ∈ domain g1 ==> lookup i g2 ≠ lookup i g1) ==> i ∈ gd`; -Theorem state_globals_approx_disjoint_extends - `!s1 mgx s2 g1 gax g2. +Theorem state_globals_approx_disjoint_extends: + !s1 mgx s2 g1 gax g2. mglobals_extend s1.globals mgx s2.globals /\ gapprox_extend g1 gax g2 /\ DISJOINT (mapped_globals s1.globals) gax /\ DISJOINT gax mgx /\ state_globals_approx s2 g1 ==> - state_globals_approx s2 g2` - (rw [state_globals_approx_def] + state_globals_approx s2 g2 +Proof + rw [state_globals_approx_def] \\ fs [DISJOINT_ALT] \\ fs [mglobals_extend_def, gapprox_extend_def] \\ fs [mapped_globals_def, domain_lookup, PULL_EXISTS] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem state_globals_approx_evaluate - `!xs env s0 res s c ys aenv g0 eas g. +Theorem state_globals_approx_evaluate: + !xs env s0 res s c ys aenv g0 eas g. evaluate (xs,env,s0) = (res, s) /\ known c ys aenv g0 = (eas, g) /\ ssgc_free s0 /\ EVERY vsgc_free env /\ EVERY esgc_free xs /\ mglobals_disjoint s0.globals ys /\ unique_set_globals (xs ++ ys) s0.compile_oracle /\ state_globals_approx s g0 ==> - state_globals_approx s g` - (rw [state_globals_approx_def] + state_globals_approx s g +Proof + rw [state_globals_approx_def] \\ drule known_changed_globals_cases \\ disch_then drule \\ strip_tac THEN1 (metis_tac [state_globals_approx_def]) @@ -1500,17 +1663,19 @@ Theorem state_globals_approx_evaluate \\ metis_tac []) \\ strip_tac \\ fs [mglobals_disjoint_def, DISJOINT_ALT, mapped_globals_def, PULL_EXISTS] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem state_globals_approx_known_op_evaluate - `evaluate (xs,env,s0) = (res, s) /\ +Theorem state_globals_approx_known_op_evaluate: + evaluate (xs,env,s0) = (res, s) /\ known_op opn aargs g0 = (ea, g) /\ ssgc_free s0 /\ EVERY vsgc_free env /\ EVERY esgc_free xs /\ DISJOINT (mapped_globals s0.globals) (SET_OF_BAG (op_gbag opn)) /\ unique_set_globals [Op tr opn xs] s0.compile_oracle /\ state_globals_approx s g0 ==> - state_globals_approx s g` - (rw [state_globals_approx_def] + state_globals_approx s g +Proof + rw [state_globals_approx_def] \\ drule known_op_changed_globals_cases \\ disch_then drule \\ strip_tac THEN1 (metis_tac [state_globals_approx_def]) @@ -1522,38 +1687,46 @@ Theorem state_globals_approx_known_op_evaluate \\ metis_tac []) \\ strip_tac \\ fs [mglobals_disjoint_def, DISJOINT_ALT, mapped_globals_def, PULL_EXISTS] - \\ metis_tac []); - -Theorem elist_globals_first_n_exps_lemma - `!i k co. i ⋲ elist_globals (FST (SND (co k))) ==> - !n. k < n ==> i ⋲ elist_globals (FLAT (first_n_exps co n))` - (rw [] + \\ metis_tac [] +QED + +Theorem elist_globals_first_n_exps_lemma: + !i k co. i ⋲ elist_globals (FST (SND (co k))) ==> + !n. k < n ==> i ⋲ elist_globals (FLAT (first_n_exps co n)) +Proof + rw [] \\ `MEM (FST (SND (co k))) (first_n_exps co n)` by metis_tac [MEM_first_n_exps] - \\ fs [MEM_SPLIT, elist_globals_append]); - -Theorem elist_globals_first_n_exps_shift_seq_lemma - `!i k co. i ⋲ elist_globals (FST (SND (co k))) ==> - !m n. m < k /\ k < m + n ==> i ⋲ elist_globals (FLAT (first_n_exps (shift_seq m co) n))` - (rw [] + \\ fs [MEM_SPLIT, elist_globals_append] +QED + +Theorem elist_globals_first_n_exps_shift_seq_lemma: + !i k co. i ⋲ elist_globals (FST (SND (co k))) ==> + !m n. m < k /\ k < m + n ==> i ⋲ elist_globals (FLAT (first_n_exps (shift_seq m co) n)) +Proof + rw [] \\ irule elist_globals_first_n_exps_lemma \\ simp [shift_seq_def] - \\ qexists_tac `k - m` \\ simp []) - -Theorem elist_globals_first_n_exps_exists - `!i co n. i ⋲ elist_globals (FLAT (first_n_exps co n)) ==> - ?k. k < n /\ i ⋲ elist_globals (FST (SND (co k)))` - (Induct_on `n` THEN1 simp [first_n_exps_def] + \\ qexists_tac `k - m` \\ simp [] +QED + +Theorem elist_globals_first_n_exps_exists: + !i co n. i ⋲ elist_globals (FLAT (first_n_exps co n)) ==> + ?k. k < n /\ i ⋲ elist_globals (FST (SND (co k))) +Proof + Induct_on `n` THEN1 simp [first_n_exps_def] \\ rw [] \\ fs [ADD1, first_n_exps_shift_seq, elist_globals_append] THEN1 (fs [first_n_exps_def] \\ qexists_tac `0` \\ simp []) - \\ res_tac \\ qexists_tac `k + 1` \\ fs [shift_seq_def]); + \\ res_tac \\ qexists_tac `k + 1` \\ fs [shift_seq_def] +QED -Theorem oracle_gapprox_disjoint_Install - `!c co g0 eas g. +Theorem oracle_gapprox_disjoint_Install: + !c co g0 eas g. known c (FST (SND (co 0))) [] g0 = (eas, g) /\ unique_set_globals [] co /\ oracle_gapprox_disjoint g0 co ==> - oracle_gapprox_disjoint g (shift_seq 1 co)` - (rw [] + oracle_gapprox_disjoint g (shift_seq 1 co) +Proof + rw [] \\ rw [oracle_gapprox_disjoint_def, gapprox_disjoint_def, DISJOINT_ALT, domain_lookup, PULL_EXISTS] \\ drule known_changed_globals_cases @@ -1568,15 +1741,17 @@ Theorem oracle_gapprox_disjoint_Install \\ fs [o_DEF, shift_seq_def, ADD1] \\ metis_tac []) \\ fs [oracle_gapprox_disjoint_def, gapprox_disjoint_def, DISJOINT_ALT, domain_lookup, PULL_EXISTS] - \\ res_tac \\ simp [shift_seq_def]); + \\ res_tac \\ simp [shift_seq_def] +QED -Theorem oracle_gapprox_disjoint_shift_seq_unique_set_globals - `!c xs aenv g0 eas g s0 k. +Theorem oracle_gapprox_disjoint_shift_seq_unique_set_globals: + !c xs aenv g0 eas g s0 k. known c xs aenv g0 = (eas, g) /\ unique_set_globals xs s0.compile_oracle /\ oracle_gapprox_disjoint g0 s0.compile_oracle ==> - oracle_gapprox_disjoint g (shift_seq k s0.compile_oracle)` - (rw [] + oracle_gapprox_disjoint g (shift_seq k s0.compile_oracle) +Proof + rw [] \\ rw [oracle_gapprox_disjoint_def, gapprox_disjoint_def, DISJOINT_ALT, domain_lookup, PULL_EXISTS] \\ drule known_changed_globals_cases @@ -1590,23 +1765,26 @@ Theorem oracle_gapprox_disjoint_shift_seq_unique_set_globals \\ disch_then (qspec_then `k + n + 1` mp_tac) \\ simp [] \\ metis_tac []) \\ fs [oracle_gapprox_disjoint_def, gapprox_disjoint_def, DISJOINT_ALT, domain_lookup, PULL_EXISTS] - \\ res_tac \\ simp [shift_seq_def]); + \\ res_tac \\ simp [shift_seq_def] +QED (* essentially a duplicate of the above *) -Theorem oracle_gapprox_disjoint_lemma - `!xs env s0 res s c aenv g0 eas g. +Theorem oracle_gapprox_disjoint_lemma: + !xs env s0 res s c aenv g0 eas g. evaluate (xs,env,s0) = (res,s) /\ known c xs aenv g0 = (eas, g) /\ unique_set_globals xs s0.compile_oracle /\ oracle_gapprox_disjoint g0 s0.compile_oracle ==> - oracle_gapprox_disjoint g s.compile_oracle` - (rw [] \\ imp_res_tac evaluate_IMP_shift_seq - \\ metis_tac [oracle_gapprox_disjoint_shift_seq_unique_set_globals]); + oracle_gapprox_disjoint g s.compile_oracle +Proof + rw [] \\ imp_res_tac evaluate_IMP_shift_seq + \\ metis_tac [oracle_gapprox_disjoint_shift_seq_unique_set_globals] +QED val say = say0 "known_correct_approx"; -Theorem known_correct_approx - `!c xs aenv g0 eas g env extra s0:((val_approx num_map#'c,'ffi) closSem$state) res s. +Theorem known_correct_approx: + !c xs aenv g0 eas g env extra s0:((val_approx num_map#'c,'ffi) closSem$state) res s. known c xs aenv g0 = (eas, g) /\ evaluate (xs, env ++ extra, s0) = (res, s) /\ (*fv_max (LENGTH env) xs /\*) @@ -1619,8 +1797,9 @@ Theorem known_correct_approx EVERY val_approx_sgc_free aenv /\ globals_approx_sgc_free g0 ==> state_globals_approx s g /\ - !vs. res = Rval vs ==> LIST_REL val_approx_val (MAP SND eas) vs` - (ho_match_mp_tac known_ind \\ simp [known_def] + !vs. res = Rval vs ==> LIST_REL val_approx_val (MAP SND eas) vs +Proof + ho_match_mp_tac known_ind \\ simp [known_def] \\ rpt conj_tac \\ rpt (gen_tac ORELSE disch_then strip_assume_tac) \\ imp_res_tac evaluate_SING \\ rveq \\ imp_res_tac unique_set_globals_subexps @@ -2107,7 +2286,8 @@ Theorem known_correct_approx \\ disch_then match_mp_tac \\ simp [EVERY_GENLIST] \\ irule EVERY2_APPEND_suff \\ simp [] - \\ fs [case_eq_thms] \\ rveq \\ simp [LIST_REL_GENLIST])); + \\ fs [case_eq_thms] \\ rveq \\ simp [LIST_REL_GENLIST]) +QED (* code relation *) @@ -2119,9 +2299,11 @@ val exp_rel_def = Define ` globals_approx_sgc_free g0 /\ known (c with inline_factor := k) [e1] aenv g0 = ([(e2, apx)], g)`; -Theorem exp_rel_dec_inline_factor[simp] - `exp_rel (dec_inline_factor c) aenv g e1 e2 <=> exp_rel c aenv g e1 e2` - (simp [exp_rel_def, dec_inline_factor_def]); +Theorem exp_rel_dec_inline_factor[simp]: + exp_rel (dec_inline_factor c) aenv g e1 e2 <=> exp_rel c aenv g e1 e2 +Proof + simp [exp_rel_def, dec_inline_factor_def] +QED (* value relation *) @@ -2129,9 +2311,11 @@ val f_rel_def = Define ` f_rel c aenv g (n1, e1) (n2, e2) <=> n1 = n2 /\ exp_rel c (REPLICATE n1 Other ++ aenv) g e1 e2`; -Theorem v1_size_append - `!xs ys. closSem$v1_size (xs ++ ys) = v1_size xs + v1_size ys` - (Induct \\ fs [closSemTheory.v_size_def]); +Theorem v1_size_append: + !xs ys. closSem$v1_size (xs ++ ys) = v1_size xs + v1_size ys +Proof + Induct \\ fs [closSemTheory.v_size_def] +QED val v_rel_def = tDefine "v_rel" ` (v_rel c g (Number i) v <=> v = Number i) /\ @@ -2195,21 +2379,28 @@ val v_rel_app_def = Define ` (v_rel_app c g (Recclosure loc_opt pargs1 env1 funs1 i) v args1 <=> v_rel c g (Recclosure loc_opt pargs1 env1 funs1 i) v)`; -Theorem v_rel_app_NONE - `v_rel_app c g v1 v2 NONE = v_rel c g v1 v2` - (Cases_on `v1` \\ simp [v_rel_app_def] \\ metis_tac []); - -Theorem exp_rel_upd_inline_factor - `exp_rel (c with inline_factor := k) = exp_rel c` - (simp [FUN_EQ_THM, exp_rel_def]); - -Theorem f_rel_upd_inline_factor - `f_rel (c with inline_factor := k) = f_rel c` - (simp [FUN_EQ_THM, FORALL_PROD, f_rel_def, exp_rel_upd_inline_factor]); - -Theorem v_rel_upd_inline_factor - `!c. v_rel (c with inline_factor := k) = v_rel c` - (simp [FUN_EQ_THM] +Theorem v_rel_app_NONE: + v_rel_app c g v1 v2 NONE = v_rel c g v1 v2 +Proof + Cases_on `v1` \\ simp [v_rel_app_def] \\ metis_tac [] +QED + +Theorem exp_rel_upd_inline_factor: + exp_rel (c with inline_factor := k) = exp_rel c +Proof + simp [FUN_EQ_THM, exp_rel_def] +QED + +Theorem f_rel_upd_inline_factor: + f_rel (c with inline_factor := k) = f_rel c +Proof + simp [FUN_EQ_THM, FORALL_PROD, f_rel_def, exp_rel_upd_inline_factor] +QED + +Theorem v_rel_upd_inline_factor: + !c. v_rel (c with inline_factor := k) = v_rel c +Proof + simp [FUN_EQ_THM] \\ ho_match_mp_tac v_rel_ind \\ rw [] THEN1 (fs [LIST_REL_EL_EQN] \\ rw [] \\ metis_tac [MEM_EL]) THEN1 (simp [exp_rel_upd_inline_factor] @@ -2225,21 +2416,28 @@ Theorem v_rel_upd_inline_factor \\ asm_exists_tac \\ fs [] \\ `env2a ++ env2b = env2a ++ env2b` by simp [] \\ goal_assum (pop_assum o mp_then Any mp_tac) - \\ fs [LIST_REL_EL_EQN] \\ rw [] \\ metis_tac [MEM_EL])); - -Theorem v_rel_Block[simp] - `v_rel c g x (Block n ys) <=> - ?xs. x = Block n xs /\ LIST_REL (v_rel c g) xs ys` - (Cases_on `x` \\ fs [v_rel_def] \\ eq_tac \\ rw [] \\ metis_tac []); - -Theorem v_rel_Boolv[simp] - `(v_rel c g (Boolv b) v ⇔ v = Boolv b) ∧ - (v_rel c g v (Boolv b) ⇔ v = Boolv b)` - (simp [closSemTheory.Boolv_def] >> Cases_on `v` >> simp[] >> metis_tac[]); - -Theorem v_rel_Unit[simp] - `(v_rel c g Unit v ⇔ v = Unit) ∧ (v_rel c g v Unit ⇔ v = Unit)` - (simp[Unit_def] >> Cases_on `v` >> simp[] >> metis_tac[]) + \\ fs [LIST_REL_EL_EQN] \\ rw [] \\ metis_tac [MEM_EL]) +QED + +Theorem v_rel_Block[simp]: + v_rel c g x (Block n ys) <=> + ?xs. x = Block n xs /\ LIST_REL (v_rel c g) xs ys +Proof + Cases_on `x` \\ fs [v_rel_def] \\ eq_tac \\ rw [] \\ metis_tac [] +QED + +Theorem v_rel_Boolv[simp]: + (v_rel c g (Boolv b) v ⇔ v = Boolv b) ∧ + (v_rel c g v (Boolv b) ⇔ v = Boolv b) +Proof + simp [closSemTheory.Boolv_def] >> Cases_on `v` >> simp[] >> metis_tac[] +QED + +Theorem v_rel_Unit[simp]: + (v_rel c g Unit v ⇔ v = Unit) ∧ (v_rel c g v Unit ⇔ v = Unit) +Proof + simp[Unit_def] >> Cases_on `v` >> simp[] >> metis_tac[] +QED val v_rel_IMP_v_to_bytes_lemma = prove( ``!x y c g. @@ -2287,9 +2485,11 @@ val ref_rel_simps = save_thm("ref_rel_simps[simp]",LIST_CONJ [ SIMP_CONV (srw_ss()) [ref_rel_cases] ``ref_rel c g (ValueArray vs) x``, SIMP_CONV (srw_ss()) [ref_rel_cases] ``ref_rel c g (ByteArray b bs) x``]) -Theorem ref_rel_upd_inline_factor - `ref_rel (c with inline_factor := k) = ref_rel c` - (simp [FUN_EQ_THM, ref_rel_cases, v_rel_upd_inline_factor]); +Theorem ref_rel_upd_inline_factor: + ref_rel (c with inline_factor := k) = ref_rel c +Proof + simp [FUN_EQ_THM, ref_rel_cases, v_rel_upd_inline_factor] +QED val compile_inc_def = Define ` compile_inc c g (es,xs) = @@ -2307,17 +2507,20 @@ val state_rel_def = Define ` t.compile_oracle = state_co (compile_inc c) s.compile_oracle `; -Theorem state_rel_upd_inline_factor - `state_rel (c with inline_factor := k) = state_rel c` - (simp [FUN_EQ_THM] \\ rw [] +Theorem state_rel_upd_inline_factor: + state_rel (c with inline_factor := k) = state_rel c +Proof + simp [FUN_EQ_THM] \\ rw [] \\ eq_tac \\ strip_tac \\ fs [state_rel_def] \\ fs [v_rel_upd_inline_factor, ref_rel_upd_inline_factor] \\ simp [state_cc_def, state_co_def, LAMBDA_PROD, - compile_inc_def, reset_inline_factor_def]) + compile_inc_def, reset_inline_factor_def] +QED -Theorem v_rel_subspt - `!c g v1 v2 g'. v_rel c g v1 v2 ∧ subspt g g' ⇒ v_rel c g' v1 v2` - (ho_match_mp_tac v_rel_ind >> simp[PULL_EXISTS] >> rpt strip_tac +Theorem v_rel_subspt: + !c g v1 v2 g'. v_rel c g v1 v2 ∧ subspt g g' ⇒ v_rel c g' v1 v2 +Proof + ho_match_mp_tac v_rel_ind >> simp[PULL_EXISTS] >> rpt strip_tac >- (irule EVERY2_MEM_MONO >> imp_res_tac LIST_REL_LENGTH >> simp[FORALL_PROD, MEM_ZIP, PULL_EXISTS] >> qexists_tac `v_rel c g` >> simp[] >> metis_tac[MEM_EL]) @@ -2341,22 +2544,29 @@ Theorem v_rel_subspt rename1 `nn < LENGTH _` >> first_x_assum (qspec_then `nn` mp_tac) >> rename1 `f_rel _ _ _ (EL nn fns1) (EL nn fns2)` >> Cases_on `EL nn fns1` >> Cases_on `EL nn fns2` >> - simp[] >> simp[f_rel_def, exp_rel_def] >> metis_tac[subspt_trans])); - -Theorem v_rel_LIST_REL_subspt - `∀vs1 vs2. LIST_REL (v_rel c g) vs1 vs2 ⇒ - ∀g'. subspt g g' ⇒ LIST_REL (v_rel c g') vs1 vs2` - (Induct_on `LIST_REL` >> simp[] >> metis_tac[v_rel_subspt]); - -Theorem ref_rel_subspt - `!c g r1 r2 g'. ref_rel c g r1 r2 /\ subspt g g' ==> ref_rel c g' r1 r2` - (Cases_on `r1` \\ rw [] \\ metis_tac [v_rel_LIST_REL_subspt]); - -Theorem state_rel_subspt - `!c g s1 s2 g'. state_rel c g s1 s2 /\ subspt g g' ==> state_rel c g' s1 s2` - (rw [state_rel_def] + simp[] >> simp[f_rel_def, exp_rel_def] >> metis_tac[subspt_trans]) +QED + +Theorem v_rel_LIST_REL_subspt: + ∀vs1 vs2. LIST_REL (v_rel c g) vs1 vs2 ⇒ + ∀g'. subspt g g' ⇒ LIST_REL (v_rel c g') vs1 vs2 +Proof + Induct_on `LIST_REL` >> simp[] >> metis_tac[v_rel_subspt] +QED + +Theorem ref_rel_subspt: + !c g r1 r2 g'. ref_rel c g r1 r2 /\ subspt g g' ==> ref_rel c g' r1 r2 +Proof + Cases_on `r1` \\ rw [] \\ metis_tac [v_rel_LIST_REL_subspt] +QED + +Theorem state_rel_subspt: + !c g s1 s2 g'. state_rel c g s1 s2 /\ subspt g g' ==> state_rel c g' s1 s2 +Proof + rw [state_rel_def] THEN1 (irule LIST_REL_mono \\ metis_tac [OPTREL_MONO, v_rel_subspt]) - THEN1 (irule fmap_rel_mono \\ metis_tac [ref_rel_subspt])); + THEN1 (irule fmap_rel_mono \\ metis_tac [ref_rel_subspt]) +QED val co_every_Fn_vs_NONE_def = Define ` co_every_Fn_vs_NONE co = @@ -2365,14 +2575,17 @@ val co_every_Fn_vs_NONE_def = Define ` every_Fn_vs_NONE (MAP (SND o SND) aux) `; -Theorem co_every_Fn_vs_NONE_shift_seq - `!co. co_every_Fn_vs_NONE co ==> !n. co_every_Fn_vs_NONE (shift_seq n co)` - (rpt strip_tac \\ fs [co_every_Fn_vs_NONE_def, shift_seq_def] \\ metis_tac []) - -Theorem state_rel_co_elist_globals - `state_rel c g s t /\ ssgc_free s /\ oracle_state_sgc_free s.compile_oracle ==> - elist_globals (FST (SND (t.compile_oracle n))) <= elist_globals (FST (SND (s.compile_oracle n)))` - (strip_tac \\ fs [state_rel_def] +Theorem co_every_Fn_vs_NONE_shift_seq: + !co. co_every_Fn_vs_NONE co ==> !n. co_every_Fn_vs_NONE (shift_seq n co) +Proof + rpt strip_tac \\ fs [co_every_Fn_vs_NONE_def, shift_seq_def] \\ metis_tac [] +QED + +Theorem state_rel_co_elist_globals: + state_rel c g s t /\ ssgc_free s /\ oracle_state_sgc_free s.compile_oracle ==> + elist_globals (FST (SND (t.compile_oracle n))) <= elist_globals (FST (SND (s.compile_oracle n))) +Proof + strip_tac \\ fs [state_rel_def] \\ fs [state_co_def] \\ rpt (pairarg_tac \\ fs []) \\ rename1 `compile_inc _ _ p1 = (_, p2)` @@ -2386,22 +2599,26 @@ Theorem state_rel_co_elist_globals \\ fs [oracle_state_sgc_free_def] \\ qpat_x_assum `!n. globals_approx_sgc_free _` (qspec_then `nn` mp_tac) \\ simp [] \\ fs [ssgc_free_def] - \\ qpat_x_assum `!n e a. _` (qspec_then `nn` mp_tac) \\ simp []); - -Theorem state_rel_first_n_exps - `state_rel c g s t /\ ssgc_free s /\ oracle_state_sgc_free s.compile_oracle ==> - elist_globals (FLAT (first_n_exps t.compile_oracle n)) <= elist_globals (FLAT (first_n_exps s.compile_oracle n))` - (strip_tac + \\ qpat_x_assum `!n e a. _` (qspec_then `nn` mp_tac) \\ simp [] +QED + +Theorem state_rel_first_n_exps: + state_rel c g s t /\ ssgc_free s /\ oracle_state_sgc_free s.compile_oracle ==> + elist_globals (FLAT (first_n_exps t.compile_oracle n)) <= elist_globals (FLAT (first_n_exps s.compile_oracle n)) +Proof + strip_tac \\ imp_res_tac state_rel_co_elist_globals \\ fs [first_n_exps_def] \\ Induct_on `n` \\ fs [GENLIST] \\ simp [SNOC_APPEND, elist_globals_append] - \\ simp [SUB_BAG_UNION]); - -Theorem state_rel_unique_set_globals - `!xs. state_rel c g s t /\ ssgc_free s /\ oracle_state_sgc_free s.compile_oracle /\ - unique_set_globals xs s.compile_oracle ==> unique_set_globals xs t.compile_oracle` - (rpt strip_tac + \\ simp [SUB_BAG_UNION] +QED + +Theorem state_rel_unique_set_globals: + !xs. state_rel c g s t /\ ssgc_free s /\ oracle_state_sgc_free s.compile_oracle /\ + unique_set_globals xs s.compile_oracle ==> unique_set_globals xs t.compile_oracle +Proof + rpt strip_tac \\ imp_res_tac state_rel_first_n_exps \\ fs [unique_set_globals_def] \\ fs [elist_globals_append, BAG_ALL_DISTINCT_BAG_UNION] @@ -2409,13 +2626,16 @@ Theorem state_rel_unique_set_globals \\ rpt (qpat_x_assum `!n. _` (qspec_then `n` assume_tac)) \\ fs [] \\ imp_res_tac SUB_BAG_DIFF_EQ \\ pop_assum (fn th => fs [Once th]) - \\ fs [BAG_ALL_DISTINCT_BAG_UNION]) + \\ fs [BAG_ALL_DISTINCT_BAG_UNION] +QED -Theorem state_rel_get_global_IMP - `!c g s t n v1. state_rel c g s t /\ get_global n s.globals = SOME (SOME v1) ==> - ?v2. get_global n t.globals = SOME (SOME v2) /\ v_rel c g v1 v2` - (rw [state_rel_def, get_global_def, LIST_REL_EL_EQN] - \\ metis_tac [OPTREL_SOME]); +Theorem state_rel_get_global_IMP: + !c g s t n v1. state_rel c g s t /\ get_global n s.globals = SOME (SOME v1) ==> + ?v2. get_global n t.globals = SOME (SOME v2) /\ v_rel c g v1 v2 +Proof + rw [state_rel_def, get_global_def, LIST_REL_EL_EQN] + \\ metis_tac [OPTREL_SOME] +QED val do_app_lemma = Q.prove( `!c g s t xs ys opp. state_rel c g s t /\ LIST_REL (v_rel c g) xs ys ==> @@ -2437,21 +2657,23 @@ val do_app_lemma = Q.prove( \\ fs [FAPPLY_FUPDATE_THM] \\ rw [] \\ fs [ref_rel_cases]); -Theorem evaluate_app_exact_rw - `args <> [] /\ num_args = LENGTH args +Theorem evaluate_app_exact_rw: + args <> [] /\ num_args = LENGTH args ==> evaluate_app (SOME loc) (Closure (SOME loc) [] env num_args body) args s = if s.clock < LENGTH args then (Rerr (Rabort Rtimeout_error), s with clock := 0) else - evaluate ([body], args ++ env, dec_clock num_args s)` - (strip_tac + evaluate ([body], args ++ env, dec_clock num_args s) +Proof + strip_tac \\ simp [evaluate_app_rw, dest_closure_def, check_loc_def] \\ fs [NOT_NIL_EQ_LENGTH_NOT_0] \\ IF_CASES_TAC \\ simp [] \\ simp [TAKE_LENGTH_ID_rwt, LENGTH_REVERSE] \\ simp [DROP_LENGTH_TOO_LONG] - \\ EVERY_CASE_TAC \\ simp []); + \\ EVERY_CASE_TAC \\ simp [] +QED val v_caseT = v_case_eq |> INST_TYPE [alpha |-> bool] |> Q.INST [`v` |-> `T`] |> REWRITE_RULE [] @@ -2475,36 +2697,45 @@ val loptrel_arg1_NONE = save_thm( loptrel_def |> SPEC_ALL |> Q.INST [`lopt1` |-> `NONE`] |> SIMP_RULE (srw_ss()) [opt_caseT, v_caseT]) -Theorem dest_closure_SOME_IMP - `dest_closure max_app loc_opt f2 xs = SOME x ==> +Theorem dest_closure_SOME_IMP: + dest_closure max_app loc_opt f2 xs = SOME x ==> (?loc arg_env clo_env num_args e. f2 = Closure loc arg_env clo_env num_args e) \/ - (?loc arg_env clo_env fns i. f2 = Recclosure loc arg_env clo_env fns i)` - (fs [dest_closure_def,case_eq_thms] \\ rw [] \\ fs []); - -Theorem state_globals_approx_subspt - `!g0 g s. subspt g0 g /\ state_globals_approx s g ==> - state_globals_approx s g0` - (rw [state_globals_approx_def] \\ res_tac - \\ fs [subspt_def, domain_lookup]); - -Theorem oracle_gapprox_disjoint_subspt - `!g0 g co. subspt g0 g /\ oracle_gapprox_disjoint g co ==> - oracle_gapprox_disjoint g0 co` - (rw [oracle_gapprox_disjoint_def, gapprox_disjoint_def, DISJOINT_ALT] - \\ fs [subspt_def, domain_lookup]); - -Theorem decide_inline_inlD_LetInline_sgc_free - `!c a lopt n body. decide_inline c a lopt n = inlD_LetInline body /\ val_approx_sgc_free a ==> set_globals body = {||}` - (rw [] \\ fs [decide_inline_def, va_case_eq, bool_case_eq] - \\ rveq \\ fs []); - -Theorem known_op_subspt - `!opn aargs g0 a g. + (?loc arg_env clo_env fns i. f2 = Recclosure loc arg_env clo_env fns i) +Proof + fs [dest_closure_def,case_eq_thms] \\ rw [] \\ fs [] +QED + +Theorem state_globals_approx_subspt: + !g0 g s. subspt g0 g /\ state_globals_approx s g ==> + state_globals_approx s g0 +Proof + rw [state_globals_approx_def] \\ res_tac + \\ fs [subspt_def, domain_lookup] +QED + +Theorem oracle_gapprox_disjoint_subspt: + !g0 g co. subspt g0 g /\ oracle_gapprox_disjoint g co ==> + oracle_gapprox_disjoint g0 co +Proof + rw [oracle_gapprox_disjoint_def, gapprox_disjoint_def, DISJOINT_ALT] + \\ fs [subspt_def, domain_lookup] +QED + +Theorem decide_inline_inlD_LetInline_sgc_free: + !c a lopt n body. decide_inline c a lopt n = inlD_LetInline body /\ val_approx_sgc_free a ==> set_globals body = {||} +Proof + rw [] \\ fs [decide_inline_def, va_case_eq, bool_case_eq] + \\ rveq \\ fs [] +QED + +Theorem known_op_subspt: + !opn aargs g0 a g. known_op opn aargs g0 = (a, g) /\ BAG_DISJOINT (BAG_OF_SET (domain g0)) (op_gbag opn) ==> BAG_OF_SET (domain g) ≤ BAG_OF_SET (domain g0) ⊎ op_gbag opn /\ - subspt g0 g` - (Cases_on `opn` \\ fs [known_op_def] + subspt g0 g +Proof + Cases_on `opn` \\ fs [known_op_def] \\ rpt (gen_tac ORELSE disch_then strip_assume_tac) THEN1 fs [bool_case_eq, option_case_eq] THEN1 @@ -2516,16 +2747,18 @@ Theorem known_op_subspt \\ rw [SUB_BAG, BAG_INN, BAG_OF_SET] \\ Cases_on `x = n ∨ x ∈ domain g0` \\ fs [] \\ rveq \\ fs [BAG_UNION, BAG_INSERT, domain_lookup]) - THEN1 fs [list_case_eq, va_case_eq, bool_case_eq]); + THEN1 fs [list_case_eq, va_case_eq, bool_case_eq] +QED -Theorem known_subspt - `!c xs aenv g0 eas g. +Theorem known_subspt: + !c xs aenv g0 eas g. known c xs aenv g0 = (eas, g) /\ EVERY esgc_free xs /\ EVERY val_approx_sgc_free aenv /\ globals_approx_sgc_free g0 /\ BAG_ALL_DISTINCT (BAG_OF_SET (domain g0) ⊎ elist_globals xs) ==> BAG_OF_SET (domain g) ≤ BAG_OF_SET (domain g0) ⊎ elist_globals xs /\ - subspt g0 g` - (ho_match_mp_tac known_ind + subspt g0 g +Proof + ho_match_mp_tac known_ind \\ rpt conj_tac \\ rpt (gen_tac ORELSE disch_then strip_assume_tac) \\ fs [known_def] \\ rpt (pairarg_tac \\ fs []) \\ rveq @@ -2593,21 +2826,23 @@ Theorem known_subspt THEN1 (last_x_assum irule \\ CASE_TAC THEN1 simp [EVERY_REPLICATE] - \\ simp [clos_gen_noinline_eq, EVERY_GENLIST])); + \\ simp [clos_gen_noinline_eq, EVERY_GENLIST]) +QED (* Set globals in all future installs is disjoint from currently mapped globals. *) val state_oracle_mglobals_disjoint_def = Define ` state_oracle_mglobals_disjoint s <=> !n. mglobals_disjoint s.globals (FST (SND (s.compile_oracle n)))`; -Theorem state_oracle_mglobals_disjoint_evaluate_suff - `!xs env s0 res s. evaluate (xs, env, s0) = (res, s) /\ +Theorem state_oracle_mglobals_disjoint_evaluate_suff: + !xs env s0 res s. evaluate (xs, env, s0) = (res, s) /\ ssgc_free s0 /\ EVERY esgc_free xs /\ EVERY vsgc_free env /\ unique_set_globals xs s0.compile_oracle /\ mglobals_disjoint s0.globals xs /\ state_oracle_mglobals_disjoint s0 ==> - state_oracle_mglobals_disjoint s` - (rw [state_oracle_mglobals_disjoint_def, mglobals_disjoint_def, DISJOINT_ALT] + state_oracle_mglobals_disjoint s +Proof + rw [state_oracle_mglobals_disjoint_def, mglobals_disjoint_def, DISJOINT_ALT] \\ drule evaluate_changed_globals \\ simp [] \\ strip_tac \\ fs [mglobals_extend_def] \\ imp_res_tac SUBSET_THM @@ -2627,7 +2862,8 @@ Theorem state_oracle_mglobals_disjoint_evaluate_suff \\ qmatch_assum_abbrev_tac`x <: elist_globals (FLAT (first_n_exps co m))` \\ last_x_assum(qspec_then`(n+1)+m`mp_tac) \\ simp[first_n_exps_shift_seq, elist_globals_append, BAG_ALL_DISTINCT_BAG_UNION, BAG_DISJOINT_BAG_IN] - \\ rw[] \\ metis_tac[])); + \\ rw[] \\ metis_tac[]) +QED val say = say0 "known_correct0"; @@ -4171,8 +4407,8 @@ val known_correct0 = Q.prove( \\ fs [CONV_RULE (LHS_CONV SYM_CONV) REVERSE_EQ_NIL, DROP_NIL] \\ simp [DROP_LENGTH_TOO_LONG]))))); -Theorem semantics_known - `semantics (ffi:'ffi ffi_state) max_app FEMPTY co +Theorem semantics_known: + semantics (ffi:'ffi ffi_state) max_app FEMPTY co (state_cc (compile_inc c) cc) xs <> Fail ==> (!n. SND (SND (co n)) = []) /\ (!n. fv_max 0 (FST (SND (co n)))) /\ @@ -4190,8 +4426,9 @@ Theorem semantics_known semantics (ffi:'ffi ffi_state) max_app FEMPTY (state_co (compile_inc c) co) cc (MAP FST eas) = semantics (ffi:'ffi ffi_state) max_app FEMPTY - co (state_cc (compile_inc c) cc) xs` - (strip_tac + co (state_cc (compile_inc c) cc) xs +Proof + strip_tac \\ ho_match_mp_tac IMP_semantics_eq \\ fs [] \\ fs [eval_sim_def] \\ rw [] \\ drule (CONJUNCT1 known_correct0) @@ -4215,32 +4452,40 @@ Theorem semantics_known \\ qexists_tac `0` \\ simp [] \\ fs [state_rel_def] \\ Cases_on `res1` \\ fs [] - \\ Cases_on `e` \\ fs []); + \\ Cases_on `e` \\ fs [] +QED -Theorem code_locs_mk_Ticks[simp] - `∀a b c d. code_locs [mk_Ticks a b c d] = code_locs [d]` - (recInduct mk_Ticks_ind \\ rw[] +Theorem code_locs_mk_Ticks[simp]: + ∀a b c d. code_locs [mk_Ticks a b c d] = code_locs [d] +Proof + recInduct mk_Ticks_ind \\ rw[] \\ rw[Once mk_Ticks_def] - \\ rw[code_locs_def]); + \\ rw[code_locs_def] +QED -Theorem contains_closures_code_locs - `∀es. ¬contains_closures es ⇒ code_locs es = []` - (recInduct contains_closures_ind +Theorem contains_closures_code_locs: + ∀es. ¬contains_closures es ⇒ code_locs es = [] +Proof + recInduct contains_closures_ind \\ rw[contains_closures_def] - \\ rw[code_locs_def]); + \\ rw[code_locs_def] +QED -Theorem code_locs_decide_inline - `decide_inline a b c d = inlD_LetInline e ⇒ code_locs [e] = []` - (rw[decide_inline_def] +Theorem code_locs_decide_inline: + decide_inline a b c d = inlD_LetInline e ⇒ code_locs [e] = [] +Proof + rw[decide_inline_def] \\ fs[CaseEq"val_approx",bool_case_eq] \\ rveq - \\ imp_res_tac contains_closures_code_locs); + \\ imp_res_tac contains_closures_code_locs +QED -Theorem known_code_locs_bag - `!c xs aenv g0 eas g. +Theorem known_code_locs_bag: + !c xs aenv g0 eas g. known c xs aenv g0 = (eas, g) ==> - LIST_TO_BAG (code_locs (MAP FST eas)) ≤ LIST_TO_BAG (code_locs xs)` - (recInduct known_ind + LIST_TO_BAG (code_locs (MAP FST eas)) ≤ LIST_TO_BAG (code_locs xs) +Proof + recInduct known_ind \\ rw[known_def] \\ rw[] \\ rpt(pairarg_tac \\ fs[]) \\ rw[] \\ imp_res_tac known_sing_EQ_E \\ rw [] @@ -4272,27 +4517,32 @@ Theorem known_code_locs_bag \\ rpt(pairarg_tac \\ fs[]) \\ imp_res_tac known_LENGTH_EQ_E \\ fs[LENGTH_EQ_NUM_compute] - \\ rveq \\ fs[]); + \\ rveq \\ fs[] +QED -Theorem compile_code_locs_bag - `clos_known$compile kc es = (kc', es') ⇒ - LIST_TO_BAG (code_locs es') ≤ LIST_TO_BAG (code_locs es)` - (Cases_on`kc` +Theorem compile_code_locs_bag: + clos_known$compile kc es = (kc', es') ⇒ + LIST_TO_BAG (code_locs es') ≤ LIST_TO_BAG (code_locs es) +Proof + Cases_on`kc` \\ rw[clos_knownTheory.compile_def] \\ pairarg_tac \\ fs[] \\ rw [] \\ fs [clos_letopProofTheory.code_locs_let_op, clos_ticksProofTheory.code_locs_remove_ticks] \\ imp_res_tac known_code_locs_bag \\ rw[] - \\ fs[clos_fvsTheory.compile_def]); + \\ fs[clos_fvsTheory.compile_def] +QED -Theorem compile_LENGTH - `clos_known$compile kc es = (kc', es') ⇒ LENGTH es' = LENGTH es` - (Cases_on`kc` \\ rw[compile_def] +Theorem compile_LENGTH: + clos_known$compile kc es = (kc', es') ⇒ LENGTH es' = LENGTH es +Proof + Cases_on`kc` \\ rw[compile_def] \\ pairarg_tac \\ fs[] \\ rw[] \\ fs [clos_letopTheory.LENGTH_let_op,clos_ticksTheory.LENGTH_remove_ticks, clos_fvsTheory.compile_def] \\ imp_res_tac known_LENGTH_EQ_E - \\ fs[clos_fvsProofTheory.LENGTH_remove_fvs]); + \\ fs[clos_fvsProofTheory.LENGTH_remove_fvs] +QED val syntax_ok_def = Define` syntax_ok xs ⇔ @@ -4331,13 +4581,15 @@ val known_co_def = Define ` : 'b clos_co)) : 'b clos_co)) | NONE => (state_co (CURRY I) co) : 'b clos_co)`; -Theorem FST_known_co - `FST (known_co kc co n) = SND (FST (co n))` - (rw[known_co_def] \\ CASE_TAC - \\ simp[backendPropsTheory.FST_state_co]); +Theorem FST_known_co: + FST (known_co kc co n) = SND (FST (co n)) +Proof + rw[known_co_def] \\ CASE_TAC + \\ simp[backendPropsTheory.FST_state_co] +QED -Theorem semantics_compile - `closSem$semantics ffi max_app FEMPTY co cc1 xs ≠ Fail ∧ +Theorem semantics_compile: + closSem$semantics ffi max_app FEMPTY co cc1 xs ≠ Fail ∧ (cc1 = known_cc known_conf cc) ∧ (co1 = known_co known_conf co) ∧ (compile known_conf xs = (known_conf', es)) ∧ @@ -4346,8 +4598,9 @@ Theorem semantics_compile FST (FST (co 0)) = (THE known_conf').val_approx_spt) ⇒ semantics ffi max_app FEMPTY co1 cc es = - semantics ffi max_app FEMPTY co cc1 xs` - (simp [known_co_def,known_cc_def] + semantics ffi max_app FEMPTY co cc1 xs +Proof + simp [known_co_def,known_cc_def] \\ strip_tac \\ Cases_on`known_conf` \\ fs[compile_def] >- ( match_mp_tac semantics_CURRY_I \\ fs[] ) @@ -4430,23 +4683,28 @@ Theorem semantics_compile \\ first_x_assum (qspec_then `n` assume_tac) \\ fs [] \\ qmatch_assum_abbrev_tac `SND pp = []` \\ Cases_on `pp` \\ fs [clos_ticksProofTheory.compile_inc_def] - \\ fs []); + \\ fs [] +QED -Theorem every_Fn_SOME_mk_Ticks - `∀t tc n e. every_Fn_SOME [e] ⇒ every_Fn_SOME [mk_Ticks t tc n e]` - (recInduct mk_Ticks_ind +Theorem every_Fn_SOME_mk_Ticks: + ∀t tc n e. every_Fn_SOME [e] ⇒ every_Fn_SOME [mk_Ticks t tc n e] +Proof + recInduct mk_Ticks_ind \\ rw[Once mk_Ticks_def] \\ rw[Once mk_Ticks_def] \\ fs[] - \\ rw[Once mk_Ticks_def]); + \\ rw[Once mk_Ticks_def] +QED -Theorem every_Fn_vs_NONE_mk_Ticks - `∀t tc n e. every_Fn_vs_NONE [e] ⇒ every_Fn_vs_NONE [mk_Ticks t tc n e]` - (recInduct mk_Ticks_ind +Theorem every_Fn_vs_NONE_mk_Ticks: + ∀t tc n e. every_Fn_vs_NONE [e] ⇒ every_Fn_vs_NONE [mk_Ticks t tc n e] +Proof + recInduct mk_Ticks_ind \\ rw[Once mk_Ticks_def] \\ rw[Once mk_Ticks_def] \\ fs[] - \\ rw[Once mk_Ticks_def]); + \\ rw[Once mk_Ticks_def] +QED val val_approx_every_Fn_SOME_def = tDefine"val_approx_every_Fn_SOME"` (val_approx_every_Fn_SOME (Tuple _ vs) ⇔ EVERY val_approx_every_Fn_SOME vs) ∧ @@ -4457,33 +4715,38 @@ val val_approx_every_Fn_SOME_def = tDefine"val_approx_every_Fn_SOME"` \\ rw[] \\ res_tac \\ rw[]); val _ = export_rewrites["val_approx_every_Fn_SOME_def"]; -Theorem val_approx_every_Fn_SOME_merge - `∀a b. val_approx_every_Fn_SOME a ∧ val_approx_every_Fn_SOME b ⇒ - val_approx_every_Fn_SOME (merge a b)` - (recInduct merge_ind +Theorem val_approx_every_Fn_SOME_merge: + ∀a b. val_approx_every_Fn_SOME a ∧ val_approx_every_Fn_SOME b ⇒ + val_approx_every_Fn_SOME (merge a b) +Proof + recInduct merge_ind \\ rw[merge_def] \\ fs[EVERY_MEM,MAP2_MAP,MEM_MAP] \\ rw[] \\ imp_res_tac MEM_ZIP_MEM_MAP - \\ rfs[UNCURRY]); - -Theorem decide_inline_every_Fn_SOME - `val_approx_every_Fn_SOME b ∧ decide_inline a b c d = inlD_LetInline e ⇒ - every_Fn_SOME [e]` - (rw[decide_inline_def,CaseEq"val_approx",CaseEq"bool"] - \\ fs[]); + \\ rfs[UNCURRY] +QED + +Theorem decide_inline_every_Fn_SOME: + val_approx_every_Fn_SOME b ∧ decide_inline a b c d = inlD_LetInline e ⇒ + every_Fn_SOME [e] +Proof + rw[decide_inline_def,CaseEq"val_approx",CaseEq"bool"] + \\ fs[] +QED val globals_approx_every_Fn_SOME_def = Define` globals_approx_every_Fn_SOME g = (∀c d. lookup c g = SOME d ⇒ val_approx_every_Fn_SOME d)`; -Theorem known_op_every_Fn_SOME - `known_op op x y = (a,b) ∧ +Theorem known_op_every_Fn_SOME: + known_op op x y = (a,b) ∧ EVERY val_approx_every_Fn_SOME x ∧ globals_approx_every_Fn_SOME y ⇒ val_approx_every_Fn_SOME a ∧ - globals_approx_every_Fn_SOME b` - (Cases_on`op` \\ fs[known_op_def] + globals_approx_every_Fn_SOME b +Proof + Cases_on`op` \\ fs[known_op_def] \\ rw[] \\ fsrw_tac[ETA_ss][CaseEq"prod",CaseEq"option",NULL_EQ,CaseEq"list",CaseEq"val_approx",CaseEq"bool"] \\ rw[] \\ fs[] \\ fs[EVERY_MEM,MEM_EL,PULL_EXISTS,globals_approx_every_Fn_SOME_def,lookup_insert] @@ -4491,24 +4754,28 @@ Theorem known_op_every_Fn_SOME \\ TRY ( match_mp_tac val_approx_every_Fn_SOME_merge \\ fs[] ) \\ last_x_assum match_mp_tac \\ fs[] \\ TRY asm_exists_tac \\ fs[] - \\ intLib.COOPER_TAC); - -Theorem clos_gen_no_inline_every_Fn_SOME - `!(xs:(num,closLang$exp) alist) n x. - EVERY val_approx_every_Fn_SOME (clos_gen_noinline x n xs)` - (Induct \\ rw [clos_gen_noinline_def] + \\ intLib.COOPER_TAC +QED + +Theorem clos_gen_no_inline_every_Fn_SOME: + !(xs:(num,closLang$exp) alist) n x. + EVERY val_approx_every_Fn_SOME (clos_gen_noinline x n xs) +Proof + Induct \\ rw [clos_gen_noinline_def] \\ PairCases_on `h` - \\ rw [clos_gen_noinline_def]) + \\ rw [clos_gen_noinline_def] +QED -Theorem known_every_Fn_SOME - `∀a b c d. +Theorem known_every_Fn_SOME: + ∀a b c d. every_Fn_SOME b ∧ EVERY val_approx_every_Fn_SOME c ∧ globals_approx_every_Fn_SOME d ⇒ every_Fn_SOME (MAP FST (FST (known a b c d))) ∧ EVERY val_approx_every_Fn_SOME (MAP SND (FST (known a b c d))) ∧ - globals_approx_every_Fn_SOME (SND (known a b c d))` - (recInduct known_ind + globals_approx_every_Fn_SOME (SND (known a b c d)) +Proof + recInduct known_ind \\ rw[known_def] \\ rpt(pairarg_tac \\ fs[]) \\ imp_res_tac known_sing_EQ_E \\ rveq \\ fs[] @@ -4553,7 +4820,8 @@ Theorem known_every_Fn_SOME \\ first_x_assum drule \\ rw [] \\ rename1 `known c [pp] qq` \\ Cases_on `known c [pp] qq g` - \\ imp_res_tac known_sing_EQ_E \\ fs []); + \\ imp_res_tac known_sing_EQ_E \\ fs [] +QED val val_approx_every_Fn_vs_NONE_def = tDefine"val_approx_every_Fn_vs_NONE"` (val_approx_every_Fn_vs_NONE (Tuple _ vs) ⇔ EVERY val_approx_every_Fn_vs_NONE vs) ∧ @@ -4564,33 +4832,38 @@ val val_approx_every_Fn_vs_NONE_def = tDefine"val_approx_every_Fn_vs_NONE"` \\ rw[] \\ res_tac \\ rw[]); val _ = export_rewrites["val_approx_every_Fn_vs_NONE_def"]; -Theorem val_approx_every_Fn_vs_NONE_merge - `∀a b. val_approx_every_Fn_vs_NONE a ∧ val_approx_every_Fn_vs_NONE b ⇒ - val_approx_every_Fn_vs_NONE (merge a b)` - (recInduct clos_knownTheory.merge_ind +Theorem val_approx_every_Fn_vs_NONE_merge: + ∀a b. val_approx_every_Fn_vs_NONE a ∧ val_approx_every_Fn_vs_NONE b ⇒ + val_approx_every_Fn_vs_NONE (merge a b) +Proof + recInduct clos_knownTheory.merge_ind \\ rw[clos_knownTheory.merge_def] \\ fs[EVERY_MEM,MAP2_MAP,MEM_MAP] \\ rw[] \\ imp_res_tac MEM_ZIP_MEM_MAP - \\ rfs[UNCURRY]); - -Theorem decide_inline_every_Fn_vs_NONE - `val_approx_every_Fn_vs_NONE b ∧ decide_inline a b c d = inlD_LetInline e ⇒ - every_Fn_vs_NONE [e]` - (rw[clos_knownTheory.decide_inline_def,CaseEq"val_approx",CaseEq"bool"] - \\ fs[]); + \\ rfs[UNCURRY] +QED + +Theorem decide_inline_every_Fn_vs_NONE: + val_approx_every_Fn_vs_NONE b ∧ decide_inline a b c d = inlD_LetInline e ⇒ + every_Fn_vs_NONE [e] +Proof + rw[clos_knownTheory.decide_inline_def,CaseEq"val_approx",CaseEq"bool"] + \\ fs[] +QED val globals_approx_every_Fn_vs_NONE_def = Define` globals_approx_every_Fn_vs_NONE g = (∀c d. lookup c g = SOME d ⇒ val_approx_every_Fn_vs_NONE d)`; -Theorem known_op_every_Fn_vs_NONE - `known_op op x y = (a,b) ∧ +Theorem known_op_every_Fn_vs_NONE: + known_op op x y = (a,b) ∧ EVERY val_approx_every_Fn_vs_NONE x ∧ globals_approx_every_Fn_vs_NONE y ⇒ val_approx_every_Fn_vs_NONE a ∧ - globals_approx_every_Fn_vs_NONE b` - (Cases_on`op` \\ fs[clos_knownTheory.known_op_def] + globals_approx_every_Fn_vs_NONE b +Proof + Cases_on`op` \\ fs[clos_knownTheory.known_op_def] \\ rw[] \\ fsrw_tac[ETA_ss][CaseEq"prod",CaseEq"option",NULL_EQ,CaseEq"list",CaseEq"val_approx",CaseEq"bool"] \\ rw[] \\ fs[] \\ fs[EVERY_MEM,MEM_EL,PULL_EXISTS,globals_approx_every_Fn_vs_NONE_def,lookup_insert] @@ -4598,24 +4871,28 @@ Theorem known_op_every_Fn_vs_NONE \\ TRY ( match_mp_tac val_approx_every_Fn_vs_NONE_merge \\ fs[] ) \\ last_x_assum match_mp_tac \\ fs[] \\ TRY asm_exists_tac \\ fs[] - \\ intLib.COOPER_TAC); - -Theorem clos_gen_no_inline_every_Fn_vs_NONE - `!(xs:(num,closLang$exp) alist) n x. - EVERY val_approx_every_Fn_vs_NONE (clos_gen_noinline x n xs)` - (Induct \\ rw [clos_knownTheory.clos_gen_noinline_def] + \\ intLib.COOPER_TAC +QED + +Theorem clos_gen_no_inline_every_Fn_vs_NONE: + !(xs:(num,closLang$exp) alist) n x. + EVERY val_approx_every_Fn_vs_NONE (clos_gen_noinline x n xs) +Proof + Induct \\ rw [clos_knownTheory.clos_gen_noinline_def] \\ PairCases_on `h` - \\ rw [clos_knownTheory.clos_gen_noinline_def]); + \\ rw [clos_knownTheory.clos_gen_noinline_def] +QED -Theorem known_every_Fn_vs_NONE - `∀a b c d. +Theorem known_every_Fn_vs_NONE: + ∀a b c d. every_Fn_vs_NONE b ∧ EVERY val_approx_every_Fn_vs_NONE c ∧ globals_approx_every_Fn_vs_NONE d ⇒ every_Fn_vs_NONE (MAP FST (FST (known a b c d))) ∧ EVERY val_approx_every_Fn_vs_NONE (MAP SND (FST (known a b c d))) ∧ - globals_approx_every_Fn_vs_NONE (SND (known a b c d))` - (recInduct clos_knownTheory.known_ind + globals_approx_every_Fn_vs_NONE (SND (known a b c d)) +Proof + recInduct clos_knownTheory.known_ind \\ rw[clos_knownTheory.known_def] \\ rpt(pairarg_tac \\ fs[]) \\ imp_res_tac clos_knownTheory.known_sing_EQ_E \\ rveq \\ fs[] @@ -4664,17 +4941,19 @@ Theorem known_every_Fn_vs_NONE \\ first_x_assum drule \\ fs [MEM_REPLICATE_EQ] \\ rw [] \\ rename1 `known c [pp] qq` \\ Cases_on `known c [pp] qq g` - \\ imp_res_tac clos_knownTheory.known_sing_EQ_E \\ fs []); + \\ imp_res_tac clos_knownTheory.known_sing_EQ_E \\ fs [] +QED -Theorem known_every_Fn_vs_NONE - `∀a b c d. +Theorem known_every_Fn_vs_NONE: + ∀a b c d. every_Fn_vs_NONE b ∧ EVERY val_approx_every_Fn_vs_NONE c ∧ globals_approx_every_Fn_vs_NONE d ⇒ every_Fn_vs_NONE (MAP FST (FST (known a b c d))) ∧ EVERY val_approx_every_Fn_vs_NONE (MAP SND (FST (known a b c d))) ∧ - globals_approx_every_Fn_vs_NONE (SND (known a b c d))` - (recInduct clos_knownTheory.known_ind + globals_approx_every_Fn_vs_NONE (SND (known a b c d)) +Proof + recInduct clos_knownTheory.known_ind \\ rw[clos_knownTheory.known_def] \\ rpt(pairarg_tac \\ fs[]) \\ imp_res_tac clos_knownTheory.known_sing_EQ_E \\ rveq \\ fs[] @@ -4723,7 +5002,8 @@ Theorem known_every_Fn_vs_NONE \\ first_x_assum drule \\ fs [MEM_REPLICATE_EQ] \\ rw [] \\ rename1 `known c [pp] qq` \\ Cases_on `known c [pp] qq g` - \\ imp_res_tac clos_knownTheory.known_sing_EQ_E \\ fs []); + \\ imp_res_tac clos_knownTheory.known_sing_EQ_E \\ fs [] +QED (* no_Labels *) @@ -4739,32 +5019,37 @@ val val_approx_no_Labels_def = tDefine "val_approx_no_Labels" ` \\ disch_then (qspec_then `tag` assume_tac) \\ fs [val_approx_size_def]); -Theorem decide_inline_no_Labels - `val_approx_no_Labels b ∧ decide_inline a b c d = inlD_LetInline e ⇒ - no_Labels e` - (rw[decide_inline_def,CaseEq"val_approx",CaseEq"bool"] - \\ fs[val_approx_no_Labels_def]); +Theorem decide_inline_no_Labels: + val_approx_no_Labels b ∧ decide_inline a b c d = inlD_LetInline e ⇒ + no_Labels e +Proof + rw[decide_inline_def,CaseEq"val_approx",CaseEq"bool"] + \\ fs[val_approx_no_Labels_def] +QED val globals_approx_no_Labels_def = Define` globals_approx_no_Labels g = (∀c d. lookup c g = SOME d ⇒ val_approx_no_Labels d)`; -Theorem val_approx_no_Labels_merge - `∀a b. val_approx_no_Labels a ∧ val_approx_no_Labels b ⇒ - val_approx_no_Labels (merge a b)` - (recInduct clos_knownTheory.merge_ind +Theorem val_approx_no_Labels_merge: + ∀a b. val_approx_no_Labels a ∧ val_approx_no_Labels b ⇒ + val_approx_no_Labels (merge a b) +Proof + recInduct clos_knownTheory.merge_ind \\ rw[clos_knownTheory.merge_def,val_approx_no_Labels_def] \\ fs[EVERY_MEM,MAP2_MAP,MEM_MAP] \\ rw[] \\ imp_res_tac MEM_ZIP_MEM_MAP - \\ rfs[UNCURRY]); + \\ rfs[UNCURRY] +QED -Theorem known_op_no_Labels - `known_op op x y = (a,b) ∧ +Theorem known_op_no_Labels: + known_op op x y = (a,b) ∧ EVERY val_approx_no_Labels x ∧ globals_approx_no_Labels y ⇒ val_approx_no_Labels a ∧ - globals_approx_no_Labels b` - (Cases_on`op` \\ fs[clos_knownTheory.known_op_def] \\ rw[] + globals_approx_no_Labels b +Proof + Cases_on`op` \\ fs[clos_knownTheory.known_op_def] \\ rw[] \\ fsrw_tac[ETA_ss][CaseEq"prod",CaseEq"option",NULL_EQ, CaseEq"list",CaseEq"val_approx",CaseEq"bool"] \\ rw[] \\ fs[val_approx_no_Labels_def] @@ -4773,31 +5058,37 @@ Theorem known_op_no_Labels \\ TRY ( match_mp_tac val_approx_no_Labels_merge \\ fs[] ) \\ last_x_assum match_mp_tac \\ fs[] \\ TRY asm_exists_tac \\ fs[] - \\ intLib.COOPER_TAC); + \\ intLib.COOPER_TAC +QED -Theorem no_Labels_mk_Ticks - `∀t tc n e. no_Labels e ⇒ no_Labels (mk_Ticks t tc n e)` - (recInduct mk_Ticks_ind +Theorem no_Labels_mk_Ticks: + ∀t tc n e. no_Labels e ⇒ no_Labels (mk_Ticks t tc n e) +Proof + recInduct mk_Ticks_ind \\ rw[Once mk_Ticks_def] \\ rw[Once mk_Ticks_def] - \\ fs[] \\ rw[Once mk_Ticks_def]); - -Theorem clos_gen_no_inline_no_Labels - `!(xs:(num,closLang$exp) alist) n x. - EVERY val_approx_no_Labels (clos_gen_noinline x n xs)` - (Induct \\ rw [clos_gen_noinline_def] + \\ fs[] \\ rw[Once mk_Ticks_def] +QED + +Theorem clos_gen_no_inline_no_Labels: + !(xs:(num,closLang$exp) alist) n x. + EVERY val_approx_no_Labels (clos_gen_noinline x n xs) +Proof + Induct \\ rw [clos_gen_noinline_def] \\ PairCases_on `h` - \\ rw [clos_gen_noinline_def,val_approx_no_Labels_def]) + \\ rw [clos_gen_noinline_def,val_approx_no_Labels_def] +QED -Theorem known_no_Labels - `∀a b c d. +Theorem known_no_Labels: + ∀a b c d. EVERY no_Labels b ∧ EVERY val_approx_no_Labels c ∧ globals_approx_no_Labels d ⇒ EVERY no_Labels (MAP FST (FST (known a b c d))) ∧ EVERY val_approx_no_Labels (MAP SND (FST (known a b c d))) ∧ - globals_approx_no_Labels (SND (known a b c d))` - (recInduct clos_knownTheory.known_ind + globals_approx_no_Labels (SND (known a b c d)) +Proof + recInduct clos_knownTheory.known_ind \\ rw[clos_knownTheory.known_def] \\ rpt(pairarg_tac \\ fs[]) \\ imp_res_tac clos_knownTheory.known_sing_EQ_E @@ -4850,13 +5141,15 @@ Theorem known_no_Labels \\ fs [val_approx_no_Labels_def] \\ rename1 `known c [pp] qq` \\ Cases_on `known c [pp] qq g` - \\ imp_res_tac clos_knownTheory.known_sing_EQ_E \\ fs []); + \\ imp_res_tac clos_knownTheory.known_sing_EQ_E \\ fs [] +QED -Theorem compile_no_Labels - `compile (SOME c) xs = (res,ys) /\ EVERY no_Labels xs ==> +Theorem compile_no_Labels: + compile (SOME c) xs = (res,ys) /\ EVERY no_Labels xs ==> ?c1. res = SOME c1 /\ EVERY no_Labels ys /\ - globals_approx_no_Labels c1.val_approx_spt` - (fs [clos_knownTheory.compile_def,clos_fvsTheory.compile_def] + globals_approx_no_Labels c1.val_approx_spt +Proof + fs [clos_knownTheory.compile_def,clos_fvsTheory.compile_def] \\ rpt (pairarg_tac \\ fs []) \\ strip_tac \\ rveq \\ fs [] \\ qspecl_then [`c`,`remove_fvs 0 xs`,`[]`,`LN`] @@ -4865,7 +5158,8 @@ Theorem compile_no_Labels \\ impl_tac THEN1 (fs [globals_approx_no_Labels_def,lookup_def]) \\ metis_tac [clos_ticksProofTheory.remove_ticks_no_Labels, - clos_letopProofTheory.let_op_no_Labels]); + clos_letopProofTheory.let_op_no_Labels] +QED (* obeys_max_app *) @@ -4881,32 +5175,37 @@ val val_approx_obeys_max_app_def = tDefine "val_approx_obeys_max_app" ` \\ disch_then (qspec_then `tag` assume_tac) \\ fs [val_approx_size_def]); -Theorem decide_inline_obeys_max_app - `val_approx_obeys_max_app k b ∧ decide_inline a b c d = inlD_LetInline e ⇒ - obeys_max_app k e` - (rw[decide_inline_def,CaseEq"val_approx",CaseEq"bool"] - \\ fs[val_approx_obeys_max_app_def]); +Theorem decide_inline_obeys_max_app: + val_approx_obeys_max_app k b ∧ decide_inline a b c d = inlD_LetInline e ⇒ + obeys_max_app k e +Proof + rw[decide_inline_def,CaseEq"val_approx",CaseEq"bool"] + \\ fs[val_approx_obeys_max_app_def] +QED val globals_approx_obeys_max_app_def = Define` globals_approx_obeys_max_app k g = (∀c d. lookup c g = SOME d ⇒ val_approx_obeys_max_app k d)`; -Theorem val_approx_obeys_max_app_merge - `∀a b. val_approx_obeys_max_app k a ∧ val_approx_obeys_max_app k b ⇒ - val_approx_obeys_max_app k (merge a b)` - (recInduct clos_knownTheory.merge_ind +Theorem val_approx_obeys_max_app_merge: + ∀a b. val_approx_obeys_max_app k a ∧ val_approx_obeys_max_app k b ⇒ + val_approx_obeys_max_app k (merge a b) +Proof + recInduct clos_knownTheory.merge_ind \\ rw[clos_knownTheory.merge_def,val_approx_obeys_max_app_def] \\ fs[EVERY_MEM,MAP2_MAP,MEM_MAP] \\ rw[] \\ imp_res_tac MEM_ZIP_MEM_MAP - \\ rfs[UNCURRY]); + \\ rfs[UNCURRY] +QED -Theorem known_op_obeys_max_app - `known_op op x y = (a,b) ∧ +Theorem known_op_obeys_max_app: + known_op op x y = (a,b) ∧ EVERY (val_approx_obeys_max_app k) x ∧ globals_approx_obeys_max_app k y ⇒ val_approx_obeys_max_app k a ∧ - globals_approx_obeys_max_app k b` - (Cases_on`op` \\ fs[clos_knownTheory.known_op_def] \\ rw[] + globals_approx_obeys_max_app k b +Proof + Cases_on`op` \\ fs[clos_knownTheory.known_op_def] \\ rw[] \\ fsrw_tac[ETA_ss][CaseEq"prod",CaseEq"option",NULL_EQ, CaseEq"list",CaseEq"val_approx",CaseEq"bool"] \\ rw[] \\ fs[val_approx_obeys_max_app_def] @@ -4915,35 +5214,43 @@ Theorem known_op_obeys_max_app \\ TRY ( match_mp_tac val_approx_obeys_max_app_merge \\ fs[] ) \\ last_x_assum match_mp_tac \\ fs[] \\ TRY asm_exists_tac \\ fs[] - \\ intLib.COOPER_TAC); + \\ intLib.COOPER_TAC +QED -Theorem obeys_max_app_mk_Ticks - `∀t tc n e. obeys_max_app k e ⇒ obeys_max_app k (mk_Ticks t tc n e)` - (recInduct mk_Ticks_ind +Theorem obeys_max_app_mk_Ticks: + ∀t tc n e. obeys_max_app k e ⇒ obeys_max_app k (mk_Ticks t tc n e) +Proof + recInduct mk_Ticks_ind \\ rw[Once mk_Ticks_def] \\ rw[Once mk_Ticks_def] - \\ fs[] \\ rw[Once mk_Ticks_def]); - -Theorem clos_gen_no_inline_obeys_max_app - `!(xs:(num,closLang$exp) alist) n x. - EVERY (val_approx_obeys_max_app k) (clos_gen_noinline x n xs)` - (Induct \\ rw [clos_gen_noinline_def] + \\ fs[] \\ rw[Once mk_Ticks_def] +QED + +Theorem clos_gen_no_inline_obeys_max_app: + !(xs:(num,closLang$exp) alist) n x. + EVERY (val_approx_obeys_max_app k) (clos_gen_noinline x n xs) +Proof + Induct \\ rw [clos_gen_noinline_def] \\ PairCases_on `h` - \\ rw [clos_gen_noinline_def,val_approx_obeys_max_app_def]) + \\ rw [clos_gen_noinline_def,val_approx_obeys_max_app_def] +QED -Theorem known_IMP_LENGTH - `known c xs vs g = (ys,g') ==> LENGTH ys = LENGTH xs` - (metis_tac [known_LENGTH,FST]); +Theorem known_IMP_LENGTH: + known c xs vs g = (ys,g') ==> LENGTH ys = LENGTH xs +Proof + metis_tac [known_LENGTH,FST] +QED -Theorem known_obeys_max_app - `∀a b c d. +Theorem known_obeys_max_app: + ∀a b c d. EVERY (obeys_max_app k) b ∧ EVERY (val_approx_obeys_max_app k) c ∧ globals_approx_obeys_max_app k d ⇒ EVERY (obeys_max_app k) (MAP FST (FST (known a b c d))) ∧ EVERY (val_approx_obeys_max_app k) (MAP SND (FST (known a b c d))) ∧ - globals_approx_obeys_max_app k (SND (known a b c d))` - (recInduct clos_knownTheory.known_ind + globals_approx_obeys_max_app k (SND (known a b c d)) +Proof + recInduct clos_knownTheory.known_ind \\ rw[clos_knownTheory.known_def] \\ rpt(pairarg_tac \\ fs[]) \\ imp_res_tac clos_knownTheory.known_sing_EQ_E @@ -4997,13 +5304,15 @@ Theorem known_obeys_max_app \\ fs [val_approx_obeys_max_app_def] \\ rename1 `known c [pp] qq` \\ Cases_on `known c [pp] qq g` - \\ imp_res_tac clos_knownTheory.known_sing_EQ_E \\ fs []); + \\ imp_res_tac clos_knownTheory.known_sing_EQ_E \\ fs [] +QED -Theorem compile_obeys_max_app - `compile (SOME c) xs = (res,ys) /\ EVERY (obeys_max_app k) xs ==> +Theorem compile_obeys_max_app: + compile (SOME c) xs = (res,ys) /\ EVERY (obeys_max_app k) xs ==> ?c1. res = SOME c1 /\ EVERY (obeys_max_app k) ys /\ - globals_approx_obeys_max_app k c1.val_approx_spt` - (fs [clos_knownTheory.compile_def,clos_fvsTheory.compile_def] + globals_approx_obeys_max_app k c1.val_approx_spt +Proof + fs [clos_knownTheory.compile_def,clos_fvsTheory.compile_def] \\ rpt (pairarg_tac \\ fs []) \\ strip_tac \\ rveq \\ fs [] \\ qspecl_then [`c`,`remove_fvs 0 xs`,`[]`,`LN`] @@ -5011,15 +5320,18 @@ Theorem compile_obeys_max_app \\ fs [clos_fvsProofTheory.remove_fvs_obeys_max_app] \\ impl_tac THEN1 (fs [globals_approx_obeys_max_app_def,lookup_def]) \\ metis_tac [clos_ticksProofTheory.remove_ticks_obeys_max_app, - clos_letopProofTheory.let_op_obeys_max_app]); + clos_letopProofTheory.let_op_obeys_max_app] +QED (* names *) -Theorem get_code_labels_mk_Ticks[simp] - `∀a b c d. get_code_labels (mk_Ticks a b c d) = get_code_labels d` - (recInduct clos_knownTheory.mk_Ticks_ind +Theorem get_code_labels_mk_Ticks[simp]: + ∀a b c d. get_code_labels (mk_Ticks a b c d) = get_code_labels d +Proof + recInduct clos_knownTheory.mk_Ticks_ind \\ rw[] - \\ rw[Once clos_knownTheory.mk_Ticks_def]); + \\ rw[Once clos_knownTheory.mk_Ticks_def] +QED (* val val_approx_bodies_def = tDefine"val_approx_bodies_def"` @@ -5036,25 +5348,32 @@ val val_approx_bodies_def = |> SIMP_RULE(srw_ss()++ETA_ss)[] |> curry save_thm "val_approx_bodies_def[simp,compute]"; -Theorem val_approx_bodies_cons - `val_approx_bodies (x::ys) = val_approx_bodies [x] ++ val_approx_bodies ys` - (Cases_on`ys` \\ rw[]); +Theorem val_approx_bodies_cons: + val_approx_bodies (x::ys) = val_approx_bodies [x] ++ val_approx_bodies ys +Proof + Cases_on`ys` \\ rw[] +QED -Theorem val_approx_bodies_append - `∀l1 l2. val_approx_bodies (l1 ++ l2) = val_approx_bodies l1 ++ val_approx_bodies l2` - (Induct +Theorem val_approx_bodies_append: + ∀l1 l2. val_approx_bodies (l1 ++ l2) = val_approx_bodies l1 ++ val_approx_bodies l2 +Proof + Induct \\ rw[Once val_approx_bodies_cons] - \\ rw[Once val_approx_bodies_cons,SimpRHS]); + \\ rw[Once val_approx_bodies_cons,SimpRHS] +QED -Theorem val_approx_bodies_map - `∀xs. val_approx_bodies (MAP f xs) = FLAT (MAP (λx. val_approx_bodies [f x]) xs)` - (Induct \\ rw[] \\ rw[Once val_approx_bodies_cons]); +Theorem val_approx_bodies_map: + ∀xs. val_approx_bodies (MAP f xs) = FLAT (MAP (λx. val_approx_bodies [f x]) xs) +Proof + Induct \\ rw[] \\ rw[Once val_approx_bodies_cons] +QED -Theorem app_call_dests_val_approx_bodies_merge - `∀a1 a2. app_call_dests x (val_approx_bodies [merge a1 a2]) ⊆ +Theorem app_call_dests_val_approx_bodies_merge: + ∀a1 a2. app_call_dests x (val_approx_bodies [merge a1 a2]) ⊆ app_call_dests x (val_approx_bodies [a1]) ∪ - app_call_dests x (val_approx_bodies [a2])` - (recInduct merge_ind \\ rw[] + app_call_dests x (val_approx_bodies [a2]) +Proof + recInduct merge_ind \\ rw[] \\ simp[Once(app_call_dests_map |> Q.ISPEC`ls:closLang$exp list` |> Q.GEN`f` |> Q.SPEC`I` |> SIMP_RULE (srw_ss()) [])] \\ fs[MAP2_MAP, val_approx_bodies_map] @@ -5076,7 +5395,8 @@ Theorem app_call_dests_val_approx_bodies_merge |> Q.GEN`f` |> Q.SPEC`I` |> SIMP_RULE (srw_ss()) [])] \\ rw[MEM_MAP, MEM_FLAT, PULL_EXISTS] \\ asm_exists_tac \\ rw[] - \\ metis_tac[MEM_EL]); + \\ metis_tac[MEM_EL] +QED *) (* @@ -5094,39 +5414,50 @@ val val_approx_dests_def = |> SIMP_RULE(srw_ss()++ETA_ss)[] |> curry save_thm "val_approx_dests_def[simp,compute]"; -Theorem val_approx_dests_cons - `val_approx_dests a (x::ys) = val_approx_dests a [x] ∪ val_approx_dests a ys` - (Cases_on`ys` \\ rw[]); +Theorem val_approx_dests_cons: + val_approx_dests a (x::ys) = val_approx_dests a [x] ∪ val_approx_dests a ys +Proof + Cases_on`ys` \\ rw[] +QED -Theorem val_approx_dests_append - `∀l1 l2. val_approx_dests a (l1 ++ l2) = val_approx_dests a l1 ∪ val_approx_dests a l2` - (Induct +Theorem val_approx_dests_append: + ∀l1 l2. val_approx_dests a (l1 ++ l2) = val_approx_dests a l1 ∪ val_approx_dests a l2 +Proof + Induct \\ rw[Once val_approx_dests_cons] \\ rw[Once val_approx_dests_cons,SimpRHS] - \\ rw[UNION_ASSOC]); + \\ rw[UNION_ASSOC] +QED -Theorem val_approx_dests_reverse - `∀ls. val_approx_dests x (REVERSE ls) = val_approx_dests x ls` - (Induct \\ simp[val_approx_dests_append] +Theorem val_approx_dests_reverse: + ∀ls. val_approx_dests x (REVERSE ls) = val_approx_dests x ls +Proof + Induct \\ simp[val_approx_dests_append] \\ simp[Once val_approx_dests_cons, SimpRHS] - \\ rw[EXTENSION] \\ metis_tac[]); - -Theorem val_approx_dests_map - `∀xs. val_approx_dests a (MAP f xs) = BIGUNION (set (MAP (λx. val_approx_dests a [f x]) xs))` - (Induct \\ rw[] \\ rw[Once val_approx_dests_cons]); - -Theorem val_approx_dests_replicate - `val_approx_dests x (REPLICATE n y) = if 0 < n then val_approx_dests x [y] else {}` - (`n = LENGTH (GENLIST ARB n)` by simp[] + \\ rw[EXTENSION] \\ metis_tac[] +QED + +Theorem val_approx_dests_map: + ∀xs. val_approx_dests a (MAP f xs) = BIGUNION (set (MAP (λx. val_approx_dests a [f x]) xs)) +Proof + Induct \\ rw[] \\ rw[Once val_approx_dests_cons] +QED + +Theorem val_approx_dests_replicate: + val_approx_dests x (REPLICATE n y) = if 0 < n then val_approx_dests x [y] else {} +Proof + `n = LENGTH (GENLIST ARB n)` by simp[] \\ pop_assum SUBST1_TAC \\ simp[GSYM MAP_K_REPLICATE] \\ simp[val_approx_dests_map] \\ simp[Once EXTENSION, PULL_EXISTS, MEM_MAP, MEM_GENLIST] - \\ rw[] \\ metis_tac[]); + \\ rw[] \\ metis_tac[] +QED -Theorem val_approx_dests_merge - `∀x y. val_approx_dests a [merge x y] ⊆ val_approx_dests a [x] ∪ val_approx_dests a [y]` - (recInduct clos_knownTheory.merge_ind +Theorem val_approx_dests_merge: + ∀x y. val_approx_dests a [merge x y] ⊆ val_approx_dests a [x] ∪ val_approx_dests a [y] +Proof + recInduct clos_knownTheory.merge_ind \\ rw[clos_knownTheory.merge_def] \\ fs[SUBSET_DEF, PULL_EXISTS, MEM_MAP, MAP2_MAP, FORALL_PROD, MEM_ZIP] \\ rw[] \\ fs[MEM_EL, PULL_EXISTS] @@ -5139,20 +5470,23 @@ Theorem val_approx_dests_merge \\ simp[Once(val_approx_dests_map |> Q.ISPEC`ls:val_approx list` |> Q.GEN`f` |> Q.SPEC`I` |> SIMP_RULE (srw_ss()) [])] \\ rw[MEM_MAP, MEM_EL, PULL_EXISTS] - \\ metis_tac[]); + \\ metis_tac[] +QED val val_approx_dests_to_sing = (val_approx_dests_map |> Q.ISPEC`ls:val_approx list` |> Q.GEN`f` |> Q.SPEC`I` |> SIMP_RULE (srw_ss()) []) -Theorem app_call_dests_mk_Ticks[simp] - `∀a b c d. app_call_dests x [mk_Ticks a b c d] = app_call_dests x [d]` - (recInduct clos_knownTheory.mk_Ticks_ind +Theorem app_call_dests_mk_Ticks[simp]: + ∀a b c d. app_call_dests x [mk_Ticks a b c d] = app_call_dests x [d] +Proof + recInduct clos_knownTheory.mk_Ticks_ind \\ rw[] - \\ rw[Once clos_knownTheory.mk_Ticks_def]); + \\ rw[Once clos_knownTheory.mk_Ticks_def] +QED -Theorem known_app_call_dests - `∀a b c d e f. +Theorem known_app_call_dests: + ∀a b c d e f. known a b c d = (e,f) ⇒ app_call_dests x (MAP FST e) ∪ @@ -5161,8 +5495,9 @@ Theorem known_app_call_dests ⊆ app_call_dests x b ∪ val_approx_dests x c ∪ - val_approx_dests x (toList d)` - (recInduct clos_knownTheory.known_ind + val_approx_dests x (toList d) +Proof + recInduct clos_knownTheory.known_ind \\ rpt conj_tac \\ simp[clos_knownTheory.known_def] \\ TRY (gen_tac \\ rpt gen_tac \\ strip_tac) @@ -5331,15 +5666,17 @@ Theorem known_app_call_dests \\ simp[Once(app_call_dests_map |> Q.ISPEC`ls:closLang$exp list` |> Q.GEN`f` |> Q.SPEC`I` |> SIMP_RULE (srw_ss()) [])] \\ simp[MEM_MAP, PULL_EXISTS, EXISTS_PROD] - \\ metis_tac[] ) ); + \\ metis_tac[] ) +QED -Theorem compile_locs - `clos_known$compile b number_code = (kc,known_code) /\ +Theorem compile_locs: + clos_known$compile b number_code = (kc,known_code) /\ call_dests number_code = ∅ /\ app_dests number_code = ∅ /\ (case b of SOME x => (∀n. val_approx_dests (SOME n) (toList x.val_approx_spt) = {}) | _ => T) ==> call_dests known_code = ∅ /\ - app_dests known_code ⊆ set (code_locs known_code)` - (strip_tac + app_dests known_code ⊆ set (code_locs known_code) +Proof + strip_tac \\ Cases_on`b` \\ fs[clos_knownTheory.compile_def] \\ rveq \\ fs[] \\ pairarg_tac \\ fs[] @@ -5349,7 +5686,8 @@ Theorem compile_locs \\ drule (GEN_ALL known_app_call_dests) \\ disch_then(fn th => assume_tac (SPEC``SOME T`` th) \\ assume_tac (SPEC``SOME F`` th)) \\ fs[] \\ rfs[] - \\ ...); + \\ ... +QED *) val _ = export_theory(); diff --git a/compiler/backend/proofs/clos_knownPropsScript.sml b/compiler/backend/proofs/clos_knownPropsScript.sml index 8daa39eebd..b8e38a428d 100644 --- a/compiler/backend/proofs/clos_knownPropsScript.sml +++ b/compiler/backend/proofs/clos_knownPropsScript.sml @@ -12,40 +12,50 @@ val va_case_eq = prove_case_eq_thm{case_def = TypeBase.case_def_of ``:val_approx``, nchotomy = TypeBase.nchotomy_of ``:val_approx``} -Theorem merge_Other[simp] - `merge Other a = Other ∧ merge a Other = Other` - (Cases_on `a` >> simp[]); - -Theorem merge_Impossible[simp] - `merge a Impossible = a` - (Cases_on `a` >> simp[]); +Theorem merge_Other[simp]: + merge Other a = Other ∧ merge a Other = Other +Proof + Cases_on `a` >> simp[] +QED + +Theorem merge_Impossible[simp]: + merge a Impossible = a +Proof + Cases_on `a` >> simp[] +QED (* See merge as a join operation on a semi-lattice: it's a join because it's a little akin to a union: as merge is used, more and more values might inhabit the approximation, with Other at the top corresponding to anything at all. *) -Theorem merge_comm - `∀a1 a2. merge a1 a2 = merge a2 a1` - (ho_match_mp_tac merge_ind >> rpt strip_tac >> simp_tac(srw_ss()) [] >> +Theorem merge_comm: + ∀a1 a2. merge a1 a2 = merge a2 a1 +Proof + ho_match_mp_tac merge_ind >> rpt strip_tac >> simp_tac(srw_ss()) [] >> COND_CASES_TAC >> simp[] >> simp[MAP2_MAP, MAP_EQ_EVERY2, LIST_REL_EL_EQN, EL_ZIP] >> - metis_tac[MEM_EL]); + metis_tac[MEM_EL] +QED -Theorem merge_assoc - `∀a1 a2 a3. merge a1 (merge a2 a3) = merge (merge a1 a2) a3` - (ho_match_mp_tac merge_ind >> rpt strip_tac >> Cases_on `a3` >> +Theorem merge_assoc: + ∀a1 a2 a3. merge a1 (merge a2 a3) = merge (merge a1 a2) a3 +Proof + ho_match_mp_tac merge_ind >> rpt strip_tac >> Cases_on `a3` >> simp[] >> rw[LENGTH_MAP2] >- (simp[MAP2_MAP, MAP_EQ_EVERY2, LIST_REL_EL_EQN, EL_ZIP, EL_MAP] >> metis_tac[MEM_EL]) >> - rw[]) + rw[] +QED -Theorem merge_idem[simp] - `merge a a = a` - (completeInduct_on `val_approx_size a` >> Cases_on `a` >> +Theorem merge_idem[simp]: + merge a a = a +Proof + completeInduct_on `val_approx_size a` >> Cases_on `a` >> simp[val_approx_size_def] >> strip_tac >> fs[PULL_FORALL] >> simp[MAP2_MAP, MAP_EQ_ID] >> rpt strip_tac >> first_x_assum match_mp_tac >> rw[] >> Induct_on `l` >> dsimp[val_approx_size_def] >> rpt strip_tac >> - res_tac >> simp[]); + res_tac >> simp[] +QED val subapprox_def = Define` subapprox a1 a2 ⇔ merge a1 a2 = a2 @@ -54,87 +64,117 @@ val subapprox_def = Define` val _ = set_fixity "◁" (Infix(NONASSOC,450)) val _ = overload_on ("◁", ``subapprox``) -Theorem subapprox_refl[simp] - `a ◁ a` - (simp[subapprox_def]); - -Theorem subapprox_trans - `a1 ◁ a2 ∧ a2 ◁ a3 ⇒ a1 ◁ a3` - (simp[subapprox_def] >> metis_tac[merge_assoc]); - -Theorem subapprox_antisym - `a1 ◁ a2 ∧ a2 ◁ a1 ⇒ a1 = a2` - (simp[subapprox_def] >> metis_tac[merge_comm]); - -Theorem subapprox_merge[simp] - `a ◁ merge a b ∧ a ◁ merge b a` - (simp[subapprox_def] >> - metis_tac[merge_assoc, merge_comm, merge_idem]); - -Theorem subapprox_Other[simp] - `(Other ◁ a ⇔ (a = Other)) ∧ a ◁ Other` - (simp[subapprox_def] >> metis_tac[]); - -Theorem subapprox_Int[simp] - `(a ◁ Int i ⇔ a = Int i ∨ a = Impossible) ∧ - (Int i ◁ a ⇔ a = Int i ∨ a = Other)` - (simp[subapprox_def] >> Cases_on `a` >> simp[] >> rw[]); - - -Theorem subapprox_ClosNoInline[simp] - `(a ◁ ClosNoInline m n ⇔ a = ClosNoInline m n ∨ a = Impossible) ∧ - (ClosNoInline m n ◁ a ⇔ a = ClosNoInline m n ∨ a = Other)` - (simp[subapprox_def] >> Cases_on `a` >> simp[] >> rw[] >> - fs [DE_MORGAN_THM]); - -Theorem subapprox_Clos[simp] - `(a ◁ Clos m n e s ⇔ a = Clos m n e s ∨ a = Impossible) ∧ - (Clos m n e s ◁ a ⇔ a = Clos m n e s ∨ a = Other)` - (simp[subapprox_def] >> Cases_on `a` >> simp[] >> rw[] >> - fs [DE_MORGAN_THM]); - -Theorem subapprox_Impossible[simp] - `(a ◁ Impossible ⇔ a = Impossible) ∧ Impossible ◁ a` - (simp[subapprox_def]); - -Theorem subapprox_Tuple[simp] - `Tuple tg1 as1 ◁ Tuple tg2 as2 ⇔ tg1 = tg2 ∧ LIST_REL subapprox as1 as2` - (simp[subapprox_def, MAP2_MAP, LIST_REL_EL_EQN, bool_case_eq] >> +Theorem subapprox_refl[simp]: + a ◁ a +Proof + simp[subapprox_def] +QED + +Theorem subapprox_trans: + a1 ◁ a2 ∧ a2 ◁ a3 ⇒ a1 ◁ a3 +Proof + simp[subapprox_def] >> metis_tac[merge_assoc] +QED + +Theorem subapprox_antisym: + a1 ◁ a2 ∧ a2 ◁ a1 ⇒ a1 = a2 +Proof + simp[subapprox_def] >> metis_tac[merge_comm] +QED + +Theorem subapprox_merge[simp]: + a ◁ merge a b ∧ a ◁ merge b a +Proof + simp[subapprox_def] >> + metis_tac[merge_assoc, merge_comm, merge_idem] +QED + +Theorem subapprox_Other[simp]: + (Other ◁ a ⇔ (a = Other)) ∧ a ◁ Other +Proof + simp[subapprox_def] >> metis_tac[] +QED + +Theorem subapprox_Int[simp]: + (a ◁ Int i ⇔ a = Int i ∨ a = Impossible) ∧ + (Int i ◁ a ⇔ a = Int i ∨ a = Other) +Proof + simp[subapprox_def] >> Cases_on `a` >> simp[] >> rw[] +QED + + +Theorem subapprox_ClosNoInline[simp]: + (a ◁ ClosNoInline m n ⇔ a = ClosNoInline m n ∨ a = Impossible) ∧ + (ClosNoInline m n ◁ a ⇔ a = ClosNoInline m n ∨ a = Other) +Proof + simp[subapprox_def] >> Cases_on `a` >> simp[] >> rw[] >> + fs [DE_MORGAN_THM] +QED + +Theorem subapprox_Clos[simp]: + (a ◁ Clos m n e s ⇔ a = Clos m n e s ∨ a = Impossible) ∧ + (Clos m n e s ◁ a ⇔ a = Clos m n e s ∨ a = Other) +Proof + simp[subapprox_def] >> Cases_on `a` >> simp[] >> rw[] >> + fs [DE_MORGAN_THM] +QED + +Theorem subapprox_Impossible[simp]: + (a ◁ Impossible ⇔ a = Impossible) ∧ Impossible ◁ a +Proof + simp[subapprox_def] +QED + +Theorem subapprox_Tuple[simp]: + Tuple tg1 as1 ◁ Tuple tg2 as2 ⇔ tg1 = tg2 ∧ LIST_REL subapprox as1 as2 +Proof + simp[subapprox_def, MAP2_MAP, LIST_REL_EL_EQN, bool_case_eq] >> Cases_on `LENGTH as1 = LENGTH as2` >> Cases_on `tg1 = tg2` >> - simp[LIST_EQ_REWRITE, EL_MAP, EL_ZIP] >> metis_tac[]); + simp[LIST_EQ_REWRITE, EL_MAP, EL_ZIP] >> metis_tac[] +QED val better_definedg_def = Define` better_definedg g1 g2 ⇔ ∀k. k ∈ domain g1 ⇒ k ∈ domain g2 ∧ THE (lookup k g1) ◁ THE (lookup k g2) `; -Theorem better_definedg_refl[simp] - `better_definedg g g` - (simp[better_definedg_def]); - -Theorem better_definedg_trans - `better_definedg g1 g2 ∧ better_definedg g2 g3 ⇒ better_definedg g1 g3` - (simp[better_definedg_def] >> metis_tac[subapprox_trans]) - -Theorem known_op_better_definedg - `known_op opn apxs g0 = (a,g) ⇒ better_definedg g0 g` - (Cases_on `opn` >> +Theorem better_definedg_refl[simp]: + better_definedg g g +Proof + simp[better_definedg_def] +QED + +Theorem better_definedg_trans: + better_definedg g1 g2 ∧ better_definedg g2 g3 ⇒ better_definedg g1 g3 +Proof + simp[better_definedg_def] >> metis_tac[subapprox_trans] +QED + +Theorem known_op_better_definedg: + known_op opn apxs g0 = (a,g) ⇒ better_definedg g0 g +Proof + Cases_on `opn` >> simp[known_op_def, pair_case_eq, closSemTheory.case_eq_thms, va_case_eq, bool_case_eq] >> rw[] >> rw[better_definedg_def, lookup_insert] >> - rw[] >> fs[lookup_NONE_domain]) - -Theorem known_better_definedg - `∀c es apxs g0 alist g. - known c es apxs g0 = (alist, g) ⇒ better_definedg g0 g` - (ho_match_mp_tac known_ind >> simp[known_def] >> + rw[] >> fs[lookup_NONE_domain] +QED + +Theorem known_better_definedg: + ∀c es apxs g0 alist g. + known c es apxs g0 = (alist, g) ⇒ better_definedg g0 g +Proof + ho_match_mp_tac known_ind >> simp[known_def] >> reverse (rpt strip_tac) >> rpt (pairarg_tac >> fs[]) >> rw[] >- (EVERY_CASE_TAC >> rpt (pairarg_tac >> fs[]) >> fs [] >> metis_tac[better_definedg_trans, known_op_better_definedg]) >> - metis_tac[better_definedg_trans, known_op_better_definedg]); - -Theorem mk_Ticks_alt - `(!t tc e. mk_Ticks t tc 0 e = e) /\ - (!t tc n e. mk_Ticks t tc (SUC n) e = mk_Ticks t (tc + 1) n (Tick (t§tc) e))` - (conj_tac \\ simp [Once mk_Ticks_def]); + metis_tac[better_definedg_trans, known_op_better_definedg] +QED + +Theorem mk_Ticks_alt: + (!t tc e. mk_Ticks t tc 0 e = e) /\ + (!t tc n e. mk_Ticks t tc (SUC n) e = mk_Ticks t (tc + 1) n (Tick (t§tc) e)) +Proof + conj_tac \\ simp [Once mk_Ticks_def] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/clos_labelsProofScript.sml b/compiler/backend/proofs/clos_labelsProofScript.sml index 16ce928afd..728e0ee08b 100644 --- a/compiler/backend/proofs/clos_labelsProofScript.sml +++ b/compiler/backend/proofs/clos_labelsProofScript.sml @@ -7,41 +7,55 @@ val _ = new_theory "clos_labelsProof"; val _ = set_grammar_ancestry ["closLang","clos_labels","closSem","closProps","backend_common"] -Theorem LENGTH_remove_dests - `!dests xs. LENGTH (remove_dests dests xs) = LENGTH xs` - (recInduct remove_dests_ind \\ simp [remove_dests_def] \\ rw [] ); +Theorem LENGTH_remove_dests: + !dests xs. LENGTH (remove_dests dests xs) = LENGTH xs +Proof + recInduct remove_dests_ind \\ simp [remove_dests_def] \\ rw [] +QED -Theorem remove_dests_SING - `!x. ?y. remove_dests dests [x] = [y]` - (Induct \\ fs [remove_dests_def] \\ rw[] +Theorem remove_dests_SING: + !x. ?y. remove_dests dests [x] = [y] +Proof + Induct \\ fs [remove_dests_def] \\ rw[] \\ rename1`App _ opt` - \\ Cases_on`opt` \\ rw[remove_dests_def]); + \\ Cases_on`opt` \\ rw[remove_dests_def] +QED -Theorem HD_remove_dests_SING[simp] - `!x. [HD (remove_dests dests [x])] = remove_dests dests [x] ∧ - LENGTH (remove_dests dests [x]) = 1` - (strip_tac \\ strip_assume_tac (Q.SPEC `x` remove_dests_SING) \\ simp []); +Theorem HD_remove_dests_SING[simp]: + !x. [HD (remove_dests dests [x])] = remove_dests dests [x] ∧ + LENGTH (remove_dests dests [x]) = 1 +Proof + strip_tac \\ strip_assume_tac (Q.SPEC `x` remove_dests_SING) \\ simp [] +QED -Theorem EVERY_remove_dests_SING - `EVERY P (remove_dests dests [x]) ⇔ P (HD (remove_dests dests [x]))` - (strip_assume_tac(SPEC_ALL remove_dests_SING) \\ rw[]); +Theorem EVERY_remove_dests_SING: + EVERY P (remove_dests dests [x]) ⇔ P (HD (remove_dests dests [x])) +Proof + strip_assume_tac(SPEC_ALL remove_dests_SING) \\ rw[] +QED -Theorem remove_dests_cons - `∀x ys. remove_dests ds (x::ys) = remove_dests ds [x] ++ remove_dests ds ys` - (gen_tac \\ Cases \\ rw[remove_dests_def]); +Theorem remove_dests_cons: + ∀x ys. remove_dests ds (x::ys) = remove_dests ds [x] ++ remove_dests ds ys +Proof + gen_tac \\ Cases \\ rw[remove_dests_def] +QED val code_rel_def = Define ` code_rel dests e1 e2 <=> e2 = remove_dests dests e1`; -Theorem code_rel_IMP_LENGTH - `!xs ys. code_rel dests xs ys ==> LENGTH xs = LENGTH ys` - (fs [code_rel_def, LENGTH_remove_dests]); +Theorem code_rel_IMP_LENGTH: + !xs ys. code_rel dests xs ys ==> LENGTH xs = LENGTH ys +Proof + fs [code_rel_def, LENGTH_remove_dests] +QED -Theorem code_rel_CONS_CONS - `code_rel dests (x1::x2::xs) (y1::y2::ys) ==> - code_rel dests [x1] [y1] /\ code_rel dests (x2::xs) (y2::ys)` - (simp [code_rel_def, remove_dests_def]); +Theorem code_rel_CONS_CONS: + code_rel dests (x1::x2::xs) (y1::y2::ys) ==> + code_rel dests [x1] [y1] /\ code_rel dests (x2::xs) (y2::ys) +Proof + simp [code_rel_def, remove_dests_def] +QED (* value relation *) @@ -144,35 +158,40 @@ val v_rel_IMP_v_to_words = prove( (* *) -Theorem lookup_vars_lemma - `!vs env1 env2. LIST_REL (v_rel ds) env1 env2 ==> +Theorem lookup_vars_lemma: + !vs env1 env2. LIST_REL (v_rel ds) env1 env2 ==> case lookup_vars vs env1 of | NONE => lookup_vars vs env2 = NONE - | SOME l1 => ?l2. LIST_REL (v_rel ds) l1 l2 /\ lookup_vars vs env2 = SOME l2` - (Induct_on `vs` \\ fs [lookup_vars_def] + | SOME l1 => ?l2. LIST_REL (v_rel ds) l1 l2 /\ lookup_vars vs env2 = SOME l2 +Proof + Induct_on `vs` \\ fs [lookup_vars_def] \\ rpt strip_tac \\ imp_res_tac LIST_REL_LENGTH \\ rw [] \\ res_tac \\ Cases_on `lookup_vars vs env1` \\ fs [] - \\ fs [LIST_REL_EL_EQN]); + \\ fs [LIST_REL_EL_EQN] +QED -Theorem dest_closure_SOME_IMP - `dest_closure max_app loc_opt f2 xs = SOME x ==> +Theorem dest_closure_SOME_IMP: + dest_closure max_app loc_opt f2 xs = SOME x ==> (?loc arg_env clo_env num_args e. f2 = Closure loc arg_env clo_env num_args e) \/ - (?loc arg_env clo_env fns i. f2 = Recclosure loc arg_env clo_env fns i)` - (fs [dest_closure_def,case_eq_thms] \\ rw [] \\ fs []); + (?loc arg_env clo_env fns i. f2 = Recclosure loc arg_env clo_env fns i) +Proof + fs [dest_closure_def,case_eq_thms] \\ rw [] \\ fs [] +QED -Theorem dest_closure_SOME_Full_app - `v_rel ds f1 f2 /\ v_rel ds a1 a2 /\ LIST_REL (v_rel ds) args1 args2 /\ +Theorem dest_closure_SOME_Full_app: + v_rel ds f1 f2 /\ v_rel ds a1 a2 /\ LIST_REL (v_rel ds) args1 args2 /\ dest_closure max_app loc_opt f1 (a1::args1) = SOME (Full_app exp1 env1 rest_args1) ==> ?exp2 env2 rest_args2. code_rel ds [exp1] [exp2] /\ LIST_REL (v_rel ds) env1 env2 /\ LIST_REL (v_rel ds) rest_args1 rest_args2 /\ - dest_closure max_app loc_opt f2 (a2::args2) = SOME (Full_app exp2 env2 rest_args2)` - (rpt strip_tac + dest_closure max_app loc_opt f2 (a2::args2) = SOME (Full_app exp2 env2 rest_args2) +Proof + rpt strip_tac \\ imp_res_tac dest_closure_SOME_IMP \\ rveq \\ fs [] \\ rveq \\ imp_res_tac LIST_REL_LENGTH @@ -205,7 +224,8 @@ Theorem dest_closure_SOME_Full_app \\ irule EVERY2_TAKE \\ irule EVERY2_APPEND_suff \\ simp []) \\ irule EVERY2_DROP - \\ irule EVERY2_APPEND_suff \\ simp []); + \\ irule EVERY2_APPEND_suff \\ simp [] +QED val do_app_lemma = prove( ``state_rel ds s t /\ LIST_REL (v_rel ds) xs ys ==> @@ -244,15 +264,17 @@ val evaluate_code_const_lemma = prove( \\ full_simp_tac(srw_ss())[dec_clock_def]) |> SIMP_RULE std_ss [FORALL_PROD] -Theorem evaluate_code_const - `(evaluate (xs,env,s) = (res,s1)) ==> - (s1.code = s.code)` - (REPEAT STRIP_TAC +Theorem evaluate_code_const: + (evaluate (xs,env,s) = (res,s1)) ==> + (s1.code = s.code) +Proof + REPEAT STRIP_TAC \\ (evaluate_code_const_lemma |> CONJUNCT1 |> Q.ISPECL_THEN [`xs`,`env`,`s`] mp_tac) - \\ full_simp_tac(srw_ss())[]); + \\ full_simp_tac(srw_ss())[] +QED -Theorem evaluate_remove_dests - `(!xs env1 (s1:('c,'ffi) closSem$state) res1 s2 ys env2 t1. +Theorem evaluate_remove_dests: + (!xs env1 (s1:('c,'ffi) closSem$state) res1 s2 ys env2 t1. evaluate (xs, env1, s1) = (res1, s2) /\ LIST_REL (v_rel ds) env1 env2 /\ state_rel ds s1 t1 /\ FDOM s1.code ⊆ domain ds ∧ set (code_locs xs) ⊆ domain ds ∧ @@ -272,8 +294,9 @@ Theorem evaluate_remove_dests ?res2 t2. evaluate_app loc_opt f2 args2 t1 = (res2, t2) /\ result_rel (LIST_REL (v_rel ds)) (v_rel ds) res1 res2 /\ - state_rel ds s2 t2)` - (ho_match_mp_tac (evaluate_ind |> Q.SPEC `\(x1,x2,x3). P0 x1 x2 x3` + state_rel ds s2 t2) +Proof + ho_match_mp_tac (evaluate_ind |> Q.SPEC `\(x1,x2,x3). P0 x1 x2 x3` |> Q.GEN `P0` |> SIMP_RULE std_ss [FORALL_PROD]) \\ conj_tac >- ( @@ -660,23 +683,26 @@ Theorem evaluate_remove_dests \\ strip_tac \\ fs [] \\ fs [case_eq_thms] \\ rveq \\ fs [] \\ first_x_assum irule \\ fs[] - \\ imp_res_tac evaluate_code_const \\ fs[dec_clock_def]) + \\ imp_res_tac evaluate_code_const \\ fs[dec_clock_def] +QED -Theorem add_code_locs_code_locs - `∀ds es. domain (add_code_locs ds es) = domain ds ∪ set (code_locs es)` - (recInduct add_code_locs_ind +Theorem add_code_locs_code_locs: + ∀ds es. domain (add_code_locs ds es) = domain ds ∪ set (code_locs es) +Proof + recInduct add_code_locs_ind \\ rw[add_code_locs_def, code_locs_def, UNION_ASSOC] >- ( CASE_TAC \\ rw[EXTENSION] \\ metis_tac[] ) >- ( simp[EXTENSION, domain_list_insert] - \\ metis_tac[])); + \\ metis_tac[]) +QED val code_code_locs_def = Define` code_code_locs fm = FDOM fm ∪ BIGUNION (IMAGE (λ(_,e). set (code_locs [e])) (FRANGE fm))`; -Theorem remove_dests_correct - `!xs env1 (s1:('c,'ffi) closSem$state) res1 s2 env2 t1 ds. +Theorem remove_dests_correct: + !xs env1 (s1:('c,'ffi) closSem$state) res1 s2 env2 t1 ds. evaluate (xs, env1, s1) = (res1, s2) /\ LIST_REL (v_rel ds) env1 env2 /\ state_rel ds s1 t1 /\ code_code_locs s1.code ⊆ domain ds ∧ @@ -685,11 +711,13 @@ Theorem remove_dests_correct ?res2 t2. evaluate (remove_dests ds xs, env2, t1) = (res2, t2) /\ result_rel (LIST_REL (v_rel ds)) (v_rel ds) res1 res2 /\ - state_rel ds s2 t2` - (rpt strip_tac \\ drule (CONJUNCT1 evaluate_remove_dests) + state_rel ds s2 t2 +Proof + rpt strip_tac \\ drule (CONJUNCT1 evaluate_remove_dests) \\ disch_then drule \\ disch_then drule - \\ fs [code_rel_def, code_code_locs_def]); + \\ fs [code_rel_def, code_code_locs_def] +QED (* preservation of observational semantics *) @@ -700,8 +728,8 @@ val compile_inc_def = Define ` (* this is probably wrong *) remove_dests ds es, clos_labels$compile aux)`; -Theorem semantics_compile - `semantics (ffi:'ffi ffi$ffi_state) max_app (alist_to_fmap aux) +Theorem semantics_compile: + semantics (ffi:'ffi ffi$ffi_state) max_app (alist_to_fmap aux) co (pure_cc (compile_inc) cc) xs <> ffi$Fail ==> set (code_locs xs) ⊆ code_code_locs (alist_to_fmap aux) ==> semantics (ffi:'ffi ffi$ffi_state) max_app @@ -710,8 +738,9 @@ Theorem semantics_compile (remove_dests (add_code_locs (list_insert (MAP FST aux) LN) (MAP (SND o SND) aux)) xs) = semantics (ffi:'ffi ffi$ffi_state) max_app (alist_to_fmap aux) - co (pure_cc (compile_inc) cc) xs` - (strip_tac + co (pure_cc (compile_inc) cc) xs +Proof + strip_tac \\ ho_match_mp_tac IMP_semantics_eq \\ fs [] \\ fs [eval_sim_def] \\ rw [] \\ drule remove_dests_correct @@ -740,13 +769,15 @@ Theorem semantics_compile \\ qexists_tac `0` \\ simp [] \\ fs [state_rel_def] \\ Cases_on `res1` \\ fs [] - \\ Cases_on `e` \\ fs []) + \\ Cases_on `e` \\ fs [] +QED (* syntactic properties *) -Theorem remove_dests_every_Fn_SOME[simp] - `∀ds es. every_Fn_SOME es ==> every_Fn_SOME (remove_dests ds es)` - (recInduct remove_dests_ind +Theorem remove_dests_every_Fn_SOME[simp]: + ∀ds es. every_Fn_SOME es ==> every_Fn_SOME (remove_dests ds es) +Proof + recInduct remove_dests_ind \\ rw[remove_dests_def] >- ( fs[Once every_Fn_SOME_EVERY] @@ -757,11 +788,13 @@ Theorem remove_dests_every_Fn_SOME[simp] \\ pop_assum mp_tac \\ Cases_on `fns` \\ fs [] \\ PairCases_on `h` \\ fs [] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem remove_dests_every_Fn_vs_NONE[simp] - `∀ds es. every_Fn_vs_NONE es ==> every_Fn_vs_NONE (remove_dests ds es)` - (recInduct remove_dests_ind +Theorem remove_dests_every_Fn_vs_NONE[simp]: + ∀ds es. every_Fn_vs_NONE es ==> every_Fn_vs_NONE (remove_dests ds es) +Proof + recInduct remove_dests_ind \\ rw[remove_dests_def] >- ( fs[Once every_Fn_vs_NONE_EVERY] @@ -772,11 +805,13 @@ Theorem remove_dests_every_Fn_vs_NONE[simp] \\ pop_assum mp_tac \\ Cases_on `fns` \\ fs [] \\ PairCases_on `h` \\ fs [] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem remove_dests_every_Fn_vs_SOME[simp] - `∀ds es. every_Fn_vs_SOME es ==> every_Fn_vs_SOME (clos_labels$remove_dests ds es)` - (recInduct clos_labelsTheory.remove_dests_ind +Theorem remove_dests_every_Fn_vs_SOME[simp]: + ∀ds es. every_Fn_vs_SOME es ==> every_Fn_vs_SOME (clos_labels$remove_dests ds es) +Proof + recInduct clos_labelsTheory.remove_dests_ind \\ rw[clos_labelsTheory.remove_dests_def] >- ( fs[Once every_Fn_vs_SOME_EVERY] @@ -787,47 +822,59 @@ Theorem remove_dests_every_Fn_vs_SOME[simp] \\ pop_assum mp_tac \\ Cases_on `fns` \\ fs [] \\ PairCases_on `h` \\ fs [] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem compile_every_Fn_SOME - `every_Fn_SOME (MAP (SND o SND) es) ⇒ - every_Fn_SOME (MAP (SND o SND) (clos_labels$compile es))` - (rw[clos_labelsTheory.compile_def, Once every_Fn_SOME_EVERY] +Theorem compile_every_Fn_SOME: + every_Fn_SOME (MAP (SND o SND) es) ⇒ + every_Fn_SOME (MAP (SND o SND) (clos_labels$compile es)) +Proof + rw[clos_labelsTheory.compile_def, Once every_Fn_SOME_EVERY] \\ fs[Once every_Fn_SOME_EVERY] \\ fs[EVERY_MAP, UNCURRY] - \\ fs[EVERY_MEM] \\ rw[remove_dests_SING]); + \\ fs[EVERY_MEM] \\ rw[remove_dests_SING] +QED -Theorem compile_every_Fn_vs_SOME - `every_Fn_vs_SOME (MAP (SND o SND) es) ⇒ - every_Fn_vs_SOME (MAP (SND o SND) (clos_labels$compile es))` - (rw[Once every_Fn_vs_SOME_EVERY] +Theorem compile_every_Fn_vs_SOME: + every_Fn_vs_SOME (MAP (SND o SND) es) ⇒ + every_Fn_vs_SOME (MAP (SND o SND) (clos_labels$compile es)) +Proof + rw[Once every_Fn_vs_SOME_EVERY] \\ rw[clos_labelsTheory.compile_def] \\ rw[Once every_Fn_vs_SOME_EVERY] \\ fs[EVERY_MAP, UNCURRY] - \\ fs[EVERY_MEM, remove_dests_SING]); + \\ fs[EVERY_MEM, remove_dests_SING] +QED -Theorem EVERY_remove_dests_sing - `EVERY f (remove_dests n [y]) <=> f (HD (remove_dests n [y]))` - (`?t. remove_dests n [y] = [t]` by metis_tac [remove_dests_SING] \\ fs []); +Theorem EVERY_remove_dests_sing: + EVERY f (remove_dests n [y]) <=> f (HD (remove_dests n [y])) +Proof + `?t. remove_dests n [y] = [t]` by metis_tac [remove_dests_SING] \\ fs [] +QED -Theorem remove_dests_no_Labels - `!ds xs. EVERY no_Labels xs ==> EVERY no_Labels (remove_dests ds xs)` - (ho_match_mp_tac remove_dests_ind \\ rw [remove_dests_def] +Theorem remove_dests_no_Labels: + !ds xs. EVERY no_Labels xs ==> EVERY no_Labels (remove_dests ds xs) +Proof + ho_match_mp_tac remove_dests_ind \\ rw [remove_dests_def] \\ fs [EVERY_remove_dests_sing] \\ fs [EVERY_MEM,MEM_MAP,FORALL_PROD,PULL_EXISTS] - \\ rw [] \\ res_tac); + \\ rw [] \\ res_tac +QED -Theorem remove_dests_obeys_max_app - `!ds xs. EVERY (obeys_max_app k) xs ==> - EVERY (obeys_max_app k) (remove_dests ds xs)` - (ho_match_mp_tac remove_dests_ind \\ rw [remove_dests_def] +Theorem remove_dests_obeys_max_app: + !ds xs. EVERY (obeys_max_app k) xs ==> + EVERY (obeys_max_app k) (remove_dests ds xs) +Proof + ho_match_mp_tac remove_dests_ind \\ rw [remove_dests_def] \\ fs [EVERY_remove_dests_sing] \\ fs [EVERY_MEM,MEM_MAP,FORALL_PROD,PULL_EXISTS,LENGTH_remove_dests] - \\ rw [] \\ res_tac); + \\ rw [] \\ res_tac +QED -Theorem code_locs_remove_dests - `!ds xs. set (code_locs (remove_dests ds xs)) = set (code_locs xs)` - (ho_match_mp_tac remove_dests_ind \\ rw [remove_dests_def] +Theorem code_locs_remove_dests: + !ds xs. set (code_locs (remove_dests ds xs)) = set (code_locs xs) +Proof + ho_match_mp_tac remove_dests_ind \\ rw [remove_dests_def] \\ `?x1. remove_dests ds [x] = [x1]` by fs [remove_dests_SING] \\ `?r1. remove_dests ds [x1] = [r1]` by fs [remove_dests_SING] \\ `?r2. remove_dests ds [x2] = [r2]` by fs [remove_dests_SING] @@ -838,11 +885,13 @@ Theorem code_locs_remove_dests \\ fs[code_locs_append] >- ( simp[UNION_COMM] ) \\ fs[Once EXTENSION, code_locs_map, MEM_MAP, PULL_EXISTS, MEM_FLAT, EXISTS_PROD] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem code_locs_remove_dests_distinct - `!ds xs. ALL_DISTINCT (code_locs xs) ⇒ ALL_DISTINCT (code_locs (clos_labels$remove_dests ds xs))` - (ho_match_mp_tac clos_labelsTheory.remove_dests_ind \\ rw [clos_labelsTheory.remove_dests_def] +Theorem code_locs_remove_dests_distinct: + !ds xs. ALL_DISTINCT (code_locs xs) ⇒ ALL_DISTINCT (code_locs (clos_labels$remove_dests ds xs)) +Proof + ho_match_mp_tac clos_labelsTheory.remove_dests_ind \\ rw [clos_labelsTheory.remove_dests_def] \\ `?x1. clos_labels$remove_dests ds [x] = [x1]` by fs [remove_dests_SING] \\ `?r1. clos_labels$remove_dests ds [x1] = [r1]` by fs [remove_dests_SING] \\ `?r2. clos_labels$remove_dests ds [x2] = [r2]` by fs [remove_dests_SING] @@ -887,23 +936,27 @@ Theorem code_locs_remove_dests_distinct >- metis_tac[] \\ qspecl_then[`ds`,`[p_2']`]mp_tac code_locs_remove_dests \\ rw[] \\ fs[] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem any_dests_remove_dests - `∀ds xs. any_dests (remove_dests ds xs) ⊆ domain ds` - (recInduct remove_dests_ind +Theorem any_dests_remove_dests: + ∀ds xs. any_dests (remove_dests ds xs) ⊆ domain ds +Proof + recInduct remove_dests_ind \\ rw[remove_dests_def, IS_SOME_EXISTS, app_call_dests_append] \\ simp[Once app_call_dests_cons] \\ fs[domain_lookup, NULL_EQ] \\ TRY(Cases_on`lookup dest ds` \\ fs[remove_dests_def] \\ NO_TAC) \\ simp[app_call_dests_map, SUBSET_DEF, PULL_EXISTS, MEM_MAP, FORALL_PROD] - \\ fs[SUBSET_DEF] \\ metis_tac[]); + \\ fs[SUBSET_DEF] \\ metis_tac[] +QED -Theorem compile_any_dests_SUBSET_code_locs - `any_dests (MAP (SND ∘ SND) (compile input)) ⊆ +Theorem compile_any_dests_SUBSET_code_locs: + any_dests (MAP (SND ∘ SND) (compile input)) ⊆ set (MAP FST (compile input)) ∪ - set (code_locs (MAP (SND ∘ SND) (compile input)))` - (fs [compile_def] \\ fs [MAP_MAP_o,o_DEF,UNCURRY] + set (code_locs (MAP (SND ∘ SND) (compile input))) +Proof + fs [compile_def] \\ fs [MAP_MAP_o,o_DEF,UNCURRY] \\ qmatch_abbrev_tac `any_dests (MAP (λx. HD (remove_dests ds [SND (SND x)])) input) ⊆ d` \\ `d = domain ds` @@ -922,67 +975,81 @@ Theorem compile_any_dests_SUBSET_code_locs \\ rpt gen_tac \\ qmatch_goalsub_abbrev_tac`remove_dests ds xs` \\ mp_tac(SPEC_ALL any_dests_remove_dests) - \\ simp[SUBSET_DEF]); + \\ simp[SUBSET_DEF] +QED -Theorem MAP_FST_compile - `∀ls. MAP FST (clos_labels$compile ls) = MAP FST ls` - (Induct +Theorem MAP_FST_compile: + ∀ls. MAP FST (clos_labels$compile ls) = MAP FST ls +Proof + Induct \\ rw[clos_labelsTheory.compile_def, MAP_MAP_o, o_DEF, UNCURRY] - \\ srw_tac[ETA_ss][]); + \\ srw_tac[ETA_ss][] +QED -Theorem no_Labels_labs - `!xs. +Theorem no_Labels_labs: + !xs. EVERY no_Labels (MAP (SND o SND) xs) ==> - EVERY no_Labels (MAP (SND ∘ SND) (clos_labels$compile xs))` - (fs [EVERY_MEM,FORALL_PROD,MEM_MAP,PULL_EXISTS,clos_labelsTheory.compile_def] + EVERY no_Labels (MAP (SND ∘ SND) (clos_labels$compile xs)) +Proof + fs [EVERY_MEM,FORALL_PROD,MEM_MAP,PULL_EXISTS,clos_labelsTheory.compile_def] \\ rw [] \\ res_tac \\ fs [] \\ rename [`(x1,x2,x3)`,`remove_dests ds`] \\ fs [] \\ qspecl_then [`ds`,`[x3]`] mp_tac remove_dests_no_Labels - \\ fs [EVERY_remove_dests_sing]); + \\ fs [EVERY_remove_dests_sing] +QED -Theorem obeys_max_app_labs - `!xs. +Theorem obeys_max_app_labs: + !xs. EVERY (obeys_max_app k) (MAP (SND o SND) xs) ==> - EVERY (obeys_max_app k) (MAP (SND ∘ SND) (clos_labels$compile xs))` - (fs [EVERY_MEM,FORALL_PROD,MEM_MAP,PULL_EXISTS,clos_labelsTheory.compile_def] + EVERY (obeys_max_app k) (MAP (SND ∘ SND) (clos_labels$compile xs)) +Proof + fs [EVERY_MEM,FORALL_PROD,MEM_MAP,PULL_EXISTS,clos_labelsTheory.compile_def] \\ rw [] \\ res_tac \\ fs [] \\ rename [`(x1,x2,x3)`,`remove_dests ds`] \\ fs [] \\ qspecl_then [`ds`,`[x3]`] mp_tac remove_dests_obeys_max_app - \\ fs [EVERY_remove_dests_sing]); + \\ fs [EVERY_remove_dests_sing] +QED -Theorem every_Fn_SOME_labs - `!xs. +Theorem every_Fn_SOME_labs: + !xs. every_Fn_SOME (MAP (SND o SND) xs) ==> - every_Fn_SOME (MAP (SND ∘ SND) (clos_labels$compile xs))` - (fs [EVERY_MEM,FORALL_PROD,MEM_MAP,PULL_EXISTS,clos_labelsTheory.compile_def] + every_Fn_SOME (MAP (SND ∘ SND) (clos_labels$compile xs)) +Proof + fs [EVERY_MEM,FORALL_PROD,MEM_MAP,PULL_EXISTS,clos_labelsTheory.compile_def] \\ rw [] \\ res_tac \\ fs [] \\ fs [MAP_MAP_o,o_DEF,UNCURRY] \\ rename [`remove_dests ds`] \\ fs [] \\ Induct_on `xs` \\ fs [] \\ once_rewrite_tac [closPropsTheory.every_Fn_SOME_APPEND |> Q.INST [`l1`|->`x::[]`] |> SIMP_RULE std_ss [APPEND]] - \\ fs [] \\ rw []); + \\ fs [] \\ rw [] +QED (* -Theorem remove_fvs_set_globals[simp] - `∀fvs x. MAP set_globals (remove_fvs fvs x) = MAP set_globals x` - (recInduct remove_fvs_ind +Theorem remove_fvs_set_globals[simp]: + ∀fvs x. MAP set_globals (remove_fvs fvs x) = MAP set_globals x +Proof + recInduct remove_fvs_ind \\ rw[remove_fvs_def] \\ fs[] \\ simp[elist_globals_FOLDR] >- EVAL_TAC \\ AP_TERM_TAC \\ simp[MAP_MAP_o, MAP_EQ_f, FORALL_PROD] - \\ rw[] \\ res_tac \\ fs[]); + \\ rw[] \\ res_tac \\ fs[] +QED -Theorem set_globals_HD_remove_fvs_SING[simp] - `set_globals (HD (remove_fvs fvs [x])) = set_globals x` - (strip_assume_tac(SPEC_ALL remove_fvs_SING) +Theorem set_globals_HD_remove_fvs_SING[simp]: + set_globals (HD (remove_fvs fvs [x])) = set_globals x +Proof + strip_assume_tac(SPEC_ALL remove_fvs_SING) \\ first_assum(mp_tac o Q.AP_TERM`MAP set_globals`) - \\ rw[]); + \\ rw[] +QED -Theorem remove_fvs_esgc_free[simp] - `∀fvs x. EVERY (esgc_free) (remove_fvs fvs x) ⇔ EVERY esgc_free x` - (recInduct remove_fvs_ind +Theorem remove_fvs_esgc_free[simp]: + ∀fvs x. EVERY (esgc_free) (remove_fvs fvs x) ⇔ EVERY esgc_free x +Proof + recInduct remove_fvs_ind \\ rw[remove_fvs_def, EVERY_remove_fvs_SING] \\ simp[elist_globals_FOLDR] \\ AP_THM_TAC @@ -990,11 +1057,14 @@ Theorem remove_fvs_esgc_free[simp] \\ AP_THM_TAC \\ AP_TERM_TAC \\ AP_TERM_TAC - \\ simp[MAP_MAP_o, o_DEF, UNCURRY]); + \\ simp[MAP_MAP_o, o_DEF, UNCURRY] +QED -Theorem remove_fvs_elist_globals[simp] - `elist_globals (remove_fvs fvs xs) = elist_globals xs` - (rw[elist_globals_FOLDR]); +Theorem remove_fvs_elist_globals[simp]: + elist_globals (remove_fvs fvs xs) = elist_globals xs +Proof + rw[elist_globals_FOLDR] +QED *) diff --git a/compiler/backend/proofs/clos_letopProofScript.sml b/compiler/backend/proofs/clos_letopProofScript.sml index acc7cd3ff2..073179cc00 100644 --- a/compiler/backend/proofs/clos_letopProofScript.sml +++ b/compiler/backend/proofs/clos_letopProofScript.sml @@ -12,27 +12,35 @@ val _ = new_theory "clos_letopProof"; val _ = temp_overload_on("let_op",``clos_letop$let_op``); val _ = temp_overload_on("var_list",``clos_letop$var_list``); -Theorem let_op_SING - `!x. ?y. let_op [x] = [y]` - (Induct \\ fs [let_op_def] \\ CASE_TAC); +Theorem let_op_SING: + !x. ?y. let_op [x] = [y] +Proof + Induct \\ fs [let_op_def] \\ CASE_TAC +QED -Theorem HD_let_op_SING[simp] - `!x. [HD (let_op [x])] = let_op [x] ∧ - LENGTH (let_op [x]) = 1` - (strip_tac \\ strip_assume_tac (Q.SPEC `x` let_op_SING) \\ simp []); +Theorem HD_let_op_SING[simp]: + !x. [HD (let_op [x])] = let_op [x] ∧ + LENGTH (let_op [x]) = 1 +Proof + strip_tac \\ strip_assume_tac (Q.SPEC `x` let_op_SING) \\ simp [] +QED val code_rel_def = Define ` code_rel e1 e2 <=> e2 = let_op e1`; -Theorem code_rel_IMP_LENGTH - `!xs ys. code_rel xs ys ==> LENGTH xs = LENGTH ys` - (fs [code_rel_def, LENGTH_let_op]); +Theorem code_rel_IMP_LENGTH: + !xs ys. code_rel xs ys ==> LENGTH xs = LENGTH ys +Proof + fs [code_rel_def, LENGTH_let_op] +QED -Theorem code_rel_CONS_CONS - `code_rel (x1::x2::xs) (y1::y2::ys) ==> - code_rel [x1] [y1] /\ code_rel (x2::xs) (y2::ys)` - (simp [code_rel_def, let_op_def]); +Theorem code_rel_CONS_CONS: + code_rel (x1::x2::xs) (y1::y2::ys) ==> + code_rel [x1] [y1] /\ code_rel (x2::xs) (y2::ys) +Proof + simp [code_rel_def, let_op_def] +QED (* value relation *) @@ -140,20 +148,24 @@ val v_rel_IMP_v_to_words = prove( (* *) -Theorem dest_op_SOME_IMP - `!x args opp. dest_op x args = SOME opp ==> +Theorem dest_op_SOME_IMP: + !x args opp. dest_op x args = SOME opp ==> ?t xs. x = Op t opp xs /\ - var_list 0 xs args` - (Cases \\ fs [dest_op_def]); + var_list 0 xs args +Proof + Cases \\ fs [dest_op_def] +QED -Theorem var_list_IMP_LENGTH - `!n xs ys. var_list n xs ys ==> LENGTH xs = LENGTH ys` - (Induct_on `xs` \\ Cases_on `ys` \\ fs [var_list_def] +Theorem var_list_IMP_LENGTH: + !n xs ys. var_list n xs ys ==> LENGTH xs = LENGTH ys +Proof + Induct_on `xs` \\ Cases_on `ys` \\ fs [var_list_def] THEN1 (Cases_on `h` \\ fs [var_list_def]) \\ rw [] \\ Cases_on `h'` \\ fs [var_list_def] - \\ res_tac); + \\ res_tac +QED val var_list_IMP_evaluate = prove( ``!a2 a1 xs (ys:closLang$exp list) (s:('c,'ffi) closSem$state) env. @@ -180,41 +192,48 @@ val var_list_IMP_evaluate = prove( |> SIMP_RULE std_ss [APPEND,LENGTH]) \\ asm_exists_tac \\ fs []); -Theorem lookup_vars_lemma - `!vs env1 env2. LIST_REL v_rel env1 env2 ==> +Theorem lookup_vars_lemma: + !vs env1 env2. LIST_REL v_rel env1 env2 ==> case lookup_vars vs env1 of | NONE => lookup_vars vs env2 = NONE - | SOME l1 => ?l2. LIST_REL v_rel l1 l2 /\ lookup_vars vs env2 = SOME l2` - (Induct_on `vs` \\ fs [lookup_vars_def] + | SOME l1 => ?l2. LIST_REL v_rel l1 l2 /\ lookup_vars vs env2 = SOME l2 +Proof + Induct_on `vs` \\ fs [lookup_vars_def] \\ rpt strip_tac \\ imp_res_tac LIST_REL_LENGTH \\ rw [] \\ res_tac \\ Cases_on `lookup_vars vs env1` \\ fs [] - \\ fs [LIST_REL_EL_EQN]); + \\ fs [LIST_REL_EL_EQN] +QED -Theorem find_code_lemma - `!s t p args. state_rel s t ==> +Theorem find_code_lemma: + !s t p args. state_rel s t ==> find_code p args s.code = NONE /\ - find_code p args t.code = NONE` - (fs [state_rel_def, find_code_def]); + find_code p args t.code = NONE +Proof + fs [state_rel_def, find_code_def] +QED -Theorem dest_closure_SOME_IMP - `dest_closure max_app loc_opt f2 xs = SOME x ==> +Theorem dest_closure_SOME_IMP: + dest_closure max_app loc_opt f2 xs = SOME x ==> (?loc arg_env clo_env num_args e. f2 = Closure loc arg_env clo_env num_args e) \/ - (?loc arg_env clo_env fns i. f2 = Recclosure loc arg_env clo_env fns i)` - (fs [dest_closure_def,case_eq_thms] \\ rw [] \\ fs []); + (?loc arg_env clo_env fns i. f2 = Recclosure loc arg_env clo_env fns i) +Proof + fs [dest_closure_def,case_eq_thms] \\ rw [] \\ fs [] +QED -Theorem dest_closure_SOME_Full_app - `v_rel f1 f2 /\ v_rel a1 a2 /\ LIST_REL v_rel args1 args2 /\ +Theorem dest_closure_SOME_Full_app: + v_rel f1 f2 /\ v_rel a1 a2 /\ LIST_REL v_rel args1 args2 /\ dest_closure max_app loc_opt f1 (a1::args1) = SOME (Full_app exp1 env1 rest_args1) ==> ?exp2 env2 rest_args2. code_rel [exp1] [exp2] /\ LIST_REL v_rel env1 env2 /\ LIST_REL v_rel rest_args1 rest_args2 /\ - dest_closure max_app loc_opt f2 (a2::args2) = SOME (Full_app exp2 env2 rest_args2)` - (rpt strip_tac + dest_closure max_app loc_opt f2 (a2::args2) = SOME (Full_app exp2 env2 rest_args2) +Proof + rpt strip_tac \\ imp_res_tac dest_closure_SOME_IMP \\ rveq \\ fs [] \\ rveq \\ imp_res_tac LIST_REL_LENGTH @@ -247,7 +266,8 @@ Theorem dest_closure_SOME_Full_app \\ irule EVERY2_TAKE \\ irule EVERY2_APPEND_suff \\ simp []) \\ irule EVERY2_DROP - \\ irule EVERY2_APPEND_suff \\ simp []); + \\ irule EVERY2_APPEND_suff \\ simp [] +QED val do_app_lemma = prove( ``state_rel s t /\ LIST_REL v_rel xs ys ==> @@ -615,27 +635,30 @@ Proof \\ fs [case_eq_thms] \\ rveq \\ fs [] QED -Theorem let_op_correct - `!xs env1 (s1:('c,'ffi) closSem$state) res1 s2 env2 t1. +Theorem let_op_correct: + !xs env1 (s1:('c,'ffi) closSem$state) res1 s2 env2 t1. evaluate (xs, env1, s1) = (res1, s2) /\ LIST_REL v_rel env1 env2 /\ state_rel s1 t1 ==> ?res2 t2. evaluate (let_op xs, env2, t1) = (res2, t2) /\ result_rel (LIST_REL v_rel) v_rel res1 res2 /\ - state_rel s2 t2` - (rpt strip_tac \\ drule (CONJUNCT1 evaluate_let_op) \\ simp [code_rel_def]) + state_rel s2 t2 +Proof + rpt strip_tac \\ drule (CONJUNCT1 evaluate_let_op) \\ simp [code_rel_def] +QED (* preservation of observational semantics *) -Theorem semantics_let_op - `semantics (ffi:'ffi ffi_state) max_app FEMPTY +Theorem semantics_let_op: + semantics (ffi:'ffi ffi_state) max_app FEMPTY co (pure_cc compile_inc cc) xs <> Fail ==> (!n. SND (SND (co n)) = []) /\ 1 <= max_app ==> semantics (ffi:'ffi ffi_state) max_app FEMPTY (pure_co compile_inc o co) cc (let_op xs) = semantics (ffi:'ffi ffi_state) max_app FEMPTY - co (pure_cc compile_inc cc) xs` - (strip_tac + co (pure_cc compile_inc cc) xs +Proof + strip_tac \\ ho_match_mp_tac IMP_semantics_eq \\ fs [] \\ fs [eval_sim_def] \\ rw [] \\ drule let_op_correct @@ -648,7 +671,8 @@ Theorem semantics_let_op \\ qexists_tac `0` \\ simp [] \\ fs [state_rel_def] \\ Cases_on `res1` \\ fs [] - \\ Cases_on `e` \\ fs []) + \\ Cases_on `e` \\ fs [] +QED (* syntactic properties *) @@ -669,9 +693,10 @@ val var_list_let_op_IMP_code_locs = prove( \\ Cases_on `l` \\ fs [let_op_def,var_list_def,code_locs_def] \\ every_case_tac \\ fs [var_list_def]); -Theorem code_locs_let_op - `!xs. code_locs (let_op xs) = code_locs xs` - (ho_match_mp_tac let_op_ind \\ rw [] +Theorem code_locs_let_op: + !xs. code_locs (let_op xs) = code_locs xs +Proof + ho_match_mp_tac let_op_ind \\ rw [] \\ fs [code_locs_def,let_op_def] THEN1 (`?y. let_op [x] = [y]` by metis_tac [let_op_SING] @@ -688,11 +713,13 @@ Theorem code_locs_let_op \\ Induct_on `fns` \\ fs [FORALL_PROD] \\ rw [] \\ fs [] \\ once_rewrite_tac [code_locs_cons] \\ fs [] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem let_op_every_Fn_SOME[simp] - `∀es. every_Fn_SOME (let_op es) ⇔ every_Fn_SOME es` - (recInduct clos_letopTheory.let_op_ind +Theorem let_op_every_Fn_SOME[simp]: + ∀es. every_Fn_SOME (let_op es) ⇔ every_Fn_SOME es +Proof + recInduct clos_letopTheory.let_op_ind \\ rw[clos_letopTheory.let_op_def] >- ( fs[Once every_Fn_SOME_EVERY] @@ -719,11 +746,13 @@ Theorem let_op_every_Fn_SOME[simp] \\ fs[EVERY_MEM,UNCURRY,MEM_MAP,PULL_EXISTS,FORALL_PROD] \\ simp[Once every_Fn_SOME_EVERY, SimpRHS] \\ simp[EVERY_MEM,MEM_MAP,PULL_EXISTS,FORALL_PROD] - \\ metis_tac[])); + \\ metis_tac[]) +QED -Theorem let_op_every_Fn_vs_NONE[simp] - `∀es. every_Fn_vs_NONE (let_op es) ⇔ every_Fn_vs_NONE es` - (recInduct clos_letopTheory.let_op_ind +Theorem let_op_every_Fn_vs_NONE[simp]: + ∀es. every_Fn_vs_NONE (let_op es) ⇔ every_Fn_vs_NONE es +Proof + recInduct clos_letopTheory.let_op_ind \\ rw[clos_letopTheory.let_op_def] >- ( fs[Once every_Fn_vs_NONE_EVERY] @@ -750,20 +779,26 @@ Theorem let_op_every_Fn_vs_NONE[simp] \\ fs[EVERY_MEM,UNCURRY,MEM_MAP,PULL_EXISTS,FORALL_PROD] \\ simp[Once every_Fn_vs_NONE_EVERY, SimpRHS] \\ simp[EVERY_MEM,MEM_MAP,PULL_EXISTS,FORALL_PROD] - \\ metis_tac[])); + \\ metis_tac[]) +QED -Theorem EVERY_let_op_sing - `EVERY f (let_op [x]) = f (HD (let_op [x]))` - (qspec_then`x`strip_assume_tac let_op_SING \\ fs []); +Theorem EVERY_let_op_sing: + EVERY f (let_op [x]) = f (HD (let_op [x])) +Proof + qspec_then`x`strip_assume_tac let_op_SING \\ fs [] +QED -Theorem var_list_no_Labels - `!n l m. var_list n l m ==> EVERY no_Labels l /\ EVERY (obeys_max_app k) l` - (Induct_on `l` \\ Cases_on `m` \\ fs [var_list_def] - \\ Cases \\ fs [var_list_def] \\ rw [] \\ res_tac \\ fs []); +Theorem var_list_no_Labels: + !n l m. var_list n l m ==> EVERY no_Labels l /\ EVERY (obeys_max_app k) l +Proof + Induct_on `l` \\ Cases_on `m` \\ fs [var_list_def] + \\ Cases \\ fs [var_list_def] \\ rw [] \\ res_tac \\ fs [] +QED -Theorem let_op_obeys_max_app - `∀es. EVERY (obeys_max_app k) (let_op es) ⇔ EVERY (obeys_max_app k) es` - (recInduct clos_letopTheory.let_op_ind +Theorem let_op_obeys_max_app: + ∀es. EVERY (obeys_max_app k) (let_op es) ⇔ EVERY (obeys_max_app k) es +Proof + recInduct clos_letopTheory.let_op_ind \\ rw[clos_letopTheory.let_op_def] \\ fs [EVERY_let_op_sing] \\ TRY CASE_TAC \\ fs [LENGTH_let_op] THEN1 @@ -773,11 +808,13 @@ Theorem let_op_obeys_max_app \\ metis_tac [var_list_no_Labels]) \\ eq_tac \\ rw[] \\ fs [EVERY_MEM,MEM_MAP,FORALL_PROD,PULL_EXISTS] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem let_op_no_Labels - `∀es. EVERY no_Labels (let_op es) ⇔ EVERY no_Labels es` - (recInduct clos_letopTheory.let_op_ind +Theorem let_op_no_Labels: + ∀es. EVERY no_Labels (let_op es) ⇔ EVERY no_Labels es +Proof + recInduct clos_letopTheory.let_op_ind \\ rw[clos_letopTheory.let_op_def] \\ fs [EVERY_let_op_sing] \\ TRY CASE_TAC \\ fs [] THEN1 @@ -786,17 +823,21 @@ Theorem let_op_no_Labels \\ qsuff_tac `EVERY no_Labels l` THEN1 metis_tac [] \\ metis_tac [var_list_no_Labels]) \\ fs [EVERY_MEM,MEM_MAP,FORALL_PROD,PULL_EXISTS] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem var_list_app_call_dests - `∀x y z. var_list x y z ⇒ app_call_dests a y = {}` - (recInduct clos_letopTheory.var_list_ind +Theorem var_list_app_call_dests: + ∀x y z. var_list x y z ⇒ app_call_dests a y = {} +Proof + recInduct clos_letopTheory.var_list_ind \\ rw[clos_letopTheory.var_list_def] - \\ rw[Once app_call_dests_cons]); + \\ rw[Once app_call_dests_cons] +QED -Theorem let_op_app_call_dests[simp] - `∀es. app_call_dests x (let_op es) = app_call_dests x es` - (recInduct clos_letopTheory.let_op_ind +Theorem let_op_app_call_dests[simp]: + ∀es. app_call_dests x (let_op es) = app_call_dests x es +Proof + recInduct clos_letopTheory.let_op_ind \\ rw[clos_letopTheory.let_op_def] >- rw[Once closPropsTheory.app_call_dests_cons] >- ( @@ -810,16 +851,20 @@ Theorem let_op_app_call_dests[simp] \\ simp[app_call_dests_map] \\ AP_TERM_TAC \\ AP_TERM_TAC \\ simp[MAP_EQ_f, FORALL_PROD] \\ rw[] - \\ first_x_assum drule \\ rw[]); + \\ first_x_assum drule \\ rw[] +QED -Theorem var_list_code_labels_imp - `∀n x y. var_list n x y ⇒ BIGUNION (set (MAP get_code_labels x)) = {}` - (recInduct clos_letopTheory.var_list_ind - \\ rw[clos_letopTheory.var_list_def] \\ fs[]); +Theorem var_list_code_labels_imp: + ∀n x y. var_list n x y ⇒ BIGUNION (set (MAP get_code_labels x)) = {} +Proof + recInduct clos_letopTheory.var_list_ind + \\ rw[clos_letopTheory.var_list_def] \\ fs[] +QED -Theorem let_op_get_code_labels[simp] - `∀es. MAP get_code_labels (clos_letop$let_op es) = MAP get_code_labels es` - (recInduct clos_letopTheory.let_op_ind +Theorem let_op_get_code_labels[simp]: + ∀es. MAP get_code_labels (clos_letop$let_op es) = MAP get_code_labels es +Proof + recInduct clos_letopTheory.let_op_ind \\ rw[clos_letopTheory.let_op_def] \\ fs[] >- ( PURE_TOP_CASE_TAC \\ fs[] @@ -829,6 +874,7 @@ Theorem let_op_get_code_labels[simp] \\ fs[MAP_MAP_o, UNCURRY, o_DEF] \\ AP_TERM_TAC \\ AP_TERM_TAC \\ AP_TERM_TAC \\ simp[MAP_EQ_f, FORALL_PROD] \\ rw[] - \\ res_tac \\ fs[]); + \\ res_tac \\ fs[] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/clos_mtiProofScript.sml b/compiler/backend/proofs/clos_mtiProofScript.sml index 51471745b7..c7476f4076 100644 --- a/compiler/backend/proofs/clos_mtiProofScript.sml +++ b/compiler/backend/proofs/clos_mtiProofScript.sml @@ -55,33 +55,43 @@ val syntax_ok_def = tDefine "syntax_ok" ` (WF_REL_TAC `measure exp3_size` \\ rw [] \\ imp_res_tac closLang_exp_size_lemma \\ fs []); -Theorem syntax_ok_cons - `syntax_ok (x::xs) <=> syntax_ok [x] /\ syntax_ok xs` - (Cases_on `xs` \\ fs [syntax_ok_def]); - -Theorem syntax_ok_append[simp] - `!xs ys. syntax_ok (xs ++ ys) <=> syntax_ok xs /\ syntax_ok ys` - (Induct \\ fs [syntax_ok_def] +Theorem syntax_ok_cons: + syntax_ok (x::xs) <=> syntax_ok [x] /\ syntax_ok xs +Proof + Cases_on `xs` \\ fs [syntax_ok_def] +QED + +Theorem syntax_ok_append[simp]: + !xs ys. syntax_ok (xs ++ ys) <=> syntax_ok xs /\ syntax_ok ys +Proof + Induct \\ fs [syntax_ok_def] \\ once_rewrite_tac [syntax_ok_cons] - \\ fs [syntax_ok_def] \\ rw [] \\ eq_tac \\ rw[]); + \\ fs [syntax_ok_def] \\ rw [] \\ eq_tac \\ rw[] +QED -Theorem syntax_ok_REVERSE[simp] - `!xs. syntax_ok (REVERSE xs) <=> syntax_ok xs` - (ho_match_mp_tac (theorem "syntax_ok_ind") +Theorem syntax_ok_REVERSE[simp]: + !xs. syntax_ok (REVERSE xs) <=> syntax_ok xs +Proof + ho_match_mp_tac (theorem "syntax_ok_ind") \\ rw [syntax_ok_def] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem syntax_ok_MAP - `!xs. (!x. MEM x xs ==> syntax_ok [f x]) ==> syntax_ok (MAP f xs)` - (Induct +Theorem syntax_ok_MAP: + !xs. (!x. MEM x xs ==> syntax_ok [f x]) ==> syntax_ok (MAP f xs) +Proof + Induct \\ rw [syntax_ok_def] - \\ rw [Once syntax_ok_cons]); + \\ rw [Once syntax_ok_cons] +QED -Theorem syntax_ok_REPLICATE - `syntax_ok [x] ==> syntax_ok (REPLICATE n x)` - (Induct_on `n` +Theorem syntax_ok_REPLICATE: + syntax_ok [x] ==> syntax_ok (REPLICATE n x) +Proof + Induct_on `n` \\ rw [syntax_ok_def] - \\ rw [Once syntax_ok_cons]); + \\ rw [Once syntax_ok_cons] +QED (* code relation *) @@ -89,28 +99,36 @@ val code_rel_def = Define ` code_rel max_app e1 e2 <=> syntax_ok e1 /\ (e2 = intro_multi max_app e1)` -Theorem code_rel_IMP_LENGTH - `code_rel max_app xs ys ==> LENGTH ys = LENGTH xs` - (rw [code_rel_def,clos_mtiTheory.intro_multi_length]); - -Theorem HD_intro_multi[simp] - `[HD (intro_multi max_app [e2])] = intro_multi max_app [e2]` - (`?x. intro_multi max_app [e2] = [x]` by metis_tac [intro_multi_sing] - \\ fs []); +Theorem code_rel_IMP_LENGTH: + code_rel max_app xs ys ==> LENGTH ys = LENGTH xs +Proof + rw [code_rel_def,clos_mtiTheory.intro_multi_length] +QED -Theorem intro_multi_cons - `!xs x. intro_multi m (x::xs) = HD (intro_multi m [x]) :: intro_multi m xs` - (Induct \\ fs[intro_multi_def]); - -Theorem code_rel_CONS_CONS - `code_rel m (x1::x2::xs) (y1::y2::ys) <=> - code_rel m [x1] [y1] /\ code_rel m (x2::xs) (y2::ys)` - (fs [code_rel_def,syntax_ok_def,intro_multi_def] +Theorem HD_intro_multi[simp]: + [HD (intro_multi max_app [e2])] = intro_multi max_app [e2] +Proof + `?x. intro_multi max_app [e2] = [x]` by metis_tac [intro_multi_sing] + \\ fs [] +QED + +Theorem intro_multi_cons: + !xs x. intro_multi m (x::xs) = HD (intro_multi m [x]) :: intro_multi m xs +Proof + Induct \\ fs[intro_multi_def] +QED + +Theorem code_rel_CONS_CONS: + code_rel m (x1::x2::xs) (y1::y2::ys) <=> + code_rel m [x1] [y1] /\ code_rel m (x2::xs) (y2::ys) +Proof + fs [code_rel_def,syntax_ok_def,intro_multi_def] \\ `?t1. intro_multi m [x1] = [t1]` by metis_tac [intro_multi_sing] \\ `?t2. intro_multi m [x2] = [t2]` by metis_tac [intro_multi_sing] \\ fs [] \\ eq_tac \\ rw [] \\ pop_assum mp_tac - \\ once_rewrite_tac [intro_multi_cons] \\ fs []); + \\ once_rewrite_tac [intro_multi_cons] \\ fs [] +QED (* value relation *) @@ -183,9 +201,11 @@ val compile_inc_def = Define ` compile_inc max_app (e,es) = (intro_multi max_app e, [])` -Theorem SND_compile_inc[simp] - `SND (compile_inc max_app p) = []` - (Cases_on`p` \\ EVAL_TAC); +Theorem SND_compile_inc[simp]: + SND (compile_inc max_app p) = [] +Proof + Cases_on`p` \\ EVAL_TAC +QED val state_rel_def = Define ` state_rel (s:('c,'ffi) closSem$state) (t:('c,'ffi) closSem$state) <=> @@ -204,21 +224,24 @@ val state_rel_def = Define ` (* evaluation theorem *) -Theorem collect_args_IMP - `!max_app k e1 num_args e2. +Theorem collect_args_IMP: + !max_app k e1 num_args e2. collect_args max_app k e1 = (num_args,e2) /\ k <= max_app ==> - k <= num_args /\ num_args <= max_app` - (recInduct collect_args_ind + k <= num_args /\ num_args <= max_app +Proof + recInduct collect_args_ind \\ rpt conj_tac \\ rpt gen_tac \\ strip_tac \\ fs [collect_args_def] - \\ rw [] \\ fs []); + \\ rw [] \\ fs [] +QED -Theorem collect_args_ok_IMP - `!max_app k e num_args e2. +Theorem collect_args_ok_IMP: + !max_app k e num_args e2. collect_args max_app k e = (num_args,e2) /\ syntax_ok [e] ==> ?ts. e = mk_Fns ts e2 ∧ num_args = k + LENGTH ts /\ - syntax_ok [e2]` - (recInduct collect_args_ind + syntax_ok [e2] +Proof + recInduct collect_args_ind \\ rw [] \\ fs [] \\ fs [collect_args_def] \\ rveq \\ TRY (fs [collect_args_def] \\ rveq @@ -229,13 +252,16 @@ Theorem collect_args_ok_IMP \\ first_x_assum drule \\ fs [syntax_ok_def] \\ rveq \\ strip_tac \\ fs [] \\ rveq - \\ qexists_tac `t::ts` \\ fs [mk_Fns_def]); + \\ qexists_tac `t::ts` \\ fs [mk_Fns_def] +QED -Theorem dest_closure_SOME_IMP - `dest_closure max_app loc_opt f2 xs = SOME x ==> +Theorem dest_closure_SOME_IMP: + dest_closure max_app loc_opt f2 xs = SOME x ==> (?loc arg_env clo_env num_args e. f2 = Closure loc arg_env clo_env num_args e) \/ - (?loc arg_env clo_env fns i. f2 = Recclosure loc arg_env clo_env fns i)` - (fs [dest_closure_def,case_eq_thms] \\ rw [] \\ fs []); + (?loc arg_env clo_env fns i. f2 = Recclosure loc arg_env clo_env fns i) +Proof + fs [dest_closure_def,case_eq_thms] \\ rw [] \\ fs [] +QED val collect_apps_acc = prove( ``!max_app acc e res s. @@ -278,12 +304,12 @@ val mk_Apps_def = Define ` mk_Apps e [] = e /\ mk_Apps e ((t,other)::ts) = App t NONE (mk_Apps e ts) [other]` -Theorem collect_apps_IMP_mk_Apps - `!es max_app (acc:closLang$exp list) e other e3. +Theorem collect_apps_IMP_mk_Apps = Q.prove(` + !es max_app (acc:closLang$exp list) e other e3. collect_apps max_app [] e = (other,e3) /\ syntax_ok es /\ es = [e] ==> ?ts. e = mk_Apps e3 (ZIP (ts, other)) /\ LENGTH other = LENGTH ts /\ - LENGTH other <= max_app` - (recInduct (theorem "syntax_ok_ind") \\ fs [] \\ rw [] + LENGTH other <= max_app`, + recInduct (theorem "syntax_ok_ind") \\ fs [] \\ rw [] \\ fs [collect_apps_def] \\ rveq \\ TRY (qexists_tac `[]` \\ fs [mk_Apps_def] \\ FULL_CASE_TAC \\ fs [] \\ rveq \\ fs [mk_Apps_def] \\ NO_TAC) @@ -326,14 +352,16 @@ val mk_Apps_err_2 = prove( \\ rveq \\ fs [] \\ fs [evaluate_def] \\ imp_res_tac evaluate_SING \\ rveq \\ fs []); -Theorem collect_apps_syntax_ok - `!k aux e res e1. +Theorem collect_apps_syntax_ok: + !k aux e res e1. collect_apps k aux e = (res,e1) /\ syntax_ok [e] /\ syntax_ok aux ==> - syntax_ok res /\ syntax_ok [e1]` - (recInduct collect_apps_ind + syntax_ok res /\ syntax_ok [e1] +Proof + recInduct collect_apps_ind \\ rw [collect_apps_def] \\ fs [] - \\ fs [syntax_ok_def]); + \\ fs [syntax_ok_def] +QED val evaluate_mk_Apps_err = prove( ``!other ts env1 s1 vs. @@ -512,14 +540,15 @@ val v_rel_opt_thm = prove( ``v_rel_opt m = OPTREL (v_rel m)``, fs [FUN_EQ_THM] \\ Cases \\ Cases \\ fs [OPTREL_def,v_rel_opt_def]); -Theorem do_app_lemma - `state_rel s (t:('c,'ffi) closSem$state) /\ LIST_REL (v_rel s.max_app) xs ys ==> +Theorem do_app_lemma: + state_rel s (t:('c,'ffi) closSem$state) /\ LIST_REL (v_rel s.max_app) xs ys ==> case do_app opp ys t of | Rerr err2 => (?err1. do_app opp xs s = Rerr err1 /\ exc_rel (v_rel s.max_app) err1 err2) | Rval (y,t1) => ?x s1. v_rel s.max_app x y /\ state_rel s1 t1 /\ - do_app opp xs s = Rval (x,s1)` - (mp_tac do_app_inst \\ fs [] + do_app opp xs s = Rval (x,s1) +Proof + mp_tac do_app_inst \\ fs [] \\ reverse impl_tac THEN1 (rw [] \\ fs [] \\ Cases_on `do_app opp ys t` \\ fs [] @@ -539,7 +568,8 @@ Theorem do_app_lemma THEN (rpt gen_tac \\ Cases_on `k = p` \\ fs [] THEN1 (fs [ref_rel_cases]) - \\ fs [FAPPLY_FUPDATE_THM])); + \\ fs [FAPPLY_FUPDATE_THM]) +QED val v_rel_IMP_v_to_bytes_lemma = prove( ``!y x. @@ -575,17 +605,22 @@ val v_rel_IMP_v_to_words = prove( ``v_rel max_app x y ==> v_to_words y = v_to_words x``, rw [v_to_words_def] \\ drule v_rel_IMP_v_to_words_lemma \\ fs []); -Theorem intro_multi_EQ_NIL[simp] - `∀max_app es. intro_multi max_app es = [] ⇔ es = []` - (ho_match_mp_tac clos_mtiTheory.intro_multi_ind >> +Theorem intro_multi_EQ_NIL[simp]: + ∀max_app es. intro_multi max_app es = [] ⇔ es = [] +Proof + ho_match_mp_tac clos_mtiTheory.intro_multi_ind >> simp[clos_mtiTheory.intro_multi_def] >> rpt strip_tac >> - rpt (pairarg_tac >> fs[])) + rpt (pairarg_tac >> fs[]) +QED -Theorem intro_multi_nil - `intro_multi x [] = []` (metis_tac[intro_multi_EQ_NIL]); +Theorem intro_multi_nil: + intro_multi x [] = [] +Proof +metis_tac[intro_multi_EQ_NIL] +QED -Theorem evaluate_intro_multi - `(!ys env2 (t1:('c,'ffi) closSem$state) env1 t2 s1 res2 xs. +Theorem evaluate_intro_multi: + (!ys env2 (t1:('c,'ffi) closSem$state) env1 t2 s1 res2 xs. (evaluate (ys,env2,t1) = (res2,t2)) /\ EVERY2 (v_rel s1.max_app) env1 env2 /\ state_rel s1 t1 /\ code_rel s1.max_app xs ys ==> @@ -600,8 +635,9 @@ Theorem evaluate_intro_multi ?res1 s2. (evaluate_apps f1 args1 s1 = (res1,s2)) /\ result_rel (LIST_REL (v_rel s1.max_app)) (v_rel s1.max_app) res1 res2 /\ - state_rel s2 t2)` - (ho_match_mp_tac (evaluate_ind |> Q.SPEC `λ(x1,x2,x3). P0 x1 x2 x3` + state_rel s2 t2) +Proof + ho_match_mp_tac (evaluate_ind |> Q.SPEC `λ(x1,x2,x3). P0 x1 x2 x3` |> Q.GEN `P0` |> SIMP_RULE std_ss [FORALL_PROD]) \\ rpt strip_tac \\ TRY (drule code_rel_IMP_LENGTH \\ strip_tac) @@ -1244,36 +1280,42 @@ Theorem evaluate_intro_multi \\ fs [] \\ first_x_assum match_mp_tac \\ fs [] \\ fs [Abbr `xxs`,Abbr`vvs`] \\ match_mp_tac EVERY2_DROP \\ fs [] - \\ match_mp_tac EVERY2_APPEND_suff \\ fs [])); + \\ match_mp_tac EVERY2_APPEND_suff \\ fs []) +QED -Theorem intro_multi_correct - `!xs env1 (s1:('c,'ffi) closSem$state) res1 s2 env2 t2 t1. +Theorem intro_multi_correct: + !xs env1 (s1:('c,'ffi) closSem$state) res1 s2 env2 t2 t1. evaluate (xs,env1,s1) = (res1,s2) /\ syntax_ok xs /\ LIST_REL (v_rel s1.max_app) env1 env2 /\ state_rel s1 t1 ==> ?res2 t2. evaluate (intro_multi s1.max_app xs,env2,t1) = (res2,t2) /\ result_rel (LIST_REL (v_rel s1.max_app)) (v_rel s1.max_app) res1 - res2 /\ state_rel s2 t2` - (rpt gen_tac + res2 /\ state_rel s2 t2 +Proof + rpt gen_tac \\ Cases_on `evaluate (intro_multi s1.max_app xs,env2,t1)` \\ fs [] \\ drule (CONJUNCT1 evaluate_intro_multi) \\ ntac 2 strip_tac \\ first_x_assum drule - \\ fs [code_rel_def] \\ disch_then drule \\ fs []); + \\ fs [code_rel_def] \\ disch_then drule \\ fs [] +QED (* syntax well-formedness *) -Theorem contains_App_SOME_collect_args - `∀m x y a b. collect_args m x y = (a,b) ⇒ - (contains_App_SOME m [y] ⇔ contains_App_SOME m [b])` - (ho_match_mp_tac collect_args_ind >> +Theorem contains_App_SOME_collect_args: + ∀m x y a b. collect_args m x y = (a,b) ⇒ + (contains_App_SOME m [y] ⇔ contains_App_SOME m [b]) +Proof + ho_match_mp_tac collect_args_ind >> srw_tac[][collect_args_def,contains_App_SOME_def] >> - srw_tac[][contains_App_SOME_def]); + srw_tac[][contains_App_SOME_def] +QED -Theorem contains_App_SOME_collect_apps - `∀max_app x y a b. collect_apps max_app x y = (a,b) ⇒ +Theorem contains_App_SOME_collect_apps: + ∀max_app x y a b. collect_apps max_app x y = (a,b) ⇒ (max_app < LENGTH x ∨ contains_App_SOME max_app x ∨ contains_App_SOME max_app [y] ⇔ - max_app < LENGTH a ∨ contains_App_SOME max_app a ∨ contains_App_SOME max_app [b])` - (ho_match_mp_tac collect_apps_ind >> + max_app < LENGTH a ∨ contains_App_SOME max_app a ∨ contains_App_SOME max_app [b]) +Proof + ho_match_mp_tac collect_apps_ind >> srw_tac[][collect_apps_def,contains_App_SOME_def] >> srw_tac[][contains_App_SOME_def] >> full_simp_tac(srw_ss())[] >> Cases_on`max_app < LENGTH x`>>full_simp_tac(srw_ss())[] >- DECIDE_TAC >> @@ -1281,11 +1323,13 @@ Theorem contains_App_SOME_collect_apps rev_full_simp_tac(srw_ss()++ARITH_ss)[] >> srw_tac[][] >> rpt (pop_assum mp_tac) >> ONCE_REWRITE_TAC[contains_App_SOME_EXISTS] >> srw_tac[][] >> - metis_tac[]); + metis_tac[] +QED -Theorem contains_App_SOME_intro_multi[simp] - `∀max_app es. contains_App_SOME max_app (intro_multi max_app es) ⇔ contains_App_SOME max_app es` - (ho_match_mp_tac intro_multi_ind >> +Theorem contains_App_SOME_intro_multi[simp]: + ∀max_app es. contains_App_SOME max_app (intro_multi max_app es) ⇔ contains_App_SOME max_app es +Proof + ho_match_mp_tac intro_multi_ind >> srw_tac[][intro_multi_def,contains_App_SOME_def] >> ONCE_REWRITE_TAC[CONS_APPEND] >> REWRITE_TAC[HD_intro_multi] >> @@ -1305,18 +1349,23 @@ Theorem contains_App_SOME_intro_multi[simp] rpt(pop_assum mp_tac) >> ONCE_REWRITE_TAC[contains_App_SOME_EXISTS] >> srw_tac[QUANT_INST_ss[pair_default_qp]][] >> - metis_tac[contains_App_SOME_collect_args,SND,PAIR])); - -Theorem contains_App_SOME_compile[simp] - `∀do_mti es. contains_App_SOME max_app (clos_mti$compile do_mti max_app es) ⇔ contains_App_SOME max_app es` - (Cases>>fs[clos_mtiTheory.compile_def]); - -Theorem collect_args_preserves_esgc_free - `∀max_app n e n' e'. collect_args max_app n e = (n',e') ∧ - esgc_free e ⇒ esgc_free e'` - (ho_match_mp_tac clos_mtiTheory.collect_args_ind >> + metis_tac[contains_App_SOME_collect_args,SND,PAIR]) +QED + +Theorem contains_App_SOME_compile[simp]: + ∀do_mti es. contains_App_SOME max_app (clos_mti$compile do_mti max_app es) ⇔ contains_App_SOME max_app es +Proof + Cases>>fs[clos_mtiTheory.compile_def] +QED + +Theorem collect_args_preserves_esgc_free: + ∀max_app n e n' e'. collect_args max_app n e = (n',e') ∧ + esgc_free e ⇒ esgc_free e' +Proof + ho_match_mp_tac clos_mtiTheory.collect_args_ind >> simp[clos_mtiTheory.collect_args_def, bool_case_eq] >> dsimp[] >> - rpt strip_tac >> metis_tac[set_globals_empty_esgc_free]); + rpt strip_tac >> metis_tac[set_globals_empty_esgc_free] +QED val every_Fn_vs_NONE_collect_apps = Q.prove( `∀max_app es e x y. collect_apps max_app es e = (x,y) ⇒ @@ -1333,9 +1382,10 @@ val every_Fn_vs_NONE_collect_args = Q.prove( ho_match_mp_tac collect_args_ind >> srw_tac[][collect_args_def] >> full_simp_tac(srw_ss())[]); -Theorem every_Fn_vs_NONE_intro_multi[simp] - `∀max_app es. every_Fn_vs_NONE (intro_multi max_app es) = every_Fn_vs_NONE es` - (ho_match_mp_tac intro_multi_ind >> +Theorem every_Fn_vs_NONE_intro_multi[simp]: + ∀max_app es. every_Fn_vs_NONE (intro_multi max_app es) = every_Fn_vs_NONE es +Proof + ho_match_mp_tac intro_multi_ind >> srw_tac[][intro_multi_def] >> ONCE_REWRITE_TAC[CONS_APPEND] >> REWRITE_TAC[HD_intro_multi] >> @@ -1353,43 +1403,54 @@ Theorem every_Fn_vs_NONE_intro_multi[simp] rpt(pop_assum mp_tac) >> ONCE_REWRITE_TAC[every_Fn_vs_NONE_EVERY] >> srw_tac[QUANT_INST_ss[pair_default_qp]][] >> - metis_tac[every_Fn_vs_NONE_collect_args,SND,PAIR]); + metis_tac[every_Fn_vs_NONE_collect_args,SND,PAIR] +QED -Theorem compile_EQ_NIL[simp] - `∀do_mti es. clos_mti$compile do_mti max_app es = [] ⇔ es = []` - (Cases>>fs[clos_mtiTheory.compile_def]); +Theorem compile_EQ_NIL[simp]: + ∀do_mti es. clos_mti$compile do_mti max_app es = [] ⇔ es = [] +Proof + Cases>>fs[clos_mtiTheory.compile_def] +QED -Theorem compile_length[simp] - `LENGTH (clos_mti$compile do_mti max_app es) = LENGTH es` - (Cases_on`do_mti` \\ rw[clos_mtiTheory.compile_def, clos_mtiTheory.intro_multi_length]); +Theorem compile_length[simp]: + LENGTH (clos_mti$compile do_mti max_app es) = LENGTH es +Proof + Cases_on`do_mti` \\ rw[clos_mtiTheory.compile_def, clos_mtiTheory.intro_multi_length] +QED val EVERY_HD = Q.prove( `EVERY P l ∧ l ≠ [] ⇒ P (HD l)`, Cases_on `l` >> simp[]); -Theorem collect_apps_preserves_set_globals - `∀max_app es e es' e'. +Theorem collect_apps_preserves_set_globals: + ∀max_app es e es' e'. collect_apps max_app es e = (es',e') ⇒ - elist_globals es ⊎ set_globals e = elist_globals es' ⊎ set_globals e'` - (ho_match_mp_tac clos_mtiTheory.collect_apps_ind >> + elist_globals es ⊎ set_globals e = elist_globals es' ⊎ set_globals e' +Proof + ho_match_mp_tac clos_mtiTheory.collect_apps_ind >> simp[clos_mtiTheory.collect_apps_def, bool_case_eq] >> rpt strip_tac >- (pop_assum (assume_tac o SYM) >> fs[elist_globals_append] >> metis_tac[bagTheory.COMM_BAG_UNION, bagTheory.ASSOC_BAG_UNION]) - >- (rveq >> simp[])) + >- (rveq >> simp[]) +QED -Theorem collect_apps_preserves_esgc_free - `∀max_app es e es' e'. +Theorem collect_apps_preserves_esgc_free: + ∀max_app es e es' e'. collect_apps max_app es e = (es',e') ∧ EVERY esgc_free es ∧ esgc_free e ⇒ - EVERY esgc_free es' ∧ esgc_free e'` - (ho_match_mp_tac clos_mtiTheory.collect_apps_ind >> + EVERY esgc_free es' ∧ esgc_free e' +Proof + ho_match_mp_tac clos_mtiTheory.collect_apps_ind >> simp[clos_mtiTheory.collect_apps_def, bool_case_eq] >> rw[] >> - simp[] >> metis_tac[]); + simp[] >> metis_tac[] +QED -Theorem collect_args_preserves_set_globals - `∀max_app n e n' e'. collect_args max_app n e = (n',e') ⇒ set_globals e' = set_globals e` - (ho_match_mp_tac clos_mtiTheory.collect_args_ind >> +Theorem collect_args_preserves_set_globals: + ∀max_app n e n' e'. collect_args max_app n e = (n',e') ⇒ set_globals e' = set_globals e +Proof + ho_match_mp_tac clos_mtiTheory.collect_args_ind >> simp[clos_mtiTheory.collect_args_def, bool_case_eq] >> dsimp[] >> - rpt strip_tac >> pop_assum (assume_tac o SYM) >> fs[]); + rpt strip_tac >> pop_assum (assume_tac o SYM) >> fs[] +QED val intro1_pat = ``intro_multi max_app [e]`` fun intro_sing th = @@ -1405,9 +1466,10 @@ fun intro_sing th = clos_mtiTheory.intro_multi_sing t) | NONE => NO_TAC -Theorem intro_multi_preserves_elist_globals - `∀max_app es. elist_globals (intro_multi max_app es) = elist_globals es` - (ho_match_mp_tac clos_mtiTheory.intro_multi_ind >> +Theorem intro_multi_preserves_elist_globals: + ∀max_app es. elist_globals (intro_multi max_app es) = elist_globals es +Proof + ho_match_mp_tac clos_mtiTheory.intro_multi_ind >> simp[] >> rpt conj_tac >> simp[clos_mtiTheory.intro_multi_def] >> rpt strip_tac >> fs[] >> TRY (rpt (first_assum intro_sing >> fs[] >> pop_assum mp_tac) >> NO_TAC) @@ -1425,11 +1487,13 @@ Theorem intro_multi_preserves_elist_globals `∃e3'. intro_multi max_app [e3] = [e3']` by metis_tac[clos_mtiTheory.intro_multi_sing] >> simp[] >> rename1`EL n fns = (nn,e2)` >> `MEM (nn,e2) fns` by metis_tac[MEM_EL] >> - res_tac >> rfs[])) + res_tac >> rfs[]) +QED -Theorem intro_multi_preserves_esgc_free - `∀max_app es. EVERY esgc_free es ⇒ EVERY esgc_free (intro_multi max_app es)` - (ho_match_mp_tac clos_mtiTheory.intro_multi_ind >> +Theorem intro_multi_preserves_esgc_free: + ∀max_app es. EVERY esgc_free es ⇒ EVERY esgc_free (intro_multi max_app es) +Proof + ho_match_mp_tac clos_mtiTheory.intro_multi_ind >> simp[] >> rpt conj_tac >> simp[clos_mtiTheory.intro_multi_def] >> rpt strip_tac >> fs[] >> simp[EVERY_HD] >- (pairarg_tac >> fs[] >> @@ -1457,20 +1521,26 @@ Theorem intro_multi_preserves_esgc_free simp[] >> `elist_globals [e2'] = elist_globals [e2]` by metis_tac[intro_multi_preserves_elist_globals] >> - fs[] >> metis_tac[collect_args_preserves_set_globals])) - -Theorem compile_preserves_elist_globals - `∀do_mti es. elist_globals (clos_mti$compile do_mti max_app es) = elist_globals es` - (Cases>>fs[clos_mtiTheory.compile_def,intro_multi_preserves_elist_globals]) - -Theorem compile_preserves_esgc_free - `∀do_mti es. EVERY esgc_free es ⇒ - EVERY esgc_free (clos_mti$compile do_mti max_app es)` - (Cases>>fs[clos_mtiTheory.compile_def,intro_multi_preserves_esgc_free]) - -Theorem intro_multi_obeys_max_app - `!m xs. m ≠ 0 /\ syntax_ok xs ==> EVERY (obeys_max_app m) (intro_multi m xs)` - (ho_match_mp_tac intro_multi_ind \\ rw [] + fs[] >> metis_tac[collect_args_preserves_set_globals]) +QED + +Theorem compile_preserves_elist_globals: + ∀do_mti es. elist_globals (clos_mti$compile do_mti max_app es) = elist_globals es +Proof + Cases>>fs[clos_mtiTheory.compile_def,intro_multi_preserves_elist_globals] +QED + +Theorem compile_preserves_esgc_free: + ∀do_mti es. EVERY esgc_free es ⇒ + EVERY esgc_free (clos_mti$compile do_mti max_app es) +Proof + Cases>>fs[clos_mtiTheory.compile_def,intro_multi_preserves_esgc_free] +QED + +Theorem intro_multi_obeys_max_app: + !m xs. m ≠ 0 /\ syntax_ok xs ==> EVERY (obeys_max_app m) (intro_multi m xs) +Proof + ho_match_mp_tac intro_multi_ind \\ rw [] \\ fs [intro_multi_def,syntax_ok_def] \\ TRY (pop_assum mp_tac \\ once_rewrite_tac [syntax_ok_cons] @@ -1504,22 +1574,28 @@ Theorem intro_multi_obeys_max_app \\ rename [`_ = (_,e2)`] \\ `∃x. intro_multi m [e2] = [x]` by fs [clos_mtiTheory.intro_multi_sing] \\ fs [] \\ drule collect_args_ok_IMP \\ fs [] - \\ strip_tac \\ fs []); + \\ strip_tac \\ fs [] +QED -Theorem collect_apps_no_Labels - `!m es e es' e'. +Theorem collect_apps_no_Labels: + !m es e es' e'. collect_apps m es e = (es',e') /\ EVERY no_Labels es /\ no_Labels e ==> - EVERY no_Labels es' /\ no_Labels e'` - (ho_match_mp_tac collect_apps_ind \\ fs [collect_apps_def] \\ rw [] \\ fs []); - -Theorem collect_args_no_Labels - `!m na e es' e'. - collect_args m na e = (es',e') /\ no_Labels e ==> no_Labels e'` - (ho_match_mp_tac collect_args_ind \\ fs [] \\ rw [collect_args_def] \\ fs []); - -Theorem intro_multi_no_Labels - `!m xs. EVERY no_Labels xs ==> EVERY no_Labels (intro_multi m xs)` - (ho_match_mp_tac intro_multi_ind \\ rw [] + EVERY no_Labels es' /\ no_Labels e' +Proof + ho_match_mp_tac collect_apps_ind \\ fs [collect_apps_def] \\ rw [] \\ fs [] +QED + +Theorem collect_args_no_Labels: + !m na e es' e'. + collect_args m na e = (es',e') /\ no_Labels e ==> no_Labels e' +Proof + ho_match_mp_tac collect_args_ind \\ fs [] \\ rw [collect_args_def] \\ fs [] +QED + +Theorem intro_multi_no_Labels: + !m xs. EVERY no_Labels xs ==> EVERY no_Labels (intro_multi m xs) +Proof + ho_match_mp_tac intro_multi_ind \\ rw [] \\ fs [intro_multi_def,no_Labels_def] \\ TRY (`∃x. intro_multi m [e] = [x]` by fs [intro_multi_sing] @@ -1538,12 +1614,13 @@ Theorem intro_multi_no_Labels \\ first_x_assum match_mp_tac \\ rename [`_ = (_,e2)`] \\ `∃x. intro_multi m [e2] = [x]` by fs [clos_mtiTheory.intro_multi_sing] \\ fs [] - \\ imp_res_tac collect_args_no_Labels \\ fs []); + \\ imp_res_tac collect_args_no_Labels \\ fs [] +QED (* preservation of observable semantics *) -Theorem semantics_intro_multi - `semantics (ffi:'ffi ffi_state) max_app FEMPTY +Theorem semantics_intro_multi: + semantics (ffi:'ffi ffi_state) max_app FEMPTY co (pure_cc (compile_inc max_app) cc) xs <> Fail ==> (* (∀n. SND (SND (co n)) = [] ∧ syntax_ok (FST (SND (co n)))) ∧ @@ -1553,8 +1630,9 @@ Theorem semantics_intro_multi (pure_co (compile_inc max_app) ∘ co) cc (intro_multi max_app xs) = semantics (ffi:'ffi ffi_state) max_app FEMPTY - co (pure_cc (compile_inc max_app) cc) xs` - (strip_tac + co (pure_cc (compile_inc max_app) cc) xs +Proof + strip_tac \\ ho_match_mp_tac IMP_semantics_eq \\ fs [] \\ fs [eval_sim_def] \\ rw [] \\ drule (intro_multi_correct |> SIMP_RULE std_ss []) @@ -1567,18 +1645,21 @@ Theorem semantics_intro_multi \\ qexists_tac `0` \\ fs [] \\ fs [state_rel_def] \\ Cases_on `res1` \\ fs [] - \\ Cases_on `e` \\ fs []); + \\ Cases_on `e` \\ fs [] +QED -Theorem semantics_compile - `semantics ffi max_app FEMPTY co cc1 xs ≠ Fail ∧ +Theorem semantics_compile: + semantics ffi max_app FEMPTY co cc1 xs ≠ Fail ∧ cc1 = (if do_mti then pure_cc (compile_inc max_app) else I) cc ∧ co1 = (if do_mti then pure_co (compile_inc max_app) else I) o co ∧ (do_mti ⇒ (∀n. SND (SND (co n)) = [] ∧ syntax_ok (FST (SND (co n)))) ∧ 1 ≤ max_app ∧ syntax_ok xs) ⇒ semantics ffi max_app FEMPTY co1 cc (compile do_mti max_app xs) = - semantics ffi max_app FEMPTY co cc1 xs` - (strip_tac + semantics ffi max_app FEMPTY co cc1 xs +Proof + strip_tac \\ Cases_on`do_mti` \\ fs[compile_def] \\ irule semantics_intro_multi - \\ fs[]); + \\ fs[] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/clos_numberProofScript.sml b/compiler/backend/proofs/clos_numberProofScript.sml index af9a8ee899..2cf3c8fd91 100644 --- a/compiler/backend/proofs/clos_numberProofScript.sml +++ b/compiler/backend/proofs/clos_numberProofScript.sml @@ -31,31 +31,39 @@ fun tac (g as (asl,w)) = map_every (fn tm => Cases_on [ANTIQUOTE tm]) tms g end -Theorem renumber_code_locs_list_IMP_LENGTH - `renumber_code_locs_list loc es = (l1,es2) ==> LENGTH es2 = LENGTH es` - (metis_tac [SND,renumber_code_locs_length]); +Theorem renumber_code_locs_list_IMP_LENGTH: + renumber_code_locs_list loc es = (l1,es2) ==> LENGTH es2 = LENGTH es +Proof + metis_tac [SND,renumber_code_locs_length] +QED -Theorem renumber_code_locs_inc - `(∀n es. n ≤ FST (renumber_code_locs_list n es)) ∧ - (∀n e. n ≤ FST (renumber_code_locs n e))` - (ho_match_mp_tac renumber_code_locs_ind >> +Theorem renumber_code_locs_inc: + (∀n es. n ≤ FST (renumber_code_locs_list n es)) ∧ + (∀n e. n ≤ FST (renumber_code_locs n e)) +Proof + ho_match_mp_tac renumber_code_locs_ind >> simp[renumber_code_locs_def] >> srw_tac[][] >> tac >> full_simp_tac(srw_ss())[] >> tac >> full_simp_tac(srw_ss())[] >> tac >> full_simp_tac(srw_ss())[] >> simp[] >> - pairarg_tac \\ fs[] \\ pairarg_tac \\ fs[]); + pairarg_tac \\ fs[] \\ pairarg_tac \\ fs[] +QED -Theorem renumber_code_locs_imp_inc - `(renumber_code_locs_list n es = (m,vs) ⇒ n ≤ m) ∧ - (renumber_code_locs n e = (z,v) ⇒ n ≤ z)` - (metis_tac[pairTheory.pair_CASES,pairTheory.FST,renumber_code_locs_inc]) +Theorem renumber_code_locs_imp_inc: + (renumber_code_locs_list n es = (m,vs) ⇒ n ≤ m) ∧ + (renumber_code_locs n e = (z,v) ⇒ n ≤ z) +Proof + metis_tac[pairTheory.pair_CASES,pairTheory.FST,renumber_code_locs_inc] +QED -Theorem renumber_code_locs_list_length - `∀ls n x y. renumber_code_locs_list n ls = (x,y) ⇒ LENGTH y = LENGTH ls` - (Induct >> simp[renumber_code_locs_def,LENGTH_NIL] >> srw_tac[][] >> +Theorem renumber_code_locs_list_length: + ∀ls n x y. renumber_code_locs_list n ls = (x,y) ⇒ LENGTH y = LENGTH ls +Proof + Induct >> simp[renumber_code_locs_def,LENGTH_NIL] >> srw_tac[][] >> Cases_on`renumber_code_locs n h`>>full_simp_tac(srw_ss())[]>> Cases_on`renumber_code_locs_list q ls`>>full_simp_tac(srw_ss())[]>>srw_tac[][]>> - res_tac) + res_tac +QED val renumber_code_locs_distinct_lemma = Q.prove( `(∀n es. SORTED $< (code_locs (SND (renumber_code_locs_list n es))) ∧ @@ -111,27 +119,31 @@ val renumber_code_locs_distinct_lemma = Q.prove( rev_full_simp_tac(srw_ss())[MAP_ZIP] >> srw_tac[][] >> full_simp_tac(srw_ss())[EVERY_MEM] >> res_tac >> fsrw_tac[ARITH_ss][MAP_ZIP]); -Theorem renumber_code_locs_distinct - `∀n e. ALL_DISTINCT (code_locs [SND (renumber_code_locs n e)]) ∧ +Theorem renumber_code_locs_distinct: + ∀n e. ALL_DISTINCT (code_locs [SND (renumber_code_locs n e)]) ∧ EVERY ($<= n) (code_locs [SND (renumber_code_locs n e)]) ∧ - EVERY ($> (FST (renumber_code_locs n e))) (code_locs [SND (renumber_code_locs n e)])` - (srw_tac[][] >> + EVERY ($> (FST (renumber_code_locs n e))) (code_locs [SND (renumber_code_locs n e)]) +Proof + srw_tac[][] >> qspecl_then[`n`,`e`]strip_assume_tac (CONJUNCT2 renumber_code_locs_distinct_lemma) >> simp[] >> match_mp_tac (MP_CANON (GEN_ALL SORTED_ALL_DISTINCT)) >> qexists_tac`$<` >> simp[] >> - simp[relationTheory.irreflexive_def]) + simp[relationTheory.irreflexive_def] +QED -Theorem renumber_code_locs_list_distinct - `!n es. +Theorem renumber_code_locs_list_distinct: + !n es. ALL_DISTINCT (code_locs (SND (renumber_code_locs_list n es))) /\ EVERY ($<= n) (code_locs (SND (renumber_code_locs_list n es))) /\ EVERY ($> (FST (renumber_code_locs_list n es))) - (code_locs (SND (renumber_code_locs_list n es)))` - (rw [] + (code_locs (SND (renumber_code_locs_list n es))) +Proof + rw [] \\ qspecl_then [`n`,`es`] strip_assume_tac (CONJUNCT1 renumber_code_locs_distinct_lemma) \\ fs [] \\ match_mp_tac (MP_CANON (GEN_ALL SORTED_ALL_DISTINCT)) - \\ qexists_tac `$<` \\ simp [relationTheory.irreflexive_def]); + \\ qexists_tac `$<` \\ simp [relationTheory.irreflexive_def] +QED val renumber_code_locs_list_els = Q.prove( `∀ls ls' n n'. renumber_code_locs_list n ls = (n',ls') ⇒ @@ -237,16 +249,20 @@ val v_rel_simp = let ``v_rel max_app y (Recclosure x1 x2 x3 x4 x5)``] |> LIST_CONJ end |> curry save_thm"v_rel_simp" -Theorem v_rel_Boolv[simp] - `(v_rel max_app x (Boolv b) ⇔ (x = Boolv b)) ∧ - (v_rel max_app (Boolv b) x ⇔ (x = Boolv b))` - (Cases_on`b`>>srw_tac[][Boolv_def,Once v_rel_cases] >> - srw_tac[][Once v_rel_cases]) +Theorem v_rel_Boolv[simp]: + (v_rel max_app x (Boolv b) ⇔ (x = Boolv b)) ∧ + (v_rel max_app (Boolv b) x ⇔ (x = Boolv b)) +Proof + Cases_on`b`>>srw_tac[][Boolv_def,Once v_rel_cases] >> + srw_tac[][Once v_rel_cases] +QED -Theorem v_rel_Unit[simp] - `(v_rel max_app x Unit ⇔ (x = Unit)) ∧ - (v_rel max_app Unit x ⇔ (x = Unit))` - (EVAL_TAC >> simp[v_rel_simp]) +Theorem v_rel_Unit[simp]: + (v_rel max_app x Unit ⇔ (x = Unit)) ∧ + (v_rel max_app Unit x ⇔ (x = Unit)) +Proof + EVAL_TAC >> simp[v_rel_simp] +QED (* semantic functions respect relation *) @@ -404,8 +420,8 @@ val do_app_inst = |> Q.INST [`sr`|->`\r t. (r.max_app = s.max_app) /\ state_rel r t`] |> SIMP_RULE std_ss [] -Theorem do_app_lemma - `state_rel s t ∧ LIST_REL (v_rel s.max_app) xs ys ⇒ +Theorem do_app_lemma: + state_rel s t ∧ LIST_REL (v_rel s.max_app) xs ys ⇒ case do_app opp xs s of Rval (x,s1) => ∃y t1. @@ -415,8 +431,9 @@ Theorem do_app_lemma | Rerr err1 => ∃err2. do_app opp ys t = Rerr err2 ∧ - exc_rel (v_rel s.max_app) err1 err2` - (match_mp_tac do_app_inst + exc_rel (v_rel s.max_app) err1 err2 +Proof + match_mp_tac do_app_inst \\ conj_tac THEN1 (fs [simple_val_rel_def] \\ once_rewrite_tac [v_rel_cases] \\ fs [] @@ -432,14 +449,17 @@ Theorem do_app_lemma \\ rpt (qpat_x_assum `!x._` kall_tac) \\ rfs [] \\ Cases_on `r.refs ' ptr` \\ fs [ref_rel_def]) \\ rpt gen_tac \\ fs [] \\ Cases_on `x = p` \\ fs [FAPPLY_FUPDATE_THM] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem list_to_v_v_rel - `!xs ys. - LIST_REL (v_rel ap) xs ys ==> v_rel ap (list_to_v xs) (list_to_v ys)` - (Induct +Theorem list_to_v_v_rel: + !xs ys. + LIST_REL (v_rel ap) xs ys ==> v_rel ap (list_to_v xs) (list_to_v ys) +Proof + Induct >- rw [LIST_REL_EL_EQN, v_rel_simp, list_to_v_def] - \\ rw [] \\ fs [v_rel_simp, list_to_v_def]); + \\ rw [] \\ fs [v_rel_simp, list_to_v_def] +QED val do_app = Q.prove( `state_rel s1 s2 ∧ @@ -544,19 +564,23 @@ val do_install = Q.prove( (* compiler correctness *) -Theorem lookup_vars_NONE_related_env - `LIST_REL (v_rel max_app) e1 e2 ⇒ - (lookup_vars vs e1 = NONE ⇔ lookup_vars vs e2 = NONE)` - (strip_tac >> `LENGTH e1 = LENGTH e2` by metis_tac[LIST_REL_LENGTH] >> - metis_tac[lookup_vars_NONE]); +Theorem lookup_vars_NONE_related_env: + LIST_REL (v_rel max_app) e1 e2 ⇒ + (lookup_vars vs e1 = NONE ⇔ lookup_vars vs e2 = NONE) +Proof + strip_tac >> `LENGTH e1 = LENGTH e2` by metis_tac[LIST_REL_LENGTH] >> + metis_tac[lookup_vars_NONE] +QED -Theorem lookup_vars_SOME_related_env - `LIST_REL (v_rel max_app) e1 e2 ∧ lookup_vars vs e1 = SOME e1' ∧ - lookup_vars vs e2 = SOME e2' ⇒ LIST_REL (v_rel max_app) e1' e2'` - (map_every qid_spec_tac [`e2'`, `e1'`, `e2`, `e1`, `vs`] >> Induct >> +Theorem lookup_vars_SOME_related_env: + LIST_REL (v_rel max_app) e1 e2 ∧ lookup_vars vs e1 = SOME e1' ∧ + lookup_vars vs e2 = SOME e2' ⇒ LIST_REL (v_rel max_app) e1' e2' +Proof + map_every qid_spec_tac [`e2'`, `e1'`, `e2`, `e1`, `vs`] >> Induct >> simp[lookup_vars_def] >> dsimp[CaseEq"option"] >> reverse conj_tac >- metis_tac[] >> - simp[LIST_REL_EL_EQN]); + simp[LIST_REL_EL_EQN] +QED (* val do_install_Rabort = prove( @@ -568,8 +592,8 @@ val do_install_Rabort = prove( \\ fs [do_install_def,case_eq_thms,pair_case_eq,bool_case_eq]); *) -Theorem renumber_code_locs_correct - `(!tmp xs env (s1:(num#'c,'ffi) closSem$state) env' t1 res s2 n. +Theorem renumber_code_locs_correct: + (!tmp xs env (s1:(num#'c,'ffi) closSem$state) env' t1 res s2 n. tmp = (xs,env,s1) ∧ (evaluate (xs,env,s1) = (res,s2)) /\ res <> Rerr (Rabort Rtype_error) ⇒ ¬contains_App_SOME s1.max_app xs ∧ @@ -589,8 +613,9 @@ Theorem renumber_code_locs_correct ?res' t2. (evaluate_app loc f' args' t1 = (res',t2)) /\ result_rel (LIST_REL (v_rel s.max_app)) (v_rel s.max_app) res res' /\ - state_rel s2 t2)` - (ho_match_mp_tac evaluate_ind \\ srw_tac[][] + state_rel s2 t2) +Proof + ho_match_mp_tac evaluate_ind \\ srw_tac[][] THEN1 (* NIL *) (full_simp_tac(srw_ss())[renumber_code_locs_def,evaluate_def] \\ SRW_TAC [] []) @@ -921,24 +946,28 @@ Theorem renumber_code_locs_correct BasicProvers.EVERY_CASE_TAC >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> imp_res_tac state_rel_max_app >> - imp_res_tac evaluate_const >> fs[])); + imp_res_tac evaluate_const >> fs[]) +QED -Theorem renumber_code_locs_every_Fn_SOME - `(∀n es. every_Fn_SOME (SND (renumber_code_locs_list n es))) ∧ - (∀n e. every_Fn_SOME [SND (renumber_code_locs n e)])` - (ho_match_mp_tac renumber_code_locs_ind >> +Theorem renumber_code_locs_every_Fn_SOME: + (∀n es. every_Fn_SOME (SND (renumber_code_locs_list n es))) ∧ + (∀n e. every_Fn_SOME [SND (renumber_code_locs n e)]) +Proof + ho_match_mp_tac renumber_code_locs_ind >> srw_tac[][renumber_code_locs_def] >> srw_tac[][every_Fn_SOME_def] >> full_simp_tac(srw_ss())[] >> full_simp_tac(srw_ss())[Once every_Fn_SOME_EVERY] >> imp_res_tac renumber_code_locs_list_length >> full_simp_tac(srw_ss())[EVERY_MAP,ZIP_MAP] >> - full_simp_tac(srw_ss())[EVERY_MEM,MEM_ZIP,PULL_EXISTS,MEM_EL]); + full_simp_tac(srw_ss())[EVERY_MEM,MEM_ZIP,PULL_EXISTS,MEM_EL] +QED -Theorem renumber_code_locs_every_Fn_vs_NONE - `(∀n es. every_Fn_vs_NONE (SND (renumber_code_locs_list n es)) ⇔ +Theorem renumber_code_locs_every_Fn_vs_NONE: + (∀n es. every_Fn_vs_NONE (SND (renumber_code_locs_list n es)) ⇔ every_Fn_vs_NONE es) ∧ (∀n e. every_Fn_vs_NONE [SND (renumber_code_locs n e)] ⇔ - every_Fn_vs_NONE [e])` - (ho_match_mp_tac renumber_code_locs_ind >> + every_Fn_vs_NONE [e]) +Proof + ho_match_mp_tac renumber_code_locs_ind >> srw_tac[][renumber_code_locs_def] >> srw_tac[][] >> full_simp_tac(srw_ss())[] >- ( simp[Once every_Fn_vs_NONE_EVERY] >> simp[Once every_Fn_vs_NONE_EVERY,SimpRHS] >> @@ -947,12 +976,14 @@ Theorem renumber_code_locs_every_Fn_vs_NONE full_simp_tac(srw_ss())[Once every_Fn_vs_NONE_EVERY] >> full_simp_tac(srw_ss())[Once every_Fn_vs_NONE_EVERY,SimpRHS] >> full_simp_tac(srw_ss())[EVERY_MAP,ZIP_MAP] >> - full_simp_tac(srw_ss())[EVERY_MEM,MEM_ZIP,PULL_EXISTS,MEM_EL]); + full_simp_tac(srw_ss())[EVERY_MEM,MEM_ZIP,PULL_EXISTS,MEM_EL] +QED -Theorem renumber_code_locs_EVEN - `(∀n es. EVEN n ⇒ EVEN (FST (renumber_code_locs_list n es)) ∧ EVERY EVEN (code_locs (SND (renumber_code_locs_list n es)))) ∧ - (∀n e. EVEN n ⇒ EVEN (FST (renumber_code_locs n e)) ∧ EVERY EVEN (code_locs [SND (renumber_code_locs n e)]))` - (ho_match_mp_tac renumber_code_locs_ind +Theorem renumber_code_locs_EVEN: + (∀n es. EVEN n ⇒ EVEN (FST (renumber_code_locs_list n es)) ∧ EVERY EVEN (code_locs (SND (renumber_code_locs_list n es)))) ∧ + (∀n e. EVEN n ⇒ EVEN (FST (renumber_code_locs n e)) ∧ EVERY EVEN (code_locs [SND (renumber_code_locs n e)])) +Proof + ho_match_mp_tac renumber_code_locs_ind \\ rw[renumber_code_locs_def,code_locs_def] \\ rpt (pairarg_tac \\ fs[]) \\ fs[code_locs_def] @@ -961,30 +992,34 @@ Theorem renumber_code_locs_EVEN \\ fs[SIMP_RULE(srw_ss()++ARITH_ss)[]MOD_TIMES] \\ imp_res_tac renumber_code_locs_list_length \\ fs[MAP_ZIP,EVERY_GENLIST] \\ rw[] - \\ simp[EVEN_MOD2,SIMP_RULE(srw_ss()++ARITH_ss)[]MOD_TIMES]); + \\ simp[EVEN_MOD2,SIMP_RULE(srw_ss()++ARITH_ss)[]MOD_TIMES] +QED -Theorem renumber_code_locs_elist_globals - `(∀loc es n es'. +Theorem renumber_code_locs_elist_globals: + (∀loc es n es'. renumber_code_locs_list loc es = (n,es') ⇒ elist_globals es' = elist_globals es) ∧ (∀loc e n e'. renumber_code_locs loc e = (n, e') ⇒ - set_globals e' = set_globals e)` - (ho_match_mp_tac renumber_code_locs_ind >> + set_globals e' = set_globals e) +Proof + ho_match_mp_tac renumber_code_locs_ind >> simp[renumber_code_locs_def] >> rpt strip_tac >> rpt (pairarg_tac >> fs[]) >> rveq >> fs[EVAL ``op_gbag Add``] >> rename1`renumber_code_locs_list locn1 (MAP SND functions)` >> qspecl_then [`locn1`, `MAP SND functions`] mp_tac (CONJUNCT1 renumber_code_locs_length) >> - simp[] >> simp[MAP_ZIP]); + simp[] >> simp[MAP_ZIP] +QED -Theorem renumber_code_locs_esgc_free - `(∀loc es n es'. +Theorem renumber_code_locs_esgc_free: + (∀loc es n es'. renumber_code_locs_list loc es = (n,es') ∧ EVERY esgc_free es ⇒ EVERY esgc_free es') ∧ (∀loc e n e'. - renumber_code_locs loc e = (n,e') ∧ esgc_free e ⇒ esgc_free e')` - (ho_match_mp_tac renumber_code_locs_ind >> + renumber_code_locs loc e = (n,e') ∧ esgc_free e ⇒ esgc_free e') +Proof + ho_match_mp_tac renumber_code_locs_ind >> simp[renumber_code_locs_def] >> rpt strip_tac >> rpt (pairarg_tac >> fs[]) >> rveq >> fs[] >- (imp_res_tac renumber_code_locs_elist_globals >> simp[]) @@ -992,47 +1027,55 @@ Theorem renumber_code_locs_esgc_free qspecl_then [`locn1`, `MAP SND functions`] mp_tac (CONJUNCT1 renumber_code_locs_length) >> simp[] >> simp[MAP_ZIP] >> imp_res_tac renumber_code_locs_elist_globals >> - simp[])); + simp[]) +QED -Theorem renumber_code_locs_obeys_max_app - `(∀loc es n es'. +Theorem renumber_code_locs_obeys_max_app: + (∀loc es n es'. renumber_code_locs_list loc es = (n,es') ∧ EVERY (obeys_max_app m) es ⇒ EVERY (obeys_max_app m) es') ∧ (∀loc e n e'. - renumber_code_locs loc e = (n,e') ∧ obeys_max_app m e ⇒ obeys_max_app m e')` - (ho_match_mp_tac renumber_code_locs_ind + renumber_code_locs loc e = (n,e') ∧ obeys_max_app m e ⇒ obeys_max_app m e') +Proof + ho_match_mp_tac renumber_code_locs_ind \\ rw [renumber_code_locs_def] \\ fs [] \\ rpt (pairarg_tac \\ fs[]) \\ rveq \\ fs[] \\ imp_res_tac renumber_code_locs_list_IMP_LENGTH \\ fs [] \\ fs [] \\ rw [] \\ fs [EVERY_MEM,FORALL_PROD,MEM_MAP,PULL_EXISTS] - \\ fs [MEM_ZIP] \\ fs [PULL_EXISTS,MEM_EL]); + \\ fs [MEM_ZIP] \\ fs [PULL_EXISTS,MEM_EL] +QED -Theorem renumber_code_locs_no_Labels - `(∀loc es n es'. +Theorem renumber_code_locs_no_Labels: + (∀loc es n es'. renumber_code_locs_list loc es = (n,es') ∧ EVERY no_Labels es ⇒ EVERY no_Labels es') ∧ (∀loc e n e'. - renumber_code_locs loc e = (n,e') ∧ no_Labels e ⇒ no_Labels e')` - (ho_match_mp_tac renumber_code_locs_ind + renumber_code_locs loc e = (n,e') ∧ no_Labels e ⇒ no_Labels e') +Proof + ho_match_mp_tac renumber_code_locs_ind \\ rw [renumber_code_locs_def] \\ fs [] \\ rpt (pairarg_tac \\ fs[]) \\ rveq \\ fs[] \\ imp_res_tac renumber_code_locs_list_IMP_LENGTH \\ fs [] \\ fs [] \\ rw [] \\ fs [EVERY_MEM,FORALL_PROD,MEM_MAP,PULL_EXISTS] - \\ fs [MEM_ZIP] \\ fs [PULL_EXISTS,MEM_EL]); + \\ fs [MEM_ZIP] \\ fs [PULL_EXISTS,MEM_EL] +QED -Theorem renumber_code_locs_imp_EVEN - `(renumber_code_locs_list n es = (n',es') ∧ EVEN n ⇒ EVEN n') ∧ - (renumber_code_locs n e = (n',e') ∧ EVEN n ⇒ EVEN n')` - (rw[] +Theorem renumber_code_locs_imp_EVEN: + (renumber_code_locs_list n es = (n',es') ∧ EVEN n ⇒ EVEN n') ∧ + (renumber_code_locs n e = (n',e') ∧ EVEN n ⇒ EVEN n') +Proof + rw[] \\ strip_assume_tac(SPEC_ALL (CONJUNCT1 renumber_code_locs_EVEN)) \\ rfs[] - \\ strip_assume_tac(SPEC_ALL (CONJUNCT2 renumber_code_locs_EVEN)) \\ rfs[]); + \\ strip_assume_tac(SPEC_ALL (CONJUNCT2 renumber_code_locs_EVEN)) \\ rfs[] +QED -Theorem renumber_code_locs_get_code_labels - `(∀n es n' es'. renumber_code_locs_list n es = (n',es') ∧ EVERY ((=){}) (MAP get_code_labels es) ∧ EVEN n ⇒ +Theorem renumber_code_locs_get_code_labels: + (∀n es n' es'. renumber_code_locs_list n es = (n',es') ∧ EVERY ((=){}) (MAP get_code_labels es) ∧ EVEN n ⇒ BIGUNION (set (MAP get_code_labels es')) = { n + 2 * k | k | n + 2 * k < n' }) ∧ (∀n e n' e'. renumber_code_locs n e = (n',e') ∧ get_code_labels e = {} ∧ EVEN n ⇒ - get_code_labels e' = { n + 2 * k | k | n + 2 * k < n' })` - (ho_match_mp_tac clos_numberTheory.renumber_code_locs_ind + get_code_labels e' = { n + 2 * k | k | n + 2 * k < n' }) +Proof + ho_match_mp_tac clos_numberTheory.renumber_code_locs_ind \\ rw[clos_numberTheory.renumber_code_locs_def] \\ rpt(pairarg_tac \\ fs[]) \\ rveq \\ fs[] \\ imp_res_tac renumber_code_locs_imp_inc @@ -1210,23 +1253,26 @@ Theorem renumber_code_locs_get_code_labels \\ simp[EVEN_EXISTS] \\ strip_tac \\ rveq \\ fs[] \\ fs[LESS_EQ_EXISTS] \\ rveq \\ qexists_tac`k-p` - \\ simp[] ))); + \\ simp[] )) +QED -Theorem renumber_code_locs_any_dests - `(!k xs n ys. renumber_code_locs_list k xs = (n,ys) ==> any_dests ys = ∅) /\ - (!k x n y. renumber_code_locs k x = (n,y) ==> any_dests [y] = ∅)` - (ho_match_mp_tac clos_numberTheory.renumber_code_locs_ind \\ rpt strip_tac +Theorem renumber_code_locs_any_dests: + (!k xs n ys. renumber_code_locs_list k xs = (n,ys) ==> any_dests ys = ∅) /\ + (!k x n y. renumber_code_locs k x = (n,y) ==> any_dests [y] = ∅) +Proof + ho_match_mp_tac clos_numberTheory.renumber_code_locs_ind \\ rpt strip_tac \\ fs [clos_numberTheory.renumber_code_locs_def] \\ rveq \\ fs [] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] \\ once_rewrite_tac [closPropsTheory.app_call_dests_cons] \\ fs [] \\ `LENGTH fns = LENGTH fns'` by metis_tac [clos_numberTheory.renumber_code_locs_length,LENGTH_MAP,SND] - \\ fs [MAP_ZIP]); + \\ fs [MAP_ZIP] +QED (* preservation of observable semantics *) -Theorem semantics_number - `semantics (ffi:'ffi ffi_state) max_app FEMPTY co +Theorem semantics_number: + semantics (ffi:'ffi ffi_state) max_app FEMPTY co (state_cc (ignore_table compile_inc) cc) xs <> Fail ==> ¬contains_App_SOME max_app xs (* /\ (∀n. @@ -1236,8 +1282,9 @@ Theorem semantics_number (state_co (ignore_table compile_inc) co) cc (SND (renumber_code_locs_list n xs)) = semantics (ffi:'ffi ffi_state) max_app FEMPTY - co (state_cc (ignore_table compile_inc) cc) xs` - (strip_tac + co (state_cc (ignore_table compile_inc) cc) xs +Proof + strip_tac \\ ho_match_mp_tac IMP_semantics_eq \\ fs [] \\ fs [eval_sim_def] \\ rw [] \\ drule (renumber_code_locs_correct @@ -1253,6 +1300,7 @@ Theorem semantics_number \\ qexists_tac `0` \\ fs [] \\ fs [state_rel_def] \\ Cases_on `res1` \\ fs [] - \\ Cases_on `e` \\ fs []); + \\ Cases_on `e` \\ fs [] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/clos_ticksProofScript.sml b/compiler/backend/proofs/clos_ticksProofScript.sml index 8ca55a563b..bc71592f64 100644 --- a/compiler/backend/proofs/clos_ticksProofScript.sml +++ b/compiler/backend/proofs/clos_ticksProofScript.sml @@ -12,18 +12,24 @@ val _ = new_theory "clos_ticksProof"; val _ = temp_overload_on("remove_ticks",``clos_ticks$remove_ticks``); -Theorem remove_ticks_IMP_LENGTH - `!(es:closLang$exp list) xs. xs = remove_ticks es ==> LENGTH es = LENGTH xs` - (fs [LENGTH_remove_ticks]); +Theorem remove_ticks_IMP_LENGTH: + !(es:closLang$exp list) xs. xs = remove_ticks es ==> LENGTH es = LENGTH xs +Proof + fs [LENGTH_remove_ticks] +QED -Theorem remove_ticks_SING - `!e. ?e'. remove_ticks [e] = [e']` - (Induct \\ fs [remove_ticks_def]); +Theorem remove_ticks_SING: + !e. ?e'. remove_ticks [e] = [e'] +Proof + Induct \\ fs [remove_ticks_def] +QED -Theorem HD_remove_ticks_SING[simp] - `!x. [HD (remove_ticks [x])] = remove_ticks [x] ∧ - LENGTH (remove_ticks [x]) = 1` - (gen_tac \\ strip_assume_tac (Q.SPEC `x` remove_ticks_SING) \\ fs []); +Theorem HD_remove_ticks_SING[simp]: + !x. [HD (remove_ticks [x])] = remove_ticks [x] ∧ + LENGTH (remove_ticks [x]) = 1 +Proof + gen_tac \\ strip_assume_tac (Q.SPEC `x` remove_ticks_SING) \\ fs [] +QED (* code relation *) @@ -31,22 +37,28 @@ val code_rel_def = Define ` code_rel e1 e2 <=> e2 = remove_ticks e1`; -Theorem code_rel_IMP_LENGTH - `!xs ys. code_rel xs ys ==> LENGTH xs = LENGTH ys` - (fs [code_rel_def, LENGTH_remove_ticks]); +Theorem code_rel_IMP_LENGTH: + !xs ys. code_rel xs ys ==> LENGTH xs = LENGTH ys +Proof + fs [code_rel_def, LENGTH_remove_ticks] +QED -Theorem remove_ticks_CONS - `!es e. remove_ticks (e::es) = HD (remove_ticks [e])::remove_ticks es` - (Induct_on `es` \\ Induct_on `e` \\ fs [remove_ticks_def]); +Theorem remove_ticks_CONS: + !es e. remove_ticks (e::es) = HD (remove_ticks [e])::remove_ticks es +Proof + Induct_on `es` \\ Induct_on `e` \\ fs [remove_ticks_def] +QED -Theorem code_rel_CONS_CONS - `!x1 x2 xs y1 y2 ys. code_rel (x1::x2::xs) (y1::y2::ys) <=> - code_rel [x1] [y1] /\ code_rel (x2::xs) (y2::ys)` - (fs [code_rel_def] +Theorem code_rel_CONS_CONS: + !x1 x2 xs y1 y2 ys. code_rel (x1::x2::xs) (y1::y2::ys) <=> + code_rel [x1] [y1] /\ code_rel (x2::xs) (y2::ys) +Proof + fs [code_rel_def] \\ rpt strip_tac \\ `?t1. remove_ticks [x1] = [t1]` by metis_tac [remove_ticks_SING] \\ `?t2. remove_ticks [x2] = [t2]` by metis_tac [remove_ticks_SING] - \\ rw [remove_ticks_CONS]); + \\ rw [remove_ticks_CONS] +QED (* value relation *) @@ -121,108 +133,134 @@ val mk_Ticks_def = Define ` (mk_Ticks [] (e : closLang$exp) = e) /\ (mk_Ticks (t::tr) e = Tick t (mk_Ticks tr e))`; -Theorem remove_ticks_Tick - `!x t e. ~([Tick t e] = remove_ticks [x])` - (Induct \\ fs [remove_ticks_def]); +Theorem remove_ticks_Tick: + !x t e. ~([Tick t e] = remove_ticks [x]) +Proof + Induct \\ fs [remove_ticks_def] +QED -Theorem remove_ticks_Var_IMP_mk_Ticks - `(!x tr n. [Var tr n] = remove_ticks [x] ==> ?ts. x = mk_Ticks ts (Var tr n))` - (Induct \\ fs [remove_ticks_def] \\ metis_tac [mk_Ticks_def]); +Theorem remove_ticks_Var_IMP_mk_Ticks: + (!x tr n. [Var tr n] = remove_ticks [x] ==> ?ts. x = mk_Ticks ts (Var tr n)) +Proof + Induct \\ fs [remove_ticks_def] \\ metis_tac [mk_Ticks_def] +QED -Theorem remove_ticks_If_IMP_mk_Ticks - `!x tr e1' e2' e3'. +Theorem remove_ticks_If_IMP_mk_Ticks: + !x tr e1' e2' e3'. [If tr e1' e2' e3'] = remove_ticks [x] ==> ?ts e1 e2 e3. x = mk_Ticks ts (If tr e1 e2 e3) /\ e1' = HD (remove_ticks [e1]) /\ e2' = HD (remove_ticks [e2]) /\ - e3' = HD (remove_ticks [e3])` - (Induct \\ fs [remove_ticks_def] \\ rpt strip_tac + e3' = HD (remove_ticks [e3]) +Proof + Induct \\ fs [remove_ticks_def] \\ rpt strip_tac THEN1 (qexists_tac `[]` \\ fs [mk_Ticks_def]) - \\ res_tac \\ qexists_tac `t::ts` \\ metis_tac [mk_Ticks_def]); + \\ res_tac \\ qexists_tac `t::ts` \\ metis_tac [mk_Ticks_def] +QED -Theorem remove_ticks_Let_IMP_mk_Ticks - `!x t l e. [Let t l e] = remove_ticks [x] ==> +Theorem remove_ticks_Let_IMP_mk_Ticks: + !x t l e. [Let t l e] = remove_ticks [x] ==> (?ts l' e'. x = mk_Ticks ts (Let t l' e') /\ l = remove_ticks l' /\ - [e] = remove_ticks [e'])` - (Induct \\ fs [remove_ticks_def] \\ rpt strip_tac + [e] = remove_ticks [e']) +Proof + Induct \\ fs [remove_ticks_def] \\ rpt strip_tac THEN1 (qexists_tac `[]` \\ fs [mk_Ticks_def]) - \\ res_tac \\ qexistsl_tac [`t::ts`, `l'`, `e'`] \\ fs [mk_Ticks_def]); + \\ res_tac \\ qexistsl_tac [`t::ts`, `l'`, `e'`] \\ fs [mk_Ticks_def] +QED -Theorem remove_ticks_Raise_IMP_mk_Ticks - `!x t e. [Raise t e] = remove_ticks [x] ==> - (?ts e'. x = mk_Ticks ts (Raise t e') /\ [e] = remove_ticks [e'])` - (Induct \\ fs [remove_ticks_def] \\ rpt strip_tac +Theorem remove_ticks_Raise_IMP_mk_Ticks: + !x t e. [Raise t e] = remove_ticks [x] ==> + (?ts e'. x = mk_Ticks ts (Raise t e') /\ [e] = remove_ticks [e']) +Proof + Induct \\ fs [remove_ticks_def] \\ rpt strip_tac THEN1 (qexists_tac `[]` \\ fs [mk_Ticks_def]) - \\ res_tac \\ qexistsl_tac [`t::ts`, `e'`] \\ fs [mk_Ticks_def]); + \\ res_tac \\ qexistsl_tac [`t::ts`, `e'`] \\ fs [mk_Ticks_def] +QED -Theorem remove_ticks_Handle_IMP_mk_Ticks - `!x t e1' e2'. [Handle t e1' e2'] = remove_ticks [x] ==> +Theorem remove_ticks_Handle_IMP_mk_Ticks: + !x t e1' e2'. [Handle t e1' e2'] = remove_ticks [x] ==> (?ts e1 e2. x = mk_Ticks ts (Handle t e1 e2) /\ - [e1'] = remove_ticks [e1] /\ [e2'] = remove_ticks [e2])` - (Induct \\ fs [remove_ticks_def] \\ rpt strip_tac + [e1'] = remove_ticks [e1] /\ [e2'] = remove_ticks [e2]) +Proof + Induct \\ fs [remove_ticks_def] \\ rpt strip_tac THEN1 (qexists_tac `[]` \\ fs [mk_Ticks_def]) - \\ res_tac \\ qexistsl_tac [`t::ts`, `e1`, `e2`] \\ fs [mk_Ticks_def]); + \\ res_tac \\ qexistsl_tac [`t::ts`, `e1`, `e2`] \\ fs [mk_Ticks_def] +QED -Theorem remove_ticks_Op_IMP_mk_Ticks - `!x tr op es'. [Op tr op es'] = remove_ticks [x] ==> - ?ts es. x = mk_Ticks ts (Op tr op es) /\ es' = remove_ticks es` - (reverse (Induct \\ fs [remove_ticks_def]) \\ rpt strip_tac +Theorem remove_ticks_Op_IMP_mk_Ticks: + !x tr op es'. [Op tr op es'] = remove_ticks [x] ==> + ?ts es. x = mk_Ticks ts (Op tr op es) /\ es' = remove_ticks es +Proof + reverse (Induct \\ fs [remove_ticks_def]) \\ rpt strip_tac THEN1 (qexists_tac `[]` \\ fs [mk_Ticks_def]) - \\ res_tac \\ qexistsl_tac [`t::ts`, `es`] \\ fs [mk_Ticks_def]); + \\ res_tac \\ qexistsl_tac [`t::ts`, `es`] \\ fs [mk_Ticks_def] +QED -Theorem remove_ticks_Fn_IMP_mk_Ticks - `!x tr loc vsopt num_args e'. +Theorem remove_ticks_Fn_IMP_mk_Ticks: + !x tr loc vsopt num_args e'. [Fn tr loc vsopt num_args e'] = remove_ticks [x] ==> - ?ts e. x = mk_Ticks ts (Fn tr loc vsopt num_args e) /\ [e'] = remove_ticks [e]` - (reverse (Induct \\ fs [remove_ticks_def]) \\ rpt strip_tac + ?ts e. x = mk_Ticks ts (Fn tr loc vsopt num_args e) /\ [e'] = remove_ticks [e] +Proof + reverse (Induct \\ fs [remove_ticks_def]) \\ rpt strip_tac THEN1 (qexists_tac `[]` \\ fs [mk_Ticks_def]) - \\ res_tac \\ qexistsl_tac [`t::ts`, `e`] \\ fs [mk_Ticks_def]); + \\ res_tac \\ qexistsl_tac [`t::ts`, `e`] \\ fs [mk_Ticks_def] +QED -Theorem remove_ticks_Letrec_IMP_mk_Ticks - `!x tr loc vsopt fns' e'. +Theorem remove_ticks_Letrec_IMP_mk_Ticks: + !x tr loc vsopt fns' e'. [Letrec tr loc vsopt fns' e'] = remove_ticks [x] ==> ?ts fns e. x = mk_Ticks ts (Letrec tr loc vsopt fns e) /\ e' = HD (remove_ticks [e]) /\ - fns' = MAP (\(num_args, x). (num_args, HD (remove_ticks [x]))) fns` - (reverse (Induct \\ fs [remove_ticks_def]) \\ rpt strip_tac + fns' = MAP (\(num_args, x). (num_args, HD (remove_ticks [x]))) fns +Proof + reverse (Induct \\ fs [remove_ticks_def]) \\ rpt strip_tac THEN1 (qexists_tac `[]` \\ fs [mk_Ticks_def]) - \\ res_tac \\ qexistsl_tac [`t::ts`, `fns`, `e`] \\ fs [mk_Ticks_def]); + \\ res_tac \\ qexistsl_tac [`t::ts`, `fns`, `e`] \\ fs [mk_Ticks_def] +QED -Theorem remove_ticks_App_IMP_mk_Ticks - `!x tr loc_opt e1' es'. +Theorem remove_ticks_App_IMP_mk_Ticks: + !x tr loc_opt e1' es'. [App tr loc_opt e1' es'] = remove_ticks [x] ==> ?ts e1 es. x = mk_Ticks ts (App tr loc_opt e1 es) /\ e1' = HD (remove_ticks [e1]) /\ - es' = remove_ticks es` - (reverse (Induct \\ fs [remove_ticks_def]) \\ rpt strip_tac + es' = remove_ticks es +Proof + reverse (Induct \\ fs [remove_ticks_def]) \\ rpt strip_tac THEN1 (qexists_tac `[]` \\ fs [mk_Ticks_def]) - \\ res_tac \\ qexistsl_tac [`t::ts`, `e1`, `es`] \\ fs [mk_Ticks_def]); + \\ res_tac \\ qexistsl_tac [`t::ts`, `e1`, `es`] \\ fs [mk_Ticks_def] +QED -Theorem remove_ticks_Call_IMP_mk_Ticks - `!x tr ticks' dest es'. [Call tr ticks' dest es'] = remove_ticks [x] ==> +Theorem remove_ticks_Call_IMP_mk_Ticks: + !x tr ticks' dest es'. [Call tr ticks' dest es'] = remove_ticks [x] ==> ticks' = 0 /\ ?ts ticks es. x = mk_Ticks ts (Call tr ticks dest es) /\ - es' = remove_ticks es` - (reverse (Induct \\ rw [remove_ticks_def]) + es' = remove_ticks es +Proof + reverse (Induct \\ rw [remove_ticks_def]) THEN1 (qexists_tac `[]` \\ fs [mk_Ticks_def]) \\ rpt strip_tac \\ res_tac - \\ qexistsl_tac [`t::ts`, `ticks`, `es`] \\ fs [mk_Ticks_def]) + \\ qexistsl_tac [`t::ts`, `ticks`, `es`] \\ fs [mk_Ticks_def] +QED -Theorem remove_ticks_mk_Ticks - `!tr e. remove_ticks [mk_Ticks tr e] = remove_ticks [e]` - (Induct_on `tr` \\ fs [mk_Ticks_def, remove_ticks_def]); +Theorem remove_ticks_mk_Ticks: + !tr e. remove_ticks [mk_Ticks tr e] = remove_ticks [e] +Proof + Induct_on `tr` \\ fs [mk_Ticks_def, remove_ticks_def] +QED -Theorem evaluate_mk_Ticks - `!tr e env s1. +Theorem evaluate_mk_Ticks: + !tr e env s1. evaluate ([mk_Ticks tr e], env, s1) = if s1.clock < LENGTH tr then (Rerr (Rabort Rtimeout_error), s1 with clock := 0) - else evaluate ([e], env, dec_clock (LENGTH tr) s1)` - (Induct THEN1 simp [mk_Ticks_def, dec_clock_def] + else evaluate ([e], env, dec_clock (LENGTH tr) s1) +Proof + Induct THEN1 simp [mk_Ticks_def, dec_clock_def] \\ rw [] \\ fs [mk_Ticks_def, evaluate_def, dec_clock_def] THEN1 (IF_CASES_TAC \\ simp [state_component_equality]) - \\ fs [ADD1]); + \\ fs [ADD1] +QED val do_app_lemma = prove( ``state_rel s t /\ LIST_REL v_rel xs ys ==> @@ -241,38 +279,46 @@ val do_app_lemma = prove( \\ fs [FAPPLY_FUPDATE_THM] \\ rw [] \\ fs [ref_rel_cases]); -Theorem lookup_vars_lemma - `!vs env1 env2. LIST_REL v_rel env1 env2 ==> +Theorem lookup_vars_lemma: + !vs env1 env2. LIST_REL v_rel env1 env2 ==> case lookup_vars vs env2 of | NONE => lookup_vars vs env1 = NONE - | SOME l2 => ?l1. LIST_REL v_rel l1 l2 /\ lookup_vars vs env1 = SOME l1` - (Induct_on `vs` \\ fs [lookup_vars_def] + | SOME l2 => ?l1. LIST_REL v_rel l1 l2 /\ lookup_vars vs env1 = SOME l1 +Proof + Induct_on `vs` \\ fs [lookup_vars_def] \\ rpt strip_tac \\ imp_res_tac LIST_REL_LENGTH \\ rw [] \\ res_tac \\ Cases_on `lookup_vars vs env2` \\ fs [] - \\ fs [LIST_REL_EL_EQN]); + \\ fs [LIST_REL_EL_EQN] +QED -Theorem state_rel_IMP_max_app_EQ - `!s t. state_rel s t ==> s.max_app = t.max_app` - (fs [state_rel_def]); +Theorem state_rel_IMP_max_app_EQ: + !s t. state_rel s t ==> s.max_app = t.max_app +Proof + fs [state_rel_def] +QED val state_rel_IMP_code_FEMPTY = prove( ``!s t. state_rel s t ==> s.code = FEMPTY /\ t.code = FEMPTY``, fs [state_rel_def]); -Theorem state_rel_clock - `!s t k. state_rel (s with clock := k) (t with clock := k) <=> state_rel s (t with clock := s.clock)` - (rw [] \\ eq_tac \\ rw [state_rel_def]); +Theorem state_rel_clock: + !s t k. state_rel (s with clock := k) (t with clock := k) <=> state_rel s (t with clock := s.clock) +Proof + rw [] \\ eq_tac \\ rw [state_rel_def] +QED -Theorem dest_closure_SOME_IMP - `dest_closure max_app loc_opt f2 xs = SOME x ==> +Theorem dest_closure_SOME_IMP: + dest_closure max_app loc_opt f2 xs = SOME x ==> (?loc arg_env clo_env num_args e. f2 = Closure loc arg_env clo_env num_args e) \/ - (?loc arg_env clo_env fns i. f2 = Recclosure loc arg_env clo_env fns i)` - (fs [dest_closure_def,case_eq_thms] \\ rw [] \\ fs []); + (?loc arg_env clo_env fns i. f2 = Recclosure loc arg_env clo_env fns i) +Proof + fs [dest_closure_def,case_eq_thms] \\ rw [] \\ fs [] +QED val v_rel_IMP_v_to_bytes_lemma = prove( ``!y x. @@ -309,8 +355,8 @@ val v_rel_IMP_v_to_words = prove( rw [v_to_words_def] \\ drule v_rel_IMP_v_to_words_lemma \\ fs []); -Theorem evaluate_remove_ticks - `(!ys env2 (t1:('c,'ffi) closSem$state) res2 t2 env1 s1 xs. +Theorem evaluate_remove_ticks: + (!ys env2 (t1:('c,'ffi) closSem$state) res2 t2 env1 s1 xs. (evaluate (ys,env2,t1) = (res2,t2)) /\ LIST_REL v_rel env1 env2 /\ state_rel s1 t1 /\ code_rel xs ys ==> @@ -325,8 +371,9 @@ Theorem evaluate_remove_ticks ?ck res1 s2. (evaluate_app loc_opt f1 args1 (s1 with clock := s1.clock + ck) = (res1,s2)) /\ result_rel (LIST_REL v_rel) v_rel res1 res2 /\ - state_rel s2 t2)` - ((**) + state_rel s2 t2) +Proof + (**) ho_match_mp_tac (evaluate_ind |> Q.SPEC `λ(x1,x2,x3). P0 x1 x2 x3` |> Q.GEN `P0` |> SIMP_RULE std_ss [FORALL_PROD]) \\ rpt strip_tac @@ -892,30 +939,34 @@ Theorem evaluate_remove_ticks \\ disch_then drule \\ strip_tac \\ Cases_on `res1` \\ fs [] \\ rveq - \\ qexists_tac `ck` \\ fs []))) + \\ qexists_tac `ck` \\ fs [])) +QED -Theorem remove_ticks_correct - `(!xs env2 (t1:('c,'ffi) closSem$state) res2 t2 env1 s1. +Theorem remove_ticks_correct: + (!xs env2 (t1:('c,'ffi) closSem$state) res2 t2 env1 s1. (evaluate (remove_ticks xs,env2,t1) = (res2,t2)) /\ LIST_REL v_rel env1 env2 /\ state_rel s1 t1 ==> ?ck res1 s2. (evaluate (xs,env1,s1 with clock := s1.clock + ck) = (res1,s2)) /\ result_rel (LIST_REL v_rel) v_rel res1 res2 /\ - state_rel s2 t2)` - (rpt strip_tac \\ drule (CONJUNCT1 evaluate_remove_ticks) \\ simp [code_rel_def]); + state_rel s2 t2) +Proof + rpt strip_tac \\ drule (CONJUNCT1 evaluate_remove_ticks) \\ simp [code_rel_def] +QED (* preservation of observable semantics *) -Theorem semantics_remove_ticks - `semantics (ffi:'ffi ffi_state) max_app FEMPTY +Theorem semantics_remove_ticks: + semantics (ffi:'ffi ffi_state) max_app FEMPTY co (pure_cc compile_inc cc) xs <> Fail ==> (∀n. SND (SND (co n)) = []) /\ 1 <= max_app ==> semantics (ffi:'ffi ffi_state) max_app FEMPTY co (pure_cc compile_inc cc) xs = semantics (ffi:'ffi ffi_state) max_app FEMPTY (pure_co compile_inc ∘ co) cc - (remove_ticks xs)` - ((**) + (remove_ticks xs) +Proof + (**) strip_tac \\ ho_match_mp_tac IMP_semantics_eq_no_fail \\ fs [] \\ fs [eval_sim_def] \\ rw [] @@ -931,13 +982,15 @@ Theorem semantics_remove_ticks \\ rename1 `result_rel _ v_rel res2 _` \\ Cases_on `res2` \\ fs [] \\ TRY (Cases_on `e` \\ fs []) - \\ fs [state_rel_def]) + \\ fs [state_rel_def] +QED (* syntactic properties *) -Theorem code_locs_remove_ticks - `!xs. code_locs (remove_ticks xs) = code_locs xs` - (ho_match_mp_tac clos_ticksTheory.remove_ticks_ind \\ rw [] +Theorem code_locs_remove_ticks: + !xs. code_locs (remove_ticks xs) = code_locs xs +Proof + ho_match_mp_tac clos_ticksTheory.remove_ticks_ind \\ rw [] \\ fs [code_locs_def,clos_ticksTheory.remove_ticks_def] THEN1 (`?y. remove_ticks [x] = [y]` by metis_tac [remove_ticks_SING] @@ -945,53 +998,65 @@ Theorem code_locs_remove_ticks \\ Induct_on `fns` \\ fs [FORALL_PROD] \\ rw [] \\ fs [] \\ once_rewrite_tac [code_locs_cons] \\ fs [] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem remove_ticks_every_Fn_SOME[simp] - `∀ls. every_Fn_SOME (remove_ticks ls) ⇔ every_Fn_SOME ls` - (recInduct clos_ticksTheory.remove_ticks_ind +Theorem remove_ticks_every_Fn_SOME[simp]: + ∀ls. every_Fn_SOME (remove_ticks ls) ⇔ every_Fn_SOME ls +Proof + recInduct clos_ticksTheory.remove_ticks_ind \\ rw[clos_ticksTheory.remove_ticks_def] >- ( qspec_then`x`strip_assume_tac remove_ticks_SING \\ fs[] \\ fs[Once every_Fn_SOME_EVERY] ) \\ simp[Once every_Fn_SOME_EVERY,EVERY_MEM,MEM_MAP,PULL_EXISTS,FORALL_PROD] \\ simp[Once every_Fn_SOME_EVERY,SimpRHS,EVERY_MEM,MEM_MAP,PULL_EXISTS,FORALL_PROD] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem remove_ticks_every_Fn_vs_NONE[simp] - `∀ls. every_Fn_vs_NONE (remove_ticks ls) ⇔ every_Fn_vs_NONE ls` - (recInduct clos_ticksTheory.remove_ticks_ind +Theorem remove_ticks_every_Fn_vs_NONE[simp]: + ∀ls. every_Fn_vs_NONE (remove_ticks ls) ⇔ every_Fn_vs_NONE ls +Proof + recInduct clos_ticksTheory.remove_ticks_ind \\ rw[clos_ticksTheory.remove_ticks_def] >- ( qspec_then`x`strip_assume_tac remove_ticks_SING \\ fs[] \\ fs[Once every_Fn_vs_NONE_EVERY] ) \\ simp[Once every_Fn_vs_NONE_EVERY,EVERY_MEM,MEM_MAP,PULL_EXISTS,FORALL_PROD] \\ simp[Once every_Fn_vs_NONE_EVERY,SimpRHS,EVERY_MEM,MEM_MAP,PULL_EXISTS,FORALL_PROD] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem EVERY_remove_ticks_sing - `EVERY f (remove_ticks [x]) = f (HD (remove_ticks [x]))` - (qspec_then`x`strip_assume_tac remove_ticks_SING \\ fs []); +Theorem EVERY_remove_ticks_sing: + EVERY f (remove_ticks [x]) = f (HD (remove_ticks [x])) +Proof + qspec_then`x`strip_assume_tac remove_ticks_SING \\ fs [] +QED -Theorem remove_ticks_obeys_max_app - `!xs. EVERY (obeys_max_app m) xs ==> EVERY (obeys_max_app m) (remove_ticks xs)` - (recInduct clos_ticksTheory.remove_ticks_ind +Theorem remove_ticks_obeys_max_app: + !xs. EVERY (obeys_max_app m) xs ==> EVERY (obeys_max_app m) (remove_ticks xs) +Proof + recInduct clos_ticksTheory.remove_ticks_ind \\ rw[clos_ticksTheory.remove_ticks_def] \\ fs [EVERY_remove_ticks_sing,LENGTH_remove_ticks] \\ fs [EVERY_MEM,FORALL_PROD,MEM_MAP,PULL_EXISTS] - \\ rw [] \\ res_tac); + \\ rw [] \\ res_tac +QED -Theorem remove_ticks_no_Labels - `!xs. EVERY no_Labels xs ==> EVERY no_Labels (remove_ticks xs)` - (recInduct clos_ticksTheory.remove_ticks_ind +Theorem remove_ticks_no_Labels: + !xs. EVERY no_Labels xs ==> EVERY no_Labels (remove_ticks xs) +Proof + recInduct clos_ticksTheory.remove_ticks_ind \\ rw[clos_ticksTheory.remove_ticks_def] \\ fs [EVERY_remove_ticks_sing] \\ fs [EVERY_MEM,FORALL_PROD,MEM_MAP,PULL_EXISTS] - \\ rw [] \\ res_tac); + \\ rw [] \\ res_tac +QED -Theorem remove_ticks_app_call_dests[simp] - `∀es. app_call_dests x (remove_ticks es) = app_call_dests x es` - (recInduct clos_ticksTheory.remove_ticks_ind +Theorem remove_ticks_app_call_dests[simp]: + ∀es. app_call_dests x (remove_ticks es) = app_call_dests x es +Proof + recInduct clos_ticksTheory.remove_ticks_ind \\ rw[clos_ticksTheory.remove_ticks_def] >- rw[Once closPropsTheory.app_call_dests_cons] \\ AP_THM_TAC \\ AP_TERM_TAC @@ -999,15 +1064,18 @@ Theorem remove_ticks_app_call_dests[simp] \\ simp[app_call_dests_map] \\ AP_TERM_TAC \\ AP_TERM_TAC \\ simp[MAP_EQ_f, FORALL_PROD] \\ rw[] - \\ first_x_assum drule \\ rw[]); + \\ first_x_assum drule \\ rw[] +QED -Theorem remove_ticks_code_labels[simp] - `∀es. MAP get_code_labels (clos_ticks$remove_ticks es) = MAP get_code_labels es` - (recInduct clos_ticksTheory.remove_ticks_ind +Theorem remove_ticks_code_labels[simp]: + ∀es. MAP get_code_labels (clos_ticks$remove_ticks es) = MAP get_code_labels es +Proof + recInduct clos_ticksTheory.remove_ticks_ind \\ rw[clos_ticksTheory.remove_ticks_def] \\ fs[] \\ fs[MAP_MAP_o, UNCURRY, o_DEF] \\ AP_TERM_TAC \\ AP_TERM_TAC \\ AP_TERM_TAC \\ simp[MAP_EQ_f, FORALL_PROD] \\ rw[] - \\ res_tac \\ fs[]); + \\ res_tac \\ fs[] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/clos_to_bvlProofScript.sml b/compiler/backend/proofs/clos_to_bvlProofScript.sml index 6083fdf84b..aff02cfe7f 100644 --- a/compiler/backend/proofs/clos_to_bvlProofScript.sml +++ b/compiler/backend/proofs/clos_to_bvlProofScript.sml @@ -292,9 +292,11 @@ val p_genlist = Q.prove ( `EL k (MAP SND exps_ps) = EL k (GENLIST (λn. loc + (num_stubs max_app) + 2*n) (LENGTH exps_ps))` by metis_tac [] >> rev_full_simp_tac(srw_ss())[EL_MAP]); -Theorem list_CASE_same - `list_CASE ls (P []) (λx y. P (x::y)) = P ls` - (Cases_on`ls` \\ simp[]); +Theorem list_CASE_same: + list_CASE ls (P []) (λx y. P (x::y)) = P ls +Proof + Cases_on`ls` \\ simp[] +QED (* -- *) @@ -757,10 +759,12 @@ val code_installed_def = Define ` code_installed aux code = EVERY (\(n,num_args,exp). lookup n code = SOME (num_args,exp)) aux`; -Theorem code_installed_fromAList - `ALL_DISTINCT (MAP FST ls) ⇒ code_installed ls (fromAList ls)` - (srw_tac[][code_installed_def,EVERY_MEM,FORALL_PROD,lookup_fromAList] >> - metis_tac[ALOOKUP_ALL_DISTINCT_MEM]) +Theorem code_installed_fromAList: + ALL_DISTINCT (MAP FST ls) ⇒ code_installed ls (fromAList ls) +Proof + srw_tac[][code_installed_def,EVERY_MEM,FORALL_PROD,lookup_fromAList] >> + metis_tac[ALOOKUP_ALL_DISTINCT_MEM] +QED val closure_code_installed_def = Define ` closure_code_installed max_app code exps_ps (env:closSem$v list) = @@ -884,19 +888,23 @@ val add_args_F = Q.prove ( Cases_on `cl` >> srw_tac[][add_args_def]); -Theorem v_rel_Unit[simp] - `(v_rel max_app f refs code Unit y ⇔ (y = Unit)) ∧ - (v_rel max_app f refs code x Unit ⇔ (x = Unit))` - (EVAL_TAC >> simp[v_rel_cases] >> EVAL_TAC >> +Theorem v_rel_Unit[simp]: + (v_rel max_app f refs code Unit y ⇔ (y = Unit)) ∧ + (v_rel max_app f refs code x Unit ⇔ (x = Unit)) +Proof + EVAL_TAC >> simp[v_rel_cases] >> EVAL_TAC >> srw_tac[][EQ_IMP_THM] >> full_simp_tac(srw_ss())[add_args_F,cl_rel_F] >> - every_case_tac >> srw_tac[][] >> fsrw_tac[ARITH_ss][]) + every_case_tac >> srw_tac[][] >> fsrw_tac[ARITH_ss][] +QED -Theorem v_rel_Boolv[simp] - `(v_rel max_app f refs code (Boolv b) y ⇔ (y = Boolv b)) ∧ - (v_rel max_app f refs code x (Boolv b) ⇔ (x = Boolv b))` - (EVAL_TAC >> simp[v_rel_cases] >> EVAL_TAC >> simp[] >> +Theorem v_rel_Boolv[simp]: + (v_rel max_app f refs code (Boolv b) y ⇔ (y = Boolv b)) ∧ + (v_rel max_app f refs code x (Boolv b) ⇔ (x = Boolv b)) +Proof + EVAL_TAC >> simp[v_rel_cases] >> EVAL_TAC >> simp[] >> srw_tac[][EQ_IMP_THM] >> full_simp_tac(srw_ss())[cl_rel_F,add_args_F] >> - every_case_tac >> srw_tac[][] >> fsrw_tac[ARITH_ss][]) + every_case_tac >> srw_tac[][] >> fsrw_tac[ARITH_ss][] +QED val v_rel_SIMP = LIST_CONJ [``v_rel max_app f refs code (RefPtr p) y`` @@ -1028,19 +1036,23 @@ val state_rel_globals = Q.prove( LIST_REL (OPTREL (v_rel s.max_app f t.refs t.code)) s.globals (DROP num_added_globals t.globals)`, srw_tac[][state_rel_def]); -Theorem state_rel_clock[simp] - `(!f s t. state_rel f s (t with clock := x) = state_rel f s t) ∧ - (!f s t. state_rel f (s with clock := x) t = state_rel f s t)` - (srw_tac[][state_rel_def]); +Theorem state_rel_clock[simp]: + (!f s t. state_rel f s (t with clock := x) = state_rel f s t) ∧ + (!f s t. state_rel f (s with clock := x) t = state_rel f s t) +Proof + srw_tac[][state_rel_def] +QED -Theorem state_rel_refs_lookup - `state_rel f s1 s2 ∧ +Theorem state_rel_refs_lookup: + state_rel f s1 s2 ∧ FLOOKUP s1.refs p = SOME x ∧ FLOOKUP f p = SOME p' ⇒ ∃x'. FLOOKUP s2.refs p' = SOME x' ∧ - ref_rel (v_rel s1.max_app f s2.refs s2.code) x x'` - (rw[state_rel_def] - \\ res_tac \\ fs[] \\ rw[]); + ref_rel (v_rel s1.max_app f s2.refs s2.code) x x' +Proof + rw[state_rel_def] + \\ res_tac \\ fs[] \\ rw[] +QED val cl_rel_SUBMAP = Q.prove ( `cl_rel max_app f1 refs1 code (env,ys) x y ∧ @@ -1201,16 +1213,17 @@ val OPTREL_v_rel_NEW_F = Q.prove( Cases_on `x` \\ Cases_on `y` \\ full_simp_tac(srw_ss())[OPTREL_def] \\ METIS_TAC [v_rel_NEW_F]) |> MP_CANON; -Theorem state_rel_UPDATE_REF - `state_rel f2 p1 t2 ∧ +Theorem state_rel_UPDATE_REF: + state_rel f2 p1 t2 ∧ FLOOKUP f2 dst = SOME r2 ∧ FLOOKUP p1.refs dst = SOME v0 ∧ ref_rel (v_rel p1.max_app f2 t2.refs t2.code) v v' ∧ (∀bs. v' ≠ ByteArray T bs) ⇒ state_rel f2 (p1 with refs := p1.refs |+ (dst,v)) - (t2 with refs := t2.refs |+ (r2,v'))` - (rw[state_rel_def,FLOOKUP_UPDATE] + (t2 with refs := t2.refs |+ (r2,v')) +Proof + rw[state_rel_def,FLOOKUP_UPDATE] >- ( match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) \\ ONCE_REWRITE_TAC[CONJ_COMM] >> @@ -1250,12 +1263,14 @@ Theorem state_rel_UPDATE_REF rpt strip_tac >> match_mp_tac v_rel_UPDATE_REF >> fs[IN_FRANGE_FLOOKUP] - \\ asm_exists_tac \\ fs[] )); + \\ asm_exists_tac \\ fs[] ) +QED -Theorem state_rel_NEW_REF - `state_rel f2 p1 t2 ∧ p ∉ FDOM t2.refs ⇒ - state_rel f2 p1 (t2 with refs := t2.refs |+ (p,v))` - (rw[state_rel_def,FLOOKUP_UPDATE] +Theorem state_rel_NEW_REF: + state_rel f2 p1 t2 ∧ p ∉ FDOM t2.refs ⇒ + state_rel f2 p1 (t2 with refs := t2.refs |+ (p,v)) +Proof + rw[state_rel_def,FLOOKUP_UPDATE] >- ( match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) \\ ONCE_REWRITE_TAC[CONJ_COMM] >> @@ -1277,7 +1292,8 @@ Theorem state_rel_NEW_REF first_assum(match_exists_tac o concl) >> simp[] >> rpt strip_tac >> match_mp_tac v_rel_NEW_REF >> - fs[IN_FRANGE_FLOOKUP]); + fs[IN_FRANGE_FLOOKUP] +QED (* semantic functions respect relation *) @@ -1293,9 +1309,11 @@ val v_to_list = Q.prove( every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> srw_tac[][bvlSemTheory.v_to_list_def] >> res_tac >> srw_tac[][]); -Theorem not_isClos[simp] - `~isClos (if n < ^(closure_tag_def |> concl |> rand) then n else (n + 2)) ys` - (EVAL_TAC \\ rw []); +Theorem not_isClos[simp]: + ~isClos (if n < ^(closure_tag_def |> concl |> rand) then n else (n + 2)) ys +Proof + EVAL_TAC \\ rw [] +QED val do_eq = Q.prove( `INJ ($' f) (FDOM f) (FRANGE f) ∧ @@ -1350,20 +1368,24 @@ val do_eq_sym = Q.prove( srw_tac[][] >> full_simp_tac(srw_ss())[] ) >> srw_tac[][] >> every_case_tac >> fs[]); -Theorem do_eq_list_T_every - `∀vs1 vs2. do_eq_list r vs1 vs2 = Eq_val T ⇔ LIST_REL (λv1 v2. do_eq r v1 v2 = Eq_val T) vs1 vs2` - (Induct \\ simp[do_eq_def] +Theorem do_eq_list_T_every: + ∀vs1 vs2. do_eq_list r vs1 vs2 = Eq_val T ⇔ LIST_REL (λv1 v2. do_eq r v1 v2 = Eq_val T) vs1 vs2 +Proof + Induct \\ simp[do_eq_def] \\ Cases_on`vs2`\\ simp[do_eq_def] \\ srw_tac[][] - \\ every_case_tac \\ full_simp_tac(srw_ss())[]); + \\ every_case_tac \\ full_simp_tac(srw_ss())[] +QED -Theorem list_to_v_v_rel - `!xs ys. +Theorem list_to_v_v_rel: + !xs ys. LIST_REL (v_rel app f refs code) xs ys ==> - v_rel app f refs code (list_to_v xs) (list_to_v ys)` - (Induct + v_rel app f refs code (list_to_v xs) (list_to_v ys) +Proof + Induct >- rw [LIST_REL_EL_EQN, v_rel_SIMP, closSemTheory.list_to_v_def, list_to_v_def] - \\ rw [] \\ fs [v_rel_SIMP, closSemTheory.list_to_v_def, list_to_v_def]); + \\ rw [] \\ fs [v_rel_SIMP, closSemTheory.list_to_v_def, list_to_v_def] +QED val do_app = Q.prove( `(do_app op xs s1 = Rval (v,s2)) /\ @@ -1757,14 +1779,15 @@ val compile_exps_LIST_IMP_compile_exps_EL = Q.prove( \\ REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[code_installed_def]); -Theorem compile_exps_EL - `∀ls aux l2 aux2 n. compile_exps ma ls aux = (l2, aux2) ∧ +Theorem compile_exps_EL: + ∀ls aux l2 aux2 n. compile_exps ma ls aux = (l2, aux2) ∧ n < LENGTH ls ⇒ ∃auxn aux2n. compile_exps ma [EL n ls] auxn = ([EL n l2], aux2n) ∧ - IS_SUBLIST aux2 aux2n` - (ho_match_mp_tac SNOC_INDUCT + IS_SUBLIST aux2 aux2n +Proof + ho_match_mp_tac SNOC_INDUCT \\ fs[compile_exps_SNOC] \\ rw[] \\ pairarg_tac \\ fs[] @@ -1781,7 +1804,8 @@ Theorem compile_exps_EL \\ qspecl_then[`ma`,`[x]`,`aux1`]mp_tac compile_exps_acc \\ simp[] \\ rw[] \\ fs[IS_SUBLIST_APPEND] - \\ metis_tac[APPEND_ASSOC]); + \\ metis_tac[APPEND_ASSOC] +QED val evaluate_recc_Lets = Q.prove( `!(ll:(num#'a) list) n7 rr env' (t1:('c,'ffi) bvlSem$state) ys c8 (x:(num#'a)) (x':(num#'a)) ck. @@ -2560,29 +2584,35 @@ val s1 = ``s1:('c,'ffi) closSem$state``; val env_rel_ind = theorem"env_rel_ind"; -Theorem code_installed_subspt - `code_installed aux code1 /\ subspt code1 code2 ==> code_installed aux code2` - (rw[code_installed_def,EVERY_MEM] +Theorem code_installed_subspt: + code_installed aux code1 /\ subspt code1 code2 ==> code_installed aux code2 +Proof + rw[code_installed_def,EVERY_MEM] \\ res_tac \\ rpt(pairarg_tac \\ fs[]) - \\ fs[subspt_lookup]); + \\ fs[subspt_lookup] +QED -Theorem closure_code_installed_subspt - `closure_code_installed a code1 b c /\ subspt code1 code2 ==> closure_code_installed a code2 b c` - (rw[closure_code_installed_def,EVERY_MEM] +Theorem closure_code_installed_subspt: + closure_code_installed a code1 b c /\ subspt code1 code2 ==> closure_code_installed a code2 b c +Proof + rw[closure_code_installed_def,EVERY_MEM] \\ res_tac \\ rpt(pairarg_tac \\ fs[]) - \\ metis_tac[subspt_lookup,code_installed_subspt]); + \\ metis_tac[subspt_lookup,code_installed_subspt] +QED -Theorem cl_rel_subspt - `∀a b c. - cl_rel x y z code1 a b c ⇒ subspt code1 code2 ⇒ cl_rel x y z code2 a b c` - (ho_match_mp_tac cl_rel_ind \\ rw[] +Theorem cl_rel_subspt: + ∀a b c. + cl_rel x y z code1 a b c ⇒ subspt code1 code2 ⇒ cl_rel x y z code2 a b c +Proof + ho_match_mp_tac cl_rel_ind \\ rw[] \\ rw[Once cl_rel_cases] >- metis_tac[code_installed_subspt,subspt_lookup] >- metis_tac[code_installed_subspt,subspt_lookup] \\ disj2_tac \\ map_every qexists_tac[`exps_ps`,`r`] \\ fs[] - \\ metis_tac[closure_code_installed_subspt]); + \\ metis_tac[closure_code_installed_subspt] +QED val v_rel_subspt = Q.prove( `!x y. v_rel max_app f refs code1 x y ==> @@ -2600,19 +2630,23 @@ val v_rel_subspt = Q.prove( \\ metis_tac[cl_rel_subspt]) |> SPEC_ALL |> MP_CANON |> curry save_thm "v_rel_subspt"; -Theorem env_rel_subspt - `∀x y z code e1 e2. +Theorem env_rel_subspt: + ∀x y z code e1 e2. env_rel x y z code e1 e2 ⇒ - ∀code'. subspt code code' ⇒ env_rel x y z code' e1 e2` - (recInduct env_rel_ind + ∀code'. subspt code code' ⇒ env_rel x y z code' e1 e2 +Proof + recInduct env_rel_ind \\ rw[env_rel_def] - \\ metis_tac[v_rel_subspt]); + \\ metis_tac[v_rel_subspt] +QED -Theorem clos_tag_shift_eq_nil_tag[simp] - `(clos_tag_shift tag = nil_tag <=> tag = nil_tag) /\ - (clos_tag_shift tag = cons_tag <=> tag = cons_tag)` - (fs [clos_tag_shift_def] \\ rw [] \\ fs [] - \\ EVAL_TAC \\ decide_tac); +Theorem clos_tag_shift_eq_nil_tag[simp]: + (clos_tag_shift tag = nil_tag <=> tag = nil_tag) /\ + (clos_tag_shift tag = cons_tag <=> tag = cons_tag) +Proof + fs [clos_tag_shift_def] \\ rw [] \\ fs [] + \\ EVAL_TAC \\ decide_tac +QED val v_rel_IMP_v_to_words_lemma = prove( ``!x y. @@ -2652,9 +2686,11 @@ val v_rel_IMP_v_to_bytes = prove( rw [v_to_bytes_def,closSemTheory.v_to_bytes_def] \\ drule v_rel_IMP_v_to_bytes_lemma \\ fs []); -Theorem not_domain_lookup - `~(n IN domain x) <=> lookup n x = NONE` - (fs [domain_lookup] \\ Cases_on `lookup n x` \\ fs []); +Theorem not_domain_lookup: + ~(n IN domain x) <=> lookup n x = NONE +Proof + fs [domain_lookup] \\ Cases_on `lookup n x` \\ fs [] +QED val cl_rel_union = prove( ``!a x y. @@ -2721,17 +2757,20 @@ val v_rel_union = prove( \\ rpt strip_tac \\ match_mp_tac cl_rel_union \\ fs [])); -Theorem FEVERY_FUPDATE_LIST_SUFF - `!progs x p. FEVERY p x /\ EVERY p progs ==> FEVERY p (x |++ progs)` - (Induct \\ fs [FUPDATE_LIST] \\ rw [] \\ fs [] +Theorem FEVERY_FUPDATE_LIST_SUFF: + !progs x p. FEVERY p x /\ EVERY p progs ==> FEVERY p (x |++ progs) +Proof + Induct \\ fs [FUPDATE_LIST] \\ rw [] \\ fs [] \\ first_x_assum match_mp_tac \\ fs [] \\ Cases_on `h` \\ fs [FEVERY_FUPDATE] - \\ fs [FEVERY_DEF,FDOM_DRESTRICT,DRESTRICT_DEF]); + \\ fs [FEVERY_DEF,FDOM_DRESTRICT,DRESTRICT_DEF] +QED -Theorem code_installed_union - `code_installed aux y /\ DISJOINT (set (MAP FST aux)) (domain x) ==> - code_installed aux (union x y)` - (fs [code_installed_def,EVERY_MEM,FORALL_PROD] \\ rw [] +Theorem code_installed_union: + code_installed aux y /\ DISJOINT (set (MAP FST aux)) (domain x) ==> + code_installed aux (union x y) +Proof + fs [code_installed_def,EVERY_MEM,FORALL_PROD] \\ rw [] \\ first_x_assum drule \\ fs [lookup_union,case_eq_thms] \\ rw [] \\ disj1_tac @@ -2739,51 +2778,62 @@ Theorem code_installed_union \\ fs [METIS_PROVE [] ``~b\/c <=> b ==> c``,not_domain_lookup] \\ first_x_assum match_mp_tac \\ fs [MEM_MAP,EXISTS_PROD] - \\ asm_exists_tac \\ fs []); + \\ asm_exists_tac \\ fs [] +QED -Theorem code_installed_union1 - `code_installed aux t1 ⇒ code_installed aux (union t1 t2)` - (rw[code_installed_def,lookup_union,EVERY_MEM] +Theorem code_installed_union1: + code_installed aux t1 ⇒ code_installed aux (union t1 t2) +Proof + rw[code_installed_def,lookup_union,EVERY_MEM] \\ pairarg_tac \\ fs[] - \\ res_tac \\ fs[]); + \\ res_tac \\ fs[] +QED -Theorem code_installed_insert - `code_installed aux t /\ ~(MEM x (MAP FST aux)) ==> - code_installed aux (insert x y t)` - (fs [code_installed_def,EVERY_MEM,FORALL_PROD] \\ rw [] +Theorem code_installed_insert: + code_installed aux t /\ ~(MEM x (MAP FST aux)) ==> + code_installed aux (insert x y t) +Proof + fs [code_installed_def,EVERY_MEM,FORALL_PROD] \\ rw [] \\ first_x_assum drule \\ fs [lookup_insert,case_eq_thms] \\ fs [MEM_MAP,EXISTS_PROD] \\ rpt strip_tac \\ fs [] \\ CCONTR_TAC \\ fs [] - \\ rveq \\ fs [] \\ rfs []); + \\ rveq \\ fs [] \\ rfs [] +QED -Theorem code_installed_fromAList - `ALL_DISTINCT (MAP FST ls) ∧ IS_SUBLIST ls aux ==> - code_installed aux (fromAList ls)` - (fs [code_installed_def,EVERY_MEM,FORALL_PROD] \\ rw [] +Theorem code_installed_fromAList: + ALL_DISTINCT (MAP FST ls) ∧ IS_SUBLIST ls aux ==> + code_installed aux (fromAList ls) +Proof + fs [code_installed_def,EVERY_MEM,FORALL_PROD] \\ rw [] \\ fs [lookup_fromAList] \\ fs [ALOOKUP_APPEND, IS_SUBLIST_APPEND] \\ fs [case_eq_thms, ALL_DISTINCT_APPEND, MEM_MAP, PULL_EXISTS, EXISTS_PROD] \\ imp_res_tac MEM_ALOOKUP \\ fs [] - \\ metis_tac[pair_CASES,option_CASES]); + \\ metis_tac[pair_CASES,option_CASES] +QED -Theorem chains_exp_cons - `?k1 k2 other. chain_exps n real_es = (k1,0,k2)::other` - (Cases_on `real_es` \\ fs [chain_exps_def] - \\ rename [`h1::t1`] \\ Cases_on `t1` \\ fs [chain_exps_def]); +Theorem chains_exp_cons: + ?k1 k2 other. chain_exps n real_es = (k1,0,k2)::other +Proof + Cases_on `real_es` \\ fs [chain_exps_def] + \\ rename [`h1::t1`] \\ Cases_on `t1` \\ fs [chain_exps_def] +QED -Theorem compile_exps_APPEND - `!max_app xs ys aux. +Theorem compile_exps_APPEND: + !max_app xs ys aux. compile_exps max_app (xs ++ ys) aux = (let (c1,aux1) = compile_exps max_app xs aux in let (c2,aux2) = compile_exps max_app ys aux1 in - (c1 ++ c2,aux2))` - (strip_tac \\ Induct_on `xs` + (c1 ++ c2,aux2)) +Proof + strip_tac \\ Induct_on `xs` THEN1 (fs [compile_exps_def] \\ rw [] \\ pairarg_tac \\ fs []) \\ rpt strip_tac \\ simp [] \\ once_rewrite_tac [compile_exps_CONS] \\ simp [] - \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs []); + \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] +QED val compile_exps_chain_exps_cons = prove( ``!n h t a new_exps aux x6 x7. @@ -2797,12 +2847,13 @@ val compile_exps_chain_exps_cons = prove( \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] \\ rw [] \\ res_tac \\ fs []); -Theorem compile_exps_same_aux - `compile_exps max_app +Theorem compile_exps_same_aux: + compile_exps max_app (MAP (SND ∘ SND) (chain_exps n real_es)) [] = (new_exps,aux) /\ extract_name progs0 = (n,real_es) /\ - compile_exps max_app progs0 [] = (x6,x7) ==> x7 = aux` - (Cases_on `progs0` \\ fs [extract_name_def] \\ rw [] + compile_exps max_app progs0 [] = (x6,x7) ==> x7 = aux +Proof + Cases_on `progs0` \\ fs [extract_name_def] \\ rw [] THEN1 (fs [MAP,chain_exps_def,compile_exps_def]) \\ fs [option_case_eq] \\ rveq \\ fs [] THEN1 (imp_res_tac compile_exps_chain_exps_cons \\ fs []) @@ -2813,29 +2864,34 @@ Theorem compile_exps_same_aux \\ pairarg_tac \\ fs [] \\ rw [] \\ Cases_on `real_es` \\ imp_res_tac compile_exps_chain_exps_cons \\ fs [] - \\ fs [chain_exps_def,compile_exps_def]); + \\ fs [chain_exps_def,compile_exps_def] +QED -Theorem compile_exps_twice_IS_SUBLIST - `extract_name progs0 = (n,real_es) /\ +Theorem compile_exps_twice_IS_SUBLIST: + extract_name progs0 = (n,real_es) /\ compile_exps max_app (MAP (SND ∘ SND) (chain_exps n real_es) ++ progs1) [] = (new_exps,aux) /\ compile_exps max_app progs0 [] = (x6,x7) ==> - IS_SUBLIST aux x7` - (rw [] \\ fs [compile_exps_APPEND] + IS_SUBLIST aux x7 +Proof + rw [] \\ fs [compile_exps_APPEND] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] \\ drule (GEN_ALL compile_exps_same_aux) \\ disch_then drule \\ fs [] \\ rw [] \\ qspecl_then [`max_app`,`progs1`,`aux1`] mp_tac compile_exps_acc \\ fs [] \\ rw [] \\ fs [IS_SUBLIST_APPEND] - \\ qexists_tac `ys` \\ fs []); + \\ qexists_tac `ys` \\ fs [] +QED -Theorem code_installed_cons - `code_installed (x::xs) c ==> code_installed xs c` - (fs [code_installed_def]); +Theorem code_installed_cons: + code_installed (x::xs) c ==> code_installed xs c +Proof + fs [code_installed_def] +QED -Theorem chained_lemma - `!index all x6 t res t1 progs k1 d1 new_exps rest acc x7 max_app aux. +Theorem chained_lemma: + !index all x6 t res t1 progs k1 d1 new_exps rest acc x7 max_app aux. evaluate (x6,[],t) = (res,t1) /\ HD progs = (k1,0,d1) /\ Abbrev (progs = MAP2 (λ(loc,args,_) exp. (loc + num_stubs max_app,args,exp)) @@ -2847,8 +2903,9 @@ Theorem chained_lemma evaluate ([d1],[],t with clock := ck8 + t.clock) = (res8,t1) ∧ case res of Rval vs => res8 = Rval [LAST vs] - | Rerr v3 => res8 = Rerr v3` - (Induct_on `all` THEN1 fs [compile_exps_def] + | Rerr v3 => res8 = Rerr v3 +Proof + Induct_on `all` THEN1 fs [compile_exps_def] \\ rpt gen_tac \\ Cases_on `all` THEN1 (fs [chain_exps_def] \\ rpt strip_tac @@ -2903,10 +2960,11 @@ Theorem chained_lemma \\ reverse (Cases_on `res2`) \\ fs [] \\ rveq \\ fs [] \\ imp_res_tac evaluate_IMP_LENGTH \\ Cases_on `c2` \\ fs [] - \\ Cases_on `a` \\ fs []); + \\ Cases_on `a` \\ fs [] +QED -Theorem evaluate_IMP_evaluate_chained - `bvlSem$evaluate (x6,[],t:('c,'ffi) bvlSem$state) = (res,t1) /\ +Theorem evaluate_IMP_evaluate_chained: + bvlSem$evaluate (x6,[],t:('c,'ffi) bvlSem$state) = (res,t1) /\ Abbrev (progs ⧺ aux = (k1,0,d1)::rest) /\ Abbrev (progs = MAP2 (λ(loc,args,_) exp. (loc + num_stubs max_app,args,exp)) @@ -2920,8 +2978,9 @@ Theorem evaluate_IMP_evaluate_chained ?ck8 res8. bvlSem$evaluate ([d1],[],t with clock := t.clock + ck8) = (res8,t1) /\ case res of Rval vs => res8 = Rval [LAST vs] - | err => res8 = err` - (Cases_on `progs0` \\ fs [] + | err => res8 = err +Proof + Cases_on `progs0` \\ fs [] THEN1 (fs [extract_name_def] \\ rw [] \\ fs [compile_exps_def]) \\ fs [extract_name_def,option_case_eq] \\ rw [] THEN1 @@ -2972,7 +3031,8 @@ Theorem evaluate_IMP_evaluate_chained \\ Cases_on `c2` \\ fs [] \\ Cases_on `real_es` \\ fs [] \\ rename [`chain_exps kk (h5::t5)`] \\ Cases_on `t5` \\ fs [chain_exps_def] - \\ Cases_on `c1` \\ fs [chain_exps_def]); + \\ Cases_on `c1` \\ fs [chain_exps_def] +QED Theorem compile_exps_correct: (!tmp xs env ^s1 aux1 (t1:('c,'ffi) bvlSem$state) env' f1 res s2 ys aux2. @@ -4979,14 +5039,16 @@ val build_aux_thm = Q.prove( srw_tac[][GENLIST,REVERSE_APPEND,REVERSE_GENLIST,PRE_SUB1] >> simp[LIST_EQ_REWRITE]) -Theorem MEM_build_aux_imp_SND_MEM - `∀n ls acc m aux x. +Theorem MEM_build_aux_imp_SND_MEM: + ∀n ls acc m aux x. build_aux n ls acc = (m,aux) ∧ MEM x aux ⇒ - MEM (SND x) ls ∨ MEM x acc` - (Induct_on`ls` + MEM (SND x) ls ∨ MEM x acc +Proof + Induct_on`ls` \\ rw[clos_to_bvlTheory.build_aux_def] \\ first_x_assum drule \\ rw[] - \\ first_x_assum drule \\ rw[] \\ fs[]); + \\ first_x_assum drule \\ rw[] \\ fs[] +QED val lemma = Q.prove(` compile_exps max_app xs aux = (c,aux1) ⇒ @@ -4999,11 +5061,12 @@ val lemma2 = Q.prove(` ∃z. b = z ++ aux`, mp_tac (SPEC_ALL build_aux_acc) \\ rw[] \\ fs[]); -Theorem compile_exps_code_locs - `∀max_app xs aux ys aux2. +Theorem compile_exps_code_locs: + ∀max_app xs aux ys aux2. compile_exps max_app xs aux = (ys,aux2++aux) ⇒ - MAP FST aux2 = MAP ((+) (num_stubs max_app)) (REVERSE(code_locs xs))` - (ho_match_mp_tac compile_exps_ind >> rpt conj_tac >> + MAP FST aux2 = MAP ((+) (num_stubs max_app)) (REVERSE(code_locs xs)) +Proof + ho_match_mp_tac compile_exps_ind >> rpt conj_tac >> rw[compile_exps_def] >> rpt(pairarg_tac \\ fs[]) >> fs[case_eq_thms,code_locs_def,pair_case_eq] >> @@ -5020,17 +5083,19 @@ Theorem compile_exps_code_locs \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ imp_res_tac build_aux_thm \\ fs[LENGTH_MAP2,ADD1] - \\ simp[LIST_EQ_REWRITE]); + \\ simp[LIST_EQ_REWRITE] +QED -Theorem init_code_ok - `0 < max_app ⇒ +Theorem init_code_ok: + 0 < max_app ⇒ (!n. n < max_app ⇒ lookup (generic_app_fn_location n) (init_code max_app) = SOME (n + 2, generate_generic_app max_app n)) ∧ (!tot n. tot < max_app ∧ n < tot ⇒ lookup (partial_app_fn_location max_app tot n) (init_code max_app) = - SOME (tot - n + 1, generate_partial_app_closure_fn tot n))` - (srw_tac[][init_code_def, lookup_fromList, EL_APPEND1, partial_app_fn_location_def, + SOME (tot - n + 1, generate_partial_app_closure_fn tot n)) +Proof + srw_tac[][init_code_def, lookup_fromList, EL_APPEND1, partial_app_fn_location_def, generic_app_fn_location_def] >- decide_tac >- ( @@ -5044,39 +5109,47 @@ Theorem init_code_ok `max_app ≤ max_app + (n + tot * (tot − 1) DIV 2)` by decide_tac >> ONCE_REWRITE_TAC[GSYM APPEND_ASSOC] >> simp[EL_APPEND2] >> - rw [triangle_el_no_suff])); + rw [triangle_el_no_suff]) +QED -Theorem domain_init_code_lt_num_stubs - `∀max_app x. x ∈ domain (init_code max_app) ⇒ x < (num_stubs max_app)` - (simp[init_code_def,num_stubs_def,domain_fromList,LENGTH_FLAT,MAP_GENLIST,o_DEF] +Theorem domain_init_code_lt_num_stubs: + ∀max_app x. x ∈ domain (init_code max_app) ⇒ x < (num_stubs max_app) +Proof + simp[init_code_def,num_stubs_def,domain_fromList,LENGTH_FLAT,MAP_GENLIST,o_DEF] \\ simp[GSYM(SIMP_RULE(srw_ss())[K_DEF]REPLICATE_GENLIST),SUM_REPLICATE] - \\ simp [sum_genlist_triangle]); + \\ simp [sum_genlist_triangle] +QED -Theorem domain_init_code - `0 < max_app ⇒ domain (init_code max_app) = count (max_app + max_app * (max_app - 1) DIV 2)` - (rw[clos_to_bvlTheory.init_code_def, domain_fromList, LENGTH_FLAT, MAP_GENLIST, o_DEF, +Theorem domain_init_code: + 0 < max_app ⇒ domain (init_code max_app) = count (max_app + max_app * (max_app - 1) DIV 2) +Proof + rw[clos_to_bvlTheory.init_code_def, domain_fromList, LENGTH_FLAT, MAP_GENLIST, o_DEF, GSYM SUM_IMAGE_count_SUM_GENLIST] \\ qmatch_goalsub_abbrev_tac`SUM_IMAGE f` \\ `f = I` by simp[Abbr`f`,FUN_EQ_THM] - \\ rw[GSYM SUM_SET_DEF, SUM_SET_count]); + \\ rw[GSYM SUM_SET_DEF, SUM_SET_count] +QED -Theorem compile_prog_code_locs - `∀ls. +Theorem compile_prog_code_locs: + ∀ls. MAP FST (compile_prog max_app ls) = MAP ((+)(num_stubs max_app) o FST) ls ++ - MAP ((+)(num_stubs max_app)) (REVERSE (code_locs (MAP (SND o SND) ls)))` - (rw[compile_prog_def] + MAP ((+)(num_stubs max_app)) (REVERSE (code_locs (MAP (SND o SND) ls))) +Proof + rw[compile_prog_def] \\ pairarg_tac \\ fs[] \\ pop_assum mp_tac \\ specl_args_of_then``compile_exps``compile_exps_code_locs strip_assume_tac \\ strip_tac \\ fs[] \\ imp_res_tac compile_exps_LENGTH \\ fs[] \\ simp[MAP2_MAP, MAP_MAP_o, o_DEF, UNCURRY] - \\ simp[LIST_EQ_REWRITE,EL_MAP,EL_ZIP]); + \\ simp[LIST_EQ_REWRITE,EL_MAP,EL_ZIP] +QED -Theorem IMP_PERM_code_merge - `!xs ys zs. PERM (xs ++ ys) zs ==> PERM (code_merge xs ys) zs` - (HO_MATCH_MP_TAC code_merge_ind \\ rw [] +Theorem IMP_PERM_code_merge: + !xs ys zs. PERM (xs ++ ys) zs ==> PERM (code_merge xs ys) zs +Proof + HO_MATCH_MP_TAC code_merge_ind \\ rw [] \\ once_rewrite_tac [code_merge_def] \\ fs [] \\ Cases_on `xs` \\ fs [] \\ TRY (Cases_on `ys` \\ fs []) @@ -5094,56 +5167,69 @@ Theorem IMP_PERM_code_merge \\ simp [Once sortingTheory.PERM_CONS_EQ_APPEND] \\ rw [] \\ res_tac \\ simp [Once sortingTheory.PERM_CONS_EQ_APPEND] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem code_split_IMP_PERM - `!xs1 xs2 xs3 ts1 ts2. +Theorem code_split_IMP_PERM: + !xs1 xs2 xs3 ts1 ts2. code_split xs1 xs2 xs3 = (ts1,ts2) ==> - PERM (ts1 ++ ts2) (xs2 ++ xs3 ++ xs1)` - (Induct \\ fs [code_split_def] \\ rw [] \\ res_tac + PERM (ts1 ++ ts2) (xs2 ++ xs3 ++ xs1) +Proof + Induct \\ fs [code_split_def] \\ rw [] \\ res_tac \\ match_mp_tac PERM_TRANS \\ asm_exists_tac \\ fs [] \\ fs [sortingTheory.PERM_NIL,sortingTheory.PERM_CONS_EQ_APPEND] \\ qexists_tac `xs2 ++ xs3` \\ fs [sortingTheory.PERM_APPEND_IFF] - \\ fs [PERM_APPEND]); + \\ fs [PERM_APPEND] +QED -Theorem PERM_code_sort - `!xs. PERM (code_sort xs) xs` - (HO_MATCH_MP_TAC code_sort_ind \\ rw [code_sort_def] +Theorem PERM_code_sort: + !xs. PERM (code_sort xs) xs +Proof + HO_MATCH_MP_TAC code_sort_ind \\ rw [code_sort_def] \\ pairarg_tac \\ fs [] \\ match_mp_tac IMP_PERM_code_merge \\ imp_res_tac code_split_IMP_PERM \\ fs [] \\ match_mp_tac PERM_TRANS \\ once_rewrite_tac [CONJ_COMM] \\ asm_exists_tac \\ fs [] - \\ match_mp_tac sortingTheory.PERM_CONG \\ fs []); + \\ match_mp_tac sortingTheory.PERM_CONG \\ fs [] +QED -Theorem set_MAP_code_sort - `LIST_TO_SET (MAP f (code_sort x)) = set (MAP f x)` - (Q.ISPEC_THEN`x`mp_tac PERM_code_sort +Theorem set_MAP_code_sort: + LIST_TO_SET (MAP f (code_sort x)) = set (MAP f x) +Proof + Q.ISPEC_THEN`x`mp_tac PERM_code_sort \\ rw[EXTENSION, MEM_MAP] - \\ imp_res_tac MEM_PERM \\ fs[]); + \\ imp_res_tac MEM_PERM \\ fs[] +QED -Theorem ALL_DISTINCT_code_sort - `ALL_DISTINCT (MAP FST (code_sort xs)) <=> ALL_DISTINCT (MAP FST xs)` - (match_mp_tac sortingTheory.ALL_DISTINCT_PERM - \\ match_mp_tac sortingTheory.PERM_MAP \\ fs [PERM_code_sort]); +Theorem ALL_DISTINCT_code_sort: + ALL_DISTINCT (MAP FST (code_sort xs)) <=> ALL_DISTINCT (MAP FST xs) +Proof + match_mp_tac sortingTheory.ALL_DISTINCT_PERM + \\ match_mp_tac sortingTheory.PERM_MAP \\ fs [PERM_code_sort] +QED -Theorem PERM_IMP_fromAList_EQ_fromAList - `!xs ys. +Theorem PERM_IMP_fromAList_EQ_fromAList: + !xs ys. PERM xs ys ==> ALL_DISTINCT (MAP FST xs) ==> - fromAList xs = fromAList ys` - (Induct \\ fs [sortingTheory.PERM_NIL,sortingTheory.PERM_CONS_EQ_APPEND] + fromAList xs = fromAList ys +Proof + Induct \\ fs [sortingTheory.PERM_NIL,sortingTheory.PERM_CONS_EQ_APPEND] \\ rw [] \\ res_tac \\ fs [ALL_DISTINCT_APPEND] \\ fs [spt_eq_thm,wf_fromAList,lookup_fromAList] \\ PairCases_on `h` \\ fs [ALOOKUP_APPEND] \\ rw [] \\ fs [GSYM alistTheory.ALOOKUP_NONE] - \\ every_case_tac \\ fs []); + \\ every_case_tac \\ fs [] +QED -Theorem fromAList_code_sort - `ALL_DISTINCT (MAP FST xs) ==> - fromAList (code_sort xs) = fromAList xs` - (rw [] \\ match_mp_tac (MP_CANON PERM_IMP_fromAList_EQ_fromAList) - \\ fs [PERM_code_sort,ALL_DISTINCT_code_sort]); +Theorem fromAList_code_sort: + ALL_DISTINCT (MAP FST xs) ==> + fromAList (code_sort xs) = fromAList xs +Proof + rw [] \\ match_mp_tac (MP_CANON PERM_IMP_fromAList_EQ_fromAList) + \\ fs [PERM_code_sort,ALL_DISTINCT_code_sort] +QED (* val even_stubs3 = Q.prove ( @@ -5155,17 +5241,20 @@ val even_stubs3 = Q.prove ( val _ = overload_on("code_loc'",``λe. code_locs [e]``); -Theorem MAP_FST_chain_exps - `∀i ls. ls <> [] ==> (MAP FST (chain_exps i ls) = MAP ((+)i) (COUNT_LIST (LENGTH ls)))` - (recInduct chain_exps_ind +Theorem MAP_FST_chain_exps: + ∀i ls. ls <> [] ==> (MAP FST (chain_exps i ls) = MAP ((+)i) (COUNT_LIST (LENGTH ls))) +Proof + recInduct chain_exps_ind \\ rw[chain_exps_def, COUNT_LIST_def, MAP_MAP_o, o_DEF] >- (EVAL_TAC \\ rw[]) \\ AP_THM_TAC \\ AP_TERM_TAC - \\ rw[FUN_EQ_THM]); + \\ rw[FUN_EQ_THM] +QED -Theorem MAP_FST_chain_exps_any - `∀i ls. (MAP FST (chain_exps i ls) = MAP ((+)i) (COUNT_LIST (MAX 1 (LENGTH ls))))` - (rpt gen_tac +Theorem MAP_FST_chain_exps_any: + ∀i ls. (MAP FST (chain_exps i ls) = MAP ((+)i) (COUNT_LIST (MAX 1 (LENGTH ls)))) +Proof + rpt gen_tac \\ reverse(Cases_on`ls=[]`) >- ( simp[MAP_FST_chain_exps] @@ -5177,40 +5266,50 @@ Theorem MAP_FST_chain_exps_any \\ decide_tac ) \\ simp[] ) \\ rw[chain_exps_def] - \\ EVAL_TAC \\ rw[]); + \\ EVAL_TAC \\ rw[] +QED -Theorem chain_exps_code_locs[simp] - `∀n es. code_locs (MAP (SND o SND) (chain_exps n es)) = code_locs es` - (recInduct chain_exps_ind +Theorem chain_exps_code_locs[simp]: + ∀n es. code_locs (MAP (SND o SND) (chain_exps n es)) = code_locs es +Proof + recInduct chain_exps_ind \\ rw[chain_exps_def] \\ rw[Once code_locs_cons] - \\ rw[code_locs_def]); + \\ rw[code_locs_def] +QED -Theorem chain_exps_ALL_DISTINCT[simp] - `ALL_DISTINCT (MAP FST (chain_exps i ls))` - (Cases_on`ls=[]` +Theorem chain_exps_ALL_DISTINCT[simp]: + ALL_DISTINCT (MAP FST (chain_exps i ls)) +Proof + Cases_on`ls=[]` >- (rw[chain_exps_def]) \\ fs [MAP_FST_chain_exps] \\ match_mp_tac ALL_DISTINCT_MAP_INJ - \\ fs [all_distinct_count_list]); + \\ fs [all_distinct_count_list] +QED -Theorem chain_exps_LE - `!n xs. EVERY ($<= n) (MAP FST (chain_exps n xs))` - (ho_match_mp_tac chain_exps_ind \\ rw [chain_exps_def] +Theorem chain_exps_LE: + !n xs. EVERY ($<= n) (MAP FST (chain_exps n xs)) +Proof + ho_match_mp_tac chain_exps_ind \\ rw [chain_exps_def] \\ fs [EVERY_MEM, MEM_MAP] \\ rw [] \\ fs [PULL_EXISTS] - \\ res_tac \\ fs []); + \\ res_tac \\ fs [] +QED -Theorem chain_exps_GT - `!n xs. xs <> [] ==> EVERY ($> (n + LENGTH xs)) (MAP FST (chain_exps n xs))` - (ho_match_mp_tac chain_exps_ind \\ rw [chain_exps_def] +Theorem chain_exps_GT: + !n xs. xs <> [] ==> EVERY ($> (n + LENGTH xs)) (MAP FST (chain_exps n xs)) +Proof + ho_match_mp_tac chain_exps_ind \\ rw [chain_exps_def] \\ fs [EVERY_MEM, MEM_MAP] \\ rw [] \\ fs [PULL_EXISTS] - \\ res_tac \\ fs []); + \\ res_tac \\ fs [] +QED -Theorem compile_common_distinct_locs - `compile_common c e = (c', p) ==> ALL_DISTINCT (MAP FST p ++ code_locs (MAP (SND o SND) p))` - (simp [compile_common_def] +Theorem compile_common_distinct_locs: + compile_common c e = (c', p) ==> ALL_DISTINCT (MAP FST p ++ code_locs (MAP (SND o SND) p)) +Proof + simp [compile_common_def] \\ rpt (pairarg_tac \\ fs []) \\ strip_tac \\ rveq \\ qmatch_asmsub_abbrev_tac`renumber_code_locs_list N` @@ -5341,11 +5440,13 @@ Theorem compile_common_distinct_locs \\ fs [SUBSET_DEF, MEM_MAP, PULL_EXISTS, EXISTS_PROD, FORALL_PROD, Abbr `N`] \\ fs [SIMP_CONV(srw_ss())[IN_DEF]``x ∈ EVEN``] \\ rw [] \\ strip_tac \\ res_tac \\ res_tac \\ fs [] \\ rw [] - \\ fs[EVEN] \\ every_case_tac \\ fs[GSYM EVEN_MOD2]); + \\ fs[EVEN] \\ every_case_tac \\ fs[GSYM EVEN_MOD2] +QED -Theorem compile_all_distinct_locs - `clos_to_bvl$compile c e = (c',p) ⇒ ALL_DISTINCT (MAP FST p)` - (rw [compile_def] +Theorem compile_all_distinct_locs: + clos_to_bvl$compile c e = (c',p) ⇒ ALL_DISTINCT (MAP FST p) +Proof + rw [compile_def] \\ rpt (pairarg_tac \\ fs []) \\ rw [ALL_DISTINCT_code_sort] \\ simp [compile_prog_code_locs, ALL_DISTINCT_APPEND] @@ -5374,16 +5475,19 @@ Theorem compile_all_distinct_locs \\ rw[] \\ imp_res_tac domain_init_code_lt_num_stubs \\ CCONTR_TAC \\ fs[] - \\ fs[num_stubs_def]); + \\ fs[num_stubs_def] +QED (* Initial state *) val clos_init_def = Define` clos_init max_app s ⇔ s.globals = [] ∧ s.refs = FEMPTY ∧ s.code = FEMPTY ∧ s.max_app = max_app` -Theorem clos_init_with_clock[simp] - `clos_init max_app (s with clock := k) ⇔ clos_init max_app s` - (EVAL_TAC); +Theorem clos_init_with_clock[simp]: + clos_init max_app (s with clock := k) ⇔ clos_init max_app s +Proof + EVAL_TAC +QED (* actually, this can be made even stronger *) val code_installed_fromAList_strong = Q.prove(` @@ -5484,13 +5588,14 @@ val initial_state_with_clock_bvl = prove( initial_state ffi code co cc (k + ck))``, fs [bvlSemTheory.initial_state_def,inc_clock_def]); -Theorem IMP_semantics_eq - `eval_sim ffi max_app code1 co1 cc1 es1 code2 co2 cc2 start rel /\ +Theorem IMP_semantics_eq: + eval_sim ffi max_app code1 co1 cc1 es1 code2 co2 cc2 start rel /\ closSem$semantics (ffi:'ffi ffi_state) max_app code1 co1 cc1 es1 <> Fail ==> rel code1 co1 cc1 es1 code2 co2 cc2 start ==> bvlSem$semantics ffi code2 co2 cc2 start = - closSem$semantics ffi max_app code1 co1 cc1 es1` - (rewrite_tac [GSYM AND_IMP_INTRO] + closSem$semantics ffi max_app code1 co1 cc1 es1 +Proof + rewrite_tac [GSYM AND_IMP_INTRO] \\ strip_tac \\ simp [Once closSemTheory.semantics_def] \\ IF_CASES_TAC \\ fs [] \\ disch_then kall_tac @@ -5633,7 +5738,8 @@ Theorem IMP_semantics_eq [bvlPropsTheory.evaluate_add_to_clock_io_events_mono, closPropsTheory.evaluate_add_to_clock_io_events_mono, initial_state_with_clock_bvl, - initial_state_with_clock,SND,ADD_SYM]); + initial_state_with_clock,SND,ADD_SYM] +QED val init_code_def = Define ` init_code code1 code2 max_app <=> @@ -5659,27 +5765,31 @@ val chain_installed_def = Define` then Let None [EL i es] (Call None 0 (start + i + 1) []) else EL i es))`; -Theorem chain_installed_cons - `chain_installed start (e::es) code ⇔ +Theorem chain_installed_cons: + chain_installed start (e::es) code ⇔ find_code start ([]:closSem$v list) code = SOME ([], if es = [] then e else Let None [e] (Call None 0 (start+1) [])) ∧ - chain_installed (start+1) es code` - (rw[chain_installed_def,ADD1,EQ_IMP_THM] + chain_installed (start+1) es code +Proof + rw[chain_installed_def,ADD1,EQ_IMP_THM] >- (pop_assum(qspec_then`0`mp_tac) \\ rw[] \\ fs[]) >- ( first_x_assum(qspec_then`i+1`mp_tac) \\ rw[EL_CONS,PRE_SUB1] ) - >- ( Cases_on`i` \\ fs[ADD1] \\ rw[] \\ fs[] )); + >- ( Cases_on`i` \\ fs[ADD1] \\ rw[] \\ fs[] ) +QED -Theorem chain_installed_SUBMAP - `∀start es code code'. +Theorem chain_installed_SUBMAP: + ∀start es code code'. chain_installed start es code ∧ code ⊑ code' ⇒ - chain_installed start es code'` - (Induct_on`es` + chain_installed start es code' +Proof + Induct_on`es` \\ rw[chain_installed_def] \\ res_tac \\ fs[closSemTheory.find_code_def,CaseEq"option",CaseEq"prod"] - \\ imp_res_tac FLOOKUP_SUBMAP); + \\ imp_res_tac FLOOKUP_SUBMAP +QED -Theorem chain_installed_thm - `∀es start. ∃e. ∀st code res st'. +Theorem chain_installed_thm: + ∀es start. ∃e. ∀st code res st'. chain_installed start es st.code ∧ closSem$evaluate (es,[],st) = (res,st') ∧ 0 < LENGTH es @@ -5688,8 +5798,9 @@ Theorem chain_installed_thm find_code start ([]:closSem$v list) st.code = SOME ([],e) ∧ closSem$evaluate ([e],[],st with <| clock := st.clock + k |>) = (res1,st1) ∧ result_rel (λx y. T) (λx y. T) res1 res ∧ st'.ffi = st1.ffi (*∧ - (every_Fn_vs_NONE es ⇒ every_Fn_vs_NONE [e])*)` - (Induct >- rw[] + (every_Fn_vs_NONE es ⇒ every_Fn_vs_NONE [e])*) +Proof + Induct >- rw[] \\ rw[chain_installed_cons] >- ( qexists_tac`h` \\ rw[] @@ -5718,11 +5829,13 @@ Theorem chain_installed_thm \\ simp[Once every_Fn_vs_NONE_EVERY] \\ CASE_TAC \\ fs[] \\ rveq \\ fs[] \\ rename1`result_rel _ _ tres` - \\ Cases_on`tres` \\ fs[] \\ rveq \\ fs[] \\ rveq \\ fs[]); + \\ Cases_on`tres` \\ fs[] \\ rveq \\ fs[] \\ rveq \\ fs[] +QED -Theorem chain_installed_chain_exps - `∀start es. chain_installed start es (alist_to_fmap (chain_exps start es))` - (recInduct chain_exps_ind +Theorem chain_installed_chain_exps: + ∀start es. chain_installed start es (alist_to_fmap (chain_exps start es)) +Proof + recInduct chain_exps_ind \\ rw[chain_exps_def, chain_installed_def] >- rw[closSemTheory.find_code_def, FLOOKUP_UPDATE] \\ qmatch_assum_rename_tac`z < _` @@ -5731,10 +5844,11 @@ Theorem chain_installed_chain_exps \\ first_x_assum(qspec_then`z-1`mp_tac) \\ fs[ADD1] \\ rw[closSemTheory.find_code_def, FLOOKUP_UPDATE] \\ fs[] - \\ fs[EL_CONS, PRE_SUB1]); + \\ fs[EL_CONS, PRE_SUB1] +QED -Theorem chain_exps_semantics - `semantics ffi max_app code co cc es ≠ Fail ∧ (* es ≠ [] ∧*) +Theorem chain_exps_semantics: + semantics ffi max_app code co cc es ≠ Fail ∧ (* es ≠ [] ∧*) DISJOINT (IMAGE ((+)start) (count (LENGTH es))) (FDOM code) (*∧ (∀n. DISJOINT (FDOM code) (set (MAP FST (SND (SND (co n))))) ∧ DISJOINT (IMAGE ((+)start) (count (LENGTH es))) (set (MAP FST (SND (SND (co n))))) ∧ @@ -5743,8 +5857,9 @@ Theorem chain_exps_semantics ∃e. semantics ffi max_app (alist_to_fmap (chain_exps start es) ⊌ code) co cc [e] = semantics ffi max_app code co cc es ∧ - ALOOKUP (chain_exps start es) start = SOME (0,e)` - (rw[] + ALOOKUP (chain_exps start es) start = SOME (0,e) +Proof + rw[] \\ reverse(Cases_on`0 < LENGTH es`) >- ( fs[chain_exps_def] @@ -5807,18 +5922,20 @@ Theorem chain_exps_semantics \\ Cases_on`e'` \\ fs[] ) \\ drule (GEN_ALL closPropsTheory.IMP_semantics_eq) \\ simp[] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem chain_exps_semantics_call - `semantics ffi max_app code co cc es ≠ Fail ∧ +Theorem chain_exps_semantics_call: + semantics ffi max_app code co cc es ≠ Fail ∧ DISJOINT (IMAGE ((+)start) (count (LENGTH es))) (FDOM code) (* ∧ (∀n. DISJOINT (FDOM code) (set (MAP FST (SND (SND (co n))))) ∧ DISJOINT (IMAGE ((+)start) (count (LENGTH es))) (set (MAP FST (SND (SND (co n))))) ∧ ∀m. m < n ⇒ DISJOINT (set (MAP FST (SND (SND (co m))))) (set (MAP FST (SND (SND (co n)))))) *) ⇒ semantics ffi max_app (alist_to_fmap (chain_exps start es) ⊌ code) co cc ([Call None 0 start []]) = - semantics ffi max_app code co cc es` - (rw[] + semantics ffi max_app code co cc es +Proof + rw[] (* >- ( rw[closSemTheory.semantics_def, closSemTheory.evaluate_def, chain_exps_def] ) @@ -5837,16 +5954,18 @@ Theorem chain_exps_semantics_call \\ rw[Once closSemTheory.initial_state_def] \\ qexists_tac`1` \\ rw[closSemTheory.dec_clock_def] - \\ fs[closSemTheory.initial_state_def]); + \\ fs[closSemTheory.initial_state_def] +QED (* -Theorem ALOOKUP_compile_prog_main - `∀max_app prog n a e. +Theorem ALOOKUP_compile_prog_main: + ∀max_app prog n a e. ALOOKUP prog n = SOME (a,e) ∧ ¬MEM n (code_locs (MAP (SND o SND) prog)) ⇒ ALOOKUP (compile_prog max_app prog) (n + num_stubs max_app) = - SOME (a, HD(FST(compile_exps max_app [e] [])))` - (recInduct compile_prog_ind + SOME (a, HD(FST(compile_exps max_app [e] []))) +Proof + recInduct compile_prog_ind \\ rw[compile_prog_def] \\ pairarg_tac \\ fs[] \\ reverse(fs[CaseEq"bool"] \\ rw[]) @@ -5873,15 +5992,17 @@ Theorem ALOOKUP_compile_prog_main \\ rw[] \\ fs[Once code_locs_cons] \\ fs[] \\ fs[code_locs_def] ) - \\ imp_res_tac compile_exps_SING \\ fs[]); + \\ imp_res_tac compile_exps_SING \\ fs[] +QED -Theorem ALOOKUP_compile_prog_aux - `∀max_app prog start a e r aux. +Theorem ALOOKUP_compile_prog_aux: + ∀max_app prog start a e r aux. ALOOKUP prog start = SOME (a,e) ∧ ALL_DISTINCT (MAP FST (compile_prog max_app prog)) ∧ compile_exps max_app [e] [] = (r,aux) ⇒ - code_installed aux (fromAList (compile_prog max_app prog))` - (rw[] + code_installed aux (fromAList (compile_prog max_app prog)) +Proof + rw[] \\ irule code_installed_fromAList_strong \\ rw[] \\ qhdtm_x_assum`ALL_DISTINCT`kall_tac @@ -5892,7 +6013,8 @@ Theorem ALOOKUP_compile_prog_aux \\ pairarg_tac \\ fs[] \\ fs[CaseEq"bool"] \\ rw[] \\ fs[] \\ rw[] \\ res_tac - \\ metis_tac[IS_SUBLIST_APPEND, APPEND_ASSOC]); + \\ metis_tac[IS_SUBLIST_APPEND, APPEND_ASSOC] +QED *) val compile_common_inc_def = Define` @@ -5906,12 +6028,13 @@ val compile_common_inc_def = Define` (* TODO: there's lots to move in this file *) -Theorem kcompile_csyntax_ok - `clos_callProof$syntax_ok es ∧ +Theorem kcompile_csyntax_ok: + clos_callProof$syntax_ok es ∧ clos_known$compile kc es = (x,y) ⇒ - clos_callProof$syntax_ok y` - (Cases_on`kc` \\ rw[clos_knownTheory.compile_def] \\ fs[] + clos_callProof$syntax_ok y +Proof + Cases_on`kc` \\ rw[clos_knownTheory.compile_def] \\ fs[] \\ pairarg_tac \\ fs[] \\ fs[clos_callProofTheory.syntax_ok_def] \\ imp_res_tac clos_knownProofTheory.known_code_locs_bag @@ -5929,12 +6052,14 @@ Theorem kcompile_csyntax_ok \\ simp[clos_ticksProofTheory.code_locs_remove_ticks] \\ simp[GSYM LIST_TO_BAG_DISTINCT] \\ match_mp_tac BAG_ALL_DISTINCT_SUB_BAG - \\ asm_exists_tac \\ fs[LIST_TO_BAG_DISTINCT]); + \\ asm_exists_tac \\ fs[LIST_TO_BAG_DISTINCT] +QED -Theorem renumber_code_locs_fv1 - `(∀n es v. LIST_REL (λe1 e2. ∀v. fv1 v e1 ⇔ fv1 v e2) (SND (renumber_code_locs_list n es)) es) ∧ - (∀n e v. fv1 v (SND (renumber_code_locs n e)) ⇔ fv1 v (e))` - (HO_MATCH_MP_TAC clos_numberTheory.renumber_code_locs_ind +Theorem renumber_code_locs_fv1: + (∀n es v. LIST_REL (λe1 e2. ∀v. fv1 v e1 ⇔ fv1 v e2) (SND (renumber_code_locs_list n es)) es) ∧ + (∀n e v. fv1 v (SND (renumber_code_locs n e)) ⇔ fv1 v (e)) +Proof + HO_MATCH_MP_TAC clos_numberTheory.renumber_code_locs_ind \\ rw[clos_numberTheory.renumber_code_locs_def] \\ rpt(pairarg_tac \\ fs[]) \\ fs[fv1_thm] @@ -5946,60 +6071,75 @@ Theorem renumber_code_locs_fv1 >- metis_tac[] \\ disj1_tac \\ asm_exists_tac - \\ simp[EL_ZIP, EL_MAP]); + \\ simp[EL_ZIP, EL_MAP] +QED -Theorem renumber_code_locs_list_fv - `renumber_code_locs_list n es = (k,es') ⇒ fv x es' = fv x es` - (qspecl_then[`n`,`es`]mp_tac(CONJUNCT1 renumber_code_locs_fv1) +Theorem renumber_code_locs_list_fv: + renumber_code_locs_list n es = (k,es') ⇒ fv x es' = fv x es +Proof + qspecl_then[`n`,`es`]mp_tac(CONJUNCT1 renumber_code_locs_fv1) \\ rw[] \\ rw[fv_exists, EXISTS_MEM, MEM_EL] \\ fs[LIST_REL_EL_EQN, PULL_EXISTS] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem syntax_ok_renumber_code_locs_list - `∀k es. clos_knownProof$syntax_ok es ⇒ clos_knownProof$syntax_ok (SND (renumber_code_locs_list k es))` - (rw[clos_knownProofTheory.syntax_ok_def] +Theorem syntax_ok_renumber_code_locs_list: + ∀k es. clos_knownProof$syntax_ok es ⇒ clos_knownProof$syntax_ok (SND (renumber_code_locs_list k es)) +Proof + rw[clos_knownProofTheory.syntax_ok_def] \\ qspecl_then[`k`,`es`]mp_tac (CONJUNCT1 clos_numberProofTheory.renumber_code_locs_every_Fn_vs_NONE) \\ simp[] \\ strip_tac \\ Cases_on`renumber_code_locs_list k es` \\ qspecl_then[`k`,`es`]mp_tac (CONJUNCT1 clos_numberProofTheory.renumber_code_locs_esgc_free) \\ simp[] \\ strip_tac \\ imp_res_tac renumber_code_locs_list_fv - \\ fs[clos_knownProofTheory.fv_max_def]); + \\ fs[clos_knownProofTheory.fv_max_def] +QED -Theorem syntax_ok_renumber_code_locs - `∀k e. clos_knownProof$syntax_ok [e] ⇒ clos_knownProof$syntax_ok [SND (renumber_code_locs k e)]` - (rw[clos_knownProofTheory.syntax_ok_def] +Theorem syntax_ok_renumber_code_locs: + ∀k e. clos_knownProof$syntax_ok [e] ⇒ clos_knownProof$syntax_ok [SND (renumber_code_locs k e)] +Proof + rw[clos_knownProofTheory.syntax_ok_def] \\ qspecl_then[`k`,`e`]mp_tac (CONJUNCT2 clos_numberProofTheory.renumber_code_locs_every_Fn_vs_NONE) \\ simp[] \\ strip_tac >- ( Cases_on`renumber_code_locs k e` \\ qspecl_then[`k`,`e`]mp_tac (CONJUNCT2 clos_numberProofTheory.renumber_code_locs_esgc_free) \\ simp[] \\ strip_tac) - \\ fs[renumber_code_locs_fv1,clos_knownProofTheory.fv_max_def]); + \\ fs[renumber_code_locs_fv1,clos_knownProofTheory.fv_max_def] +QED -Theorem set_globals_SND_renumber_code_locs - `set_globals (SND (renumber_code_locs x y)) = set_globals y` - (metis_tac[clos_numberProofTheory.renumber_code_locs_elist_globals,PAIR]); +Theorem set_globals_SND_renumber_code_locs: + set_globals (SND (renumber_code_locs x y)) = set_globals y +Proof + metis_tac[clos_numberProofTheory.renumber_code_locs_elist_globals,PAIR] +QED -Theorem elist_globals_FLAT - `elist_globals (FLAT ls) = FOLDR BAG_UNION {||} (MAP elist_globals ls)` - (rw[elist_globals_FOLDR, MAP_FLAT] +Theorem elist_globals_FLAT: + elist_globals (FLAT ls) = FOLDR BAG_UNION {||} (MAP elist_globals ls) +Proof + rw[elist_globals_FOLDR, MAP_FLAT] \\ DEP_REWRITE_TAC[ASSOC_FOLDR_FLAT] \\ simp[MAP_MAP_o,o_DEF, GSYM elist_globals_FOLDR] \\ srw_tac[ETA_ss][] - \\ simp[ASSOC_DEF, ASSOC_BAG_UNION, LEFT_ID_DEF]); + \\ simp[ASSOC_DEF, ASSOC_BAG_UNION, LEFT_ID_DEF] +QED -Theorem elist_globals_SND_renumber_code_locs_list - `elist_globals (SND (renumber_code_locs_list x y)) = elist_globals y` - (metis_tac[clos_numberProofTheory.renumber_code_locs_elist_globals,PAIR]); +Theorem elist_globals_SND_renumber_code_locs_list: + elist_globals (SND (renumber_code_locs_list x y)) = elist_globals y +Proof + metis_tac[clos_numberProofTheory.renumber_code_locs_elist_globals,PAIR] +QED -Theorem elist_globals_SND_ncompile_inc[simp] - `elist_globals (SND (clos_numberProof$compile_inc x y)) = elist_globals y` - (rw[clos_numberProofTheory.compile_inc_def,UNCURRY,op_gbag_def,elist_globals_SND_renumber_code_locs_list]); +Theorem elist_globals_SND_ncompile_inc[simp]: + elist_globals (SND (clos_numberProof$compile_inc x y)) = elist_globals y +Proof + rw[clos_numberProofTheory.compile_inc_def,UNCURRY,op_gbag_def,elist_globals_SND_renumber_code_locs_list] +QED -Theorem syntax_oracle_ok_renumber_code_locs - `renumber_code_locs_list n es1 = (k,es2) ∧ +Theorem syntax_oracle_ok_renumber_code_locs: + renumber_code_locs_list n es1 = (k,es2) ∧ clos_knownProof$syntax_ok es1 ∧ clos_knownProof$co_every_Fn_vs_NONE co1 ∧ BAG_ALL_DISTINCT (elist_globals es1) ∧ @@ -6011,8 +6151,9 @@ Theorem syntax_oracle_ok_renumber_code_locs BAG_DISJOINT (elist_globals es1) (elist_globals (FST (SND (co1 n))))) ⇒ clos_knownProof$syntax_oracle_ok es2 - (state_co (ignore_table clos_numberProof$compile_inc) co1)` - (simp[clos_knownProofTheory.syntax_oracle_ok_def, + (state_co (ignore_table clos_numberProof$compile_inc) co1) +Proof + simp[clos_knownProofTheory.syntax_oracle_ok_def, clos_knownProofTheory.oracle_state_sgc_free_def, clos_knownProofTheory.oracle_gapprox_subspt_def, clos_knownProofTheory.oracle_gapprox_disjoint_def, @@ -6061,26 +6202,32 @@ Theorem syntax_oracle_ok_renumber_code_locs \\ simp[elist_globals_FLAT, MAP_GENLIST, o_DEF, op_gbag_def] \\ fs[o_DEF, elist_globals_FLAT, MAP_GENLIST] \\ simp[BAG_DISJOINT_FOLDR_BAG_UNION, EVERY_GENLIST]) - \\ simp[FST_SND_ignore_table]); + \\ simp[FST_SND_ignore_table] +QED -Theorem collect_apps_fv1 - `∀x y z v. fv v (FST (collect_apps x y z)) ∨ fv1 v (SND (collect_apps x y z)) ⇔ fv v y ∨ fv1 v z` - (recInduct clos_mtiTheory.collect_apps_ind +Theorem collect_apps_fv1: + ∀x y z v. fv v (FST (collect_apps x y z)) ∨ fv1 v (SND (collect_apps x y z)) ⇔ fv v y ∨ fv1 v z +Proof + recInduct clos_mtiTheory.collect_apps_ind \\ rw[clos_mtiTheory.collect_apps_def] \\ rw[fv1_thm] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem collect_args_fv1 - `∀m n e n' e' v. +Theorem collect_args_fv1: + ∀m n e n' e' v. (collect_args m n e = (n',e')) ⇒ - (fv1 (n'+v) e' ⇔ fv1 (n+v) e)` - (recInduct clos_mtiTheory.collect_args_ind + (fv1 (n'+v) e' ⇔ fv1 (n+v) e) +Proof + recInduct clos_mtiTheory.collect_args_ind \\ rw[clos_mtiTheory.collect_args_def] - \\ rw[fv1_thm]); + \\ rw[fv1_thm] +QED -Theorem intro_multi_fv1 - `∀max_app es. LIST_REL (λe1 e2. ∀v. fv1 v e1 ⇔ fv1 v e2) (intro_multi max_app es) es` - (recInduct clos_mtiTheory.intro_multi_ind +Theorem intro_multi_fv1: + ∀max_app es. LIST_REL (λe1 e2. ∀v. fv1 v e1 ⇔ fv1 v e2) (intro_multi max_app es) es +Proof + recInduct clos_mtiTheory.intro_multi_ind \\ rw[clos_mtiTheory.intro_multi_def, fv1_thm, clos_mtiTheory.intro_multi_length] \\ TRY ( pairarg_tac \\ fs[fv1_thm] ) \\ TRY ( @@ -6105,159 +6252,200 @@ Theorem intro_multi_fv1 \\ res_tac \\ rfs[] \\ imp_res_tac collect_args_fv1 )) \\ fs[fv_exists, LIST_REL_EL_EQN, EXISTS_MEM, MEM_EL, PULL_EXISTS, clos_mtiTheory.intro_multi_length] - \\ metis_tac[clos_mtiProofTheory.HD_intro_multi, fv1_def]); + \\ metis_tac[clos_mtiProofTheory.HD_intro_multi, fv1_def] +QED -Theorem ksyntax_ok_intro_multi - `clos_knownProof$syntax_ok es ⇒ clos_knownProof$syntax_ok (intro_multi max_app es)` - (fs[clos_knownProofTheory.syntax_ok_def] +Theorem ksyntax_ok_intro_multi: + clos_knownProof$syntax_ok es ⇒ clos_knownProof$syntax_ok (intro_multi max_app es) +Proof + fs[clos_knownProofTheory.syntax_ok_def] \\ fs[GSYM clos_mtiProofTheory.intro_multi_preserves_esgc_free] \\ fs[clos_knownProofTheory.fv_max_def, fv_exists] \\ fs[EVERY_MEM, MEM_EL, PULL_EXISTS, clos_mtiTheory.intro_multi_length] \\ qspecl_then[`max_app`,`es`]strip_assume_tac intro_multi_fv1 - \\ fs[LIST_REL_EL_EQN]); + \\ fs[LIST_REL_EL_EQN] +QED -Theorem ksyntax_ok_compile_mti - `clos_knownProof$syntax_ok es ⇒ - clos_knownProof$syntax_ok (clos_mti$compile do_mti max_app es)` - (Cases_on`do_mti` \\ rw[clos_mtiTheory.compile_def] - \\ fs[ksyntax_ok_intro_multi]); +Theorem ksyntax_ok_compile_mti: + clos_knownProof$syntax_ok es ⇒ + clos_knownProof$syntax_ok (clos_mti$compile do_mti max_app es) +Proof + Cases_on`do_mti` \\ rw[clos_mtiTheory.compile_def] + \\ fs[ksyntax_ok_intro_multi] +QED -Theorem compile_elist_globals - `elist_globals (clos_mti$compile do_mti max_app es) = elist_globals es` - (Cases_on`do_mti` \\ EVAL_TAC - \\ rw[clos_mtiProofTheory.intro_multi_preserves_elist_globals]); +Theorem compile_elist_globals: + elist_globals (clos_mti$compile do_mti max_app es) = elist_globals es +Proof + Cases_on`do_mti` \\ EVAL_TAC + \\ rw[clos_mtiProofTheory.intro_multi_preserves_elist_globals] +QED -Theorem mcompile_inc_uncurry - `clos_mtiProof$compile_inc max_app p = ((intro_multi max_app (FST p)),[])` - (Cases_on`p` \\ EVAL_TAC); +Theorem mcompile_inc_uncurry: + clos_mtiProof$compile_inc max_app p = ((intro_multi max_app (FST p)),[]) +Proof + Cases_on`p` \\ EVAL_TAC +QED -Theorem kcompile_inc_uncurry - `clos_knownProof$compile_inc c g p = +Theorem kcompile_inc_uncurry: + clos_knownProof$compile_inc c g p = (SND (known (reset_inline_factor c) (FST p) [] g), MAP FST (FST (known (reset_inline_factor c) (FST p) [] g)), - SND p)` - (Cases_on`p` \\ EVAL_TAC - \\ pairarg_tac \\ simp[]); + SND p) +Proof + Cases_on`p` \\ EVAL_TAC + \\ pairarg_tac \\ simp[] +QED -Theorem acompile_inc_uncurry - `clos_annotateProof$compile_inc p = ((annotate 0 (FST p)), compile (SND p))` - (Cases_on`p` \\ rw[clos_annotateProofTheory.compile_inc_def]); +Theorem acompile_inc_uncurry: + clos_annotateProof$compile_inc p = ((annotate 0 (FST p)), compile (SND p)) +Proof + Cases_on`p` \\ rw[clos_annotateProofTheory.compile_inc_def] +QED -Theorem ccompile_inc_uncurry - `clos_callProof$compile_inc g p = +Theorem ccompile_inc_uncurry: + clos_callProof$compile_inc g p = (FST(SND (calls (FST p) (g,[]))), (FST (calls (FST p) (g,[]))), - SND(SND (calls (FST p) (g,[]))))` - (Cases_on`p` \\ EVAL_TAC - \\ pairarg_tac \\ simp[]); - -Theorem compile_inc_uncurry - `compile_inc max_app p = [] (* - compile_prog max_app ((chain_exps (FST (extract_name (FST p))) (SND (extract_name (FST p)))) ++ SND p)*)` - (Cases_on`p` \\ rw[compile_inc_def] - \\ pairarg_tac \\ rw[]); - -Theorem fcompile_inc_uncurry - `clos_fvsProof$compile_inc p = (compile (FST p), [])` - (Cases_on`p` \\ EVAL_TAC); - -Theorem elist_globals_sing - `elist_globals [x] = set_globals x` - (rw[elist_globals_FOLDR]); - -Theorem set_globals_HD_intro_multi - `set_globals (HD (intro_multi x [y])) = set_globals y` - (qspecl_then[`x`,`[y]`]mp_tac clos_mtiProofTheory.intro_multi_preserves_elist_globals + SND(SND (calls (FST p) (g,[])))) +Proof + Cases_on`p` \\ EVAL_TAC + \\ pairarg_tac \\ simp[] +QED + +Theorem compile_inc_uncurry: + compile_inc max_app p = [] (* + compile_prog max_app ((chain_exps (FST (extract_name (FST p))) (SND (extract_name (FST p)))) ++ SND p)*) +Proof + Cases_on`p` \\ rw[compile_inc_def] + \\ pairarg_tac \\ rw[] +QED + +Theorem fcompile_inc_uncurry: + clos_fvsProof$compile_inc p = (compile (FST p), []) +Proof + Cases_on`p` \\ EVAL_TAC +QED + +Theorem elist_globals_sing: + elist_globals [x] = set_globals x +Proof + rw[elist_globals_FOLDR] +QED + +Theorem set_globals_HD_intro_multi: + set_globals (HD (intro_multi x [y])) = set_globals y +Proof + qspecl_then[`x`,`[y]`]mp_tac clos_mtiProofTheory.intro_multi_preserves_elist_globals \\ rw[] \\ rewrite_tac[Once(GSYM elist_globals_sing)] \\ rewrite_tac[clos_mtiProofTheory.HD_intro_multi] - \\ fs[]); + \\ fs[] +QED -Theorem renumber_code_locs_list_csyntax_ok - `renumber_code_locs_list n es = (k,es') ∧ +Theorem renumber_code_locs_list_csyntax_ok: + renumber_code_locs_list n es = (k,es') ∧ every_Fn_vs_NONE es ⇒ - clos_callProof$syntax_ok es'` - (specl_args_of_then``renumber_code_locs_list`` + clos_callProof$syntax_ok es' +Proof + specl_args_of_then``renumber_code_locs_list`` clos_numberProofTheory.renumber_code_locs_list_distinct mp_tac \\ specl_args_of_then``renumber_code_locs_list`` (CONJUNCT1 clos_numberProofTheory.renumber_code_locs_every_Fn_SOME) mp_tac \\ specl_args_of_then``renumber_code_locs_list`` (CONJUNCT1 clos_numberProofTheory.renumber_code_locs_every_Fn_vs_NONE) mp_tac - \\ rw[clos_callProofTheory.syntax_ok_def] \\ fs[]); + \\ rw[clos_callProofTheory.syntax_ok_def] \\ fs[] +QED -Theorem compile_every_Fn_vs_NONE[simp] - `every_Fn_vs_NONE (clos_mti$compile do_mti max_app es) ⇔ - every_Fn_vs_NONE es` - (Cases_on`do_mti` \\ rw[clos_mtiTheory.compile_def]); +Theorem compile_every_Fn_vs_NONE[simp]: + every_Fn_vs_NONE (clos_mti$compile do_mti max_app es) ⇔ + every_Fn_vs_NONE es +Proof + Cases_on`do_mti` \\ rw[clos_mtiTheory.compile_def] +QED -Theorem compile_code_locs_ALL_DISTINCT - `clos_call$compile do_call es = (xs,g,aux) ∧ +Theorem compile_code_locs_ALL_DISTINCT: + clos_call$compile do_call es = (xs,g,aux) ∧ ALL_DISTINCT (code_locs es) ⇒ - ALL_DISTINCT (code_locs xs ++ code_locs (MAP (SND o SND) aux))` - (Cases_on`do_call` \\ rw[clos_callTheory.compile_def] + ALL_DISTINCT (code_locs xs ++ code_locs (MAP (SND o SND) aux)) +Proof + Cases_on`do_call` \\ rw[clos_callTheory.compile_def] \\ rw[] \\ fs[code_locs_def] \\ pairarg_tac \\ fs[] \\ drule clos_callProofTheory.calls_code_locs_ALL_DISTINCT - \\ rw[code_locs_def]); + \\ rw[code_locs_def] +QED -Theorem chain_exps_every_Fn_vs_NONE - `!n xs. +Theorem chain_exps_every_Fn_vs_NONE: + !n xs. every_Fn_vs_NONE (MAP (SND o SND) (chain_exps n xs)) <=> - every_Fn_vs_NONE xs` - (recInduct chain_exps_ind + every_Fn_vs_NONE xs +Proof + recInduct chain_exps_ind \\ rw [chain_exps_def] \\ pop_assum mp_tac \\ once_rewrite_tac [CONS_APPEND] - \\ fs [every_Fn_vs_NONE_APPEND]); + \\ fs [every_Fn_vs_NONE_APPEND] +QED -Theorem calls_compile_csyntax_ok - `clos_callProof$syntax_ok xs /\ +Theorem calls_compile_csyntax_ok: + clos_callProof$syntax_ok xs /\ clos_call$compile p xs = (ys, g, aux) ==> every_Fn_vs_NONE ys /\ - every_Fn_vs_NONE (MAP (SND o SND) aux)` - (Cases_on `p` \\ rw [clos_callTheory.compile_def] + every_Fn_vs_NONE (MAP (SND o SND) aux) +Proof + Cases_on `p` \\ rw [clos_callTheory.compile_def] \\ fs [clos_callProofTheory.syntax_ok_def] \\ pairarg_tac \\ fs [] \\ rw [] \\ imp_res_tac clos_callProofTheory.calls_preserves_every_Fn_vs_NONE - \\ fs []); + \\ fs [] +QED -Theorem HD_FST_calls - `[HD (FST (calls [x] y))] = FST (calls [x] y)` - (Cases_on`calls [x] y` +Theorem HD_FST_calls: + [HD (FST (calls [x] y))] = FST (calls [x] y) +Proof + Cases_on`calls [x] y` \\ imp_res_tac clos_callTheory.calls_sing - \\ fs[]); + \\ fs[] +QED -Theorem every_Fn_SOME_collect_apps - `∀max_app es e es' e'. +Theorem every_Fn_SOME_collect_apps: + ∀max_app es e es' e'. collect_apps max_app es e = (es',e') ⇒ (every_Fn_SOME es' ∧ every_Fn_SOME [e'] ⇔ - every_Fn_SOME es ∧ every_Fn_SOME [e])` - (ho_match_mp_tac clos_mtiTheory.collect_apps_ind + every_Fn_SOME es ∧ every_Fn_SOME [e]) +Proof + ho_match_mp_tac clos_mtiTheory.collect_apps_ind \\ rw[clos_mtiTheory.collect_apps_def] \\ fs[] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem every_Fn_SOME_intro_multi[simp] - `∀max_app es. every_Fn_SOME (intro_multi max_app es) ⇔ every_Fn_SOME es` - (ho_match_mp_tac clos_mtiTheory.intro_multi_ind >> +Theorem every_Fn_SOME_intro_multi[simp]: + ∀max_app es. every_Fn_SOME (intro_multi max_app es) ⇔ every_Fn_SOME es +Proof + ho_match_mp_tac clos_mtiTheory.intro_multi_ind >> srw_tac[][clos_mtiTheory.intro_multi_def] >> ONCE_REWRITE_TAC[CONS_APPEND] >> REWRITE_TAC[clos_mtiProofTheory.HD_intro_multi] >> full_simp_tac(srw_ss())[clos_mtiProofTheory.HD_intro_multi] - \\ PROVE_TAC[every_Fn_SOME_collect_apps]); + \\ PROVE_TAC[every_Fn_SOME_collect_apps] +QED -Theorem set_code_locs_collect_apps - `∀max_app es e es' e'. +Theorem set_code_locs_collect_apps: + ∀max_app es e es' e'. collect_apps max_app es e = (es',e') ⇒ (set (code_locs [e']) ∪ set (code_locs es') = - set (code_locs [e]) ∪ set (code_locs es))` - (ho_match_mp_tac clos_mtiTheory.collect_apps_ind + set (code_locs [e]) ∪ set (code_locs es)) +Proof + ho_match_mp_tac clos_mtiTheory.collect_apps_ind \\ rw[clos_mtiTheory.collect_apps_def] \\ fs[] \\ rw[code_locs_def, code_locs_append] - \\ metis_tac[UNION_COMM,UNION_ASSOC]); + \\ metis_tac[UNION_COMM,UNION_ASSOC] +QED (* Theorem set_code_locs_intro_multi[simp] @@ -6274,47 +6462,59 @@ Theorem set_code_locs_intro_multi[simp] >- ( *) -Theorem every_Fn_SOME_ncompile_inc[simp] - `every_Fn_SOME (SND (clos_numberProof$compile_inc x y))` - (rw[clos_numberProofTheory.compile_inc_def, UNCURRY] +Theorem every_Fn_SOME_ncompile_inc[simp]: + every_Fn_SOME (SND (clos_numberProof$compile_inc x y)) +Proof + rw[clos_numberProofTheory.compile_inc_def, UNCURRY] \\ rw[Once every_Fn_SOME_EVERY] \\ rw[GSYM every_Fn_SOME_EVERY] - \\ simp[clos_numberProofTheory.renumber_code_locs_every_Fn_SOME]); + \\ simp[clos_numberProofTheory.renumber_code_locs_every_Fn_SOME] +QED -Theorem every_Fn_vs_NONE_ncompile_inc[simp] - `every_Fn_vs_NONE (SND (clos_numberProof$compile_inc x y)) ⇔ every_Fn_vs_NONE y` - (rw[clos_numberProofTheory.compile_inc_def, UNCURRY] +Theorem every_Fn_vs_NONE_ncompile_inc[simp]: + every_Fn_vs_NONE (SND (clos_numberProof$compile_inc x y)) ⇔ every_Fn_vs_NONE y +Proof + rw[clos_numberProofTheory.compile_inc_def, UNCURRY] \\ rw[Once every_Fn_vs_NONE_EVERY] \\ rw[GSYM every_Fn_vs_NONE_EVERY] - \\ simp[clos_numberProofTheory.renumber_code_locs_every_Fn_vs_NONE]); + \\ simp[clos_numberProofTheory.renumber_code_locs_every_Fn_vs_NONE] +QED -Theorem ncompile_inc_code_locs_distinct[simp] - `ALL_DISTINCT (code_locs (SND (clos_numberProof$compile_inc x y)))` - (rw[clos_numberProofTheory.compile_inc_def, UNCURRY] +Theorem ncompile_inc_code_locs_distinct[simp]: + ALL_DISTINCT (code_locs (SND (clos_numberProof$compile_inc x y))) +Proof + rw[clos_numberProofTheory.compile_inc_def, UNCURRY] \\ rw[Once code_locs_cons] \\ rw[Once code_locs_def] \\ rw[Once code_locs_def] - \\ rw[clos_numberProofTheory.renumber_code_locs_list_distinct]); + \\ rw[clos_numberProofTheory.renumber_code_locs_list_distinct] +QED -Theorem code_locs_FST_letop_compile_inc[simp] - `code_locs (FST (clos_letopProof$compile_inc x)) = code_locs (FST x)` - (Cases_on`x` \\ rw[clos_letopProofTheory.compile_inc_def, clos_letopProofTheory.code_locs_let_op]); +Theorem code_locs_FST_letop_compile_inc[simp]: + code_locs (FST (clos_letopProof$compile_inc x)) = code_locs (FST x) +Proof + Cases_on`x` \\ rw[clos_letopProofTheory.compile_inc_def, clos_letopProofTheory.code_locs_let_op] +QED -Theorem code_locs_FST_ticks_compile_inc[simp] - `code_locs (FST (clos_ticksProof$compile_inc x)) = code_locs (FST x)` - (Cases_on`x` \\ rw[clos_ticksProofTheory.compile_inc_def, clos_ticksProofTheory.code_locs_remove_ticks]); +Theorem code_locs_FST_ticks_compile_inc[simp]: + code_locs (FST (clos_ticksProof$compile_inc x)) = code_locs (FST x) +Proof + Cases_on`x` \\ rw[clos_ticksProofTheory.compile_inc_def, clos_ticksProofTheory.code_locs_remove_ticks] +QED -Theorem code_locs_FST_SND_kcompile_inc - `LIST_TO_BAG (code_locs (FST (SND (clos_knownProof$compile_inc x y z)))) ≤ - LIST_TO_BAG (code_locs (FST z))` - (rw[kcompile_inc_uncurry] +Theorem code_locs_FST_SND_kcompile_inc: + LIST_TO_BAG (code_locs (FST (SND (clos_knownProof$compile_inc x y z)))) ≤ + LIST_TO_BAG (code_locs (FST z)) +Proof + rw[kcompile_inc_uncurry] \\ qmatch_goalsub_abbrev_tac`known a b c d` \\ specl_args_of_then``known``clos_knownProofTheory.known_code_locs_bag mp_tac \\ Cases_on`known a b c d` - \\ simp[]); + \\ simp[] +QED -Theorem compile_common_semantics - `closSem$semantics (ffi:'ffi ffi_state) c.max_app FEMPTY co1 +Theorem compile_common_semantics: + closSem$semantics (ffi:'ffi ffi_state) c.max_app FEMPTY co1 (compile_common_inc c cc) es1 ≠ Fail ∧ compile_common c es1 = (c', code2) ∧ (c.do_mti ⇒ 1 ≤ c.max_app ∧ clos_mtiProof$syntax_ok es1 ∧ @@ -6377,8 +6577,9 @@ Theorem compile_common_semantics (state_co (ignore_table clos_numberProof$compile_inc) ((if c.do_mti then pure_co (clos_mtiProof$compile_inc c.max_app) else I) o co1)))) cc ([Call None 0 c'.start []]) = - closSem$semantics ffi c.max_app FEMPTY co1 (compile_common_inc c cc) es1` - (simp[compile_common_def] + closSem$semantics ffi c.max_app FEMPTY co1 (compile_common_inc c cc) es1 +Proof + simp[compile_common_def] \\ rpt(pairarg_tac \\ fs[]) \\ qmatch_asmsub_rename_tac`renumber_code_locs_list _ _ = (k,_)` \\ qmatch_asmsub_abbrev_tac`renumber_code_locs_list n` @@ -6944,10 +7145,11 @@ Theorem compile_common_semantics \\ rpt disj1_tac \\ simp[MEM_MAP] \\ qexists_tac`0` - \\ rw[MEM_COUNT_LIST]); + \\ rw[MEM_COUNT_LIST] +QED -Theorem compile_prog_semantics - `semantics (ffi:'ffi ffi_state) max_app code1 co1 cc1 [Call None 0 start []] ≠ Fail ∧ +Theorem compile_prog_semantics: + semantics (ffi:'ffi ffi_state) max_app code1 co1 cc1 [Call None 0 start []] ≠ Fail ∧ (∀name arity c. FLOOKUP code1 name = SOME (arity,c) ⇒ ∃aux1 c2 aux2. @@ -6963,8 +7165,9 @@ Theorem compile_prog_semantics code_installed prog2 code2 ⇒ bvlSem$semantics ffi code2 (co2 : num -> 'c # (num # num # bvl$exp) list) cc2 nsm1 = - closSem$semantics ffi max_app code1 (co1 : 'c clos_co) cc1 [Call None 0 start []]` - (rw[] + closSem$semantics ffi max_app code1 (co1 : 'c clos_co) cc1 [Call None 0 start []] +Proof + rw[] \\ irule (GEN_ALL IMP_semantics_eq) \\ simp[] \\ qexists_tac`K (K (K (K (K (K (K (K T)))))))` @@ -7019,7 +7222,8 @@ Theorem compile_prog_semantics \\ fs[] \\ fs[state_rel_def] \\ Cases_on`res1` \\ fs[] - \\ Cases_on`e` \\ fs[]); + \\ Cases_on`e` \\ fs[] +QED val syntax_oracle_ok_def = Define` syntax_oracle_ok c es co ⇔ @@ -7075,54 +7279,66 @@ val syntax_oracle_ok_def = Define` ¬contains_App_SOME c.max_app es ∧ clos_knownProof$syntax_ok es`; -Theorem compile_every_Fn_SOME - `every_Fn_SOME (MAP (SND o SND) es) ⇒ - every_Fn_SOME (MAP (SND o SND) (clos_annotate$compile es))` - (rw[clos_annotateTheory.compile_def, Once every_Fn_SOME_EVERY] +Theorem compile_every_Fn_SOME: + every_Fn_SOME (MAP (SND o SND) es) ⇒ + every_Fn_SOME (MAP (SND o SND) (clos_annotate$compile es)) +Proof + rw[clos_annotateTheory.compile_def, Once every_Fn_SOME_EVERY] \\ fs[Once every_Fn_SOME_EVERY] \\ fs[EVERY_MAP, UNCURRY] \\ fs[EVERY_MEM] \\ rw[clos_annotateProofTheory.HD_annotate_SING] \\ irule clos_annotateProofTheory.every_Fn_SOME_annotate - \\ res_tac); + \\ res_tac +QED -Theorem compile_every_Fn_vs_SOME - `every_Fn_vs_SOME (MAP (SND o SND) (clos_annotate$compile es))` - (rw[clos_annotateTheory.compile_def, Once every_Fn_vs_SOME_EVERY] +Theorem compile_every_Fn_vs_SOME: + every_Fn_vs_SOME (MAP (SND o SND) (clos_annotate$compile es)) +Proof + rw[clos_annotateTheory.compile_def, Once every_Fn_vs_SOME_EVERY] \\ fs[EVERY_MAP, UNCURRY] - \\ rw[EVERY_MEM, clos_annotateProofTheory.HD_annotate_SING]); + \\ rw[EVERY_MEM, clos_annotateProofTheory.HD_annotate_SING] +QED -Theorem compile_common_max_app - `compile_common c es = (c',es') ⇒ c'.max_app = c.max_app` - (simp[compile_common_def] +Theorem compile_common_max_app: + compile_common c es = (c',es') ⇒ c'.max_app = c.max_app +Proof + simp[compile_common_def] \\ rpt(pairarg_tac \\ fs[]) - \\ strip_tac \\ rveq \\ fs[]); + \\ strip_tac \\ rveq \\ fs[] +QED -Theorem chain_exps_every_Fn_SOME - `∀x y. every_Fn_SOME (MAP (SND o SND) (chain_exps x y)) ⇔ every_Fn_SOME y` - (recInduct chain_exps_ind +Theorem chain_exps_every_Fn_SOME: + ∀x y. every_Fn_SOME (MAP (SND o SND) (chain_exps x y)) ⇔ every_Fn_SOME y +Proof + recInduct chain_exps_ind \\ rw[chain_exps_def] \\ pop_assum mp_tac \\ once_rewrite_tac [CONS_APPEND] - \\ fs [every_Fn_SOME_APPEND]); + \\ fs [every_Fn_SOME_APPEND] +QED -Theorem chain_exps_every_Fn_vs_SOME - `∀x y. every_Fn_vs_SOME (MAP (SND o SND) (chain_exps x y)) ⇔ every_Fn_vs_SOME y` - (recInduct chain_exps_ind +Theorem chain_exps_every_Fn_vs_SOME: + ∀x y. every_Fn_vs_SOME (MAP (SND o SND) (chain_exps x y)) ⇔ every_Fn_vs_SOME y +Proof + recInduct chain_exps_ind \\ rw[chain_exps_def] \\ pop_assum mp_tac \\ once_rewrite_tac [CONS_APPEND] - \\ fs []); + \\ fs [] +QED -Theorem ccompile_every_Fn_SOME - `every_Fn_SOME es ∧ +Theorem ccompile_every_Fn_SOME: + every_Fn_SOME es ∧ clos_call$compile do_call es = (es',g,aux) ⇒ every_Fn_SOME es' ∧ - every_Fn_SOME (MAP (SND o SND) aux)` - (Cases_on`do_call` \\ rw[clos_callTheory.compile_def] \\ fs[] + every_Fn_SOME (MAP (SND o SND) aux) +Proof + Cases_on`do_call` \\ rw[clos_callTheory.compile_def] \\ fs[] \\ pairarg_tac \\ fs[] \\ imp_res_tac clos_callProofTheory.calls_preserves_every_Fn_SOME - \\ fs[] \\ rveq \\ fs[]); + \\ fs[] \\ rveq \\ fs[] +QED (* TODO: move *) val ALOOKUP_lemma = Q.prove( @@ -7145,15 +7361,16 @@ val ALOOKUP_lemma = Q.prove( \\ rw[] ) \\ Cases_on`n` \\ fs[]); -Theorem ALOOKUP_compile_common - `compile_common c es = (c', prog) ∧ +Theorem ALOOKUP_compile_common: + compile_common c es = (c', prog) ∧ ALOOKUP prog name = SOME (arity, exp) ⇒ ∃aux1 exp2 aux2. compile_exps c.max_app [exp] aux1 = ([exp2], aux2) ∧ ALOOKUP (compile_prog c.max_app prog) (name + num_stubs c.max_app) = SOME (arity, exp2) ∧ - code_installed aux2 (fromAList (compile_prog c.max_app prog))` - (strip_tac + code_installed aux2 (fromAList (compile_prog c.max_app prog)) +Proof + strip_tac \\ imp_res_tac compile_common_distinct_locs \\ fs[compile_common_def] \\ rpt(pairarg_tac \\ fs[]) @@ -7209,36 +7426,42 @@ Theorem ALOOKUP_compile_common \\ fs[GSYM MAP_MAP_o,Abbr`f`] \\ fs[IN_DISJOINT,ALL_DISTINCT_APPEND,MEM_MAP,PULL_EXISTS] \\ rw[] \\ CCONTR_TAC \\ fs[] \\ rw[] \\ fs[] \\ rw[] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem set_code_locs_FST_calls_SUBSET - `∀x y. set (code_locs (FST (calls x y))) ⊆ - set (code_locs x) ∪ set (code_locs (MAP (SND o SND) (SND y)))` - (rw[] \\ Cases_on`calls x y` +Theorem set_code_locs_FST_calls_SUBSET: + ∀x y. set (code_locs (FST (calls x y))) ⊆ + set (code_locs x) ∪ set (code_locs (MAP (SND o SND) (SND y))) +Proof + rw[] \\ Cases_on`calls x y` \\ imp_res_tac clos_callProofTheory.calls_code_locs_MEM - \\ fs[SUBSET_DEF]); + \\ fs[SUBSET_DEF] +QED -Theorem renumber_code_locs_sing - `(∀n es n' es'. +Theorem renumber_code_locs_sing: + (∀n es n' es'. LENGTH es = 1 ⇒ (renumber_code_locs_list n es = (n',es') ⇔ LENGTH es' = 1 ∧ renumber_code_locs n (HD es) = (n', HD es'))) ∧ (∀n e n' e'. renumber_code_locs n e = (n',e') ⇔ - renumber_code_locs_list n [e] = (n',[e']))` - (ho_match_mp_tac clos_numberTheory.renumber_code_locs_ind + renumber_code_locs_list n [e] = (n',[e'])) +Proof + ho_match_mp_tac clos_numberTheory.renumber_code_locs_ind \\ rw[clos_numberTheory.renumber_code_locs_def] \\ fs[] \\ rpt(pairarg_tac \\ fs[]) \\ fs[LENGTH_EQ_NUM_compute] - \\ rw[EQ_IMP_THM] \\ rw[]); + \\ rw[EQ_IMP_THM] \\ rw[] +QED (* -- *) -Theorem MAP_FST_compile_prog - `MAP FST (compile_prog max_app ls) = +Theorem MAP_FST_compile_prog: + MAP FST (compile_prog max_app ls) = MAP (((+)(num_stubs max_app))) - (MAP FST ls ++ REVERSE (code_locs (MAP (SND o SND) ls)))` - (simp[clos_to_bvlTheory.compile_prog_def, UNCURRY] + (MAP FST ls ++ REVERSE (code_locs (MAP (SND o SND) ls))) +Proof + simp[clos_to_bvlTheory.compile_prog_def, UNCURRY] \\ Cases_on`compile_exps max_app (MAP (SND o SND) ls) []` \\ imp_res_tac compile_exps_LENGTH \\ fs[MAP2_MAP, MAP_MAP_o, o_DEF, UNCURRY] @@ -7250,10 +7473,11 @@ Theorem MAP_FST_compile_prog \\ simp[MAP_MAP_o, o_DEF] \\ qhdtm_x_assum`compile_exps`mp_tac \\ specl_args_of_then``compile_exps`` compile_exps_code_locs mp_tac - \\ rw[] \\ fs[]); + \\ rw[] \\ fs[] +QED -Theorem MAP_FST_compile_inc - `MAP FST (compile_inc max_app p) = [] (* +Theorem MAP_FST_compile_inc: + MAP FST (compile_inc max_app p) = [] (* MAP ((+)(num_stubs max_app)) (MAP ((+)(FST(extract_name (FST p)))) (COUNT_LIST (MAX 1 (LENGTH (SND (extract_name (FST p)))))) @@ -7262,73 +7486,94 @@ Theorem MAP_FST_compile_inc (code_locs (MAP (SND o SND) (chain_exps (FST (extract_name (FST p))) - (SND (extract_name (FST p))) ++ SND p))))) *)` - (rw[compile_inc_uncurry, MAP_FST_compile_prog, MAP_FST_chain_exps_any]); - -Theorem calls_Op_Const - `calls ((Op None (Const n) [])::ls) aux = - ((CONS (Op None (Const n) [])) ## I) (calls ls aux)` - (Cases_on`ls` \\ rw[clos_callTheory.calls_def] - \\ pairarg_tac \\ fs[]); - -Theorem annotate_Op_Const - `annotate m ((Op None (Const n) [])::ls) = Op None (Const n) [] :: annotate m ls` - (rw[clos_annotateTheory.annotate_def] + (SND (extract_name (FST p))) ++ SND p))))) *) +Proof + rw[compile_inc_uncurry, MAP_FST_compile_prog, MAP_FST_chain_exps_any] +QED + +Theorem calls_Op_Const: + calls ((Op None (Const n) [])::ls) aux = + ((CONS (Op None (Const n) [])) ## I) (calls ls aux) +Proof + Cases_on`ls` \\ rw[clos_callTheory.calls_def] + \\ pairarg_tac \\ fs[] +QED + +Theorem annotate_Op_Const: + annotate m ((Op None (Const n) [])::ls) = Op None (Const n) [] :: annotate m ls +Proof + rw[clos_annotateTheory.annotate_def] \\ Cases_on`ls` >- EVAL_TAC \\ rw[clos_annotateTheory.alt_free_def] \\ pairarg_tac \\ fs[] \\ Cases_on`c2` >- EVAL_TAC - \\ rw[clos_annotateTheory.shift_def]); + \\ rw[clos_annotateTheory.shift_def] +QED -Theorem extract_name_Op_Const - `extract_name ((Op None (Const (&n)) [])::ls) = if NULL ls then (0,[Op None (Const (&n)) []]) else (n, ls)` - (EVAL_TAC +Theorem extract_name_Op_Const: + extract_name ((Op None (Const (&n)) [])::ls) = if NULL ls then (0,[Op None (Const (&n)) []]) else (n, ls) +Proof + EVAL_TAC \\ DEEP_INTRO_TAC some_intro - \\ fs[NULL_EQ]); - -Theorem known_Op_Const - `known a ((Op None (Const (&n)) [])::b) c d = ((CONS (Op None (Const (&n)) [], Int (&n))) ## I) (known a b c d)` - (Cases_on`b` \\ rw[clos_knownTheory.known_def] - \\ EVAL_TAC \\ simp[UNCURRY] \\ Cases_on`known a (h::t) c d` \\ simp[]); - -Theorem remove_ticks_Op_Const - `remove_ticks ((Op None (Const (&n)) [])::ls) = (Op None (Const (&n)) [])::(remove_ticks ls)` - (Cases_on`ls` \\ EVAL_TAC); - -Theorem let_op_Op_Const - `let_op ((Op None (Const (&n)) [])::ls) = (Op None (Const (&n)) [])::(let_op ls)` - (Cases_on`ls` \\ EVAL_TAC); - -Theorem mcompile_inc_nil - `(FST p = [] ⇒ (clos_mtiProof$compile_inc max_app p = ([],[]))) ∧ - (FST p ≠ [] ⇒ FST (clos_mtiProof$compile_inc max_app p) ≠ [])` - (Cases_on`p` \\ rw[] \\ EVAL_TAC - \\ strip_tac \\ fs[]); - -Theorem renumber_code_locs_list_nil - `((xs = []) ⇒ (SND (renumber_code_locs_list n xs) = [])) ∧ - ((xs ≠ []) ⇒ (SND (renumber_code_locs_list n xs) ≠ []))` - (rw[] + \\ fs[NULL_EQ] +QED + +Theorem known_Op_Const: + known a ((Op None (Const (&n)) [])::b) c d = ((CONS (Op None (Const (&n)) [], Int (&n))) ## I) (known a b c d) +Proof + Cases_on`b` \\ rw[clos_knownTheory.known_def] + \\ EVAL_TAC \\ simp[UNCURRY] \\ Cases_on`known a (h::t) c d` \\ simp[] +QED + +Theorem remove_ticks_Op_Const: + remove_ticks ((Op None (Const (&n)) [])::ls) = (Op None (Const (&n)) [])::(remove_ticks ls) +Proof + Cases_on`ls` \\ EVAL_TAC +QED + +Theorem let_op_Op_Const: + let_op ((Op None (Const (&n)) [])::ls) = (Op None (Const (&n)) [])::(let_op ls) +Proof + Cases_on`ls` \\ EVAL_TAC +QED + +Theorem mcompile_inc_nil: + (FST p = [] ⇒ (clos_mtiProof$compile_inc max_app p = ([],[]))) ∧ + (FST p ≠ [] ⇒ FST (clos_mtiProof$compile_inc max_app p) ≠ []) +Proof + Cases_on`p` \\ rw[] \\ EVAL_TAC + \\ strip_tac \\ fs[] +QED + +Theorem renumber_code_locs_list_nil: + ((xs = []) ⇒ (SND (renumber_code_locs_list n xs) = [])) ∧ + ((xs ≠ []) ⇒ (SND (renumber_code_locs_list n xs) ≠ [])) +Proof + rw[] \\ EVAL_TAC \\ strip_tac \\ fs[] \\ pop_assum(mp_tac o Q.AP_TERM`LENGTH`) \\ simp_tac std_ss [clos_numberTheory.renumber_code_locs_length] - \\ simp[]); + \\ simp[] +QED -Theorem calls_nil - `((xs = []) ⇒ ((calls xs p) = ([],p))) ∧ - ((xs ≠ []) ⇒ (FST (calls xs p) ≠ []))` - (rw[] >- EVAL_TAC +Theorem calls_nil: + ((xs = []) ⇒ ((calls xs p) = ([],p))) ∧ + ((xs ≠ []) ⇒ (FST (calls xs p) ≠ [])) +Proof + rw[] >- EVAL_TAC \\ strip_tac \\ fs[] \\ Cases_on`calls xs p` \\ imp_res_tac clos_callTheory.calls_length - \\ rfs[]); + \\ rfs[] +QED -Theorem annotate_nil - `((xs = []) ⇒ (annotate n xs = [])) ∧ - ((xs ≠ []) ⇒ (annotate n xs ≠ []))` - (rw[] +Theorem annotate_nil: + ((xs = []) ⇒ (annotate n xs = [])) ∧ + ((xs ≠ []) ⇒ (annotate n xs ≠ [])) +Proof + rw[] \\ EVAL_TAC \\ strip_tac \\ fs[] \\ pop_assum(mp_tac o Q.AP_TERM`LENGTH`) @@ -7337,52 +7582,65 @@ Theorem annotate_nil \\ strip_tac \\ fs[] \\ pop_assum(mp_tac o Q.AP_TERM`LENGTH`) \\ simp_tac std_ss [clos_annotateTheory.LENGTH_FST_alt_free] - \\ simp[]); + \\ simp[] +QED -Theorem let_op_nil - `((xs = []) ⇒ (let_op xs = [])) ∧ - ((xs ≠ []) ⇒ (let_op xs ≠ []))` - (rw[] +Theorem let_op_nil: + ((xs = []) ⇒ (let_op xs = [])) ∧ + ((xs ≠ []) ⇒ (let_op xs ≠ [])) +Proof + rw[] \\ EVAL_TAC \\ strip_tac \\ Cases_on`xs` \\ fs[] \\ Cases_on`t` \\ fs[clos_letopTheory.let_op_def] \\ qspec_then`h`strip_assume_tac clos_letopProofTheory.let_op_SING - \\ fs[]); + \\ fs[] +QED -Theorem remove_ticks_nil - `((xs = []) ⇒ (remove_ticks xs = [])) ∧ - ((xs ≠ []) ⇒ (remove_ticks xs ≠ []))` - (rw[] +Theorem remove_ticks_nil: + ((xs = []) ⇒ (remove_ticks xs = [])) ∧ + ((xs ≠ []) ⇒ (remove_ticks xs ≠ [])) +Proof + rw[] \\ EVAL_TAC \\ strip_tac \\ Cases_on`xs` \\ fs[] \\ Cases_on`t` \\ fs[clos_ticksTheory.remove_ticks_def] \\ qspec_then`h`strip_assume_tac clos_ticksProofTheory.remove_ticks_SING - \\ fs[]); + \\ fs[] +QED -Theorem known_nil - `((b = []) ⇒ (FST (known a b c d) = [])) ∧ - ((b ≠ []) ⇒ (FST (known a b c d) ≠ []))` - (rw[] \\ EVAL_TAC \\ strip_tac +Theorem known_nil: + ((b = []) ⇒ (FST (known a b c d) = [])) ∧ + ((b ≠ []) ⇒ (FST (known a b c d) ≠ [])) +Proof + rw[] \\ EVAL_TAC \\ strip_tac \\ qspecl_then[`a`,`b`,`c`,`d`]mp_tac clos_knownTheory.known_LENGTH - \\ simp[]); + \\ simp[] +QED -Theorem ignore_table_uncurry - `ignore_table f st p = (FST(f st (FST p)), (SND(f st (FST p))), SND p)` - (Cases_on`p` \\ EVAL_TAC \\ rw[UNCURRY]); +Theorem ignore_table_uncurry: + ignore_table f st p = (FST(f st (FST p)), (SND(f st (FST p))), SND p) +Proof + Cases_on`p` \\ EVAL_TAC \\ rw[UNCURRY] +QED -Theorem LENGTH_FST_calls - `LENGTH (FST (calls xs g0)) = LENGTH xs` - (Cases_on`calls xs g0` - \\ imp_res_tac clos_callTheory.calls_length \\ fs[]); +Theorem LENGTH_FST_calls: + LENGTH (FST (calls xs g0)) = LENGTH xs +Proof + Cases_on`calls xs g0` + \\ imp_res_tac clos_callTheory.calls_length \\ fs[] +QED -Theorem MAX_MAX_ELIM - `a ≤ b ∨ a ≤ c ⇒ (MAX a (MAX b c) = MAX b c)` - (rw[MAX_DEF]); +Theorem MAX_MAX_ELIM: + a ≤ b ∨ a ≤ c ⇒ (MAX a (MAX b c) = MAX b c) +Proof + rw[MAX_DEF] +QED -Theorem compile_semantics - `semantics (ffi:'ffi ffi_state) c.max_app FEMPTY co +Theorem compile_semantics: + semantics (ffi:'ffi ffi_state) c.max_app FEMPTY co (compile_common_inc c (pure_cc (compile_inc c.max_app) cc)) es ≠ Fail ∧ compile c es = (c', prog) ∧ syntax_oracle_ok c es co @@ -7397,8 +7655,9 @@ Theorem compile_semantics ((if c.do_mti then pure_co (clos_mtiProof$compile_inc c.max_app) else I) o co)))) cc c'.start = semantics ffi c.max_app FEMPTY co - (compile_common_inc c (pure_cc (compile_inc c.max_app) cc)) es` - (strip_tac + (compile_common_inc c (pure_cc (compile_inc c.max_app) cc)) es +Proof + strip_tac \\ imp_res_tac compile_all_distinct_locs \\ fs[compile_def] \\ pairarg_tac \\ fs[] \\ rveq @@ -7743,26 +8002,31 @@ Theorem compile_semantics \\ simp[ALL_DISTINCT_APPEND] \\ strip_tac \\ ... ) - \\ ... (* many syntactic properties of oracle *)*)); + \\ ... (* many syntactic properties of oracle *)*) +QED -Theorem assign_get_code_label_compile_op - `closLang$assign_get_code_label (compile_op op) = case some n. op = Label n of SOME n => {n} | _ => {}` - (Cases_on`op` \\ rw[clos_to_bvlTheory.compile_op_def, closLangTheory.assign_get_code_label_def]); +Theorem assign_get_code_label_compile_op: + closLang$assign_get_code_label (compile_op op) = case some n. op = Label n of SOME n => {n} | _ => {} +Proof + Cases_on`op` \\ rw[clos_to_bvlTheory.compile_op_def, closLangTheory.assign_get_code_label_def] +QED -Theorem recc_Lets_code_labels - `∀n nargs k rest. get_code_labels (recc_Lets n nargs k rest) = - IMAGE (λj. n + 2 * j) (count k) ∪ get_code_labels rest` - (recInduct clos_to_bvlTheory.recc_Lets_ind \\ rw[] +Theorem recc_Lets_code_labels: + ∀n nargs k rest. get_code_labels (recc_Lets n nargs k rest) = + IMAGE (λj. n + 2 * j) (count k) ∪ get_code_labels rest +Proof + recInduct clos_to_bvlTheory.recc_Lets_ind \\ rw[] \\ rw[Once clos_to_bvlTheory.recc_Lets_def] \\ fs[] \\ fs[clos_to_bvlTheory.recc_Let_def, closLangTheory.assign_get_code_label_def] \\ rw[Once EXTENSION] \\ Cases_on`k` \\ fs[] \\ fsrw_tac[DNF_ss][EQ_IMP_THM, PULL_EXISTS,ADD1] \\ rw[ADD1] >- ( disj1_tac \\ qexists_tac`n'` \\ simp[] ) - \\ Cases_on`j < n'` \\ fs[]); + \\ Cases_on`j < n'` \\ fs[] +QED -Theorem compile_exps_code_labels - `!app es1 aux1 es2 aux2. +Theorem compile_exps_code_labels: + !app es1 aux1 es2 aux2. compile_exps app es1 aux1 = (es2, aux2) ∧ EVERY no_Labels es1 ∧ 0 < app ∧ EVERY (obeys_max_app app) es1 ∧ every_Fn_SOME es1 ==> @@ -7771,8 +8035,9 @@ Theorem compile_exps_code_labels ⊆ IMAGE (((+) (num_stubs app))) (BIGUNION (set (MAP get_code_labels es1))) ∪ BIGUNION (set (MAP (get_code_labels o SND o SND) aux1)) ∪ - domain (init_code app)` - (recInduct clos_to_bvlTheory.compile_exps_ind + domain (init_code app) +Proof + recInduct clos_to_bvlTheory.compile_exps_ind \\ rw [clos_to_bvlTheory.compile_exps_def] \\ rw [] \\ rpt (pairarg_tac \\ fs []) \\ rw [] \\ imp_res_tac clos_to_bvlTheory.compile_exps_SING \\ rveq \\ fs [] @@ -7855,10 +8120,11 @@ Theorem compile_exps_code_labels \\ fs[] \\ metis_tac[] ) >- metis_tac[]) - \\ fs[SUBSET_DEF, PULL_EXISTS, MEM_GENLIST] \\ rw[] \\ metis_tac[]); + \\ fs[SUBSET_DEF, PULL_EXISTS, MEM_GENLIST] \\ rw[] \\ metis_tac[] +QED -Theorem compile_prog_code_labels - `0 < max_app ∧ +Theorem compile_prog_code_labels: + 0 < max_app ∧ EVERY no_Labels (MAP (SND o SND) prog) ∧ EVERY (obeys_max_app max_app) (MAP (SND o SND) prog) ∧ every_Fn_SOME (MAP (SND o SND) prog) @@ -7866,8 +8132,9 @@ Theorem compile_prog_code_labels BIGUNION (set (MAP (get_code_labels o SND o SND) (compile_prog max_app prog))) SUBSET IMAGE (((+) (clos_to_bvl$num_stubs max_app))) (BIGUNION (set (MAP get_code_labels (MAP (SND o SND) prog)))) ∪ - domain (init_code max_app)` - (rw[clos_to_bvlTheory.compile_prog_def] + domain (init_code max_app) +Proof + rw[clos_to_bvlTheory.compile_prog_def] \\ pairarg_tac \\ fs[] \\ imp_res_tac clos_to_bvlTheory.compile_exps_LENGTH \\ fs[] \\ simp[MAP2_MAP] @@ -7875,29 +8142,36 @@ Theorem compile_prog_code_labels \\ simp[GSYM o_DEF, GSYM MAP_MAP_o, MAP_ZIP] \\ fs[MAP_MAP_o, o_DEF] \\ drule compile_exps_code_labels - \\ simp[MAP_MAP_o, o_DEF]); - -Theorem chain_exps_no_Labels - `!es l. EVERY no_Labels es ==> - EVERY no_Labels (MAP (SND ∘ SND) (chain_exps l es))` - (Induct_on `es` \\ fs [clos_to_bvlTheory.chain_exps_def] - \\ Cases_on `es` \\ fs [clos_to_bvlTheory.chain_exps_def]); - -Theorem chain_exps_obeys_max_app - `!es l. EVERY (obeys_max_app k) es ==> - EVERY (obeys_max_app k) (MAP (SND ∘ SND) (chain_exps l es))` - (Induct_on `es` \\ fs [clos_to_bvlTheory.chain_exps_def] - \\ Cases_on `es` \\ fs [clos_to_bvlTheory.chain_exps_def]); - -Theorem chain_exps_every_Fn_SOME - `!es l. every_Fn_SOME es ==> - every_Fn_SOME (MAP (SND ∘ SND) (chain_exps l es))` - (Induct_on `es` \\ fs [clos_to_bvlTheory.chain_exps_def] + \\ simp[MAP_MAP_o, o_DEF] +QED + +Theorem chain_exps_no_Labels: + !es l. EVERY no_Labels es ==> + EVERY no_Labels (MAP (SND ∘ SND) (chain_exps l es)) +Proof + Induct_on `es` \\ fs [clos_to_bvlTheory.chain_exps_def] + \\ Cases_on `es` \\ fs [clos_to_bvlTheory.chain_exps_def] +QED + +Theorem chain_exps_obeys_max_app: + !es l. EVERY (obeys_max_app k) es ==> + EVERY (obeys_max_app k) (MAP (SND ∘ SND) (chain_exps l es)) +Proof + Induct_on `es` \\ fs [clos_to_bvlTheory.chain_exps_def] + \\ Cases_on `es` \\ fs [clos_to_bvlTheory.chain_exps_def] +QED + +Theorem chain_exps_every_Fn_SOME: + !es l. every_Fn_SOME es ==> + every_Fn_SOME (MAP (SND ∘ SND) (chain_exps l es)) +Proof + Induct_on `es` \\ fs [clos_to_bvlTheory.chain_exps_def] \\ Cases_on `es` \\ fs [clos_to_bvlTheory.chain_exps_def] \\ rw [] \\ res_tac \\ fs [] \\ once_rewrite_tac [closPropsTheory.every_Fn_SOME_APPEND |> Q.INST [`l1`|->`x::[]`] |> SIMP_RULE std_ss [APPEND]] - \\ fs []); + \\ fs [] +QED (* val () = temp_overload_on("acompile",``clos_annotate$compile``); diff --git a/compiler/backend/proofs/data_liveProofScript.sml b/compiler/backend/proofs/data_liveProofScript.sml index c880320759..1a400fab45 100644 --- a/compiler/backend/proofs/data_liveProofScript.sml +++ b/compiler/backend/proofs/data_liveProofScript.sml @@ -483,11 +483,12 @@ val evaluate_compile = Q.prove( \\ Cases_on `h` \\ fs [] \\ SRW_TAC [] [] \\ fs []); -Theorem compile_correct - `!c s. FST (evaluate (c,s)) <> SOME (Rerr(Rabort Rtype_error)) /\ +Theorem compile_correct: + !c s. FST (evaluate (c,s)) <> SOME (Rerr(Rabort Rtype_error)) /\ FST (evaluate (c,s)) <> NONE ==> - (evaluate (FST (compile c LN),s) = evaluate (c,s))` - (REPEAT STRIP_TAC + (evaluate (FST (compile c LN),s) = evaluate (c,s)) +Proof + REPEAT STRIP_TAC \\ (evaluate_compile |> ONCE_REWRITE_RULE [SPLIT_PAIR] |> SIMP_RULE std_ss [] |> Q.SPECL [`c`,`s`,`LN`,`s`] |> SIMP_RULE std_ss [state_rel_ID] |> MP_TAC) @@ -501,13 +502,16 @@ Theorem compile_correct \\ (Q.ISPECL_THEN [`FST (compile c LN)`,`s`]mp_tac evaluate_stack) \\ fs [] \\ Cases_on `x` \\ fs [] \\ Cases_on`e`>>fs[] \\ Cases_on`a`>>fs[] - \\ REPEAT STRIP_TAC \\ fs [] \\ SRW_TAC [] [] \\ fs []); + \\ REPEAT STRIP_TAC \\ fs [] \\ SRW_TAC [] [] \\ fs [] +QED -Theorem get_code_labels_compile - `∀x y. get_code_labels (FST (compile x y)) ⊆ get_code_labels x` - (recInduct data_liveTheory.compile_ind +Theorem get_code_labels_compile: + ∀x y. get_code_labels (FST (compile x y)) ⊆ get_code_labels x +Proof + recInduct data_liveTheory.compile_ind \\ rw[data_liveTheory.compile_def] \\ rpt(pairarg_tac \\ fs[]) - \\ fs[SUBSET_DEF]); + \\ fs[SUBSET_DEF] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/data_simpProofScript.sml b/compiler/backend/proofs/data_simpProofScript.sml index 173d680de0..36b572d835 100644 --- a/compiler/backend/proofs/data_simpProofScript.sml +++ b/compiler/backend/proofs/data_simpProofScript.sml @@ -33,15 +33,19 @@ val evaluate_simp = Q.prove( \\ CONV_TAC (DEPTH_CONV (PairRules.PBETA_CONV)) \\ every_case_tac >> fs[evaluate_def]); -Theorem simp_correct - `!c s. evaluate (simp c Skip,s) = evaluate (c,s)` - (SIMP_TAC std_ss [evaluate_simp,evaluate_Seq_Skip]); - -Theorem get_code_labels_simp - `∀x y. get_code_labels (simp x y) ⊆ get_code_labels x ∪ get_code_labels y` - (recInduct data_simpTheory.simp_ind +Theorem simp_correct: + !c s. evaluate (simp c Skip,s) = evaluate (c,s) +Proof + SIMP_TAC std_ss [evaluate_simp,evaluate_Seq_Skip] +QED + +Theorem get_code_labels_simp: + ∀x y. get_code_labels (simp x y) ⊆ get_code_labels x ∪ get_code_labels y +Proof + recInduct data_simpTheory.simp_ind \\ rw[data_simpTheory.simp_def] \\ fs[SUBSET_DEF, data_simpTheory.pSeq_def] \\ rw[] - \\ metis_tac[]); + \\ metis_tac[] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/data_spaceProofScript.sml b/compiler/backend/proofs/data_spaceProofScript.sml index d8c5d1ae74..1508ebad10 100644 --- a/compiler/backend/proofs/data_spaceProofScript.sml +++ b/compiler/backend/proofs/data_spaceProofScript.sml @@ -20,10 +20,12 @@ val mk_wf_inter = Q.prove( `!t1 t2. inter t1 t2 = mk_wf (inter t1 t2)`, full_simp_tac(srw_ss())[]); -Theorem get_vars_IMP_LENGTH - `!xs s l. get_vars xs s = SOME l ==> (LENGTH l = LENGTH xs)` - (Induct \\ fs [get_vars_def] \\ rw [] \\ every_case_tac \\ fs [] - \\ rw [] \\ fs [] \\ res_tac \\ fs []); +Theorem get_vars_IMP_LENGTH: + !xs s l. get_vars xs s = SOME l ==> (LENGTH l = LENGTH xs) +Proof + Induct \\ fs [get_vars_def] \\ rw [] \\ every_case_tac \\ fs [] + \\ rw [] \\ fs [] \\ res_tac \\ fs [] +QED val case_eq_thms = bvlPropsTheory.case_eq_thms; @@ -373,23 +375,26 @@ val evaluate_compile = Q.prove( dec_clock_def] \\ METIS_TAC []) \\ full_simp_tac(srw_ss())[] \\ METIS_TAC [locals_ok_refl,with_same_locals])); -Theorem compile_correct - `!c s. +Theorem compile_correct: + !c s. FST (evaluate (c,s)) <> NONE /\ FST (evaluate (c,s)) <> SOME (Rerr(Rabort Rtype_error)) ==> - (evaluate (compile c, s) = evaluate (c,s))` - (REPEAT STRIP_TAC \\ Cases_on `evaluate (c,s)` \\ full_simp_tac(srw_ss())[] + (evaluate (compile c, s) = evaluate (c,s)) +Proof + REPEAT STRIP_TAC \\ Cases_on `evaluate (c,s)` \\ full_simp_tac(srw_ss())[] \\ MP_TAC (Q.SPECL [`c`,`s`] evaluate_compile) \\ full_simp_tac(srw_ss())[] \\ REPEAT STRIP_TAC \\ POP_ASSUM (MP_TAC o Q.SPECL [`s.locals`]) \\ full_simp_tac(srw_ss())[locals_ok_refl] - \\ REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[with_same_locals]); + \\ REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[with_same_locals] +QED -Theorem get_code_labels_space - `∀x y y0 y1 y2. +Theorem get_code_labels_space: + ∀x y y0 y1 y2. (space x = INL y ⇒ get_code_labels y = get_code_labels x) ∧ - (space x = INR (y0,y1,y2) ⇒ get_code_labels y2 = get_code_labels x)` - (recInduct data_spaceTheory.space_ind + (space x = INR (y0,y1,y2) ⇒ get_code_labels y2 = get_code_labels x) +Proof + recInduct data_spaceTheory.space_ind \\ rw[data_spaceTheory.space_def] \\ simp[] \\ fs[CaseEq"sum",CaseEq"dataLang$prog"] \\ rveq \\ fs[data_spaceTheory.space_def] \\ fs[data_spaceTheory.pMakeSpace_def] @@ -399,15 +404,18 @@ Theorem get_code_labels_space \\ Cases_on`space c2` \\ Cases_on`space c3` \\ fs[] \\ TRY(PairCases_on`y`) \\ fs[data_spaceTheory.pMakeSpace_def,CaseEq"option",data_spaceTheory.space_def] \\ PairCases_on`y'` - \\ fs[data_spaceTheory.pMakeSpace_def,CaseEq"option",data_spaceTheory.space_def]); + \\ fs[data_spaceTheory.pMakeSpace_def,CaseEq"option",data_spaceTheory.space_def] +QED -Theorem get_code_labels_compile[simp] - `∀x. get_code_labels (data_space$compile x) = get_code_labels x` - (rw[data_spaceTheory.compile_def] +Theorem get_code_labels_compile[simp]: + ∀x. get_code_labels (data_space$compile x) = get_code_labels x +Proof + rw[data_spaceTheory.compile_def] \\ Cases_on`space x` \\ simp[data_spaceTheory.pMakeSpace_def] \\ TRY (PairCases_on`y`) \\ simp[data_spaceTheory.pMakeSpace_def] - \\ imp_res_tac get_code_labels_space); + \\ imp_res_tac get_code_labels_space +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/data_to_wordProofScript.sml b/compiler/backend/proofs/data_to_wordProofScript.sml index 8c2b10d801..fbce16f131 100644 --- a/compiler/backend/proofs/data_to_wordProofScript.sml +++ b/compiler/backend/proofs/data_to_wordProofScript.sml @@ -34,8 +34,8 @@ val assign_def = data_to_wordTheory.arg4_def, data_to_wordTheory.all_assign_defs]; -Theorem data_compile_correct - `!prog s c n l l1 l2 res s1 (t:('a,'c,'ffi)wordSem$state) locs. +Theorem data_compile_correct: + !prog s c n l l1 l2 res s1 (t:('a,'c,'ffi)wordSem$state) locs. (dataSem$evaluate (prog,s) = (res,s1)) /\ res <> SOME (Rerr (Rabort Rtype_error)) /\ state_rel c l1 l2 s t [] locs /\ @@ -59,8 +59,9 @@ Theorem data_compile_correct !i. state_rel c l5 l6 (set_var i v s1) (set_var (adjust_var i) w t1) [] ll) | SOME (Rerr (Rabort(Rffi_error f))) => (res1 = SOME(FinalFFI f) /\ t1.ffi = s1.ffi) - | SOME (Rerr (Rabort e)) => (res1 = SOME TimeOut) /\ t1.ffi = s1.ffi)` - (recInduct dataSemTheory.evaluate_ind \\ rpt strip_tac \\ full_simp_tac(srw_ss())[] + | SOME (Rerr (Rabort e)) => (res1 = SOME TimeOut) /\ t1.ffi = s1.ffi) +Proof + recInduct dataSemTheory.evaluate_ind \\ rpt strip_tac \\ full_simp_tac(srw_ss())[] THEN1 (* Skip *) (full_simp_tac(srw_ss())[comp_def,dataSemTheory.evaluate_def,wordSemTheory.evaluate_def] \\ srw_tac[][]) @@ -395,10 +396,11 @@ Theorem data_compile_correct \\ imp_res_tac mk_loc_eq_push_env_exc_Exception \\ full_simp_tac(srw_ss())[] \\ imp_res_tac eval_push_env_SOME_exc_IMP_s_key_eq \\ imp_res_tac s_key_eq_handler_eq_IMP - \\ full_simp_tac(srw_ss())[jump_exc_inc_clock_EQ_NONE] \\ metis_tac [])); + \\ full_simp_tac(srw_ss())[jump_exc_inc_clock_EQ_NONE] \\ metis_tac []) +QED -Theorem compile_correct_lemma - `!s c l1 l2 res s1 (t:('a,'c,'ffi) wordSem$state) start. +Theorem compile_correct_lemma: + !s c l1 l2 res s1 (t:('a,'c,'ffi) wordSem$state) start. (dataSem$evaluate (Call NONE (SOME start) [] NONE,s) = (res,s1)) /\ res <> SOME (Rerr (Rabort Rtype_error)) /\ t.termdep > 1 /\ @@ -415,8 +417,9 @@ Theorem compile_correct_lemma | SOME (Rerr (Rraise v)) => (t1.ffi = s1.ffi) /\ (?v w. res1 = SOME (Exception v w)) | SOME (Rerr (Rabort(Rffi_error f))) => (res1 = SOME(FinalFFI f) /\ t1.ffi = s1.ffi) - | SOME (Rerr (Rabort e)) => (res1 = SOME TimeOut) /\ t1.ffi = s1.ffi)` - (rpt strip_tac + | SOME (Rerr (Rabort e)) => (res1 = SOME TimeOut) /\ t1.ffi = s1.ffi) +Proof + rpt strip_tac \\ drule data_compile_correct \\ full_simp_tac(srw_ss())[] \\ ntac 2 (disch_then drule) \\ full_simp_tac(srw_ss())[comp_def] \\ strip_tac @@ -424,7 +427,8 @@ Theorem compile_correct_lemma \\ qexists_tac `res1` \\ full_simp_tac(srw_ss())[] \\ strip_tac \\ full_simp_tac(srw_ss())[] \\ every_case_tac \\ full_simp_tac(srw_ss())[] - \\ full_simp_tac(srw_ss())[state_rel_def]); + \\ full_simp_tac(srw_ss())[state_rel_def] +QED val state_rel_ext_def = Define ` state_rel_ext c l1 l2 s u <=> @@ -443,8 +447,8 @@ val state_rel_ext_def = Define ` lookup n l = SOME (SND (full_compile_single t' k' a' c' ((n,v),col)))) /\ u = t with <| code := l; termdep:=0; compile:=u.compile; compile_oracle := u.compile_oracle|>` -Theorem compile_correct - `!x s l1 l2 res s1 (t:('a,'c,'ffi) wordSem$state) start. +Theorem compile_correct: + !x s l1 l2 res s1 (t:('a,'c,'ffi) wordSem$state) start. (dataSem$evaluate (Call NONE (SOME start) [] NONE,s) = (res,s1)) /\ res <> SOME (Rerr (Rabort Rtype_error)) /\ state_rel_ext x l1 l2 s t ==> @@ -460,8 +464,9 @@ Theorem compile_correct | SOME (Rval v) => ?w. (res1 = SOME (Result (Loc l1 l2) w)) | SOME (Rerr (Rraise v)) => (?v w. res1 = SOME (Exception v w)) | SOME (Rerr (Rabort(Rffi_error f))) => (res1 = SOME(FinalFFI f)) - | SOME (Rerr (Rabort e)) => (res1 = SOME TimeOut))` - (gen_tac + | SOME (Rerr (Rabort e)) => (res1 = SOME TimeOut)) +Proof + gen_tac \\ full_simp_tac(srw_ss())[state_rel_ext_def,PULL_EXISTS] \\ srw_tac[][] \\ fs [wordSemTheory.state_component_equality] \\ rename1 `state_rel x0 l1 l2 s t2 [] []` @@ -521,7 +526,8 @@ Theorem compile_correct \\ qsuff_tac `t6 = t7` THEN1 (every_case_tac \\ fs []) \\ unabbrev_all_tac \\ fs [] - \\ fs [wordSemTheory.state_component_equality]); + \\ fs [wordSemTheory.state_component_equality] +QED val state_rel_ext_with_clock = Q.prove( `state_rel_ext a b c s1 s2 ==> @@ -535,12 +541,13 @@ val state_rel_ext_with_clock = Q.prove( (* observational semantics preservation *) -Theorem compile_semantics_lemma - `state_rel_ext conf 1 0 (initial_state (ffi:'ffi ffi_state) (fromAList prog) co cc t.clock) (t:('a,'c,'ffi) wordSem$state) /\ +Theorem compile_semantics_lemma: + state_rel_ext conf 1 0 (initial_state (ffi:'ffi ffi_state) (fromAList prog) co cc t.clock) (t:('a,'c,'ffi) wordSem$state) /\ semantics ffi (fromAList prog) co cc start <> Fail ==> semantics t start IN - extend_with_resource_limit { semantics ffi (fromAList prog) co cc start }` - (simp[GSYM AND_IMP_INTRO] >> ntac 1 strip_tac >> + extend_with_resource_limit { semantics ffi (fromAList prog) co cc start } +Proof + simp[GSYM AND_IMP_INTRO] >> ntac 1 strip_tac >> simp[dataSemTheory.semantics_def] >> IF_CASES_TAC >> full_simp_tac(srw_ss())[] >> DEEP_INTRO_TAC some_intro >> simp[] >> @@ -755,7 +762,8 @@ Theorem compile_semantics_lemma rpt(first_x_assum(qspec_then`k+ck`mp_tac)>>simp[])) >> REV_FULL_SIMP_TAC(srw_ss()++ARITH_ss)[]>> fsrw_tac[ARITH_ss][IS_PREFIX_APPEND]>> - simp[EL_APPEND1]); + simp[EL_APPEND1] +QED val code_rel_ext_def = Define` code_rel_ext code l ⇔ @@ -766,8 +774,8 @@ val code_rel_ext_def = Define` (SND (full_compile_single t' k' a' c' ((n,p_1,p_2),col))) = lookup n l)` -Theorem compile_semantics ` - (* Definitely correct *) +Theorem compile_semantics: + (* Definitely correct *) t:('a,'c,'ffi) state.handler = 0 ∧ t.gc_fun = word_gc_fun c ∧ init_store_ok c t.store t.memory t.mdomain t.code_buffer t.data_buffer ∧ good_dimindex (:α) ∧ @@ -790,8 +798,9 @@ Theorem compile_semantics ` Fail ≠ semantics t.ffi (fromAList prog) co cc start ⇒ semantics t start ∈ extend_with_resource_limit - {semantics t.ffi (fromAList prog) co cc start}` - (rw[]>> + {semantics t.ffi (fromAList prog) co cc start} +Proof + rw[]>> match_mp_tac (GEN_ALL compile_semantics_lemma)>> qexists_tac`c`>>fs[state_rel_ext_def]>>rw[]>> fs[code_rel_ext_def]>> @@ -809,7 +818,8 @@ Theorem compile_semantics ` (unabbrev_all_tac>>fs[]>> metis_tac[])>> fs[FORALL_PROD]>> - metis_tac[]); + metis_tac[] +QED val code_rel_ext_def = definition"code_rel_ext_def"; @@ -817,14 +827,18 @@ val _ = (max_print_depth := 15); val extract_labels_def = wordPropsTheory.extract_labels_def; -Theorem extract_labels_MemEqList[simp] - `!a x. extract_labels (MemEqList a x) = []` - (Induct_on `x` - \\ asm_rewrite_tac [MemEqList_def,extract_labels_def,APPEND]); +Theorem extract_labels_MemEqList[simp]: + !a x. extract_labels (MemEqList a x) = [] +Proof + Induct_on `x` + \\ asm_rewrite_tac [MemEqList_def,extract_labels_def,APPEND] +QED -Theorem extract_labels_StoreEach - `!xs a d. extract_labels (StoreEach a xs d) = []` - (Induct \\ fs [StoreEach_def,extract_labels_def]); +Theorem extract_labels_StoreEach: + !xs a d. extract_labels (StoreEach a xs d) = [] +Proof + Induct \\ fs [StoreEach_def,extract_labels_def] +QED (* TODO: goes away on inlineenc branch *) val extract_labels_WordOp64_on_32 = Q.prove(` @@ -860,14 +874,15 @@ val extract_labels_assignWordShift = Q.prove(` simp[extract_labels_def,list_Seq_def,extract_labels_WordShift64_on_32]>> EVAL_TAC); -Theorem data_to_word_lab_pres_lem ` - ∀c n l p. +Theorem data_to_word_lab_pres_lem: + ∀c n l p. l ≠ 0 ⇒ let (cp,l') = comp c n l p in l ≤ l' ∧ EVERY (λ(l1,l2). l1 = n ∧ l ≤ l2 ∧ l2 < l') (extract_labels cp) ∧ - ALL_DISTINCT (extract_labels cp)` - (HO_MATCH_MP_TAC comp_ind>>Cases_on`p`>>rw[]>> + ALL_DISTINCT (extract_labels cp) +Proof + HO_MATCH_MP_TAC comp_ind>>Cases_on`p`>>rw[]>> once_rewrite_tac[comp_def]>>fs[extract_labels_def] >- (BasicProvers.EVERY_CASE_TAC>>fs[]>>rveq>>fs[extract_labels_def]>> @@ -899,7 +914,8 @@ Theorem data_to_word_lab_pres_lem ` SilentFFI_def,list_Seq_def]>> every_case_tac >> fs [] >> fs[extract_labels_def,EVERY_MEM,FORALL_PROD,ALL_DISTINCT_APPEND, - SilentFFI_def,list_Seq_def])); + SilentFFI_def,list_Seq_def]) +QED open match_goal; @@ -907,26 +923,31 @@ val labels_rel_emp = Q.prove(` labels_rel [] ls ⇒ ls = [] `, fs[word_simpProofTheory.labels_rel_def]); -Theorem stub_labels ` - EVERY (λ(n,m,p). +Theorem stub_labels: + EVERY (λ(n,m,p). EVERY (λ(l1,l2). l1 = n ∧ l2 ≠ 0) (extract_labels p) ∧ ALL_DISTINCT (extract_labels p)) - (stubs (:'a) data_conf)` - (simp[data_to_wordTheory.stubs_def,generated_bignum_stubs_eq]>> + (stubs (:'a) data_conf) +Proof + simp[data_to_wordTheory.stubs_def,generated_bignum_stubs_eq]>> EVAL_TAC>> - rw[]>>EVAL_TAC); + rw[]>>EVAL_TAC +QED -Theorem stubs_with_has_fp_ops[simp] - `stubs (:α) (data_conf with has_fp_ops := b) = stubs (:α) data_conf` - (EVAL_TAC \\ fs []); +Theorem stubs_with_has_fp_ops[simp]: + stubs (:α) (data_conf with has_fp_ops := b) = stubs (:α) data_conf +Proof + EVAL_TAC \\ fs [] +QED -Theorem data_to_word_compile_lab_pres ` - let (c,p) = compile data_conf word_conf asm_conf prog in +Theorem data_to_word_compile_lab_pres: + let (c,p) = compile data_conf word_conf asm_conf prog in MAP FST p = MAP FST (stubs(:α) data_conf) ++ MAP FST prog ∧ EVERY (λn,m,(p:α wordLang$prog). let labs = extract_labels p in EVERY (λ(l1,l2).l1 = n ∧ l2 ≠ 0) labs ∧ - ALL_DISTINCT labs) p` - (fs[data_to_wordTheory.compile_def]>> + ALL_DISTINCT labs) p +Proof + fs[data_to_wordTheory.compile_def]>> qpat_abbrev_tac`datap = _ ++ MAP (A B) prog`>> mp_tac (compile_to_word_conventions |>GEN_ALL |> Q.SPECL [`word_conf`,`datap`,`asm_conf`])>> rw[]>> @@ -963,7 +984,8 @@ Theorem data_to_word_compile_lab_pres ` res_tac>>fs[]>> pairarg_tac>>fs[]>> qpat_x_assum`A=MAP FST pp` mp_tac>>simp[Once LIST_EQ_REWRITE,EL_MAP]>> - disch_then(qspec_then`n` assume_tac)>>rfs[]); + disch_then(qspec_then`n` assume_tac)>>rfs[] +QED val StoreEach_no_inst = Q.prove(` ∀a ls off. @@ -999,20 +1021,22 @@ val assign_no_inst = Q.prove(` inst_ok_less_def *) -Theorem comp_no_inst ` - ∀c n m p. +Theorem comp_no_inst: + ∀c n m p. ((c.has_longdiv ⇒ (ac.ISA = x86_64)) ∧ (c.has_div ⇒ (ac.ISA ∈ {ARMv8; MIPS;RISC_V})) ∧ (c.has_fp_ops ⇒ 1 < ac.fp_reg_count)) ∧ addr_offset_ok ac 0w /\ byte_offset_ok ac 0w ⇒ - every_inst (inst_ok_less ac) (FST(comp c n m p))` - (ho_match_mp_tac comp_ind>>Cases_on`p`>>rw[]>> + every_inst (inst_ok_less ac) (FST(comp c n m p)) +Proof + ho_match_mp_tac comp_ind>>Cases_on`p`>>rw[]>> simp[Once comp_def,every_inst_def]>> every_case_tac>>fs[]>> rpt(pairarg_tac>>fs[])>> fs[assign_no_inst]>> EVAL_TAC>>fs[] >> - IF_CASES_TAC >> EVAL_TAC >> fs []); + IF_CASES_TAC >> EVAL_TAC >> fs [] +QED val bounds_lem = Q.prove(` (dimindex(:'a) = 32 ∨ dimindex(:'a) = 64) ∧ @@ -1037,8 +1061,8 @@ val bounds_lem = Q.prove(` EVAL_TAC>> simp[numeral_bitTheory.iSUC,numeralTheory.numeral_evenodd,ODD]); -Theorem data_to_word_compile_conventions ` - good_dimindex(:'a) ==> +Theorem data_to_word_compile_conventions: + good_dimindex(:'a) ==> let (c,p) = compile data_conf wc ac prog in EVERY (λ(n,m,prog). flat_exp_conventions (prog:'a prog) ∧ @@ -1051,8 +1075,9 @@ Theorem data_to_word_compile_conventions ` anyway on all the targets *) (∀w. -8w <= w ∧ w <= 8w ==> byte_offset_ok ac w) ⇒ full_inst_ok_less ac prog) ∧ - (ac.two_reg_arith ⇒ every_inst two_reg_inst prog)) p` - (fs[data_to_wordTheory.compile_def]>> + (ac.two_reg_arith ⇒ every_inst two_reg_inst prog)) p +Proof + fs[data_to_wordTheory.compile_def]>> qpat_abbrev_tac`p= stubs(:'a) data_conf ++B`>> pairarg_tac>>fs[]>> Q.SPECL_THEN [`wc`,`p`,`ac`] mp_tac (GEN_ALL word_to_wordProofTheory.compile_to_word_conventions)>> @@ -1087,29 +1112,37 @@ Theorem data_to_word_compile_conventions ` match_mp_tac comp_no_inst>>fs[]>> first_x_assum match_mp_tac>> fs[good_dimindex_def]>> - metis_tac[bounds_lem]); - -Theorem data_to_word_names - `word_to_word$compile c1 c2 (stubs(:α)c.data_conf ++ MAP (compile_part c3) prog) = (col,p) ==> - MAP FST p = (MAP FST (stubs(:α)c.data_conf))++MAP FST prog` - (rw[]>>assume_tac(GEN_ALL word_to_wordProofTheory.compile_to_word_conventions)>> + metis_tac[bounds_lem] +QED + +Theorem data_to_word_names: + word_to_word$compile c1 c2 (stubs(:α)c.data_conf ++ MAP (compile_part c3) prog) = (col,p) ==> + MAP FST p = (MAP FST (stubs(:α)c.data_conf))++MAP FST prog +Proof + rw[]>>assume_tac(GEN_ALL word_to_wordProofTheory.compile_to_word_conventions)>> pop_assum (qspecl_then [`c1`,`stubs(:α)c.data_conf++(MAP (compile_part c3) prog)`,`c2`] assume_tac)>>rfs[]>> - fs[MAP_MAP_o,MAP_EQ_f,FORALL_PROD,data_to_wordTheory.compile_part_def]); - -Theorem ALL_DISTINCT_MAP_FST_stubs - `ALL_DISTINCT (MAP FST (stubs a c))` - (Cases_on`a` \\ EVAL_TAC); - -Theorem MAP_FST_stubs_bound - `MEM n (MAP FST (stubs a c)) ⇒ n < data_num_stubs` - (Cases_on`a` \\ EVAL_TAC - \\ strip_tac \\ rveq \\ EVAL_TAC); - -Theorem code_rel_ext_word_to_word - `∀code c1 col code'. + fs[MAP_MAP_o,MAP_EQ_f,FORALL_PROD,data_to_wordTheory.compile_part_def] +QED + +Theorem ALL_DISTINCT_MAP_FST_stubs: + ALL_DISTINCT (MAP FST (stubs a c)) +Proof + Cases_on`a` \\ EVAL_TAC +QED + +Theorem MAP_FST_stubs_bound: + MEM n (MAP FST (stubs a c)) ⇒ n < data_num_stubs +Proof + Cases_on`a` \\ EVAL_TAC + \\ strip_tac \\ rveq \\ EVAL_TAC +QED + +Theorem code_rel_ext_word_to_word: + ∀code c1 col code'. compile c1 c2 code = (col,code') ⇒ - code_rel_ext (fromAList code) (fromAList code')` - (simp[word_to_wordTheory.compile_def,code_rel_ext_def] \\ + code_rel_ext (fromAList code) (fromAList code') +Proof + simp[word_to_wordTheory.compile_def,code_rel_ext_def] \\ ntac 2 gen_tac \\ map_every qspec_tac (map swap [(`r`,`c1.reg_alg`), (`col`,`c1.col_oracle`)]) \\ Induct_on`code` \\ rw[] \\ @@ -1122,16 +1155,21 @@ Theorem code_rel_ext_word_to_word PairCases_on`p` \\ fs[word_to_wordTheory.compile_single_def] \\ rveq \\ fs[] \\ IF_CASES_TAC \\ fs[] \\ simp[word_to_wordTheory.full_compile_single_def,word_to_wordTheory.compile_single_def] \\ - metis_tac[]); - -Theorem max_heap_limit_has_fp_ops[simp] - `max_heap_limit (:α) (conf with has_fp_ops := b) = - max_heap_limit (:α) conf` - (EVAL_TAC); - -Theorem FST_compile_part[simp] - `FST (compile_part a b) = (FST b)` - (PairCases_on`b` \\ EVAL_TAC); + metis_tac[] +QED + +Theorem max_heap_limit_has_fp_ops[simp]: + max_heap_limit (:α) (conf with has_fp_ops := b) = + max_heap_limit (:α) conf +Proof + EVAL_TAC +QED + +Theorem FST_compile_part[simp]: + FST (compile_part a b) = (FST b) +Proof + PairCases_on`b` \\ EVAL_TAC +QED val _ = temp_overload_on("data_get_code_labels",``dataProps$get_code_labels``); val _ = temp_overload_on("data_good_code_labels",``dataProps$good_code_labels``); @@ -1239,22 +1277,25 @@ val word_good_handlers_remove_dead = Q.prove(` (* ssa *) -Theorem word_get_code_labels_fake_moves - `∀a b c d e f g h i. +Theorem word_get_code_labels_fake_moves: + ∀a b c d e f g h i. fake_moves a b c d = (e,f,g,h,i) ⇒ word_get_code_labels e = {} ∧ - word_get_code_labels f = {}` - (Induct \\ rw[fake_moves_def] \\ rw[] + word_get_code_labels f = {} +Proof + Induct \\ rw[fake_moves_def] \\ rw[] \\ pairarg_tac \\ fs[] \\ fs[CaseEq"option"] \\ rw[] \\ first_x_assum drule \\ rw[] - \\ rw[fake_move_def]); + \\ rw[fake_move_def] +QED -Theorem word_get_code_labels_ssa_cc_trans - `∀x y z a b c. +Theorem word_get_code_labels_ssa_cc_trans: + ∀x y z a b c. ssa_cc_trans x y z = (a,b,c) ⇒ - word_get_code_labels a = word_get_code_labels x` - (recInduct ssa_cc_trans_ind + word_get_code_labels a = word_get_code_labels x +Proof + recInduct ssa_cc_trans_ind \\ rw[ssa_cc_trans_def] \\ fs[] \\ rpt(pairarg_tac \\ fs[]) \\ rveq \\ fs[] >- ( @@ -1293,7 +1334,8 @@ Theorem word_get_code_labels_ssa_cc_trans \\ rpt(pairarg_tac \\ fs[]) \\ rveq \\ fs[] \\ imp_res_tac word_get_code_labels_fake_moves - \\ fs[])); + \\ fs[]) +QED val word_get_code_labels_full_ssa_cc_trans = Q.prove(` ∀m p. @@ -1309,22 +1351,25 @@ val word_get_code_labels_full_ssa_cc_trans = Q.prove(` \\ drule word_get_code_labels_ssa_cc_trans \\ rw[]); -Theorem word_good_handlers_fake_moves - `∀a b c d e f g h i. +Theorem word_good_handlers_fake_moves: + ∀a b c d e f g h i. fake_moves a b c d = (e,f,g,h,i) ⇒ word_good_handlers n e ∧ - word_good_handlers n f` - (Induct \\ rw[fake_moves_def] \\ rw[] + word_good_handlers n f +Proof + Induct \\ rw[fake_moves_def] \\ rw[] \\ pairarg_tac \\ fs[] \\ fs[CaseEq"option"] \\ rw[] \\ first_x_assum drule \\ rw[] - \\ rw[fake_move_def]); + \\ rw[fake_move_def] +QED -Theorem word_good_handlers_ssa_cc_trans - `∀x y z a b c. +Theorem word_good_handlers_ssa_cc_trans: + ∀x y z a b c. ssa_cc_trans x y z = (a,b,c) ⇒ - word_good_handlers n a = word_good_handlers n x` - (recInduct ssa_cc_trans_ind + word_good_handlers n a = word_good_handlers n x +Proof + recInduct ssa_cc_trans_ind \\ rw[ssa_cc_trans_def] \\ fs[] \\ rpt(pairarg_tac \\ fs[]) \\ rveq \\ fs[] >- ( @@ -1363,7 +1408,8 @@ Theorem word_good_handlers_ssa_cc_trans \\ rpt(pairarg_tac \\ fs[]) \\ rveq \\ fs[] \\ imp_res_tac word_good_handlers_fake_moves - \\ fs[])); + \\ fs[]) +QED val word_good_handlers_full_ssa_cc_trans = Q.prove(` ∀m p. @@ -1429,9 +1475,10 @@ val word_good_handlers_const_fp_loop = Q.prove(` \\ every_case_tac\\ fs[] \\ rpt (pairarg_tac \\ fs[])); -Theorem word_get_code_labels_apply_if_opt - `∀x y z. apply_if_opt x y = SOME z ⇒ word_get_code_labels z = word_get_code_labels x ∪ word_get_code_labels y` - (rw[apply_if_opt_def] +Theorem word_get_code_labels_apply_if_opt: + ∀x y z. apply_if_opt x y = SOME z ⇒ word_get_code_labels z = word_get_code_labels x ∪ word_get_code_labels y +Proof + rw[apply_if_opt_def] \\ fs[CaseEq"option",CaseEq"prod"] \\ pairarg_tac \\ fs[] \\ fs[CaseEq"option",CaseEq"prod"] @@ -1444,22 +1491,26 @@ Theorem word_get_code_labels_apply_if_opt \\ fs[dest_If_Eq_Imm_def,CaseEq"option",CaseEq"prod",CaseEq"cmp",CaseEq"reg_imm"] \\ Cases_on`y` \\ fs[dest_If_def] \\ rveq \\ Cases_on`x` \\ fs[dest_Seq_def] \\ rveq \\ fs[] - \\ rw[EXTENSION, EQ_IMP_THM] \\ rw[]); + \\ rw[EXTENSION, EQ_IMP_THM] \\ rw[] +QED -Theorem word_get_code_labels_simp_if[simp] - `∀p. word_get_code_labels (simp_if p) = word_get_code_labels p` - (recInduct simp_if_ind +Theorem word_get_code_labels_simp_if[simp]: + ∀p. word_get_code_labels (simp_if p) = word_get_code_labels p +Proof + recInduct simp_if_ind \\ rw[simp_if_def] \\ CASE_TAC \\ simp[] >- ( drule word_get_code_labels_apply_if_opt \\ rw[] ) - \\ every_case_tac \\ fs[]); + \\ every_case_tac \\ fs[] +QED -Theorem word_good_handlers_apply_if_opt - `∀x y z. apply_if_opt x y = SOME z ∧ +Theorem word_good_handlers_apply_if_opt: + ∀x y z. apply_if_opt x y = SOME z ∧ word_good_handlers n x ∧ word_good_handlers n y ⇒ - word_good_handlers n z ` - (rw[apply_if_opt_def] + word_good_handlers n z +Proof + rw[apply_if_opt_def] \\ fs[CaseEq"option",CaseEq"prod"] \\ pairarg_tac \\ fs[] \\ fs[CaseEq"option",CaseEq"prod"] @@ -1471,7 +1522,8 @@ Theorem word_good_handlers_apply_if_opt \\ rveq \\ fs[] \\ fs[dest_If_Eq_Imm_def,CaseEq"option",CaseEq"prod",CaseEq"cmp",CaseEq"reg_imm"] \\ Cases_on`y` \\ fs[dest_If_def] \\ rveq - \\ Cases_on`x` \\ fs[dest_Seq_def] \\ rveq \\ fs[]); + \\ Cases_on`x` \\ fs[dest_Seq_def] \\ rveq \\ fs[] +QED val word_good_handlers_simp_if = Q.prove(` ∀p. @@ -1657,11 +1709,12 @@ val stubs_labels = Q.prove(` IF_CASES_TAC>> simp[])); -Theorem data_to_word_good_code_labels ` - (data_to_word$compile data_conf word_conf asm_conf prog) = (xx,prog') ∧ +Theorem data_to_word_good_code_labels: + (data_to_word$compile data_conf word_conf asm_conf prog) = (xx,prog') ∧ data_good_code_labels prog ⇒ - word_good_code_labels prog'` - (fs[data_to_wordTheory.compile_def]>>rw[]>> + word_good_code_labels prog' +Proof + fs[data_to_wordTheory.compile_def]>>rw[]>> qmatch_asmsub_abbrev_tac`LHS = _`>> `prog' = SND LHS` by (unabbrev_all_tac>>fs[])>> pop_assum SUBST_ALL_TAC>> @@ -1686,7 +1739,8 @@ Theorem data_to_word_good_code_labels ` (first_x_assum drule>> disch_then drule>>fs[MEM_MAP,EXISTS_PROD]) >> - fs[MEM_MAP]>>metis_tac[]); + fs[MEM_MAP]>>metis_tac[] +QED end diff --git a/compiler/backend/proofs/data_to_word_assignProofScript.sml b/compiler/backend/proofs/data_to_word_assignProofScript.sml index d2d26f5c60..cbc4f44839 100644 --- a/compiler/backend/proofs/data_to_word_assignProofScript.sml +++ b/compiler/backend/proofs/data_to_word_assignProofScript.sml @@ -60,19 +60,23 @@ val assign_def_extras = save_thm("assign_def_extras",LIST_CONJ WriteWord32_on_32_def, AllocVar_def, SilentFFI_def, WordOp64_on_32_def, WordShift64_on_32_def, Make_ptr_bits_code_def]); -Theorem get_vars_SING - `dataSem$get_vars args s = SOME [w] ==> ?y. args = [y]` - (Cases_on `args` \\ fs [get_vars_def] +Theorem get_vars_SING: + dataSem$get_vars args s = SOME [w] ==> ?y. args = [y] +Proof + Cases_on `args` \\ fs [get_vars_def] \\ every_case_tac \\ fs [] \\ rw [] \\ fs [] \\ Cases_on `t` \\ fs [get_vars_def] - \\ every_case_tac \\ fs [] \\ rw [] \\ fs []); + \\ every_case_tac \\ fs [] \\ rw [] \\ fs [] +QED -Theorem INT_EQ_NUM_LEMMA - `0 <= (i:int) <=> ?index. i = & index` - (Cases_on `i` \\ fs []); +Theorem INT_EQ_NUM_LEMMA: + 0 <= (i:int) <=> ?index. i = & index +Proof + Cases_on `i` \\ fs [] +QED -Theorem memory_rel_lookup_var_IMP - `memory_rel c be refs sp st m dm +Theorem memory_rel_lookup_var_IMP: + memory_rel c be refs sp st m dm (join_env ll (toAList (inter t.locals (adjust_set ll))) ++ envs) ∧ get_vars n ll = SOME x ∧ @@ -80,37 +84,45 @@ Theorem memory_rel_lookup_var_IMP memory_rel c be refs sp st m dm (ZIP (x,w) ++ join_env ll - (toAList (inter t.locals (adjust_set ll))) ++ envs)` - (fs [memory_rel_def] \\ rw [] \\ asm_exists_tac \\ fs [] - \\ drule0 word_ml_inv_get_vars_IMP_lemma \\ fs []); - -Theorem get_real_offset_lemma - `get_var v t = SOME (Word i_w) /\ + (toAList (inter t.locals (adjust_set ll))) ++ envs) +Proof + fs [memory_rel_def] \\ rw [] \\ asm_exists_tac \\ fs [] + \\ drule0 word_ml_inv_get_vars_IMP_lemma \\ fs [] +QED + +Theorem get_real_offset_lemma: + get_var v t = SOME (Word i_w) /\ good_dimindex (:'a) /\ get_real_offset i_w = SOME y ==> - word_exp t (real_offset c v) = SOME (Word (y:'a word))` - (fs [get_real_offset_def] \\ every_case_tac \\ fs [] + word_exp t (real_offset c v) = SOME (Word (y:'a word)) +Proof + fs [get_real_offset_def] \\ every_case_tac \\ fs [] \\ fs [wordSemTheory.get_var_def,real_offset_def] \\ eval_tac \\ fs [] - \\ fs [labPropsTheory.good_dimindex_def,dimword_def] \\ rw []); - -Theorem get_real_byte_offset_lemma - `get_var v t = SOME (Word (w:α word)) ∧ good_dimindex (:α) ⇒ - word_exp t (real_byte_offset v) = SOME (Word (bytes_in_word + (w >>> 2)))` - (rw[real_byte_offset_def,wordSemTheory.get_var_def] - \\ eval_tac \\ fs[good_dimindex_def]); - -Theorem reorder_lemma - `memory_rel c be x.refs x.space t.store t.memory t.mdomain (x1::x2::x3::xs) ==> - memory_rel c be x.refs x.space t.store t.memory t.mdomain (x3::x1::x2::xs)` - (match_mp_tac memory_rel_rearrange \\ fs [] \\ rw [] \\ fs []); - -Theorem evaluate_StoreEach - `!xs ys t offset m1. + \\ fs [labPropsTheory.good_dimindex_def,dimword_def] \\ rw [] +QED + +Theorem get_real_byte_offset_lemma: + get_var v t = SOME (Word (w:α word)) ∧ good_dimindex (:α) ⇒ + word_exp t (real_byte_offset v) = SOME (Word (bytes_in_word + (w >>> 2))) +Proof + rw[real_byte_offset_def,wordSemTheory.get_var_def] + \\ eval_tac \\ fs[good_dimindex_def] +QED + +Theorem reorder_lemma: + memory_rel c be x.refs x.space t.store t.memory t.mdomain (x1::x2::x3::xs) ==> + memory_rel c be x.refs x.space t.store t.memory t.mdomain (x3::x1::x2::xs) +Proof + match_mp_tac memory_rel_rearrange \\ fs [] \\ rw [] \\ fs [] +QED + +Theorem evaluate_StoreEach = Q.prove(` + !xs ys t offset m1. store_list (a + offset) ys t.memory t.mdomain = SOME m1 /\ get_vars xs t = SOME ys /\ get_var i t = SOME (Word a) ==> - evaluate (StoreEach i xs offset, t) = (NONE,t with memory := m1)` - (Induct + evaluate (StoreEach i xs offset, t) = (NONE,t with memory := m1)`, + Induct \\ fs [store_list_def,StoreEach_def] \\ eval_tac \\ fs [wordSemTheory.state_component_equality, wordSemTheory.get_vars_def,store_list_def, @@ -132,74 +144,95 @@ Theorem evaluate_StoreEach \\ rw [] \\ every_case_tac \\ fs []) |> Q.SPECL [`xs`,`ys`,`t`,`0w`] |> SIMP_RULE (srw_ss()) [] |> GEN_ALL; -Theorem get_vars_adjust_var - `ODD k ==> +Theorem get_vars_adjust_var: + ODD k ==> get_vars (MAP adjust_var args) (t with locals := insert k w s) = - get_vars (MAP adjust_var args) (t with locals := s)` - (Induct_on `args` + get_vars (MAP adjust_var args) (t with locals := s) +Proof + Induct_on `args` \\ fs [wordSemTheory.get_vars_def,wordSemTheory.get_var_def,lookup_insert] - \\ rw [] \\ fs [ODD_EVEN,EVEN_adjust_var]); - -Theorem get_vars_with_store - `!args. get_vars args (t with <| locals := t.locals ; store := s |>) = - get_vars args t` - (Induct \\ fs [wordSemTheory.get_vars_def,wordSemTheory.get_var_def]); - -Theorem word_less_lemma1 - `v2 < (v1:'a word) <=> ~(v1 <= v2)` - (metis_tac [WORD_NOT_LESS]); - -Theorem heap_in_memory_store_IMP_UPDATE - `heap_in_memory_store heap a sp sp1 gens c st m dm l ==> - heap_in_memory_store heap a sp sp1 gens c (st |+ (Globals,h)) m dm l` - (fs [heap_in_memory_store_def,FLOOKUP_UPDATE]); - -Theorem get_vars_2_imp - `wordSem$get_vars [x1;x2] s = SOME [y1;y2] ==> + \\ rw [] \\ fs [ODD_EVEN,EVEN_adjust_var] +QED + +Theorem get_vars_with_store: + !args. get_vars args (t with <| locals := t.locals ; store := s |>) = + get_vars args t +Proof + Induct \\ fs [wordSemTheory.get_vars_def,wordSemTheory.get_var_def] +QED + +Theorem word_less_lemma1: + v2 < (v1:'a word) <=> ~(v1 <= v2) +Proof + metis_tac [WORD_NOT_LESS] +QED + +Theorem heap_in_memory_store_IMP_UPDATE: + heap_in_memory_store heap a sp sp1 gens c st m dm l ==> + heap_in_memory_store heap a sp sp1 gens c (st |+ (Globals,h)) m dm l +Proof + fs [heap_in_memory_store_def,FLOOKUP_UPDATE] +QED + +Theorem get_vars_2_imp: + wordSem$get_vars [x1;x2] s = SOME [y1;y2] ==> wordSem$get_var x1 s = SOME y1 /\ - wordSem$get_var x2 s = SOME y2` - (fs [wordSemTheory.get_vars_def] \\ every_case_tac \\ fs []); - -Theorem get_vars_1_imp - `wordSem$get_vars [x1] s = SOME [y1] ==> - wordSem$get_var x1 s = SOME y1` - (fs [wordSemTheory.get_vars_def] \\ every_case_tac \\ fs []); - -Theorem LESS_DIV_16_IMP - `n < k DIV 16 ==> 16 * n + 2 < k:num` - (fs [X_LT_DIV]); - -Theorem word_exp_real_addr - `get_real_addr c t.store ptr_w = SOME a /\ + wordSem$get_var x2 s = SOME y2 +Proof + fs [wordSemTheory.get_vars_def] \\ every_case_tac \\ fs [] +QED + +Theorem get_vars_1_imp: + wordSem$get_vars [x1] s = SOME [y1] ==> + wordSem$get_var x1 s = SOME y1 +Proof + fs [wordSemTheory.get_vars_def] \\ every_case_tac \\ fs [] +QED + +Theorem LESS_DIV_16_IMP: + n < k DIV 16 ==> 16 * n + 2 < k:num +Proof + fs [X_LT_DIV] +QED + +Theorem word_exp_real_addr: + get_real_addr c t.store ptr_w = SOME a /\ shift_length c < dimindex (:α) ∧ good_dimindex (:α) /\ lookup (adjust_var a1) (t:('a,'c,'ffi) wordSem$state).locals = SOME (Word ptr_w) ==> !w. word_exp (t with locals := insert 1 (Word (w:'a word)) t.locals) - (real_addr c (adjust_var a1)) = SOME (Word a)` - (rpt strip_tac \\ match_mp_tac (GEN_ALL get_real_addr_lemma) - \\ fs [wordSemTheory.get_var_def,lookup_insert]) + (real_addr c (adjust_var a1)) = SOME (Word a) +Proof + rpt strip_tac \\ match_mp_tac (GEN_ALL get_real_addr_lemma) + \\ fs [wordSemTheory.get_var_def,lookup_insert] +QED -Theorem word_exp_real_addr_2 - `get_real_addr c (t:('a,'c,'ffi) wordSem$state).store ptr_w = SOME a /\ +Theorem word_exp_real_addr_2: + get_real_addr c (t:('a,'c,'ffi) wordSem$state).store ptr_w = SOME a /\ shift_length c < dimindex (:α) ∧ good_dimindex (:α) /\ lookup (adjust_var a1) t.locals = SOME (Word ptr_w) ==> !w1 w2. word_exp (t with locals := insert 3 (Word (w1:'a word)) (insert 1 (Word w2) t.locals)) - (real_addr c (adjust_var a1)) = SOME (Word a)` - (rpt strip_tac \\ match_mp_tac (GEN_ALL get_real_addr_lemma) - \\ fs [wordSemTheory.get_var_def,lookup_insert]) + (real_addr c (adjust_var a1)) = SOME (Word a) +Proof + rpt strip_tac \\ match_mp_tac (GEN_ALL get_real_addr_lemma) + \\ fs [wordSemTheory.get_var_def,lookup_insert] +QED -Theorem encode_header_IMP_BIT0 - `encode_header c tag l = SOME w ==> w ' 0` - (fs [encode_header_def,make_header_def] \\ rw [] - \\ fs [word_or_def,fcpTheory.FCP_BETA,word_index]); +Theorem encode_header_IMP_BIT0: + encode_header c tag l = SOME w ==> w ' 0 +Proof + fs [encode_header_def,make_header_def] \\ rw [] + \\ fs [word_or_def,fcpTheory.FCP_BETA,word_index] +QED -Theorem get_addr_inj - `p1 * 2 ** shift_length c < dimword (:'a) ∧ +Theorem get_addr_inj: + p1 * 2 ** shift_length c < dimword (:'a) ∧ p2 * 2 ** shift_length c < dimword (:'a) ∧ get_addr c p1 (Word (0w:'a word)) = get_addr c p2 (Word 0w) - ⇒ p1 = p2` - (rw[get_addr_def,get_lowerbits_def] + ⇒ p1 = p2 +Proof + rw[get_addr_def,get_lowerbits_def] \\ `1 < 2 ** shift_length c` by ( fs[ONE_LT_EXP,shift_length_NOT_ZERO,GSYM NOT_ZERO_LT_ZERO] ) \\ `dimword (:'a) < dimword(:'a) * 2 ** shift_length c` by fs[] @@ -223,19 +256,23 @@ Theorem get_addr_inj \\ simp[] ) \\ `n2w p1 = n2w p2` by metis_tac[] \\ imp_res_tac n2w_11 - \\ rfs[]); - -Theorem Word64Rep_inj - `good_dimindex(:'a) ⇒ - (Word64Rep (:'a) w1 = Word64Rep (:'a) w2 ⇔ w1 = w2)` - (rw[good_dimindex_def,Word64Rep_def] - \\ srw_tac[wordsLib.WORD_BIT_EQ_ss][Word64Rep_def,EQ_IMP_THM]); - -Theorem IMP_read_bytearray_GENLIST - `∀ls len a. len = LENGTH ls ∧ + \\ rfs[] +QED + +Theorem Word64Rep_inj: + good_dimindex(:'a) ⇒ + (Word64Rep (:'a) w1 = Word64Rep (:'a) w2 ⇔ w1 = w2) +Proof + rw[good_dimindex_def,Word64Rep_def] + \\ srw_tac[wordsLib.WORD_BIT_EQ_ss][Word64Rep_def,EQ_IMP_THM] +QED + +Theorem IMP_read_bytearray_GENLIST: + ∀ls len a. len = LENGTH ls ∧ (∀i. i < len ⇒ g (a + n2w i) = SOME (EL i ls)) - ⇒ read_bytearray a len g = SOME ls` - (Induct \\ rw[read_bytearray_def] \\ fs[] + ⇒ read_bytearray a len g = SOME ls +Proof + Induct \\ rw[read_bytearray_def] \\ fs[] \\ last_x_assum(qspec_then`a + 1w`mp_tac) \\ impl_tac >- ( @@ -245,61 +282,78 @@ Theorem IMP_read_bytearray_GENLIST \\ simp[ADD1,GSYM word_add_n2w] ) \\ rw[] \\ first_x_assum(qspec_then`0`mp_tac) - \\ simp[]); - -Theorem lookup_IMP_insert_EQ - `!t x y. lookup x t = SOME y ==> insert x y t = t` - (Induct \\ fs [lookup_def,Once insert_def] \\ rw []); - -Theorem set_vars_sing - `set_vars [n] [w] t = set_var n w t` - (EVAL_TAC); - -Theorem NONNEG_INT - `0 <= (i:int) ==> ?j. i = & j` - (Cases_on `i` \\ fs []); - -Theorem BIT_X_1 - `BIT i 1 = (i = 0)` - (EQ_TAC \\ rw []); - -Theorem minus_2_word_and_id - `~(w ' 0) ==> (-2w && w) = w` - (fs [fcpTheory.CART_EQ,word_and_def,fcpTheory.FCP_BETA] + \\ simp[] +QED + +Theorem lookup_IMP_insert_EQ: + !t x y. lookup x t = SOME y ==> insert x y t = t +Proof + Induct \\ fs [lookup_def,Once insert_def] \\ rw [] +QED + +Theorem set_vars_sing: + set_vars [n] [w] t = set_var n w t +Proof + EVAL_TAC +QED + +Theorem NONNEG_INT: + 0 <= (i:int) ==> ?j. i = & j +Proof + Cases_on `i` \\ fs [] +QED + +Theorem BIT_X_1: + BIT i 1 = (i = 0) +Proof + EQ_TAC \\ rw [] +QED + +Theorem minus_2_word_and_id: + ~(w ' 0) ==> (-2w && w) = w +Proof + fs [fcpTheory.CART_EQ,word_and_def,fcpTheory.FCP_BETA] \\ rewrite_tac [GSYM (SIMP_CONV (srw_ss()) [] ``~1w``)] \\ Cases_on `w` \\ simp_tac std_ss [word_1comp_def,fcpTheory.FCP_BETA,word_index, - DIMINDEX_GT_0,BIT_X_1] \\ metis_tac []); + DIMINDEX_GT_0,BIT_X_1] \\ metis_tac [] +QED -Theorem FOUR_MUL_LSL - `n2w (4 * i) << k = n2w i << (k + 2)` - (fs [WORD_MUL_LSL,EXP_ADD,word_mul_n2w]); +Theorem FOUR_MUL_LSL: + n2w (4 * i) << k = n2w i << (k + 2) +Proof + fs [WORD_MUL_LSL,EXP_ADD,word_mul_n2w] +QED -Theorem evaluate_BignumHalt - `state_rel c l1 l2 s t [] locs /\ +Theorem evaluate_BignumHalt: + state_rel c l1 l2 s t [] locs /\ get_var reg t = SOME (Word w) ==> ∃r. (evaluate (BignumHalt reg,t) = if w ' 0 then (SOME NotEnoughSpace,r) - else (NONE,t)) ∧ r.ffi = s.ffi ∧ t.ffi = s.ffi` - (fs [BignumHalt_def,wordSemTheory.evaluate_def,word_exp_rw, + else (NONE,t)) ∧ r.ffi = s.ffi ∧ t.ffi = s.ffi +Proof + fs [BignumHalt_def,wordSemTheory.evaluate_def,word_exp_rw, asmTheory.word_cmp_def,word_and_one_eq_0_iff |> SIMP_RULE (srw_ss()) []] \\ IF_CASES_TAC \\ fs [] THEN1 (rw [] \\ qexists_tac `t` \\ fs [state_rel_def]) - \\ rw [] \\ match_mp_tac evaluate_GiveUp \\ fs []); + \\ rw [] \\ match_mp_tac evaluate_GiveUp \\ fs [] +QED -Theorem state_rel_get_var_Number_IMP_alt - `!k i. state_rel c l1 l2 s t [] locs /\ +Theorem state_rel_get_var_Number_IMP_alt: + !k i. state_rel c l1 l2 s t [] locs /\ get_var k s.locals = SOME (Number i) /\ get_var (2 * k + 2) t = SOME a1 ==> - ?w:'a word. a1 = Word w /\ w ' 0 = ~small_int (:'a) i` - (fs [state_rel_thm] \\ rw [] + ?w:'a word. a1 = Word w /\ w ' 0 = ~small_int (:'a) i +Proof + fs [state_rel_thm] \\ rw [] \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ rpt_drule0 memory_rel_get_var_IMP \\ fs [adjust_var_def] \\ rw [] - \\ imp_res_tac memory_rel_any_Number_IMP \\ fs []); + \\ imp_res_tac memory_rel_any_Number_IMP \\ fs [] +QED -Theorem RefArray_thm - `state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs /\ +Theorem RefArray_thm: + state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs /\ get_vars [0;1] s.locals = SOME vals /\ t.clock = MustTerminate_limit (:'a) - 1 /\ do_app RefArray vals s = Rval (v,s2) ==> @@ -310,8 +364,9 @@ Theorem RefArray_thm else ?rv. q = SOME (Result (Loc l1 l2) rv) /\ state_rel c r1 r2 (s2 with <| locals := LN; clock := new_c |>) - r [(v,rv)] locs` - (fs [RefArray_code_def] + r [(v,rv)] locs +Proof + fs [RefArray_code_def] \\ fs [do_app_def,do_space_def,EVAL ``op_space_reset RefArray``,do_app_aux_def] \\ Cases_on `vals` \\ fs [] \\ Cases_on `t'` \\ fs [] @@ -504,54 +559,62 @@ Theorem RefArray_thm \\ disj1_tac \\ fs [make_ptr_def] \\ qunabbrev_tac `ww` - \\ AP_THM_TAC \\ AP_TERM_TAC \\ fs []); + \\ AP_THM_TAC \\ AP_TERM_TAC \\ fs [] +QED -Theorem word_exp_SmallLsr - `word_exp s (SmallLsr e n) = +Theorem word_exp_SmallLsr: + word_exp s (SmallLsr e n) = if dimindex (:'a) <= n then NONE else case word_exp s e of | SOME (Word w) => SOME (Word ((w:'a word) >>> n)) - | res => (if n = 0 then res else NONE)` - (rw [SmallLsr_def] \\ assume_tac DIMINDEX_GT_0 + | res => (if n = 0 then res else NONE) +Proof + rw [SmallLsr_def] \\ assume_tac DIMINDEX_GT_0 \\ TRY (`F` by decide_tac \\ NO_TAC) THEN1 (full_simp_tac std_ss [GSYM NOT_LESS] \\ Cases_on `word_exp s e` \\ fs [] \\ Cases_on `x` \\ fs []) - \\ fs [word_exp_rw] \\ every_case_tac \\ fs [] ); + \\ fs [word_exp_rw] \\ every_case_tac \\ fs [] +QED -Theorem evaluate_MakeBytes - `good_dimindex (:'a) ==> +Theorem evaluate_MakeBytes: + good_dimindex (:'a) ==> evaluate (MakeBytes n,s) = case get_var n s of | SOME (Word w) => (NONE,set_var n (Word (word_of_byte ((w:'a word) >>> 2))) s) - | _ => (SOME Error,s)` - (fs [MakeBytes_def,list_Seq_def,wordSemTheory.evaluate_def,word_exp_rw, + | _ => (SOME Error,s) +Proof + fs [MakeBytes_def,list_Seq_def,wordSemTheory.evaluate_def,word_exp_rw, wordSemTheory.get_var_def] \\ strip_tac \\ Cases_on `lookup n s.locals` \\ fs [] \\ Cases_on `x` \\ fs [] \\ IF_CASES_TAC \\ fs [EVAL ``good_dimindex (:'a)``] \\ fs [wordSemTheory.set_var_def,lookup_insert,word_of_byte_def, - insert_shadow,wordSemTheory.evaluate_def,word_exp_rw]); + insert_shadow,wordSemTheory.evaluate_def,word_exp_rw] +QED -Theorem w2w_shift_shift - `good_dimindex (:'a) ==> ((w2w (w:word8) ≪ 2 ⋙ 2) : 'a word) = w2w w` - (fs [labPropsTheory.good_dimindex_def,fcpTheory.CART_EQ, +Theorem w2w_shift_shift: + good_dimindex (:'a) ==> ((w2w (w:word8) ≪ 2 ⋙ 2) : 'a word) = w2w w +Proof + fs [labPropsTheory.good_dimindex_def,fcpTheory.CART_EQ, word_lsl_def,word_lsr_def,fcpTheory.FCP_BETA,w2w] - \\ rw [] \\ fs [] \\ EQ_TAC \\ rw [] \\ rfs [fcpTheory.FCP_BETA,w2w]); + \\ rw [] \\ fs [] \\ EQ_TAC \\ rw [] \\ rfs [fcpTheory.FCP_BETA,w2w] +QED fun sort_tac n = CONV_TAC(PATH_CONV(String.concat(List.tabulate(n,(K "lr"))))(REWR_CONV set_byte_sort)) \\ simp[labPropsTheory.good_dimindex_def] -Theorem evaluate_WriteLastBytes - `good_dimindex(:'a) ∧ w2n n < dimindex(:'a) DIV 8 ∧ +Theorem evaluate_WriteLastBytes: + good_dimindex(:'a) ∧ w2n n < dimindex(:'a) DIV 8 ∧ get_vars [av;bv;nv] (s:('a,'c,'ffi)wordSem$state) = SOME [Word (a:'a word); Word b; Word n] ∧ byte_aligned a ∧ a ∈ s.mdomain ∧ s.memory a = Word w ⇒ evaluate (WriteLastBytes av bv nv,s) = - (NONE, s with memory := (a =+ Word (last_bytes (w2n n) (w2w b) 0w w s.be)) s.memory)` - (rw[labPropsTheory.good_dimindex_def] + (NONE, s with memory := (a =+ Word (last_bytes (w2n n) (w2w b) 0w w s.be)) s.memory) +Proof + rw[labPropsTheory.good_dimindex_def] \\ fs[get_vars_SOME_IFF] \\ simp[WriteLastBytes_def] \\ simp[WriteLastByte_aux_def] @@ -588,21 +651,24 @@ Theorem evaluate_WriteLastBytes >- ( map_every sort_tac [1,2,3,4,3,2,1,2,3,2] ) >- ( map_every sort_tac [1,2,3,4,5,4,3,2,1,2,3,4,3,2,3] ) >- ( map_every sort_tac [1,2,3,4,5,6,5,4,3,2,1,2,3,4,5,4,3,2,3,4,5,4,3,4,3,4,5] ) - >- ( Cases_on`n` \\ fs[dimword_def] \\ rfs[] )); + >- ( Cases_on`n` \\ fs[dimword_def] \\ rfs[] ) +QED -Theorem byte_aligned_bytes_in_word - `good_dimindex (:'a) ==> +Theorem byte_aligned_bytes_in_word: + good_dimindex (:'a) ==> byte_aligned (w * bytes_in_word) /\ - byte_aligned (bytes_in_word * w:'a word)` - (fs [byte_aligned_def,good_dimindex_def] \\ rw [] + byte_aligned (bytes_in_word * w:'a word) +Proof + fs [byte_aligned_def,good_dimindex_def] \\ rw [] \\ fs [bytes_in_word_def] \\ `aligned 2 (0w + w * n2w (2 ** 2)) /\ aligned 3 (0w + w * n2w (2 ** 3))` by (Cases_on `w` \\ rewrite_tac [word_mul_n2w,aligned_add_pow,aligned_0]) - \\ fs []); + \\ fs [] +QED -Theorem RefByte_thm - `state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs /\ +Theorem RefByte_thm: + state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs /\ get_vars [0;1;2] s.locals = SOME (vals ++ [Number &(if fl then 0 else 4)]) /\ t.clock = MustTerminate_limit (:'a) - 1 /\ do_app (RefByte fl) vals s = Rval (v,s2) ==> @@ -613,8 +679,9 @@ Theorem RefByte_thm else ?rv. q = SOME (Result (Loc l1 l2) rv) /\ state_rel c r1 r2 (s2 with <| locals := LN; clock := new_c |>) - r [(v,rv)] locs` - (qpat_abbrev_tac`tag = if fl then _ else _` + r [(v,rv)] locs +Proof + qpat_abbrev_tac`tag = if fl then _ else _` \\ fs [RefByte_code_def] \\ fs [do_app_def,do_space_def,EVAL ``op_space_reset (RefByte fl)``,do_app_aux_def] \\ Cases_on `vals` \\ fs [] @@ -1021,10 +1088,11 @@ Theorem RefByte_thm \\ match_mp_tac memory_rel_rearrange \\ unabbrev_all_tac \\ rpt (pop_assum kall_tac) \\ fs[FAPPLY_FUPDATE_THM] - \\ rw [] \\ fs []); + \\ rw [] \\ fs [] +QED -Theorem FromList1_code_thm - `!k a b r x m1 a1 a2 a3 a4 a5 a6. +Theorem FromList1_code_thm: + !k a b r x m1 a1 a2 a3 a4 a5 a6. lookup FromList1_location r.code = SOME (6,FromList1_code c) /\ copy_list c r.store k (a,x,b,(r:('a,'c,'ffi) wordSem$state).memory, r.mdomain) = SOME (b1,m1) /\ @@ -1040,8 +1108,9 @@ Theorem FromList1_code_thm evaluate (Call NONE (SOME FromList1_location) [a1;a2;a3;a4;a5;a6] NONE,r) = (SOME (Result (Loc l1 l2) ret_val), r with <| memory := m1 ; clock := r.clock - k - 1; locals := LN ; - store := r.store |+ (NextFree, Word b1) |>)` - (Induct \\ rw [] \\ simp [wordSemTheory.evaluate_def] + store := r.store |+ (NextFree, Word b1) |>) +Proof + Induct \\ rw [] \\ simp [wordSemTheory.evaluate_def] \\ simp [wordSemTheory.get_vars_def,wordSemTheory.bad_dest_args_def, wordSemTheory.find_code_def,wordSemTheory.add_ret_loc_def] \\ rw [] \\ simp [FromList1_code_def] @@ -1092,13 +1161,15 @@ Theorem FromList1_code_thm (strip_tac \\ fs [] \\ rw [wordSemTheory.state_component_equality,Abbr `r7`]) \\ unabbrev_all_tac \\ fs [] \\ fs [wordSemTheory.get_var_def,lookup_insert] - \\ fs [MULT_CLAUSES,GSYM word_add_n2w]); + \\ fs [MULT_CLAUSES,GSYM word_add_n2w] +QED -Theorem state_rel_IMP_test_zero - `state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) vs locs /\ +Theorem state_rel_IMP_test_zero: + state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) vs locs /\ get_var i s.locals = SOME (Number n) ==> - ?w. get_var (adjust_var i) t = SOME (Word w) /\ (w = 0w <=> (n = 0))` - (strip_tac + ?w. get_var (adjust_var i) t = SOME (Word w) /\ (w = 0w <=> (n = 0)) +Proof + strip_tac \\ rpt_drule0 state_rel_get_var_IMP \\ strip_tac \\ fs [] \\ fs [state_rel_thm,get_vars_SOME_IFF_data] \\ rw [] @@ -1115,13 +1186,15 @@ Theorem state_rel_IMP_test_zero \\ fs [] \\ strip_tac \\ drule0 memory_rel_Number_EQ \\ fs [] \\ strip_tac \\ fs [Smallnum_def] - \\ eq_tac \\ rw [] \\ fs []); + \\ eq_tac \\ rw [] \\ fs [] +QED -Theorem state_rel_get_var_Number_IMP - `state_rel c l1 l2 s t vs locs /\ +Theorem state_rel_get_var_Number_IMP: + state_rel c l1 l2 s t vs locs /\ get_var i s.locals = SOME (Number (&n)) /\ small_int (:'a) (&n) ==> - ?w. get_var (adjust_var i) t = SOME (Word (Smallnum (&n):'a word))` - (strip_tac + ?w. get_var (adjust_var i) t = SOME (Word (Smallnum (&n):'a word)) +Proof + strip_tac \\ rpt_drule0 state_rel_get_var_IMP \\ strip_tac \\ fs [] \\ fs [state_rel_thm,get_vars_SOME_IFF_data] \\ rw [] @@ -1137,26 +1210,31 @@ Theorem state_rel_get_var_Number_IMP \\ fs [abs_ml_inv_def,bc_stack_ref_inv_def,v_inv_def] \\ rfs [] \\ rw [] \\ fs [word_addr_def,Smallnum_def] \\ match_mp_tac minus_2_word_and_id - \\ fs [word_index,word_mul_n2w,bitTheory.BIT0_ODD,ODD_MULT]); + \\ fs [word_index,word_mul_n2w,bitTheory.BIT0_ODD,ODD_MULT] +QED -Theorem EXP_LEMMA1 - `4n * n * (2 ** k) = n * 2 ** (k + 2)` - (fs [EXP_ADD]); +Theorem EXP_LEMMA1: + 4n * n * (2 ** k) = n * 2 ** (k + 2) +Proof + fs [EXP_ADD] +QED -Theorem evaluate_Maxout_bits_code - `n_reg <> dest /\ n < dimword (:'a) /\ rep_len < dimindex (:α) /\ +Theorem evaluate_Maxout_bits_code: + n_reg <> dest /\ n < dimword (:'a) /\ rep_len < dimindex (:α) /\ k < dimindex (:'a) /\ lookup n_reg (t:('a,'c,'ffi) wordSem$state).locals = SOME (Word (n2w n:'a word)) ==> evaluate (Maxout_bits_code rep_len k dest n_reg,set_var dest (Word w) t) = - (NONE,set_var dest (Word (w || maxout_bits n rep_len k)) t)` - (fs [Maxout_bits_code_def,wordSemTheory.evaluate_def,wordSemTheory.get_var_def, + (NONE,set_var dest (Word (w || maxout_bits n rep_len k)) t) +Proof + fs [Maxout_bits_code_def,wordSemTheory.evaluate_def,wordSemTheory.get_var_def, wordSemTheory.set_var_def,wordSemTheory.get_var_imm_def, asmTheory.word_cmp_def,lookup_insert,WORD_LO,word_exp_rw, maxout_bits_def] \\ rw [] \\ fs [insert_shadow] - \\ sg `2 ** rep_len < dimword (:α)` \\ fs [] \\ fs [dimword_def]); + \\ sg `2 ** rep_len < dimword (:α)` \\ fs [] \\ fs [dimword_def] +QED -Theorem Make_ptr_bits_thm - `tag_reg ≠ dest ∧ tag1 < dimword (:α) ∧ c.tag_bits < dimindex (:α) ∧ +Theorem Make_ptr_bits_thm: + tag_reg ≠ dest ∧ tag1 < dimword (:α) ∧ c.tag_bits < dimindex (:α) ∧ len_reg ≠ dest ∧ len1 < dimword (:α) ∧ c.len_bits < dimindex (:α) ∧ c.len_bits + 1 < dimindex (:α) /\ FLOOKUP (t:('a,'c,'ffi) wordSem$state).store NextFree = SOME (Word f) /\ @@ -1166,8 +1244,9 @@ Theorem Make_ptr_bits_thm shift_length c < dimindex (:α) + shift (:α) ==> ?t1. evaluate (Make_ptr_bits_code c tag_reg len_reg dest,t) = - (NONE,set_var dest (make_cons_ptr c (f-d) tag1 len1:'a word_loc) t)` - (fs [Make_ptr_bits_code_def,list_Seq_def,wordSemTheory.evaluate_def,word_exp_rw] + (NONE,set_var dest (make_cons_ptr c (f-d) tag1 len1:'a word_loc) t) +Proof + fs [Make_ptr_bits_code_def,list_Seq_def,wordSemTheory.evaluate_def,word_exp_rw] \\ fs [make_cons_ptr_thm] \\ strip_tac \\ pairarg_tac \\ fs [] \\ pop_assum mp_tac @@ -1177,10 +1256,11 @@ Theorem Make_ptr_bits_thm \\ assume_tac (GEN_ALL evaluate_Maxout_bits_code) \\ SEP_I_TAC "evaluate" \\ pop_assum (qspec_then `len1` mp_tac) \\ fs [] \\ rw [] - \\ fs [ptr_bits_def]); + \\ fs [ptr_bits_def] +QED -Theorem FromList_thm - `state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs /\ +Theorem FromList_thm: + state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs /\ encode_header c (4 * tag) 0 <> (NONE:'a word option) /\ get_vars [0; 1; 2] s.locals = SOME [v1; v2; Number (&(4 * tag))] /\ t.clock = MustTerminate_limit (:'a) - 1 /\ @@ -1192,8 +1272,9 @@ Theorem FromList_thm else ?rv. q = SOME (Result (Loc l1 l2) rv) /\ state_rel c r1 r2 (s2 with <| locals := LN; clock := new_c |>) - r [(v,rv)] locs` - (fs [do_app_def,do_app_aux_def,do_space_def, + r [(v,rv)] locs +Proof + fs [do_app_def,do_app_aux_def,do_space_def, dataLangTheory.op_space_reset_def] \\ Cases_on `v_to_list v2` \\ fs [with_fresh_ts_def] \\ reverse (Cases_on `v1 = Number (&LENGTH x)`) @@ -1347,7 +1428,8 @@ Theorem FromList_thm \\ fs [FAPPLY_FUPDATE_THM,FLOOKUP_UPDATE] \\ drule0 memory_rel_zero_space \\ match_mp_tac memory_rel_rearrange - \\ fs [] \\ rw [] \\ fs [])); + \\ fs [] \\ rw [] \\ fs []) +QED val get_var_get_real_addr_lemma = GEN_ALL(CONV_RULE(LAND_CONV(move_conj_left( @@ -1355,13 +1437,14 @@ val get_var_get_real_addr_lemma = strip_comb o lhs))) get_real_addr_lemma) -Theorem evaluate_LoadWord64 - `memory_rel c be refs sp t.store t.memory t.mdomain ((Word64 w,v)::vars) ∧ +Theorem evaluate_LoadWord64: + memory_rel c be refs sp t.store t.memory t.mdomain ((Word64 w,v)::vars) ∧ shift_length c < dimindex(:α) ∧ dimindex(:α) = 64 ∧ get_var src (t:('a,'c,'ffi) state) = SOME v ==> - evaluate (LoadWord64 c dest src,t) = (NONE, set_var dest (Word (w2w w)) t)` - (rw[LoadWord64_def] \\ eval_tac + evaluate (LoadWord64 c dest src,t) = (NONE, set_var dest (Word (w2w w)) t) +Proof + rw[LoadWord64_def] \\ eval_tac \\ rpt_drule0 memory_rel_Word64_IMP \\ impl_keep_tac >- fs[good_dimindex_def] \\ strip_tac \\ rfs[] \\ clean_tac @@ -1370,10 +1453,11 @@ Theorem evaluate_LoadWord64 \\ simp[] \\ rw[] \\ rpt(AP_TERM_TAC ORELSE AP_THM_TAC) \\ simp[FUN_EQ_THM] - \\ rw[WORD_w2w_EXTRACT]); + \\ rw[WORD_w2w_EXTRACT] +QED -Theorem evaluate_WriteWord64 - `memory_rel c be refs sp t.store t.memory t.mdomain +Theorem evaluate_WriteWord64: + memory_rel c be refs sp t.store t.memory t.mdomain (join_env_locals sl t.locals ++ vars) ∧ get_var src (t:('a,'c,'ffi) state) = SOME (Word w) ∧ shift_length c < dimindex(:α) ∧ @@ -1390,8 +1474,9 @@ Theorem evaluate_WriteWord64 (join_env_locals (insert dest (Word64 (w2w w)) sl) locals' ++ vars) ∧ (∀n. IS_SOME (lookup n sl) ⇒ IS_SOME (lookup (adjust_var n) locals')) ∧ IS_SOME (lookup (adjust_var dest) locals') ∧ - lookup 0 locals' = lookup 0 t.locals` - (rw[WriteWord64_def,list_Seq_def,join_env_locals_def] + lookup 0 locals' = lookup 0 t.locals +Proof + rw[WriteWord64_def,list_Seq_def,join_env_locals_def] \\ drule0(GEN_ALL(memory_rel_Word64_alt |> Q.GEN`vs` |> Q.SPEC`[]` |> SIMP_RULE (srw_ss())[])) \\ disch_then(qspecl_then[`[Word w]`,`w2w w`]mp_tac) \\ simp[] @@ -1422,10 +1507,11 @@ Theorem evaluate_WriteWord64 \\ rw[] \\ fs[] \\ fs [addressTheory.WORD_EQ_ADD_CANCEL] \\ pop_assum mp_tac \\ EVAL_TAC - \\ fs [dimword_def]); + \\ fs [dimword_def] +QED -Theorem evaluate_WriteWord64_on_32 - `memory_rel c be refs sp t.store t.memory t.mdomain +Theorem evaluate_WriteWord64_on_32: + memory_rel c be refs sp t.store t.memory t.mdomain (join_env_locals sl t.locals ++ vars) ∧ get_var src1 (t:('a,'c,'ffi) state) = SOME (Word ((31 >< 0) w)) ∧ get_var src2 (t:('a,'c,'ffi) state) = SOME (Word ((63 >< 32) w)) ∧ @@ -1443,8 +1529,9 @@ Theorem evaluate_WriteWord64_on_32 (join_env_locals (insert dest (Word64 w) sl) locals' ++ vars) ∧ (∀n. IS_SOME (lookup n sl) ⇒ IS_SOME (lookup (adjust_var n) locals')) ∧ IS_SOME (lookup (adjust_var dest) locals') ∧ - lookup 0 locals' = lookup 0 t.locals` - (qpat_abbrev_tac `w1 = ((31 >< 0) w):'a word` + lookup 0 locals' = lookup 0 t.locals +Proof + qpat_abbrev_tac `w1 = ((31 >< 0) w):'a word` \\ qpat_abbrev_tac `w2 = ((63 >< 32) w):'a word` \\ rw[WriteWord64_on_32_def,list_Seq_def,join_env_locals_def] \\ drule0(GEN_ALL(memory_rel_Word64_alt |> Q.GEN`vs` |> Q.SPEC`[]` |> SIMP_RULE (srw_ss())[])) @@ -1481,14 +1568,15 @@ Theorem evaluate_WriteWord64_on_32 \\ rw[] \\ fs[] \\ fs [addressTheory.WORD_EQ_ADD_CANCEL] \\ pop_assum mp_tac \\ EVAL_TAC \\ fs [dimword_def] - \\ pop_assum mp_tac \\ EVAL_TAC \\ fs [dimword_def]); + \\ pop_assum mp_tac \\ EVAL_TAC \\ fs [dimword_def] +QED val Num_ABS_AND = prove( ``Num (ABS (& n)) = n /\ Num (ABS (- & n)) = n``, intLib.COOPER_TAC); -Theorem evaluate_WriteWord64_on_32_num - `memory_rel c be refs sp t.store t.memory t.mdomain +Theorem evaluate_WriteWord64_on_32_num: + memory_rel c be refs sp t.store t.memory t.mdomain (join_env_locals sl t.locals ++ vars) ∧ get_var src1 (t:('a,'c,'ffi) state) = SOME (Word w1) ∧ get_var src2 (t:('a,'c,'ffi) state) = SOME (Word w2) ∧ @@ -1506,8 +1594,9 @@ Theorem evaluate_WriteWord64_on_32_num (join_env_locals (insert dest (Number (&(w2n w2 * dimword (:'a) + w2n w1))) sl) locals' ++ vars) ∧ (∀n. IS_SOME (lookup n sl) ⇒ IS_SOME (lookup (adjust_var n) locals')) ∧ IS_SOME (lookup (adjust_var dest) locals') ∧ - lookup 0 locals' = lookup 0 t.locals` - (rw[WriteWord64_on_32_def,list_Seq_def,join_env_locals_def] + lookup 0 locals' = lookup 0 t.locals +Proof + rw[WriteWord64_on_32_def,list_Seq_def,join_env_locals_def] \\ drule0(GEN_ALL(IMP_memory_rel_bignum_alt)) \\ disch_then(qspecl_then[`[w1;w2]`,`F`, `&(w2n w2 * dimword (:'a) + w2n w1)`,`header`]mp_tac) @@ -1557,10 +1646,11 @@ Theorem evaluate_WriteWord64_on_32_num \\ fs [addressTheory.WORD_EQ_ADD_CANCEL] \\ pop_assum mp_tac \\ EVAL_TAC \\ fs [dimword_def] - \\ rfs [bytes_in_word_def,dimword_def]); + \\ rfs [bytes_in_word_def,dimword_def] +QED -Theorem evaluate_WriteWord32_bignum - `memory_rel c be refs sp t.store t.memory t.mdomain +Theorem evaluate_WriteWord32_bignum: + memory_rel c be refs sp t.store t.memory t.mdomain (join_env_locals sl t.locals ++ vars) ∧ get_var src (t:('a,'c,'ffi) state) = SOME (Word w) ∧ shift_length c < dimindex(:α) ∧ @@ -1577,8 +1667,9 @@ Theorem evaluate_WriteWord32_bignum (join_env_locals (insert dest (Number (&w2n w)) sl) locals' ++ vars) ∧ (∀n. IS_SOME (lookup n sl) ⇒ IS_SOME (lookup (adjust_var n) locals')) ∧ IS_SOME (lookup (adjust_var dest) locals') ∧ - lookup 0 locals' = lookup 0 t.locals` - (rw[WriteWord32_on_32_def,list_Seq_def,join_env_locals_def] + lookup 0 locals' = lookup 0 t.locals +Proof + rw[WriteWord32_on_32_def,list_Seq_def,join_env_locals_def] \\ drule0(GEN_ALL(IMP_memory_rel_bignum_alt)) \\ disch_then(qspecl_then[`[w]`,`F`,`&w2n w`,`header`]mp_tac) \\ simp[] @@ -1618,10 +1709,11 @@ Theorem evaluate_WriteWord32_bignum \\ rw[] \\ fs[] \\ fs [addressTheory.WORD_EQ_ADD_CANCEL] \\ pop_assum mp_tac \\ EVAL_TAC - \\ fs [dimword_def]); + \\ fs [dimword_def] +QED -Theorem evaluate_WriteWord64_bignum - `memory_rel c be refs sp t.store t.memory t.mdomain +Theorem evaluate_WriteWord64_bignum: + memory_rel c be refs sp t.store t.memory t.mdomain (join_env_locals sl t.locals ++ vars) ∧ get_var src (t:('a,'c,'ffi) state) = SOME (Word w) ∧ shift_length c < dimindex(:α) ∧ @@ -1638,8 +1730,9 @@ Theorem evaluate_WriteWord64_bignum (join_env_locals (insert dest (Number (&w2n w)) sl) locals' ++ vars) ∧ (∀n. IS_SOME (lookup n sl) ⇒ IS_SOME (lookup (adjust_var n) locals')) ∧ IS_SOME (lookup (adjust_var dest) locals') ∧ - lookup 0 locals' = lookup 0 t.locals` - (rw[WriteWord64_def,list_Seq_def,join_env_locals_def] + lookup 0 locals' = lookup 0 t.locals +Proof + rw[WriteWord64_def,list_Seq_def,join_env_locals_def] \\ drule0(GEN_ALL(IMP_memory_rel_bignum_alt)) \\ disch_then(qspecl_then[`[w]`,`F`,`&w2n w`,`header`]mp_tac) \\ simp[] @@ -1679,10 +1772,11 @@ Theorem evaluate_WriteWord64_bignum \\ rw[] \\ fs[] \\ fs [addressTheory.WORD_EQ_ADD_CANCEL] \\ pop_assum mp_tac \\ EVAL_TAC - \\ fs [dimword_def]); + \\ fs [dimword_def] +QED -Theorem evaluate_LoadBignum - `memory_rel c be refs sp t.store t.memory t.mdomain ((Number i,v)::vars) ∧ +Theorem evaluate_LoadBignum: + memory_rel c be refs sp t.store t.memory t.mdomain ((Number i,v)::vars) ∧ ¬small_int (:α) i ∧ good_dimindex (:α) ∧ shift_length c < dimindex (:α) ∧ get_var src (t:(α,'c,'ffi) state) = SOME v ∧ header ≠ w1 ⇒ @@ -1690,14 +1784,16 @@ Theorem evaluate_LoadBignum evaluate (LoadBignum c header w1 src,t) = (NONE, set_vars [w1;header;w1] [Word (n2w (Num (ABS i)));(Word h);junk] t) ∧ - ((16w && h) = 0w ⇔ 0 ≤ i)` - (rw[LoadBignum_def,list_Seq_def] \\ eval_tac + ((16w && h) = 0w ⇔ 0 ≤ i) +Proof + rw[LoadBignum_def,list_Seq_def] \\ eval_tac \\ rpt_drule0 memory_rel_Number_bignum_IMP \\ strip_tac \\ rfs[] \\ clean_tac \\ rpt_drule0 get_var_get_real_addr_lemma \\ simp[lookup_insert] \\ simp[wordSemTheory.set_vars_def,wordSemTheory.state_component_equality,alist_insert_def] - \\ rw[] \\ metis_tac[]); + \\ rw[] \\ metis_tac[] +QED val assign_thm_goal = ``state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs /\ @@ -1715,33 +1811,41 @@ val assign_thm_goal = val evaluate_Assign = SIMP_CONV(srw_ss())[wordSemTheory.evaluate_def]``evaluate (Assign _ _, _)`` -Theorem cut_env_adjust_set_insert_1 - `cut_env (adjust_set x) (insert 1 w l) = - cut_env (adjust_set x) l` - (fs [wordSemTheory.cut_env_def] \\ rw [] +Theorem cut_env_adjust_set_insert_1: + cut_env (adjust_set x) (insert 1 w l) = + cut_env (adjust_set x) l +Proof + fs [wordSemTheory.cut_env_def] \\ rw [] \\ fs [lookup_inter_alt,lookup_insert] \\ rw [] \\ fs [SUBSET_DEF] - \\ res_tac \\ fs [NOT_1_domain]); - -Theorem cut_env_adjust_set_insert_3 - `cut_env (adjust_set x) (insert 3 w l) = - cut_env (adjust_set x) l` - (fs [wordSemTheory.cut_env_def] \\ rw [] + \\ res_tac \\ fs [NOT_1_domain] +QED + +Theorem cut_env_adjust_set_insert_3: + cut_env (adjust_set x) (insert 3 w l) = + cut_env (adjust_set x) l +Proof + fs [wordSemTheory.cut_env_def] \\ rw [] \\ fs [lookup_inter_alt,lookup_insert] \\ rw [] \\ fs [SUBSET_DEF] - \\ res_tac \\ fs [NOT_3_domain]); - -Theorem cut_env_adjust_set_insert_5 - `cut_env (adjust_set x) (insert 5 w l) = - cut_env (adjust_set x) l` - (fs [wordSemTheory.cut_env_def] \\ rw [] + \\ res_tac \\ fs [NOT_3_domain] +QED + +Theorem cut_env_adjust_set_insert_5: + cut_env (adjust_set x) (insert 5 w l) = + cut_env (adjust_set x) l +Proof + fs [wordSemTheory.cut_env_def] \\ rw [] \\ fs [lookup_inter_alt,lookup_insert] \\ rw [] \\ fs [SUBSET_DEF] - \\ res_tac \\ fs [NOT_5_domain]); + \\ res_tac \\ fs [NOT_5_domain] +QED -Theorem word_bit_test_0 - `(1w && w) = 0w <=> ~word_bit 0 w` - (fs [word_bit_test]); +Theorem word_bit_test_0: + (1w && w) = 0w <=> ~word_bit 0 w +Proof + fs [word_bit_test] +QED val MAP_Number_11_w2n_word8 = prove( ``!ns ns'. @@ -1755,16 +1859,18 @@ val MAP_Word64_11 = prove( ns = ns'``, Induct \\ Cases_on `ns'` \\ fs []); -Theorem v_to_list_EQ_SOME_NIL - `v_to_list hv1 = SOME [] <=> ∃ts. hv1 = Block ts 0 []` - (Cases_on `hv1` \\ fs [v_to_list_def] +Theorem v_to_list_EQ_SOME_NIL: + v_to_list hv1 = SOME [] <=> ∃ts. hv1 = Block ts 0 [] +Proof + Cases_on `hv1` \\ fs [v_to_list_def] \\ Cases_on `l` \\ fs [v_to_list_def] \\ EVAL_TAC \\ Cases_on `t` \\ fs [v_to_list_def] \\ Cases_on `t'` \\ fs [v_to_list_def] - \\ every_case_tac \\ fs []); + \\ every_case_tac \\ fs [] +QED -Theorem InstallCode_code_thm - `!(t:('a,'c,'ffi) wordSem$state) c hv1 v1 q1 a1 a2 ret_val bptr s1 vars sp refs. +Theorem InstallCode_code_thm: + !(t:('a,'c,'ffi) wordSem$state) c hv1 v1 q1 a1 a2 ret_val bptr s1 vars sp refs. memory_rel c t.be refs sp t.store t.memory t.mdomain ((hv1,a1)::vars) /\ lookup InstallCode_location t.code = SOME (4,InstallCode_code c) /\ @@ -1790,8 +1896,9 @@ Theorem InstallCode_code_thm <| buffer := t.code_buffer.buffer ++ q1 ; space_left := t.code_buffer.space_left - LENGTH q1 |> |>) of | (NONE,s) => (SOME Error, s) - | res => res` - (Induct_on `q1` \\ fs [] THEN1 + | res => res +Proof + Induct_on `q1` \\ fs [] THEN1 (fs [v_to_bytes_def] \\ fs [some_def] \\ rw [] \\ rfs [MAP_Number_11_w2n_word8] \\ rveq \\ fs [v_to_list_EQ_SOME_NIL] \\ rveq @@ -1866,14 +1973,15 @@ Theorem InstallCode_code_thm \\ fs [ADD1,GSYM word_add_n2w] \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,APPEND] \\ CASE_TAC \\ fs [] - \\ Cases_on `q` \\ fs []); + \\ Cases_on `q` \\ fs [] +QED val w2w_upper_def = Define ` w2w_upper (w:word64) = if dimindex (:'a) = 32 then ((63 >< 32) w):'a word else w2w w` -Theorem InstallData_code_thm - `!(t:('a,'c,'ffi) wordSem$state) c hv2 v1 q2 a1 a2 ret_val s1 vars sp refs. +Theorem InstallData_code_thm: + !(t:('a,'c,'ffi) wordSem$state) c hv2 v1 q2 a1 a2 ret_val s1 vars sp refs. memory_rel c t.be refs sp t.store t.memory t.mdomain ((hv2,a2)::vars) /\ lookup InstallData_location t.code = SOME (4,InstallData_code c) /\ @@ -1901,8 +2009,9 @@ Theorem InstallData_code_thm <| buffer := t.data_buffer.buffer ++ MAP w2w_upper q2 ; space_left := t.data_buffer.space_left - LENGTH q2 |> |>) of | (NONE,s) => (SOME Error, s) - | res => res` - (Induct_on `q2` \\ fs [] THEN1 + | res => res +Proof + Induct_on `q2` \\ fs [] THEN1 (fs [v_to_words_def] \\ fs [some_def] \\ rw [] \\ rfs [MAP_Word64_11] \\ rveq \\ fs [v_to_list_EQ_SOME_NIL] \\ rveq @@ -1988,23 +2097,28 @@ Theorem InstallData_code_thm \\ CASE_TAC \\ fs [] \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,APPEND] \\ fs [WORD_LEFT_ADD_DISTRIB] - \\ CASE_TAC \\ fs []); - -Theorem LENGTH_EQ_4 - `(LENGTH xs = 4 <=> ?a1 a2 a3 a4. xs = [a1;a2;a3;a4]) /\ - (4 = LENGTH xs <=> ?a1 a2 a3 a4. xs = [a1;a2;a3;a4])` - (Cases_on `xs` \\ fs [] - \\ rpt (Cases_on `t` \\ fs [] ORELSE Cases_on `t'` \\ fs [])); - -Theorem w2w_upper_upper_w2w - `!z1. good_dimindex (:'a) ==> - MAP w2w_upper (MAP upper_w2w z1) = z1:'a word list` - (Induct \\ fs [] + \\ CASE_TAC \\ fs [] +QED + +Theorem LENGTH_EQ_4: + (LENGTH xs = 4 <=> ?a1 a2 a3 a4. xs = [a1;a2;a3;a4]) /\ + (4 = LENGTH xs <=> ?a1 a2 a3 a4. xs = [a1;a2;a3;a4]) +Proof + Cases_on `xs` \\ fs [] + \\ rpt (Cases_on `t` \\ fs [] ORELSE Cases_on `t'` \\ fs []) +QED + +Theorem w2w_upper_upper_w2w: + !z1. good_dimindex (:'a) ==> + MAP w2w_upper (MAP upper_w2w z1) = z1:'a word list +Proof + Induct \\ fs [] \\ fs [good_dimindex_def] \\ reverse (rw []) \\ fs [w2w_upper_def,upper_w2w_def] THEN1 (Cases_on `h` \\ rfs [w2w_def,dimword_def]) \\ fs [fcpTheory.CART_EQ,word_extract_def,w2w,word_bits_def, - fcpTheory.FCP_BETA,word_lsl_def]); + fcpTheory.FCP_BETA,word_lsl_def] +QED val MAP_FST_MAP_compile_part = prove( ``!full_list. MAP FST (MAP (compile_part c) full_list) = MAP FST full_list``, @@ -2021,9 +2135,10 @@ val compile_part_loc_IMP = prove( ``compile_part c (a1,a2) = (n,x) ==> n = a1``, PairCases_on `a2` \\ fs [compile_part_def]); -Theorem assign_Install - `(op = Install) ==> ^assign_thm_goal` - (rpt strip_tac \\ drule (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_Install: + (op = Install) ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ strip_tac \\ imp_res_tac get_vars_IMP_LENGTH @@ -2299,20 +2414,24 @@ Theorem assign_Install THEN1 asm_simp_tac std_ss [] \\ fs [lookup_inter_alt,lookup_fromAList] \\ rw [] \\ fs [cut_env_def] \\ rveq \\ fs [] - \\ fs [domain_inter,adjust_set_inter]); - -Theorem LENGTH_EQ_5 - `(LENGTH xs = 5 <=> ?a1 a2 a3 a4 a5. xs = [a1;a2;a3;a4;a5]) /\ - (5 = LENGTH xs <=> ?a1 a2 a3 a4 a5. xs = [a1;a2;a3;a4;a5])` - (Cases_on `xs` \\ fs [] - \\ rpt (Cases_on `t` \\ fs [] ORELSE Cases_on `t'` \\ fs [])); - -Theorem memory_rel_get_num - `memory_rel c be refs sp st m dm vars /\ + \\ fs [domain_inter,adjust_set_inter] +QED + +Theorem LENGTH_EQ_5: + (LENGTH xs = 5 <=> ?a1 a2 a3 a4 a5. xs = [a1;a2;a3;a4;a5]) /\ + (5 = LENGTH xs <=> ?a1 a2 a3 a4 a5. xs = [a1;a2;a3;a4;a5]) +Proof + Cases_on `xs` \\ fs [] + \\ rpt (Cases_on `t` \\ fs [] ORELSE Cases_on `t'` \\ fs []) +QED + +Theorem memory_rel_get_num: + memory_rel c be refs sp st m dm vars /\ n < dimword (:'a) DIV 8 /\ good_dimindex (:'a) /\ MEM (Number (&n),a:'a word_loc) vars ==> - ?w. a = Word w /\ w >>> 2 = n2w n` - (rw [] + ?w. a = Word w /\ w >>> 2 = n2w n +Proof + rw [] \\ `memory_rel c be refs sp st m dm [Number (&n),a]` by (first_x_assum (fn th => mp_tac th THEN match_mp_tac memory_rel_rearrange) \\ fs []) @@ -2323,27 +2442,34 @@ Theorem memory_rel_get_num \\ fs [good_dimindex_def,dimword_def] \\ `4 * n < dimword (:'a)` by fs [dimword_def] \\ fs [dimword_def] - \\ match_mp_tac (MULT_DIV |> ONCE_REWRITE_RULE [MULT_COMM]) \\ fs []); + \\ match_mp_tac (MULT_DIV |> ONCE_REWRITE_RULE [MULT_COMM]) \\ fs [] +QED -Theorem ZERO_IN_adjust_set - `0 ∈ domain (adjust_set the_names)` - (fs [domain_lookup,lookup_adjust_set]); +Theorem ZERO_IN_adjust_set: + 0 ∈ domain (adjust_set the_names) +Proof + fs [domain_lookup,lookup_adjust_set] +QED -Theorem IN_domain_adjust_set_inter - `x ∈ domain (adjust_set (inter s1 s2)) <=> +Theorem IN_domain_adjust_set_inter: + x ∈ domain (adjust_set (inter s1 s2)) <=> x ∈ domain (adjust_set s1) /\ - x ∈ domain (adjust_set s2)` - (fs [domain_lookup,lookup_adjust_set] + x ∈ domain (adjust_set s2) +Proof + fs [domain_lookup,lookup_adjust_set] \\ rw [] \\ fs [lookup_inter] \\ rfs [] - \\ every_case_tac \\ fs []); + \\ every_case_tac \\ fs [] +QED -Theorem get_var_to_word_exp - `get_var r s = SOME (Word w) ⇒ +Theorem get_var_to_word_exp: + get_var r s = SOME (Word w) ⇒ word_exp s (Op Add [Var r;Const 0w] ) = SOME (Word (w+0w)) ∧ word_exp s (Op Add [Var r;Const 1w] ) = SOME (Word (w+1w)) ∧ word_exp s (Op Add [Var r;Const 2w] ) = SOME (Word (w+2w)) ∧ - word_exp s (Op Add [Var r;Const 3w] ) = SOME (Word (w+3w)) ` - (EVAL_TAC>>rw[]); + word_exp s (Op Add [Var r;Const 3w] ) = SOME (Word (w+3w)) +Proof + EVAL_TAC>>rw[] +QED val word_exp_set = Q.prove(` (word_exp s (Op Add [Var n; Const c]) = @@ -2376,8 +2502,8 @@ val get_var_consts = Q.prove(` get_var r (s with memory:=m) = get_var r s`, EVAL_TAC>>rw[]); -Theorem CopyByteAdd_thm - `!be n a1 a2 m dm ret_val l1 l2 (s:('a,'c,'ffi) wordSem$state) m1. +Theorem CopyByteAdd_thm: + !be n a1 a2 m dm ret_val l1 l2 (s:('a,'c,'ffi) wordSem$state) m1. word_copy_fwd be n a1 a2 m dm = SOME m1 /\ s.memory = m /\ s.mdomain = dm /\ s.be = be ∧ @@ -2392,8 +2518,9 @@ Theorem CopyByteAdd_thm evaluate (ByteCopyAdd_code,s) = (SOME (Result (Loc l1 l2) ret_val), s with <| clock := s.clock - w2n n DIV 4 ; - memory := m1 ; locals := LN |>)` - (ho_match_mp_tac word_copy_fwd_ind >> + memory := m1 ; locals := LN |>) +Proof + ho_match_mp_tac word_copy_fwd_ind >> rw[]>> qpat_x_assum`A=SOME m1` mp_tac>> simp[Once word_copy_fwd_def]>> @@ -2477,10 +2604,11 @@ Theorem CopyByteAdd_thm simp[wordSemTheory.get_var_def,lookup_fromList2,lookup_fromList,set_var_consts])>> rw[]>> unabbrev_all_tac>>simp[wordSemTheory.call_env_def,wordSemTheory.dec_clock_def]>> - simp[wordSemTheory.state_component_equality,wordSemTheory.set_var_def])); + simp[wordSemTheory.state_component_equality,wordSemTheory.set_var_def]) +QED -Theorem CopyByteSub_thm - `!be n a1 a2 m dm ret_val l1 l2 (s:('a,'c,'ffi) wordSem$state) m1. +Theorem CopyByteSub_thm: + !be n a1 a2 m dm ret_val l1 l2 (s:('a,'c,'ffi) wordSem$state) m1. word_copy_bwd be n a1 a2 m dm = SOME m1 /\ s.memory = m /\ s.mdomain = dm /\ s.be = be ∧ @@ -2495,8 +2623,9 @@ Theorem CopyByteSub_thm evaluate (ByteCopySub_code,s) = (SOME (Result (Loc l1 l2) ret_val), s with <| clock := s.clock - w2n n DIV 4 ; - memory := m1 ; locals := LN |>)` - (ho_match_mp_tac word_copy_bwd_ind >> + memory := m1 ; locals := LN |>) +Proof + ho_match_mp_tac word_copy_bwd_ind >> rw[]>> qpat_x_assum`A=SOME m1` mp_tac>> simp[Once word_copy_bwd_def]>> @@ -2580,27 +2709,31 @@ Theorem CopyByteSub_thm simp[wordSemTheory.get_var_def,lookup_fromList2,lookup_fromList,set_var_consts])>> rw[]>> unabbrev_all_tac>>simp[wordSemTheory.call_env_def,wordSemTheory.dec_clock_def]>> - simp[wordSemTheory.state_component_equality,wordSemTheory.set_var_def])); + simp[wordSemTheory.state_component_equality,wordSemTheory.set_var_def]) +QED -Theorem push_env_store - `(push_env x y s).store = s.store /\ +Theorem push_env_store: + (push_env x y s).store = s.store /\ (push_env x y s).memory = s.memory /\ (push_env x y s).mdomain = s.mdomain /\ (push_env x y s).code = s.code /\ - (push_env x y s).be = s.be` - (Cases_on `y` + (push_env x y s).be = s.be +Proof + Cases_on `y` \\ fs [wordSemTheory.push_env_def] \\ TRY pairarg_tac \\ fs [] \\ PairCases_on `x'` \\ fs [wordSemTheory.push_env_def] - \\ TRY pairarg_tac \\ fs []); + \\ TRY pairarg_tac \\ fs [] +QED val not_less_zero_int_eq = prove( ``~(i < 0:int) <=> ?n. i = &n``, Cases_on `i` \\ fs []); -Theorem assign_WordFromWord - `(?b. op = WordFromWord b) ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_WordFromWord: + (?b. op = WordFromWord b) ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ imp_res_tac state_rel_cut_IMP \\ pop_assum mp_tac \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -2705,11 +2838,13 @@ Theorem assign_WordFromWord \\ fs [FAPPLY_FUPDATE_THM,w2w_def] \\ Cases_on `w` \\ fs [] \\ rfs [dimword_def] \\ fs [] \\ match_mp_tac (GEN_ALL memory_rel_less_space) - \\ qexists_tac`x.space - 2` \\ fs[])); + \\ qexists_tac`x.space - 2` \\ fs[]) +QED -Theorem assign_CopyByte - `(?new_flag. op = CopyByte new_flag /\ ¬ new_flag) ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_CopyByte: + (?new_flag. op = CopyByte new_flag /\ ¬ new_flag) ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ strip_tac \\ imp_res_tac get_vars_IMP_LENGTH \\ fs [assign_def] \\ rw [] @@ -3132,7 +3267,8 @@ Theorem assign_CopyByte \\ rpt strip_tac \\ fs [] \\ fs [lookup_inter_alt] \\ rw [] \\ sg `F` \\ fs [] \\ pop_assum mp_tac \\ simp [] - \\ unabbrev_all_tac \\ fs [IN_domain_adjust_set_inter]))); + \\ unabbrev_all_tac \\ fs [IN_domain_adjust_set_inter])) +QED (* This equality captures all the information that is preserved after `v_to_list` *) @@ -3151,63 +3287,80 @@ val eq_upto_ts_def = tDefine"eq_upto_ts"` val _ = Parse.add_infix("≅ts",425,Parse.NONASSOC); val _ = Parse.overload_on("≅ts",``eq_upto_ts``); -Theorem eq_imp_upto_ts - `∀x y. x = y ⇒ x ≅ts y` - (ho_match_mp_tac (theorem "eq_upto_ts_ind") +Theorem eq_imp_upto_ts: + ∀x y. x = y ⇒ x ≅ts y +Proof + ho_match_mp_tac (theorem "eq_upto_ts_ind") \\ rw [eq_upto_ts_def] - \\ Induct_on `xs1` \\ rw [eq_upto_ts_def]); + \\ Induct_on `xs1` \\ rw [eq_upto_ts_def] +QED -Theorem eq_upto_ts_refl - `∀v. v ≅ts v` - (Induct +Theorem eq_upto_ts_refl: + ∀v. v ≅ts v +Proof + Induct \\ rw [eq_upto_ts_def] \\ Induct_on `l` \\ rw [eq_upto_ts_def,eq_imp_upto_ts] - \\ Induct_on `l` \\ rw [eq_upto_ts_def,eq_imp_upto_ts]); + \\ Induct_on `l` \\ rw [eq_upto_ts_def,eq_imp_upto_ts] +QED -Theorem v_to_list_IFF_list_to_v - `!r2 in2. v_to_list r2 = SOME in2 <=> ?r3. r3 = list_to_v in2 /\ r2 ≅ts r3` - (recInduct v_to_list_ind +Theorem v_to_list_IFF_list_to_v: + !r2 in2. v_to_list r2 = SOME in2 <=> ?r3. r3 = list_to_v in2 /\ r2 ≅ts r3 +Proof + recInduct v_to_list_ind \\ rw [] \\ fs [v_to_list_def,list_to_v_def,eq_upto_ts_def] \\ TRY (eq_tac \\ rw [list_to_v_def,eq_upto_ts_def]) \\ fs [v_to_list_def,list_to_v_def,eq_upto_ts_def] \\ fs [case_eq_thms] \\ rveq \\ fs [] \\ rveq \\ fs [list_to_v_def,eq_upto_ts_def,eq_upto_ts_refl] - \\ Cases_on `in2` \\ fs [list_to_v_def,eq_upto_ts_def,eq_upto_ts_refl]); + \\ Cases_on `in2` \\ fs [list_to_v_def,eq_upto_ts_def,eq_upto_ts_refl] +QED -Theorem v_to_list_SOME_NIL_IFF - `!v. v_to_list v = SOME [] <=> ?ts. v = Block ts nil_tag []` - (recInduct v_to_list_ind +Theorem v_to_list_SOME_NIL_IFF: + !v. v_to_list v = SOME [] <=> ?ts. v = Block ts nil_tag [] +Proof + recInduct v_to_list_ind \\ rw [] \\ fs [v_to_list_def,list_to_v_def] \\ TRY (eq_tac \\ rw [list_to_v_def]) \\ fs [v_to_list_def,list_to_v_def] \\ fs [case_eq_thms] \\ rveq \\ fs [] \\ rveq \\ fs [list_to_v_def] - \\ Cases_on `in2` \\ fs [list_to_v_def]); - -Theorem v_to_list_SOME_CONS_IMP - `v_to_list v = SOME (x::xs) ==> ?ts ys. v = Block ts cons_tag [x;ys] ∧ - ys ≅ts list_to_v xs` - (Cases_on `v` + \\ Cases_on `in2` \\ fs [list_to_v_def] +QED + +Theorem v_to_list_SOME_CONS_IMP: + v_to_list v = SOME (x::xs) ==> ?ts ys. v = Block ts cons_tag [x;ys] ∧ + ys ≅ts list_to_v xs +Proof + Cases_on `v` \\ rw [v_to_list_IFF_list_to_v,list_to_v_def,eq_upto_ts_def] - \\ Cases_on `l` \\ fs [v_to_list_IFF_list_to_v,list_to_v_def,eq_upto_ts_def]); - -Theorem eq_upto_ts_list_to_v_Block - `∀v vl. v ≅ts list_to_v vl ⇒ ∃ts t l. v = Block ts t l` - (rw [] \\ Cases_on `vl` \\ Cases_on `v` \\ fs [list_to_v_def,eq_upto_ts_def]); - -Theorem eq_upto_ts_list_to_v_Cons - `∀v vl vs. v ≅ts list_to_v (vs::vl) ⇒ ∃ts t l. v = Block ts t (vs::l)` - (rw [] \\ Cases_on `vl` \\ Cases_on `v` \\ fs [list_to_v_def,eq_upto_ts_def] - \\ Cases_on `l` \\ fs [list_to_v_def,eq_upto_ts_def]); - -Theorem v_to_list_IMP_list_to_v - `!r2 in2. v_to_list r2 = SOME in2 ==> ?r3. r3 = list_to_v in2 ∧ r2 ≅ts r3` - (fs [v_to_list_IFF_list_to_v]); - - -Theorem eq_upto_ts_get_refs - `∀x y. x ≅ts y ⇒ get_refs x = get_refs y` - (ho_match_mp_tac (theorem "eq_upto_ts_ind") + \\ Cases_on `l` \\ fs [v_to_list_IFF_list_to_v,list_to_v_def,eq_upto_ts_def] +QED + +Theorem eq_upto_ts_list_to_v_Block: + ∀v vl. v ≅ts list_to_v vl ⇒ ∃ts t l. v = Block ts t l +Proof + rw [] \\ Cases_on `vl` \\ Cases_on `v` \\ fs [list_to_v_def,eq_upto_ts_def] +QED + +Theorem eq_upto_ts_list_to_v_Cons: + ∀v vl vs. v ≅ts list_to_v (vs::vl) ⇒ ∃ts t l. v = Block ts t (vs::l) +Proof + rw [] \\ Cases_on `vl` \\ Cases_on `v` \\ fs [list_to_v_def,eq_upto_ts_def] + \\ Cases_on `l` \\ fs [list_to_v_def,eq_upto_ts_def] +QED + +Theorem v_to_list_IMP_list_to_v: + !r2 in2. v_to_list r2 = SOME in2 ==> ?r3. r3 = list_to_v in2 ∧ r2 ≅ts r3 +Proof + fs [v_to_list_IFF_list_to_v] +QED + + +Theorem eq_upto_ts_get_refs: + ∀x y. x ≅ts y ⇒ get_refs x = get_refs y +Proof + ho_match_mp_tac (theorem "eq_upto_ts_ind") \\ rw [eq_upto_ts_def,get_refs_def] \\ rw [eq_upto_ts_def,get_refs_def] \\ AP_TERM_TAC @@ -3216,20 +3369,24 @@ Theorem eq_upto_ts_get_refs \\ ntac 2 (last_x_assum mp_tac) \\ EVERY (map Q.SPEC_TAC [(`xs2`,`y`),(`xs1`,`x`)]) \\ ho_match_mp_tac LIST_REL_ind - \\ rw []); + \\ rw [] +QED -Theorem eq_upto_ts_get_refs_map - `∀x y. +Theorem eq_upto_ts_get_refs_map: + ∀x y. LIST_REL (λa' a. a' ≅ts a) x y - ⇒ MAP (λa. get_refs a) x = MAP (λa. get_refs a) y` - (Induct + ⇒ MAP (λa. get_refs a) x = MAP (λa. get_refs a) y +Proof + Induct \\ rw [] - \\ rw [eq_upto_ts_get_refs]); - -Theorem eq_upto_ts_reachable_refs - `∀v v' vars refs n. - v ≅ts v' ⇒ reachable_refs (v::vars) refs n = reachable_refs (v'::vars) refs n` - (ho_match_mp_tac (theorem "eq_upto_ts_ind") + \\ rw [eq_upto_ts_get_refs] +QED + +Theorem eq_upto_ts_reachable_refs: + ∀v v' vars refs n. + v ≅ts v' ⇒ reachable_refs (v::vars) refs n = reachable_refs (v'::vars) refs n +Proof + ho_match_mp_tac (theorem "eq_upto_ts_ind") \\ rw [eq_upto_ts_def,reachable_refs_def] \\ EQ_TAC \\ rw [] >- (EVERY (map Q.EXISTS_TAC [`Block v' tag1 []`,`r`]) \\ fs [get_refs_def]) @@ -3243,12 +3400,14 @@ Theorem eq_upto_ts_reachable_refs >- (EVERY (map Q.EXISTS_TAC [`Block v2 tag1 (x1::xs1)`,`r`]) \\ first_assum (mp_then Any assume_tac eq_upto_ts_get_refs_map) \\ fs [get_refs_def,eq_upto_ts_get_refs_map]) - >- (EVERY (map Q.EXISTS_TAC [`x`,`r`]) \\ fs [get_refs_def])); + >- (EVERY (map Q.EXISTS_TAC [`x`,`r`]) \\ fs [get_refs_def]) +QED -Theorem eq_upto_ts_v_inv - `∀v lv c w f heap. - v ≅ts list_to_v lv ∧ v_inv c v (w,f,heap) ⇒ v_inv c (list_to_v lv) (w,f,heap)` - (`∀v v'. v ≅ts v' +Theorem eq_upto_ts_v_inv: + ∀v lv c w f heap. + v ≅ts list_to_v lv ∧ v_inv c v (w,f,heap) ⇒ v_inv c (list_to_v lv) (w,f,heap) +Proof + `∀v v'. v ≅ts v' ⇒ ∀lv c w f heap. v' = list_to_v lv ∧ v_inv c v (w,f,heap) ⇒ v_inv c v' (w,f,heap)` suffices_by METIS_TAC [] @@ -3263,13 +3422,15 @@ Theorem eq_upto_ts_v_inv \\ rw [] \\ Cases_on `lv` \\ fs [list_to_v_def] \\ rveq \\ fs []) - \\ Cases_on `lv` \\ fs [list_to_v_def]); + \\ Cases_on `lv` \\ fs [list_to_v_def] +QED -Theorem eq_upto_ts_mem_rel - `∀v vl c be refs sp m dm st l vars. +Theorem eq_upto_ts_mem_rel: + ∀v vl c be refs sp m dm st l vars. v ≅ts (list_to_v vl) ∧ memory_rel c be refs sp st m dm ((v,l)::vars) - ⇒ memory_rel c be refs sp st m dm ((list_to_v vl,l)::vars)` - (`∀v v'. v ≅ts v' + ⇒ memory_rel c be refs sp st m dm ((list_to_v vl,l)::vars) +Proof + `∀v v'. v ≅ts v' ⇒ ∀vl c be refs sp m dm st l vars. v' = list_to_v vl ∧ memory_rel c be refs sp st m dm ((v,l)::vars) ⇒ memory_rel c be refs sp st m dm ((v',l)::vars)` @@ -3280,7 +3441,8 @@ Theorem eq_upto_ts_mem_rel \\ EVERY (map Q.EXISTS_TAC [`heap`,`limit`,`a`,`sp'`,`sp1`,`gens`]) \\ fs [word_ml_inv_def] \\ Q.EXISTS_TAC `hs` \\ rw [] \\ fs [abs_ml_inv_def,bc_stack_ref_inv_def] \\ Q.EXISTS_TAC `f` \\ rw [] - \\ METIS_TAC [eq_upto_ts_def,eq_upto_ts_v_inv,eq_upto_ts_reachable_refs]); + \\ METIS_TAC [eq_upto_ts_def,eq_upto_ts_v_inv,eq_upto_ts_reachable_refs] +QED val evaluate_AppendMainLoop_code = prove( ``!xs ww (t:('a,'c,'ffi)wordSem$state) vars ptr hdr l k frame r1 r2 next_free. @@ -3725,9 +3887,10 @@ val evaluate_AppendLenLoop_code = prove( \\ Cases_on `q` \\ fs []) |> Q.SPEC `0` |> SIMP_RULE std_ss [] |> Q.GEN `refs`; -Theorem assign_ListAppend - `op = ListAppend ==> ^assign_thm_goal` - (rpt strip_tac \\ drule (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_ListAppend: + op = ListAppend ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ imp_res_tac state_rel_cut_IMP \\ fs [assign_def] \\ rveq @@ -4276,11 +4439,13 @@ Theorem assign_ListAppend \\ strip_tac \\ qexists_tac `p_1` \\ simp [] \\ fs [lookup_fromAList] - \\ drule ALOOKUP_MEM \\ simp []); + \\ drule ALOOKUP_MEM \\ simp [] +QED -Theorem assign_ConfigGC - `op = ConfigGC ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_ConfigGC: + op = ConfigGC ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ imp_res_tac state_rel_cut_IMP \\ pop_assum mp_tac \\ strip_tac \\ imp_res_tac get_vars_IMP_LENGTH @@ -4347,11 +4512,13 @@ Theorem assign_ConfigGC \\ strip_tac \\ rw [] \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ match_mp_tac memory_rel_insert - \\ fs [] \\ match_mp_tac memory_rel_Unit \\ fs []); + \\ fs [] \\ match_mp_tac memory_rel_Unit \\ fs [] +QED -Theorem assign_WordToInt - `op = WordToInt ==> ^assign_thm_goal ` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_WordToInt: + op = WordToInt ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -4541,24 +4708,31 @@ Theorem assign_WordToInt \\ qmatch_asmsub_abbrev_tac`Number w2` \\ `w1 = w2` suffices_by simp[] \\ simp[Abbr`w1`,Abbr`w2`] - \\ simp[w2n_w2w]); - -Theorem push_env_tstamps - `∀x t s. (push_env x t s).tstamps = s.tstamps` - (rw [push_env_def] \\ Cases_on `t` \\ rw [push_env_def]); - -Theorem dec_clock_tstamps - `∀s. (dec_clock s).tstamps = s.tstamps` - (rw [dataSemTheory.dec_clock_def]); - -Theorem with_fresh_ts_state - `∀s ts tag lv. + \\ simp[w2n_w2w] +QED + +Theorem push_env_tstamps: + ∀x t s. (push_env x t s).tstamps = s.tstamps +Proof + rw [push_env_def] \\ Cases_on `t` \\ rw [push_env_def] +QED + +Theorem dec_clock_tstamps: + ∀s. (dec_clock s).tstamps = s.tstamps +Proof + rw [dataSemTheory.dec_clock_def] +QED + +Theorem with_fresh_ts_state: + ∀s ts tag lv. with_fresh_ts s (λts s'. Rval (Block ts tag lv,s')) = - Rval (Block (with_fresh_ts s K) tag lv, with_fresh_ts s (λx y. y))` - (rw [with_fresh_ts_def] \\ Cases_on `s.tstamps` \\ fs []); + Rval (Block (with_fresh_ts s K) tag lv, with_fresh_ts s (λx y. y)) +Proof + rw [with_fresh_ts_def] \\ Cases_on `s.tstamps` \\ fs [] +QED -Theorem with_fresh_ts_state_eq - `(∀s. (with_fresh_ts s (λx y. y)).ffi = s.ffi) ∧ +Theorem with_fresh_ts_state_eq: + (∀s. (with_fresh_ts s (λx y. y)).ffi = s.ffi) ∧ (∀s. (with_fresh_ts s (λx y. y)).locals = s.locals) ∧ (∀s. (with_fresh_ts s (λx y. y)).stack = s.stack) ∧ (∀s. (with_fresh_ts s (λx y. y)).global = s.global) ∧ @@ -4568,12 +4742,15 @@ Theorem with_fresh_ts_state_eq (∀s. (with_fresh_ts s (λx y. y)).compile = s.compile) ∧ (∀s. (with_fresh_ts s (λx y. y)).compile_oracle = s.compile_oracle) ∧ (∀s. (with_fresh_ts s (λx y. y)).clock = s.clock) ∧ - (∀s. (with_fresh_ts s (λx y. y)).space = s.space)` - (rw [with_fresh_ts_def] \\ Cases_on `s.tstamps` \\ fs []); - -Theorem assign_FromList - `(?tag. op = FromList tag) ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] + (∀s. (with_fresh_ts s (λx y. y)).space = s.space) +Proof + rw [with_fresh_ts_def] \\ Cases_on `s.tstamps` \\ fs [] +QED + +Theorem assign_FromList: + (?tag. op = FromList tag) ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ strip_tac \\ fs [assign_def] \\ rveq @@ -4691,11 +4868,13 @@ Theorem assign_FromList \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ match_mp_tac word_ml_inv_insert \\ fs [flat_def] \\ first_x_assum (fn th => mp_tac th \\ match_mp_tac word_ml_inv_rearrange) - \\ fs[MEM] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[])); + \\ fs[MEM] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[]) +QED -Theorem assign_RefByte - `(?fl. op = RefByte fl) ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_RefByte: + (?fl. op = RefByte fl) ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ strip_tac \\ fs [assign_def] \\ rveq @@ -4816,11 +4995,13 @@ Theorem assign_RefByte \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ match_mp_tac word_ml_inv_insert \\ fs [flat_def] \\ first_x_assum (fn th => mp_tac th \\ match_mp_tac word_ml_inv_rearrange) - \\ fs[MEM] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[]); + \\ fs[MEM] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] +QED -Theorem assign_RefArray - `op = RefArray ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_RefArray: + op = RefArray ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ strip_tac \\ fs [assign_def] \\ rveq @@ -4922,7 +5103,8 @@ Theorem assign_RefArray \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ match_mp_tac word_ml_inv_insert \\ fs [flat_def] \\ first_x_assum (fn th => mp_tac th \\ match_mp_tac word_ml_inv_rearrange) - \\ fs[MEM] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[]); + \\ fs[MEM] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] +QED val LENGTH_n2mw_1 = prove( ``LENGTH ((n2mw n) :'a word list) = 1 <=> n <> 0 /\ n < dimword (:'a)``, @@ -4950,12 +5132,14 @@ val LESS_IMP_NOT_BIT = prove( ``!k n. n < 2 ** k ==> ~BIT k n``, fs [bitTheory.BIT_def,bitTheory.BITS_THM,LESS_DIV_EQ_ZERO]); -Theorem Smallnum_alt - `Smallnum i = - if i < 0 then (0w - n2w (Num (-i))) << 2 else n2w (Num i) << 2` - (Cases_on `i` \\ fs [WORD_MUL_LSL,Smallnum_def,GSYM word_mul_n2w] +Theorem Smallnum_alt: + Smallnum i = + if i < 0 then (0w - n2w (Num (-i))) << 2 else n2w (Num i) << 2 +Proof + Cases_on `i` \\ fs [WORD_MUL_LSL,Smallnum_def,GSYM word_mul_n2w] \\ once_rewrite_tac [SIMP_CONV (srw_ss()) [] ``-w:'a word``] - \\ simp_tac std_ss [AC WORD_MULT_COMM WORD_MULT_ASSOC]); + \\ simp_tac std_ss [AC WORD_MULT_COMM WORD_MULT_ASSOC] +QED val BIT_lemma = prove( ``BIT n (2 ** k - i) <=> if n < k /\ i < 2n ** k /\ i <> 0 @@ -4993,9 +5177,10 @@ val BIT_Lemma2 = prove( \\ `n - 1 < 2 ** m` by fs [] \\ fs [] \\ fs [LESS_DIV_EQ_ZERO]); -Theorem assign_WordFromInt - `op = WordFromInt ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_WordFromInt: + op = WordFromInt ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -5433,11 +5618,13 @@ Theorem assign_WordFromInt \\ match_mp_tac WORD_EXTRACT_ID \\ qmatch_goalsub_abbrev_tac`w2n ww` \\ Q.ISPEC_THEN`ww`mp_tac w2n_lt - \\ simp[dimword_def]); + \\ simp[dimword_def] +QED -Theorem assign_TagEq - `(?tag. op = TagEq tag) ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_TagEq: + (?tag. op = TagEq tag) ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -5494,11 +5681,13 @@ Theorem assign_TagEq \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ match_mp_tac memory_rel_insert \\ fs [inter_insert_ODD_adjust_set_alt] \\ TRY (match_mp_tac memory_rel_Boolv_T) - \\ TRY (match_mp_tac memory_rel_Boolv_F) \\ fs []); + \\ TRY (match_mp_tac memory_rel_Boolv_F) \\ fs [] +QED -Theorem assign_TagLenEq - `(?tag len. op = TagLenEq tag len) ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_TagLenEq: + (?tag len. op = TagLenEq tag len) ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -5570,7 +5759,8 @@ Theorem assign_TagLenEq \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ match_mp_tac memory_rel_insert \\ fs [] \\ TRY (match_mp_tac memory_rel_Boolv_F) \\ fs [] - \\ TRY (match_mp_tac memory_rel_Boolv_T) \\ fs []); + \\ TRY (match_mp_tac memory_rel_Boolv_T) \\ fs [] +QED val eval_Call_Add = Q.SPEC `0` eval_Call_Arith |> SIMP_RULE std_ss [int_op_def,Arith_location_def]; @@ -5587,9 +5777,10 @@ val eval_Call_Div = Q.SPEC `5` eval_Call_Arith val eval_Call_Mod = Q.SPEC `6` eval_Call_Arith |> SIMP_RULE std_ss [int_op_def,Arith_location_def]; -Theorem assign_Add - `op = Add ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_Add: + op = Add ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ imp_res_tac get_vars_IMP_LENGTH \\ fs [] \\ rw [] @@ -5631,11 +5822,13 @@ Theorem assign_Add \\ drule0 memory_rel_zero_space \\ fs []) \\ unabbrev_all_tac \\ match_mp_tac eval_Call_Add - \\ fs [state_rel_insert_3_1]); + \\ fs [state_rel_insert_3_1] +QED -Theorem assign_Sub - `op = Sub ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_Sub: + op = Sub ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ imp_res_tac get_vars_IMP_LENGTH \\ fs [] \\ rw [] @@ -5677,16 +5870,20 @@ Theorem assign_Sub \\ drule0 memory_rel_zero_space \\ fs []) \\ unabbrev_all_tac \\ match_mp_tac eval_Call_Sub - \\ fs [state_rel_insert_3_1]); + \\ fs [state_rel_insert_3_1] +QED -Theorem cut_state_opt_IMP_ffi - `dataSem$cut_state_opt names_opt s = SOME x ==> x.ffi = s.ffi` - (fs [dataSemTheory.cut_state_opt_def,dataSemTheory.cut_state_def] - \\ every_case_tac \\ fs [] \\ rw [] \\ fs []); +Theorem cut_state_opt_IMP_ffi: + dataSem$cut_state_opt names_opt s = SOME x ==> x.ffi = s.ffi +Proof + fs [dataSemTheory.cut_state_opt_def,dataSemTheory.cut_state_def] + \\ every_case_tac \\ fs [] \\ rw [] \\ fs [] +QED -Theorem assign_Mult - `op = Mult ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_Mult: + op = Mult ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ imp_res_tac get_vars_IMP_LENGTH \\ fs [] \\ rw [] @@ -5752,20 +5949,24 @@ Theorem assign_Mult \\ fs [get_vars_def,get_var_def] \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` mp_tac \\ fs [state_rel_thm,lookup_insert] - \\ fs [inter_insert_ODD_adjust_set_alt]); + \\ fs [inter_insert_ODD_adjust_set_alt] +QED -Theorem word_bit_lsr_dimindex_1 - `word_bit 0 ((w1 ⋙ (dimindex (:'a) − 1)):'a word) <=> word_msb w1` - (fs [word_bit_def,word_lsr_def,fcpTheory.FCP_BETA,word_msb_def]); +Theorem word_bit_lsr_dimindex_1: + word_bit 0 ((w1 ⋙ (dimindex (:'a) − 1)):'a word) <=> word_msb w1 +Proof + fs [word_bit_def,word_lsr_def,fcpTheory.FCP_BETA,word_msb_def] +QED -Theorem state_rel_Number_IMP - `state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs /\ +Theorem state_rel_Number_IMP: + state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs /\ get_var a1 s.locals = SOME (Number i1) /\ lookup (adjust_var a1) t.locals = SOME v1 ==> ?w1. (v1 = Word w1) /\ (~(word_bit 0 w1) <=> small_int (:'a) i1) /\ - (~(word_msb w1) /\ ~(word_bit 0 w1) ==> 0 <= i1 /\ w1 = n2w (4 * Num i1))` - (fs [state_rel_thm] \\ rw [] + (~(word_msb w1) /\ ~(word_bit 0 w1) ==> 0 <= i1 /\ w1 = n2w (4 * Num i1)) +Proof + fs [state_rel_thm] \\ rw [] \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,APPEND] \\ drule0 (GEN_ALL memory_rel_get_var_IMP) \\ disch_then (qspec_then `a1` mp_tac) @@ -5774,11 +5975,13 @@ Theorem state_rel_Number_IMP \\ fs [word_bit_def] \\ strip_tac \\ imp_res_tac memory_rel_Number_IMP \\ fs [] \\ rveq \\ rpt_drule0 memory_rel_Number_word_msb \\ fs [] - \\ Cases_on `i1` \\ fs [Smallnum_def]); + \\ Cases_on `i1` \\ fs [Smallnum_def] +QED -Theorem assign_Div - `op = Div ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_Div: + op = Div ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ imp_res_tac get_vars_IMP_LENGTH \\ fs [] \\ rw [] @@ -5946,11 +6149,13 @@ Theorem assign_Div \\ match_mp_tac (eval_Call_Div |> REWRITE_RULE [list_Seq_def]) \\ fs [get_vars_SOME_IFF_data,insert_shadow] \\ fs [GSYM wordSemTheory.set_var_def] - \\ fs [wordSemTheory.set_var_def,state_rel_insert_1]); + \\ fs [wordSemTheory.set_var_def,state_rel_insert_1] +QED -Theorem assign_Mod - `op = Mod ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_Mod: + op = Mod ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ imp_res_tac get_vars_IMP_LENGTH \\ fs [] \\ rw [] @@ -6122,11 +6327,13 @@ Theorem assign_Mod \\ match_mp_tac (eval_Call_Mod |> REWRITE_RULE [list_Seq_def]) \\ fs [get_vars_SOME_IFF_data,insert_shadow] \\ fs [GSYM wordSemTheory.set_var_def] - \\ fs [wordSemTheory.set_var_def,state_rel_insert_1]); + \\ fs [wordSemTheory.set_var_def,state_rel_insert_1] +QED -Theorem assign_LengthByte - `op = LengthByte ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_LengthByte: + op = LengthByte ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -6170,11 +6377,13 @@ Theorem assign_LengthByte \\ rfs[shift_def,bytes_in_word_def,WORD_LEFT_ADD_DISTRIB,word_mul_n2w] \\ match_mp_tac (IMP_memory_rel_Number_num3 |> SIMP_RULE std_ss [WORD_MUL_LSL,word_mul_n2w]) \\ fs [] - \\ fs[good_dimindex_def]); + \\ fs[good_dimindex_def] +QED -Theorem assign_Length - `op = Length ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_Length: + op = Length ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -6211,11 +6420,13 @@ Theorem assign_Length \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ match_mp_tac memory_rel_insert \\ fs [] \\ fs [decode_length_def] - \\ match_mp_tac IMP_memory_rel_Number_num \\ fs []); + \\ match_mp_tac IMP_memory_rel_Number_num \\ fs [] +QED -Theorem assign_LengthBlock - `op = LengthBlock ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_LengthBlock: + op = LengthBlock ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -6260,10 +6471,11 @@ Theorem assign_LengthBlock \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ match_mp_tac memory_rel_insert \\ fs [] \\ fs [decode_length_def] - \\ match_mp_tac IMP_memory_rel_Number_num \\ fs []) + \\ match_mp_tac IMP_memory_rel_Number_num \\ fs [] +QED -Theorem assign_BoundsCheckBlock - `assign c secn l dest BoundsCheckBlock args names = +Theorem assign_BoundsCheckBlock: + assign c secn l dest BoundsCheckBlock args names = case args of | [v1;v2] => (list_Seq [If Test (adjust_var v1) (Imm 1w) (Assign 1 (Const 0w)) @@ -6276,12 +6488,15 @@ Theorem assign_BoundsCheckBlock If Lower 3 (Reg 1) (Assign (adjust_var dest) TRUE_CONST) (Assign (adjust_var dest) FALSE_CONST)],l) - | _ => (Skip:'a wordLang$prog,l)` - (fs [assign_def] \\ every_case_tac \\ fs []) ; - -Theorem assign_BoundsCheckBlock - `op = BoundsCheckBlock ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] + | _ => (Skip:'a wordLang$prog,l) +Proof + fs [assign_def] \\ every_case_tac \\ fs [] +QED ; + +Theorem assign_BoundsCheckBlock: + op = BoundsCheckBlock ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -6343,10 +6558,11 @@ Theorem assign_BoundsCheckBlock \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ match_mp_tac memory_rel_insert \\ fs [] \\ TRY (match_mp_tac memory_rel_Boolv_T \\ fs []) - \\ TRY (match_mp_tac memory_rel_Boolv_F \\ fs [])); + \\ TRY (match_mp_tac memory_rel_Boolv_F \\ fs []) +QED -Theorem assign_BoundsCheckArray - `assign c secn l dest BoundsCheckArray args names = +Theorem assign_BoundsCheckArray: + assign c secn l dest BoundsCheckArray args names = case args of | [v1;v2] => (list_Seq [Assign 1 (let addr = real_addr c (adjust_var v1) in @@ -6357,12 +6573,15 @@ Theorem assign_BoundsCheckArray If Lower 3 (Reg 1) (Assign (adjust_var dest) TRUE_CONST) (Assign (adjust_var dest) FALSE_CONST)],l) - | _ => (Skip:'a wordLang$prog,l)` - (fs [assign_def] \\ every_case_tac \\ fs []) ; - -Theorem assign_BoundsCheckArray - `op = BoundsCheckArray ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] + | _ => (Skip:'a wordLang$prog,l) +Proof + fs [assign_def] \\ every_case_tac \\ fs [] +QED ; + +Theorem assign_BoundsCheckArray: + op = BoundsCheckArray ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -6412,10 +6631,11 @@ Theorem assign_BoundsCheckArray \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ match_mp_tac memory_rel_insert \\ fs [] \\ TRY (match_mp_tac memory_rel_Boolv_T \\ fs []) - \\ TRY (match_mp_tac memory_rel_Boolv_F \\ fs [])); + \\ TRY (match_mp_tac memory_rel_Boolv_F \\ fs []) +QED -Theorem assign_BoundsCheckByte - `assign c secn l dest (BoundsCheckByte leq) args names = +Theorem assign_BoundsCheckByte: + assign c secn l dest (BoundsCheckByte leq) args names = case args of | [v1;v2] => (list_Seq [Assign 1 (let addr = real_addr c (adjust_var v1) in @@ -6429,12 +6649,15 @@ Theorem assign_BoundsCheckByte If Lower 3 (Reg 1)) (Assign (adjust_var dest) TRUE_CONST) (Assign (adjust_var dest) FALSE_CONST)],l) - | _ => (Skip:'a wordLang$prog,l)` - (fs [assign_def] \\ every_case_tac \\ fs []); - -Theorem assign_BoundsCheckByte - `(?leq. op = BoundsCheckByte leq) ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] + | _ => (Skip:'a wordLang$prog,l) +Proof + fs [assign_def] \\ every_case_tac \\ fs [] +QED + +Theorem assign_BoundsCheckByte: + (?leq. op = BoundsCheckByte leq) ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -6486,20 +6709,24 @@ Theorem assign_BoundsCheckByte \\ match_mp_tac memory_rel_insert \\ fs [] \\ TRY (match_mp_tac memory_rel_Boolv_T \\ fs []) \\ TRY (match_mp_tac memory_rel_Boolv_F \\ fs []) - \\ fs [good_dimindex_def]); + \\ fs [good_dimindex_def] +QED -Theorem assign_LessConstSmall - `assign c secn l dest (LessConstSmall i) args names = +Theorem assign_LessConstSmall: + assign c secn l dest (LessConstSmall i) args names = case args of | [v1] => (If Less (adjust_var v1) (Imm (n2w (4 * i))) (Assign (adjust_var dest) TRUE_CONST) (Assign (adjust_var dest) FALSE_CONST),l) - | _ => (Skip:'a wordLang$prog,l)` - (fs [assign_def] \\ every_case_tac \\ fs []); - -Theorem assign_LessSmallConst - `(?i. op = LessConstSmall i) ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] + | _ => (Skip:'a wordLang$prog,l) +Proof + fs [assign_def] \\ every_case_tac \\ fs [] +QED + +Theorem assign_LessSmallConst: + (?i. op = LessConstSmall i) ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -6532,10 +6759,11 @@ Theorem assign_LessSmallConst \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ match_mp_tac memory_rel_insert \\ fs [] \\ TRY (match_mp_tac memory_rel_Boolv_T \\ fs []) - \\ TRY (match_mp_tac memory_rel_Boolv_F \\ fs [])); + \\ TRY (match_mp_tac memory_rel_Boolv_F \\ fs []) +QED -Theorem Compare1_code_thm - `!l a1 a2 dm m res (t:('a,'c,'ffi) wordSem$state). +Theorem Compare1_code_thm: + !l a1 a2 dm m res (t:('a,'c,'ffi) wordSem$state). word_cmp_loop l a1 a2 dm m = SOME res /\ dm = t.mdomain /\ m = t.memory /\ @@ -6549,8 +6777,9 @@ Theorem Compare1_code_thm evaluate (Compare1_code,t) = (SOME (Result (Loc l1 l2) (Word res)), t with <| clock := ck; locals := LN |>) /\ - t.clock <= w2n l + ck` - (ho_match_mp_tac word_cmp_loop_ind \\ rw [] + t.clock <= w2n l + ck +Proof + ho_match_mp_tac word_cmp_loop_ind \\ rw [] \\ qpat_assum `_ = SOME res` mp_tac \\ once_rewrite_tac [word_cmp_loop_def,Compare1_code_def] \\ IF_CASES_TAC \\ fs [] \\ strip_tac \\ rveq @@ -6582,21 +6811,24 @@ Theorem Compare1_code_thm \\ strip_tac \\ fs [wordSemTheory.state_component_equality] \\ unabbrev_all_tac \\ fs [wordSemTheory.dec_clock_def,lookup_insert] \\ Cases_on `l` \\ fs [] - \\ Cases_on `n` \\ fs [ADD1,GSYM word_add_n2w]); + \\ Cases_on `n` \\ fs [ADD1,GSYM word_add_n2w] +QED -Theorem word_exp_insert - `(m <> n ==> +Theorem word_exp_insert: + (m <> n ==> (word_exp (t with locals := insert n w t.locals) (real_addr c m) = word_exp t (real_addr c m))) /\ (~(m IN {n;n1}) ==> (word_exp (t with locals := insert n w (insert n1 w1 t.locals)) (real_addr c m) = - word_exp t (real_addr c m)))` - (fs [wordSemTheory.word_exp_def,real_addr_def] + word_exp t (real_addr c m))) +Proof + fs [wordSemTheory.word_exp_def,real_addr_def] \\ IF_CASES_TAC \\ fs [] - \\ fs [wordSemTheory.word_exp_def,real_addr_def] \\ fs [lookup_insert]); + \\ fs [wordSemTheory.word_exp_def,real_addr_def] \\ fs [lookup_insert] +QED -Theorem Compare_code_thm - `memory_rel c be refs sp st m dm +Theorem Compare_code_thm: + memory_rel c be refs sp st m dm ((Number i1,Word v1)::(Number i2,Word v2)::vars) /\ dm = (t:('a,'c,'ffi) wordSem$state).mdomain /\ m = t.memory /\ @@ -6614,8 +6846,9 @@ Theorem Compare_code_thm ?ck. evaluate (Compare_code c,t) = (SOME (Result (Loc l1 l2) (Word (word_cmp_res i1 i2))), - t with <| clock := ck; locals := LN |>)` - (rw [] \\ drule0 memory_rel_Number_cmp + t with <| clock := ck; locals := LN |>) +Proof + rw [] \\ drule0 memory_rel_Number_cmp \\ fs [] \\ strip_tac \\ fs [] \\ pop_assum mp_tac \\ IF_CASES_TAC THEN1 fs [] @@ -6689,45 +6922,57 @@ Theorem Compare_code_thm \\ eval_tac \\ fs [wordSemTheory.get_var_imm_def,asmTheory.word_cmp_def, wordSemTheory.get_var_def,lookup_insert,wordSemTheory.call_env_def, fromList2_def,wordSemTheory.state_component_equality,word_bit_test, - word_exp_insert,GSYM decode_length_def]); - -Theorem word_cmp_Less_word_cmp_res - `!i i'. good_dimindex (:'a) ==> - (word_cmp Less (word_cmp_res i i') (1w:'a word) <=> i < i')` - (rw [] \\ fs [labPropsTheory.good_dimindex_def] + word_exp_insert,GSYM decode_length_def] +QED + +Theorem word_cmp_Less_word_cmp_res: + !i i'. good_dimindex (:'a) ==> + (word_cmp Less (word_cmp_res i i') (1w:'a word) <=> i < i') +Proof + rw [] \\ fs [labPropsTheory.good_dimindex_def] \\ fs [word_cmp_res_def,asmTheory.word_cmp_def] - \\ rw [] \\ fs [WORD_LT] \\ fs [word_msb_def,word_index,dimword_def]); + \\ rw [] \\ fs [WORD_LT] \\ fs [word_msb_def,word_index,dimword_def] +QED -Theorem word_cmp_NotLess_word_cmp_res - `!i i'. good_dimindex (:'a) ==> - (word_cmp NotLess (1w:'a word) (word_cmp_res i i') <=> (i <= i'))` - (rw [] \\ fs [labPropsTheory.good_dimindex_def] +Theorem word_cmp_NotLess_word_cmp_res: + !i i'. good_dimindex (:'a) ==> + (word_cmp NotLess (1w:'a word) (word_cmp_res i i') <=> (i <= i')) +Proof + rw [] \\ fs [labPropsTheory.good_dimindex_def] \\ fs [word_cmp_res_def,asmTheory.word_cmp_def] \\ rw [] \\ fs [WORD_LT] \\ fs [word_msb_def,word_index,dimword_def] - \\ intLib.COOPER_TAC); - -Theorem IMP_spt_eq - `wf t1 /\ wf t2 /\ (∀n. lookup n t1 = lookup n t2) ==> (t1 = t2)` - (metis_tac [spt_eq_thm]); - -Theorem env_to_list_cut_env_IMP - `env_to_list x t.permute = (l,permute) /\ cut_env y s = SOME x ==> - (fromAList l = x)` - (strip_tac \\ match_mp_tac IMP_spt_eq + \\ intLib.COOPER_TAC +QED + +Theorem IMP_spt_eq: + wf t1 /\ wf t2 /\ (∀n. lookup n t1 = lookup n t2) ==> (t1 = t2) +Proof + metis_tac [spt_eq_thm] +QED + +Theorem env_to_list_cut_env_IMP: + env_to_list x t.permute = (l,permute) /\ cut_env y s = SOME x ==> + (fromAList l = x) +Proof + strip_tac \\ match_mp_tac IMP_spt_eq \\ fs [wf_fromAList] \\ drule0 env_to_list_lookup_equiv \\ fs [lookup_fromAList] - \\ fs [wordSemTheory.cut_env_def] \\ rveq \\ rw []); + \\ fs [wordSemTheory.cut_env_def] \\ rveq \\ rw [] +QED -Theorem dimword_LESS_MustTerminate_limit - `good_dimindex (:'a) ==> dimword (:α) < MustTerminate_limit (:α) - 1` - (strip_tac \\ fs [wordSemTheory.MustTerminate_limit_def,dimword_def] +Theorem dimword_LESS_MustTerminate_limit: + good_dimindex (:'a) ==> dimword (:α) < MustTerminate_limit (:α) - 1 +Proof + strip_tac \\ fs [wordSemTheory.MustTerminate_limit_def,dimword_def] \\ match_mp_tac (DECIDE ``1 < n ==> n < (2 * n + k) - 1n``) - \\ fs [labPropsTheory.good_dimindex_def]); + \\ fs [labPropsTheory.good_dimindex_def] +QED -Theorem assign_Less - `op = Less ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_Less: + op = Less ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ strip_tac \\ imp_res_tac get_vars_IMP_LENGTH \\ fs [] \\ rw [] @@ -6857,11 +7102,13 @@ Theorem assign_Less (adjust_set x.locals) = inter t.locals (adjust_set x.locals)` \\ asm_simp_tac std_ss [] \\ fs [] \\ fs [lookup_inter_alt,SUBSET_DEF] - \\ rw [] \\ fs [domain_inter] \\ res_tac); + \\ rw [] \\ fs [domain_inter] \\ res_tac +QED -Theorem assign_LessEq - `op = LessEq ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_LessEq: + op = LessEq ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ strip_tac \\ imp_res_tac get_vars_IMP_LENGTH \\ fs [] \\ rw [] @@ -6995,30 +7242,35 @@ Theorem assign_LessEq (adjust_set x.locals) = inter t.locals (adjust_set x.locals)` \\ asm_simp_tac std_ss [] \\ fs [] \\ fs [lookup_inter_alt,SUBSET_DEF] - \\ rw [] \\ fs [domain_inter] \\ res_tac); - -Theorem cut_env_IMP_domain - `wordSem$cut_env x y = SOME t ==> domain t = domain x` - (fs [wordSemTheory.cut_env_def] \\ rw [] - \\ fs [SUBSET_DEF,EXTENSION,domain_inter] \\ metis_tac []); - -Theorem word_exp_set_var_ShiftVar - `word_exp (set_var v (Word w) t) (ShiftVar sow v n) = + \\ rw [] \\ fs [domain_inter] \\ res_tac +QED + +Theorem cut_env_IMP_domain: + wordSem$cut_env x y = SOME t ==> domain t = domain x +Proof + fs [wordSemTheory.cut_env_def] \\ rw [] + \\ fs [SUBSET_DEF,EXTENSION,domain_inter] \\ metis_tac [] +QED + +Theorem word_exp_set_var_ShiftVar: + word_exp (set_var v (Word w) t) (ShiftVar sow v n) = OPTION_MAP Word (case sow of Lsl => SOME (w << n) | Lsr => SOME (w >>> n) | Asr => SOME (w >> n) - | Ror => SOME (word_ror w n))` - (once_rewrite_tac [word_exp_set_var_ShiftVar_lemma] - \\ eval_tac \\ fs [lookup_insert] \\ fs []); - -Theorem MemEqList_thm - `!offset t xs dm m b a. + | Ror => SOME (word_ror w n)) +Proof + once_rewrite_tac [word_exp_set_var_ShiftVar_lemma] + \\ eval_tac \\ fs [lookup_insert] \\ fs [] +QED + +Theorem MemEqList_thm = Q.prove(` + !offset t xs dm m b a. word_mem_eq (a + offset) xs dm m = SOME b /\ get_var 3 t = SOME (Word a) /\ dm = t.mdomain /\ m = t.memory ==> ?x. evaluate (MemEqList offset xs,t) = (NONE,t with locals := ((if b then insert 1 (Word 18w) else I) o - (if xs <> [] then insert 5 x else I)) t.locals)` - (Induct_on `xs` + (if xs <> [] then insert 5 x else I)) t.locals)`, + Induct_on `xs` THEN1 (fs [MemEqList_def,eq_eval,word_mem_eq_def]) \\ fs [word_mem_eq_def] \\ rpt strip_tac @@ -7038,9 +7290,10 @@ Theorem MemEqList_thm \\ metis_tac []) |> Q.SPEC `0w` |> SIMP_RULE std_ss [WORD_ADD_0]; -Theorem assign_EqualInt - `(?i. op = EqualInt i) ==> ^assign_thm_goal` - (rpt strip_tac \\ rveq \\ fs [] +Theorem assign_EqualInt: + (?i. op = EqualInt i) ==> ^assign_thm_goal +Proof + rpt strip_tac \\ rveq \\ fs [] \\ rpt_drule0 state_rel_cut_IMP \\ strip_tac \\ imp_res_tac get_vars_IMP_LENGTH \\ fs [] \\ rw [] \\ fs [do_app] \\ rfs [] \\ every_case_tac \\ fs [] @@ -7118,10 +7371,11 @@ Theorem assign_EqualInt \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ match_mp_tac memory_rel_insert \\ fs [] \\ TRY (match_mp_tac memory_rel_Boolv_T \\ fs []) - \\ TRY (match_mp_tac memory_rel_Boolv_F \\ fs [])); + \\ TRY (match_mp_tac memory_rel_Boolv_F \\ fs []) +QED -Theorem Equal_code_lemma - `(!c st dm m l v1 v2 t l1 l2 q1 q2 res l'. +Theorem Equal_code_lemma: + (!c st dm m l v1 v2 t l1 l2 q1 q2 res l'. word_eq c st dm m l v1 v2 = SOME (res,l') /\ dm = (t:('a,'c,'ffi) wordSem$state).mdomain /\ m = t.memory /\ @@ -7163,8 +7417,9 @@ Theorem Equal_code_lemma evaluate (Equal1_code,t) = (SOME (Result (Loc l1 l2) (Word res)), t with <| clock := ck; locals := LN; permute := new_p |>) /\ - l' <= ck)` - (ho_match_mp_tac word_eq_ind \\ reverse (rpt strip_tac) \\ rveq + l' <= ck) +Proof + ho_match_mp_tac word_eq_ind \\ reverse (rpt strip_tac) \\ rveq \\ qpat_x_assum `_ = SOME (res,_)` mp_tac \\ once_rewrite_tac [word_eq_def] THEN1 @@ -7369,10 +7624,11 @@ Theorem Equal_code_lemma \\ first_x_assum (qspecl_then [`t8`,`l1`,`l2`] mp_tac) \\ impl_tac THEN1 (unabbrev_all_tac \\ fs [eq_eval]) \\ strip_tac \\ fs [] - \\ fs [Abbr`t8`,wordSemTheory.state_component_equality]); + \\ fs [Abbr`t8`,wordSemTheory.state_component_equality] +QED -Theorem Equal_code_thm - `memory_rel c be refs sp st m dm ((q1,Word v1)::(q2,Word v2)::vars) /\ +Theorem Equal_code_thm: + memory_rel c be refs sp st m dm ((q1,Word v1)::(q2,Word v2)::vars) /\ word_eq c st dm m l v1 v2 = SOME (res,l') /\ dm = (t:('a,'c,'ffi) wordSem$state).mdomain /\ m = t.memory /\ @@ -7392,14 +7648,17 @@ Theorem Equal_code_thm evaluate (Equal_code c,t) = (SOME (Result (Loc l1 l2) (Word res)), t with <| clock := ck; locals := LN; permute := new_p |>) /\ - l' <= ck` - (strip_tac + l' <= ck +Proof + strip_tac \\ match_mp_tac (Equal_code_lemma |> CONJUNCT1) - \\ fs [] \\ asm_exists_tac \\ fs []); + \\ fs [] \\ asm_exists_tac \\ fs [] +QED -Theorem assign_Equal - `op = Equal ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_Equal: + op = Equal ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ strip_tac \\ imp_res_tac get_vars_IMP_LENGTH \\ fs [] \\ rw [] @@ -7541,11 +7800,13 @@ Theorem assign_Equal (adjust_set x.locals) = inter t.locals (adjust_set x.locals)` \\ asm_simp_tac std_ss [] \\ fs [] \\ fs [lookup_inter_alt,SUBSET_DEF] - \\ rw [] \\ fs [domain_inter] \\ res_tac); + \\ rw [] \\ fs [domain_inter] \\ res_tac +QED -Theorem assign_WordOpW8 - `(?opw. op = WordOp W8 opw) ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_WordOpW8: + (?opw. op = WordOp W8 opw) ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -7707,36 +7968,41 @@ Theorem assign_WordOpW8 \\ fs[Abbr`i`,small_int_def] \\ qmatch_goalsub_rename_tac`w2n w` \\ Q.ISPEC_THEN`w`mp_tac w2n_lt - \\ fs[good_dimindex_def,dimword_def] )); + \\ fs[good_dimindex_def,dimword_def] ) +QED val assign_WordOp64 = ``assign c n l dest (WordOp W64 opw) [e1; e2] names_opt`` |> SIMP_CONV (srw_ss()) [assign_def] -Theorem mw2n_2_IMP - `mw2n [w1;w2:'a word] = n ==> +Theorem mw2n_2_IMP: + mw2n [w1;w2:'a word] = n ==> w2 = n2w (n DIV dimword (:'a)) /\ - w1 = n2w n` - (fs [multiwordTheory.mw2n_def] \\ rw [] + w1 = n2w n +Proof + fs [multiwordTheory.mw2n_def] \\ rw [] \\ Cases_on `w1` \\ Cases_on `w2` \\ fs [] \\ once_rewrite_tac [ADD_COMM] - \\ asm_simp_tac std_ss [DIV_MULT]); + \\ asm_simp_tac std_ss [DIV_MULT] +QED -Theorem IMP_mw2n_2 - `Abbrev (x2 = (63 >< 32) (n2w n:word64)) /\ +Theorem IMP_mw2n_2: + Abbrev (x2 = (63 >< 32) (n2w n:word64)) /\ Abbrev (x1 = (31 >< 0) (n2w n:word64)) /\ n < dimword (:64) /\ dimindex (:'a) = 32 ==> - mw2n [x1;x2:'a word] = n` - (fs [markerTheory.Abbrev_def] + mw2n [x1;x2:'a word] = n +Proof + fs [markerTheory.Abbrev_def] \\ rw [multiwordTheory.mw2n_def] \\ fs [word_extract_n2w] \\ fs [bitTheory.BITS_THM2,dimword_def] \\ fs [DIV_MOD_MOD_DIV] \\ once_rewrite_tac [EQ_SYM_EQ] - \\ simp [Once (MATCH_MP DIVISION (DECIDE ``0 < 4294967296n``))]); + \\ simp [Once (MATCH_MP DIVISION (DECIDE ``0 < 4294967296n``))] +QED -Theorem evaluate_WordOp64_on_32 - `!l. +Theorem evaluate_WordOp64_on_32: + !l. dimindex (:'a) = 32 ==> ?w27 w29. evaluate @@ -7755,8 +8021,9 @@ Theorem evaluate_WordOp64_on_32 (insert 23 (Word ((31 >< 0) c'')) (insert 21 (Word ((63 >< 32) c'')) (insert 13 (Word ((31 >< 0) c')) - (insert 11 (Word ((63 >< 32) c')) l))))))))` - (Cases_on `opw` + (insert 11 (Word ((63 >< 32) c')) l)))))))) +Proof + Cases_on `opw` \\ fs [WordOp64_on_32_def,semanticPrimitivesPropsTheory.opw_lookup_def, list_Seq_def] \\ eval_tac \\ fs [lookup_insert] @@ -7869,11 +8136,13 @@ Theorem evaluate_WordOp64_on_32 THEN1 fs [] \\ Cases_on `c` \\ fs [multiwordTheory.b2n_def] \\ `n' <= n` by decide_tac - \\ fs [LESS_EQ_EXISTS]); + \\ fs [LESS_EQ_EXISTS] +QED -Theorem assign_WordOpW64 - `(?opw. op = WordOp W64 opw) ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_WordOpW64: + (?opw. op = WordOp W64 opw) ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -7979,11 +8248,13 @@ Theorem assign_WordOpW64 \\ strip_tac \\ fs [] \\ fs[FAPPLY_FUPDATE_THM] \\ fs [consume_space_def] - \\ rveq \\ fs [] \\ rw [] \\ fs [code_oracle_rel_def,FLOOKUP_UPDATE]); + \\ rveq \\ fs [] \\ rw [] \\ fs [code_oracle_rel_def,FLOOKUP_UPDATE] +QED -Theorem assign_WordShiftW8 - `(?sh n. op = WordShift W8 sh n) ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_WordShiftW8: + (?sh n. op = WordShift W8 sh n) ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -8233,14 +8504,15 @@ Theorem assign_WordShiftW8 \\ strip_tac \\ fs [] \\ drule0 (DECIDE ``n < 8n ==> n=0 \/ n=1 \/ n=2 \/ n=3 \/ n=4 \/ n=5 \/ n=6 \/ n=7``) - \\ strip_tac \\ fs [w2w]))); + \\ strip_tac \\ fs [w2w])) +QED val assign_WordShift64 = ``assign c n l dest (WordShift W64 sh n) [e1] names_opt`` |> SIMP_CONV (srw_ss()) [assign_def] -Theorem evaluate_WordShift64_on_32 - `!l. +Theorem evaluate_WordShift64_on_32: + !l. dimindex (:'a) = 32 ==> evaluate (WordShift64_on_32 sh n, @@ -8252,8 +8524,9 @@ Theorem evaluate_WordShift64_on_32 insert 31 (Word ((63 >< 32) (shift_lookup sh c' n))) (insert 33 (Word ((31 >< 0) (shift_lookup sh (c':word64) n))) (insert 13 (Word ((31 >< 0) c')) - (insert 11 (Word ((63 >< 32) c')) l))))` - (ntac 2 strip_tac \\ Cases_on `sh = Ror` + (insert 11 (Word ((63 >< 32) c')) l)))) +Proof + ntac 2 strip_tac \\ Cases_on `sh = Ror` THEN1 (simp [WordShift64_on_32_def] \\ TOP_CASE_TAC \\ fs [list_Seq_def] \\ eval_tac @@ -8329,11 +8602,13 @@ Theorem evaluate_WordShift64_on_32 THEN1 (Cases_on `n <= i` \\ fs [] \\ fs [fcpTheory.FCP_BETA,w2w]) THEN1 (Cases_on `i + n < 32` \\ fs [fcpTheory.FCP_BETA,w2w]) THEN1 (Cases_on `i + n < 32` \\ fs [fcpTheory.FCP_BETA,w2w]) - THEN1 (Cases_on `i + n < 32` \\ fs [fcpTheory.FCP_BETA,w2w])); + THEN1 (Cases_on `i + n < 32` \\ fs [fcpTheory.FCP_BETA,w2w]) +QED -Theorem assign_WordShiftW64 - `(?sh n. op = WordShift W64 sh n) ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_WordShiftW64: + (?sh n. op = WordShift W64 sh n) ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -8454,7 +8729,8 @@ Theorem assign_WordShiftW64 \\ rveq \\ fs [] \\ rw [] \\ fs [] \\ qpat_x_assum `code_oracle_rel _ _ _ _ _ _ _ _` mp_tac \\ rpt (pop_assum kall_tac) - \\ fs [code_oracle_rel_def,FLOOKUP_UPDATE]); + \\ fs [code_oracle_rel_def,FLOOKUP_UPDATE] +QED val assign_FP_cmp = SIMP_CONV (srw_ss()) [assign_def] ``((assign (c:data_to_word$config) (secn:num) (l:num) (dest:num) (FP_cmp fpc) @@ -8468,30 +8744,38 @@ val assign_FP_uop = SIMP_CONV (srw_ss()) [assign_def] ``((assign (c:data_to_word$config) (secn:num) (l:num) (dest:num) (FP_uop fpu) (args:num list) (names:num_set option)):'a wordLang$prog # num)``; -Theorem w2w_select_id - `dimindex (:'a) = 64 ==> - ((w2w:'a word -> word64) ((63 >< 0) w)) = w` - (Cases_on `w` - \\ fs [wordsTheory.word_extract_n2w,bitTheory.BITS_THM,w2w_def,dimword_def]); - -Theorem extract_append_id - `dimindex (:'a) = 32 ==> - ((((63 >< 32) w):'a word) @@ (((31 >< 0) w):'a word)) = w:word64` - (fs [fcpTheory.CART_EQ,word_concat_def,word_join_def,w2w,word_or_def, +Theorem w2w_select_id: + dimindex (:'a) = 64 ==> + ((w2w:'a word -> word64) ((63 >< 0) w)) = w +Proof + Cases_on `w` + \\ fs [wordsTheory.word_extract_n2w,bitTheory.BITS_THM,w2w_def,dimword_def] +QED + +Theorem extract_append_id: + dimindex (:'a) = 32 ==> + ((((63 >< 32) w):'a word) @@ (((31 >< 0) w):'a word)) = w:word64 +Proof + fs [fcpTheory.CART_EQ,word_concat_def,word_join_def,w2w,word_or_def, fcpTheory.FCP_BETA,w2w] \\ rw [] \\ `FINITE 𝕌(:α)` by (CCONTR_TAC \\ fs [fcpTheory.dimindex_def]) \\ `dimindex (:'a + 'a) = 64` by fs [fcpTheory.index_sum] \\ fs [fcpTheory.FCP_BETA,w2w,word_lsl_def,word_extract_def,word_bits_def] \\ Cases_on `i < 32` \\ fs [] - \\ fs [fcpTheory.FCP_BETA,w2w,word_lsl_def,word_extract_def,word_bits_def]); + \\ fs [fcpTheory.FCP_BETA,w2w,word_lsl_def,word_extract_def,word_bits_def] +QED -Theorem word1_cases - `!w:word1. w = 0w \/ w = 1w` - (Cases \\ fs [dimword_def]); +Theorem word1_cases: + !w:word1. w = 0w \/ w = 1w +Proof + Cases \\ fs [dimword_def] +QED -Theorem w2w_w2w_64 - `!w. dimindex (:'a) = 64 ==> w2w ((w2w w):'a word) = w:word64` - (Cases \\ fs [w2w_def,dimword_def]); +Theorem w2w_w2w_64: + !w. dimindex (:'a) = 64 ==> w2w ((w2w w):'a word) = w:word64 +Proof + Cases \\ fs [w2w_def,dimword_def] +QED val fp_greater = prove( ``fp64_greaterThan a b = fp64_lessThan b a /\ @@ -8509,9 +8793,10 @@ val fp_greater = prove( \\ metis_tac [realTheory.REAL_LT_ANTISYM, realTheory.REAL_LT_TOTAL,word1_cases]); -Theorem assign_FP_cmp - `(?fpc. op = FP_cmp fpc) ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_FP_cmp: + (?fpc. op = FP_cmp fpc) ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ imp_res_tac state_rel_cut_IMP \\ pop_assum mp_tac \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -8601,11 +8886,13 @@ Theorem assign_FP_cmp \\ rw [] \\ fs [WORD_MUL_LSL] \\ TRY (match_mp_tac memory_rel_Boolv_T) \\ TRY (match_mp_tac memory_rel_Boolv_F) - \\ fs []); + \\ fs [] +QED -Theorem assign_FP_bop - `(?fpb. op = FP_bop fpb) ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_FP_bop: + (?fpb. op = FP_bop fpb) ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ imp_res_tac state_rel_cut_IMP \\ pop_assum mp_tac \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -8700,11 +8987,13 @@ Theorem assign_FP_bop \\ disch_then (qspec_then `ww` mp_tac) \\ fs [] \\ TRY impl_tac \\ TRY (rw [] \\ NO_TAC) \\ strip_tac \\ fs [FAPPLY_FUPDATE_THM] - \\ rveq \\ fs [] \\ rw []); + \\ rveq \\ fs [] \\ rw [] +QED -Theorem assign_FP_uop - `(?fpu. op = FP_uop fpu) ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_FP_uop: + (?fpu. op = FP_uop fpu) ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ imp_res_tac state_rel_cut_IMP \\ pop_assum mp_tac \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -8779,11 +9068,13 @@ Theorem assign_FP_uop ORELSE qpat_abbrev_tac `ww = fp64_sqrt _ _`) \\ disch_then (qspec_then `ww` mp_tac) \\ fs [] \\ strip_tac \\ fs [FAPPLY_FUPDATE_THM] - \\ rveq \\ fs [] \\ rw []); + \\ rveq \\ fs [] \\ rw [] +QED -Theorem assign_Label - `(?lab. op = Label lab) ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_Label: + (?lab. op = Label lab) ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -8804,22 +9095,26 @@ Theorem assign_Label \\ rw [] \\ fs [] \\ rw [] \\ fs [] \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ match_mp_tac memory_rel_insert \\ fs [] - \\ match_mp_tac memory_rel_CodePtr \\ fs []); + \\ match_mp_tac memory_rel_CodePtr \\ fs [] +QED -Theorem do_app_Ref - `do_app Ref vals x = +Theorem do_app_Ref: + do_app Ref vals x = case consume_space (LENGTH vals + 1) x of NONE => Rerr (Rabort Rtype_error) | SOME s1 => Rval (RefPtr (LEAST ptr. ptr ∉ FDOM s1.refs), s1 with - refs := (s1.refs |+ ((LEAST ptr. ptr ∉ FDOM s1.refs),ValueArray vals)))` - (fs [do_app] \\ Cases_on `vals` \\ fs [LET_THM]); - -Theorem assign_Ref - `op = Ref ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] + refs := (s1.refs |+ ((LEAST ptr. ptr ∉ FDOM s1.refs),ValueArray vals))) +Proof + fs [do_app] \\ Cases_on `vals` \\ fs [LET_THM] +QED + +Theorem assign_Ref: + op = Ref ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -8864,11 +9159,13 @@ Theorem assign_Ref \\ match_mp_tac memory_rel_insert \\ fs [] \\ fs [make_ptr_def] \\ `TriggerGC <> EndOfHeap` by fs [] - \\ pop_assum (fn th => fs [MATCH_MP FUPDATE_COMMUTES th])); + \\ pop_assum (fn th => fs [MATCH_MP FUPDATE_COMMUTES th]) +QED -Theorem assign_Update - `op = Update ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_Update: + op = Update ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -8900,11 +9197,13 @@ Theorem assign_Update \\ match_mp_tac memory_rel_insert \\ fs [] \\ match_mp_tac memory_rel_Unit \\ fs [] \\ first_x_assum (fn th => mp_tac th THEN match_mp_tac memory_rel_rearrange) - \\ rw [] \\ fs []); + \\ rw [] \\ fs [] +QED -Theorem assign_Deref - `op = Deref ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_Deref: + op = Deref ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -8931,11 +9230,13 @@ Theorem assign_Deref \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ match_mp_tac memory_rel_insert \\ fs [] \\ first_x_assum (fn th => mp_tac th THEN match_mp_tac memory_rel_rearrange) - \\ fs [] \\ rw [] \\ fs []); + \\ fs [] \\ rw [] \\ fs [] +QED -Theorem assign_UpdateByte - `op = UpdateByte ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_UpdateByte: + op = UpdateByte ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -9033,11 +9334,13 @@ Theorem assign_UpdateByte \\ simp[WORD_ALL_BITS] \\ drule0 memory_rel_tl \\ simp[] \\ strip_tac \\ drule0 memory_rel_tl \\ simp[] \\ strip_tac - \\ drule0 memory_rel_tl \\ simp[]); + \\ drule0 memory_rel_tl \\ simp[] +QED -Theorem assign_DerefByte - `op = DerefByte ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_DerefByte: + op = DerefByte ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -9120,11 +9423,13 @@ Theorem assign_DerefByte \\ simp[w2w_def] ) \\ simp[] \\ match_mp_tac IMP_memory_rel_Number - \\ fs[]); + \\ fs[] +QED -Theorem assign_El - `op = El ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_El: + op = El ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -9151,11 +9456,13 @@ Theorem assign_El \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ match_mp_tac memory_rel_insert \\ fs [] \\ first_x_assum (fn th => mp_tac th THEN match_mp_tac memory_rel_rearrange) - \\ fs [] \\ rw [] \\ fs []); + \\ fs [] \\ rw [] \\ fs [] +QED -Theorem assign_Const - `(?i. op = Const i) ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_Const: + (?i. op = Const i) ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -9172,11 +9479,13 @@ Theorem assign_Const \\ match_mp_tac word_ml_inv_insert \\ fs [] \\ TRY (match_mp_tac word_ml_inv_zero) \\ fs [] \\ TRY (match_mp_tac word_ml_inv_num) \\ fs [] - \\ TRY (match_mp_tac word_ml_inv_neg_num) \\ fs []); + \\ TRY (match_mp_tac word_ml_inv_neg_num) \\ fs [] +QED -Theorem assign_GlobalsPtr - `op = GlobalsPtr ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_GlobalsPtr: + op = GlobalsPtr ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -9193,11 +9502,13 @@ Theorem assign_GlobalsPtr \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ match_mp_tac word_ml_inv_insert \\ fs [] \\ first_x_assum (fn th => mp_tac th THEN match_mp_tac word_ml_inv_rearrange) - \\ fs [] \\ rw [] \\ fs []); + \\ fs [] \\ rw [] \\ fs [] +QED -Theorem assign_SetGlobalsPtr - `op = SetGlobalsPtr ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_SetGlobalsPtr: + op = SetGlobalsPtr ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -9228,11 +9539,14 @@ Theorem assign_SetGlobalsPtr \\ match_mp_tac word_ml_inv_insert \\ fs [] \\ match_mp_tac word_ml_inv_Unit \\ pop_assum mp_tac \\ fs [] - \\ match_mp_tac word_ml_inv_rearrange \\ rw [] \\ fs []) + \\ match_mp_tac word_ml_inv_rearrange \\ rw [] \\ fs [] +QED -Theorem IMP - `b1 \/ b2 <=> ~b1 ==> b2` - (Cases_on `b1` \\ Cases_on `b2` \\ fs []); +Theorem IMP: + b1 \/ b2 <=> ~b1 ==> b2 +Proof + Cases_on `b1` \\ Cases_on `b2` \\ fs [] +QED val memcopy_def = Define ` memcopy k a1 a2 m dm = @@ -9241,8 +9555,8 @@ val memcopy_def = Define ` memcopy (k-1) (a1+bytes_in_word) (a2+bytes_in_word) ((a2 =+ m a1) m) dm else NONE` -Theorem MemCopy_thm - `!ret_val l1 l2 k a1 a2 (s:('a,'c,'ffi) wordSem$state) m dm m1. +Theorem MemCopy_thm: + !ret_val l1 l2 k a1 a2 (s:('a,'c,'ffi) wordSem$state) m dm m1. memcopy k a1 a2 m dm = SOME m1 /\ s.memory = m /\ s.mdomain = dm /\ lookup MemCopy_location s.code = SOME (5,MemCopy_code) /\ @@ -9255,8 +9569,9 @@ Theorem MemCopy_thm evaluate (MemCopy_code,s) = (SOME (Result (Loc l1 l2) ret_val), s with <| clock := s.clock - k ; - memory := m1 ; locals := LN |>)` - (ntac 3 gen_tac + memory := m1 ; locals := LN |>) +Proof + ntac 3 gen_tac \\ Induct \\ simp [Once memcopy_def] \\ rw [] \\ simp [MemCopy_code_def] \\ fs [eq_eval] THEN1 (fs [wordSemTheory.state_component_equality]) @@ -9267,26 +9582,30 @@ Theorem MemCopy_thm \\ qmatch_goalsub_abbrev_tac `(MemCopy_code,s5)` \\ first_x_assum (qspecl_then [`a1 + bytes_in_word`, `a2 + bytes_in_word`,`s5`] mp_tac) - \\ qunabbrev_tac `s5` \\ fs [lookup_insert,ADD1]); + \\ qunabbrev_tac `s5` \\ fs [lookup_insert,ADD1] +QED val assign_ConsExtend = save_thm("assign_ConsExtend", ``assign c n l dest (ConsExtend tag) args names_opt`` |> SIMP_CONV (srw_ss()) [assign_def]) -Theorem get_vars_IMP_domain - `!xs s y. +Theorem get_vars_IMP_domain: + !xs s y. get_vars xs s = SOME y ==> - EVERY (\x. x IN domain s) xs` - (Induct \\ fs [get_vars_SOME_IFF_data_eq] \\ rw [] - \\ fs [get_var_def,domain_lookup]); - -Theorem memory_rel_IMP_free_space - `memory_rel c be refs sp st m dm vars ==> + EVERY (\x. x IN domain s) xs +Proof + Induct \\ fs [get_vars_SOME_IFF_data_eq] \\ rw [] + \\ fs [get_var_def,domain_lookup] +QED + +Theorem memory_rel_IMP_free_space: + memory_rel c be refs sp st m dm vars ==> ?nfree curr other. FLOOKUP st NextFree = SOME (Word nfree) /\ FLOOKUP st CurrHeap = SOME (Word curr) /\ - (word_list_exists nfree sp * other) (fun2set (m,dm))` - (fs [memory_rel_def,heap_in_memory_store_def] \\ strip_tac + (word_list_exists nfree sp * other) (fun2set (m,dm)) +Proof + fs [memory_rel_def,heap_in_memory_store_def] \\ strip_tac \\ fs [word_ml_inv_def,abs_ml_inv_def,unused_space_inv_def] \\ Cases_on `sp = 0` THEN1 (fs [word_list_exists_def,SEP_CLAUSES,LENGTH_NIL,SEP_EXISTS_THM] @@ -9302,102 +9621,121 @@ Theorem memory_rel_IMP_free_space \\ full_simp_tac std_ss [word_list_exists_ADD] \\ qpat_abbrev_tac `aa = word_list_exists _ _` \\ fs [AC STAR_ASSOC STAR_COMM] - \\ asm_exists_tac \\ fs []); + \\ asm_exists_tac \\ fs [] +QED -Theorem IMP_store_list_SOME - `!ws a n m dm other. +Theorem IMP_store_list_SOME: + !ws a n m dm other. (word_list_exists a n * other) (fun2set (m,dm)) /\ LENGTH ws <= n ==> ∃m1. store_list a ws m dm = SOME m1 /\ (word_list a ws * word_list_exists (a + bytes_in_word * n2w (LENGTH ws)) (n - LENGTH ws) * - other) (fun2set (m1,dm))` - (Induct \\ fs [store_list_def,word_list_def,SEP_CLAUSES] \\ rw [] + other) (fun2set (m1,dm)) +Proof + Induct \\ fs [store_list_def,word_list_def,SEP_CLAUSES] \\ rw [] \\ Cases_on `n` \\ fs [word_list_exists_thm,SEP_CLAUSES,SEP_EXISTS_THM] \\ SEP_R_TAC \\ fs [] \\ SEP_W_TAC \\ SEP_F_TAC \\ fs [] \\ strip_tac \\ fs [] - \\ fs [AC STAR_COMM STAR_ASSOC,ADD1,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB]); + \\ fs [AC STAR_COMM STAR_ASSOC,ADD1,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] +QED -Theorem get_vars_cut_env - `!vs bs. +Theorem get_vars_cut_env: + !vs bs. dataSem$cut_env nms x1 = SOME x2 /\ dataSem$get_vars vs x1 = SOME bs /\ EVERY (\v. v IN domain nms) vs ==> - dataSem$get_vars vs x2 = SOME bs` - (Induct \\ fs [get_vars_def] \\ rw [] \\ fs [] + dataSem$get_vars vs x2 = SOME bs +Proof + Induct \\ fs [get_vars_def] \\ rw [] \\ fs [] \\ every_case_tac \\ fs [] \\ rveq \\ fs [] \\ fs [cut_env_def] \\ rveq - \\ fs [get_var_def,lookup_inter_alt]); + \\ fs [get_var_def,lookup_inter_alt] +QED -Theorem word_exp_real_addr_some_value - `FLOOKUP s3.store CurrHeap = SOME (Word curr) /\ +Theorem word_exp_real_addr_some_value: + FLOOKUP s3.store CurrHeap = SOME (Word curr) /\ get_var a s3 = SOME (Word ww) /\ good_dimindex (:'a) /\ shift_length c < dimindex (:'a) ==> - ∃wx. word_exp (s3:('a,'c,'ffi) wordSem$state) (real_addr c a) = SOME (Word wx)` - (rw [real_addr_def] \\ fs [eq_eval] \\ eval_tac + ∃wx. word_exp (s3:('a,'c,'ffi) wordSem$state) (real_addr c a) = SOME (Word wx) +Proof + rw [real_addr_def] \\ fs [eq_eval] \\ eval_tac \\ IF_CASES_TAC \\ fs [NOT_LESS] \\ fs [GSYM NOT_LESS] - \\ fs [good_dimindex_def] \\ rfs [shift_def]); + \\ fs [good_dimindex_def] \\ rfs [shift_def] +QED -Theorem store_list_APPEND - `!xs ys a m. +Theorem store_list_APPEND: + !xs ys a m. store_list a (xs ++ ys) m dm = case store_list a xs m dm of | NONE => NONE - | SOME m1 => store_list (a + bytes_in_word * n2w (LENGTH xs)) ys m1 dm` - (Induct \\ fs [store_list_def] + | SOME m1 => store_list (a + bytes_in_word * n2w (LENGTH xs)) ys m1 dm +Proof + Induct \\ fs [store_list_def] \\ rw [] \\ fs [] \\ every_case_tac \\ fs [] - \\ fs [GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB,ADD1]); + \\ fs [GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB,ADD1] +QED -Theorem memory_rel_store_list_to_unused - `!ws2 m dm m1. +Theorem memory_rel_store_list_to_unused: + !ws2 m dm m1. memory_rel c be refs n st m dm vars /\ store_list nfree ws2 m dm = SOME m1 /\ FLOOKUP st NextFree = SOME (Word nfree) /\ LENGTH ws2 <= n ==> - memory_rel c be refs n st m1 dm vars` - (ho_match_mp_tac SNOC_INDUCT \\ rw [] \\ fs [store_list_def] + memory_rel c be refs n st m1 dm vars +Proof + ho_match_mp_tac SNOC_INDUCT \\ rw [] \\ fs [store_list_def] \\ fs [SNOC_APPEND] \\ fs [store_list_APPEND] \\ every_case_tac \\ fs [] \\ res_tac \\ rfs [] \\ fs [store_list_def] \\ rveq \\ fs [] - \\ rpt_drule0 memory_rel_write \\ fs []); + \\ rpt_drule0 memory_rel_write \\ fs [] +QED -Theorem get_vars_delete_lemma - `!t7. get_vars (MAP adjust_var t7) +Theorem get_vars_delete_lemma: + !t7. get_vars (MAP adjust_var t7) (s1 with locals := insert 9 x9 (insert 7 x7 (insert 5 x5 (insert 1 x1 s1.locals)))) = - get_vars (MAP adjust_var t7) s1` - (Induct \\ fs [wordSemTheory.get_vars_def,wordSemTheory.get_var_def,eq_eval]); - -Theorem cut_env_adjust_set_insert_ODD - `ODD n ==> cut_env (adjust_set the_names) (insert n w s) = - cut_env (adjust_set the_names) s` - (reverse (rw [wordSemTheory.cut_env_def] \\ fs [SUBSET_DEF]) + get_vars (MAP adjust_var t7) s1 +Proof + Induct \\ fs [wordSemTheory.get_vars_def,wordSemTheory.get_var_def,eq_eval] +QED + +Theorem cut_env_adjust_set_insert_ODD: + ODD n ==> cut_env (adjust_set the_names) (insert n w s) = + cut_env (adjust_set the_names) s +Proof + reverse (rw [wordSemTheory.cut_env_def] \\ fs [SUBSET_DEF]) \\ res_tac \\ fs [] THEN1 (rveq \\ fs [domain_lookup,lookup_adjust_set] \\ every_case_tac \\ fs []) \\ fs [lookup_inter_alt,lookup_insert] \\ rw [] \\ pop_assum mp_tac \\ simp [domain_lookup,lookup_adjust_set] - \\ rw [] \\ fs []); - -Theorem INTRO_IS_SOME - `(?v. x = SOME v) <=> IS_SOME x` - (Cases_on `x` \\ fs []); - -Theorem STAR_fun2set_IMP_SEP_T - `(p * q) (fun2set (m, dm)) ==> (p * SEP_T) (fun2set (m, dm))` - (qspec_tac (`fun2set (m, dm)`,`s`) + \\ rw [] \\ fs [] +QED + +Theorem INTRO_IS_SOME: + (?v. x = SOME v) <=> IS_SOME x +Proof + Cases_on `x` \\ fs [] +QED + +Theorem STAR_fun2set_IMP_SEP_T: + (p * q) (fun2set (m, dm)) ==> (p * SEP_T) (fun2set (m, dm)) +Proof + qspec_tac (`fun2set (m, dm)`,`s`) \\ fs [GSYM SEP_IMP_def] \\ CONV_TAC (DEPTH_CONV ETA_CONV) \\ match_mp_tac SEP_IMP_STAR \\ fs [SEP_IMP_REFL] - \\ EVAL_TAC \\ fs []); + \\ EVAL_TAC \\ fs [] +QED -Theorem IMP_memcopy_lemma - `memory_rel c s1.be x.refs sp s1.store m1 s1.mdomain +Theorem IMP_memcopy_lemma: + memory_rel c s1.be x.refs sp s1.store m1 s1.mdomain ((Block ts' n' l',Word w_ptr)::(ZIP (ys7,ws1) ++ vars)) /\ startptr < LENGTH l' /\ LENGTH ys7 = LENGTH ws1 /\ good_dimindex (:α) /\ lookup (adjust_var a1) s1.locals = SOME (Word (w_ptr:'a word)) /\ @@ -9406,8 +9744,9 @@ Theorem IMP_memcopy_lemma ((Block ts' n' l',Word w_ptr):: (ZIP (ys7 ++ [EL startptr l'], ws1 ++ [m1 (wx + bytes_in_word + bytes_in_word * n2w startptr)]) ++ vars)) /\ - (wx + bytes_in_word + bytes_in_word * n2w startptr) IN s1.mdomain` - (strip_tac \\ fs [GSYM SNOC_APPEND,ZIP_SNOC] \\ fs [SNOC_APPEND] + (wx + bytes_in_word + bytes_in_word * n2w startptr) IN s1.mdomain +Proof + strip_tac \\ fs [GSYM SNOC_APPEND,ZIP_SNOC] \\ fs [SNOC_APPEND] \\ rpt_drule0 memory_rel_Block_IMP \\ full_simp_tac (std_ss++ARITH_ss) [GSYM LENGTH_NIL] \\ strip_tac \\ `word_exp s1 (real_addr c (adjust_var a1)) = SOME (Word a)` by @@ -9427,10 +9766,11 @@ Theorem IMP_memcopy_lemma bytes_in_word_def,word_mul_n2w,WORD_MUL_LSL] \\ fs [] \\ rpt strip_tac \\ pop_assum mp_tac \\ match_mp_tac memory_rel_rearrange - \\ fs [] \\ rw[] \\ fs[]); + \\ fs [] \\ rw[] \\ fs[] +QED -Theorem IMP_memcopy - `!len startptr m1 m2 ws1 ys7 k. +Theorem IMP_memcopy = Q.prove(` + !len startptr m1 m2 ws1 ys7 k. memory_rel c s1.be x.refs sp s1.store m1 s1.mdomain ((Block ts' n' l',Word w_ptr)::(ZIP (ys7,ws1) ++ vars)) /\ (word_list nfree (Word full_header::ws1) * @@ -9451,8 +9791,8 @@ Theorem IMP_memcopy (fun2set (m2,s1.mdomain)) ∧ LENGTH ws2 = len ∧ memory_rel c s1.be x.refs sp s1.store m2 s1.mdomain - (ZIP (ys7 ++ TAKE len (DROP startptr l'),ws1 ++ ws2) ++ vars)` - (Induct \\ simp [Once memcopy_def,LENGTH_NIL] THEN1 + (ZIP (ys7 ++ TAKE len (DROP startptr l'),ws1 ++ ws2) ++ vars)`, + Induct \\ simp [Once memcopy_def,LENGTH_NIL] THEN1 (rpt strip_tac \\ full_simp_tac std_ss [GSYM STAR_ASSOC] THEN1 imp_res_tac STAR_fun2set_IMP_SEP_T \\ imp_res_tac memory_rel_tl \\ fs []) @@ -9489,9 +9829,10 @@ Theorem IMP_memcopy \\ full_simp_tac std_ss [APPEND,GSYM APPEND_ASSOC] \\ fs []) |> SPEC_ALL |> GEN_ALL; -Theorem assign_ConsExtend - `(?tag. op = ConsExtend tag) ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_ConsExtend: + (?tag. op = ConsExtend tag) ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -9908,11 +10249,13 @@ Theorem assign_ConsExtend `tag`,`full_header`] mp_tac) \\ reverse impl_tac THEN1 fs [shift_lsl,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] - \\ fs [Abbr `tot_len`] \\ CCONTR_TAC \\ fs [DROP_NIL]); + \\ fs [Abbr `tot_len`] \\ CCONTR_TAC \\ fs [DROP_NIL] +QED -Theorem assign_Cons - `(?tag. op = Cons tag) ==> ^assign_thm_goal` - (rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] +Theorem assign_Cons: + (?tag. op = Cons tag) ==> ^assign_thm_goal +Proof + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac @@ -9976,11 +10319,12 @@ Theorem assign_Cons \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ match_mp_tac memory_rel_insert \\ fs [] \\ fs [make_cons_ptr_def,get_lowerbits_def] -); +QED -Theorem assign_FFI - `(?n. op = FFI n) ==> ^assign_thm_goal` - ((* (* new proof *) *) +Theorem assign_FFI: + (?n. op = FFI n) ==> ^assign_thm_goal +Proof + (* (* new proof *) *) rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP @@ -10381,10 +10725,11 @@ Theorem assign_FFI >> disch_then match_mp_tac >> BasicProvers.CASE_TAC >> fs[SUBSET_DEF,domain_lookup] - >> res_tac >> fs[]); + >> res_tac >> fs[] +QED -Theorem assign_FFI_final - `state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs /\ +Theorem assign_FFI_final: + state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs /\ (op_requires_names (FFI i) ==> names_opt <> NONE) /\ cut_state_opt names_opt s = SOME x /\ get_vars args x.locals = SOME vals /\ @@ -10393,8 +10738,9 @@ Theorem assign_FFI_final ?q r. evaluate (FST (assign c n l dest (FFI i) args names_opt),t) = (q,r) /\ (q = SOME NotEnoughSpace ==> r.ffi = t.ffi) /\ - (q <> SOME NotEnoughSpace ==> r.ffi = t.ffi /\ q = SOME(FinalFFI f))` - ((* (* new proof *) *) + (q <> SOME NotEnoughSpace ==> r.ffi = t.ffi /\ q = SOME(FinalFFI f)) +Proof + (* (* new proof *) *) rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ `t.termdep <> 0` by fs[] \\ rpt_drule0 state_rel_cut_IMP @@ -10559,11 +10905,13 @@ Theorem assign_FFI_final >> disch_then match_mp_tac >> BasicProvers.CASE_TAC >> fs[SUBSET_DEF,domain_lookup] - >> res_tac >> fs[]); + >> res_tac >> fs[] +QED -Theorem assign_thm - `^assign_thm_goal` - (Cases_on `op = AllocGlobal` \\ fs [] +Theorem assign_thm: + ^assign_thm_goal +Proof + Cases_on `op = AllocGlobal` \\ fs [] THEN1 (fs [do_app] \\ every_case_tac \\ fs []) \\ Cases_on `?i. op = Global i` \\ fs [] THEN1 (fs [do_app] \\ every_case_tac \\ fs []) @@ -10586,6 +10934,7 @@ Theorem assign_thm \\ `?f. f () = op` by (qexists_tac `K op` \\ fs []) (* here for debugging only *) \\ Cases_on `op` \\ fs [assign_def] \\ rpt (PURE_CASE_TAC \\ fs []) - \\ qhdtm_x_assum`do_app`mp_tac \\ EVAL_TAC); + \\ qhdtm_x_assum`do_app`mp_tac \\ EVAL_TAC +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/data_to_word_bignumProofScript.sml b/compiler/backend/proofs/data_to_word_bignumProofScript.sml index 0deaa9c516..4321564095 100644 --- a/compiler/backend/proofs/data_to_word_bignumProofScript.sml +++ b/compiler/backend/proofs/data_to_word_bignumProofScript.sml @@ -48,19 +48,21 @@ val eq_eval = save_thm("eq_eval", list_insert_def,wordSemTheory.dec_clock_def,wordSemTheory.the_words_def, wordLangTheory.word_op_def]); -Theorem word_list_IMP_store_list - `!xs a frame m dm. +Theorem word_list_IMP_store_list: + !xs a frame m dm. (word_list a xs * frame) (fun2set (m,dm)) ==> - store_list a xs m dm = SOME m` - (Induct \\ fs [store_list_def,word_list_def] + store_list a xs m dm = SOME m +Proof + Induct \\ fs [store_list_def,word_list_def] \\ rw [] \\ SEP_R_TAC \\ `(a =+ h) m = m` by (fs [FUN_EQ_THM,APPLY_UPDATE_THM] \\ rw [] \\ SEP_R_TAC \\ fs []) \\ fs [] \\ first_x_assum match_mp_tac - \\ qexists_tac `frame * one (a,h)` \\ fs [AC STAR_COMM STAR_ASSOC]); + \\ qexists_tac `frame * one (a,h)` \\ fs [AC STAR_COMM STAR_ASSOC] +QED -Theorem word_exp_set_var_ShiftVar_lemma - `word_exp t (ShiftVar sow v n) = +Theorem word_exp_set_var_ShiftVar_lemma: + word_exp t (ShiftVar sow v n) = case lookup v t.locals of | SOME (Word w) => OPTION_MAP Word @@ -68,8 +70,9 @@ Theorem word_exp_set_var_ShiftVar_lemma | Lsr => SOME (w >>> n) | Asr => SOME (w >> n) | Ror => SOME (word_ror w n)) - | _ => FAIL (word_exp t (ShiftVar sow v n)) "lookup failed"` - (Cases_on `lookup v t.locals` \\ fs [] \\ rw [FAIL_DEF] + | _ => FAIL (word_exp t (ShiftVar sow v n)) "lookup failed" +Proof + Cases_on `lookup v t.locals` \\ fs [] \\ rw [FAIL_DEF] \\ fs [ShiftVar_def] \\ IF_CASES_TAC \\ fs [] THEN1 @@ -87,12 +90,14 @@ Theorem word_exp_set_var_ShiftVar_lemma (drule word_asr_dimindex \\ IF_CASES_TAC \\ eval_tac \\ every_case_tac \\ eval_tac) - \\ eval_tac \\ every_case_tac \\ fs [] \\ eval_tac); + \\ eval_tac \\ every_case_tac \\ fs [] \\ eval_tac +QED -Theorem i2mw_small_int_IMP_0 - `(∀v1. i2mw v ≠ (F,[v1:'a word])) /\ (∀v1. i2mw v ≠ (T,[v1:'a word])) /\ - small_int (:α) v /\ good_dimindex (:'a) ==> v = 0` - (CCONTR_TAC \\ fs [] \\ Cases_on `v` \\ fs [] +Theorem i2mw_small_int_IMP_0: + (∀v1. i2mw v ≠ (F,[v1:'a word])) /\ (∀v1. i2mw v ≠ (T,[v1:'a word])) /\ + small_int (:α) v /\ good_dimindex (:'a) ==> v = 0 +Proof + CCONTR_TAC \\ fs [] \\ Cases_on `v` \\ fs [] \\ fs [multiwordTheory.i2mw_def,small_int_def] \\ qpat_x_assum `!x._` mp_tac \\ fs [] \\ once_rewrite_tac [multiwordTheory.n2mw_def] @@ -100,49 +105,59 @@ Theorem i2mw_small_int_IMP_0 \\ rw [] \\ fs [good_dimindex_def,dimword_def] \\ fs [good_dimindex_def,dimword_def] \\ rfs [DIV_EQ_X] - \\ intLib.COOPER_TAC); + \\ intLib.COOPER_TAC +QED -Theorem state_rel_Number_small_int - `state_rel c r1 r2 s t [x] locs /\ small_int (:'a) i ==> - state_rel c r1 r2 s t [(Number i,Word (Smallnum i:'a word))] locs` - (fs [state_rel_thm] \\ rw[] +Theorem state_rel_Number_small_int: + state_rel c r1 r2 s t [x] locs /\ small_int (:'a) i ==> + state_rel c r1 r2 s t [(Number i,Word (Smallnum i:'a word))] locs +Proof + fs [state_rel_thm] \\ rw[] \\ match_mp_tac IMP_memory_rel_Number \\ fs [] \\ first_x_assum (fn th => mp_tac th THEN match_mp_tac memory_rel_rearrange) - \\ fs []); + \\ fs [] +QED -Theorem heap_lookup_Unused_Bignum - `heap_lookup a (Unused k::hb) = SOME (Bignum j) <=> +Theorem heap_lookup_Unused_Bignum: + heap_lookup a (Unused k::hb) = SOME (Bignum j) <=> k+1 <= a /\ - heap_lookup (a - (k+1)) hb = SOME (Bignum j)` - (fs [heap_lookup_def,el_length_def] + heap_lookup (a - (k+1)) hb = SOME (Bignum j) +Proof + fs [heap_lookup_def,el_length_def] \\ rw [] \\ fs [Bignum_def] - \\ pairarg_tac \\ fs []); + \\ pairarg_tac \\ fs [] +QED -Theorem push_env_insert_0 - `push_env (insert 0 x LN) NONE t = +Theorem push_env_insert_0: + push_env (insert 0 x LN) NONE t = t with <| stack := StackFrame [(0,x)] NONE :: t.stack ; - permute := \n. t.permute (n+1) |>` - (fs [wordSemTheory.push_env_def] + permute := \n. t.permute (n+1) |> +Proof + fs [wordSemTheory.push_env_def] \\ fs [wordSemTheory.env_to_list_def] \\ EVAL_TAC \\ rw [] \\ fs [] - \\ fs [BIJ_DEF,INJ_DEF]); + \\ fs [BIJ_DEF,INJ_DEF] +QED -Theorem mc_header_i2mw_eq_0w - `2 * LENGTH (SND (i2mw i):'a word list) + 1 < dimword (:'a) ==> - (mc_header (i2mw i:bool # 'a word list) = 0w:'a word <=> i = 0)` - (Cases_on `i = 0` +Theorem mc_header_i2mw_eq_0w: + 2 * LENGTH (SND (i2mw i):'a word list) + 1 < dimword (:'a) ==> + (mc_header (i2mw i:bool # 'a word list) = 0w:'a word <=> i = 0) +Proof + Cases_on `i = 0` \\ fs [multiwordTheory.i2mw_def,mc_multiwordTheory.mc_header_def] \\ rw [] \\ fs [word_add_n2w] THEN1 EVAL_TAC \\ fs [LENGTH_NIL] \\ once_rewrite_tac [multiwordTheory.n2mw_def] - \\ rw [] \\ intLib.COOPER_TAC); + \\ rw [] \\ intLib.COOPER_TAC +QED -Theorem MustTerminate_limit_eq - `good_dimindex (:'a) ==> +Theorem MustTerminate_limit_eq: + good_dimindex (:'a) ==> ?k. MustTerminate_limit (:α) = 10 * dimword (:'a) * dimword (:'a) + - 10 * dimword (:'a) + 100 + k` - (rewrite_tac [GSYM LESS_EQ_EXISTS] + 10 * dimword (:'a) + 100 + k +Proof + rewrite_tac [GSYM LESS_EQ_EXISTS] \\ fs [wordSemTheory.MustTerminate_limit_def] \\ rw [] \\ match_mp_tac LESS_EQ_TRANS \\ qexists_tac `dimword (:α) ** dimword (:α)` @@ -155,22 +170,29 @@ Theorem MustTerminate_limit_eq \\ fs [] \\ match_mp_tac LESS_EQ_TRANS \\ qexists_tac `(dimword (:α)) * (dimword (:α))²` \\ fs [] - \\ fs [dimword_def,good_dimindex_def]); + \\ fs [dimword_def,good_dimindex_def] +QED -Theorem SND_i2mw_NIL - `SND (i2mw i) = [] <=> i = 0` - (Cases_on `i` \\ fs [] +Theorem SND_i2mw_NIL: + SND (i2mw i) = [] <=> i = 0 +Proof + Cases_on `i` \\ fs [] \\ fs [multiwordTheory.i2mw_def] \\ once_rewrite_tac [multiwordTheory.n2mw_def] - \\ rw [] \\ intLib.COOPER_TAC); + \\ rw [] \\ intLib.COOPER_TAC +QED -Theorem word_cmp_Test_1 - `word_cmp Test w 1w <=> ~(word_bit 0 w)` - (EVAL_TAC \\ fs [word_and_one_eq_0_iff,word_bit_def]); +Theorem word_cmp_Test_1: + word_cmp Test w 1w <=> ~(word_bit 0 w) +Proof + EVAL_TAC \\ fs [word_and_one_eq_0_iff,word_bit_def] +QED -Theorem word_bit_if_1_0 - `word_bit 0 (if b then 1w else 0w) <=> b` - (Cases_on `b` \\ EVAL_TAC); +Theorem word_bit_if_1_0: + word_bit 0 (if b then 1w else 0w) <=> b +Proof + Cases_on `b` \\ EVAL_TAC +QED val get_iop_def = Define ` get_iop (n:num) = @@ -188,18 +210,20 @@ val int_op_def = Define ` if op_index = 5 /\ j <> 0 then SOME (i / j) else if op_index = 6 /\ j <> 0 then SOME (i % j) else NONE` -Theorem get_sign_word_lemma - `good_dimindex (:α) ⇒ (1w && x ⋙ 4) = if word_bit 4 x then 1w else 0w:'a word` - (rw [] \\ fs [fcpTheory.CART_EQ,word_and_def,word_lsr_def,fcpTheory.FCP_BETA, +Theorem get_sign_word_lemma: + good_dimindex (:α) ⇒ (1w && x ⋙ 4) = if word_bit 4 x then 1w else 0w:'a word +Proof + rw [] \\ fs [fcpTheory.CART_EQ,word_and_def,word_lsr_def,fcpTheory.FCP_BETA, good_dimindex_def,word_index] - \\ rw [] \\ Cases_on `i = 0` \\ fs [word_bit_def]); + \\ rw [] \\ Cases_on `i = 0` \\ fs [word_bit_def] +QED val if_eq_b2w = prove( ``(if b then 1w else 0w) = b2w b``, Cases_on `b` \\ EVAL_TAC); -Theorem LongDiv1_thm - `!k n1 n2 m i1 i2 (t2:('a,'c,'ffi) wordSem$state) +Theorem LongDiv1_thm: + !k n1 n2 m i1 i2 (t2:('a,'c,'ffi) wordSem$state) r1 r2 m1 is1 c:data_to_word$config. single_div_loop (n2w k,[n1;n2],m,[i1;i2]) = (m1,is1) /\ lookup LongDiv1_location t2.code = SOME (7,LongDiv1_code c) /\ @@ -216,8 +240,9 @@ Theorem LongDiv1_thm evaluate (LongDiv1_code c,t2) = (SOME (Result (Loc r1 r2) (Word m1)), t2 with <| clock := t2.clock - k; locals := LN; - store := t2.store |+ (Temp 28w,Word (HD is1)) |>)` - (Induct THEN1 + store := t2.store |+ (Temp 28w,Word (HD is1)) |>) +Proof + Induct THEN1 (fs [Once multiwordTheory.single_div_loop_def] \\ rw [] \\ rewrite_tac [LongDiv1_code_def] \\ fs [eq_eval,wordSemTheory.set_store_def] @@ -299,39 +324,45 @@ Theorem LongDiv1_thm \\ disch_then (qspecl_then [`t3`,`r1`,`r2`,`c`] mp_tac) \\ impl_tac THEN1 (unabbrev_all_tac \\ fs [lookup_insert]) \\ strip_tac \\ fs [] - \\ unabbrev_all_tac \\ fs [wordSemTheory.state_component_equality]); + \\ unabbrev_all_tac \\ fs [wordSemTheory.state_component_equality] +QED -Theorem get_real_addr_lemma - `shift_length c < dimindex (:'a) /\ +Theorem get_real_addr_lemma: + shift_length c < dimindex (:'a) /\ good_dimindex (:'a) /\ get_var v (t:('a,'c,'ffi) wordSem$state) = SOME (Word ptr_w) /\ get_real_addr c t.store ptr_w = SOME x ==> - word_exp t (real_addr c v) = SOME (Word (x:'a word))` - (fs [get_real_addr_def] \\ every_case_tac \\ fs [] + word_exp t (real_addr c v) = SOME (Word (x:'a word)) +Proof + fs [get_real_addr_def] \\ every_case_tac \\ fs [] \\ fs [wordSemTheory.get_var_def,real_addr_def] \\ eval_tac \\ fs [] \\ rw [] \\ eval_tac \\ fs [] \\ rw [] \\ fs [] \\ fs [labPropsTheory.good_dimindex_def,dimword_def] \\ rw [] - \\ rfs [backend_commonTheory.word_shift_def] \\ fs []); + \\ rfs [backend_commonTheory.word_shift_def] \\ fs [] +QED -Theorem memory_rel_lookup - `memory_rel c be refs s st m dm +Theorem memory_rel_lookup: + memory_rel c be refs s st m dm (join_env l1 (toAList (inter l2 (adjust_set l1))) ++ xs) ∧ lookup n l1 = SOME x ∧ lookup (adjust_var n) l2 = SOME w ⇒ memory_rel c be refs s st m dm - ((x,w)::(join_env l1 (toAList (inter l2 (adjust_set l1))) ++ xs))` - (fs [memory_rel_def] \\ rw [] \\ asm_exists_tac \\ fs [] + ((x,w)::(join_env l1 (toAList (inter l2 (adjust_set l1))) ++ xs)) +Proof + fs [memory_rel_def] \\ rw [] \\ asm_exists_tac \\ fs [] \\ rpt_drule (Q.INST [`ys`|->`[]`] word_ml_inv_lookup - |> SIMP_RULE std_ss [APPEND])); + |> SIMP_RULE std_ss [APPEND]) +QED -Theorem evaluate_AddNumSize - `!src c l1 l2 s t locs i w. +Theorem evaluate_AddNumSize: + !src c l1 l2 s t locs i w. state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs /\ get_var src s.locals = SOME (Number i) ==> evaluate (AddNumSize c src,set_var 1 (Word w) t) = (NONE,set_var 1 (Word (w + - n2w (4 * LENGTH ((SND (i2mw i):'a word list))))) t)` - (fs [AddNumSize_def] \\ rpt strip_tac + n2w (4 * LENGTH ((SND (i2mw i):'a word list))))) t) +Proof + fs [AddNumSize_def] \\ rpt strip_tac \\ imp_res_tac state_rel_get_var_IMP \\ fs [state_rel_thm,get_var_def,wordSemTheory.get_var_def] \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] @@ -379,10 +410,11 @@ Theorem evaluate_AddNumSize \\ IF_CASES_TAC THEN1 (fs [good_dimindex_def] \\ rfs []) \\ pop_assum kall_tac \\ fs [] - \\ fs [WORD_MUL_LSL,GSYM word_mul_n2w,multiwordTheory.i2mw_def]); + \\ fs [WORD_MUL_LSL,GSYM word_mul_n2w,multiwordTheory.i2mw_def] +QED -Theorem AnyHeader_thm - `!t1 t2 t3 r. +Theorem AnyHeader_thm: + !t1 t2 t3 r. state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs /\ get_var r s.locals = SOME (Number i) /\ ALL_DISTINCT [t1;t2;t3] ==> @@ -400,8 +432,9 @@ Theorem AnyHeader_thm (~small_int (:'a) i ==> ?w x. get_var (adjust_var r) t = SOME (Word w) /\ get_real_addr c t.store w = SOME x /\ - a2 = x + bytes_in_word)` - (rpt strip_tac + a2 = x + bytes_in_word) +Proof + rpt strip_tac \\ imp_res_tac state_rel_get_var_IMP \\ fs [state_rel_thm] \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] @@ -528,22 +561,26 @@ Theorem AnyHeader_thm \\ fs [wordSemTheory.state_component_equality] \\ fs [GSYM fmap_EQ,FUN_EQ_THM,FAPPLY_FUPDATE_THM] \\ rw [] \\ fs [] \\ TRY (eq_tac \\ rw [] \\ fs []) - \\ EVAL_TAC \\ fs [n2w_mod])); + \\ EVAL_TAC \\ fs [n2w_mod]) +QED -Theorem state_rel_set_store_Temp - `state_rel c l1 l2 s (set_store (Temp tmp) w t) vs locs = - state_rel c l1 l2 s t vs locs` - (fs [state_rel_def,wordSemTheory.set_store_def] +Theorem state_rel_set_store_Temp: + state_rel c l1 l2 s (set_store (Temp tmp) w t) vs locs = + state_rel c l1 l2 s t vs locs +Proof + fs [state_rel_def,wordSemTheory.set_store_def] \\ rw [] \\ eq_tac \\ rw [] \\ fs [heap_in_memory_store_def,PULL_EXISTS,FLOOKUP_UPDATE, FAPPLY_FUPDATE_THM,code_oracle_rel_def] - \\ rpt (asm_exists_tac \\ fs []) \\ metis_tac []); + \\ rpt (asm_exists_tac \\ fs []) \\ metis_tac [] +QED -Theorem state_rel_IMP_num_size_limit - `state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs /\ +Theorem state_rel_IMP_num_size_limit: + state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs /\ get_var k s.locals = SOME (Number i) ==> - LENGTH (SND (i2mw i):'a word list) < dimword (:'a) DIV 16` - (rpt strip_tac + LENGTH (SND (i2mw i):'a word list) < dimword (:'a) DIV 16 +Proof + rpt strip_tac \\ imp_res_tac state_rel_get_var_IMP \\ fs [state_rel_thm,get_var_def,wordSemTheory.get_var_def] \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] @@ -559,46 +596,57 @@ Theorem state_rel_IMP_num_size_limit \\ strip_tac \\ rpt_drule memory_rel_Number_bignum_IMP_ALT \\ fs [multiwordTheory.i2mw_def] \\ rw [] \\ fs [] - \\ fs [good_dimindex_def,dimword_def] \\ rfs [EXP_SUB]); + \\ fs [good_dimindex_def,dimword_def] \\ rfs [EXP_SUB] +QED -Theorem word_list_store_list - `!xs a frame m dm. +Theorem word_list_store_list: + !xs a frame m dm. (word_list a xs * frame) (fun2set (m,dm)) ==> ?m2. (store_list a (REPLICATE (LENGTH xs) (Word 0w)) m dm = SOME m2) /\ (word_list a (REPLICATE (LENGTH xs) (Word 0w)) * frame) - (fun2set (m2,dm))` - (Induct \\ fs [store_list_def,REPLICATE,word_list_def] \\ rw [] + (fun2set (m2,dm)) +Proof + Induct \\ fs [store_list_def,REPLICATE,word_list_def] \\ rw [] \\ SEP_R_TAC \\ fs [] \\ SEP_W_TAC \\ SEP_F_TAC - \\ strip_tac \\ fs [AC STAR_COMM STAR_ASSOC]); + \\ strip_tac \\ fs [AC STAR_COMM STAR_ASSOC] +QED -Theorem MustTerminate_limit_SUB_2 - `good_dimindex (:'a) ==> dimword (:'a) <= MustTerminate_limit (:α) − 2` - (fs [wordSemTheory.MustTerminate_limit_def] +Theorem MustTerminate_limit_SUB_2: + good_dimindex (:'a) ==> dimword (:'a) <= MustTerminate_limit (:α) − 2 +Proof + fs [wordSemTheory.MustTerminate_limit_def] \\ qpat_abbrev_tac `m = (_:num) ** _` \\ qpat_abbrev_tac `n = (_:num) ** _` \\ rpt (pop_assum kall_tac) - \\ fs [good_dimindex_def] \\ rw [] \\ fs [dimword_def]); + \\ fs [good_dimindex_def] \\ rw [] \\ fs [dimword_def] +QED -Theorem cut_env_fromList_sing - `cut_env (fromList [()]) (insert 0 (Loc l1 l2) LN) = - SOME (insert 0 (Loc l1 l2) LN)` - (EVAL_TAC); +Theorem cut_env_fromList_sing: + cut_env (fromList [()]) (insert 0 (Loc l1 l2) LN) = + SOME (insert 0 (Loc l1 l2) LN) +Proof + EVAL_TAC +QED -Theorem single_div_pre_IMP_single_div_full - `single_div_pre x1 x2 y ==> - single_div x1 x2 y = single_div_full x1 x2 y` - (strip_tac +Theorem single_div_pre_IMP_single_div_full: + single_div_pre x1 x2 y ==> + single_div x1 x2 y = single_div_full x1 x2 y +Proof + strip_tac \\ match_mp_tac (GSYM multiwordTheory.single_div_full_thm) \\ fs [mc_multiwordTheory.single_div_pre_def,multiwordTheory.mw2n_def] - \\ Cases_on `y` \\ fs [] \\ rfs [DIV_LT_X]); + \\ Cases_on `y` \\ fs [] \\ rfs [DIV_LT_X] +QED -Theorem IMP_LESS_MustTerminate_limit[simp] - `i < dimword (:α) ==> - i < MustTerminate_limit (:α) − 1` - (rewrite_tac [wordSemTheory.MustTerminate_limit_def] \\ decide_tac); +Theorem IMP_LESS_MustTerminate_limit[simp]: + i < dimword (:α) ==> + i < MustTerminate_limit (:α) − 1 +Proof + rewrite_tac [wordSemTheory.MustTerminate_limit_def] \\ decide_tac +QED -Theorem evaluate_LongDiv_code - `!(t:('a,'c,'ffi) wordSem$state) l1 l2 c w x1 x2 y d1 m1. +Theorem evaluate_LongDiv_code: + !(t:('a,'c,'ffi) wordSem$state) l1 l2 c w x1 x2 y d1 m1. single_div_pre x1 x2 y /\ single_div x1 x2 y = (d1,m1:'a word) /\ lookup LongDiv1_location t.code = SOME (7,LongDiv1_code c) /\ @@ -611,8 +659,9 @@ Theorem evaluate_LongDiv_code evaluate (LongDiv_code c,t) = (SOME (Result (Loc l1 l2) (Word d1)), t with <| clock := ck; locals := LN; - store := t.store |+ (Temp 28w,Word m1) |>)` - (rpt strip_tac + store := t.store |+ (Temp 28w,Word m1) |>) +Proof + rpt strip_tac \\ Cases_on `c.has_longdiv` \\ simp [] \\ fs [LongDiv_code_def,eq_eval,wordSemTheory.push_env_def] THEN1 (* has_longdiv case *) @@ -639,12 +688,14 @@ Theorem evaluate_LongDiv_code \\ strip_tac \\ fs [] \\ qunabbrev_tac `t2` \\ fs [] \\ fs [FLOOKUP_UPDATE,wordSemTheory.set_store_def, - wordSemTheory.state_component_equality,fromAList_def]); + wordSemTheory.state_component_equality,fromAList_def] +QED -Theorem div_code_assum_thm - `state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs ==> - div_code_assum (:'ffi) (:'c) t.code` - (fs [DivCode_def,div_code_assum_def,eq_eval] \\ rpt strip_tac +Theorem div_code_assum_thm: + state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs ==> + div_code_assum (:'ffi) (:'c) t.code +Proof + fs [DivCode_def,div_code_assum_def,eq_eval] \\ rpt strip_tac \\ fs [state_rel_thm,code_rel_def,stubs_def] \\ fs [EVAL ``LongDiv_location``,div_location_def] \\ qpat_abbrev_tac `x = cut_env (LS ()) _` @@ -681,28 +732,33 @@ Theorem div_code_assum_thm \\ rpt strip_tac \\ rpt (IF_CASES_TAC \\ asm_rewrite_tac []) \\ rveq \\ qpat_x_assum `0 < 0n` mp_tac - \\ simp_tac (srw_ss()) []); + \\ simp_tac (srw_ss()) [] +QED -Theorem IMP_bignum_code_rel - `compile Bignum_location 1 1 (Bignum_location + 1,[]) +Theorem IMP_bignum_code_rel: + compile Bignum_location 1 1 (Bignum_location + 1,[]) mc_iop_code = (xx1,xx2,xx3,xx4,xx5) /\ state_rel c l1 l2 s t [] locs ==> - code_rel (xx4,xx5) t.code` - (fs [word_bignumProofTheory.code_rel_def,state_rel_def,code_rel_def,stubs_def] + code_rel (xx4,xx5) t.code +Proof + fs [word_bignumProofTheory.code_rel_def,state_rel_def,code_rel_def,stubs_def] \\ rpt strip_tac \\ fs [generated_bignum_stubs_def] \\ rfs [] \\ fs [EVERY_MAP] \\ drule alistTheory.ALOOKUP_MEM \\ strip_tac \\ first_x_assum (drule o REWRITE_RULE [EVERY_MEM]) \\ fs [] \\ strip_tac \\ imp_res_tac compile_NIL_IMP \\ fs [] - \\ asm_exists_tac \\ fs []); + \\ asm_exists_tac \\ fs [] +QED -Theorem TWO_LESS_MustTerminate_limit[simp] - `2 < MustTerminate_limit (:α) /\ - ~(MustTerminate_limit (:α) <= 1)` - (fs [wordSemTheory.MustTerminate_limit_def,dimword_def] +Theorem TWO_LESS_MustTerminate_limit[simp]: + 2 < MustTerminate_limit (:α) /\ + ~(MustTerminate_limit (:α) <= 1) +Proof + fs [wordSemTheory.MustTerminate_limit_def,dimword_def] \\ Cases_on `dimindex (:'a)` \\ fs [dimword_def,MULT_CLAUSES,EXP] - \\ Cases_on `n` \\ fs [EXP] \\ Cases_on `2 ** n'` \\ fs []); + \\ Cases_on `n` \\ fs [EXP] \\ Cases_on `2 ** n'` \\ fs [] +QED val Arith_location_def = Define ` Arith_location index = @@ -712,24 +768,28 @@ val Arith_location_def = Define ` if index = 5n then Div_location else if index = 6n then Mod_location else ARB`; -Theorem push_env_code - `(push_env y NONE t).code = t.code` - (fs [wordSemTheory.push_env_def] \\ pairarg_tac \\ fs []); +Theorem push_env_code: + (push_env y NONE t).code = t.code +Proof + fs [wordSemTheory.push_env_def] \\ pairarg_tac \\ fs [] +QED val Arith_code_def = Define ` Arith_code index = Seq (Assign 6 (Const (n2w (4 * index)))) (Call NONE (SOME AnyArith_location) [0; 2; 4; 6] NONE)`; -Theorem lookup_Arith_location - `state_rel c l1 l2 x t [] locs /\ int_op index i1 i2 = SOME r ==> - lookup (Arith_location index) t.code = SOME (3,Arith_code index)` - (rw [] \\ drule lookup_RefByte_location +Theorem lookup_Arith_location: + state_rel c l1 l2 x t [] locs /\ int_op index i1 i2 = SOME r ==> + lookup (Arith_location index) t.code = SOME (3,Arith_code index) +Proof + rw [] \\ drule lookup_RefByte_location \\ fs [int_op_def] \\ every_case_tac \\ fs [] - \\ fs [Arith_location_def] \\ rw [] \\ EVAL_TAC); + \\ fs [Arith_location_def] \\ rw [] \\ EVAL_TAC +QED -Theorem Replicate_code_thm - `!n a r m1 a1 a2 a3 a4 a5. +Theorem Replicate_code_thm: + !n a r m1 a1 a2 a3 a4 a5. lookup Replicate_location r.code = SOME (5,Replicate_code) /\ store_list (a + bytes_in_word) (REPLICATE n v) (r:('a,'c,'ffi) wordSem$state).memory r.mdomain = SOME m1 /\ @@ -742,8 +802,9 @@ Theorem Replicate_code_thm n < r.clock ==> evaluate (Call NONE (SOME Replicate_location) [a1;a2;a3;a4;a5] NONE,r) = (SOME (Result (Loc l1 l2) ret_val), - r with <| memory := m1 ; clock := r.clock - n - 1; locals := LN |>)` - (Induct \\ rw [] \\ simp [wordSemTheory.evaluate_def] + r with <| memory := m1 ; clock := r.clock - n - 1; locals := LN |>) +Proof + Induct \\ rw [] \\ simp [wordSemTheory.evaluate_def] \\ simp [wordSemTheory.get_vars_def,wordSemTheory.bad_dest_args_def, wordSemTheory.find_code_def,wordSemTheory.add_ret_loc_def] \\ rw [] \\ simp [Replicate_code_def] @@ -763,10 +824,11 @@ Theorem Replicate_code_thm wordSemTheory.get_var_def,word_exp_rw,fromList2_def, wordSemTheory.set_var_def,wordSemTheory.mem_store_def, asmTheory.word_cmp_def,wordSemTheory.dec_clock_def] - \\ rfs [] \\ fs [MULT_CLAUSES,GSYM word_add_n2w] \\ fs [ADD1]); + \\ rfs [] \\ fs [MULT_CLAUSES,GSYM word_add_n2w] \\ fs [ADD1] +QED -Theorem Replicate_code_alt_thm - `!n a r m1 a1 a2 a3 a4 a5 var. +Theorem Replicate_code_alt_thm: + !n a r m1 a1 a2 a3 a4 a5 var. lookup Replicate_location r.code = SOME (5,Replicate_code) /\ store_list (a + bytes_in_word) (REPLICATE n v) (r:('a,'c,'ffi) wordSem$state).memory r.mdomain = SOME m1 /\ @@ -781,8 +843,9 @@ Theorem Replicate_code_alt_thm (NONE, r with <| memory := m1 ; clock := r.clock - n - 1; locals := insert 0 ret_val LN ; - permute := (\n. r.permute (n+1)) |>)` - (rw [] \\ fs [wordSemTheory.evaluate_def] + permute := (\n. r.permute (n+1)) |>) +Proof + rw [] \\ fs [wordSemTheory.evaluate_def] \\ simp [wordSemTheory.get_vars_def,wordSemTheory.bad_dest_args_def, wordSemTheory.find_code_def,wordSemTheory.add_ret_loc_def] \\ fs [EVAL ``sptree$fromList [()]``] @@ -825,12 +888,13 @@ Theorem Replicate_code_alt_thm \\ fs [wordSemTheory.pop_env_def,Abbr `t5`, EVAL ``domain (fromAList [(0,ret_val)])``] \\ fs [wordSemTheory.state_component_equality] - \\ fs [fromAList_def,insert_shadow]); + \\ fs [fromAList_def,insert_shadow] +QED val s = ``s:('c,'ffi)dataSem$state`` -Theorem AnyArith_thm - `∀op_index i j v t s r2 r1 locs l2 l1 c. +Theorem AnyArith_thm: + ∀op_index i j v t s r2 r1 locs l2 l1 c. state_rel c l1 l2 ^s (t:('a,'c,'ffi) wordSem$state) [] locs /\ get_vars [0;1;2] s.locals = SOME [Number i; Number j; Number (& op_index)] /\ t.clock = MustTerminate_limit (:'a) - 2 /\ t.termdep <> 0 /\ @@ -844,8 +908,9 @@ Theorem AnyArith_thm ?rv. q = SOME (Result (Loc l1 l2) rv) /\ state_rel c r1 r2 (s with <| locals := LN; clock := new_c; space := 0 |>) r - [(Number v,rv)] locs` - (rpt strip_tac \\ fs [AnyArith_code_def] + [(Number v,rv)] locs +Proof + rpt strip_tac \\ fs [AnyArith_code_def] \\ once_rewrite_tac [list_Seq_def] \\ fs [wordSemTheory.evaluate_def,wordSemTheory.word_exp_def] \\ once_rewrite_tac [list_Seq_def] @@ -1723,17 +1788,20 @@ Theorem AnyArith_thm \\ drule memory_rel_zero_space \\ match_mp_tac memory_rel_rearrange \\ rpt (pop_assum kall_tac) - \\ fs [] \\ rw [] \\ fs []); + \\ fs [] \\ rw [] \\ fs [] +QED -Theorem MAP_FST_EQ_IMP_IS_SOME_ALOOKUP - `!xs ys. +Theorem MAP_FST_EQ_IMP_IS_SOME_ALOOKUP: + !xs ys. MAP FST xs = MAP FST ys ==> - IS_SOME (ALOOKUP xs n) = IS_SOME (ALOOKUP ys n)` - (Induct \\ fs [] \\ Cases \\ Cases_on `ys` \\ fs [] - \\ Cases_on `h` \\ fs [] \\ rw []); + IS_SOME (ALOOKUP xs n) = IS_SOME (ALOOKUP ys n) +Proof + Induct \\ fs [] \\ Cases \\ Cases_on `ys` \\ fs [] + \\ Cases_on `h` \\ fs [] \\ rw [] +QED -Theorem eval_Call_Arith - `!index r. +Theorem eval_Call_Arith: + !index r. state_rel c l1 l2 ^s (t:('a,'c,'ffi) wordSem$state) [] locs /\ names_opt ≠ NONE /\ 1 < t.termdep /\ get_vars [a1; a2] x.locals = SOME [Number i1; Number i2] /\ @@ -1754,8 +1822,9 @@ Theorem eval_Call_Arith state_rel c l1 l2 (x with <|locals := insert dest (Number r) x.locals; space := 0|>) - r' [] locs ∧ q = NONE)` - (rpt strip_tac \\ drule (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] + r' [] locs ∧ q = NONE) +Proof + rpt strip_tac \\ drule (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ imp_res_tac state_rel_cut_IMP \\ Cases_on `names_opt` \\ fs [] \\ imp_res_tac get_vars_IMP_LENGTH \\ fs [] \\ rw [] @@ -1873,6 +1942,7 @@ Theorem eval_Call_Arith \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ match_mp_tac word_ml_inv_insert \\ fs [flat_def] \\ first_x_assum (fn th => mp_tac th \\ match_mp_tac word_ml_inv_rearrange) - \\ fs[MEM] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[]); + \\ fs[MEM] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/data_to_word_gcProofScript.sml b/compiler/backend/proofs/data_to_word_gcProofScript.sml index ac73721204..8a25352172 100644 --- a/compiler/backend/proofs/data_to_word_gcProofScript.sml +++ b/compiler/backend/proofs/data_to_word_gcProofScript.sml @@ -36,190 +36,256 @@ infix 8 by1 val clean_tac = rpt var_eq_tac \\ rpt (qpat_x_assum `T` kall_tac) fun rpt_drule th = drule (th |> GEN_ALL) \\ rpt (disch_then drule \\ fs []) -Theorem LESS_EQ_IMP_APPEND_ALT - `∀n xs. n ≤ LENGTH xs ⇒ ∃ys zs. xs = ys ++ zs ∧ LENGTH zs = n` - (Induct \\ fs [LENGTH_NIL] \\ Cases_on `xs` \\ fs [] +Theorem LESS_EQ_IMP_APPEND_ALT: + ∀n xs. n ≤ LENGTH xs ⇒ ∃ys zs. xs = ys ++ zs ∧ LENGTH zs = n +Proof + Induct \\ fs [LENGTH_NIL] \\ Cases_on `xs` \\ fs [] \\ rw [] \\ res_tac \\ rveq \\ Cases_on `ys` \\ fs [] THEN1 (qexists_tac `[]` \\ fs []) \\ qexists_tac `BUTLAST (h::h'::t)` \\ fs [] \\ qexists_tac `LAST (h::h'::t) :: zs` \\ fs [] - \\ fs [APPEND_FRONT_LAST]); - -Theorem word_asr_dimindex - `!w:'a word n. dimindex (:'a) <= n ==> (w >> n = w >> (dimindex (:'a) - 1))` - (fs [word_asr_def,fcpTheory.CART_EQ,fcpTheory.FCP_BETA] - \\ rw [] \\ Cases_on `i` \\ fs [] \\ rw [] \\ fs [word_msb_def]); - -Theorem WORD_MUL_BIT0 - `!a b. (a * b) ' 0 <=> a ' 0 /\ b ' 0` - (fs [word_mul_def,word_index,bitTheory.BIT0_ODD,ODD_MULT] - \\ Cases \\ Cases \\ fs [word_index,bitTheory.BIT0_ODD]); - -Theorem word_lsl_index - `i < dimindex(:'a) ⇒ - (((w:'a word) << n) ' i ⇔ n ≤ i ∧ w ' (i-n))` - (rw[word_lsl_def,fcpTheory.FCP_BETA]); - -Theorem word_lsr_index - `i < dimindex(:'a) ⇒ - (((w:'a word) >>> n) ' i ⇔ i + n < dimindex(:'a) ∧ w ' (i+n))` - (rw[word_lsr_def,fcpTheory.FCP_BETA]); - -Theorem lsr_lsl - `∀w n. aligned n w ⇒ (w >>> n << n = w)` - (simp [aligned_def, alignmentTheory.align_shift]); - -Theorem word_index_test - `n < dimindex (:'a) ==> (w ' n <=> ((w && n2w (2 ** n)) <> 0w:'a word))` - (srw_tac [wordsLib.WORD_BIT_EQ_ss] [wordsTheory.word_index]) + \\ fs [APPEND_FRONT_LAST] +QED + +Theorem word_asr_dimindex: + !w:'a word n. dimindex (:'a) <= n ==> (w >> n = w >> (dimindex (:'a) - 1)) +Proof + fs [word_asr_def,fcpTheory.CART_EQ,fcpTheory.FCP_BETA] + \\ rw [] \\ Cases_on `i` \\ fs [] \\ rw [] \\ fs [word_msb_def] +QED + +Theorem WORD_MUL_BIT0: + !a b. (a * b) ' 0 <=> a ' 0 /\ b ' 0 +Proof + fs [word_mul_def,word_index,bitTheory.BIT0_ODD,ODD_MULT] + \\ Cases \\ Cases \\ fs [word_index,bitTheory.BIT0_ODD] +QED + +Theorem word_lsl_index: + i < dimindex(:'a) ⇒ + (((w:'a word) << n) ' i ⇔ n ≤ i ∧ w ' (i-n)) +Proof + rw[word_lsl_def,fcpTheory.FCP_BETA] +QED + +Theorem word_lsr_index: + i < dimindex(:'a) ⇒ + (((w:'a word) >>> n) ' i ⇔ i + n < dimindex(:'a) ∧ w ' (i+n)) +Proof + rw[word_lsr_def,fcpTheory.FCP_BETA] +QED + +Theorem lsr_lsl: + ∀w n. aligned n w ⇒ (w >>> n << n = w) +Proof + simp [aligned_def, alignmentTheory.align_shift] +QED + +Theorem word_index_test: + n < dimindex (:'a) ==> (w ' n <=> ((w && n2w (2 ** n)) <> 0w:'a word)) +Proof + srw_tac [wordsLib.WORD_BIT_EQ_ss] [wordsTheory.word_index] +QED val word_and_one_eq_0_iff = Q.store_thm("word_and_one_eq_0_iff", (* same in stack_alloc *) `!w. ((w && 1w) = 0w) <=> ~(w ' 0)`, srw_tac [wordsLib.WORD_BIT_EQ_ss] [word_index]) -Theorem word_index_0 - `!w. w ' 0 <=> ~((1w && w) = 0w)` - (metis_tac [word_and_one_eq_0_iff,WORD_AND_COMM]); - -Theorem ABS_w2n[simp] - `ABS (&w2n w) = &w2n w` - (rw[integerTheory.INT_ABS_EQ_ID]); - -Theorem n2mw_w2n - `∀w. n2mw (w2n w) = if w = 0w then [] else [w]` - (simp[Once multiwordTheory.n2mw_def] +Theorem word_index_0: + !w. w ' 0 <=> ~((1w && w) = 0w) +Proof + metis_tac [word_and_one_eq_0_iff,WORD_AND_COMM] +QED + +Theorem ABS_w2n[simp]: + ABS (&w2n w) = &w2n w +Proof + rw[integerTheory.INT_ABS_EQ_ID] +QED + +Theorem n2mw_w2n: + ∀w. n2mw (w2n w) = if w = 0w then [] else [w] +Proof + simp[Once multiwordTheory.n2mw_def] \\ gen_tac \\ IF_CASES_TAC \\ fs[] \\ Q.ISPEC_THEN`w`mp_tac w2n_lt - \\ simp[LESS_DIV_EQ_ZERO,multiwordTheory.n2mw_NIL]); - -Theorem get_var_set_var[simp] - `get_var n (set_var n w s) = SOME w` - (full_simp_tac(srw_ss())[wordSemTheory.get_var_def,wordSemTheory.set_var_def]); - -Theorem set_var_set_var[simp] - `set_var n v (wordSem$set_var n w s) = set_var n v s` - (fs[wordSemTheory.state_component_equality,wordSemTheory.set_var_def, - insert_shadow]); - -Theorem toAList_LN[simp] - `toAList LN = []` - (EVAL_TAC) - -Theorem adjust_set_LN[simp] - `adjust_set LN = insert 0 () LN` - (srw_tac[][adjust_set_def,fromAList_def]); - -Theorem push_env_termdep - `(push_env y opt t).termdep = t.termdep` - (Cases_on `opt` \\ TRY (PairCases_on `x`) + \\ simp[LESS_DIV_EQ_ZERO,multiwordTheory.n2mw_NIL] +QED + +Theorem get_var_set_var[simp]: + get_var n (set_var n w s) = SOME w +Proof + full_simp_tac(srw_ss())[wordSemTheory.get_var_def,wordSemTheory.set_var_def] +QED + +Theorem set_var_set_var[simp]: + set_var n v (wordSem$set_var n w s) = set_var n v s +Proof + fs[wordSemTheory.state_component_equality,wordSemTheory.set_var_def, + insert_shadow] +QED + +Theorem toAList_LN[simp]: + toAList LN = [] +Proof + EVAL_TAC +QED + +Theorem adjust_set_LN[simp]: + adjust_set LN = insert 0 () LN +Proof + srw_tac[][adjust_set_def,fromAList_def] +QED + +Theorem push_env_termdep: + (push_env y opt t).termdep = t.termdep +Proof + Cases_on `opt` \\ TRY (PairCases_on `x`) \\ fs [wordSemTheory.push_env_def] - \\ pairarg_tac \\ fs []); - -Theorem ALOOKUP_SKIP_LEMMA - `¬MEM n (MAP FST xs) /\ d = e ==> - ALOOKUP (xs ++ [(n,d)] ++ ys) n = SOME e` - (full_simp_tac(srw_ss())[ALOOKUP_APPEND] \\ fs[GSYM ALOOKUP_NONE]) - -Theorem LAST_EQ - `(LAST (x::xs) = if xs = [] then x else LAST xs) /\ - (FRONT (x::xs) = if xs = [] then [] else x::FRONT xs)` - (Cases_on `xs` \\ full_simp_tac(srw_ss())[]); - -Theorem LASTN_LIST_REL_LEMMA - `!xs1 ys1 xs n y ys x P. + \\ pairarg_tac \\ fs [] +QED + +Theorem ALOOKUP_SKIP_LEMMA: + ¬MEM n (MAP FST xs) /\ d = e ==> + ALOOKUP (xs ++ [(n,d)] ++ ys) n = SOME e +Proof + full_simp_tac(srw_ss())[ALOOKUP_APPEND] \\ fs[GSYM ALOOKUP_NONE] +QED + +Theorem LAST_EQ: + (LAST (x::xs) = if xs = [] then x else LAST xs) /\ + (FRONT (x::xs) = if xs = [] then [] else x::FRONT xs) +Proof + Cases_on `xs` \\ full_simp_tac(srw_ss())[] +QED + +Theorem LASTN_LIST_REL_LEMMA: + !xs1 ys1 xs n y ys x P. LASTN n xs1 = x::xs /\ LIST_REL P xs1 ys1 ==> - ?y ys. LASTN n ys1 = y::ys /\ P x y /\ LIST_REL P xs ys` - (Induct \\ Cases_on `ys1` \\ full_simp_tac(srw_ss())[LASTN_ALT] \\ rpt strip_tac + ?y ys. LASTN n ys1 = y::ys /\ P x y /\ LIST_REL P xs ys +Proof + Induct \\ Cases_on `ys1` \\ full_simp_tac(srw_ss())[LASTN_ALT] \\ rpt strip_tac \\ imp_res_tac LIST_REL_LENGTH \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ every_case_tac \\ full_simp_tac(srw_ss())[] - \\ srw_tac[][] \\ `F` by decide_tac); + \\ srw_tac[][] \\ `F` by decide_tac +QED -Theorem LASTN_CONS_IMP_LENGTH - `!xs n y ys. +Theorem LASTN_CONS_IMP_LENGTH: + !xs n y ys. n <= LENGTH xs ==> - (LASTN n xs = y::ys) ==> LENGTH (y::ys) = n` - (Induct \\ full_simp_tac(srw_ss())[LASTN_ALT] - \\ srw_tac[][] THEN1 decide_tac \\ full_simp_tac(srw_ss())[GSYM NOT_LESS]); - -Theorem LASTN_IMP_APPEND - `!xs n ys. + (LASTN n xs = y::ys) ==> LENGTH (y::ys) = n +Proof + Induct \\ full_simp_tac(srw_ss())[LASTN_ALT] + \\ srw_tac[][] THEN1 decide_tac \\ full_simp_tac(srw_ss())[GSYM NOT_LESS] +QED + +Theorem LASTN_IMP_APPEND: + !xs n ys. n <= LENGTH xs /\ (LASTN n xs = ys) ==> - ?zs. xs = zs ++ ys /\ LENGTH ys = n` - (Induct \\ full_simp_tac(srw_ss())[LASTN_ALT] \\ srw_tac[][] THEN1 decide_tac + ?zs. xs = zs ++ ys /\ LENGTH ys = n +Proof + Induct \\ full_simp_tac(srw_ss())[LASTN_ALT] \\ srw_tac[][] THEN1 decide_tac \\ `n <= LENGTH xs` by decide_tac \\ res_tac \\ full_simp_tac(srw_ss())[] - \\ qpat_x_assum `xs = zs ++ LASTN n xs` (fn th => simp [Once th])); - -Theorem NOT_NIL_IMP_LAST - `!xs x. xs <> [] ==> LAST (x::xs) = LAST xs` - (Cases \\ full_simp_tac(srw_ss())[]); - -Theorem IS_SOME_IF - `IS_SOME (if b then x else y) = if b then IS_SOME x else IS_SOME y` - (Cases_on `b` \\ full_simp_tac(srw_ss())[]); - -Theorem IS_SOME_ALOOKUP_EQ - `!l x. IS_SOME (ALOOKUP l x) = MEM x (MAP FST l)` - (Induct \\ full_simp_tac(srw_ss())[] - \\ Cases \\ full_simp_tac(srw_ss())[ALOOKUP_def] \\ srw_tac[][]); - -Theorem MEM_IMP_IS_SOME_ALOOKUP - `!l x y. MEM (x,y) l ==> IS_SOME (ALOOKUP l x)` - (full_simp_tac(srw_ss())[IS_SOME_ALOOKUP_EQ,MEM_MAP,EXISTS_PROD] \\ metis_tac []); - -Theorem SUBSET_INSERT_EQ_SUBSET - `~(x IN s) ==> (s SUBSET (x INSERT t) <=> s SUBSET t)` - (full_simp_tac(srw_ss())[EXTENSION]); - -Theorem EVERY2_IMP_EL - `!xs ys P n. EVERY2 P xs ys /\ n < LENGTH ys ==> P (EL n xs) (EL n ys)` - (Induct \\ Cases_on `ys` \\ full_simp_tac(srw_ss())[] - \\ srw_tac[][] \\ Cases_on `n` \\ full_simp_tac(srw_ss())[]); - -Theorem FST_PAIR_EQ - `!x v. (FST x,v) = x <=> v = SND x` - (Cases \\ full_simp_tac(srw_ss())[]); - -Theorem EVERY2_APPEND_IMP - `!xs1 xs2 zs P. + \\ qpat_x_assum `xs = zs ++ LASTN n xs` (fn th => simp [Once th]) +QED + +Theorem NOT_NIL_IMP_LAST: + !xs x. xs <> [] ==> LAST (x::xs) = LAST xs +Proof + Cases \\ full_simp_tac(srw_ss())[] +QED + +Theorem IS_SOME_IF: + IS_SOME (if b then x else y) = if b then IS_SOME x else IS_SOME y +Proof + Cases_on `b` \\ full_simp_tac(srw_ss())[] +QED + +Theorem IS_SOME_ALOOKUP_EQ: + !l x. IS_SOME (ALOOKUP l x) = MEM x (MAP FST l) +Proof + Induct \\ full_simp_tac(srw_ss())[] + \\ Cases \\ full_simp_tac(srw_ss())[ALOOKUP_def] \\ srw_tac[][] +QED + +Theorem MEM_IMP_IS_SOME_ALOOKUP: + !l x y. MEM (x,y) l ==> IS_SOME (ALOOKUP l x) +Proof + full_simp_tac(srw_ss())[IS_SOME_ALOOKUP_EQ,MEM_MAP,EXISTS_PROD] \\ metis_tac [] +QED + +Theorem SUBSET_INSERT_EQ_SUBSET: + ~(x IN s) ==> (s SUBSET (x INSERT t) <=> s SUBSET t) +Proof + full_simp_tac(srw_ss())[EXTENSION] +QED + +Theorem EVERY2_IMP_EL: + !xs ys P n. EVERY2 P xs ys /\ n < LENGTH ys ==> P (EL n xs) (EL n ys) +Proof + Induct \\ Cases_on `ys` \\ full_simp_tac(srw_ss())[] + \\ srw_tac[][] \\ Cases_on `n` \\ full_simp_tac(srw_ss())[] +QED + +Theorem FST_PAIR_EQ: + !x v. (FST x,v) = x <=> v = SND x +Proof + Cases \\ full_simp_tac(srw_ss())[] +QED + +Theorem EVERY2_APPEND_IMP: + !xs1 xs2 zs P. EVERY2 P (xs1 ++ xs2) zs ==> - ?zs1 zs2. zs = zs1 ++ zs2 /\ EVERY2 P xs1 zs1 /\ EVERY2 P xs2 zs2` - (Induct \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] + ?zs1 zs2. zs = zs1 ++ zs2 /\ EVERY2 P xs1 zs1 /\ EVERY2 P xs2 zs2 +Proof + Induct \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ res_tac \\ full_simp_tac(srw_ss())[] - \\ Q.LIST_EXISTS_TAC [`y::zs1`,`zs2`] \\ full_simp_tac(srw_ss())[]); + \\ Q.LIST_EXISTS_TAC [`y::zs1`,`zs2`] \\ full_simp_tac(srw_ss())[] +QED -Theorem ZIP_ID - `!xs. ZIP (MAP FST xs, MAP SND xs) = xs` - (Induct \\ full_simp_tac(srw_ss())[]); +Theorem ZIP_ID: + !xs. ZIP (MAP FST xs, MAP SND xs) = xs +Proof + Induct \\ full_simp_tac(srw_ss())[] +QED -Theorem write_bytearray_isWord - `∀ls a m x. +Theorem write_bytearray_isWord: + ∀ls a m x. isWord (m x) ⇒ - isWord (write_bytearray a ls m dm be x)` - (Induct \\ rw[wordSemTheory.write_bytearray_def] + isWord (write_bytearray a ls m dm be x) +Proof + Induct \\ rw[wordSemTheory.write_bytearray_def] \\ rw[wordSemTheory.mem_store_byte_aux_def] \\ every_case_tac \\ fs[] \\ simp[APPLY_UPDATE_THM] - \\ rw[isWord_def]); + \\ rw[isWord_def] +QED -Theorem FOLDL_LENGTH_LEMMA - `!xs k l d q r. +Theorem FOLDL_LENGTH_LEMMA: + !xs k l d q r. FOLDL (λ(i,t) a. (i + d,insert i a t)) (k,l) xs = (q,r) ==> - q = LENGTH xs * d + k` - (Induct \\ fs [FOLDL] \\ rw [] \\ res_tac \\ fs [MULT_CLAUSES]); - -Theorem fromList_SNOC - `!xs y. fromList (SNOC y xs) = insert (LENGTH xs) y (fromList xs)` - (fs [fromList_def,FOLDL_APPEND,SNOC_APPEND] \\ rw [] + q = LENGTH xs * d + k +Proof + Induct \\ fs [FOLDL] \\ rw [] \\ res_tac \\ fs [MULT_CLAUSES] +QED + +Theorem fromList_SNOC: + !xs y. fromList (SNOC y xs) = insert (LENGTH xs) y (fromList xs) +Proof + fs [fromList_def,FOLDL_APPEND,SNOC_APPEND] \\ rw [] \\ Cases_on `FOLDL (λ(i,t) a. (i + 1,insert i a t)) (0,LN) xs` - \\ fs [] \\ imp_res_tac FOLDL_LENGTH_LEMMA \\ fs []); + \\ fs [] \\ imp_res_tac FOLDL_LENGTH_LEMMA \\ fs [] +QED -Theorem fromList2_SNOC - `!xs y. fromList2 (SNOC y xs) = insert (2 * LENGTH xs) y (fromList2 xs)` - (fs [fromList2_def,FOLDL_APPEND,SNOC_APPEND] \\ rw [] +Theorem fromList2_SNOC: + !xs y. fromList2 (SNOC y xs) = insert (2 * LENGTH xs) y (fromList2 xs) +Proof + fs [fromList2_def,FOLDL_APPEND,SNOC_APPEND] \\ rw [] \\ Cases_on `FOLDL (λ(i,t) a. (i + 2,insert i a t)) (0,LN) xs` - \\ fs [] \\ imp_res_tac FOLDL_LENGTH_LEMMA \\ fs []); + \\ fs [] \\ imp_res_tac FOLDL_LENGTH_LEMMA \\ fs [] +QED (* -- *) @@ -239,102 +305,133 @@ val flat_def = Define ` join_env env vs ++ flat xs ys) /\ (flat _ _ = [])` -Theorem flat_APPEND - `!xs ys xs1 ys1. +Theorem flat_APPEND: + !xs ys xs1 ys1. LENGTH xs = LENGTH ys ==> - flat (xs ++ xs1) (ys ++ ys1) = flat xs ys ++ flat xs1 ys1` - (Induct \\ Cases_on `ys` \\ full_simp_tac(srw_ss())[flat_def] \\ srw_tac[][] + flat (xs ++ xs1) (ys ++ ys1) = flat xs ys ++ flat xs1 ys1 +Proof + Induct \\ Cases_on `ys` \\ full_simp_tac(srw_ss())[flat_def] \\ srw_tac[][] \\ Cases_on `h'` \\ Cases_on `h` - \\ TRY (Cases_on `o'`) \\ full_simp_tac(srw_ss())[flat_def]); - -Theorem adjust_var_DIV_2 - `(adjust_var n - 2) DIV 2 = n` - (full_simp_tac(srw_ss())[ONCE_REWRITE_RULE[MULT_COMM]adjust_var_def,MULT_DIV]); - -Theorem adjust_var_DIV_2_ANY - `(adjust_var n) DIV 2 = n + 1` - (fs [adjust_var_def,ONCE_REWRITE_RULE[MULT_COMM]ADD_DIV_ADD_DIV]); - -Theorem EVEN_adjust_var - `EVEN (adjust_var n)` - (full_simp_tac(srw_ss())[adjust_var_def,EVEN_MOD2, - ONCE_REWRITE_RULE[MULT_COMM]MOD_TIMES]); - -Theorem adjust_var_eq_numeral[simp] - `adjust_var n = NUMERAL k <=> - EVEN (NUMERAL k) /\ NUMERAL k <> 0 /\ n = (NUMERAL k - 2) DIV 2` - (qabbrev_tac `kk = NUMERAL k` + \\ TRY (Cases_on `o'`) \\ full_simp_tac(srw_ss())[flat_def] +QED + +Theorem adjust_var_DIV_2: + (adjust_var n - 2) DIV 2 = n +Proof + full_simp_tac(srw_ss())[ONCE_REWRITE_RULE[MULT_COMM]adjust_var_def,MULT_DIV] +QED + +Theorem adjust_var_DIV_2_ANY: + (adjust_var n) DIV 2 = n + 1 +Proof + fs [adjust_var_def,ONCE_REWRITE_RULE[MULT_COMM]ADD_DIV_ADD_DIV] +QED + +Theorem EVEN_adjust_var: + EVEN (adjust_var n) +Proof + full_simp_tac(srw_ss())[adjust_var_def,EVEN_MOD2, + ONCE_REWRITE_RULE[MULT_COMM]MOD_TIMES] +QED + +Theorem adjust_var_eq_numeral[simp]: + adjust_var n = NUMERAL k <=> + EVEN (NUMERAL k) /\ NUMERAL k <> 0 /\ n = (NUMERAL k - 2) DIV 2 +Proof + qabbrev_tac `kk = NUMERAL k` \\ pop_assum kall_tac \\ fs [adjust_var_def] \\ fs [EVEN_EXISTS] \\ rw [] \\ eq_tac \\ rw [] THEN1 (qexists_tac `n+1` \\ fs []) \\ fs [ONCE_REWRITE_RULE [MULT_COMM] MULT_DIV] \\ Cases_on `m` \\ fs [ADD1,LEFT_ADD_DISTRIB] - \\ fs [ONCE_REWRITE_RULE [MULT_COMM] MULT_DIV]); - -Theorem adjust_var_NEQ_0[simp] - `adjust_var n <> 0` - (fs [adjust_var_def]); - -Theorem adjust_var_NEQ_1 - `adjust_var n <> 1` - (fs []); - -Theorem adjust_var_NEQ[simp] - `adjust_var n <> 0 /\ + \\ fs [ONCE_REWRITE_RULE [MULT_COMM] MULT_DIV] +QED + +Theorem adjust_var_NEQ_0[simp]: + adjust_var n <> 0 +Proof + fs [adjust_var_def] +QED + +Theorem adjust_var_NEQ_1: + adjust_var n <> 1 +Proof + fs [] +QED + +Theorem adjust_var_NEQ[simp]: + adjust_var n <> 0 /\ adjust_var n <> 1 /\ adjust_var n <> 3 /\ adjust_var n <> 5 /\ adjust_var n <> 7 /\ adjust_var n <> 9 /\ adjust_var n <> 11 /\ - adjust_var n <> 13` - (fs [adjust_var_NEQ_0]); - -Theorem unit_opt_eq - `(x = y:unit option) <=> (IS_SOME x <=> IS_SOME y)` - (Cases_on `x` \\ Cases_on `y` \\ full_simp_tac(srw_ss())[]); - -Theorem adjust_var_11 - `(adjust_var n = adjust_var m) <=> n = m` - (full_simp_tac(srw_ss())[adjust_var_def,EQ_MULT_LCANCEL]); - -Theorem lookup_adjust_var_adjust_set - `lookup (adjust_var n) (adjust_set s) = lookup n s` - (full_simp_tac(srw_ss())[lookup_def,adjust_set_def,lookup_fromAList,unit_opt_eq,adjust_var_NEQ_0] + adjust_var n <> 13 +Proof + fs [adjust_var_NEQ_0] +QED + +Theorem unit_opt_eq: + (x = y:unit option) <=> (IS_SOME x <=> IS_SOME y) +Proof + Cases_on `x` \\ Cases_on `y` \\ full_simp_tac(srw_ss())[] +QED + +Theorem adjust_var_11: + (adjust_var n = adjust_var m) <=> n = m +Proof + full_simp_tac(srw_ss())[adjust_var_def,EQ_MULT_LCANCEL] +QED + +Theorem lookup_adjust_var_adjust_set: + lookup (adjust_var n) (adjust_set s) = lookup n s +Proof + full_simp_tac(srw_ss())[lookup_def,adjust_set_def,lookup_fromAList,unit_opt_eq,adjust_var_NEQ_0] \\ full_simp_tac(srw_ss())[IS_SOME_ALOOKUP_EQ,MEM_MAP,PULL_EXISTS,EXISTS_PROD,adjust_var_11] - \\ full_simp_tac(srw_ss())[MEM_toAList] \\ Cases_on `lookup n s` \\ full_simp_tac(srw_ss())[]); - -Theorem adjust_var_IN_adjust_set - `adjust_var n IN domain (adjust_set (s:num_set)) <=> n IN domain s` - (fs [domain_lookup,lookup_adjust_var_adjust_set]); - -Theorem none_opt_eq - `((x = NONE) = (y = NONE)) <=> (IS_SOME x <=> IS_SOME y)` - (Cases_on `x` \\ Cases_on `y` \\ full_simp_tac(srw_ss())[]); - -Theorem lookup_adjust_var_adjust_set_NONE - `lookup (adjust_var n) (adjust_set s) = NONE <=> lookup n s = NONE` - (full_simp_tac(srw_ss())[lookup_def,adjust_set_def,lookup_fromAList,adjust_var_NEQ_0,none_opt_eq] + \\ full_simp_tac(srw_ss())[MEM_toAList] \\ Cases_on `lookup n s` \\ full_simp_tac(srw_ss())[] +QED + +Theorem adjust_var_IN_adjust_set: + adjust_var n IN domain (adjust_set (s:num_set)) <=> n IN domain s +Proof + fs [domain_lookup,lookup_adjust_var_adjust_set] +QED + +Theorem none_opt_eq: + ((x = NONE) = (y = NONE)) <=> (IS_SOME x <=> IS_SOME y) +Proof + Cases_on `x` \\ Cases_on `y` \\ full_simp_tac(srw_ss())[] +QED + +Theorem lookup_adjust_var_adjust_set_NONE: + lookup (adjust_var n) (adjust_set s) = NONE <=> lookup n s = NONE +Proof + full_simp_tac(srw_ss())[lookup_def,adjust_set_def,lookup_fromAList,adjust_var_NEQ_0,none_opt_eq] \\ full_simp_tac(srw_ss())[IS_SOME_ALOOKUP_EQ,MEM_MAP,PULL_EXISTS,EXISTS_PROD,adjust_var_11] - \\ full_simp_tac(srw_ss())[MEM_toAList] \\ Cases_on `lookup n s` \\ full_simp_tac(srw_ss())[]); + \\ full_simp_tac(srw_ss())[MEM_toAList] \\ Cases_on `lookup n s` \\ full_simp_tac(srw_ss())[] +QED -Theorem lookup_adjust_var_adjust_set_SOME_UNIT - `lookup (adjust_var n) (adjust_set s) = SOME () <=> IS_SOME (lookup n s)` - (Cases_on `lookup (adjust_var n) (adjust_set s) = NONE` +Theorem lookup_adjust_var_adjust_set_SOME_UNIT: + lookup (adjust_var n) (adjust_set s) = SOME () <=> IS_SOME (lookup n s) +Proof + Cases_on `lookup (adjust_var n) (adjust_set s) = NONE` \\ pop_assum (fn th => assume_tac th THEN assume_tac (SIMP_RULE std_ss [lookup_adjust_var_adjust_set_NONE] th)) \\ full_simp_tac(srw_ss())[] \\ Cases_on `lookup n s` - \\ Cases_on `lookup (adjust_var n) (adjust_set s)` \\ full_simp_tac(srw_ss())[]); + \\ Cases_on `lookup (adjust_var n) (adjust_set s)` \\ full_simp_tac(srw_ss())[] +QED -Theorem word_ml_inv_lookup - `word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs +Theorem word_ml_inv_lookup: + word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs (ys ++ join_env l1 (toAList (inter l2 (adjust_set l1))) ++ xs) /\ lookup n l1 = SOME x /\ lookup (adjust_var n) l2 = SOME w ==> word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs - (ys ++ [(x,w)] ++ join_env l1 (toAList (inter l2 (adjust_set l1))) ++ xs)` - (full_simp_tac(srw_ss())[toAList_def,foldi_def,LET_DEF] + (ys ++ [(x,w)] ++ join_env l1 (toAList (inter l2 (adjust_set l1))) ++ xs) +Proof + full_simp_tac(srw_ss())[toAList_def,foldi_def,LET_DEF] \\ full_simp_tac(srw_ss())[GSYM toAList_def] \\ srw_tac[][] \\ `MEM (x,w) (join_env l1 (toAList (inter l2 (adjust_set l1))))` by (full_simp_tac(srw_ss())[join_env_def,MEM_MAP,MEM_FILTER,EXISTS_PROD,MEM_toAList,lookup_inter] @@ -343,34 +440,39 @@ Theorem word_ml_inv_lookup \\ full_simp_tac(srw_ss())[lookup_adjust_var_adjust_set_NONE]) \\ full_simp_tac(srw_ss())[MEM_SPLIT] \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[adjust_var_def] \\ qpat_x_assum `word_ml_inv yyy limit c refs xxx` mp_tac - \\ match_mp_tac word_ml_inv_rearrange \\ full_simp_tac(srw_ss())[MEM] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[]); + \\ match_mp_tac word_ml_inv_rearrange \\ full_simp_tac(srw_ss())[MEM] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] +QED -Theorem word_ml_inv_get_var_IMP_lemma - `word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs +Theorem word_ml_inv_get_var_IMP_lemma: + word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs (join_env ll (toAList (inter t.locals (adjust_set ll)))++envs) /\ get_var n ll = SOME x /\ get_var (adjust_var n) t = SOME w ==> word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs ([(x,w)]++join_env ll - (toAList (inter t.locals (adjust_set ll)))++envs)` - (srw_tac[][] \\ match_mp_tac (word_ml_inv_lookup + (toAList (inter t.locals (adjust_set ll)))++envs) +Proof + srw_tac[][] \\ match_mp_tac (word_ml_inv_lookup |> Q.INST [`ys`|->`[]`] |> SIMP_RULE std_ss [APPEND]) - \\ full_simp_tac(srw_ss())[get_var_def,wordSemTheory.get_var_def]); + \\ full_simp_tac(srw_ss())[get_var_def,wordSemTheory.get_var_def] +QED -Theorem word_ml_inv_get_var_IMP - `word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs +Theorem word_ml_inv_get_var_IMP: + word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs (join_env s.locals (toAList (inter t.locals (adjust_set s.locals)))++envs) /\ get_var n s.locals = SOME x /\ get_var (adjust_var n) t = SOME w ==> word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs ([(x,w)]++join_env s.locals - (toAList (inter t.locals (adjust_set s.locals)))++envs)` - (srw_tac[][] \\ match_mp_tac (word_ml_inv_lookup + (toAList (inter t.locals (adjust_set s.locals)))++envs) +Proof + srw_tac[][] \\ match_mp_tac (word_ml_inv_lookup |> Q.INST [`ys`|->`[]`] |> SIMP_RULE std_ss [APPEND]) - \\ full_simp_tac(srw_ss())[get_var_def,wordSemTheory.get_var_def]); + \\ full_simp_tac(srw_ss())[get_var_def,wordSemTheory.get_var_def] +QED -Theorem word_ml_inv_get_vars_IMP_lemma - `!n x w envs. +Theorem word_ml_inv_get_vars_IMP_lemma = Q.prove(` + !n x w envs. word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs (join_env ll (toAList (inter t.locals (adjust_set ll)))++envs) /\ @@ -378,8 +480,8 @@ Theorem word_ml_inv_get_vars_IMP_lemma get_vars (MAP adjust_var n) t = SOME w ==> word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs (ZIP(x,w)++join_env ll - (toAList (inter t.locals (adjust_set ll)))++envs)` - (Induct \\ full_simp_tac(srw_ss())[get_vars_def,wordSemTheory.get_vars_def] + (toAList (inter t.locals (adjust_set ll)))++envs)`, + Induct \\ full_simp_tac(srw_ss())[get_vars_def,wordSemTheory.get_vars_def] \\ rpt strip_tac \\ every_case_tac \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ imp_res_tac word_ml_inv_get_var_IMP_lemma @@ -395,8 +497,8 @@ Theorem word_ml_inv_get_vars_IMP_lemma \\ full_simp_tac(srw_ss())[MEM] \\ srw_tac[][] \\ fs[]) |> SPEC_ALL |> curry save_thm "word_ml_inv_get_vars_IMP_lemma"; -Theorem word_ml_inv_get_vars_IMP - `!n x w envs. +Theorem word_ml_inv_get_vars_IMP = Q.prove(` + !n x w envs. word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs (join_env s.locals (toAList (inter t.locals (adjust_set s.locals)))++envs) /\ @@ -404,28 +506,33 @@ Theorem word_ml_inv_get_vars_IMP get_vars (MAP adjust_var n) t = SOME w ==> word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs (ZIP(x,w)++join_env s.locals - (toAList (inter t.locals (adjust_set s.locals)))++envs)` - (metis_tac [word_ml_inv_get_vars_IMP_lemma]) |> SPEC_ALL + (toAList (inter t.locals (adjust_set s.locals)))++envs)`, + metis_tac [word_ml_inv_get_vars_IMP_lemma]) |> SPEC_ALL |> curry save_thm "word_ml_inv_get_vars_IMP"; -Theorem IMP_adjust_var - `n <> 0 /\ EVEN n ==> adjust_var ((n - 2) DIV 2) = n` - (full_simp_tac(srw_ss())[EVEN_EXISTS] \\ srw_tac[][] \\ Cases_on `m` \\ full_simp_tac(srw_ss())[MULT_CLAUSES] +Theorem IMP_adjust_var: + n <> 0 /\ EVEN n ==> adjust_var ((n - 2) DIV 2) = n +Proof + full_simp_tac(srw_ss())[EVEN_EXISTS] \\ srw_tac[][] \\ Cases_on `m` \\ full_simp_tac(srw_ss())[MULT_CLAUSES] \\ once_rewrite_tac [MULT_COMM] \\ full_simp_tac(srw_ss())[MULT_DIV] - \\ full_simp_tac(srw_ss())[adjust_var_def] \\ decide_tac); + \\ full_simp_tac(srw_ss())[adjust_var_def] \\ decide_tac +QED -Theorem unit_some_eq_IS_SOME - `!x. (x = SOME ()) <=> IS_SOME x` - (Cases \\ full_simp_tac(srw_ss())[]); +Theorem unit_some_eq_IS_SOME: + !x. (x = SOME ()) <=> IS_SOME x +Proof + Cases \\ full_simp_tac(srw_ss())[] +QED -Theorem word_ml_inv_insert - `word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs +Theorem word_ml_inv_insert: + word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs ([(x,w)]++join_env d (toAList (inter l (adjust_set d)))++xs) ==> word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs (join_env (insert dest x d) (toAList (inter (insert (adjust_var dest) w l) - (adjust_set (insert dest x d))))++xs)` - (match_mp_tac word_ml_inv_rearrange \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] + (adjust_set (insert dest x d))))++xs) +Proof + match_mp_tac word_ml_inv_rearrange \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[join_env_def,MEM_MAP,MEM_FILTER,EXISTS_PROD] \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[MEM_toAList] \\ full_simp_tac(srw_ss())[lookup_insert,lookup_inter_alt] @@ -437,64 +544,88 @@ Theorem word_ml_inv_insert \\ disj1_tac \\ disj2_tac \\ qexists_tac `p_1` \\ full_simp_tac(srw_ss())[unit_some_eq_IS_SOME] \\ full_simp_tac(srw_ss())[adjust_set_def,lookup_fromAList] \\ rev_full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[IS_SOME_ALOOKUP_EQ,MEM_MAP,PULL_EXISTS,EXISTS_PROD,adjust_var_11] - \\ full_simp_tac(srw_ss())[MEM_toAList,lookup_insert] \\ every_case_tac \\ full_simp_tac(srw_ss())[]); - -Theorem one_and_or_1 - `(1w && (w || 1w)) = 1w` - (srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] [word_index]) - -Theorem one_and_or_3 - `(3w && (w || 3w)) = 3w` - (srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] [word_index]) - -Theorem ODD_not_zero - `ODD n ==> n2w n <> 0w` - (CCONTR_TAC \\ full_simp_tac std_ss [] + \\ full_simp_tac(srw_ss())[MEM_toAList,lookup_insert] \\ every_case_tac \\ full_simp_tac(srw_ss())[] +QED + +Theorem one_and_or_1: + (1w && (w || 1w)) = 1w +Proof + srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] [word_index] +QED + +Theorem one_and_or_3: + (3w && (w || 3w)) = 3w +Proof + srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] [word_index] +QED + +Theorem ODD_not_zero: + ODD n ==> n2w n <> 0w +Proof + CCONTR_TAC \\ full_simp_tac std_ss [] \\ `((n2w n):'a word) ' 0 = (0w:'a word) ' 0` by metis_tac [] \\ full_simp_tac(srw_ss())[wordsTheory.word_index,bitTheory.BIT_def,bitTheory.BITS_THM] - \\ full_simp_tac(srw_ss())[dimword_def,bitTheory.ODD_MOD2_LEM]) + \\ full_simp_tac(srw_ss())[dimword_def,bitTheory.ODD_MOD2_LEM] +QED -Theorem three_not_0[simp] - `3w <> 0w` - (match_mp_tac ODD_not_zero \\ full_simp_tac(srw_ss())[]); +Theorem three_not_0[simp]: + 3w <> 0w +Proof + match_mp_tac ODD_not_zero \\ full_simp_tac(srw_ss())[] +QED val DISJ_EQ_IMP = METIS_PROVE [] ``(~b \/ c) <=> (b ==> c)`` -Theorem three_and_shift_2 - `(3w && (w << 2)) = 0w` - (srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] [word_index]) - -Theorem shift_to_zero - `3w >>> 2 = 0w` - (srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] [word_index]) - -Theorem shift_around_under_big_shift - `!w n k. n <= k ==> (w << n >>> n << k = w << k)` - (srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] [word_index]) - -Theorem select_shift_out - `n <> 0 /\ n <= m ==> ((n - 1 -- 0) (w || v << m) = (n - 1 -- 0) w)` - (srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] [word_index]); - -Theorem shift_length_NOT_ZERO[simp] - `shift_length conf <> 0` - (full_simp_tac(srw_ss())[shift_length_def] \\ decide_tac); - -Theorem get_addr_and_1_not_0 - `(1w && get_addr conf k a) <> 0w` - (Cases_on `a` \\ full_simp_tac(srw_ss())[get_addr_def,get_lowerbits_def] - \\ rewrite_tac [one_and_or_1,GSYM WORD_OR_ASSOC] \\ full_simp_tac(srw_ss())[]); - -Theorem one_lsr_shift_length - `1w >>> shift_length conf = 0w` - (srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] - [word_index, shift_length_def]) - -Theorem ptr_to_addr_get_addr - `k * 2 ** shift_length conf < dimword (:'a) ==> +Theorem three_and_shift_2: + (3w && (w << 2)) = 0w +Proof + srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] [word_index] +QED + +Theorem shift_to_zero: + 3w >>> 2 = 0w +Proof + srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] [word_index] +QED + +Theorem shift_around_under_big_shift: + !w n k. n <= k ==> (w << n >>> n << k = w << k) +Proof + srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] [word_index] +QED + +Theorem select_shift_out: + n <> 0 /\ n <= m ==> ((n - 1 -- 0) (w || v << m) = (n - 1 -- 0) w) +Proof + srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] [word_index] +QED + +Theorem shift_length_NOT_ZERO[simp]: + shift_length conf <> 0 +Proof + full_simp_tac(srw_ss())[shift_length_def] \\ decide_tac +QED + +Theorem get_addr_and_1_not_0: + (1w && get_addr conf k a) <> 0w +Proof + Cases_on `a` \\ full_simp_tac(srw_ss())[get_addr_def,get_lowerbits_def] + \\ rewrite_tac [one_and_or_1,GSYM WORD_OR_ASSOC] \\ full_simp_tac(srw_ss())[] +QED + +Theorem one_lsr_shift_length: + 1w >>> shift_length conf = 0w +Proof + srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] + [word_index, shift_length_def] +QED + +Theorem ptr_to_addr_get_addr: + k * 2 ** shift_length conf < dimword (:'a) ==> ptr_to_addr conf curr (get_addr conf k a) = - curr + n2w k * bytes_in_word:'a word` - (strip_tac + curr + n2w k * bytes_in_word:'a word +Proof + strip_tac \\ full_simp_tac(srw_ss())[ptr_to_addr_def,bytes_in_word_def,WORD_MUL_LSL,get_addr_def] \\ simp_tac std_ss [Once WORD_MULT_COMM] \\ AP_THM_TAC \\ AP_TERM_TAC \\ full_simp_tac(srw_ss())[get_lowerbits_LSL_shift_length,word_mul_n2w] @@ -503,88 +634,110 @@ Theorem ptr_to_addr_get_addr \\ full_simp_tac(srw_ss())[MULT_DIV] \\ Cases_on `2 ** shift_length conf` \\ full_simp_tac(srw_ss())[] \\ Cases_on `n` \\ full_simp_tac(srw_ss())[MULT_CLAUSES] - \\ decide_tac); + \\ decide_tac +QED -Theorem is_fws_ptr_OR_3 - `is_fwd_ptr (Word (w << 2)) /\ ~is_fwd_ptr (Word (w || 3w))` - (full_simp_tac(srw_ss())[is_fwd_ptr_def] \\ rewrite_tac [one_and_or_3,three_and_shift_2] - \\ full_simp_tac(srw_ss())[]); +Theorem is_fws_ptr_OR_3: + is_fwd_ptr (Word (w << 2)) /\ ~is_fwd_ptr (Word (w || 3w)) +Proof + full_simp_tac(srw_ss())[is_fwd_ptr_def] \\ rewrite_tac [one_and_or_3,three_and_shift_2] + \\ full_simp_tac(srw_ss())[] +QED -Theorem is_fws_ptr_OR_15 - `~is_fwd_ptr (Word (w || 15w))` - (full_simp_tac(srw_ss())[is_fwd_ptr_def] +Theorem is_fws_ptr_OR_15: + ~is_fwd_ptr (Word (w || 15w)) +Proof + full_simp_tac(srw_ss())[is_fwd_ptr_def] \\ srw_tac [wordsLib.WORD_BIT_EQ_ss] [word_index, get_lowerbits_def] - \\ qexists_tac `0` \\ fs []); + \\ qexists_tac `0` \\ fs [] +QED -Theorem is_fws_ptr_OR_10111 - `~is_fwd_ptr (Word (w || 0b10111w))` - (full_simp_tac(srw_ss())[is_fwd_ptr_def] +Theorem is_fws_ptr_OR_10111: + ~is_fwd_ptr (Word (w || 0b10111w)) +Proof + full_simp_tac(srw_ss())[is_fwd_ptr_def] \\ srw_tac [wordsLib.WORD_BIT_EQ_ss] [word_index, get_lowerbits_def] - \\ qexists_tac `0` \\ fs []); + \\ qexists_tac `0` \\ fs [] +QED -Theorem is_fws_ptr_OR_7 - `~is_fwd_ptr (Word (w || 7w))` - (full_simp_tac(srw_ss())[is_fwd_ptr_def] +Theorem is_fws_ptr_OR_7: + ~is_fwd_ptr (Word (w || 7w)) +Proof + full_simp_tac(srw_ss())[is_fwd_ptr_def] \\ srw_tac [wordsLib.WORD_BIT_EQ_ss] [word_index, get_lowerbits_def] - \\ qexists_tac `0` \\ fs []); + \\ qexists_tac `0` \\ fs [] +QED -Theorem select_get_lowerbits - `(shift_length conf − 1 -- 0) (get_lowerbits conf a) = +Theorem select_get_lowerbits: + (shift_length conf − 1 -- 0) (get_lowerbits conf a) = get_lowerbits conf a /\ (small_shift_length conf − 1 -- 0) (get_lowerbits conf a) = - get_lowerbits conf a` - (Cases_on `a` + get_lowerbits conf a +Proof + Cases_on `a` \\ srw_tac [wordsLib.WORD_BIT_EQ_ss] [word_index, get_lowerbits_def, small_shift_length_def,shift_length_def] - \\ eq_tac \\ rw [] \\ fs []); + \\ eq_tac \\ rw [] \\ fs [] +QED -Theorem LE_DIV_LT_IMP - `n <= l DIV 2 ** m /\ k < n ==> k * 2 ** m < l` - (srw_tac[][] \\ `k < l DIV 2 ** m` by decide_tac +Theorem LE_DIV_LT_IMP: + n <= l DIV 2 ** m /\ k < n ==> k * 2 ** m < l +Proof + srw_tac[][] \\ `k < l DIV 2 ** m` by decide_tac \\ full_simp_tac(srw_ss())[X_LT_DIV,MULT_CLAUSES,GSYM ADD1] \\ Cases_on `2 ** m` \\ full_simp_tac(srw_ss())[] - \\ decide_tac); + \\ decide_tac +QED -Theorem word_bits_eq_slice_shift - `((k -- n) w) = (((k '' n) w) >>> n)` - (srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] [word_index] +Theorem word_bits_eq_slice_shift: + ((k -- n) w) = (((k '' n) w) >>> n) +Proof + srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] [word_index] \\ Cases_on `i + n < dimindex (:'a)` \\ fs [] - ) +QED -Theorem word_slice_or - `(k '' n) (w || v) = ((k '' n) w || (k '' n) v)` - (srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] [word_index] +Theorem word_slice_or: + (k '' n) (w || v) = ((k '' n) w || (k '' n) v) +Proof + srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] [word_index] \\ eq_tac \\ rw [] \\ fs [] - ) +QED -Theorem word_slice_lsl_eq_0 - `(k '' n) (w << (k + 1)) = 0w` - (srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] [word_index]) +Theorem word_slice_lsl_eq_0: + (k '' n) (w << (k + 1)) = 0w +Proof + srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] [word_index] +QED -Theorem word_slice_2_3_eq_0 - `(n '' 2) 3w = 0w` - (srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] [word_index]) +Theorem word_slice_2_3_eq_0: + (n '' 2) 3w = 0w +Proof + srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] [word_index] +QED val can_select_def = Define ` can_select k n w <=> ((k - 1 -- n) (w << n) = w)` -Theorem read_length_lemma - `can_select (n+2) 2 (n2w k :'a word) ==> - (((n + 1 -- 2) (h ≪ (2 + n) ‖ n2w k ≪ 2 ‖ 3w)) = n2w k :'a word)` - (full_simp_tac(srw_ss())[word_bits_eq_slice_shift,word_slice_or,can_select_def,DECIDE ``n+2-1=n+1n``] - \\ full_simp_tac(srw_ss())[DECIDE ``2+n=n+1+1n``,word_slice_lsl_eq_0,word_slice_2_3_eq_0]); +Theorem read_length_lemma: + can_select (n+2) 2 (n2w k :'a word) ==> + (((n + 1 -- 2) (h ≪ (2 + n) ‖ n2w k ≪ 2 ‖ 3w)) = n2w k :'a word) +Proof + full_simp_tac(srw_ss())[word_bits_eq_slice_shift,word_slice_or,can_select_def,DECIDE ``n+2-1=n+1n``] + \\ full_simp_tac(srw_ss())[DECIDE ``2+n=n+1+1n``,word_slice_lsl_eq_0,word_slice_2_3_eq_0] +QED -Theorem memcpy_thm - `!xs a:'a word c b m m1 dm b1 ys frame. +Theorem memcpy_thm: + !xs a:'a word c b m m1 dm b1 ys frame. memcpy (n2w (LENGTH xs):'a word) a b m dm = (b1,m1,c) /\ (LENGTH ys = LENGTH xs) /\ LENGTH xs < dimword(:'a) /\ (frame * word_list a xs * word_list b ys) (fun2set (m,dm)) ==> (frame * word_list a xs * word_list b xs) (fun2set (m1,dm)) /\ - b1 = b + n2w (LENGTH xs) * bytes_in_word /\ c` - (Induct_on `xs` \\ Cases_on `ys` + b1 = b + n2w (LENGTH xs) * bytes_in_word /\ c +Proof + Induct_on `xs` \\ Cases_on `ys` THEN1 (simp [LENGTH,Once memcpy_def,LENGTH]) THEN1 (simp [LENGTH,Once memcpy_def,LENGTH]) THEN1 (rpt strip_tac \\ full_simp_tac(srw_ss())[LENGTH]) @@ -604,22 +757,27 @@ Theorem memcpy_thm \\ full_simp_tac(srw_ss())[AC STAR_ASSOC STAR_COMM] \\ rpt (disch_then assume_tac) \\ full_simp_tac(srw_ss())[] \\ imp_res_tac (DECIDE ``n+1n n ?ys zs. xs = ys ++ zs /\ LENGTH ys = n` - (Induct_on `xs` \\ full_simp_tac(srw_ss())[] \\ Cases_on `n` \\ full_simp_tac(srw_ss())[LENGTH_NIL] +Theorem LESS_EQ_IMP_APPEND: + !n xs. n <= LENGTH xs ==> ?ys zs. xs = ys ++ zs /\ LENGTH ys = n +Proof + Induct_on `xs` \\ full_simp_tac(srw_ss())[] \\ Cases_on `n` \\ full_simp_tac(srw_ss())[LENGTH_NIL] \\ srw_tac[][] \\ res_tac \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] - \\ qexists_tac `h::ys` \\ full_simp_tac(srw_ss())[]); + \\ qexists_tac `h::ys` \\ full_simp_tac(srw_ss())[] +QED -Theorem NOT_is_fwd_ptr - `word_payload addrs ll tag tt1 conf = (h,ts,c5) ==> ~is_fwd_ptr (Word h)` - (Cases_on `tag` \\ fs [word_payload_def] \\ rw [make_byte_header_def] +Theorem NOT_is_fwd_ptr: + word_payload addrs ll tag tt1 conf = (h,ts,c5) ==> ~is_fwd_ptr (Word h) +Proof + Cases_on `tag` \\ fs [word_payload_def] \\ rw [make_byte_header_def] \\ full_simp_tac std_ss [GSYM WORD_OR_ASSOC,is_fws_ptr_OR_3,is_fws_ptr_OR_15, - is_fws_ptr_OR_10111,is_fws_ptr_OR_7,isWord_def,theWord_def,make_header_def,LET_DEF]); + is_fws_ptr_OR_10111,is_fws_ptr_OR_7,isWord_def,theWord_def,make_header_def,LET_DEF] +QED -Theorem word_gc_move_thm - `(copying_gc$gc_move (x,[],a,n,heap,T,limit) = (x1,h1,a1,n1,heap1,T)) /\ +Theorem word_gc_move_thm: + (copying_gc$gc_move (x,[],a,n,heap,T,limit) = (x1,h1,a1,n1,heap1,T)) /\ heap_length heap <= dimword (:'a) DIV 2 ** shift_length conf /\ (word_heap curr heap conf * word_list pa xs * frame) (fun2set (m,dm)) /\ (word_gc_move conf (word_addr conf x,n2w a,pa,curr,m,dm) = @@ -632,8 +790,9 @@ Theorem word_gc_move_thm (w = word_addr conf x1) /\ heap_length heap1 = heap_length heap /\ c1 /\ (i1 = n2w a1) /\ n1 = LENGTH xs1 /\ - pa1 = pa + bytes_in_word * n2w (heap_length h1)` - (reverse (Cases_on `x`) \\ full_simp_tac(srw_ss())[copying_gcTheory.gc_move_def] THEN1 + pa1 = pa + bytes_in_word * n2w (heap_length h1) +Proof + reverse (Cases_on `x`) \\ full_simp_tac(srw_ss())[copying_gcTheory.gc_move_def] THEN1 (srw_tac[][] \\ full_simp_tac(srw_ss())[word_heap_def,SEP_CLAUSES] \\ Cases_on `a'` \\ full_simp_tac(srw_ss())[word_addr_def,word_gc_move_def] \\ qexists_tac `xs` \\ full_simp_tac(srw_ss())[heap_length_def]) @@ -707,10 +866,11 @@ Theorem word_gc_move_thm \\ full_simp_tac(srw_ss())[heap_length_def,SUM_APPEND,el_length_def,ADD1] \\ full_simp_tac(srw_ss())[word_list_exists_def,SEP_CLAUSES,SEP_EXISTS_THM] \\ srw_tac[][] \\ qexists_tac `ts` - \\ full_simp_tac(srw_ss())[AC STAR_ASSOC STAR_COMM,SEP_CLAUSES]); + \\ full_simp_tac(srw_ss())[AC STAR_ASSOC STAR_COMM,SEP_CLAUSES] +QED -Theorem word_gc_move_roots_thm - `!x a n heap limit pa x1 h1 a1 n1 heap1 pa1 m m1 xs i1 c1 w frame. +Theorem word_gc_move_roots_thm: + !x a n heap limit pa x1 h1 a1 n1 heap1 pa1 m m1 xs i1 c1 w frame. (gc_move_list (x,[],a,n,heap,T,limit) = (x1,h1,a1,n1,heap1,T)) /\ heap_length heap <= dimword (:'a) DIV 2 ** shift_length conf /\ (word_heap curr heap conf * word_list pa xs * frame) (fun2set (m,dm)) /\ @@ -724,8 +884,9 @@ Theorem word_gc_move_roots_thm (w = MAP (word_addr conf) x1) /\ heap_length heap1 = heap_length heap /\ c1 /\ (i1 = n2w a1) /\ n1 = LENGTH xs1 /\ - pa1 = pa + n2w (heap_length h1) * bytes_in_word` - (Induct THEN1 + pa1 = pa + n2w (heap_length h1) * bytes_in_word +Proof + Induct THEN1 (full_simp_tac(srw_ss())[copying_gcTheory.gc_move_list_def,word_gc_move_roots_def,word_heap_def,SEP_CLAUSES] \\ srw_tac[][] \\ qexists_tac `xs` \\ full_simp_tac(srw_ss())[heap_length_def]) \\ srw_tac[][] \\ full_simp_tac(srw_ss())[copying_gcTheory.gc_move_list_def,LET_THM] @@ -758,10 +919,11 @@ Theorem word_gc_move_roots_thm \\ qexists_tac `xs9` \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[word_heap_APPEND] \\ full_simp_tac(srw_ss())[AC STAR_COMM STAR_ASSOC] - \\ full_simp_tac(srw_ss())[WORD_LEFT_ADD_DISTRIB,heap_length_def,SUM_APPEND,GSYM word_add_n2w]); + \\ full_simp_tac(srw_ss())[WORD_LEFT_ADD_DISTRIB,heap_length_def,SUM_APPEND,GSYM word_add_n2w] +QED -Theorem word_gc_move_list_thm - `!x a n heap limit pa x1 h1 a1 n1 heap1 pa1 m m1 xs i1 c1 frame k k1. +Theorem word_gc_move_list_thm: + !x a n heap limit pa x1 h1 a1 n1 heap1 pa1 m m1 xs i1 c1 frame k k1. (copying_gc$gc_move_list (x,[],a,n,heap,T,limit) = (x1,h1,a1,n1,heap1,T)) /\ heap_length heap <= dimword (:'a) DIV 2 ** shift_length conf /\ (word_gc_move_list conf (k,n2w (LENGTH x),n2w a,pa,curr,m,dm) = @@ -777,8 +939,9 @@ Theorem word_gc_move_list_thm heap_length heap1 = heap_length heap /\ c1 /\ (i1 = n2w a1) /\ n1 = LENGTH xs1 /\ k1 = k + n2w (LENGTH x) * bytes_in_word /\ - pa1 = pa + n2w (heap_length h1) * bytes_in_word` - (Induct THEN1 + pa1 = pa + n2w (heap_length h1) * bytes_in_word +Proof + Induct THEN1 (full_simp_tac(srw_ss())[copying_gcTheory.gc_move_list_def,Once word_gc_move_list_def,word_heap_def,SEP_CLAUSES] \\ srw_tac[][] \\ qexists_tac `xs` \\ full_simp_tac(srw_ss())[heap_length_def]) \\ srw_tac[][] \\ full_simp_tac(srw_ss())[copying_gcTheory.gc_move_list_def,LET_THM] @@ -820,17 +983,20 @@ Theorem word_gc_move_list_thm \\ full_simp_tac(srw_ss())[word_heap_APPEND] \\ full_simp_tac(srw_ss())[AC STAR_COMM STAR_ASSOC] \\ full_simp_tac(srw_ss())[WORD_LEFT_ADD_DISTRIB,heap_length_def, - SUM_APPEND,GSYM word_add_n2w]); + SUM_APPEND,GSYM word_add_n2w] +QED -Theorem word_payload_swap - `word_payload l5 (LENGTH l5) tag r conf = (h,MAP (word_addr conf) l5,T) /\ +Theorem word_payload_swap: + word_payload l5 (LENGTH l5) tag r conf = (h,MAP (word_addr conf) l5,T) /\ LENGTH xs' = LENGTH l5 ==> - word_payload xs' (LENGTH l5) tag r conf = (h,MAP (word_addr conf) xs',T)` - (Cases_on `tag` \\ full_simp_tac(srw_ss())[word_payload_def] - \\ srw_tac[][] \\ full_simp_tac(srw_ss())[LENGTH_NIL]); - -Theorem word_gc_move_loop_thm - `!h1 h2 a n heap c0 limit h11 a1 n1 heap1 i1 pa1 m1 c1 xs frame m k. + word_payload xs' (LENGTH l5) tag r conf = (h,MAP (word_addr conf) xs',T) +Proof + Cases_on `tag` \\ full_simp_tac(srw_ss())[word_payload_def] + \\ srw_tac[][] \\ full_simp_tac(srw_ss())[LENGTH_NIL] +QED + +Theorem word_gc_move_loop_thm: + !h1 h2 a n heap c0 limit h11 a1 n1 heap1 i1 pa1 m1 c1 xs frame m k. (gc_move_loop (h1,h2,a,n,heap,c0,limit) = (h11,a1,n1,heap1,T)) /\ c0 /\ heap_length heap <= dimword (:'a) DIV 2 ** shift_length conf /\ heap_length heap * (dimindex (:'a) DIV 8) < dimword (:'a) /\ @@ -850,8 +1016,9 @@ Theorem word_gc_move_loop_thm word_list pa1 xs1 * frame) (fun2set (m1,dm)) /\ heap_length heap1 = heap_length heap /\ c1 /\ (i1 = n2w a1) /\ n1 = LENGTH xs1 /\ - pa1 = new + bytes_in_word * n2w (heap_length h11)` - (recInduct gc_move_loop_ind \\ rpt strip_tac + pa1 = new + bytes_in_word * n2w (heap_length h11) +Proof + recInduct gc_move_loop_ind \\ rpt strip_tac THEN1 (full_simp_tac(srw_ss())[gc_move_loop_def] \\ rpt var_eq_tac \\ full_simp_tac(srw_ss())[] @@ -959,10 +1126,11 @@ Theorem word_gc_move_loop_thm \\ qpat_x_assum `_ (fun2set (m1',dm))` mp_tac \\ full_simp_tac(srw_ss())[word_heap_APPEND,heap_length_def,el_length_def,SUM_APPEND] \\ full_simp_tac(srw_ss())[GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB,SEP_CLAUSES] - \\ full_simp_tac(srw_ss())[AC STAR_ASSOC STAR_COMM,word_heap_APPEND]); + \\ full_simp_tac(srw_ss())[AC STAR_ASSOC STAR_COMM,word_heap_APPEND] +QED -Theorem word_full_gc_thm - `(full_gc (roots,heap,limit) = (roots1,heap1,a1,T)) /\ +Theorem word_full_gc_thm: + (full_gc (roots,heap,limit) = (roots1,heap1,a1,T)) /\ heap_length heap <= dimword (:'a) DIV 2 ** shift_length conf /\ heap_length heap * (dimindex (:'a) DIV 8) < dimword (:'a) /\ conf.len_size + 2 < dimindex (:'a) /\ @@ -975,8 +1143,9 @@ Theorem word_full_gc_thm word_heap curr (heap_expand limit) conf * frame) (fun2set (m1,dm)) /\ c1 /\ i1 = n2w a1 /\ rs1 = MAP (word_addr conf) roots1 /\ - pa1 = new + bytes_in_word * n2w a1` - (strip_tac \\ full_simp_tac(srw_ss())[full_gc_def,LET_THM] + pa1 = new + bytes_in_word * n2w a1 +Proof + strip_tac \\ full_simp_tac(srw_ss())[full_gc_def,LET_THM] \\ pairarg_tac \\ full_simp_tac(srw_ss())[] \\ pairarg_tac \\ full_simp_tac(srw_ss())[] \\ rpt var_eq_tac \\ full_simp_tac(srw_ss())[] @@ -1014,24 +1183,30 @@ Theorem word_full_gc_thm \\ rename1 `LENGTH ys = heap_length temp` \\ qexists_tac `ys` \\ full_simp_tac(srw_ss())[heap_length_def] \\ qexists_tac `xs1'` \\ full_simp_tac(srw_ss())[] - \\ full_simp_tac(srw_ss())[AC STAR_ASSOC STAR_COMM]); - -Theorem LIST_REL_EQ_MAP - `!vs ws f. LIST_REL (λv w. f v = w) vs ws <=> ws = MAP f vs` - (Induct \\ full_simp_tac(srw_ss())[]); - -Theorem full_gc_IMP - `full_gc (xs,heap,limit) = (t,heap2,n,T) ==> - n <= limit /\ limit = heap_length heap` - (full_simp_tac(srw_ss())[full_gc_def,LET_THM] + \\ full_simp_tac(srw_ss())[AC STAR_ASSOC STAR_COMM] +QED + +Theorem LIST_REL_EQ_MAP: + !vs ws f. LIST_REL (λv w. f v = w) vs ws <=> ws = MAP f vs +Proof + Induct \\ full_simp_tac(srw_ss())[] +QED + +Theorem full_gc_IMP: + full_gc (xs,heap,limit) = (t,heap2,n,T) ==> + n <= limit /\ limit = heap_length heap +Proof + full_simp_tac(srw_ss())[full_gc_def,LET_THM] \\ pairarg_tac \\ full_simp_tac(srw_ss())[] \\ pairarg_tac \\ full_simp_tac(srw_ss())[] - \\ srw_tac[][] \\ full_simp_tac(srw_ss())[]); + \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] +QED -Theorem is_ref_header_alt - `good_dimindex (:'a) ==> - (is_ref_header (w:'a word) <=> ~(w ' 2) /\ (w ' 3) /\ ~(w ' 4))` - (fs [is_ref_header_def,fcpTheory.CART_EQ,good_dimindex_def] \\ rw [] +Theorem is_ref_header_alt: + good_dimindex (:'a) ==> + (is_ref_header (w:'a word) <=> ~(w ' 2) /\ (w ' 3) /\ ~(w ' 4)) +Proof + fs [is_ref_header_def,fcpTheory.CART_EQ,good_dimindex_def] \\ rw [] \\ fs [word_and_def,word_index,fcpTheory.FCP_BETA] \\ rw [] \\ eq_tac \\ rw [] \\ fs [] \\ TRY (qpat_x_assum `!x._` @@ -1040,17 +1215,20 @@ Theorem is_ref_header_alt \\ qspec_then `4` mp_tac th )) \\ fs [] \\ Cases_on `i = 2` \\ fs [] \\ Cases_on `i = 3` - \\ fs [] \\ Cases_on `i = 4` \\ fs []); + \\ fs [] \\ Cases_on `i = 4` \\ fs [] +QED -Theorem is_ref_header_thm - `(word_payload addrs ll tt0 tt1 conf = (h,ts,c5)) /\ good_dimindex (:'a) /\ +Theorem is_ref_header_thm: + (word_payload addrs ll tt0 tt1 conf = (h,ts,c5)) /\ good_dimindex (:'a) /\ conf.len_size + 5 <= dimindex (:'a) ==> - (is_ref_header (h:'a word) ⇔ tt0 = RefTag)` - (Cases_on `tt0` \\ fs [word_payload_def] \\ rw [] + (is_ref_header (h:'a word) ⇔ tt0 = RefTag) +Proof + Cases_on `tt0` \\ fs [word_payload_def] \\ rw [] \\ fs [make_header_def,make_byte_header_def,is_ref_header_alt] \\ fs [word_or_def,fcpTheory.FCP_BETA,good_dimindex_def,word_lsl_def,word_index] \\ rw [] - \\ fs [word_or_def,fcpTheory.FCP_BETA,good_dimindex_def,word_lsl_def,word_index]); + \\ fs [word_or_def,fcpTheory.FCP_BETA,good_dimindex_def,word_lsl_def,word_index] +QED val is_Ref_def = Define ` is_Ref is_ref_tag (DataElement xs l r) = is_ref_tag r /\ @@ -1061,8 +1239,8 @@ val len_inv_def = Define ` heap_length s.heap = heap_length (s.h1 ++ s.h2) + s.n + heap_length (s.r4 ++ s.r3 ++ s.r2 ++ s.r1)`; -Theorem word_gen_gc_move_thm - `(gen_gc$gc_move gen_conf s x = (x1,s1)) /\ s1.ok /\ s.h2 = [] /\ s.r4 = [] /\ +Theorem word_gen_gc_move_thm: + (gen_gc$gc_move gen_conf s x = (x1,s1)) /\ s1.ok /\ s.h2 = [] /\ s.r4 = [] /\ heap_length s.heap <= dimword (:'a) DIV 2 ** shift_length conf /\ (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\ conf.len_size + 5 <= dimindex (:'a) /\ @@ -1087,8 +1265,9 @@ Theorem word_gen_gc_move_thm s.n = heap_length s1.h2 + s1.n + heap_length s1.r4 /\ pa1 = pa + bytes_in_word * n2w (heap_length s1.h2) /\ pb1 = pa1 + bytes_in_word * n2w s1.n /\ - EVERY (is_Ref gen_conf.isRef) (s1.r4 ++ s1.r3 ++ s1.r2 ++ s1.r1)` - (reverse (Cases_on `x`) \\ fs[gen_gcTheory.gc_move_def] THEN1 + EVERY (is_Ref gen_conf.isRef) (s1.r4 ++ s1.r3 ++ s1.r2 ++ s1.r1) +Proof + reverse (Cases_on `x`) \\ fs[gen_gcTheory.gc_move_def] THEN1 (rw [] \\ full_simp_tac(srw_ss())[word_heap_def,SEP_CLAUSES] \\ Cases_on `a` \\ fs [word_addr_def,word_gen_gc_move_def] \\ rveq \\ fs [] \\ asm_exists_tac \\ fs [heap_length_def]) @@ -1224,14 +1403,16 @@ Theorem word_gen_gc_move_thm \\ srw_tac[][] \\ qexists_tac `ts` \\ full_simp_tac(srw_ss())[AC STAR_ASSOC STAR_COMM,SEP_CLAUSES] \\ fs [GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] - \\ fs [WORD_MUL_LSL])); + \\ fs [WORD_MUL_LSL]) +QED -Theorem gc_move_with_NIL - `!x s y t. +Theorem gc_move_with_NIL: + !x s y t. gen_gc$gc_move gen_conf s x = (y,t) /\ t.ok ==> (let (y,s1) = gc_move gen_conf (s with <| h2 := []; r4 := [] |>) x in - (y,s1 with <| h2 := s.h2 ++ s1.h2; r4 := s1.r4 ++ s.r4 |>)) = (y,t)` - (Cases \\ fs [gen_gcTheory.gc_move_def] \\ rw [] + (y,s1 with <| h2 := s.h2 ++ s1.h2; r4 := s1.r4 ++ s.r4 |>)) = (y,t) +Proof + Cases \\ fs [gen_gcTheory.gc_move_def] \\ rw [] \\ fs [gc_sharedTheory.gc_state_component_equality] \\ CASE_TAC \\ fs [] \\ fs [gc_sharedTheory.gc_state_component_equality] @@ -1240,24 +1421,27 @@ Theorem gc_move_with_NIL \\ CASE_TAC \\ fs [] \\ fs [gc_sharedTheory.gc_state_component_equality] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] - \\ fs [gc_sharedTheory.gc_state_component_equality]); + \\ fs [gc_sharedTheory.gc_state_component_equality] +QED -Theorem gc_move_with_NIL_LEMMA - `!x s y t h2 r4 y1 t1. +Theorem gc_move_with_NIL_LEMMA: + !x s y t h2 r4 y1 t1. gen_gc$gc_move gen_conf s x = (y1,t1) /\ t1.ok ==> ?x1 x2. t1.h2 = s.h2 ++ x1 /\ t1.r4 = x2 ++ s.r4 /\ gen_gc$gc_move gen_conf (s with <| h2 := []; r4 := [] |>) x = - (y1,t1 with <| h2 := x1; r4 := x2 |>)` - (Cases \\ fs [gen_gcTheory.gc_move_def] \\ rw [] + (y1,t1 with <| h2 := x1; r4 := x2 |>) +Proof + Cases \\ fs [gen_gcTheory.gc_move_def] \\ rw [] \\ CASE_TAC \\ fs [] \\ fs [gc_sharedTheory.gc_state_component_equality] \\ CASE_TAC \\ fs [] \\ fs [gc_sharedTheory.gc_state_component_equality] \\ CASE_TAC \\ fs [] \\ fs [gc_sharedTheory.gc_state_component_equality] - \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs []); + \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] +QED val gc_move_list_ok_irr0 = prove( ``!x s y1 y2 t1 t2 h2 r4. @@ -1269,12 +1453,13 @@ val gc_move_list_ok_irr0 = prove( \\ every_case_tac \\ fs [] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs []); -Theorem gc_move_list_ok_irr - `!x s y1 y2 t1 t2 h2 r4. +Theorem gc_move_list_ok_irr: + !x s y1 y2 t1 t2 h2 r4. gen_gc$gc_move_list gen_conf s x = (y1,t1) /\ t1.ok /\ gen_gc$gc_move_list gen_conf (s with <| h2 := h2 ; r4 := r4 |>) x = (y2,t2) ==> - t2.ok` - (Induct \\ fs [gen_gcTheory.gc_move_list_def] + t2.ok +Proof + Induct \\ fs [gen_gcTheory.gc_move_list_def] \\ rw [] \\ fs [gc_sharedTheory.gc_state_component_equality] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] \\ imp_res_tac gen_gcTheory.gc_move_list_ok @@ -1284,17 +1469,18 @@ Theorem gc_move_list_ok_irr \\ asm_exists_tac \\ fs [] \\ once_rewrite_tac [CONJ_COMM] \\ asm_exists_tac \\ fs [] - \\ metis_tac [gc_move_list_ok_irr0]); + \\ metis_tac [gc_move_list_ok_irr0] +QED -Theorem gc_move_list_with_NIL_LEMMA - `!x s y t h2 r4 y1 t1. +Theorem gc_move_list_with_NIL_LEMMA = Q.prove(` + !x s y t h2 r4 y1 t1. gen_gc$gc_move_list gen_conf s x = (y1,t1) /\ t1.ok ==> ?x1 x2. t1.h2 = s.h2 ++ x1 /\ t1.r4 = x2 ++ s.r4 /\ gen_gc$gc_move_list gen_conf (s with <| h2 := []; r4 := [] |>) x = - (y1,t1 with <| h2 := x1; r4 := x2 |>)` - (Induct \\ fs [gen_gcTheory.gc_move_list_def] \\ rw [] + (y1,t1 with <| h2 := x1; r4 := x2 |>)`, + Induct \\ fs [gen_gcTheory.gc_move_list_def] \\ rw [] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] \\ rename1 `gc_move gen_conf s h = (x3,state3)` \\ rename1 `_ = (x4,state4)` @@ -1308,16 +1494,18 @@ Theorem gc_move_list_with_NIL_LEMMA \\ fs [] \\ rw [] \\ fs [] \\ fs [gc_sharedTheory.gc_state_component_equality]) |> SIMP_RULE std_ss []; -Theorem gc_move_list_with_NIL - `!x s y t. +Theorem gc_move_list_with_NIL: + !x s y t. gen_gc$gc_move_list gen_conf s x = (y,t) /\ t.ok ==> (let (y,s1) = gc_move_list gen_conf (s with <| h2 := []; r4 := [] |>) x in - (y,s1 with <| h2 := s.h2 ++ s1.h2; r4 := s1.r4 ++ s.r4 |>)) = (y,t)` - (rw [] \\ drule gc_move_list_with_NIL_LEMMA \\ fs [] - \\ strip_tac \\ fs [] \\ fs [gc_sharedTheory.gc_state_component_equality]); - -Theorem word_gen_gc_move_roots_thm - `!x xs x1 w s1 s pb1 pa1 pa m1 m ib1 i1 frame dm curr c1. + (y,s1 with <| h2 := s.h2 ++ s1.h2; r4 := s1.r4 ++ s.r4 |>)) = (y,t) +Proof + rw [] \\ drule gc_move_list_with_NIL_LEMMA \\ fs [] + \\ strip_tac \\ fs [] \\ fs [gc_sharedTheory.gc_state_component_equality] +QED + +Theorem word_gen_gc_move_roots_thm: + !x xs x1 w s1 s pb1 pa1 pa m1 m ib1 i1 frame dm curr c1. (gen_gc$gc_move_list gen_conf s x = (x1,s1)) /\ s1.ok /\ s.h2 = [] /\ s.r4 = [] /\ heap_length s.heap <= dimword (:'a) DIV 2 ** shift_length conf /\ (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\ @@ -1341,8 +1529,9 @@ Theorem word_gen_gc_move_roots_thm s.n = heap_length s1.h2 + s1.n + heap_length s1.r4 /\ pa1 = pa + bytes_in_word * n2w (heap_length s1.h2) /\ pb1 = pa1 + bytes_in_word * n2w s1.n /\ - EVERY (is_Ref gen_conf.isRef) (s1.r4 ++ s1.r3 ++ s1.r2 ++ s1.r1)` - (Induct + EVERY (is_Ref gen_conf.isRef) (s1.r4 ++ s1.r3 ++ s1.r2 ++ s1.r1) +Proof + Induct THEN1 (fs [gen_gcTheory.gc_move_list_def,word_gen_gc_move_roots_def] \\ rw [] \\ fs [word_heap_def,SEP_CLAUSES] \\ asm_exists_tac \\ fs []) @@ -1366,10 +1555,11 @@ Theorem word_gen_gc_move_roots_thm \\ qexists_tac `xs2` \\ fs [] \\ fs [word_heap_APPEND] \\ fs [heap_length_APPEND,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] - \\ fs [AC STAR_COMM STAR_ASSOC]); + \\ fs [AC STAR_COMM STAR_ASSOC] +QED -Theorem word_gen_gc_move_list_thm - `!x xs x1 w s1 s pb1 pa1 pa m1 m ib1 i1 frame dm curr c1 k k1. +Theorem word_gen_gc_move_list_thm = Q.prove(` + !x xs x1 w s1 s pb1 pa1 pa m1 m ib1 i1 frame dm curr c1 k k1. (gen_gc$gc_move_list gen_conf s x = (x1,s1)) /\ s1.ok /\ s.h2 = [] /\ s.r4 = [] /\ heap_length s.heap <= dimword (:'a) DIV 2 ** shift_length conf /\ (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\ @@ -1394,8 +1584,8 @@ Theorem word_gen_gc_move_list_thm k1 = k + n2w (LENGTH x) * bytes_in_word /\ pa1 = pa + bytes_in_word * n2w (heap_length s1.h2) /\ pb1 = pa1 + bytes_in_word * n2w s1.n /\ - EVERY (is_Ref gen_conf.isRef) (s1.r4 ++ s1.r3 ++ s1.r2 ++ s1.r1)` - (Induct + EVERY (is_Ref gen_conf.isRef) (s1.r4 ++ s1.r3 ++ s1.r2 ++ s1.r1)`, + Induct THEN1 (fs [gen_gcTheory.gc_move_list_def,Once word_gen_gc_move_list_def] \\ rw [] \\ fs [word_heap_def,SEP_CLAUSES] \\ asm_exists_tac \\ fs []) @@ -1437,31 +1627,36 @@ val word_heap_parts_def = Define ` word_heap (p + bytes_in_word * n2w (heap_length (s.h1 ++ s.h2) + LENGTH xs)) (s.r4 ++ s.r3 ++ s.r2 ++ s.r1) conf` -Theorem gc_move_const - `!l s xs' s'. +Theorem gc_move_const: + !l s xs' s'. gen_gc$gc_move gen_conf s l = (xs',s') ==> - s'.h1 = s.h1 /\ s'.r1 = s.r1 /\ s'.r2 = s.r2 /\ s'.r3 = s.r3` - (Cases \\ fs [gen_gcTheory.gc_move_def] \\ rpt gen_tac + s'.h1 = s.h1 /\ s'.r1 = s.r1 /\ s'.r2 = s.r2 /\ s'.r3 = s.r3 +Proof + Cases \\ fs [gen_gcTheory.gc_move_def] \\ rpt gen_tac \\ CASE_TAC \\ TRY (rw [] \\ fs [] \\ NO_TAC) \\ CASE_TAC \\ TRY (rw [] \\ fs [] \\ NO_TAC) \\ CASE_TAC \\ TRY (rw [] \\ fs [] \\ NO_TAC) \\ pairarg_tac \\ fs [] - \\ rpt strip_tac \\ rveq \\ fs []); + \\ rpt strip_tac \\ rveq \\ fs [] +QED -Theorem gc_move_list_const - `!l s xs' s'. +Theorem gc_move_list_const: + !l s xs' s'. gen_gc$gc_move_list gen_conf s l = (xs',s') ==> - s'.h1 = s.h1 /\ s'.r1 = s.r1 /\ s'.r2 = s.r2 /\ s'.r3 = s.r3` - (Induct \\ fs [gen_gcTheory.gc_move_list_def] + s'.h1 = s.h1 /\ s'.r1 = s.r1 /\ s'.r2 = s.r2 /\ s'.r3 = s.r3 +Proof + Induct \\ fs [gen_gcTheory.gc_move_list_def] \\ rpt gen_tac \\ rpt (pairarg_tac \\ fs []) \\ fs [] \\ imp_res_tac gc_move_const \\ res_tac \\ fs [] - \\ strip_tac \\ rveq \\ fs []); + \\ strip_tac \\ rveq \\ fs [] +QED -Theorem gc_move_data_const - `!gen_conf s s'. +Theorem gc_move_data_const: + !gen_conf s s'. gen_gc$gc_move_data gen_conf s = s' ==> - s'.r1 = s.r1 /\ s'.r2 = s.r2 /\ s'.r3 = s.r3` - (ho_match_mp_tac gen_gcTheory.gc_move_data_ind + s'.r1 = s.r1 /\ s'.r2 = s.r2 /\ s'.r3 = s.r3 +Proof + ho_match_mp_tac gen_gcTheory.gc_move_data_ind \\ rpt (gen_tac ORELSE disch_then assume_tac) \\ pop_assum mp_tac \\ once_rewrite_tac [gen_gcTheory.gc_move_data_def] @@ -1472,13 +1667,15 @@ Theorem gc_move_data_const \\ TRY (strip_tac \\ rveq \\ fs [] \\ NO_TAC) \\ pairarg_tac \\ fs [] \\ strip_tac \\ fs [] - \\ rfs [] \\ imp_res_tac gc_move_list_const \\ fs []); + \\ rfs [] \\ imp_res_tac gc_move_list_const \\ fs [] +QED -Theorem gc_move_refs_const - `!gen_conf s s'. +Theorem gc_move_refs_const: + !gen_conf s s'. gen_gc$gc_move_refs gen_conf s = s' ==> - s'.h1 = s.h1` - (ho_match_mp_tac gen_gcTheory.gc_move_refs_ind + s'.h1 = s.h1 +Proof + ho_match_mp_tac gen_gcTheory.gc_move_refs_ind \\ rpt (gen_tac ORELSE disch_then assume_tac) \\ pop_assum mp_tac \\ once_rewrite_tac [gen_gcTheory.gc_move_refs_def] @@ -1488,13 +1685,15 @@ Theorem gc_move_refs_const \\ TRY (strip_tac \\ rveq \\ fs [] \\ NO_TAC) \\ pairarg_tac \\ fs [] \\ strip_tac \\ fs [] - \\ rfs [] \\ imp_res_tac gc_move_list_const \\ fs []); + \\ rfs [] \\ imp_res_tac gc_move_list_const \\ fs [] +QED -Theorem heap_length_gc_forward_ptr - `!hs n k a ok heap. +Theorem heap_length_gc_forward_ptr: + !hs n k a ok heap. gc_forward_ptr n hs k a ok = (heap,T) ==> - heap_length heap = heap_length hs /\ ok` - (Induct \\ once_rewrite_tac [gc_forward_ptr_def] \\ rpt gen_tac + heap_length heap = heap_length hs /\ ok +Proof + Induct \\ once_rewrite_tac [gc_forward_ptr_def] \\ rpt gen_tac THEN1 fs [] \\ IF_CASES_TAC THEN1 (strip_tac \\ rveq @@ -1507,13 +1706,15 @@ Theorem heap_length_gc_forward_ptr \\ simp_tac std_ss [LET_THM] \\ strip_tac \\ rveq \\ first_x_assum drule \\ rw [] - \\ fs [heap_length_def]); + \\ fs [heap_length_def] +QED -Theorem gc_move_thm - `!l s l1 s1. +Theorem gc_move_thm: + !l s l1 s1. gen_gc$gc_move gen_conf s l = (l1,s1) /\ s1.ok /\ len_inv s ==> - len_inv s1` - (Cases \\ fs [gen_gcTheory.gc_move_def] \\ rpt gen_tac + len_inv s1 +Proof + Cases \\ fs [gen_gcTheory.gc_move_def] \\ rpt gen_tac \\ CASE_TAC \\ TRY (rw [] \\ fs [] \\ NO_TAC) \\ CASE_TAC \\ TRY (rw [] \\ fs [] \\ NO_TAC) \\ CASE_TAC \\ TRY (rw [] \\ fs [] \\ NO_TAC) @@ -1521,25 +1722,29 @@ Theorem gc_move_thm \\ rpt strip_tac \\ rveq \\ fs [] \\ fs [len_inv_def] \\ imp_res_tac heap_length_gc_forward_ptr - \\ fs [heap_length_def,el_length_def,SUM_APPEND]); + \\ fs [heap_length_def,el_length_def,SUM_APPEND] +QED -Theorem gc_move_list_thm - `!l s l1 s1. +Theorem gc_move_list_thm: + !l s l1 s1. gen_gc$gc_move_list gen_conf s l = (l1,s1) /\ s1.ok /\ len_inv s ==> - len_inv s1` - (Induct \\ fs [gen_gcTheory.gc_move_list_def] + len_inv s1 +Proof + Induct \\ fs [gen_gcTheory.gc_move_list_def] \\ rpt gen_tac \\ rpt (pairarg_tac \\ fs []) \\ fs [] \\ imp_res_tac gc_move_const \\ res_tac \\ fs [] \\ strip_tac \\ rveq \\ fs [] \\ drule gen_gcTheory.gc_move_list_ok \\ fs [] \\ strip_tac \\ imp_res_tac gc_move_thm - \\ fs []); + \\ fs [] +QED -Theorem word_list_IMP_limit - `(word_list (curr:'a word) hs * frame) (fun2set (m,dm)) /\ +Theorem word_list_IMP_limit: + (word_list (curr:'a word) hs * frame) (fun2set (m,dm)) /\ good_dimindex (:'a) ==> - LENGTH hs <= dimword (:'a) DIV (dimindex (:α) DIV 8)` - (rw [] \\ CCONTR_TAC + LENGTH hs <= dimword (:'a) DIV (dimindex (:α) DIV 8) +Proof + rw [] \\ CCONTR_TAC \\ rfs [good_dimindex_def] \\ rfs [dimword_def] \\ fs [GSYM NOT_LESS] \\ imp_res_tac LESS_LENGTH @@ -1553,16 +1758,18 @@ Theorem word_list_IMP_limit \\ pop_assum mp_tac \\ fs [] \\ unabbrev_all_tac \\ once_rewrite_tac [GSYM n2w_mod] - \\ fs [dimword_def]); + \\ fs [dimword_def] +QED -Theorem word_el_eq_word_list - `!hs curr frame. +Theorem word_el_eq_word_list: + !hs curr frame. (word_el (curr:'a word) hs conf * frame) (fun2set (m,dm)) ==> ?xs. (word_list curr xs * frame) (fun2set (m,dm)) /\ el_length hs = LENGTH xs /\ !frame1 curr1 m1. (word_list curr1 xs * frame1) (fun2set (m1,dm)) ==> - (word_el curr1 hs conf *frame1) (fun2set (m1,dm))` - (Cases \\ fs [word_el_def,el_length_def,word_list_exists_def] + (word_el curr1 hs conf *frame1) (fun2set (m1,dm)) +Proof + Cases \\ fs [word_el_def,el_length_def,word_list_exists_def] \\ fs [SEP_CLAUSES,SEP_EXISTS_THM] \\ full_simp_tac (std_ss++sep_cond_ss) [cond_STAR] THEN1 (rw [] \\ asm_exists_tac \\ fs [] \\ rpt strip_tac \\ asm_exists_tac \\ fs[]) @@ -1573,16 +1780,18 @@ Theorem word_el_eq_word_list \\ fs [SEP_CLAUSES,SEP_EXISTS_THM] \\ full_simp_tac (std_ss++sep_cond_ss) [cond_STAR] \\ asm_exists_tac \\ fs [] - \\ Cases_on `q` \\ fs [word_payload_def] \\ rfs [] \\ rveq \\ fs []); + \\ Cases_on `q` \\ fs [word_payload_def] \\ rfs [] \\ rveq \\ fs [] +QED -Theorem word_heap_eq_word_list_strong - `!(hs:'a ml_heap) curr frame. +Theorem word_heap_eq_word_list_strong: + !(hs:'a ml_heap) curr frame. (word_heap (curr:'a word) (hs:'a ml_heap) conf * frame) (fun2set (m,dm)) ==> ?xs. (word_list curr xs * frame) (fun2set (m,dm)) /\ heap_length hs = LENGTH xs /\ !curr1 frame1 m1. (word_list curr1 xs * frame1) (fun2set (m1,dm)) - ==> (word_heap curr1 hs conf * frame1) (fun2set (m1,dm))` - (Induct + ==> (word_heap curr1 hs conf * frame1) (fun2set (m1,dm)) +Proof + Induct >- rw[word_list_def,word_heap_def] \\ rw [] \\ fs [word_heap_def] \\ fs [GSYM STAR_ASSOC] \\ drule word_el_eq_word_list @@ -1595,25 +1804,30 @@ Theorem word_heap_eq_word_list_strong \\ strip_tac \\ qabbrev_tac `a1 = word_heap (curr + bytes_in_word * n2w (LENGTH xs)) hs conf` \\ fs[AC STAR_ASSOC STAR_COMM] - \\ fs[STAR_ASSOC] \\ SEP_F_TAC \\ fs[AC STAR_ASSOC STAR_COMM]); + \\ fs[STAR_ASSOC] \\ SEP_F_TAC \\ fs[AC STAR_ASSOC STAR_COMM] +QED -Theorem word_heap_eq_word_list - `!(hs:'a ml_heap) curr frame. +Theorem word_heap_eq_word_list: + !(hs:'a ml_heap) curr frame. (word_heap (curr:'a word) (hs:'a ml_heap) conf * frame) (fun2set (m,dm)) ==> ?xs. (word_list curr xs * frame) (fun2set (m,dm)) /\ - heap_length hs = LENGTH xs` - (metis_tac [word_heap_eq_word_list_strong]); + heap_length hs = LENGTH xs +Proof + metis_tac [word_heap_eq_word_list_strong] +QED -Theorem word_heap_IMP_limit - `(word_heap (curr:'a word) (hs:'a ml_heap) conf * frame) (fun2set (m,dm)) /\ +Theorem word_heap_IMP_limit: + (word_heap (curr:'a word) (hs:'a ml_heap) conf * frame) (fun2set (m,dm)) /\ good_dimindex (:'a) ==> - heap_length hs <= dimword (:'a) DIV (dimindex (:α) DIV 8)` - (rpt strip_tac + heap_length hs <= dimword (:'a) DIV (dimindex (:α) DIV 8) +Proof + rpt strip_tac \\ drule word_heap_eq_word_list \\ strip_tac - \\ drule word_list_IMP_limit \\ fs [] ); + \\ drule word_list_IMP_limit \\ fs [] +QED -Theorem word_gen_gc_move_refs_thm - `!k s m dm curr xs s1 pb1 pa1 m1 ib1 i1 frame c1 p1. +Theorem word_gen_gc_move_refs_thm: + !k s m dm curr xs s1 pb1 pa1 m1 ib1 i1 frame c1 p1. (gen_gc$gc_move_refs gen_conf s = s1) /\ s1.ok /\ heap_length s.heap <= dimword (:'a) DIV 2 ** shift_length conf /\ heap_length s.heap * (dimindex (:'a) DIV 8) < dimword (:'a) /\ @@ -1648,8 +1862,9 @@ Theorem word_gen_gc_move_refs_thm pb1 = p + bytes_in_word * n2w (heap_length (s1.h1 ++ s1.h2) + s1.n) /\ p1 = p + bytes_in_word * n2w (heap_length (s.h1 ++ s.h2 ++ s.r4 ++ s.r3 ++ s.r2) + LENGTH xs) /\ len_inv s1 /\ - EVERY (is_Ref gen_conf.isRef) (s1.r4 ++ s1.r3 ++ s1.r2 ++ s1.r1)` - (completeInduct_on `k` \\ rpt strip_tac + EVERY (is_Ref gen_conf.isRef) (s1.r4 ++ s1.r3 ++ s1.r2 ++ s1.r1) +Proof + completeInduct_on `k` \\ rpt strip_tac \\ fs [PULL_FORALL,AND_IMP_INTRO,GSYM CONJ_ASSOC] \\ qpat_x_assum `gc_move_refs gen_conf s = s1` mp_tac \\ once_rewrite_tac [gen_gcTheory.gc_move_refs_def] @@ -1764,10 +1979,11 @@ Theorem word_gen_gc_move_refs_thm \\ qpat_x_assum `_ = s.n` (assume_tac o GSYM) \\ fs [] \\ fs [word_heap_parts_def,word_heap_APPEND,word_heap_def,word_el_def, heap_length_APPEND,word_payload_def,GSYM word_add_n2w, - WORD_LEFT_ADD_DISTRIB,word_list_def,el_length_def,heap_length_def]); + WORD_LEFT_ADD_DISTRIB,word_list_def,el_length_def,heap_length_def] +QED -Theorem word_gen_gc_move_data_thm - `!k s m dm curr xs s1 pb1 pa1 m1 ib1 i1 frame c1. +Theorem word_gen_gc_move_data_thm: + !k s m dm curr xs s1 pb1 pa1 m1 ib1 i1 frame c1. (gen_gc$gc_move_data gen_conf s = s1) /\ s1.ok /\ heap_length s.heap <= dimword (:'a) DIV 2 ** shift_length conf /\ heap_length s.heap * (dimindex (:'a) DIV 8) < dimword (:'a) /\ @@ -1799,8 +2015,9 @@ Theorem word_gen_gc_move_data_thm heap_length (s.h1 ++ s.h2 ++ s.r4) + s.n /\ pa1 = p + bytes_in_word * n2w (heap_length (s1.h1 ++ s1.h2)) /\ pb1 = p + bytes_in_word * n2w (heap_length (s1.h1 ++ s1.h2) + s1.n) /\ - EVERY (is_Ref gen_conf.isRef) (s1.r4 ++ s1.r3 ++ s1.r2 ++ s1.r1)` - (completeInduct_on `k` \\ rpt strip_tac + EVERY (is_Ref gen_conf.isRef) (s1.r4 ++ s1.r3 ++ s1.r2 ++ s1.r1) +Proof + completeInduct_on `k` \\ rpt strip_tac \\ fs [PULL_FORALL,AND_IMP_INTRO,GSYM CONJ_ASSOC] \\ qpat_x_assum `gc_move_data gen_conf s = s1` mp_tac \\ once_rewrite_tac [gen_gcTheory.gc_move_data_def] @@ -1964,14 +2181,17 @@ Theorem word_gen_gc_move_data_thm \\ qpat_x_assum `_ = s.n` (assume_tac o GSYM) \\ fs [] \\ fs [word_heap_parts_def,word_heap_APPEND,word_heap_def,word_el_def, heap_length_APPEND,word_payload_def,GSYM word_add_n2w, - WORD_LEFT_ADD_DISTRIB,word_list_def,el_length_def,heap_length_def]); + WORD_LEFT_ADD_DISTRIB,word_list_def,el_length_def,heap_length_def] +QED -Theorem LENGTH_LESS_EQ_SUM_el_length - `!t. LENGTH t <= SUM (MAP el_length t)` - (Induct \\ fs [] \\ Cases \\ fs [el_length_def]); +Theorem LENGTH_LESS_EQ_SUM_el_length: + !t. LENGTH t <= SUM (MAP el_length t) +Proof + Induct \\ fs [] \\ Cases \\ fs [el_length_def] +QED -Theorem word_gen_gc_move_loop_thm - `!k s m dm curr xs s1 pb1 pa1 m1 ib1 i1 frame c1. +Theorem word_gen_gc_move_loop_thm: + !k s m dm curr xs s1 pb1 pa1 m1 ib1 i1 frame c1. (gen_gc$gc_move_loop gen_conf s k = s1) /\ s1.ok /\ heap_length s.heap <= dimword (:'a) DIV 2 ** shift_length conf /\ heap_length s.heap * (dimindex (:'a) DIV 8) < dimword (:'a) /\ @@ -2002,8 +2222,9 @@ Theorem word_gen_gc_move_loop_thm pa1 = p + bytes_in_word * n2w (heap_length s1.h1) /\ pb1 = p + bytes_in_word * n2w (heap_length s1.h1 + s1.n) /\ (ib1 = n2w (s1.a + s1.n)) /\ - EVERY (is_Ref gen_conf.isRef) s1.r1` - (completeInduct_on `k` \\ rpt strip_tac + EVERY (is_Ref gen_conf.isRef) s1.r1 +Proof + completeInduct_on `k` \\ rpt strip_tac \\ fs [PULL_FORALL,AND_IMP_INTRO,GSYM CONJ_ASSOC] \\ qpat_x_assum `gc_move_loop gen_conf s k = s1` mp_tac \\ once_rewrite_tac [gen_gcTheory.gc_move_loop_def] @@ -2119,10 +2340,11 @@ Theorem word_gen_gc_move_loop_thm \\ qpat_abbrev_tac `n6 = SUM (MAP _ _.h2)` \\ qpat_abbrev_tac `n7 = SUM (MAP _ _.r4)` \\ qpat_x_assum `LENGTH xs + n2 = _` (assume_tac o GSYM) - \\ fs []); + \\ fs [] +QED -Theorem word_gen_gc_thm - `!m dm curr s1 pb1 pa1 m1 ib1 i1 frame c1 roots heap roots1 roots1' new. +Theorem word_gen_gc_thm: + !m dm curr s1 pb1 pa1 m1 ib1 i1 frame c1 roots heap roots1 roots1' new. (gen_gc$gen_gc gen_conf (roots,heap) = (roots1,s1)) /\ s1.ok /\ (word_gen_gc conf (MAP (word_addr conf) roots,curr,new, bytes_in_word * n2w (heap_length heap),m,dm) = @@ -2148,8 +2370,9 @@ Theorem word_gen_gc_thm pb1 = new + bytes_in_word * n2w (heap_length s1.h1 + s1.n) /\ roots1' = MAP (word_addr conf) roots1 /\ s1.n = LENGTH xs1 /\ len_inv s1 /\ - EVERY (is_Ref gen_conf.isRef) s1.r1` - (rpt gen_tac \\ once_rewrite_tac [gen_gcTheory.gen_gc_def] + EVERY (is_Ref gen_conf.isRef) s1.r1 +Proof + rpt gen_tac \\ once_rewrite_tac [gen_gcTheory.gen_gc_def] \\ fs [] \\ rpt (pairarg_tac \\ fs []) \\ strip_tac \\ fs [] \\ drule (word_gen_gc_move_loop_thm |> Q.GEN `p`) \\ drule word_gen_gc_move_roots_thm @@ -2183,57 +2406,74 @@ Theorem word_gen_gc_thm \\ fs [GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB,heap_length_APPEND] \\ strip_tac \\ SEP_F_TAC \\ impl_tac THEN1 fs [len_inv_def] - \\ strip_tac \\ asm_exists_tac \\ fs []); + \\ strip_tac \\ asm_exists_tac \\ fs [] +QED -Theorem gc_forward_ptr_APPEND ` - !h1 n h2 a b ok. +Theorem gc_forward_ptr_APPEND: + !h1 n h2 a b ok. gc_forward_ptr n (h1 ++ h2) a b ok = if n < heap_length h1 then (λ(h,ok). (h++h2,ok)) (gc_forward_ptr n h1 a b ok) else - (λ(h,ok). (h1++h,ok)) (gc_forward_ptr (n-heap_length h1) h2 a b ok)` - (Induct + (λ(h,ok). (h1++h,ok)) (gc_forward_ptr (n-heap_length h1) h2 a b ok) +Proof + Induct >- fs[pairTheory.ELIM_UNCURRY] >> Cases >> rpt strip_tac >> fs[gc_forward_ptr_def] >> fs[el_length_def,heap_length_def] >> rw[] >> fs[] - >> fs[pairTheory.ELIM_UNCURRY]); - -Theorem heap_split_APPEND - `heap_split (heap_length h1) (h1 ++ h2) = SOME(h1,h2)` - (Induct_on `h1` >> fs[heap_split_def,heap_length_def]); - -Theorem heap_split_APPEND' - `heap_split (SUM (MAP el_length h1)) (h1 ++ h2) = SOME(h1,h2)` - (metis_tac[heap_split_APPEND,heap_length_def]); - -Theorem heap_drop_APPEND - `heap_drop (heap_length h1) (h1 ++ h2) = h2` - (rw[heap_drop_def,heap_split_APPEND]); - -Theorem heap_take_APPEND - `heap_take (heap_length h1) (h1 ++ h2) = h1` - (rw[heap_take_def,heap_split_APPEND]); - -Theorem heap_drop_0 - `heap_drop 0 h = h` (Cases_on `h` >> fs[heap_drop_def,heap_split_def]); - -Theorem gc_forward_ptr_heap_split - `!h1 h2 n h3 l n' b ok ok1 heap a b'. + >> fs[pairTheory.ELIM_UNCURRY] +QED + +Theorem heap_split_APPEND: + heap_split (heap_length h1) (h1 ++ h2) = SOME(h1,h2) +Proof + Induct_on `h1` >> fs[heap_split_def,heap_length_def] +QED + +Theorem heap_split_APPEND': + heap_split (SUM (MAP el_length h1)) (h1 ++ h2) = SOME(h1,h2) +Proof + metis_tac[heap_split_APPEND,heap_length_def] +QED + +Theorem heap_drop_APPEND: + heap_drop (heap_length h1) (h1 ++ h2) = h2 +Proof + rw[heap_drop_def,heap_split_APPEND] +QED + +Theorem heap_take_APPEND: + heap_take (heap_length h1) (h1 ++ h2) = h1 +Proof + rw[heap_take_def,heap_split_APPEND] +QED + +Theorem heap_drop_0: + heap_drop 0 h = h +Proof +Cases_on `h` >> fs[heap_drop_def,heap_split_def] +QED + +Theorem gc_forward_ptr_heap_split: + !h1 h2 n h3 l n' b ok ok1 heap a b'. (heap_lookup n (h1 ++ h2 ++ h3) = SOME (DataElement l n' b)) /\ (gc_forward_ptr n (h1 ++ h2 ++ h3) a b' ok = (heap,ok1)) /\ n >= heap_length h1 /\ n < heap_length(h1 ++ h2) - ==> heap = h1 ++ heap_take (heap_length h2) (heap_drop (heap_length h1) heap) ++ h3` - (rw[gc_forward_ptr_APPEND] >> ntac 2 (pairarg_tac >> fs[] >> rveq) + ==> heap = h1 ++ heap_take (heap_length h2) (heap_drop (heap_length h1) heap) ++ h3 +Proof + rw[gc_forward_ptr_APPEND] >> ntac 2 (pairarg_tac >> fs[] >> rveq) >> drule gc_forward_ptr_heap_length >> strip_tac - >> ASM_SIMP_TAC std_ss [heap_take_APPEND,heap_drop_APPEND,GSYM APPEND_ASSOC]); + >> ASM_SIMP_TAC std_ss [heap_take_APPEND,heap_drop_APPEND,GSYM APPEND_ASSOC] +QED -Theorem partial_gc_move_heap_split - `(gen_gc_partial$gc_move conf s x = (x1,s1)) +Theorem partial_gc_move_heap_split: + (gen_gc_partial$gc_move conf s x = (x1,s1)) /\ heap_segment (conf.gen_start,conf.refs_start) s.heap = SOME (h1,h2,h3) /\ conf.gen_start <= conf.refs_start - ==> s1.heap = h1 ++ heap_take (heap_length h2) (heap_drop (heap_length h1) s1.heap) ++ h3` - (Cases_on `x` >> rw[gen_gc_partialTheory.gc_move_def] + ==> s1.heap = h1 ++ heap_take (heap_length h2) (heap_drop (heap_length h1) s1.heap) ++ h3 +Proof + Cases_on `x` >> rw[gen_gc_partialTheory.gc_move_def] >> fs[] >> drule heap_segment_IMP >> strip_tac >> fs[] >> rfs[] @@ -2244,15 +2484,17 @@ Theorem partial_gc_move_heap_split >> every_case_tac >> fs[] >> rveq >> fs[] >> SIMP_TAC std_ss [GSYM APPEND_ASSOC,heap_take_APPEND,heap_drop_APPEND] >> pairarg_tac >> fs[] >> rveq >> fs[] - >> drule gc_forward_ptr_heap_split >> disch_then drule >> fs[]); + >> drule gc_forward_ptr_heap_split >> disch_then drule >> fs[] +QED -Theorem partial_gc_move_list_heap_split - `!x conf s x1 s1 h1 h2 h3. +Theorem partial_gc_move_list_heap_split: + !x conf s x1 s1 h1 h2 h3. (gen_gc_partial$gc_move_list conf s x = (x1,s1)) /\ heap_segment (conf.gen_start,conf.refs_start) s.heap = SOME (h1,h2,h3) /\ conf.gen_start <= conf.refs_start - ==> s1.heap = h1 ++ heap_take (heap_length h2) (heap_drop (heap_length h1) s1.heap) ++ h3` - (Induct >> rpt strip_tac >> fs[gen_gc_partialTheory.gc_move_list_def] + ==> s1.heap = h1 ++ heap_take (heap_length h2) (heap_drop (heap_length h1) s1.heap) ++ h3 +Proof + Induct >> rpt strip_tac >> fs[gen_gc_partialTheory.gc_move_list_def] >> drule heap_segment_IMP >> strip_tac >> rveq >> fs[] >> qpat_x_assum `_ = s.heap` (assume_tac o GSYM) @@ -2284,10 +2526,11 @@ Theorem partial_gc_move_list_heap_split >> fs[heap_length_APPEND] >> disch_then (fn thm => rw[Once thm] >> assume_tac thm) >> SIMP_TAC std_ss [GSYM APPEND_ASSOC,heap_drop_APPEND,heap_take_APPEND] - >> pop_assum (fn thm => fs[GSYM thm])); + >> pop_assum (fn thm => fs[GSYM thm]) +QED -Theorem word_gen_gc_partial_move_thm - `(gen_gc_partial$gc_move gc_conf gcstate x = (x1,gcstate1)) /\ +Theorem word_gen_gc_partial_move_thm: + (gen_gc_partial$gc_move gc_conf gcstate x = (x1,gcstate1)) /\ gcstate.h2 = [] /\ gcstate.r4 = [] /\ gcstate1.ok /\ gc_conf.limit = heap_length gcstate.heap /\ good_dimindex (:α) /\ @@ -2312,8 +2555,9 @@ Theorem word_gen_gc_partial_move_thm (heap_segment (gc_conf.gen_start,gc_conf.refs_start) gcstate1.heap = SOME(old,current1,refs)) /\ c1 /\ (i1 = n2w gcstate1.a) /\ gcstate1.n = LENGTH xs1 /\ gcstate.n = heap_length gcstate1.h2 + gcstate1.n + heap_length gcstate1.r4 /\ - pa1 = pa + bytes_in_word * n2w (heap_length gcstate1.h2)` - (reverse (Cases_on `x`) \\ + pa1 = pa + bytes_in_word * n2w (heap_length gcstate1.h2) +Proof + reverse (Cases_on `x`) \\ full_simp_tac(srw_ss())[gc_move_def] THEN1 (srw_tac[][] \\ full_simp_tac(srw_ss())[word_heap_def,SEP_CLAUSES] @@ -2488,21 +2732,25 @@ Theorem word_gen_gc_partial_move_thm \\ pairarg_tac \\ full_simp_tac(srw_ss())[] \\ pairarg_tac \\ full_simp_tac(srw_ss())[] \\ rveq \\ rfs[] - \\ metis_tac[gc_forward_ptr_ok])); + \\ metis_tac[gc_forward_ptr_ok]) +QED -Theorem gc_partial_move_ok_irr - `!x s y1 y2 t1 t2 h2 r4. +Theorem gc_partial_move_ok_irr: + !x s y1 y2 t1 t2 h2 r4. gen_gc_partial$gc_move gen_conf s x = (y1,t1) /\ gen_gc_partial$gc_move gen_conf (s with <| h2 := h2 ; r4 := r4 |>) x = (y2,t2) ==> - y1 = y2 /\ ?x1 x2. t2 = t1 with <| h2 := x1 ; r4 := x2 |>` - (Cases \\ fs [gen_gc_partialTheory.gc_move_def] \\ rw [] + y1 = y2 /\ ?x1 x2. t2 = t1 with <| h2 := x1 ; r4 := x2 |> +Proof + Cases \\ fs [gen_gc_partialTheory.gc_move_def] \\ rw [] \\ fs [gc_sharedTheory.gc_state_component_equality] \\ every_case_tac \\ fs [] - \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs []); + \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] +QED -Theorem gc_partial_move_ok_before - `gen_gc_partial$gc_move gen_conf s x = (x1,s1) /\ s1.ok ==> s.ok` - (Induct_on `x` >> rw[gen_gc_partialTheory.gc_move_def] +Theorem gc_partial_move_ok_before: + gen_gc_partial$gc_move gen_conf s x = (x1,s1) /\ s1.ok ==> s.ok +Proof + Induct_on `x` >> rw[gen_gc_partialTheory.gc_move_def] >> fs[] >> every_case_tac >> fs[] >- (qpat_x_assum `s with ok := F = s1` (assume_tac o GSYM) >> fs[]) @@ -2515,33 +2763,41 @@ Theorem gc_partial_move_ok_before >> match_mp_tac (GEN_ALL gc_forward_ptr_ok) >> qexists_tac `a` >> qexists_tac `s.heap` >> qexists_tac `n` >> qexists_tac `s.a` >> qexists_tac `heap` - >> fs[]); - -Theorem gc_partial_move_list_ok_before - `!x s x1 s1. gen_gc_partial$gc_move_list gen_conf s x = (x1,s1) /\ s1.ok ==> s.ok` - (Induct_on `x` >> fs[gc_move_list_def] >> rpt strip_tac - >> ntac 2 (pairarg_tac >> fs[]) >> metis_tac[gc_partial_move_ok_before]); - -Theorem gc_partial_move_ref_list_ok_before - `!x s x1 s1. gen_gc_partial$gc_move_ref_list gen_conf s x = (x1,s1) /\ s1.ok ==> s.ok` - (Induct >> Cases >> fs[gc_move_ref_list_def] >> rpt strip_tac - >> ntac 2 (pairarg_tac >> fs[]) >> metis_tac[gc_partial_move_list_ok_before]); - -Theorem gc_partial_move_data_ok_before - `!gen_conf s s1. gen_gc_partial$gc_move_data gen_conf s = s1 /\ s1.ok ==> s.ok` - (recInduct (fetch "gen_gc_partial" "gc_move_data_ind") + >> fs[] +QED + +Theorem gc_partial_move_list_ok_before: + !x s x1 s1. gen_gc_partial$gc_move_list gen_conf s x = (x1,s1) /\ s1.ok ==> s.ok +Proof + Induct_on `x` >> fs[gc_move_list_def] >> rpt strip_tac + >> ntac 2 (pairarg_tac >> fs[]) >> metis_tac[gc_partial_move_ok_before] +QED + +Theorem gc_partial_move_ref_list_ok_before: + !x s x1 s1. gen_gc_partial$gc_move_ref_list gen_conf s x = (x1,s1) /\ s1.ok ==> s.ok +Proof + Induct >> Cases >> fs[gc_move_ref_list_def] >> rpt strip_tac + >> ntac 2 (pairarg_tac >> fs[]) >> metis_tac[gc_partial_move_list_ok_before] +QED + +Theorem gc_partial_move_data_ok_before: + !gen_conf s s1. gen_gc_partial$gc_move_data gen_conf s = s1 /\ s1.ok ==> s.ok +Proof + recInduct (fetch "gen_gc_partial" "gc_move_data_ind") \\ rw[] \\ pop_assum mp_tac \\ once_rewrite_tac [gc_move_data_def] \\ rpt (CASE_TAC \\ simp_tac (srw_ss()) [LET_THM]) \\ pairarg_tac \\ fs [] \\ strip_tac \\ res_tac - \\ imp_res_tac gc_partial_move_list_ok_before) + \\ imp_res_tac gc_partial_move_list_ok_before +QED -Theorem gc_partial_move_list_ok_irr - `!x s y1 y2 t1 t2 h2 r4. +Theorem gc_partial_move_list_ok_irr: + !x s y1 y2 t1 t2 h2 r4. gen_gc_partial$gc_move_list gen_conf s x = (y1,t1) /\ t1.ok /\ gen_gc_partial$gc_move_list gen_conf (s with <| h2 := h2 ; r4 := r4 |>) x = (y2,t2) ==> - t2.ok` - (Induct \\ fs [gen_gc_partialTheory.gc_move_list_def] + t2.ok +Proof + Induct \\ fs [gen_gc_partialTheory.gc_move_list_def] \\ rw [] \\ fs [gc_sharedTheory.gc_state_component_equality] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] \\ drule gc_move_heap_length @@ -2557,27 +2813,31 @@ Theorem gc_partial_move_list_ok_irr \\ asm_exists_tac \\ fs [] \\ once_rewrite_tac [CONJ_COMM] \\ asm_exists_tac \\ fs [] - \\ metis_tac [gc_partial_move_ok_irr]); + \\ metis_tac [gc_partial_move_ok_irr] +QED -Theorem gc_partial_move_list_ok_irr' - `!x s y1 y2 t1 t2 h2 r4. +Theorem gc_partial_move_list_ok_irr': + !x s y1 y2 t1 t2 h2 r4. gen_gc_partial$gc_move_list gen_conf s x = (y1,t1) /\ gen_gc_partial$gc_move_list gen_conf (s with <| h2 := h2 ; r4 := r4 |>) x = (y2,t2) ==> - y1 = y2 /\ ?x1 x2. t2 = t1 with <| h2 := x1 ; r4 := x2 |>` - (Induct \\ fs [gen_gc_partialTheory.gc_move_list_def] \\ rw [] + y1 = y2 /\ ?x1 x2. t2 = t1 with <| h2 := x1 ; r4 := x2 |> +Proof + Induct \\ fs [gen_gc_partialTheory.gc_move_list_def] \\ rw [] \\ fs [gc_sharedTheory.gc_state_component_equality] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] \\ drule gc_partial_move_ok_irr \\ disch_then drule \\ DISCH_TAC \\ fs[] \\ fs[] - \\ first_x_assum drule \\ disch_then drule \\ fs[]); + \\ first_x_assum drule \\ disch_then drule \\ fs[] +QED -Theorem gc_partial_move_ref_list_ok_irr - `!x s y1 y2 t1 t2 h2 r4. +Theorem gc_partial_move_ref_list_ok_irr: + !x s y1 y2 t1 t2 h2 r4. gen_gc_partial$gc_move_ref_list gen_conf s x = (y1,t1) /\ t1.ok /\ gen_gc_partial$gc_move_ref_list gen_conf (s with <| h2 := h2 ; r4 := r4 |>) x = (y2,t2) ==> - t2.ok` - (Induct \\ Cases \\ fs [gen_gc_partialTheory.gc_move_ref_list_def] + t2.ok +Proof + Induct \\ Cases \\ fs [gen_gc_partialTheory.gc_move_ref_list_def] \\ rw [] \\ fs [gc_sharedTheory.gc_state_component_equality] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] \\ drule gc_move_list_heap_length @@ -2593,47 +2853,52 @@ Theorem gc_partial_move_ref_list_ok_irr \\ asm_exists_tac \\ fs [] \\ once_rewrite_tac [CONJ_COMM] \\ asm_exists_tac \\ fs [] - \\ metis_tac [gc_partial_move_list_ok_irr']); + \\ metis_tac [gc_partial_move_list_ok_irr'] +QED -Theorem gc_partial_move_with_NIL - `!x s y t. +Theorem gc_partial_move_with_NIL: + !x s y t. gen_gc_partial$gc_move gen_conf s x = (y,t) /\ t.ok ==> (let (y,s1) = gc_move gen_conf (s with <| h2 := []; r4 := [] |>) x in - (y,s1 with <| h2 := s.h2 ++ s1.h2; r4 := s1.r4 ++ s.r4 |>)) = (y,t)` - (Cases \\ fs [gen_gc_partialTheory.gc_move_def] \\ rw [] + (y,s1 with <| h2 := s.h2 ++ s1.h2; r4 := s1.r4 ++ s.r4 |>)) = (y,t) +Proof + Cases \\ fs [gen_gc_partialTheory.gc_move_def] \\ rw [] \\ fs [gc_sharedTheory.gc_state_component_equality] \\ CASE_TAC \\ fs [] \\ fs [gc_sharedTheory.gc_state_component_equality] \\ CASE_TAC \\ fs [] \\ fs [gc_sharedTheory.gc_state_component_equality] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] - \\ fs [gc_sharedTheory.gc_state_component_equality]); + \\ fs [gc_sharedTheory.gc_state_component_equality] +QED -Theorem gc_partial_move_with_NIL_LEMMA - `!x s y t h2 r4 y1 t1. +Theorem gc_partial_move_with_NIL_LEMMA: + !x s y t h2 r4 y1 t1. gen_gc_partial$gc_move gen_conf s x = (y1,t1) /\ t1.ok ==> ?x1 x2. t1.h2 = s.h2 ++ x1 /\ t1.r4 = x2 ++ s.r4 /\ gen_gc_partial$gc_move gen_conf (s with <| h2 := []; r4 := [] |>) x = - (y1,t1 with <| h2 := x1; r4 := x2 |>)` - (Cases \\ fs [gen_gc_partialTheory.gc_move_def] \\ rw [] + (y1,t1 with <| h2 := x1; r4 := x2 |>) +Proof + Cases \\ fs [gen_gc_partialTheory.gc_move_def] \\ rw [] \\ fs [gc_sharedTheory.gc_state_component_equality] \\ CASE_TAC \\ fs [gc_sharedTheory.gc_state_component_equality] \\ CASE_TAC \\ fs [gc_sharedTheory.gc_state_component_equality] - \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs []); + \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] +QED -Theorem gc_partial_move_list_with_NIL_LEMMA - `!x s y t h2 r4 y1 t1. +Theorem gc_partial_move_list_with_NIL_LEMMA = Q.prove(` + !x s y t h2 r4 y1 t1. gen_gc_partial$gc_move_list gen_conf s x = (y1,t1) /\ t1.ok ==> ?x1 x2. t1.h2 = s.h2 ++ x1 /\ t1.r4 = x2 ++ s.r4 /\ gen_gc_partial$gc_move_list gen_conf (s with <| h2 := []; r4 := [] |>) x = - (y1,t1 with <| h2 := x1; r4 := x2 |>)` - (Induct \\ fs [gen_gc_partialTheory.gc_move_list_def] \\ rw [] + (y1,t1 with <| h2 := x1; r4 := x2 |>)`, + Induct \\ fs [gen_gc_partialTheory.gc_move_list_def] \\ rw [] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] \\ rename1 `gc_move gen_conf s h = (x3,state3)` \\ rename1 `_ = (x4,state4)` @@ -2647,23 +2912,25 @@ Theorem gc_partial_move_list_with_NIL_LEMMA \\ fs [] \\ rw [] \\ fs [] \\ fs [gc_sharedTheory.gc_state_component_equality]) |> SIMP_RULE std_ss []; -Theorem gc_partial_move_list_with_NIL - `!x s y t. +Theorem gc_partial_move_list_with_NIL: + !x s y t. gen_gc_partial$gc_move_list gen_conf s x = (y,t) /\ t.ok ==> (let (y,s1) = gen_gc_partial$gc_move_list gen_conf (s with <| h2 := []; r4 := [] |>) x in - (y,s1 with <| h2 := s.h2 ++ s1.h2; r4 := s1.r4 ++ s.r4 |>)) = (y,t)` - (rw [] \\ drule gc_partial_move_list_with_NIL_LEMMA \\ fs [] - \\ strip_tac \\ fs [] \\ fs [gc_sharedTheory.gc_state_component_equality]); - -Theorem gc_partial_move_ref_list_with_NIL_LEMMA - `!x s y t h2 r4 y1 t1. + (y,s1 with <| h2 := s.h2 ++ s1.h2; r4 := s1.r4 ++ s.r4 |>)) = (y,t) +Proof + rw [] \\ drule gc_partial_move_list_with_NIL_LEMMA \\ fs [] + \\ strip_tac \\ fs [] \\ fs [gc_sharedTheory.gc_state_component_equality] +QED + +Theorem gc_partial_move_ref_list_with_NIL_LEMMA = Q.prove(` + !x s y t h2 r4 y1 t1. gen_gc_partial$gc_move_ref_list gen_conf s x = (y1,t1) /\ t1.ok ==> ?x1 x2. t1.h2 = s.h2 ++ x1 /\ t1.r4 = x2 ++ s.r4 /\ gen_gc_partial$gc_move_ref_list gen_conf (s with <| h2 := []; r4 := [] |>) x = - (y1,t1 with <| h2 := x1; r4 := x2 |>)` - (Induct THEN1 fs [gen_gc_partialTheory.gc_move_ref_list_def] + (y1,t1 with <| h2 := x1; r4 := x2 |>)`, + Induct THEN1 fs [gen_gc_partialTheory.gc_move_ref_list_def] \\ Cases \\ fs [gen_gc_partialTheory.gc_move_ref_list_def] \\ rw [] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] @@ -2679,16 +2946,18 @@ Theorem gc_partial_move_ref_list_with_NIL_LEMMA \\ fs [] \\ rw [] \\ fs [] \\ fs [gc_sharedTheory.gc_state_component_equality]) |> SIMP_RULE std_ss []; -Theorem gc_partial_move_ref_list_with_NIL - `!x s y t. +Theorem gc_partial_move_ref_list_with_NIL: + !x s y t. gen_gc_partial$gc_move_ref_list gen_conf s x = (y,t) /\ t.ok ==> (let (y,s1) = gen_gc_partial$gc_move_ref_list gen_conf (s with <| h2 := []; r4 := [] |>) x in - (y,s1 with <| h2 := s.h2 ++ s1.h2; r4 := s1.r4 ++ s.r4 |>)) = (y,t)` - (rw [] \\ drule gc_partial_move_ref_list_with_NIL_LEMMA \\ fs [] - \\ strip_tac \\ fs [] \\ fs [gc_sharedTheory.gc_state_component_equality]); - -Theorem word_gen_gc_partial_move_roots_thm - `!x xs x1 w s1 s pa1 pa m1 m i1 frame dm curr c1 old current refs. + (y,s1 with <| h2 := s.h2 ++ s1.h2; r4 := s1.r4 ++ s.r4 |>)) = (y,t) +Proof + rw [] \\ drule gc_partial_move_ref_list_with_NIL_LEMMA \\ fs [] + \\ strip_tac \\ fs [] \\ fs [gc_sharedTheory.gc_state_component_equality] +QED + +Theorem word_gen_gc_partial_move_roots_thm: + !x xs x1 w s1 s pa1 pa m1 m i1 frame dm curr c1 old current refs. (gen_gc_partial$gc_move_list gen_conf s x = (x1,s1)) /\ s1.ok /\ s.h2 = [] /\ s.r4 = [] /\ gen_conf.limit = heap_length s.heap /\ heap_length s.heap <= dimword (:'a) DIV 2 ** shift_length conf /\ @@ -2713,8 +2982,9 @@ Theorem word_gen_gc_partial_move_roots_thm (heap_segment (gen_conf.gen_start,gen_conf.refs_start) s1.heap = SOME(old,current1,refs)) /\ c1 /\ (i1 = n2w s1.a) /\ s1.n = LENGTH xs1 /\ s.n = heap_length s1.h2 + s1.n + heap_length s1.r4 /\ - pa1 = pa + bytes_in_word * n2w (heap_length s1.h2)` - (Induct + pa1 = pa + bytes_in_word * n2w (heap_length s1.h2) +Proof + Induct THEN1 (fs [gen_gc_partialTheory.gc_move_list_def,Once word_gen_gc_partial_move_roots_def] \\ rw [] \\ fs [word_heap_def,SEP_CLAUSES] \\ asm_exists_tac \\ fs []) @@ -2751,10 +3021,11 @@ Theorem word_gen_gc_partial_move_roots_thm \\ fs [heap_length_APPEND,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] \\ fs [AC STAR_COMM STAR_ASSOC] \\ qpat_x_assum `LENGTH xs = s.n` (assume_tac o GSYM) - \\ fs[]); + \\ fs[] +QED -Theorem word_gen_gc_partial_move_list_thm - `!x xs x1 s1 s pa1 pa m1 m i1 frame dm curr c1 k old current refs. +Theorem word_gen_gc_partial_move_list_thm: + !x xs x1 s1 s pa1 pa m1 m i1 frame dm curr c1 k old current refs. (gen_gc_partial$gc_move_list gen_conf s x = (x1,s1)) /\ s1.ok /\ s.h2 = [] /\ s.r4 = [] /\ gen_conf.limit = heap_length s.heap /\ heap_length s.heap <= dimword (:'a) DIV 2 ** shift_length conf /\ @@ -2782,8 +3053,9 @@ Theorem word_gen_gc_partial_move_list_thm c1 /\ (i1 = n2w s1.a) /\ s1.n = LENGTH xs1 /\ s.n = heap_length s1.h2 + s1.n + heap_length s1.r4 /\ k1 = k + n2w (LENGTH x) * bytes_in_word /\ - pa1 = pa + bytes_in_word * n2w (heap_length s1.h2)` - (Induct + pa1 = pa + bytes_in_word * n2w (heap_length s1.h2) +Proof + Induct THEN1 (fs [gen_gc_partialTheory.gc_move_list_def,Once word_gen_gc_partial_move_list_def] \\ rw [] \\ fs [word_heap_def,SEP_CLAUSES] \\ asm_exists_tac \\ fs []) @@ -2820,12 +3092,14 @@ Theorem word_gen_gc_partial_move_list_thm \\ fs [heap_length_APPEND,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] \\ fs [AC STAR_COMM STAR_ASSOC] \\ qpat_x_assum `LENGTH xs = s.n` (assume_tac o GSYM) - \\ fs[]); + \\ fs[] +QED -Theorem gc_partial_move_heap_lengths - `gen_gc_partial$gc_move gen_conf s x = (x1,s1) /\ s1.ok ==> - s.n + heap_length s.h2 = s1.n + heap_length s1.h2` - (Cases_on `x` >> rw[gc_move_def] +Theorem gc_partial_move_heap_lengths: + gen_gc_partial$gc_move gen_conf s x = (x1,s1) /\ s1.ok ==> + s.n + heap_length s.h2 = s1.n + heap_length s1.h2 +Proof + Cases_on `x` >> rw[gc_move_def] >> fs[] >> every_case_tac >> fs[] >- (qpat_x_assum `_ = s1` (assume_tac o GSYM) @@ -2841,22 +3115,25 @@ Theorem gc_partial_move_heap_lengths by(match_mp_tac (GEN_ALL gc_forward_ptr_ok) >> qexists_tac `a` >> qexists_tac `s.heap` >> qexists_tac `n` >> qexists_tac `s.a` >> qexists_tac `heap` >> fs[]) - >> fs[]); + >> fs[] +QED -Theorem gc_partial_move_list_heap_lengths - `!x gen_conf s x1 s1. gen_gc_partial$gc_move_list gen_conf s x = (x1,s1) /\ s1.ok ==> - s.n + heap_length s.h2 = s1.n + heap_length s1.h2` - (Induct_on `x` >> rw[gen_gc_partialTheory.gc_move_list_def] +Theorem gc_partial_move_list_heap_lengths: + !x gen_conf s x1 s1. gen_gc_partial$gc_move_list gen_conf s x = (x1,s1) /\ s1.ok ==> + s.n + heap_length s.h2 = s1.n + heap_length s1.h2 +Proof + Induct_on `x` >> rw[gen_gc_partialTheory.gc_move_list_def] >> ntac 2 (pairarg_tac >> fs[]) - >> metis_tac[gc_partial_move_heap_lengths,gc_partial_move_list_ok_before]); + >> metis_tac[gc_partial_move_heap_lengths,gc_partial_move_list_ok_before] +QED val partial_len_inv_def = Define ` partial_len_inv s <=> heap_length s.heap = heap_length (s.h1 ++ s.h2) + s.n + heap_length (s.r4 ++ s.r3 ++ s.r2 ++ s.r1 ++ s.old)`; -Theorem word_gen_gc_partial_move_data_thm - `!k s m dm curr xs s1 pa1 m1 i1 frame c1 old current refs. +Theorem word_gen_gc_partial_move_data_thm: + !k s m dm curr xs s1 pa1 m1 i1 frame c1 old current refs. (gen_gc_partial$gc_move_data gen_conf s = s1) /\ s1.ok /\ gen_conf.limit = heap_length s.heap /\ heap_length s.heap <= dimword (:'a) DIV 2 ** shift_length conf /\ @@ -2893,8 +3170,9 @@ Theorem word_gen_gc_partial_move_data_thm heap_length (s1.h1 ++ s1.h2 ++ s1.r4) + s1.n = heap_length (s.h1 ++ s.h2 ++ s.r4) + s.n /\ pa1 = p + bytes_in_word * n2w (heap_length (s1.h1 ++ s1.h2)) /\ - EVERY (is_Ref gen_conf.isRef) (s1.r4 ++ s1.r3 ++ s1.r2 ++ s1.r1)` - (completeInduct_on `k` \\ rpt strip_tac + EVERY (is_Ref gen_conf.isRef) (s1.r4 ++ s1.r3 ++ s1.r2 ++ s1.r1) +Proof + completeInduct_on `k` \\ rpt strip_tac \\ fs [PULL_FORALL,AND_IMP_INTRO,GSYM CONJ_ASSOC] \\ qpat_x_assum `gc_move_data gen_conf s = s1` mp_tac \\ once_rewrite_tac [gen_gc_partialTheory.gc_move_data_def] @@ -3065,11 +3343,12 @@ Theorem word_gen_gc_partial_move_data_thm \\ qpat_x_assum `_ = s.n` (assume_tac o GSYM) \\ fs [] \\ fs [word_heap_parts_def,word_heap_APPEND,word_heap_def,word_el_def, heap_length_APPEND,word_payload_def,GSYM word_add_n2w, - WORD_LEFT_ADD_DISTRIB,word_list_def,el_length_def,heap_length_def]); + WORD_LEFT_ADD_DISTRIB,word_list_def,el_length_def,heap_length_def] +QED -Theorem word_gen_gc_partial_move_ref_list_thm - `!x ck xs x1 s1 s pa1 pa m1 m i1 frame dm curr c1 k old current refs. +Theorem word_gen_gc_partial_move_ref_list_thm: + !x ck xs x1 s1 s pa1 pa m1 m i1 frame dm curr c1 k old current refs. (gen_gc_partial$gc_move_ref_list gen_conf s x = (x1,s1)) /\ s1.ok /\ s.h2 = [] /\ s.r4 = [] /\ heap_length x <= ck /\ gen_conf.limit = heap_length s.heap /\ @@ -3101,8 +3380,9 @@ Theorem word_gen_gc_partial_move_ref_list_thm c1 /\ (i1 = n2w s1.a) /\ s1.n = LENGTH xs1 /\ EVERY isRef x1 /\ s.n = heap_length s1.h2 + s1.n + heap_length s1.r4 /\ - pa1 = pa + bytes_in_word * n2w (heap_length s1.h2)` - (Induct + pa1 = pa + bytes_in_word * n2w (heap_length s1.h2) +Proof + Induct THEN1 (fs [gen_gc_partialTheory.gc_move_ref_list_def,Once word_gen_gc_partial_move_ref_list_def] \\ rw [] \\ fs [word_heap_def,SEP_CLAUSES,refs_to_addresses_def] \\ asm_exists_tac \\ fs []) @@ -3160,7 +3440,8 @@ Theorem word_gen_gc_partial_move_ref_list_thm \\ fs[GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB,heap_length_def] \\ fs[AC STAR_ASSOC STAR_COMM] \\ fs[SEP_CLAUSES] - \\ fs[isRef_def]); + \\ fs[isRef_def] +QED val gc_move_ref_list_IMP = prove ( ``!conf state refs state1 refs1. @@ -3194,33 +3475,40 @@ val gc_move_ref_list_IMP = prove ( >- simp [isSomeDataElement_def] \\ IF_CASES_TAC \\ fs [el_length_def]); -Theorem heap_length_LENGTH `LENGTH x <= heap_length x` - (Induct_on `x` >- fs[LENGTH] - >> Cases >> fs[LENGTH,heap_length_def,el_length_def]); +Theorem heap_length_LENGTH: + LENGTH x <= heap_length x +Proof + Induct_on `x` >- fs[LENGTH] + >> Cases >> fs[LENGTH,heap_length_def,el_length_def] +QED -Theorem partial_gc_move_ref_list_isRef ` - !refs s refs' state'. +Theorem partial_gc_move_ref_list_isRef: + !refs s refs' state'. gen_gc_partial$gc_move_ref_list gen_conf s refs = (refs',state') - ==> EVERY (is_Ref gen_conf.isRef) refs' = EVERY (is_Ref gen_conf.isRef) refs` - (Induct >- fs[gc_move_ref_list_def] + ==> EVERY (is_Ref gen_conf.isRef) refs' = EVERY (is_Ref gen_conf.isRef) refs +Proof + Induct >- fs[gc_move_ref_list_def] >> Cases >> rpt strip_tac >> fs[gc_move_ref_list_def] >> rveq >> fs[is_Ref_def] >> ntac 2 (pairarg_tac >> fs[]) >> rveq >> fs[is_Ref_def] - >> metis_tac[]); + >> metis_tac[] +QED -Theorem EVERY_is_Ref_isRef - `(∀t r. f (t,r) ⇔ t = RefTag) ==> EVERY (is_Ref f) refs = EVERY isRef refs` - (Induct_on `refs` >- fs[] >> Cases >> rpt strip_tac >> fs[isRef_def,is_Ref_def] - >> Cases_on `b` >> fs[isRef_def]); +Theorem EVERY_is_Ref_isRef: + (∀t r. f (t,r) ⇔ t = RefTag) ==> EVERY (is_Ref f) refs = EVERY isRef refs +Proof + Induct_on `refs` >- fs[] >> Cases >> rpt strip_tac >> fs[isRef_def,is_Ref_def] + >> Cases_on `b` >> fs[isRef_def] +QED val ends_with_refs_def = Define ` ends_with_refs rs heap = ?h1 h2. heap_split rs heap = SOME (h1,h2) /\ EVERY isRef h2` -Theorem word_gen_gc_partial_thm - `!m dm curr s1 pa1 m1 i1 frame c1 roots heap roots1 roots1' new. +Theorem word_gen_gc_partial_thm: + !m dm curr s1 pa1 m1 i1 frame c1 roots heap roots1 roots1' new. (gen_gc_partial$partial_gc gen_conf (roots,heap) = (roots1,s1)) /\ s1.ok /\ heap_length heap <= dimword (:'a) DIV 2 ** shift_length conf /\ heap_length heap * (dimindex (:'a) DIV 8) < dimword (:'a) /\ @@ -3251,8 +3539,9 @@ Theorem word_gen_gc_partial_thm c1 /\ (i1 = n2w s1.a) /\ pa1 = new + bytes_in_word * n2w (heap_length s1.h1) /\ s1.n = LENGTH xs1 /\ partial_len_inv s1 /\ heap_length s1.h1 <= heap_length current1 /\ heap_length s1.h1 + LENGTH xs1 + gen_conf.gen_start = gen_conf.refs_start /\ - EVERY (is_Ref gen_conf.isRef) s1.r1` - (rpt gen_tac \\ once_rewrite_tac [gen_gc_partialTheory.partial_gc_def] + EVERY (is_Ref gen_conf.isRef) s1.r1 +Proof + rpt gen_tac \\ once_rewrite_tac [gen_gc_partialTheory.partial_gc_def] \\ fs [] \\ rpt (pairarg_tac \\ fs []) \\ strip_tac \\ fs [] \\ every_case_tac THEN1 (fs[] \\ rveq \\ fs[]) \\ ntac 2 (pairarg_tac \\ fs[]) @@ -3355,10 +3644,11 @@ Theorem word_gen_gc_partial_thm \\ fs[AC STAR_ASSOC STAR_COMM] \\ qexists_tac `xs1''` \\ fs[] \\ drule partial_gc_move_ref_list_isRef - \\ fs[EVERY_is_Ref_isRef]); + \\ fs[EVERY_is_Ref_isRef] +QED -Theorem word_gen_gc_partial_full_thm - `!m dm curr s1 pa1 m1 i1 frame c1 roots heap roots1 roots1' new. +Theorem word_gen_gc_partial_full_thm: + !m dm curr s1 pa1 m1 i1 frame c1 roots heap roots1 roots1' new. (gen_gc_partial$partial_gc gen_conf (roots,heap) = (roots1,s1)) /\ s1.ok /\ heap_length heap <= dimword (:'a) DIV 2 ** shift_length conf /\ heap_length heap * (dimindex (:'a) DIV 8) < dimword (:'a) /\ @@ -3390,8 +3680,9 @@ Theorem word_gen_gc_partial_full_thm heap_segment (gen_conf.gen_start,gen_conf.refs_start) s1.heap = SOME(s1.old,current1,refs1) /\ c1 /\ (i1 = n2w s1.a) /\ pa1 = curr + bytes_in_word * n2w (heap_length(s1.old ++ s1.h1)) /\ partial_len_inv s1 /\ - EVERY (is_Ref gen_conf.isRef) s1.r1` - (rpt gen_tac \\ rw[word_gen_gc_partial_full_def] + EVERY (is_Ref gen_conf.isRef) s1.r1 +Proof + rpt gen_tac \\ rw[word_gen_gc_partial_full_def] \\ fs [] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs[] \\ drule word_gen_gc_partial_thm \\ rpt(disch_then drule) \\ fs[] @@ -3454,17 +3745,20 @@ Theorem word_gen_gc_partial_full_thm by(drule heap_segment_IMP >> fs[heap_length_APPEND]) \\ fs[AC STAR_ASSOC STAR_COMM,SEP_CLAUSES] \\ qpat_x_assum `_ = gen_conf.refs_start` (assume_tac o GSYM) - \\ fs[AC STAR_ASSOC STAR_COMM,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB]); + \\ fs[AC STAR_ASSOC STAR_COMM,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] +QED -Theorem gen_starts_in_store_IMP_SOME_Word - `gen_starts_in_store c gens x ==> ?w. x = SOME (Word w)` - (Cases_on `x` \\ fs [gen_starts_in_store_def] - \\ Cases_on `x'` \\ fs [gen_starts_in_store_def]); +Theorem gen_starts_in_store_IMP_SOME_Word: + gen_starts_in_store c gens x ==> ?w. x = SOME (Word w) +Proof + Cases_on `x` \\ fs [gen_starts_in_store_def] + \\ Cases_on `x'` \\ fs [gen_starts_in_store_def] +QED -Theorem word_gc_fun_lemma_Simple - `abs_ml_inv c (v::MAP FST stack) refs (hs,heap,be,a,sp,sp1,gens) limit /\ +Theorem word_gc_fun_lemma_Simple = Q.prove(` + abs_ml_inv c (v::MAP FST stack) refs (hs,heap,be,a,sp,sp1,gens) limit /\ good_dimindex (:'a) /\ heap_in_memory_store heap a sp sp1 gens c s m dm limit /\ LIST_REL (\v w. word_addr c v = w) hs (s ' Globals::MAP SND stack) /\ @@ -3477,8 +3771,8 @@ Theorem word_gc_fun_lemma_Simple (limit - heap_length heap2) 0 gens c s1 m1 dm limit /\ LIST_REL (λv w. word_addr c v = (w:'a word_loc)) roots2 (s1 ' Globals::MAP SND (ZIP (MAP FST stack,stack1))) /\ - LENGTH stack1 = LENGTH stack` - (strip_tac + LENGTH stack1 = LENGTH stack`, + strip_tac \\ rewrite_tac [word_gc_fun_def] \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[heap_in_memory_store_def,FLOOKUP_DEF,theWord_def,LET_THM] \\ pairarg_tac @@ -3517,52 +3811,63 @@ val do_partial_def = Define ` | Generational l => word_gen_gc_can_do_partial l s | _ => F` -Theorem heap_segment_IMP_split - `heap_segment (m,n) heap = SOME (x1,x2,x3) ==> +Theorem heap_segment_IMP_split: + heap_segment (m,n) heap = SOME (x1,x2,x3) ==> heap_split m heap = SOME (x1,x2++x3) /\ - heap_split n heap = SOME (x1++x2,x3)` - (strip_tac \\ drule heap_segment_IMP \\ strip_tac \\ rveq + heap_split n heap = SOME (x1++x2,x3) +Proof + strip_tac \\ drule heap_segment_IMP \\ strip_tac \\ rveq \\ rpt strip_tac THEN1 (full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ full_simp_tac std_ss [heap_split_APPEND_if] \\ fs [] \\ rw [] \\ Cases_on `x2` \\ fs [heap_length_def,el_length_def]) - \\ full_simp_tac std_ss [heap_split_APPEND_if] \\ fs []); + \\ full_simp_tac std_ss [heap_split_APPEND_if] \\ fs [] +QED -Theorem heap_split_IMP_heap_length - `!heap n h1 h2. +Theorem heap_split_IMP_heap_length: + !heap n h1 h2. heap_split n heap = SOME (h1,h2) ==> - heap_length h1 = n` - (Induct \\ fs [heap_split_def] \\ rw [] + heap_length h1 = n +Proof + Induct \\ fs [heap_split_def] \\ rw [] \\ every_case_tac \\ fs [] \\ rveq \\ fs [] - \\ res_tac \\ fs [heap_length_def]); + \\ res_tac \\ fs [heap_length_def] +QED -Theorem heap_split_APPEND_EQ - `!h1 h2 a. +Theorem heap_split_APPEND_EQ: + !h1 h2 a. heap_split a (h1 ++ h2) = SOME (h1,h2) <=> - a = heap_length h1` - (rw [] \\ eq_tac \\ rw [] + a = heap_length h1 +Proof + rw [] \\ eq_tac \\ rw [] THEN1 (drule heap_split_IMP_heap_length \\ fs []) - \\ fs [heap_split_APPEND_if]); - -Theorem heap_split_IMP_APPEND - `!heap n h1 h2. heap_split n heap = SOME (h1,h2) ==> heap = h1 ++ h2` - (Induct \\ fs[heap_split_def] - \\ rw [] \\ every_case_tac \\ fs [] \\ rveq \\ fs [] \\ res_tac); - -Theorem heap_length_nil - `heap_length m = 0 <=> m = []` - (Cases_on `m` \\ fs [heap_length_def,el_length_def]); - -Theorem abs_ml_inv_GenState_IMP_heap_length_FILTER - `abs_ml_inv c stack refs + \\ fs [heap_split_APPEND_if] +QED + +Theorem heap_split_IMP_APPEND: + !heap n h1 h2. heap_split n heap = SOME (h1,h2) ==> heap = h1 ++ h2 +Proof + Induct \\ fs[heap_split_def] + \\ rw [] \\ every_case_tac \\ fs [] \\ rveq \\ fs [] \\ res_tac +QED + +Theorem heap_length_nil: + heap_length m = 0 <=> m = [] +Proof + Cases_on `m` \\ fs [heap_length_def,el_length_def] +QED + +Theorem abs_ml_inv_GenState_IMP_heap_length_FILTER: + abs_ml_inv c stack refs (xs,heap,be,a,sp,sp1,GenState n (t::ts)) (heap_length heap) /\ c.gc_kind = Generational (y::ys) /\ heap_split (a+sp+sp1) heap = SOME (h1,h2) ==> EVERY isDataElement h2 /\ - heap_length (FILTER isDataElement heap) = a + heap_length h2` - (fs [abs_ml_inv_def,unused_space_inv_def,gc_kind_inv_def] + heap_length (FILTER isDataElement heap) = a + heap_length h2 +Proof + fs [abs_ml_inv_def,unused_space_inv_def,gc_kind_inv_def] \\ strip_tac \\ fs [] \\ `EVERY isDataElement h2` by (fs [EVERY_MEM] \\ Cases \\ strip_tac \\ res_tac \\ fs [isRef_def]) @@ -3591,7 +3896,8 @@ Theorem abs_ml_inv_GenState_IMP_heap_length_FILTER \\ Cases_on `m` \\ fs [heap_length_def] \\ fs [heap_lookup_def] \\ rveq \\ fs [isDataElement_def] \\ fs [SUM_APPEND,el_length_def] - \\ rfs [] \\ fs [GSYM heap_length_def,heap_length_nil]); + \\ rfs [] \\ fs [GSYM heap_length_def,heap_length_nil] +QED val new_trig_ok = prove( ``a <=+ (bytes_in_word * n2w n) /\ good_dimindex (:'a) ==> @@ -3600,20 +3906,23 @@ val new_trig_ok = prove( \\ fs [WORD_LO,WORD_LS,MIN_DEF] \\ rw [] \\ rfs [w2n_lt]); -Theorem byte_aligned_IMP_bytes_in_word - `byte_aligned w /\ good_dimindex (:'a) ==> ?v. w = bytes_in_word * v:'a word` - (fs [good_dimindex_def] \\ rw [] +Theorem byte_aligned_IMP_bytes_in_word: + byte_aligned w /\ good_dimindex (:'a) ==> ?v. w = bytes_in_word * v:'a word +Proof + fs [good_dimindex_def] \\ rw [] \\ fs [bytes_in_word_def,byte_aligned_def] \\ fs [aligned_def] \\ fs [align_w2n] \\ fs [GSYM word_mul_n2w] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem MULT_bytes_in_word_LESS_EQ_IMP - `w2n (k * bytes_in_word:'a word) ≤ w2n (bytes_in_word * n2w n:'a word) /\ +Theorem MULT_bytes_in_word_LESS_EQ_IMP: + w2n (k * bytes_in_word:'a word) ≤ w2n (bytes_in_word * n2w n:'a word) /\ good_dimindex (:'a) ==> - ?l. k * bytes_in_word = n2w l * bytes_in_word /\ l <= n` - (fs [good_dimindex_def] \\ rw [] + ?l. k * bytes_in_word = n2w l * bytes_in_word /\ l <= n +Proof + fs [good_dimindex_def] \\ rw [] \\ fs [bytes_in_word_def,byte_aligned_def] \\ Cases_on `k` \\ fs [word_mul_n2w] \\ fs [dimword_def] @@ -3633,7 +3942,8 @@ Theorem MULT_bytes_in_word_LESS_EQ_IMP \\ `0 < 2305843009213693952n` by EVAL_TAC \\ conj_tac THEN1 fs [] \\ drule DIVISION \\ disch_then (fn th => CONV_TAC (RAND_CONV (ONCE_REWRITE_CONV [th]))) - \\ fs [])); + \\ fs []) +QED val new_trig_LESS_EQ = prove( ``good_dimindex (:'a) ==> @@ -3654,8 +3964,8 @@ val new_trig_LESS_EQ = prove( MULT_bytes_in_word_LESS_EQ_IMP) \\ fs [] \\ qexists_tac `l` \\ fs []); -Theorem word_gc_fun_lemma - `abs_ml_inv c (v::MAP FST stack) refs (hs,heap,be,a,sp,sp1,gens) limit /\ +Theorem word_gc_fun_lemma = Q.prove(` + abs_ml_inv c (v::MAP FST stack) refs (hs,heap,be,a,sp,sp1,gens) limit /\ good_dimindex (:'a) /\ heap_in_memory_store heap a sp sp1 gens c s m dm limit /\ LIST_REL (\v w. word_addr c v = w) hs (s ' Globals::MAP SND stack) /\ @@ -3668,8 +3978,8 @@ Theorem word_gc_fun_lemma (c.gc_kind = None \/ c.gc_kind = Simple ==> k3 = 0) /\ LIST_REL (λv w. word_addr c v = (w:'a word_loc)) roots2 (s1 ' Globals::MAP SND (ZIP (MAP FST stack,stack1))) /\ - LENGTH stack1 = LENGTH stack` - (Cases_on `c.gc_kind` \\ fs [do_partial_def] + LENGTH stack1 = LENGTH stack`, + Cases_on `c.gc_kind` \\ fs [do_partial_def] THEN1 (fs [gc_combinedTheory.gc_combined_def] \\ rpt strip_tac \\ rveq \\ fs [] @@ -3880,16 +4190,17 @@ val abs_ml_inv_ADD = prove( fs [abs_ml_inv_def,gc_kind_inv_def] \\ rw [] \\ fs [gen_state_ok_def]); -Theorem word_gc_fun_correct - `good_dimindex (:'a) /\ +Theorem word_gc_fun_correct: + good_dimindex (:'a) /\ heap_in_memory_store heap a sp sp1 gens c s m dm limit /\ word_ml_inv (heap:'a ml_heap,be,a,sp,sp1,gens) limit c refs ((v,s ' Globals)::stack) ==> ?stack1 m1 s1 heap1 a1 sp1 sp2 gens2. word_gc_fun c (MAP SND stack,m,dm,s) = SOME (stack1,m1,s1) /\ heap_in_memory_store heap1 a1 sp1 sp2 gens2 c s1 m1 dm limit /\ word_ml_inv (heap1,be,a1,sp1,sp2,gens2) limit c refs - ((v,s1 ' Globals)::ZIP (MAP FST stack,stack1))` - (full_simp_tac(srw_ss())[word_ml_inv_def] + ((v,s1 ' Globals)::ZIP (MAP FST stack,stack1)) +Proof + full_simp_tac(srw_ss())[word_ml_inv_def] \\ srw_tac[][] \\ drule (GEN_ALL gc_combined_thm) \\ disch_then (qspec_then `do_partial c s` mp_tac) \\ impl_tac THEN1 @@ -3905,7 +4216,8 @@ Theorem word_gc_fun_correct \\ rveq \\ Cases_on `c.gc_kind` \\ fs [] \\ rpt (asm_exists_tac \\ fs [MAP_ZIP] \\ rfs [MAP_ZIP]) \\ imp_res_tac abs_ml_inv_ADD - \\ rpt (asm_exists_tac \\ fs [MAP_ZIP] \\ rfs [MAP_ZIP])); + \\ rpt (asm_exists_tac \\ fs [MAP_ZIP] \\ rfs [MAP_ZIP]) +QED (* ------------------------------------------------------- @@ -3961,10 +4273,12 @@ val code_oracle_rel_def = Define ` t_compile_oracle = (I ## MAP (compile_part c)) o s_compile_oracle /\ (!n. EVERY (\(n,_). data_num_stubs <= n) (SND (s_compile_oracle n)))` -Theorem code_oracle_rel_NextFree[simp] - `code_oracle_rel c sc sco (ts |+ (NextFree,x)) tcc tco cb db ⇔ - code_oracle_rel c sc sco ts tcc tco cb db` - (rw[code_oracle_rel_def,FLOOKUP_UPDATE]); +Theorem code_oracle_rel_NextFree[simp]: + code_oracle_rel c sc sco (ts |+ (NextFree,x)) tcc tco cb db ⇔ + code_oracle_rel c sc sco ts tcc tco cb db +Proof + rw[code_oracle_rel_def,FLOOKUP_UPDATE] +QED val s = ``(s:('c,'ffi) dataSem$state)`` @@ -4001,18 +4315,22 @@ val state_rel_thm = save_thm("state_rel_thm",state_rel_thm); val state_rel_def = save_thm("state_rel_def[compute]", state_rel_thm |> REWRITE_RULE [memory_rel_def]); -Theorem state_rel_with_clock - `state_rel a b c s1 s2 d e ⇒ - state_rel a b c (s1 with clock := k) (s2 with clock := k) d e` - (srw_tac[][state_rel_def]); +Theorem state_rel_with_clock: + state_rel a b c s1 s2 d e ⇒ + state_rel a b c (s1 with clock := k) (s2 with clock := k) d e +Proof + srw_tac[][state_rel_def] +QED (* ------------------------------------------------------- init ------------------------------------------------------- *) -Theorem flat_NIL - `flat [] xs = []` - (Cases_on `xs` \\ fs [flat_def]); +Theorem flat_NIL: + flat [] xs = [] +Proof + Cases_on `xs` \\ fs [flat_def] +QED val init_store_ok_def = Define ` init_store_ok c store m (dm:'a word set) code_buffer data_buffer <=> @@ -4043,8 +4361,8 @@ val init_store_ok_def = Define ` (word_list_exists curr (limit + limit)) (fun2set (m,dm)) ∧ byte_aligned curr` -Theorem state_rel_init - `t.ffi = ffi ∧ t.handler = 0 ∧ t.gc_fun = word_gc_fun c ∧ +Theorem state_rel_init: + t.ffi = ffi ∧ t.handler = 0 ∧ t.gc_fun = word_gc_fun c ∧ code_rel c code t.code ∧ code_oracle_rel c cc co t.store t.compile t.compile_oracle t.code_buffer t.data_buffer ∧ @@ -4054,8 +4372,9 @@ Theorem state_rel_init conf_ok (:'a) c /\ init_store_ok c t.store t.memory t.mdomain t.code_buffer t.data_buffer ==> state_rel c l1 l2 (initial_state ffi code co cc t.clock) - (t:('a,'c,'ffi) state) [] []` - (simp_tac std_ss [word_list_exists_ADD,conf_ok_def,init_store_ok_def] + (t:('a,'c,'ffi) state) [] [] +Proof + simp_tac std_ss [word_list_exists_ADD,conf_ok_def,init_store_ok_def] \\ fs [state_rel_thm,dataSemTheory.initial_state_def, join_env_def,lookup_def,the_global_def, libTheory.the_def,flat_NIL,FLOOKUP_DEF] \\ strip_tac \\ fs [] @@ -4102,54 +4421,64 @@ Theorem state_rel_init \\ simp_tac bool_ss [aligned_add_pow] \\ rfs [] \\ fs [gen_starts_in_store_def] \\ Cases \\ fs [] \\ rw[] \\ EVAL_TAC - \\ Cases_on `l` \\ fs []); + \\ Cases_on `l` \\ fs [] +QED (* ------------------------------------------------------- compiler proof ------------------------------------------------------- *) -Theorem adjust_var_NOT_0[simp] - `adjust_var n <> 0` - (full_simp_tac(srw_ss())[adjust_var_def]); +Theorem adjust_var_NOT_0[simp]: + adjust_var n <> 0 +Proof + full_simp_tac(srw_ss())[adjust_var_def] +QED -Theorem state_rel_get_var_IMP - `state_rel c l1 l2 ^s t v1 locs ==> +Theorem state_rel_get_var_IMP: + state_rel c l1 l2 ^s t v1 locs ==> (get_var n s.locals = SOME x) ==> - ?w. get_var (adjust_var n) t = SOME w` - (full_simp_tac(srw_ss())[dataSemTheory.get_var_def,wordSemTheory.get_var_def] + ?w. get_var (adjust_var n) t = SOME w +Proof + full_simp_tac(srw_ss())[dataSemTheory.get_var_def,wordSemTheory.get_var_def] \\ full_simp_tac(srw_ss())[state_rel_def] \\ rpt strip_tac \\ `IS_SOME (lookup n s.locals)` by full_simp_tac(srw_ss())[] \\ res_tac - \\ Cases_on `lookup (adjust_var n) t.locals` \\ full_simp_tac(srw_ss())[]); + \\ Cases_on `lookup (adjust_var n) t.locals` \\ full_simp_tac(srw_ss())[] +QED -Theorem state_rel_get_vars_IMP - `!n xs. +Theorem state_rel_get_vars_IMP: + !n xs. state_rel c l1 l2 ^s t [] locs ==> (get_vars n s.locals = SOME xs) ==> - ?ws. get_vars (MAP adjust_var n) t = SOME ws /\ (LENGTH xs = LENGTH ws)` - (Induct \\ full_simp_tac(srw_ss())[dataSemTheory.get_vars_def,wordSemTheory.get_vars_def] + ?ws. get_vars (MAP adjust_var n) t = SOME ws /\ (LENGTH xs = LENGTH ws) +Proof + Induct \\ full_simp_tac(srw_ss())[dataSemTheory.get_vars_def,wordSemTheory.get_vars_def] \\ rpt strip_tac \\ Cases_on `get_var h s.locals` \\ full_simp_tac(srw_ss())[] \\ Cases_on `get_vars n s.locals` \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] - \\ imp_res_tac state_rel_get_var_IMP \\ full_simp_tac(srw_ss())[]); + \\ imp_res_tac state_rel_get_var_IMP \\ full_simp_tac(srw_ss())[] +QED -Theorem state_rel_0_get_vars_IMP - `state_rel c l1 l2 ^s t [] locs ==> +Theorem state_rel_0_get_vars_IMP: + state_rel c l1 l2 ^s t [] locs ==> (get_vars n s.locals = SOME xs) ==> ?ws. get_vars (0::MAP adjust_var n) t = SOME ((Loc l1 l2)::ws) /\ - (LENGTH xs = LENGTH ws)` - (rpt strip_tac + (LENGTH xs = LENGTH ws) +Proof + rpt strip_tac \\ imp_res_tac state_rel_get_vars_IMP \\ full_simp_tac(srw_ss())[wordSemTheory.get_vars_def] - \\ full_simp_tac(srw_ss())[state_rel_def,wordSemTheory.get_var_def]); + \\ full_simp_tac(srw_ss())[state_rel_def,wordSemTheory.get_var_def] +QED -Theorem get_var_T_OR_F - `state_rel c l1 l2 ^s (t:('a,'c,'ffi) state) [] locs /\ +Theorem get_var_T_OR_F: + state_rel c l1 l2 ^s (t:('a,'c,'ffi) state) [] locs /\ get_var n s.locals = SOME x /\ get_var (adjust_var n) t = SOME w ==> 18 MOD dimword (:'a) <> 2 MOD dimword (:'a) /\ ((x = Boolv T) ==> (w = Word 18w)) /\ - ((x = Boolv F) ==> (w = Word 2w))` - (full_simp_tac(srw_ss())[state_rel_def,get_var_def,wordSemTheory.get_var_def] + ((x = Boolv F) ==> (w = Word 2w)) +Proof + full_simp_tac(srw_ss())[state_rel_def,get_var_def,wordSemTheory.get_var_def] \\ strip_tac \\ strip_tac THEN1 (full_simp_tac(srw_ss())[good_dimindex_def] \\ full_simp_tac(srw_ss())[dimword_def]) \\ full_simp_tac bool_ss [GSYM APPEND_ASSOC] \\ imp_res_tac (word_ml_inv_lookup |> Q.INST [`ys`|->`[]`] @@ -4161,7 +4490,8 @@ Theorem get_var_T_OR_F \\ pop_assum (fn th => full_simp_tac(srw_ss())[GSYM th]) \\ full_simp_tac(srw_ss())[Boolv_def] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[v_inv_def] \\ full_simp_tac(srw_ss())[word_addr_def] \\ full_simp_tac(srw_ss())[word_addr_def] - \\ EVAL_TAC \\ full_simp_tac(srw_ss())[good_dimindex_def,dimword_def]); + \\ EVAL_TAC \\ full_simp_tac(srw_ss())[good_dimindex_def,dimword_def] +QED val get_var_isT_OR_isF = Q.store_thm("get_var_isT_OR_isF", `state_rel c l1 l2 ^s (t:('a,'c,'ffi) state) [] locs /\ @@ -4192,11 +4522,12 @@ val get_var_isT_OR_isF = Q.store_thm("get_var_isT_OR_isF", val mk_loc_def = Define ` mk_loc (SOME (t1,d1,d2)) = Loc d1 d2`; -Theorem cut_env_IMP_cut_env - `state_rel c l1 l2 ^s t [] locs /\ +Theorem cut_env_IMP_cut_env: + state_rel c l1 l2 ^s t [] locs /\ dataSem$cut_env r s.locals = SOME x ==> - ?y. wordSem$cut_env (adjust_set r) t.locals = SOME y` - (full_simp_tac(srw_ss())[dataSemTheory.cut_env_def,wordSemTheory.cut_env_def] + ?y. wordSem$cut_env (adjust_set r) t.locals = SOME y +Proof + full_simp_tac(srw_ss())[dataSemTheory.cut_env_def,wordSemTheory.cut_env_def] \\ full_simp_tac(srw_ss())[adjust_set_def,domain_fromAList,SUBSET_DEF,MEM_MAP, PULL_EXISTS,sptreeTheory.domain_lookup,lookup_fromAList] \\ srw_tac[][] \\ Cases_on `x' = 0` \\ full_simp_tac(srw_ss())[] THEN1 full_simp_tac(srw_ss())[state_rel_def] @@ -4207,24 +4538,30 @@ Theorem cut_env_IMP_cut_env \\ full_simp_tac(srw_ss())[state_rel_def] \\ res_tac \\ sg `IS_SOME (lookup q s.locals)` \\ full_simp_tac(srw_ss())[] \\ res_tac \\ Cases_on `lookup (adjust_var q) t.locals` \\ full_simp_tac(srw_ss())[] - \\ full_simp_tac(srw_ss())[MEM_toAList,unit_some_eq_IS_SOME] \\ res_tac \\ full_simp_tac(srw_ss())[]); - -Theorem jump_exc_call_env - `wordSem$jump_exc (call_env x s) = jump_exc s` - (full_simp_tac(srw_ss())[wordSemTheory.jump_exc_def,wordSemTheory.call_env_def]); - -Theorem jump_exc_dec_clock - `mk_loc (wordSem$jump_exc (dec_clock s)) = mk_loc (jump_exc s)` - (full_simp_tac(srw_ss())[wordSemTheory.jump_exc_def,wordSemTheory.dec_clock_def] - \\ srw_tac[][] \\ BasicProvers.EVERY_CASE_TAC \\ full_simp_tac(srw_ss())[mk_loc_def]); + \\ full_simp_tac(srw_ss())[MEM_toAList,unit_some_eq_IS_SOME] \\ res_tac \\ full_simp_tac(srw_ss())[] +QED + +Theorem jump_exc_call_env: + wordSem$jump_exc (call_env x s) = jump_exc s +Proof + full_simp_tac(srw_ss())[wordSemTheory.jump_exc_def,wordSemTheory.call_env_def] +QED + +Theorem jump_exc_dec_clock: + mk_loc (wordSem$jump_exc (dec_clock s)) = mk_loc (jump_exc s) +Proof + full_simp_tac(srw_ss())[wordSemTheory.jump_exc_def,wordSemTheory.dec_clock_def] + \\ srw_tac[][] \\ BasicProvers.EVERY_CASE_TAC \\ full_simp_tac(srw_ss())[mk_loc_def] +QED val LASTN_ADD1 = save_thm("LASTN_ADD1",LASTN_LENGTH_ID |> Q.SPEC `x::xs` |> SIMP_RULE (srw_ss()) [ADD1]); -Theorem jump_exc_push_env_NONE - `mk_loc (jump_exc (push_env y NONE s)) = - mk_loc (jump_exc (s:('a,'c,'ffi) wordSem$state))` - (full_simp_tac(srw_ss())[wordSemTheory.push_env_def,wordSemTheory.jump_exc_def] +Theorem jump_exc_push_env_NONE: + mk_loc (jump_exc (push_env y NONE s)) = + mk_loc (jump_exc (s:('a,'c,'ffi) wordSem$state)) +Proof + full_simp_tac(srw_ss())[wordSemTheory.push_env_def,wordSemTheory.jump_exc_def] \\ Cases_on `env_to_list y s.permute` \\ full_simp_tac(srw_ss())[LET_DEF] \\ Cases_on `s.handler = LENGTH s.stack` \\ full_simp_tac(srw_ss())[LASTN_ADD1] \\ Cases_on `~(s.handler < LENGTH s.stack)` \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] @@ -4233,17 +4570,19 @@ Theorem jump_exc_push_env_NONE LASTN (s.handler + 1) s.stack` by (match_mp_tac LASTN_TL \\ decide_tac) \\ every_case_tac \\ srw_tac[][mk_loc_def] - \\ `F` by decide_tac); + \\ `F` by decide_tac +QED val s1 = mk_var("s1",type_of s) -Theorem state_rel_pop_env_IMP - `state_rel c q l ^s1 t1 xs locs /\ +Theorem state_rel_pop_env_IMP: + state_rel c q l ^s1 t1 xs locs /\ pop_env s1 = SOME s2 ==> ?t2 l8 l9 ll. pop_env t1 = SOME t2 /\ locs = (l8,l9)::ll /\ - state_rel c l8 l9 s2 t2 xs ll` - (full_simp_tac(srw_ss())[pop_env_def] + state_rel c l8 l9 s2 t2 xs ll +Proof + full_simp_tac(srw_ss())[pop_env_def] \\ Cases_on `s1.stack` \\ full_simp_tac(srw_ss())[] \\ Cases_on `h` \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[state_rel_def] \\ TRY (Cases_on `y`) \\ full_simp_tac(srw_ss())[stack_rel_def] @@ -4259,15 +4598,17 @@ Theorem state_rel_pop_env_IMP \\ full_simp_tac(srw_ss())[flat_def] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ Cases_on `x` \\ full_simp_tac(srw_ss())[join_env_def,MEM_MAP,MEM_FILTER,EXISTS_PROD] \\ full_simp_tac(srw_ss())[MEM_toAList,lookup_fromAList,lookup_inter_alt] - \\ imp_res_tac alistTheory.ALOOKUP_MEM \\ metis_tac []); + \\ imp_res_tac alistTheory.ALOOKUP_MEM \\ metis_tac [] +QED -Theorem state_rel_pop_env_set_var_IMP - `state_rel c q l ^s1 t1 [(a,w)] locs /\ +Theorem state_rel_pop_env_set_var_IMP: + state_rel c q l ^s1 t1 [(a,w)] locs /\ pop_env s1 = SOME s2 ==> ?t2 l8 l9 ll. pop_env t1 = SOME t2 /\ locs = (l8,l9)::ll /\ - state_rel c l8 l9 (set_var q1 a s2) (set_var (adjust_var q1) w t2) [] ll` - (full_simp_tac(srw_ss())[pop_env_def] + state_rel c l8 l9 (set_var q1 a s2) (set_var (adjust_var q1) w t2) [] ll +Proof + full_simp_tac(srw_ss())[pop_env_def] \\ Cases_on `s1.stack` \\ full_simp_tac(srw_ss())[] \\ Cases_on `h` \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[state_rel_def,set_var_def,wordSemTheory.set_var_def] @@ -4295,18 +4636,20 @@ Theorem state_rel_pop_env_set_var_IMP \\ full_simp_tac(srw_ss())[MEM] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ Cases_on `x` \\ full_simp_tac(srw_ss())[join_env_def,MEM_MAP,MEM_FILTER,EXISTS_PROD] \\ full_simp_tac(srw_ss())[MEM_toAList,lookup_fromAList,lookup_inter_alt] - \\ imp_res_tac alistTheory.ALOOKUP_MEM \\ metis_tac []); + \\ imp_res_tac alistTheory.ALOOKUP_MEM \\ metis_tac [] +QED -Theorem state_rel_jump_exc - `state_rel c l1 l2 ^s (t:('a,'c,'ffi) wordSem$state) [] locs /\ +Theorem state_rel_jump_exc: + state_rel c l1 l2 ^s (t:('a,'c,'ffi) wordSem$state) [] locs /\ get_var n s.locals = SOME x /\ get_var (adjust_var n) t = SOME w /\ jump_exc s = SOME s1 ==> ?t1 d1 d2 l5 l6 ll. jump_exc t = SOME (t1,d1,d2) /\ LASTN (LENGTH s1.stack + 1) locs = (l5,l6)::ll /\ - !i. state_rel c l5 l6 (set_var i x s1) (set_var (adjust_var i) w t1) [] ll` - (full_simp_tac(srw_ss())[jump_exc_def] \\ rpt CASE_TAC \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[state_rel_def] + !i. state_rel c l5 l6 (set_var i x s1) (set_var (adjust_var i) w t1) [] ll +Proof + full_simp_tac(srw_ss())[jump_exc_def] \\ rpt CASE_TAC \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[state_rel_def] \\ full_simp_tac(srw_ss())[wordSemTheory.set_var_def,set_var_def] \\ full_simp_tac bool_ss [GSYM APPEND_ASSOC] \\ imp_res_tac word_ml_inv_get_var_IMP @@ -4336,32 +4679,40 @@ Theorem state_rel_jump_exc \\ full_simp_tac(srw_ss())[MEM] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ Cases_on `x'` \\ full_simp_tac(srw_ss())[join_env_def,MEM_MAP,MEM_FILTER,EXISTS_PROD] \\ full_simp_tac(srw_ss())[MEM_toAList,lookup_fromAList,lookup_inter_alt] - \\ imp_res_tac alistTheory.ALOOKUP_MEM \\ metis_tac []); - -Theorem get_vars_IMP_LENGTH - `!x t s. dataSem$get_vars x s = SOME t ==> LENGTH x = LENGTH t` - (Induct \\ full_simp_tac(srw_ss())[dataSemTheory.get_vars_def] \\ srw_tac[][] - \\ every_case_tac \\ res_tac \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[]); - -Theorem get_vars_IMP_LENGTH_word - `!x t s. wordSem$get_vars x s = SOME t ==> LENGTH x = LENGTH t` - (Induct \\ full_simp_tac(srw_ss())[wordSemTheory.get_vars_def] \\ srw_tac[][] - \\ every_case_tac \\ res_tac \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[]); - -Theorem lookup_adjust_var_fromList2 - `lookup (adjust_var n) (fromList2 (w::ws)) = lookup n (fromList ws)` - (full_simp_tac(srw_ss())[lookup_fromList2,EVEN_adjust_var,lookup_fromList] + \\ imp_res_tac alistTheory.ALOOKUP_MEM \\ metis_tac [] +QED + +Theorem get_vars_IMP_LENGTH: + !x t s. dataSem$get_vars x s = SOME t ==> LENGTH x = LENGTH t +Proof + Induct \\ full_simp_tac(srw_ss())[dataSemTheory.get_vars_def] \\ srw_tac[][] + \\ every_case_tac \\ res_tac \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] +QED + +Theorem get_vars_IMP_LENGTH_word: + !x t s. wordSem$get_vars x s = SOME t ==> LENGTH x = LENGTH t +Proof + Induct \\ full_simp_tac(srw_ss())[wordSemTheory.get_vars_def] \\ srw_tac[][] + \\ every_case_tac \\ res_tac \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] +QED + +Theorem lookup_adjust_var_fromList2: + lookup (adjust_var n) (fromList2 (w::ws)) = lookup n (fromList ws) +Proof + full_simp_tac(srw_ss())[lookup_fromList2,EVEN_adjust_var,lookup_fromList] \\ full_simp_tac(srw_ss())[adjust_var_def] \\ once_rewrite_tac [MULT_COMM] - \\ full_simp_tac(srw_ss())[GSYM MULT_CLAUSES,MULT_DIV]); + \\ full_simp_tac(srw_ss())[GSYM MULT_CLAUSES,MULT_DIV] +QED -Theorem state_rel_call_env - `get_vars args ^s.locals = SOME q /\ +Theorem state_rel_call_env: + get_vars args ^s.locals = SOME q /\ get_vars (MAP adjust_var args) (t:('a,'c,'ffi) wordSem$state) = SOME ws /\ state_rel c l5 l6 s t [] locs ==> state_rel c l1 l2 (call_env q (dec_clock s)) - (call_env (Loc l1 l2::ws) (dec_clock t)) [] locs` - (full_simp_tac(srw_ss())[state_rel_def,call_env_def,wordSemTheory.call_env_def, + (call_env (Loc l1 l2::ws) (dec_clock t)) [] locs +Proof + full_simp_tac(srw_ss())[state_rel_def,call_env_def,wordSemTheory.call_env_def, dataSemTheory.dec_clock_def,wordSemTheory.dec_clock_def,lookup_adjust_var_fromList2] \\ srw_tac[][lookup_fromList2,lookup_fromList] \\ srw_tac[][] \\ imp_res_tac get_vars_IMP_LENGTH @@ -4386,42 +4737,46 @@ Theorem state_rel_call_env \\ Cases_on `k` \\ full_simp_tac(srw_ss())[] \\ Cases_on `n` \\ full_simp_tac(srw_ss())[DECIDE ``SUC (SUC n) = n + 2``] \\ simp [MATCH_MP ADD_DIV_RWT (DECIDE ``0<2:num``)] - \\ full_simp_tac(srw_ss())[GSYM ADD1,EL]); + \\ full_simp_tac(srw_ss())[GSYM ADD1,EL] +QED -Theorem data_get_vars_SNOC_IMP - `!x2 x. dataSem$get_vars (SNOC x1 x2) s = SOME x ==> +Theorem data_get_vars_SNOC_IMP = Q.prove(` + !x2 x. dataSem$get_vars (SNOC x1 x2) s = SOME x ==> ?y1 y2. x = SNOC y1 y2 /\ dataSem$get_var x1 s = SOME y1 /\ - dataSem$get_vars x2 s = SOME y2` - (Induct \\ full_simp_tac(srw_ss())[dataSemTheory.get_vars_def] + dataSem$get_vars x2 s = SOME y2`, + Induct \\ full_simp_tac(srw_ss())[dataSemTheory.get_vars_def] \\ srw_tac[][] \\ every_case_tac \\ full_simp_tac(srw_ss())[] \\ srw_tac[][]) |> SPEC_ALL; val _ = save_thm("data_get_vars_SNOC_IMP",data_get_vars_SNOC_IMP); -Theorem word_get_vars_SNOC_IMP - `!x2 x. wordSem$get_vars (SNOC x1 x2) s = SOME x ==> +Theorem word_get_vars_SNOC_IMP = Q.prove(` + !x2 x. wordSem$get_vars (SNOC x1 x2) s = SOME x ==> ?y1 y2. x = SNOC y1 y2 /\ wordSem$get_var x1 s = SOME y1 /\ - wordSem$get_vars x2 s = SOME y2` - (Induct \\ full_simp_tac(srw_ss())[wordSemTheory.get_vars_def] + wordSem$get_vars x2 s = SOME y2`, + Induct \\ full_simp_tac(srw_ss())[wordSemTheory.get_vars_def] \\ srw_tac[][] \\ every_case_tac \\ full_simp_tac(srw_ss())[] \\ srw_tac[][]) |> SPEC_ALL; val _ = save_thm("word_get_vars_SNOC_IMP",word_get_vars_SNOC_IMP); -Theorem word_ml_inv_CodePtr - `word_ml_inv (heap,be,a,sp,sp1,gens) limit c s.refs ((CodePtr n,v)::xs) ==> - (v = Loc n 0)` - (full_simp_tac(srw_ss())[word_ml_inv_def,PULL_EXISTS] \\ srw_tac[][] +Theorem word_ml_inv_CodePtr: + word_ml_inv (heap,be,a,sp,sp1,gens) limit c s.refs ((CodePtr n,v)::xs) ==> + (v = Loc n 0) +Proof + full_simp_tac(srw_ss())[word_ml_inv_def,PULL_EXISTS] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[abs_ml_inv_def,bc_stack_ref_inv_def,v_inv_def] - \\ srw_tac[][word_addr_def]); + \\ srw_tac[][word_addr_def] +QED -Theorem state_rel_CodePtr - `state_rel c l1 l2 s t [] locs /\ +Theorem state_rel_CodePtr: + state_rel c l1 l2 s t [] locs /\ get_vars args s.locals = SOME x /\ get_vars (MAP adjust_var args) t = SOME y /\ LAST x = CodePtr n /\ x <> [] ==> - y <> [] /\ LAST y = Loc n 0` - (rpt strip_tac + y <> [] /\ LAST y = Loc n 0 +Proof + rpt strip_tac \\ imp_res_tac wordPropsTheory.get_vars_length_lemma \\ imp_res_tac get_vars_IMP_LENGTH \\ full_simp_tac(srw_ss())[] THEN1 (srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ Cases_on `x` \\ full_simp_tac(srw_ss())[]) @@ -4434,10 +4789,11 @@ Theorem state_rel_CodePtr \\ full_simp_tac(srw_ss())[state_rel_def] \\ full_simp_tac bool_ss [GSYM APPEND_ASSOC] \\ imp_res_tac word_ml_inv_get_var_IMP \\ full_simp_tac(srw_ss())[] - \\ imp_res_tac word_ml_inv_CodePtr); + \\ imp_res_tac word_ml_inv_CodePtr +QED -Theorem find_code_thm - `!s (t:('a,'c,'ffi)wordSem$state). +Theorem find_code_thm = Q.prove(` + !s (t:('a,'c,'ffi)wordSem$state). state_rel c l1 l2 ^s t [] locs /\ get_vars args s.locals = SOME x /\ get_vars (0::MAP adjust_var args) t = SOME (Loc l1 l2::ws) /\ @@ -4445,8 +4801,8 @@ Theorem find_code_thm ?args1 n1 n2. find_code dest (Loc l1 l2::ws) t.code = SOME (args1,FST (comp c n1 n2 r)) /\ state_rel c l1 l2 (call_env q (dec_clock s)) - (call_env args1 (dec_clock t)) [] locs` - (Cases_on `dest` \\ srw_tac[][] \\ full_simp_tac(srw_ss())[find_code_def] + (call_env args1 (dec_clock t)) [] locs`, + Cases_on `dest` \\ srw_tac[][] \\ full_simp_tac(srw_ss())[find_code_def] \\ every_case_tac \\ full_simp_tac(srw_ss())[wordSemTheory.find_code_def] \\ srw_tac[][] \\ `code_rel c s.code t.code` by full_simp_tac(srw_ss())[state_rel_def] \\ full_simp_tac(srw_ss())[code_rel_def] \\ res_tac \\ full_simp_tac(srw_ss())[ADD1] @@ -4472,43 +4828,54 @@ Theorem find_code_thm \\ imp_res_tac state_rel_call_env \\ full_simp_tac(srw_ss())[]) |> SPEC_ALL; val _ = save_thm("find_code_thm",find_code_thm); -Theorem cut_env_adjust_set_lookup_0 - `wordSem$cut_env (adjust_set r) x = SOME y ==> lookup 0 y = lookup 0 x` - (full_simp_tac(srw_ss())[wordSemTheory.cut_env_def,SUBSET_DEF,domain_lookup,adjust_set_def, +Theorem cut_env_adjust_set_lookup_0: + wordSem$cut_env (adjust_set r) x = SOME y ==> lookup 0 y = lookup 0 x +Proof + full_simp_tac(srw_ss())[wordSemTheory.cut_env_def,SUBSET_DEF,domain_lookup,adjust_set_def, lookup_fromAList] \\ srw_tac[][lookup_inter] \\ pop_assum (qspec_then `0` mp_tac) \\ full_simp_tac(srw_ss())[] - \\ srw_tac[][] \\ full_simp_tac(srw_ss())[lookup_fromAList,lookup_inter]); + \\ srw_tac[][] \\ full_simp_tac(srw_ss())[lookup_fromAList,lookup_inter] +QED + +Theorem cut_env_IMP_MEM: + dataSem$cut_env s r = SOME x ==> + (IS_SOME (lookup n x) <=> IS_SOME (lookup n s)) +Proof + full_simp_tac(srw_ss())[cut_env_def,SUBSET_DEF,domain_lookup] + \\ srw_tac[][] \\ full_simp_tac(srw_ss())[lookup_inter] \\ every_case_tac \\ full_simp_tac(srw_ss())[] + \\ res_tac \\ full_simp_tac(srw_ss())[] +QED + +Theorem cut_env_IMP_lookup: + wordSem$cut_env s r = SOME x /\ lookup n x = SOME q ==> + lookup n r = SOME q +Proof + full_simp_tac(srw_ss())[wordSemTheory.cut_env_def,SUBSET_DEF,domain_lookup] + \\ srw_tac[][] \\ full_simp_tac(srw_ss())[lookup_inter] \\ every_case_tac \\ full_simp_tac(srw_ss())[] +QED + +Theorem cut_env_IMP_lookup_EQ: + dataSem$cut_env r y = SOME x /\ n IN domain r ==> + lookup n x = lookup n y +Proof + full_simp_tac(srw_ss())[dataSemTheory.cut_env_def,SUBSET_DEF,domain_lookup] + \\ srw_tac[][] \\ full_simp_tac(srw_ss())[lookup_inter] \\ every_case_tac \\ full_simp_tac(srw_ss())[] +QED -Theorem cut_env_IMP_MEM - `dataSem$cut_env s r = SOME x ==> - (IS_SOME (lookup n x) <=> IS_SOME (lookup n s))` - (full_simp_tac(srw_ss())[cut_env_def,SUBSET_DEF,domain_lookup] +Theorem cut_env_res_IS_SOME_IMP: + wordSem$cut_env r x = SOME y /\ IS_SOME (lookup k y) ==> + IS_SOME (lookup k x) /\ IS_SOME (lookup k r) +Proof + full_simp_tac(srw_ss())[wordSemTheory.cut_env_def,SUBSET_DEF,domain_lookup] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[lookup_inter] \\ every_case_tac \\ full_simp_tac(srw_ss())[] - \\ res_tac \\ full_simp_tac(srw_ss())[]); - -Theorem cut_env_IMP_lookup - `wordSem$cut_env s r = SOME x /\ lookup n x = SOME q ==> - lookup n r = SOME q` - (full_simp_tac(srw_ss())[wordSemTheory.cut_env_def,SUBSET_DEF,domain_lookup] - \\ srw_tac[][] \\ full_simp_tac(srw_ss())[lookup_inter] \\ every_case_tac \\ full_simp_tac(srw_ss())[]); - -Theorem cut_env_IMP_lookup_EQ - `dataSem$cut_env r y = SOME x /\ n IN domain r ==> - lookup n x = lookup n y` - (full_simp_tac(srw_ss())[dataSemTheory.cut_env_def,SUBSET_DEF,domain_lookup] - \\ srw_tac[][] \\ full_simp_tac(srw_ss())[lookup_inter] \\ every_case_tac \\ full_simp_tac(srw_ss())[]); - -Theorem cut_env_res_IS_SOME_IMP - `wordSem$cut_env r x = SOME y /\ IS_SOME (lookup k y) ==> - IS_SOME (lookup k x) /\ IS_SOME (lookup k r)` - (full_simp_tac(srw_ss())[wordSemTheory.cut_env_def,SUBSET_DEF,domain_lookup] - \\ srw_tac[][] \\ full_simp_tac(srw_ss())[lookup_inter] \\ every_case_tac \\ full_simp_tac(srw_ss())[]); - -Theorem adjust_var_cut_env_IMP_MEM - `wordSem$cut_env (adjust_set s) r = SOME x ==> +QED + +Theorem adjust_var_cut_env_IMP_MEM: + wordSem$cut_env (adjust_set s) r = SOME x ==> domain x SUBSET EVEN /\ - (IS_SOME (lookup (adjust_var n) x) <=> IS_SOME (lookup n s))` - (full_simp_tac(srw_ss())[wordSemTheory.cut_env_def,SUBSET_DEF,domain_lookup] + (IS_SOME (lookup (adjust_var n) x) <=> IS_SOME (lookup n s)) +Proof + full_simp_tac(srw_ss())[wordSemTheory.cut_env_def,SUBSET_DEF,domain_lookup] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[lookup_inter_alt] THEN1 (full_simp_tac(srw_ss())[domain_lookup,unit_some_eq_IS_SOME,adjust_set_def] \\ full_simp_tac(srw_ss())[IS_SOME_ALOOKUP_EQ,MEM_MAP,lookup_fromAList] @@ -4516,10 +4883,11 @@ Theorem adjust_var_cut_env_IMP_MEM \\ full_simp_tac(srw_ss())[IS_SOME_ALOOKUP_EQ,MEM_MAP,lookup_fromAList] \\ pairarg_tac \\ srw_tac[][] \\ full_simp_tac(srw_ss())[EVEN_adjust_var]) \\ full_simp_tac(srw_ss())[domain_lookup,lookup_adjust_var_adjust_set_SOME_UNIT] \\ srw_tac[][] - \\ metis_tac [lookup_adjust_var_adjust_set_SOME_UNIT,IS_SOME_DEF]); + \\ metis_tac [lookup_adjust_var_adjust_set_SOME_UNIT,IS_SOME_DEF] +QED -Theorem state_rel_call_env_push_env - `!opt:(num # 'a wordLang$prog # num # num) option. +Theorem state_rel_call_env_push_env: + !opt:(num # 'a wordLang$prog # num # num) option. state_rel c l1 l2 s (t:('a,'c,'ffi)wordSem$state) [] locs /\ get_vars args s.locals = SOME xs /\ get_vars (MAP adjust_var args) t = SOME ws /\ @@ -4527,8 +4895,9 @@ Theorem state_rel_call_env_push_env wordSem$cut_env (adjust_set r) t.locals = SOME y ==> state_rel c q l (call_env xs (push_env x (IS_SOME opt) (dec_clock s))) (call_env (Loc q l::ws) (push_env y opt (dec_clock t))) [] - ((l1,l2)::locs)` - (Cases \\ TRY (PairCases_on `x'`) \\ full_simp_tac(srw_ss())[] + ((l1,l2)::locs) +Proof + Cases \\ TRY (PairCases_on `x'`) \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[state_rel_def,call_env_def,push_env_def,dataSemTheory.dec_clock_def, wordSemTheory.call_env_def,wordSemTheory.push_env_def, wordSemTheory.dec_clock_def] @@ -4588,10 +4957,11 @@ Theorem state_rel_call_env_push_env \\ srw_tac[][adjust_var_11,adjust_var_DIV_2] \\ imp_res_tac MEM_toAList \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[dataSemTheory.cut_env_def,SUBSET_DEF,domain_lookup] - \\ res_tac \\ full_simp_tac(srw_ss())[MEM_toAList]); + \\ res_tac \\ full_simp_tac(srw_ss())[MEM_toAList] +QED -Theorem find_code_thm_ret - `!s (t:('a,'c,'ffi)wordSem$state). +Theorem find_code_thm_ret = Q.prove(` + !s (t:('a,'c,'ffi)wordSem$state). state_rel c l1 l2 s t [] locs /\ get_vars args s.locals = SOME xs /\ get_vars (MAP adjust_var args) t = SOME ws /\ @@ -4603,8 +4973,8 @@ Theorem find_code_thm_ret state_rel c q l (call_env ys (push_env x F (dec_clock s))) (call_env args1 (push_env y (NONE:(num # ('a wordLang$prog) # num # num) option) - (dec_clock t))) [] ((l1,l2)::locs)` - (reverse (Cases_on `dest`) \\ srw_tac[][] \\ full_simp_tac(srw_ss())[find_code_def] + (dec_clock t))) [] ((l1,l2)::locs)`, + reverse (Cases_on `dest`) \\ srw_tac[][] \\ full_simp_tac(srw_ss())[find_code_def] \\ every_case_tac \\ full_simp_tac(srw_ss())[wordSemTheory.find_code_def] \\ srw_tac[][] \\ `code_rel c s.code t.code` by full_simp_tac(srw_ss())[state_rel_def] \\ full_simp_tac(srw_ss())[code_rel_def] \\ res_tac \\ full_simp_tac(srw_ss())[ADD1] @@ -4628,8 +4998,8 @@ Theorem find_code_thm_ret \\ full_simp_tac(srw_ss())[] \\ metis_tac []) |> SPEC_ALL; val _ = save_thm("find_code_thm_ret",find_code_thm_ret); -Theorem find_code_thm_handler - `!s (t:('a,'c,'ffi)wordSem$state). +Theorem find_code_thm_handler = Q.prove(` + !s (t:('a,'c,'ffi)wordSem$state). state_rel c l1 l2 s t [] locs /\ get_vars args s.locals = SOME xs /\ get_vars (MAP adjust_var args) t = SOME ws /\ @@ -4641,8 +5011,8 @@ Theorem find_code_thm_handler state_rel c q l (call_env ys (push_env x T (dec_clock s))) (call_env args1 (push_env y (SOME (adjust_var x0,(prog1:'a wordLang$prog),nn,l + 1)) - (dec_clock t))) [] ((l1,l2)::locs)` - (reverse (Cases_on `dest`) \\ srw_tac[][] \\ full_simp_tac(srw_ss())[find_code_def] + (dec_clock t))) [] ((l1,l2)::locs)`, + reverse (Cases_on `dest`) \\ srw_tac[][] \\ full_simp_tac(srw_ss())[find_code_def] \\ every_case_tac \\ full_simp_tac(srw_ss())[wordSemTheory.find_code_def] \\ srw_tac[][] \\ `code_rel c s.code t.code` by full_simp_tac(srw_ss())[state_rel_def] \\ full_simp_tac(srw_ss())[code_rel_def] \\ res_tac \\ full_simp_tac(srw_ss())[ADD1] @@ -4668,38 +5038,47 @@ Theorem find_code_thm_handler val _ = save_thm("find_code_thm_handler",find_code_thm_handler); -Theorem data_find_code - `dataSem$find_code dest xs code = SOME(ys,prog) ⇒ ¬bad_dest_args dest xs` - (Cases_on`dest`>> - full_simp_tac(srw_ss())[dataSemTheory.find_code_def,wordSemTheory.bad_dest_args_def]); +Theorem data_find_code: + dataSem$find_code dest xs code = SOME(ys,prog) ⇒ ¬bad_dest_args dest xs +Proof + Cases_on`dest`>> + full_simp_tac(srw_ss())[dataSemTheory.find_code_def,wordSemTheory.bad_dest_args_def] +QED -Theorem s_key_eq_LENGTH - `!xs ys. s_key_eq xs ys ==> (LENGTH xs = LENGTH ys)` - (Induct \\ Cases_on `ys` \\ full_simp_tac(srw_ss())[s_key_eq_def]); +Theorem s_key_eq_LENGTH: + !xs ys. s_key_eq xs ys ==> (LENGTH xs = LENGTH ys) +Proof + Induct \\ Cases_on `ys` \\ full_simp_tac(srw_ss())[s_key_eq_def] +QED -Theorem s_key_eq_LASTN - `!xs ys n. s_key_eq xs ys ==> s_key_eq (LASTN n xs) (LASTN n ys)` - (Induct \\ Cases_on `ys` \\ full_simp_tac(srw_ss())[s_key_eq_def,LASTN_ALT] +Theorem s_key_eq_LASTN: + !xs ys n. s_key_eq xs ys ==> s_key_eq (LASTN n xs) (LASTN n ys) +Proof + Induct \\ Cases_on `ys` \\ full_simp_tac(srw_ss())[s_key_eq_def,LASTN_ALT] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[s_key_eq_def,LASTN_ALT] \\ res_tac - \\ imp_res_tac s_key_eq_LENGTH \\ full_simp_tac(srw_ss())[] \\ `F` by decide_tac); - -Theorem evaluate_mk_loc_EQ - `evaluate (q,t) = (NONE,t1:('a,'b,'c) state) ==> - mk_loc (jump_exc t1) = ((mk_loc (jump_exc t)):'a word_loc)` - (qspecl_then [`q`,`t`] mp_tac wordPropsTheory.evaluate_stack_swap \\ srw_tac[][] + \\ imp_res_tac s_key_eq_LENGTH \\ full_simp_tac(srw_ss())[] \\ `F` by decide_tac +QED + +Theorem evaluate_mk_loc_EQ: + evaluate (q,t) = (NONE,t1:('a,'b,'c) state) ==> + mk_loc (jump_exc t1) = ((mk_loc (jump_exc t)):'a word_loc) +Proof + qspecl_then [`q`,`t`] mp_tac wordPropsTheory.evaluate_stack_swap \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[wordSemTheory.jump_exc_def] \\ imp_res_tac s_key_eq_LENGTH \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ imp_res_tac s_key_eq_LASTN \\ pop_assum (qspec_then `t.handler + 1` mp_tac) - \\ every_case_tac \\ full_simp_tac(srw_ss())[s_key_eq_def,s_frame_key_eq_def,mk_loc_def]) + \\ every_case_tac \\ full_simp_tac(srw_ss())[s_key_eq_def,s_frame_key_eq_def,mk_loc_def] +QED -Theorem mk_loc_eq_push_env_exc_Exception - `evaluate +Theorem mk_loc_eq_push_env_exc_Exception: + evaluate (c:'a wordLang$prog, call_env args1 (push_env y (SOME (x0,prog1:'a wordLang$prog,x1,l)) (dec_clock t))) = (SOME (Exception xx w),(t1:('a,'b,'c) state)) ==> - mk_loc (jump_exc t1) = mk_loc (jump_exc t) :'a word_loc` - (qspecl_then [`c`,`call_env args1 + mk_loc (jump_exc t1) = mk_loc (jump_exc t) :'a word_loc +Proof + qspecl_then [`c`,`call_env args1 (push_env y (SOME (x0,prog1:'a wordLang$prog,x1,l)) (dec_clock t))`] mp_tac wordPropsTheory.evaluate_stack_swap \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[wordSemTheory.call_env_def,wordSemTheory.push_env_def, @@ -4710,13 +5089,15 @@ Theorem mk_loc_eq_push_env_exc_Exception \\ imp_res_tac s_key_eq_LENGTH \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ imp_res_tac s_key_eq_LASTN \\ pop_assum (qspec_then `t.handler+1` mp_tac) \\ srw_tac[][] - \\ every_case_tac \\ full_simp_tac(srw_ss())[s_key_eq_def,s_frame_key_eq_def,mk_loc_def]); + \\ every_case_tac \\ full_simp_tac(srw_ss())[s_key_eq_def,s_frame_key_eq_def,mk_loc_def] +QED -Theorem evaluate_IMP_domain_EQ - `evaluate (c,call_env (args1:'a word_loc list) (push_env y (opt:(num # ('a wordLang$prog) # num # num) option) (dec_clock t))) = +Theorem evaluate_IMP_domain_EQ: + evaluate (c,call_env (args1:'a word_loc list) (push_env y (opt:(num # ('a wordLang$prog) # num # num) option) (dec_clock t))) = (SOME (Result ll w),t1) /\ pop_env t1 = SOME t2 ==> - domain t2.locals = domain y` - (qspecl_then [`c`,`call_env args1 (push_env y opt (dec_clock t))`] mp_tac + domain t2.locals = domain y +Proof + qspecl_then [`c`,`call_env args1 (push_env y opt (dec_clock t))`] mp_tac wordPropsTheory.evaluate_stack_swap \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[wordSemTheory.call_env_def] \\ Cases_on `opt` \\ full_simp_tac(srw_ss())[] \\ TRY (PairCases_on `x`) @@ -4727,14 +5108,16 @@ Theorem evaluate_IMP_domain_EQ \\ full_simp_tac(srw_ss())[s_frame_key_eq_def,domain_fromAList] \\ srw_tac[][] \\ qpat_x_assum `xxx = MAP FST l` (fn th => full_simp_tac(srw_ss())[GSYM th]) \\ full_simp_tac(srw_ss())[EXTENSION,MEM_MAP,EXISTS_PROD,mem_list_rearrange,QSORT_MEM, - domain_lookup,MEM_toAList]); + domain_lookup,MEM_toAList] +QED -Theorem evaluate_IMP_domain_EQ_Exc - `evaluate (c,call_env args1 (push_env y +Theorem evaluate_IMP_domain_EQ_Exc: + evaluate (c,call_env args1 (push_env y (SOME (x0,prog1:'a wordLang$prog,x1,l)) (dec_clock (t:('a,'b,'c) state)))) = (SOME (Exception ll w),t1) ==> - domain t1.locals = domain y` - (qspecl_then [`c`,`call_env args1 + domain t1.locals = domain y +Proof + qspecl_then [`c`,`call_env args1 (push_env y (SOME (x0,prog1:'a wordLang$prog,x1,l)) (dec_clock t))`] mp_tac wordPropsTheory.evaluate_stack_swap \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[wordSemTheory.call_env_def,wordSemTheory.push_env_def, @@ -4747,47 +5130,59 @@ Theorem evaluate_IMP_domain_EQ_Exc \\ full_simp_tac(srw_ss())[s_frame_key_eq_def,domain_fromAList] \\ srw_tac[][] \\ qpat_x_assum `xxx = MAP FST lss` (fn th => full_simp_tac(srw_ss())[GSYM th]) \\ full_simp_tac(srw_ss())[EXTENSION,MEM_MAP,EXISTS_PROD,mem_list_rearrange,QSORT_MEM, - domain_lookup,MEM_toAList]); + domain_lookup,MEM_toAList] +QED -Theorem mk_loc_jump_exc - `mk_loc +Theorem mk_loc_jump_exc: + mk_loc (jump_exc (call_env args1 (push_env y (SOME (adjust_var n,prog1,x0,l)) - (dec_clock t)))) = Loc x0 l` - (full_simp_tac(srw_ss())[wordSemTheory.push_env_def,wordSemTheory.call_env_def, + (dec_clock t)))) = Loc x0 l +Proof + full_simp_tac(srw_ss())[wordSemTheory.push_env_def,wordSemTheory.call_env_def, wordSemTheory.jump_exc_def] \\ Cases_on `env_to_list y (dec_clock t).permute` - \\ full_simp_tac(srw_ss())[LET_DEF,LASTN_ADD1,mk_loc_def]); + \\ full_simp_tac(srw_ss())[LET_DEF,LASTN_ADD1,mk_loc_def] +QED val inc_clock_def = Define ` inc_clock n (t:('a,'c,'ffi) wordSem$state) = t with clock := t.clock + n`; -Theorem inc_clock_0[simp] - `!t. inc_clock 0 t = t` - (full_simp_tac(srw_ss())[inc_clock_def,wordSemTheory.state_component_equality]); - -Theorem inc_clock_inc_clock[simp] - `!t. inc_clock n (inc_clock m t) = inc_clock (n+m) t` - (full_simp_tac(srw_ss())[inc_clock_def,wordSemTheory.state_component_equality,AC ADD_ASSOC ADD_COMM]); - -Theorem mk_loc_jmup_exc_inc_clock[simp] - `mk_loc (jump_exc (inc_clock ck t)) = mk_loc (jump_exc t)` - (full_simp_tac(srw_ss())[mk_loc_def,wordSemTheory.jump_exc_def,inc_clock_def] - \\ every_case_tac \\ full_simp_tac(srw_ss())[mk_loc_def]); - -Theorem jump_exc_inc_clock_EQ_NONE - `jump_exc (inc_clock n s) = NONE <=> jump_exc s = NONE` - (full_simp_tac(srw_ss())[mk_loc_def,wordSemTheory.jump_exc_def,inc_clock_def] - \\ every_case_tac \\ full_simp_tac(srw_ss())[mk_loc_def]); - -Theorem state_rel_lookup_globals - `state_rel c l1 l2 s t v1 locs ∧ s.global = SOME g (* ∧ +Theorem inc_clock_0[simp]: + !t. inc_clock 0 t = t +Proof + full_simp_tac(srw_ss())[inc_clock_def,wordSemTheory.state_component_equality] +QED + +Theorem inc_clock_inc_clock[simp]: + !t. inc_clock n (inc_clock m t) = inc_clock (n+m) t +Proof + full_simp_tac(srw_ss())[inc_clock_def,wordSemTheory.state_component_equality,AC ADD_ASSOC ADD_COMM] +QED + +Theorem mk_loc_jmup_exc_inc_clock[simp]: + mk_loc (jump_exc (inc_clock ck t)) = mk_loc (jump_exc t) +Proof + full_simp_tac(srw_ss())[mk_loc_def,wordSemTheory.jump_exc_def,inc_clock_def] + \\ every_case_tac \\ full_simp_tac(srw_ss())[mk_loc_def] +QED + +Theorem jump_exc_inc_clock_EQ_NONE: + jump_exc (inc_clock n s) = NONE <=> jump_exc s = NONE +Proof + full_simp_tac(srw_ss())[mk_loc_def,wordSemTheory.jump_exc_def,inc_clock_def] + \\ every_case_tac \\ full_simp_tac(srw_ss())[mk_loc_def] +QED + +Theorem state_rel_lookup_globals: + state_rel c l1 l2 s t v1 locs ∧ s.global = SOME g (* ∧ FLOOKUP s.refs g = SOME (ValueArray gs) *) ⇒ ∃x u. - FLOOKUP t.store Globals = SOME (Word (get_addr c x u))` - (rw[state_rel_def] + FLOOKUP t.store Globals = SOME (Word (get_addr c x u)) +Proof + rw[state_rel_def] \\ fs[the_global_def,libTheory.the_def] \\ qmatch_assum_abbrev_tac`word_ml_inv heapp limit c refs _` \\ qmatch_asmsub_abbrev_tac`[gg]` @@ -4808,13 +5203,15 @@ Theorem state_rel_lookup_globals \\ first_assum(CHANGED_TAC o SUBST1_TAC o SYM) \\ rveq \\ simp_tac(srw_ss())[word_addr_def] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem state_rel_cut_env - `state_rel c l1 l2 s t [] locs /\ +Theorem state_rel_cut_env: + state_rel c l1 l2 s t [] locs /\ dataSem$cut_env names s.locals = SOME x ==> - state_rel c l1 l2 (s with locals := x) t [] locs` - (full_simp_tac(srw_ss())[state_rel_def,dataSemTheory.cut_env_def] \\ srw_tac[][] + state_rel c l1 l2 (s with locals := x) t [] locs +Proof + full_simp_tac(srw_ss())[state_rel_def,dataSemTheory.cut_env_def] \\ srw_tac[][] THEN1 (full_simp_tac(srw_ss())[lookup_inter] \\ every_case_tac \\ full_simp_tac(srw_ss())[]) \\ asm_exists_tac \\ full_simp_tac(srw_ss())[] \\ first_x_assum (fn th => mp_tac th THEN match_mp_tac word_ml_inv_rearrange) @@ -4835,13 +5232,15 @@ Theorem state_rel_cut_env \\ full_simp_tac(srw_ss())[domain_lookup,unit_some_eq_IS_SOME,adjust_set_def,lookup_fromAList] \\ rev_full_simp_tac(srw_ss())[IS_SOME_ALOOKUP_EQ,MEM_MAP] \\ srw_tac[][] \\ Cases_on `y'` \\ full_simp_tac(srw_ss())[] \\ srw_tac[][EXISTS_PROD,adjust_var_11] - \\ full_simp_tac(srw_ss())[MEM_toAList,lookup_inter_alt]); + \\ full_simp_tac(srw_ss())[MEM_toAList,lookup_inter_alt] +QED -Theorem state_rel_get_var_RefPtr - `state_rel c l1 l2 s t v1 locs ∧ +Theorem state_rel_get_var_RefPtr: + state_rel c l1 l2 s t v1 locs ∧ get_var n s.locals = SOME (RefPtr p) ⇒ - ∃f u. get_var (adjust_var n) t = SOME (Word (get_addr c (FAPPLY f p) u))` - (rw[] + ∃f u. get_var (adjust_var n) t = SOME (Word (get_addr c (FAPPLY f p) u)) +Proof + rw[] \\ imp_res_tac state_rel_get_var_IMP \\ fs[state_rel_def,wordSemTheory.get_var_def,dataSemTheory.get_var_def] \\ full_simp_tac std_ss [Once (GSYM APPEND_ASSOC)] @@ -4867,13 +5266,15 @@ Theorem state_rel_get_var_RefPtr \\ fs[bc_stack_ref_inv_def] \\ fs[v_inv_def] \\ simp[word_addr_def] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem state_rel_get_var_Block - `state_rel c l1 l2 s t v1 locs ∧ +Theorem state_rel_get_var_Block: + state_rel c l1 l2 s t v1 locs ∧ get_var n s.locals = SOME (Block ts tag vs) ⇒ - ∃w. get_var (adjust_var n) t = SOME (Word w)` - (rw[] + ∃w. get_var (adjust_var n) t = SOME (Word w) +Proof + rw[] \\ imp_res_tac state_rel_get_var_IMP \\ fs[state_rel_def,wordSemTheory.get_var_def,dataSemTheory.get_var_def] \\ full_simp_tac std_ss [Once (GSYM APPEND_ASSOC)] @@ -4901,28 +5302,31 @@ Theorem state_rel_get_var_Block \\ qhdtm_x_assum`COND`mp_tac \\ IF_CASES_TAC \\ simp[word_addr_def] \\ strip_tac \\ rveq - \\ simp[word_addr_def]); + \\ simp[word_addr_def] +QED val s' = mk_var("s'",type_of s); -Theorem state_rel_cut_state_opt_get_var - `state_rel c l1 l2 ^s t [] locs ∧ +Theorem state_rel_cut_state_opt_get_var: + state_rel c l1 l2 ^s t [] locs ∧ cut_state_opt names_opt s = SOME x ∧ get_var v x.locals = SOME w ⇒ ∃s'. state_rel c l1 l2 ^s' t [] locs ∧ - get_var v s'.locals = SOME w` - (rw[cut_state_opt_def] + get_var v s'.locals = SOME w +Proof + rw[cut_state_opt_def] \\ every_case_tac \\ fs[] >- metis_tac[] \\ fs[cut_state_def] \\ every_case_tac \\ fs[] \\ imp_res_tac state_rel_cut_env - \\ metis_tac[] ); + \\ metis_tac[] +QED -Theorem jump_exc_push_env_NONE_simp - `(jump_exc (wordSem$dec_clock t) = NONE <=> jump_exc t = NONE) /\ +Theorem jump_exc_push_env_NONE_simp = Q.prove(` + (jump_exc (wordSem$dec_clock t) = NONE <=> jump_exc t = NONE) /\ (jump_exc (wordSem$push_env y NONE t) = NONE <=> jump_exc t = NONE) /\ - (jump_exc (wordSem$call_env args s) = NONE <=> jump_exc s = NONE)` - (full_simp_tac(srw_ss())[wordSemTheory.jump_exc_def,wordSemTheory.call_env_def, + (jump_exc (wordSem$call_env args s) = NONE <=> jump_exc s = NONE)`, + full_simp_tac(srw_ss())[wordSemTheory.jump_exc_def,wordSemTheory.call_env_def, wordSemTheory.dec_clock_def] \\ srw_tac[][] THEN1 every_case_tac \\ full_simp_tac(srw_ss())[wordSemTheory.push_env_def] \\ Cases_on `env_to_list y t.permute` \\ full_simp_tac(srw_ss())[LET_DEF] @@ -4939,55 +5343,66 @@ Theorem jump_exc_push_env_NONE_simp |> SIMP_RULE std_ss [LENGTH]) \\ full_simp_tac(srw_ss())[]) |> curry save_thm "jump_exc_push_env_NONE_simp"; -Theorem s_key_eq_handler_eq_IMP - `s_key_eq t.stack t1.stack /\ t.handler = t1.handler ==> - (jump_exc t1 <> NONE <=> jump_exc t <> NONE)` - (full_simp_tac(srw_ss())[wordSemTheory.jump_exc_def] \\ srw_tac[][] +Theorem s_key_eq_handler_eq_IMP: + s_key_eq t.stack t1.stack /\ t.handler = t1.handler ==> + (jump_exc t1 <> NONE <=> jump_exc t <> NONE) +Proof + full_simp_tac(srw_ss())[wordSemTheory.jump_exc_def] \\ srw_tac[][] \\ imp_res_tac s_key_eq_LENGTH \\ full_simp_tac(srw_ss())[] \\ Cases_on `t1.handler < LENGTH t1.stack` \\ full_simp_tac(srw_ss())[] \\ imp_res_tac s_key_eq_LASTN \\ pop_assum (qspec_then `t1.handler + 1` mp_tac) - \\ every_case_tac \\ full_simp_tac(srw_ss())[s_key_eq_def,s_frame_key_eq_def]); - -Theorem eval_NONE_IMP_jump_exc_NONE_EQ - `wordSem$evaluate (q,t) = (NONE,t1) ==> (jump_exc t1 = NONE <=> jump_exc t = NONE)` - (srw_tac[][] \\ mp_tac (wordPropsTheory.evaluate_stack_swap |> Q.SPECL [`q`,`t`]) - \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ imp_res_tac s_key_eq_handler_eq_IMP \\ metis_tac []); - -Theorem jump_exc_push_env_SOME - `jump_exc (push_env y (SOME (x,prog1,l1,l2)) t) <> NONE` - (full_simp_tac(srw_ss())[wordSemTheory.jump_exc_def,wordSemTheory.push_env_def] + \\ every_case_tac \\ full_simp_tac(srw_ss())[s_key_eq_def,s_frame_key_eq_def] +QED + +Theorem eval_NONE_IMP_jump_exc_NONE_EQ: + wordSem$evaluate (q,t) = (NONE,t1) ==> (jump_exc t1 = NONE <=> jump_exc t = NONE) +Proof + srw_tac[][] \\ mp_tac (wordPropsTheory.evaluate_stack_swap |> Q.SPECL [`q`,`t`]) + \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ imp_res_tac s_key_eq_handler_eq_IMP \\ metis_tac [] +QED + +Theorem jump_exc_push_env_SOME: + jump_exc (push_env y (SOME (x,prog1,l1,l2)) t) <> NONE +Proof + full_simp_tac(srw_ss())[wordSemTheory.jump_exc_def,wordSemTheory.push_env_def] \\ Cases_on `env_to_list y t.permute` \\ full_simp_tac(srw_ss())[LET_DEF] - \\ full_simp_tac(srw_ss())[LASTN_ADD1]); + \\ full_simp_tac(srw_ss())[LASTN_ADD1] +QED -Theorem eval_push_env_T_Raise_IMP_stack_length - `evaluate (p,call_env ys (push_env x T (dec_clock (s:('c,'ffi)dataSem$state)))) = +Theorem eval_push_env_T_Raise_IMP_stack_length: + evaluate (p,call_env ys (push_env x T (dec_clock (s:('c,'ffi)dataSem$state)))) = (SOME (Rerr (Rraise a)),r') ==> - LENGTH r'.stack = LENGTH s.stack` - (qspecl_then [`p`,`call_env ys (push_env x T (dec_clock s))`] + LENGTH r'.stack = LENGTH s.stack +Proof + qspecl_then [`p`,`call_env ys (push_env x T (dec_clock s))`] mp_tac dataPropsTheory.evaluate_stack_swap \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[call_env_def,jump_exc_def,push_env_def,dataSemTheory.dec_clock_def,LASTN_ADD1] - \\ srw_tac[][] \\ full_simp_tac(srw_ss())[]); + \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] +QED -Theorem eval_push_env_SOME_exc_IMP_s_key_eq - `evaluate (p, call_env args1 (push_env y (SOME (x1,x2,x3,x4)) (dec_clock t))) = +Theorem eval_push_env_SOME_exc_IMP_s_key_eq: + evaluate (p, call_env args1 (push_env y (SOME (x1,x2,x3,x4)) (dec_clock t))) = (SOME (Exception l w),t1) ==> - s_key_eq t1.stack t.stack /\ t.handler = t1.handler` - (qspecl_then [`p`,`call_env args1 (push_env y (SOME (x1,x2,x3,x4)) (dec_clock t))`] + s_key_eq t1.stack t.stack /\ t.handler = t1.handler +Proof + qspecl_then [`p`,`call_env args1 (push_env y (SOME (x1,x2,x3,x4)) (dec_clock t))`] mp_tac wordPropsTheory.evaluate_stack_swap \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[wordSemTheory.call_env_def,wordSemTheory.jump_exc_def, wordSemTheory.push_env_def,wordSemTheory.dec_clock_def,LASTN_ADD1] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ Cases_on `env_to_list y t.permute` \\ full_simp_tac(srw_ss())[LET_DEF,LASTN_ADD1] - \\ srw_tac[][] \\ full_simp_tac(srw_ss())[]); + \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] +QED -Theorem eval_exc_stack_shorter - `evaluate (c,call_env ys (push_env x F (dec_clock (s:('c,'ffi)dataSem$state)))) = +Theorem eval_exc_stack_shorter: + evaluate (c,call_env ys (push_env x F (dec_clock (s:('c,'ffi)dataSem$state)))) = (SOME (Rerr (Rraise a)),r') ==> - LENGTH r'.stack < LENGTH s.stack` - (srw_tac[][] \\ qspecl_then [`c`,`call_env ys (push_env x F (dec_clock s))`] + LENGTH r'.stack < LENGTH s.stack +Proof + srw_tac[][] \\ qspecl_then [`c`,`call_env ys (push_env x F (dec_clock s))`] mp_tac dataPropsTheory.evaluate_stack_swap \\ full_simp_tac(srw_ss())[] \\ once_rewrite_tac [EQ_SYM_EQ] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[dataSemTheory.jump_exc_def,call_env_def,push_env_def,dataSemTheory.dec_clock_def] @@ -4997,101 +5412,131 @@ Theorem eval_exc_stack_shorter \\ every_case_tac \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ match_mp_tac LESS_LESS_EQ_TRANS \\ qexists_tac `LENGTH (LASTN (s.handler + 1) s.stack)` - \\ full_simp_tac(srw_ss())[LENGTH_LASTN_LESS]); + \\ full_simp_tac(srw_ss())[LENGTH_LASTN_LESS] +QED val alloc_size_def = Define ` alloc_size k = (if k * (dimindex (:'a) DIV 8) < dimword (:α) then n2w (k * (dimindex (:'a) DIV 8)) else (-1w)):'a word` -Theorem NOT_1_domain - `~(1 IN domain (adjust_set names))` - (full_simp_tac(srw_ss())[domain_fromAList,adjust_set_def,MEM_MAP,MEM_toAList, - FORALL_PROD,adjust_var_def] \\ CCONTR_TAC \\ full_simp_tac(srw_ss())[] \\ decide_tac) - -Theorem NOT_3_domain - `~(3 IN domain (adjust_set names))` - (full_simp_tac(srw_ss())[domain_fromAList,adjust_set_def,MEM_MAP,MEM_toAList, +Theorem NOT_1_domain: + ~(1 IN domain (adjust_set names)) +Proof + full_simp_tac(srw_ss())[domain_fromAList,adjust_set_def,MEM_MAP,MEM_toAList, + FORALL_PROD,adjust_var_def] \\ CCONTR_TAC \\ full_simp_tac(srw_ss())[] \\ decide_tac +QED + +Theorem NOT_3_domain: + ~(3 IN domain (adjust_set names)) +Proof + full_simp_tac(srw_ss())[domain_fromAList,adjust_set_def,MEM_MAP,MEM_toAList, FORALL_PROD,adjust_var_def] \\ CCONTR_TAC \\ full_simp_tac(srw_ss())[] - \\ Cases_on `p_1'` \\ fs []) + \\ Cases_on `p_1'` \\ fs [] +QED -Theorem NOT_5_domain - `~(5 IN domain (adjust_set names))` - (full_simp_tac(srw_ss())[domain_fromAList,adjust_set_def,MEM_MAP,MEM_toAList, +Theorem NOT_5_domain: + ~(5 IN domain (adjust_set names)) +Proof + full_simp_tac(srw_ss())[domain_fromAList,adjust_set_def,MEM_MAP,MEM_toAList, FORALL_PROD,adjust_var_def] \\ CCONTR_TAC \\ full_simp_tac(srw_ss())[] - \\ Cases_on `p_1'` \\ fs [] \\ Cases_on `n` \\ fs []) + \\ Cases_on `p_1'` \\ fs [] \\ Cases_on `n` \\ fs [] +QED -Theorem cut_env_adjust_set_insert_1 - `wordSem$cut_env (adjust_set names) (insert 1 w l) = wordSem$cut_env (adjust_set names) l` - (full_simp_tac(srw_ss())[wordSemTheory.cut_env_def,MATCH_MP SUBSET_INSERT_EQ_SUBSET NOT_1_domain] +Theorem cut_env_adjust_set_insert_1: + wordSem$cut_env (adjust_set names) (insert 1 w l) = wordSem$cut_env (adjust_set names) l +Proof + full_simp_tac(srw_ss())[wordSemTheory.cut_env_def,MATCH_MP SUBSET_INSERT_EQ_SUBSET NOT_1_domain] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[lookup_inter,lookup_insert] \\ Cases_on `x = 1` \\ full_simp_tac(srw_ss())[] \\ every_case_tac \\ srw_tac[][] - \\ full_simp_tac(srw_ss())[SIMP_RULE std_ss [domain_lookup] NOT_1_domain]); + \\ full_simp_tac(srw_ss())[SIMP_RULE std_ss [domain_lookup] NOT_1_domain] +QED -Theorem cut_env_adjust_set_insert_3 - `wordSem$cut_env (adjust_set names) (insert 3 w l) = wordSem$cut_env (adjust_set names) l` - (full_simp_tac(srw_ss())[wordSemTheory.cut_env_def,MATCH_MP SUBSET_INSERT_EQ_SUBSET NOT_3_domain] +Theorem cut_env_adjust_set_insert_3: + wordSem$cut_env (adjust_set names) (insert 3 w l) = wordSem$cut_env (adjust_set names) l +Proof + full_simp_tac(srw_ss())[wordSemTheory.cut_env_def,MATCH_MP SUBSET_INSERT_EQ_SUBSET NOT_3_domain] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[lookup_inter,lookup_insert] \\ Cases_on `x = 3` \\ full_simp_tac(srw_ss())[] \\ every_case_tac \\ srw_tac[][] - \\ full_simp_tac(srw_ss())[SIMP_RULE std_ss [domain_lookup] NOT_3_domain]); - -Theorem case_EQ_SOME_IFF - `(case p of NONE => NONE | SOME x => g x) = SOME y <=> - ?x. p = SOME x /\ g x = SOME y` - (Cases_on `p` \\ full_simp_tac(srw_ss())[]); - -Theorem state_rel_set_store_AllocSize - `state_rel c l1 l2 s (set_store AllocSize (Word w) t) v locs = - state_rel c l1 l2 s t v locs` - (full_simp_tac(srw_ss())[state_rel_def,wordSemTheory.set_store_def] + \\ full_simp_tac(srw_ss())[SIMP_RULE std_ss [domain_lookup] NOT_3_domain] +QED + +Theorem case_EQ_SOME_IFF: + (case p of NONE => NONE | SOME x => g x) = SOME y <=> + ?x. p = SOME x /\ g x = SOME y +Proof + Cases_on `p` \\ full_simp_tac(srw_ss())[] +QED + +Theorem state_rel_set_store_AllocSize: + state_rel c l1 l2 s (set_store AllocSize (Word w) t) v locs = + state_rel c l1 l2 s t v locs +Proof + full_simp_tac(srw_ss())[state_rel_def,wordSemTheory.set_store_def] \\ eq_tac \\ srw_tac[][] \\ full_simp_tac(srw_ss())[heap_in_memory_store_def,FLOOKUP_DEF,FAPPLY_FUPDATE_THM] \\ fs [code_oracle_rel_def,FLOOKUP_UPDATE] - \\ metis_tac []); - -Theorem inter_insert - `inter (insert n x t1) t2 = - if n IN domain t2 then insert n x (inter t1 t2) else inter t1 t2` - (srw_tac[][] \\ full_simp_tac(srw_ss())[spt_eq_thm,wf_inter,wf_insert,lookup_inter_alt,lookup_insert] - \\ srw_tac[][] \\ full_simp_tac(srw_ss())[]); - -Theorem lookup_0_adjust_set - `lookup 0 (adjust_set l) = SOME ()` - (fs[adjust_set_def,lookup_fromAList,ALOOKUP_NONE,MEM_MAP,FORALL_PROD]); - -Theorem lookup_1_adjust_set - `lookup 1 (adjust_set l) = NONE` - (full_simp_tac(srw_ss())[adjust_set_def,lookup_fromAList,ALOOKUP_NONE,MEM_MAP,FORALL_PROD] - \\ full_simp_tac(srw_ss())[adjust_var_def] \\ CCONTR_TAC \\ full_simp_tac(srw_ss())[] \\ decide_tac); - -Theorem lookup_3_adjust_set - `lookup 3 (adjust_set l) = NONE` - (full_simp_tac(srw_ss())[adjust_set_def,lookup_fromAList,ALOOKUP_NONE,MEM_MAP,FORALL_PROD] - \\ full_simp_tac(srw_ss())[adjust_var_def] \\ CCONTR_TAC \\ full_simp_tac(srw_ss())[] \\ decide_tac); - -Theorem lookup_5_adjust_set - `lookup 5 (adjust_set l) = NONE` - (full_simp_tac(srw_ss())[adjust_set_def,lookup_fromAList,ALOOKUP_NONE,MEM_MAP,FORALL_PROD] - \\ full_simp_tac(srw_ss())[adjust_var_def] \\ CCONTR_TAC \\ full_simp_tac(srw_ss())[] \\ decide_tac); - -Theorem lookup_ODD_adjust_set - `ODD n ==> lookup n (adjust_set l) = NONE` - (fs[adjust_set_def,lookup_fromAList,ALOOKUP_NONE,MEM_MAP,FORALL_PROD] + \\ metis_tac [] +QED + +Theorem inter_insert: + inter (insert n x t1) t2 = + if n IN domain t2 then insert n x (inter t1 t2) else inter t1 t2 +Proof + srw_tac[][] \\ full_simp_tac(srw_ss())[spt_eq_thm,wf_inter,wf_insert,lookup_inter_alt,lookup_insert] + \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] +QED + +Theorem lookup_0_adjust_set: + lookup 0 (adjust_set l) = SOME () +Proof + fs[adjust_set_def,lookup_fromAList,ALOOKUP_NONE,MEM_MAP,FORALL_PROD] +QED + +Theorem lookup_1_adjust_set: + lookup 1 (adjust_set l) = NONE +Proof + full_simp_tac(srw_ss())[adjust_set_def,lookup_fromAList,ALOOKUP_NONE,MEM_MAP,FORALL_PROD] + \\ full_simp_tac(srw_ss())[adjust_var_def] \\ CCONTR_TAC \\ full_simp_tac(srw_ss())[] \\ decide_tac +QED + +Theorem lookup_3_adjust_set: + lookup 3 (adjust_set l) = NONE +Proof + full_simp_tac(srw_ss())[adjust_set_def,lookup_fromAList,ALOOKUP_NONE,MEM_MAP,FORALL_PROD] + \\ full_simp_tac(srw_ss())[adjust_var_def] \\ CCONTR_TAC \\ full_simp_tac(srw_ss())[] \\ decide_tac +QED + +Theorem lookup_5_adjust_set: + lookup 5 (adjust_set l) = NONE +Proof + full_simp_tac(srw_ss())[adjust_set_def,lookup_fromAList,ALOOKUP_NONE,MEM_MAP,FORALL_PROD] + \\ full_simp_tac(srw_ss())[adjust_var_def] \\ CCONTR_TAC \\ full_simp_tac(srw_ss())[] \\ decide_tac +QED + +Theorem lookup_ODD_adjust_set: + ODD n ==> lookup n (adjust_set l) = NONE +Proof + fs[adjust_set_def,lookup_fromAList,ALOOKUP_NONE,MEM_MAP,FORALL_PROD] \\ IF_CASES_TAC \\ fs [] \\ rw [] \\ fs [] \\ fs[adjust_set_def,lookup_fromAList,ALOOKUP_NONE,MEM_MAP,FORALL_PROD] \\ CCONTR_TAC \\ fs [] \\ rveq - \\ fs [EVEN_adjust_var,ODD_EVEN]); + \\ fs [EVEN_adjust_var,ODD_EVEN] +QED -Theorem wf_adjust_set - `wf (adjust_set s)` - (fs [adjust_set_def,wf_fromAList]); +Theorem wf_adjust_set: + wf (adjust_set s) +Proof + fs [adjust_set_def,wf_fromAList] +QED -Theorem lookup_adjust_set - `lookup n (adjust_set s) = +Theorem lookup_adjust_set: + lookup n (adjust_set s) = if n = 0 then SOME () else if ODD n then NONE else - if (n - 2) DIV 2 IN domain s then SOME () else NONE` - (fs[adjust_set_def,lookup_fromAList,ALOOKUP_NONE,MEM_MAP,FORALL_PROD] + if (n - 2) DIV 2 IN domain s then SOME () else NONE +Proof + fs[adjust_set_def,lookup_fromAList,ALOOKUP_NONE,MEM_MAP,FORALL_PROD] \\ IF_CASES_TAC \\ fs [] \\ rw [] \\ fs[adjust_set_def,lookup_fromAList,ALOOKUP_NONE,MEM_MAP,FORALL_PROD] \\ CCONTR_TAC \\ fs [] \\ rveq \\ fs [EVEN_adjust_var,ODD_EVEN] @@ -5105,81 +5550,102 @@ Theorem lookup_adjust_set \\ fs [adjust_var_def] \\ imp_res_tac EVEN_ODD_EXISTS \\ rveq \\ Cases_on `m` \\ fs [MULT_CLAUSES] - \\ fs [ONCE_REWRITE_RULE [MULT_COMM] MULT_DIV]); + \\ fs [ONCE_REWRITE_RULE [MULT_COMM] MULT_DIV] +QED -Theorem adjust_set_inter - `adjust_set (inter t1 t2) = inter (adjust_set t1) (adjust_set t2)` - (fs [wf_adjust_set,wf_inter,spt_eq_thm,lookup_inter_alt,domain_lookup] +Theorem adjust_set_inter: + adjust_set (inter t1 t2) = inter (adjust_set t1) (adjust_set t2) +Proof + fs [wf_adjust_set,wf_inter,spt_eq_thm,lookup_inter_alt,domain_lookup] \\ strip_tac \\ Cases_on `ODD n` \\ fs [lookup_ODD_adjust_set] \\ Cases_on `n = 0` \\ fs [lookup_0_adjust_set] \\ fs [lookup_adjust_set] - \\ fs [domain_inter] \\ rw [] \\ fs []); - -Theorem state_rel_insert_1 - `state_rel c l1 l2 s (t with locals := insert 1 x t.locals) v locs = - state_rel c l1 l2 s t v locs` - (full_simp_tac(srw_ss())[state_rel_def] \\ eq_tac \\ srw_tac[][] + \\ fs [domain_inter] \\ rw [] \\ fs [] +QED + +Theorem state_rel_insert_1: + state_rel c l1 l2 s (t with locals := insert 1 x t.locals) v locs = + state_rel c l1 l2 s t v locs +Proof + full_simp_tac(srw_ss())[state_rel_def] \\ eq_tac \\ srw_tac[][] \\ full_simp_tac(srw_ss())[lookup_insert,adjust_var_NEQ_1] \\ full_simp_tac(srw_ss())[inter_insert,domain_lookup,lookup_1_adjust_set] - \\ metis_tac []); - -Theorem state_rel_insert_3 - `state_rel c l1 l2 s (t with locals := insert 3 x t.locals) v locs = - state_rel c l1 l2 s t v locs` - (full_simp_tac(srw_ss())[state_rel_def] \\ eq_tac \\ srw_tac[][] + \\ metis_tac [] +QED + +Theorem state_rel_insert_3: + state_rel c l1 l2 s (t with locals := insert 3 x t.locals) v locs = + state_rel c l1 l2 s t v locs +Proof + full_simp_tac(srw_ss())[state_rel_def] \\ eq_tac \\ srw_tac[][] \\ full_simp_tac(srw_ss())[lookup_insert,adjust_var_NEQ_1] \\ asm_exists_tac \\ fs [] - \\ full_simp_tac(srw_ss())[inter_insert,domain_lookup,lookup_3_adjust_set]); - -Theorem state_rel_insert_7 - `state_rel c l1 l2 s (t with locals := insert 7 x t.locals) v locs = - state_rel c l1 l2 s t v locs` - (full_simp_tac(srw_ss())[state_rel_def] \\ eq_tac \\ srw_tac[][] + \\ full_simp_tac(srw_ss())[inter_insert,domain_lookup,lookup_3_adjust_set] +QED + +Theorem state_rel_insert_7: + state_rel c l1 l2 s (t with locals := insert 7 x t.locals) v locs = + state_rel c l1 l2 s t v locs +Proof + full_simp_tac(srw_ss())[state_rel_def] \\ eq_tac \\ srw_tac[][] \\ full_simp_tac(srw_ss())[lookup_insert,adjust_var_NEQ_1] \\ asm_exists_tac \\ fs [] - \\ full_simp_tac(srw_ss())[inter_insert,domain_lookup,lookup_ODD_adjust_set]); - -Theorem state_rel_insert_3_1 - `state_rel c l1 l2 s (t with locals := insert 3 x (insert 1 y t.locals)) v locs = - state_rel c l1 l2 s t v locs` - (full_simp_tac(srw_ss())[state_rel_def] \\ eq_tac \\ srw_tac[][] + \\ full_simp_tac(srw_ss())[inter_insert,domain_lookup,lookup_ODD_adjust_set] +QED + +Theorem state_rel_insert_3_1: + state_rel c l1 l2 s (t with locals := insert 3 x (insert 1 y t.locals)) v locs = + state_rel c l1 l2 s t v locs +Proof + full_simp_tac(srw_ss())[state_rel_def] \\ eq_tac \\ srw_tac[][] \\ full_simp_tac(srw_ss())[lookup_insert,adjust_var_NEQ_1] \\ asm_exists_tac \\ fs [] \\ full_simp_tac(srw_ss())[inter_insert,domain_lookup, - lookup_3_adjust_set,lookup_1_adjust_set]); + lookup_3_adjust_set,lookup_1_adjust_set] +QED -Theorem state_rel_inc_clock - `state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs ==> +Theorem state_rel_inc_clock: + state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs ==> state_rel c l1 l2 (s with clock := s.clock + 1) - (t with clock := t.clock + 1) [] locs` - (full_simp_tac(srw_ss())[state_rel_def]); - -Theorem dec_clock_inc_clock - `(dataSem$dec_clock (s with clock := s.clock + 1) = s) /\ - (wordSem$dec_clock (t with clock := t.clock + 1) = t)` - (full_simp_tac(srw_ss())[dataSemTheory.dec_clock_def,wordSemTheory.dec_clock_def] + (t with clock := t.clock + 1) [] locs +Proof + full_simp_tac(srw_ss())[state_rel_def] +QED + +Theorem dec_clock_inc_clock: + (dataSem$dec_clock (s with clock := s.clock + 1) = s) /\ + (wordSem$dec_clock (t with clock := t.clock + 1) = t) +Proof + full_simp_tac(srw_ss())[dataSemTheory.dec_clock_def,wordSemTheory.dec_clock_def] \\ full_simp_tac(srw_ss())[dataSemTheory.state_component_equality] - \\ full_simp_tac(srw_ss())[wordSemTheory.state_component_equality]) + \\ full_simp_tac(srw_ss())[wordSemTheory.state_component_equality] +QED -Theorem word_gc_move_IMP_isWord - `word_gc_move c' (Word c,i,pa,old,m,dm) = (w1,i1,pa1,m1,c1) ==> isWord w1` - (full_simp_tac(srw_ss())[word_gc_move_def,LET_DEF] +Theorem word_gc_move_IMP_isWord: + word_gc_move c' (Word c,i,pa,old,m,dm) = (w1,i1,pa1,m1,c1) ==> isWord w1 +Proof + full_simp_tac(srw_ss())[word_gc_move_def,LET_DEF] \\ CONV_TAC (DEPTH_CONV PairRules.PBETA_CONV) - \\ srw_tac[][] \\ full_simp_tac(srw_ss())[isWord_def]); - -Theorem word_gen_gc_move_IMP_isWord - `word_gen_gc_move c' (Word c,i,pa,ib,pb,old,m,dm) = (w1,i1,pa1,ib1,pb1,m1,c1) ==> - isWord w1` - (full_simp_tac(srw_ss())[word_gen_gc_move_def,LET_DEF] + \\ srw_tac[][] \\ full_simp_tac(srw_ss())[isWord_def] +QED + +Theorem word_gen_gc_move_IMP_isWord: + word_gen_gc_move c' (Word c,i,pa,ib,pb,old,m,dm) = (w1,i1,pa1,ib1,pb1,m1,c1) ==> + isWord w1 +Proof + full_simp_tac(srw_ss())[word_gen_gc_move_def,LET_DEF] \\ CONV_TAC (DEPTH_CONV PairRules.PBETA_CONV) - \\ srw_tac[][] \\ full_simp_tac(srw_ss())[isWord_def]); - -Theorem word_gen_gc_partial_move_IMP_isWord - `word_gen_gc_partial_move c' (Word c,i,pa,old,m,dm,gs,rs) = (w1,i1,pa1,m1,c1) ==> - isWord w1` - (full_simp_tac(srw_ss())[word_gen_gc_partial_move_def,LET_DEF] + \\ srw_tac[][] \\ full_simp_tac(srw_ss())[isWord_def] +QED + +Theorem word_gen_gc_partial_move_IMP_isWord: + word_gen_gc_partial_move c' (Word c,i,pa,old,m,dm,gs,rs) = (w1,i1,pa1,m1,c1) ==> + isWord w1 +Proof + full_simp_tac(srw_ss())[word_gen_gc_partial_move_def,LET_DEF] \\ CONV_TAC (DEPTH_CONV PairRules.PBETA_CONV) - \\ srw_tac[][] \\ full_simp_tac(srw_ss())[isWord_def]); + \\ srw_tac[][] \\ full_simp_tac(srw_ss())[isWord_def] +QED val word_gc_move_roots_IMP_FILTER0 = Q.prove( `!ws i pa old m dm ws2 i2 pa2 m2 c2 c. @@ -5216,13 +5682,14 @@ val word_gen_gc_move_roots_IMP_FILTER0 = Q.prove( \\ rpt (pairarg_tac \\ fs []) \\ fs [] \\ rveq \\ res_tac \\ fs [isWord_def]); -Theorem word_gen_gc_partial_move_roots_IMP_FILTER - `!ws i pa ib pb old m dm ws2 i2 pa2 ib2 pb2 m2 c2 c. +Theorem word_gen_gc_partial_move_roots_IMP_FILTER: + !ws i pa ib pb old m dm ws2 i2 pa2 ib2 pb2 m2 c2 c. word_gen_gc_partial_move_roots c (ws,i,pa,old,m,dm,gs,rs) = (ws2,i2,pa2,m2,c2) ==> word_gen_gc_partial_move_roots c (FILTER isWord ws,i,pa,old,m,dm,gs,rs) = - (FILTER isWord ws2,i2,pa2,m2,c2)` - (Induct \\ full_simp_tac(srw_ss())[word_gen_gc_partial_move_roots_def] + (FILTER isWord ws2,i2,pa2,m2,c2) +Proof + Induct \\ full_simp_tac(srw_ss())[word_gen_gc_partial_move_roots_def] \\ Cases \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[word_gen_gc_partial_move_roots_def] THEN1 @@ -5232,14 +5699,16 @@ Theorem word_gen_gc_partial_move_roots_IMP_FILTER \\ res_tac \\ fs []) \\ fs [isWord_def,word_gen_gc_partial_move_def,LET_DEF] \\ rpt (pairarg_tac \\ fs []) \\ fs [] \\ rveq - \\ res_tac \\ fs [isWord_def]); + \\ res_tac \\ fs [isWord_def] +QED val IMP_EQ_DISJ = METIS_PROVE [] ``(b1 ==> b2) <=> ~b1 \/ b2`` -Theorem word_gc_fun_IMP_FILTER - `word_gc_fun c (xs,m,dm,s) = SOME (stack1,m1,s1) ==> - word_gc_fun c (FILTER isWord xs,m,dm,s) = SOME (FILTER isWord stack1,m1,s1)` - (full_simp_tac(srw_ss())[word_gc_fun_def,LET_THM,word_gc_fun_def, +Theorem word_gc_fun_IMP_FILTER: + word_gc_fun c (xs,m,dm,s) = SOME (stack1,m1,s1) ==> + word_gc_fun c (FILTER isWord xs,m,dm,s) = SOME (FILTER isWord stack1,m1,s1) +Proof + full_simp_tac(srw_ss())[word_gc_fun_def,LET_THM,word_gc_fun_def, word_full_gc_def,word_gen_gc_def,word_gen_gc_partial_def, word_gen_gc_partial_full_def] \\ TOP_CASE_TAC \\ fs [] @@ -5271,7 +5740,8 @@ Theorem word_gc_fun_IMP_FILTER \\ rpt var_eq_tac \\ full_simp_tac(srw_ss())[] \\ imp_res_tac word_gen_gc_move_roots_IMP_FILTER0 \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] - \\ rev_full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[])); + \\ rev_full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[]) +QED val loc_merge_def = Define ` (loc_merge [] ys = []) /\ @@ -5279,65 +5749,76 @@ val loc_merge_def = Define ` (loc_merge (Word w::xs) (y::ys) = y::loc_merge xs ys) /\ (loc_merge (Word w::xs) [] = Word w::xs)` -Theorem LENGTH_loc_merge - `!xs ys. LENGTH (loc_merge xs ys) = LENGTH xs` - (Induct \\ Cases_on `ys` \\ full_simp_tac(srw_ss())[loc_merge_def] +Theorem LENGTH_loc_merge: + !xs ys. LENGTH (loc_merge xs ys) = LENGTH xs +Proof + Induct \\ Cases_on `ys` \\ full_simp_tac(srw_ss())[loc_merge_def] \\ Cases_on `h` \\ full_simp_tac(srw_ss())[loc_merge_def] - \\ Cases_on `h'` \\ full_simp_tac(srw_ss())[loc_merge_def]); + \\ Cases_on `h'` \\ full_simp_tac(srw_ss())[loc_merge_def] +QED -Theorem word_gc_move_roots_IMP_FILTER - `!ws i pa old m dm ws2 i2 pa2 m2 c2 c. +Theorem word_gc_move_roots_IMP_FILTER: + !ws i pa old m dm ws2 i2 pa2 m2 c2 c. word_gc_move_roots c (FILTER isWord ws,i,pa,old,m,dm) = (ws2,i2,pa2,m2,c2) ==> word_gc_move_roots c (ws,i,pa,old,m,dm) = - (loc_merge ws ws2,i2,pa2,m2,c2)` - (Induct \\ full_simp_tac(srw_ss())[word_gc_move_roots_def,loc_merge_def] + (loc_merge ws ws2,i2,pa2,m2,c2) +Proof + Induct \\ full_simp_tac(srw_ss())[word_gc_move_roots_def,loc_merge_def] \\ reverse Cases \\ full_simp_tac(srw_ss())[isWord_def,loc_merge_def,LET_DEF] THEN1 (full_simp_tac(srw_ss())[word_gc_move_def] \\ srw_tac[][] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ res_tac \\ fs []) \\ fs [word_gc_move_roots_def,loc_merge_def] \\ rw [] \\ rpt (pairarg_tac \\ fs []) \\ rveq - \\ res_tac \\ fs [] \\ rveq \\ fs [loc_merge_def]); + \\ res_tac \\ fs [] \\ rveq \\ fs [loc_merge_def] +QED -Theorem word_gen_gc_move_roots_IMP_FILTER - `!ws i pa ib pb old m dm ws2 i2 pa2 ib2 pb2 m2 c2 c. +Theorem word_gen_gc_move_roots_IMP_FILTER: + !ws i pa ib pb old m dm ws2 i2 pa2 ib2 pb2 m2 c2 c. word_gen_gc_move_roots c (FILTER isWord ws,i,pa,ib,pb,old,m,dm) = (ws2,i2,pa2,ib2,pb2,m2,c2) ==> word_gen_gc_move_roots c (ws,i,pa,ib,pb,old,m,dm) = - (loc_merge ws ws2,i2,pa2,ib2,pb2,m2,c2)` - (Induct \\ full_simp_tac(srw_ss())[word_gen_gc_move_roots_def,loc_merge_def] + (loc_merge ws ws2,i2,pa2,ib2,pb2,m2,c2) +Proof + Induct \\ full_simp_tac(srw_ss())[word_gen_gc_move_roots_def,loc_merge_def] \\ reverse Cases \\ full_simp_tac(srw_ss())[isWord_def,loc_merge_def,LET_DEF] THEN1 (full_simp_tac(srw_ss())[word_gen_gc_move_def] \\ srw_tac[][] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ res_tac \\ fs []) \\ fs [word_gen_gc_move_roots_def,loc_merge_def] \\ rw [] \\ rpt (pairarg_tac \\ fs []) \\ rveq - \\ res_tac \\ fs [] \\ rveq \\ fs [loc_merge_def]); + \\ res_tac \\ fs [] \\ rveq \\ fs [loc_merge_def] +QED -Theorem word_gen_gc_partial_move_roots_IMP_FILTER - `!ws i pa old m dm gs rs ws2 i2 pa2 m2 c2 c. +Theorem word_gen_gc_partial_move_roots_IMP_FILTER: + !ws i pa old m dm gs rs ws2 i2 pa2 m2 c2 c. word_gen_gc_partial_move_roots c (FILTER isWord ws,i,pa,old,m,dm,gs,rs) = (ws2,i2,pa2,m2,c2) ==> word_gen_gc_partial_move_roots c (ws,i,pa,old,m,dm,gs,rs) = - (loc_merge ws ws2,i2,pa2,m2,c2)` - (Induct \\ full_simp_tac(srw_ss())[word_gen_gc_partial_move_roots_def,loc_merge_def] + (loc_merge ws ws2,i2,pa2,m2,c2) +Proof + Induct \\ full_simp_tac(srw_ss())[word_gen_gc_partial_move_roots_def,loc_merge_def] \\ reverse Cases \\ full_simp_tac(srw_ss())[isWord_def,loc_merge_def,LET_DEF] THEN1 (full_simp_tac(srw_ss())[word_gen_gc_partial_move_def] \\ srw_tac[][] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ res_tac \\ fs []) \\ fs [word_gen_gc_partial_move_roots_def,loc_merge_def] \\ rw [] \\ rpt (pairarg_tac \\ fs []) \\ rveq - \\ res_tac \\ fs [] \\ rveq \\ fs [loc_merge_def]); - -Theorem loc_merge_FILTER_isWord - `!xs. loc_merge xs (FILTER isWord xs) = xs` - (Induct \\ fs [loc_merge_def] \\ Cases \\ fs [loc_merge_def,isWord_def]); - -Theorem word_gc_fun_loc_merge - `word_gc_fun c (FILTER isWord xs,m,dm,s) = SOME (ys,m1,s1) ==> - word_gc_fun c (xs,m,dm,s) = SOME (loc_merge xs ys,m1,s1)` - (full_simp_tac(srw_ss())[word_gc_fun_def,LET_THM,word_gc_fun_def, + \\ res_tac \\ fs [] \\ rveq \\ fs [loc_merge_def] +QED + +Theorem loc_merge_FILTER_isWord: + !xs. loc_merge xs (FILTER isWord xs) = xs +Proof + Induct \\ fs [loc_merge_def] \\ Cases \\ fs [loc_merge_def,isWord_def] +QED + +Theorem word_gc_fun_loc_merge: + word_gc_fun c (FILTER isWord xs,m,dm,s) = SOME (ys,m1,s1) ==> + word_gc_fun c (xs,m,dm,s) = SOME (loc_merge xs ys,m1,s1) +Proof + full_simp_tac(srw_ss())[word_gc_fun_def,LET_THM,word_gc_fun_def, word_full_gc_def,word_gen_gc_def,word_gen_gc_partial_def, word_gen_gc_partial_full_def] \\ TOP_CASE_TAC \\ fs [loc_merge_FILTER_isWord] @@ -5370,34 +5851,40 @@ Theorem word_gc_fun_loc_merge \\ rpt var_eq_tac \\ full_simp_tac(srw_ss())[] \\ imp_res_tac word_gen_gc_move_roots_IMP_FILTER \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] - \\ rev_full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[])); + \\ rev_full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[]) +QED -Theorem word_gc_fun_IMP - `word_gc_fun c (xs,m,dm,s) = SOME (ys,m1,s1) ==> +Theorem word_gc_fun_IMP: + word_gc_fun c (xs,m,dm,s) = SOME (ys,m1,s1) ==> FLOOKUP s1 AllocSize = FLOOKUP s AllocSize /\ FLOOKUP s1 Handler = FLOOKUP s Handler /\ FLOOKUP s1 CodeBuffer = FLOOKUP s CodeBuffer /\ FLOOKUP s1 CodeBufferEnd = FLOOKUP s CodeBufferEnd /\ FLOOKUP s1 BitmapBuffer = FLOOKUP s BitmapBuffer /\ FLOOKUP s1 BitmapBufferEnd = FLOOKUP s BitmapBufferEnd /\ - Globals IN FDOM s1` - (fs[IMP_EQ_DISJ,word_gc_fun_def] \\ TOP_CASE_TAC \\ fs [] + Globals IN FDOM s1 +Proof + fs[IMP_EQ_DISJ,word_gc_fun_def] \\ TOP_CASE_TAC \\ fs [] \\ rpt (pairarg_tac \\ fs []) \\ fs [FUPDATE_LIST,FLOOKUP_UPDATE] \\ TRY TOP_CASE_TAC \\ fs [] \\ CCONTR_TAC \\ fs [] \\ rveq \\ fs [FUPDATE_LIST,FLOOKUP_UPDATE] - \\ fs [word_gc_fun_assum_def]); + \\ fs [word_gc_fun_assum_def] +QED -Theorem gc_fun_const_ok_word_gc_fun - `gc_fun_const_ok (word_gc_fun c)` - (fs [word_simpProofTheory.gc_fun_const_ok_def] \\ rw [] +Theorem gc_fun_const_ok_word_gc_fun: + gc_fun_const_ok (word_gc_fun c) +Proof + fs [word_simpProofTheory.gc_fun_const_ok_def] \\ rw [] \\ PairCases_on `x` \\ fs [] \\ PairCases_on `y` \\ fs [] \\ imp_res_tac word_gc_IMP_EVERY2 \\ pop_assum mp_tac - \\ match_mp_tac LIST_REL_mono \\ fs []); + \\ match_mp_tac LIST_REL_mono \\ fs [] +QED -Theorem gc_fun_ok_word_gc_fun - `gc_fun_ok (word_gc_fun c1)` - (fs [gc_fun_ok_def] \\ rpt gen_tac \\ strip_tac +Theorem gc_fun_ok_word_gc_fun: + gc_fun_ok (word_gc_fun c1) +Proof + fs [gc_fun_ok_def] \\ rpt gen_tac \\ strip_tac \\ imp_res_tac word_gc_fun_LENGTH \\ fs [] \\ imp_res_tac word_gc_fun_IMP \\ fs [FLOOKUP_DEF] @@ -5411,44 +5898,52 @@ Theorem gc_fun_ok_word_gc_fun \\ fs [fmap_EXT,FUPDATE_LIST,EXTENSION] \\ fs [FAPPLY_FUPDATE_THM,DOMSUB_FAPPLY_THM] \\ rw [] \\ fs [] \\ eq_tac \\ rw[] \\ fs [] - \\ metis_tac []); - -Theorem word_gc_fun_APPEND_IMP - `word_gc_fun c (xs ++ ys,m,dm,s) = SOME (zs,m1,s1) ==> - ?zs1 zs2. zs = zs1 ++ zs2 /\ LENGTH xs = LENGTH zs1 /\ LENGTH ys = LENGTH zs2` - (srw_tac[][] \\ imp_res_tac word_gc_fun_LENGTH \\ full_simp_tac(srw_ss())[LENGTH_APPEND] + \\ metis_tac [] +QED + +Theorem word_gc_fun_APPEND_IMP: + word_gc_fun c (xs ++ ys,m,dm,s) = SOME (zs,m1,s1) ==> + ?zs1 zs2. zs = zs1 ++ zs2 /\ LENGTH xs = LENGTH zs1 /\ LENGTH ys = LENGTH zs2 +Proof + srw_tac[][] \\ imp_res_tac word_gc_fun_LENGTH \\ full_simp_tac(srw_ss())[LENGTH_APPEND] \\ pop_assum mp_tac \\ pop_assum (K all_tac) \\ qspec_tac (`zs`,`zs`) \\ qspec_tac (`ys`,`ys`) \\ qspec_tac (`xs`,`xs`) \\ Induct \\ full_simp_tac(srw_ss())[] \\ Cases_on `zs` \\ full_simp_tac(srw_ss())[LENGTH_NIL] \\ srw_tac[][] \\ once_rewrite_tac [EQ_SYM_EQ] \\ full_simp_tac(srw_ss())[LENGTH_NIL] \\ full_simp_tac(srw_ss())[ADD_CLAUSES] \\ res_tac - \\ full_simp_tac(srw_ss())[] \\ Q.LIST_EXISTS_TAC [`h::zs1`,`zs2`] \\ full_simp_tac(srw_ss())[]); + \\ full_simp_tac(srw_ss())[] \\ Q.LIST_EXISTS_TAC [`h::zs1`,`zs2`] \\ full_simp_tac(srw_ss())[] +QED -Theorem IMP_loc_merge_APPEND - `!ts qs xs ys. +Theorem IMP_loc_merge_APPEND = Q.prove(` + !ts qs xs ys. LENGTH (FILTER isWord ts) = LENGTH qs ==> - loc_merge (ts ++ xs) (qs ++ ys) = loc_merge ts qs ++ loc_merge xs ys` - (Induct \\ full_simp_tac(srw_ss())[] THEN1 (full_simp_tac(srw_ss())[LENGTH,loc_merge_def]) + loc_merge (ts ++ xs) (qs ++ ys) = loc_merge ts qs ++ loc_merge xs ys`, + Induct \\ full_simp_tac(srw_ss())[] THEN1 (full_simp_tac(srw_ss())[LENGTH,loc_merge_def]) \\ Cases \\ full_simp_tac(srw_ss())[isWord_def,loc_merge_def] \\ Cases \\ full_simp_tac(srw_ss())[loc_merge_def]) |> SPEC_ALL |> curry save_thm "IMP_loc_merge_APPEND"; -Theorem TAKE_DROP_loc_merge_APPEND - `TAKE (LENGTH q) (loc_merge (MAP SND q) xs ++ ys) = loc_merge (MAP SND q) xs /\ - DROP (LENGTH q) (loc_merge (MAP SND q) xs ++ ys) = ys` - (`LENGTH q = LENGTH (loc_merge (MAP SND q) xs)` by full_simp_tac(srw_ss())[LENGTH_loc_merge] - \\ full_simp_tac(srw_ss())[TAKE_LENGTH_APPEND,DROP_LENGTH_APPEND]); - -Theorem loc_merge_NIL - `!xs. loc_merge xs [] = xs` - (Induct \\ full_simp_tac(srw_ss())[loc_merge_def] \\ Cases \\ full_simp_tac(srw_ss())[loc_merge_def]); - -Theorem loc_merge_APPEND - `!xs1 xs2 ys. +Theorem TAKE_DROP_loc_merge_APPEND: + TAKE (LENGTH q) (loc_merge (MAP SND q) xs ++ ys) = loc_merge (MAP SND q) xs /\ + DROP (LENGTH q) (loc_merge (MAP SND q) xs ++ ys) = ys +Proof + `LENGTH q = LENGTH (loc_merge (MAP SND q) xs)` by full_simp_tac(srw_ss())[LENGTH_loc_merge] + \\ full_simp_tac(srw_ss())[TAKE_LENGTH_APPEND,DROP_LENGTH_APPEND] +QED + +Theorem loc_merge_NIL: + !xs. loc_merge xs [] = xs +Proof + Induct \\ full_simp_tac(srw_ss())[loc_merge_def] \\ Cases \\ full_simp_tac(srw_ss())[loc_merge_def] +QED + +Theorem loc_merge_APPEND: + !xs1 xs2 ys. ?zs1 zs2. loc_merge (xs1 ++ xs2) ys = zs1 ++ zs2 /\ LENGTH zs1 = LENGTH xs1 /\ LENGTH xs2 = LENGTH xs2 /\ - ?ts. loc_merge xs2 ts = zs2` - (Induct \\ full_simp_tac(srw_ss())[loc_merge_def,LENGTH_NIL,LENGTH_loc_merge] THEN1 (metis_tac []) + ?ts. loc_merge xs2 ts = zs2 +Proof + Induct \\ full_simp_tac(srw_ss())[loc_merge_def,LENGTH_NIL,LENGTH_loc_merge] THEN1 (metis_tac []) \\ Cases THEN1 (Cases_on `ys` \\ full_simp_tac(srw_ss())[loc_merge_def] \\ srw_tac[][] THEN1 (Q.LIST_EXISTS_TAC [`Word c::xs1`,`xs2`] \\ full_simp_tac(srw_ss())[] @@ -5457,18 +5952,22 @@ Theorem loc_merge_APPEND \\ full_simp_tac(srw_ss())[] \\ Q.LIST_EXISTS_TAC [`h::zs1`,`zs2`] \\ full_simp_tac(srw_ss())[] \\ metis_tac []) \\ srw_tac[][] \\ full_simp_tac(srw_ss())[loc_merge_def] \\ pop_assum (qspecl_then [`xs2`,`ys`] strip_assume_tac) - \\ full_simp_tac(srw_ss())[] \\ Q.LIST_EXISTS_TAC [`Loc n n0::zs1`,`zs2`] \\ full_simp_tac(srw_ss())[] \\ metis_tac []) - -Theorem EVERY2_loc_merge - `!xs ys. EVERY2 (\x y. (isWord y ==> isWord x) /\ - (~isWord x ==> x = y)) xs (loc_merge xs ys)` - (Induct \\ full_simp_tac(srw_ss())[loc_merge_def,LENGTH_NIL,LENGTH_loc_merge] \\ Cases + \\ full_simp_tac(srw_ss())[] \\ Q.LIST_EXISTS_TAC [`Loc n n0::zs1`,`zs2`] \\ full_simp_tac(srw_ss())[] \\ metis_tac [] +QED + +Theorem EVERY2_loc_merge: + !xs ys. EVERY2 (\x y. (isWord y ==> isWord x) /\ + (~isWord x ==> x = y)) xs (loc_merge xs ys) +Proof + Induct \\ full_simp_tac(srw_ss())[loc_merge_def,LENGTH_NIL,LENGTH_loc_merge] \\ Cases \\ full_simp_tac(srw_ss())[loc_merge_def] \\ Cases_on `ys` - \\ full_simp_tac(srw_ss())[loc_merge_def,GSYM EVERY2_refl,isWord_def]) + \\ full_simp_tac(srw_ss())[loc_merge_def,GSYM EVERY2_refl,isWord_def] +QED -Theorem dec_stack_loc_merge_enc_stack - `!xs ys. ?ss. dec_stack (loc_merge (enc_stack xs) ys) xs = SOME ss` - (Induct \\ full_simp_tac(srw_ss())[wordSemTheory.enc_stack_def, +Theorem dec_stack_loc_merge_enc_stack: + !xs ys. ?ss. dec_stack (loc_merge (enc_stack xs) ys) xs = SOME ss +Proof + Induct \\ full_simp_tac(srw_ss())[wordSemTheory.enc_stack_def, loc_merge_def,wordSemTheory.dec_stack_def] \\ Cases \\ Cases_on `o'` \\ full_simp_tac(srw_ss())[] \\ TRY (PairCases_on `x`) \\ full_simp_tac(srw_ss())[wordSemTheory.enc_stack_def] \\ srw_tac[][] @@ -5477,23 +5976,27 @@ Theorem dec_stack_loc_merge_enc_stack \\ pop_assum (fn th => full_simp_tac(srw_ss())[GSYM th]) \\ full_simp_tac(srw_ss())[DROP_LENGTH_APPEND] \\ first_assum (qspec_then `ts` strip_assume_tac) \\ full_simp_tac(srw_ss())[] - \\ decide_tac); + \\ decide_tac +QED -Theorem ALOOKUP_ZIP - `!l zs1. +Theorem ALOOKUP_ZIP: + !l zs1. ALOOKUP l (0:num) = SOME (Loc q r) /\ LIST_REL (λx y. (isWord y ⇒ isWord x) ∧ (¬isWord x ⇒ x = y)) (MAP SND l) zs1 ==> - ALOOKUP (ZIP (MAP FST l,zs1)) 0 = SOME (Loc q r)` - (Induct \\ full_simp_tac(srw_ss())[] \\ Cases \\ full_simp_tac(srw_ss())[ALOOKUP_def,PULL_EXISTS] - \\ Cases_on `q' = 0` \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[isWord_def] \\ srw_tac[][]); - -Theorem stack_rel_dec_stack_IMP_stack_rel - `!xs ys ts stack locs. + ALOOKUP (ZIP (MAP FST l,zs1)) 0 = SOME (Loc q r) +Proof + Induct \\ full_simp_tac(srw_ss())[] \\ Cases \\ full_simp_tac(srw_ss())[ALOOKUP_def,PULL_EXISTS] + \\ Cases_on `q' = 0` \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[isWord_def] \\ srw_tac[][] +QED + +Theorem stack_rel_dec_stack_IMP_stack_rel: + !xs ys ts stack locs. LIST_REL stack_rel ts xs /\ LIST_REL contains_loc xs locs /\ dec_stack (loc_merge (enc_stack xs) ys) xs = SOME stack ==> - LIST_REL stack_rel ts stack /\ LIST_REL contains_loc stack locs` - (Induct_on `ts` \\ Cases_on `xs` \\ full_simp_tac(srw_ss())[] + LIST_REL stack_rel ts stack /\ LIST_REL contains_loc stack locs +Proof + Induct_on `ts` \\ Cases_on `xs` \\ full_simp_tac(srw_ss())[] THEN1 (full_simp_tac(srw_ss())[wordSemTheory.enc_stack_def,loc_merge_def,wordSemTheory.dec_stack_def]) \\ full_simp_tac(srw_ss())[PULL_EXISTS] \\ srw_tac[][] \\ Cases_on `h` \\ Cases_on `o'` \\ TRY (PairCases_on `x`) \\ full_simp_tac(srw_ss())[] @@ -5523,25 +6026,31 @@ Theorem stack_rel_dec_stack_IMP_stack_rel \\ Q.MATCH_ASSUM_RENAME_TAC `isWord (EL k zs1)` \\ full_simp_tac(srw_ss())[MEM_EL,PULL_EXISTS] \\ asm_exists_tac \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[FST_PAIR_EQ] - \\ imp_res_tac EVERY2_IMP_EL \\ rev_full_simp_tac(srw_ss())[EL_MAP]); + \\ imp_res_tac EVERY2_IMP_EL \\ rev_full_simp_tac(srw_ss())[EL_MAP] +QED -Theorem join_env_NIL - `join_env s [] = []` - (full_simp_tac(srw_ss())[join_env_def]); +Theorem join_env_NIL: + join_env s [] = [] +Proof + full_simp_tac(srw_ss())[join_env_def] +QED -Theorem join_env_CONS - `join_env s ((n,v)::xs) = +Theorem join_env_CONS: + join_env s ((n,v)::xs) = if n <> 0 /\ EVEN n then (THE (lookup ((n - 2) DIV 2) s),v)::join_env s xs - else join_env s xs` - (full_simp_tac(srw_ss())[join_env_def] \\ srw_tac[][]); + else join_env s xs +Proof + full_simp_tac(srw_ss())[join_env_def] \\ srw_tac[][] +QED -Theorem FILTER_enc_stack_lemma - `!xs ys. +Theorem FILTER_enc_stack_lemma: + !xs ys. LIST_REL stack_rel xs ys ==> FILTER isWord (MAP SND (flat xs ys)) = - FILTER isWord (enc_stack ys)` - (Induct \\ Cases_on `ys` + FILTER isWord (enc_stack ys) +Proof + Induct \\ Cases_on `ys` \\ full_simp_tac(srw_ss())[stack_rel_def,wordSemTheory.enc_stack_def,flat_def] \\ Cases \\ Cases_on `h` \\ full_simp_tac(srw_ss())[] \\ Cases_on `o'` \\ TRY (PairCases_on `x`) \\ full_simp_tac(srw_ss())[stack_rel_def] \\ srw_tac[][] @@ -5549,60 +6058,71 @@ Theorem FILTER_enc_stack_lemma \\ qpat_x_assum `EVERY (\(x1,x2). isWord x2 ==> x1 <> 0 /\ EVEN x1) l` mp_tac \\ rpt (pop_assum (K all_tac)) \\ Induct_on `l` \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[join_env_NIL] - \\ Cases \\ full_simp_tac(srw_ss())[join_env_CONS] \\ srw_tac[][]); + \\ Cases \\ full_simp_tac(srw_ss())[join_env_CONS] \\ srw_tac[][] +QED -Theorem stack_rel_simp - `(stack_rel (Env s) y <=> +Theorem stack_rel_simp: + (stack_rel (Env s) y <=> ?vs. stack_rel (Env s) y /\ (y = StackFrame vs NONE)) /\ (stack_rel (Exc s n) y <=> - ?vs x1 x2 x3. stack_rel (Exc s n) y /\ (y = StackFrame vs (SOME (x1,x2,x3))))` - (Cases_on `y` \\ full_simp_tac(srw_ss())[stack_rel_def] \\ Cases_on `o'` + ?vs x1 x2 x3. stack_rel (Exc s n) y /\ (y = StackFrame vs (SOME (x1,x2,x3)))) +Proof + Cases_on `y` \\ full_simp_tac(srw_ss())[stack_rel_def] \\ Cases_on `o'` \\ full_simp_tac(srw_ss())[stack_rel_def] \\ PairCases_on `x` - \\ full_simp_tac(srw_ss())[stack_rel_def,CONJ_ASSOC]); + \\ full_simp_tac(srw_ss())[stack_rel_def,CONJ_ASSOC] +QED -Theorem join_env_EQ_ZIP - `!vs s zs1. +Theorem join_env_EQ_ZIP: + !vs s zs1. EVERY (\(x1,x2). isWord x2 ==> x1 <> 0 /\ EVEN x1) vs /\ LENGTH (join_env s vs) = LENGTH zs1 /\ LIST_REL (\x y. isWord x = isWord y /\ (~isWord x ==> x = y)) (MAP SND (join_env s vs)) zs1 ==> join_env s (ZIP (MAP FST vs,loc_merge (MAP SND vs) (FILTER isWord zs1))) = - ZIP (MAP FST (join_env s vs),zs1)` - (Induct \\ simp [join_env_NIL,loc_merge_def] \\ rpt strip_tac + ZIP (MAP FST (join_env s vs),zs1) +Proof + Induct \\ simp [join_env_NIL,loc_merge_def] \\ rpt strip_tac \\ Cases_on `h` \\ simp [] \\ full_simp_tac(srw_ss())[] \\ Cases_on `r` \\ full_simp_tac(srw_ss())[isWord_def] \\ full_simp_tac(srw_ss())[loc_merge_def] \\ full_simp_tac(srw_ss())[join_env_CONS] \\ rev_full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ rev_full_simp_tac(srw_ss())[isWord_def] \\ full_simp_tac(srw_ss())[] - \\ Cases_on `y` \\ full_simp_tac(srw_ss())[loc_merge_def,join_env_CONS,isWord_def]); + \\ Cases_on `y` \\ full_simp_tac(srw_ss())[loc_merge_def,join_env_CONS,isWord_def] +QED -Theorem LENGTH_MAP_SND_join_env_IMP - `!vs zs1 s. +Theorem LENGTH_MAP_SND_join_env_IMP: + !vs zs1 s. LIST_REL (\x y. (isWord x = isWord y) /\ (~isWord x ==> x = y)) (MAP SND (join_env s vs)) zs1 /\ EVERY (\(x1,x2). isWord x2 ==> x1 <> 0 /\ EVEN x1) vs /\ LENGTH (join_env s vs) = LENGTH zs1 ==> - LENGTH (FILTER isWord (MAP SND vs)) = LENGTH (FILTER isWord zs1)` - (Induct \\ rpt strip_tac THEN1 + LENGTH (FILTER isWord (MAP SND vs)) = LENGTH (FILTER isWord zs1) +Proof + Induct \\ rpt strip_tac THEN1 (pop_assum mp_tac \\ simp [join_env_NIL] \\ Cases_on `zs1` \\ full_simp_tac(srw_ss())[] \\ srw_tac[][]) \\ Cases_on `h` \\ full_simp_tac(srw_ss())[join_env_CONS] \\ srw_tac[][] THEN1 (full_simp_tac(srw_ss())[] \\ rev_full_simp_tac(srw_ss())[] \\ first_assum match_mp_tac \\ metis_tac[]) \\ full_simp_tac(srw_ss())[] \\ Cases_on `q <> 0 /\ EVEN q` - \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ metis_tac []) + \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ metis_tac [] +QED -Theorem lemma1 `(y1 = y2) /\ (x1 = x2) ==> (f x1 y1 = f x2 y2)` (full_simp_tac(srw_ss())[]); +Theorem lemma1: + (y1 = y2) /\ (x1 = x2) ==> (f x1 y1 = f x2 y2) +Proof +full_simp_tac(srw_ss())[] +QED -Theorem word_gc_fun_EL_lemma - `!xs ys stack1 m dm st m1 s1 stack. +Theorem word_gc_fun_EL_lemma = Q.prove(` + !xs ys stack1 m dm st m1 s1 stack. LIST_REL stack_rel xs stack /\ EVERY2 (\x y. isWord x = isWord y /\ (~isWord x ==> x = y)) (MAP SND (flat xs ys)) stack1 /\ dec_stack (loc_merge (enc_stack ys) (FILTER isWord stack1)) ys = SOME stack /\ LIST_REL stack_rel xs ys ==> (flat xs stack = - ZIP (MAP FST (flat xs ys),stack1))` - (Induct THEN1 (EVAL_TAC \\ full_simp_tac(srw_ss())[] \\ EVAL_TAC \\ srw_tac[][] \\ srw_tac[][flat_def]) + ZIP (MAP FST (flat xs ys),stack1))`, + Induct THEN1 (EVAL_TAC \\ full_simp_tac(srw_ss())[] \\ EVAL_TAC \\ srw_tac[][] \\ srw_tac[][flat_def]) \\ Cases_on `h` \\ full_simp_tac(srw_ss())[] \\ once_rewrite_tac [stack_rel_simp] \\ full_simp_tac(srw_ss())[PULL_EXISTS,stack_rel_def,flat_def,wordSemTheory.enc_stack_def] \\ srw_tac[][] \\ imp_res_tac EVERY2_APPEND_IMP \\ srw_tac[][] @@ -5621,8 +6141,8 @@ Theorem word_gc_fun_EL_lemma \\ TRY (match_mp_tac join_env_EQ_ZIP) \\ full_simp_tac(srw_ss())[]) |> SPEC_ALL |> curry save_thm "word_gc_fun_EL_lemma"; -Theorem state_rel_gc - `state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs ==> +Theorem state_rel_gc: + state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs ==> FLOOKUP t.store AllocSize = SOME (Word (alloc_size k)) /\ s.locals = LN /\ t.locals = LS (Loc l1 l2) ==> @@ -5633,8 +6153,9 @@ Theorem state_rel_gc FLOOKUP st (Temp 29w) = FLOOKUP t.store (Temp 29w) /\ FLOOKUP st AllocSize = SOME (Word (alloc_size k)) /\ state_rel c l1 l2 (s with space := 0) - (t with <|stack := stack; store := st; memory := m|>) [] locs` - (full_simp_tac(srw_ss())[state_rel_def] \\ srw_tac[][] + (t with <|stack := stack; store := st; memory := m|>) [] locs +Proof + full_simp_tac(srw_ss())[state_rel_def] \\ srw_tac[][] \\ rev_full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[] \\ rev_full_simp_tac(srw_ss())[lookup_def] \\ srw_tac[][] \\ qhdtm_x_assum `word_ml_inv` mp_tac @@ -5676,10 +6197,11 @@ Theorem state_rel_gc \\ pop_assum mp_tac \\ match_mp_tac LIST_REL_mono \\ fs [] \\ Cases \\ fs [] - \\ fs [word_simpProofTheory.is_gc_word_const_def,isWord_def]); + \\ fs [word_simpProofTheory.is_gc_word_const_def,isWord_def] +QED -Theorem gc_lemma - `let t0 = call_env [Loc l1 l2] (push_env y +Theorem gc_lemma: + let t0 = call_env [Loc l1 l2] (push_env y (NONE:(num # 'a wordLang$prog # num # num) option) t) in dataSem$cut_env names (s:('c,'ffi) dataSem$state).locals = SOME x /\ state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs /\ @@ -5692,8 +6214,9 @@ Theorem gc_lemma pop_env (t0 with <|stack := stack; store := st; memory := m|>) = SOME t2 /\ FLOOKUP t2.store (Temp 29w) = FLOOKUP t.store (Temp 29w) ∧ FLOOKUP t2.store AllocSize = SOME (Word (alloc_size k)) /\ - state_rel c l1 l2 (s with <| locals := x; space := 0 |>) t2 [] locs` - (srw_tac[][] \\ full_simp_tac(srw_ss())[LET_DEF] + state_rel c l1 l2 (s with <| locals := x; space := 0 |>) t2 [] locs +Proof + srw_tac[][] \\ full_simp_tac(srw_ss())[LET_DEF] \\ Q.UNABBREV_TAC `t0` \\ full_simp_tac(srw_ss())[] \\ imp_res_tac (state_rel_call_env_push_env |> Q.SPEC `NONE` |> Q.INST [`args`|->`[]`] |> GEN_ALL @@ -5721,10 +6244,11 @@ Theorem gc_lemma \\ full_simp_tac(srw_ss())[wordSemTheory.pop_env_def,wordSemTheory.push_env_def] \\ Cases_on `env_to_list y t.permute` \\ full_simp_tac(srw_ss())[LET_DEF] \\ every_case_tac \\ full_simp_tac(srw_ss())[] - \\ srw_tac[][] \\ full_simp_tac(srw_ss())[]); + \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] +QED -Theorem gc_add_call_env - `(case gc (wordSem$push_env y NONE t5) of +Theorem gc_add_call_env: + (case gc (wordSem$push_env y NONE t5) of | NONE => (SOME wordSem$Error,x) | SOME s' => case pop_env s' of | NONE => (SOME Error, call_env [] s') @@ -5733,19 +6257,22 @@ Theorem gc_add_call_env | NONE => (SOME Error,x) | SOME s' => case pop_env s' of | NONE => (SOME Error, call_env [] s') - | SOME s' => f s') = (res,t)` - (full_simp_tac(srw_ss())[wordSemTheory.gc_def,wordSemTheory.call_env_def,LET_DEF, + | SOME s' => f s') = (res,t) +Proof + full_simp_tac(srw_ss())[wordSemTheory.gc_def,wordSemTheory.call_env_def,LET_DEF, wordSemTheory.push_env_def] \\ Cases_on `env_to_list y t5.permute` \\ full_simp_tac(srw_ss())[LET_DEF] \\ every_case_tac \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] - \\ full_simp_tac(srw_ss())[wordSemTheory.pop_env_def]); + \\ full_simp_tac(srw_ss())[wordSemTheory.pop_env_def] +QED -Theorem has_space_state_rel - `has_space (Word ((alloc_size k):'a word)) (r:('a,'c,'ffi) state) = SOME T /\ +Theorem has_space_state_rel: + has_space (Word ((alloc_size k):'a word)) (r:('a,'c,'ffi) state) = SOME T /\ state_rel c l1 l2 s r [] locs ==> - state_rel c l1 l2 (s with space := k) r [] locs` - (full_simp_tac(srw_ss())[state_rel_def] \\ srw_tac[][] + state_rel c l1 l2 (s with space := k) r [] locs +Proof + full_simp_tac(srw_ss())[state_rel_def] \\ srw_tac[][] \\ asm_exists_tac \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[heap_in_memory_store_def,wordSemTheory.has_space_def] \\ full_simp_tac(srw_ss())[GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] @@ -5759,56 +6286,71 @@ Theorem has_space_state_rel \\ every_case_tac \\ full_simp_tac(srw_ss())[word_mul_n2w] \\ full_simp_tac(srw_ss())[good_dimindex_def] \\ full_simp_tac(srw_ss())[w2n_minus1] \\ rev_full_simp_tac(srw_ss())[] - \\ fs []); - -Theorem evaluate_IMP_inc_clock - `evaluate (q,t) = (NONE,t1) ==> - evaluate (q,inc_clock ck t) = (NONE,inc_clock ck t1)` - (srw_tac[][inc_clock_def] \\ match_mp_tac evaluate_add_clock - \\ full_simp_tac(srw_ss())[]); - -Theorem evaluate_IMP_inc_clock_Ex - `evaluate (q,t) = (SOME (Exception x y),t1) ==> - evaluate (q,inc_clock ck t) = (SOME (Exception x y),inc_clock ck t1)` - (srw_tac[][inc_clock_def] \\ match_mp_tac evaluate_add_clock - \\ full_simp_tac(srw_ss())[]); - -Theorem get_var_inc_clock - `get_var n (inc_clock k s) = get_var n s` - (full_simp_tac(srw_ss())[wordSemTheory.get_var_def,inc_clock_def]); + \\ fs [] +QED -Theorem get_vars_inc_clock - `get_vars n (inc_clock k s) = get_vars n s` - (Induct_on `n` \\ full_simp_tac(srw_ss())[wordSemTheory.get_vars_def] - \\ every_case_tac \\ full_simp_tac(srw_ss())[get_var_inc_clock]); +Theorem evaluate_IMP_inc_clock: + evaluate (q,t) = (NONE,t1) ==> + evaluate (q,inc_clock ck t) = (NONE,inc_clock ck t1) +Proof + srw_tac[][inc_clock_def] \\ match_mp_tac evaluate_add_clock + \\ full_simp_tac(srw_ss())[] +QED -Theorem set_var_inc_clock - `set_var n x (inc_clock ck t) = inc_clock ck (set_var n x t)` - (full_simp_tac(srw_ss())[wordSemTheory.set_var_def,inc_clock_def]); +Theorem evaluate_IMP_inc_clock_Ex: + evaluate (q,t) = (SOME (Exception x y),t1) ==> + evaluate (q,inc_clock ck t) = (SOME (Exception x y),inc_clock ck t1) +Proof + srw_tac[][inc_clock_def] \\ match_mp_tac evaluate_add_clock + \\ full_simp_tac(srw_ss())[] +QED + +Theorem get_var_inc_clock: + get_var n (inc_clock k s) = get_var n s +Proof + full_simp_tac(srw_ss())[wordSemTheory.get_var_def,inc_clock_def] +QED + +Theorem get_vars_inc_clock: + get_vars n (inc_clock k s) = get_vars n s +Proof + Induct_on `n` \\ full_simp_tac(srw_ss())[wordSemTheory.get_vars_def] + \\ every_case_tac \\ full_simp_tac(srw_ss())[get_var_inc_clock] +QED + +Theorem set_var_inc_clock: + set_var n x (inc_clock ck t) = inc_clock ck (set_var n x t) +Proof + full_simp_tac(srw_ss())[wordSemTheory.set_var_def,inc_clock_def] +QED val do_app = LIST_CONJ [dataSemTheory.do_app_def,do_space_def, data_spaceTheory.op_space_req_def, dataLangTheory.op_space_reset_def, dataSemTheory.do_app_aux_def] -Theorem w2n_minus_1_LESS_EQ - `(w2n (-1w:'a word) <= w2n (w:'a word)) <=> w + 1w = 0w` - (fs [word_2comp_n2w] +Theorem w2n_minus_1_LESS_EQ: + (w2n (-1w:'a word) <= w2n (w:'a word)) <=> w + 1w = 0w +Proof + fs [word_2comp_n2w] \\ Cases_on `w` \\ fs [word_add_n2w] \\ `n + 1 <= dimword (:'a)` by decide_tac - \\ Cases_on `dimword (:'a) = n + 1` \\ fs []); - -Theorem bytes_in_word_ADD_1_NOT_ZERO - `good_dimindex (:'a) ==> - bytes_in_word * w + 1w <> 0w:'a word` - (rpt strip_tac + \\ Cases_on `dimword (:'a) = n + 1` \\ fs [] +QED + +Theorem bytes_in_word_ADD_1_NOT_ZERO: + good_dimindex (:'a) ==> + bytes_in_word * w + 1w <> 0w:'a word +Proof + rpt strip_tac \\ `(bytes_in_word * w + 1w) ' 0 = (0w:'a word) ' 0` by metis_tac [] \\ fs [WORD_ADD_BIT0,word_index,WORD_MUL_BIT0] \\ rfs [bytes_in_word_def,EVAL ``good_dimindex (:α)``,word_index] - \\ rfs [bytes_in_word_def,EVAL ``good_dimindex (:α)``,word_index]); + \\ rfs [bytes_in_word_def,EVAL ``good_dimindex (:α)``,word_index] +QED -Theorem alloc_lemma - `state_rel c l1 l2 s (t:('a,'c,'ffi)wordSem$state) [] locs /\ +Theorem alloc_lemma: + state_rel c l1 l2 s (t:('a,'c,'ffi)wordSem$state) [] locs /\ dataSem$cut_env names s.locals = SOME x /\ alloc (alloc_size k) (adjust_set names) (t with locals := insert 1 (Word (alloc_size k)) t.locals) = @@ -5822,8 +6364,9 @@ Theorem alloc_lemma r.code_buffer = t.code_buffer /\ r.data_buffer = t.data_buffer /\ r.compile_oracle = t.compile_oracle /\ - q = NONE)` - (strip_tac + q = NONE) +Proof + strip_tac \\ full_simp_tac(srw_ss())[wordSemTheory.alloc_def, LET_DEF,addressTheory.CONTAINER_def] \\ pop_assum mp_tac @@ -5861,13 +6404,15 @@ Theorem alloc_lemma \\ CCONTR_TAC \\ fs [wordSemTheory.has_space_def] \\ rfs [heap_in_memory_store_def,FLOOKUP_DEF,FAPPLY_FUPDATE_THM] \\ rfs [WORD_LEFT_ADD_DISTRIB,GSYM word_add_n2w,w2n_minus_1_LESS_EQ] - \\ rfs [bytes_in_word_ADD_1_NOT_ZERO]); + \\ rfs [bytes_in_word_ADD_1_NOT_ZERO] +QED -Theorem evaluate_GiveUp - `state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs ==> +Theorem evaluate_GiveUp: + state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs ==> ?r. evaluate (GiveUp,t) = (SOME NotEnoughSpace,r) /\ - r.ffi = s.ffi /\ t.ffi = s.ffi` - (fs [GiveUp_def,wordSemTheory.evaluate_def,wordSemTheory.word_exp_def] + r.ffi = s.ffi /\ t.ffi = s.ffi +Proof + fs [GiveUp_def,wordSemTheory.evaluate_def,wordSemTheory.word_exp_def] \\ strip_tac \\ Cases_on `alloc (-1w) (insert 0 () LN) (set_var 1 (Word (-1w)) t) :'a result option # ('a,'c,'ffi) wordSem$state` @@ -5886,16 +6431,21 @@ Theorem evaluate_GiveUp \\ imp_res_tac heap_lookup_SPLIT \\ fs [heap_length_APPEND] \\ fs [heap_length_def,el_length_def] \\ fs [labPropsTheory.good_dimindex_def,dimword_def] \\ rw [] - \\ rfs [] \\ fs []); - -Theorem insert_insert_3_1 - `insert 3 x (insert 1 y t) = insert 1 y (insert 3 x t)` - (fs [Once insert_insert]); - -Theorem shift_lsl - `good_dimindex (:'a) ==> w << shift (:'a) = w * bytes_in_word:'a word` - (rw [labPropsTheory.good_dimindex_def,shift_def,bytes_in_word_def] - \\ fs [WORD_MUL_LSL]); + \\ rfs [] \\ fs [] +QED + +Theorem insert_insert_3_1: + insert 3 x (insert 1 y t) = insert 1 y (insert 3 x t) +Proof + fs [Once insert_insert] +QED + +Theorem shift_lsl: + good_dimindex (:'a) ==> w << shift (:'a) = w * bytes_in_word:'a word +Proof + rw [labPropsTheory.good_dimindex_def,shift_def,bytes_in_word_def] + \\ fs [WORD_MUL_LSL] +QED val alloc_alt = SPEC_ALL alloc_lemma @@ -5904,10 +6454,12 @@ val alloc_alt = ([],[],[prove(``alloc_size k ≠ -1w ==> T``,fs [])])) |> GEN_ALL -Theorem alloc_size_dimword - `good_dimindex (:'a) ==> - alloc_size (dimword (:'a)) = -1w:'a word` - (fs [alloc_size_def,EVAL ``good_dimindex (:'a)``] \\ rw [] \\ fs []); +Theorem alloc_size_dimword: + good_dimindex (:'a) ==> + alloc_size (dimword (:'a)) = -1w:'a word +Proof + fs [alloc_size_def,EVAL ``good_dimindex (:'a)``] \\ rw [] \\ fs [] +QED val alloc_fail = alloc_lemma |> Q.INST [`k`|->`dimword (:'a)`] @@ -5922,14 +6474,17 @@ val word_exp_rw = save_thm("word_exp_rw",LIST_CONJ wordSemTheory.the_words_def, lookup_insert]); -Theorem get_var_set_var_thm - `wordSem$get_var n (set_var m x y) = if n = m then SOME x else get_var n y` - (fs[wordSemTheory.get_var_def,wordSemTheory.set_var_def,lookup_insert]); - -Theorem alloc_NONE_IMP_cut_env - `alloc w (adjust_set names) t = (NONE,s1) ==> - wordSem$cut_env (adjust_set names) s1.locals = SOME s1.locals` - (fs [wordSemTheory.alloc_def,wordSemTheory.gc_def] +Theorem get_var_set_var_thm: + wordSem$get_var n (set_var m x y) = if n = m then SOME x else get_var n y +Proof + fs[wordSemTheory.get_var_def,wordSemTheory.set_var_def,lookup_insert] +QED + +Theorem alloc_NONE_IMP_cut_env: + alloc w (adjust_set names) t = (NONE,s1) ==> + wordSem$cut_env (adjust_set names) s1.locals = SOME s1.locals +Proof + fs [wordSemTheory.alloc_def,wordSemTheory.gc_def] \\ fs [case_eq_thms] \\ rw [] \\ fs [wordSemTheory.push_env_def,wordSemTheory.pop_env_def, wordSemTheory.set_store_def] @@ -5951,14 +6506,16 @@ Theorem alloc_NONE_IMP_cut_env \\ fs [ALOOKUP_NONE] \\ fs [MAP_ZIP] \\ qpat_x_assum `!x. _ = _` (qspec_then `n` mp_tac) - \\ fs [ALOOKUP_NONE]); + \\ fs [ALOOKUP_NONE] +QED -Theorem state_rel_cut_env_cut_env - `state_rel c l1 l2 s t [] locs /\ +Theorem state_rel_cut_env_cut_env: + state_rel c l1 l2 s t [] locs /\ dataSem$cut_env names s.locals = SOME x /\ wordSem$cut_env (adjust_set names) t.locals = SOME y ==> - state_rel c l1 l2 (s with locals := x) (t with locals := y) [] locs` - (rpt strip_tac + state_rel c l1 l2 (s with locals := x) (t with locals := y) [] locs +Proof + rpt strip_tac \\ drule (GEN_ALL state_rel_cut_env) \\ disch_then drule \\ simp [state_rel_thm] @@ -5985,16 +6542,19 @@ Theorem state_rel_cut_env_cut_env \\ rveq \\ fs [lookup_inter_alt] \\ rw [] \\ fs [dataSemTheory.cut_env_def] \\ rveq \\ fs [] - \\ fs [adjust_set_inter,domain_inter]); + \\ fs [adjust_set_inter,domain_inter] +QED -Theorem domain_adjust_set_EVEN - `k IN domain (adjust_set s) ==> EVEN k` - (fs [adjust_set_def,domain_lookup,lookup_fromAList] \\ rw [] \\ fs [] +Theorem domain_adjust_set_EVEN: + k IN domain (adjust_set s) ==> EVEN k +Proof + fs [adjust_set_def,domain_lookup,lookup_fromAList] \\ rw [] \\ fs [] \\ imp_res_tac ALOOKUP_MEM \\ fs [MEM_MAP] - \\ pairarg_tac \\ fs [EVEN_adjust_var]); + \\ pairarg_tac \\ fs [EVEN_adjust_var] +QED -Theorem AllocVar_thm - `state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs ∧ +Theorem AllocVar_thm: + state_rel c l1 l2 s (t:('a,'c,'ffi) wordSem$state) [] locs ∧ dataSem$cut_env names s.locals = SOME x ∧ get_var 1 t = SOME (Word w) /\ evaluate (AllocVar c limit names,t) = (q,r) /\ @@ -6008,8 +6568,9 @@ Theorem AllocVar_thm r.code_buffer = t.code_buffer /\ r.data_buffer = t.data_buffer /\ r.compile_oracle = t.compile_oracle /\ - q = NONE)` - (fs [wordSemTheory.evaluate_def,AllocVar_def,list_Seq_def] \\ strip_tac + q = NONE) +Proof + fs [wordSemTheory.evaluate_def,AllocVar_def,list_Seq_def] \\ strip_tac \\ `limit < dimword (:'a)` by (rfs [EVAL ``good_dimindex (:'a)``,state_rel_def,dimword_def] \\ rfs []) \\ `?end next. @@ -6187,20 +6748,24 @@ Theorem AllocVar_thm \\ `t5 = t with locals := insert 1 (Word (alloc_size (w2n w DIV 4 + 1))) y` by (unabbrev_all_tac \\ fs [wordSemTheory.state_component_equality]) \\ fs [] - \\ fs [wordSemTheory.state_component_equality]); - -Theorem state_rel_with_clock_0 - `state_rel c r1 r2 s t x locs ==> - state_rel c r1 r2 (s with space := 0) t x locs` - (fs [state_rel_thm] \\ rw [] \\ fs [memory_rel_def] - \\ asm_exists_tac \\ fs []); + \\ fs [wordSemTheory.state_component_equality] +QED + +Theorem state_rel_with_clock_0: + state_rel c r1 r2 s t x locs ==> + state_rel c r1 r2 (s with space := 0) t x locs +Proof + fs [state_rel_thm] \\ rw [] \\ fs [memory_rel_def] + \\ asm_exists_tac \\ fs [] +QED -Theorem word_heap_non_empty_limit - `limit <> 0 ==> +Theorem word_heap_non_empty_limit: + limit <> 0 ==> word_heap other (heap_expand limit) c = SEP_EXISTS w1. one (other,w1) * - word_heap (other + bytes_in_word) (heap_expand (limit - 1)) c` - (Cases_on `limit` \\ fs [] + word_heap (other + bytes_in_word) (heap_expand (limit - 1)) c +Proof + Cases_on `limit` \\ fs [] \\ fs [heap_expand_def,word_heap_def,word_el_def] \\ once_rewrite_tac [ADD_COMM] \\ fs [word_list_exists_ADD] @@ -6211,48 +6776,61 @@ Theorem word_heap_non_empty_limit \\ fs [word_list_exists_def] \\ simp_tac (std_ss++sep_cond_ss) [cond_STAR,PULL_EXISTS,word_list_def, SEP_CLAUSES,word_list_def,word_heap_def,word_el_def,SEP_EXISTS_THM] - \\ metis_tac []); - -Theorem small_int_0 - `good_dimindex (:'a) ==> small_int (:α) 0` - (fs [good_dimindex_def,small_int_def,dimword_def] \\ rw [] \\ fs []); - -Theorem state_rel_imp_clock - `state_rel c l1 l2 s t [] locs ==> s.clock = t.clock` - (fs [state_rel_def]); - -Theorem get_vars_SOME_IFF_data - `(get_vars [] t = SOME [] <=> T) /\ + \\ metis_tac [] +QED + +Theorem small_int_0: + good_dimindex (:'a) ==> small_int (:α) 0 +Proof + fs [good_dimindex_def,small_int_def,dimword_def] \\ rw [] \\ fs [] +QED + +Theorem state_rel_imp_clock: + state_rel c l1 l2 s t [] locs ==> s.clock = t.clock +Proof + fs [state_rel_def] +QED + +Theorem get_vars_SOME_IFF_data: + (get_vars [] t = SOME [] <=> T) /\ (get_vars (x::xs) t = SOME (y::ys) <=> dataSem$get_var x t = SOME y /\ - get_vars xs t = SOME ys)` - (fs [dataSemTheory.get_vars_def] \\ every_case_tac \\ fs []); + get_vars xs t = SOME ys) +Proof + fs [dataSemTheory.get_vars_def] \\ every_case_tac \\ fs [] +QED -Theorem get_vars_SOME_IFF_data_eq - `((get_vars [] t = SOME z) <=> (z = [])) /\ +Theorem get_vars_SOME_IFF_data_eq: + ((get_vars [] t = SOME z) <=> (z = [])) /\ (get_vars (x::xs) t = SOME z <=> ?y ys. z = y::ys /\ dataSem$get_var x t = SOME y /\ - get_vars xs t = SOME ys)` - (Cases_on `z` \\ fs [get_vars_SOME_IFF_data] - \\ fs [dataSemTheory.get_vars_def] \\ every_case_tac \\ fs []); - -Theorem get_vars_SOME_IFF - `(get_vars [] t = SOME [] <=> T) /\ + get_vars xs t = SOME ys) +Proof + Cases_on `z` \\ fs [get_vars_SOME_IFF_data] + \\ fs [dataSemTheory.get_vars_def] \\ every_case_tac \\ fs [] +QED + +Theorem get_vars_SOME_IFF: + (get_vars [] t = SOME [] <=> T) /\ (get_vars (x::xs) t = SOME (y::ys) <=> get_var x t = SOME y /\ - wordSem$get_vars xs t = SOME ys)` - (fs [wordSemTheory.get_vars_def] \\ every_case_tac \\ fs []); + wordSem$get_vars xs t = SOME ys) +Proof + fs [wordSemTheory.get_vars_def] \\ every_case_tac \\ fs [] +QED -Theorem get_vars_SOME_IFF_eq - `((get_vars [] t = SOME z) <=> (z = [])) /\ +Theorem get_vars_SOME_IFF_eq: + ((get_vars [] t = SOME z) <=> (z = [])) /\ (get_vars (x::xs) t = SOME z <=> ?y ys. z = y::ys /\ wordSem$get_var x t = SOME y /\ - get_vars xs t = SOME ys)` - (Cases_on `z` \\ fs [get_vars_SOME_IFF] - \\ fs [wordSemTheory.get_vars_def] \\ every_case_tac \\ fs []); - -Theorem memory_rel_get_vars_IMP_lemma - `memory_rel c be refs sp st m dm + get_vars xs t = SOME ys) +Proof + Cases_on `z` \\ fs [get_vars_SOME_IFF] + \\ fs [wordSemTheory.get_vars_def] \\ every_case_tac \\ fs [] +QED + +Theorem memory_rel_get_vars_IMP_lemma: + memory_rel c be refs sp st m dm (join_env ll (toAList (inter t.locals (adjust_set ll))) ++ envs) ∧ get_vars n ll = SOME x ∧ @@ -6260,12 +6838,14 @@ Theorem memory_rel_get_vars_IMP_lemma memory_rel c be refs sp st m dm (ZIP (x,w) ++ join_env ll - (toAList (inter t.locals (adjust_set ll))) ++ envs)` - (fs [memory_rel_def] \\ rw [] \\ asm_exists_tac \\ fs [] - \\ rpt_drule word_ml_inv_get_vars_IMP_lemma \\ fs []); - -Theorem memory_rel_get_vars_IMP - `memory_rel c be s.refs sp st m dm + (toAList (inter t.locals (adjust_set ll))) ++ envs) +Proof + fs [memory_rel_def] \\ rw [] \\ asm_exists_tac \\ fs [] + \\ rpt_drule word_ml_inv_get_vars_IMP_lemma \\ fs [] +QED + +Theorem memory_rel_get_vars_IMP: + memory_rel c be s.refs sp st m dm (join_env s.locals (toAList (inter t.locals (adjust_set s.locals))) ++ envs) ∧ get_vars n ^s.locals = SOME x ∧ @@ -6273,16 +6853,18 @@ Theorem memory_rel_get_vars_IMP memory_rel c be s.refs sp st m dm (ZIP (x,w) ++ join_env s.locals - (toAList (inter t.locals (adjust_set s.locals))) ++ envs)` - (metis_tac [memory_rel_get_vars_IMP_lemma]); + (toAList (inter t.locals (adjust_set s.locals))) ++ envs) +Proof + metis_tac [memory_rel_get_vars_IMP_lemma] +QED val memory_rel_get_var_IMP = save_thm("memory_rel_get_var_IMP", memory_rel_get_vars_IMP |> Q.INST [`n`|->`[u]`] |> GEN_ALL |> SIMP_RULE std_ss [MAP,get_vars_SOME_IFF_eq,get_vars_SOME_IFF_data_eq, PULL_EXISTS,ZIP,APPEND]); -Theorem lookup_RefByte_location - `state_rel c l1 l2 x t [] locs ==> +Theorem lookup_RefByte_location: + state_rel c l1 l2 x t [] locs ==> lookup RefByte_location t.code = SOME (4,RefByte_code c) /\ lookup RefArray_location t.code = SOME (3,RefArray_code c) /\ lookup FromList_location t.code = SOME (4,FromList_code c) /\ @@ -6292,27 +6874,32 @@ Theorem lookup_RefByte_location lookup Sub_location t.code = SOME (3,Sub_code) /\ lookup Mul_location t.code = SOME (3,Mul_code) /\ lookup Div_location t.code = SOME (3,Div_code) /\ - lookup Mod_location t.code = SOME (3,Mod_code)` - (fs [state_rel_def,code_rel_def,stubs_def]); + lookup Mod_location t.code = SOME (3,Mod_code) +Proof + fs [state_rel_def,code_rel_def,stubs_def] +QED -Theorem memory_rel_insert - `memory_rel c be refs sp st m dm +Theorem memory_rel_insert: + memory_rel c be refs sp st m dm ([(x,w)] ++ join_env d (toAList (inter l (adjust_set d))) ++ xs) ⇒ memory_rel c be refs sp st m dm (join_env (insert dest x d) (toAList (inter (insert (adjust_var dest) w l) - (adjust_set (insert dest x d)))) ++ xs)` - (fs [memory_rel_def] \\ rw [] \\ asm_exists_tac \\ fs [] - \\ match_mp_tac word_ml_inv_insert \\ fs []); - -Theorem state_rel_IMP_Number_arg - `state_rel c l1 l2 (call_env xs s) (call_env ys t) [] locs /\ + (adjust_set (insert dest x d)))) ++ xs) +Proof + fs [memory_rel_def] \\ rw [] \\ asm_exists_tac \\ fs [] + \\ match_mp_tac word_ml_inv_insert \\ fs [] +QED + +Theorem state_rel_IMP_Number_arg: + state_rel c l1 l2 (call_env xs s) (call_env ys t) [] locs /\ n < dimword (:'a) DIV 16 /\ LENGTH ys = LENGTH xs + 1 ==> state_rel c l1 l2 (call_env (xs ++ [Number (& n)]) s) - (call_env (ys ++ [Word (n2w (4 * n):'a word)]) t) [] locs` - (fs [state_rel_thm,call_env_def,wordSemTheory.call_env_def] \\ rw [] + (call_env (ys ++ [Word (n2w (4 * n):'a word)]) t) [] locs +Proof + fs [state_rel_thm,call_env_def,wordSemTheory.call_env_def] \\ rw [] THEN1 (Cases_on `ys` \\ fs [lookup_fromList,lookup_fromList2]) THEN1 (fs [lookup_fromList,lookup_fromList2,EVEN_adjust_var] @@ -6329,83 +6916,110 @@ Theorem state_rel_IMP_Number_arg \\ fs [] \\ match_mp_tac IMP_memory_rel_Number \\ full_simp_tac std_ss [SNOC_APPEND,GSYM APPEND_ASSOC,APPEND] \\ fs [small_int_def,labPropsTheory.good_dimindex_def] - \\ rfs [dimword_def]); - -Theorem state_rel_cut_IMP - `state_rel c l1 l2 s t [] locs /\ cut_state_opt names_opt s = SOME x ==> - state_rel c l1 l2 x t [] locs` - (Cases_on `names_opt` \\ fs [dataSemTheory.cut_state_opt_def] + \\ rfs [dimword_def] +QED + +Theorem state_rel_cut_IMP: + state_rel c l1 l2 s t [] locs /\ cut_state_opt names_opt s = SOME x ==> + state_rel c l1 l2 x t [] locs +Proof + Cases_on `names_opt` \\ fs [dataSemTheory.cut_state_opt_def] THEN1 (rw [] \\ fs []) \\ fs [dataSemTheory.cut_state_def] \\ every_case_tac \\ fs [] \\ rw [] \\ fs [] - \\ imp_res_tac state_rel_cut_env); + \\ imp_res_tac state_rel_cut_env +QED -Theorem get_vars_2_IMP - `(wordSem$get_vars [x1;x2] s = SOME [v1;v2]) ==> +Theorem get_vars_2_IMP: + (wordSem$get_vars [x1;x2] s = SOME [v1;v2]) ==> get_var x1 s = SOME v1 /\ - get_var x2 s = SOME v2` - (fs [wordSemTheory.get_vars_def] \\ every_case_tac \\ fs []); + get_var x2 s = SOME v2 +Proof + fs [wordSemTheory.get_vars_def] \\ every_case_tac \\ fs [] +QED -Theorem get_vars_3_IMP - `(wordSem$get_vars [x1;x2;x3] s = SOME [v1;v2;v3]) ==> +Theorem get_vars_3_IMP: + (wordSem$get_vars [x1;x2;x3] s = SOME [v1;v2;v3]) ==> get_var x1 s = SOME v1 /\ get_var x2 s = SOME v2 /\ - get_var x3 s = SOME v3` - (fs [wordSemTheory.get_vars_def] \\ every_case_tac \\ fs []); + get_var x3 s = SOME v3 +Proof + fs [wordSemTheory.get_vars_def] \\ every_case_tac \\ fs [] +QED -Theorem inter_insert_ODD_adjust_set - `!k. ODD k ==> +Theorem inter_insert_ODD_adjust_set: + !k. ODD k ==> inter (insert (adjust_var dest) w (insert k v s)) (adjust_set t) = - inter (insert (adjust_var dest) w s) (adjust_set t)` - (fs [spt_eq_thm,wf_inter,lookup_inter_alt,lookup_insert] + inter (insert (adjust_var dest) w s) (adjust_set t) +Proof + fs [spt_eq_thm,wf_inter,lookup_inter_alt,lookup_insert] \\ rw [] \\ rw [] \\ fs [] - \\ imp_res_tac domain_adjust_set_EVEN \\ fs [EVEN_ODD]); + \\ imp_res_tac domain_adjust_set_EVEN \\ fs [EVEN_ODD] +QED -Theorem inter_insert_ODD_adjust_set_alt - `!k. ODD k ==> +Theorem inter_insert_ODD_adjust_set_alt: + !k. ODD k ==> inter (insert k v s) (adjust_set t) = - inter s (adjust_set t)` - (fs [spt_eq_thm,wf_inter,lookup_inter_alt,lookup_insert] + inter s (adjust_set t) +Proof + fs [spt_eq_thm,wf_inter,lookup_inter_alt,lookup_insert] \\ rw [] \\ rw [] \\ fs [] - \\ imp_res_tac domain_adjust_set_EVEN \\ fs [EVEN_ODD]); - -Theorem domain_adjust_set_NOT_EMPTY[simp] - `domain (adjust_set s) <> EMPTY` - (fs [EXTENSION,domain_lookup,adjust_set_def] \\ EVAL_TAC - \\ fs [lookup_insert] \\ metis_tac []); - -Theorem get_vars_termdep[simp] - `!xs. get_vars xs (t with termdep := t.termdep - 1) = get_vars xs t` - (Induct \\ EVAL_TAC \\ rw [] \\ every_case_tac \\ fs []); + \\ imp_res_tac domain_adjust_set_EVEN \\ fs [EVEN_ODD] +QED + +Theorem domain_adjust_set_NOT_EMPTY[simp]: + domain (adjust_set s) <> EMPTY +Proof + fs [EXTENSION,domain_lookup,adjust_set_def] \\ EVAL_TAC + \\ fs [lookup_insert] \\ metis_tac [] +QED + +Theorem get_vars_termdep[simp]: + !xs. get_vars xs (t with termdep := t.termdep - 1) = get_vars xs t +Proof + Induct \\ EVAL_TAC \\ rw [] \\ every_case_tac \\ fs [] +QED val join_env_locals_def = Define` join_env_locals sl tl = join_env sl (toAList (inter tl (adjust_set sl)))`; -Theorem join_env_locals_insert_odd[simp] - `ODD n ⇒ join_env_locals sl (insert n v ls) = join_env_locals sl ls` - (rw[join_env_locals_def,inter_insert_ODD_adjust_set_alt]); - -Theorem join_env_locals_insert_dest_odd[simp] - `ODD n ⇒ join_env_locals sl (insert (adjust_var dest) w (insert n v ls)) = join_env_locals sl (insert (adjust_var dest) w ls)` - (rw[join_env_locals_def,inter_insert_ODD_adjust_set]); - -Theorem MustTerminate_limit_NOT_0[simp] - `MustTerminate_limit (:'a) <> 0` - (rewrite_tac [wordSemTheory.MustTerminate_limit_def] \\ fs [dimword_def]); - -Theorem memory_rel_Temp[simp] - `memory_rel c be refs sp (st |+ (Temp i,w)) m dm vars <=> - memory_rel c be refs sp st m dm vars` - (fs [memory_rel_def,heap_in_memory_store_def,FLOOKUP_UPDATE]); - -Theorem adjust_var_not_15[simp] - `adjust_var a2 <> 15` - (metis_tac [EVAL ``EVEN 15``,EVEN_adjust_var]); - -Theorem get_vars_sing - `wordSem$get_vars [n] t = SOME x <=> ?x1. get_vars [n] t = SOME [x1] /\ x = [x1]` - (fs [wordSemTheory.get_vars_def] \\ every_case_tac \\ fs [] \\ EQ_TAC \\ fs []); +Theorem join_env_locals_insert_odd[simp]: + ODD n ⇒ join_env_locals sl (insert n v ls) = join_env_locals sl ls +Proof + rw[join_env_locals_def,inter_insert_ODD_adjust_set_alt] +QED + +Theorem join_env_locals_insert_dest_odd[simp]: + ODD n ⇒ join_env_locals sl (insert (adjust_var dest) w (insert n v ls)) = join_env_locals sl (insert (adjust_var dest) w ls) +Proof + rw[join_env_locals_def,inter_insert_ODD_adjust_set] +QED + +Theorem MustTerminate_limit_NOT_0[simp]: + MustTerminate_limit (:'a) <> 0 +Proof + rewrite_tac [wordSemTheory.MustTerminate_limit_def] \\ fs [dimword_def] +QED + +Theorem memory_rel_Temp[simp]: + memory_rel c be refs sp (st |+ (Temp i,w)) m dm vars <=> + memory_rel c be refs sp st m dm vars +Proof + fs [memory_rel_def,heap_in_memory_store_def,FLOOKUP_UPDATE] +QED + +Theorem adjust_var_not_15[simp]: + adjust_var a2 <> 15 +Proof + metis_tac [EVAL ``EVEN 15``,EVEN_adjust_var] +QED + +Theorem get_vars_sing: + wordSem$get_vars [n] t = SOME x <=> ?x1. get_vars [n] t = SOME [x1] /\ x = [x1] +Proof + fs [wordSemTheory.get_vars_def] \\ every_case_tac \\ fs [] \\ EQ_TAC \\ fs [] +QED val word_ml_inv_get_var_IMP = save_thm("word_ml_inv_get_var_IMP", word_ml_inv_get_vars_IMP diff --git a/compiler/backend/proofs/data_to_word_memoryProofScript.sml b/compiler/backend/proofs/data_to_word_memoryProofScript.sml index 985b5e743a..be02374630 100644 --- a/compiler/backend/proofs/data_to_word_memoryProofScript.sml +++ b/compiler/backend/proofs/data_to_word_memoryProofScript.sml @@ -29,38 +29,51 @@ val LESS_4 = DECIDE ``i < 4 <=> (i = 0) \/ (i = 1) \/ (i = 2) \/ (i = 3n)`` val LESS_8 = DECIDE ``i < 8 <=> (i = 0) \/ (i = 1) \/ (i = 2) \/ (i = 3n) \/ (i = 4) \/ (i = 5) \/ (i = 6) \/ (i = 7)`` -Theorem word_eq - `!w v. w = v <=> !n. word_bit n w = word_bit n v` - (fs [word_bit_thm,fcpTheory.CART_EQ] +Theorem word_eq: + !w v. w = v <=> !n. word_bit n w = word_bit n v +Proof + fs [word_bit_thm,fcpTheory.CART_EQ] \\ rw [] \\ eq_tac \\ rw [] - \\ eq_tac \\ rw [] \\ res_tac \\ fs []); - -Theorem ZIP_REPLICATE - `!n. ZIP (REPLICATE n x, REPLICATE n y) = REPLICATE n (x,y)` - (Induct \\ fs [REPLICATE]); - -Theorem list_max_leq_suff - `EVERY (\x. x <= b) ls ==> list_max ls <= b` - (Induct_on`ls` \\ rw[list_max_def]); - -Theorem list_max_mem - `ls <> [] ==> MEM (list_max ls) ls` - (Induct_on`ls` \\ rw[list_max_def] - \\ Cases_on`ls` \\ fs[list_max_def]); - -Theorem list_max_sum_bound - `SUM ls <= list_max ls * LENGTH ls` - (Induct_on`ls` \\ rw[list_max_def,ADD1,LEFT_ADD_DISTRIB] + \\ eq_tac \\ rw [] \\ res_tac \\ fs [] +QED + +Theorem ZIP_REPLICATE: + !n. ZIP (REPLICATE n x, REPLICATE n y) = REPLICATE n (x,y) +Proof + Induct \\ fs [REPLICATE] +QED + +Theorem list_max_leq_suff: + EVERY (\x. x <= b) ls ==> list_max ls <= b +Proof + Induct_on`ls` \\ rw[list_max_def] +QED + +Theorem list_max_mem: + ls <> [] ==> MEM (list_max ls) ls +Proof + Induct_on`ls` \\ rw[list_max_def] + \\ Cases_on`ls` \\ fs[list_max_def] +QED + +Theorem list_max_sum_bound: + SUM ls <= list_max ls * LENGTH ls +Proof + Induct_on`ls` \\ rw[list_max_def,ADD1,LEFT_ADD_DISTRIB] \\ match_mp_tac LESS_EQ_TRANS - \\ asm_exists_tac \\ simp[] ); - -Theorem list_max_bounded_elements - `!l1 l2. LIST_REL $<= l1 l2 ==> list_max l1 <= list_max l2` - (Induct \\ rw[list_max_def] \\ res_tac \\ rw[list_max_def]); - -Theorem list_max_map - `∀f l. (∀x y. x < y ==> f x < f y) ==> list_max (MAP f l) = if NULL l then 0 else f (list_max l)` - (rpt strip_tac + \\ asm_exists_tac \\ simp[] +QED + +Theorem list_max_bounded_elements: + !l1 l2. LIST_REL $<= l1 l2 ==> list_max l1 <= list_max l2 +Proof + Induct \\ rw[list_max_def] \\ res_tac \\ rw[list_max_def] +QED + +Theorem list_max_map: + ∀f l. (∀x y. x < y ==> f x < f y) ==> list_max (MAP f l) = if NULL l then 0 else f (list_max l) +Proof + rpt strip_tac \\ Induct_on`l` \\ rw[list_max_def,NULL_EQ] \\ res_tac \\ fs[list_max_def] \\ rveq \\ fs[NOT_LESS] @@ -68,11 +81,13 @@ Theorem list_max_map \\ Cases_on`h < list_max l` \\ fs[] >- ( res_tac \\ fs[] ) \\ `h = list_max l` by fs[] - \\ fs[]); + \\ fs[] +QED -Theorem w2i_i2w_IMP - `(w2i ((i2w i):'a word)) = i ==> INT_MIN (:α) ≤ i ∧ i ≤ INT_MAX (:α)` - (Cases_on `i` +Theorem w2i_i2w_IMP: + (w2i ((i2w i):'a word)) = i ==> INT_MIN (:α) ≤ i ∧ i ≤ INT_MAX (:α) +Proof + Cases_on `i` \\ fs [integer_wordTheory.i2w_def,integer_wordTheory.w2i_def] \\ rw [] THEN1 (fs [word_msb_def,word_index,bitTheory.BIT_def,bitTheory.BITS_THM] @@ -97,12 +112,15 @@ Theorem w2i_i2w_IMP \\ fs [DIV_EQ_X] \\ fs [GSYM EXP,ADD1] \\ Cases_on `dimindex (:α)` \\ fs [] \\ fs [wordsTheory.INT_MIN_def,integer_wordTheory.INT_MIN_def, - wordsTheory.INT_MAX_def,integer_wordTheory.INT_MAX_def,EXP]); + wordsTheory.INT_MAX_def,integer_wordTheory.INT_MAX_def,EXP] +QED -Theorem word_i2w_sub - `!a b. i2w a - i2w b = i2w (a - b)` - (fs [integer_wordTheory.word_i2w_add,word_sub_def,integerTheory.int_sub, - integer_wordTheory.MULT_MINUS_ONE]); +Theorem word_i2w_sub: + !a b. i2w a - i2w b = i2w (a - b) +Proof + fs [integer_wordTheory.word_i2w_add,word_sub_def,integerTheory.int_sub, + integer_wordTheory.MULT_MINUS_ONE] +QED (* -- *) @@ -149,9 +167,11 @@ val Word64Rep_def = Define` else DataElement [] 1 (Word64Tag, [Word (((63 >< 0) w):'a word)])`; -Theorem Word64Rep_DataElement - `∀a w. ∃ws. (Word64Rep a w:'a ml_el) = DataElement [] (LENGTH ws) (Word64Tag,ws)` - (Cases \\ rw[Word64Rep_def]); +Theorem Word64Rep_DataElement: + ∀a w. ∃ws. (Word64Rep a w:'a ml_el) = DataElement [] (LENGTH ws) (Word64Tag,ws) +Proof + Cases \\ rw[Word64Rep_def] +QED val v_size_LEMMA = Q.prove( `!vs v. MEM v vs ==> v_size v <= v1_size vs`, @@ -282,10 +302,11 @@ val abs_ml_inv_def = Define ` (* TODO: move/reorganise various things in this file *) -Theorem word_list_limit - `EVERY isWord ws ∧ ALL_DISTINCT ws ⇒ - LENGTH (ws:'a word_loc list) ≤ dimword(:'a) ` - (rw[] +Theorem word_list_limit: + EVERY isWord ws ∧ ALL_DISTINCT ws ⇒ + LENGTH (ws:'a word_loc list) ≤ dimword(:'a) +Proof + rw[] \\ `LENGTH ws = CARD (set ws)` by simp[ALL_DISTINCT_CARD_LIST_TO_SET] \\ pop_assum SUBST_ALL_TAC \\ CONV_TAC(RAND_CONV(REWR_CONV(GSYM CARD_COUNT))) @@ -299,53 +320,68 @@ Theorem word_list_limit \\ qexists_tac`w2n o theWord` \\ simp[INJ_DEF] \\ fs[EVERY_MEM,isWord_exists] \\ rw[] \\ res_tac \\ fs[theWord_def] - \\ metis_tac[w2n_lt]); - -Theorem MOD_EQ_0_0 - `∀n b. 0 < b ⇒ (n MOD b = 0) ⇒ n < b ⇒ (n = 0)` - (rw[MOD_EQ_0_DIVISOR] >> Cases_on`d`>>fs[]) - -Theorem EVERY2_IMP_EVERY - `!xs ys. EVERY2 P xs ys ==> EVERY (\(x,y). P y x) (ZIP(ys,xs))` - (Induct \\ Cases_on `ys` \\ full_simp_tac(srw_ss())[]); - -Theorem EVERY2_IMP_EVERY2 - `!xs ys P1 P2. + \\ metis_tac[w2n_lt] +QED + +Theorem MOD_EQ_0_0: + ∀n b. 0 < b ⇒ (n MOD b = 0) ⇒ n < b ⇒ (n = 0) +Proof + rw[MOD_EQ_0_DIVISOR] >> Cases_on`d`>>fs[] +QED + +Theorem EVERY2_IMP_EVERY: + !xs ys. EVERY2 P xs ys ==> EVERY (\(x,y). P y x) (ZIP(ys,xs)) +Proof + Induct \\ Cases_on `ys` \\ full_simp_tac(srw_ss())[] +QED + +Theorem EVERY2_IMP_EVERY2: + !xs ys P1 P2. (!x y. MEM x xs /\ MEM y ys /\ P1 x y ==> P2 x y) ==> - EVERY2 P1 xs ys ==> EVERY2 P2 xs ys` - (Induct \\ Cases_on `ys` \\ full_simp_tac (srw_ss()) [] - \\ rpt strip_tac \\ metis_tac []); - -Theorem MEM_EVERY2_IMP - `!l x zs P. MEM x l /\ EVERY2 P zs l ==> ?z. MEM z zs /\ P z x` - (Induct \\ Cases_on `zs` \\ full_simp_tac (srw_ss()) [] \\ metis_tac []); + EVERY2 P1 xs ys ==> EVERY2 P2 xs ys +Proof + Induct \\ Cases_on `ys` \\ full_simp_tac (srw_ss()) [] + \\ rpt strip_tac \\ metis_tac [] +QED + +Theorem MEM_EVERY2_IMP: + !l x zs P. MEM x l /\ EVERY2 P zs l ==> ?z. MEM z zs /\ P z x +Proof + Induct \\ Cases_on `zs` \\ full_simp_tac (srw_ss()) [] \\ metis_tac [] +QED val EVERY2_LENGTH = LIST_REL_LENGTH val EVERY2_IMP_LENGTH = EVERY2_LENGTH -Theorem EVERY2_APPEND_CONS - `!xs y ys zs P. EVERY2 P (xs ++ y::ys) zs ==> +Theorem EVERY2_APPEND_CONS: + !xs y ys zs P. EVERY2 P (xs ++ y::ys) zs ==> ?t1 t t2. (zs = t1 ++ t::t2) /\ (LENGTH t1 = LENGTH xs) /\ - EVERY2 P xs t1 /\ P y t /\ EVERY2 P ys t2` - (Induct \\ full_simp_tac (srw_ss()) [] + EVERY2 P xs t1 /\ P y t /\ EVERY2 P ys t2 +Proof + Induct \\ full_simp_tac (srw_ss()) [] \\ Cases_on `zs` \\ full_simp_tac (srw_ss()) [] \\ rpt strip_tac \\ res_tac \\ full_simp_tac std_ss [] \\ Q.LIST_EXISTS_TAC [`h::t1`,`t'`,`t2`] - \\ full_simp_tac (srw_ss()) []); + \\ full_simp_tac (srw_ss()) [] +QED -Theorem EVERY2_SWAP - `!xs ys. EVERY2 P xs ys ==> EVERY2 (\y x. P x y) ys xs` - (Induct \\ Cases_on `ys` \\ full_simp_tac (srw_ss()) []); +Theorem EVERY2_SWAP: + !xs ys. EVERY2 P xs ys ==> EVERY2 (\y x. P x y) ys xs +Proof + Induct \\ Cases_on `ys` \\ full_simp_tac (srw_ss()) [] +QED -Theorem EVERY2_APPEND_IMP_APPEND - `!xs1 xs2 ys P. +Theorem EVERY2_APPEND_IMP_APPEND: + !xs1 xs2 ys P. EVERY2 P (xs1 ++ xs2) ys ==> - ?ys1 ys2. (ys = ys1 ++ ys2) /\ EVERY2 P xs1 ys1 /\ EVERY2 P xs2 ys2` - (Induct \\ Cases_on `ys` \\ full_simp_tac (srw_ss()) [] \\ rpt strip_tac + ?ys1 ys2. (ys = ys1 ++ ys2) /\ EVERY2 P xs1 ys1 /\ EVERY2 P xs2 ys2 +Proof + Induct \\ Cases_on `ys` \\ full_simp_tac (srw_ss()) [] \\ rpt strip_tac \\ res_tac \\ full_simp_tac std_ss [] \\ Q.LIST_EXISTS_TAC [`h::ys1`,`ys2`] - \\ full_simp_tac std_ss [APPEND,LIST_REL_def] \\ metis_tac[]); + \\ full_simp_tac std_ss [APPEND,LIST_REL_def] \\ metis_tac[] +QED val EVERY2_IMP_APPEND = rich_listTheory.EVERY2_APPEND_suff val IMP_EVERY2_APPEND = EVERY2_IMP_APPEND @@ -359,10 +395,12 @@ val EVERY2_MAP_FST_SND = Q.prove( `!xs. EVERY2 P (MAP FST xs) (MAP SND xs) = EVERY (\(x,y). P x y) xs`, Induct \\ srw_tac [] [LIST_REL_def] \\ Cases_on `h` \\ srw_tac [] []); -Theorem fapply_fupdate_update - `$' (f |+ p) = (FST p =+ SND p) ($' f)` - (Cases_on`p`>> - simp[FUN_EQ_THM,FAPPLY_FUPDATE_THM,APPLY_UPDATE_THM] >> rw[]) +Theorem fapply_fupdate_update: + $' (f |+ p) = (FST p =+ SND p) ($' f) +Proof + Cases_on`p`>> + simp[FUN_EQ_THM,FAPPLY_FUPDATE_THM,APPLY_UPDATE_THM] >> rw[] +QED val heap_lookup_APPEND1 = Q.prove( `∀h1 z h2. @@ -378,13 +416,15 @@ val heap_lookup_APPEND2 = Q.prove( Induct >> fs[heap_lookup_def,heap_length_def] >> rw[] >> simp[]) -Theorem heap_lookup_APPEND - `heap_lookup a (h1 ++ h2) = +Theorem heap_lookup_APPEND: + heap_lookup a (h1 ++ h2) = if a < heap_length h1 then heap_lookup a h1 else - heap_lookup (a-heap_length h1) h2` - (rw[heap_lookup_APPEND2] >> - simp[heap_lookup_APPEND1]) + heap_lookup (a-heap_length h1) h2 +Proof + rw[heap_lookup_APPEND2] >> + simp[heap_lookup_APPEND1] +QED (* Prove refinement is maintained past GC calls *) @@ -566,12 +606,14 @@ val bc_stack_ref_inv_related = Q.prove( \\ match_mp_tac bc_ref_inv_related \\ full_simp_tac std_ss [] \\ metis_tac [reachable_refs_lemma]); -Theorem data_up_to_APPEND[simp] - `data_up_to (heap_length xs) (xs ++ ys) <=> EVERY isDataElement xs` - (fs [data_up_to_def,heap_split_APPEND_if,heap_split_0]); +Theorem data_up_to_APPEND[simp]: + data_up_to (heap_length xs) (xs ++ ys) <=> EVERY isDataElement xs +Proof + fs [data_up_to_def,heap_split_APPEND_if,heap_split_0] +QED -Theorem full_gc_thm - `abs_ml_inv conf stack refs (roots,heap,be,a,sp,sp1,gens) limit /\ +Theorem full_gc_thm: + abs_ml_inv conf stack refs (roots,heap,be,a,sp,sp1,gens) limit /\ conf.gc_kind = Simple ==> ?roots2 heap2 a2. (full_gc (roots,heap,limit) = (roots2,heap2,a2,T)) /\ @@ -580,8 +622,9 @@ Theorem full_gc_thm a2,limit - a2,0,gens) limit /\ (heap_length heap2 = a2) /\ (heap_length (heap_filter (reachable_addresses roots heap) heap) = - heap_length heap2)` - (simp_tac std_ss [abs_ml_inv_def,GSYM CONJ_ASSOC] + heap_length heap2) +Proof + simp_tac std_ss [abs_ml_inv_def,GSYM CONJ_ASSOC] \\ rpt strip_tac \\ drule full_gc_related \\ asm_simp_tac std_ss [] \\ strip_tac \\ qpat_x_assum `heap_length heap2 = _` (assume_tac o GSYM) @@ -604,7 +647,8 @@ Theorem full_gc_thm (qpat_x_assum `full_gc (roots,heap,limit) = xxx` (ASSUME_TAC o GSYM) \\ imp_res_tac full_gc_ok \\ NTAC 3 (POP_ASSUM (K ALL_TAC)) \\ full_simp_tac std_ss [] \\ metis_tac []) - \\ fs [gc_kind_inv_def] \\ CASE_TAC \\ fs []); + \\ fs [gc_kind_inv_def] \\ CASE_TAC \\ fs [] +QED val make_gc_conf_def = Define ` make_gc_conf limit = @@ -707,9 +751,11 @@ val gen_gc_data_refs_split = Q.prove(`!cc roots heap. >> drule gc_move_loop_data_refs_split >> fs []); -Theorem heap_expand_not_isRef - `EVERY (λx. ¬isRef x) (heap_expand n)` - (Induct_on `n` >> fs[isRef_def,heap_expand_def]) +Theorem heap_expand_not_isRef: + EVERY (λx. ¬isRef x) (heap_expand n) +Proof + Induct_on `n` >> fs[isRef_def,heap_expand_def] +QED val reset_gens_def = Define ` reset_gens conf a = @@ -717,11 +763,12 @@ val reset_gens_def = Define ` | Generational sizes => GenState 0 (MAP (K a) sizes) | _ => GenState 0 []`; -Theorem gen_state_ok_reset - `heap_ok (h ++ heap_expand n ++ r) l ==> +Theorem gen_state_ok_reset: + heap_ok (h ++ heap_expand n ++ r) l ==> gen_state_ok (heap_length h) (n + heap_length h) - (h ++ heap_expand n ++ r) (reset_gens conf (heap_length h))` - (strip_tac + (h ++ heap_expand n ++ r) (reset_gens conf (heap_length h)) +Proof + strip_tac \\ fs [reset_gens_def] \\ TOP_CASE_TAC \\ fs [gen_state_ok_def,reset_gens_def] \\ fs [EVERY_MAP] \\ disj2_tac \\ fs [gen_start_ok_def] @@ -735,18 +782,20 @@ Theorem gen_state_ok_reset \\ rfs [heap_lookup_APPEND,heap_length_APPEND,heap_length_heap_expand] \\ every_case_tac \\ imp_res_tac heap_lookup_MEM - \\ pop_assum mp_tac \\ fs [heap_expand_def]); + \\ pop_assum mp_tac \\ fs [heap_expand_def] +QED -Theorem gen_gc_thm - `abs_ml_inv conf stack refs (roots,heap,be,a,sp,sp1,gens) limit ==> +Theorem gen_gc_thm: + abs_ml_inv conf stack refs (roots,heap,be,a,sp,sp1,gens) limit ==> ?roots2 state2. (gen_gc (make_gc_conf limit) (roots,heap) = (roots2,state2)) /\ abs_ml_inv conf stack refs (roots2,state2.h1 ++ heap_expand state2.n ++ state2.r1,be, state2.a,state2.n,0,reset_gens conf state2.a) limit /\ state2.ok /\ (heap_length (state2.h1 ⧺ state2.r1) = - heap_length (heap_filter (reachable_addresses roots heap) heap))` - (simp_tac std_ss [abs_ml_inv_def,GSYM CONJ_ASSOC,make_gc_conf_def] + heap_length (heap_filter (reachable_addresses roots heap) heap)) +Proof + simp_tac std_ss [abs_ml_inv_def,GSYM CONJ_ASSOC,make_gc_conf_def] \\ rpt strip_tac \\ qmatch_goalsub_abbrev_tac `gen_gc cc` \\ `heap_ok heap cc.limit` by fs [Abbr `cc`] \\ drule gen_gcTheory.gen_gc_related @@ -778,19 +827,21 @@ Theorem gen_gc_thm by fs[heap_length_APPEND,heap_length_heap_expand] \\ pop_assum (fn thm => PURE_ONCE_REWRITE_TAC [thm]) \\ PURE_ONCE_REWRITE_TAC [gen_gc_partialTheory.heap_split_length] - \\ fs[heap_expand_not_isRef])); + \\ fs[heap_expand_not_isRef]) +QED val has_gen_def = Define ` has_gen (GenState _ xs) <=> xs <> []`; -Theorem heap_split_heap_split - `!heap n1 n2 h1 h2 h3 h4. +Theorem heap_split_heap_split: + !heap n1 n2 h1 h2 h3 h4. heap_split n2 heap = SOME (h3,h4) /\ heap_split n1 heap = SOME (h1,h2) /\ n1 <= n2 ==> ?m. h2 = m ++ h4 /\ h3 = h1 ++ m /\ heap = h1 ++ m ++ h4 /\ - heap_split (n2 - heap_length h1) h2 = SOME (m,h4)` - (Induct \\ fs [heap_split_def] + heap_split (n2 - heap_length h1) h2 = SOME (m,h4) +Proof + Induct \\ fs [heap_split_def] \\ rpt gen_tac \\ Cases_on `n2 = 0` \\ fs [] THEN1 (strip_tac \\ rveq \\ fs [] \\ rveq \\ fs [heap_split_0]) @@ -806,20 +857,23 @@ Theorem heap_split_heap_split \\ TOP_CASE_TAC \\ fs [] \\ TOP_CASE_TAC \\ fs [] \\ strip_tac \\ rveq \\ fs [] - \\ res_tac \\ rfs [] \\ fs [heap_length_def]); + \\ res_tac \\ rfs [] \\ fs [heap_length_def] +QED -Theorem heap_split_LESS_EQ - `!heap n x. heap_split n heap = SOME x ==> n <= heap_length heap` - (Induct \\ fs [heap_split_def] \\ rw [] +Theorem heap_split_LESS_EQ: + !heap n x. heap_split n heap = SOME x ==> n <= heap_length heap +Proof + Induct \\ fs [heap_split_def] \\ rw [] \\ every_case_tac \\ fs [] \\ rveq - \\ res_tac \\ fs [heap_length_def]); + \\ res_tac \\ fs [heap_length_def] +QED val isRef_heap_expand = prove( ``!x. EVERY (λx. ¬isRef x) (heap_expand x)``, Cases \\ EVAL_TAC \\ fs [] \\ EVAL_TAC); -Theorem gen_gc_partial_thm - `abs_ml_inv conf stack refs (roots,heap,be,a,sp,sp1,gens) limit /\ +Theorem gen_gc_partial_thm: + abs_ml_inv conf stack refs (roots,heap,be,a,sp,sp1,gens) limit /\ has_gen gens /\ conf.gc_kind = Generational xs ==> ?roots2 state2. partial_gc @@ -827,8 +881,9 @@ Theorem gen_gc_partial_thm (roots,heap) = (roots2,state2) /\ abs_ml_inv conf stack refs (roots2,state2.old ++ state2.h1 ++ heap_expand state2.n ++ state2.r1,be, - state2.a,state2.n,0,reset_gens conf state2.a) limit /\ state2.ok` - (simp_tac std_ss [abs_ml_inv_def,GSYM CONJ_ASSOC,make_gc_conf_def] + state2.a,state2.n,0,reset_gens conf state2.a) limit /\ state2.ok +Proof + simp_tac std_ss [abs_ml_inv_def,GSYM CONJ_ASSOC,make_gc_conf_def] \\ rpt strip_tac \\ qmatch_goalsub_abbrev_tac `partial_gc cc` \\ `heap_ok heap cc.limit` by (fs [Abbr `cc`] \\ Cases_on `gens` \\ fs [make_partial_conf_def]) @@ -949,17 +1004,19 @@ Theorem gen_gc_partial_thm \\ res_tac \\ qmatch_goalsub_abbrev_tac `heap_lookup _ heap2` \\ fs [gc_related_def,isSomeDataElement_def] - \\ res_tac \\ fs []); + \\ res_tac \\ fs [] +QED -Theorem gc_combined_thm - `abs_ml_inv conf stack refs (roots,heap,be,a,sp,sp1,gens) limit /\ +Theorem gc_combined_thm: + abs_ml_inv conf stack refs (roots,heap,be,a,sp,sp1,gens) limit /\ (do_partial ==> has_gen gens) ==> ?roots2 heap2 gens2 n2 a2. (gc_combined (make_gc_conf limit) conf.gc_kind (roots,heap,gens,a+sp+sp1,do_partial) = (roots2,heap2,a2,n2,gens2,T)) /\ - abs_ml_inv conf stack refs (roots2,heap2,be,a2,n2,0,gens2) limit` - (Cases_on `conf.gc_kind` \\ fs [gc_combined_def] + abs_ml_inv conf stack refs (roots2,heap2,be,a2,n2,0,gens2) limit +Proof + Cases_on `conf.gc_kind` \\ fs [gc_combined_def] THEN1 (fs [make_gc_conf_def] \\ fs [abs_ml_inv_def] \\ fs [unused_space_inv_def,gc_kind_inv_def] @@ -973,7 +1030,8 @@ Theorem gc_combined_thm (pairarg_tac \\ fs [] \\ strip_tac \\ drule (GEN_ALL gen_gc_thm) \\ fs [reset_gens_def]) \\ pairarg_tac \\ fs [] \\ strip_tac \\ rveq - \\ drule (GEN_ALL gen_gc_partial_thm) \\ fs [reset_gens_def]); + \\ drule (GEN_ALL gen_gc_partial_thm) \\ fs [reset_gens_def] +QED (* Write to unused heap space is fine, e.g. cons *) @@ -1003,15 +1061,17 @@ val heap_store_unused_alt_def = Define ` heap_store a ([x] ++ heap_expand (sp - el_length x)) xs else (xs,F)`; -Theorem heap_store_lemma - `!xs y x ys. +Theorem heap_store_lemma: + !xs y x ys. heap_store (heap_length xs) y (xs ++ x::ys) = - (xs ++ y ++ ys, heap_length y = el_length x)` - (Induct \\ full_simp_tac (srw_ss()) [heap_length_def,heap_store_def,LET_DEF] + (xs ++ y ++ ys, heap_length y = el_length x) +Proof + Induct \\ full_simp_tac (srw_ss()) [heap_length_def,heap_store_def,LET_DEF] THEN1 DECIDE_TAC \\ rpt strip_tac \\ `el_length h <> 0` by (Cases_on `h` \\ full_simp_tac std_ss [el_length_def]) \\ `~(el_length h + SUM (MAP el_length xs) < el_length h)` by DECIDE_TAC - \\ full_simp_tac std_ss []); + \\ full_simp_tac std_ss [] +QED val heap_store_rel_def = Define ` heap_store_rel heap heap2 <=> @@ -1322,11 +1382,12 @@ val heap_store_unused_alt_thm = prove( \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,APPEND] \\ fs [heap_store_lemma]); -Theorem heap_store_unused_alt_heap_lookup - `!heap heap2 a k x n. +Theorem heap_store_unused_alt_heap_lookup: + !heap heap2 a k x n. heap_store_unused_alt a k x heap = (heap2,T) /\ n < a ==> - heap_lookup n heap = heap_lookup n heap2` - (Induct THEN1 fs [heap_lookup_def,heap_store_unused_alt_def] + heap_lookup n heap = heap_lookup n heap2 +Proof + Induct THEN1 fs [heap_lookup_def,heap_store_unused_alt_def] \\ simp [heap_store_unused_alt_def] \\ rpt strip_tac \\ every_case_tac \\ fs [] \\ ntac 4 (pop_assum mp_tac) @@ -1341,7 +1402,8 @@ Theorem heap_store_unused_alt_heap_lookup \\ rpt strip_tac \\ first_x_assum match_mp_tac \\ fs [heap_store_unused_alt_def] - \\ qexists_tac `(a − el_length h)` \\ fs [] \\ metis_tac []); + \\ qexists_tac `(a − el_length h)` \\ fs [] \\ metis_tac [] +QED val heap_split_heap_store = prove( ``!heap e h1 h2 a y heap2. @@ -1375,15 +1437,17 @@ val heap_store_unused_alt_gen_state_ok = prove( \\ imp_res_tac heap_split_heap_store \\ fs [] \\ rveq \\ fs [] \\ res_tac \\ fs []); -Theorem isDataElement_lemmas[simp] - `isDataElement (DataElement x1 x2 x3) /\ +Theorem isDataElement_lemmas[simp]: + isDataElement (DataElement x1 x2 x3) /\ isDataElement (BlockRep tag ys1) /\ isDataElement (Word64Rep (:'a) w) /\ isDataElement (RefBlock ws) /\ isDataElement (Bytes y1 y2 y3 y4) /\ - isDataElement (Bignum i)` - (rw [BlockRep_def,isDataElement_def,Bignum_def,i2mw_def, - Word64Rep_def,RefBlock_def,Bytes_def]); + isDataElement (Bignum i) +Proof + rw [BlockRep_def,isDataElement_def,Bignum_def,i2mw_def, + Word64Rep_def,RefBlock_def,Bytes_def] +QED (* --- Allocating multiple cons-elements in one go --- *) @@ -1397,33 +1461,41 @@ val list_to_BlockReps_def = Define ` [h; Pointer (a + 3) (Word (ptr_bits conf cons_tag 2))] :: list_to_BlockReps conf t (a + 3) l`; -Theorem list_to_BlockReps_heap_length - `!xs len. +Theorem list_to_BlockReps_heap_length: + !xs len. xs <> [] ==> heap_length (list_to_BlockReps conf x len xs) = - 3 * LENGTH xs` - (Induct \\ fs [] + 3 * LENGTH xs +Proof + Induct \\ fs [] \\ rw [list_to_BlockReps_def, el_length_def, BlockRep_def] - \\ Cases_on `xs` \\ fs [heap_length_def, el_length_def]); + \\ Cases_on `xs` \\ fs [heap_length_def, el_length_def] +QED -Theorem heap_lookup_heap_length - `heap_lookup (heap_length h1) (h1 ++ h2) = heap_lookup 0 h2` - (rw [heap_length_def, heap_lookup_def, heap_lookup_APPEND]); +Theorem heap_lookup_heap_length: + heap_lookup (heap_length h1) (h1 ++ h2) = heap_lookup 0 h2 +Proof + rw [heap_length_def, heap_lookup_def, heap_lookup_APPEND] +QED -Theorem list_to_BlockReps_heap_lookup_0 - `xs <> [] +Theorem list_to_BlockReps_heap_lookup_0: + xs <> [] ==> - isSomeDataElement (heap_lookup 0 (list_to_BlockReps conf x len xs))` - (Cases_on `xs` \\ rw [list_to_BlockReps_def, BlockRep_def, isSomeDataElement_def] - \\ CASE_TAC \\ fs [heap_lookup_def]); - -Theorem list_to_BlockReps_isDataElement - `!xs x len. + isSomeDataElement (heap_lookup 0 (list_to_BlockReps conf x len xs)) +Proof + Cases_on `xs` \\ rw [list_to_BlockReps_def, BlockRep_def, isSomeDataElement_def] + \\ CASE_TAC \\ fs [heap_lookup_def] +QED + +Theorem list_to_BlockReps_isDataElement: + !xs x len. xs <> [] ==> - EVERY isDataElement (list_to_BlockReps conf x len xs)` - (Induct \\ rw [list_to_BlockReps_def] \\ CASE_TAC \\ fs []); + EVERY isDataElement (list_to_BlockReps conf x len xs) +Proof + Induct \\ rw [list_to_BlockReps_def] \\ CASE_TAC \\ fs [] +QED val list_to_BlockReps_data_up_to_lem = Q.prove ( `xs <> [] /\ @@ -1437,35 +1509,43 @@ val list_to_BlockReps_data_up_to = save_thm ( |> Q.INST [`h1`|->`list_to_BlockReps conf x len xs`] |> SIMP_RULE std_ss []); -Theorem list_to_BlockReps_ForwardPointer - `xs <> [] ==> FILTER isForwardPointer (list_to_BlockReps conf x len xs) = []` - (rw [FILTER_EQ_NIL, EVERY_MEM] \\ CCONTR_TAC \\ fs [] +Theorem list_to_BlockReps_ForwardPointer: + xs <> [] ==> FILTER isForwardPointer (list_to_BlockReps conf x len xs) = [] +Proof + rw [FILTER_EQ_NIL, EVERY_MEM] \\ CCONTR_TAC \\ fs [] \\ imp_res_tac (list_to_BlockReps_isDataElement |> SIMP_RULE (srw_ss()) [EVERY_MEM]) - \\ Cases_on `x'` \\ fs [isForwardPointer_def, isDataElement_def]); - -Theorem list_to_BlockReps_Ref - `!xs len x conf. - xs <> [] ==> EVERY (\v. ~isRef v) (list_to_BlockReps conf x len xs)` - (Induct \\ rw [list_to_BlockReps_def, BlockRep_def] - \\ TRY CASE_TAC \\ fs [isRef_def]); - -Theorem list_to_BlockReps_NULL - `xs <> [] ==> list_to_BlockReps conf x len xs <> []` - (Cases_on `xs` \\ fs [list_to_BlockReps_def] \\ CASE_TAC \\ fs []); + \\ Cases_on `x'` \\ fs [isForwardPointer_def, isDataElement_def] +QED + +Theorem list_to_BlockReps_Ref: + !xs len x conf. + xs <> [] ==> EVERY (\v. ~isRef v) (list_to_BlockReps conf x len xs) +Proof + Induct \\ rw [list_to_BlockReps_def, BlockRep_def] + \\ TRY CASE_TAC \\ fs [isRef_def] +QED + +Theorem list_to_BlockReps_NULL: + xs <> [] ==> list_to_BlockReps conf x len xs <> [] +Proof + Cases_on `xs` \\ fs [list_to_BlockReps_def] \\ CASE_TAC \\ fs [] +QED fun unlength_tac thms = fs ([heap_length_def, el_length_def, SUM_APPEND] @ thms) \\ fs [GSYM heap_length_def] -Theorem list_to_BlockReps_MEM - `MEM v (list_to_BlockReps conf x len (h::t)) ==> +Theorem list_to_BlockReps_MEM: + MEM v (list_to_BlockReps conf x len (h::t)) ==> MEM v (list_to_BlockReps conf x (len + 3) t) \/ v = BlockRep cons_tag [h; Pointer (len + 3) (Word (ptr_bits conf cons_tag 2))] \/ - v = BlockRep cons_tag [h; x]` - (rw [list_to_BlockReps_def, BlockRep_def] \\ fs [] - \\ Cases_on `t` \\ fs [list_to_BlockReps_def]); + v = BlockRep cons_tag [h; x] +Proof + rw [list_to_BlockReps_def, BlockRep_def] \\ fs [] + \\ Cases_on `t` \\ fs [list_to_BlockReps_def] +QED val list_to_BlockReps_Pointer_lem = Q.prove ( `!xs len ys l d ptr u. @@ -1501,20 +1581,23 @@ val list_to_BlockReps_Pointer = save_thm ("list_to_BlockReps_Pointer", list_to_BlockReps_Pointer_lem |> SIMP_RULE (srw_ss()) [LET_THM]); -Theorem list_to_v_alt_get_refs - `!xs t r. +Theorem list_to_v_alt_get_refs: + !xs t r. MEM r (get_refs (list_to_v_alt t xs)) ==> - ?x. (MEM x xs \/ x = t) /\ MEM r (get_refs x)` - (Induct \\ rw [dataSemTheory.list_to_v_alt_def] - \\ fs [get_refs_def] \\ metis_tac []); - -Theorem v_inv_lemma - `!v x f hs ha hb sp. + ?x. (MEM x xs \/ x = t) /\ MEM r (get_refs x) +Proof + Induct \\ rw [dataSemTheory.list_to_v_alt_def] + \\ fs [get_refs_def] \\ metis_tac [] +QED + +Theorem v_inv_lemma: + !v x f hs ha hb sp. 0 < heap_length hs /\ heap_length hs <= sp /\ v_inv conf v (x,f,ha++heap_expand sp++hb) ==> - v_inv conf v (x,f,ha++hs++heap_expand (sp - heap_length hs)++hb)` - (recInduct (theorem"v_inv_ind") \\ rw [v_inv_def] + v_inv conf v (x,f,ha++hs++heap_expand (sp - heap_length hs)++hb) +Proof + recInduct (theorem"v_inv_ind") \\ rw [v_inv_def] \\ unlength_tac [heap_lookup_APPEND, heap_length_APPEND, heap_expand_def] \\ fs [case_eq_thms] \\ Cases_on `sp` \\ fs [] @@ -1530,19 +1613,22 @@ Theorem v_inv_lemma \\ simp [EL_MEM] \\ rpt (disch_then drule \\ fs [])) \\ unlength_tac [] - \\ rpt (AP_THM_TAC ORELSE AP_TERM_TAC) \\ fs []); + \\ rpt (AP_THM_TAC ORELSE AP_TERM_TAC) \\ fs [] +QED -Theorem v_inv_LIST_REL - `!l1 l2. +Theorem v_inv_LIST_REL: + !l1 l2. 0 < heap_length hs /\ heap_length hs <= sp /\ LIST_REL (\z y. v_inv conf y (z, f, ha ++ heap_expand sp ++ hb)) l1 l2 ==> LIST_REL (\z y. v_inv conf y - (z, f, ha ++ hs ++ heap_expand (sp - heap_length hs) ++ hb)) l1 l2` - (rw [LIST_REL_EL_EQN] - \\ metis_tac [v_inv_lemma]); + (z, f, ha ++ hs ++ heap_expand (sp - heap_length hs) ++ hb)) l1 l2 +Proof + rw [LIST_REL_EL_EQN] + \\ metis_tac [v_inv_lemma] +QED val v_inv_list_to_v_alt_lem = Q.prove ( `!rs xs t rt ha hb sp. @@ -1630,8 +1716,8 @@ val v_inv_list_to_v_alt_lem = Q.prove ( val v_inv_list_to_v_alt = save_thm ("v_inv_list_to_v_alt", SIMP_RULE (srw_ss()) [LET_THM] v_inv_list_to_v_alt_lem); -Theorem cons_multi_thm - `abs_ml_inv conf (t::xs ++ stack) refs (roots,heap,be,a,sp,sp1,gens) limit /\ +Theorem cons_multi_thm: + abs_ml_inv conf (t::xs ++ stack) refs (roots,heap,be,a,sp,sp1,gens) limit /\ 3 * LENGTH xs <= sp /\ xs <> [] ==> ?rt rs roots2 heap1 heap2. let Allocd = list_to_BlockReps conf rt a rs in @@ -1644,8 +1730,9 @@ Theorem cons_multi_thm heap1 ++ Allocd ++ heap_expand (sp + sp1 - heap_length Allocd) ++ heap2, be, - a + heap_length Allocd, sp - heap_length Allocd, sp1, gens) limit` - (rw [abs_ml_inv_def] + a + heap_length Allocd, sp - heap_length Allocd, sp1, gens) limit +Proof + rw [abs_ml_inv_def] \\ qpat_x_assum `bc_stack_ref_inv _ _ _ _` mp_tac \\ simp [Once bc_stack_ref_inv_def] \\ strip_tac \\ imp_res_tac LIST_REL_SPLIT1 \\ rw [] @@ -1816,10 +1903,11 @@ Theorem cons_multi_thm \\ pop_assum (fn th => fs [th]) \\ qunabbrev_tac `Allocd` \\ match_mp_tac (Q.INST [`sp`|->`sp+sp1`] (SPEC_ALL v_inv_list_to_v_alt)) - \\ unlength_tac [heap_expand_def]); + \\ unlength_tac [heap_expand_def] +QED -Theorem cons_thm_alt - `abs_ml_inv conf (xs ++ stack) refs (roots,heap,be,a,sp,sp1,gens) limit /\ +Theorem cons_thm_alt: + abs_ml_inv conf (xs ++ stack) refs (roots,heap,be,a,sp,sp1,gens) limit /\ LENGTH xs < sp /\ xs <> [] ==> ?rs roots2 heap2. (roots = rs ++ roots2) /\ (LENGTH rs = LENGTH xs) /\ @@ -1828,8 +1916,9 @@ Theorem cons_thm_alt ((Block ts tag xs)::stack) refs (Pointer a (Word (ptr_bits conf tag (LENGTH xs)))::roots2, heap2,be,a+el_length (BlockRep tag rs), - sp-el_length (BlockRep tag rs),sp1,gens) limit` - (simp_tac std_ss [abs_ml_inv_def] + sp-el_length (BlockRep tag rs),sp1,gens) limit +Proof + simp_tac std_ss [abs_ml_inv_def] \\ rpt strip_tac \\ full_simp_tac std_ss [bc_stack_ref_inv_def,LIST_REL_def] \\ imp_res_tac LIST_REL_SPLIT1 \\ full_simp_tac std_ss [] \\ Q.LIST_EXISTS_TAC [`ys1`,`ys2`] \\ full_simp_tac std_ss [] @@ -1905,14 +1994,16 @@ Theorem cons_thm_alt \\ rpt strip_tac \\ res_tac \\ imp_res_tac v_inv_SUBMAP \\ `f SUBMAP f` by full_simp_tac std_ss [SUBMAP_REFL] \\ res_tac) \\ fs[Bytes_def,LET_THM] >> imp_res_tac heap_store_rel_lemma - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem cons_thm_EMPTY - `abs_ml_inv conf stack refs (roots,heap:'a ml_heap,be,a,sp,sp1,gens) limit /\ +Theorem cons_thm_EMPTY: + abs_ml_inv conf stack refs (roots,heap:'a ml_heap,be,a,sp,sp1,gens) limit /\ tag < dimword (:'a) DIV 16 ==> abs_ml_inv conf ((Block 0 tag [])::stack) refs - (Data (Word (BlockNil tag))::roots,heap,be,a,sp,sp1,gens) limit` - (simp_tac std_ss [abs_ml_inv_def] \\ rpt strip_tac + (Data (Word (BlockNil tag))::roots,heap,be,a,sp,sp1,gens) limit +Proof + simp_tac std_ss [abs_ml_inv_def] \\ rpt strip_tac \\ full_simp_tac std_ss [bc_stack_ref_inv_def,LIST_REL_def] \\ full_simp_tac (srw_ss()) [roots_ok_def,MEM] THEN1 (rw [] \\ fs [] \\ res_tac \\ fs []) @@ -1921,12 +2012,13 @@ Theorem cons_thm_EMPTY \\ rpt strip_tac \\ sg `reachable_refs stack refs n` \\ res_tac \\ full_simp_tac std_ss [reachable_refs_def] \\ Cases_on `x = Block 0 tag []` \\ full_simp_tac std_ss [] - \\ full_simp_tac (srw_ss()) [get_refs_def] \\ metis_tac []); + \\ full_simp_tac (srw_ss()) [get_refs_def] \\ metis_tac [] +QED (* word64 *) -Theorem word64_alt_thm - `abs_ml_inv conf (ws ++ stack) refs (rs ++ roots,heap,be,a,sp,sp1,gens) limit ∧ +Theorem word64_alt_thm: + abs_ml_inv conf (ws ++ stack) refs (rs ++ roots,heap,be,a,sp,sp1,gens) limit ∧ LENGTH ws = LENGTH rs ∧ (Word64Rep (:'a) w64 :'a ml_el) = DataElement [] len (Word64Tag,xs) ∧ LENGTH xs < sp @@ -1935,8 +2027,9 @@ Theorem word64_alt_thm heap_store_unused_alt a (sp + sp1) (Word64Rep (:'a) w64) heap = (heap2,T) ∧ abs_ml_inv conf (Word64 w64::stack) refs (Pointer a (Word 0w)::roots,heap2, - be,a + len + 1,sp - len - 1,sp1,gens) limit` - (rw[abs_ml_inv_def] + be,a + len + 1,sp - len - 1,sp1,gens) limit +Proof + rw[abs_ml_inv_def] \\ qpat_abbrev_tac`wr = DataElement _ _ _` \\ `el_length wr = len + 1` by ( fs[Abbr`wr`,Word64Rep_def] \\ rw[] \\ fs[el_length_def]) @@ -2019,20 +2112,22 @@ Theorem word64_alt_thm \\ first_assum(part_match_exists_tac(last o strip_conj) o concl) \\ simp[FORALL_PROD] \\ rw[] \\ match_mp_tac v_inv_SUBMAP - \\ simp[]); + \\ simp[] +QED (* bignum *) -Theorem bignum_alt_thm - `abs_ml_inv conf (ws ++ stack) refs (rs ++ roots,heap,be,a,sp,sp1,gens) limit ∧ +Theorem bignum_alt_thm: + abs_ml_inv conf (ws ++ stack) refs (rs ++ roots,heap,be,a,sp,sp1,gens) limit ∧ LENGTH ws = LENGTH rs ∧ ¬small_int (:α) i ∧ (Bignum i :α ml_el) = DataElement [] len (tag,xs) ∧ LENGTH xs < sp ⇒ ∃heap2. heap_store_unused_alt a (sp+sp1) (Bignum i) heap = (heap2,T) ∧ abs_ml_inv conf (Number i::stack) refs - (Pointer a (Word (0w:α word))::roots,heap2,be,a+len+1,sp-len-1,sp1,gens) limit` - (rw[abs_ml_inv_def] + (Pointer a (Word (0w:α word))::roots,heap2,be,a+len+1,sp-len-1,sp1,gens) limit +Proof + rw[abs_ml_inv_def] \\ qmatch_assum_abbrev_tac`br = DataElement _ _ _` \\ `el_length br = len + 1` by (fs[Bignum_def,Abbr`br`] \\ pairarg_tac \\ rw[] \\ fs[el_length_def]) @@ -2117,7 +2212,8 @@ Theorem bignum_alt_thm \\ first_assum(part_match_exists_tac(last o strip_conj) o concl) \\ simp[FORALL_PROD] \\ rw[] \\ match_mp_tac v_inv_SUBMAP - \\ simp[]); + \\ simp[] +QED (* update ref *) @@ -2202,16 +2298,18 @@ val RefBlock_inv_def = Define ` (!n x. (heap_lookup n heap2 = SOME x) /\ ~(isRefBlock x) ==> (heap_lookup n heap = SOME x))`; -Theorem heap_store_RefBlock_thm - `!ha. (LENGTH x = LENGTH y) ==> +Theorem heap_store_RefBlock_thm: + !ha. (LENGTH x = LENGTH y) ==> (heap_store (heap_length ha) [RefBlock x] (ha ++ RefBlock y::hb) = - (ha ++ RefBlock x::hb,T))` - (Induct \\ full_simp_tac (srw_ss()) [heap_store_def,heap_length_def] + (ha ++ RefBlock x::hb,T)) +Proof + Induct \\ full_simp_tac (srw_ss()) [heap_store_def,heap_length_def] THEN1 full_simp_tac std_ss [RefBlock_def,el_length_def] \\ strip_tac \\ rpt strip_tac \\ full_simp_tac std_ss [] \\ `~(el_length h + SUM (MAP el_length ha) < el_length h) /\ el_length h <> 0` by (Cases_on `h` \\ full_simp_tac std_ss [el_length_def] \\ DECIDE_TAC) - \\ full_simp_tac std_ss [LET_DEF]); + \\ full_simp_tac std_ss [LET_DEF] +QED val heap_lookup_RefBlock_lemma = Q.prove( `(heap_lookup n (ha ++ RefBlock y::hb) = SOME x) = @@ -2345,11 +2443,12 @@ val heap_lookup_heap_split = prove( \\ rveq \\ fs [] \\ rfs [] \\ every_case_tac \\ fs [] \\ rveq \\ fs []); -Theorem heap_store_heap_lookup - `!heap heap2 a x n. +Theorem heap_store_heap_lookup: + !heap heap2 a x n. heap_store a x heap = (heap2,T) /\ n < a ==> - heap_lookup n heap = heap_lookup n heap2` - (Induct THEN1 fs [heap_lookup_def,heap_store_def] + heap_lookup n heap = heap_lookup n heap2 +Proof + Induct THEN1 fs [heap_lookup_def,heap_store_def] \\ simp [heap_store_def] \\ rpt strip_tac \\ every_case_tac \\ fs [] \\ pairarg_tac \\ fs [] \\ rveq \\ fs [] @@ -2358,7 +2457,8 @@ Theorem heap_store_heap_lookup \\ IF_CASES_TAC \\ fs [] \\ rpt strip_tac \\ first_x_assum match_mp_tac - \\ asm_exists_tac \\ fs []); + \\ asm_exists_tac \\ fs [] +QED val update_ref_gen_state_ok = prove( ``heap_store b [RefBlock t1] heap = (heap2,T) /\ a <= b /\ @@ -2382,11 +2482,12 @@ val data_up_to_alt = prove( \\ rpt (CASE_TAC \\ fs []) \\ rw [] \\ eq_tac \\ rw []); -Theorem data_up_to_heap_store - `!heap a b heap2 y. +Theorem data_up_to_heap_store: + !heap a b heap2 y. data_up_to a heap /\ heap_store b [y] heap = (heap2,T) /\ - isDataElement y ==> data_up_to a heap2` - (Induct \\ fs [heap_store_def] + isDataElement y ==> data_up_to a heap2 +Proof + Induct \\ fs [heap_store_def] \\ rpt gen_tac \\ fs [data_up_to_alt] \\ Cases_on `a = 0` \\ fs [] THEN1 (fs [data_up_to_def]) @@ -2398,18 +2499,20 @@ Theorem data_up_to_heap_store \\ strip_tac \\ rveq \\ fs [] \\ fs [data_up_to_alt,heap_length_def] \\ first_x_assum match_mp_tac \\ fs [] - \\ asm_exists_tac \\ fs []); + \\ asm_exists_tac \\ fs [] +QED -Theorem update_ref_thm - `abs_ml_inv conf (xs ++ (RefPtr ptr)::stack) refs +Theorem update_ref_thm: + abs_ml_inv conf (xs ++ (RefPtr ptr)::stack) refs (roots,heap,be,a,sp,sp1,gens) limit /\ (FLOOKUP refs ptr = SOME (ValueArray xs1)) /\ (LENGTH xs = LENGTH xs1) ==> ?p rs roots2 heap2 u. (roots = rs ++ Pointer p u :: roots2) /\ (heap_store p [RefBlock rs] heap = (heap2,T)) /\ abs_ml_inv conf (xs ++ (RefPtr ptr)::stack) (refs |+ (ptr,ValueArray xs)) - (roots,heap2,be,a,sp,sp1,gens) limit` - (simp_tac std_ss [abs_ml_inv_def] + (roots,heap2,be,a,sp,sp1,gens) limit +Proof + simp_tac std_ss [abs_ml_inv_def] \\ rpt strip_tac \\ full_simp_tac std_ss [bc_stack_ref_inv_def] \\ imp_res_tac EVERY2_APPEND_CONS \\ full_simp_tac std_ss [v_inv_def] @@ -2481,7 +2584,8 @@ Theorem update_ref_thm \\ Cases_on `FLOOKUP refs n` \\ full_simp_tac (srw_ss()) [] \\ full_simp_tac (srw_ss()) [FLOOKUP_DEF,FAPPLY_FUPDATE_THM] \\ rw [] \\ Cases_on `refs ' n` \\ full_simp_tac (srw_ss()) [] - \\ full_simp_tac (srw_ss()) [INJ_DEF] \\ metis_tac []) + \\ full_simp_tac (srw_ss()) [INJ_DEF] \\ metis_tac [] +QED val heap_deref_def = Define ` (heap_deref a heap = @@ -2489,8 +2593,8 @@ val heap_deref_def = Define ` | SOME (DataElement xs l (RefTag,[])) => SOME xs | _ => NONE)`; -Theorem update_ref_thm1 - `abs_ml_inv conf (xs ++ RefPtr ptr::stack) refs +Theorem update_ref_thm1: + abs_ml_inv conf (xs ++ RefPtr ptr::stack) refs (roots,heap,be,a,sp,sp1,gens) limit /\ (FLOOKUP refs ptr = SOME (ValueArray xs1)) /\ i < LENGTH xs1 /\ 0 < LENGTH xs ==> @@ -2500,8 +2604,9 @@ Theorem update_ref_thm1 (heap_store p [RefBlock (LUPDATE (HD rs) i vs1)] heap = (heap2,T)) /\ abs_ml_inv conf (xs ++ (RefPtr ptr)::stack) (refs |+ (ptr,ValueArray (LUPDATE (HD xs) i xs1))) - (roots,heap2,be,a,sp,sp1,gens) limit` - (simp_tac std_ss [abs_ml_inv_def] + (roots,heap2,be,a,sp,sp1,gens) limit +Proof + simp_tac std_ss [abs_ml_inv_def] \\ rpt strip_tac \\ full_simp_tac std_ss [bc_stack_ref_inv_def] \\ imp_res_tac EVERY2_APPEND_CONS \\ full_simp_tac std_ss [v_inv_def] @@ -2588,13 +2693,16 @@ Theorem update_ref_thm1 \\ Cases_on `FLOOKUP refs n` \\ full_simp_tac (srw_ss()) [] \\ full_simp_tac (srw_ss()) [FLOOKUP_DEF,FAPPLY_FUPDATE_THM] \\ rw [] \\ Cases_on `refs ' n` \\ full_simp_tac (srw_ss()) [] - \\ full_simp_tac (srw_ss()) [INJ_DEF] \\ metis_tac []) + \\ full_simp_tac (srw_ss()) [INJ_DEF] \\ metis_tac [] +QED (* update byte ref *) -Theorem LENGTH_write_bytes[simp] - `!ws bs be. LENGTH (write_bytes bs ws be) = LENGTH ws` - (Induct \\ fs [write_bytes_def]); +Theorem LENGTH_write_bytes[simp]: + !ws bs be. LENGTH (write_bytes bs ws be) = LENGTH ws +Proof + Induct \\ fs [write_bytes_def] +QED val LIST_REL_IMP_LIST_REL = Q.prove( `!xs ys. @@ -2670,16 +2778,17 @@ val unused_space_inv_byte_update = prove( \\ fs [data_up_to_alt,el_length_def,Bytes_def] \\ rpt gen_tac \\ Cases_on `a = 0` \\ fs []); -Theorem update_byte_ref_thm - `abs_ml_inv conf ((RefPtr ptr)::stack) refs (roots,heap,be,a,sp,sp1,gens) limit /\ +Theorem update_byte_ref_thm: + abs_ml_inv conf ((RefPtr ptr)::stack) refs (roots,heap,be,a,sp,sp1,gens) limit /\ (FLOOKUP refs ptr = SOME (ByteArray fl xs)) /\ (LENGTH xs = LENGTH ys) ==> ?roots2 h1 h2 ws. (roots = Pointer (heap_length h1) ((Word 0w):'a word_loc) :: roots2) /\ heap = h1 ++ [Bytes be fl xs ws] ++ h2 /\ (* LENGTH ws = LENGTH xs DIV (dimindex (:α) DIV 8) + 1 /\ *) abs_ml_inv conf ((RefPtr ptr)::stack) (refs |+ (ptr,ByteArray fl ys)) - (roots,h1 ++ [Bytes be fl ys ws] ++ h2,be,a,sp,sp1,gens) limit` - (simp_tac std_ss [abs_ml_inv_def] + (roots,h1 ++ [Bytes be fl ys ws] ++ h2,be,a,sp,sp1,gens) limit +Proof + simp_tac std_ss [abs_ml_inv_def] \\ rpt strip_tac \\ full_simp_tac std_ss [bc_stack_ref_inv_def] \\ Cases_on `roots` \\ fs [v_inv_def] \\ rpt var_eq_tac \\ fs [] \\ `reachable_refs (RefPtr ptr::stack) refs ptr` by @@ -2765,7 +2874,8 @@ Theorem update_byte_ref_thm THEN1 (fs [INJ_DEF,FLOOKUP_DEF] \\ metis_tac []) \\ fs [heap_lookup_APPEND,Bytes_def,heap_length_def,el_length_def,SUM_APPEND] \\ rfs [] \\ rw [] \\ fs [] \\ rfs [heap_lookup_def] - \\ metis_tac[]) + \\ metis_tac[] +QED val heap_store_unused_thm = prove( ``!a n heap h1 h2 heap2 x. @@ -2791,11 +2901,12 @@ val heap_store_unused_thm = prove( \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,APPEND] \\ fs [heap_store_lemma]); -Theorem heap_store_unused_heap_lookup - `!heap heap2 a k x n. +Theorem heap_store_unused_heap_lookup: + !heap heap2 a k x n. heap_store_unused a k x heap = (heap2,T) /\ n < a ==> - heap_lookup n heap = heap_lookup n heap2` - (Induct THEN1 fs [heap_lookup_def,heap_store_unused_def] + heap_lookup n heap = heap_lookup n heap2 +Proof + Induct THEN1 fs [heap_lookup_def,heap_store_unused_def] \\ simp [heap_store_unused_def] \\ rpt strip_tac \\ every_case_tac \\ fs [] \\ ntac 4 (pop_assum mp_tac) @@ -2810,7 +2921,8 @@ Theorem heap_store_unused_heap_lookup \\ rpt strip_tac \\ first_x_assum match_mp_tac \\ fs [heap_store_unused_def] - \\ qexists_tac `(a − el_length h)` \\ fs [] \\ metis_tac []); + \\ qexists_tac `(a − el_length h)` \\ fs [] \\ metis_tac [] +QED val heap_store_unused_gen_state_ok = prove( ``heap_store_unused a k x heap = (heap2,T) /\ @@ -2829,16 +2941,17 @@ val heap_store_unused_gen_state_ok = prove( (* new ref *) -Theorem new_ref_thm - `abs_ml_inv conf (xs ++ stack) refs (roots,heap,be,a,sp,sp1,gens) limit /\ +Theorem new_ref_thm: + abs_ml_inv conf (xs ++ stack) refs (roots,heap,be,a,sp,sp1,gens) limit /\ ~(ptr IN FDOM refs) /\ LENGTH xs + 1 <= sp ==> ?p rs roots2 heap2. (roots = rs ++ roots2) /\ LENGTH rs = LENGTH xs /\ (heap_store_unused a (sp+sp1) (RefBlock rs) heap = (heap2,T)) /\ abs_ml_inv conf (xs ++ (RefPtr ptr)::stack) (refs |+ (ptr,ValueArray xs)) (rs ++ Pointer (a+sp+sp1-(LENGTH xs + 1)) (Word 0w)::roots2,heap2,be,a, - sp - (LENGTH xs + 1),sp1,gens) limit` - (simp_tac std_ss [abs_ml_inv_def] + sp - (LENGTH xs + 1),sp1,gens) limit +Proof + simp_tac std_ss [abs_ml_inv_def] \\ rpt strip_tac \\ full_simp_tac std_ss [bc_stack_ref_inv_def] \\ imp_res_tac EVERY2_APPEND_IMP_APPEND \\ full_simp_tac (srw_ss()) [] @@ -2956,7 +3069,8 @@ Theorem new_ref_thm \\ full_simp_tac std_ss [] \\ simp_tac (srw_ss()) [] \\ rpt strip_tac \\ match_mp_tac v_inv_SUBMAP - \\ full_simp_tac (srw_ss()) []); + \\ full_simp_tac (srw_ss()) [] +QED (* deref *) @@ -2968,8 +3082,8 @@ val heap_el_def = Define ` | _ => (ARB,F)) /\ (heap_el _ _ _ = (ARB,F))`; -Theorem deref_thm - `abs_ml_inv conf (RefPtr ptr::stack) refs (roots,heap,be,a,sp,sp1,gens) limit ==> +Theorem deref_thm: + abs_ml_inv conf (RefPtr ptr::stack) refs (roots,heap,be,a,sp,sp1,gens) limit ==> ?r roots2. (roots = r::roots2) /\ ptr IN FDOM refs /\ case refs ' ptr of @@ -2978,8 +3092,9 @@ Theorem deref_thm !n. n < LENGTH ts ==> ?y. (heap_el r n heap = (y,T)) /\ abs_ml_inv conf (EL n ts::RefPtr ptr::stack) refs - (y::roots,heap,be,a,sp,sp1,gens) limit` - (full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def] + (y::roots,heap,be,a,sp,sp1,gens) limit +Proof + full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def] \\ rpt strip_tac \\ Cases_on `roots` \\ full_simp_tac (srw_ss()) [LIST_REL_def] \\ full_simp_tac std_ss [v_inv_def] \\ `reachable_refs (RefPtr ptr::stack) refs ptr` by @@ -3017,18 +3132,20 @@ Theorem deref_thm \\ full_simp_tac (srw_ss()) [ref_edge_def,FLOOKUP_DEF,get_refs_def] \\ full_simp_tac (srw_ss()) [MEM_FLAT,MEM_MAP,PULL_EXISTS] \\ qexists_tac `(EL n l)` \\ full_simp_tac std_ss [] - \\ full_simp_tac std_ss [MEM_EL] \\ metis_tac []); + \\ full_simp_tac std_ss [MEM_EL] \\ metis_tac [] +QED (* el *) -Theorem el_thm - `abs_ml_inv conf (Block ts n xs::stack) refs (roots,heap,be,a,sp,sp1,gens) limit /\ +Theorem el_thm: + abs_ml_inv conf (Block ts n xs::stack) refs (roots,heap,be,a,sp,sp1,gens) limit /\ i < LENGTH xs ==> ?r roots2 y. (roots = r :: roots2) /\ (heap_el r i heap = (y,T)) /\ abs_ml_inv conf (EL i xs::Block ts n xs::stack) refs - (y::roots,heap,be,a,sp,sp1,gens) limit` - (full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def] + (y::roots,heap,be,a,sp,sp1,gens) limit +Proof + full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def] \\ rpt strip_tac \\ Cases_on `roots` \\ full_simp_tac (srw_ss()) [LIST_REL_def] \\ full_simp_tac std_ss [v_inv_def] \\ `xs <> []` by (rpt strip_tac \\ full_simp_tac std_ss [GSYM LENGTH_NIL,LENGTH]) @@ -3055,12 +3172,13 @@ Theorem el_thm \\ full_simp_tac std_ss [get_refs_def,MEM_FLAT,MEM_MAP,PULL_EXISTS] \\ qexists_tac `EL i xs` \\ full_simp_tac std_ss [] \\ full_simp_tac std_ss [MEM_EL] \\ qexists_tac `i` - \\ full_simp_tac std_ss []); + \\ full_simp_tac std_ss [] +QED (* new byte array *) -Theorem new_byte_alt_thm - `abs_ml_inv conf stack refs (roots,heap,be,a,sp,sp1,gens) limit /\ +Theorem new_byte_alt_thm: + abs_ml_inv conf stack refs (roots,heap,be,a,sp,sp1,gens) limit /\ LENGTH bs ≤ ws * (dimindex (:α) DIV 8) ∧ ws ≤ LENGTH bs DIV (dimindex (:α) DIV 8) + 1 /\ ~(ptr IN FDOM refs) /\ ws + 1 <= sp ==> @@ -3069,8 +3187,9 @@ Theorem new_byte_alt_thm (Bytes be fl bs (REPLICATE ws (0w:'a word))) heap = (heap2,T)) /\ abs_ml_inv conf ((RefPtr ptr)::stack) (refs |+ (ptr,ByteArray fl bs)) (Pointer a (Word 0w)::roots,heap2,be,a + ws + 1, - sp - (ws + 1),sp1,gens) limit` - (simp_tac std_ss [abs_ml_inv_def] + sp - (ws + 1),sp1,gens) limit +Proof + simp_tac std_ss [abs_ml_inv_def] \\ rpt strip_tac \\ full_simp_tac std_ss [bc_stack_ref_inv_def] \\ imp_res_tac EVERY2_APPEND_IMP_APPEND \\ full_simp_tac (srw_ss()) [] @@ -3171,15 +3290,17 @@ Theorem new_byte_alt_thm \\ rpt strip_tac \\ match_mp_tac v_inv_SUBMAP \\ fs [heap_store_rel_def,isSomeDataElement_def,PULL_EXISTS]) - \\ metis_tac []); + \\ metis_tac [] +QED (* pop *) -Theorem pop_thm - `abs_ml_inv conf (xs ++ stack) refs (rs ++ roots,heap,be,a,sp,sp1,gens) limit /\ +Theorem pop_thm: + abs_ml_inv conf (xs ++ stack) refs (rs ++ roots,heap,be,a,sp,sp1,gens) limit /\ (LENGTH xs = LENGTH rs) ==> - abs_ml_inv conf (stack) refs (roots,heap,be,a,sp,sp1,gens) limit` - (full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def] \\ rpt strip_tac + abs_ml_inv conf (stack) refs (roots,heap,be,a,sp,sp1,gens) limit +Proof + full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def] \\ rpt strip_tac \\ full_simp_tac std_ss [roots_ok_def,MEM_APPEND] THEN1 (rw [] \\ res_tac \\ fs []) \\ qexists_tac `f` \\ full_simp_tac std_ss [] @@ -3187,66 +3308,78 @@ Theorem pop_thm \\ imp_res_tac LIST_REL_LENGTH \\ fs[APPEND_EQ_APPEND] \\ rveq \\ fs[] \\ rveq \\ rfs[] \\ rveq \\ fs[] - \\ full_simp_tac std_ss [reachable_refs_def,MEM_APPEND] \\ metis_tac []); + \\ full_simp_tac std_ss [reachable_refs_def,MEM_APPEND] \\ metis_tac [] +QED (* equality *) -Theorem ref_eq_thm - `abs_ml_inv conf (RefPtr p1::RefPtr p2::stack) refs +Theorem ref_eq_thm: + abs_ml_inv conf (RefPtr p1::RefPtr p2::stack) refs (r1::r2::roots,heap,be,a,sp,sp1,gens) limit ==> ((p1 = p2) <=> (r1 = r2)) /\ - ?p1 p2. r1 = Pointer p1 (Word 0w) /\ r2 = Pointer p2 (Word 0w)` - (full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def] \\ rpt strip_tac + ?p1 p2. r1 = Pointer p1 (Word 0w) /\ r2 = Pointer p2 (Word 0w) +Proof + full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def] \\ rpt strip_tac \\ fs [v_inv_def,INJ_DEF] \\ res_tac \\ fs [] \\ fs [] - \\ eq_tac \\ rw [] \\ fs []); + \\ eq_tac \\ rw [] \\ fs [] +QED -Theorem num_eq_thm - `abs_ml_inv conf (Number i1::Number i2::stack) refs +Theorem num_eq_thm: + abs_ml_inv conf (Number i1::Number i2::stack) refs (r1::r2::roots,heap,be,a,sp,sp1,gens) limit /\ small_int (:'a) i1 /\ small_int (:'a) i2 ==> ((i1 = i2) <=> (r1 = r2)) /\ r1 = Data (Word (Smallnum i1:'a word)) /\ - r2 = Data (Word (Smallnum i2))` - (full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def] \\ rpt strip_tac + r2 = Data (Word (Smallnum i2)) +Proof + full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def] \\ rpt strip_tac \\ fs [v_inv_def,INJ_DEF] \\ fs [Smallnum_def] \\ Cases_on `i1` \\ Cases_on `i2` - \\ fs [small_int_def,X_LT_DIV,X_LE_DIV] \\ fs [word_2comp_n2w]); + \\ fs [small_int_def,X_LT_DIV,X_LE_DIV] \\ fs [word_2comp_n2w] +QED -Theorem Smallnum_i2w - `Smallnum i = i2w (4 * i)` - (fs [Smallnum_def,integer_wordTheory.i2w_def] +Theorem Smallnum_i2w: + Smallnum i = i2w (4 * i) +Proof + fs [Smallnum_def,integer_wordTheory.i2w_def] \\ Cases_on `i` \\ fs [] \\ reverse IF_CASES_TAC \\ fs [WORD_EQ_NEG] THEN1 (`F` by intLib.COOPER_TAC) - \\ AP_THM_TAC \\ AP_TERM_TAC \\ intLib.COOPER_TAC); - -Theorem small_int_IMP_MIN_MAX - `good_dimindex (:'a) /\ small_int (:'a) i ==> - INT_MIN (:'a) <= 4 * i ∧ 4 * i <= INT_MAX (:'a)` - (fs [labPropsTheory.good_dimindex_def] \\ rw [] + \\ AP_THM_TAC \\ AP_TERM_TAC \\ intLib.COOPER_TAC +QED + +Theorem small_int_IMP_MIN_MAX: + good_dimindex (:'a) /\ small_int (:'a) i ==> + INT_MIN (:'a) <= 4 * i ∧ 4 * i <= INT_MAX (:'a) +Proof + fs [labPropsTheory.good_dimindex_def] \\ rw [] \\ rfs [small_int_def,dimword_def, wordsTheory.INT_MIN_def,wordsTheory.INT_MAX_def] - \\ intLib.COOPER_TAC); - -Theorem num_less_thm - `good_dimindex (:'a) /\ small_int (:'a) i1 /\ small_int (:'a) i2 ==> - ((i1 < i2) <=> (Smallnum i1 < Smallnum i2:'a word))` - (fs [integer_wordTheory.WORD_LTi,Smallnum_i2w] \\ strip_tac + \\ intLib.COOPER_TAC +QED + +Theorem num_less_thm: + good_dimindex (:'a) /\ small_int (:'a) i1 /\ small_int (:'a) i2 ==> + ((i1 < i2) <=> (Smallnum i1 < Smallnum i2:'a word)) +Proof + fs [integer_wordTheory.WORD_LTi,Smallnum_i2w] \\ strip_tac \\ imp_res_tac small_int_IMP_MIN_MAX \\ fs [integer_wordTheory.w2i_i2w] - \\ intLib.COOPER_TAC); + \\ intLib.COOPER_TAC +QED (* permute stack *) -Theorem abs_ml_inv_stack_permute - `!xs ys. +Theorem abs_ml_inv_stack_permute: + !xs ys. abs_ml_inv conf (MAP FST xs ++ stack) refs (MAP SND xs ++ roots,heap,be,a,sp,sp1,gens) limit /\ set ys SUBSET set xs ==> abs_ml_inv conf (MAP FST ys ++ stack) refs - (MAP SND ys ++ roots,heap,be,a,sp,sp1,gens) limit` - (full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def] \\ rpt strip_tac + (MAP SND ys ++ roots,heap,be,a,sp,sp1,gens) limit +Proof + full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def] \\ rpt strip_tac \\ full_simp_tac std_ss [roots_ok_def] THEN1 (full_simp_tac std_ss [MEM_APPEND,SUBSET_DEF,MEM_MAP] \\ metis_tac []) \\ qexists_tac `f` \\ full_simp_tac std_ss [] @@ -3254,20 +3387,23 @@ Theorem abs_ml_inv_stack_permute \\ full_simp_tac std_ss [EVERY2_MAP_FST_SND] \\ full_simp_tac std_ss [EVERY_MEM,SUBSET_DEF] \\ full_simp_tac std_ss [reachable_refs_def,MEM_APPEND,MEM_MAP] - \\ metis_tac []); + \\ metis_tac [] +QED (* duplicate *) -Theorem duplicate_thm - `abs_ml_inv conf (xs ++ stack) refs (rs ++ roots,heap,be,a,sp,sp1,gens) limit /\ +Theorem duplicate_thm: + abs_ml_inv conf (xs ++ stack) refs (rs ++ roots,heap,be,a,sp,sp1,gens) limit /\ (LENGTH xs = LENGTH rs) ==> - abs_ml_inv conf (xs ++ xs ++ stack) refs (rs ++ rs ++ roots,heap,be,a,sp,sp1,gens) limit` - (full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def] \\ rpt strip_tac + abs_ml_inv conf (xs ++ xs ++ stack) refs (rs ++ rs ++ roots,heap,be,a,sp,sp1,gens) limit +Proof + full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def] \\ rpt strip_tac \\ full_simp_tac std_ss [roots_ok_def] THEN1 metis_tac [MEM_APPEND] \\ qexists_tac `f` \\ full_simp_tac std_ss [] \\ imp_res_tac LIST_REL_APPEND_EQ \\ full_simp_tac std_ss [] \\ full_simp_tac std_ss [APPEND_ASSOC] - \\ full_simp_tac std_ss [reachable_refs_def,MEM_APPEND] \\ metis_tac []); + \\ full_simp_tac std_ss [reachable_refs_def,MEM_APPEND] \\ metis_tac [] +QED val duplicate1_thm = save_thm("duplicate1_thm", duplicate_thm |> Q.INST [`xs`|->`[x1]`,`rs`|->`[r1]`] @@ -3275,70 +3411,84 @@ val duplicate1_thm = save_thm("duplicate1_thm", (* move *) -Theorem move_thm - `!xs1 rs1 xs2 rs2 xs3 rs3. +Theorem move_thm: + !xs1 rs1 xs2 rs2 xs3 rs3. abs_ml_inv conf (xs1 ++ xs2 ++ xs3 ++ stack) refs (rs1 ++ rs2 ++ rs3 ++ roots,heap,be,a,sp,sp1,gens) limit /\ (LENGTH xs1 = LENGTH rs1) /\ (LENGTH xs2 = LENGTH rs2) /\ (LENGTH xs3 = LENGTH rs3) ==> abs_ml_inv conf (xs1 ++ xs3 ++ xs2 ++ stack) refs - (rs1 ++ rs3 ++ rs2 ++ roots,heap,be,a,sp,sp1,gens) limit` - (REPEAT GEN_TAC + (rs1 ++ rs3 ++ rs2 ++ roots,heap,be,a,sp,sp1,gens) limit +Proof + REPEAT GEN_TAC \\ full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def] \\ rpt strip_tac \\ full_simp_tac std_ss [roots_ok_def] THEN1 metis_tac [MEM_APPEND] \\ qexists_tac `f` \\ full_simp_tac std_ss [] \\ strip_tac THEN1 fs[LIST_REL_APPEND_EQ] - \\ full_simp_tac std_ss [reachable_refs_def,MEM_APPEND] \\ metis_tac []); + \\ full_simp_tac std_ss [reachable_refs_def,MEM_APPEND] \\ metis_tac [] +QED (* splits *) -Theorem split1_thm - `abs_ml_inv conf (xs1 ++ stack) refs (roots,heap,be,a,sp,sp1,gens) limit ==> - ?rs1 roots1. (roots = rs1 ++ roots1) /\ (LENGTH rs1 = LENGTH xs1)` - (full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def,GSYM APPEND_ASSOC] - \\ rpt strip_tac \\ NTAC 5 (imp_res_tac LIST_REL_SPLIT1 \\ imp_res_tac LIST_REL_LENGTH) \\ metis_tac []); +Theorem split1_thm: + abs_ml_inv conf (xs1 ++ stack) refs (roots,heap,be,a,sp,sp1,gens) limit ==> + ?rs1 roots1. (roots = rs1 ++ roots1) /\ (LENGTH rs1 = LENGTH xs1) +Proof + full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def,GSYM APPEND_ASSOC] + \\ rpt strip_tac \\ NTAC 5 (imp_res_tac LIST_REL_SPLIT1 \\ imp_res_tac LIST_REL_LENGTH) \\ metis_tac [] +QED -Theorem split2_thm - `abs_ml_inv conf (xs1 ++ xs2 ++ stack) refs (roots,heap,be,a,sp,sp1,gens) limit ==> +Theorem split2_thm: + abs_ml_inv conf (xs1 ++ xs2 ++ stack) refs (roots,heap,be,a,sp,sp1,gens) limit ==> ?rs1 rs2 roots1. (roots = rs1 ++ rs2 ++ roots1) /\ - (LENGTH rs1 = LENGTH xs1) /\ (LENGTH rs2 = LENGTH xs2)` - (full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def,GSYM APPEND_ASSOC] - \\ rpt strip_tac \\ NTAC 5 (imp_res_tac LIST_REL_SPLIT1 \\ imp_res_tac LIST_REL_LENGTH) \\ metis_tac []); - -Theorem split3_thm - `abs_ml_inv conf (xs1 ++ xs2 ++ xs3 ++ stack) refs (roots,heap,be,a,sp,sp1,gens) limit ==> + (LENGTH rs1 = LENGTH xs1) /\ (LENGTH rs2 = LENGTH xs2) +Proof + full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def,GSYM APPEND_ASSOC] + \\ rpt strip_tac \\ NTAC 5 (imp_res_tac LIST_REL_SPLIT1 \\ imp_res_tac LIST_REL_LENGTH) \\ metis_tac [] +QED + +Theorem split3_thm: + abs_ml_inv conf (xs1 ++ xs2 ++ xs3 ++ stack) refs (roots,heap,be,a,sp,sp1,gens) limit ==> ?rs1 rs2 rs3 roots1. (roots = rs1 ++ rs2 ++ rs3 ++ roots1) /\ (LENGTH rs1 = LENGTH xs1) /\ (LENGTH rs2 = LENGTH xs2) /\ - (LENGTH rs3 = LENGTH xs3)` - (full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def,GSYM APPEND_ASSOC] - \\ rpt strip_tac \\ NTAC 5 (imp_res_tac LIST_REL_SPLIT1 \\ imp_res_tac LIST_REL_LENGTH) \\ metis_tac []); - -Theorem abs_ml_inv_Num - `abs_ml_inv conf stack refs (roots,heap,be,a,sp,sp1,gens) limit /\ small_int (:α) i ==> + (LENGTH rs3 = LENGTH xs3) +Proof + full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def,GSYM APPEND_ASSOC] + \\ rpt strip_tac \\ NTAC 5 (imp_res_tac LIST_REL_SPLIT1 \\ imp_res_tac LIST_REL_LENGTH) \\ metis_tac [] +QED + +Theorem abs_ml_inv_Num: + abs_ml_inv conf stack refs (roots,heap,be,a,sp,sp1,gens) limit /\ small_int (:α) i ==> abs_ml_inv conf (Number i::stack) refs - (Data (Word ((Smallnum i):'a word))::roots,heap,be,a,sp,sp1,gens) limit` - (fs [abs_ml_inv_def,roots_ok_def,bc_stack_ref_inv_def,v_inv_def] + (Data (Word ((Smallnum i):'a word))::roots,heap,be,a,sp,sp1,gens) limit +Proof + fs [abs_ml_inv_def,roots_ok_def,bc_stack_ref_inv_def,v_inv_def] \\ fs [reachable_refs_def] \\ rw [] \\ fs [] \\ res_tac \\ fs [] \\ qexists_tac `f` \\ fs [] - \\ rw [] \\ fs [get_refs_def] \\ metis_tac []); - -Theorem heap_store_unused_IMP_length - `heap_store_unused a sp' x heap = (heap2,T) ==> - heap_length heap2 = heap_length heap` - (fs [heap_store_unused_def] \\ IF_CASES_TAC \\ fs [] + \\ rw [] \\ fs [get_refs_def] \\ metis_tac [] +QED + +Theorem heap_store_unused_IMP_length: + heap_store_unused a sp' x heap = (heap2,T) ==> + heap_length heap2 = heap_length heap +Proof + fs [heap_store_unused_def] \\ IF_CASES_TAC \\ fs [] \\ imp_res_tac heap_lookup_SPLIT \\ fs [] \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,APPEND,heap_store_lemma] - \\ rw [] \\ fs [] \\ fs [heap_length_APPEND,el_length_def,heap_length_def]); - -Theorem heap_store_unused_alt_IMP_length - `heap_store_unused_alt a sp' x heap = (heap2,T) ==> - heap_length heap2 = heap_length heap` - (fs [heap_store_unused_alt_def] \\ IF_CASES_TAC \\ fs [] + \\ rw [] \\ fs [] \\ fs [heap_length_APPEND,el_length_def,heap_length_def] +QED + +Theorem heap_store_unused_alt_IMP_length: + heap_store_unused_alt a sp' x heap = (heap2,T) ==> + heap_length heap2 = heap_length heap +Proof + fs [heap_store_unused_alt_def] \\ IF_CASES_TAC \\ fs [] \\ imp_res_tac heap_lookup_SPLIT \\ fs [] \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,APPEND,heap_store_lemma] - \\ rw [] \\ fs [] \\ fs [heap_length_APPEND,el_length_def,heap_length_def]); + \\ rw [] \\ fs [] \\ fs [heap_length_APPEND,el_length_def,heap_length_def] +QED (* ------------------------------------------------------- @@ -3415,18 +3565,20 @@ val word_payload_def = Define ` let k = if dimindex(:'a) = 32 then 2 else 3 in n + (2 ** k - 1) < 2 ** (conf.len_size + k)))`; -Theorem word_payload_T_IMP - `word_payload l5 n5 tag r conf = (h:'a word,ts,T) /\ +Theorem word_payload_T_IMP: + word_payload l5 n5 tag r conf = (h:'a word,ts,T) /\ good_dimindex (:'a) /\ conf.len_size + 2 < dimindex (:'a) ==> n5 = LENGTH ts /\ - if word_bit 2 h then l5 = [] else ts = MAP (word_addr conf) l5` - (Cases_on `tag` + if word_bit 2 h then l5 = [] else ts = MAP (word_addr conf) l5 +Proof + Cases_on `tag` \\ full_simp_tac(srw_ss())[word_payload_def,make_header_def, make_byte_header_def,LET_THM] \\ rw [] \\ fs [] \\ fs [word_bit_def] \\ rfs [word_or_def,fcpTheory.FCP_BETA,word_lsl_def,wordsTheory.word_index] \\ fs [labPropsTheory.good_dimindex_def,fcpTheory.FCP_BETA, - word_index] \\ rfs []); + word_index] \\ rfs [] +QED val word_el_def = Define ` (word_el a (Unused l) conf = word_list_exists (a:'a word) (l+1)) /\ @@ -3454,10 +3606,12 @@ val gen_starts_in_store_def = Define ` w = (bytes_in_word * n2w x)) /\ gen_starts_in_store c _ _ = F` -Theorem gen_starts_in_store_IMP - `gen_starts_in_store c gens x ==> ?w. x = SOME (Word w)` - (Cases_on `x` \\ Cases_on `gens` \\ fs [gen_starts_in_store_def] - \\ Cases_on `x'` \\ fs [gen_starts_in_store_def]); +Theorem gen_starts_in_store_IMP: + gen_starts_in_store c gens x ==> ?w. x = SOME (Word w) +Proof + Cases_on `x` \\ Cases_on `gens` \\ fs [gen_starts_in_store_def] + \\ Cases_on `x'` \\ fs [gen_starts_in_store_def] +QED val heap_in_memory_store_def = Define ` heap_in_memory_store heap a sp sp1 gens c s m dm limit <=> @@ -3484,9 +3638,11 @@ val word_ml_inv_def = Define ` ?hs. abs_ml_inv c (MAP FST stack) refs (hs,heap,be,a,sp,sp1,gens) limit /\ EVERY2 (\v w. word_addr c v = w) hs (MAP SND stack)` -Theorem IMP_THE_EQ - `x = SOME w ==> THE x = w` - (full_simp_tac(srw_ss())[]); +Theorem IMP_THE_EQ: + x = SOME w ==> THE x = w +Proof + full_simp_tac(srw_ss())[] +QED val memory_rel_def = Define ` memory_rel c be refs space st (m:'a word -> 'a word_loc) dm vars <=> @@ -3495,16 +3651,19 @@ val memory_rel_def = Define ` word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs vars ∧ (limit+3) * (dimindex (:α) DIV 8) + 1 < dimword (:α) ∧ space ≤ sp` -Theorem EVERY2_MAP_MAP - `!xs. EVERY2 P (MAP f xs) (MAP g xs) = EVERY (\x. P (f x) (g x)) xs` - (Induct \\ full_simp_tac(srw_ss())[]); +Theorem EVERY2_MAP_MAP: + !xs. EVERY2 P (MAP f xs) (MAP g xs) = EVERY (\x. P (f x) (g x)) xs +Proof + Induct \\ full_simp_tac(srw_ss())[] +QED -Theorem MEM_FIRST_EL - `!xs x. +Theorem MEM_FIRST_EL: + !xs x. MEM x xs <=> ?n. n < LENGTH xs /\ (EL n xs = x) /\ - !m. m < n ==> (EL m xs <> EL n xs)` - (srw_tac[][] \\ eq_tac + !m. m < n ==> (EL m xs <> EL n xs) +Proof + srw_tac[][] \\ eq_tac THEN1 (srw_tac[][] \\ qexists_tac `LEAST n. EL n xs = x /\ n < LENGTH xs` \\ mp_tac (Q.SPEC `\n. EL n xs = x /\ n < LENGTH xs` (GEN_ALL FULL_LEAST_INTRO)) \\ full_simp_tac(srw_ss())[MEM_EL] @@ -3512,26 +3671,30 @@ Theorem MEM_FIRST_EL \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ imp_res_tac LESS_LEAST \\ full_simp_tac(srw_ss())[] \\ `F` by decide_tac) \\ srw_tac[][] \\ full_simp_tac(srw_ss())[MEM_EL] - \\ qexists_tac `n` \\ full_simp_tac(srw_ss())[]); + \\ qexists_tac `n` \\ full_simp_tac(srw_ss())[] +QED -Theorem ALOOKUP_ZIP_EL - `!xs hs n. +Theorem ALOOKUP_ZIP_EL: + !xs hs n. n < LENGTH xs /\ LENGTH hs = LENGTH xs /\ (∀m. m < n ⇒ EL m xs ≠ EL n xs) ==> - ALOOKUP (ZIP (xs,hs)) (EL n xs) = SOME (EL n hs)` - (Induct \\ Cases_on `hs` \\ full_simp_tac(srw_ss())[] + ALOOKUP (ZIP (xs,hs)) (EL n xs) = SOME (EL n hs) +Proof + Induct \\ Cases_on `hs` \\ full_simp_tac(srw_ss())[] \\ Cases_on `n` \\ full_simp_tac(srw_ss())[] \\ rpt strip_tac \\ first_assum (qspec_then `0` assume_tac) \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ first_x_assum match_mp_tac \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] - \\ first_x_assum (qspec_then `SUC m` mp_tac) \\ full_simp_tac(srw_ss())[]); + \\ first_x_assum (qspec_then `SUC m` mp_tac) \\ full_simp_tac(srw_ss())[] +QED -Theorem word_ml_inv_rearrange - `(!x. MEM x ys ==> MEM x xs) ==> +Theorem word_ml_inv_rearrange: + (!x. MEM x ys ==> MEM x xs) ==> word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs xs ==> - word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs ys` - (full_simp_tac(srw_ss())[word_ml_inv_def] \\ srw_tac[][] + word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs ys +Proof + full_simp_tac(srw_ss())[word_ml_inv_def] \\ srw_tac[][] \\ qexists_tac `MAP (\y. THE (ALOOKUP (ZIP(xs,hs)) y)) ys` \\ full_simp_tac(srw_ss())[EVERY2_MAP_MAP,EVERY_MEM] \\ reverse (srw_tac[][]) @@ -3569,46 +3732,57 @@ Theorem word_ml_inv_rearrange \\ qexists_tac `n'` \\ rev_full_simp_tac(srw_ss())[EL_MAP] \\ match_mp_tac IMP_THE_EQ \\ qpat_x_assum `EL n' xs = (p_1,p_2')` (fn th => full_simp_tac(srw_ss())[GSYM th]) - \\ match_mp_tac ALOOKUP_ZIP_EL \\ full_simp_tac(srw_ss())[]); + \\ match_mp_tac ALOOKUP_ZIP_EL \\ full_simp_tac(srw_ss())[] +QED -Theorem memory_rel_rearrange - `(∀x. MEM x ys ⇒ MEM x xs) ⇒ +Theorem memory_rel_rearrange: + (∀x. MEM x ys ⇒ MEM x xs) ⇒ memory_rel c be refs sp st m dm xs ==> - memory_rel c be refs sp st m dm ys` - (fs [memory_rel_def] \\ rw [] \\ asm_exists_tac \\ fs [] + memory_rel c be refs sp st m dm ys +Proof + fs [memory_rel_def] \\ rw [] \\ asm_exists_tac \\ fs [] \\ qpat_x_assum `word_ml_inv _ _ _ _ _` mp_tac - \\ match_mp_tac word_ml_inv_rearrange \\ fs []); - -Theorem memory_rel_tl - `memory_rel c be refs sp st m dm (x::xs) ==> - memory_rel c be refs sp st m dm xs` - (match_mp_tac memory_rel_rearrange \\ fs []); - -Theorem word_ml_inv_Unit - `word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs ws /\ + \\ match_mp_tac word_ml_inv_rearrange \\ fs [] +QED + +Theorem memory_rel_tl: + memory_rel c be refs sp st m dm (x::xs) ==> + memory_rel c be refs sp st m dm xs +Proof + match_mp_tac memory_rel_rearrange \\ fs [] +QED + +Theorem word_ml_inv_Unit: + word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs ws /\ good_dimindex (:'a) ==> word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs - ((Unit,Word (2w:'a word))::ws)` - (fs [word_ml_inv_def,PULL_EXISTS] \\ rw [] + ((Unit,Word (2w:'a word))::ws) +Proof + fs [word_ml_inv_def,PULL_EXISTS] \\ rw [] \\ qexists_tac `Data (Word 2w)` \\ qexists_tac `hs` \\ fs [word_addr_def] \\ fs [dataSemTheory.Unit_def,EVAL ``tuple_tag``] \\ drule (GEN_ALL cons_thm_EMPTY) \\ disch_then (qspec_then `0` mp_tac) \\ fs [labPropsTheory.good_dimindex_def,dimword_def] - \\ fs [BlockNil_def]); - -Theorem memory_rel_Unit - `memory_rel c be refs sp st m dm xs /\ good_dimindex (:'a) ==> - memory_rel c be refs sp st m dm ((Unit,Word (2w:'a word))::xs)` - (fs [memory_rel_def] \\ rw [] \\ asm_exists_tac \\ fs [] - \\ match_mp_tac word_ml_inv_Unit \\ fs []); - -Theorem get_lowerbits_LSL_shift_length - `get_lowerbits conf a >>> shift_length conf = 0w` - (Cases_on `a` + \\ fs [BlockNil_def] +QED + +Theorem memory_rel_Unit: + memory_rel c be refs sp st m dm xs /\ good_dimindex (:'a) ==> + memory_rel c be refs sp st m dm ((Unit,Word (2w:'a word))::xs) +Proof + fs [memory_rel_def] \\ rw [] \\ asm_exists_tac \\ fs [] + \\ match_mp_tac word_ml_inv_Unit \\ fs [] +QED + +Theorem get_lowerbits_LSL_shift_length: + get_lowerbits conf a >>> shift_length conf = 0w +Proof + Cases_on `a` \\ srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] - [word_index, get_lowerbits_def, small_shift_length_def, shift_length_def]) + [word_index, get_lowerbits_def, small_shift_length_def, shift_length_def] +QED val get_real_addr_def = Define ` get_real_addr conf st (w:'a word) = @@ -3625,13 +3799,14 @@ val get_real_offset_def = Define ` if dimindex (:'a) = 32 then SOME (w + bytes_in_word) else SOME (w << 1 + bytes_in_word)` -Theorem get_real_addr_get_addr - `heap_length heap <= dimword (:'a) DIV 2 ** shift_length c /\ +Theorem get_real_addr_get_addr: + heap_length heap <= dimword (:'a) DIV 2 ** shift_length c /\ heap_lookup n heap = SOME anything /\ FLOOKUP st CurrHeap = SOME (Word (curr:'a word)) /\ good_dimindex (:'a) ==> - get_real_addr c st (get_addr c n w) = SOME (curr + n2w n * bytes_in_word)` - (fs [X_LE_DIV] \\ fs [get_addr_def,get_real_addr_def] \\ strip_tac + get_real_addr c st (get_addr c n w) = SOME (curr + n2w n * bytes_in_word) +Proof + fs [X_LE_DIV] \\ fs [get_addr_def,get_real_addr_def] \\ strip_tac \\ imp_res_tac heap_lookup_LESS \\ fs [] \\ `w2n ((n2w n):'a word) * 2 ** shift_length c < dimword (:'a)` by (`n < dimword (:'a)` by @@ -3668,55 +3843,67 @@ Theorem get_real_addr_get_addr (fs [shift_def,labPropsTheory.good_dimindex_def,shift_length_def] \\ NO_TAC) \\ pop_assum (fn th => simp_tac std_ss [Once th]) \\ simp_tac std_ss [EXP_ADD,MULT_ASSOC,MULT_DIV] - \\ fs [shift_def,labPropsTheory.good_dimindex_def]); + \\ fs [shift_def,labPropsTheory.good_dimindex_def] +QED -Theorem get_real_offset_thm - `good_dimindex (:'a) ==> +Theorem get_real_offset_thm: + good_dimindex (:'a) ==> get_real_offset (n2w (4 * index)) = - SOME (bytes_in_word + n2w index * bytes_in_word:'a word)` - (fs [labPropsTheory.good_dimindex_def,dimword_def] \\ rw [] - \\ fs [get_real_offset_def,bytes_in_word_def,word_mul_n2w,WORD_MUL_LSL]); - -Theorem word_heap_APPEND - `!xs ys a. + SOME (bytes_in_word + n2w index * bytes_in_word:'a word) +Proof + fs [labPropsTheory.good_dimindex_def,dimword_def] \\ rw [] + \\ fs [get_real_offset_def,bytes_in_word_def,word_mul_n2w,WORD_MUL_LSL] +QED + +Theorem word_heap_APPEND: + !xs ys a. word_heap a (xs ++ ys) conf = word_heap a xs conf * - word_heap (a + bytes_in_word * n2w (heap_length xs)) ys conf` - (Induct \\ full_simp_tac(srw_ss())[word_heap_def,heap_length_def, + word_heap (a + bytes_in_word * n2w (heap_length xs)) ys conf +Proof + Induct \\ full_simp_tac(srw_ss())[word_heap_def,heap_length_def, SEP_CLAUSES,STAR_ASSOC] - \\ full_simp_tac(srw_ss())[GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB]); + \\ full_simp_tac(srw_ss())[GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] +QED -Theorem FORALL_WORD - `(!v:'a word. P v) <=> !n. n < dimword (:'a) ==> P (n2w n)` - (eq_tac \\ rw [] \\ Cases_on `v` \\ fs []); +Theorem FORALL_WORD: + (!v:'a word. P v) <=> !n. n < dimword (:'a) ==> P (n2w n) +Proof + eq_tac \\ rw [] \\ Cases_on `v` \\ fs [] +QED -Theorem BlockNil_and_lemma - `good_dimindex (:'a) ==> - (-2w && 16w * tag + 2w) = 16w * tag + 2w:'a word` - (`!w:word64. (-2w && 16w * w + 2w) = 16w * w + 2w` by blastLib.BBLAST_TAC +Theorem BlockNil_and_lemma: + good_dimindex (:'a) ==> + (-2w && 16w * tag + 2w) = 16w * tag + 2w:'a word +Proof + `!w:word64. (-2w && 16w * w + 2w) = 16w * w + 2w` by blastLib.BBLAST_TAC \\ `!w:word32. (-2w && 16w * w + 2w) = 16w * w + 2w` by blastLib.BBLAST_TAC \\ fs [GSYM word_mul_n2w,GSYM word_add_n2w] \\ rfs [dimword_def,FORALL_WORD] \\ Cases_on `tag` \\ fs [labPropsTheory.good_dimindex_def] \\ rw [] \\ fs [word_mul_n2w,word_add_n2w,word_2comp_n2w,word_and_n2w] - \\ rfs [dimword_def] \\ fs []); + \\ rfs [dimword_def] \\ fs [] +QED -Theorem word_ml_inv_num_lemma - `good_dimindex (:'a) ==> (-2w && 4w * v) = 4w * v:'a word` - (`!w:word64. (-2w && 4w * w) = 4w * w` by blastLib.BBLAST_TAC +Theorem word_ml_inv_num_lemma: + good_dimindex (:'a) ==> (-2w && 4w * v) = 4w * v:'a word +Proof + `!w:word64. (-2w && 4w * w) = 4w * w` by blastLib.BBLAST_TAC \\ `!w:word32. (-2w && 4w * w) = 4w * w` by blastLib.BBLAST_TAC \\ rfs [dimword_def,FORALL_WORD] \\ fs [labPropsTheory.good_dimindex_def] \\ rw [] \\ Cases_on `v` \\ fs [word_mul_n2w,word_and_n2w,word_2comp_n2w] - \\ rfs [dimword_def]); + \\ rfs [dimword_def] +QED -Theorem word_ml_inv_num - `word_ml_inv (heap,be,a,sp,sp1,gens) limit c s.refs ws /\ +Theorem word_ml_inv_num: + word_ml_inv (heap,be,a,sp,sp1,gens) limit c s.refs ws /\ good_dimindex (:'a) /\ small_enough_int (&n) ==> word_ml_inv (heap,be,a,sp,sp1,gens) limit c s.refs - ((Number (&n),Word (n2w (4 * n):'a word))::ws)` - (fs [word_ml_inv_def,PULL_EXISTS] \\ rw [] + ((Number (&n),Word (n2w (4 * n):'a word))::ws) +Proof + fs [word_ml_inv_def,PULL_EXISTS] \\ rw [] \\ qexists_tac `Data (Word (Smallnum (&n)))` \\ qexists_tac `hs` \\ fs [] \\ conj_tac THEN1 @@ -3725,27 +3912,31 @@ Theorem word_ml_inv_num \\ fs [small_int_def,Smallnum_def] \\ fs [labPropsTheory.good_dimindex_def,dimword_def] \\ rw []) \\ fs [word_addr_def,Smallnum_def,GSYM word_mul_n2w] - \\ match_mp_tac word_ml_inv_num_lemma \\ fs []); + \\ match_mp_tac word_ml_inv_num_lemma \\ fs [] +QED val word_ml_inv_zero = save_thm("word_ml_inv_zero", word_ml_inv_num |> Q.INST [`n`|->`0`] |> SIMP_RULE (srw_ss()) []) -Theorem word_ml_inv_neg_num_lemma - `good_dimindex (:'a) ==> (-2w && -4w * v) = -4w * v:'a word` - (`!w:word64. (-2w && -4w * w) = -4w * w` by blastLib.BBLAST_TAC +Theorem word_ml_inv_neg_num_lemma: + good_dimindex (:'a) ==> (-2w && -4w * v) = -4w * v:'a word +Proof + `!w:word64. (-2w && -4w * w) = -4w * w` by blastLib.BBLAST_TAC \\ `!w:word32. (-2w && -4w * w) = -4w * w` by blastLib.BBLAST_TAC \\ rfs [dimword_def,FORALL_WORD] \\ fs [labPropsTheory.good_dimindex_def] \\ rw [] \\ Cases_on `v` \\ fs [word_mul_n2w,word_and_n2w,word_2comp_n2w] - \\ rfs [dimword_def]); + \\ rfs [dimword_def] +QED -Theorem word_ml_inv_neg_num - `word_ml_inv (heap,be,a,sp,sp1,gens) limit c s.refs ws /\ +Theorem word_ml_inv_neg_num: + word_ml_inv (heap,be,a,sp,sp1,gens) limit c s.refs ws /\ good_dimindex (:'a) /\ small_enough_int (-&n) /\ n <> 0 ==> word_ml_inv (heap,be,a,sp,sp1,gens) limit c s.refs - ((Number (-&n),Word (-n2w (4 * n):'a word))::ws)` - (fs [word_ml_inv_def,PULL_EXISTS] \\ rw [] + ((Number (-&n),Word (-n2w (4 * n):'a word))::ws) +Proof + fs [word_ml_inv_def,PULL_EXISTS] \\ rw [] \\ qexists_tac `Data (Word (Smallnum (-&n)))` \\ qexists_tac `hs` \\ fs [] \\ conj_tac THEN1 @@ -3754,16 +3945,19 @@ Theorem word_ml_inv_neg_num \\ fs [small_int_def,Smallnum_def] \\ fs [labPropsTheory.good_dimindex_def,dimword_def] \\ rw []) \\ fs [word_addr_def,Smallnum_def,GSYM word_mul_n2w] - \\ match_mp_tac word_ml_inv_neg_num_lemma \\ fs []); - -Theorem word_list_APPEND - `!xs ys a. word_list a (xs ++ ys) = - word_list a xs * word_list (a + n2w (LENGTH xs) * bytes_in_word) ys` - (Induct \\ full_simp_tac(srw_ss())[word_list_def,SEP_CLAUSES,STAR_ASSOC,ADD1, - GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB]); - -Theorem memory_rel_El - `memory_rel c be refs sp st m dm + \\ match_mp_tac word_ml_inv_neg_num_lemma \\ fs [] +QED + +Theorem word_list_APPEND: + !xs ys a. word_list a (xs ++ ys) = + word_list a xs * word_list (a + n2w (LENGTH xs) * bytes_in_word) ys +Proof + Induct \\ full_simp_tac(srw_ss())[word_list_def,SEP_CLAUSES,STAR_ASSOC,ADD1, + GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] +QED + +Theorem memory_rel_El: + memory_rel c be refs sp st m dm ((Block ts tag vals,ptr)::(Number (&index),i)::vars) /\ good_dimindex (:'a) /\ index < LENGTH vals ==> @@ -3774,8 +3968,9 @@ Theorem memory_rel_El (x + y) IN dm /\ memory_rel c be refs sp st m dm ((EL index vals,m (x + y)):: - (Block ts tag vals,ptr)::(Number (&index),i)::vars)` - (rewrite_tac [CONJ_ASSOC] + (Block ts tag vals,ptr)::(Number (&index),i)::vars) +Proof + rewrite_tac [CONJ_ASSOC] \\ once_rewrite_tac [CONJ_COMM] \\ fs [memory_rel_def,PULL_EXISTS] \\ rw [] \\ asm_exists_tac \\ fs [] @@ -3814,15 +4009,18 @@ Theorem memory_rel_El \\ clean_tac \\ fs [word_heap_APPEND,word_heap_def,word_el_def,word_payload_def] \\ fs [word_list_def,word_list_APPEND] - \\ SEP_R_TAC \\ fs []); + \\ SEP_R_TAC \\ fs [] +QED -Theorem memory_rel_swap - `memory_rel c be refs sp st m dm (x::y::z) ==> - memory_rel c be refs sp st m dm (y::x::z)` - (match_mp_tac memory_rel_rearrange \\ rw[] \\ rw[]); +Theorem memory_rel_swap: + memory_rel c be refs sp st m dm (x::y::z) ==> + memory_rel c be refs sp st m dm (y::x::z) +Proof + match_mp_tac memory_rel_rearrange \\ rw[] \\ rw[] +QED -Theorem memory_rel_Deref - `memory_rel c be refs sp st m dm +Theorem memory_rel_Deref: + memory_rel c be refs sp st m dm ((RefPtr nn,ptr)::(Number (&index),i)::vars) /\ FLOOKUP refs nn = SOME (ValueArray vals) /\ good_dimindex (:'a) /\ @@ -3834,8 +4032,9 @@ Theorem memory_rel_Deref (x + y) IN dm /\ memory_rel c be refs sp st m dm ((EL index vals,m (x + y)):: - (RefPtr nn,ptr)::(Number (&index),i)::vars)` - (rewrite_tac [CONJ_ASSOC] + (RefPtr nn,ptr)::(Number (&index),i)::vars) +Proof + rewrite_tac [CONJ_ASSOC] \\ once_rewrite_tac [CONJ_COMM] \\ fs [memory_rel_def,PULL_EXISTS] \\ rw [] \\ asm_exists_tac \\ fs [] @@ -3879,42 +4078,51 @@ Theorem memory_rel_Deref \\ fs [word_heap_APPEND,word_heap_def,word_el_def,word_payload_def] \\ Cases_on `b0` \\ fs [word_payload_def] \\ fs [word_list_def,word_list_APPEND,SEP_CLAUSES] \\ fs [SEP_F_def] - \\ SEP_R_TAC \\ fs []); - -Theorem LENGTH_EQ_1 - `(LENGTH xs = 1 <=> ?a1. xs = [a1]) /\ - (1 = LENGTH xs <=> ?a1. xs = [a1])` - (rw [] \\ eq_tac \\ rw [] \\ fs [] - \\ Cases_on `xs` \\ fs [LENGTH_NIL]); - -Theorem LENGTH_EQ_2 - `(LENGTH xs = 2 <=> ?a1 a2. xs = [a1;a2]) /\ - (2 = LENGTH xs <=> ?a1 a2. xs = [a1;a2])` - (rw [] \\ eq_tac \\ rw [] \\ fs [] + \\ SEP_R_TAC \\ fs [] +QED + +Theorem LENGTH_EQ_1: + (LENGTH xs = 1 <=> ?a1. xs = [a1]) /\ + (1 = LENGTH xs <=> ?a1. xs = [a1]) +Proof + rw [] \\ eq_tac \\ rw [] \\ fs [] + \\ Cases_on `xs` \\ fs [LENGTH_NIL] +QED + +Theorem LENGTH_EQ_2: + (LENGTH xs = 2 <=> ?a1 a2. xs = [a1;a2]) /\ + (2 = LENGTH xs <=> ?a1 a2. xs = [a1;a2]) +Proof + rw [] \\ eq_tac \\ rw [] \\ fs [] \\ Cases_on `xs` \\ fs [] - \\ Cases_on `t` \\ fs [LENGTH_NIL]); + \\ Cases_on `t` \\ fs [LENGTH_NIL] +QED -Theorem LENGTH_EQ_3 - `(LENGTH xs = 3 <=> ?a1 a2 a3. xs = [a1;a2;a3]) /\ - (3 = LENGTH xs <=> ?a1 a2 a3. xs = [a1;a2;a3])` - (rw [] \\ eq_tac \\ rw [] \\ fs [] +Theorem LENGTH_EQ_3: + (LENGTH xs = 3 <=> ?a1 a2 a3. xs = [a1;a2;a3]) /\ + (3 = LENGTH xs <=> ?a1 a2 a3. xs = [a1;a2;a3]) +Proof + rw [] \\ eq_tac \\ rw [] \\ fs [] \\ Cases_on `xs` \\ fs [] \\ Cases_on `t` \\ fs [LENGTH_NIL] \\ Cases_on `t'` \\ fs [LENGTH_NIL] - \\ Cases_on `t` \\ fs [LENGTH_NIL]); + \\ Cases_on `t` \\ fs [LENGTH_NIL] +QED -Theorem heap_split_SOME_APPEND - `!xs ys a h1 h2. +Theorem heap_split_SOME_APPEND: + !xs ys a h1 h2. heap_split a (xs ++ ys) = SOME (h1,h2) <=> if a < heap_length xs then ?ha hb. heap_split a xs = SOME (ha,hb) /\ h1 = ha /\ h2 = hb ++ ys else ?ha hb. heap_split (a - heap_length xs) ys = SOME (ha,hb) /\ - h1 = xs ++ ha /\ h2 = hb` - (fs [heap_split_APPEND_if] \\ rw [] + h1 = xs ++ ha /\ h2 = hb +Proof + fs [heap_split_APPEND_if] \\ rw [] \\ every_case_tac \\ fs [] - \\ eq_tac \\ rw []); + \\ eq_tac \\ rw [] +QED val gc_kind_update_Ref = prove( ``gc_kind_inv c a sp sp1 gens @@ -3944,8 +4152,8 @@ val gc_kind_update_Ref = prove( \\ rpt (CASE_TAC \\ fs []) \\ rveq \\ fs [isRef_def]); -Theorem memory_rel_Update - `memory_rel c be refs sp st m dm +Theorem memory_rel_Update: + memory_rel c be refs sp st m dm ((h,w)::(RefPtr nn,ptr)::(Number (&index),i)::vars) /\ FLOOKUP refs nn = SOME (ValueArray vals) /\ good_dimindex (:'a) /\ @@ -3957,8 +4165,9 @@ Theorem memory_rel_Update (x + y) IN dm /\ memory_rel c be (refs |+ (nn,ValueArray (LUPDATE h index vals))) sp st ((x + y =+ w) m) dm - ((h,w)::(RefPtr nn,ptr)::(Number (&index),i)::vars)` - (rewrite_tac [CONJ_ASSOC] + ((h,w)::(RefPtr nn,ptr)::(Number (&index),i)::vars) +Proof + rewrite_tac [CONJ_ASSOC] \\ once_rewrite_tac [CONJ_COMM] \\ fs [memory_rel_def,PULL_EXISTS] \\ rw [] \\ fs [word_ml_inv_def,PULL_EXISTS] \\ clean_tac @@ -4013,7 +4222,8 @@ Theorem memory_rel_Update \\ fs [GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] \\ SEP_R_TAC \\ fs [] \\ SEP_W_TAC \\ fs [AC STAR_ASSOC STAR_COMM] - \\ imp_res_tac gc_kind_update_Ref \\ fs []); + \\ imp_res_tac gc_kind_update_Ref \\ fs [] +QED val make_cons_ptr_def = Define ` make_cons_ptr conf nf tag len = @@ -4035,9 +4245,11 @@ val minus_lemma = Q.prove( `-1w * (bytes_in_word * w) = bytes_in_word * -w`, fs []); -Theorem n2w_lsr_eq_0 - `n DIV 2 ** k = 0 /\ n < dimword (:'a) ==> n2w n >>> k = 0w:'a word` - (rw [] \\ simp_tac std_ss [GSYM w2n_11,w2n_lsr] \\ fs []); +Theorem n2w_lsr_eq_0: + n DIV 2 ** k = 0 /\ n < dimword (:'a) ==> n2w n >>> k = 0w:'a word +Proof + rw [] \\ simp_tac std_ss [GSYM w2n_11,w2n_lsr] \\ fs [] +QED val LESS_EXO_SUB = Q.prove( `n < 2 ** (k - m) ==> n < 2n ** k`, @@ -4054,12 +4266,14 @@ val less_pow_dimindex_sub_imp = Q.prove( `n < 2 ** (dimindex (:'a) - k) ==> n < dimword (:'a)`, fs [dimword_def] \\ metis_tac [LESS_EXO_SUB]); -Theorem encode_header_NEQ_0 - `encode_header c n k = SOME w ==> w <> 0w` - (fs [encode_header_def] \\ rw [] +Theorem encode_header_NEQ_0: + encode_header c n k = SOME w ==> w <> 0w +Proof + fs [encode_header_def] \\ rw [] \\ fs [make_header_def,LET_DEF] \\ full_simp_tac (srw_ss()++wordsLib.WORD_BIT_EQ_ss) [] - \\ qexists_tac `0` \\ fs [] \\ EVAL_TAC); + \\ qexists_tac `0` \\ fs [] \\ EVAL_TAC +QED val encode_header_IMP = Q.prove( `encode_header c tag len = SOME (hd:'a word) /\ @@ -4093,11 +4307,12 @@ val encode_header_IMP = Q.prove( suffices_by fs [] \\ fs [GSYM EXP_ADD,dimword_def]); -Theorem word_list_exists_thm - `(word_list_exists a 0 = emp) /\ +Theorem word_list_exists_thm: + (word_list_exists a 0 = emp) /\ (word_list_exists a (SUC n) = - SEP_EXISTS w. one (a,w) * word_list_exists (a + bytes_in_word) n)` - (full_simp_tac(srw_ss())[word_heap_def,word_list_exists_def, + SEP_EXISTS w. one (a,w) * word_list_exists (a + bytes_in_word) n) +Proof + full_simp_tac(srw_ss())[word_heap_def,word_list_exists_def, LENGTH_NIL,FUN_EQ_THM,ADD1, SEP_EXISTS_THM,cond_STAR,word_list_def,word_el_def,SEP_CLAUSES] \\ srw_tac[][] \\ eq_tac \\ srw_tac[][] @@ -4107,52 +4322,62 @@ Theorem word_list_exists_thm \\ qexists_tac `h` \\ full_simp_tac(srw_ss())[] \\ qexists_tac `t` \\ full_simp_tac(srw_ss())[SEP_CLAUSES]) \\ qexists_tac `w::xs` - \\ full_simp_tac(srw_ss())[word_list_def,ADD1,STAR_ASSOC,cond_STAR]); + \\ full_simp_tac(srw_ss())[word_list_def,ADD1,STAR_ASSOC,cond_STAR] +QED -Theorem word_list_exists_ADD - `!m n a. +Theorem word_list_exists_ADD: + !m n a. word_list_exists a (m + n) = word_list_exists a m * - word_list_exists (a + bytes_in_word * n2w m) n` - (Induct \\ full_simp_tac(srw_ss())[word_list_exists_thm,SEP_CLAUSES,ADD_CLAUSES] + word_list_exists (a + bytes_in_word * n2w m) n +Proof + Induct \\ full_simp_tac(srw_ss())[word_list_exists_thm,SEP_CLAUSES,ADD_CLAUSES] \\ full_simp_tac(srw_ss())[STAR_ASSOC,ADD1, - GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB]); + GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] +QED -Theorem store_list_thm - `!xs a frame m dm. +Theorem store_list_thm: + !xs a frame m dm. (word_list_exists a (LENGTH xs) * frame) (fun2set (m,dm)) ==> ?m1. store_list a xs m dm = SOME m1 /\ - (word_list a xs * frame) (fun2set (m1,dm))` - (Induct \\ fs [store_list_def,word_list_exists_thm,word_list_def,SEP_CLAUSES] + (word_list a xs * frame) (fun2set (m1,dm)) +Proof + Induct \\ fs [store_list_def,word_list_exists_thm,word_list_def,SEP_CLAUSES] \\ fs [SEP_EXISTS_THM,PULL_EXISTS] \\ rpt strip_tac \\ SEP_R_TAC \\ fs [] \\ SEP_W_TAC - \\ SEP_F_TAC \\ rw [] \\ fs [AC STAR_COMM STAR_ASSOC]) + \\ SEP_F_TAC \\ rw [] \\ fs [AC STAR_COMM STAR_ASSOC] +QED -Theorem store_list_domain - `∀a xs m dm m1. +Theorem store_list_domain: + ∀a xs m dm m1. store_list a xs m dm = SOME m1 ==> - ∀n. n < LENGTH xs ==> a + n2w n * bytes_in_word ∈ dm` - (Induct_on`xs` + ∀n. n < LENGTH xs ==> a + n2w n * bytes_in_word ∈ dm +Proof + Induct_on`xs` \\ rw[store_list_def] \\ res_tac - \\ Cases_on`n` \\ fs[ADD1,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB]); + \\ Cases_on`n` \\ fs[ADD1,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] +QED -Theorem store_list_append_imp - `∀w1 a m dm m' w2. +Theorem store_list_append_imp: + ∀w1 a m dm m' w2. store_list a (w1 ++ w2) m dm = SOME m' ⇒ ∃m''. store_list a w1 m dm = SOME m'' ∧ - store_list (a + n2w (LENGTH w1) * bytes_in_word) w2 m'' dm = SOME m'` - (Induct \\ rw[store_list_def] + store_list (a + n2w (LENGTH w1) * bytes_in_word) w2 m'' dm = SOME m' +Proof + Induct \\ rw[store_list_def] \\ first_x_assum drule \\ rw[] \\ rw[] - \\ rw[ADD1,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB]); + \\ rw[ADD1,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] +QED -Theorem store_list_update_m_outside - `∀ws a m dm m'. +Theorem store_list_update_m_outside: + ∀ws a m dm m'. store_list a ws m dm = SOME m' ∧ (∀i. i < LENGTH ws ⇒ a + n2w i * bytes_in_word ≠ a') ⇒ - store_list a ws ((a' =+ v) m) dm = SOME ((a' =+ v) m')` - (Induct \\ rw[store_list_def] + store_list a ws ((a' =+ v) m) dm = SOME ((a' =+ v) m') +Proof + Induct \\ rw[store_list_def] \\ first_x_assum drule \\ impl_tac >- ( @@ -4162,17 +4387,21 @@ Theorem store_list_update_m_outside \\ AP_THM_TAC \\ AP_TERM_TAC \\ match_mp_tac UPDATE_COMMUTES \\ first_x_assum(qspec_then`0`mp_tac) - \\ simp[]); + \\ simp[] +QED -Theorem word_payload_IMP - `word_payload addrs ll tags tt1 conf = (h,ts,T) ==> LENGTH ts = ll` - (Cases_on `tags` \\ full_simp_tac(srw_ss())[word_payload_def] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[]); +Theorem word_payload_IMP: + word_payload addrs ll tags tt1 conf = (h,ts,T) ==> LENGTH ts = ll +Proof + Cases_on `tags` \\ full_simp_tac(srw_ss())[word_payload_def] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] +QED -Theorem word_el_IMP_word_list_exists - `!temp p curr. +Theorem word_el_IMP_word_list_exists: + !temp p curr. (p * word_el curr temp conf) s ==> - (p * word_list_exists curr (el_length temp)) s` - (Cases \\ fs[word_el_def,el_length_def,GSYM ADD1,word_list_exists_thm] + (p * word_list_exists curr (el_length temp)) s +Proof + Cases \\ fs[word_el_def,el_length_def,GSYM ADD1,word_list_exists_thm] THEN1 (full_simp_tac(srw_ss())[SEP_CLAUSES,SEP_EXISTS_THM] \\ metis_tac []) \\ Cases_on `b` \\ fs[word_el_def,el_length_def,GSYM ADD1,word_list_exists_thm,LET_THM] @@ -4180,36 +4409,41 @@ Theorem word_el_IMP_word_list_exists \\ full_simp_tac (std_ss++sep_cond_ss) [cond_STAR] \\ srw_tac[][] \\ fs[word_list_def,SEP_CLAUSES,SEP_EXISTS_THM,word_list_exists_def] \\ full_simp_tac (std_ss++sep_cond_ss) [cond_STAR] - \\ imp_res_tac word_payload_IMP \\ asm_exists_tac \\ fs [] \\ metis_tac []); + \\ imp_res_tac word_payload_IMP \\ asm_exists_tac \\ fs [] \\ metis_tac [] +QED -Theorem word_heap_IMP_word_list_exists - `!temp p curr. +Theorem word_heap_IMP_word_list_exists: + !temp p curr. (p * word_heap curr temp conf) s ==> - (p * word_list_exists curr (heap_length temp)) s` - (Induct \\ full_simp_tac(srw_ss())[heap_length_def, + (p * word_list_exists curr (heap_length temp)) s +Proof + Induct \\ full_simp_tac(srw_ss())[heap_length_def, word_heap_def,word_list_exists_thm] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[word_el_def,word_list_exists_ADD] \\ full_simp_tac(srw_ss())[STAR_ASSOC] \\ res_tac \\ pop_assum mp_tac \\ once_rewrite_tac [STAR_COMM] \\ full_simp_tac(srw_ss())[STAR_ASSOC] - \\ metis_tac [word_el_IMP_word_list_exists]); + \\ metis_tac [word_el_IMP_word_list_exists] +QED val EVERY2_f_EQ = Q.prove( `!rs ws f. EVERY2 (\v w. f v = w) rs ws <=> MAP f rs = ws`, Induct \\ fs [] \\ rw [] \\ eq_tac \\ rw [] \\ fs []); -Theorem word_heap_heap_expand - `word_heap a (heap_expand n) conf = word_list_exists a n` - (Cases_on `n` \\ full_simp_tac(srw_ss())[heap_expand_def] +Theorem word_heap_heap_expand: + word_heap a (heap_expand n) conf = word_list_exists a n +Proof + Cases_on `n` \\ full_simp_tac(srw_ss())[heap_expand_def] \\ fs [word_heap_def,word_list_exists_def,LENGTH_NIL,FUN_EQ_THM,ADD1, - SEP_EXISTS_THM,cond_STAR,word_list_def,word_el_def,SEP_CLAUSES]) + SEP_EXISTS_THM,cond_STAR,word_list_def,word_el_def,SEP_CLAUSES] +QED val get_lowerbits_or_1 = Q.prove( `get_lowerbits c v = (get_lowerbits c v || 1w)`, Cases_on `v` \\ fs [get_lowerbits_def]); -Theorem memory_rel_Word64_alt - `memory_rel c be refs sp st m dm (vs ++ vars) ∧ good_dimindex (:'a) ∧ +Theorem memory_rel_Word64_alt: + memory_rel c be refs sp st m dm (vs ++ vars) ∧ good_dimindex (:'a) ∧ (Word64Rep (:'a) w64 : 'a ml_el) = DataElement [] (LENGTH ws) (Word64Tag,ws) ∧ LENGTH ws < sp ∧ encode_header c 3 (LENGTH ws) = SOME hd @@ -4220,8 +4454,9 @@ Theorem memory_rel_Word64_alt store_list ne (Word hd::ws) m dm = SOME m1 ∧ memory_rel c be refs (sp - (LENGTH ws + 1)) (st |+ (NextFree,Word (ne + bytes_in_word * n2w (LENGTH ws + 1)))) m1 dm - ((Word64 w64, make_ptr c (ne - curr) (0w:'a word) (LENGTH ws))::vars)` - (rw[memory_rel_def,word_ml_inv_def,PULL_EXISTS] + ((Word64 w64, make_ptr c (ne - curr) (0w:'a word) (LENGTH ws))::vars) +Proof + rw[memory_rel_def,word_ml_inv_def,PULL_EXISTS] \\ imp_res_tac EVERY2_SWAP \\ imp_res_tac EVERY2_APPEND_IMP_APPEND \\ imp_res_tac LIST_REL_LENGTH @@ -4283,7 +4518,8 @@ Theorem memory_rel_Word64_alt \\ fs[encode_header_def,SEP_CLAUSES] \\ simp[word_list_def] \\ simp[Q.SPEC`[_]`heap_length_def,el_length_def,ADD1] - \\ simp[AC STAR_ASSOC STAR_COMM,ADD1,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB]); + \\ simp[AC STAR_ASSOC STAR_COMM,ADD1,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] +QED val memory_rel_WordOp64_alt = memory_rel_Word64_alt |> Q.GEN`vs` |> Q.SPEC`[w1;w2]` @@ -4375,8 +4611,8 @@ val IMP_memory_rel_bignum_alt = Q.prove( val IMP_memory_rel_bignum_alt = save_thm("IMP_memory_rel_bignum_alt", IMP_memory_rel_bignum_alt |> Q.INST [`vs`|->`[]`] |> SIMP_RULE std_ss [APPEND]); -Theorem memory_rel_Cons1 - `memory_rel c be refs sp st m dm (ZIP (vals,ws) ++ vars) /\ +Theorem memory_rel_Cons1: + memory_rel c be refs sp st m dm (ZIP (vals,ws) ++ vars) /\ LENGTH vals = LENGTH (ws:'a word_loc list) /\ vals <> [] /\ encode_header c (4 * tag) (LENGTH ws) = SOME hd /\ LENGTH ws < sp /\ good_dimindex (:'a) ==> @@ -4387,8 +4623,9 @@ Theorem memory_rel_Cons1 store_list free (Word hd::ws) m dm = SOME m1 /\ memory_rel c be refs (sp - (LENGTH ws + 1)) (st |+ (NextFree,Word w)) m1 dm - ((Block ts tag vals,make_cons_ptr c (free - curr) tag (LENGTH ws))::vars)` - (simp_tac std_ss [LET_THM] + ((Block ts tag vals,make_cons_ptr c (free - curr) tag (LENGTH ws))::vars) +Proof + simp_tac std_ss [LET_THM] \\ rewrite_tac [CONJ_ASSOC] \\ once_rewrite_tac [CONJ_COMM] \\ fs [memory_rel_def,PULL_EXISTS] \\ rw [] @@ -4452,14 +4689,16 @@ Theorem memory_rel_Cons1 \\ fs [AC STAR_ASSOC STAR_COMM] \\ fs [STAR_ASSOC] \\ fs [el_length_def,heap_length_APPEND,heap_length_heap_expand, GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB,ADD1] - \\ fs [AC STAR_ASSOC STAR_COMM] \\ fs [STAR_ASSOC]); + \\ fs [AC STAR_ASSOC STAR_COMM] \\ fs [STAR_ASSOC] +QED -Theorem memory_rel_Cons_empty - `memory_rel c be refs sp st m (dm:'a word set) vars /\ +Theorem memory_rel_Cons_empty: + memory_rel c be refs sp st m (dm:'a word set) vars /\ tag < dimword (:α) DIV 16 /\ good_dimindex (:'a) ==> memory_rel c be refs sp st m dm - ((Block 0 tag [],Word (BlockNil tag))::vars)` - (fs [memory_rel_def] \\ rw [] + ((Block 0 tag [],Word (BlockNil tag))::vars) +Proof + fs [memory_rel_def] \\ rw [] \\ asm_exists_tac \\ fs [] \\ fs [word_ml_inv_def] \\ rpt_drule cons_thm_EMPTY @@ -4467,10 +4706,11 @@ Theorem memory_rel_Cons_empty \\ asm_exists_tac \\ fs [] \\ fs [word_addr_def,BlockNil_def,WORD_MUL_LSL,word_mul_n2w] \\ fs [GSYM word_mul_n2w] - \\ match_mp_tac BlockNil_and_lemma \\ fs []); + \\ match_mp_tac BlockNil_and_lemma \\ fs [] +QED -Theorem memory_rel_Ref - `memory_rel c be refs sp st m dm (ZIP (vals,ws) ++ vars) /\ +Theorem memory_rel_Ref: + memory_rel c be refs sp st m dm (ZIP (vals,ws) ++ vars) /\ LENGTH vals = LENGTH (ws:'a word_loc list) /\ encode_header c 2 (LENGTH ws) = SOME hd /\ ~(new IN FDOM refs) /\ LENGTH ws < sp /\ good_dimindex (:'a) ==> @@ -4483,8 +4723,9 @@ Theorem memory_rel_Ref store_list w (Word hd::ws) m dm = SOME m1 /\ memory_rel c be (refs |+ (new,ValueArray vals)) (sp - (LENGTH ws + 1)) (st |+ (EndOfHeap,Word w) |+ (TriggerGC,Word w1)) m1 dm - ((RefPtr new,make_ptr c (w - curr) 0w (LENGTH ws))::vars)` - (simp_tac std_ss [LET_THM] + ((RefPtr new,make_ptr c (w - curr) 0w (LENGTH ws))::vars) +Proof + simp_tac std_ss [LET_THM] \\ rewrite_tac [CONJ_ASSOC] \\ once_rewrite_tac [CONJ_COMM] \\ fs [memory_rel_def,PULL_EXISTS] \\ rw [] @@ -4532,17 +4773,19 @@ Theorem memory_rel_Ref \\ fs [AC STAR_ASSOC STAR_COMM] \\ fs [STAR_ASSOC] \\ pop_assum mp_tac \\ CONV_TAC (DEPTH_CONV ETA_CONV) \\ fs [ADD1,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] - \\ fs [AC STAR_ASSOC STAR_COMM] \\ fs [STAR_ASSOC]); + \\ fs [AC STAR_ASSOC STAR_COMM] \\ fs [STAR_ASSOC] +QED -Theorem memory_rel_write - `memory_rel c be refs sp st m dm vars ==> +Theorem memory_rel_write: + memory_rel c be refs sp st m dm vars ==> ?(free:'a word). FLOOKUP st NextFree = SOME (Word free) /\ !n. n < sp ==> let a = free + bytes_in_word * n2w n in - a IN dm /\ memory_rel c be refs sp st ((a =+ w) m) dm vars` - (fs [LET_THM,memory_rel_def,heap_in_memory_store_def] + a IN dm /\ memory_rel c be refs sp st ((a =+ w) m) dm vars +Proof + fs [LET_THM,memory_rel_def,heap_in_memory_store_def] \\ strip_tac \\ fs [word_ml_inv_def,abs_ml_inv_def] \\ fs [unused_space_inv_def] \\ ntac 2 strip_tac \\ fs [] @@ -4568,17 +4811,19 @@ Theorem memory_rel_write \\ qexists_tac `ys1 ++ w::ys2` \\ fs [SEP_CLAUSES] \\ qexists_tac `hs` \\ fs [] \\ fs [word_list_def,word_list_APPEND] - \\ SEP_WRITE_TAC); + \\ SEP_WRITE_TAC +QED -Theorem word_list_AND_word_list_exists_IMP - `!ws aa frame n. +Theorem word_list_AND_word_list_exists_IMP: + !ws aa frame n. (word_list aa ws * SEP_T) (fun2set (m,dm)) /\ (word_list_exists aa n * frame) (fun2set (m,dm)) /\ LENGTH ws <= n ==> (word_list aa ws * word_list_exists (aa + bytes_in_word * n2w (LENGTH ws)) (n - LENGTH ws) * - frame) (fun2set (m,dm))` - (Induct \\ fs [word_list_def,SEP_CLAUSES] \\ rw [] + frame) (fun2set (m,dm)) +Proof + Induct \\ fs [word_list_def,SEP_CLAUSES] \\ rw [] \\ Cases_on `n` \\ fs [ADD1,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] \\ qsuff_tac `(word_list (aa + bytes_in_word) ws * @@ -4599,10 +4844,11 @@ Theorem word_list_AND_word_list_exists_IMP (fs [FUN_EQ_THM,APPLY_UPDATE_THM] \\ rw [] \\ SEP_R_TAC \\ NO_TAC) \\ pop_assum (fn th => once_rewrite_tac [th]) \\ fs [GSYM ADD1,word_list_exists_thm,SEP_CLAUSES,SEP_EXISTS_THM] - \\ SEP_WRITE_TAC); + \\ SEP_WRITE_TAC +QED -Theorem memory_rel_Cons_alt - `memory_rel c be refs sp st m dm (ZIP (vals,ws) ++ vars) /\ +Theorem memory_rel_Cons_alt: + memory_rel c be refs sp st m dm (ZIP (vals,ws) ++ vars) /\ LENGTH vals = LENGTH (ws:'a word_loc list) /\ vals <> [] /\ encode_header c (4 * tag) (LENGTH ws) = SOME hd /\ LENGTH ws < sp /\ good_dimindex (:'a) ==> @@ -4612,8 +4858,9 @@ Theorem memory_rel_Cons_alt ((word_list free (Word hd::ws) * SEP_T) (fun2set(m,dm)) ==> memory_rel c be refs (sp - (LENGTH ws + 1)) (st |+ (NextFree,Word (free + bytes_in_word * n2w (LENGTH ws + 1)))) m dm - ((Block ts tag vals,make_cons_ptr c (free - curr) tag (LENGTH ws))::vars))` - (simp_tac std_ss [LET_THM] + ((Block ts tag vals,make_cons_ptr c (free - curr) tag (LENGTH ws))::vars)) +Proof + simp_tac std_ss [LET_THM] \\ rewrite_tac [CONJ_ASSOC] \\ once_rewrite_tac [CONJ_COMM] \\ fs [memory_rel_def,PULL_EXISTS] \\ rw [] @@ -4677,13 +4924,16 @@ Theorem memory_rel_Cons_alt \\ pop_assum kall_tac \\ fs [wordsTheory.n2w_sub,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] \\ CONV_TAC (DEPTH_CONV ETA_CONV) - \\ simp_tac std_ss [AC STAR_ASSOC STAR_COMM]); + \\ simp_tac std_ss [AC STAR_ASSOC STAR_COMM] +QED -Theorem memory_rel_REPLICATE - `memory_rel c be refs sp st m dm ((v,w)::vars) ==> - memory_rel c be refs sp st m dm (REPLICATE n (v,w) ++ vars)` - (match_mp_tac memory_rel_rearrange \\ fs [] \\ rw [] \\ fs [] - \\ Induct_on `n` \\ fs [REPLICATE] \\ rw [] \\ fs []) +Theorem memory_rel_REPLICATE: + memory_rel c be refs sp st m dm ((v,w)::vars) ==> + memory_rel c be refs sp st m dm (REPLICATE n (v,w) ++ vars) +Proof + match_mp_tac memory_rel_rearrange \\ fs [] \\ rw [] \\ fs [] + \\ Induct_on `n` \\ fs [REPLICATE] \\ rw [] \\ fs [] +QED val memory_rel_RefArray = save_thm("memory_rel_RefArray", memory_rel_Ref @@ -4722,11 +4972,13 @@ val set_byte_word_of_byte = Q.prove( \\ fs [fcpTheory.CART_EQ,word_or_def,word_lsl_def,fcpTheory.FCP_BETA, word_slice_alt_def,w2w] \\ rw [] \\ EQ_TAC \\ rw [] \\ fs []); -Theorem w2w_word_of_byte_w2w - `good_dimindex(:'a) ==> - w2w (word_of_byte (w2w w:'a word)):word8 = w` - (rw[word_of_byte_def,labPropsTheory.good_dimindex_def] - \\ srw_tac[wordsLib.WORD_BIT_EQ_ss][]); +Theorem w2w_word_of_byte_w2w: + good_dimindex(:'a) ==> + w2w (word_of_byte (w2w w:'a word)):word8 = w +Proof + rw[word_of_byte_def,labPropsTheory.good_dimindex_def] + \\ srw_tac[wordsLib.WORD_BIT_EQ_ss][] +QED val write_bytes_REPLICATE = Q.prove( `!n m. @@ -4741,9 +4993,11 @@ val write_bytes_REPLICATE = Q.prove( \\ fs [bytes_to_word_def,REPLICATE] \\ Cases_on `m` \\ fs [bytes_to_word_def,REPLICATE,set_byte_word_of_byte]); -Theorem IMP_EXP_LESS - `m <= l ==> 2n ** m <= 2 ** l` - (simp [Once LESS_EQ_EXISTS] \\ rw []); +Theorem IMP_EXP_LESS: + m <= l ==> 2n ** m <= 2 ** l +Proof + simp [Once LESS_EQ_EXISTS] \\ rw [] +QED val shift_shift_lemma = Q.prove( `l = k + shift (:'a) /\ t < k /\ n DIV i < 2 ** t /\ l = dimindex (:'a) /\ @@ -4767,21 +5021,25 @@ val shift_shift_lemma = Q.prove( \\ simp_tac bool_ss [Once MULT_COMM] \\ rewrite_tac [LT_MULT_LCANCEL,GSYM MULT_ASSOC] \\ fs []); -Theorem write_bytes_APPEND - `!xs ys vals be. +Theorem write_bytes_APPEND: + !xs ys vals be. write_bytes vals (xs ++ (ys:'a word list)) be = write_bytes vals xs be ++ - write_bytes (DROP ((dimindex (:α) DIV 8) * LENGTH xs) vals) ys be` - (Induct \\ fs [write_bytes_def,ADD1,RIGHT_ADD_DISTRIB,DROP_DROP_T]); + write_bytes (DROP ((dimindex (:α) DIV 8) * LENGTH xs) vals) ys be +Proof + Induct \\ fs [write_bytes_def,ADD1,RIGHT_ADD_DISTRIB,DROP_DROP_T] +QED -Theorem bytes_to_word_simp - `(bytes_to_word k a [] w be = w) /\ +Theorem bytes_to_word_simp: + (bytes_to_word k a [] w be = w) /\ (bytes_to_word k a (b::bs) w be = - if k = 0 then w else set_byte a b (bytes_to_word (k-1) (a+1w) bs w be) be)` - (Cases_on `k` \\ fs [bytes_to_word_def]); + if k = 0 then w else set_byte a b (bytes_to_word (k-1) (a+1w) bs w be) be) +Proof + Cases_on `k` \\ fs [bytes_to_word_def] +QED -Theorem set_byte_sort - `!n1 n2. +Theorem set_byte_sort: + !n1 n2. set_byte (n2w n1) b1 (set_byte (n2w n2:'a word) b2 w be) be = if n1 = n2 then set_byte (n2w n1) b1 w be else if n1 < dimindex(:α) DIV 8 /\ n2 < dimindex(:α) DIV 8 /\ @@ -4789,8 +5047,9 @@ Theorem set_byte_sort then set_byte (n2w n2) b2 (set_byte (n2w n1) b1 w be) be else - set_byte (n2w n1) b1 (set_byte (n2w n2) b2 w be) be` - (rw [] THEN1 + set_byte (n2w n1) b1 (set_byte (n2w n2) b2 w be) be +Proof + rw [] THEN1 (fs [set_byte_def] \\ full_simp_tac (std_ss++wordsLib.WORD_BIT_EQ_ss) [word_slice_alt_def] \\ rw [] \\ eq_tac \\ rw [] @@ -4803,7 +5062,8 @@ Theorem set_byte_sort \\ fs [byte_index_def] \\ fs[labPropsTheory.good_dimindex_def] \\ rfs[dimword_def] \\ Cases_on `be` \\ fs [] - \\ fs [LESS_4,LESS_8] \\ rfs []); + \\ fs [LESS_4,LESS_8] \\ rfs [] +QED val (set_byte_sort_dec,set_byte_sort_asc) = let fun cross [] ys = [] @@ -4817,8 +5077,8 @@ val (set_byte_sort_dec,set_byte_sort_asc) = let val ts2 = filter (fn (x,y) => y < x) ys in (LIST_CONJ (map f ts1), LIST_CONJ (map f ts2)) end -Theorem set_byte_eq_ARB - `good_dimindex (:α) ==> +Theorem set_byte_eq_ARB: + good_dimindex (:α) ==> !x h h'. (set_byte 0w x h be = set_byte 0w x (h':'a word) be <=> set_byte 0w ARB h be = set_byte 0w ARB h' be) /\ @@ -4835,19 +5095,22 @@ Theorem set_byte_eq_ARB (set_byte 6w x h be = set_byte 6w x (h':'a word) be <=> set_byte 6w ARB h be = set_byte 6w ARB h' be) /\ (set_byte 7w x h be = set_byte 7w x (h':'a word) be <=> - set_byte 7w ARB h be = set_byte 7w ARB h' be)` - (rw [labPropsTheory.good_dimindex_def] + set_byte 7w ARB h be = set_byte 7w ARB h' be) +Proof + rw [labPropsTheory.good_dimindex_def] \\ Cases_on `be` \\ fs [set_byte_def,LET_THM,byte_index_def,dimword_def] \\ full_simp_tac (std_ss++wordsLib.WORD_BIT_EQ_ss) - [word_slice_alt_def,set_byte_def,LET_THM,dimword_def]); + [word_slice_alt_def,set_byte_def,LET_THM,dimword_def] +QED -Theorem bytes_to_word_eq_lemma - `good_dimindex (:α) /\ LENGTH bs' = LENGTH bs /\ +Theorem bytes_to_word_eq_lemma: + good_dimindex (:α) /\ LENGTH bs' = LENGTH bs /\ bytes_to_word (dimindex (:α) DIV 8) 0w bs (h:'a word) be = bytes_to_word (dimindex (:α) DIV 8) 0w bs h' be ==> bytes_to_word (dimindex (:α) DIV 8) 0w bs' h be = - bytes_to_word (dimindex (:α) DIV 8) 0w bs' h' be` - (fs[labPropsTheory.good_dimindex_def] \\ rfs[dimword_def] + bytes_to_word (dimindex (:α) DIV 8) 0w bs' h' be +Proof + fs[labPropsTheory.good_dimindex_def] \\ rfs[dimword_def] \\ rw [] \\ rfs [] \\ pop_assum mp_tac \\ `good_dimindex (:α)` by fs[labPropsTheory.good_dimindex_def] \\ Cases_on `bs` \\ Cases_on `bs'` \\ fs [bytes_to_word_simp] @@ -4857,10 +5120,11 @@ Theorem bytes_to_word_eq_lemma \\ Cases_on `t1` \\ Cases_on `t2` \\ fs [bytes_to_word_simp] \\ NTAC 30 (fs [Once set_byte_sort_dec]) \\ assume_tac (UNDISCH set_byte_eq_ARB) - \\ pop_assum (fn th => once_rewrite_tac [th]))) + \\ pop_assum (fn th => once_rewrite_tac [th])) +QED -Theorem write_bytes_inj_lemma - `good_dimindex(:α) ⇒ +Theorem write_bytes_inj_lemma: + good_dimindex(:α) ⇒ ∀w1 w2 bs bs'. write_bytes bs w1 be = write_bytes bs (w2:'a word list) be ∧ LENGTH w1 = LENGTH w2 ∧ @@ -4868,16 +5132,18 @@ Theorem write_bytes_inj_lemma LENGTH bs ≤ LENGTH (w1:α word list) * (dimindex (:α) DIV 8) *) (* ∧ LENGTH (w1:α word list) ≤ LENGTH bs DIV (dimindex(:α) DIV 8) +1 *) ⇒ - write_bytes bs' w1 be = write_bytes bs' w2 be` - (strip_tac \\ Induct >- rw[] \\ rw[Once write_bytes_def] + write_bytes bs' w1 be = write_bytes bs' w2 be +Proof + strip_tac \\ Induct >- rw[] \\ rw[Once write_bytes_def] \\ Cases_on`w2` \\ fs[write_bytes_def] \\ rw[] >- (match_mp_tac bytes_to_word_eq_lemma \\ fs []) \\ first_x_assum match_mp_tac - \\ rw[] \\ asm_exists_tac \\ simp[]); + \\ rw[] \\ asm_exists_tac \\ simp[] +QED (* slow *) -Theorem set_byte_all_64 - `dimindex(:'a) = 64 ⇒ +Theorem set_byte_all_64: + dimindex(:'a) = 64 ⇒ set_byte (0w:'a word) b1 (set_byte 1w b2 (set_byte 2w b3 @@ -4894,13 +5160,15 @@ Theorem set_byte_all_64 (set_byte 4w b5 (set_byte 5w b6 (set_byte 6w b7 - (set_byte 7w b8 y be) be) be) be) be) be) be) be` - (Cases_on`be` + (set_byte 7w b8 y be) be) be) be) be) be) be) be +Proof + Cases_on`be` \\ rw[set_byte_def,byte_index_def,dimword_def,word_slice_alt_def] - \\ srw_tac[wordsLib.WORD_BIT_EQ_ss][]); + \\ srw_tac[wordsLib.WORD_BIT_EQ_ss][] +QED -Theorem set_byte_all_32 - `dimindex(:'a) = 32 ⇒ +Theorem set_byte_all_32: + dimindex(:'a) = 32 ⇒ set_byte (0w:'a word) b1 (set_byte 1w b2 (set_byte 2w b3 @@ -4909,14 +5177,16 @@ Theorem set_byte_all_32 set_byte 0w b1 (set_byte 1w b2 (set_byte 2w b3 - (set_byte 3w b8 y be) be) be) be` - (Cases_on`be` + (set_byte 3w b8 y be) be) be) be +Proof + Cases_on`be` \\ rw[set_byte_def,byte_index_def,dimword_def,word_slice_alt_def] - \\ srw_tac[wordsLib.WORD_BIT_EQ_ss][]); + \\ srw_tac[wordsLib.WORD_BIT_EQ_ss][] +QED (* slow *) -Theorem word_of_byte_set_byte_64 - `dimindex(:'a) = 64 ⇒ +Theorem word_of_byte_set_byte_64: + dimindex(:'a) = 64 ⇒ word_of_byte (w2w w) = set_byte 0w w (set_byte 1w w @@ -4925,28 +5195,33 @@ Theorem word_of_byte_set_byte_64 (set_byte 4w w (set_byte 5w w (set_byte 6w w - (set_byte 7w w (x:'a word) be) be) be) be) be) be) be) be` - (rw[word_of_byte_def,set_byte_def,byte_index_def,dimword_def,word_slice_alt_def] - \\ srw_tac[wordsLib.WORD_BIT_EQ_ss][]); - -Theorem word_of_byte_set_byte_32 - `dimindex(:'a) = 32 ⇒ + (set_byte 7w w (x:'a word) be) be) be) be) be) be) be) be +Proof + rw[word_of_byte_def,set_byte_def,byte_index_def,dimword_def,word_slice_alt_def] + \\ srw_tac[wordsLib.WORD_BIT_EQ_ss][] +QED + +Theorem word_of_byte_set_byte_32: + dimindex(:'a) = 32 ⇒ word_of_byte (w2w w) = set_byte 0w w (set_byte 1w w (set_byte 2w w - (set_byte 3w w (x:'a word) be) be) be) be` - (rw[word_of_byte_def,set_byte_def,byte_index_def,dimword_def,word_slice_alt_def] - \\ srw_tac[wordsLib.WORD_BIT_EQ_ss][]); - -Theorem write_bytes_change_extra - `∀ws bs be ws'. + (set_byte 3w w (x:'a word) be) be) be) be +Proof + rw[word_of_byte_def,set_byte_def,byte_index_def,dimword_def,word_slice_alt_def] + \\ srw_tac[wordsLib.WORD_BIT_EQ_ss][] +QED + +Theorem write_bytes_change_extra: + ∀ws bs be ws'. good_dimindex(:'a) ∧ LENGTH ws = LENGTH ws' ∧ LENGTH ws < byte_len (:'a) (LENGTH bs) ⇒ - write_bytes bs (ws:'a word list) be = write_bytes bs ws' be` - (Induct \\ rw[write_bytes_def,LENGTH_NIL_SYM] + write_bytes bs (ws:'a word list) be = write_bytes bs ws' be +Proof + Induct \\ rw[write_bytes_def,LENGTH_NIL_SYM] \\ Cases_on`ws'` \\ fs[write_bytes_def] \\ reverse conj_tac >- ( @@ -4975,16 +5250,18 @@ Theorem write_bytes_change_extra \\ TRY ( qmatch_goalsub_rename_tac`_::_::_::_::_::_::_::_::bs` \\ Cases_on`bs` \\ rfs[ADD1] ) - \\ simp[bytes_to_word_simp,set_byte_all_64,set_byte_all_32]); + \\ simp[bytes_to_word_simp,set_byte_all_64,set_byte_all_32] +QED -Theorem byte_len_lemma - `good_dimindex(:'a) ∧ +Theorem byte_len_lemma: + good_dimindex(:'a) ∧ byte_len (:'a) n = SUC l ⇒ n - l * (dimindex (:'a) DIV 8) = if n MOD (dimindex (:'a) DIV 8) = 0 then dimindex(:'a) DIV 8 - else n MOD (dimindex (:'a) DIV 8)` - (rw[labPropsTheory.good_dimindex_def,byte_len_def] + else n MOD (dimindex (:'a) DIV 8) +Proof + rw[labPropsTheory.good_dimindex_def,byte_len_def] \\ fs[DIV_EQ_X,MULT_CLAUSES,MOD_EQ_0_DIVISOR] \\ rfs[] \\ fs[MOD_EQ_0_DIVISOR] \\ rfs[] >- ( `4 * l < 4 * d` by decide_tac \\ fs[] ) @@ -5008,7 +5285,8 @@ Theorem byte_len_lemma \\ `n ≠ 8 * l + 8` suffices_by decide_tac \\ strip_tac \\ fs[] \\ first_x_assum(qspec_then`l+1`mp_tac) - \\ simp[] )); + \\ simp[] ) +QED val last_bytes_def = Define` last_bytes k b a w be = @@ -5022,17 +5300,19 @@ val last_bytes_simp = Q.prove( |> CONJUNCTS |> map GEN_ALL |> LIST_CONJ |> CONV_RULE numLib.SUC_TO_NUMERAL_DEFN_CONV |> curry save_thm "last_bytes_simp"; -Theorem last_bytes_bytes_to_word_REPLICATE - `!n k a w. +Theorem last_bytes_bytes_to_word_REPLICATE: + !n k a w. n <= k ==> bytes_to_word k a (REPLICATE n b) w be = - last_bytes n b a w be` - (Induct \\ rw[bytes_to_word_simp,REPLICATE] + last_bytes n b a w be +Proof + Induct \\ rw[bytes_to_word_simp,REPLICATE] >- ( rw[Once last_bytes_def] ) - \\ rw[Once last_bytes_def,SimpRHS]); + \\ rw[Once last_bytes_def,SimpRHS] +QED -Theorem memory_rel_RefByte_alt - `memory_rel c be refs sp st m dm vars ∧ +Theorem memory_rel_RefByte_alt: + memory_rel c be refs sp st m dm vars ∧ new ∉ FDOM refs ∧ byte_len (:'a) n < sp ∧ byte_len (:'a) n < 2 ** (dimindex (:α) − 4) /\ byte_len (:'a) n < 2 ** c.len_size /\ @@ -5048,8 +5328,9 @@ Theorem memory_rel_RefByte_alt store_list free (Word (make_byte_header c fl n)::ws) m dm = SOME m1 ∧ memory_rel c be (refs |+ (new,ByteArray fl (REPLICATE n w))) (sp − (byte_len (:'a) n + 1)) (st |+ (NextFree,Word (free + w'))) m1 dm - ((RefPtr new,make_ptr c (free − curr) 0w (byte_len (:'a) n))::vars))` - (simp_tac std_ss [LET_THM] + ((RefPtr new,make_ptr c (free − curr) 0w (byte_len (:'a) n))::vars)) +Proof + simp_tac std_ss [LET_THM] \\ rewrite_tac [CONJ_ASSOC] \\ once_rewrite_tac [CONJ_COMM] \\ fs [memory_rel_def,PULL_EXISTS] @@ -5177,23 +5458,29 @@ Theorem memory_rel_RefByte_alt \\ strip_tac \\ fs [] \\ fs [heap_length_def,el_length_def] \\ fs [GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] - \\ fs [AC STAR_ASSOC STAR_COMM] \\ fs [STAR_ASSOC]); - -Theorem memory_rel_tail - `memory_rel c be refs sp st m dm (v::vars) ==> - memory_rel c be refs sp st m dm vars` - (match_mp_tac memory_rel_rearrange \\ fs []); - -Theorem memory_rel_drop - `memory_rel c be refs sp st m dm (vs ++ vars) ==> - memory_rel c be refs sp st m dm vars` - (match_mp_tac memory_rel_rearrange \\ fs []); - -Theorem memory_rel_IMP_word_list_exists - `memory_rel c be refs sp st m dm vars /\ n <= sp /\ + \\ fs [AC STAR_ASSOC STAR_COMM] \\ fs [STAR_ASSOC] +QED + +Theorem memory_rel_tail: + memory_rel c be refs sp st m dm (v::vars) ==> + memory_rel c be refs sp st m dm vars +Proof + match_mp_tac memory_rel_rearrange \\ fs [] +QED + +Theorem memory_rel_drop: + memory_rel c be refs sp st m dm (vs ++ vars) ==> + memory_rel c be refs sp st m dm vars +Proof + match_mp_tac memory_rel_rearrange \\ fs [] +QED + +Theorem memory_rel_IMP_word_list_exists: + memory_rel c be refs sp st m dm vars /\ n <= sp /\ FLOOKUP st NextFree = SOME (Word f) ==> - (word_list_exists f n * SEP_T) (fun2set (m,dm))` - (fs [memory_rel_def,heap_in_memory_store_def] \\ rw [] \\ fs [] + (word_list_exists f n * SEP_T) (fun2set (m,dm)) +Proof + fs [memory_rel_def,heap_in_memory_store_def] \\ rw [] \\ fs [] \\ fs [word_ml_inv_def,abs_ml_inv_def,unused_space_inv_def] \\ Cases_on `n = 0` THEN1 (fs [word_list_exists_thm,SEP_CLAUSES] \\ fs [SEP_T_def]) @@ -5213,32 +5500,39 @@ Theorem memory_rel_IMP_word_list_exists \\ CONV_TAC (DEPTH_CONV ETA_CONV) \\ match_mp_tac SEP_IMP_STAR \\ fs [SEP_IMP_REFL] - \\ fs [SEP_IMP_def,SEP_T_def]); - -Theorem get_addr_0 - `get_addr c n u ' 0` - (Cases_on `u` \\ fs [get_addr_def,get_lowerbits_def, - word_or_def,fcpTheory.FCP_BETA,word_index]); - -Theorem word_addr_eq_Loc - `word_addr c v = Loc l1 l2 <=> v = Data (Loc l1 l2)` - (Cases_on `v` \\ fs [word_addr_def] - \\ Cases_on `a` \\ fs [word_addr_def]); - -Theorem memory_rel_CodePtr - `memory_rel c be refs sp st m dm vars ==> - memory_rel c be refs sp st m dm ((CodePtr lab,Loc lab 0)::vars)` - (fs [memory_rel_def] \\ rw [] \\ asm_exists_tac \\ fs [] + \\ fs [SEP_IMP_def,SEP_T_def] +QED + +Theorem get_addr_0: + get_addr c n u ' 0 +Proof + Cases_on `u` \\ fs [get_addr_def,get_lowerbits_def, + word_or_def,fcpTheory.FCP_BETA,word_index] +QED + +Theorem word_addr_eq_Loc: + word_addr c v = Loc l1 l2 <=> v = Data (Loc l1 l2) +Proof + Cases_on `v` \\ fs [word_addr_def] + \\ Cases_on `a` \\ fs [word_addr_def] +QED + +Theorem memory_rel_CodePtr: + memory_rel c be refs sp st m dm vars ==> + memory_rel c be refs sp st m dm ((CodePtr lab,Loc lab 0)::vars) +Proof + fs [memory_rel_def] \\ rw [] \\ asm_exists_tac \\ fs [] \\ fs [word_ml_inv_def,PULL_EXISTS,word_addr_eq_Loc] \\ once_rewrite_tac [CONJ_COMM] \\ asm_exists_tac \\ fs [] \\ fs [abs_ml_inv_def,bc_stack_ref_inv_def,v_inv_def, roots_ok_def,reachable_refs_def] \\ rw [] \\ fs [] \\ res_tac \\ fs [] \\ asm_exists_tac \\ fs [PULL_EXISTS] \\ rw [] \\ fs [] - \\ fs [get_refs_def] \\ res_tac); + \\ fs [get_refs_def] \\ res_tac +QED -Theorem memory_rel_Block_IMP - `memory_rel c be refs sp st m dm ((Block ts tag vals,v:'a word_loc)::vars) /\ +Theorem memory_rel_Block_IMP: + memory_rel c be refs sp st m dm ((Block ts tag vals,v:'a word_loc)::vars) /\ good_dimindex (:'a) ==> ?w. v = Word w /\ (* ASK: If the Block has no vals then it's timestamp is 0 *) @@ -5251,8 +5545,9 @@ Theorem memory_rel_Block_IMP get_real_addr c st w = SOME a /\ m a = Word x /\ a IN dm /\ decode_length c x = n2w (LENGTH vals) /\ LENGTH vals < 2 ** (dimindex (:'a) − 4) /\ - encode_header c (4 * tag) (LENGTH vals) = SOME x` - (fs [memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def, + encode_header c (4 * tag) (LENGTH vals) = SOME x +Proof + fs [memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def, bc_stack_ref_inv_def,v_inv_def] \\ CASE_TAC \\ fs [] \\ rw [] THEN1 (fs [word_addr_def,BlockNil_def,WORD_MUL_LSL,GSYM word_mul_n2w, @@ -5271,22 +5566,25 @@ Theorem memory_rel_Block_IMP \\ imp_res_tac EVERY2_LENGTH \\ SEP_R_TAC \\ fs [get_addr_0] \\ fs [make_header_def,word_bit_def,word_or_def,fcpTheory.FCP_BETA] \\ fs [labPropsTheory.good_dimindex_def] - \\ fs [fcpTheory.FCP_BETA,word_lsl_def,word_index]); + \\ fs [fcpTheory.FCP_BETA,word_lsl_def,word_index] +QED -Theorem IMP_memory_rel_Number - `good_dimindex (:'a) /\ small_int (:'a) i /\ +Theorem IMP_memory_rel_Number: + good_dimindex (:'a) /\ small_int (:'a) i /\ memory_rel c be refs sp st m dm vars ==> memory_rel c be refs sp st m dm - ((Number i,(Word (Smallnum i):'a word_loc))::vars)` - (fs [memory_rel_def,word_ml_inv_def,PULL_EXISTS] \\ rpt strip_tac + ((Number i,(Word (Smallnum i):'a word_loc))::vars) +Proof + fs [memory_rel_def,word_ml_inv_def,PULL_EXISTS] \\ rpt strip_tac \\ asm_exists_tac \\ fs [] \\ rpt_drule abs_ml_inv_Num \\ strip_tac \\ asm_exists_tac \\ fs [word_addr_def] \\ fs [Smallnum_def] \\ Cases_on `i` - \\ fs [GSYM word_mul_n2w,word_ml_inv_num_lemma,word_ml_inv_neg_num_lemma]); + \\ fs [GSYM word_mul_n2w,word_ml_inv_num_lemma,word_ml_inv_neg_num_lemma] +QED -Theorem memory_rel_El_any - `memory_rel c be refs sp st m dm ((Block ts tag vals,ptr:'a word_loc)::vars) /\ +Theorem memory_rel_El_any: + memory_rel c be refs sp st m dm ((Block ts tag vals,ptr:'a word_loc)::vars) /\ good_dimindex (:'a) /\ index < LENGTH vals ==> ?ptr_w x y:'a word. @@ -5295,8 +5593,9 @@ Theorem memory_rel_El_any (x + bytes_in_word + bytes_in_word * n2w index) IN dm /\ memory_rel c be refs sp st m dm ((EL index vals,m (x + bytes_in_word + bytes_in_word * n2w index)):: - (Block ts tag vals,ptr)::vars)` - (rw [] \\ rpt_drule memory_rel_Block_IMP \\ rw [] \\ fs [] + (Block ts tag vals,ptr)::vars) +Proof + rw [] \\ rpt_drule memory_rel_Block_IMP \\ rw [] \\ fs [] \\ Cases_on `vals = []` \\ fs [] \\ `memory_rel c be refs sp st m dm ((Block ts tag vals,Word w)::(Number (&index), @@ -5309,7 +5608,8 @@ Theorem memory_rel_El_any \\ rveq \\ fs [bytes_in_word_def] \\ rfs [word_mul_n2w,WORD_MUL_LSL] \\ pop_assum mp_tac \\ match_mp_tac memory_rel_rearrange - \\ fs [] \\ rw [] \\ fs []); + \\ fs [] \\ rw [] \\ fs [] +QED val copy_list_def = Define ` copy_list c' st k (a,x,b:'a word,m:'a word -> 'a word_loc,dm) = @@ -5324,8 +5624,8 @@ val copy_list_def = Define ` let a = m (a + 2w * bytes_in_word) in if c then copy_list c' st (k-1) (a,x,b,m,dm) else NONE`; -Theorem copy_list_thm - `!v k vs b m vars a x frame. +Theorem copy_list_thm = Q.prove(` + !v k vs b m vars a x frame. memory_rel c be refs sp st m dm ((v,a:'a word_loc)::vars) /\ v_to_list v = SOME vs /\ (word_list_exists (b + bytes_in_word * n2w k) (SUC (LENGTH vs)) * frame) @@ -5338,8 +5638,8 @@ Theorem copy_list_thm SOME (b + bytes_in_word * n2w (k + LENGTH vs + 1),m1) /\ LENGTH vs = LENGTH xs /\ memory_rel c be refs sp st m1 dm (ZIP (vs,xs) ++ vars) /\ - (word_list (b + bytes_in_word * n2w k) (x::xs) * frame) (fun2set (m1,dm))` - (Induct_on `vs` + (word_list (b + bytes_in_word * n2w k) (x::xs) * frame) (fun2set (m1,dm))`, + Induct_on `vs` THEN1 (rewrite_tac [LENGTH,word_list_exists_thm] \\ fs [] \\ rw [] \\ once_rewrite_tac [copy_list_def] \\ fs [] @@ -5419,8 +5719,8 @@ Theorem copy_list_thm |> Q.SPECL [`v`,`0`] |> SIMP_RULE (srw_ss()) [WORD_MULT_CLAUSES] |> Q.GEN `v`; -Theorem memory_rel_FromList - `v_to_list v = SOME vs /\ vs <> [] /\ +Theorem memory_rel_FromList: + v_to_list v = SOME vs /\ vs <> [] /\ memory_rel c be refs sp st m dm ((v,a:'a word_loc)::vars) /\ encode_header c (4 * tag) (LENGTH vs) = SOME hd ∧ LENGTH vs < sp ∧ good_dimindex (:α) ==> @@ -5430,8 +5730,9 @@ Theorem memory_rel_FromList copy_list c st (LENGTH vs) (a,Word hd,free,m,dm) = SOME (f1,m1) /\ memory_rel c be refs (sp − (LENGTH vs + 1)) (st |+ (NextFree,Word f1)) m1 dm ((Block ts tag vs, - make_cons_ptr c (free − curr) tag (LENGTH vs))::vars)` - (strip_tac + make_cons_ptr c (free − curr) tag (LENGTH vs))::vars) +Proof + strip_tac \\ `?f. FLOOKUP st NextFree = SOME (Word f)` by fs [memory_rel_def,heap_in_memory_store_def] \\ rpt_drule copy_list_thm @@ -5440,7 +5741,8 @@ Theorem memory_rel_FromList \\ strip_tac \\ disch_then drule \\ disch_then (qspecl_then [`Word hd`] strip_assume_tac) \\ fs [] \\ rpt_drule memory_rel_Cons_alt - \\ strip_tac \\ fs []); + \\ strip_tac \\ fs [] +QED val make_header_tag_mask = Q.prove( `k < 2 ** (dimindex (:α) − (c.len_size + 2)) ==> @@ -5468,11 +5770,12 @@ val make_header_and_2 = Q.prove( \\ srw_tac [wordsLib.WORD_BIT_EQ_ss] [word_index] \\ Cases_on `i=1` \\ fs []); -Theorem encode_header_tag_mask - `encode_header c (4 * tag) n = SOME (w:'a word) /\ good_dimindex (:'a) ==> +Theorem encode_header_tag_mask: + encode_header c (4 * tag) n = SOME (w:'a word) /\ good_dimindex (:'a) ==> tag < dimword (:α) DIV 16 /\ - (w && (tag_mask c ‖ 2w)) = n2w (16 * tag + 2)` - (strip_tac \\ fs [encode_header_def,WORD_LEFT_AND_OVER_OR] + (w && (tag_mask c ‖ 2w)) = n2w (16 * tag + 2) +Proof + strip_tac \\ fs [encode_header_def,WORD_LEFT_AND_OVER_OR] \\ rw [make_header_and_2] \\ drule (GEN_ALL make_header_tag_mask) \\ fs [] \\ rw [GSYM word_add_n2w] @@ -5481,15 +5784,18 @@ Theorem encode_header_tag_mask \\ fs [bitTheory.BIT_DIV2 |> Q.SPEC `0` |> SIMP_RULE std_ss [ADD1] |> GSYM,bitTheory.BIT0_ODD] \\ rewrite_tac [DECIDE ``16 * n = (8 * n) * 2n``, - MATCH_MP MULT_DIV (DECIDE ``0<2n``),ODD_MULT] \\ fs []); + MATCH_MP MULT_DIV (DECIDE ``0<2n``),ODD_MULT] \\ fs [] +QED -Theorem memory_rel_tag_limit - `memory_rel c be refs sp st m dm ((Block ts tag l,(w:'a word_loc))::rest) /\ +Theorem memory_rel_tag_limit: + memory_rel c be refs sp st m dm ((Block ts tag l,(w:'a word_loc))::rest) /\ good_dimindex (:'a) ==> - tag < dimword (:'a) DIV 16` - (strip_tac \\ drule memory_rel_Block_IMP \\ fs [] \\ rw [] + tag < dimword (:'a) DIV 16 +Proof + strip_tac \\ drule memory_rel_Block_IMP \\ fs [] \\ rw [] \\ every_case_tac \\ fs [] - \\ imp_res_tac encode_header_tag_mask \\ fs []); + \\ imp_res_tac encode_header_tag_mask \\ fs [] +QED val LESS_DIV_16_IMP = Q.prove( `n < k DIV 16 ==> 16 * n + 2 < k:num`, @@ -5499,23 +5805,27 @@ val MULT_BIT0 = Q.prove( `BIT 0 (m * n) <=> BIT 0 m /\ BIT 0 n`, fs [bitTheory.BIT0_ODD,ODD_MULT]); -Theorem memory_rel_test_nil_eq - `memory_rel c be refs sp st m dm ((Block ts tag l,w:'a word_loc)::rest) /\ +Theorem memory_rel_test_nil_eq: + memory_rel c be refs sp st m dm ((Block ts tag l,w:'a word_loc)::rest) /\ n < dimword (:'a) DIV 16 /\ good_dimindex (:'a) ==> - ?v. w = Word v /\ (v = n2w (16 * n + 2) <=> tag = n /\ l = [])` - (strip_tac \\ drule memory_rel_Block_IMP \\ fs [] \\ rw [] + ?v. w = Word v /\ (v = n2w (16 * n + 2) <=> tag = n /\ l = []) +Proof + strip_tac \\ drule memory_rel_Block_IMP \\ fs [] \\ rw [] \\ reverse every_case_tac \\ fs [] THEN1 (CCONTR_TAC \\ rw [] \\ fs [word_index,bitTheory.ADD_BIT0,MULT_BIT0]) \\ fs [word_mul_n2w,word_add_n2w] - \\ imp_res_tac LESS_DIV_16_IMP \\ fs []); + \\ imp_res_tac LESS_DIV_16_IMP \\ fs [] +QED -Theorem memory_rel_test_none_eq - `encode_header c (4 * n) len = (NONE:'a word option) /\ +Theorem memory_rel_test_none_eq: + encode_header c (4 * n) len = (NONE:'a word option) /\ memory_rel c be refs sp st m dm ((Block ts tag l,w:'a word_loc)::rest) /\ len <> 0 /\ good_dimindex (:'a) ==> - ~(tag = n /\ LENGTH l = len)` - (strip_tac \\ drule memory_rel_Block_IMP \\ fs [] \\ rw [] - \\ CCONTR_TAC \\ fs [] \\ rw [] \\ rfs [LENGTH_NIL,PULL_EXISTS]); + ~(tag = n /\ LENGTH l = len) +Proof + strip_tac \\ drule memory_rel_Block_IMP \\ fs [] \\ rw [] + \\ CCONTR_TAC \\ fs [] \\ rw [] \\ rfs [LENGTH_NIL,PULL_EXISTS] +QED val not_bit_lt_2exp = Q.prove( `!p x n. n < 2 ** (p + 1) ==> ~BIT (p + (x + 1)) n`, @@ -5524,12 +5834,13 @@ val not_bit_lt_2exp = Q.prove( val not_bit_lt_2 = not_bit_lt_2exp |> Q.SPEC `0` |> SIMP_RULE (srw_ss()) [] -Theorem encode_header_EQ - `encode_header c t1 l1 = SOME (w1:'a word) /\ +Theorem encode_header_EQ: + encode_header c t1 l1 = SOME (w1:'a word) /\ encode_header c t2 l2 = SOME (w2:'a word) /\ c.len_size + 2 < dimindex (:'a) ==> - (w1 = w2 <=> t1 = t2 /\ l1 = l2)` - (fs [encode_header_def] \\ rw [] \\ fs [make_header_def,LET_THM] + (w1 = w2 <=> t1 = t2 /\ l1 = l2) +Proof + fs [encode_header_def] \\ rw [] \\ fs [make_header_def,LET_THM] \\ srw_tac [wordsLib.WORD_BIT_EQ_ss] [wordsTheory.word_index] \\ Tactical.REVERSE EQ_TAC >- rw [] \\ `4 <= dimindex(:'a)` @@ -5580,17 +5891,18 @@ Theorem encode_header_EQ \\ res_tac \\ fs [] \\ rfs [not_bit_lt_2exp] - ); +QED -Theorem memory_rel_ValueArray_IMP - `memory_rel c be refs sp st m dm ((RefPtr p,v:'a word_loc)::vars) /\ +Theorem memory_rel_ValueArray_IMP: + memory_rel c be refs sp st m dm ((RefPtr p,v:'a word_loc)::vars) /\ FLOOKUP refs p = SOME (ValueArray vals) /\ good_dimindex (:'a) ==> ?w a x. v = Word w /\ w ' 0 /\ word_bit 3 x /\ ~word_bit 2 x /\ ~word_bit 4 x /\ get_real_addr c st w = SOME a /\ m a = Word x /\ a IN dm /\ decode_length c x = n2w (LENGTH vals) /\ - LENGTH vals < 2 ** (dimindex (:'a) − 4)` - (fs [memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def, + LENGTH vals < 2 ** (dimindex (:'a) − 4) +Proof + fs [memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def, bc_stack_ref_inv_def,v_inv_def,word_addr_def] \\ rw [get_addr_0] \\ `bc_ref_inv c p refs (f,heap,be)` by (first_x_assum match_mp_tac \\ fs [reachable_refs_def] @@ -5606,24 +5918,28 @@ Theorem memory_rel_ValueArray_IMP \\ imp_res_tac EVERY2_LENGTH \\ SEP_R_TAC \\ fs [get_addr_0] \\ fs [make_header_def,word_bit_def,word_or_def,fcpTheory.FCP_BETA] \\ fs [labPropsTheory.good_dimindex_def] - \\ fs [fcpTheory.FCP_BETA,word_lsl_def,word_index]) + \\ fs [fcpTheory.FCP_BETA,word_lsl_def,word_index] +QED val expand_num = DECIDE ``4 = SUC 3 /\ 3 = SUC 2 /\ 2 = SUC 1 /\ 1 = SUC 0 /\ 5 = SUC 4 /\ 6 = SUC 5 /\ 7 = SUC 6 /\ 8 = SUC 7`` -Theorem get_byte_set_byte_alt - `good_dimindex (:'a) /\ w <> v /\ byte_align w = byte_align v /\ +Theorem get_byte_set_byte_alt: + good_dimindex (:'a) /\ w <> v /\ byte_align w = byte_align v /\ get_byte w s be = x ==> - get_byte w (set_byte v b (s:'a word) be) be = x` - (rw [] \\ rpt_drule labPropsTheory.get_byte_set_byte_diff \\ fs []); + get_byte w (set_byte v b (s:'a word) be) be = x +Proof + rw [] \\ rpt_drule labPropsTheory.get_byte_set_byte_diff \\ fs [] +QED -Theorem get_byte_bytes_to_word - `∀zs (t:'a word). +Theorem get_byte_bytes_to_word: + ∀zs (t:'a word). i < LENGTH zs /\ i < 2 ** k /\ 2 ** k = dimindex(:'a) DIV 8 /\ good_dimindex (:'a) ⇒ - get_byte (n2w i) (bytes_to_word (2 ** k) 0w zs t be) be = EL i zs` - (rw [] \\ fs [] \\ Cases_on `dimindex (:α) = 32` \\ fs [] THEN1 + get_byte (n2w i) (bytes_to_word (2 ** k) 0w zs t be) be = EL i zs +Proof + rw [] \\ fs [] \\ Cases_on `dimindex (:α) = 32` \\ fs [] THEN1 (fs [LESS_4] \\ fs [] \\ Cases_on `zs` \\ fs [] \\ TRY (Cases_on `t'`) \\ fs [] @@ -5651,7 +5967,8 @@ Theorem get_byte_bytes_to_word \\ match_mp_tac get_byte_set_byte_alt \\ fs [dimword_def,alignmentTheory.byte_align_def, alignmentTheory.align_w2n])) - \\ rfs [labPropsTheory.good_dimindex_def]); + \\ rfs [labPropsTheory.good_dimindex_def] +QED val MOD_MULT_MOD_LEMMA = Q.prove( `k MOD n = 0 /\ x MOD n = t /\ 0 < k /\ 0 < n /\ n <= k ==> @@ -5662,39 +5979,46 @@ val MOD_MULT_MOD_LEMMA = Q.prove( \\ fs [] \\ Cases_on `0 < k DIV n` \\ fs [MOD_MULT_MOD] \\ fs [DIV_EQ_X] \\ rfs [DIV_EQ_X]); -Theorem w2n_add_byte_align_lemma - `good_dimindex (:'a) ==> +Theorem w2n_add_byte_align_lemma: + good_dimindex (:'a) ==> w2n (a' + byte_align (a:'a word)) MOD (dimindex (:'a) DIV 8) = - w2n a' MOD (dimindex (:'a) DIV 8)` - (Cases_on `a'` \\ Cases_on `a` + w2n a' MOD (dimindex (:'a) DIV 8) +Proof + Cases_on `a'` \\ Cases_on `a` \\ fs [byte_align_def,align_w2n] \\ fs [labPropsTheory.good_dimindex_def] \\ rw [] \\ fs [word_add_n2w] \\ fs [dimword_def] \\ match_mp_tac MOD_MULT_MOD_LEMMA \\ fs [] \\ once_rewrite_tac [MULT_COMM] \\ once_rewrite_tac [ADD_COMM] - \\ fs [MOD_TIMES]); + \\ fs [MOD_TIMES] +QED -Theorem get_byte_byte_align - `good_dimindex (:'a) ==> - get_byte (a' + byte_align a) w be = get_byte a' (w:'a word) be` - (fs [get_byte_def] \\ rw [] \\ rpt AP_TERM_TAC - \\ fs [byte_index_def,w2n_add_byte_align_lemma]); - -Theorem get_byte_eq - `good_dimindex (:'a) /\ a = byte_align a + a' ==> - get_byte a w be = get_byte a' (w:'a word) be` - (rw [] \\ pop_assum (fn th => once_rewrite_tac [th]) - \\ fs [get_byte_byte_align]); - -Theorem decode_length_make_byte_header - `good_dimindex(:α) ∧ c.len_size + 7 < dimindex(:α) ∧ +Theorem get_byte_byte_align: + good_dimindex (:'a) ==> + get_byte (a' + byte_align a) w be = get_byte a' (w:'a word) be +Proof + fs [get_byte_def] \\ rw [] \\ rpt AP_TERM_TAC + \\ fs [byte_index_def,w2n_add_byte_align_lemma] +QED + +Theorem get_byte_eq: + good_dimindex (:'a) /\ a = byte_align a + a' ==> + get_byte a w be = get_byte a' (w:'a word) be +Proof + rw [] \\ pop_assum (fn th => once_rewrite_tac [th]) + \\ fs [get_byte_byte_align] +QED + +Theorem decode_length_make_byte_header: + good_dimindex(:α) ∧ c.len_size + 7 < dimindex(:α) ∧ len + (2 ** shift(:α) - 1) < 2 ** (c.len_size + shift(:α)) ⇒ len ≤ w2n ((decode_length c (make_byte_header c fl len)):α word) * (dimindex(:α) DIV 8) ∧ w2n ((decode_length c (make_byte_header c fl len)):α word) ≤ - len DIV (dimindex(:α) DIV 8) + 1` - (simp[decode_length_def,make_byte_header_def,labPropsTheory.good_dimindex_def] + len DIV (dimindex(:α) DIV 8) + 1 +Proof + simp[decode_length_def,make_byte_header_def,labPropsTheory.good_dimindex_def] \\ strip_tac \\ simp[] \\ qpat_abbrev_tac`z = COND _ _ _ >>> _` \\ `z = 0w` @@ -5750,13 +6074,15 @@ Theorem decode_length_make_byte_header \\ disch_then(qspec_then`len`mp_tac) \\ `len MOD n + n < n + n` by simp[] \\ qunabbrev_tac`n` - \\ decide_tac); + \\ decide_tac +QED -Theorem write_bytes_same - `∀ws b1 b2. +Theorem write_bytes_same: + ∀ws b1 b2. (∀n. n < LENGTH (ws:α word list) * (dimindex(:α) DIV 8) ⇒ n < LENGTH b1 ∧ n < LENGTH b2 ∧ EL n b1 = EL n b2) - ⇒ write_bytes b1 ws be = write_bytes b2 ws be` - (Induct \\ rw[write_bytes_def] + ⇒ write_bytes b1 ws be = write_bytes b2 ws be +Proof + Induct \\ rw[write_bytes_def] >- ( match_mp_tac bytes_to_word_same \\ gen_tac \\ strip_tac @@ -5767,14 +6093,16 @@ Theorem write_bytes_same \\ fs[MULT] \\ qpat_abbrev_tac`bw= _ DIV _` \\ first_x_assum(qspec_then`n+bw`mp_tac) - \\ simp[EL_DROP]); + \\ simp[EL_DROP] +QED -Theorem set_byte_bytes_to_word - `i < LENGTH ls ∧ i < 2 ** k ∧ 2 ** k = dimindex (:α) DIV 8 ∧ +Theorem set_byte_bytes_to_word: + i < LENGTH ls ∧ i < 2 ** k ∧ 2 ** k = dimindex (:α) DIV 8 ∧ good_dimindex(:α) ⇒ set_byte (n2w i) b (bytes_to_word (2 ** k) 0w ls t be) be = - bytes_to_word (2 ** k) (0w:'a word) (LUPDATE b i ls) t be` - (rw[] \\ fs[] \\ fs[labPropsTheory.good_dimindex_def] \\ fs[] + bytes_to_word (2 ** k) (0w:'a word) (LUPDATE b i ls) t be +Proof + rw[] \\ fs[] \\ fs[labPropsTheory.good_dimindex_def] \\ fs[] \\ fs[LESS_4,LESS_8] \\ fs[] \\ Cases_on`ls` \\ fs[] \\ TRY (Cases_on`t'`) \\ fs[] @@ -5786,7 +6114,8 @@ Theorem set_byte_bytes_to_word \\ TRY (Cases_on`t'`) \\ fs[] \\ rewrite_tac[expand_num,bytes_to_word_def,LUPDATE_def] \\ fs [ADD1] \\ rpt (fs [Once set_byte_sort,labPropsTheory.good_dimindex_def] - \\ AP_THM_TAC \\ AP_TERM_TAC)); + \\ AP_THM_TAC \\ AP_TERM_TAC) +QED Theorem heap_in_memory_store_UpdateByte `heap_in_memory_store heap a sp sp1 gens c s m dm limit ∧ @@ -6001,8 +6330,8 @@ val hide_memory_rel_def = Define` val hide_heap_in_memory_store_def = Define` hide_heap_in_memory_store = heap_in_memory_store`; -Theorem memory_rel_ByteArray_IMP - `memory_rel c be refs sp st m dm ((RefPtr p,v:'a word_loc)::vars) /\ +Theorem memory_rel_ByteArray_IMP: + memory_rel c be refs sp st m dm ((RefPtr p,v:'a word_loc)::vars) /\ FLOOKUP refs p = SOME (ByteArray fl vals) /\ good_dimindex (:'a) ==> ?w a x l. v = Word w /\ w ' 0 /\ @@ -6023,8 +6352,9 @@ Theorem memory_rel_ByteArray_IMP (x >>> (dimindex (:'a) - c.len_size - 2) = n2w (LENGTH vals + 3)) else LENGTH vals + 7 < 2 ** (dimindex (:'a) - 3) /\ - (x >>> (dimindex (:'a) - c.len_size - 3) = n2w (LENGTH vals + 7))` - (CONV_TAC(RAND_CONV(REWRITE_CONV[GSYM hide_memory_rel_def])) + (x >>> (dimindex (:'a) - c.len_size - 3) = n2w (LENGTH vals + 7)) +Proof + CONV_TAC(RAND_CONV(REWRITE_CONV[GSYM hide_memory_rel_def])) \\ qpat_abbrev_tac`P = $= (make_byte_header _ _ _)` \\ fs [memory_rel_def,word_ml_inv_def,PULL_EXISTS, bc_stack_ref_inv_def,v_inv_def,word_addr_def] @@ -6266,62 +6596,73 @@ Theorem memory_rel_ByteArray_IMP \\ qmatch_assum_abbrev_tac`(x:num) + y ≤ z` \\ qmatch_abbrev_tac`x + y' < z` \\ `y' < y` by simp[Abbr`y`,Abbr`y'`] - \\ decide_tac)); + \\ decide_tac) +QED -Theorem memory_rel_RefPtr_IMP_lemma - `memory_rel c be refs sp st m dm ((RefPtr p,v:'a word_loc)::vars) ==> - ?res. FLOOKUP refs p = SOME res` - (fs [memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def, +Theorem memory_rel_RefPtr_IMP_lemma: + memory_rel c be refs sp st m dm ((RefPtr p,v:'a word_loc)::vars) ==> + ?res. FLOOKUP refs p = SOME res +Proof + fs [memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def, bc_stack_ref_inv_def,v_inv_def,word_addr_def] \\ rw [] \\ `bc_ref_inv c p refs (f,heap,be)` by (first_x_assum match_mp_tac \\ fs [reachable_refs_def] \\ qexists_tac `RefPtr p` \\ fs [get_refs_def]) \\ pop_assum mp_tac \\ simp [bc_ref_inv_def] - \\ fs [FLOOKUP_DEF] \\ rw []); + \\ fs [FLOOKUP_DEF] \\ rw [] +QED -Theorem memory_rel_RefPtr_IMP - `memory_rel c be refs sp st m dm ((RefPtr p,v:'a word_loc)::vars) /\ +Theorem memory_rel_RefPtr_IMP: + memory_rel c be refs sp st m dm ((RefPtr p,v:'a word_loc)::vars) /\ good_dimindex (:'a) ==> ?w a x. v = Word w /\ w ' 0 /\ (word_bit 4 x ==> word_bit 2 x) /\ (word_bit 3 x <=> ~word_bit 2 x) /\ - get_real_addr c st w = SOME a /\ m a = Word x /\ a IN dm` - (strip_tac \\ drule memory_rel_RefPtr_IMP_lemma \\ strip_tac + get_real_addr c st w = SOME a /\ m a = Word x /\ a IN dm +Proof + strip_tac \\ drule memory_rel_RefPtr_IMP_lemma \\ strip_tac \\ Cases_on `res` \\ fs [] THEN1 (rpt_drule memory_rel_ValueArray_IMP \\ rw [] \\ fs []) - THEN1 (rpt_drule memory_rel_ByteArray_IMP \\ rw [] \\ fs [])); + THEN1 (rpt_drule memory_rel_ByteArray_IMP \\ rw [] \\ fs []) +QED -Theorem Smallnum_bits - `(1w && Smallnum i) = 0w /\ (2w && Smallnum i) = 0w` - (Cases_on `i` +Theorem Smallnum_bits: + (1w && Smallnum i) = 0w /\ (2w && Smallnum i) = 0w +Proof + Cases_on `i` \\ srw_tac [wordsLib.WORD_MUL_LSL_ss] [Smallnum_def, GSYM wordsTheory.word_mul_n2w] - \\ srw_tac [wordsLib.WORD_BIT_EQ_ss] [wordsTheory.word_index]) + \\ srw_tac [wordsLib.WORD_BIT_EQ_ss] [wordsTheory.word_index] +QED -Theorem memory_rel_any_Number_IMP - `good_dimindex (:'a) /\ +Theorem memory_rel_any_Number_IMP: + good_dimindex (:'a) /\ memory_rel c be refs sp st m dm ((Number i,v:'a word_loc)::vars) ==> - ?w. v = Word w /\ (w ' 0 <=> ~small_int (:'a) i)` - (fs [memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def, + ?w. v = Word w /\ (w ' 0 <=> ~small_int (:'a) i) +Proof + fs [memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def, bc_stack_ref_inv_def,v_inv_def] \\ rw [] \\ fs [word_addr_def,get_addr_0] \\ fs [fcpTheory.FCP_BETA,word_and_def,word_index] \\ rewrite_tac [WORD_NEG,WORD_ADD_BIT0,word_index,word_1comp_def] \\ simp_tac std_ss [fcpTheory.FCP_BETA,DIMINDEX_GT_0,word_1comp_def] - \\ EVAL_TAC); + \\ EVAL_TAC +QED -Theorem memory_rel_Number_IMP - `good_dimindex (:'a) /\ small_int (:'a) i /\ +Theorem memory_rel_Number_IMP: + good_dimindex (:'a) /\ small_int (:'a) i /\ memory_rel c be refs sp st m dm ((Number i,v:'a word_loc)::vars) ==> - v = Word (Smallnum i)` - (fs [memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def, + v = Word (Smallnum i) +Proof + fs [memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def, bc_stack_ref_inv_def,v_inv_def] \\ rw [] \\ fs [word_addr_def,Smallnum_def,integer_wordTheory.i2w_def] \\ Cases_on `i` - \\ fs [GSYM word_mul_n2w,word_ml_inv_num_lemma,word_ml_inv_neg_num_lemma]) + \\ fs [GSYM word_mul_n2w,word_ml_inv_num_lemma,word_ml_inv_neg_num_lemma] +QED -Theorem memory_rel_Number_bignum_IMP_ALT - `memory_rel c be refs sp st m dm ((Number i,v)::vars) /\ +Theorem memory_rel_Number_bignum_IMP_ALT: + memory_rel c be refs sp st m dm ((Number i,v)::vars) /\ ~small_int (:'a) i /\ good_dimindex (:'a) ==> ?ff w x a y. v = Word w /\ (w && 1w) <> (0w:'a word) /\ @@ -6337,8 +6678,9 @@ Theorem memory_rel_Number_bignum_IMP_ALT LENGTH (n2mw (Num (ABS i)):'a word list) < 2 ** (dimindex (:α) − 4) /\ LENGTH (n2mw (Num (ABS i)):'a word list) < dimword (:'a) /\ decode_length c x = n2w - (LENGTH (n2mw (Num (ABS i)):'a word list))` - (fs[memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def, + (LENGTH (n2mw (Num (ABS i)):'a word list)) +Proof + fs[memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def, bc_stack_ref_inv_def,v_inv_def] \\ rw[] \\ fs[word_addr_def] \\ fs[heap_in_memory_store_def] \\ imp_res_tac get_real_addr_get_addr \\ fs [] @@ -6374,18 +6716,20 @@ Theorem memory_rel_Number_bignum_IMP_ALT \\ rfs [] \\ fs [] \\ NO_TAC) \\ srw_tac [wordsLib.WORD_BIT_EQ_ss] [wordsTheory.word_index] \\ fs [GSYM integerTheory.INT_NOT_LT] - \\ Cases_on `i < 0i` \\ fs [] \\ EVAL_TAC); + \\ Cases_on `i < 0i` \\ fs [] \\ EVAL_TAC +QED -Theorem memory_rel_Number_bignum_header - `memory_rel c be refs sp st m dm ((Number i,v:'a word_loc)::vars) /\ +Theorem memory_rel_Number_bignum_header: + memory_rel c be refs sp st m dm ((Number i,v:'a word_loc)::vars) /\ ~small_int (:'a) i /\ good_dimindex (:'a) ==> ?ff w x a y. v = Word w /\ get_real_addr c st w = SOME a /\ IS_SOME ((encode_header c (w2n ((b2w (i < 0) ≪ 2 ‖ 3w):'a word)) (LENGTH (n2mw (Num (ABS i)):'a word list))):'a word option) /\ m a = Word (make_header c (b2w (i < 0) ≪ 2 ‖ 3w) - (LENGTH (n2mw (Num (ABS i)):'a word list)))` - (fs[memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def, + (LENGTH (n2mw (Num (ABS i)):'a word list))) +Proof + fs[memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def, bc_stack_ref_inv_def,v_inv_def] \\ rw[] \\ fs[word_addr_def] \\ fs[heap_in_memory_store_def] \\ imp_res_tac get_real_addr_get_addr \\ fs [] @@ -6395,10 +6739,11 @@ Theorem memory_rel_Number_bignum_header Bignum_def,multiwordTheory.i2mw_def] \\ fs [word_payload_def,make_header_def] \\ SEP_R_TAC \\ fs [] - \\ full_simp_tac (std_ss++sep_cond_ss) [cond_STAR]); + \\ full_simp_tac (std_ss++sep_cond_ss) [cond_STAR] +QED -Theorem memory_rel_bignum_cmp - `memory_rel c be refs sp st m dm +Theorem memory_rel_bignum_cmp: + memory_rel c be refs sp st m dm ((Number i1,v1)::(Number i2,v2:'a word_loc)::vars) /\ good_dimindex (:'a) /\ ~small_int (:'a) i1 /\ ~small_int (:'a) i2 ==> ?w1 w2 a1 a2 x1 x2. @@ -6409,8 +6754,9 @@ Theorem memory_rel_bignum_cmp m a2 = Word x2 /\ (x1 <> x2 ==> (decode_length c (x1) = decode_length c (x2)) ==> - ((16w && x1) = 0w) <> ((16w && x2) = 0w))` - (fs [``~word_bit 4 w`` |> SIMP_CONV (srw_ss()) [word_bit_test] |> GSYM] + ((16w && x1) = 0w) <> ((16w && x2) = 0w)) +Proof + fs [``~word_bit 4 w`` |> SIMP_CONV (srw_ss()) [word_bit_test] |> GSYM] \\ strip_tac \\ rpt_drule memory_rel_Number_bignum_header \\ rpt_drule memory_rel_Number_bignum_IMP_ALT @@ -6419,10 +6765,11 @@ Theorem memory_rel_bignum_cmp \\ rpt_drule memory_rel_Number_bignum_IMP_ALT \\ rw [] \\ fs [] \\ fs [``~word_bit 4 w`` |> SIMP_CONV (srw_ss()) [word_bit_test] |> GSYM] - \\ rfs [] \\ rveq \\ fs [] \\ rw [] \\ CCONTR_TAC \\ fs []) + \\ rfs [] \\ rveq \\ fs [] \\ rw [] \\ CCONTR_TAC \\ fs [] +QED -Theorem memory_rel_Number_bignum_IMP - `memory_rel c be refs sp st m dm ((Number i,v)::vars) /\ +Theorem memory_rel_Number_bignum_IMP: + memory_rel c be refs sp st m dm ((Number i,v)::vars) /\ ~small_int (:'a) i /\ good_dimindex (:'a) ==> ?w x a y. v = Word w /\ (w && 1w) <> (0w:'a word) /\ @@ -6430,11 +6777,13 @@ Theorem memory_rel_Number_bignum_IMP a IN dm /\ m a = Word x /\ ((x && 8w) <> 0w) /\ a + bytes_in_word IN dm /\ m (a + bytes_in_word) = Word (n2w (Num (ABS i))) /\ - ((x && 16w) = 0w <=> 0 <= i)` - (metis_tac [memory_rel_Number_bignum_IMP_ALT]); + ((x && 16w) = 0w <=> 0 <= i) +Proof + metis_tac [memory_rel_Number_bignum_IMP_ALT] +QED -Theorem memory_rel_Word64_IMP - `memory_rel c be refs sp st m dm ((Word64 w64,v:'a word_loc)::vars) /\ +Theorem memory_rel_Word64_IMP: + memory_rel c be refs sp st m dm ((Word64 w64,v:'a word_loc)::vars) /\ good_dimindex (:'a) ==> ?ptr x w. v = Word (get_addr c ptr (Word 0w)) ∧ @@ -6449,8 +6798,9 @@ Theorem memory_rel_Word64_IMP else (m (x + bytes_in_word) = Word ((63 >< 0) w64)) /\ decode_length c w = 1w /\ - w = make_header c 3w 1` - (fs[memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def, + w = make_header c 3w 1 +Proof + fs[memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def, bc_stack_ref_inv_def,v_inv_def] \\ rw[] \\ fs[word_addr_def] \\ qexists_tac`ptr` \\ simp[] @@ -6473,37 +6823,43 @@ Theorem memory_rel_Word64_IMP \\ IF_CASES_TAC \\ fs[] \\ rveq \\ fs[word_payload_def,word_list_def,LSL_ONE] \\ SEP_R_TAC \\ fs[] - \\ full_simp_tac (std_ss++sep_cond_ss) [cond_STAR]); + \\ full_simp_tac (std_ss++sep_cond_ss) [cond_STAR] +QED -Theorem IMP_memory_rel_Number_num3 - `good_dimindex (:'a) /\ n < 2 ** (dimindex (:'a) - 3) /\ +Theorem IMP_memory_rel_Number_num3: + good_dimindex (:'a) /\ n < 2 ** (dimindex (:'a) - 3) /\ memory_rel c be refs sp st m dm vars ==> memory_rel c be refs sp st m dm - ((Number (&n),Word ((n2w n << 2):'a word))::vars)` - (strip_tac \\ mp_tac (IMP_memory_rel_Number |> Q.INST [`i`|->`&n`]) \\ fs [] + ((Number (&n),Word ((n2w n << 2):'a word))::vars) +Proof + strip_tac \\ mp_tac (IMP_memory_rel_Number |> Q.INST [`i`|->`&n`]) \\ fs [] \\ fs [Smallnum_def,WORD_MUL_LSL,word_mul_n2w] \\ disch_then match_mp_tac \\ fs [small_int_def,dimword_def] - \\ fs [labPropsTheory.good_dimindex_def] \\ rfs []) + \\ fs [labPropsTheory.good_dimindex_def] \\ rfs [] +QED -Theorem IMP_memory_rel_Number_num - `good_dimindex (:'a) /\ n < 2 ** (dimindex (:'a) - 4) /\ +Theorem IMP_memory_rel_Number_num: + good_dimindex (:'a) /\ n < 2 ** (dimindex (:'a) - 4) /\ memory_rel c be refs sp st m dm vars ==> memory_rel c be refs sp st m dm - ((Number (&n),Word ((n2w n << 2):'a word))::vars)` - (strip_tac \\ mp_tac (IMP_memory_rel_Number |> Q.INST [`i`|->`&n`]) \\ fs [] + ((Number (&n),Word ((n2w n << 2):'a word))::vars) +Proof + strip_tac \\ mp_tac (IMP_memory_rel_Number |> Q.INST [`i`|->`&n`]) \\ fs [] \\ fs [Smallnum_def,WORD_MUL_LSL,word_mul_n2w] \\ disch_then match_mp_tac \\ fs [small_int_def,dimword_def] - \\ fs [labPropsTheory.good_dimindex_def] \\ rfs []) + \\ fs [labPropsTheory.good_dimindex_def] \\ rfs [] +QED -Theorem memory_rel_Number_EQ - `memory_rel c be refs sp st m dm +Theorem memory_rel_Number_EQ: + memory_rel c be refs sp st m dm ((Number i1,w1)::(Number i2,w2)::vars) /\ (small_int (:'a) i1 \/ small_int (:'a) i2) /\ good_dimindex (:'a) ==> - ?v1 v2. w1 = Word v1 /\ w2 = Word (v2:'a word) /\ (v1 = v2 <=> i1 = i2)` - (Cases_on `small_int (:'a) i1` \\ Cases_on `small_int (:'a) i2` \\ fs [] + ?v1 v2. w1 = Word v1 /\ w2 = Word (v2:'a word) /\ (v1 = v2 <=> i1 = i2) +Proof + Cases_on `small_int (:'a) i1` \\ Cases_on `small_int (:'a) i2` \\ fs [] THEN1 (strip_tac \\ imp_res_tac memory_rel_Number_IMP @@ -6517,43 +6873,50 @@ Theorem memory_rel_Number_EQ \\ imp_res_tac memory_rel_any_Number_IMP \\ fs [] \\ rw [] \\ fs [] \\ clean_tac \\ rfs [] \\ Cases_on `w = w'` \\ fs [] - \\ CCONTR_TAC \\ fs []); + \\ CCONTR_TAC \\ fs [] +QED -Theorem memory_rel_Number_LESS - `memory_rel c be refs sp st m dm +Theorem memory_rel_Number_LESS: + memory_rel c be refs sp st m dm ((Number i1,w1)::(Number i2,w2)::vars) /\ small_int (:'a) i1 /\ small_int (:'a) i2 /\ good_dimindex (:'a) ==> - ?v1 v2. w1 = Word v1 /\ w2 = Word v2 /\ (v1 < (v2:'a word) <=> i1 < i2)` - (strip_tac + ?v1 v2. w1 = Word v1 /\ w2 = Word v2 /\ (v1 < (v2:'a word) <=> i1 < i2) +Proof + strip_tac \\ imp_res_tac memory_rel_Number_IMP \\ drule memory_rel_tail \\ strip_tac \\ imp_res_tac memory_rel_Number_IMP - \\ fs [] \\ fs [memory_rel_def] \\ rw [] \\ fs [num_less_thm]); + \\ fs [] \\ fs [memory_rel_def] \\ rw [] \\ fs [num_less_thm] +QED -Theorem memory_rel_Number_LESS_EQ - `memory_rel c be refs sp st m dm +Theorem memory_rel_Number_LESS_EQ: + memory_rel c be refs sp st m dm ((Number i1,w1)::(Number i2,w2)::vars) /\ small_int (:'a) i1 /\ small_int (:'a) i2 /\ good_dimindex (:'a) ==> - ?v1 v2. w1 = Word v1 /\ w2 = Word v2 /\ (v1 <= (v2:'a word) <=> i1 <= i2)` - (rw [] \\ drule memory_rel_Number_LESS \\ fs [] \\ rw [] \\ fs [] + ?v1 v2. w1 = Word v1 /\ w2 = Word v2 /\ (v1 <= (v2:'a word) <=> i1 <= i2) +Proof + rw [] \\ drule memory_rel_Number_LESS \\ fs [] \\ rw [] \\ fs [] \\ drule memory_rel_Number_EQ \\ fs [] \\ rw [] \\ fs [] - \\ fs [WORD_LESS_OR_EQ,integerTheory.INT_LE_LT]); + \\ fs [WORD_LESS_OR_EQ,integerTheory.INT_LE_LT] +QED -Theorem memory_rel_Number_word_msb - `memory_rel c be refs sp st m dm ((Number i1,Word (w:'a word))::vars) /\ +Theorem memory_rel_Number_word_msb: + memory_rel c be refs sp st m dm ((Number i1,Word (w:'a word))::vars) /\ good_dimindex(:'a) /\ small_int (:'a) i1 ==> - (word_msb w <=> i1 < 0)` - (rw [] + (word_msb w <=> i1 < 0) +Proof + rw [] \\ `small_int (:'a) 0` by (EVAL_TAC \\ fs [good_dimindex_def,dimword_def]) \\ rpt_drule (IMP_memory_rel_Number |> REWRITE_RULE [CONJ_ASSOC] |> ONCE_REWRITE_RULE [CONJ_COMM]) \\ fs [EVAL ``Smallnum 0``] \\ strip_tac \\ rpt_drule memory_rel_Number_LESS_EQ - \\ Cases_on `i1` \\ fs [GSYM WORD_NOT_LESS,word_msb_neg]); + \\ Cases_on `i1` \\ fs [GSYM WORD_NOT_LESS,word_msb_neg] +QED val memory_rel_RefPtr_EQ_lemma = Q.prove( `n * 2 ** k < dimword (:'a) /\ m * 2 ** k < dimword (:'a) /\ 0 < k /\ @@ -6571,11 +6934,12 @@ val memory_rel_RefPtr_EQ_lemma = Q.prove( \\ rfs [] ) -Theorem memory_rel_RefPtr_EQ - `memory_rel c be refs sp st m dm +Theorem memory_rel_RefPtr_EQ: + memory_rel c be refs sp st m dm ((RefPtr i1,w1)::(RefPtr i2,w2)::vars) /\ good_dimindex (:'a) ==> - ?v1 v2. w1 = Word v1 /\ w2 = Word (v2:'a word) /\ (v1 = v2 <=> i1 = i2)` - (fs [memory_rel_def] \\ rw [] \\ fs [word_ml_inv_def] \\ clean_tac + ?v1 v2. w1 = Word v1 /\ w2 = Word (v2:'a word) /\ (v1 = v2 <=> i1 = i2) +Proof + fs [memory_rel_def] \\ rw [] \\ fs [word_ml_inv_def] \\ clean_tac \\ drule ref_eq_thm \\ rw [] \\ clean_tac \\ fs [word_addr_def,get_addr_def] \\ eq_tac \\ rw [] \\ fs [get_lowerbits_def] @@ -6599,38 +6963,45 @@ Theorem memory_rel_RefPtr_EQ f ' i2 * 2 ** shift_length c < dimword (:'a)` by (fs [X_LT_DIV,RIGHT_ADD_DISTRIB] \\ Cases_on `2 ** shift_length c` \\ fs []) \\ fs [] - \\ imp_res_tac memory_rel_RefPtr_EQ_lemma \\ rfs[]); - -Theorem memory_rel_Boolv_T - `memory_rel c be refs sp st m dm vars /\ good_dimindex (:'a) ==> - memory_rel c be refs sp st m dm ((Boolv T,Word (18w:'a word))::vars)` - (fs [memory_rel_def] \\ rw [] \\ asm_exists_tac \\ fs [] + \\ imp_res_tac memory_rel_RefPtr_EQ_lemma \\ rfs[] +QED + +Theorem memory_rel_Boolv_T: + memory_rel c be refs sp st m dm vars /\ good_dimindex (:'a) ==> + memory_rel c be refs sp st m dm ((Boolv T,Word (18w:'a word))::vars) +Proof + fs [memory_rel_def] \\ rw [] \\ asm_exists_tac \\ fs [] \\ fs [word_ml_inv_def,PULL_EXISTS,EVAL ``Boolv F``,EVAL ``Boolv T``] \\ rpt_drule cons_thm_EMPTY \\ disch_then (qspecl_then [`1`] assume_tac) \\ rfs [labPropsTheory.good_dimindex_def,dimword_def] \\ rfs [labPropsTheory.good_dimindex_def,dimword_def] \\ asm_exists_tac \\ fs [] \\ fs [word_addr_def,BlockNil_def] - \\ EVAL_TAC \\ fs [labPropsTheory.good_dimindex_def,dimword_def]); - -Theorem memory_rel_Boolv_F - `memory_rel c be refs sp st m dm vars /\ good_dimindex (:'a) ==> - memory_rel c be refs sp st m dm ((Boolv F,Word (2w:'a word))::vars)` - (fs [memory_rel_def] \\ rw [] \\ asm_exists_tac \\ fs [] + \\ EVAL_TAC \\ fs [labPropsTheory.good_dimindex_def,dimword_def] +QED + +Theorem memory_rel_Boolv_F: + memory_rel c be refs sp st m dm vars /\ good_dimindex (:'a) ==> + memory_rel c be refs sp st m dm ((Boolv F,Word (2w:'a word))::vars) +Proof + fs [memory_rel_def] \\ rw [] \\ asm_exists_tac \\ fs [] \\ fs [word_ml_inv_def,PULL_EXISTS,EVAL ``Boolv F``,EVAL ``Boolv T``] \\ rpt_drule cons_thm_EMPTY \\ disch_then (qspecl_then [`0`] assume_tac) \\ rfs [labPropsTheory.good_dimindex_def,dimword_def] \\ rfs [labPropsTheory.good_dimindex_def,dimword_def] \\ asm_exists_tac \\ fs [] \\ fs [word_addr_def,BlockNil_def] - \\ EVAL_TAC \\ fs [labPropsTheory.good_dimindex_def,dimword_def]); + \\ EVAL_TAC \\ fs [labPropsTheory.good_dimindex_def,dimword_def] +QED -Theorem word_ml_inv_SP_LIMIT - `word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs stack ==> sp <= limit` - (srw_tac[][] \\ Cases_on `sp = 0` +Theorem word_ml_inv_SP_LIMIT: + word_ml_inv (heap,be,a,sp,sp1,gens) limit c refs stack ==> sp <= limit +Proof + srw_tac[][] \\ Cases_on `sp = 0` \\ full_simp_tac(srw_ss())[word_ml_inv_def,abs_ml_inv_def, heap_ok_def,unused_space_inv_def] \\ imp_res_tac heap_lookup_SPLIT \\ srw_tac[][] \\ full_simp_tac(srw_ss())[heap_length_APPEND, - heap_length_def,el_length_def] \\ decide_tac); + heap_length_def,el_length_def] \\ decide_tac +QED val lt8 = DECIDE ``(n < 8n) = (n = 0 \/ n = 1 \/ n = 2 \/ n = 3 \/ @@ -6715,14 +7086,15 @@ val small_int_w2i_i2w = prove( INT_MIN_def,INT_MAX_def] \\ rfs [] \\ fs [] \\ intLib.COOPER_TAC); -Theorem memory_rel_Add - `memory_rel c be refs sp st m dm +Theorem memory_rel_Add: + memory_rel c be refs sp st m dm ((Number i,Word wi)::(Number j,Word wj)::vars) /\ ~word_bit 0 wi /\ ~word_bit 0 wj /\ good_dimindex (:'a) /\ (w2i (wi + wj) = w2i wi + w2i wj) ==> memory_rel c be refs sp st m dm - ((Number (i + j),Word (wi + wj:'a word))::vars)` - (strip_tac + ((Number (i + j),Word (wi + wj:'a word))::vars) +Proof + strip_tac \\ rpt_drule memory_rel_any_Number_IMP \\ fs [word_bit_def] \\ strip_tac \\ drule memory_rel_tail \\ strip_tac \\ rpt_drule memory_rel_any_Number_IMP \\ fs [word_bit_def] \\ strip_tac @@ -6737,16 +7109,18 @@ Theorem memory_rel_Add \\ imp_res_tac w2i_i2w_IMP \\ fs [small_int_def,dimword_def,labPropsTheory.good_dimindex_def, INT_MIN_def,INT_MAX_def] \\ rfs [] - \\ intLib.COOPER_TAC); + \\ intLib.COOPER_TAC +QED -Theorem memory_rel_Sub - `memory_rel c be refs sp st m dm +Theorem memory_rel_Sub: + memory_rel c be refs sp st m dm ((Number i,Word wi)::(Number j,Word wj)::vars) /\ ~word_bit 0 wi /\ ~word_bit 0 wj /\ good_dimindex (:'a) /\ (w2i (wi - wj) = w2i wi - w2i wj) ==> memory_rel c be refs sp st m dm - ((Number (i - j),Word (wi - wj:'a word))::vars)` - (strip_tac + ((Number (i - j),Word (wi - wj:'a word))::vars) +Proof + strip_tac \\ rpt_drule memory_rel_any_Number_IMP \\ fs [word_bit_def] \\ strip_tac \\ drule memory_rel_tail \\ strip_tac \\ rpt_drule memory_rel_any_Number_IMP \\ fs [word_bit_def] \\ strip_tac @@ -6761,25 +7135,29 @@ Theorem memory_rel_Sub \\ imp_res_tac w2i_i2w_IMP \\ fs [small_int_def,dimword_def,labPropsTheory.good_dimindex_def, INT_MIN_def,INT_MAX_def] \\ rfs [] - \\ intLib.COOPER_TAC); + \\ intLib.COOPER_TAC +QED val exists_num = Q.prove( `~(i < 0i) <=> ?n. i = &n`, Cases_on `i` \\ fs []); -Theorem small_int_w2n[simp] - `good_dimindex (:'a) ==> small_int (:'a) (& (w2n (w:word8)))` - (rw [labPropsTheory.good_dimindex_def,small_int_def] \\ fs [dimword_def] +Theorem small_int_w2n[simp]: + good_dimindex (:'a) ==> small_int (:'a) (& (w2n (w:word8))) +Proof + rw [labPropsTheory.good_dimindex_def,small_int_def] \\ fs [dimword_def] \\ assume_tac (w2n_lt |> INST_TYPE [``:'a``|->``:8``]) - \\ fs [dimword_def] \\ pop_assum (assume_tac o SPEC_ALL) \\ fs []); + \\ fs [dimword_def] \\ pop_assum (assume_tac o SPEC_ALL) \\ fs [] +QED -Theorem memory_rel_And - `memory_rel c be refs sp st m dm +Theorem memory_rel_And: + memory_rel c be refs sp st m dm ((Number (&(w2n (i:word8))),Word wi)::(Number (&(w2n j)),Word wj)::vars) /\ good_dimindex (:'a) ==> memory_rel c be refs sp st m dm - ((Number (&w2n(i && j)),Word (wi && wj:'a word))::vars)` - (rw [] \\ imp_res_tac memory_rel_Number_IMP \\ fs [] + ((Number (&w2n(i && j)),Word (wi && wj:'a word))::vars) +Proof + rw [] \\ imp_res_tac memory_rel_Number_IMP \\ fs [] \\ rfs [small_int_w2n] \\ fs [WORD_LEFT_AND_OVER_OR] \\ drule memory_rel_tail \\ strip_tac @@ -6798,15 +7176,17 @@ Theorem memory_rel_And \\ fs [small_int_def] \\ fs[dimword_def] \\ Q.ISPEC_THEN`i && j`strip_assume_tac w2n_lt - \\ fs[labPropsTheory.good_dimindex_def]); + \\ fs[labPropsTheory.good_dimindex_def] +QED -Theorem memory_rel_Or - `memory_rel c be refs sp st m dm +Theorem memory_rel_Or: + memory_rel c be refs sp st m dm ((Number (&(w2n (i:word8))),Word wi)::(Number (&(w2n j)),Word wj)::vars) /\ good_dimindex (:'a) ==> memory_rel c be refs sp st m dm - ((Number (&w2n(i || j)),Word (wi || wj:'a word))::vars)` - (rw [] \\ imp_res_tac memory_rel_Number_IMP \\ fs [] + ((Number (&w2n(i || j)),Word (wi || wj:'a word))::vars) +Proof + rw [] \\ imp_res_tac memory_rel_Number_IMP \\ fs [] \\ fs [WORD_LEFT_AND_OVER_OR] \\ drule memory_rel_tail \\ strip_tac \\ imp_res_tac memory_rel_Number_IMP \\ fs [] @@ -6824,15 +7204,17 @@ Theorem memory_rel_Or \\ fs [small_int_def] \\ fs[dimword_def] \\ Q.ISPEC_THEN`i || j`strip_assume_tac w2n_lt - \\ fs[labPropsTheory.good_dimindex_def]); + \\ fs[labPropsTheory.good_dimindex_def] +QED -Theorem memory_rel_Xor - `memory_rel c be refs sp st m dm +Theorem memory_rel_Xor: + memory_rel c be refs sp st m dm ((Number (&(w2n (i:word8))),Word wi)::(Number (&(w2n j)),Word wj)::vars) /\ good_dimindex (:'a) ==> memory_rel c be refs sp st m dm - ((Number (&w2n(word_xor i j)),Word (word_xor wi wj:'a word))::vars)` - (rw [] \\ imp_res_tac memory_rel_Number_IMP \\ fs [] + ((Number (&w2n(word_xor i j)),Word (word_xor wi wj:'a word))::vars) +Proof + rw [] \\ imp_res_tac memory_rel_Number_IMP \\ fs [] \\ fs [WORD_LEFT_AND_OVER_OR] \\ drule memory_rel_tail \\ strip_tac \\ imp_res_tac memory_rel_Number_IMP \\ fs [] @@ -6850,33 +7232,43 @@ Theorem memory_rel_Xor \\ fs [small_int_def] \\ fs[dimword_def] \\ Q.ISPEC_THEN`i ⊕ j`strip_assume_tac w2n_lt - \\ fs[labPropsTheory.good_dimindex_def]); - -Theorem memory_rel_Number_IMP_Word - `memory_rel c be refs sp st m dm ((Number i,v)::vars) ==> ?w. v = Word w` - (fs [memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def, - bc_stack_ref_inv_def,v_inv_def] \\ rw [] \\ fs [word_addr_def]); - -Theorem memory_rel_Number_IMP_Word_2 - `memory_rel c be refs sp st m dm ((Number i,v)::(Number j,w)::vars) ==> - ?w1 w2. v = Word w1 /\ w = Word w2` - (fs [memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def, - bc_stack_ref_inv_def,v_inv_def] \\ rw [] \\ fs [word_addr_def]); - -Theorem memory_rel_zero_space - `memory_rel c be refs sp st m dm vars ==> - memory_rel c be refs 0 st m dm vars` - (fs [memory_rel_def,heap_in_memory_store_def] - \\ rw [] \\ fs [] \\ rpt (asm_exists_tac \\ fs []) \\ metis_tac []); - -Theorem memory_rel_less_space - `memory_rel c be refs sp st m dm vars ∧ sp' ≤ sp ⇒ - memory_rel c be refs sp' st m dm vars` - (rw[memory_rel_def] \\ asm_exists_tac \\ simp[]); - -Theorem maxout_bits_IMP - `i < dimindex (:'a) /\ (maxout_bits tag k n:'a word) ' i ==> i < n + k` - (rw [maxout_bits_def] \\ rfs [word_lsl_def,fcpTheory.FCP_BETA,n2w_def] + \\ fs[labPropsTheory.good_dimindex_def] +QED + +Theorem memory_rel_Number_IMP_Word: + memory_rel c be refs sp st m dm ((Number i,v)::vars) ==> ?w. v = Word w +Proof + fs [memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def, + bc_stack_ref_inv_def,v_inv_def] \\ rw [] \\ fs [word_addr_def] +QED + +Theorem memory_rel_Number_IMP_Word_2: + memory_rel c be refs sp st m dm ((Number i,v)::(Number j,w)::vars) ==> + ?w1 w2. v = Word w1 /\ w = Word w2 +Proof + fs [memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def, + bc_stack_ref_inv_def,v_inv_def] \\ rw [] \\ fs [word_addr_def] +QED + +Theorem memory_rel_zero_space: + memory_rel c be refs sp st m dm vars ==> + memory_rel c be refs 0 st m dm vars +Proof + fs [memory_rel_def,heap_in_memory_store_def] + \\ rw [] \\ fs [] \\ rpt (asm_exists_tac \\ fs []) \\ metis_tac [] +QED + +Theorem memory_rel_less_space: + memory_rel c be refs sp st m dm vars ∧ sp' ≤ sp ⇒ + memory_rel c be refs sp' st m dm vars +Proof + rw[memory_rel_def] \\ asm_exists_tac \\ simp[] +QED + +Theorem maxout_bits_IMP: + i < dimindex (:'a) /\ (maxout_bits tag k n:'a word) ' i ==> i < n + k +Proof + rw [maxout_bits_def] \\ rfs [word_lsl_def,fcpTheory.FCP_BETA,n2w_def] THEN1 (CCONTR_TAC \\ fs [GSYM NOT_LESS] \\ fs [bitTheory.BIT_def,bitTheory.BITS_THM] @@ -6886,20 +7278,23 @@ Theorem maxout_bits_IMP \\ asm_exists_tac \\ fs []) \\ rfs [all_ones_def,word_slice_def,fcpTheory.FCP_BETA] \\ Cases_on `k` \\ fs [] \\ rfs [word_0] - \\ rfs [ADD1,fcpTheory.FCP_BETA]); + \\ rfs [ADD1,fcpTheory.FCP_BETA] +QED -Theorem make_cons_ptr_thm - `make_cons_ptr conf (f:'a word) tag len = +Theorem make_cons_ptr_thm: + make_cons_ptr conf (f:'a word) tag len = Word ((f << (shift_length conf − shift (:'a)) || 1w || - ptr_bits conf tag len))` - (fs [make_cons_ptr_def] + ptr_bits conf tag len)) +Proof + fs [make_cons_ptr_def] \\ sg `get_lowerbits conf (Word (ptr_bits conf tag len)) = (ptr_bits conf tag len || 1w)` \\ fs [] \\ fs [get_lowerbits_def] \\ fs [fcpTheory.CART_EQ,fcpTheory.FCP_BETA,word_bits_def,word_or_def] \\ rw [] \\ fs [] \\ eq_tac \\ fs [] \\ rw [] \\ fs [] \\ disj1_tac \\ rfs [ptr_bits_def,word_or_def,fcpTheory.FCP_BETA] - \\ imp_res_tac maxout_bits_IMP \\ fs [small_shift_length_def]); + \\ imp_res_tac maxout_bits_IMP \\ fs [small_shift_length_def] +QED val Num_ABS_lemmas = prove( ``Num (ABS (& n)) = n /\ Num (ABS (- & n)) = n``, @@ -6950,8 +7345,8 @@ val word_cmp_loop_thm = prove( \\ first_x_assum match_mp_tac \\ metis_tac [STAR_ASSOC]); -Theorem memory_rel_Number_cmp - `memory_rel c be refs sp st m dm ((Number i1,v1)::(Number i2,v2)::vars) /\ +Theorem memory_rel_Number_cmp: + memory_rel c be refs sp st m dm ((Number i1,v1)::(Number i2,v2)::vars) /\ good_dimindex (:'a) ==> ?w1 w2. v1 = Word w1 /\ v2 = Word (w2:'a word) /\ @@ -6984,8 +7379,9 @@ Theorem memory_rel_Number_cmp 0w else if decode_length c x1 <+ decode_length c x2 then 2w else 0w) - else T` - (strip_tac + else T +Proof + strip_tac \\ drule memory_rel_Number_IMP_Word_2 \\ strip_tac \\ rveq \\ qexists_tac `w1` \\ qexists_tac `w2` \\ rewrite_tac [] \\ IF_CASES_TAC THEN1 @@ -7044,7 +7440,8 @@ Theorem memory_rel_Number_cmp \\ Cases_on `n = n'` \\ fs [] \\ Cases_on `n <= n'` \\ Cases_on `n' <= n` \\ imp_res_tac LENGTH_n2mw_LESS_LENGTH_n2mw \\ fs [] - \\ full_simp_tac (std_ss++ARITH_ss) [GSYM LENGTH_NIL]); + \\ full_simp_tac (std_ss++ARITH_ss) [GSYM LENGTH_NIL] +QED val word_cmp_loop_refl = Q.prove( `∀l a b dm m x. a = b ∧ word_cmp_loop l a a dm m = SOME x ⇒ x = 1w`, @@ -7081,16 +7478,17 @@ val v_ind = |> UNDISCH_ALL |> CONJUNCT1 |> DISCH_ALL -Theorem memory_rel_Block_MEM - `memory_rel c be refs sp st m dm ((Block ts n ls,(v:'a word_loc))::vars) ∧ +Theorem memory_rel_Block_MEM: + memory_rel c be refs sp st m dm ((Block ts n ls,(v:'a word_loc))::vars) ∧ i < LENGTH ls ∧ good_dimindex (:'a) ⇒ ∃w a y. get_real_offset (Smallnum (&i)) = SOME y ∧ v = Word w ∧ get_real_addr c st w = SOME a ∧ (a + y) IN dm /\ - memory_rel c be refs sp st m dm ((EL i ls,m (a + y))::(Block ts n ls,v)::vars)` - (rw[] + memory_rel c be refs sp st m dm ((EL i ls,m (a + y))::(Block ts n ls,v)::vars) +Proof + rw[] \\ rpt_drule memory_rel_Block_IMP \\ rw[] \\ Cases_on`ls=[]`\\fs[] @@ -7104,22 +7502,27 @@ Theorem memory_rel_Block_MEM \\ asm_exists_tac \\ rw[] \\ pop_assum mp_tac \\ match_mp_tac memory_rel_rearrange - \\ rw[] \\ rw[]); + \\ rw[] \\ rw[] +QED -Theorem Smallnum_0 - `¬(Smallnum i:'a word) ' 0` - (`0 < dimindex(:'a)` by simp[] +Theorem Smallnum_0: + ¬(Smallnum i:'a word) ' 0 +Proof + `0 < dimindex(:'a)` by simp[] \\ strip_tac \\ imp_res_tac word_bit_thm - \\ fs[word_bit_test,Smallnum_bits]); + \\ fs[word_bit_test,Smallnum_bits] +QED -Theorem Smallnum_1 - `good_dimindex(:'a) ==> ¬(Smallnum i:'a word) ' 1` - (strip_tac +Theorem Smallnum_1: + good_dimindex(:'a) ==> ¬(Smallnum i:'a word) ' 1 +Proof + strip_tac \\ `1 < dimindex(:'a)` by fs[good_dimindex_def] \\ strip_tac \\ imp_res_tac word_bit_thm - \\ fs[word_bit_test,Smallnum_bits]); + \\ fs[word_bit_test,Smallnum_bits] +QED val vb_size_def = tDefine"vb_size"` (vb_size (Block ts t ls) = 1 + t + SUM (MAP vb_size ls) + LENGTH ls) ∧ @@ -7130,12 +7533,13 @@ val vb_size_def = tDefine"vb_size"` val vb_size_ind = theorem"vb_size_ind"; -Theorem memory_rel_pointer_eq_size - `∀v1 v2 w. +Theorem memory_rel_pointer_eq_size: + ∀v1 v2 w. good_dimindex (:'a) ∧ memory_rel c be refs sp st m dm ((v1,(w:'a word_loc))::(v2,w)::vars) ==> - vb_size v1 = vb_size v2` - (ho_match_mp_tac v_ind \\ rw[] \\ Cases_on`v2` \\ fs[vb_size_def] + vb_size v1 = vb_size v2 +Proof + ho_match_mp_tac v_ind \\ rw[] \\ Cases_on`v2` \\ fs[vb_size_def] \\ qhdtm_x_assum`memory_rel`mp_tac \\ qid_spec_tac`n` \\ qid_spec_tac`n0` \\ qid_spec_tac`n'` THEN_LT USE_SG_THEN (fn th => metis_tac[memory_rel_swap,th]) 1 3 @@ -7227,7 +7631,8 @@ Theorem memory_rel_pointer_eq_size \\ rpt_drule memory_rel_tail \\ strip_tac \\ rpt_drule memory_rel_Block_IMP \\ strip_tac \\ strip_tac - \\ fs[] \\ rveq \\ fs[] \\ rfs [] )); + \\ fs[] \\ rveq \\ fs[] \\ rfs [] ) +QED val do_eq_list_F_IMP_MEM = prove( ``!l l'. @@ -7244,12 +7649,12 @@ val memory_rel_rotate3 = prove( match_mp_tac memory_rel_rearrange \\ fs [] \\ rw [] \\ fs []); -Theorem memory_rel_pointer_eq - `∀v1 v2 w b. +Theorem memory_rel_pointer_eq = Q.prove(` + ∀v1 v2 w b. good_dimindex (:'a) ∧ do_eq refs v1 v2 = Eq_val b /\ - memory_rel c be refs sp st m dm ((v1,(w:'a word_loc))::(v2,w)::vars) ==> b` - (ho_match_mp_tac v_ind \\ rw[] \\ Cases_on`v2` \\ fs[] \\ rveq + memory_rel c be refs sp st m dm ((v1,(w:'a word_loc))::(v2,w)::vars) ==> b`, + ho_match_mp_tac v_ind \\ rw[] \\ Cases_on`v2` \\ fs[] \\ rveq \\ TRY ( rpt_drule memory_rel_RefPtr_EQ \\ strip_tac \\ fs [] \\ every_case_tac \\ fs[] \\ rfs[] \\ NO_TAC) @@ -7327,9 +7732,11 @@ Theorem memory_rel_pointer_eq \\ fs [] \\ rw [] \\ fs [])) |> REWRITE_RULE [CONJ_ASSOC] |> ONCE_REWRITE_RULE [CONJ_COMM]; -Theorem v1_size_map - `∀ls. v1_size ls = SUM (MAP v_size ls) + LENGTH ls` - (Induct \\ rw[v_size_def]); +Theorem v1_size_map: + ∀ls. v1_size ls = SUM (MAP v_size ls) + LENGTH ls +Proof + Induct \\ rw[v_size_def] +QED val v_depth_def = tDefine"v_depth"` (v_depth (Block _ _ ls) = (if NULL ls then 0 else 1) + list_max (MAP v_depth ls)) ∧ @@ -7341,17 +7748,19 @@ val _ = export_rewrites["v_depth_def"]; val v_depth_ind = theorem"v_depth_ind"; -Theorem v_inv_Block_tag_limit - `v_inv c (Block ts n l) (v,f,(heap:'a ml_heap)) ∧ +Theorem v_inv_Block_tag_limit: + v_inv c (Block ts n l) (v,f,(heap:'a ml_heap)) ∧ heap_in_memory_store heap a sp sp1 gens c s m (dm:'a word set) limit - ⇒ n < dimword(:'a) DIV 16` - (rw[v_inv_def] \\ fs[BlockRep_def] + ⇒ n < dimword(:'a) DIV 16 +Proof + rw[v_inv_def] \\ fs[BlockRep_def] \\ fs[heap_in_memory_store_def] \\ imp_res_tac heap_lookup_SPLIT \\ fs[word_heap_APPEND,word_heap_def,word_el_def,word_payload_def] \\ fs[encode_header_def,X_LT_DIV] \\ fsrw_tac[sep_cond_ss][cond_STAR] - \\ fs[LEFT_ADD_DISTRIB]); + \\ fs[LEFT_ADD_DISTRIB] +QED val elements_list_def = Define` (elements_list [] = T) ∧ @@ -7372,16 +7781,17 @@ val elements_list_size_mono = Q.prove( \\ fsrw_tac[ETA_ss][] \\ decide_tac) |> SIMP_RULE std_ss [] |> curry save_thm "elements_list_size_mono"; -Theorem memory_rel_depth_limit - `∀v w vars. +Theorem memory_rel_depth_limit: + ∀v w vars. memory_rel c b refs sp st m dm ((v,(w:'a word_loc))::vars) ∧ elements_list (v::(MAP FST vars)) ∧ good_dimindex(:'a) ⇒ ∃ls. memory_rel c b refs sp st m dm (ls ++ (v,w)::vars) ∧ v_depth v = LENGTH ls ∧ - elements_list (MAP FST ls ++ (v::(MAP FST vars)))` - (ho_match_mp_tac v_ind + elements_list (MAP FST ls ++ (v::(MAP FST vars))) +Proof + ho_match_mp_tac v_ind \\ rw[v_depth_def,LENGTH_NIL_SYM,NULL_EQ,list_max_def] \\ fsrw_tac[ETA_ss][] \\ `MEM (list_max (MAP v_depth l)) (MAP v_depth l)` @@ -7398,17 +7808,18 @@ Theorem memory_rel_depth_limit \\ qmatch_asmsub_abbrev_tac`(EL i l,wi)` \\ qexists_tac`ls ++ [(EL i l,wi)]` \\ simp[] - \\ metis_tac[CONS_APPEND,APPEND_ASSOC]); + \\ metis_tac[CONS_APPEND,APPEND_ASSOC] +QED -Theorem memory_rel_elements_list_distinct - `∀vs vars. +Theorem memory_rel_elements_list_distinct: + ∀vs vars. memory_rel c be refs sp st m (dm:'a word set) vars ∧ elements_list vs ∧ vs = MAP FST vars ∧ good_dimindex (:'a) ⇒ ALL_DISTINCT (MAP SND vars) - ` - (ho_match_mp_tac elements_list_ind +Proof + ho_match_mp_tac elements_list_ind \\ rw[] \\ rw[] \\ Cases_on`vars` \\ fs[] \\ qmatch_assum_rename_tac`_ :: _ = MAP FST l1` \\ rveq @@ -7449,15 +7860,17 @@ Theorem memory_rel_elements_list_distinct \\ srw_tac[ETA_ss][] \\ imp_res_tac SUM_MAP_MEM_bound \\ first_x_assum(qspec_then`vb_size`mp_tac) - \\ simp[]); + \\ simp[] +QED -Theorem memory_rel_elements_list_words - `∀vs vars. +Theorem memory_rel_elements_list_words: + ∀vs vars. memory_rel c be refs sp st m (dm:'a word set) vars ∧ elements_list vs ∧ vs = MAP FST vars ∧ good_dimindex(:'a) - ⇒ vars ≠ [] ==> EVERY isWord (TL (MAP SND vars))` - (ho_match_mp_tac elements_list_ind + ⇒ vars ≠ [] ==> EVERY isWord (TL (MAP SND vars)) +Proof + ho_match_mp_tac elements_list_ind \\ rw[] \\ rw[] \\ Cases_on`vars` \\ fs[] \\ qmatch_assum_rename_tac`_ :: _ = MAP FST l1` \\ rveq \\ Cases_on`l1` \\ fs[] \\ rveq @@ -7468,15 +7881,17 @@ Theorem memory_rel_elements_list_words \\ rpt_drule memory_rel_tail \\ strip_tac \\ rpt_drule memory_rel_Block_IMP \\ strip_tac \\ rw[isWord_def] - \\ first_x_assum drule \\ simp[]); + \\ first_x_assum drule \\ simp[] +QED -Theorem memory_rel_depth_size_limit - `∀v w vars. +Theorem memory_rel_depth_size_limit: + ∀v w vars. memory_rel c be refs sp st m dm ((v,w:'a word_loc)::vars) ∧ good_dimindex (:'a) ⇒ - vb_size v ≤ dimword(:'a) ** (v_depth v + 1)` - (ho_match_mp_tac v_ind \\ rw[vb_size_def,EXP,NULL_EQ,list_max_def] + vb_size v ≤ dimword(:'a) ** (v_depth v + 1) +Proof + ho_match_mp_tac v_ind \\ rw[vb_size_def,EXP,NULL_EQ,list_max_def] \\ TRY ( fs[dimword_def] \\ NO_TAC ) >- ( rpt_drule memory_rel_Block_IMP @@ -7537,15 +7952,17 @@ Theorem memory_rel_depth_size_limit \\ match_mp_tac LESS_EQ_TRANS \\ qexists_tac`dw DIV 16 + dw DIV 8` \\ fs[X_LE_DIV] - \\ fs[Abbr`dw`,dimword_def,good_dimindex_def]); + \\ fs[Abbr`dw`,dimword_def,good_dimindex_def] +QED -Theorem memory_rel_limit - `∀v w. +Theorem memory_rel_limit: + ∀v w. memory_rel c be refs sp st m dm ((v,w:'a word_loc)::vars) ∧ good_dimindex (:'a) ==> - vb_size v * dimword (:'a) < MustTerminate_limit (:'a) - dimword (:'a)` - (rw[] + vb_size v * dimword (:'a) < MustTerminate_limit (:'a) - dimword (:'a) +Proof + rw[] \\ rpt_drule memory_rel_depth_size_limit \\ rw[] \\ `memory_rel c be refs sp st m dm [(v,w)]` by ( @@ -7583,14 +8000,17 @@ Theorem memory_rel_limit \\ match_mp_tac LESS_EQ_TRANS \\ qexists_tac`dimword (:'a) * dimword (:'a)` \\ simp[] - \\ fs[good_dimindex_def,dimword_def]); + \\ fs[good_dimindex_def,dimword_def] +QED -Theorem memory_rel_ptr_eq - `memory_rel c be refs sp st m dm ((v1,x1)::(v2,x1:'a word_loc)::vars) /\ +Theorem memory_rel_ptr_eq: + memory_rel c be refs sp st m dm ((v1,x1)::(v2,x1:'a word_loc)::vars) /\ do_eq refs v1 v2 = Eq_val b /\ - good_dimindex (:'a) ==> b` - (rw [] \\ CCONTR_TAC \\ fs [] \\ rveq - \\ imp_res_tac memory_rel_pointer_eq); + good_dimindex (:'a) ==> b +Proof + rw [] \\ CCONTR_TAC \\ fs [] \\ rveq + \\ imp_res_tac memory_rel_pointer_eq +QED val memory_rel_Block_Block_small_eq = prove( ``memory_rel c be refs sp st m dm @@ -7604,15 +8024,16 @@ val memory_rel_Block_Block_small_eq = prove( \\ imp_res_tac memory_rel_tail \\ drule memory_rel_Block_IMP \\ fs []); -Theorem memory_rel_simple_eq - `memory_rel c be refs sp st m dm ((v1,x1)::(v2,x2)::vars) /\ +Theorem memory_rel_simple_eq: + memory_rel c be refs sp st m dm ((v1,x1)::(v2,x2)::vars) /\ do_eq refs v1 v2 = Eq_val b /\ good_dimindex (:'a) ==> ?w1 w2:'a word. x1 = Word w1 /\ x2 = Word w2 /\ (~word_bit 0 w1 \/ ~word_bit 0 w2 ==> - (w1 = w2) = b)` - (Cases_on `v1` \\ Cases_on `v2` \\ fs [do_eq_def] \\ rpt strip_tac + (w1 = w2) = b) +Proof + Cases_on `v1` \\ Cases_on `v2` \\ fs [do_eq_def] \\ rpt strip_tac \\ TRY ( drule memory_rel_RefPtr_EQ \\ fs [] \\ rw [] \\ imp_res_tac memory_rel_RefPtr_IMP @@ -7652,7 +8073,8 @@ Theorem memory_rel_simple_eq \\ Cases_on `word_bit 0 w1` \\ fs [] \\ strip_tac \\ fs [] \\ imp_res_tac memory_rel_swap \\ drule memory_rel_Block_Block_small_eq \\ fs [] - \\ strip_tac \\ fs []); + \\ strip_tac \\ fs [] +QED val word_header_def = Define ` word_header c st a dm m = @@ -7744,12 +8166,14 @@ val word_eq_def = save_thm("word_eq_def[compute]", val word_eq_ind = save_thm("word_eq_ind", word_eq_ind |> REWRITE_RULE [fix_clock_word_eq]); -Theorem bit_pattern_1100[simp] - `good_dimindex (:'a) ==> - ((0b1100w && x1) = 0w <=> ~word_bit 2 x1 /\ ~word_bit 3 (x1:'a word))` - (fs [fcpTheory.CART_EQ,word_and_def,word_index,fcpTheory.FCP_BETA, +Theorem bit_pattern_1100[simp]: + good_dimindex (:'a) ==> + ((0b1100w && x1) = 0w <=> ~word_bit 2 x1 /\ ~word_bit 3 (x1:'a word)) +Proof + fs [fcpTheory.CART_EQ,word_and_def,word_index,fcpTheory.FCP_BETA, GSYM word_bit,good_dimindex_def] \\ fs [] \\ rw [] \\ eq_tac \\ rw [] - \\ metis_tac [DECIDE ``2 < 32n /\ 2 < 64n /\ 3 < 32n /\ 3 < 64n``]); + \\ metis_tac [DECIDE ``2 < 32n /\ 2 < 64n /\ 3 < 32n /\ 3 < 64n``] +QED val memory_rel_isClos = prove( ``memory_rel c be refs sp st m dm ((Block ts1 t1 v1,Word (w1:'a word))::vars) /\ @@ -7825,27 +8249,31 @@ val memory_rel_Block_explode_lemma = prove( \\ first_x_assum (fn th => mp_tac th THEN match_mp_tac memory_rel_rearrange) \\ fs [] \\ rw [] \\ fs []); -Theorem memory_rel_Block_explode - `memory_rel c be refs sp st m dm ((Block ts1 t1 v1,Word w1)::vars) /\ +Theorem memory_rel_Block_explode: + memory_rel c be refs sp st m dm ((Block ts1 t1 v1,Word w1)::vars) /\ word_bit 0 w1 /\ get_real_addr c st w1 = SOME a /\ good_dimindex (:α) ==> memory_rel c be refs sp st m dm (eq_explode (a + bytes_in_word:'a word) m dm v1 ++ vars) /\ - eq_assum (a + bytes_in_word) m dm v1` - (strip_tac + eq_assum (a + bytes_in_word) m dm v1 +Proof + strip_tac \\ rpt_drule (memory_rel_Block_explode_lemma |> Q.SPEC `LENGTH (v1:v list)`) \\ strip_tac \\ first_x_assum (fn th => mp_tac th THEN match_mp_tac memory_rel_rearrange) - \\ fs [] \\ rw [] \\ fs []); + \\ fs [] \\ rw [] \\ fs [] +QED -Theorem memory_rel_Loc - `memory_rel c be refs sp st m dm ((v1,Loc n k)::vars) ==> v1 = CodePtr n` - (fs [memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def, +Theorem memory_rel_Loc: + memory_rel c be refs sp st m dm ((v1,Loc n k)::vars) ==> v1 = CodePtr n +Proof + fs [memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def, bc_stack_ref_inv_def] \\ rw [] \\ Cases_on `v1` \\ fs [v_inv_def,word_addr_def] - \\ every_case_tac \\ fs [] \\ rveq \\ fs [word_addr_def]); + \\ every_case_tac \\ fs [] \\ rveq \\ fs [word_addr_def] +QED -Theorem memory_rel_ByteArray_words_IMP - `memory_rel c be refs sp st m dm ((RefPtr p,Word (w:'a word))::vars) ∧ +Theorem memory_rel_ByteArray_words_IMP: + memory_rel c be refs sp st m dm ((RefPtr p,Word (w:'a word))::vars) ∧ FLOOKUP refs p = SOME (ByteArray fl vals) ∧ good_dimindex(:'a) ∧ get_real_addr c st w = SOME a ⇒ @@ -7856,8 +8284,9 @@ Theorem memory_rel_ByteArray_words_IMP * frame) (fun2set (m,dm)) ∧ w2n (decode_length c x) < dimword(:'a) ∧ LENGTH vals ≤ w2n (decode_length c x) * (dimindex (:'a) DIV 8) ∧ - w2n (decode_length c x) ≤ LENGTH vals DIV (dimindex(:'a) DIV 8) + 1` - (rw[memory_rel_def,word_ml_inv_def,abs_ml_inv_def,bc_stack_ref_inv_def,v_inv_def] + w2n (decode_length c x) ≤ LENGTH vals DIV (dimindex(:'a) DIV 8) + 1 +Proof + rw[memory_rel_def,word_ml_inv_def,abs_ml_inv_def,bc_stack_ref_inv_def,v_inv_def] \\ fs[word_addr_def] \\ rw[] \\ first_x_assum(qspec_then`p`mp_tac) \\ impl_tac >- ( @@ -7876,34 +8305,40 @@ Theorem memory_rel_ByteArray_words_IMP \\ fsrw_tac[sep_cond_ss][cond_STAR] \\ `ws < dimword(:'a)` by (fs[dimword_def,good_dimindex_def] \\ fs[]) \\ simp[] - \\ metis_tac[STAR_ASSOC,STAR_COMM]); + \\ metis_tac[STAR_ASSOC,STAR_COMM] +QED -Theorem poly_inj_lemma - `(a:num) < b ∧ a' < b ∧ a + b * c = a' + b * c' ⇒ a = a' ∧ c = c'` - (strip_tac +Theorem poly_inj_lemma: + (a:num) < b ∧ a' < b ∧ a + b * c = a' + b * c' ⇒ a = a' ∧ c = c' +Proof + strip_tac \\ qspec_then`b`mp_tac DIVISION \\ simp[] \\ disch_then(qspec_then`a + b * c`mp_tac) \\ simp[ADD_DIV_RWT,LESS_DIV_EQ_ZERO] \\ once_rewrite_tac[MULT_COMM] \\ simp[MULT_DIV] - \\ strip_tac \\ fs[]); + \\ strip_tac \\ fs[] +QED -Theorem mw2n_inj - `∀x y. LENGTH x = LENGTH y ⇒ (mw2n (x:'a word list) = mw2n y ⇔ x = y)` - (Induct \\ simp[mw2n_def,LENGTH_NIL,LENGTH_NIL_SYM] +Theorem mw2n_inj: + ∀x y. LENGTH x = LENGTH y ⇒ (mw2n (x:'a word list) = mw2n y ⇔ x = y) +Proof + Induct \\ simp[mw2n_def,LENGTH_NIL,LENGTH_NIL_SYM] \\ gen_tac \\ Cases \\ simp[mw2n_def] \\ rw[EQ_IMP_THM] \\ res_tac \\ fs[] \\ imp_res_tac poly_inj_lemma - \\ fs[w2n_lt]); + \\ fs[w2n_lt] +QED -Theorem write_bytes_inj - `good_dimindex(:'a) ==> +Theorem write_bytes_inj: + good_dimindex(:'a) ==> ∀ws bs1 bs2. LENGTH bs1 = LENGTH bs2 ∧ LENGTH bs1 ≤ LENGTH ws * (dimindex(:'a) DIV 8) ∧ LENGTH ws ≤ LENGTH bs1 DIV (dimindex(:'a) DIV 8) + 1 ⇒ - (write_bytes bs1 (ws:'a word list) be = write_bytes bs2 ws be ⇔ bs1 = bs2)` - (strip_tac \\ Induct + (write_bytes bs1 (ws:'a word list) be = write_bytes bs2 ws be ⇔ bs1 = bs2) +Proof + strip_tac \\ Induct \\ simp[write_bytes_def,LENGTH_NIL,LENGTH_NIL_SYM] \\ rw[] \\ rw[EQ_IMP_THM] \\ fs[MULT_CLAUSES] \\ qmatch_asmsub_abbrev_tac`bytes_to_word bw 0w bs1 _ _` @@ -7982,7 +8417,8 @@ Theorem write_bytes_inj \\ first_x_assum(fn th => qspec_then`7`mp_tac th \\ assume_tac th) \\ last_x_assum(fn th => qspec_then`7`mp_tac th \\ assume_tac th) \\ simp_tac(srw_ss()++ARITH_ss)[ADD1] - \\ metis_tac[]); + \\ metis_tac[] +QED val word_eq_thm0 = prove( ``(!refs v1 v2 l b w1 w2. @@ -8264,20 +8700,22 @@ val word_eq_thm0 = prove( \\ impl_tac THEN1 fs [LEFT_ADD_DISTRIB] \\ strip_tac \\ fs [] \\ fs [LEFT_ADD_DISTRIB]); -Theorem word_eq_thm - `memory_rel c be refs sp st m dm +Theorem word_eq_thm: + memory_rel c be refs sp st m dm ((v1,Word w1)::(v2,Word w2:'a word_loc)::vars) /\ do_eq refs v1 v2 = Eq_val b /\ good_dimindex (:'a) ==> ?res l1. word_eq c st dm m (MustTerminate_limit (:'a) - 1) w1 w2 = SOME (res,l1) /\ - (b <=> (res = 1w))` - (rw [] \\ imp_res_tac memory_rel_limit + (b <=> (res = 1w)) +Proof + rw [] \\ imp_res_tac memory_rel_limit \\ drule (word_eq_thm0 |> CONJUNCT1) \\ fs [] \\ `dimword (:α) * vb_size v1 < MustTerminate_limit (:α) − 1` by (fs [good_dimindex_def,dimword_def] \\ rfs []) \\ disch_then drule - \\ rw [] \\ fs []); + \\ rw [] \\ fs [] +QED val word_mem_eq_def = Define ` (word_mem_eq a [] dm m <=> SOME T) /\ @@ -8300,8 +8738,8 @@ val word_mem_eq_thm = prove( \\ qexists_tac `one (a,Word h) * ff` \\ fs [AC STAR_COMM STAR_ASSOC]); -Theorem memory_rel_Number_const_test - `memory_rel c be refs sp st m dm ((Number i,Word (w:'a word))::vars) /\ +Theorem memory_rel_Number_const_test: + memory_rel c be refs sp st m dm ((Number i,Word (w:'a word))::vars) /\ good_dimindex (:'a) ==> if small_int (:'a) j then (Smallnum j = w <=> i = j) @@ -8311,8 +8749,9 @@ Theorem memory_rel_Number_const_test | SOME words => if ~(word_bit 0 w) then i <> j else ?a. get_real_addr c st w = SOME a /\ - word_mem_eq a words dm m = SOME (i = j)` - (strip_tac + word_mem_eq a words dm m = SOME (i = j) +Proof + strip_tac \\ rpt_drule (memory_rel_any_Number_IMP |> ONCE_REWRITE_RULE [CONJ_COMM]) \\ fs [word_bit] \\ strip_tac \\ IF_CASES_TAC THEN1 @@ -8358,20 +8797,22 @@ Theorem memory_rel_Number_const_test \\ Cases_on `i` \\ Cases_on `j` \\ fs [] \\ pop_assum mp_tac \\ rpt (pop_assum kall_tac) - \\ intLib.COOPER_TAC); + \\ intLib.COOPER_TAC +QED val word_1_and_eq_0 = prove( ``((1w && w) = 0w) <=> ~(word_bit 0 w)``, fs [word_bit_test]); -Theorem memory_rel_Number_single_mul - `memory_rel c be refs sp st m dm +Theorem memory_rel_Number_single_mul: + memory_rel c be refs sp st m dm ((Number i1,Word (w1:'a word))::(Number i2,Word w2)::vars) /\ good_dimindex(:'a) ==> let (lw,hw) = single_mul w1 (w2 >>> 1) 0w in (hw || ((w1 || w2) && 1w)) = 0w ==> - memory_rel c be refs sp st m dm ((Number (i1 * i2),Word (lw >>> 1))::vars)` - (Cases_on `i2 = 0` \\ fs [] + memory_rel c be refs sp st m dm ((Number (i1 * i2),Word (lw >>> 1))::vars) +Proof + Cases_on `i2 = 0` \\ fs [] \\ rpt strip_tac \\ fs [word_or_eq_0,word_bit_or] THEN1 (drule memory_rel_swap \\ strip_tac @@ -8468,14 +8909,16 @@ Theorem memory_rel_Number_single_mul \\ match_mp_tac IMP_memory_rel_Number_num3 \\ fs [] \\ rfs [good_dimindex_def,dimword_def] \\ rfs [] \\ first_x_assum (fn th => mp_tac th THEN match_mp_tac memory_rel_rearrange) - \\ fs [] \\ rw [] \\ fs []); + \\ fs [] \\ rw [] \\ fs [] +QED -Theorem memory_rel_bounds_check - `memory_rel c be refs sp st m dm ((Number i1,Word (w1:'a word))::vars) /\ +Theorem memory_rel_bounds_check: + memory_rel c be refs sp st m dm ((Number i1,Word (w1:'a word))::vars) /\ small_int (:'a) (& n) /\ good_dimindex (:'a) ==> (word_ror w1 2 <+ n2w n <=> 0 <= i1 /\ i1 < & n) /\ - (word_ror w1 2 <=+ n2w n <=> 0 <= i1 /\ i1 <= & n)` - (strip_tac \\ imp_res_tac memory_rel_any_Number_IMP + (word_ror w1 2 <=+ n2w n <=> 0 <= i1 /\ i1 <= & n) +Proof + strip_tac \\ imp_res_tac memory_rel_any_Number_IMP \\ rveq \\ fs [] \\ rveq \\ fs [] \\ `n < dimword (:'a) /\ n < dimword (:'a) DIV 4 /\ n < dimword (:'a) DIV 8` by (fs [small_int_def,good_dimindex_def,dimword_def] \\ fs [] \\ NO_TAC) @@ -8532,19 +8975,22 @@ Theorem memory_rel_bounds_check \\ fs [word_ror_n2w,bitTheory.BIT_def,bitTheory.BITS_THM2] \\ fs [good_dimindex_def,dimword_def] \\ rfs [] \\ fs [ONCE_REWRITE_RULE [MULT_COMM] MULT_DIV] - \\ rfs []); + \\ rfs [] +QED -Theorem memory_rel_ByteArray_IMP_store - `memory_rel c be refs sp st m dm ((RefPtr p,Word (w:'a word))::vars) ∧ +Theorem memory_rel_ByteArray_IMP_store: + memory_rel c be refs sp st m dm ((RefPtr p,Word (w:'a word))::vars) ∧ FLOOKUP refs p = SOME (ByteArray fl vals) ∧ good_dimindex (:α) /\ get_real_addr c st w = SOME a /\ i < LENGTH vals ==> ?m1. mem_store_byte_aux m dm be (a + bytes_in_word + n2w i) b = SOME m1 /\ memory_rel c be (refs |+ (p,ByteArray fl (LUPDATE b i vals))) sp st m1 dm - ((RefPtr p,Word (w:'a word))::vars)` - (rw [] \\ rpt_drule memory_rel_ByteArray_IMP + ((RefPtr p,Word (w:'a word))::vars) +Proof + rw [] \\ rpt_drule memory_rel_ByteArray_IMP \\ fs [mem_load_byte_aux_def,mem_store_byte_aux_def] \\ rw [] \\ ntac 2 (first_x_assum drule) - \\ TOP_CASE_TAC \\ fs [theWord_def]); + \\ TOP_CASE_TAC \\ fs [theWord_def] +QED (* copy forward *) @@ -8616,8 +9062,8 @@ val list_copy_fwd_alias_def = Define ` LUPDATE (EL (xp+0) ys) (yp+0)) ys) else NONE` -Theorem word_copy_fwd_thm - `!n xp yp ys ys1 m. +Theorem word_copy_fwd_thm: + !n xp yp ys ys1 m. memory_rel c be (refs |+ (p2,ByteArray fl_ys ys)) sp st m dm ((RefPtr p1,v1)::(RefPtr p2,v2)::vars) /\ FLOOKUP refs p1 = SOME (ByteArray fl_xs xs) /\ @@ -8630,8 +9076,9 @@ Theorem word_copy_fwd_thm word_copy_fwd be (n2w n) (a1 + bytes_in_word + n2w xp) (a2 + bytes_in_word + n2w yp) m dm = SOME m1 /\ memory_rel c be (refs |+ (p2,ByteArray fl_ys ys1)) - sp st m1 dm ((RefPtr p1,v1)::(RefPtr p2,v2)::vars)` - (completeInduct_on `n` \\ fs [PULL_FORALL,AND_IMP_INTRO] + sp st m1 dm ((RefPtr p1,v1)::(RefPtr p2,v2)::vars) +Proof + completeInduct_on `n` \\ fs [PULL_FORALL,AND_IMP_INTRO] \\ once_rewrite_tac [list_copy_fwd_def] \\ rpt strip_tac \\ `4 < dimword (:'a)` by fs [good_dimindex_def,dimword_def] @@ -8705,10 +9152,11 @@ Theorem word_copy_fwd_thm \\ drule memory_rel_swap \\ strip_tac \\ rewrite_tac [GSYM word_sub_def,addressTheory.word_arith_lemma2] \\ fs [] \\ first_x_assum match_mp_tac - \\ fs [] \\ asm_exists_tac \\ fs []); + \\ fs [] \\ asm_exists_tac \\ fs [] +QED -Theorem word_copy_fwd_alias_thm - `!n xp yp ys ys1 m. +Theorem word_copy_fwd_alias_thm: + !n xp yp ys ys1 m. memory_rel c be (refs |+ (p2,ByteArray fl_ys ys)) sp st m dm ((RefPtr p2,v2)::vars) /\ list_copy_fwd_alias n xp yp ys = SOME ys1 /\ @@ -8719,8 +9167,9 @@ Theorem word_copy_fwd_alias_thm word_copy_fwd be (n2w n) (a2 + bytes_in_word + n2w xp) (a2 + bytes_in_word + n2w yp) m dm = SOME m1 /\ memory_rel c be (refs |+ (p2,ByteArray fl_ys ys1)) - sp st m1 dm ((RefPtr p2,v2)::vars)` - (completeInduct_on `n` \\ fs [PULL_FORALL,AND_IMP_INTRO] + sp st m1 dm ((RefPtr p2,v2)::vars) +Proof + completeInduct_on `n` \\ fs [PULL_FORALL,AND_IMP_INTRO] \\ once_rewrite_tac [list_copy_fwd_alias_def] \\ rpt strip_tac \\ `4 < dimword (:'a)` by fs [good_dimindex_def,dimword_def] @@ -8780,7 +9229,8 @@ Theorem word_copy_fwd_alias_thm \\ strip_tac \\ rfs [] \\ rewrite_tac [GSYM word_sub_def,addressTheory.word_arith_lemma2] \\ fs [] \\ first_x_assum match_mp_tac - \\ fs [] \\ asm_exists_tac \\ fs []); + \\ fs [] \\ asm_exists_tac \\ fs [] +QED (* copy backward *) @@ -8854,8 +9304,8 @@ val list_copy_bwd_alias_def = Define ` LUPDATE (EL (minus xp 0) ys) (minus yp 0)) ys) else NONE` |> REWRITE_RULE [minus_def]; -Theorem word_copy_bwd_thm - `!n xp yp ys ys1 m. +Theorem word_copy_bwd_thm: + !n xp yp ys ys1 m. memory_rel c be (refs |+ (p2,ByteArray fl_ys ys)) sp st m dm ((RefPtr p1,v1)::(RefPtr p2,v2)::vars) /\ FLOOKUP refs p1 = SOME (ByteArray fl_xs xs) /\ @@ -8868,8 +9318,9 @@ Theorem word_copy_bwd_thm word_copy_bwd be (n2w n) (a1 + bytes_in_word + n2w xp) (a2 + bytes_in_word + n2w yp) m dm = SOME m1 /\ memory_rel c be (refs |+ (p2,ByteArray fl_ys ys1)) - sp st m1 dm ((RefPtr p1,v1)::(RefPtr p2,v2)::vars)` - (completeInduct_on `n` \\ fs [PULL_FORALL,AND_IMP_INTRO] + sp st m1 dm ((RefPtr p1,v1)::(RefPtr p2,v2)::vars) +Proof + completeInduct_on `n` \\ fs [PULL_FORALL,AND_IMP_INTRO] \\ once_rewrite_tac [list_copy_bwd_def] \\ rpt strip_tac \\ `4 < dimword (:'a)` by fs [good_dimindex_def,dimword_def] @@ -8959,10 +9410,11 @@ Theorem word_copy_bwd_thm fs[Once word_copy_bwd_def,WORD_LO,Once list_copy_bwd_def]>> rw[]) \\ first_x_assum match_mp_tac - \\ fs [] \\ asm_exists_tac \\ fs []); + \\ fs [] \\ asm_exists_tac \\ fs [] +QED -Theorem word_copy_bwd_alias_thm - `!n xp yp ys ys1 m. +Theorem word_copy_bwd_alias_thm: + !n xp yp ys ys1 m. memory_rel c be (refs |+ (p2,ByteArray fl_ys ys)) sp st m dm ((RefPtr p2,v2)::vars) /\ list_copy_bwd_alias n xp yp ys = SOME ys1 /\ @@ -8973,8 +9425,9 @@ Theorem word_copy_bwd_alias_thm word_copy_bwd be (n2w n) (a2 + bytes_in_word + n2w xp) (a2 + bytes_in_word + n2w yp) m dm = SOME m1 /\ memory_rel c be (refs |+ (p2,ByteArray fl_ys ys1)) - sp st m1 dm ((RefPtr p2,v2)::vars)` - (completeInduct_on `n` \\ fs [PULL_FORALL,AND_IMP_INTRO] + sp st m1 dm ((RefPtr p2,v2)::vars) +Proof + completeInduct_on `n` \\ fs [PULL_FORALL,AND_IMP_INTRO] \\ once_rewrite_tac [list_copy_bwd_alias_def] \\ rpt strip_tac \\ `4 < dimword (:'a)` by fs [good_dimindex_def,dimword_def] @@ -9050,7 +9503,8 @@ Theorem word_copy_bwd_alias_thm fs[Once list_copy_bwd_alias_def]>>rw[]) \\ simp[] \\ first_x_assum match_mp_tac - \\ fs [] \\ asm_exists_tac \\ fs []); + \\ fs [] \\ asm_exists_tac \\ fs [] +QED (* copy array *) @@ -9127,11 +9581,12 @@ val list_copy_bwd_eq = Q.prove(` rpt(IF_CASES_TAC>> simp[EL_TAKE,EL_DROP])); -Theorem list_copy_thm - `!xs ys xp yp n ys1. +Theorem list_copy_thm: + !xs ys xp yp n ys1. copy_array (xs, &xp) (& n) (SOME (ys, &yp)) = SOME ys1 ==> - list_copy n xp xs yp ys = SOME ys1` - (rw[semanticPrimitivesTheory.copy_array_def,list_copy_def]>> + list_copy n xp xs yp ys = SOME ys1 +Proof + rw[semanticPrimitivesTheory.copy_array_def,list_copy_def]>> fs[integerTheory.INT_ADD,integerTheory.INT_ABS_NUM] >- (match_mp_tac list_copy_fwd_eq>> @@ -9143,7 +9598,8 @@ Theorem list_copy_thm impl_tac >- simp[]>> rw[]>> - simp[]); + simp[] +QED (* see more interesting theorem below *) @@ -9210,11 +9666,12 @@ val list_copy_bwd_alias_eq = Q.prove(` rpt(IF_CASES_TAC>> simp[EL_TAKE,EL_DROP])); -Theorem list_copy_alias_thm - `!ys xp yp n ys1. +Theorem list_copy_alias_thm: + !ys xp yp n ys1. copy_array (ys, &xp) (& n) (SOME (ys, &yp)) = SOME ys1 ==> - list_copy_alias n xp yp ys = SOME ys1` - (rw[semanticPrimitivesTheory.copy_array_def,list_copy_alias_def]>> + list_copy_alias n xp yp ys = SOME ys1 +Proof + rw[semanticPrimitivesTheory.copy_array_def,list_copy_alias_def]>> fs[integerTheory.INT_ADD,integerTheory.INT_ABS_NUM] >- (match_mp_tac list_copy_fwd_alias_eq>>simp[]) @@ -9224,16 +9681,19 @@ Theorem list_copy_alias_thm (Q.ISPECL_THEN [`n`,`n+xp-1`,`n+yp-1`,`ys`] mp_tac list_copy_bwd_alias_eq>> impl_tac >- simp[]>> - rw[])); + rw[]) +QED -Theorem copy_array_NONE_IMP - `!xs ys xp n. +Theorem copy_array_NONE_IMP: + !xs ys xp n. copy_array (xs, &xp) (& n) NONE = SOME ys ==> - list_copy_fwd n xp xs 0 (REPLICATE n 0w) = SOME ys` - (rw[semanticPrimitivesTheory.copy_array_def,list_copy_alias_def]>> + list_copy_fwd n xp xs 0 (REPLICATE n 0w) = SOME ys +Proof + rw[semanticPrimitivesTheory.copy_array_def,list_copy_alias_def]>> fs[integerTheory.INT_ADD,integerTheory.INT_ABS_NUM]>> Q.ISPECL_THEN [`n`,`xp`,`xs`,`0`,`REPLICATE n 0w`] mp_tac list_copy_fwd_eq>> - simp[DROP_LENGTH_NIL_rwt]); + simp[DROP_LENGTH_NIL_rwt] +QED (* @@ -9269,8 +9729,8 @@ val word_copy_bwd_0 = prove( rw [good_dimindex_def] \\ once_rewrite_tac [word_copy_bwd_def] \\ fs [dimword_def,WORD_LO]); -Theorem word_copy_array_thm - `!n xp yp xs ys ys1 m. +Theorem word_copy_array_thm: + !n xp yp xs ys ys1 m. memory_rel c be refs sp st m dm ((RefPtr p1,v1)::(RefPtr p2,v2)::vars) /\ FLOOKUP refs p1 = SOME (ByteArray fl_xs xs) /\ FLOOKUP refs p2 = SOME (ByteArray fl_ys ys) /\ @@ -9283,8 +9743,9 @@ Theorem word_copy_array_thm word_copy_array be (n2w n) (a1 + bytes_in_word) (n2w xp) (a2 + bytes_in_word) (n2w yp) m dm = SOME m1 /\ memory_rel c be (refs |+ (p2,ByteArray fl_ys ys1)) - sp st m1 dm ((RefPtr p1,v1)::(RefPtr p2,v2)::vars)` - (rw [] \\ drule list_copy_thm + sp st m1 dm ((RefPtr p1,v1)::(RefPtr p2,v2)::vars) +Proof + rw [] \\ drule list_copy_thm \\ fs [list_copy_def] \\ `n + xp <= LENGTH xs /\ n + yp <= LENGTH ys` by (fs [semanticPrimitivesTheory.copy_array_def,NOT_LESS] @@ -9315,10 +9776,11 @@ Theorem word_copy_array_thm THEN1 (strip_tac \\ asm_rewrite_tac [] \\ fs []) \\ fs [WORD_ADD_ASSOC,word_add_n2w] \\ rewrite_tac [GSYM word_sub_def,addressTheory.word_arith_lemma2] - \\ fs [])); + \\ fs []) +QED -Theorem word_copy_array_alias_thm - `!n xp yp ys ys1 m. +Theorem word_copy_array_alias_thm: + !n xp yp ys ys1 m. memory_rel c be refs sp st m dm ((RefPtr p2,v2)::vars) /\ FLOOKUP refs p2 = SOME (ByteArray fl_ys ys) /\ copy_array (ys, &xp) (& n) (SOME (ys, &yp)) = SOME ys1 /\ @@ -9329,8 +9791,9 @@ Theorem word_copy_array_alias_thm word_copy_array be (n2w n) (a2 + bytes_in_word) (n2w xp) (a2 + bytes_in_word) (n2w yp) m dm = SOME m1 /\ memory_rel c be (refs |+ (p2,ByteArray fl_ys ys1)) - sp st m1 dm ((RefPtr p2,v2)::vars)` - (rw [] \\ drule list_copy_alias_thm + sp st m1 dm ((RefPtr p2,v2)::vars) +Proof + rw [] \\ drule list_copy_alias_thm \\ fs [list_copy_alias_def] \\ `n + xp <= LENGTH ys /\ n + yp <= LENGTH ys` by (fs [semanticPrimitivesTheory.copy_array_def,NOT_LESS] @@ -9359,24 +9822,31 @@ Theorem word_copy_array_alias_thm THEN1 (strip_tac \\ asm_rewrite_tac [] \\ fs []) \\ fs [WORD_ADD_ASSOC,word_add_n2w] \\ rewrite_tac [GSYM word_sub_def,addressTheory.word_arith_lemma2] - \\ fs [])); - -Theorem word_of_byte_0 - `word_of_byte 0w = 0w` - (rw [word_of_byte_def]); - -Theorem last_bytes_0 - `!nb a. last_bytes nb 0w a 0w be = 0w` - (Induct_on `nb` + \\ fs []) +QED + +Theorem word_of_byte_0: + word_of_byte 0w = 0w +Proof + rw [word_of_byte_def] +QED + +Theorem last_bytes_0: + !nb a. last_bytes nb 0w a 0w be = 0w +Proof + Induct_on `nb` \\ once_rewrite_tac [last_bytes_def] \\ fs [] \\ rw [] \\ fs [set_byte_def] \\ fs [word_slice_alt_def] - \\ fs [word_0,word_or_def,fcpTheory.FCP_BETA,fcpTheory.CART_EQ]); + \\ fs [word_0,word_or_def,fcpTheory.FCP_BETA,fcpTheory.CART_EQ] +QED -Theorem LUPDATE_REPLICATE[simp] - `!n a. LUPDATE x a (REPLICATE n x) = REPLICATE n x` - (Induct \\ rewrite_tac [REPLICATE,LUPDATE_def] - \\ Cases \\ asm_rewrite_tac [REPLICATE,LUPDATE_def]); +Theorem LUPDATE_REPLICATE[simp]: + !n a. LUPDATE x a (REPLICATE n x) = REPLICATE n x +Proof + Induct \\ rewrite_tac [REPLICATE,LUPDATE_def] + \\ Cases \\ asm_rewrite_tac [REPLICATE,LUPDATE_def] +QED val memory_rel_copy_array_NONE_lemma = memory_rel_RefByte_alt @@ -9384,8 +9854,8 @@ val memory_rel_copy_array_NONE_lemma = |> SIMP_RULE (srw_ss()) [w2w_def,w2n_n2w,word_of_byte_0,last_bytes_0, LET_THM,LUPDATE_REPLICATE] -Theorem memory_rel_copy_array_NONE - `memory_rel c be refs sp st m dm ((RefPtr p1,v1:'a word_loc)::vars) ∧ +Theorem memory_rel_copy_array_NONE: + memory_rel c be refs sp st m dm ((RefPtr p1,v1:'a word_loc)::vars) ∧ new ∉ FDOM refs ∧ FLOOKUP refs p1 = SOME (ByteArray fl_xs xs) /\ copy_array (xs, &xp) (& n) NONE = SOME ys /\ @@ -9407,8 +9877,9 @@ Theorem memory_rel_copy_array_NONE (sp − (byte_len (:α) n + 1)) (st |+ (NextFree, Word (free + bytes_in_word * n2w (byte_len (:α) n + 1)))) m2 dm - ((RefPtr new,Word w2)::vars)` - (rw [] \\ rpt_drule memory_rel_copy_array_NONE_lemma + ((RefPtr new,Word w2)::vars) +Proof + rw [] \\ rpt_drule memory_rel_copy_array_NONE_lemma \\ disch_then (qspec_then `fl` mp_tac) \\ strip_tac \\ fs [] \\ drule memory_rel_swap \\ strip_tac @@ -9421,17 +9892,19 @@ Theorem memory_rel_copy_array_NONE \\ strip_tac \\ fs [] \\ fs [get_real_addr_def,FLOOKUP_UPDATE] \\ rfs [] \\ pop_assum mp_tac - \\ match_mp_tac memory_rel_rearrange \\ fs []); + \\ match_mp_tac memory_rel_rearrange \\ fs [] +QED -Theorem memory_rel_space_max - `memory_rel c be refs old_sp st m dm vars ==> +Theorem memory_rel_space_max: + memory_rel c be refs old_sp st m dm vars ==> ?next_free trig_gc sp. FLOOKUP st NextFree = SOME (Word next_free) /\ FLOOKUP st TriggerGC = SOME (Word trig_gc) /\ trig_gc - next_free = bytes_in_word * n2w sp :'a word /\ old_sp <= sp /\ memory_rel c be refs sp st m dm vars /\ - (good_dimindex (:'a) ==> (dimindex (:α) DIV 8) * sp < dimword (:'a))` - (fs [memory_rel_def,heap_in_memory_store_def] \\ strip_tac \\ fs [] + (good_dimindex (:'a) ==> (dimindex (:α) DIV 8) * sp < dimword (:'a)) +Proof + fs [memory_rel_def,heap_in_memory_store_def] \\ strip_tac \\ fs [] \\ fs [GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] \\ qexists_tac `sp` \\ fs [] \\ fs [PULL_EXISTS] @@ -9443,15 +9916,18 @@ Theorem memory_rel_space_max \\ qexists_tac `gens` \\ fs [] \\ rw [] \\ fs [good_dimindex_def] \\ fs [word_ml_inv_def,abs_ml_inv_def,unused_space_inv_def,heap_ok_def] - \\ rfs [] \\ rveq \\ fs []); + \\ rfs [] \\ rveq \\ fs [] +QED -Theorem get_lowerbits_ptrbits - `get_lowerbits c (Word (ptr_bits c x y)) = (ptr_bits c x y || 1w)` - (rw [get_lowerbits_def, fcpTheory.CART_EQ, fcpTheory.FCP_BETA, ptr_bits_def, +Theorem get_lowerbits_ptrbits: + get_lowerbits c (Word (ptr_bits c x y)) = (ptr_bits c x y || 1w) +Proof + rw [get_lowerbits_def, fcpTheory.CART_EQ, fcpTheory.FCP_BETA, ptr_bits_def, small_shift_length_def] \\ eq_tac \\ rw [] \\ fs [] \\ rfs [word_or_def, word_lsl_def, word_bits_def, fcpTheory.FCP_BETA] - \\ imp_res_tac maxout_bits_IMP \\ fs []); + \\ imp_res_tac maxout_bits_IMP \\ fs [] +QED val append_writes_def = Define ` append_writes c ptr hdr [] l = ARB /\ @@ -9462,15 +9938,19 @@ val append_writes_def = Define ` Word ptr :: append_writes c ptr hdr xs l` -Theorem append_writes_LENGTH - `!xs ptr. - xs <> [] ==> LENGTH (append_writes c ptr hdr xs l) = 3 * LENGTH xs` - (Induct \\ rw [append_writes_def]); +Theorem append_writes_LENGTH: + !xs ptr. + xs <> [] ==> LENGTH (append_writes c ptr hdr xs l) = 3 * LENGTH xs +Proof + Induct \\ rw [append_writes_def] +QED -Theorem list_to_v_alt_list_to_v - `!xs ys. - list_to_v_alt (list_to_v ys) xs = list_to_v (xs ++ ys)` - (Induct \\ rw [list_to_v_alt_def, list_to_v_def]); +Theorem list_to_v_alt_list_to_v: + !xs ys. + list_to_v_alt (list_to_v ys) xs = list_to_v (xs ++ ys) +Proof + Induct \\ rw [list_to_v_alt_def, list_to_v_def] +QED val ptr_bits_1 = Q.prove ( `(ptr_bits c 0 2 || 1w) = ptr_bits c 0 2 + 1w`, @@ -9486,31 +9966,35 @@ val ptr_bits_1 = Q.prove ( \\ FULL_CASE_TAC \\ fs [word_0] \\ fs [WORD_SLICE_THM, word_lsl_def, word_bits_def, fcpTheory.FCP_BETA]); -Theorem ptr_bits_lemma - `(w << shift_length conf || ptr_bits conf 0 2 || 1w) = - w << shift_length conf + ptr_bits conf 0 2 + 1w` - (once_rewrite_tac [GSYM WORD_ADD_ASSOC] +Theorem ptr_bits_lemma: + (w << shift_length conf || ptr_bits conf 0 2 || 1w) = + w << shift_length conf + ptr_bits conf 0 2 + 1w +Proof + once_rewrite_tac [GSYM WORD_ADD_ASSOC] \\ once_rewrite_tac [GSYM ptr_bits_1] \\ irule (SPEC_ALL WORD_ADD_OR |> PURE_ONCE_REWRITE_RULE [EQ_SYM_EQ]) \\ rw [word_0, fcpTheory.CART_EQ] \\ strip_tac \\ rfs [fcpTheory.FCP_BETA, word_lsl_def, word_or_def, word_and_def, ptr_bits_def] \\ imp_res_tac maxout_bits_IMP \\ fs [] \\ imp_res_tac word_bit - \\ fsrw_tac [wordsLib.WORD_BIT_EQ_ss] [word_index, word_bit_test, shift_length_def]); + \\ fsrw_tac [wordsLib.WORD_BIT_EQ_ss] [word_index, word_bit_test, shift_length_def] +QED -Theorem encode_header_lemma - `1 < c.len_size /\ c.len_size + 5 < dimindex (:'a) /\ +Theorem encode_header_lemma: + 1 < c.len_size /\ c.len_size + 5 < dimindex (:'a) /\ good_dimindex (:'a) ==> decode_length c (make_header c 0w 2) = (2w: 'a word) /\ - encode_header c 0 2 = SOME (make_header c (0w: 'a word) 2)` - (strip_tac + encode_header c 0 2 = SOME (make_header c (0w: 'a word) 2) +Proof + strip_tac \\ reverse conj_asm2_tac >- fs [encode_header_def, good_dimindex_def, dimword_def] - \\ imp_res_tac encode_header_IMP \\ fs []); + \\ imp_res_tac encode_header_IMP \\ fs [] +QED -Theorem append_writes_list_to_BlockReps - `!xs ws x w offset init_ptr. +Theorem append_writes_list_to_BlockReps: + !xs ws x w offset init_ptr. LENGTH xs = LENGTH ws /\ good_dimindex (:'a) /\ 1 < c.len_size /\ c.len_size + 5 < dimindex (:'a) /\ @@ -9522,8 +10006,9 @@ Theorem append_writes_list_to_BlockReps (append_writes c init_ptr (make_header c 0w 2) (w::ws) (word_addr c v)) = word_heap (curr + bytes_in_word * n2w offset :'a word) - (list_to_BlockReps c v offset (x::xs)) c` - (Induct \\ rw [] + (list_to_BlockReps c v offset (x::xs)) c +Proof + Induct \\ rw [] >- rw [append_writes_def, list_to_BlockReps_def, BlockRep_def, word_heap_def, el_length_def, word_el_def, word_payload_def, backend_commonTheory.cons_tag_def, word_list_def, word_addr_def, @@ -9546,10 +10031,11 @@ Theorem append_writes_list_to_BlockReps \\ once_rewrite_tac [GSYM WORD_ADD_LSL] \\ once_rewrite_tac [word_add_n2w] \\ pop_assum (fn th => fs [GSYM th]) - \\ fs [AC STAR_COMM STAR_ASSOC, ptr_bits_lemma]); + \\ fs [AC STAR_COMM STAR_ASSOC, ptr_bits_lemma] +QED -Theorem memory_rel_append - `memory_rel c be refs sp st m1 dm +Theorem memory_rel_append: + memory_rel c be refs sp st m1 dm ((list_to_v in2,h)::ZIP (in1,ws) ++ vars) /\ (word_list next_free (append_writes c init_ptr (make_header c 0w 2) ws h) * SEP_T) @@ -9563,8 +10049,9 @@ Theorem memory_rel_append memory_rel c be refs (sp - 3 * LENGTH in1) (st |+ (NextFree, Word (next_free + bytes_in_word * n2w (3 * LENGTH in1)))) m1 dm - ((list_to_v (in1 ++ in2),Word init_ptr)::vars)` - (rw [] + ((list_to_v (in1 ++ in2),Word init_ptr)::vars) +Proof + rw [] \\ qabbrev_tac `p1 = ptr_bits c 0 2` \\ qabbrev_tac `sl = shift_length c - shift (:'a)` \\ qmatch_asmsub_abbrev_tac `append_writes c nfs` @@ -9620,7 +10107,8 @@ Theorem memory_rel_append >- fs [AC STAR_COMM STAR_ASSOC, WORD_LEFT_ADD_DISTRIB, GSYM word_add_n2w] \\ unabbrev_all_tac \\ rfs [] \\ irule append_writes_list_to_BlockReps \\ fs [] - \\ metis_tac [LIST_REL_APPEND_IMP]); + \\ metis_tac [LIST_REL_APPEND_IMP] +QED (* --- ML lists cannot exceed heap size: --- *) @@ -9636,47 +10124,57 @@ val walk_def = Define ` | SOME p => ptr::walk conf heap p (n-1)`; -Theorem v_inv_list_to_v_lemma - `v_inv c (list_to_v vs) (y,f,heap) /\ +Theorem v_inv_list_to_v_lemma: + v_inv c (list_to_v vs) (y,f,heap) /\ vs <> [] ==> ?p ys. y = Pointer p (Word (ptr_bits c cons_tag 2)) /\ - heap_lookup p heap = SOME (BlockRep cons_tag ys)` - (rw [] \\ Cases_on `vs` \\ fs [] \\ rw [] + heap_lookup p heap = SOME (BlockRep cons_tag ys) +Proof + rw [] \\ Cases_on `vs` \\ fs [] \\ rw [] \\ pop_assum mp_tac - \\ rw [list_to_v_def, v_inv_def, BlockRep_def]); + \\ rw [list_to_v_def, v_inv_def, BlockRep_def] +QED -Theorem walk_LENGTH - `!vs ptr ps. +Theorem walk_LENGTH: + !vs ptr ps. v_inv c (list_to_v vs) (Pointer ptr (Word (ptr_bits c cons_tag 2)),f,heap) /\ vs <> [] /\ walk c heap ptr (LENGTH vs) = ps ==> - LENGTH ps = LENGTH vs` - (Induct \\ rw [list_to_v_def, v_inv_def] + LENGTH ps = LENGTH vs +Proof + Induct \\ rw [list_to_v_def, v_inv_def] \\ drule (GEN_ALL v_inv_list_to_v_lemma) \\ Cases_on `vs` \\ fs [] >- (once_rewrite_tac [walk_def] \\ fs []) \\ rw [] \\ first_x_assum drule \\ strip_tac \\ once_rewrite_tac [walk_def] \\ fs [] - \\ fs [some_def, BlockRep_def]); + \\ fs [some_def, BlockRep_def] +QED -Theorem BlockRep_heap_length[simp] - `heap_length [BlockRep tag [x;y]] = 3` (EVAL_TAC); +Theorem BlockRep_heap_length[simp]: + heap_length [BlockRep tag [x;y]] = 3 +Proof +EVAL_TAC +QED -Theorem ALL_DISTINCT_FILTER_LENGTH - `ALL_DISTINCT xs +Theorem ALL_DISTINCT_FILTER_LENGTH: + ALL_DISTINCT xs ==> - LENGTH (FILTER ($~ o P) xs) + LENGTH (FILTER P xs) = LENGTH xs` - (Induct_on `xs` \\ rw [] \\ fs []); + LENGTH (FILTER ($~ o P) xs) + LENGTH (FILTER P xs) = LENGTH xs +Proof + Induct_on `xs` \\ rw [] \\ fs [] +QED -Theorem heap_length_Blocks - `!ps (heap: 'a ml_heap). +Theorem heap_length_Blocks: + !ps (heap: 'a ml_heap). ALL_DISTINCT ps /\ EVERY (\p. ?x y. heap_lookup p heap = SOME (BlockRep cons_tag [x;y])) ps ==> - 3 * LENGTH ps <= heap_length heap` - (gen_tac \\ completeInduct_on `LENGTH ps` + 3 * LENGTH ps <= heap_length heap +Proof + gen_tac \\ completeInduct_on `LENGTH ps` \\ Cases \\ rw [] \\ fs [EVERY_MEM] \\ imp_res_tac heap_lookup_SPLIT \\ fs [] \\ rveq \\ qabbrev_tac `t1 = FILTER (\x. x < heap_length ha) t` @@ -9715,17 +10213,19 @@ Theorem heap_length_Blocks \\ fs [MEM_FILTER, MEM_MAP] \\ rveq \\ res_tac \\ fs [] \\ rfs [heap_lookup_APPEND, heap_length_APPEND, BlockRep_def]) - \\ fs [LEFT_ADD_DISTRIB, heap_length_APPEND, ADD1, LESS_EQ_TRANS]); + \\ fs [LEFT_ADD_DISTRIB, heap_length_APPEND, ADD1, LESS_EQ_TRANS] +QED -Theorem walk_heap_lookup - `!vs p ps. +Theorem walk_heap_lookup: + !vs p ps. v_inv c (list_to_v vs) (Pointer p (Word (ptr_bits c cons_tag 2)),f,heap) /\ vs <> [] /\ walk c heap p (LENGTH vs) = ps ==> - EVERY (\p. ?x y. heap_lookup p heap = SOME (BlockRep cons_tag [x; y])) ps` - (Induct \\ rw [list_to_v_def, v_inv_def] + EVERY (\p. ?x y. heap_lookup p heap = SOME (BlockRep cons_tag [x; y])) ps +Proof + Induct \\ rw [list_to_v_def, v_inv_def] \\ imp_res_tac v_inv_list_to_v_lemma \\ Cases_on `vs = []` \\ fs [] \\ rveq >- (once_rewrite_tac [walk_def] \\ fs [BlockRep_def]) @@ -9733,14 +10233,16 @@ Theorem walk_heap_lookup \\ pop_assum mp_tac \\ once_rewrite_tac [walk_def] \\ fs [] \\ CASE_TAC \\ fs [] \\ rw [] - \\ fs [BlockRep_def]); + \\ fs [BlockRep_def] +QED -Theorem walk_MEM - `v_inv c (list_to_v vs) (Pointer ptr (Word (ptr_bits c cons_tag 2)),f,heap) /\ +Theorem walk_MEM: + v_inv c (list_to_v vs) (Pointer ptr (Word (ptr_bits c cons_tag 2)),f,heap) /\ vs <> [] ==> - MEM ptr (walk c heap ptr (LENGTH vs))` - (Cases_on `vs` \\ fs [] + MEM ptr (walk c heap ptr (LENGTH vs)) +Proof + Cases_on `vs` \\ fs [] \\ simp [Once walk_def, list_to_v_def, v_inv_def, some_def, BlockRep_def] \\ strip_tac \\ rveq \\ fs [] \\ IF_CASES_TAC \\ fs [] @@ -9749,10 +10251,11 @@ Theorem walk_MEM \\ Cases_on `z` \\ fs [] \\ qhdtm_x_assum `v_inv` mp_tac \\ Cases_on `t` \\ rw [v_inv_def, list_to_v_def, BlockRep_def] - \\ CCONTR_TAC \\ fs [] \\ rveq \\ fs []); + \\ CCONTR_TAC \\ fs [] \\ rveq \\ fs [] +QED -Theorem walk_EL - `!vs ptr ps. +Theorem walk_EL: + !vs ptr ps. v_inv c (list_to_v vs) (Pointer ptr (Word (ptr_bits c cons_tag 2)),f,heap) /\ vs <> [] /\ @@ -9762,8 +10265,9 @@ Theorem walk_EL ?x. heap_lookup (EL n ps) heap = SOME (BlockRep cons_tag [x; - Pointer (EL (SUC n) ps) (Word (ptr_bits c cons_tag 2))])` - (Induct >- rw [] \\ ntac 4 strip_tac + Pointer (EL (SUC n) ps) (Word (ptr_bits c cons_tag 2))]) +Proof + Induct >- rw [] \\ ntac 4 strip_tac \\ Induct \\ rw [] \\ qhdtm_x_assum `v_inv` mp_tac \\ rw [list_to_v_def, v_inv_def] @@ -9777,15 +10281,17 @@ Theorem walk_EL \\ qhdtm_x_assum `v_inv` mp_tac \\ rw [list_to_v_def, v_inv_def] \\ fs [BlockRep_def]) \\ disch_then drule \\ rw [] - \\ once_rewrite_tac [walk_def] \\ fs [BlockRep_def]); + \\ once_rewrite_tac [walk_def] \\ fs [BlockRep_def] +QED -Theorem list_to_v_same_LENGTH - `!xs x ys. +Theorem list_to_v_same_LENGTH: + !xs x ys. v_inv c (list_to_v xs) (x,f,heap) /\ v_inv c (list_to_v ys) (x,f,heap) ==> - LENGTH xs = LENGTH ys` - (Induct \\ rw [] + LENGTH xs = LENGTH ys +Proof + Induct \\ rw [] \\ pop_assum mp_tac \\ pop_assum mp_tac \\ rw [v_inv_def, list_to_v_def] @@ -9793,10 +10299,11 @@ Theorem list_to_v_same_LENGTH \\ Cases_on `ys` \\ rw [v_inv_def, list_to_v_def] \\ fs [BlockRep_def] \\ rveq - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem list_to_v_DROP - `!vs ptr ps k. +Theorem list_to_v_DROP: + !vs ptr ps k. v_inv c (list_to_v vs) (Pointer ptr (Word (ptr_bits c cons_tag 2)),f,heap) /\ vs <> [] /\ walk c heap ptr (LENGTH vs) = ps /\ @@ -9804,8 +10311,9 @@ Theorem list_to_v_DROP k < LENGTH vs ==> v_inv c (list_to_v (DROP k vs)) - (Pointer (EL k ps) (Word (ptr_bits c cons_tag 2)),f,heap)` - (Induct >- rw [] + (Pointer (EL k ps) (Word (ptr_bits c cons_tag 2)),f,heap) +Proof + Induct >- rw [] \\ ntac 3 strip_tac \\ Induct \\ rw [] >- @@ -9843,16 +10351,18 @@ Theorem list_to_v_DROP >- simp [list_to_v_def, v_inv_def, PULL_EXISTS, BlockRep_def, Once walk_def] \\ strip_tac \\ Cases_on `k` \\ fs [] - \\ once_rewrite_tac [walk_def] \\ fs [BlockRep_def]); + \\ once_rewrite_tac [walk_def] \\ fs [BlockRep_def] +QED -Theorem walk_ALL_DISTINCT - `!vs ptr ps. +Theorem walk_ALL_DISTINCT: + !vs ptr ps. v_inv c (list_to_v vs) (Pointer ptr (Word (ptr_bits c cons_tag 2)),f,heap) /\ vs <> [] /\ walk c heap ptr (LENGTH vs) = ps ==> - ALL_DISTINCT ps` - (Induct \\ rw [v_inv_def, list_to_v_def] + ALL_DISTINCT ps +Proof + Induct \\ rw [v_inv_def, list_to_v_def] \\ rename1 `(y,f,heap)` \\ rename1 `SUC (LENGTH vs)` \\ drule (GEN_ALL v_inv_list_to_v_lemma) \\ strip_tac @@ -9877,26 +10387,31 @@ Theorem walk_ALL_DISTINCT >- rw [v_inv_def, list_to_v_def, BlockRep_def] \\ sg `LENGTH (h::vs) = LENGTH (DROP n vs)` >- (irule list_to_v_same_LENGTH \\ asm_exists_tac \\ fs []) - \\ fs [LENGTH_DROP]); + \\ fs [LENGTH_DROP] +QED -Theorem list_to_v_heap_length - `v_inv c (list_to_v vs) (x,f,heap) /\ +Theorem list_to_v_heap_length: + v_inv c (list_to_v vs) (x,f,heap) /\ vs <> [] ==> - 3 * LENGTH vs <= heap_length heap` - (metis_tac [walk_heap_lookup, walk_LENGTH, walk_ALL_DISTINCT, - heap_length_Blocks, v_inv_list_to_v_lemma]); + 3 * LENGTH vs <= heap_length heap +Proof + metis_tac [walk_heap_lookup, walk_LENGTH, walk_ALL_DISTINCT, + heap_length_Blocks, v_inv_list_to_v_lemma] +QED (* ------------------------------------------------------------------------- *) -Theorem memory_rel_list_limit - `memory_rel c be refs sp0 st m dm ((list_to_v xs, (w: 'a word_loc))::vars) /\ +Theorem memory_rel_list_limit: + memory_rel c be refs sp0 st m dm ((list_to_v xs, (w: 'a word_loc))::vars) /\ good_dimindex (:'a) ==> - 3 * (LENGTH xs + 1) * (dimindex (:'a) DIV 8) < dimword (:'a)` - (rw [memory_rel_def, word_ml_inv_def, abs_ml_inv_def, bc_stack_ref_inv_def, + 3 * (LENGTH xs + 1) * (dimindex (:'a) DIV 8) < dimword (:'a) +Proof + rw [memory_rel_def, word_ml_inv_def, abs_ml_inv_def, bc_stack_ref_inv_def, heap_ok_def, heap_in_memory_store_def] \\ drule (GEN_ALL list_to_v_heap_length) - \\ Cases_on `xs` \\ fs [dimword_def, good_dimindex_def] \\ rw [] \\ fs []); + \\ Cases_on `xs` \\ fs [dimword_def, good_dimindex_def] \\ rw [] \\ fs [] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/flat_elimProofScript.sml b/compiler/backend/proofs/flat_elimProofScript.sml index 1b47a3d50f..033b94f687 100644 --- a/compiler/backend/proofs/flat_elimProofScript.sml +++ b/compiler/backend/proofs/flat_elimProofScript.sml @@ -15,132 +15,151 @@ val _ = set_grammar_ancestry grammar_ancestry; (**************************** ANALYSIS LEMMAS *****************************) -Theorem is_pure_EVERY_aconv - `∀ es . EVERY (λ a . is_pure a) es = EVERY is_pure es` - (Induct >> fs[] -); - -Theorem wf_find_loc_wf_find_locL - `(∀ e locs . find_loc e = locs ⇒ wf locs) ∧ - (∀ l locs . find_locL l = locs ⇒ wf locs)` - (ho_match_mp_tac find_loc_ind >> rw[find_loc_def, wf_union] >> rw[wf_def] >> +Theorem is_pure_EVERY_aconv: + ∀ es . EVERY (λ a . is_pure a) es = EVERY is_pure es +Proof + Induct >> fs[] +QED + +Theorem wf_find_loc_wf_find_locL: + (∀ e locs . find_loc e = locs ⇒ wf locs) ∧ + (∀ l locs . find_locL l = locs ⇒ wf locs) +Proof + ho_match_mp_tac find_loc_ind >> rw[find_loc_def, wf_union] >> rw[wf_def] >> Cases_on `dest_GlobalVarInit op` >> fs[wf_insert] -); - -Theorem wf_find_locL - `∀ l . wf(find_locL l)` - (metis_tac[wf_find_loc_wf_find_locL] -); - -Theorem wf_find_loc - `∀ e . wf(find_loc e)` - (metis_tac[wf_find_loc_wf_find_locL] -); - -Theorem wf_find_lookups_wf_find_lookupsL - `(∀ e lookups . find_lookups e = lookups ⇒ wf lookups) ∧ - (∀ l lookups . find_lookupsL l = lookups ⇒ wf lookups)` - (ho_match_mp_tac find_lookups_ind >> +QED + +Theorem wf_find_locL: + ∀ l . wf(find_locL l) +Proof + metis_tac[wf_find_loc_wf_find_locL] +QED + +Theorem wf_find_loc: + ∀ e . wf(find_loc e) +Proof + metis_tac[wf_find_loc_wf_find_locL] +QED + +Theorem wf_find_lookups_wf_find_lookupsL: + (∀ e lookups . find_lookups e = lookups ⇒ wf lookups) ∧ + (∀ l lookups . find_lookupsL l = lookups ⇒ wf lookups) +Proof + ho_match_mp_tac find_lookups_ind >> rw[find_lookups_def, wf_union] >> rw[wf_def] >> Cases_on `dest_GlobalVarLookup op` >> fs[wf_insert] -); - -Theorem wf_find_lookupsL - `∀ l . wf(find_lookupsL l)` - (metis_tac[wf_find_lookups_wf_find_lookupsL] -); - -Theorem wf_find_lookups - `∀ e . wf(find_lookups e)` - (metis_tac[wf_find_lookups_wf_find_lookupsL] -); - -Theorem find_lookupsL_MEM - `∀ e es . MEM e es ⇒ domain (find_lookups e) ⊆ domain (find_lookupsL es)` - (Induct_on `es` >> rw[] >> fs[find_lookups_def, domain_union] >> +QED + +Theorem wf_find_lookupsL: + ∀ l . wf(find_lookupsL l) +Proof + metis_tac[wf_find_lookups_wf_find_lookupsL] +QED + +Theorem wf_find_lookups: + ∀ e . wf(find_lookups e) +Proof + metis_tac[wf_find_lookups_wf_find_lookupsL] +QED + +Theorem find_lookupsL_MEM: + ∀ e es . MEM e es ⇒ domain (find_lookups e) ⊆ domain (find_lookupsL es) +Proof + Induct_on `es` >> rw[] >> fs[find_lookups_def, domain_union] >> res_tac >> fs[SUBSET_DEF] -); - -Theorem find_lookupsL_APPEND - `∀ l1 l2 . find_lookupsL (l1 ++ l2) = - union (find_lookupsL l1) (find_lookupsL l2)` - (Induct >> fs[find_lookups_def] >> fs[union_assoc] -); - -Theorem find_lookupsL_REVERSE - `∀ l . find_lookupsL l = find_lookupsL (REVERSE l)` - (Induct >> fs[find_lookups_def] >> +QED + +Theorem find_lookupsL_APPEND: + ∀ l1 l2 . find_lookupsL (l1 ++ l2) = + union (find_lookupsL l1) (find_lookupsL l2) +Proof + Induct >> fs[find_lookups_def] >> fs[union_assoc] +QED + +Theorem find_lookupsL_REVERSE: + ∀ l . find_lookupsL l = find_lookupsL (REVERSE l) +Proof + Induct >> fs[find_lookups_def] >> fs[find_lookupsL_APPEND, find_lookups_def, union_num_set_sym] -); +QED -Theorem find_loc_EVERY_isEmpty - `∀ l reachable:num_set . +Theorem find_loc_EVERY_isEmpty: + ∀ l reachable:num_set . EVERY (λ e . isEmpty (inter (find_loc e) reachable)) l - ⇔ isEmpty (inter (find_locL l) reachable)` - (Induct >- fs[Once find_loc_def, inter_def] + ⇔ isEmpty (inter (find_locL l) reachable) +Proof + Induct >- fs[Once find_loc_def, inter_def] >> fs[EVERY_DEF] >> rw[] >> EQ_TAC >> rw[] >> qpat_x_assum `isEmpty _` mp_tac >> simp[Once find_loc_def] >> fs[inter_union_empty] -); +QED -Theorem wf_analyse_exp - `∀ e roots tree . analyse_exp e = (roots, tree) ⇒ (wf roots) ∧ (wf tree)` - (simp[analyse_exp_def] >> rw[] >> +Theorem wf_analyse_exp: + ∀ e roots tree . analyse_exp e = (roots, tree) ⇒ (wf roots) ∧ (wf tree) +Proof + simp[analyse_exp_def] >> rw[] >> metis_tac[ wf_def, wf_map, wf_union, wf_find_loc, wf_find_lookups_wf_find_lookupsL] -); +QED -Theorem analyse_exp_domain - `∀ e roots tree . analyse_exp e = (roots, tree) - ⇒ (domain roots ⊆ domain tree)` - (simp[analyse_exp_def] >> rw[] >> rw[domain_def, domain_map] -); +Theorem analyse_exp_domain: + ∀ e roots tree . analyse_exp e = (roots, tree) + ⇒ (domain roots ⊆ domain tree) +Proof + simp[analyse_exp_def] >> rw[] >> rw[domain_def, domain_map] +QED (**************************** ELIMINATION LEMMAS *****************************) -Theorem keep_Dlet - `∀ (reachable:num_set) h . ¬ keep reachable h ⇒ ∃ x . h = Dlet x` - (Cases_on `h` >> rw[keep_def] -); +Theorem keep_Dlet: + ∀ (reachable:num_set) h . ¬ keep reachable h ⇒ ∃ x . h = Dlet x +Proof + Cases_on `h` >> rw[keep_def] +QED -Theorem num_set_tree_union_empty - `∀ t1 t2 . isEmpty(num_set_tree_union t1 t2) ⇔ isEmpty t1 ∧ isEmpty t2` - (Induct >> rw[num_set_tree_union_def] >> CASE_TAC >> +Theorem num_set_tree_union_empty: + ∀ t1 t2 . isEmpty(num_set_tree_union t1 t2) ⇔ isEmpty t1 ∧ isEmpty t2 +Proof + Induct >> rw[num_set_tree_union_def] >> CASE_TAC >> rw[num_set_tree_union_def] -); +QED -Theorem wf_num_set_tree_union - `∀ t1 t2 result . wf t1 ∧ wf t2 ∧ num_set_tree_union t1 t2 = result - ⇒ wf result` - (Induct >> rw[num_set_tree_union_def, wf_def] >> rw[wf_def] >> +Theorem wf_num_set_tree_union: + ∀ t1 t2 result . wf t1 ∧ wf t2 ∧ num_set_tree_union t1 t2 = result + ⇒ wf result +Proof + Induct >> rw[num_set_tree_union_def, wf_def] >> rw[wf_def] >> TRY(CASE_TAC) >> rw[wf_def] >> TRY(metis_tac[wf_def, num_set_tree_union_empty]) -); +QED -Theorem domain_num_set_tree_union - `∀ t1 t2 . domain (num_set_tree_union t1 t2) = domain t1 ∪ domain t2` - (Induct >> rw[num_set_tree_union_def, domain_def] >> CASE_TAC >> +Theorem domain_num_set_tree_union: + ∀ t1 t2 . domain (num_set_tree_union t1 t2) = domain t1 ∪ domain t2 +Proof + Induct >> rw[num_set_tree_union_def, domain_def] >> CASE_TAC >> rw[domain_def, domain_union] >> rw[UNION_ASSOC] >> rw[UNION_COMM] >> rw[UNION_ASSOC] >> rw[UNION_COMM] >> metis_tac[UNION_ASSOC, UNION_COMM, UNION_IDEMPOT] -); +QED -Theorem num_set_tree_union_sym - `∀ (t1 : num_set num_map) t2 . - num_set_tree_union t1 t2 = num_set_tree_union t2 t1` - (Induct >> rw[num_set_tree_union_def] >> +Theorem num_set_tree_union_sym: + ∀ (t1 : num_set num_map) t2 . + num_set_tree_union t1 t2 = num_set_tree_union t2 t1 +Proof + Induct >> rw[num_set_tree_union_def] >> Cases_on `t2` >> fs[num_set_tree_union_def] >> fs[union_num_set_sym] -); +QED -Theorem lookup_domain_num_set_tree_union - `∀ n (t1:num_set num_map) t2 x . lookup n t1 = SOME x - ⇒ ∃ y . lookup n (num_set_tree_union t1 t2) = SOME y ∧ domain x ⊆ domain y` - (Induct_on `t1` >> rw[] +Theorem lookup_domain_num_set_tree_union: + ∀ n (t1:num_set num_map) t2 x . lookup n t1 = SOME x + ⇒ ∃ y . lookup n (num_set_tree_union t1 t2) = SOME y ∧ domain x ⊆ domain y +Proof + Induct_on `t1` >> rw[] >- fs[lookup_def] >- (fs[lookup_def, num_set_tree_union_def] >> CASE_TAC >> fs[lookup_def, domain_union]) @@ -149,34 +168,37 @@ Theorem lookup_domain_num_set_tree_union >- (fs[lookup_def, num_set_tree_union_def] >> CASE_TAC >> fs[lookup_def, domain_union] >> Cases_on `n = 0` >> fs[domain_union] >> Cases_on `EVEN n` >> fs[]) -); +QED -Theorem lookup_NONE_num_set_tree_union - `∀ n (t1:num_set num_map) t2 . lookup n t1 = NONE - ⇒ lookup n (num_set_tree_union t1 t2) = lookup n t2` - (Induct_on `t1` >> rw[] >> fs[lookup_def, num_set_tree_union_def] >> +Theorem lookup_NONE_num_set_tree_union: + ∀ n (t1:num_set num_map) t2 . lookup n t1 = NONE + ⇒ lookup n (num_set_tree_union t1 t2) = lookup n t2 +Proof + Induct_on `t1` >> rw[] >> fs[lookup_def, num_set_tree_union_def] >> Cases_on `t2` >> fs[lookup_def] >> Cases_on `n = 0` >> fs[] >> Cases_on `EVEN n` >> fs[] -); +QED -Theorem lookup_SOME_SOME_num_set_tree_union - `∀ n (t1:num_set num_map) x1 t2 x2 . +Theorem lookup_SOME_SOME_num_set_tree_union: + ∀ n (t1:num_set num_map) x1 t2 x2 . lookup n t1 = SOME x1 ∧ lookup n t2 = SOME x2 - ⇒ lookup n (num_set_tree_union t1 t2) = SOME (union x1 x2)` - (Induct_on `t1` >> rw[] >> fs[lookup_def, num_set_tree_union_def] >> + ⇒ lookup n (num_set_tree_union t1 t2) = SOME (union x1 x2) +Proof + Induct_on `t1` >> rw[] >> fs[lookup_def, num_set_tree_union_def] >> Cases_on `t2` >> fs[lookup_def] >> Cases_on `EVEN n` >> fs[] >> Cases_on `n = 0` >> fs[] -); +QED -Theorem lookup_num_set_tree_union - `∀ (t1 : num_set num_map) t2 n . +Theorem lookup_num_set_tree_union: + ∀ (t1 : num_set num_map) t2 n . lookup n (num_set_tree_union t1 t2) = case (lookup n t1) of | NONE => lookup n t2 | SOME s1 => case (lookup n t2) of | NONE => SOME s1 - | SOME s2 => SOME (union s1 s2)` - (rw[] >> Cases_on `lookup n t1` >> fs[] + | SOME s2 => SOME (union s1 s2) +Proof + rw[] >> Cases_on `lookup n t1` >> fs[] >- fs[lookup_NONE_num_set_tree_union] >- (Cases_on `lookup n t2` >> fs[] >- (fs[lookup_NONE_num_set_tree_union, num_set_tree_union_sym] >> @@ -184,56 +206,63 @@ Theorem lookup_num_set_tree_union pop_assum (qspec_then `t1` mp_tac) >> rw[] >> fs[num_set_tree_union_sym]) >- fs[lookup_SOME_SOME_num_set_tree_union]) -); +QED -Theorem wf_code_analysis_union - `∀ r3 r2 r1 t1 t2 t3. wf r1 ∧ wf r2 - ∧ code_analysis_union (r1, t1) (r2, t2) = (r3, t3) ⇒ wf r3` - (rw[code_analysis_union_def] >> rw[wf_union] -); +Theorem wf_code_analysis_union: + ∀ r3 r2 r1 t1 t2 t3. wf r1 ∧ wf r2 + ∧ code_analysis_union (r1, t1) (r2, t2) = (r3, t3) ⇒ wf r3 +Proof + rw[code_analysis_union_def] >> rw[wf_union] +QED -Theorem wf_code_analysis_union_strong - `∀ r3:num_set r2 r1 (t1:num_set num_map) t2 t3. +Theorem wf_code_analysis_union_strong: + ∀ r3:num_set r2 r1 (t1:num_set num_map) t2 t3. wf r1 ∧ wf r2 ∧ wf t1 ∧ wf t2 ∧ - code_analysis_union (r1, t1) (r2, t2) = (r3, t3) ⇒ wf r3 ∧ wf t3` - (rw[code_analysis_union_def] >> rw[wf_union] >> + code_analysis_union (r1, t1) (r2, t2) = (r3, t3) ⇒ wf r3 ∧ wf t3 +Proof + rw[code_analysis_union_def] >> rw[wf_union] >> imp_res_tac wf_num_set_tree_union >> fs[] -); +QED -Theorem domain_code_analysis_union - `∀ r1:num_set r2 r3 (t1:num_set num_map) t2 t3 . +Theorem domain_code_analysis_union: + ∀ r1:num_set r2 r3 (t1:num_set num_map) t2 t3 . domain r1 ⊆ domain t1 ∧ domain r2 ⊆ domain t2 ∧ - code_analysis_union (r1, t1) (r2, t2) = (r3, t3) ⇒ domain r3 ⊆ domain t3` - (rw[code_analysis_union_def] >> rw[domain_union] >> + code_analysis_union (r1, t1) (r2, t2) = (r3, t3) ⇒ domain r3 ⊆ domain t3 +Proof + rw[code_analysis_union_def] >> rw[domain_union] >> rw[domain_num_set_tree_union] >> fs[SUBSET_DEF] -); +QED -Theorem wf_code_analysis_union - `∀ r3 r2 r1 t1 t2 t3. wf r1 ∧ wf r2 - ∧ code_analysis_union (r1, t1) (r2, t2) = (r3, t3) ⇒ wf r3` - (rw[code_analysis_union_def] >> rw[wf_union] -); +Theorem wf_code_analysis_union: + ∀ r3 r2 r1 t1 t2 t3. wf r1 ∧ wf r2 + ∧ code_analysis_union (r1, t1) (r2, t2) = (r3, t3) ⇒ wf r3 +Proof + rw[code_analysis_union_def] >> rw[wf_union] +QED -Theorem wf_code_analysis_union_strong - `∀ r3:num_set r2 r1 (t1:num_set num_map) t2 t3. +Theorem wf_code_analysis_union_strong: + ∀ r3:num_set r2 r1 (t1:num_set num_map) t2 t3. wf r1 ∧ wf r2 ∧ wf t1 ∧ wf t2 ∧ - code_analysis_union (r1, t1) (r2, t2) = (r3, t3) ⇒ wf r3 ∧ wf t3` - (rw[code_analysis_union_def] >> rw[wf_union] >> + code_analysis_union (r1, t1) (r2, t2) = (r3, t3) ⇒ wf r3 ∧ wf t3 +Proof + rw[code_analysis_union_def] >> rw[wf_union] >> imp_res_tac wf_num_set_tree_union >> fs[] -); +QED -Theorem domain_code_analysis_union - `∀ r1:num_set r2 r3 (t1:num_set num_map) t2 t3 . +Theorem domain_code_analysis_union: + ∀ r1:num_set r2 r3 (t1:num_set num_map) t2 t3 . domain r1 ⊆ domain t1 ∧ domain r2 ⊆ domain t2 ∧ - code_analysis_union (r1, t1) (r2, t2) = (r3, t3) ⇒ domain r3 ⊆ domain t3` - (rw[code_analysis_union_def] >> rw[domain_union] >> + code_analysis_union (r1, t1) (r2, t2) = (r3, t3) ⇒ domain r3 ⊆ domain t3 +Proof + rw[code_analysis_union_def] >> rw[domain_union] >> rw[domain_num_set_tree_union] >> fs[SUBSET_DEF] -); +QED -Theorem analyse_code_thm - `∀ code root tree . analyse_code code = (root, tree) - ⇒ (wf root) ∧ (domain root ⊆ domain tree)` - (Induct +Theorem analyse_code_thm: + ∀ code root tree . analyse_code code = (root, tree) + ⇒ (wf root) ∧ (domain root ⊆ domain tree) +Proof + Induct >-(rw[analyse_code_def] >> rw[wf_def]) >> Cases_on `h` >> simp[analyse_code_def] >> Cases_on `analyse_exp e` >> Cases_on `analyse_code code` >> @@ -242,19 +271,19 @@ Theorem analyse_code_thm >- imp_res_tac wf_code_analysis_union >> qspecl_then [`e`, `q`, `r`] mp_tac analyse_exp_domain >> rw[] >> imp_res_tac domain_code_analysis_union -); +QED (**************************** REACHABILITY LEMMAS *****************************) -Theorem subspt_superdomain - `∀ t1 a t2 . subspt (superdomain t1) (superdomain (BS t1 a t2)) ∧ +Theorem subspt_superdomain: + ∀ t1 a t2 . subspt (superdomain t1) (superdomain (BS t1 a t2)) ∧ subspt (superdomain t2) (superdomain (BS t1 a t2)) ∧ subspt a (superdomain (BS t1 a t2)) ∧ subspt (superdomain t1) (superdomain (BN t1 t2)) ∧ - subspt (superdomain t2) (superdomain (BN t1 t2))` - ( + subspt (superdomain t2) (superdomain (BN t1 t2)) +Proof fs[subspt_domain, superdomain_def] >> fs[SUBSET_DEF, domain_lookup, lookup_spt_fold_union_STRONG, lookup_def] >> rw[] @@ -282,33 +311,33 @@ Theorem subspt_superdomain fs[EVEN_DOUBLE, EVEN_ADD] >> once_rewrite_tac[MULT_COMM] >> fs[MULT_DIV] ) - ); +QED -Theorem superdomain_thm - `∀ x y (tree : unit spt spt) . lookup x tree = SOME y - ⇒ domain y ⊆ domain (superdomain tree)` - ( +Theorem superdomain_thm: + ∀ x y (tree : unit spt spt) . lookup x tree = SOME y + ⇒ domain y ⊆ domain (superdomain tree) +Proof fs[superdomain_def, domain_lookup, SUBSET_DEF] >> fs[lookup_spt_fold_union_STRONG, lookup_def] >> rw[] >> metis_tac[] - ); +QED -Theorem superdomain_inverse_thm - `∀ n tree . n ∈ domain (superdomain tree) - ⇒ ∃ k aSet . lookup k tree = SOME aSet ∧ n ∈ domain aSet` - ( +Theorem superdomain_inverse_thm: + ∀ n tree . n ∈ domain (superdomain tree) + ⇒ ∃ k aSet . lookup k tree = SOME aSet ∧ n ∈ domain aSet +Proof fs[superdomain_def, domain_lookup] >> fs[lookup_spt_fold_union_STRONG, lookup_def] - ); +QED -Theorem superdomain_not_in_thm - `∀ n tree . n ∉ domain (superdomain tree) - ⇒ ∀ k aSet . lookup k tree = SOME aSet ⇒ n ∉ domain aSet` - ( +Theorem superdomain_not_in_thm: + ∀ n tree . n ∉ domain (superdomain tree) + ⇒ ∀ k aSet . lookup k tree = SOME aSet ⇒ n ∉ domain aSet +Proof fs[superdomain_def, domain_lookup] >> fs[lookup_spt_fold_union_STRONG, lookup_def] >> rw[] >> metis_tac[] - ); +QED val wf_set_tree_def = Define ` wf_set_tree tree ⇔ @@ -317,38 +346,43 @@ val wf_set_tree_def = Define ` wf tree ` -Theorem mk_wf_set_tree_domain - `∀ tree . domain tree ⊆ domain (mk_wf_set_tree tree)` - (Induct >> +Theorem mk_wf_set_tree_domain: + ∀ tree . domain tree ⊆ domain (mk_wf_set_tree tree) +Proof + Induct >> rw[mk_wf_set_tree_def, domain_map, domain_mk_wf, domain_union, SUBSET_DEF] -); +QED -Theorem mk_wf_set_tree_thm - `∀ x tree . x = mk_wf_set_tree tree ⇒ wf_set_tree x` - (rw[mk_wf_set_tree_def, wf_set_tree_def] >> fs[lookup_map] >> +Theorem mk_wf_set_tree_thm: + ∀ x tree . x = mk_wf_set_tree tree ⇒ wf_set_tree x +Proof + rw[mk_wf_set_tree_def, wf_set_tree_def] >> fs[lookup_map] >> rw[domain_map, domain_union] >> fs[lookup_union] >> Cases_on `lookup x' tree` >> fs[] >- fs[lookup_map] >> rw[] >> qspecl_then [`x'`, `x`, `tree`] mp_tac superdomain_thm >> rw[SUBSET_DEF] -); - -Theorem lookup_mk_wf_set_tree - `∀ n tree x . lookup n tree = SOME x - ⇒ ∃ y . lookup n (mk_wf_set_tree tree) = SOME y ∧ domain x = domain y` - (rw[mk_wf_set_tree_def] >> rw[lookup_map] >> rw[lookup_union] -); - -Theorem lookup_domain_mk_wf_set_tree - `∀ n t x y . lookup n (mk_wf_set_tree t) = SOME x ⇒ - lookup n t = SOME y ⇒ domain y = domain x` - (rw[mk_wf_set_tree_def] >> fs[lookup_map, lookup_union] >> +QED + +Theorem lookup_mk_wf_set_tree: + ∀ n tree x . lookup n tree = SOME x + ⇒ ∃ y . lookup n (mk_wf_set_tree tree) = SOME y ∧ domain x = domain y +Proof + rw[mk_wf_set_tree_def] >> rw[lookup_map] >> rw[lookup_union] +QED + +Theorem lookup_domain_mk_wf_set_tree: + ∀ n t x y . lookup n (mk_wf_set_tree t) = SOME x ⇒ + lookup n t = SOME y ⇒ domain y = domain x +Proof + rw[mk_wf_set_tree_def] >> fs[lookup_map, lookup_union] >> metis_tac[domain_mk_wf] -); +QED -Theorem wf_close_spt - `∀ reachable seen tree. (wf reachable) ∧ (wf seen) ∧ (wf tree) ∧ +Theorem wf_close_spt: + ∀ reachable seen tree. (wf reachable) ∧ (wf seen) ∧ (wf tree) ∧ (∀ n x . (lookup n tree = SOME x) ⇒ wf x) - ⇒ wf (close_spt reachable seen tree)` - (recInduct close_spt_ind >> rw[] >> + ⇒ wf (close_spt reachable seen tree) +Proof + recInduct close_spt_ind >> rw[] >> once_rewrite_tac [close_spt_def] >> rw[] >> fs[] >> last_x_assum match_mp_tac >> @@ -361,25 +395,27 @@ Theorem wf_close_spt fs[lookup_inter] >> rw[] >> EVERY_CASE_TAC >> fs[] >> rveq >> metis_tac[] -); +QED (**************************** OTHER LEMMAS *****************************) -Theorem domain_superdomain_num_set_tree_union - `∀ t1 t2 . domain (superdomain t1) - ⊆ domain (superdomain (num_set_tree_union t1 t2))` - (fs[SUBSET_DEF] >> rw[] >> imp_res_tac superdomain_inverse_thm >> +Theorem domain_superdomain_num_set_tree_union: + ∀ t1 t2 . domain (superdomain t1) + ⊆ domain (superdomain (num_set_tree_union t1 t2)) +Proof + fs[SUBSET_DEF] >> rw[] >> imp_res_tac superdomain_inverse_thm >> imp_res_tac lookup_domain_num_set_tree_union >> pop_assum (qspec_then `t2` mp_tac) >> rw[] >> imp_res_tac superdomain_thm >> metis_tac[SUBSET_DEF] -); +QED -Theorem domain_superdomain_num_set_tree_union_STRONG - `∀ t1 t2 . domain (superdomain t1) ∪ domain (superdomain t2) = - domain (superdomain (num_set_tree_union t1 t2))` - (fs[EXTENSION] >> rw[] >> EQ_TAC >> rw[] +Theorem domain_superdomain_num_set_tree_union_STRONG: + ∀ t1 t2 . domain (superdomain t1) ∪ domain (superdomain t2) = + domain (superdomain (num_set_tree_union t1 t2)) +Proof + fs[EXTENSION] >> rw[] >> EQ_TAC >> rw[] >- metis_tac[domain_superdomain_num_set_tree_union, SUBSET_DEF, num_set_tree_union_sym] >- metis_tac[domain_superdomain_num_set_tree_union, @@ -391,12 +427,13 @@ Theorem domain_superdomain_num_set_tree_union_STRONG >- (rveq >> imp_res_tac superdomain_thm >> fs[SUBSET_DEF, domain_union]) ) -); +QED -Theorem mk_wf_set_tree_num_set_tree_union - `∀ t1 t2 . mk_wf_set_tree (num_set_tree_union t1 t2) = - num_set_tree_union (mk_wf_set_tree t1) (mk_wf_set_tree t2)` - (rw[] >> +Theorem mk_wf_set_tree_num_set_tree_union: + ∀ t1 t2 . mk_wf_set_tree (num_set_tree_union t1 t2) = + num_set_tree_union (mk_wf_set_tree t1) (mk_wf_set_tree t2) +Proof + rw[] >> `wf (mk_wf_set_tree (num_set_tree_union t1 t2))` by metis_tac[mk_wf_set_tree_thm, wf_set_tree_def] >> `wf (num_set_tree_union (mk_wf_set_tree t1) (mk_wf_set_tree t2))` by @@ -423,7 +460,7 @@ Theorem mk_wf_set_tree_num_set_tree_union >- (qsuff_tac `n ∈ domain (superdomain (num_set_tree_union t1 t2))` >- rw[domain_lookup] >> imp_res_tac domain_lookup >> metis_tac[]) -); +QED @@ -436,45 +473,50 @@ val is_adjacent_def = Define ` ( lookup y tree = SOME aSety ) `; -Theorem adjacent_domain - `∀ tree x y . is_adjacent tree x y ⇒ x ∈ domain tree ∧ y ∈ domain tree` - (rw[is_adjacent_def] >> rw[domain_lookup] -); +Theorem adjacent_domain: + ∀ tree x y . is_adjacent tree x y ⇒ x ∈ domain tree ∧ y ∈ domain tree +Proof + rw[is_adjacent_def] >> rw[domain_lookup] +QED val is_reachable_def = Define ` is_reachable tree = RTC (is_adjacent tree) `; -Theorem reachable_domain - `∀ tree x y . is_reachable tree x y - ⇒ (x = y ∨ (x ∈ domain tree ∧ y ∈ domain tree))` - (simp[is_reachable_def] >> strip_tac >> ho_match_mp_tac RTC_INDUCT_RIGHT1 >> +Theorem reachable_domain: + ∀ tree x y . is_reachable tree x y + ⇒ (x = y ∨ (x ∈ domain tree ∧ y ∈ domain tree)) +Proof + simp[is_reachable_def] >> strip_tac >> ho_match_mp_tac RTC_INDUCT_RIGHT1 >> metis_tac[adjacent_domain] -); +QED -Theorem rtc_is_adjacent - `s ⊆ t ∧ (∀ k . k ∈ t ⇒ ∀ n . (is_adjacent fullTree k n ⇒ n ∈ t)) ⇒ - ∀ x y . RTC(is_adjacent fullTree) x y ⇒ x ∈ s ⇒ y ∈ t` - (strip_tac >> +Theorem rtc_is_adjacent: + s ⊆ t ∧ (∀ k . k ∈ t ⇒ ∀ n . (is_adjacent fullTree k n ⇒ n ∈ t)) ⇒ + ∀ x y . RTC(is_adjacent fullTree) x y ⇒ x ∈ s ⇒ y ∈ t +Proof + strip_tac >> ho_match_mp_tac RTC_INDUCT_RIGHT1 >> fs[SUBSET_DEF] >> metis_tac [] -); +QED -Theorem is_adjacent_num_set_tree_union - `∀ t1 t2 n m . - is_adjacent t1 n m ⇒ is_adjacent (num_set_tree_union t1 t2) n m` - (rw[is_adjacent_def] >> imp_res_tac lookup_domain_num_set_tree_union >> +Theorem is_adjacent_num_set_tree_union: + ∀ t1 t2 n m . + is_adjacent t1 n m ⇒ is_adjacent (num_set_tree_union t1 t2) n m +Proof + rw[is_adjacent_def] >> imp_res_tac lookup_domain_num_set_tree_union >> first_x_assum (qspec_then `t2` mp_tac) >> rw[] >> first_x_assum (qspec_then `t2` mp_tac) >> rw[] >> fs[SUBSET_DEF, domain_lookup] -); +QED -Theorem is_adjacent_wf_set_tree_num_set_tree_union - `∀ t1 t2 n m . +Theorem is_adjacent_wf_set_tree_num_set_tree_union: + ∀ t1 t2 n m . is_adjacent (mk_wf_set_tree t1) n m - ⇒ is_adjacent (mk_wf_set_tree (num_set_tree_union t1 t2)) n m` - (rw[is_adjacent_def] >> fs[mk_wf_set_tree_def] >> fs[lookup_map] >> + ⇒ is_adjacent (mk_wf_set_tree (num_set_tree_union t1 t2)) n m +Proof + rw[is_adjacent_def] >> fs[mk_wf_set_tree_def] >> fs[lookup_map] >> fs[lookup_union] >> fs[lookup_map] >> fs[PULL_EXISTS] >> fs[lookup_num_set_tree_union] >> Cases_on `lookup n t1` >> fs[] >> Cases_on `lookup n t2` >> fs[] >> @@ -482,28 +524,30 @@ Theorem is_adjacent_wf_set_tree_num_set_tree_union EVERY_CASE_TAC >> fs[] >> qspecl_then [`t1`, `t2`] mp_tac domain_superdomain_num_set_tree_union >> rw[SUBSET_DEF, domain_lookup] -); +QED -Theorem is_reachable_wf_set_tree_num_set_tree_union - `∀ t1 t2 n m . +Theorem is_reachable_wf_set_tree_num_set_tree_union: + ∀ t1 t2 n m . is_reachable (mk_wf_set_tree t1) n m - ⇒ is_reachable (mk_wf_set_tree (num_set_tree_union t1 t2)) n m` - (simp[is_reachable_def] >> strip_tac >> strip_tac >> + ⇒ is_reachable (mk_wf_set_tree (num_set_tree_union t1 t2)) n m +Proof + simp[is_reachable_def] >> strip_tac >> strip_tac >> ho_match_mp_tac RTC_INDUCT_RIGHT1 >> rw[] >> simp[Once RTC_CASES2] >> disj2_tac >> qexists_tac `m` >> fs[] >> imp_res_tac is_adjacent_wf_set_tree_num_set_tree_union >> fs[] -); +QED (************************** DEFINITIONS ***************************) -Theorem v_size_map_snd - `∀ vvs . v3_size (MAP SND vvs) ≤ v1_size vvs` - (Induct >> rw[v_size_def] >> +Theorem v_size_map_snd: + ∀ vvs . v3_size (MAP SND vvs) ≤ v1_size vvs +Proof + Induct >> rw[v_size_def] >> Cases_on `v3_size (MAP SND vvs) = v1_size vvs` >> `v_size (SND h) ≤ v2_size h` by (Cases_on `h` >> rw[v_size_def]) >> rw[] -); +QED val find_v_globals_def = tDefine "find_v_globals" ` (find_v_globals (Conv _ vl) = (find_v_globalsL vl):num_set) ∧ @@ -527,73 +571,82 @@ val find_v_globals_def = tDefine "find_v_globals" ` val find_v_globals_ind = theorem "find_v_globals_ind"; -Theorem find_v_globalsL_APPEND - `∀ l1 l2 . find_v_globalsL (l1 ++ l2) = - union (find_v_globalsL l1) (find_v_globalsL l2)` - (Induct >> fs[find_v_globals_def] >> fs[union_assoc] -); - -Theorem find_v_globalsL_REVERSE - `∀ l . find_v_globalsL l = find_v_globalsL (REVERSE l)` - (Induct >> fs[find_v_globals_def] >> +Theorem find_v_globalsL_APPEND: + ∀ l1 l2 . find_v_globalsL (l1 ++ l2) = + union (find_v_globalsL l1) (find_v_globalsL l2) +Proof + Induct >> fs[find_v_globals_def] >> fs[union_assoc] +QED + +Theorem find_v_globalsL_REVERSE: + ∀ l . find_v_globalsL l = find_v_globalsL (REVERSE l) +Proof + Induct >> fs[find_v_globals_def] >> fs[find_v_globalsL_APPEND, union_num_set_sym, find_v_globals_def] -); +QED -Theorem find_v_globalsL_MEM - `∀ k v vs . MEM (k, v) vs - ⇒ domain (find_v_globals v) ⊆ domain (find_v_globalsL (MAP SND vs))` - (Induct_on `vs` >> rw[] >> fs[find_v_globals_def, domain_union] >> +Theorem find_v_globalsL_MEM: + ∀ k v vs . MEM (k, v) vs + ⇒ domain (find_v_globals v) ⊆ domain (find_v_globalsL (MAP SND vs)) +Proof + Induct_on `vs` >> rw[] >> fs[find_v_globals_def, domain_union] >> res_tac >> fs[SUBSET_DEF] -); +QED -Theorem find_v_globalsL_EL - `∀ n vs . n < LENGTH vs ⇒ - domain (find_v_globals (EL n vs)) ⊆ domain(find_v_globalsL vs)` - (Induct >> fs[EL] >> rw[] >> Cases_on `vs` >> +Theorem find_v_globalsL_EL: + ∀ n vs . n < LENGTH vs ⇒ + domain (find_v_globals (EL n vs)) ⊆ domain(find_v_globalsL vs) +Proof + Induct >> fs[EL] >> rw[] >> Cases_on `vs` >> fs[find_v_globals_def, domain_union] >> Cases_on `n = 0` >> fs[] >> fs[EXTENSION, SUBSET_DEF] -); +QED -Theorem find_v_globals_MAP_Recclosure - `∀ (funs:(tvarN,tvarN # flatLang$exp) alist) v l . +Theorem find_v_globals_MAP_Recclosure: + ∀ (funs:(tvarN,tvarN # flatLang$exp) alist) v l . domain (find_v_globalsL (MAP (λ (f,x,e). Recclosure v l f) funs)) ⊆ domain (find_v_globalsL (MAP SND v)) ∪ - domain (find_lookupsL (MAP (SND o SND) l))` - (Induct >> fs[find_v_globals_def] >> rw[domain_union] >> + domain (find_lookupsL (MAP (SND o SND) l)) +Proof + Induct >> fs[find_v_globals_def] >> rw[domain_union] >> PairCases_on `h` >> fs[find_v_globals_def, domain_union] -); +QED -Theorem find_v_globalsL_REPLICATE - `∀ n v vs . domain (find_v_globalsL (REPLICATE n v)) ⊆ - domain (find_v_globals v)` - (Induct >> fs[REPLICATE, find_v_globals_def, domain_union] -); +Theorem find_v_globalsL_REPLICATE: + ∀ n v vs . domain (find_v_globalsL (REPLICATE n v)) ⊆ + domain (find_v_globals v) +Proof + Induct >> fs[REPLICATE, find_v_globals_def, domain_union] +QED -Theorem find_v_globalsL_LUPDATE - `∀ n vs (reachable:num_set) v . n < LENGTH vs ∧ +Theorem find_v_globalsL_LUPDATE: + ∀ n vs (reachable:num_set) v . n < LENGTH vs ∧ domain (find_v_globalsL vs) ⊆ domain reachable ∧ domain (find_v_globals v) ⊆ domain reachable - ⇒ domain (find_v_globalsL (LUPDATE v n vs)) ⊆ domain reachable` - (Induct_on `vs` >> rw[] >> Cases_on `n` >> fs[LUPDATE_def] >> + ⇒ domain (find_v_globalsL (LUPDATE v n vs)) ⊆ domain reachable +Proof + Induct_on `vs` >> rw[] >> Cases_on `n` >> fs[LUPDATE_def] >> fs[find_v_globals_def, domain_union] -); +QED -Theorem find_v_globals_v_to_list - `∀ x reachable xs . +Theorem find_v_globals_v_to_list: + ∀ x reachable xs . domain (find_v_globals x) ⊆ domain reachable ∧ v_to_list x = SOME xs - ⇒ domain (find_v_globalsL xs) ⊆ domain reachable` - (recInduct v_to_list_ind >> + ⇒ domain (find_v_globalsL xs) ⊆ domain reachable +Proof + recInduct v_to_list_ind >> fs[v_to_list_def, find_v_globals_def, domain_union] >> rw[] >> Cases_on `v_to_list v2` >> fs[] >> rveq >> fs[find_v_globals_def, domain_union] >> metis_tac[] -); +QED -Theorem find_v_globals_list_to_v - `∀ xs reachable x . +Theorem find_v_globals_list_to_v: + ∀ xs reachable x . domain (find_v_globalsL xs) ⊆ domain reachable ∧ list_to_v xs = x - ⇒ domain (find_v_globals x) ⊆ domain reachable` - (Induct >> fs[list_to_v_def, find_v_globals_def, domain_union] -); + ⇒ domain (find_v_globals x) ⊆ domain reachable +Proof + Induct >> fs[list_to_v_def, find_v_globals_def, domain_union] +QED val find_refs_globals_def = Define ` (find_refs_globals (Refv a::t) = @@ -606,34 +659,36 @@ val find_refs_globals_def = Define ` val find_refs_globals_ind = theorem "find_refs_globals_ind"; -Theorem find_refs_globals_EL - `∀ n l . n < LENGTH l ⇒ +Theorem find_refs_globals_EL: + ∀ n l . n < LENGTH l ⇒ (∀ a . EL n l = Refv a ⇒ domain (find_v_globals a) ⊆ domain (find_refs_globals l)) ∧ (∀ vs . EL n l = Varray vs - ⇒ domain (find_v_globalsL vs) ⊆ domain (find_refs_globals l))` - (Induct >> rw[] + ⇒ domain (find_v_globalsL vs) ⊆ domain (find_refs_globals l)) +Proof + Induct >> rw[] >- (Cases_on `l` >> fs[find_refs_globals_def, domain_union]) >- (Cases_on `l` >> fs[find_refs_globals_def, domain_union]) >> fs[EL] >> first_x_assum (qspec_then `TL l` mp_tac) >> rw[] >> `n < LENGTH (TL l)` by fs[LENGTH_TL] >> fs[] >> Cases_on `l` >> fs[] >> Cases_on `h` >> fs[find_refs_globals_def, domain_union, SUBSET_DEF] -); +QED -Theorem find_refs_globals_MEM - `∀ refs reachable:num_set . +Theorem find_refs_globals_MEM: + ∀ refs reachable:num_set . domain (find_refs_globals refs) ⊆ domain reachable ⇒ (∀ a . MEM (Refv a) refs ⇒ domain (find_v_globals a) ⊆ domain reachable) ∧ (∀ vs . MEM (Varray vs) refs - ⇒ domain (find_v_globalsL vs) ⊆ domain reachable)` - (Induct >> rw[] >> fs[find_refs_globals_def, domain_union] >> + ⇒ domain (find_v_globalsL vs) ⊆ domain reachable) +Proof + Induct >> rw[] >> fs[find_refs_globals_def, domain_union] >> Cases_on `h` >> fs[find_refs_globals_def, domain_union] -); +QED -Theorem find_refs_globals_LUPDATE - `∀ reachable:num_set refs n . +Theorem find_refs_globals_LUPDATE: + ∀ reachable:num_set refs n . n < LENGTH refs ∧ domain (find_refs_globals refs) ⊆ domain reachable ⇒ (∀ a . domain (find_v_globals a) ⊆ domain reachable @@ -643,21 +698,22 @@ Theorem find_refs_globals_LUPDATE ⇒ domain (find_refs_globals (LUPDATE (Varray vs) n refs)) ⊆ domain reachable) ∧ (∀ ws. domain (find_refs_globals (LUPDATE (W8array ws) n refs)) - ⊆ domain reachable)` - (Induct_on `refs` >> rw[] >> Cases_on `h` >> + ⊆ domain reachable) +Proof + Induct_on `refs` >> rw[] >> Cases_on `h` >> fs[find_refs_globals_def, domain_union] >> Cases_on `n = 0` >> fs[LUPDATE_def, find_refs_globals_def, domain_union] >> fs[domain_union, LUPDATE_def] >> Cases_on `n` >> fs[] >> fs[LUPDATE_def, find_refs_globals_def, domain_union] -); +QED -Theorem find_refs_globals_APPEND - `∀ refs new . find_refs_globals (refs ++ new) = - union (find_refs_globals refs) (find_refs_globals new)` - (Induct >> rw[] >> fs[find_refs_globals_def] >> +Theorem find_refs_globals_APPEND: + ∀ refs new . find_refs_globals (refs ++ new) = + union (find_refs_globals refs) (find_refs_globals new) +Proof + Induct >> rw[] >> fs[find_refs_globals_def] >> Cases_on `h` >> fs[find_refs_globals_def] >> fs[union_assoc] - -); +QED val find_env_globals_def = Define ` find_env_globals env = find_v_globalsL (MAP SND env.v) @@ -693,12 +749,13 @@ val globals_rel_def = Define ` ⇒ domain (find_v_globals x) ⊆ domain reachable) ` -Theorem globals_rel_trans - `∀ reachable s1 s2 s3 . +Theorem globals_rel_trans: + ∀ reachable s1 s2 s3 . globals_rel reachable s1 s2 ∧ globals_rel reachable s2 s3 - ⇒ globals_rel reachable s1 s3` - (rw[globals_rel_def] -); + ⇒ globals_rel reachable s1 s3 +Proof + rw[globals_rel_def] +QED val decs_closed_def = Define ` decs_closed (reachable : num_set) decs ⇔ ∀ r t . analyse_code decs = (r,t) @@ -707,21 +764,23 @@ val decs_closed_def = Define ` ⇒ m ∈ domain reachable) ` -Theorem decs_closed_reduce - `∀ reachable h t . decs_closed reachable (h::t) ⇒ decs_closed reachable t` - (fs[decs_closed_def] >> rw[] >> Cases_on `h` >> fs[analyse_code_def] +Theorem decs_closed_reduce: + ∀ reachable h t . decs_closed reachable (h::t) ⇒ decs_closed reachable t +Proof + fs[decs_closed_def] >> rw[] >> Cases_on `h` >> fs[analyse_code_def] >- (Cases_on `analyse_exp e` >> fs[code_analysis_union_def, domain_union]) >- (Cases_on `analyse_exp e` >> fs[code_analysis_union_def, domain_union] >> first_x_assum drule >> rw[] >> pop_assum match_mp_tac >> assume_tac is_reachable_wf_set_tree_num_set_tree_union >> fs[] >> fs[Once num_set_tree_union_sym]) >> metis_tac[] -); +QED -Theorem decs_closed_reduce_HD - `∀ reachable h t . - decs_closed reachable (h::t) ⇒ decs_closed reachable [h]` - (fs[decs_closed_def] >> rw[] >> Cases_on `h` >> fs[analyse_code_def] >> +Theorem decs_closed_reduce_HD: + ∀ reachable h t . + decs_closed reachable (h::t) ⇒ decs_closed reachable [h] +Proof + fs[decs_closed_def] >> rw[] >> Cases_on `h` >> fs[analyse_code_def] >> Cases_on `analyse_exp e` >> fs[code_analysis_union_def, domain_union] >> rveq >> fs[domain_def] >- (Cases_on `analyse_code t` >> fs[code_analysis_union_def, domain_union]) @@ -734,7 +793,7 @@ Theorem decs_closed_reduce_HD imp_res_tac reachable_domain >> fs[domain_def]) >- (fs[EVAL ``mk_wf_set_tree LN``] >> imp_res_tac reachable_domain >> fs[domain_def]) -); +QED (* s = state, t = removed state *) val flat_state_rel_def = Define ` @@ -743,17 +802,18 @@ val flat_state_rel_def = Define ` domain (find_refs_globals s.refs) ⊆ domain reachable ` -Theorem flat_state_rel_trans - `∀ reachable s1 s2 s3 . flat_state_rel reachable s1 s2 ∧ +Theorem flat_state_rel_trans: + ∀ reachable s1 s2 s3 . flat_state_rel reachable s1 s2 ∧ flat_state_rel reachable s2 s3 - ⇒ flat_state_rel reachable s1 s3` - (rw[flat_state_rel_def, globals_rel_def] -); + ⇒ flat_state_rel reachable s1 s3 +Proof + rw[flat_state_rel_def, globals_rel_def] +QED (**************************** FLATLANG LEMMAS *****************************) -Theorem pmatch_Match_reachable - `(∀ env refs p v l a reachable:num_set . pmatch env refs p v l = Match a ∧ +Theorem pmatch_Match_reachable: + (∀ env refs p v l a reachable:num_set . pmatch env refs p v l = Match a ∧ domain (find_v_globalsL (MAP SND env.v)) ⊆ domain reachable ∧ domain (find_v_globals v) ⊆ domain reachable ∧ domain (find_v_globalsL (MAP SND l)) ⊆ domain reachable ∧ @@ -766,32 +826,36 @@ Theorem pmatch_Match_reachable domain (find_v_globalsL vs) ⊆ domain reachable ∧ domain (find_v_globalsL (MAP SND l)) ⊆ domain reachable ∧ domain (find_refs_globals refs) ⊆ domain reachable - ⇒ domain (find_v_globalsL (MAP SND a)) ⊆ domain reachable)` - (ho_match_mp_tac pmatch_ind >> rw[pmatch_def] >> + ⇒ domain (find_v_globalsL (MAP SND a)) ⊆ domain reachable) +Proof + ho_match_mp_tac pmatch_ind >> rw[pmatch_def] >> fs[find_v_globals_def, domain_union] >- (Cases_on `store_lookup lnum refs` >> fs[] >> Cases_on `x` >> fs[] >> fs[semanticPrimitivesTheory.store_lookup_def] >> first_x_assum (qspec_then `reachable` match_mp_tac) >> rw[] >> imp_res_tac find_refs_globals_EL >> metis_tac[SUBSET_TRANS]) >- (Cases_on `pmatch env refs p v l` >> fs[domain_union]) -); +QED -Theorem find_v_globals_list_to_v_APPEND - `∀ xs reachable ys . +Theorem find_v_globals_list_to_v_APPEND: + ∀ xs reachable ys . domain (find_v_globalsL xs) ⊆ domain reachable ∧ domain(find_v_globalsL ys) ⊆ domain reachable - ⇒ domain (find_v_globals (list_to_v (xs ++ ys))) ⊆ domain reachable` - (Induct >> fs[list_to_v_def, find_v_globals_def, domain_union] >> + ⇒ domain (find_v_globals (list_to_v (xs ++ ys))) ⊆ domain reachable +Proof + Induct >> fs[list_to_v_def, find_v_globals_def, domain_union] >> metis_tac[find_v_globals_list_to_v] -); +QED -Theorem find_v_globals_Unitv[simp] - `find_v_globals (Unitv cc) = LN` - (EVAL_TAC); +Theorem find_v_globals_Unitv[simp]: + find_v_globals (Unitv cc) = LN +Proof + EVAL_TAC +QED -Theorem do_app_SOME_flat_state_rel - `∀ reachable state removed_state op l new_state result new_removed_state. +Theorem do_app_SOME_flat_state_rel: + ∀ reachable state removed_state op l new_state result new_removed_state. flat_state_rel reachable state removed_state ∧ op ≠ Opapp ∧ domain(find_v_globalsL l) ⊆ domain reachable ∧ domain (find_lookups (App tra op [])) ⊆ domain reachable @@ -802,9 +866,9 @@ Theorem do_app_SOME_flat_state_rel do_app cc removed_state op l = SOME (new_removed_state, result) ∧ domain (find_sem_prim_res_globals (list_result result)) ⊆ - domain reachable` - - (rw[] >> qpat_x_assum `flat_state_rel _ _ _` mp_tac >> + domain reachable +Proof + rw[] >> qpat_x_assum `flat_state_rel _ _ _` mp_tac >> simp[Once flat_state_rel_def] >> strip_tac >> `∃ this_case . this_case op` by (qexists_tac `K T` >> simp[]) >> reverse (Cases_on `op`) >> fs[] @@ -878,14 +942,14 @@ Theorem do_app_SOME_flat_state_rel fs[find_refs_globals_APPEND, find_refs_globals_def, find_v_globals_def, domain_union] >> res_tac) >- (rw[] >> metis_tac[find_refs_globals_LUPDATE]) -); +QED (**************************** MAIN LEMMAS *****************************) -Theorem close_spt_thm - `∀ reachable seen tree closure (roots : num set) . +Theorem close_spt_thm: + ∀ reachable seen tree closure (roots : num set) . (wf reachable) ∧ (wf seen) ∧ (wf_set_tree tree) ∧ (close_spt reachable seen tree = closure) ∧ (subspt reachable seen) ∧ @@ -895,8 +959,9 @@ Theorem close_spt_thm ⇒ (∃ n . (n ∈ roots) ∧ (is_reachable tree n k))) ∧ (∀ k . k ∈ domain (reachable) ⇒ (∀ a . (is_adjacent tree k a) ⇒ a ∈ domain (seen))) - ⇒ (domain closure = {a | ∃ n . (is_reachable tree n a) ∧ (n ∈ roots)})` - (recInduct close_spt_ind >> rw[] >> + ⇒ (domain closure = {a | ∃ n . (is_reachable tree n a) ∧ (n ∈ roots)}) +Proof + recInduct close_spt_ind >> rw[] >> once_rewrite_tac [close_spt_def] >> simp[] >> fs[wf_set_tree_def] >> IF_CASES_TAC >- ( @@ -1001,7 +1066,7 @@ Theorem close_spt_thm qexists_tac `k` >> fs[] ) ) -); +QED val closure_spt_lemma = close_spt_thm |> Q.SPECL [`LN`, `start:num_set`, `tree`] @@ -1018,33 +1083,35 @@ val closure_spt_lemma = ] |> GEN_ALL ; -Theorem closure_spt_thm - `∀ tree start . wf start ∧ (wf_set_tree tree) ∧ +Theorem closure_spt_thm: + ∀ tree start . wf start ∧ (wf_set_tree tree) ∧ (domain start ⊆ domain tree) ⇒ domain (closure_spt start tree) = - {a | ∃ n . is_reachable tree n a ∧ n ∈ domain start}` - (rw[] >> assume_tac closure_spt_lemma >> rw[] >> fs[wf_set_tree_def] >> + {a | ∃ n . is_reachable tree n a ∧ n ∈ domain start} +Proof + rw[] >> assume_tac closure_spt_lemma >> rw[] >> fs[wf_set_tree_def] >> first_x_assum match_mp_tac >> reverse(rw[]) >> res_tac >> fs[SUBSET_DEF] >> qexists_tac `k` >> fs[] -); +QED -Theorem analysis_reachable_thm - `∀ (compiled : dec list) start tree t . +Theorem analysis_reachable_thm: + ∀ (compiled : dec list) start tree t . ((start, t) = analyse_code compiled) ∧ (tree = mk_wf_set_tree t) ⇒ domain (closure_spt start tree) = - {a | ∃ n . is_reachable tree n a ∧ n ∈ domain start}` - (rw[] >> qspecl_then [`mk_wf_set_tree t`, `start`] mp_tac closure_spt_thm >> + {a | ∃ n . is_reachable tree n a ∧ n ∈ domain start} +Proof + rw[] >> qspecl_then [`mk_wf_set_tree t`, `start`] mp_tac closure_spt_thm >> rw[] >> `wf_set_tree(mk_wf_set_tree t)` by metis_tac[mk_wf_set_tree_thm] >> qspecl_then [`compiled`, `start`, `t`] mp_tac analyse_code_thm >> qspec_then `t` mp_tac mk_wf_set_tree_domain >> rw[] >> metis_tac[SUBSET_TRANS] -); +QED (******** EVALUATE MUTUAL INDUCTION ********) -Theorem evaluate_sing_keep_flat_state_rel_eq_lemma - `(∀ env (state:'a flatSem$state) exprL new_state +Theorem evaluate_sing_keep_flat_state_rel_eq_lemma: + (∀ env (state:'a flatSem$state) exprL new_state result reachable:num_set removed_state . flatSem$evaluate env state exprL = (new_state, result) ∧ domain (find_lookupsL exprL) ⊆ domain reachable ∧ @@ -1070,8 +1137,9 @@ Theorem evaluate_sing_keep_flat_state_rel_eq_lemma evaluate_match env removed_state v patExp_list err_v = (new_removed_state, result) ∧ flat_state_rel reachable new_state new_removed_state ∧ - domain (find_sem_prim_res_globals result) ⊆ domain reachable)` - (ho_match_mp_tac evaluate_ind >> rpt CONJ_TAC >> rpt GEN_TAC >> strip_tac + domain (find_sem_prim_res_globals result) ⊆ domain reachable) +Proof + ho_match_mp_tac evaluate_ind >> rpt CONJ_TAC >> rpt GEN_TAC >> strip_tac (* EVALUATE CASES *) (* EMPTY LIST CASE *) >- (fs[evaluate_def] >> rveq >> @@ -1337,12 +1405,12 @@ Theorem evaluate_sing_keep_flat_state_rel_eq_lemma drule (CONJUNCT1 pmatch_Match_reachable) >> disch_then drule >> disch_then match_mp_tac >> fs[find_v_globals_def] >> rw[] >> fs[flat_state_rel_def]) -); +QED (******** EVALUATE SPECIALISATION ********) -Theorem evaluate_sing_keep_flat_state_rel_eq - `∀ env (state:'a flatSem$state) exprL new_state result expr +Theorem evaluate_sing_keep_flat_state_rel_eq: + ∀ env (state:'a flatSem$state) exprL new_state result expr reachable removed_state . flatSem$evaluate (env with v := []) state exprL = (new_state, result) ∧ exprL = [expr] ∧ @@ -1354,20 +1422,21 @@ Theorem evaluate_sing_keep_flat_state_rel_eq ⇒ ∃ new_removed_state . evaluate (env with v := []) removed_state exprL = (new_removed_state, result) ∧ - flat_state_rel reachable new_state new_removed_state` - (rpt gen_tac >> strip_tac >> fs[keep_def] >> rveq >> + flat_state_rel reachable new_state new_removed_state +Proof + rpt gen_tac >> strip_tac >> fs[keep_def] >> rveq >> drule (CONJUNCT1 evaluate_sing_keep_flat_state_rel_eq_lemma) >> fs[] >> strip_tac >> pop_assum (qspecl_then [`reachable`, `removed_state`] mp_tac) >> fs[] >> impl_tac >> fs[] >> simp[find_env_globals_def, find_v_globals_def, Once find_lookups_def] >> simp[EVAL ``find_lookupsL []``] >> rw[] >> fs[] -); +QED (******** EVALUATE_DEC ********) -Theorem evaluate_dec_flat_state_rel - `∀ env (state:'a flatSem$state) dec new_state new_ctors result +Theorem evaluate_dec_flat_state_rel: + ∀ env (state:'a flatSem$state) dec new_state new_ctors result reachable removed_state . evaluate_dec env state dec = (new_state, new_ctors, result) ∧ env.exh_pat ∧ @@ -1378,8 +1447,9 @@ Theorem evaluate_dec_flat_state_rel ⇒ ∃ new_removed_state . evaluate_dec env removed_state dec = (new_removed_state, new_ctors, result) ∧ - flat_state_rel reachable new_state new_removed_state` - (rw[] >> qpat_x_assum `evaluate_dec _ _ _ = _` mp_tac >> + flat_state_rel reachable new_state new_removed_state +Proof + rw[] >> qpat_x_assum `evaluate_dec _ _ _ = _` mp_tac >> reverse(Induct_on `dec`) >> fs[evaluate_dec_def] >> strip_tac >> strip_tac >> fs[keep_def] @@ -1422,7 +1492,7 @@ Theorem evaluate_dec_flat_state_rel qpat_x_assum `_ = (_,_,_) ` mp_tac >> fs[] >> EVERY_CASE_TAC >> fs[] >> rw[] >> fs[find_result_globals_def, find_sem_prim_res_globals_def] -); +QED @@ -1431,8 +1501,8 @@ Theorem evaluate_dec_flat_state_rel (******** EVALUATE MUTUAL INDUCTION ********) -Theorem evaluate_flat_state_rel_lemma - `(∀ env (state:'a flatSem$state) exprL new_state result +Theorem evaluate_flat_state_rel_lemma: + (∀ env (state:'a flatSem$state) exprL new_state result reachable removed_state . flatSem$evaluate env state exprL = (new_state, result) ∧ EVERY is_pure exprL ∧ @@ -1453,8 +1523,9 @@ Theorem evaluate_flat_state_rel_lemma flat_state_rel reachable state removed_state ∧ result ≠ Rerr (Rabort Rtype_error) ⇒ flat_state_rel reachable new_state removed_state ∧ - ∃ values : flatSem$v list . result = Rval values)` - (ho_match_mp_tac evaluate_ind >> rpt CONJ_TAC >> rpt GEN_TAC >> strip_tac + ∃ values : flatSem$v list . result = Rval values) +Proof + ho_match_mp_tac evaluate_ind >> rpt CONJ_TAC >> rpt GEN_TAC >> strip_tac (* EVALUATE_DECS_CASES *) >- ( (* EMPTY LIST CASE *) @@ -1722,13 +1793,13 @@ Theorem evaluate_flat_state_rel_lemma disch_then match_mp_tac >> fs[find_v_globals_def] >> rw[] >> metis_tac[] ) -); +QED (******** EVALUATE SPECIALISATION ********) -Theorem evaluate_sing_notKeep_flat_state_rel - `∀ env (state:'a flatSem$state) exprL new_state result expr +Theorem evaluate_sing_notKeep_flat_state_rel: + ∀ env (state:'a flatSem$state) exprL new_state result expr reachable removed_state . flatSem$evaluate (env with v := []) state exprL = (new_state, result) ∧ exprL = [expr] ∧ @@ -1737,19 +1808,20 @@ Theorem evaluate_sing_notKeep_flat_state_rel domain (find_env_globals env) ⊆ domain reachable ∧ result ≠ Rerr (Rabort Rtype_error) ⇒ flat_state_rel reachable new_state removed_state ∧ - ∃ value : flatSem$v . result = Rval [value]` - (rpt gen_tac >> strip_tac >> fs[keep_def] >> rveq >> + ∃ value : flatSem$v . result = Rval [value] +Proof + rpt gen_tac >> strip_tac >> fs[keep_def] >> rveq >> drule (CONJUNCT1 evaluate_flat_state_rel_lemma) >> fs[] >> disch_then drule >> disch_then drule >> fs[] >> rw[] >> imp_res_tac evaluate_sing >> fs[] >> fs[find_v_globals_def] -); +QED (******************************* MAIN PROOFS ******************************) -Theorem flat_decs_removal_lemma - `∀ env (state:'a flatSem$state) decs new_state new_ctors result +Theorem flat_decs_removal_lemma: + ∀ env (state:'a flatSem$state) decs new_state new_ctors result reachable removed_decs removed_state . evaluate_decs env state decs = (new_state, new_ctors, result) ∧ result ≠ SOME (Rabort Rtype_error) ∧ env.exh_pat ∧ @@ -1760,8 +1832,9 @@ Theorem flat_decs_removal_lemma ⇒ ∃ new_removed_state . new_removed_state.ffi = new_state.ffi /\ evaluate_decs env removed_state removed_decs = - (new_removed_state, new_ctors, result)` - (Induct_on `decs` + (new_removed_state, new_ctors, result) +Proof + Induct_on `decs` >- (rw[evaluate_decs_def, remove_unreachable_def] >> fs[evaluate_decs_def, find_result_globals_def, flat_state_rel_def]) >> fs[evaluate_decs_def, remove_unreachable_def] >> rw[] >> @@ -1798,10 +1871,10 @@ Theorem flat_decs_removal_lemma >> first_x_assum match_mp_tac >> fs[] >> asm_exists_tac >> fs[] >> imp_res_tac decs_closed_reduce >> fs[] >> drule evaluate_sing_notKeep_flat_state_rel >> fs[] -); +QED -Theorem flat_removal_thm - `∀ exh_pat check_ctor ffi k decs new_state new_ctors result roots tree +Theorem flat_removal_thm: + ∀ exh_pat check_ctor ffi k decs new_state new_ctors result roots tree reachable removed_decs . evaluate_decs (initial_env exh_pat check_ctor) (initial_state ffi k) decs = (new_state, new_ctors, result) ∧ @@ -1812,8 +1885,9 @@ Theorem flat_removal_thm ⇒ ∃ s . s.ffi = new_state.ffi /\ evaluate_decs (initial_env exh_pat check_ctor) (initial_state ffi k) - removed_decs = (s, new_ctors, result)` - (rpt strip_tac >> drule flat_decs_removal_lemma >> + removed_decs = (s, new_ctors, result) +Proof + rpt strip_tac >> drule flat_decs_removal_lemma >> rpt (disch_then drule) >> strip_tac >> pop_assum (qspecl_then [`reachable`, `removed_decs`, `initial_state ffi k`] mp_tac) >> fs[] >> @@ -1829,14 +1903,16 @@ Theorem flat_removal_thm >- (rw[SUBSET_DEF] >> qexists_tac `x` >> fs[is_reachable_def]) >- (qexists_tac `n'` >> fs[is_reachable_def] >> metis_tac[transitive_RTC, transitive_def])) -); +QED -Theorem flat_remove_eval_sim - `eval_sim ffi T T ds1 T T (remove_flat_prog ds1) - (\d1 d2. d2 = remove_flat_prog d1) F` - (rw [eval_sim_def] \\ qexists_tac `0` \\ fs [remove_flat_prog_def] +Theorem flat_remove_eval_sim: + eval_sim ffi T T ds1 T T (remove_flat_prog ds1) + (\d1 d2. d2 = remove_flat_prog d1) F +Proof + rw [eval_sim_def] \\ qexists_tac `0` \\ fs [remove_flat_prog_def] \\ pairarg_tac \\ fs [] - \\ drule flat_removal_thm \\ rw [] \\ fs []); + \\ drule flat_removal_thm \\ rw [] \\ fs [] +QED val flat_remove_semantics = save_thm ("flat_remove_semantics", MATCH_MP (REWRITE_RULE [GSYM AND_IMP_INTRO] IMP_semantics_eq) @@ -1861,32 +1937,40 @@ val elist_globals_filter_SUB_BAG = Q.prove ( elist_globals (MAP dest_Dlet (FILTER is_Dlet ds))`, Induct_on `ds` \\ rw [] \\ fs [SUB_BAG_UNION]); -Theorem remove_flat_prog_elist_globals_eq_empty - `elist_globals (MAP dest_Dlet (FILTER is_Dlet ds)) = {||} +Theorem remove_flat_prog_elist_globals_eq_empty: + elist_globals (MAP dest_Dlet (FILTER is_Dlet ds)) = {||} ==> - elist_globals (MAP dest_Dlet (FILTER is_Dlet (remove_flat_prog ds))) = {||}` - (simp [remove_flat_prog_def, remove_unreachable_def, UNCURRY] - \\ metis_tac [elist_globals_filter]); - -Theorem remove_flat_prog_esgc_free - `EVERY esgc_free (MAP dest_Dlet (FILTER is_Dlet ds)) + elist_globals (MAP dest_Dlet (FILTER is_Dlet (remove_flat_prog ds))) = {||} +Proof + simp [remove_flat_prog_def, remove_unreachable_def, UNCURRY] + \\ metis_tac [elist_globals_filter] +QED + +Theorem remove_flat_prog_esgc_free: + EVERY esgc_free (MAP dest_Dlet (FILTER is_Dlet ds)) ==> - EVERY esgc_free (MAP dest_Dlet (FILTER is_Dlet (remove_flat_prog ds)))` - (simp [remove_flat_prog_def, remove_unreachable_def, UNCURRY] - \\ metis_tac [esgc_free_filter]); - -Theorem remove_flat_prog_sub_bag - `elist_globals (MAP dest_Dlet (FILTER is_Dlet (remove_flat_prog ds))) <= - elist_globals (MAP dest_Dlet (FILTER is_Dlet ds))` - (simp [remove_flat_prog_def, remove_unreachable_def, UNCURRY] - \\ metis_tac [elist_globals_filter_SUB_BAG]); - -Theorem remove_flat_prog_distinct_globals - `BAG_ALL_DISTINCT (elist_globals (MAP dest_Dlet (FILTER is_Dlet ds))) + EVERY esgc_free (MAP dest_Dlet (FILTER is_Dlet (remove_flat_prog ds))) +Proof + simp [remove_flat_prog_def, remove_unreachable_def, UNCURRY] + \\ metis_tac [esgc_free_filter] +QED + +Theorem remove_flat_prog_sub_bag: + elist_globals (MAP dest_Dlet (FILTER is_Dlet (remove_flat_prog ds))) <= + elist_globals (MAP dest_Dlet (FILTER is_Dlet ds)) +Proof + simp [remove_flat_prog_def, remove_unreachable_def, UNCURRY] + \\ metis_tac [elist_globals_filter_SUB_BAG] +QED + +Theorem remove_flat_prog_distinct_globals: + BAG_ALL_DISTINCT (elist_globals (MAP dest_Dlet (FILTER is_Dlet ds))) ==> BAG_ALL_DISTINCT (elist_globals - (MAP dest_Dlet (FILTER is_Dlet (remove_flat_prog ds))))` - (metis_tac [remove_flat_prog_sub_bag, BAG_ALL_DISTINCT_SUB_BAG]); + (MAP dest_Dlet (FILTER is_Dlet (remove_flat_prog ds)))) +Proof + metis_tac [remove_flat_prog_sub_bag, BAG_ALL_DISTINCT_SUB_BAG] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/flat_exh_matchProofScript.sml b/compiler/backend/proofs/flat_exh_matchProofScript.sml index 3c570f7858..a4b836dfcf 100644 --- a/compiler/backend/proofs/flat_exh_matchProofScript.sml +++ b/compiler/backend/proofs/flat_exh_matchProofScript.sml @@ -27,11 +27,13 @@ Theorem compile_exps_CONS: Proof qid_spec_tac `x` \\ Induct_on `xs` \\ rw [compile_exps_def] QED -Theorem compile_exps_APPEND - `compile_exps exh (xs ++ ys) = compile_exps exh xs ++ compile_exps exh ys` - (map_every qid_spec_tac [`ys`,`xs`] \\ Induct \\ rw [compile_exps_def] +Theorem compile_exps_APPEND: + compile_exps exh (xs ++ ys) = compile_exps exh xs ++ compile_exps exh ys +Proof + map_every qid_spec_tac [`ys`,`xs`] \\ Induct \\ rw [compile_exps_def] \\ rw [Once compile_exps_CONS] - \\ rw [Once (GSYM compile_exps_CONS)]); + \\ rw [Once (GSYM compile_exps_CONS)] +QED Theorem compile_exps_REVERSE[simp]: REVERSE (compile_exps exh xs) = compile_exps exh (REVERSE xs) @@ -43,32 +45,38 @@ Proof \\ fs [LENGTH_EQ_NUM_compute] QED -Theorem compile_exps_MAP_FST - `MAP FST funs = - MAP FST (MAP (\(a,b,c). (a,b,HD (compile_exps ctors [c]))) funs)` - (Induct_on `funs` \\ rw [] - \\ PairCases_on `h` \\ fs []); +Theorem compile_exps_MAP_FST: + MAP FST funs = + MAP FST (MAP (\(a,b,c). (a,b,HD (compile_exps ctors [c]))) funs) +Proof + Induct_on `funs` \\ rw [] + \\ PairCases_on `h` \\ fs [] +QED -Theorem compile_exps_find_recfun - `!ls f exh. +Theorem compile_exps_find_recfun: + !ls f exh. find_recfun f (MAP (\(a,b,c). (a, b, HD (compile_exps exh [c]))) ls) = - OPTION_MAP (\(x,y). (x, HD (compile_exps exh [y]))) (find_recfun f ls)` - (Induct \\ rw [] + OPTION_MAP (\(x,y). (x, HD (compile_exps exh [y]))) (find_recfun f ls) +Proof + Induct \\ rw [] >- fs [semanticPrimitivesTheory.find_recfun_def] \\ simp [Once semanticPrimitivesTheory.find_recfun_def] \\ once_rewrite_tac [EQ_SYM_EQ] \\ simp [Once semanticPrimitivesTheory.find_recfun_def] - \\ every_case_tac \\ fs []) + \\ every_case_tac \\ fs [] +QED -Theorem exhaustive_SUBMAP - `!ps ctors ctors_pre. +Theorem exhaustive_SUBMAP: + !ps ctors ctors_pre. exhaustive_match ctors_pre ps /\ ctors_pre SUBMAP ctors ==> - exhaustive_match ctors ps` - (Induct \\ rw [exhaustive_match_def] \\ fs [] + exhaustive_match ctors ps +Proof + Induct \\ rw [exhaustive_match_def] \\ fs [] \\ every_case_tac \\ fs [is_unconditional_def] - \\ imp_res_tac FLOOKUP_SUBMAP \\ fs [] \\ rw []); + \\ imp_res_tac FLOOKUP_SUBMAP \\ fs [] \\ rw [] +QED (* ------------------------------------------------------------------------- *) (* Value relations *) @@ -118,8 +126,8 @@ val (v_rel_rules, v_rel_ind, v_rel_cases) = Hol_reln ` ==> nv_rel ctors ((n,v1)::vs1) ((n,v2)::vs2))` -Theorem v_rel_thms[simp] - `(v_rel ctors (Litv l) v <=> v = Litv l) /\ +Theorem v_rel_thms[simp]: + (v_rel ctors (Litv l) v <=> v = Litv l) /\ (v_rel ctors v (Litv l) <=> v = Litv l) /\ (v_rel ctors (Loc n) v <=> v = Loc n) /\ (v_rel ctors v (Loc n) <=> v = Loc n) /\ @@ -132,11 +140,13 @@ Theorem v_rel_thms[simp] (v_rel ctors (Vectorv x) v <=> ?y. v = Vectorv y /\ LIST_REL (v_rel ctors) x y) /\ (v_rel ctors v (Vectorv x) <=> - ?y. v = Vectorv y /\ LIST_REL (v_rel ctors) y x)` - (rw [] \\ Cases_on `v` \\ rw [Once v_rel_cases, EQ_SYM_EQ, ok_ctor_def] + ?y. v = Vectorv y /\ LIST_REL (v_rel ctors) y x) +Proof + rw [] \\ Cases_on `v` \\ rw [Once v_rel_cases, EQ_SYM_EQ, ok_ctor_def] \\ Cases_on `t` \\ Cases_on `o'` \\ fs [] \\ every_case_tac \\ fs [] - \\ metis_tac [SUBMAP_REFL, LIST_REL_EL_EQN, FLOOKUP_SUBMAP]); + \\ metis_tac [SUBMAP_REFL, LIST_REL_EL_EQN, FLOOKUP_SUBMAP] +QED Theorem v_rel_Boolv: init_ctors SUBMAP ctors ==> @@ -147,16 +157,21 @@ Proof \\ EVAL_TAC \\ rw [lookup_def] QED -Theorem nv_rel_LIST_REL - `!xs ys ctors. +Theorem nv_rel_LIST_REL: + !xs ys ctors. nv_rel ctors xs ys <=> - LIST_REL (\(n1, v1) (n2, v2). n1 = n2 /\ v_rel ctors v1 v2) xs ys` - (Induct \\ rw [Once (CONJUNCT2 v_rel_cases)] + LIST_REL (\(n1, v1) (n2, v2). n1 = n2 /\ v_rel ctors v1 v2) xs ys +Proof + Induct \\ rw [Once (CONJUNCT2 v_rel_cases)] \\ PairCases_on `h` \\ Cases_on `ys` \\ fs [] - \\ PairCases_on `h` \\ fs [] \\ metis_tac []); + \\ PairCases_on `h` \\ fs [] \\ metis_tac [] +QED -Theorem nv_rel_NIL[simp] - `nv_rel ctors [] []` (rw [Once v_rel_cases]); +Theorem nv_rel_NIL[simp]: + nv_rel ctors [] [] +Proof +rw [Once v_rel_cases] +QED val ctor_rel_def = Define ` ctor_rel ctors (c : ((ctor_id # type_id) # num) set) <=> @@ -198,8 +213,8 @@ val result_rel_def = Define ` e1 = e2) /\ (result_rel R ctors res1 res2 <=> F)` -Theorem result_rel_thms[simp] - `(!ctors v1 r. +Theorem result_rel_thms[simp]: + (!ctors v1 r. result_rel R ctors (Rval v1) r <=> ?v2. r = Rval v2 /\ R ctors v1 v2) /\ (!ctors v2 r. @@ -216,10 +231,12 @@ Theorem result_rel_thms[simp] (?v1 v2. err = Rraise v2 /\ r = Rerr (Rraise v1) /\ v_rel ctors v1 v2) \/ - (?a. err = Rabort a /\ r = Rerr (Rabort a)))` - (rpt conj_tac \\ ntac 2 gen_tac \\ Cases \\ rw [result_rel_def] + (?a. err = Rabort a /\ r = Rerr (Rabort a))) +Proof + rpt conj_tac \\ ntac 2 gen_tac \\ Cases \\ rw [result_rel_def] \\ Cases_on `e` \\ rw [result_rel_def] - \\ Cases_on `err` \\ fs [result_rel_def, EQ_SYM_EQ]); + \\ Cases_on `err` \\ fs [result_rel_def, EQ_SYM_EQ] +QED val match_rel_def = Define ` (match_rel ctors (Match env1) (Match env2) <=> nv_rel ctors env1 env2) /\ @@ -227,90 +244,106 @@ val match_rel_def = Define ` (match_rel ctors Match_type_error Match_type_error <=> T) /\ (match_rel ctors _ _ <=> F)` -Theorem match_rel_thms[simp] - `(match_rel ctors Match_type_error e <=> e = Match_type_error) /\ +Theorem match_rel_thms[simp]: + (match_rel ctors Match_type_error e <=> e = Match_type_error) /\ (match_rel ctors e Match_type_error <=> e = Match_type_error) /\ (match_rel ctors No_match e <=> e = No_match) /\ - (match_rel ctors e No_match <=> e = No_match)` - (Cases_on `e` \\ rw [match_rel_def]); + (match_rel ctors e No_match <=> e = No_match) +Proof + Cases_on `e` \\ rw [match_rel_def] +QED -Theorem v_rel_v_to_char_list - `!v1 v2 xs ctors. +Theorem v_rel_v_to_char_list: + !v1 v2 xs ctors. v_to_char_list v1 = SOME xs /\ v_rel ctors v1 v2 ==> - v_to_char_list v2 = SOME xs` - (ho_match_mp_tac v_to_char_list_ind \\ rw [] + v_to_char_list v2 = SOME xs +Proof + ho_match_mp_tac v_to_char_list_ind \\ rw [] \\ fs [v_to_char_list_def, case_eq_thms] - \\ rw [] \\ metis_tac []); + \\ rw [] \\ metis_tac [] +QED -Theorem v_rel_v_to_list - `!v1 v2 xs ctors. +Theorem v_rel_v_to_list: + !v1 v2 xs ctors. v_to_list v1 = SOME xs /\ v_rel ctors v1 v2 ==> ?ys. v_to_list v2 = SOME ys /\ - LIST_REL (v_rel ctors) xs ys` - (ho_match_mp_tac v_to_list_ind \\ rw [] + LIST_REL (v_rel ctors) xs ys +Proof + ho_match_mp_tac v_to_list_ind \\ rw [] \\ fs [v_to_list_def, case_eq_thms] \\ rw [] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem v_rel_vs_to_string - `!v1 v2 xs ctors. +Theorem v_rel_vs_to_string: + !v1 v2 xs ctors. vs_to_string v1 = SOME xs /\ LIST_REL (v_rel ctors) v1 v2 ==> - vs_to_string v2 = SOME xs` - (ho_match_mp_tac vs_to_string_ind \\ rw [] + vs_to_string v2 = SOME xs +Proof + ho_match_mp_tac vs_to_string_ind \\ rw [] \\ fs [vs_to_string_def, case_eq_thms] \\ rw [] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem v_rel_list_to_v_APPEND - `!xs1 xs2 ctors ys1 ys2. +Theorem v_rel_list_to_v_APPEND: + !xs1 xs2 ctors ys1 ys2. v_rel ctors (list_to_v xs1) (list_to_v xs2) /\ v_rel ctors (list_to_v ys1) (list_to_v ys2) ==> - v_rel ctors (list_to_v (xs1 ++ ys1)) (list_to_v (xs2 ++ ys2))` - (Induct \\ rw [] \\ fs [list_to_v_def] - \\ Cases_on `xs2` \\ fs [list_to_v_def, ok_ctor_def]); + v_rel ctors (list_to_v (xs1 ++ ys1)) (list_to_v (xs2 ++ ys2)) +Proof + Induct \\ rw [] \\ fs [list_to_v_def] + \\ Cases_on `xs2` \\ fs [list_to_v_def, ok_ctor_def] +QED -Theorem v_rel_list_to_v - `!v1 v2 xs ys ctors. +Theorem v_rel_list_to_v: + !v1 v2 xs ys ctors. v_to_list v1 = SOME xs /\ v_to_list v2 = SOME ys /\ v_rel ctors v1 v2 ==> - v_rel ctors (list_to_v xs) (list_to_v ys)` - (ho_match_mp_tac v_to_list_ind \\ rw [] + v_rel ctors (list_to_v xs) (list_to_v ys) +Proof + ho_match_mp_tac v_to_list_ind \\ rw [] \\ fs [v_to_list_def, case_eq_thms] \\ rw [] \\ fs [list_to_v_def, ok_ctor_def] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem v_rel_Unitv[simp] - `v_rel ctors (Unitv cc) (Unitv cc)` - (EVAL_TAC +Theorem v_rel_Unitv[simp]: + v_rel ctors (Unitv cc) (Unitv cc) +Proof + EVAL_TAC \\ rw[v_rel_cases] \\ EVAL_TAC - \\ rw[]); + \\ rw[] +QED -Theorem nv_rel_ALOOKUP_v_rel - `!xs ys ctors n x. +Theorem nv_rel_ALOOKUP_v_rel: + !xs ys ctors n x. nv_rel ctors xs ys /\ ALOOKUP xs n = SOME x ==> ?y. - ALOOKUP ys n = SOME y /\ v_rel ctors x y` - (Induct \\ rw [] + ALOOKUP ys n = SOME y /\ v_rel ctors x y +Proof + Induct \\ rw [] \\ qhdtm_x_assum `nv_rel` mp_tac \\ rw [Once (CONJUNCT2 v_rel_cases)] - \\ fs [ALOOKUP_def, bool_case_eq]); + \\ fs [ALOOKUP_def, bool_case_eq] +QED (* ------------------------------------------------------------------------- *) (* Various semantics preservation theorems *) (* ------------------------------------------------------------------------- *) -Theorem do_eq_thm - `(!v1 v2 r ctors v1' v2'. +Theorem do_eq_thm: + (!v1 v2 r ctors v1' v2'. do_eq v1 v2 = r /\ r <> Eq_type_error /\ v_rel ctors v1 v1' /\ @@ -323,16 +356,18 @@ Theorem do_eq_thm LIST_REL (v_rel ctors) vs1 vs1' /\ LIST_REL (v_rel ctors) vs2 vs2' ==> - do_eq_list vs1' vs2' = r)` - (ho_match_mp_tac do_eq_ind \\ rw [do_eq_def] \\ fs [] \\ rw [do_eq_def] + do_eq_list vs1' vs2' = r) +Proof + ho_match_mp_tac do_eq_ind \\ rw [do_eq_def] \\ fs [] \\ rw [do_eq_def] \\ TRY (metis_tac [LIST_REL_LENGTH]) \\ TRY (rpt (qhdtm_x_assum `v_rel` mp_tac \\ rw [Once v_rel_cases]) \\ rw [do_eq_def] \\ NO_TAC) - \\ every_case_tac \\ fs [] \\ res_tac \\ fs []); + \\ every_case_tac \\ fs [] \\ res_tac \\ fs [] +QED -Theorem pmatch_thm - `(!env refs p v vs r ctors refs1 v1 env1 vs1. +Theorem pmatch_thm: + (!env refs p v vs r ctors refs1 v1 env1 vs1. pmatch env refs p v vs = r /\ r <> Match_type_error /\ LIST_REL (sv_rel (v_rel ctors)) refs refs1 /\ @@ -353,8 +388,9 @@ Theorem pmatch_thm ==> ?r1. pmatch_list env1 refs1 ps v1 vs1 = r1 /\ - match_rel ctors r r1)` - (ho_match_mp_tac pmatch_ind \\ rw [pmatch_def] + match_rel ctors r r1) +Proof + ho_match_mp_tac pmatch_ind \\ rw [pmatch_def] \\ rw [match_rel_def, Once v_rel_cases] \\ fsrw_tac [DNF_ss] [] \\ rfs [] \\ rw [pmatch_def] \\ rfs [] \\ fs [] @@ -366,17 +402,19 @@ Theorem pmatch_thm \\ metis_tac [sv_rel_def]) \\ every_case_tac \\ fs [] \\ rfs [] \\ last_x_assum drule \\ rpt (disch_then drule) \\ rw [] \\ fs [] - \\ metis_tac [match_rel_def]); + \\ metis_tac [match_rel_def] +QED -Theorem do_opapp_thm - `do_opapp vs1 = SOME (nvs1, e) /\ +Theorem do_opapp_thm: + do_opapp vs1 = SOME (nvs1, e) /\ LIST_REL (v_rel ctors) vs1 vs2 ==> ?ctors_pre nvs2. nv_rel ctors nvs1 nvs2 /\ ctors_pre SUBMAP ctors /\ - do_opapp vs2 = SOME (nvs2, HD (compile_exps ctors_pre [e]))` - (simp [do_opapp_def, pair_case_eq, case_eq_thms, PULL_EXISTS] + do_opapp vs2 = SOME (nvs2, HD (compile_exps ctors_pre [e])) +Proof + simp [do_opapp_def, pair_case_eq, case_eq_thms, PULL_EXISTS] \\ rw [] \\ fs [PULL_EXISTS] \\ rw [] \\ fs [] \\ fs [Once v_rel_cases] \\ rw [] \\ fs [PULL_EXISTS] \\ TRY @@ -406,7 +444,8 @@ Theorem do_opapp_thm \\ TRY (conj_tac >- (simp [Once v_rel_cases, nv_rel_LIST_REL] \\ metis_tac [])) \\ match_mp_tac EVERY2_APPEND_suff \\ fs [EVERY2_MAP] \\ match_mp_tac EVERY2_refl \\ rw [UNCURRY] - \\ simp [Once v_rel_cases, nv_rel_LIST_REL] \\ metis_tac []); + \\ simp [Once v_rel_cases, nv_rel_LIST_REL] \\ metis_tac [] +QED val store_v_same_type_cases = Q.prove ( `(!v r. store_v_same_type (Refv v) r <=> ?v1. r = Refv v1) /\ @@ -417,8 +456,8 @@ val store_v_same_type_cases = Q.prove ( (!v r. store_v_same_type r (W8array v) <=> ?v1. r = W8array v1)`, rpt conj_tac \\ gen_tac \\ Cases \\ rw [store_v_same_type_def]); -Theorem do_app_thm - `do_app cc s1 op vs1 = SOME (t1, r1) /\ +Theorem do_app_thm: + do_app cc s1 op vs1 = SOME (t1, r1) /\ init_ctors SUBMAP ctors /\ state_rel ctors s1 s2 /\ LIST_REL (v_rel ctors) vs1 vs2 @@ -426,8 +465,9 @@ Theorem do_app_thm ?t2 r2. result_rel v_rel ctors r1 r2 /\ state_rel ctors t1 t2 /\ - do_app cc s2 op vs2 = SOME (t2, r2)` - (rpt strip_tac \\ qhdtm_x_assum `do_app` mp_tac + do_app cc s2 op vs2 = SOME (t2, r2) +Proof + rpt strip_tac \\ qhdtm_x_assum `do_app` mp_tac \\ Cases_on `op = Opb Lt \/ op = Opb Gt \/ op = Opb Leq \/ op = Opb Geq \/ op = Opn Plus \/ op = Opn Minus \/ op = Opn Times \/ op = Opn Divide \/ op = Opn Modulo` @@ -618,18 +658,20 @@ Theorem do_app_thm \\ fs [state_rel_def, LIST_REL_EL_EQN] \\ rw [] \\ fs [] \\ fs [OPTREL_def, EL_LUPDATE, EL_APPEND_EQN] \\ rw [] \\ fs [EL_REPLICATE] \\ first_x_assum (qspec_then `n` mp_tac) \\ rw [] \\ fs [] - \\ rw [ok_ctor_def]); + \\ rw [ok_ctor_def] +QED (* ------------------------------------------------------------------------- *) (* Compile expressions *) (* ------------------------------------------------------------------------- *) -Theorem is_unconditional_thm - `!p env refs v vs. +Theorem is_unconditional_thm: + !p env refs v vs. is_unconditional p ==> - pmatch env refs p v vs <> No_match` - (ho_match_mp_tac is_unconditional_ind \\ rw [] + pmatch env refs p v vs <> No_match +Proof + ho_match_mp_tac is_unconditional_ind \\ rw [] \\ pop_assum mp_tac \\ once_rewrite_tac [is_unconditional_def] \\ CASE_TAC \\ fs [pmatch_def] @@ -644,24 +686,27 @@ Theorem is_unconditional_thm \\ fsrw_tac [DNF_ss] [] \\ Cases_on `ls` \\ fs [pmatch_def] \\ CASE_TAC \\ fs [] - \\ res_tac \\ fs []); + \\ res_tac \\ fs [] +QED -Theorem is_unconditional_list_thm - `!vs1 vs2 a b c. +Theorem is_unconditional_list_thm: + !vs1 vs2 a b c. EVERY is_unconditional vs1 ==> - pmatch_list a b vs1 vs2 c <> No_match` - (Induct >- (Cases \\ rw [pmatch_def]) + pmatch_list a b vs1 vs2 c <> No_match +Proof + Induct >- (Cases \\ rw [pmatch_def]) \\ gen_tac \\ Cases \\ rw [pmatch_def] \\ every_case_tac \\ fs [] - \\ metis_tac [is_unconditional_thm]) + \\ metis_tac [is_unconditional_thm] +QED val exists_match_def = Define ` exists_match env refs ps v <=> !vs. ?p. MEM p ps /\ pmatch env refs p v vs <> No_match` -Theorem get_dty_tags_thm - `!pats tags res. +Theorem get_dty_tags_thm: + !pats tags res. get_dty_tags pats tags = SOME res ==> (!pat. @@ -682,8 +727,9 @@ Theorem get_dty_tags_thm ?ps' tyid'. MEM (Pcon (SOME (tag, SOME tyid')) ps') pats /\ EVERY is_unconditional ps' /\ - LENGTH ps' = arity))` - (Induct \\ simp [get_dty_tags_def] + LENGTH ps' = arity)) +Proof + Induct \\ simp [get_dty_tags_def] \\ Cases \\ fs [] \\ ntac 3 (PURE_TOP_CASE_TAC \\ fs []) \\ rpt gen_tac @@ -696,7 +742,8 @@ Theorem get_dty_tags_thm \\ first_x_assum (qspec_then `arity` mp_tac) \\ simp [lookup_insert] \\ rw [] \\ fs [SUBSET_DEF] \\ rw [] - \\ metis_tac []); + \\ metis_tac [] +QED val pmatch_Pcon_No_match = Q.prove( `env.check_ctor /\ @@ -713,14 +760,15 @@ val pmatch_Pcon_No_match = Q.prove( \\ rw [ctor_same_type_def, same_ctor_def] \\ fs [] \\ metis_tac [is_unconditional_list_thm]); -Theorem exhaustive_exists_match - `!ctors ps env. +Theorem exhaustive_exists_match: + !ctors ps env. exhaustive_match ctors ps /\ env.check_ctor /\ ctor_rel ctors env.c ==> - !refs v. ok_ctor ctors v ==> exists_match env refs ps v` - (rw [exhaustive_match_def, exists_match_def] + !refs v. ok_ctor ctors v ==> exists_match env refs ps v +Proof + rw [exhaustive_match_def, exists_match_def] >- (fs [EXISTS_MEM] \\ metis_tac [is_unconditional_thm]) \\ every_case_tac \\ fs [get_dty_tags_def, case_eq_thms] \\ rfs [lookup_map] \\ rveq @@ -744,14 +792,17 @@ Theorem exhaustive_exists_match \\ res_tac \\ fs [] \\ rw [] \\ res_tac \\ asm_exists_tac \\ rw [pmatch_def, same_ctor_def, ctor_same_type_def] - \\ metis_tac [EVERY_MEM, is_unconditional_list_thm]); + \\ metis_tac [EVERY_MEM, is_unconditional_list_thm] +QED -Theorem v_rel_ok_ctor - `v_rel ctors v1 v2 +Theorem v_rel_ok_ctor: + v_rel ctors v1 v2 ==> - ok_ctor ctors v1 /\ ok_ctor ctors v2` - (Cases_on `v1` \\ Cases_on `v2` \\ rw [ok_ctor_def] - \\ metis_tac [LIST_REL_LENGTH]); + ok_ctor ctors v1 /\ ok_ctor ctors v2 +Proof + Cases_on `v1` \\ Cases_on `v2` \\ rw [ok_ctor_def] + \\ metis_tac [LIST_REL_LENGTH] +QED val s1 = mk_var ("s1", ``flatSem$evaluate`` |> type_of |> strip_fun |> snd @@ -1008,16 +1059,18 @@ val dec_res_rel_def = Define ` result_rel (LIST_REL o v_rel) ctors (Rerr r1) (Rerr r2)) /\ (dec_res_rel _ _ _ <=> F)`; -Theorem dec_res_rel_thms[simp] - `(!ctors r. dec_res_rel ctors NONE r <=> r = NONE) /\ +Theorem dec_res_rel_thms[simp]: + (!ctors r. dec_res_rel ctors NONE r <=> r = NONE) /\ (!ctors r. dec_res_rel ctors r NONE <=> r = NONE) /\ (!ctors e r. dec_res_rel ctors (SOME e) r <=> ?e1. r = SOME e1 /\ result_rel (LIST_REL o v_rel) ctors (Rerr e) (Rerr e1)) /\ (!ctors e r. dec_res_rel ctors r (SOME e) <=> ?e1. r = SOME e1 /\ - result_rel (LIST_REL o v_rel) ctors (Rerr e1) (Rerr e))` - (rw [] \\ Cases_on `r` \\ rw [dec_res_rel_def]); + result_rel (LIST_REL o v_rel) ctors (Rerr e1) (Rerr e)) +Proof + rw [] \\ Cases_on `r` \\ rw [dec_res_rel_def] +QED val compile_exps_lemma = CONJUNCT1 compile_exps_evaluate @@ -1032,13 +1085,17 @@ val get_tdecs_def = Define ` MAP (\d. case d of Dtype t s => t) (FILTER (\d. ?t s. d = Dtype t s) xs)`; -Theorem get_tdecs_APPEND - `get_tdecs (xs ++ ys) = get_tdecs xs ++ get_tdecs ys` - (rw [get_tdecs_def, FILTER_APPEND]); +Theorem get_tdecs_APPEND: + get_tdecs (xs ++ ys) = get_tdecs xs ++ get_tdecs ys +Proof + rw [get_tdecs_def, FILTER_APPEND] +QED -Theorem get_tdecs_MEM - `MEM t (get_tdecs xs) <=> ?s. MEM (Dtype t s) xs` - (rw [get_tdecs_def, MEM_MAP, MEM_FILTER, PULL_EXISTS]); +Theorem get_tdecs_MEM: + MEM t (get_tdecs xs) <=> ?s. MEM (Dtype t s) xs +Proof + rw [get_tdecs_def, MEM_MAP, MEM_FILTER, PULL_EXISTS] +QED val is_new_type_def = Define ` is_new_type ctors decl <=> @@ -1066,8 +1123,8 @@ val compile_decs_SUBMAP = Q.prove ( \\ metis_tac []) \\ metis_tac [SUBMAP_TRANS]); -Theorem compile_dec_ctor_rel - `evaluate_dec env s d1 = (t, c1, r) /\ +Theorem compile_dec_ctor_rel: + evaluate_dec env s d1 = (t, c1, r) /\ r <> SOME (Rabort Rtype_error) /\ env.check_ctor /\ ctor_rel ctors_pre env.c /\ @@ -1075,8 +1132,9 @@ Theorem compile_dec_ctor_rel is_new_type ctors_pre d1 ==> ctors_pre SUBMAP ctors /\ - ctor_rel ctors (env.c UNION c1)` - (Cases_on `d1` \\ simp [evaluate_dec_def] + ctor_rel ctors (env.c UNION c1) +Proof + Cases_on `d1` \\ simp [evaluate_dec_def] >- (fs [compile_dec_def] \\ every_case_tac \\ fs [] \\ rw [] \\ fs []) >- (rw [compile_dec_def, is_fresh_type_def, FORALL_PROD, is_new_type_def] @@ -1085,7 +1143,8 @@ Theorem compile_dec_ctor_rel \\ eq_tac \\ rw [] \\ fs [] \\ `ty <> n` by metis_tac [flookup_thm] \\ fs [NOT_EQ_FAPPLY]) \\ every_case_tac \\ fs [] \\ rw [] \\ fs [] - \\ fs [compile_dec_def, is_fresh_exn_def, ctor_rel_def]); + \\ fs [compile_dec_def, is_fresh_exn_def, ctor_rel_def] +QED val env_updated_by_UNION = Q.prove ( `env with c updated_by $UNION c1 = env with c := env.c UNION c1 /\ @@ -1093,8 +1152,8 @@ val env_updated_by_UNION = Q.prove ( env with c := env.c UNION c1 UNION c2`, fs [environment_component_equality, AC UNION_COMM UNION_ASSOC]); -Theorem compile_dec_evaluate - `!d1 env1 s1 t1 c1 r1. +Theorem compile_dec_evaluate: + !d1 env1 s1 t1 c1 r1. evaluate_dec env1 s1 d1 = (t1, c1, r1) /\ r1 <> SOME (Rabort Rtype_error) ==> @@ -1111,8 +1170,9 @@ Theorem compile_dec_evaluate state_rel ctors_post t1 t2 /\ dec_res_rel ctors_post r1 r2 /\ evaluate_dec env2 s2 d2 = (t2, c2, r2) /\ - c1 = c2` - (Cases \\ rw [] + c1 = c2 +Proof + Cases \\ rw [] >- (* Dlet *) (`env_rel ctors (env1 with v := []) (env2 with v := [])` by (fs [env_rel_def] \\ metis_tac []) @@ -1142,10 +1202,11 @@ Theorem compile_dec_evaluate (* Dexn *) \\ fs [evaluate_dec_def, env_rel_def, is_fresh_exn_def, compile_dec_def] \\ every_case_tac \\ fs [] \\ rw [] \\ fs [ctor_rel_def, FORALL_PROD] - \\ metis_tac [SUBSET_DEF, SUBSET_UNION]); + \\ metis_tac [SUBSET_DEF, SUBSET_UNION] +QED -Theorem compile_decs_evaluate - `!ds1 env1 s1 t1 c1 r1. +Theorem compile_decs_evaluate: + !ds1 env1 s1 t1 c1 r1. evaluate_decs env1 s1 ds1 = (t1, c1, r1) /\ r1 <> SOME (Rabort Rtype_error) ==> @@ -1164,8 +1225,9 @@ Theorem compile_decs_evaluate state_rel ctors_post t1 t2 /\ dec_res_rel ctors_post r1 r2 /\ evaluate_decs env2 s2 ds2 = (t2, c2, r2) /\ - c1 = c2` - (Induct \\ rw [] + c1 = c2 +Proof + Induct \\ rw [] >- (fs [evaluate_decs_def, compile_decs_def, env_rel_def, get_tdecs_def, environment_component_equality] \\ rw [] @@ -1188,7 +1250,8 @@ Theorem compile_decs_evaluate \\ conj_tac >- metis_tac [SUBMAP_TRANS] \\ fs [env_updated_by_UNION, AC UNION_ASSOC UNION_COMM, evaluate_decs_def]) \\ fs [env_updated_by_UNION] \\ rw [] \\ fs [evaluate_decs_def] - \\ metis_tac [v_rel_SUBMAP, state_rel_SUBMAP, SUBMAP_TRANS, compile_decs_SUBMAP]); + \\ metis_tac [v_rel_SUBMAP, state_rel_SUBMAP, SUBMAP_TRANS, compile_decs_SUBMAP] +QED (* ------------------------------------------------------------------------- *) (* Top-level semantics theorem *) @@ -1199,15 +1262,16 @@ val ctor_rel_initial_ctor = Q.prove ( rw [ctor_rel_def, init_ctors_def, initial_env_def, flookup_fupdate_list] \\ rw [] \\ fs [lookup_insert] \\ every_case_tac \\ fs [lookup_def] \\ EVAL_TAC \\ rw []); -Theorem compile_decs_eval_sim - `EVERY (is_new_type init_ctors) ds1 /\ +Theorem compile_decs_eval_sim: + EVERY (is_new_type init_ctors) ds1 /\ ALL_DISTINCT (get_tdecs ds1) ==> eval_sim (ffi:'ffi ffi_state) F T ds1 T T (SND (compile ds1)) - (\p1 p2. p2 = SND (compile p1)) F` - (rw [eval_sim_def] \\ qexists_tac `0` \\ fs [] + (\p1 p2. p2 = SND (compile p1)) F +Proof + rw [eval_sim_def] \\ qexists_tac `0` \\ fs [] \\ Cases_on `compile ds1` \\ fs [compile_def] \\ `env_rel init_ctors (initial_env F T) (initial_env T T)` by (rw [env_rel_def, ctor_rel_initial_ctor] @@ -1217,7 +1281,8 @@ Theorem compile_decs_eval_sim by (EVAL_TAC \\ fs []) \\ drule compile_decs_evaluate \\ fs [] \\ rpt (disch_then drule) \\ rw [] - \\ fs [state_rel_def] \\ rw [dec_res_rel_def] \\ fs []); + \\ fs [state_rel_def] \\ rw [dec_res_rel_def] \\ fs [] +QED val compile_decs_semantics = save_thm ("compile_decs_semantics", MATCH_MP (REWRITE_RULE [GSYM AND_IMP_INTRO] IMP_semantics_eq) @@ -1235,12 +1300,13 @@ val compile_exps_sing = Q.prove ( \\ qspecl_then [`ctors`,`[e]`] mp_tac compile_exps_LENGTH \\ simp_tac(std_ss++listSimps.LIST_ss)[LENGTH_EQ_NUM_compute]); -Theorem compile_exps_elist_globals_eq_empty - `!ctors es. +Theorem compile_exps_elist_globals_eq_empty: + !ctors es. elist_globals es = {||} ==> - elist_globals (compile_exps ctors es) = {||}` - (ho_match_mp_tac compile_exps_ind + elist_globals (compile_exps ctors es) = {||} +Proof + ho_match_mp_tac compile_exps_ind \\ rw [compile_exps_def] \\ TRY (rename1 `HD (compile_exps ctors [e])` @@ -1268,19 +1334,23 @@ Theorem compile_exps_elist_globals_eq_empty \\ first_x_assum(fn th => mp_tac th \\ impl_tac >- METIS_TAC[]) \\ fsrw_tac [DNF_ss] [SUB_BAG_UNION] \\ rw [] \\ rename1 `compile_exps ctors [e]` - \\ Cases_on `compile_exps ctors [e]` \\ fs []); + \\ Cases_on `compile_exps ctors [e]` \\ fs [] +QED -Theorem compile_exps_set_globals_eq_empty - `set_globals e = {||} ==> set_globals (HD (compile_exps ctors [e])) = {||}` - (qspecl_then [`ctors`,`[e]`] mp_tac compile_exps_elist_globals_eq_empty - \\ rw[] \\ fs[] \\ Cases_on `compile_exps ctors [e]` \\ fs []); +Theorem compile_exps_set_globals_eq_empty: + set_globals e = {||} ==> set_globals (HD (compile_exps ctors [e])) = {||} +Proof + qspecl_then [`ctors`,`[e]`] mp_tac compile_exps_elist_globals_eq_empty + \\ rw[] \\ fs[] \\ Cases_on `compile_exps ctors [e]` \\ fs [] +QED -Theorem compile_exps_esgc_free - `!ctors es. +Theorem compile_exps_esgc_free: + !ctors es. EVERY esgc_free es ==> - EVERY esgc_free (compile_exps ctors es)` - (ho_match_mp_tac compile_exps_ind + EVERY esgc_free (compile_exps ctors es) +Proof + ho_match_mp_tac compile_exps_ind \\ rw [compile_exps_def] \\ fs [compile_exps_set_globals_eq_empty] \\ TRY @@ -1296,11 +1366,13 @@ Theorem compile_exps_esgc_free \\ fs [compile_exps_def] \\ rename1 `HD (compile_exps ctors [p])` \\ qspec_then `p` assume_tac compile_exps_sing \\ fs [] - \\ res_tac \\ fs []); + \\ res_tac \\ fs [] +QED -Theorem compile_exps_sub_bag - `!ctors es. elist_globals (compile_exps ctors es) ≤ elist_globals es` - (ho_match_mp_tac compile_exps_ind +Theorem compile_exps_sub_bag: + !ctors es. elist_globals (compile_exps ctors es) ≤ elist_globals es +Proof + ho_match_mp_tac compile_exps_ind \\ rw [compile_exps_def] \\ TRY (rename1 `HD (compile_exps ctors [x])` @@ -1328,62 +1400,73 @@ Theorem compile_exps_sub_bag \\ (impl_tac >- (rw [] \\ metis_tac [])) \\ rw [] \\ rename1 `HD (compile_exps ctors [p])` \\ qspec_then `p` assume_tac compile_exps_sing \\ fs [SUB_BAG_UNION] - \\ fsrw_tac [DNF_ss] [SUB_BAG_UNION] \\ rw []); + \\ fsrw_tac [DNF_ss] [SUB_BAG_UNION] \\ rw [] +QED -Theorem compile_exps_distinct_globals - `BAG_ALL_DISTINCT (elist_globals es) +Theorem compile_exps_distinct_globals: + BAG_ALL_DISTINCT (elist_globals es) ==> - BAG_ALL_DISTINCT (elist_globals (compile_exps ctors es))` - (metis_tac [compile_exps_sub_bag, BAG_ALL_DISTINCT_SUB_BAG]); + BAG_ALL_DISTINCT (elist_globals (compile_exps ctors es)) +Proof + metis_tac [compile_exps_sub_bag, BAG_ALL_DISTINCT_SUB_BAG] +QED (* ------------------------------------------------------------------------- *) (* Syntactic results for declarations *) (* ------------------------------------------------------------------------- *) -Theorem compile_decs_elist_globals_eq_empty - `!ds ctors. +Theorem compile_decs_elist_globals_eq_empty: + !ds ctors. elist_globals (MAP dest_Dlet (FILTER is_Dlet ds)) = {||} ==> elist_globals - (MAP dest_Dlet (FILTER is_Dlet (SND (compile_decs ctors ds)))) = {||}` - (Induct \\ rw [compile_decs_def] + (MAP dest_Dlet (FILTER is_Dlet (SND (compile_decs ctors ds)))) = {||} +Proof + Induct \\ rw [compile_decs_def] \\ fs [UNCURRY] \\ rw [] \\ Cases_on `h` \\ fs [compile_dec_def] \\ rw [compile_exp_def] - \\ metis_tac [compile_exps_set_globals_eq_empty]); + \\ metis_tac [compile_exps_set_globals_eq_empty] +QED -Theorem compile_decs_esgc_free - `!ds ctors. +Theorem compile_decs_esgc_free: + !ds ctors. EVERY esgc_free (MAP dest_Dlet (FILTER is_Dlet ds)) ==> EVERY esgc_free (MAP dest_Dlet - (FILTER is_Dlet (SND (compile_decs ctors ds))))` - (Induct \\ rw [compile_decs_def] + (FILTER is_Dlet (SND (compile_decs ctors ds)))) +Proof + Induct \\ rw [compile_decs_def] \\ fs [UNCURRY] \\ rw [] \\ Cases_on `h` \\ fs [compile_dec_def, compile_exp_def] \\ qspec_then `e` assume_tac compile_exps_sing \\ fs [] - \\ metis_tac [compile_exps_esgc_free, EVERY_DEF]); + \\ metis_tac [compile_exps_esgc_free, EVERY_DEF] +QED -Theorem compile_decs_sub_bag - `!ds ctors. +Theorem compile_decs_sub_bag: + !ds ctors. elist_globals (MAP dest_Dlet (FILTER is_Dlet (SND (compile_decs ctors ds)))) ≤ - elist_globals (MAP dest_Dlet (FILTER is_Dlet ds))` - (Induct \\ rw [compile_decs_def] + elist_globals (MAP dest_Dlet (FILTER is_Dlet ds)) +Proof + Induct \\ rw [compile_decs_def] \\ fs [UNCURRY] \\ rw [] \\ Cases_on `h` \\ fs [compile_dec_def, compile_exp_def] \\ qspec_then `e` assume_tac compile_exps_sing \\ fs [] \\ last_x_assum (qspec_then `ctors` assume_tac) \\ `elist_globals [e2] <= elist_globals [e]` by metis_tac [compile_exps_sub_bag] - \\ fs [SUB_BAG_UNION]); + \\ fs [SUB_BAG_UNION] +QED -Theorem compile_exps_distinct_globals - `BAG_ALL_DISTINCT (elist_globals (MAP dest_Dlet (FILTER is_Dlet ds))) +Theorem compile_exps_distinct_globals: + BAG_ALL_DISTINCT (elist_globals (MAP dest_Dlet (FILTER is_Dlet ds))) ==> BAG_ALL_DISTINCT (elist_globals - (MAP dest_Dlet (FILTER is_Dlet (SND (compile_decs ctors ds)))))` - (metis_tac [compile_decs_sub_bag, BAG_ALL_DISTINCT_SUB_BAG]); + (MAP dest_Dlet (FILTER is_Dlet (SND (compile_decs ctors ds))))) +Proof + metis_tac [compile_decs_sub_bag, BAG_ALL_DISTINCT_SUB_BAG] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/flat_reorder_matchProofScript.sml b/compiler/backend/proofs/flat_reorder_matchProofScript.sml index 4eb0ef97b2..5e8d342ee6 100644 --- a/compiler/backend/proofs/flat_reorder_matchProofScript.sml +++ b/compiler/backend/proofs/flat_reorder_matchProofScript.sml @@ -9,21 +9,27 @@ val grammar_ancestry = ["flat_reorder_match", "flatSem", "flatProps", "misc", "ffi"]; val _ = set_grammar_ancestry grammar_ancestry; -Theorem list_result_map_result - `list_result (map_result f g r) = map_result (MAP f) g (list_result r)` - (Cases_on`r` \\ EVAL_TAC); - -Theorem MAP_FST_MAP_triple - `! a b c y l. (MAP FST (MAP (\(a,b,c). a, b, (y c)) l)) = (MAP FST l)` - (Induct_on `l` \\ fs [] \\ rw [] - \\ pairarg_tac \\ fs []) - -Theorem ALOOKUP_MAP3 - `ALOOKUP (MAP (λ(a,b,c). (a,b, f c)) ls) = - OPTION_MAP (λ(b,c). (b, f c)) o (ALOOKUP ls)` - (qmatch_goalsub_abbrev_tac`OPTION_MAP g o _` +Theorem list_result_map_result: + list_result (map_result f g r) = map_result (MAP f) g (list_result r) +Proof + Cases_on`r` \\ EVAL_TAC +QED + +Theorem MAP_FST_MAP_triple: + ! a b c y l. (MAP FST (MAP (\(a,b,c). a, b, (y c)) l)) = (MAP FST l) +Proof + Induct_on `l` \\ fs [] \\ rw [] + \\ pairarg_tac \\ fs [] +QED + +Theorem ALOOKUP_MAP3: + ALOOKUP (MAP (λ(a,b,c). (a,b, f c)) ls) = + OPTION_MAP (λ(b,c). (b, f c)) o (ALOOKUP ls) +Proof + qmatch_goalsub_abbrev_tac`OPTION_MAP g o _` \\ Q.ISPECL_THEN[`g`,`ls`](mp_tac o GSYM) ALOOKUP_MAP - \\ simp[Abbr`g`,LAMBDA_PROD]); + \\ simp[Abbr`g`,LAMBDA_PROD] +QED val _ = temp_overload_on ("None",``NONE``) val _ = temp_overload_on ("Some",``SOME``) @@ -34,17 +40,23 @@ val BAG_OF_LIST_def = Define` (BAG_OF_LIST (x::xs) = BAG_INSERT x (BAG_OF_LIST xs))`; val _ = export_rewrites["BAG_OF_LIST_def"]; -Theorem BAG_OF_LIST_empty[simp] - `(BAG_OF_LIST l = {||} ⇔ (l = []))` - (Cases_on`l` \\ rw[]); +Theorem BAG_OF_LIST_empty[simp]: + (BAG_OF_LIST l = {||} ⇔ (l = [])) +Proof + Cases_on`l` \\ rw[] +QED -Theorem BAG_INSERT_BAG_UNION - `BAG_INSERT x (BAG_UNION b1 b2) = BAG_UNION (BAG_INSERT x b1) b2` - (rw[BAG_INSERT_UNION,ASSOC_BAG_UNION]); +Theorem BAG_INSERT_BAG_UNION: + BAG_INSERT x (BAG_UNION b1 b2) = BAG_UNION (BAG_INSERT x b1) b2 +Proof + rw[BAG_INSERT_UNION,ASSOC_BAG_UNION] +QED -Theorem BAG_OF_LIST_APPEND - `∀l1 l2. BAG_OF_LIST (l1 ++ l2) = BAG_UNION (BAG_OF_LIST l1) (BAG_OF_LIST l2)` - (Induct \\ simp[BAG_INSERT_BAG_UNION]); +Theorem BAG_OF_LIST_APPEND: + ∀l1 l2. BAG_OF_LIST (l1 ++ l2) = BAG_UNION (BAG_OF_LIST l1) (BAG_OF_LIST l2) +Proof + Induct \\ simp[BAG_INSERT_BAG_UNION] +QED (* -- *) @@ -52,13 +64,17 @@ val s = ``s:'ffi flatSem$state``; (* value transformation *) -Theorem MEM_size_mono - `!a b. (MEM a b) ==> ((v_size a) < 1 + v3_size b)` - (Induct_on `b` \\ rw [v_size_def] \\ res_tac \\ rw []) +Theorem MEM_size_mono: + !a b. (MEM a b) ==> ((v_size a) < 1 + v3_size b) +Proof + Induct_on `b` \\ rw [v_size_def] \\ res_tac \\ rw [] +QED -Theorem MEM_size_mono_v1_size - `! a v env. MEM (a,v) env ==> v_size v < 1 + v1_size env` - (Induct_on `env` \\ rw[] \\ rw [v_size_def] \\ res_tac \\ rw []) +Theorem MEM_size_mono_v1_size: + ! a v env. MEM (a,v) env ==> v_size v < 1 + v1_size env +Proof + Induct_on `env` \\ rw[] \\ rw [v_size_def] \\ res_tac \\ rw [] +QED val compile_v_def = tDefine "compile_v" ` (compile_v (Litv l) = Litv l) /\ @@ -79,13 +95,15 @@ val _ = export_rewrites ["compile_v_def"]; val _ = overload_on ("compile_env", ``MAP \(tn, v). (tn, compile_v v)``); -Theorem ALOOKUP_compile_env - `! env q x. - (ALOOKUP (compile_env env) q) = OPTION_MAP compile_v (ALOOKUP env q)` - (Induct \\ rw [] +Theorem ALOOKUP_compile_env: + ! env q x. + (ALOOKUP (compile_env env) q) = OPTION_MAP compile_v (ALOOKUP env q) +Proof + Induct \\ rw [] \\ pairarg_tac \\ fs [] - \\ rw []) + \\ rw [] +QED val compile_store_v_def = Define ` (compile_store_v (Refv v) = Refv (compile_v v)) /\ @@ -100,13 +118,17 @@ val compile_state_def = Define ` globals := MAP (OPTION_MAP compile_v) s.globals |>`; -Theorem dec_clock_compile_state - `dec_clock (compile_state s) = compile_state (dec_clock s)` - (EVAL_TAC); +Theorem dec_clock_compile_state: + dec_clock (compile_state s) = compile_state (dec_clock s) +Proof + EVAL_TAC +QED -Theorem compile_state_with_clock - `compile_state st with clock := k = compile_state (st with clock := k)` - (EVAL_TAC); +Theorem compile_state_with_clock: + compile_state st with clock := k = compile_state (st with clock := k) +Proof + EVAL_TAC +QED val compile_state_simps = save_thm ("compile_state_simps", LIST_CONJ [EVAL ``(compile_state s).globals``, @@ -118,46 +140,62 @@ val _ = export_rewrites ["compile_state_simps"]; (* syntactic properties of the compiler *) -Theorem isPcon_isPvar - `∀x. isPcon x ==> ¬isPvar x` - (Cases \\ rw[isPcon_def,isPvar_def]); - -Theorem is_const_con_thm - `is_const_con x ⇔ ∃t. x = Pcon (SOME t) []` - (Cases_on`x` \\ EVAL_TAC \\ rw[] - \\ rename1`Pcon t l` \\ Cases_on`t` \\ EVAL_TAC \\ rw[]); - -Theorem is_Pcon_thm - `isPcon x ⇔ ∃t l. x = Pcon (SOME t) l` - (Cases_on`x` \\ EVAL_TAC \\ rw[] - \\ rename1`Pcon t l` \\ Cases_on`t` \\ EVAL_TAC \\ rw[EXISTS_THM]); - -Theorem is_const_con_is_Pcon - `is_const_con x ==> isPcon x` - (rw[is_const_con_thm,is_Pcon_thm]); - -Theorem same_con_is_const_con - `same_con x y ⇒ is_const_con x ∧ is_const_con y` - (Cases_on`x` \\ Cases_on`y` \\ simp[] +Theorem isPcon_isPvar: + ∀x. isPcon x ==> ¬isPvar x +Proof + Cases \\ rw[isPcon_def,isPvar_def] +QED + +Theorem is_const_con_thm: + is_const_con x ⇔ ∃t. x = Pcon (SOME t) [] +Proof + Cases_on`x` \\ EVAL_TAC \\ rw[] + \\ rename1`Pcon t l` \\ Cases_on`t` \\ EVAL_TAC \\ rw[] +QED + +Theorem is_Pcon_thm: + isPcon x ⇔ ∃t l. x = Pcon (SOME t) l +Proof + Cases_on`x` \\ EVAL_TAC \\ rw[] + \\ rename1`Pcon t l` \\ Cases_on`t` \\ EVAL_TAC \\ rw[EXISTS_THM] +QED + +Theorem is_const_con_is_Pcon: + is_const_con x ==> isPcon x +Proof + rw[is_const_con_thm,is_Pcon_thm] +QED + +Theorem same_con_is_const_con: + same_con x y ⇒ is_const_con x ∧ is_const_con y +Proof + Cases_on`x` \\ Cases_on`y` \\ simp[] \\ rename1`same_con (Pcon o1 _) (Pcon o2 _)` \\ Cases_on`o1` \\ Cases_on`o2` \\ simp[] - \\ Cases_on`l` \\ Cases_on`l'` \\ simp[]); - -Theorem is_const_con_pat_bindings_empty - `is_const_con x ==> pat_bindings x a = a` - (rw [is_const_con_thm] \\ EVAL_TAC) - -Theorem compile_append - `! x h. compile (x ++ h) = (compile x) ++ (compile h)` - (Induct_on `x` \\ fs [] \\ rw [Once compile_cons] + \\ Cases_on`l` \\ Cases_on`l'` \\ simp[] +QED + +Theorem is_const_con_pat_bindings_empty: + is_const_con x ==> pat_bindings x a = a +Proof + rw [is_const_con_thm] \\ EVAL_TAC +QED + +Theorem compile_append: + ! x h. compile (x ++ h) = (compile x) ++ (compile h) +Proof + Induct_on `x` \\ fs [] \\ rw [Once compile_cons] \\ qspec_then `h` strip_assume_tac compile_sing \\ fs [] - \\ rw [Once compile_cons]) + \\ rw [Once compile_cons] +QED -Theorem compile_reverse - `! x. REVERSE (compile x) = compile (REVERSE x)` - (Induct \\ fs [] \\ rw [Once compile_cons] +Theorem compile_reverse: + ! x. REVERSE (compile x) = compile (REVERSE x) +Proof + Induct \\ fs [] \\ rw [Once compile_cons] \\ qspec_then `h` strip_assume_tac compile_sing \\ fs [] - \\ rw [EQ_SYM_EQ, REVERSE_DEF, compile_append]); + \\ rw [EQ_SYM_EQ, REVERSE_DEF, compile_append] +QED (* alternative characterisation of pattern matching *) @@ -171,35 +209,40 @@ val find_match_def = Define` | _ => find_match env s v pes else Match_type_error ` -Theorem evaluate_match_find_match_none - `env.exh_pat ∧ (!r. find_match env ^s.refs v pes ≠ Match r) ==> - evaluate_match env s v pes errv = (s, Rerr (Rabort Rtype_error))` - (Induct_on `pes` +Theorem evaluate_match_find_match_none: + env.exh_pat ∧ (!r. find_match env ^s.refs v pes ≠ Match r) ==> + evaluate_match env s v pes errv = (s, Rerr (Rabort Rtype_error)) +Proof + Induct_on `pes` \\ fs [find_match_def, evaluate_def] \\ Cases \\ fs [evaluate_def] \\ IF_CASES_TAC \\ fs[] \\ TOP_CASE_TAC - \\ rw []) + \\ rw [] +QED -Theorem evaluate_match_find_match_some - ` find_match env s.refs v pes = Match (env',e) ==> - evaluate_match env s v pes errv = evaluate (env with v := env' ++ env.v) s [e] ` - (Induct_on `pes` +Theorem evaluate_match_find_match_some: + find_match env s.refs v pes = Match (env',e) ==> + evaluate_match env s v pes errv = evaluate (env with v := env' ++ env.v) s [e] +Proof + Induct_on `pes` \\ fs [find_match_def,evaluate_def] \\ Cases \\ fs [evaluate_def] \\ TOP_CASE_TAC \\ CASE_TAC - \\ rw[]) + \\ rw[] +QED (* reordering operations are allowed *) -Theorem pmatch_same_match - `pmatch env refs c1 v [] = Match a /\ is_const_con c1 /\ +Theorem pmatch_same_match: + pmatch env refs c1 v [] = Match a /\ is_const_con c1 /\ pmatch env refs c2 v [] = Match b /\ ~isPvar c2 - ==> same_con c1 c2` - (rw[is_const_con_thm] + ==> same_con c1 c2 +Proof + rw[is_const_con_thm] \\ Cases_on`v` \\ fs[pmatch_def] \\ rename1`Conv o1` \\ Cases_on`o1` \\ fs[pmatch_def] \\ Cases_on`c2` \\ fs[pmatch_def] @@ -208,22 +251,26 @@ Theorem pmatch_same_match \\ fs[bool_case_eq,same_ctor_def] \\ rw[] \\ rfs[pmatch_def] \\ fs[FST_EQ_EQUIV] \\ rw[] \\ pop_assum mp_tac \\ rw[] \\ fs[] - \\ Cases_on`x` \\ fs[]); + \\ Cases_on`x` \\ fs[] +QED -Theorem pmatch_match_match - `¬env.check_ctor ∧ +Theorem pmatch_match_match: + ¬env.check_ctor ∧ is_const_con x /\ isPcon y /\ pmatch env refs x v [] = Match_type_error ==> - pmatch env refs y v [] = Match_type_error` - (rw[is_const_con_thm,is_Pcon_thm] + pmatch env refs y v [] = Match_type_error +Proof + rw[is_const_con_thm,is_Pcon_thm] \\ Cases_on`v` \\ fs[pmatch_def] \\ rename1`Conv tt _` \\ Cases_on`tt` \\ fs[pmatch_def,semanticPrimitivesTheory.same_ctor_def] - \\ pop_assum mp_tac \\ simp[bool_case_eq]); - -Theorem pmatch_no_match - `¬env.check_ctor ∧ pmatch env refs x v [] = No_match ∧ same_con y x ⇒ - pmatch env refs y v [] = No_match` - (Cases_on`x` \\ Cases_on`y` \\ fs[pmatch_def] + \\ pop_assum mp_tac \\ simp[bool_case_eq] +QED + +Theorem pmatch_no_match: + ¬env.check_ctor ∧ pmatch env refs x v [] = No_match ∧ same_con y x ⇒ + pmatch env refs y v [] = No_match +Proof + Cases_on`x` \\ Cases_on`y` \\ fs[pmatch_def] \\ rename1`same_con (Pcon o1 _) (Pcon o2 _)` \\ Cases_on`o1` \\ Cases_on`o2` \\ fs[pmatch_def] \\ Cases_on`l` \\ Cases_on`l'` \\ fs[pmatch_def] @@ -232,35 +279,39 @@ Theorem pmatch_no_match \\ Cases_on`o'` \\ fs[pmatch_def] \\ Cases_on`x` \\ rw[] \\ fs[same_ctor_def,ctor_same_type_def] - \\ rw[] \\ rfs[]); - -Theorem find_match_drop_no_match - `! a b. pmatch env s (FST b) v [] = No_match /\ (is_const_con (FST b)) ==> - ((find_match env s v ( a++ [b] ++c)) = find_match env s v (a++c))` - (Induct + \\ rw[] \\ rfs[] +QED + +Theorem find_match_drop_no_match: + ! a b. pmatch env s (FST b) v [] = No_match /\ (is_const_con (FST b)) ==> + ((find_match env s v ( a++ [b] ++c)) = find_match env s v (a++c)) +Proof + Induct \\ rw [find_match_def, is_const_con_pat_bindings_empty] -) +QED -Theorem find_match_may_drop_dup - `¬env.check_ctor ⇒ +Theorem find_match_may_drop_dup: + ¬env.check_ctor ⇒ ! a b. ((is_const_con (FST b)) /\ (EXISTS (same_con (FST b) o FST) a)) ==> - ((find_match env s v ( a++ [b] ++c)) = find_match env s v (a++c))` - (strip_tac \\ Induct + ((find_match env s v ( a++ [b] ++c)) = find_match env s v (a++c)) +Proof + strip_tac \\ Induct \\ rw [find_match_def] \\ CASE_TAC \\ fs[] \\ match_mp_tac find_match_drop_no_match \\ fs[] \\ match_mp_tac (GEN_ALL pmatch_no_match) \\ fs[] \\ asm_exists_tac \\ fs[] -); +QED -Theorem find_match_may_reord - `¬env.check_ctor ⇒ +Theorem find_match_may_reord: + ¬env.check_ctor ⇒ ! a b. is_const_con (FST b) /\ ¬(EXISTS (same_con (FST b) o FST) a) /\ EVERY isPcon (MAP FST a) /\ find_match env s v (a ++ [b] ++ c) ≠ Match_type_error ==> - find_match env s v (a ++ [b] ++ c) = find_match env s v (b::a++c) ` - (strip_tac \\ + find_match env s v (a ++ [b] ++ c) = find_match env s v (b::a++c) +Proof + strip_tac \\ Induct \\ fs [] \\ rw [find_match_def] \\ every_case_tac \\ fs [find_match_def] @@ -275,17 +326,18 @@ Theorem find_match_may_reord \\ fs[EVERY_MEM]) >- ( CCONTR_TAC \\ fs[] - \\ fs[is_const_con_pat_bindings_empty] )) + \\ fs[is_const_con_pat_bindings_empty] ) +QED -Theorem find_match_drop_after_pvar - `! a. isPvar (FST b) ==> +Theorem find_match_drop_after_pvar: + ! a. isPvar (FST b) ==> find_match env refs v (a ++ [b] ++ c) = find_match env refs v (a ++ [b]) - ` - (Induct \\ fs [find_match_def] +Proof + Induct \\ fs [find_match_def] \\ rw [] \\ CASE_TAC \\ Cases_on `FST b` \\ fs [pmatch_def, isPvar_def] - ) +QED (* characterisation of reordering operations as rules *) @@ -299,15 +351,16 @@ val (reord_rules,reord_ind,reord_cases) = Hol_reln` EVERY isPcon (MAP FST a) ==> reord (a ++ [b] ++ c) ([b] ++ a ++ c))`; -Theorem const_cons_sep_reord - `! a const_cons. +Theorem const_cons_sep_reord: + ! a const_cons. const_cons_sep pes a const_cons = (const_cons', a') /\ EVERY isPcon (MAP FST a) /\ EVERY ($~ o is_const_con) (MAP FST a) /\ EVERY is_const_con (MAP FST const_cons) ==> - reord^* (const_cons ++ (REVERSE a) ++ pes) (const_cons' ++ (REVERSE a')) ` - (Induct_on `pes` \\ fs [] \\ rw [const_cons_sep_def] + reord^* (const_cons ++ (REVERSE a) ++ pes) (const_cons' ++ (REVERSE a')) +Proof + Induct_on `pes` \\ fs [] \\ rw [const_cons_sep_def] >- ( rw [] \\ match_mp_tac RTC_SUBSET @@ -341,21 +394,25 @@ Theorem const_cons_sep_reord \\ rfs[] \\ metis_tac[CONS_APPEND,APPEND_ASSOC] ) >- ( - rw[REVERSE_APPEND] )) + rw[REVERSE_APPEND] ) +QED -Theorem const_cons_fst_reord - `reord^* pes (const_cons_fst pes)` - (fs [const_cons_fst_def] +Theorem const_cons_fst_reord: + reord^* pes (const_cons_fst pes) +Proof + fs [const_cons_fst_def] \\ pairarg_tac \\ fs [] - \\ imp_res_tac const_cons_sep_reord \\ fs[]) + \\ imp_res_tac const_cons_sep_reord \\ fs[] +QED -Theorem find_match_preserved_reord - `¬env.check_ctor ⇒ +Theorem find_match_preserved_reord: + ¬env.check_ctor ⇒ ! pes pes'. reord pes pes' ==> find_match env refs v pes <> Match_type_error ==> - find_match env refs v pes = find_match env refs v pes'` - (strip_tac \\ + find_match env refs v pes = find_match env refs v pes' +Proof + strip_tac \\ ho_match_mp_tac reord_ind \\ strip_tac >-( @@ -366,27 +423,30 @@ Theorem find_match_preserved_reord METIS_TAC [find_match_may_drop_dup] ) \\ METIS_TAC [find_match_may_reord, APPEND_ASSOC, CONS_APPEND] -) +QED -Theorem find_match_preserved_reord_RTC - `¬env.check_ctor ⇒ ! pes pes'. reord^* pes pes' ==> +Theorem find_match_preserved_reord_RTC: + ¬env.check_ctor ⇒ ! pes pes'. reord^* pes pes' ==> find_match env refs v pes <> Match_type_error ==> - find_match env refs v pes = find_match env refs v pes'` - (strip_tac \\ ho_match_mp_tac RTC_INDUCT + find_match env refs v pes = find_match env refs v pes' +Proof + strip_tac \\ ho_match_mp_tac RTC_INDUCT \\ METIS_TAC [find_match_preserved_reord] - ) +QED (* main lemma: find_match semantics preserved by compilation *) -Theorem const_cons_fst_find_match - `¬env.check_ctor ∧ find_match env refs v pes <> Match_type_error ==> - find_match env refs v pes = find_match env refs v (const_cons_fst pes)` - (METIS_TAC [find_match_preserved_reord_RTC, const_cons_fst_reord]) +Theorem const_cons_fst_find_match: + ¬env.check_ctor ∧ find_match env refs v pes <> Match_type_error ==> + find_match env refs v pes = find_match env refs v (const_cons_fst pes) +Proof + METIS_TAC [find_match_preserved_reord_RTC, const_cons_fst_reord] +QED (* semantic auxiliaries respect transformation of values *) -Theorem pmatch_compile - `(!env refs p err_v acc. +Theorem pmatch_compile: + (!env refs p err_v acc. pmatch (env with v := compile_env env.v) (MAP compile_store_v refs) p (compile_v err_v) (compile_env acc) = @@ -395,8 +455,9 @@ Theorem pmatch_compile pmatch_list (env with v := compile_env env.v) (MAP compile_store_v refs) ps (MAP compile_v vs) (compile_env acc) = - map_match (compile_env) (pmatch_list env refs ps vs acc)) ` - (ho_match_mp_tac pmatch_ind \\ rw [pmatch_def] + map_match (compile_env) (pmatch_list env refs ps vs acc)) +Proof + ho_match_mp_tac pmatch_ind \\ rw [pmatch_def] >- (fs [ETA_AX]) >- (fs [ETA_AX]) >- ( @@ -408,7 +469,8 @@ Theorem pmatch_compile >- ( every_case_tac \\ fs [] \\ rw [] - )) + ) +QED val pmatch_compile_nil = pmatch_compile |> CONJUNCT1 |> SPEC_ALL @@ -416,83 +478,104 @@ val pmatch_compile_nil = pmatch_compile |> CONJUNCT1 |> Q.SPEC`[]` |> SIMP_RULE (srw_ss())[] -Theorem find_match_compile - `find_match (env with v := compile_env env.v) +Theorem find_match_compile: + find_match (env with v := compile_env env.v) (MAP compile_store_v refs) (compile_v v) (MAP (I ## f) pes) = - map_match (compile_env ## f) (find_match env refs v pes)` - (Induct_on `pes` + map_match (compile_env ## f) (find_match env refs v pes) +Proof + Induct_on `pes` \\ fs [find_match_def] \\ rw [] \\ fs [pmatch_compile_nil] - \\ every_case_tac \\ fs []) + \\ every_case_tac \\ fs [] +QED -Theorem find_match_imp_compile - `find_match env s.refs v pes = Match (env',e) ==> +Theorem find_match_imp_compile: + find_match env s.refs v pes = Match (env',e) ==> find_match (env with v := compile_env env.v) (compile_state s).refs (compile_v v) (MAP (\(p,e). (p,HD(compile[e]))) pes) = - Match (compile_env env', HD(compile[e]))` - (strip_tac \\ + Match (compile_env env', HD(compile[e])) +Proof + strip_tac \\ (Q.GENL[`f`,`refs`,`v`,`pes`]find_match_compile |> Q.ISPECL_THEN[`\e. HD(compile[e])`,`s.refs`,`v`,`pes`]mp_tac) \\ simp[] \\ disch_then(SUBST1_TAC o SYM) \\ rpt(AP_TERM_TAC ORELSE AP_THM_TAC) \\ - simp[FUN_EQ_THM,FORALL_PROD]); - -Theorem do_opapp_compile[simp] - `do_opapp (MAP compile_v as) = - OPTION_MAP (λ(env,e). (compile_env env, HD (compile [e]))) (do_opapp as)` - (rw[do_opapp_def] + simp[FUN_EQ_THM,FORALL_PROD] +QED + +Theorem do_opapp_compile[simp]: + do_opapp (MAP compile_v as) = + OPTION_MAP (λ(env,e). (compile_env env, HD (compile [e]))) (do_opapp as) +Proof + rw[do_opapp_def] \\ every_case_tac \\ fs[semanticPrimitivesPropsTheory.find_recfun_ALOOKUP,build_rec_env_merge] - \\ rw[] \\ fsrw_tac[ETA_ss][ALOOKUP_MAP3,MAP_MAP_o,o_DEF,UNCURRY]); - -Theorem do_eq_compile[simp] - `(∀v1 v2. do_eq (compile_v v1) (compile_v v2) = do_eq v1 v2) ∧ - (∀v1 v2. do_eq_list (MAP compile_v v1) (MAP compile_v v2) = do_eq_list v1 v2)` - (ho_match_mp_tac do_eq_ind + \\ rw[] \\ fsrw_tac[ETA_ss][ALOOKUP_MAP3,MAP_MAP_o,o_DEF,UNCURRY] +QED + +Theorem do_eq_compile[simp]: + (∀v1 v2. do_eq (compile_v v1) (compile_v v2) = do_eq v1 v2) ∧ + (∀v1 v2. do_eq_list (MAP compile_v v1) (MAP compile_v v2) = do_eq_list v1 v2) +Proof + ho_match_mp_tac do_eq_ind \\ srw_tac[ETA_ss][do_eq_def] - \\ every_case_tac \\ fs[]); + \\ every_case_tac \\ fs[] +QED -Theorem store_v_same_type_compile[simp] - `(store_v_same_type (compile_store_v v1) v2 ⇔ store_v_same_type v1 v2) ∧ +Theorem store_v_same_type_compile[simp]: + (store_v_same_type (compile_store_v v1) v2 ⇔ store_v_same_type v1 v2) ∧ (store_v_same_type v1 (compile_store_v v2) ⇔ store_v_same_type v1 v2) ∧ (store_v_same_type (Refv (compile_v x1)) v2 ⇔ store_v_same_type (Refv x1) v2) ∧ - (store_v_same_type v1 (Refv (compile_v x2)) ⇔ store_v_same_type v1 (Refv x2))` - (Cases_on`v1` \\ Cases_on`v2` \\ EVAL_TAC); - -Theorem v_to_char_list_compile[simp] - `∀ls. v_to_char_list (compile_v ls) = v_to_char_list ls` - (ho_match_mp_tac v_to_char_list_ind \\ rw[v_to_char_list_def]); - -Theorem v_to_list_compile[simp] - `∀v. v_to_list (compile_v v) = OPTION_MAP (MAP compile_v) (v_to_list v)` - (ho_match_mp_tac v_to_list_ind \\ rw[v_to_list_def] - \\ every_case_tac \\ fs[]); - -Theorem vs_to_strings_compile[simp] - `∀vs. vs_to_string (MAP compile_v vs) = vs_to_string vs` - (ho_match_mp_tac vs_to_string_ind \\ rw[vs_to_string_def]); - -Theorem list_to_v_compile_APPEND - `!xs ys. + (store_v_same_type v1 (Refv (compile_v x2)) ⇔ store_v_same_type v1 (Refv x2)) +Proof + Cases_on`v1` \\ Cases_on`v2` \\ EVAL_TAC +QED + +Theorem v_to_char_list_compile[simp]: + ∀ls. v_to_char_list (compile_v ls) = v_to_char_list ls +Proof + ho_match_mp_tac v_to_char_list_ind \\ rw[v_to_char_list_def] +QED + +Theorem v_to_list_compile[simp]: + ∀v. v_to_list (compile_v v) = OPTION_MAP (MAP compile_v) (v_to_list v) +Proof + ho_match_mp_tac v_to_list_ind \\ rw[v_to_list_def] + \\ every_case_tac \\ fs[] +QED + +Theorem vs_to_strings_compile[simp]: + ∀vs. vs_to_string (MAP compile_v vs) = vs_to_string vs +Proof + ho_match_mp_tac vs_to_string_ind \\ rw[vs_to_string_def] +QED + +Theorem list_to_v_compile_APPEND: + !xs ys. list_to_v (MAP compile_v xs) = compile_v (list_to_v xs) /\ list_to_v (MAP compile_v ys) = compile_v (list_to_v ys) ==> list_to_v (MAP compile_v (xs ++ ys)) = - compile_v (list_to_v (xs ++ ys))` - (Induct \\ rw [compile_v_def, list_to_v_def] \\ rfs []); - -Theorem list_to_v_compile - `!xs. list_to_v (MAP compile_v xs) = compile_v (list_to_v xs)` - (Induct \\ rw [compile_v_def, list_to_v_def]); - -Theorem do_app_compile[simp] - `do_app cc (compile_state s) op (MAP compile_v as) = + compile_v (list_to_v (xs ++ ys)) +Proof + Induct \\ rw [compile_v_def, list_to_v_def] \\ rfs [] +QED + +Theorem list_to_v_compile: + !xs. list_to_v (MAP compile_v xs) = compile_v (list_to_v xs) +Proof + Induct \\ rw [compile_v_def, list_to_v_def] +QED + +Theorem do_app_compile[simp]: + do_app cc (compile_state s) op (MAP compile_v as) = OPTION_MAP (λ(s,r). (compile_state s, map_result compile_v compile_v r)) - (do_app cc s op as)` - (Cases_on `op = ListAppend` + (do_app cc s op as) +Proof + Cases_on `op = ListAppend` >- (Cases_on `do_app cc s op as` \\ fs [] \\ rveq \\ pop_assum mp_tac @@ -511,12 +594,13 @@ Theorem do_app_compile[simp] \\ every_case_tac \\ fs [compile_store_v_def] \\ rw [EL_MAP, METIS_PROVE [] ``a \/ b <=> ~a ==> b``, ELIM_UNCURRY] \\ fs [] \\ EVAL_TAC - \\ fs [LUPDATE_MAP,compile_store_v_def,map_replicate, IS_SOME_EXISTS]); + \\ fs [LUPDATE_MAP,compile_store_v_def,map_replicate, IS_SOME_EXISTS] +QED (* main results *) -Theorem compile_evaluate - `(!env ^s es s1 r1. +Theorem compile_evaluate: + (!env ^s es s1 r1. evaluate env s es = (s1, r1) /\ r1 <> Rerr (Rabort Rtype_error) /\ env.exh_pat /\ @@ -537,8 +621,9 @@ Theorem compile_evaluate (compile_v v) (MAP (\(p,e). (p,HD(compile[e]))) pes) (compile_v err_v) = - (compile_state s1, map_result (MAP compile_v) compile_v r1))` - (ho_match_mp_tac evaluate_ind + (compile_state s1, map_result (MAP compile_v) compile_v r1)) +Proof + ho_match_mp_tac evaluate_ind \\ rw [compile_def] \\ fs [evaluate_def] \\ rw [] \\ fs [MAP_FST_MAP_triple] >- @@ -617,10 +702,11 @@ Theorem compile_evaluate \\ qspec_then `e` strip_assume_tac compile_sing \\ fs []) \\ fs [pmatch_compile_nil] \\ every_case_tac \\ fs [] \\ rfs [] - \\ qspec_then `e` strip_assume_tac compile_sing \\ fs []); + \\ qspec_then `e` strip_assume_tac compile_sing \\ fs [] +QED -Theorem compile_dec_evaluate - `!d env s t c r. +Theorem compile_dec_evaluate: + !d env s t c r. evaluate_dec env s d = (t, c, r) /\ env.exh_pat /\ ~env.check_ctor /\ @@ -631,8 +717,9 @@ Theorem compile_dec_evaluate (compile_state s) (HD (compile_decs [d])) = (compile_state t, c, r2) /\ - r2 = OPTION_MAP (map_error_result compile_v) r` - (Cases \\ rw [evaluate_dec_def] + r2 = OPTION_MAP (map_error_result compile_v) r +Proof + Cases \\ rw [evaluate_dec_def] \\ fs [evaluate_dec_def, compile_decs_def] \\ fs [case_eq_thms, pair_case_eq] \\ rw [] \\ fs [] \\ qspec_then `e` strip_assume_tac compile_sing \\ fs [] @@ -641,18 +728,23 @@ Theorem compile_dec_evaluate \\ rw [evaluate_dec_def] >> every_case_tac >> fs [] >> - rw []); - -Theorem compile_decs_CONS - `compile_decs (d::ds) = compile_decs [d] ++ compile_decs ds` - (rw [compile_decs_def] \\ every_case_tac \\ fs []); - -Theorem compile_decs_SING - `!y. ?x. compile_decs [y] = [x]` - (Cases \\ rw [compile_decs_def] \\ fs []); - -Theorem compile_decs_evaluate - `!ds env s t c r. + rw [] +QED + +Theorem compile_decs_CONS: + compile_decs (d::ds) = compile_decs [d] ++ compile_decs ds +Proof + rw [compile_decs_def] \\ every_case_tac \\ fs [] +QED + +Theorem compile_decs_SING: + !y. ?x. compile_decs [y] = [x] +Proof + Cases \\ rw [compile_decs_def] \\ fs [] +QED + +Theorem compile_decs_evaluate: + !ds env s t c r. evaluate_decs env s ds = (t, c, r) /\ env.exh_pat /\ ~env.check_ctor /\ @@ -663,8 +755,9 @@ Theorem compile_decs_evaluate (compile_state s) (compile_decs ds) = (compile_state t, c, r2) /\ - r2 = OPTION_MAP (map_error_result compile_v) r` - (Induct >- (rw [evaluate_decs_def, compile_decs_def] \\ rw []) \\ rw[] + r2 = OPTION_MAP (map_error_result compile_v) r +Proof + Induct >- (rw [evaluate_decs_def, compile_decs_def] \\ rw []) \\ rw[] \\ fs [evaluate_decs_def, case_eq_thms, pair_case_eq] \\ rw [] \\ fs [] \\ once_rewrite_tac [compile_decs_CONS] \\ drule compile_dec_evaluate \\ rw [] \\ fs [] @@ -672,20 +765,23 @@ Theorem compile_decs_evaluate >- (last_x_assum drule \\ rw [evaluate_decs_def] \\ fs []) \\ simp [evaluate_decs_def] \\ every_case_tac \\ fs [] - \\ Cases_on `e` \\ Cases_on `a` \\ fs []); + \\ Cases_on `e` \\ Cases_on `a` \\ fs [] +QED -Theorem compile_decs_eval_sim - `eval_sim +Theorem compile_decs_eval_sim: + eval_sim (ffi:'ffi ffi_state) T F ds1 T F (compile_decs ds1) - (\p1 p2. p2 = compile_decs p1) F` - (rw [eval_sim_def] + (\p1 p2. p2 = compile_decs p1) F +Proof + rw [eval_sim_def] \\ qexists_tac `0` \\ CONV_TAC (RESORT_EXISTS_CONV rev) \\ Q.LIST_EXISTS_TAC [`c1`,`compile_state s2`] \\ drule compile_decs_evaluate \\ impl_tac >- fs [initial_env_def] \\ rw [] - \\ fs[initial_env_def, initial_state_def, compile_state_def]); + \\ fs[initial_env_def, initial_state_def, compile_state_def] +QED val compile_decs_semantics = save_thm ("compile_decs_semantics", MATCH_MP (REWRITE_RULE [GSYM AND_IMP_INTRO] IMP_semantics_eq) @@ -695,9 +791,10 @@ val compile_decs_semantics = save_thm ("compile_decs_semantics", (* syntactic results *) -Theorem compile_elist_globals_eq_empty - `∀es. elist_globals es = {||} ⇒ elist_globals (compile es) = {||}` - (ho_match_mp_tac compile_ind +Theorem compile_elist_globals_eq_empty: + ∀es. elist_globals es = {||} ⇒ elist_globals (compile es) = {||} +Proof + ho_match_mp_tac compile_ind \\ rw[compile_def] \\ TRY (Cases_on `compile [e]` \\ fs [] \\ NO_TAC) \\ fs [elist_globals_eq_empty] @@ -706,16 +803,20 @@ Theorem compile_elist_globals_eq_empty \\ imp_res_tac const_cons_fst_MEM \\ fs [] \\ res_tac \\ rename1 `compile [x]` - \\ Cases_on `compile [x]` \\ fs []); - -Theorem compile_set_globals_eq_empty - `set_globals e = {||} ⇒ set_globals (HD (compile [e])) = {||}` - (qspec_then`[e]`mp_tac compile_elist_globals_eq_empty - \\ rw[] \\ fs[] \\ Cases_on `compile [e]` \\ fs []); - -Theorem compile_esgc_free - `∀es. EVERY esgc_free es ⇒ EVERY esgc_free (compile es)` - (ho_match_mp_tac compile_ind + \\ Cases_on `compile [x]` \\ fs [] +QED + +Theorem compile_set_globals_eq_empty: + set_globals e = {||} ⇒ set_globals (HD (compile [e])) = {||} +Proof + qspec_then`[e]`mp_tac compile_elist_globals_eq_empty + \\ rw[] \\ fs[] \\ Cases_on `compile [e]` \\ fs [] +QED + +Theorem compile_esgc_free: + ∀es. EVERY esgc_free es ⇒ EVERY esgc_free (compile es) +Proof + ho_match_mp_tac compile_ind \\ rw[compile_def] \\ fs[] \\ TRY (Cases_on `compile [e]` \\ fs [] \\ NO_TAC) \\ fs[EVERY_MAP,EVERY_MEM,FORALL_PROD,elist_globals_eq_empty] @@ -724,43 +825,53 @@ Theorem compile_esgc_free \\ TRY( match_mp_tac compile_set_globals_eq_empty \\ res_tac ) - \\ METIS_TAC[compile_sing,HD,MEM,const_cons_fst_MEM,compile_set_globals_eq_empty]); - -Theorem compile_decs_esgc_free - `∀ds. EVERY esgc_free (MAP dest_Dlet (FILTER is_Dlet ds)) ⇒ - EVERY esgc_free (MAP dest_Dlet (FILTER is_Dlet (flat_reorder_match$compile_decs ds)))` - (Induct \\ simp[flat_reorder_matchTheory.compile_decs_def] + \\ METIS_TAC[compile_sing,HD,MEM,const_cons_fst_MEM,compile_set_globals_eq_empty] +QED + +Theorem compile_decs_esgc_free: + ∀ds. EVERY esgc_free (MAP dest_Dlet (FILTER is_Dlet ds)) ⇒ + EVERY esgc_free (MAP dest_Dlet (FILTER is_Dlet (flat_reorder_match$compile_decs ds))) +Proof + Induct \\ simp[flat_reorder_matchTheory.compile_decs_def] \\ Cases \\ simp[] \\ rw[] \\ fs[] \\ qspec_then`[e]`mp_tac compile_esgc_free \\ strip_assume_tac (SPEC_ALL flat_reorder_matchTheory.compile_sing) - \\ rw[]); + \\ rw[] +QED -Theorem const_cons_sep_sub_bag - `∀pes a const_cons c a'. +Theorem const_cons_sep_sub_bag: + ∀pes a const_cons c a'. const_cons_sep pes a const_cons = (c,a') ⇒ elist_globals (MAP SND (c ++ REVERSE a')) ≤ - elist_globals (MAP SND (const_cons ++ REVERSE a ++ pes))` - (Induct_on`pes` \\ rw[const_cons_sep_def] + elist_globals (MAP SND (const_cons ++ REVERSE a ++ pes)) +Proof + Induct_on`pes` \\ rw[const_cons_sep_def] \\ fs[elist_globals_append,REVERSE_APPEND] \\ fs[SUB_BAG_UNION] \\ first_x_assum drule \\ rw[elist_globals_append] - \\ metis_tac[SUB_BAG_UNION,ASSOC_BAG_UNION,COMM_BAG_UNION]); - -Theorem const_cons_fst_sub_bag - `elist_globals (MAP SND (const_cons_fst pes)) ≤ - elist_globals (MAP SND pes)` - (rw[const_cons_fst_def] + \\ metis_tac[SUB_BAG_UNION,ASSOC_BAG_UNION,COMM_BAG_UNION] +QED + +Theorem const_cons_fst_sub_bag: + elist_globals (MAP SND (const_cons_fst pes)) ≤ + elist_globals (MAP SND pes) +Proof + rw[const_cons_fst_def] \\ pairarg_tac \\ fs[] - \\ imp_res_tac const_cons_sep_sub_bag \\ fs[]) - -Theorem const_cons_fst_distinct_globals - `BAG_ALL_DISTINCT (elist_globals (MAP SND pes)) ⇒ - BAG_ALL_DISTINCT (elist_globals (MAP SND (const_cons_fst pes)))` - (METIS_TAC[const_cons_fst_sub_bag,BAG_ALL_DISTINCT_SUB_BAG]); - -Theorem compile_sub_bag - `∀es. (elist_globals (compile es)) ≤ (elist_globals es)` - (ho_match_mp_tac compile_ind + \\ imp_res_tac const_cons_sep_sub_bag \\ fs[] +QED + +Theorem const_cons_fst_distinct_globals: + BAG_ALL_DISTINCT (elist_globals (MAP SND pes)) ⇒ + BAG_ALL_DISTINCT (elist_globals (MAP SND (const_cons_fst pes))) +Proof + METIS_TAC[const_cons_fst_sub_bag,BAG_ALL_DISTINCT_SUB_BAG] +QED + +Theorem compile_sub_bag: + ∀es. (elist_globals (compile es)) ≤ (elist_globals es) +Proof + ho_match_mp_tac compile_ind \\ rw [compile_def] \\ TRY (qspec_then `e` assume_tac compile_sing \\ fs [] \\ fs []) \\ fs [SUB_BAG_UNION, elist_globals_append] \\ rfs [] @@ -790,25 +901,32 @@ Theorem compile_sub_bag \\ pairarg_tac \\ fs[] \\ qspec_then `p2` assume_tac compile_sing \\ fs [] \\ fs [] \\ first_x_assum (fn th => mp_tac th \\ impl_tac >- METIS_TAC[]) - \\ fsrw_tac[DNF_ss][UNCURRY,SUB_BAG_UNION]); - -Theorem compile_distinct_globals - `BAG_ALL_DISTINCT (elist_globals es) ⇒ BAG_ALL_DISTINCT (elist_globals (compile es))` - (METIS_TAC[compile_sub_bag,BAG_ALL_DISTINCT_SUB_BAG]); - -Theorem compile_decs_sub_bag - `(elist_globals (MAP dest_Dlet (FILTER is_Dlet (flat_reorder_match$compile_decs ds)))) ≤ (elist_globals (MAP dest_Dlet (FILTER is_Dlet ds)))` - (Induct_on`ds` \\ rw [flat_reorder_matchTheory.compile_decs_def] + \\ fsrw_tac[DNF_ss][UNCURRY,SUB_BAG_UNION] +QED + +Theorem compile_distinct_globals: + BAG_ALL_DISTINCT (elist_globals es) ⇒ BAG_ALL_DISTINCT (elist_globals (compile es)) +Proof + METIS_TAC[compile_sub_bag,BAG_ALL_DISTINCT_SUB_BAG] +QED + +Theorem compile_decs_sub_bag: + (elist_globals (MAP dest_Dlet (FILTER is_Dlet (flat_reorder_match$compile_decs ds)))) ≤ (elist_globals (MAP dest_Dlet (FILTER is_Dlet ds))) +Proof + Induct_on`ds` \\ rw [flat_reorder_matchTheory.compile_decs_def] \\ fs [UNCURRY] \\ rw [] \\ Cases_on `h` \\ fs [] \\ qspec_then `e` assume_tac flat_reorder_matchTheory.compile_sing \\ fs [] \\ `elist_globals [e2] <= elist_globals [e]` by metis_tac [compile_sub_bag] - \\ fs [SUB_BAG_UNION]); - -Theorem compile_decs_distinct_globals - `BAG_ALL_DISTINCT (elist_globals (MAP dest_Dlet (FILTER is_Dlet ds))) ⇒ - BAG_ALL_DISTINCT (elist_globals (MAP dest_Dlet (FILTER is_Dlet (flat_reorder_match$compile_decs ds))))` - (metis_tac [compile_decs_sub_bag, BAG_ALL_DISTINCT_SUB_BAG]); + \\ fs [SUB_BAG_UNION] +QED + +Theorem compile_decs_distinct_globals: + BAG_ALL_DISTINCT (elist_globals (MAP dest_Dlet (FILTER is_Dlet ds))) ⇒ + BAG_ALL_DISTINCT (elist_globals (MAP dest_Dlet (FILTER is_Dlet (flat_reorder_match$compile_decs ds)))) +Proof + metis_tac [compile_decs_sub_bag, BAG_ALL_DISTINCT_SUB_BAG] +QED val () = export_theory(); diff --git a/compiler/backend/proofs/flat_to_patProofScript.sml b/compiler/backend/proofs/flat_to_patProofScript.sml index a612cd3ae5..b6c2e437b4 100644 --- a/compiler/backend/proofs/flat_to_patProofScript.sml +++ b/compiler/backend/proofs/flat_to_patProofScript.sml @@ -31,26 +31,30 @@ val NoRun_def = tDefine "NoRun" ` (WF_REL_TAC `measure exp_size` \\ rw [] \\ imp_res_tac exp_size_MEM \\ fs []) -Theorem sLet_NoRun - `!e1 e2. +Theorem sLet_NoRun: + !e1 e2. NoRun e1 /\ NoRun e2 ==> - !t. NoRun (sLet t e1 e2)` - (recInduct (theorem"NoRun_ind") \\ rw [NoRun_def] + !t. NoRun (sLet t e1 e2) +Proof + recInduct (theorem"NoRun_ind") \\ rw [NoRun_def] \\ simp [sLet_def] - \\ every_case_tac \\ fs [NoRun_def]); + \\ every_case_tac \\ fs [NoRun_def] +QED -Theorem sIf_NoRun - `!e1 e2 e3. +Theorem sIf_NoRun: + !e1 e2 e3. NoRun e1 /\ NoRun e2 /\ NoRun e3 ==> - !t. NoRun (sIf t e1 e2 e3)` - (recInduct (theorem"NoRun_ind") \\ rw [NoRun_def] + !t. NoRun (sIf t e1 e2 e3) +Proof + recInduct (theorem"NoRun_ind") \\ rw [NoRun_def] \\ simp [sIf_def] - \\ every_case_tac \\ fs [NoRun_def]); + \\ every_case_tac \\ fs [NoRun_def] +QED -Theorem compile_row_NoRun - `(!t bvs p ns n f e. +Theorem compile_row_NoRun: + (!t bvs p ns n f e. NoRun e /\ compile_row t bvs p = (ns, n, f) ==> @@ -59,38 +63,48 @@ Theorem compile_row_NoRun NoRun e /\ compile_cols t bvs n1 n2 ps = (ns, n, f) ==> - NoRun (f e))` - (ho_match_mp_tac compile_row_ind \\ rw [compile_row_def] \\ fs [] + NoRun (f e)) +Proof + ho_match_mp_tac compile_row_ind \\ rw [compile_row_def] \\ fs [] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] - \\ irule sLet_NoRun \\ fs [NoRun_def]); - -Theorem Let_Els_NoRun - `!t n m e. NoRun e ==> NoRun (Let_Els t n m e)` - (recInduct Let_Els_ind \\ rw [NoRun_def] \\ fs [Let_Els_def] - \\ irule sLet_NoRun \\ fs [NoRun_def]); - -Theorem compile_pat_NoRun - `(!t p. NoRun (compile_pat t p)) /\ - (!t n ps. NoRun (compile_pats t n ps))` - (ho_match_mp_tac compile_pat_ind \\ rw [compile_pat_def] \\ fs [NoRun_def] + \\ irule sLet_NoRun \\ fs [NoRun_def] +QED + +Theorem Let_Els_NoRun: + !t n m e. NoRun e ==> NoRun (Let_Els t n m e) +Proof + recInduct Let_Els_ind \\ rw [NoRun_def] \\ fs [Let_Els_def] + \\ irule sLet_NoRun \\ fs [NoRun_def] +QED + +Theorem compile_pat_NoRun: + (!t p. NoRun (compile_pat t p)) /\ + (!t n ps. NoRun (compile_pats t n ps)) +Proof + ho_match_mp_tac compile_pat_ind \\ rw [compile_pat_def] \\ fs [NoRun_def] \\ TRY (irule sIf_NoRun) \\ fs [NoRun_def] \\ TRY (irule sLet_NoRun) \\ fs [NoRun_def] - \\ TRY (irule Let_Els_NoRun) \\ fs []); + \\ TRY (irule Let_Els_NoRun) \\ fs [] +QED -Theorem compile_exp_NoRun - `(!bvs x. NoRun (compile_exp bvs x)) /\ +Theorem compile_exp_NoRun: + (!bvs x. NoRun (compile_exp bvs x)) /\ (!bvs xs. EVERY NoRun (compile_exps bvs xs)) /\ (!bvs xs. EVERY NoRun (compile_funs bvs xs)) /\ - (!tr bvs xs. NoRun (compile_pes tr bvs xs))` - (ho_match_mp_tac compile_exp_ind \\ rw [NoRun_def] \\ fs [ETA_AX] + (!tr bvs xs. NoRun (compile_pes tr bvs xs)) +Proof + ho_match_mp_tac compile_exp_ind \\ rw [NoRun_def] \\ fs [ETA_AX] \\ rpt CASE_TAC \\ fs [NoRun_def] \\ TRY (metis_tac [sLet_NoRun, compile_row_NoRun]) - \\ metis_tac [compile_row_NoRun, sIf_NoRun, compile_pat_NoRun]); + \\ metis_tac [compile_row_NoRun, sIf_NoRun, compile_pat_NoRun] +QED -Theorem compile_NoRun - `∀decs. EVERY NoRun (compile decs)` - (Induct \\ simp[compile_def] - \\ Cases \\ rw[compile_def, compile_exp_NoRun]); +Theorem compile_NoRun: + ∀decs. EVERY NoRun (compile decs) +Proof + Induct \\ simp[compile_def] + \\ Cases \\ rw[compile_def, compile_exp_NoRun] +QED val v_size_MEM = Q.prove ( `!vs (v: patSem$v). MEM v vs ==> v_size v < v1_size vs`, @@ -117,68 +131,80 @@ val NoRun_state_def = Define ` EVERY NoRun_store_v st.refs /\ EVERY (\g. !x. g = SOME x ==> NoRun_v x) st.globals` -Theorem NoRun_state_dec_clock - `NoRun_state s <=> NoRun_state (dec_clock s)` - (rw [NoRun_state_def, patSemTheory.dec_clock_def]); +Theorem NoRun_state_dec_clock: + NoRun_state s <=> NoRun_state (dec_clock s) +Proof + rw [NoRun_state_def, patSemTheory.dec_clock_def] +QED -Theorem build_rec_env_NoRun - `!funs cl_env. +Theorem build_rec_env_NoRun: + !funs cl_env. EVERY NoRun_v cl_env /\ EVERY NoRun funs ==> - EVERY NoRun_v (build_rec_env funs cl_env)` - (gen_tac + EVERY NoRun_v (build_rec_env funs cl_env) +Proof + gen_tac \\ Induct_on `LENGTH funs` \\ rw [] >- simp [patSemTheory.build_rec_env_def] \\ Cases_on `funs` \\ fs [] \\ first_x_assum (qspec_then `t` mp_tac) \\ fs [] \\ disch_then drule \\ simp [patSemTheory.build_rec_env_def, EVERY_GENLIST] - \\ rw [] \\ fs [NoRun_v_def, ETA_AX]); + \\ rw [] \\ fs [NoRun_v_def, ETA_AX] +QED -Theorem do_opapp_NoRun - `EVERY NoRun_v vs /\ +Theorem do_opapp_NoRun: + EVERY NoRun_v vs /\ do_opapp vs = SOME (env, e) ==> EVERY NoRun_v env /\ - NoRun e` - (simp [patSemTheory.do_opapp_def] + NoRun e +Proof + simp [patSemTheory.do_opapp_def] \\ rpt (PURE_CASE_TAC \\ fs [NoRun_v_def]) - \\ rw [] \\ fs [ETA_AX, build_rec_env_NoRun, EVERY_EL]); + \\ rw [] \\ fs [ETA_AX, build_rec_env_NoRun, EVERY_EL] +QED -Theorem store_assign_NoRun - `!n r x t. +Theorem store_assign_NoRun: + !n r x t. NoRun_v x /\ EVERY NoRun_store_v r /\ store_assign n (Refv x) r = SOME t ==> - EVERY NoRun_store_v t` - (Induct \\ rw [store_assign_def] + EVERY NoRun_store_v t +Proof + Induct \\ rw [store_assign_def] \\ Cases_on `r` \\ fs [LUPDATE_def, NoRun_store_v_def] \\ first_x_assum drule \\ disch_then drule - \\ simp [store_assign_def]); + \\ simp [store_assign_def] +QED -Theorem v_to_list_NoRun - `!x xs. +Theorem v_to_list_NoRun: + !x xs. NoRun_v x /\ v_to_list x = SOME xs ==> - EVERY NoRun_v xs` - (recInduct patSemTheory.v_to_list_ind \\ rw [] + EVERY NoRun_v xs +Proof + recInduct patSemTheory.v_to_list_ind \\ rw [] \\ fs [patSemTheory.v_to_list_def] \\ rw [] \\ fs [] \\ FULL_CASE_TAC \\ fs [] - \\ rw [] \\ fs [NoRun_v_def]); + \\ rw [] \\ fs [NoRun_v_def] +QED -Theorem NoRun_list_to_v - `!xs. +Theorem NoRun_list_to_v: + !xs. EVERY NoRun_v xs ==> - NoRun_v (list_to_v xs)` - (Induct \\ rw [patSemTheory.list_to_v_def, NoRun_v_def]) + NoRun_v (list_to_v xs) +Proof + Induct \\ rw [patSemTheory.list_to_v_def, NoRun_v_def] +QED -Theorem do_app_NoRun - `do_app s op vs = SOME (t, res) /\ +Theorem do_app_NoRun: + do_app s op vs = SOME (t, res) /\ EVERY NoRun_v vs /\ op <> Run /\ NoRun_state s @@ -187,8 +213,9 @@ Theorem do_app_NoRun case res of Rval v => NoRun_v v | Rerr (Rraise e) => NoRun_v e - | _ => T` - (simp [patSemTheory.do_app_def] + | _ => T +Proof + simp [patSemTheory.do_app_def] \\ rpt (PURE_TOP_CASE_TAC \\ fs []) \\ rw [] \\ fs [patSemTheory.prim_exn_def, NoRun_v_def, patSemTheory.Boolv_def] \\ rpt (pairarg_tac \\ fs []) \\ rw [] @@ -213,15 +240,18 @@ Theorem do_app_NoRun \\ `NoRun_store_v (Varray l)` by (res_tac \\ fs [EQ_SYM_EQ]) \\ fs [NoRun_store_v_def, EVERY_EL] \\ NO_TAC) - \\ irule NoRun_list_to_v \\ fs []); - -Theorem do_if_NoRun - `do_if v x y = SOME z /\ - NoRun_v v /\ NoRun x /\ NoRun y ==> NoRun z` - (rw [patSemTheory.do_if_def] \\ fs []); - -Theorem evaluate_NoRun - `!env s es t res. + \\ irule NoRun_list_to_v \\ fs [] +QED + +Theorem do_if_NoRun: + do_if v x y = SOME z /\ + NoRun_v v /\ NoRun x /\ NoRun y ==> NoRun z +Proof + rw [patSemTheory.do_if_def] \\ fs [] +QED + +Theorem evaluate_NoRun: + !env s es t res. evaluate env s es = (t, res) /\ EVERY NoRun es /\ EVERY NoRun_v env /\ @@ -231,8 +261,9 @@ Theorem evaluate_NoRun case res of Rval vs => EVERY NoRun_v vs | Rerr (Rraise e) => NoRun_v e - | _ => T` - (recInduct patSemTheory.evaluate_ind + | _ => T +Proof + recInduct patSemTheory.evaluate_ind \\ rpt conj_tac >- (rw [patSemTheory.evaluate_def] \\ fs [patSemTheory.do_opapp_def]) >- @@ -258,7 +289,8 @@ Theorem evaluate_NoRun \\ drule (GEN_ALL do_app_NoRun) \\ fs [EVERY_REVERSE]) \\ every_case_tac \\ fs [ETA_AX] \\ imp_res_tac build_rec_env_NoRun \\ fs [] - \\ fs [NoRun_state_def, EVERY_GENLIST, NoRun_v_def]); + \\ fs [NoRun_state_def, EVERY_GENLIST, NoRun_v_def] +QED (* value translation *) @@ -291,22 +323,28 @@ val compile_v_def = save_thm("compile_v_def[compute]", compile_v_def |> SIMP_RULE (srw_ss()++ETA_ss) [MAP_MAP_o]) val _ = export_rewrites["compile_v_def"] -Theorem compile_vs_map - `∀vs. compile_vs vs = MAP compile_v vs` - (Induct >> simp[]) +Theorem compile_vs_map: + ∀vs. compile_vs vs = MAP compile_v vs +Proof + Induct >> simp[] +QED val _ = export_rewrites["compile_vs_map"] -Theorem map_result_compile_vs_list_result[simp] - `map_result compile_vs f (list_result r) = list_result (map_result compile_v f r)` - (Cases_on`r`>>simp[]) - -Theorem compile_v_NoRun_v - `(!v. NoRun_v (compile_v v)) /\ - (!vs. EVERY NoRun_v (compile_vs vs))` - (ho_match_mp_tac (theorem"compile_v_ind") \\ rw [] +Theorem map_result_compile_vs_list_result[simp]: + map_result compile_vs f (list_result r) = list_result (map_result compile_v f r) +Proof + Cases_on`r`>>simp[] +QED + +Theorem compile_v_NoRun_v: + (!v. NoRun_v (compile_v v)) /\ + (!vs. EVERY NoRun_v (compile_vs vs)) +Proof + ho_match_mp_tac (theorem"compile_v_ind") \\ rw [] \\ rw [NoRun_v_def] \\ fs [ETA_AX, compile_exp_NoRun] \\ rw [EVERY_MEM] \\ fs [MEM_MAP] \\ rw [] - \\ res_tac \\ fs []); + \\ res_tac \\ fs [] +QED val compile_state_def = Define` compile_state co cc (s:'ffi flatSem$state) :('c,'ffi) patSem$state = @@ -326,12 +364,14 @@ val compile_state_with_clock = Q.prove( `compile_state co cc (s with clock := k) = compile_state co cc s with clock := k`, EVAL_TAC) -Theorem compile_state_NoRun - `NoRun_state (compile_state co cc s)` - (rw [compile_state_def, NoRun_state_def, EVERY_MEM] +Theorem compile_state_NoRun: + NoRun_state (compile_state co cc s) +Proof + rw [compile_state_def, NoRun_state_def, EVERY_MEM] \\ fs [MEM_MAP] \\ rw [] \\ fs [compile_v_NoRun_v] \\ Cases_on `y` \\ fs [NoRun_store_v_def, compile_v_NoRun_v, EVERY_MAP, - EVERY_MEM, compile_v_NoRun_v]); + EVERY_MEM, compile_v_NoRun_v] +QED (* semantic functions obey translation *) @@ -400,27 +440,31 @@ val vs_to_string = Q.prove( ho_match_mp_tac flatSemTheory.vs_to_string_ind \\ rw[flatSemTheory.vs_to_string_def,patSemTheory.vs_to_string_def]); -Theorem list_to_v_compile - `!x xs. +Theorem list_to_v_compile: + !x xs. v_to_list x = SOME xs /\ v_to_list (compile_v x) = SOME (MAP compile_v xs) ==> - list_to_v (MAP compile_v xs) = compile_v (list_to_v xs)` - (ho_match_mp_tac flatSemTheory.v_to_list_ind + list_to_v (MAP compile_v xs) = compile_v (list_to_v xs) +Proof + ho_match_mp_tac flatSemTheory.v_to_list_ind \\ rw [flatSemTheory.v_to_list_def] \\ fs [] \\ fs [patSemTheory.list_to_v_def, flatSemTheory.list_to_v_def] \\ PURE_FULL_CASE_TAC \\ fs [] \\ rveq \\ fs [patSemTheory.list_to_v_def, flatSemTheory.list_to_v_def, patSemTheory.v_to_list_def, flatSemTheory.v_to_list_def] - \\ PURE_FULL_CASE_TAC \\ fs [] \\ rveq) + \\ PURE_FULL_CASE_TAC \\ fs [] \\ rveq +QED -Theorem list_to_v_compile_APPEND - `!xs ys. +Theorem list_to_v_compile_APPEND: + !xs ys. list_to_v (MAP compile_v xs) = compile_v (list_to_v xs) /\ list_to_v (MAP compile_v ys) = compile_v (list_to_v ys) ==> list_to_v (MAP compile_v (xs ++ ys)) = - compile_v (list_to_v (xs ++ ys))` - (Induct \\ rw [patSemTheory.list_to_v_def] - \\ fs [flatSemTheory.list_to_v_def, patSemTheory.list_to_v_def]); + compile_v (list_to_v (xs ++ ys)) +Proof + Induct \\ rw [patSemTheory.list_to_v_def] + \\ fs [flatSemTheory.list_to_v_def, patSemTheory.list_to_v_def] +QED val do_app = Q.prove( `∀cc co op vs s0 s res. @@ -450,12 +494,13 @@ val do_app = Q.prove( (* pattern compiler correctness *) -Theorem sIf_correct - `∀env s e1 e2 e3 res. +Theorem sIf_correct: + ∀env s e1 e2 e3 res. evaluate env s [If t e1 e2 e3] = res ∧ (SND res ≠ Rerr (Rabort Rtype_error)) ⇒ - evaluate env s [sIf t e1 e2 e3] = res` - (rpt gen_tac >> + evaluate env s [sIf t e1 e2 e3] = res +Proof + rpt gen_tac >> Cases_on`isBool T e2 ∧ isBool F e3` >- ( simp[sIf_def] >> simp[patSemTheory.evaluate_def,patSemTheory.do_if_def] >> @@ -469,13 +514,16 @@ Theorem sIf_correct Cases_on`l`>>simp[]>> simp[patSemTheory.evaluate_def] >> simp[patSemTheory.do_if_def] >> srw_tac[][] >> full_simp_tac(srw_ss())[evaluate_Con_nil] >> - full_simp_tac(srw_ss())[patSemTheory.Boolv_def,backend_commonTheory.true_tag_def,backend_commonTheory.false_tag_def]) + full_simp_tac(srw_ss())[patSemTheory.Boolv_def,backend_commonTheory.true_tag_def,backend_commonTheory.false_tag_def] +QED -Theorem sIf_intro - `P (evaluate env s [If t e1 e2 e3]) ∧ +Theorem sIf_intro: + P (evaluate env s [If t e1 e2 e3]) ∧ SND (evaluate env s [If t e1 e2 e3]) ≠ Rerr (Rabort Rtype_error) ⇒ - P (evaluate env s [sIf t e1 e2 e3])` - (metis_tac[sIf_correct]) + P (evaluate env s [sIf t e1 e2 e3]) +Proof + metis_tac[sIf_correct] +QED val v_to_list_no_closures = Q.prove ( `!v vs. @@ -502,16 +550,17 @@ val lemmas = semanticPrimitivesTheory.error_result_11, semanticPrimitivesTheory.abort_distinct] -Theorem pure_correct - `(∀e. pure e ⇒ +Theorem pure_correct: + (∀e. pure e ⇒ ∀env ^s. (∃v. evaluate env s [e] = (s,Rval v)) ∨ (evaluate env s [e] = (s,Rerr(Rabort Rtype_error)))) ∧ (∀es. pure_list es ⇒ ∀env ^s. ((∃vs. evaluate env s es = (s,Rval vs)) ∨ (evaluate env s es = (s,Rerr(Rabort Rtype_error)))) ∧ ((∃vs. evaluate env s (REVERSE es) = (s,Rval vs)) ∨ - (evaluate env s (REVERSE es) = (s,Rerr(Rabort Rtype_error)))))` - (ho_match_mp_tac(TypeBase.induction_of(``:patLang$exp``)) >> + (evaluate env s (REVERSE es) = (s,Rerr(Rabort Rtype_error))))) +Proof + ho_match_mp_tac(TypeBase.induction_of(``:patLang$exp``)) >> simp[pure_def] >> srw_tac[][] >> full_simp_tac(srw_ss())[] >> srw_tac[][patSemTheory.evaluate_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> @@ -533,10 +582,11 @@ Theorem pure_correct REWRITE_TAC[evaluate_append_Rval_iff,evaluate_append_Rerr] >> metis_tac lemmas ) >> REWRITE_TAC[evaluate_append_Rval_iff,evaluate_append_Rerr] >> - metis_tac lemmas) + metis_tac lemmas +QED -Theorem ground_correct - `(∀e n. ground n e ⇒ +Theorem ground_correct: + (∀e n. ground n e ⇒ (∀env1 env2 ^s res. n ≤ LENGTH env1 ∧ n ≤ LENGTH env2 ∧ (TAKE n env2 = TAKE n env1) ∧ @@ -549,8 +599,9 @@ Theorem ground_correct (evaluate env1 s es = res ⇒ evaluate env2 s es = res) ∧ (evaluate env1 s (REVERSE es) = res ⇒ - evaluate env2 s (REVERSE es) = res)))` - (ho_match_mp_tac(TypeBase.induction_of(``:patLang$exp``)) >> + evaluate env2 s (REVERSE es) = res))) +Proof + ho_match_mp_tac(TypeBase.induction_of(``:patLang$exp``)) >> srw_tac[][patSemTheory.evaluate_def] >> res_tac >> rev_full_simp_tac(srw_ss())[] >> srw_tac[][] >> TRY ( @@ -567,14 +618,16 @@ Theorem ground_correct simp[] >> NO_TAC) >> ONCE_REWRITE_TAC[CONS_APPEND] >> REWRITE_TAC[evaluate_append] >> - simp[]); + simp[] +QED -Theorem sLet_correct - `∀env ^s e1 e2 res. +Theorem sLet_correct: + ∀env ^s e1 e2 res. evaluate env s [Let t e1 e2] = res ∧ SND res ≠ Rerr (Rabort Rtype_error) ⇒ - evaluate env s [sLet t e1 e2] = res` - (rw[] \\ + evaluate env s [sLet t e1 e2] = res +Proof + rw[] \\ Cases_on`∃tr. e2 = Var_local tr 0` >- ( fs[sLet_def,patSemTheory.evaluate_def] \\ CASE_TAC \\ fs[] \\ CASE_TAC \\ fs[] \\ @@ -592,13 +645,16 @@ Theorem sLet_correct full_simp_tac(srw_ss())[patSemTheory.evaluate_def] >> BasicProvers.CASE_TAC >> full_simp_tac(srw_ss())[] >> BasicProvers.CASE_TAC >> full_simp_tac(srw_ss())[] >> - qspecl_then[`e2`,`0`]mp_tac(CONJUNCT1 ground_correct) >> srw_tac[][]); + qspecl_then[`e2`,`0`]mp_tac(CONJUNCT1 ground_correct) >> srw_tac[][] +QED -Theorem sLet_intro - `P (evaluate env s [Let t e1 e2]) ∧ +Theorem sLet_intro: + P (evaluate env s [Let t e1 e2]) ∧ SND (evaluate env s [Let t e1 e2]) ≠ Rerr (Rabort Rtype_error) - ⇒ P (evaluate env s [sLet t e1 e2])` - (metis_tac[sLet_correct]) + ⇒ P (evaluate env s [sLet t e1 e2]) +Proof + metis_tac[sLet_correct] +QED val Let_Els_correct = Q.prove( `∀t n k e tag vs env ^s res us. @@ -923,35 +979,43 @@ val bind_def = Define` (bind V (SUC n1) (SUC n2) ⇔ V n1 n2) ∧ (bind V _ _ ⇔ F)` -Theorem bind_mono - `(∀x y. V1 x y ⇒ V2 x y) ⇒ bind V1 x y ⇒ bind V2 x y` - (Cases_on`x`>>Cases_on`y`>>srw_tac[][bind_def]) +Theorem bind_mono: + (∀x y. V1 x y ⇒ V2 x y) ⇒ bind V1 x y ⇒ bind V2 x y +Proof + Cases_on`x`>>Cases_on`y`>>srw_tac[][bind_def] +QED val _ = export_mono"bind_mono" val bindn_def = Define`bindn = FUNPOW bind` -Theorem bind_thm - `∀V x y. bind V x y = +Theorem bind_thm: + ∀V x y. bind V x y = if x = 0 then y = 0 else if y = 0 then x = 0 else - V (x-1) (y-1)` - (gen_tac >> Cases >> Cases >> srw_tac[][bind_def]) - -Theorem bindn_mono - `(∀x y. R1 x y ⇒ R2 x y) ⇒ - bindn n R1 x y ⇒ bindn n R2 x y` - (srw_tac[][bindn_def] >> + V (x-1) (y-1) +Proof + gen_tac >> Cases >> Cases >> srw_tac[][bind_def] +QED + +Theorem bindn_mono: + (∀x y. R1 x y ⇒ R2 x y) ⇒ + bindn n R1 x y ⇒ bindn n R2 x y +Proof + srw_tac[][bindn_def] >> match_mp_tac (MP_CANON FUNPOW_mono) >> - simp[] >> metis_tac[bind_mono] ) + simp[] >> metis_tac[bind_mono] +QED val _ = export_mono"bindn_mono" -Theorem bindn_thm - `∀n k1 k2. +Theorem bindn_thm: + ∀n k1 k2. bindn n R k1 k2 ⇔ if k1 < n ∧ k2 < n then k1 = k2 - else n ≤ k1 ∧ n ≤ k2 ∧ R (k1-n) (k2-n)` - (Induct>>simp[bindn_def,arithmeticTheory.FUNPOW_SUC] >> - Cases>>Cases>>simp[bind_def,GSYM bindn_def]) + else n ≤ k1 ∧ n ≤ k2 ∧ R (k1-n) (k2-n) +Proof + Induct>>simp[bindn_def,arithmeticTheory.FUNPOW_SUC] >> + Cases>>Cases>>simp[bind_def,GSYM bindn_def] +QED val (exp_rel_rules,exp_rel_ind,exp_rel_cases) = Hol_reln` (exp_rel z1 z2 V e1 e2 @@ -977,10 +1041,11 @@ val (exp_rel_rules,exp_rel_ind,exp_rel_cases) = Hol_reln` exp_rel (z1+(LENGTH es1)) (z2+(LENGTH es2)) (bindn (LENGTH es1) V) e1 e2 ⇒ exp_rel z1 z2 V (Letrec t es1 e1) (Letrec t es2 e2))`; -Theorem exp_rel_refl - `(∀e z V. (∀k. k < z ⇒ V k k) ⇒ exp_rel z z V e e) ∧ - (∀es z V. (∀k. k < z ⇒ V k k) ⇒ LIST_REL (exp_rel z z V) es es)` - (ho_match_mp_tac(TypeBase.induction_of``:patLang$exp``) >> srw_tac[][] >> +Theorem exp_rel_refl: + (∀e z V. (∀k. k < z ⇒ V k k) ⇒ exp_rel z z V e e) ∧ + (∀es z V. (∀k. k < z ⇒ V k k) ⇒ LIST_REL (exp_rel z z V) es es) +Proof + ho_match_mp_tac(TypeBase.induction_of``:patLang$exp``) >> srw_tac[][] >> TRY (first_x_assum match_mp_tac) >> srw_tac[][Once exp_rel_cases] >> TRY (first_x_assum match_mp_tac) >> @@ -989,13 +1054,15 @@ Theorem exp_rel_refl TRY (Cases_on`n < z` >>simp[] >> NO_TAC) >> srw_tac[][bindn_thm] >> Cases_on`k < SUC (LENGTH es)` >> simp[] >> - Cases_on`k < LENGTH es` >> simp[]) + Cases_on`k < LENGTH es` >> simp[] +QED -Theorem exp_rel_mono - `(∀x y. V1 x y ⇒ V2 x y) ⇒ +Theorem exp_rel_mono: + (∀x y. V1 x y ⇒ V2 x y) ⇒ exp_rel z1 z2 V1 e1 e2 ⇒ - exp_rel z1 z2 V2 e1 e2` - (strip_tac >> strip_tac >> last_x_assum mp_tac >> + exp_rel z1 z2 V2 e1 e2 +Proof + strip_tac >> strip_tac >> last_x_assum mp_tac >> qid_spec_tac`V2` >> pop_assum mp_tac >> map_every qid_spec_tac[`e2`,`e1`,`V1`,`z2`,`z1`] >> ho_match_mp_tac exp_rel_ind >> @@ -1034,34 +1101,41 @@ Theorem exp_rel_mono simp[] ) >> first_x_assum match_mp_tac >> match_mp_tac bindn_mono >> - simp[] )) + simp[] ) +QED val _ = export_mono"exp_rel_mono"; -Theorem exp_rel_lit - `(exp_rel z1 z2 V (Lit t l) e2 ⇔ (e2 = Lit t l)) ∧ +Theorem exp_rel_lit: + (exp_rel z1 z2 V (Lit t l) e2 ⇔ (e2 = Lit t l)) ∧ (exp_rel z1 z2 V e1 (Lit t l) ⇔ (e1 = Lit t l)) ∧ (exp_rel z1 z2 V (Bool t b) e2 ⇔ (e2 = Bool t b)) ∧ - (exp_rel z1 z2 V e1 (Bool t b) ⇔ (e1 = Bool t b))` - (srw_tac[][Once exp_rel_cases] >> - srw_tac[][Once exp_rel_cases,Bool_def] ) + (exp_rel z1 z2 V e1 (Bool t b) ⇔ (e1 = Bool t b)) +Proof + srw_tac[][Once exp_rel_cases] >> + srw_tac[][Once exp_rel_cases,Bool_def] +QED val _ = export_rewrites["exp_rel_lit"]; -Theorem bind_O - `∀R1 R2. bind (R2 O R1) = bind R2 O bind R1` - (srw_tac[][] >> simp[FUN_EQ_THM] >> +Theorem bind_O: + ∀R1 R2. bind (R2 O R1) = bind R2 O bind R1 +Proof + srw_tac[][] >> simp[FUN_EQ_THM] >> simp[relationTheory.O_DEF] >> srw_tac[][bind_thm,relationTheory.O_DEF,EQ_IMP_THM] >> rev_full_simp_tac(srw_ss())[] >- ( qexists_tac`SUC y` >> simp[] ) >> - qexists_tac`y-1` >> simp[]) + qexists_tac`y-1` >> simp[] +QED val _ = export_rewrites["bind_O"]; -Theorem bindn_O - `∀R1 R2 n. bindn n (R2 O R1) = bindn n R2 O bindn n R1` - (srw_tac[][FUN_EQ_THM,bindn_thm,relationTheory.O_DEF] >> +Theorem bindn_O: + ∀R1 R2 n. bindn n (R2 O R1) = bindn n R2 O bindn n R1 +Proof + srw_tac[][FUN_EQ_THM,bindn_thm,relationTheory.O_DEF] >> srw_tac[][EQ_IMP_THM] >> simp[] >> fsrw_tac[ARITH_ss][] >> rev_full_simp_tac(srw_ss()++ARITH_ss)[]>>fsrw_tac[ARITH_ss][] >- (qexists_tac`y+n` >> simp[]) >> - (qexists_tac`y-n` >> simp[])) + (qexists_tac`y-n` >> simp[]) +QED val _ = export_rewrites["bindn_O"]; val exp_rel_trans = Q.prove( @@ -1090,23 +1164,27 @@ val exp_rel_trans = Q.prove( srw_tac[][] >> pop_assum mp_tac >> ntac 2 (srw_tac[][Once exp_rel_cases]) >> rev_full_simp_tac(srw_ss())[EVERY2_EVERY,EVERY_MEM] >> full_simp_tac(srw_ss())[MEM_ZIP,PULL_EXISTS,MEM_EL] ) ) -Theorem exp_rel_trans - `∀z1 z2 z3 V1 V2 V3 e1 e2 e3. +Theorem exp_rel_trans: + ∀z1 z2 z3 V1 V2 V3 e1 e2 e3. exp_rel z1 z2 V1 e1 e2 ∧ exp_rel z2 z3 V2 e2 e3 ∧ (V3 = V2 O V1) ⇒ - exp_rel z1 z3 V3 e1 e3` - (metis_tac[exp_rel_trans]) + exp_rel z1 z3 V3 e1 e3 +Proof + metis_tac[exp_rel_trans] +QED val env_rel_def = Define` env_rel R env1 env2 k1 k2 ⇔ k1 < LENGTH env1 ∧ k2 < LENGTH env2 ∧ R (EL k1 env1) (EL k2 env2)` -Theorem env_rel_mono - `(∀x y. R1 x y ⇒ R2 x y) ⇒ +Theorem env_rel_mono: + (∀x y. R1 x y ⇒ R2 x y) ⇒ env_rel R1 env1 env2 k1 k2 ⇒ - env_rel R2 env1 env2 k1 k2` - (srw_tac[][env_rel_def]) + env_rel R2 env1 env2 k1 k2 +Proof + srw_tac[][env_rel_def] +QED val _ = export_mono"env_rel_mono"; val env_rel_cons = Q.prove( @@ -1132,23 +1210,28 @@ val (v_rel_rules,v_rel_ind,v_rel_cases) = Hol_reln` (LIST_REL v_rel vs1 vs2 ⇒ v_rel (Vectorv vs1) (Vectorv vs2))`; -Theorem v_rel_lit - `(v_rel (Litv l) v2 ⇔ (v2 = Litv l)) ∧ +Theorem v_rel_lit: + (v_rel (Litv l) v2 ⇔ (v2 = Litv l)) ∧ (v_rel v1 (Litv l) ⇔ (v1 = Litv l)) ∧ (v_rel (Boolv b) v2 ⇔ (v2 = Boolv b)) ∧ - (v_rel v1 (Boolv b) ⇔ (v1 = Boolv b))` - (srw_tac[][Once v_rel_cases] >> srw_tac[][Once v_rel_cases,patSemTheory.Boolv_def] ) + (v_rel v1 (Boolv b) ⇔ (v1 = Boolv b)) +Proof + srw_tac[][Once v_rel_cases] >> srw_tac[][Once v_rel_cases,patSemTheory.Boolv_def] +QED val _ = export_rewrites["v_rel_lit"] -Theorem v_rel_loc - `(v_rel (Loc l) v2 ⇔ (v2 = Loc l)) ∧ - (v_rel v1 (Loc l) ⇔ (v1 = Loc l))` - (srw_tac[][Once v_rel_cases] >> srw_tac[][Once v_rel_cases] ) +Theorem v_rel_loc: + (v_rel (Loc l) v2 ⇔ (v2 = Loc l)) ∧ + (v_rel v1 (Loc l) ⇔ (v1 = Loc l)) +Proof + srw_tac[][Once v_rel_cases] >> srw_tac[][Once v_rel_cases] +QED val _ = export_rewrites["v_rel_loc"] -Theorem v_rel_refl - `∀v. v_rel v v` - (qsuff_tac`(∀v. v_rel v v) ∧ (∀vs. LIST_REL v_rel vs vs)`>-srw_tac[][]>> +Theorem v_rel_refl: + ∀v. v_rel v v +Proof + qsuff_tac`(∀v. v_rel v v) ∧ (∀vs. LIST_REL v_rel vs vs)`>-srw_tac[][]>> ho_match_mp_tac(TypeBase.induction_of``:patSem$v``)>> srw_tac[][] >> srw_tac[][Once v_rel_cases] >> TRY ( @@ -1160,12 +1243,14 @@ Theorem v_rel_refl qmatch_assum_rename_tac`k < LENGTH vs + SUC (LENGTH ls)` >> Cases_on`k < SUC (LENGTH ls)`>>simp[] >> full_simp_tac(srw_ss())[EVERY2_EVERY,EVERY_MEM,MEM_ZIP,PULL_EXISTS] >> - simp[]) + simp[] +QED val _ = export_rewrites["v_rel_refl"] -Theorem v_rel_trans - `∀v1 v2. v_rel v1 v2 ⇒ ∀v3. v_rel v2 v3 ⇒ v_rel v1 v3` - (ho_match_mp_tac (theorem"v_rel_strongind") >> simp[] >> +Theorem v_rel_trans: + ∀v1 v2. v_rel v1 v2 ⇒ ∀v3. v_rel v2 v3 ⇒ v_rel v1 v3 +Proof + ho_match_mp_tac (theorem"v_rel_strongind") >> simp[] >> strip_tac >- ( rpt gen_tac >> strip_tac >> simp[Once v_rel_cases,PULL_EXISTS] >> @@ -1215,30 +1300,38 @@ Theorem v_rel_trans match_mp_tac LIST_REL_trans >> qexists_tac`vs2` >> simp[] >> rev_full_simp_tac(srw_ss())[EVERY2_EVERY,EVERY_MEM] >> - full_simp_tac(srw_ss())[MEM_ZIP,PULL_EXISTS,MEM_EL] ); - -Theorem bind_inv - `∀V. bind (inv V) = inv (bind V)` - (srw_tac[][FUN_EQ_THM,bind_thm,relationTheory.inv_DEF] >> - srw_tac[][]) + full_simp_tac(srw_ss())[MEM_ZIP,PULL_EXISTS,MEM_EL] +QED + +Theorem bind_inv: + ∀V. bind (inv V) = inv (bind V) +Proof + srw_tac[][FUN_EQ_THM,bind_thm,relationTheory.inv_DEF] >> + srw_tac[][] +QED val _ = export_rewrites["bind_inv"] -Theorem bindn_inv - `∀V n. bindn n (inv V) = inv (bindn n V)` - (srw_tac[][FUN_EQ_THM,bindn_thm,relationTheory.inv_DEF] >> - srw_tac[][] >> simp[] >> full_simp_tac(srw_ss())[] >> simp[]) +Theorem bindn_inv: + ∀V n. bindn n (inv V) = inv (bindn n V) +Proof + srw_tac[][FUN_EQ_THM,bindn_thm,relationTheory.inv_DEF] >> + srw_tac[][] >> simp[] >> full_simp_tac(srw_ss())[] >> simp[] +QED val _ = export_rewrites["bindn_inv"] -Theorem exp_rel_sym - `∀z1 z2 V e1 e2. exp_rel z1 z2 V e1 e2 ⇒ exp_rel z2 z1 (inv V) e2 e1` - (ho_match_mp_tac exp_rel_ind >> srw_tac[][] >> +Theorem exp_rel_sym: + ∀z1 z2 V e1 e2. exp_rel z1 z2 V e1 e2 ⇒ exp_rel z2 z1 (inv V) e2 e1 +Proof + ho_match_mp_tac exp_rel_ind >> srw_tac[][] >> simp[Once exp_rel_cases] >> rev_full_simp_tac(srw_ss())[EVERY2_EVERY,EVERY_MEM] >> - full_simp_tac(srw_ss())[MEM_ZIP,PULL_EXISTS,relationTheory.inv_DEF] ) + full_simp_tac(srw_ss())[MEM_ZIP,PULL_EXISTS,relationTheory.inv_DEF] +QED -Theorem v_rel_sym - `∀v1 v2. v_rel v1 v2 ⇒ v_rel v2 v1` - (ho_match_mp_tac v_rel_ind >> srw_tac[][] >> +Theorem v_rel_sym: + ∀v1 v2. v_rel v1 v2 ⇒ v_rel v2 v1 +Proof + ho_match_mp_tac v_rel_ind >> srw_tac[][] >> simp[Once v_rel_cases] >> full_simp_tac(srw_ss())[LIST_REL_EL_EQN] >> srw_tac[][] >> rev_full_simp_tac(srw_ss())[] >> TRY(first_x_assum(fn th => first_x_assum(strip_assume_tac o MATCH_MP th))) >> @@ -1247,7 +1340,8 @@ Theorem v_rel_sym fsrw_tac[ARITH_ss][] >> HINT_EXISTS_TAC >> simp[relationTheory.inv_DEF,bind_thm,bindn_thm] >> - srw_tac[][] >> fsrw_tac[ARITH_ss][env_rel_def]) + srw_tac[][] >> fsrw_tac[ARITH_ss][env_rel_def] +QED val state_rel_def = Define` state_rel (s1: ('c,'ffi) patSem$state) (s2: ('c,'ffi) patSem$state) ⇔ @@ -1264,9 +1358,11 @@ val state_rel_dec_clock = Q.prove( `state_rel s s2 ⇒ state_rel (dec_clock s) (dec_clock s2)`, srw_tac[][state_rel_def,patSemTheory.dec_clock_def]) -Theorem state_rel_refl[simp] - `state_rel s s` - (srw_tac[][state_rel_def] >> match_mp_tac EVERY2_refl >> srw_tac[][]); +Theorem state_rel_refl[simp]: + state_rel s s +Proof + srw_tac[][state_rel_def] >> match_mp_tac EVERY2_refl >> srw_tac[][] +QED val result_rel_v_v_rel_trans = result_rel_trans @@ -1331,9 +1427,10 @@ val state_rel_trans = Q.prove( val do_eq_def = patSemTheory.do_eq_def -Theorem do_eq_v_rel - `∀v1 v2. v_rel v1 v2 ⇒ ∀v3 v4. v_rel v3 v4 ⇒ do_eq v1 v3 = do_eq v2 v4` - (ho_match_mp_tac v_rel_ind >> +Theorem do_eq_v_rel: + ∀v1 v2. v_rel v1 v2 ⇒ ∀v3 v4. v_rel v3 v4 ⇒ do_eq v1 v3 = do_eq v2 v4 +Proof + ho_match_mp_tac v_rel_ind >> simp[do_eq_def] >> srw_tac[][] >> Cases_on`v3`>>Cases_on`v4`>>full_simp_tac(srw_ss())[do_eq_def] >> pop_assum mp_tac >> simp[Once v_rel_cases] >> srw_tac[][] >> @@ -1347,23 +1444,27 @@ Theorem do_eq_v_rel srw_tac[][] >> BasicProvers.CASE_TAC >> srw_tac[][] >> BasicProvers.CASE_TAC >> srw_tac[][] >> - res_tac >> full_simp_tac(srw_ss())[]) + res_tac >> full_simp_tac(srw_ss())[] +QED -Theorem do_eq_list_v_rel - `∀v1 v2 v3 v4. LIST_REL v_rel v1 v2 ∧ LIST_REL v_rel v3 v4 ⇒ do_eq_list v1 v3 = do_eq_list v2 v4` - (Induct \\ simp[do_eq_def] \\ Cases_on`v3` \\ simp[do_eq_def,PULL_EXISTS] \\ rw[] +Theorem do_eq_list_v_rel: + ∀v1 v2 v3 v4. LIST_REL v_rel v1 v2 ∧ LIST_REL v_rel v3 v4 ⇒ do_eq_list v1 v3 = do_eq_list v2 v4 +Proof + Induct \\ simp[do_eq_def] \\ Cases_on`v3` \\ simp[do_eq_def,PULL_EXISTS] \\ rw[] \\ imp_res_tac do_eq_v_rel \\ fs[] - \\ CASE_TAC \\ fs[] \\ CASE_TAC \\ fs[]); + \\ CASE_TAC \\ fs[] \\ CASE_TAC \\ fs[] +QED -Theorem do_opapp_v_rel - `∀vs vs'. +Theorem do_opapp_v_rel: + ∀vs vs'. LIST_REL v_rel vs vs' ⇒ OPTION_REL (λ(env1,e1) (env2,e2). exp_rel (LENGTH env1) (LENGTH env2) (env_rel v_rel env1 env2) e1 e2) (do_opapp vs) - (do_opapp vs')` - (srw_tac[][patSemTheory.do_opapp_def] >> + (do_opapp vs') +Proof + srw_tac[][patSemTheory.do_opapp_def] >> BasicProvers.CASE_TAC >> full_simp_tac(srw_ss())[quotient_optionTheory.OPTION_REL_def] >> srw_tac[][] >> Cases_on`t`>>full_simp_tac(srw_ss())[quotient_optionTheory.OPTION_REL_def] >> srw_tac[][] >> Cases_on`t'`>>full_simp_tac(srw_ss())[quotient_optionTheory.OPTION_REL_def] >> srw_tac[][] >> @@ -1388,7 +1489,8 @@ Theorem do_opapp_v_rel simp[Once v_rel_cases] >> rev_full_simp_tac(srw_ss())[EVERY2_EVERY,EVERY_MEM] >> full_simp_tac(srw_ss())[MEM_ZIP,PULL_EXISTS,arithmeticTheory.ADD1,Abbr`z1`,Abbr`z2`] >> - simp[]) + simp[] +QED val v_to_list_SOME = Q.prove( `∀v ls. @@ -1478,25 +1580,29 @@ in val s = mk_var("s",ty) end -Theorem list_to_v_v_rel - `!xs ys. LIST_REL v_rel xs ys ==> v_rel (list_to_v xs) (list_to_v ys)` - (Induct \\ rw [] \\ fs [patSemTheory.list_to_v_def, v_rel_rules]); +Theorem list_to_v_v_rel: + !xs ys. LIST_REL v_rel xs ys ==> v_rel (list_to_v xs) (list_to_v ys) +Proof + Induct \\ rw [] \\ fs [patSemTheory.list_to_v_def, v_rel_rules] +QED -Theorem list_to_v_APPEND - `!x1 y1 x2 y2. +Theorem list_to_v_APPEND: + !x1 y1 x2 y2. v_rel (list_to_v x1) (list_to_v x2) /\ v_rel (list_to_v y1) (list_to_v y2) ==> - v_rel (list_to_v (x1 ++ y1)) (list_to_v (x2 ++ y2))` - (Induct \\ Induct_on `x2` + v_rel (list_to_v (x1 ++ y1)) (list_to_v (x2 ++ y2)) +Proof + Induct \\ Induct_on `x2` \\ TRY (rw [v_rel_cases, patSemTheory.list_to_v_def] \\ NO_TAC) \\ rw [] \\ fs [patSemTheory.list_to_v_def] \\ ntac 2 (pop_assum mp_tac) \\ simp [Once v_rel_cases] \\ rw [] - \\ simp [Once v_rel_cases]); + \\ simp [Once v_rel_cases] +QED -Theorem do_app_v_rel - `∀^s op s' vs vs'. +Theorem do_app_v_rel: + ∀^s op s' vs vs'. LIST_REL v_rel vs vs' ⇒ state_rel s s' ⇒ OPTION_REL @@ -1504,8 +1610,9 @@ Theorem do_app_v_rel state_rel s1 s2 ∧ result_rel v_rel v_rel res1 res2) (do_app s op vs) - (do_app s' op vs')` - (srw_tac[][] >> + (do_app s' op vs') +Proof + srw_tac[][] >> srw_tac[][optionTheory.OPTREL_def] >> Cases_on`do_app s op vs`>>srw_tac[][]>-( Cases_on `op = (Op ListAppend)` @@ -1610,35 +1717,44 @@ Theorem do_app_v_rel fs[LIST_REL_EL_EQN,OPTREL_def,EL_LUPDATE,LENGTH_REPLICATE,EL_REPLICATE] >> res_tac >> fs[sv_rel_cases] >> rfs[] >> fs[LIST_REL_EL_EQN,EL_LUPDATE,store_v_same_type_def] >> rw[EL_LUPDATE] \\ rw[EL_LUPDATE,EL_APPEND_EQN,EL_REPLICATE] >> rw[] - \\ metis_tac[]); + \\ metis_tac[] +QED (* some NoRun things for exp_rel, v_rel, state_rel etc *) -Theorem exp_rel_NoRun - `!a b R x y. - exp_rel a b R x y ==> NoRun x ==> NoRun y` - (ho_match_mp_tac exp_rel_ind \\ rw [NoRun_def, EVERY_EL, LIST_REL_EL_EQN]); +Theorem exp_rel_NoRun: + !a b R x y. + exp_rel a b R x y ==> NoRun x ==> NoRun y +Proof + ho_match_mp_tac exp_rel_ind \\ rw [NoRun_def, EVERY_EL, LIST_REL_EL_EQN] +QED -Theorem LIST_REL_exp_rel_NoRun - `!es1 es2 a b R. +Theorem LIST_REL_exp_rel_NoRun: + !es1 es2 a b R. LIST_REL (exp_rel a b R) es1 es2 /\ EVERY NoRun es1 ==> - EVERY NoRun es2` - (Induct \\ rw [] \\ fs [EVERY_DEF] \\ metis_tac [exp_rel_NoRun]); + EVERY NoRun es2 +Proof + Induct \\ rw [] \\ fs [EVERY_DEF] \\ metis_tac [exp_rel_NoRun] +QED -Theorem env_rel_NoRun_v - `!env1 env2 R k1 k2. +Theorem env_rel_NoRun_v: + !env1 env2 R k1 k2. env_rel R env1 env2 (LENGTH env1) (LENGTH env2) /\ EVERY NoRun_v env1 ==> - EVERY NoRun_v env2` - (Induct \\ rw [] \\ fs [env_rel_def]); - -Theorem v_rel_NoRun_v - `!x y. v_rel x y ==> (NoRun_v x ==> NoRun_v y)` - (ho_match_mp_tac v_rel_ind \\ rw [v_rel_cases] + EVERY NoRun_v env2 +Proof + Induct \\ rw [] \\ fs [env_rel_def] +QED + +Theorem v_rel_NoRun_v: + !x y. v_rel x y ==> (NoRun_v x ==> NoRun_v y) +Proof + ho_match_mp_tac v_rel_ind \\ rw [v_rel_cases] \\ TRY (fs [NoRun_v_def, LIST_REL_EL_EQN, EVERY_EL] \\ NO_TAC) - \\ metis_tac [NoRun_v_def, ETA_AX, exp_rel_NoRun, LIST_REL_exp_rel_NoRun]); + \\ metis_tac [NoRun_v_def, ETA_AX, exp_rel_NoRun, LIST_REL_exp_rel_NoRun] +QED val sv_rel_NoRun_store_v = Q.prove ( `!R x y. @@ -1649,18 +1765,23 @@ val sv_rel_NoRun_store_v = Q.prove ( \\ fs [NoRun_store_v_def, LIST_REL_EL_EQN, EVERY_EL] \\ rw [] \\ metis_tac []); -Theorem sv_rel_v_rel_NoRun - `sv_rel v_rel x y ==> NoRun_store_v x ==> NoRun_store_v y` - (metis_tac [sv_rel_NoRun_store_v, v_rel_NoRun_v]); - -Theorem sv_rel_sym - `!R x y. (!x y. R x y ==> R y x) ==> sv_rel R x y ==> sv_rel R y x` - (ho_match_mp_tac sv_rel_ind - \\ rw [sv_rel_cases,LIST_REL_EL_EQN]); - -Theorem state_rel_NoRun - `state_rel s1 s2 ==> (NoRun_state s1 <=> NoRun_state s2)` - (rw [state_rel_def, NoRun_state_def] +Theorem sv_rel_v_rel_NoRun: + sv_rel v_rel x y ==> NoRun_store_v x ==> NoRun_store_v y +Proof + metis_tac [sv_rel_NoRun_store_v, v_rel_NoRun_v] +QED + +Theorem sv_rel_sym: + !R x y. (!x y. R x y ==> R y x) ==> sv_rel R x y ==> sv_rel R y x +Proof + ho_match_mp_tac sv_rel_ind + \\ rw [sv_rel_cases,LIST_REL_EL_EQN] +QED + +Theorem state_rel_NoRun: + state_rel s1 s2 ==> (NoRun_state s1 <=> NoRun_state s2) +Proof + rw [state_rel_def, NoRun_state_def] \\ eq_tac \\ rw [] \\ fs [] \\ TRY (fs [EVERY_EL, LIST_REL_EL_EQN] \\ rw [] @@ -1674,10 +1795,11 @@ Theorem state_rel_NoRun \\ rpt (qpat_x_assum `_ = _` kall_tac) \\ fs [LIST_REL_EL_EQN, EVERY_EL] \\ rw [] \\ rpt (first_x_assum (qspec_then `n` mp_tac)) \\ rw [] \\ fs [] - \\ metis_tac [sv_rel_v_rel_NoRun, sv_rel_sym, v_rel_sym]); + \\ metis_tac [sv_rel_v_rel_NoRun, sv_rel_sym, v_rel_sym] +QED -Theorem evaluate_exp_rel - `(∀env1 ^s1 es1 s'1 r1. +Theorem evaluate_exp_rel: + (∀env1 ^s1 es1 s'1 r1. evaluate env1 s1 es1 = (s'1,r1) /\ EVERY NoRun es1 /\ EVERY NoRun_v env1 /\ NoRun_state s1 ==> @@ -1688,8 +1810,9 @@ Theorem evaluate_exp_rel ∃s'2 r2. evaluate env2 s2 es2 = (s'2,r2) ∧ state_rel s'1 s'2 ∧ - result_rel (LIST_REL v_rel) v_rel r1 r2)` - (ho_match_mp_tac patSemTheory.evaluate_ind >> fs [NoRun_def] >> + result_rel (LIST_REL v_rel) v_rel r1 r2) +Proof + ho_match_mp_tac patSemTheory.evaluate_ind >> fs [NoRun_def] >> strip_tac >- ( srw_tac[][patSemTheory.evaluate_def] >> srw_tac[][]) >> strip_tac >- ( rw [patSemTheory.evaluate_def,PULL_EXISTS] @@ -1880,7 +2003,8 @@ Theorem evaluate_exp_rel imp_res_tac EVERY2_LENGTH >> srw_tac[][] >> simp[rich_listTheory.EL_APPEND2,rich_listTheory.EL_APPEND1] >> fsrw_tac[ARITH_ss][env_rel_def] >> - simp[Once v_rel_cases])); + simp[Once v_rel_cases]) +QED val bvs_V_def = Define` bvs_V bvs1 bvs2 V ⇔ @@ -1926,31 +2050,38 @@ val bind_bvs_V_SOME = Q.prove( full_simp_tac(srw_ss())[Once find_index_shift_0] >> metis_tac[]) -Theorem bind_bvs_V - `∀x bvs1 bvs2 V. +Theorem bind_bvs_V: + ∀x bvs1 bvs2 V. bvs_V bvs1 bvs2 V ⇒ - bvs_V (x::bvs1) (x::bvs2) (bind V)` - (Cases >> metis_tac[bind_bvs_V_NONE,bind_bvs_V_SOME]) + bvs_V (x::bvs1) (x::bvs2) (bind V) +Proof + Cases >> metis_tac[bind_bvs_V_NONE,bind_bvs_V_SOME] +QED -Theorem bindn_bvs_V - `∀ls n bvs1 bvs2 V. +Theorem bindn_bvs_V: + ∀ls n bvs1 bvs2 V. bvs_V bvs1 bvs2 V ∧ n = LENGTH ls ⇒ - bvs_V (ls++bvs1) (ls++bvs2) (bindn n V)` - (Induct >> simp[bindn_def,arithmeticTheory.FUNPOW_SUC] >> - metis_tac[bind_bvs_V,bindn_def]) + bvs_V (ls++bvs1) (ls++bvs2) (bindn n V) +Proof + Induct >> simp[bindn_def,arithmeticTheory.FUNPOW_SUC] >> + metis_tac[bind_bvs_V,bindn_def] +QED val exp_rel_Con = SIMP_RULE(srw_ss())[](Q.SPECL[`z1`,`z2`,`V`,`Con _ X Y`]exp_rel_cases) -Theorem exp_rel_isBool - `exp_rel z1 z2 V e e' ⇒ (isBool b e ⇔ isBool b e')` - (rw[Once exp_rel_cases] \\ fs[] \\ - CASE_TAC \\ fs[] \\ fs[]); - -Theorem exp_rel_sIf - `exp_rel z1 z2 V (If t e1 e2 e3) (If t f1 f2 f3) ⇒ - exp_rel z1 z2 V (sIf t e1 e2 e3) (sIf t f1 f2 f3)` - (simp[Once exp_rel_cases] \\ strip_tac \\ +Theorem exp_rel_isBool: + exp_rel z1 z2 V e e' ⇒ (isBool b e ⇔ isBool b e') +Proof + rw[Once exp_rel_cases] \\ fs[] \\ + CASE_TAC \\ fs[] \\ fs[] +QED + +Theorem exp_rel_sIf: + exp_rel z1 z2 V (If t e1 e2 e3) (If t f1 f2 f3) ⇒ + exp_rel z1 z2 V (sIf t e1 e2 e3) (sIf t f1 f2 f3) +Proof + simp[Once exp_rel_cases] \\ strip_tac \\ simp_tac std_ss [sIf_def] \\ simp_tac std_ss [Q.SPECL[`e2`,`f2`](Q.GENL[`e`,`e'`]exp_rel_isBool) |> UNDISCH] \\ simp_tac std_ss [Q.SPECL[`e3`,`f3`](Q.GENL[`e`,`e'`]exp_rel_isBool) |> UNDISCH] \\ @@ -1970,22 +2101,26 @@ Theorem exp_rel_sIf BasicProvers.CASE_TAC>>srw_tac[][] >> TRY(BasicProvers.CASE_TAC>>srw_tac[][]) >> pop_assum mp_tac >> simp[Once exp_rel_cases]) >> - simp[Once exp_rel_cases]) - -Theorem exp_rel_pure - `∀z1 z2 V e1 e2. exp_rel z1 z2 V e1 e2 ⇒ - (pure e1 ⇔ pure e2)` - (ho_match_mp_tac (theorem"exp_rel_strongind") >> + simp[Once exp_rel_cases] +QED + +Theorem exp_rel_pure: + ∀z1 z2 V e1 e2. exp_rel z1 z2 V e1 e2 ⇒ + (pure e1 ⇔ pure e2) +Proof + ho_match_mp_tac (theorem"exp_rel_strongind") >> simp[pure_def] >> srw_tac[][EVERY_MEM,EVERY2_EVERY,EQ_IMP_THM] >> rev_full_simp_tac(srw_ss())[MEM_ZIP,PULL_EXISTS] >> rev_full_simp_tac(srw_ss())[MEM_EL,PULL_EXISTS] >> - full_simp_tac(srw_ss())[] >> srw_tac[][] >> metis_tac[]) + full_simp_tac(srw_ss())[] >> srw_tac[][] >> metis_tac[] +QED -Theorem exp_rel_imp_ground - `∀z1 z2 V e1 e2. exp_rel z1 z2 V e1 e2 ⇒ - ∀n. (∀k1 k2. k1 ≤ n ⇒ (V k1 k2 ⇔ (k1 = k2))) ∧ ground n e1 ⇒ ground n e2` - (ho_match_mp_tac exp_rel_ind >> +Theorem exp_rel_imp_ground: + ∀z1 z2 V e1 e2. exp_rel z1 z2 V e1 e2 ⇒ + ∀n. (∀k1 k2. k1 ≤ n ⇒ (V k1 k2 ⇔ (k1 = k2))) ∧ ground n e1 ⇒ ground n e2 +Proof + ho_match_mp_tac exp_rel_ind >> simp[] >> srw_tac[][] >> TRY ( first_x_assum match_mp_tac >> @@ -1996,29 +2131,35 @@ Theorem exp_rel_imp_ground full_simp_tac(srw_ss())[MEM_ZIP,PULL_EXISTS] >> rev_full_simp_tac(srw_ss())[MEM_EL,PULL_EXISTS] >> full_simp_tac(srw_ss())[arithmeticTheory.LESS_OR_EQ] >> - res_tac >> srw_tac[][]) - -Theorem bindn_0 - `∀V. bindn 0 V = V` - (srw_tac[][bindn_def]) + res_tac >> srw_tac[][] +QED + +Theorem bindn_0: + ∀V. bindn 0 V = V +Proof + srw_tac[][bindn_def] +QED val _ = export_rewrites["bindn_0"] -Theorem bind_bindn - `(bind (bindn n V) = bindn (SUC n) V) ∧ - (bindn n (bind V) = bindn (SUC n) V)` - (conj_tac >- simp[bindn_def,arithmeticTheory.FUNPOW_SUC] >> - simp[bindn_def,arithmeticTheory.FUNPOW]) +Theorem bind_bindn: + (bind (bindn n V) = bindn (SUC n) V) ∧ + (bindn n (bind V) = bindn (SUC n) V) +Proof + conj_tac >- simp[bindn_def,arithmeticTheory.FUNPOW_SUC] >> + simp[bindn_def,arithmeticTheory.FUNPOW] +QED val _ = export_rewrites["bind_bindn"] -Theorem exp_rel_unbind - `∀z1 z2 V e1 e2. exp_rel z1 z2 V e1 e2 ⇒ +Theorem exp_rel_unbind: + ∀z1 z2 V e1 e2. exp_rel z1 z2 V e1 e2 ⇒ ∀k n m U. V = bindn n U ∧ n ≤ z1 ∧ n ≤ z2 ∧ ground k e1 ∧ ground k e2 ∧ k ≤ n-m ∧ m ≤ n ⇒ - exp_rel (z1-m) (z2-m) (bindn (n-m) U) e1 e2` - (ho_match_mp_tac exp_rel_ind >> + exp_rel (z1-m) (z2-m) (bindn (n-m) U) e1 e2 +Proof + ho_match_mp_tac exp_rel_ind >> simp[] >> srw_tac[][] >> simp[Once exp_rel_cases] >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> @@ -2037,12 +2178,14 @@ Theorem exp_rel_unbind rev_full_simp_tac(srw_ss())[MEM_EL,PULL_EXISTS] >> metis_tac[]) >> qpat_x_assum`bindn n _ k1 k2`mp_tac >> - simp[bindn_thm] >> srw_tac[][]) - -Theorem exp_rel_sLet - `exp_rel z1 z2 V (Let t e1 e2) (Let t f1 f2) ⇒ - exp_rel z1 z2 V (sLet t e1 e2) (sLet t f1 f2)` - (simp[Once exp_rel_cases] \\ strip_tac \\ + simp[bindn_thm] >> srw_tac[][] +QED + +Theorem exp_rel_sLet: + exp_rel z1 z2 V (Let t e1 e2) (Let t f1 f2) ⇒ + exp_rel z1 z2 V (sLet t e1 e2) (sLet t f1 f2) +Proof + simp[Once exp_rel_cases] \\ strip_tac \\ Cases_on`∃t. e2 = Var_local t 0` >- ( pop_assum strip_assume_tac \\ qhdtm_x_assum`exp_rel`mp_tac \\ @@ -2082,49 +2225,59 @@ Theorem exp_rel_sLet asm_exists_tac \\ simp[] \\ simp[bind_thm,relationTheory.inv_DEF] ) \\ fs[] \\ - simp[Once exp_rel_cases]); - -Theorem ground_sIf - `ground n (If t e1 e2 e3) ⇒ - ground n (sIf t e1 e2 e3)` - (srw_tac[][sIf_def] >> + simp[Once exp_rel_cases] +QED + +Theorem ground_sIf: + ground n (If t e1 e2 e3) ⇒ + ground n (sIf t e1 e2 e3) +Proof + srw_tac[][sIf_def] >> Cases_on`e1`>> full_simp_tac(srw_ss())[] >> BasicProvers.CASE_TAC >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> - BasicProvers.CASE_TAC >> full_simp_tac(srw_ss())[] >> srw_tac[][] ) - -Theorem ground_inc - `(∀e n. ground n e ⇒ ∀m. n ≤ m ⇒ ground m e) ∧ - (∀es n. ground_list n es ⇒ ∀m. n ≤ m ⇒ ground_list m es)` - (ho_match_mp_tac(TypeBase.induction_of(``:patLang$exp``)) >> + BasicProvers.CASE_TAC >> full_simp_tac(srw_ss())[] >> srw_tac[][] +QED + +Theorem ground_inc: + (∀e n. ground n e ⇒ ∀m. n ≤ m ⇒ ground m e) ∧ + (∀es n. ground_list n es ⇒ ∀m. n ≤ m ⇒ ground_list m es) +Proof + ho_match_mp_tac(TypeBase.induction_of(``:patLang$exp``)) >> simp[] >> srw_tac[][] >> first_x_assum (match_mp_tac o MP_CANON) >> - metis_tac[arithmeticTheory.LE_ADD_RCANCEL]) - -Theorem ground_sLet - `ground n (Let t e1 e2) ⇒ - ground n (sLet t e1 e2)` - (simp[sLet_def] \\ strip_tac \\ + metis_tac[arithmeticTheory.LE_ADD_RCANCEL] +QED + +Theorem ground_sLet: + ground n (Let t e1 e2) ⇒ + ground n (sLet t e1 e2) +Proof + simp[sLet_def] \\ strip_tac \\ Cases_on`∃t. e2 = Var_local t 0` >- fs[] \\ qsuff_tac`ground n (if ground 0 e2 then if pure e1 then e2 else Seq t e1 e2 else Let t e1 e2)` >- ( Cases_on`e2` \\ fs[] \\ CASE_TAC \\ fs[] ) \\ rw[] \\ match_mp_tac(MP_CANON(CONJUNCT1 ground_inc))>> - qexists_tac`0`>>simp[]) + qexists_tac`0`>>simp[] +QED -Theorem ground_Let_Els - `∀k m n t e. +Theorem ground_Let_Els: + ∀k m n t e. ground (n+k) e ∧ m < n ⇒ - ground n (Let_Els t m k e)` - (Induct >> simp[Let_Els_def] >> + ground n (Let_Els t m k e) +Proof + Induct >> simp[Let_Els_def] >> srw_tac[][] >> match_mp_tac ground_sLet >> simp[] >> first_x_assum match_mp_tac >> - fsrw_tac[ARITH_ss][arithmeticTheory.ADD1]) + fsrw_tac[ARITH_ss][arithmeticTheory.ADD1] +QED -Theorem compile_pat_ground - `(∀t p. ground 1 (compile_pat t p)) ∧ - (∀t n ps. ground (n + LENGTH ps) (compile_pats t n ps))` - (ho_match_mp_tac compile_pat_ind >> +Theorem compile_pat_ground: + (∀t p. ground 1 (compile_pat t p)) ∧ + (∀t n ps. ground (n + LENGTH ps) (compile_pats t n ps)) +Proof + ho_match_mp_tac compile_pat_ind >> simp[compile_pat_def] >> strip_tac >- ( rpt gen_tac >> strip_tac >> @@ -2144,23 +2297,26 @@ Theorem compile_pat_ground fsrw_tac[ARITH_ss][arithmeticTheory.ADD1] >> match_mp_tac ground_sLet >> simp[] >> match_mp_tac (MP_CANON(CONJUNCT1 ground_inc)) >> - HINT_EXISTS_TAC >> simp[]) + HINT_EXISTS_TAC >> simp[] +QED -Theorem ground_exp_rel_refl - `(∀e n. ground n e ⇒ +Theorem ground_exp_rel_refl: + (∀e n. ground n e ⇒ ∀z1 z2 V. n ≤ z1 ∧ n ≤ z2 ⇒ exp_rel z1 z2 (bindn n V) e e) ∧ (∀es n. ground_list n es ⇒ - ∀z1 z2 V. n ≤ z1 ∧ n ≤ z2 ⇒ EVERY2 (exp_rel z1 z2 (bindn n V)) es es)` - (ho_match_mp_tac(TypeBase.induction_of(``:patLang$exp``)) >> + ∀z1 z2 V. n ≤ z1 ∧ n ≤ z2 ⇒ EVERY2 (exp_rel z1 z2 (bindn n V)) es es) +Proof + ho_match_mp_tac(TypeBase.induction_of(``:patLang$exp``)) >> simp[] >> srw_tac[][] >> simp[Once exp_rel_cases] >> TRY ( first_x_assum (match_mp_tac o MP_CANON) >> simp[arithmeticTheory.ADD1] >> NO_TAC) >> - simp[bindn_thm]) + simp[bindn_thm] +QED -Theorem compile_row_acc - `(∀t Nbvs p bvs1 N. Nbvs = N::bvs1 ⇒ +Theorem compile_row_acc: + (∀t Nbvs p bvs1 N. Nbvs = N::bvs1 ⇒ ∀bvs2 r1 n1 f1 r2 n2 f2. compile_row t (N::bvs1) p = (r1,n1,f1) ∧ compile_row t (N::bvs2) p = (r2,n2,f2) ⇒ @@ -2176,8 +2332,9 @@ Theorem compile_row_acc n1 = n2 ∧ f1 = f2 ∧ ∃ls. r1 = ls ++ bvsk ++ (N::bvs1) ∧ r2 = ls ++ bvsk ++ (N::bvs2) ∧ - LENGTH ls = n1)` - (ho_match_mp_tac compile_row_ind >> + LENGTH ls = n1) +Proof + ho_match_mp_tac compile_row_ind >> strip_tac >- ( rpt gen_tac >> strip_tac >> full_simp_tac(srw_ss())[] >> rpt BasicProvers.VAR_EQ_TAC >> @@ -2256,10 +2413,11 @@ Theorem compile_row_acc simp_tac (std_ss++listSimps.LIST_ss++ARITH_ss) [arithmeticTheory.ADD1] >> ntac 3 strip_tac >> rpt BasicProvers.VAR_EQ_TAC >> - simp[]) + simp[] +QED -Theorem compile_row_shift - `(∀t bvs p bvs1 n1 f z1 z2 V e1 e2. +Theorem compile_row_shift: + (∀t bvs p bvs1 n1 f z1 z2 V e1 e2. compile_row t bvs p = (bvs1,n1,f) ∧ 0 < z1 ∧ 0 < z2 ∧ V 0 0 ∧ bvs ≠ [] ∧ exp_rel (z1 + n1) (z2 + n1) (bindn n1 V) e1 e2 ⇒ @@ -2269,8 +2427,9 @@ Theorem compile_row_shift n < z1 ∧ n < z2 ∧ V n n ∧ exp_rel (z1 + n1) (z2 + n1) (bindn (n1) V) e1 e2 ⇒ - exp_rel z1 z2 V (f e1) (f e2))` - (ho_match_mp_tac compile_row_ind >> + exp_rel z1 z2 V (f e1) (f e2)) +Proof + ho_match_mp_tac compile_row_ind >> simp[compile_row_def] >> strip_tac >- ( rpt gen_tac >> strip_tac >> @@ -2312,10 +2471,11 @@ Theorem compile_row_shift strip_tac >> Cases_on`bvs0`>>full_simp_tac(srw_ss())[] >> conj_tac >- simp[bindn_thm,arithmeticTheory.ADD1] >> full_simp_tac(srw_ss())[bindn_def,GSYM arithmeticTheory.FUNPOW_ADD,arithmeticTheory.ADD1] >> - fsrw_tac[ARITH_ss][]) + fsrw_tac[ARITH_ss][] +QED -Theorem compile_exp_shift - `(∀bvs1 e z1 z2 bvs2 V. +Theorem compile_exp_shift: + (∀bvs1 e z1 z2 bvs2 V. (set (FILTER IS_SOME bvs1) = set (FILTER IS_SOME bvs2)) ∧ (z1 = LENGTH bvs1) ∧ (z2 = LENGTH bvs2) ∧ (bvs_V bvs1 bvs2 V) ⇒ @@ -2338,8 +2498,9 @@ Theorem compile_exp_shift (set (FILTER IS_SOME bvs1) = set (FILTER IS_SOME bvs2)) ∧ (z1 = SUC(LENGTH bvs1)) ∧ (z2 = SUC(LENGTH bvs2)) ∧ (bvs_V bvs1 bvs2 V) ⇒ - exp_rel z1 z2 (bind V) (compile_pes t (NONE::bvs1) pes) (compile_pes t (NONE::bvs2) pes))` - (ho_match_mp_tac compile_exp_ind >> + exp_rel z1 z2 (bind V) (compile_pes t (NONE::bvs1) pes) (compile_pes t (NONE::bvs2) pes)) +Proof + ho_match_mp_tac compile_exp_ind >> strip_tac >- ( srw_tac[][] >> simp[Once exp_rel_cases] ) >> strip_tac >- ( srw_tac[][] >> simp[Once exp_rel_cases] >> @@ -2473,7 +2634,8 @@ Theorem compile_exp_shift simp[arithmeticTheory.ADD1] >> disch_then match_mp_tac >> simp[bind_thm] >> fsrw_tac[ARITH_ss][arithmeticTheory.ADD1]) >> - srw_tac[][]) + srw_tac[][] +QED val lookup_find_index_SOME = Q.prove( `∀env. ALOOKUP env n = SOME v ⇒ @@ -2502,8 +2664,8 @@ val compile_env_aux = Q.prove ( `EVERY NoRun_v (MAP (compile_v o SND) env)`, rw [EVERY_MAP] \\ fs [compile_v_NoRun_v]); -Theorem compile_exp_evaluate - `(∀env ^s exps ress. flatSem$evaluate env s exps = ress ⇒ +Theorem compile_exp_evaluate: + (∀env ^s exps ress. flatSem$evaluate env s exps = ress ⇒ ¬env.check_ctor ∧ env.exh_pat ∧ (SND ress ≠ Rerr (Rabort Rtype_error)) ⇒ ∃ress4. @@ -2522,8 +2684,9 @@ Theorem compile_exp_evaluate (compile_state co cc s) [compile_pes t (NONE::(MAP (SOME o FST) env.v)) pes] = res4 ∧ state_rel (compile_state co cc (FST res)) (FST res4) ∧ - result_rel (LIST_REL v_rel) v_rel (map_result (MAP compile_v) compile_v (SND res)) (SND res4))` - (ho_match_mp_tac flatSemTheory.evaluate_ind >> + result_rel (LIST_REL v_rel) v_rel (map_result (MAP compile_v) compile_v (SND res)) (SND res4)) +Proof + ho_match_mp_tac flatSemTheory.evaluate_ind >> (* nil *) strip_tac >- ( srw_tac[][evaluate_flat_def] >> simp[patSemTheory.evaluate_def] ) >> (* cons *) @@ -2964,18 +3127,20 @@ Theorem compile_exp_evaluate strip_tac >> full_simp_tac(srw_ss())[] >> rpt var_eq_tac >> pop_assum kall_tac >> simp[patSemTheory.do_if_def] >> first_x_assum(qspec_then`t§4`strip_assume_tac) \\ - spose_not_then strip_assume_tac >> full_simp_tac(srw_ss())[])) + spose_not_then strip_assume_tac >> full_simp_tac(srw_ss())[]) +QED -Theorem compile_evaluate_decs - `flatSem$evaluate_decs env ^s prog = res ∧ ¬env.check_ctor ∧ env.exh_pat ∧ +Theorem compile_evaluate_decs: + flatSem$evaluate_decs env ^s prog = res ∧ ¬env.check_ctor ∧ env.exh_pat ∧ SND (SND res) ≠ SOME (Rabort Rtype_error) ⇒ ∃res4. patSem$evaluate [] (compile_state co cc ^s) (compile prog) = res4 ∧ state_rel (compile_state co cc (FST res)) (FST res4) ∧ OPTREL (exc_rel v_rel) (OPTION_MAP (map_error_result compile_v) (SND (SND res))) - (case (SND res4) of Rval _ => NONE | Rerr e => SOME e)` - (map_every qid_spec_tac[`res`,`env`,`s`] + (case (SND res4) of Rval _ => NONE | Rerr e => SOME e) +Proof + map_every qid_spec_tac[`res`,`env`,`s`] \\ Induct_on`prog` >- ( rw[flatSemTheory.evaluate_decs_def, compile_def] @@ -3054,16 +3219,18 @@ Theorem compile_evaluate_decs >- metis_tac[state_rel_trans] \\ strip_tac \\ fs[] \\ rveq - \\ metis_tac[state_rel_trans, exc_rel_v_rel_trans]); + \\ metis_tac[state_rel_trans, exc_rel_v_rel_trans] +QED -Theorem compile_semantics - `semantics T F (ffi:'ffi ffi$ffi_state) es ≠ Fail ⇒ +Theorem compile_semantics: + semantics T F (ffi:'ffi ffi$ffi_state) es ≠ Fail ⇒ semantics [] (compile_state co cc (initial_state ffi k0)) (compile es) = - semantics T F ffi es` - (simp[flatSemTheory.semantics_def] >> + semantics T F ffi es +Proof + simp[flatSemTheory.semantics_def] >> IF_CASES_TAC >> fs[] >> DEEP_INTRO_TAC some_intro >> simp[] >> conj_tac >- ( @@ -3160,7 +3327,8 @@ Theorem compile_semantics rpt (AP_TERM_TAC ORELSE AP_THM_TAC) >> specl_args_of_then``flatSem$evaluate_decs``(Q.GENL[`env`,`s`,`prog`,`res`]compile_evaluate_decs) mp_tac >> simp[state_rel_def,compile_state_def,flatSemTheory.initial_state_def] \\ - impl_tac >- EVAL_TAC \\ simp[]) + impl_tac >- EVAL_TAC \\ simp[] +QED val set_globals_let_els = Q.prove(` ∀t n m e. @@ -3170,26 +3338,34 @@ val set_globals_let_els = Q.prove(` CASE_TAC \\ fs[op_gbag_def] \\ last_x_assum sym_sub_tac>>fs[]) -Theorem set_globals_sIf_sub - `set_globals (sIf t e1 e2 e3) ≤ set_globals (If t e1 e2 e3)` - (rw[sIf_def,SUB_BAG_UNION] \\ +Theorem set_globals_sIf_sub: + set_globals (sIf t e1 e2 e3) ≤ set_globals (If t e1 e2 e3) +Proof + rw[sIf_def,SUB_BAG_UNION] \\ CASE_TAC \\ fs[] \\ CASE_TAC \\ fs[] \\ - CASE_TAC \\ fs[]); - -Theorem set_globals_sIf_empty_suff - `set_globals (If t e1 e2 e3) = {||} ⇒ set_globals (sIf t e1 e2 e3) = {||}` - (metis_tac[set_globals_sIf_sub,SUB_BAG_EMPTY]); - -Theorem set_globals_sLet_sub - `set_globals (sLet t e1 e2) ≤ set_globals (Let t e1 e2)` - (rw[sLet_def] \\ + CASE_TAC \\ fs[] +QED + +Theorem set_globals_sIf_empty_suff: + set_globals (If t e1 e2 e3) = {||} ⇒ set_globals (sIf t e1 e2 e3) = {||} +Proof + metis_tac[set_globals_sIf_sub,SUB_BAG_EMPTY] +QED + +Theorem set_globals_sLet_sub: + set_globals (sLet t e1 e2) ≤ set_globals (Let t e1 e2) +Proof + rw[sLet_def] \\ CASE_TAC \\ fs[] \\ - CASE_TAC \\ fs[]); + CASE_TAC \\ fs[] +QED -Theorem set_globals_sLet_empty_suff - `set_globals (Let t e1 e2) = {||} ⇒ set_globals (sLet t e1 e2) = {||}` - (metis_tac[set_globals_sLet_sub,SUB_BAG_EMPTY]); +Theorem set_globals_sLet_empty_suff: + set_globals (Let t e1 e2) = {||} ⇒ set_globals (sLet t e1 e2) = {||} +Proof + metis_tac[set_globals_sLet_sub,SUB_BAG_EMPTY] +QED val compile_pat_empty = Q.prove(` (∀t p. set_globals (compile_pat t p) = {||}) ∧ @@ -3223,16 +3399,17 @@ val sLet_set_globals_lemma = MATCH_MP (REWRITE_RULE [GSYM AND_IMP_INTRO] SUB_BAG_TRANS) set_globals_sLet_sub; -Theorem set_globals_eq - `(!bvs exp. set_globals (compile_exp bvs exp) ≤ set_globals exp) /\ +Theorem set_globals_eq: + (!bvs exp. set_globals (compile_exp bvs exp) ≤ set_globals exp) /\ (!bvs exps. elist_globals (compile_exps bvs exps) ≤ elist_globals exps) /\ (!bvs funs. elist_globals (compile_funs bvs funs) ≤ elist_globals (MAP (SND o SND) funs)) /\ (!tra bvs pes. - set_globals (compile_pes tra bvs pes) ≤ elist_globals (MAP SND pes))` - (ho_match_mp_tac compile_exp_ind + set_globals (compile_pes tra bvs pes) ≤ elist_globals (MAP SND pes)) +Proof + ho_match_mp_tac compile_exp_ind \\ rw [compile_exp_def] \\ fs [SUB_BAG_UNION] >- (match_mp_tac sIf_set_globals_lemma \\ fs [SUB_BAG_UNION]) @@ -3249,7 +3426,8 @@ Theorem set_globals_eq \\ fs [SUB_BAG_UNION] \\ split_pair_case_tac \\ fs [] \\ fs [compile_pat_empty] - \\ imp_res_tac compile_row_set_globals \\ fs [SUB_BAG_UNION]); + \\ imp_res_tac compile_row_set_globals \\ fs [SUB_BAG_UNION] +QED val esgc_free_let_els = Q.prove(` ∀t n m e. @@ -3260,16 +3438,20 @@ val esgc_free_let_els = Q.prove(` CASE_TAC \\ fs[op_gbag_def] \\ last_x_assum sym_sub_tac>>fs[]) -Theorem esgc_free_sIf_sub - `esgc_free (If t e1 e2 e3) ⇒ esgc_free (sIf t e1 e2 e3)` - (rw[sIf_def,SUB_BAG_UNION] \\ - every_case_tac \\ fs[]); - -Theorem esgc_free_sLet_sub - `esgc_free (Let t e1 e2) ⇒ esgc_free (sLet t e1 e2)` - (rw[sLet_def] \\ +Theorem esgc_free_sIf_sub: + esgc_free (If t e1 e2 e3) ⇒ esgc_free (sIf t e1 e2 e3) +Proof + rw[sIf_def,SUB_BAG_UNION] \\ + every_case_tac \\ fs[] +QED + +Theorem esgc_free_sLet_sub: + esgc_free (Let t e1 e2) ⇒ esgc_free (sLet t e1 e2) +Proof + rw[sLet_def] \\ CASE_TAC \\ fs[] \\ - CASE_TAC \\ fs[]); + CASE_TAC \\ fs[] +QED val compile_pat_esgc_free = Q.prove(` (∀t p. esgc_free (compile_pat t p)) ∧ @@ -3295,8 +3477,8 @@ val compile_row_esgc_free = Q.prove(` rw[sLet_def] \\ CASE_TAC \\ fs[op_gbag_def] \\ CASE_TAC \\ fs[op_gbag_def]); -Theorem compile_exp_esgc_free - `(!bvs exp. +Theorem compile_exp_esgc_free: + (!bvs exp. esgc_free exp ==> esgc_free (compile_exp bvs exp)) /\ @@ -3311,8 +3493,9 @@ Theorem compile_exp_esgc_free (!tra bvs pes. EVERY esgc_free (MAP SND pes) ==> - esgc_free (compile_pes tra bvs pes))` - (ho_match_mp_tac compile_exp_ind + esgc_free (compile_pes tra bvs pes)) +Proof + ho_match_mp_tac compile_exp_ind \\ rw [compile_exp_def] \\ fs [esgc_free_sLet_sub, esgc_free_sIf_sub] >- (FULL_CASE_TAC \\ fs []) @@ -3329,30 +3512,37 @@ Theorem compile_exp_esgc_free \\ split_pair_case_tac \\ fs [] >- metis_tac [compile_row_esgc_free] \\ match_mp_tac esgc_free_sIf_sub \\ fs [] - \\ metis_tac [compile_row_esgc_free, compile_pat_esgc_free]); - -Theorem compile_esgc_free - `∀p. EVERY (esgc_free o dest_Dlet) (FILTER is_Dlet p) ⇒ - EVERY esgc_free (flat_to_pat$compile p)` - (recInduct flat_to_patTheory.compile_ind + \\ metis_tac [compile_row_esgc_free, compile_pat_esgc_free] +QED + +Theorem compile_esgc_free: + ∀p. EVERY (esgc_free o dest_Dlet) (FILTER is_Dlet p) ⇒ + EVERY esgc_free (flat_to_pat$compile p) +Proof + recInduct flat_to_patTheory.compile_ind \\ rw[flat_to_patTheory.compile_def] \\ irule (CONJUNCT1 compile_exp_esgc_free) - \\ rw[]); + \\ rw[] +QED -Theorem compile_distinct_setglobals - `∀e. BAG_ALL_DISTINCT (set_globals e) ⇒ - BAG_ALL_DISTINCT (set_globals (compile_exp [] e))` - (rw[]>> +Theorem compile_distinct_setglobals: + ∀e. BAG_ALL_DISTINCT (set_globals e) ⇒ + BAG_ALL_DISTINCT (set_globals (compile_exp [] e)) +Proof + rw[]>> match_mp_tac BAG_ALL_DISTINCT_SUB_BAG >> - HINT_EXISTS_TAC>>fs[set_globals_eq]) - -Theorem elist_globals_compile - `∀ls. - elist_globals (flat_to_pat$compile ls) ≤ elist_globals (MAP dest_Dlet (FILTER is_Dlet ls))` - (recInduct flat_to_patTheory.compile_ind + HINT_EXISTS_TAC>>fs[set_globals_eq] +QED + +Theorem elist_globals_compile: + ∀ls. + elist_globals (flat_to_pat$compile ls) ≤ elist_globals (MAP dest_Dlet (FILTER is_Dlet ls)) +Proof + recInduct flat_to_patTheory.compile_ind \\ rw[flat_to_patTheory.compile_def] \\ irule (List.nth(CONJUNCTS SUB_BAG_UNION, 6)) \\ rw[] - \\ rw[set_globals_eq]); + \\ rw[set_globals_eq] +QED val _ = export_theory() diff --git a/compiler/backend/proofs/flat_uncheck_ctorsProofScript.sml b/compiler/backend/proofs/flat_uncheck_ctorsProofScript.sml index ea666060a8..82dcda80f6 100644 --- a/compiler/backend/proofs/flat_uncheck_ctorsProofScript.sml +++ b/compiler/backend/proofs/flat_uncheck_ctorsProofScript.sml @@ -8,13 +8,15 @@ val _ = new_theory "flat_uncheck_ctorsProof"; val _ = set_grammar_ancestry ["misc","flatProps","flat_uncheck_ctors"]; -Theorem pat_bindings_compile_pat[simp] -`!(p:flatLang$pat) vars. pat_bindings (compile_pat p) vars = pat_bindings p vars` - (ho_match_mp_tac compile_pat_ind >> +Theorem pat_bindings_compile_pat[simp]: + !(p:flatLang$pat) vars. pat_bindings (compile_pat p) vars = pat_bindings p vars +Proof + ho_match_mp_tac compile_pat_ind >> simp [compile_pat_def, astTheory.pat_bindings_def, pat_bindings_def] >> induct_on `ps` >> rw [] >> - fs [pat_bindings_def,astTheory.pat_bindings_def, PULL_FORALL]); + fs [pat_bindings_def,astTheory.pat_bindings_def, PULL_FORALL] +QED val (v_rel_rules, v_rel_ind, v_rel_cases) = Hol_reln ` (!lit. @@ -83,9 +85,11 @@ val alookup_env_rel = Q.prove ( first_x_assum (qspec_then `env' with v := t'` mp_tac) >> rw [env_rel_cases]); -Theorem v_rel_bool[simp] - `!v b. v_rel (Boolv b) v ⇔ v = Boolv b` - (rw [Once v_rel_cases, Boolv_def, libTheory.the_def]); +Theorem v_rel_bool[simp]: + !v b. v_rel (Boolv b) v ⇔ v = Boolv b +Proof + rw [Once v_rel_cases, Boolv_def, libTheory.the_def] +QED val lemma = Q.prove ( `(\(x,y,z). x) = FST`, @@ -169,8 +173,8 @@ val s_rel_store_lookup = Q.prove ( fs [semanticPrimitivesPropsTheory.sv_rel_cases] >> fs []); -Theorem v_rel_eqn[simp] - `(!lit v. v_rel (flatSem$Litv lit) v ⇔ v = Litv lit) ∧ +Theorem v_rel_eqn[simp]: + (!lit v. v_rel (flatSem$Litv lit) v ⇔ v = Litv lit) ∧ (!lit v. v_rel v (flatSem$Litv lit) ⇔ v = Litv lit) ∧ (v_rel (Conv NONE []) (Conv (SOME (0,NONE)) [])) ∧ (v_rel subscript_exn_v subscript_exn_v) ∧ @@ -178,62 +182,74 @@ Theorem v_rel_eqn[simp] (!loc l. v_rel (Loc loc) l ⇔ l = Loc loc) ∧ (!loc l. v_rel l (Loc loc) ⇔ l = Loc loc) ∧ (!vs v. v_rel (Vectorv vs) v ⇔ ∃vs'. v = Vectorv vs' ∧ LIST_REL v_rel vs vs') ∧ - (!vs v. v_rel v (Vectorv vs) ⇔ ∃vs'. v = Vectorv vs' ∧ LIST_REL v_rel vs' vs)` - (rw [flatSemTheory.subscript_exn_v_def, flatSemTheory.bind_exn_v_def] >> + (!vs v. v_rel v (Vectorv vs) ⇔ ∃vs'. v = Vectorv vs' ∧ LIST_REL v_rel vs' vs) +Proof + rw [flatSemTheory.subscript_exn_v_def, flatSemTheory.bind_exn_v_def] >> ONCE_REWRITE_TAC [v_rel_cases] >> - rw [libTheory.the_def]); + rw [libTheory.the_def] +QED -Theorem do_eq_correct - `(∀a c b d e. +Theorem do_eq_correct: + (∀a c b d e. v_rel a b ∧ v_rel c d ∧ do_eq a c = Eq_val e ⇒ do_eq b d = Eq_val e) ∧ (∀a c b d e. LIST_REL v_rel a b ∧ LIST_REL v_rel c d ∧ do_eq_list a c = Eq_val e ⇒ - do_eq_list b d = Eq_val e)` - (ho_match_mp_tac do_eq_ind + do_eq_list b d = Eq_val e) +Proof + ho_match_mp_tac do_eq_ind \\ rw[do_eq_def] \\ fs[do_eq_def] \\ rw[] \\ imp_res_tac LIST_REL_LENGTH \\ fs[case_eq_thms, bool_case_eq] \\ rw[] \\ fs[] \\ fs[Once v_rel_cases, do_eq_def] \\ rw[] \\ Cases_on`cn1` \\ TRY(Cases_on`cn2`) \\ fs[libTheory.the_def, ctor_same_type_def] - \\ imp_res_tac LIST_REL_LENGTH \\ fs[] \\ rfs[]); + \\ imp_res_tac LIST_REL_LENGTH \\ fs[] \\ rfs[] +QED -Theorem v_to_char_list_v_rel - `∀x y ls. v_rel x y ∧ v_to_char_list x = SOME ls ⇒ v_to_char_list y = SOME ls` - (recInduct v_to_char_list_ind +Theorem v_to_char_list_v_rel: + ∀x y ls. v_rel x y ∧ v_to_char_list x = SOME ls ⇒ v_to_char_list y = SOME ls +Proof + recInduct v_to_char_list_ind \\ rw[v_to_char_list_def] >- fs[Once v_rel_cases, v_to_char_list_def, libTheory.the_def] \\ qhdtm_x_assum`v_rel`mp_tac \\ rw[Once v_rel_cases, v_to_char_list_def, libTheory.the_def] \\ rw[v_to_char_list_def] \\ fs[case_eq_thms] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem v_to_list_v_rel - `∀x y ls. v_rel x y ∧ v_to_list x = SOME ls ⇒ ∃ls'. v_to_list y = SOME ls' ∧ LIST_REL v_rel ls ls'` - (recInduct v_to_list_ind +Theorem v_to_list_v_rel: + ∀x y ls. v_rel x y ∧ v_to_list x = SOME ls ⇒ ∃ls'. v_to_list y = SOME ls' ∧ LIST_REL v_rel ls ls' +Proof + recInduct v_to_list_ind \\ rw[v_to_list_def] \\ qhdtm_x_assum`v_rel`mp_tac \\ rw[Once v_rel_cases, v_to_list_def, libTheory.the_def] \\ rw[ v_to_list_def] \\ fs[case_eq_thms] - \\ rw[PULL_EXISTS]); + \\ rw[PULL_EXISTS] +QED -Theorem vs_to_string_v_rel - `∀vs ws str. LIST_REL v_rel vs ws ∧ vs_to_string vs = SOME str ⇒ vs_to_string ws = SOME str` - (recInduct vs_to_string_ind +Theorem vs_to_string_v_rel: + ∀vs ws str. LIST_REL v_rel vs ws ∧ vs_to_string vs = SOME str ⇒ vs_to_string ws = SOME str +Proof + recInduct vs_to_string_ind \\ rw[vs_to_string_def] \\ rw[vs_to_string_def] - \\ fs[case_eq_thms] \\ rw[]); + \\ fs[case_eq_thms] \\ rw[] +QED -Theorem v_rel_list_to_v - `∀x y. LIST_REL v_rel x y ⇒ v_rel (list_to_v x) (list_to_v y)` - (Induct \\ rw[list_to_v_def] +Theorem v_rel_list_to_v: + ∀x y. LIST_REL v_rel x y ⇒ v_rel (list_to_v x) (list_to_v y) +Proof + Induct \\ rw[list_to_v_def] \\ rw[Once v_rel_cases, libTheory.the_def] - \\ fs[PULL_EXISTS, list_to_v_def]); + \\ fs[PULL_EXISTS, list_to_v_def] +QED val do_app_correct = Q.prove ( `∀s1 s1' s2 op vs vs' r. @@ -393,8 +409,8 @@ val do_app_correct = Q.prove ( \\ res_tac \\ fs[OPTREL_def] \\ rfs[] \\ rw[] \\ fs[])); -Theorem pmatch_correct - `(∀env1 refs1 p v1 acc1 env2 refs2 v2 acc2. +Theorem pmatch_correct: + (∀env1 refs1 p v1 acc1 env2 refs2 v2 acc2. env_rel env1 env2 ∧ LIST_REL (sv_rel v_rel) refs1 refs2 ∧ v_rel v1 v2 ∧ @@ -421,8 +437,9 @@ Theorem pmatch_correct pmatch_list env2 refs2 (MAP compile_pat p) v2 acc2 = Match res2 ∧ LIST_REL v_rel (MAP SND res1) (MAP SND res2) ∧ MAP FST res1 = MAP FST res2 - | r => pmatch_list env2 refs2 (MAP compile_pat p) v2 acc2 = r)` - (ho_match_mp_tac pmatch_ind + | r => pmatch_list env2 refs2 (MAP compile_pat p) v2 acc2 = r) +Proof + ho_match_mp_tac pmatch_ind \\ rw[pmatch_def, compile_pat_def, libTheory.the_def] \\ TRY ( qpat_x_assum`v_rel (Conv _ _) _`mp_tac @@ -462,7 +479,8 @@ Theorem pmatch_correct \\ TOP_CASE_TAC \\ fs[pmatch_def] \\ strip_tac \\ fs[] \\ TOP_CASE_TAC \\ fs[] - \\ res_tac \\ fs[] )); + \\ res_tac \\ fs[] ) +QED val compile_exp_correct = Q.prove ( `(∀env (s : 'a flatSem$state) es s' r s1 env'. @@ -717,19 +735,21 @@ val dec_res_rel_def = Define ` result_rel (LIST_REL v_rel) v_rel (Rerr r1) (Rerr r2)) /\ (dec_res_rel _ _ <=> F)`; -Theorem dec_res_rel_thms[simp] - `(!r. dec_res_rel NONE r <=> r = NONE) /\ +Theorem dec_res_rel_thms[simp]: + (!r. dec_res_rel NONE r <=> r = NONE) /\ (!r. dec_res_rel r NONE <=> r = NONE) /\ (!e r. dec_res_rel (SOME e) r <=> ?e1. r = SOME e1 /\ result_rel (LIST_REL v_rel) v_rel (Rerr e) (Rerr e1)) /\ (!e r. dec_res_rel r (SOME e) <=> ?e1. r = SOME e1 /\ - result_rel (LIST_REL v_rel) v_rel (Rerr e1) (Rerr e))` - (rw [] \\ Cases_on `r` \\ rw [dec_res_rel_def]); + result_rel (LIST_REL v_rel) v_rel (Rerr e1) (Rerr e)) +Proof + rw [] \\ Cases_on `r` \\ rw [dec_res_rel_def] +QED -Theorem compile_dec_correct - `∀env (s : 'a flatSem$state) d s' r s1 env'. +Theorem compile_dec_correct: + ∀env (s : 'a flatSem$state) d s' r s1 env'. evaluate_dec env s d = (s',c,r) ∧ r ≠ SOME (Rabort Rtype_error) ∧ env_rel env env' ∧ @@ -738,8 +758,9 @@ Theorem compile_dec_correct ?s1' r1. dec_res_rel r r1 ∧ s_rel s' s1' ∧ - evaluate_decs env' s1 (compile_decs [d]) = (s1', {}, r1)` - (Cases_on `d` >> + evaluate_decs env' s1 (compile_decs [d]) = (s1', {}, r1) +Proof + Cases_on `d` >> simp [evaluate_decs_def, evaluate_dec_def, compile_decs_def] >> rpt gen_tac >- ( @@ -765,14 +786,15 @@ Theorem compile_dec_correct fs [] >> rfs [libTheory.the_def]) >> rw [] >> - rw []); + rw [] +QED val lemma = Q.prove ( `!x. (x with c updated_by $UNION ∅) = x`, rw [environment_component_equality]); -Theorem compile_decs_correct - `∀env (s : 'a flatSem$state) ds s' r s1 env' c. +Theorem compile_decs_correct: + ∀env (s : 'a flatSem$state) ds s' r s1 env' c. evaluate_decs env s ds = (s',c,r) ∧ r ≠ SOME (Rabort Rtype_error) ∧ env_rel env env' ∧ @@ -781,8 +803,9 @@ Theorem compile_decs_correct ?s1' r1. dec_res_rel r r1 ∧ s_rel s' s1' ∧ - evaluate_decs env' s1 (compile_decs ds) = (s1', {}, r1)` - (Induct_on `ds` >> + evaluate_decs env' s1 (compile_decs ds) = (s1', {}, r1) +Proof + Induct_on `ds` >> rw [evaluate_decs_def, compile_decs_def] >> rw [] >> split_pair_case_tac >> @@ -822,14 +845,16 @@ Theorem compile_decs_correct Cases_on `h` >> fs [compile_decs_def, evaluate_decs_def] >> every_case_tac >> - fs [])); + fs []) +QED -Theorem compile_decs_eval_sim - `eval_sim +Theorem compile_decs_eval_sim: + eval_sim (ffi:'ffi ffi$ffi_state) T T ds1 T F (compile_decs ds1) - (\p1 p2. p2 = compile_decs p1) F` - (rw [eval_sim_def] + (\p1 p2. p2 = compile_decs p1) F +Proof + rw [eval_sim_def] \\ qexists_tac `0` \\ CONV_TAC (RESORT_EXISTS_CONV rev) \\ drule compile_decs_correct >> @@ -841,7 +866,8 @@ Theorem compile_decs_eval_sim >- fs [initial_env_def, env_rel_cases, initial_state_def, s_rel_cases] \\ rw [initial_env_def] >> rw [] >> - fs [s_rel_cases]) ; + fs [s_rel_cases] +QED ; val compile_decs_semantics = save_thm ("compile_decs_semantics", MATCH_MP (REWRITE_RULE [GSYM AND_IMP_INTRO] IMP_semantics_eq) @@ -851,9 +877,10 @@ val compile_decs_semantics = save_thm ("compile_decs_semantics", (* syntactic results *) -Theorem compile_elist_globals_eq_empty - `!es. elist_globals es = {||} ==> elist_globals (compile es) = {||}` - (ho_match_mp_tac compile_ind +Theorem compile_elist_globals_eq_empty: + !es. elist_globals es = {||} ==> elist_globals (compile es) = {||} +Proof + ho_match_mp_tac compile_ind \\ rw [compile_def] \\ TRY (rename1 `HD (compile [e])` @@ -871,16 +898,20 @@ Theorem compile_elist_globals_eq_empty \\ first_x_assum(fn th => mp_tac th \\ impl_tac >- METIS_TAC[]) \\ fsrw_tac [DNF_ss] [SUB_BAG_UNION] \\ rw [] \\ rename1 `HD (compile [e])` - \\ qspec_then `e` assume_tac compile_sing \\ fs [] \\ fs []); - -Theorem compile_set_globals_eq_empty - `set_globals e = {||} ==> set_globals (HD (compile [e])) = {||}` - (qspec_then`[e]`mp_tac compile_elist_globals_eq_empty - \\ rw[] \\ fs[] \\ Cases_on `compile [e]` \\ fs []); - -Theorem compile_esgc_free - `!es. EVERY esgc_free es ==> EVERY esgc_free (compile es)` - (ho_match_mp_tac compile_ind + \\ qspec_then `e` assume_tac compile_sing \\ fs [] \\ fs [] +QED + +Theorem compile_set_globals_eq_empty: + set_globals e = {||} ==> set_globals (HD (compile [e])) = {||} +Proof + qspec_then`[e]`mp_tac compile_elist_globals_eq_empty + \\ rw[] \\ fs[] \\ Cases_on `compile [e]` \\ fs [] +QED + +Theorem compile_esgc_free: + !es. EVERY esgc_free es ==> EVERY esgc_free (compile es) +Proof + ho_match_mp_tac compile_ind \\ rw [compile_def] \\ fs [compile_set_globals_eq_empty] \\ TRY @@ -894,20 +925,24 @@ Theorem compile_esgc_free \\ res_tac ) \\ rename1 `HD (compile [p])` \\ qspec_then `p` assume_tac compile_sing \\ fs [] \\ fs [] - \\ res_tac \\ fs []); - -Theorem compile_decs_esgc_free - `∀ds. EVERY esgc_free (MAP dest_Dlet (FILTER is_Dlet ds)) ⇒ - EVERY esgc_free (MAP dest_Dlet (FILTER is_Dlet (flat_uncheck_ctors$compile_decs ds)))` - (Induct \\ simp[flat_uncheck_ctorsTheory.compile_decs_def] + \\ res_tac \\ fs [] +QED + +Theorem compile_decs_esgc_free: + ∀ds. EVERY esgc_free (MAP dest_Dlet (FILTER is_Dlet ds)) ⇒ + EVERY esgc_free (MAP dest_Dlet (FILTER is_Dlet (flat_uncheck_ctors$compile_decs ds))) +Proof + Induct \\ simp[flat_uncheck_ctorsTheory.compile_decs_def] \\ Cases \\ simp[] \\ rw[] \\ fs[flat_uncheck_ctorsTheory.compile_decs_def] \\ qspec_then`[e]`mp_tac compile_esgc_free \\ strip_assume_tac (SPEC_ALL flat_uncheck_ctorsTheory.compile_sing) - \\ rw[]); + \\ rw[] +QED -Theorem compile_sub_bag - `!es. (elist_globals (compile es)) ≤ (elist_globals es)` - (ho_match_mp_tac compile_ind +Theorem compile_sub_bag: + !es. (elist_globals (compile es)) ≤ (elist_globals es) +Proof + ho_match_mp_tac compile_ind \\ rw [compile_def] \\ TRY (rename1 `compile [e]` @@ -930,27 +965,34 @@ Theorem compile_sub_bag \\ fsrw_tac [DNF_ss] [SUB_BAG_UNION] \\ rw [] \\ rename1 `HD (compile [e])` \\ qspec_then `e` assume_tac compile_sing \\ fs [] \\ fs [] - \\ fsrw_tac [DNF_ss] [SUB_BAG_UNION]); + \\ fsrw_tac [DNF_ss] [SUB_BAG_UNION] +QED -Theorem compile_distinct_globals - `BAG_ALL_DISTINCT (elist_globals es) +Theorem compile_distinct_globals: + BAG_ALL_DISTINCT (elist_globals es) ==> - BAG_ALL_DISTINCT (elist_globals (compile es))` - (metis_tac [compile_sub_bag, BAG_ALL_DISTINCT_SUB_BAG]); - -Theorem compile_decs_sub_bag - `(elist_globals (MAP dest_Dlet (FILTER is_Dlet (flat_uncheck_ctors$compile_decs ds)))) ≤ (elist_globals (MAP dest_Dlet (FILTER is_Dlet ds)))` - (Induct_on`ds` \\ rw [flat_uncheck_ctorsTheory.compile_decs_def] + BAG_ALL_DISTINCT (elist_globals (compile es)) +Proof + metis_tac [compile_sub_bag, BAG_ALL_DISTINCT_SUB_BAG] +QED + +Theorem compile_decs_sub_bag: + (elist_globals (MAP dest_Dlet (FILTER is_Dlet (flat_uncheck_ctors$compile_decs ds)))) ≤ (elist_globals (MAP dest_Dlet (FILTER is_Dlet ds))) +Proof + Induct_on`ds` \\ rw [flat_uncheck_ctorsTheory.compile_decs_def] \\ fs [UNCURRY] \\ rw [] \\ Cases_on `h` \\ fs [flat_uncheck_ctorsTheory.compile_decs_def] \\ qspec_then `e` assume_tac flat_uncheck_ctorsTheory.compile_sing \\ fs [] \\ `elist_globals [e2] <= elist_globals [e]` by metis_tac [compile_sub_bag] - \\ fs [SUB_BAG_UNION]); - -Theorem compile_decs_distinct_globals - `BAG_ALL_DISTINCT (elist_globals (MAP dest_Dlet (FILTER is_Dlet ds))) ⇒ - BAG_ALL_DISTINCT (elist_globals (MAP dest_Dlet (FILTER is_Dlet (flat_uncheck_ctors$compile_decs ds))))` - (metis_tac [compile_decs_sub_bag, BAG_ALL_DISTINCT_SUB_BAG]); + \\ fs [SUB_BAG_UNION] +QED + +Theorem compile_decs_distinct_globals: + BAG_ALL_DISTINCT (elist_globals (MAP dest_Dlet (FILTER is_Dlet ds))) ⇒ + BAG_ALL_DISTINCT (elist_globals (MAP dest_Dlet (FILTER is_Dlet (flat_uncheck_ctors$compile_decs ds)))) +Proof + metis_tac [compile_decs_sub_bag, BAG_ALL_DISTINCT_SUB_BAG] +QED val _ = export_theory (); diff --git a/compiler/backend/proofs/lab_filterProofScript.sml b/compiler/backend/proofs/lab_filterProofScript.sml index 06c476e2c7..0a724f3dfb 100644 --- a/compiler/backend/proofs/lab_filterProofScript.sml +++ b/compiler/backend/proofs/lab_filterProofScript.sml @@ -522,13 +522,14 @@ val upd_pc_tac = full_simp_tac(srw_ss())[]>>rev_full_simp_tac(srw_ss())[]>> metis_tac[arithmeticTheory.ADD_COMM,arithmeticTheory.ADD_ASSOC]; -Theorem filter_correct - `!(s1:('a,'c,'ffi) labSem$state) t1 res s2. +Theorem filter_correct: + !(s1:('a,'c,'ffi) labSem$state) t1 res s2. (evaluate s1 = (res,s2)) /\ state_rel s1 t1 /\ ~t1.failed ==> ?k t2. (evaluate (t1 with clock := s1.clock + k) = (res,t2)) /\ - (s2.ffi = t2.ffi)` - (ho_match_mp_tac evaluate_ind>>srw_tac[][]>> + (s2.ffi = t2.ffi) +Proof + ho_match_mp_tac evaluate_ind>>srw_tac[][]>> qpat_x_assum`evaluate s1 = _` mp_tac>> simp[Once evaluate_def]>> IF_CASES_TAC>- @@ -845,7 +846,8 @@ Theorem filter_correct metis_tac[ADD_ASSOC]) >> EVERY_CASE_TAC>>full_simp_tac(srw_ss())[]>>srw_tac[][]>> - same_inst_tac); + same_inst_tac +QED val state_rel_IMP_sem_EQ_sem = Q.prove( `!s t. state_rel s t ==> semantics s = semantics t`, @@ -960,8 +962,8 @@ val state_rel_IMP_sem_EQ_sem = Q.prove( qexists_tac`k+k'`>>simp[EL_APPEND1] ) >> metis_tac[build_lprefix_lub_thm,unique_lprefix_lub,lprefix_lub_new_chain])); -Theorem filter_skip_semantics - `!s t. (t.pc = 0) ∧ ¬t.failed /\ +Theorem filter_skip_semantics: + !s t. (t.pc = 0) ∧ ¬t.failed /\ (∃scompile. s = t with <| code := filter_skip t.code ; compile_oracle := (λ(a,b).(a,filter_skip b)) o t.compile_oracle; @@ -969,20 +971,24 @@ Theorem filter_skip_semantics |> ∧ t.compile = λc p. scompile c (filter_skip p)) ∧ ¬t.failed ==> - semantics s = semantics t` - (srw_tac[][] \\ match_mp_tac state_rel_IMP_sem_EQ_sem - \\ full_simp_tac(srw_ss())[state_rel_def,state_component_equality,Once adjust_pc_def,o_DEF]); + semantics s = semantics t +Proof + srw_tac[][] \\ match_mp_tac state_rel_IMP_sem_EQ_sem + \\ full_simp_tac(srw_ss())[state_rel_def,state_component_equality,Once adjust_pc_def,o_DEF] +QED -Theorem sec_ends_with_label_filter_skip - `∀code. +Theorem sec_ends_with_label_filter_skip: + ∀code. EVERY sec_ends_with_label code ⇒ - EVERY sec_ends_with_label (filter_skip code)` - (Induct \\ simp[filter_skip_def] + EVERY sec_ends_with_label (filter_skip code) +Proof + Induct \\ simp[filter_skip_def] \\ Cases \\ fs[filter_skip_def,sec_ends_with_label_def] \\ Induct_on`l` \\ fs[NULL_EQ] \\ Cases \\ fs[LAST_CONS_cond,not_skip_def] \\ TOP_CASE_TAC \\ fs[] \\ TOP_CASE_TAC \\ fs[] - \\ fs[LAST_CONS_cond]); + \\ fs[LAST_CONS_cond] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/lab_to_targetProofScript.sml b/compiler/backend/proofs/lab_to_targetProofScript.sml index 3e8f97a575..fa72ae497a 100644 --- a/compiler/backend/proofs/lab_to_targetProofScript.sml +++ b/compiler/backend/proofs/lab_to_targetProofScript.sml @@ -33,16 +33,18 @@ val sec_loc_to_pc_def = Define` val sec_loc_to_pc_ind = theorem"sec_loc_to_pc_ind" -Theorem sec_loc_to_pc_cons - `sec_loc_to_pc n2 (l::lines) = +Theorem sec_loc_to_pc_cons: + sec_loc_to_pc n2 (l::lines) = if n2 = 0 ∨ (∃n1 k. l = Label n1 n2 k)then SOME 0 - else OPTION_MAP (if is_Label l then I else SUC) (sec_loc_to_pc n2 lines)` - (rw[Once sec_loc_to_pc_def] \\ fs[]); + else OPTION_MAP (if is_Label l then I else SUC) (sec_loc_to_pc n2 lines) +Proof + rw[Once sec_loc_to_pc_def] \\ fs[] +QED val _ = temp_overload_on("len_no_lab",``λxs. LENGTH (FILTER ($~ o is_Label) xs)``) -Theorem loc_to_pc_thm - `∀n1 n2 ls. +Theorem loc_to_pc_thm: + ∀n1 n2 ls. EVERY sec_labels_ok ls ⇒ loc_to_pc n1 n2 ls = case ls of [] => NONE @@ -51,8 +53,9 @@ Theorem loc_to_pc_thm case sec_loc_to_pc n2 xs of | NONE => OPTION_MAP ($+ (LENGTH (FILTER ($~ o is_Label) xs))) (loc_to_pc n1 n2 ys) | x => x - else OPTION_MAP ($+ (LENGTH (FILTER ($~ o is_Label) xs))) (loc_to_pc n1 n2 ys)` - (ho_match_mp_tac loc_to_pc_ind + else OPTION_MAP ($+ (LENGTH (FILTER ($~ o is_Label) xs))) (loc_to_pc n1 n2 ys) +Proof + ho_match_mp_tac loc_to_pc_ind \\ rw[] >- rw[Once loc_to_pc_def] >- ( @@ -73,7 +76,8 @@ Theorem loc_to_pc_thm \\ simp[] \\ `¬(∃k. h = Label n1 n2 k)` by (CCONTR_TAC \\ fs[] \\ fs[]) \\ simp[] \\ rfs[] - \\ Cases_on`loc_to_pc n1 n2 ls` \\ fs[]); + \\ Cases_on`loc_to_pc n1 n2 ls` \\ fs[] +QED (* -- *) @@ -125,10 +129,12 @@ val upd_pc_with_pc = Q.prove( `upd_pc s1.pc s1 = s1:'a asm_state`, full_simp_tac(srw_ss())[asm_state_component_equality,upd_pc_def]); -Theorem shift_interfer_twice[simp] - `shift_interfer l' (shift_interfer l c) = - shift_interfer (l + l') c` - (full_simp_tac(srw_ss())[shift_interfer_def,shift_seq_def,AC ADD_COMM ADD_ASSOC]); +Theorem shift_interfer_twice[simp]: + shift_interfer l' (shift_interfer l c) = + shift_interfer (l + l') c +Proof + full_simp_tac(srw_ss())[shift_interfer_def,shift_seq_def,AC ADD_COMM ADD_ASSOC] +QED val evaluate_nop_steps = Q.prove( `!n s1 ms1 c. @@ -253,16 +259,20 @@ val lab_lookup_IMP = Q.prove( val labs_domain_def = Define` labs_domain labs = { (n1, n2) | lab_lookup n1 n2 labs ≠ NONE }`; -Theorem labs_domain_LN[simp] - `labs_domain LN = {}` - (EVAL_TAC \\ rw[lookup_def]); - -Theorem labs_domain_insert - `k ∉ domain labs ⇒ - labs_domain (insert k s labs) = IMAGE (λn2. (k,n2)) (domain s) ∪ labs_domain labs` - (rw[labs_domain_def,lab_lookup_def, lookup_insert, EXTENSION, EQ_IMP_THM] +Theorem labs_domain_LN[simp]: + labs_domain LN = {} +Proof + EVAL_TAC \\ rw[lookup_def] +QED + +Theorem labs_domain_insert: + k ∉ domain labs ⇒ + labs_domain (insert k s labs) = IMAGE (λn2. (k,n2)) (domain s) ∪ labs_domain labs +Proof + rw[labs_domain_def,lab_lookup_def, lookup_insert, EXTENSION, EQ_IMP_THM] \\ fs[case_eq_thms] \\ fs[domain_lookup] - \\ metis_tac[NOT_SOME_NONE,option_CASES]); + \\ metis_tac[NOT_SOME_NONE,option_CASES] +QED val has_odd_inst_def = Define ` (has_odd_inst [] = F) /\ @@ -287,45 +297,57 @@ val code_similar_def = Define ` val code_similar_ind = theorem "code_similar_ind"; -Theorem line_similar_sym - `line_similar l1 l2 ⇒ line_similar l2 l1` - (Cases_on`l1`>>Cases_on`l2`>>EVAL_TAC>>srw_tac[][]); +Theorem line_similar_sym: + line_similar l1 l2 ⇒ line_similar l2 l1 +Proof + Cases_on`l1`>>Cases_on`l2`>>EVAL_TAC>>srw_tac[][] +QED -Theorem code_similar_sym - `∀code1 code2. code_similar code1 code2 ⇒ code_similar code2 code1` - (Induct >> simp[code_similar_def] +Theorem code_similar_sym: + ∀code1 code2. code_similar code1 code2 ⇒ code_similar code2 code1 +Proof + Induct >> simp[code_similar_def] >> Cases_on`code2`>>simp[code_similar_def] >> Cases >> simp[code_similar_def] >> Cases_on`h` >> simp[code_similar_def] >> srw_tac[][] >> match_mp_tac (GEN_ALL (MP_CANON EVERY2_sym)) - >> metis_tac[line_similar_sym]); - -Theorem line_similar_refl[simp] - `∀l. line_similar l l` - (Cases >> EVAL_TAC); - -Theorem code_similar_refl[simp] - `∀code. code_similar code code` - (Induct >> simp[code_similar_def] >> + >> metis_tac[line_similar_sym] +QED + +Theorem line_similar_refl[simp]: + ∀l. line_similar l l +Proof + Cases >> EVAL_TAC +QED + +Theorem code_similar_refl[simp]: + ∀code. code_similar code code +Proof + Induct >> simp[code_similar_def] >> Cases >> simp[code_similar_def] >> - match_mp_tac EVERY2_refl >> simp[]); + match_mp_tac EVERY2_refl >> simp[] +QED val line_similar_trans = Q.prove( `line_similar x y /\ line_similar y z ==> line_similar x z`, Cases_on `x` \\ Cases_on `y` \\ Cases_on `z` \\ fs[line_similar_def]); -Theorem code_similar_trans - `!c1 c2 c3. code_similar c1 c2 /\ code_similar c2 c3 ==> code_similar c1 c3` - (HO_MATCH_MP_TAC code_similar_ind \\ fs [] \\ rw [] +Theorem code_similar_trans: + !c1 c2 c3. code_similar c1 c2 /\ code_similar c2 c3 ==> code_similar c1 c3 +Proof + HO_MATCH_MP_TAC code_similar_ind \\ fs [] \\ rw [] \\ Cases_on `c3` \\ fs [code_similar_def] \\ rw [] \\ Cases_on `h` \\ fs [code_similar_def] \\ rw [] - \\ metis_tac [line_similar_trans,LIST_REL_trans]); + \\ metis_tac [line_similar_trans,LIST_REL_trans] +QED -Theorem code_similar_nil - `(code_similar [] l ⇔ l = []) ∧ - (code_similar l [] ⇔ l = [])` - (Cases_on`l`>>EVAL_TAC); +Theorem code_similar_nil: + (code_similar [] l ⇔ l = []) ∧ + (code_similar l [] ⇔ l = []) +Proof + Cases_on`l`>>EVAL_TAC +QED val code_similar_append= Q.store_thm("code_similar_append",` ∀l1 l2 r1 r2. @@ -334,40 +356,48 @@ val code_similar_append= Q.store_thm("code_similar_append",` code_similar (l1++r1) (l2++r2)`, ho_match_mp_tac code_similar_ind>>fs[code_similar_def]); -Theorem line_similar_sec_label_ok ` - ∀l1 l2. +Theorem line_similar_sec_label_ok: + ∀l1 l2. EVERY (sec_label_ok s) l1 /\ LIST_REL line_similar l1 l2 ⇒ - EVERY (sec_label_ok s) l2` - (Induct>>rw[]>> + EVERY (sec_label_ok s) l2 +Proof + Induct>>rw[]>> fs[]>> - Cases_on`h`>>Cases_on`y`>>fs[line_similar_def]); + Cases_on`h`>>Cases_on`y`>>fs[line_similar_def] +QED -Theorem code_similar_sec_labels_ok ` - ∀c1 c2. +Theorem code_similar_sec_labels_ok: + ∀c1 c2. EVERY sec_labels_ok c1 ∧ code_similar c1 c2 ⇒ - EVERY sec_labels_ok c2` - (ho_match_mp_tac code_similar_ind>>fs[code_similar_def]>>rw[]>> + EVERY sec_labels_ok c2 +Proof + ho_match_mp_tac code_similar_ind>>fs[code_similar_def]>>rw[]>> fs[]>> - metis_tac[line_similar_sec_label_ok]); + metis_tac[line_similar_sec_label_ok] +QED -Theorem line_similar_len_no_lab ` - ∀l1 l2. +Theorem line_similar_len_no_lab: + ∀l1 l2. LIST_REL line_similar l1 l2 ⇒ - len_no_lab l1 = len_no_lab l2` - (Induct>>rw[]>> + len_no_lab l1 = len_no_lab l2 +Proof + Induct>>rw[]>> res_tac>>fs[]>> - Cases_on`h`>> Cases_on`y`>>fs[line_similar_def]); + Cases_on`h`>> Cases_on`y`>>fs[line_similar_def] +QED -Theorem code_similar_len_no_lab ` - ∀(c1:'a labLang$prog) (c2:'a labLang$prog). +Theorem code_similar_len_no_lab: + ∀(c1:'a labLang$prog) (c2:'a labLang$prog). code_similar c1 c2 ⇒ MAP (len_no_lab ∘ Section_lines) c1 = - MAP (len_no_lab ∘ Section_lines) c2` - (recInduct code_similar_ind>> + MAP (len_no_lab ∘ Section_lines) c2 +Proof + recInduct code_similar_ind>> fs[code_similar_def]>>rw[]>> - metis_tac[line_similar_len_no_lab]); + metis_tac[line_similar_len_no_lab] +QED val word_loc_val_def = Define ` (word_loc_val p labs (Word w) = SOME w) /\ @@ -438,14 +468,16 @@ val all_enc_ok_def = Define ` val all_enc_ok_ind = theorem"all_enc_ok_ind"; -Theorem all_enc_ok_cons - `∀ls pos. +Theorem all_enc_ok_cons: + ∀ls pos. all_enc_ok c labs ffis pos (Section k ls::xs) ⇔ all_enc_ok c labs ffis (pos + SUM (MAP line_length ls)) xs ∧ EVEN (pos + SUM (MAP line_length ls)) ∧ - lines_ok c labs ffis pos ls` - (Induct >> srw_tac[][all_enc_ok_def,lines_ok_def] >> - simp[] >> metis_tac[]); + lines_ok c labs ffis pos ls +Proof + Induct >> srw_tac[][all_enc_ok_def,lines_ok_def] >> + simp[] >> metis_tac[] +QED val pos_val_def = Define ` (pos_val i pos [] = (pos:num)) /\ @@ -458,13 +490,15 @@ val pos_val_def = Define ` val pos_val_ind = theorem"pos_val_ind"; -Theorem pos_val_0 - `!xs c enc labs ffis pos. - all_enc_ok c labs ffis pos xs ==> (pos_val 0 pos xs = pos)` - (Induct \\ full_simp_tac(srw_ss())[pos_val_def] \\ Cases_on `h` +Theorem pos_val_0: + !xs c enc labs ffis pos. + all_enc_ok c labs ffis pos xs ==> (pos_val 0 pos xs = pos) +Proof + Induct \\ full_simp_tac(srw_ss())[pos_val_def] \\ Cases_on `h` \\ Induct_on `l` \\ full_simp_tac(srw_ss())[pos_val_def,all_enc_ok_def] \\ rpt strip_tac \\ res_tac \\ srw_tac[][] - \\ Cases_on `h` \\ full_simp_tac(srw_ss())[line_ok_def,line_length_def,is_Label_def]); + \\ Cases_on `h` \\ full_simp_tac(srw_ss())[line_ok_def,line_length_def,is_Label_def] +QED val sec_pos_val_def = Define` (sec_pos_val i pos [] = NONE) ∧ @@ -474,14 +508,18 @@ val sec_pos_val_def = Define` else if i = 0n then SOME pos else sec_pos_val (i-1) (pos + line_length y) ys)`; -Theorem sec_pos_val_too_big - `∀i pos lines. - LENGTH (FILTER ($~ o is_Label) lines) ≤ i ⇒ sec_pos_val i pos lines = NONE` - (Induct_on`lines` \\ rw[sec_pos_val_def]); +Theorem sec_pos_val_too_big: + ∀i pos lines. + LENGTH (FILTER ($~ o is_Label) lines) ≤ i ⇒ sec_pos_val i pos lines = NONE +Proof + Induct_on`lines` \\ rw[sec_pos_val_def] +QED -Theorem EVERY_is_Label_sec_pos_val - `∀n pos lines. EVERY is_Label lines ⇒ sec_pos_val n pos lines = NONE` - (Induct_on`lines` \\ rw[sec_pos_val_def]); +Theorem EVERY_is_Label_sec_pos_val: + ∀n pos lines. EVERY is_Label lines ⇒ sec_pos_val n pos lines = NONE +Proof + Induct_on`lines` \\ rw[sec_pos_val_def] +QED val pos_val_thm0 = Q.prove( `∀i pos acc. @@ -494,13 +532,15 @@ val pos_val_thm0 = Q.prove( ho_match_mp_tac pos_val_ind \\ rw[pos_val_def,sec_pos_val_def,ADD1]); -Theorem pos_val_thm - `(pos_val i pos [] = pos) ∧ +Theorem pos_val_thm: + (pos_val i pos [] = pos) ∧ (pos_val i pos (Section k s::ss) = case sec_pos_val i pos s of NONE => pos_val (i - LENGTH (FILTER ($~ o is_Label) s)) (pos + SUM (MAP line_length s)) ss - | SOME x => x)` - (rw[Once pos_val_thm0] \\ rw[Once pos_val_thm0]); + | SOME x => x) +Proof + rw[Once pos_val_thm0] \\ rw[Once pos_val_thm0] +QED val good_code_def = Define` good_code c labs code ⇔ @@ -708,20 +748,22 @@ val bytes_in_mem_APPEND = Q.prove( bytes_in_mem (a + n2w (LENGTH xs)) ys m md md1`, Induct \\ full_simp_tac(srw_ss())[bytes_in_mem_def,ADD1,GSYM word_add_n2w,CONJ_ASSOC]); -Theorem bytes_in_mem_UPDATE - `∀ls a m md md2 w1 w2. +Theorem bytes_in_mem_UPDATE: + ∀ls a m md md2 w1 w2. (∀n. n < LENGTH ls ⇒ a + n2w n ≠ w1) /\ bytes_in_mem a ls m md md2 ⇒ - bytes_in_mem a ls ((w1 =+ w2) m) md md2` - (Induct>>fs[bytes_in_mem_def]>>rw[] + bytes_in_mem a ls ((w1 =+ w2) m) md md2 +Proof + Induct>>fs[bytes_in_mem_def]>>rw[] >- (first_x_assum (qspec_then `0` assume_tac)>> rfs[APPLY_UPDATE_THM]) >> first_x_assum match_mp_tac>>rw[]>> first_x_assum (qspec_then `n+1` assume_tac)>> - rfs[GSYM word_add_n2w]); + rfs[GSYM word_add_n2w] +QED val s1 = ``s1:('a,'a lab_to_target$config,'ffi) labSem$state``; @@ -1147,27 +1189,31 @@ val aligned_IMP_ADD_LESS_dimword = Q.prove( \\ full_simp_tac std_ss [EXP_ADD] \\ match_mp_tac MULT_ADD_LESS_MULT \\ fs []); -Theorem aligned_2_imp - `aligned 2 (x:'a word) /\ dimindex (:'a) = 32 ==> +Theorem aligned_2_imp: + aligned 2 (x:'a word) /\ dimindex (:'a) = 32 ==> byte_align x = x ∧ byte_align (x + 1w) = x ∧ byte_align (x + 2w) = x ∧ - byte_align (x + 3w) = x` - (rw [alignmentTheory.byte_align_def, GSYM alignmentTheory.aligned_def] + byte_align (x + 3w) = x +Proof + rw [alignmentTheory.byte_align_def, GSYM alignmentTheory.aligned_def] \\ match_mp_tac alignmentTheory.align_add_aligned - \\ simp [wordsTheory.dimword_def]) + \\ simp [wordsTheory.dimword_def] +QED -Theorem aligned_2_not_eq - `aligned 2 (x:'a word) ∧ dimindex(:'a) = 32 ∧ +Theorem aligned_2_not_eq: + aligned 2 (x:'a word) ∧ dimindex(:'a) = 32 ∧ x ≠ byte_align a ⇒ x ≠ a ∧ x+1w ≠ a ∧ x+2w ≠ a ∧ - x+3w ≠ a` - (metis_tac[aligned_2_imp]) + x+3w ≠ a +Proof + metis_tac[aligned_2_imp] +QED -Theorem aligned_3_imp - `aligned 3 (x:'a word) /\ dimindex (:'a) = 64 ==> +Theorem aligned_3_imp: + aligned 3 (x:'a word) /\ dimindex (:'a) = 64 ==> byte_align x = x ∧ byte_align (x + 1w) = x ∧ byte_align (x + 2w) = x ∧ @@ -1175,13 +1221,15 @@ Theorem aligned_3_imp byte_align (x + 4w) = x ∧ byte_align (x + 5w) = x ∧ byte_align (x + 6w) = x ∧ - byte_align (x + 7w) = x` - (rw [alignmentTheory.byte_align_def, GSYM alignmentTheory.aligned_def] + byte_align (x + 7w) = x +Proof + rw [alignmentTheory.byte_align_def, GSYM alignmentTheory.aligned_def] \\ match_mp_tac alignmentTheory.align_add_aligned - \\ simp [wordsTheory.dimword_def]) + \\ simp [wordsTheory.dimword_def] +QED -Theorem aligned_3_not_eq - `aligned 3 (x:'a word) ∧ dimindex(:'a) = 64 ∧ +Theorem aligned_3_not_eq: + aligned 3 (x:'a word) ∧ dimindex(:'a) = 64 ∧ x ≠ byte_align a ⇒ x ≠ a ∧ x+1w ≠ a ∧ @@ -1190,8 +1238,10 @@ Theorem aligned_3_not_eq x+4w ≠ a ∧ x+5w ≠ a ∧ x+6w ≠ a ∧ - x+7w ≠ a` - (metis_tac[aligned_3_imp]) + x+7w ≠ a +Proof + metis_tac[aligned_3_imp] +QED val dimword_eq_32_imp_or_bytes = Q.prove( `dimindex (:'a) = 32 ==> @@ -1359,13 +1409,15 @@ val arith_upd_lemma = Q.prove( \\ fs[labSemTheory.assert_def])); (* The lab and asm versions should be in their individual props *) -Theorem arith_upd_fp_regs[simp] ` - ((arith_upd a s).fp_regs = s.fp_regs ∧ - (arith_upd a (t:'a asm_state)).fp_regs = t.fp_regs)` - (Cases_on`a`>> +Theorem arith_upd_fp_regs[simp]: + ((arith_upd a s).fp_regs = s.fp_regs ∧ + (arith_upd a (t:'a asm_state)).fp_regs = t.fp_regs) +Proof + Cases_on`a`>> TRY(Cases_on`b`)>> EVAL_TAC>>fs[]>>every_case_tac>> - fs[]); + fs[] +QED val fp_upd_lemma = Q.prove(` (∀r. word_loc_val p labs (read_reg r s1) = SOME (t1.regs r)) ∧ @@ -1784,11 +1836,12 @@ val pos_val_MOD_0 = Q.prove( val IMP_IMP2 = METIS_PROVE [] ``a /\ (a /\ b ==> c) ==> ((a ==> b) ==> c)`` -Theorem EVEN_add_AND - `(1w && p) = 0w ∧ +Theorem EVEN_add_AND: + (1w && p) = 0w ∧ EVEN x ⇒ - (1w && (p + n2w x)) = 0w` - (rw[]>> + (1w && (p + n2w x)) = 0w +Proof + rw[]>> `p = n2w(w2n p)` by fs[n2w_w2n]>> pop_assum SUBST1_TAC>> simp[word_add_n2w]>> @@ -1801,7 +1854,8 @@ Theorem EVEN_add_AND first_x_assum SUBST_ALL_TAC>> SIMP_TAC (std_ss++ARITH_ss) []>> PURE_REWRITE_TAC [GSYM addressTheory.n2w_and_1]>> - simp[]); + simp[] +QED val word_cmp_lemma = Q.prove( `state_rel (mc_conf,code2,labs,p) s1 t1 ms1 /\ @@ -1838,11 +1892,13 @@ val list_add_if_fresh_simp = Q.prove(` >> every_case_tac >> fs [list_add_if_fresh_def, find_index_def])) -Theorem list_add_if_fresh_thm - `list_add_if_fresh s l = - if MEM s l then l else l ++ [s]` - (fs[list_add_if_fresh_simp |> Q.SPEC`0`]>>rw[]>> - metis_tac[find_index_NOT_MEM]); +Theorem list_add_if_fresh_thm: + list_add_if_fresh s l = + if MEM s l then l else l ++ [s] +Proof + fs[list_add_if_fresh_simp |> Q.SPEC`0`]>>rw[]>> + metis_tac[find_index_NOT_MEM] +QED val list_add_if_fresh_simp = Q.SPECL [`n`,`s`] list_add_if_fresh_simp @@ -1885,22 +1941,26 @@ val find_index_in_range0 = Q.prove(` find_index s l 0 = SOME x ==> x < LENGTH l /\ x >= 0`, ASSUME_TAC (Q.SPEC `0` find_index_in_range) >> rfs []) -Theorem EL_get_ffi_index_MEM - `MEM s ls ⇒ EL (get_ffi_index ls s) ls = s` - (rw[get_ffi_index_def,find_index_LEAST_EL] +Theorem EL_get_ffi_index_MEM: + MEM s ls ⇒ EL (get_ffi_index ls s) ls = s +Proof + rw[get_ffi_index_def,find_index_LEAST_EL] \\ numLib.LEAST_ELIM_TAC \\ fs[MEM_EL,libTheory.the_def] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem has_io_name_EXISTS - `∀name ls. has_io_name name ls ⇔ +Theorem has_io_name_EXISTS: + ∀name ls. has_io_name name ls ⇔ EXISTS (λx. case x of LabAsm (CallFFI i) _ _ _ => i = name | _ => F) - (FLAT (MAP Section_lines ls))` - (recInduct has_io_name_ind + (FLAT (MAP Section_lines ls)) +Proof + recInduct has_io_name_ind \\ rw[has_io_name_def] \\ CASE_TAC \\ fs[] \\ CASE_TAC \\ fs[] - \\ Cases_on`s = index` \\ fs[]); + \\ Cases_on`s = index` \\ fs[] +QED (* -- syntactic properties of remove_labels -- *) @@ -1914,15 +1974,19 @@ val _ = export_rewrites["line_len_def"]; (* annotated section length *) -Theorem sec_length_add - `∀ls n m. sec_length ls (n+m) = sec_length ls n + m` - (ho_match_mp_tac sec_length_ind >> - simp[sec_length_def]); +Theorem sec_length_add: + ∀ls n m. sec_length ls (n+m) = sec_length ls n + m +Proof + ho_match_mp_tac sec_length_ind >> + simp[sec_length_def] +QED -Theorem sec_length_sum_line_len - `∀ls n. - sec_length ls n = SUM (MAP line_len ls) + n` - (ho_match_mp_tac sec_length_ind \\ rw[sec_length_def]); +Theorem sec_length_sum_line_len: + ∀ls n. + sec_length ls n = SUM (MAP line_len ls) + n +Proof + ho_match_mp_tac sec_length_ind \\ rw[sec_length_def] +QED (* simple syntactic properties of compiler functions *) @@ -1957,90 +2021,116 @@ val enc_lines_again_simp_EQ = Q.prove(` rpt(pairarg_tac>>fs[])>> rw[EQ_IMP_THM,sec_length_def]) -Theorem enc_lines_again_simp_len - `∀labs ffis pos enc lines res. +Theorem enc_lines_again_simp_len: + ∀labs ffis pos enc lines res. enc_lines_again_simp labs ffis pos enc lines = (res,T) ⇒ - MAP line_len res = MAP line_len lines` - (recInduct enc_lines_again_simp_ind + MAP line_len res = MAP line_len lines +Proof + recInduct enc_lines_again_simp_ind \\ rw[enc_lines_again_simp_def] - \\ pairarg_tac \\ fs[] \\ rveq \\ fs[]); + \\ pairarg_tac \\ fs[] \\ rveq \\ fs[] +QED -Theorem LENGTH_pad_bytes - `0 < LENGTH nop ∧ LENGTH bytes ≤ l ⇒ - LENGTH (pad_bytes bytes l nop) = l` - (srw_tac[][pad_bytes_def] >> srw_tac[][] >> fsrw_tac[ARITH_ss][] +Theorem LENGTH_pad_bytes: + 0 < LENGTH nop ∧ LENGTH bytes ≤ l ⇒ + LENGTH (pad_bytes bytes l nop) = l +Proof + srw_tac[][pad_bytes_def] >> srw_tac[][] >> fsrw_tac[ARITH_ss][] \\ match_mp_tac LENGTH_TAKE \\ simp[LENGTH_FLAT,SUM_MAP_LENGTH_REPLICATE] - \\ Cases_on`LENGTH nop`>>full_simp_tac(srw_ss())[]>>simp[MULT,Once MULT_COMM]); - -Theorem section_labels_sec_length - `∀pos lines acc. - FST (section_labels pos lines acc) = sec_length lines pos` - (ho_match_mp_tac section_labels_ind - \\ rw[section_labels_def,sec_length_def]); - -Theorem section_labels_append - `∀pos l1 labs l2. + \\ Cases_on`LENGTH nop`>>full_simp_tac(srw_ss())[]>>simp[MULT,Once MULT_COMM] +QED + +Theorem section_labels_sec_length: + ∀pos lines acc. + FST (section_labels pos lines acc) = sec_length lines pos +Proof + ho_match_mp_tac section_labels_ind + \\ rw[section_labels_def,sec_length_def] +QED + +Theorem section_labels_append: + ∀pos l1 labs l2. section_labels pos (l1 ++ l2) labs = - section_labels (pos + (SUM (MAP line_len l1))) l2 (SND (section_labels pos l1 labs))` - (recInduct section_labels_ind - \\ rw[section_labels_def]); + section_labels (pos + (SUM (MAP line_len l1))) l2 (SND (section_labels pos l1 labs)) +Proof + recInduct section_labels_ind + \\ rw[section_labels_def] +QED -Theorem line_length_add_nop1 - `∀nop ls. +Theorem line_length_add_nop1: + ∀nop ls. ¬EVERY is_Label ls ⇒ SUM (MAP line_length (add_nop nop ls)) = - SUM (MAP line_length ls) + LENGTH nop` - (ho_match_mp_tac add_nop_ind - \\ rw[add_nop_def,line_length_def]); - -Theorem line_length_add_nop - `∀nop ls. + SUM (MAP line_length ls) + LENGTH nop +Proof + ho_match_mp_tac add_nop_ind + \\ rw[add_nop_def,line_length_def] +QED + +Theorem line_length_add_nop: + ∀nop ls. EVERY is_Label ls ⇒ SUM (MAP line_length (add_nop nop ls)) = - SUM (MAP line_length ls)` - (ho_match_mp_tac add_nop_ind - \\ rw[add_nop_def,line_length_def]); - -Theorem line_len_add_nop1 - `∀nop ls. ¬(EVERY is_Label ls) ⇒ + SUM (MAP line_length ls) +Proof + ho_match_mp_tac add_nop_ind + \\ rw[add_nop_def,line_length_def] +QED + +Theorem line_len_add_nop1: + ∀nop ls. ¬(EVERY is_Label ls) ⇒ SUM (MAP line_len (add_nop nop ls)) = - SUM (MAP line_len ls) + 1` - (recInduct add_nop_ind \\ rw[add_nop_def]); + SUM (MAP line_len ls) + 1 +Proof + recInduct add_nop_ind \\ rw[add_nop_def] +QED -Theorem line_len_add_nop - `∀nop ls. EVERY is_Label ls ⇒ +Theorem line_len_add_nop: + ∀nop ls. EVERY is_Label ls ⇒ SUM (MAP line_len (add_nop nop ls)) = - SUM (MAP line_len ls)` - (recInduct add_nop_ind \\ rw[add_nop_def]); - -Theorem add_nop_append - `∀nop l1 l2. - add_nop nop (l1++l2) = if EVERY is_Label l1 then l1 ++ add_nop nop l2 else add_nop nop l1 ++ l2` - (ho_match_mp_tac add_nop_ind - \\ rw[add_nop_def] \\ rw[] \\ fs[add_nop_def]); - -Theorem EXISTS_not_Label_add_nop[simp] - `∀nop acc. - EXISTS ($~ o is_Label) (add_nop nop acc) ⇔ EXISTS ($~ o is_Label) acc` - (ho_match_mp_tac add_nop_ind \\ rw[add_nop_def]); - -Theorem EVERY_is_Label_add_nop_preserved[simp] - `∀nop acc. - EVERY is_Label (add_nop nop acc) ⇔ EVERY is_Label acc` - (ho_match_mp_tac add_nop_ind \\ rw[add_nop_def]); - -Theorem EVERY_is_Label_add_nop - `∀nop ls. EVERY is_Label ls ⇒ add_nop nop ls = ls` - (recInduct add_nop_ind \\ rw[add_nop_def]); - -Theorem SND_lines_upd_lab_len - `∀pos lines acc. + SUM (MAP line_len ls) +Proof + recInduct add_nop_ind \\ rw[add_nop_def] +QED + +Theorem add_nop_append: + ∀nop l1 l2. + add_nop nop (l1++l2) = if EVERY is_Label l1 then l1 ++ add_nop nop l2 else add_nop nop l1 ++ l2 +Proof + ho_match_mp_tac add_nop_ind + \\ rw[add_nop_def] \\ rw[] \\ fs[add_nop_def] +QED + +Theorem EXISTS_not_Label_add_nop[simp]: + ∀nop acc. + EXISTS ($~ o is_Label) (add_nop nop acc) ⇔ EXISTS ($~ o is_Label) acc +Proof + ho_match_mp_tac add_nop_ind \\ rw[add_nop_def] +QED + +Theorem EVERY_is_Label_add_nop_preserved[simp]: + ∀nop acc. + EVERY is_Label (add_nop nop acc) ⇔ EVERY is_Label acc +Proof + ho_match_mp_tac add_nop_ind \\ rw[add_nop_def] +QED + +Theorem EVERY_is_Label_add_nop: + ∀nop ls. EVERY is_Label ls ⇒ add_nop nop ls = ls +Proof + recInduct add_nop_ind \\ rw[add_nop_def] +QED + +Theorem SND_lines_upd_lab_len: + ∀pos lines acc. SND (lines_upd_lab_len pos lines acc) = - pos + SUM (MAP line_len (FST (lines_upd_lab_len pos lines acc))) - SUM (MAP line_len acc)` - (recInduct lines_upd_lab_len_ind + pos + SUM (MAP line_len (FST (lines_upd_lab_len pos lines acc))) - SUM (MAP line_len acc) +Proof + recInduct lines_upd_lab_len_ind \\ rw[lines_upd_lab_len_def] - \\ rw[MAP_REVERSE,SUM_REVERSE]); + \\ rw[MAP_REVERSE,SUM_REVERSE] +QED (* code_similar preservation *) @@ -2051,11 +2141,12 @@ val line_similar_add_nop = Q.prove(` Induct_on`ls`>>rw[add_nop_def]>> Cases_on`y`>>Cases_on`h`>>fs[add_nop_def,line_similar_def]); -Theorem line_similar_pad_section - `∀nop l2 aux l1. +Theorem line_similar_pad_section: + ∀nop l2 aux l1. LIST_REL line_similar l1 (REVERSE aux ++ l2) ⇒ - LIST_REL line_similar l1 (pad_section nop l2 aux)` - (ho_match_mp_tac pad_section_ind >> + LIST_REL line_similar l1 (pad_section nop l2 aux) +Proof + ho_match_mp_tac pad_section_ind >> srw_tac[][pad_section_def] >> first_x_assum match_mp_tac>> imp_res_tac LIST_REL_LENGTH >> full_simp_tac(srw_ss())[] >> @@ -2078,20 +2169,23 @@ Theorem line_similar_pad_section ho_match_mp_tac LIST_REL_trans>>HINT_EXISTS_TAC>> metis_tac[line_similar_trans,LIST_REL_REVERSE_EQ]) >> - TRY(Cases_on`x`)>>TRY(Cases_on`x'`)>>fs[line_similar_def]); + TRY(Cases_on`x`)>>TRY(Cases_on`x'`)>>fs[line_similar_def] +QED -Theorem code_similar_pad_code - `∀code1 code2. +Theorem code_similar_pad_code: + ∀code1 code2. code_similar code1 code2 ⇒ - code_similar code1 (pad_code nop code2)` - (Induct + code_similar code1 (pad_code nop code2) +Proof + Induct >- ( Cases >> simp[code_similar_def,pad_code_def] ) >> Cases_on`code2` >- simp[code_similar_def] >> Cases >> simp[code_similar_def] >> Cases_on`h` >> simp[code_similar_def,pad_code_def] >> strip_tac >> rveq >> match_mp_tac line_similar_pad_section>> - simp[]); + simp[] +QED val LIST_REL_enc_line = Q.prove(` ∀ls ls'. @@ -2100,17 +2194,19 @@ val LIST_REL_enc_line = Q.prove(` Induct>>rw[]>>Cases_on`h`>>rw[enc_line_def,EQ_IMP_THM]>>Cases_on`y`>> fs[line_similar_def]) -Theorem code_similar_enc_sec_list[simp] - `∀code1 code2 n. +Theorem code_similar_enc_sec_list[simp]: + ∀code1 code2 n. code_similar (enc_sec_list n code1) code2 ⇔ - code_similar code1 code2` - (simp[enc_sec_list_def] + code_similar code1 code2 +Proof + simp[enc_sec_list_def] >> Induct >> simp[] >> Cases_on`code2`>>simp[code_similar_def] >> Cases_on`h`>>simp[code_similar_def] >> Cases>>simp[code_similar_def,enc_sec_def]>> rw[EQ_IMP_THM]>> - metis_tac[LIST_REL_enc_line]) + metis_tac[LIST_REL_enc_line] +QED val enc_lines_again_IMP_similar = Q.prove(` ∀labs ffis pos enc lines acc ok lines' ok' curr. @@ -2125,14 +2221,16 @@ val enc_lines_again_IMP_similar = Q.prove(` Cases_on`h`>>fs[enc_lines_again_def]>>EVERY_CASE_TAC>> asm_exists_tac>>fs[SNOC_APPEND,line_similar_def]) -Theorem enc_secs_again_IMP_similar - `∀pos labs ffis enc code code1 ok. - enc_secs_again pos labs ffis enc code = (code1,ok) ==> code_similar code code1` - (ho_match_mp_tac enc_secs_again_ind>>fs[enc_secs_again_def]>>rw[]>> +Theorem enc_secs_again_IMP_similar: + ∀pos labs ffis enc code code1 ok. + enc_secs_again pos labs ffis enc code = (code1,ok) ==> code_similar code code1 +Proof + ho_match_mp_tac enc_secs_again_ind>>fs[enc_secs_again_def]>>rw[]>> ntac 2 (pairarg_tac>>fs[])>> rveq>>fs[code_similar_def]>> imp_res_tac enc_lines_again_IMP_similar>> - fs[]); + fs[] +QED val lines_upd_lab_len_AUX = Q.prove( `!l aux pos. @@ -2152,18 +2250,21 @@ val line_similar_lines_upd_lab_len = Q.prove( \\ fs [] \\ rw [] \\ eq_tac \\ rw [] \\ Cases_on `y` \\ fs [line_similar_def]); -Theorem code_similar_upd_lab_len - `!code pos code1. - code_similar (upd_lab_len pos code) code1 = code_similar code code1` - (Induct \\ fs [code_similar_def] \\ Cases +Theorem code_similar_upd_lab_len: + !code pos code1. + code_similar (upd_lab_len pos code) code1 = code_similar code code1 +Proof + Induct \\ fs [code_similar_def] \\ Cases \\ Cases_on `code1` \\ fs [upd_lab_len_def,code_similar_def,UNCURRY] \\ Cases_on `h` \\ fs [upd_lab_len_def,code_similar_def] - \\ rw [] \\ fs [line_similar_lines_upd_lab_len]); + \\ rw [] \\ fs [line_similar_lines_upd_lab_len] +QED -Theorem lines_upd_lab_len_similar - `∀pos lines aux. - LIST_REL line_similar (FST (lines_upd_lab_len pos lines aux)) (REVERSE aux ++ lines)` - (recInduct lines_upd_lab_len_ind +Theorem lines_upd_lab_len_similar: + ∀pos lines aux. + LIST_REL line_similar (FST (lines_upd_lab_len pos lines aux)) (REVERSE aux ++ lines) +Proof + recInduct lines_upd_lab_len_ind \\ rw[lines_upd_lab_len_def] \\ fs[] \\ TRY ( simp[LIST_REL_EL_EQN,line_similar_refl] \\ NO_TAC ) \\ match_mp_tac LIST_REL_trans @@ -2172,22 +2273,26 @@ Theorem lines_upd_lab_len_similar \\ once_rewrite_tac[GSYM APPEND_ASSOC] \\ match_mp_tac EVERY2_APPEND_suff \\ simp[line_similar_def] - \\ simp[LIST_REL_EL_EQN,line_similar_refl]); + \\ simp[LIST_REL_EL_EQN,line_similar_refl] +QED (* implications of code_similar *) -Theorem code_similar_MAP_Section_num - `∀c1 c2. +Theorem code_similar_MAP_Section_num: + ∀c1 c2. code_similar c1 c2 ⇒ - MAP Section_num c1 = MAP Section_num c2` - (recInduct code_similar_ind - \\ rw[code_similar_def]); + MAP Section_num c1 = MAP Section_num c2 +Proof + recInduct code_similar_ind + \\ rw[code_similar_def] +QED -Theorem code_similar_extract_labels - `∀code1 code2. code_similar code1 code2 ⇒ +Theorem code_similar_extract_labels: + ∀code1 code2. code_similar code1 code2 ⇒ MAP (extract_labels o Section_lines) code1 = - MAP (extract_labels o Section_lines) code2` - (recInduct code_similar_ind + MAP (extract_labels o Section_lines) code2 +Proof + recInduct code_similar_ind \\ rw[code_similar_def] \\ pop_assum mp_tac \\ rpt (pop_assum kall_tac) @@ -2195,12 +2300,14 @@ Theorem code_similar_extract_labels \\ qid_spec_tac`lines1` \\ Induct \\ simp[] \\ Cases \\ simp[extract_labels_def,PULL_EXISTS] - \\ Cases \\ simp[line_similar_def]); - -Theorem code_similar_loc_to_pc - `∀l1 l2 c1 c2. code_similar c1 c2 ⇒ - loc_to_pc l1 l2 c1 = loc_to_pc l1 l2 c2` - (ho_match_mp_tac loc_to_pc_ind + \\ Cases \\ simp[line_similar_def] +QED + +Theorem code_similar_loc_to_pc: + ∀l1 l2 c1 c2. code_similar c1 c2 ⇒ + loc_to_pc l1 l2 c1 = loc_to_pc l1 l2 c2 +Proof + ho_match_mp_tac loc_to_pc_ind >> simp[code_similar_nil] >> srw_tac[][] >> Cases_on`c2`>>full_simp_tac(srw_ss())[code_similar_def] @@ -2227,20 +2334,23 @@ Theorem code_similar_loc_to_pc rveq >> rev_full_simp_tac(srw_ss())[] \\ TRY (ntac 2 AP_THM_TAC >> AP_TERM_TAC) \\ first_x_assum (match_mp_tac o MP_CANON) - \\ srw_tac[][code_similar_def]); + \\ srw_tac[][code_similar_def] +QED (* sec_label_ok preservation *) -Theorem enc_sec_list_sec_labels_ok - `∀enc code. +Theorem enc_sec_list_sec_labels_ok: + ∀enc code. EVERY sec_labels_ok code - ⇒ EVERY sec_labels_ok (enc_sec_list enc code)` - (rw[enc_sec_list_def,EVERY_MAP] + ⇒ EVERY sec_labels_ok (enc_sec_list enc code) +Proof + rw[enc_sec_list_def,EVERY_MAP] \\ Induct_on`code` \\ fs[] \\ Cases \\ fs[sec_labels_ok_def,enc_sec_def,EVERY_MAP] \\ rw[] \\ fs[EVERY_MEM] \\ Cases \\ fs[enc_line_def] - \\ strip_tac \\ res_tac \\ fs[]); + \\ strip_tac \\ res_tac \\ fs[] +QED val enc_lines_again_sec_labels_ok = Q.prove(` ∀labs ffis pos enc lines acc ok res ok' k. @@ -2251,15 +2361,17 @@ val enc_lines_again_sec_labels_ok = Q.prove(` recInduct enc_lines_again_ind \\ rw[enc_lines_again_def] \\ rw[EVERY_REVERSE]); -Theorem enc_secs_again_sec_labels_ok - `∀pos ffis labs enc ls res ok k. +Theorem enc_secs_again_sec_labels_ok: + ∀pos ffis labs enc ls res ok k. enc_secs_again pos ffis labs enc ls = (res,ok) ∧ EVERY sec_labels_ok ls ⇒ - EVERY sec_labels_ok res` - (recInduct enc_secs_again_ind + EVERY sec_labels_ok res +Proof + recInduct enc_secs_again_ind \\ rw[enc_secs_again_def] \\ rw[] \\ rpt(pairarg_tac \\ fs[]) \\ rw[] \\ match_mp_tac enc_lines_again_sec_labels_ok - \\ asm_exists_tac \\ fs[]); + \\ asm_exists_tac \\ fs[] +QED val lines_upd_lab_len_sec_label_ok = Q.prove( `∀pos lines acc k. @@ -2270,13 +2382,15 @@ val lines_upd_lab_len_sec_label_ok = Q.prove( \\ rw[lines_upd_lab_len_def] \\ rw[EVERY_REVERSE]); -Theorem upd_lab_len_sec_labels_ok - `∀n ls. EVERY sec_labels_ok ls ⇒ EVERY sec_labels_ok (upd_lab_len n ls)` - (recInduct upd_lab_len_ind +Theorem upd_lab_len_sec_labels_ok: + ∀n ls. EVERY sec_labels_ok ls ⇒ EVERY sec_labels_ok (upd_lab_len n ls) +Proof + recInduct upd_lab_len_ind \\ rw[upd_lab_len_def] \\ pairarg_tac \\ fs[] \\ qspecl_then[`pos`,`lines`,`[]`]mp_tac lines_upd_lab_len_sec_label_ok - \\ rw[]); + \\ rw[] +QED val add_nop_sec_label_ok = Q.prove( `∀nop aux. @@ -2296,24 +2410,28 @@ val pad_section_sec_label_ok = Q.prove( \\ first_x_assum match_mp_tac \\ metis_tac[add_nop_sec_label_ok]); -Theorem pad_code_sec_labels_ok - `∀nop code. +Theorem pad_code_sec_labels_ok: + ∀nop code. EVERY sec_labels_ok code ⇒ - EVERY sec_labels_ok (pad_code nop code)` - (recInduct pad_code_ind + EVERY sec_labels_ok (pad_code nop code) +Proof + recInduct pad_code_ind \\ rw[pad_code_def] \\ match_mp_tac pad_section_sec_label_ok - \\ rw[]); + \\ rw[] +QED -Theorem sec_labels_ok_filter_skip[simp] - `∀code. EVERY sec_labels_ok (filter_skip code) ⇔ EVERY sec_labels_ok code` - (Induct \\ simp[lab_filterTheory.filter_skip_def] +Theorem sec_labels_ok_filter_skip[simp]: + ∀code. EVERY sec_labels_ok (filter_skip code) ⇔ EVERY sec_labels_ok code +Proof + Induct \\ simp[lab_filterTheory.filter_skip_def] \\ Cases \\ fs[lab_filterTheory.filter_skip_def,EVERY_FILTER] \\ rw[EQ_IMP_THM,EVERY_MEM] \\ Cases_on`e` \\ fs[] \\ res_tac \\ fs[] \\ first_x_assum match_mp_tac - \\ EVAL_TAC); + \\ EVAL_TAC +QED (* invariant: lines are encoded and non-label lengths annotated *) @@ -2333,61 +2451,71 @@ val _ = overload_on("all_encd0",``λenc l. EVERY (sec_encd0 enc) l``); (* establishing encd0 *) -Theorem enc_sec_list_encd0 - `∀ls. all_encd0 enc (enc_sec_list enc ls)` - (Induct \\ fs[enc_sec_list_def] +Theorem enc_sec_list_encd0: + ∀ls. all_encd0 enc (enc_sec_list enc ls) +Proof + Induct \\ fs[enc_sec_list_def] \\ Cases \\ simp[enc_sec_def,EVERY_MAP] \\ simp[EVERY_MEM] \\ Cases \\ simp[enc_line_def,line_encd0_def] - \\ metis_tac[]); + \\ metis_tac[] +QED (* encd0 preservation *) -Theorem enc_lines_again_encd0 - `∀labs ffis pos enc lines acc ok res ok'. +Theorem enc_lines_again_encd0: + ∀labs ffis pos enc lines acc ok res ok'. enc_lines_again labs ffis pos enc lines (acc,ok) = (res,ok') ∧ EVERY (line_encd0 enc) lines ∧ EVERY (line_encd0 enc) acc ⇒ - EVERY (line_encd0 enc) res` - (recInduct enc_lines_again_ind + EVERY (line_encd0 enc) res +Proof + recInduct enc_lines_again_ind \\ rw[enc_lines_again_def] \\ rw[EVERY_REVERSE] \\ fs[] \\ fs[line_encd0_def] \\ first_x_assum match_mp_tac - \\ rw[MAX_DEF] \\ metis_tac[]); + \\ rw[MAX_DEF] \\ metis_tac[] +QED -Theorem enc_secs_again_encd0 - `∀pos labs ffis enc ls res ok. +Theorem enc_secs_again_encd0: + ∀pos labs ffis enc ls res ok. enc_secs_again pos labs ffis enc ls = (res,ok) ∧ all_encd0 enc ls ⇒ - all_encd0 enc res` - (ho_match_mp_tac enc_secs_again_ind + all_encd0 enc res +Proof + ho_match_mp_tac enc_secs_again_ind \\ rw[enc_secs_again_def] \\ rw[] \\ pairarg_tac \\ fs[] \\ pairarg_tac \\ fs[] \\ fs[] \\ rw[] \\ match_mp_tac enc_lines_again_encd0 - \\ asm_exists_tac \\ fs[]); + \\ asm_exists_tac \\ fs[] +QED -Theorem lines_upd_lab_len_encd0 - `∀pos ls acc. +Theorem lines_upd_lab_len_encd0: + ∀pos ls acc. EVERY (line_encd0 enc) ls ∧ EVERY (line_encd0 enc) acc ⇒ - EVERY (line_encd0 enc) (FST (lines_upd_lab_len pos ls acc))` - (recInduct lines_upd_lab_len_ind + EVERY (line_encd0 enc) (FST (lines_upd_lab_len pos ls acc)) +Proof + recInduct lines_upd_lab_len_ind \\ rw[lines_upd_lab_len_def] - \\ fs[EVERY_REVERSE,line_encd0_def]); + \\ fs[EVERY_REVERSE,line_encd0_def] +QED -Theorem upd_lab_len_encd0 - `∀pos ss. all_encd0 enc ss ⇒ all_encd0 enc (upd_lab_len pos ss)` - (recInduct upd_lab_len_ind +Theorem upd_lab_len_encd0: + ∀pos ss. all_encd0 enc ss ⇒ all_encd0 enc (upd_lab_len pos ss) +Proof + recInduct upd_lab_len_ind \\ rw[upd_lab_len_def] \\ fs[] \\ rw[UNCURRY] >- ( match_mp_tac lines_upd_lab_len_encd0 \\ fs[]) \\ first_x_assum match_mp_tac - \\ metis_tac[PAIR]); + \\ metis_tac[PAIR] +QED (* invariant: annotated lengths are not too small *) (* this is a consequence of encd (below) and not treated separately much *) @@ -2419,49 +2547,57 @@ val _ = export_rewrites["sec_label_one_def"]; (* establishing label_one *) -Theorem lines_upd_lab_len_label_one - `∀pos ls acc. +Theorem lines_upd_lab_len_label_one: + ∀pos ls acc. EVERY label_one acc ⇒ - EVERY label_one (FST (lines_upd_lab_len pos ls acc))` - (recInduct lines_upd_lab_len_ind - \\ rw[lines_upd_lab_len_def] \\ fs[EVERY_REVERSE]); + EVERY label_one (FST (lines_upd_lab_len pos ls acc)) +Proof + recInduct lines_upd_lab_len_ind + \\ rw[lines_upd_lab_len_def] \\ fs[EVERY_REVERSE] +QED -Theorem upd_lab_len_label_one - `∀pos ss. EVERY sec_label_one (upd_lab_len pos ss)` - (ho_match_mp_tac upd_lab_len_ind +Theorem upd_lab_len_label_one: + ∀pos ss. EVERY sec_label_one (upd_lab_len pos ss) +Proof + ho_match_mp_tac upd_lab_len_ind \\ rw[upd_lab_len_def] \\ pairarg_tac \\ fs[] - \\ metis_tac[lines_upd_lab_len_label_one,FST,EVERY_DEF]); + \\ metis_tac[lines_upd_lab_len_label_one,FST,EVERY_DEF] +QED (* label_one preservation *) -Theorem enc_lines_again_simp_label_one - `∀labs ffis pos enc ls res ok. +Theorem enc_lines_again_simp_label_one: + ∀labs ffis pos enc ls res ok. enc_lines_again_simp labs ffis pos enc ls = (res,ok) ∧ EVERY label_one ls ⇒ - EVERY label_one res` - (recInduct enc_lines_again_simp_ind + EVERY label_one res +Proof + recInduct enc_lines_again_simp_ind \\ rw[enc_lines_again_simp_def] \\ fs[] - \\ pairarg_tac \\ fs[] \\ rveq \\ fs[]); + \\ pairarg_tac \\ fs[] \\ rveq \\ fs[] +QED -Theorem enc_secs_again_label_one - `∀pos labs ffis enc lines res ok. +Theorem enc_secs_again_label_one: + ∀pos labs ffis enc lines res ok. enc_secs_again pos labs ffis enc lines = (res,ok) ∧ EVERY sec_label_one lines ⇒ - EVERY sec_label_one res` - (recInduct enc_secs_again_ind + EVERY sec_label_one res +Proof + recInduct enc_secs_again_ind \\ rw[enc_secs_again_def] \\ fs[] \\ rpt(pairarg_tac \\ fs[]) \\ rveq \\ fs[] \\ match_mp_tac enc_lines_again_simp_label_one \\ qspecl_then[`labs`,`ffis`,`pos`,`enc`,`lines`,`[]`,`T`]mp_tac enc_lines_again_simp_EQ \\ simp[] \\ pairarg_tac \\ rw[] - \\ metis_tac[]); + \\ metis_tac[] +QED (* simple consequences of label_one *) -Theorem line_length_pad_section1 - `∀nop ls acc. +Theorem line_length_pad_section1: + ∀nop ls acc. LENGTH nop = 1 ∧ EVERY label_one ls ∧ EVERY line_length_leq ls ∧ @@ -2469,22 +2605,26 @@ Theorem line_length_pad_section1 SUM (MAP line_length acc) = SUM (MAP line_len acc) ⇒ SUM (MAP line_length (pad_section nop ls acc)) = - SUM (MAP line_len ls) + SUM (MAP line_len acc)` - (recInduct pad_section_ind + SUM (MAP line_len ls) + SUM (MAP line_len acc) +Proof + recInduct pad_section_ind \\ rw[pad_section_def] \\ fs[MAP_REVERSE,SUM_REVERSE,line_length_def,LENGTH_pad_bytes] - \\ fs[line_length_add_nop1,line_len_add_nop1]); + \\ fs[line_length_add_nop1,line_len_add_nop1] +QED -Theorem line_len_pad_section1 - `∀nop xs aux. +Theorem line_len_pad_section1: + ∀nop xs aux. LENGTH nop = 1 ∧ EVERY label_one xs ∧ ¬EVERY is_Label aux ⇒ SUM (MAP line_len (pad_section nop xs aux)) = - SUM (MAP line_len xs) + SUM (MAP line_len aux)` - (recInduct pad_section_ind - \\ rw[pad_section_def,MAP_REVERSE,SUM_REVERSE,line_len_add_nop1]); + SUM (MAP line_len xs) + SUM (MAP line_len aux) +Proof + recInduct pad_section_ind + \\ rw[pad_section_def,MAP_REVERSE,SUM_REVERSE,line_len_add_nop1] +QED (* invariant: lines are encoded and annotated lengths are correct *) @@ -2530,31 +2670,38 @@ val all_encd_def = Define` (* length_leq follows from encd *) -Theorem line_encd_length_leq - `∀enc labs ffis pos l. line_encd enc labs ffis pos l ⇒ line_length_leq l` - (recInduct line_encd_ind \\ rw[line_encd_def,line_length_leq_def]); - -Theorem lines_encd_length_leq - `∀enc labs ffis pos ls. lines_encd enc labs ffis pos ls ⇒ EVERY line_length_leq ls` - (Induct_on`ls` \\ rw[lines_encd_def] - \\ metis_tac[line_encd_length_leq]); - -Theorem all_encd_length_leq - `∀enc labs ffis pos ls. all_encd enc labs ffis pos ls ⇒ all_length_leq ls` - (Induct_on`ls` \\ simp[] +Theorem line_encd_length_leq: + ∀enc labs ffis pos l. line_encd enc labs ffis pos l ⇒ line_length_leq l +Proof + recInduct line_encd_ind \\ rw[line_encd_def,line_length_leq_def] +QED + +Theorem lines_encd_length_leq: + ∀enc labs ffis pos ls. lines_encd enc labs ffis pos ls ⇒ EVERY line_length_leq ls +Proof + Induct_on`ls` \\ rw[lines_encd_def] + \\ metis_tac[line_encd_length_leq] +QED + +Theorem all_encd_length_leq: + ∀enc labs ffis pos ls. all_encd enc labs ffis pos ls ⇒ all_length_leq ls +Proof + Induct_on`ls` \\ simp[] \\ Cases \\ simp[all_encd_def] - \\ metis_tac[lines_encd_length_leq]); + \\ metis_tac[lines_encd_length_leq] +QED (* establishing encd *) -Theorem enc_lines_again_simp_encd - `∀labs ffis pos enc lines res. +Theorem enc_lines_again_simp_encd: + ∀labs ffis pos enc lines res. enc_lines_again_simp labs ffis pos enc lines = (res,T) ∧ EVERY label_one lines ∧ EVERY (line_encd0 enc) lines ⇒ - lines_encd enc labs ffis pos res` - (ho_match_mp_tac enc_lines_again_simp_ind + lines_encd enc labs ffis pos res +Proof + ho_match_mp_tac enc_lines_again_simp_ind \\ rw[enc_lines_again_simp_def] \\ fs[lines_encd_def] \\ pairarg_tac \\ fs[] @@ -2563,16 +2710,18 @@ Theorem enc_lines_again_simp_encd \\ TRY ( qmatch_assum_abbrev_tac`MAX l1 l = l` \\ `l1 ≤ l` by fs[MAX_DEF]) - \\ Cases_on`a` \\ fs[line_encd_def,get_jump_offset_def,lab_inst_def,get_label_def]); + \\ Cases_on`a` \\ fs[line_encd_def,get_jump_offset_def,lab_inst_def,get_label_def] +QED -Theorem enc_secs_again_encd - `∀pos labs ffis enc ls res. +Theorem enc_secs_again_encd: + ∀pos labs ffis enc ls res. enc_secs_again pos labs ffis enc ls = (res,T) ∧ EVERY sec_label_one ls ∧ EVERY (sec_encd0 enc) ls ⇒ - all_encd enc labs ffis pos res` - (recInduct enc_secs_again_ind + all_encd enc labs ffis pos res +Proof + recInduct enc_secs_again_ind \\ rw[enc_secs_again_def] \\ fs[all_encd_def] \\ rpt(pairarg_tac \\ fs[]) @@ -2581,7 +2730,8 @@ Theorem enc_secs_again_encd \\ simp[] \\ pairarg_tac \\ fs[] \\ strip_tac \\ rveq \\ fs[sec_length_sum_line_len] \\ imp_res_tac enc_lines_again_simp_len \\ fs[] - \\ imp_res_tac enc_lines_again_simp_encd); + \\ imp_res_tac enc_lines_again_simp_encd +QED (* invariant: annotated lengths are correct *) @@ -2593,13 +2743,15 @@ val sec_length_ok_def = Define` (* simple consequences of length_ok *) -Theorem sec_length_sum_line_length - `∀ls n. +Theorem sec_length_sum_line_length: + ∀ls n. EVERY line_length_ok ls ⇒ - (sec_length ls n = SUM (MAP line_length ls) + n)` - (ho_match_mp_tac sec_length_ind + (sec_length ls n = SUM (MAP line_length ls) + n) +Proof + ho_match_mp_tac sec_length_ind \\ rw[sec_length_def,line_length_def] - \\ fs[line_length_ok_def,line_bytes_def,line_length_def]); + \\ fs[line_length_ok_def,line_bytes_def,line_length_def] +QED (* invariant: all labels annotated with length 0 *) @@ -2618,80 +2770,93 @@ val EVERY_label_zero_add_nop = Q.prove( Induct \\ fs [add_nop_def,EVERY_REVERSE] \\ Cases \\ fs [add_nop_def,EVERY_REVERSE]); -Theorem EVERY_label_zero_pad_section[simp] - `∀nop xs aux. +Theorem EVERY_label_zero_pad_section[simp]: + ∀nop xs aux. EVERY label_zero aux ⇒ - EVERY label_zero (pad_section nop xs aux)` - (ho_match_mp_tac pad_section_ind + EVERY label_zero (pad_section nop xs aux) +Proof + ho_match_mp_tac pad_section_ind >> srw_tac[][pad_section_def] >> srw_tac[][EVERY_REVERSE]>> - first_assum match_mp_tac>>fs[EVERY_label_zero_add_nop]); + first_assum match_mp_tac>>fs[EVERY_label_zero_add_nop] +QED -Theorem EVERY_sec_label_zero_pad_code[simp] - `∀nop ls. EVERY sec_label_zero (pad_code nop ls)` - (ho_match_mp_tac pad_code_ind +Theorem EVERY_sec_label_zero_pad_code[simp]: + ∀nop ls. EVERY sec_label_zero (pad_code nop ls) +Proof + ho_match_mp_tac pad_code_ind \\ srw_tac[][pad_code_def] \\ fs [] \\ srw_tac[][sec_label_zero_def] \\ unabbrev_all_tac \\ fs [] - \\ fs [EVERY_REVERSE,EVERY_label_zero_add_nop]); + \\ fs [EVERY_REVERSE,EVERY_label_zero_add_nop] +QED -Theorem enc_lines_again_simp_label_zero - `∀labs ffis pos enc ls res ok. +Theorem enc_lines_again_simp_label_zero: + ∀labs ffis pos enc ls res ok. enc_lines_again_simp labs ffis pos enc ls = (res,ok) ∧ EVERY label_zero ls ⇒ - EVERY label_zero res` - (recInduct enc_lines_again_simp_ind + EVERY label_zero res +Proof + recInduct enc_lines_again_simp_ind \\ rw[enc_lines_again_simp_def] \\ fs[] - \\ pairarg_tac \\ fs[] \\ rveq \\ fs[]); + \\ pairarg_tac \\ fs[] \\ rveq \\ fs[] +QED -Theorem enc_secs_again_label_zero - `∀pos labs ffis enc lines res ok. +Theorem enc_secs_again_label_zero: + ∀pos labs ffis enc lines res ok. enc_secs_again pos labs ffis enc lines = (res,ok) ∧ EVERY sec_label_zero lines ⇒ - EVERY sec_label_zero res` - (recInduct enc_secs_again_ind + EVERY sec_label_zero res +Proof + recInduct enc_secs_again_ind \\ rw[enc_secs_again_def] \\ fs[] \\ rpt(pairarg_tac \\ fs[]) \\ rveq \\ fs[sec_label_zero_def] \\ match_mp_tac enc_lines_again_simp_label_zero \\ qspecl_then[`labs`,`ffis`,`pos`,`enc`,`lines`,`[]`,`T`]mp_tac enc_lines_again_simp_EQ \\ simp[] \\ pairarg_tac \\ rw[] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem lines_upd_lab_len_encd0_label_zero - `∀pos lines aux. +Theorem lines_upd_lab_len_encd0_label_zero: + ∀pos lines aux. enc_ok c ∧ enc = c.encode ∧ c.code_alignment ≠ 0 ∧ EVERY (line_encd0 enc) lines ∧ EVEN pos ∧ EVERY label_zero aux ⇒ - EVERY label_zero (FST (lines_upd_lab_len pos lines aux))` - (recInduct lines_upd_lab_len_ind + EVERY label_zero (FST (lines_upd_lab_len pos lines aux)) +Proof + recInduct lines_upd_lab_len_ind \\ rw[lines_upd_lab_len_def,EVERY_REVERSE] \\ first_x_assum match_mp_tac \\ fs[EVEN_ADD,line_encd0_def] \\ fs[enc_ok_def] \\ rfs[GSYM bitTheory.MOD_2EXP_def] - \\ metis_tac[MOD_2EXP_0_EVEN,NOT_ZERO_LT_ZERO]); + \\ metis_tac[MOD_2EXP_0_EVEN,NOT_ZERO_LT_ZERO] +QED -Theorem EVEN_sec_length_lines_upd_lab_len - `∀pos lines acc. +Theorem EVEN_sec_length_lines_upd_lab_len: + ∀pos lines acc. (if NULL lines then EVEN pos ∧ EVEN (SUM (MAP line_len acc)) else is_Label (LAST lines) ∧ EVEN (pos + (SUM (MAP line_len acc)))) ⇒ - EVEN (SUM (MAP line_len (FST (lines_upd_lab_len pos lines acc))))` - (recInduct lines_upd_lab_len_ind + EVEN (SUM (MAP line_len (FST (lines_upd_lab_len pos lines acc)))) +Proof + recInduct lines_upd_lab_len_ind \\ rw[lines_upd_lab_len_def,MAP_REVERSE,SUM_REVERSE] \\ Cases_on`xs` \\ fs[] \\ first_x_assum match_mp_tac - \\ fs[EVEN_ADD,EVEN_MULT]); + \\ fs[EVEN_ADD,EVEN_MULT] +QED -Theorem upd_lab_len_encd0_label_zero - `∀pos code. +Theorem upd_lab_len_encd0_label_zero: + ∀pos code. enc_ok c ∧ enc = c.encode ∧ c.code_alignment ≠ 0 ∧ all_encd0 enc code ∧ EVEN pos ∧ EVERY sec_ends_with_label code ⇒ - EVERY sec_label_zero (upd_lab_len pos code)` - (recInduct upd_lab_len_ind + EVERY sec_label_zero (upd_lab_len pos code) +Proof + recInduct upd_lab_len_ind \\ rw[upd_lab_len_def,sec_label_zero_def] \\ pairarg_tac \\ fs[] \\ fs[sec_label_zero_def] @@ -2702,42 +2867,51 @@ Theorem upd_lab_len_encd0_label_zero \\ first_x_assum match_mp_tac \\ fs[] \\ qspecl_then[`pos`,`lines`,`[]`]mp_tac SND_lines_upd_lab_len \\ qspecl_then[`pos`,`lines`,`[]`]mp_tac EVEN_sec_length_lines_upd_lab_len - \\ fs[sec_ends_with_label_def,EVEN_ADD]); + \\ fs[sec_ends_with_label_def,EVEN_ADD] +QED (* simple consequences of label_zero *) -Theorem sec_pos_val_0 - `∀pos lines. ¬EVERY is_Label lines ∧ EVERY label_zero lines ⇒ sec_pos_val 0 pos lines = SOME pos` - (Induct_on`lines` \\ rw[sec_pos_val_def] - \\ Cases_on`h` \\ fs[line_length_def]); +Theorem sec_pos_val_0: + ∀pos lines. ¬EVERY is_Label lines ∧ EVERY label_zero lines ⇒ sec_pos_val 0 pos lines = SOME pos +Proof + Induct_on`lines` \\ rw[sec_pos_val_def] + \\ Cases_on`h` \\ fs[line_length_def] +QED -Theorem line_len_pad_section0 - `∀nop ls aux. +Theorem line_len_pad_section0: + ∀nop ls aux. EVERY label_zero ls ⇒ SUM (MAP line_len (pad_section nop ls aux)) = - SUM (MAP line_len ls) + SUM (MAP line_len aux)` - (recInduct pad_section_ind - \\ rw[pad_section_def,MAP_REVERSE,SUM_REVERSE]); + SUM (MAP line_len ls) + SUM (MAP line_len aux) +Proof + recInduct pad_section_ind + \\ rw[pad_section_def,MAP_REVERSE,SUM_REVERSE] +QED -Theorem sec_label_zero_pos_val_0 ` - ∀xs pos. +Theorem sec_label_zero_pos_val_0: + ∀xs pos. EVERY sec_label_zero xs ⇒ - pos_val 0 pos xs = pos` - (Induct_on`xs`>>srw_tac[][pos_val_def]>>full_simp_tac(srw_ss())[] + pos_val 0 pos xs = pos +Proof + Induct_on`xs`>>srw_tac[][pos_val_def]>>full_simp_tac(srw_ss())[] >> Cases_on`h`>>srw_tac[][pos_val_def] >> Induct_on`l` >> srw_tac[][pos_val_def] >> full_simp_tac(srw_ss())[sec_label_zero_def] >> Cases_on`h`>>full_simp_tac(srw_ss())[] - >> srw_tac[][line_length_def]); + >> srw_tac[][line_length_def] +QED -Theorem all_enc_ok_imp_sec_label_zero ` - !conf labs ffis n code. +Theorem all_enc_ok_imp_sec_label_zero: + !conf labs ffis n code. all_enc_ok conf labs ffis n code ⇒ - EVERY sec_label_zero code` - (ho_match_mp_tac all_enc_ok_ind>> + EVERY sec_label_zero code +Proof + ho_match_mp_tac all_enc_ok_ind>> rw[]>>fs[sec_label_zero_def,all_enc_ok_def]>> - Cases_on`y`>>fs[line_ok_def]); + Cases_on`y`>>fs[line_ok_def] +QED (* invariant: lines aligned *) @@ -2752,13 +2926,14 @@ val _ = export_rewrites["sec_aligned_def"]; (* establishing aligned *) -Theorem all_encd0_aligned - `∀c enc code. +Theorem all_encd0_aligned: + ∀c enc code. enc_ok c ∧ enc = c.encode ∧ all_encd0 enc code ∧ EVERY sec_label_zero code ⇒ - EVERY (sec_aligned (LENGTH (enc (Inst Skip)))) code` - (ntac 2 gen_tac + EVERY (sec_aligned (LENGTH (enc (Inst Skip)))) code +Proof + ntac 2 gen_tac \\ Induct \\ simp[] \\ Cases \\ simp[sec_label_zero_def] \\ strip_tac \\ fs[] @@ -2768,36 +2943,41 @@ Theorem all_encd0_aligned \\ strip_tac \\ rfs[] \\ rveq \\ fs[] \\ rw[] \\ match_mp_tac ZERO_MOD \\ simp[] - \\ metis_tac[bitTheory.ZERO_LT_TWOEXP]); + \\ metis_tac[bitTheory.ZERO_LT_TWOEXP] +QED (* aligned preservation *) -Theorem enc_lines_again_simp_aligned - `∀labs ffis pos enc ls res ok. +Theorem enc_lines_again_simp_aligned: + ∀labs ffis pos enc ls res ok. (∀a. LENGTH (enc a) MOD len = 0) ∧ enc_lines_again_simp labs ffis pos enc ls = (res,ok) ∧ EVERY (line_aligned len) ls ⇒ - EVERY (line_aligned len) res` - (recInduct enc_lines_again_simp_ind + EVERY (line_aligned len) res +Proof + recInduct enc_lines_again_simp_ind \\ rw[enc_lines_again_simp_def] \\ fs[] \\ pairarg_tac \\ fs[] \\ rveq \\ fs[] \\ fs[line_aligned_def,line_length_def,MAX_DEF] - \\ IF_CASES_TAC \\ fs[]); + \\ IF_CASES_TAC \\ fs[] +QED -Theorem enc_secs_again_aligned - `∀pos labs ffis enc lines res ok. +Theorem enc_secs_again_aligned: + ∀pos labs ffis enc lines res ok. (∀a. LENGTH (enc a) MOD len = 0) ∧ enc_secs_again pos labs ffis enc lines = (res,ok) ∧ EVERY (sec_aligned len) lines ⇒ - EVERY (sec_aligned len) res` - (recInduct enc_secs_again_ind + EVERY (sec_aligned len) res +Proof + recInduct enc_secs_again_ind \\ rw[enc_secs_again_def] \\ fs[] \\ rpt(pairarg_tac \\ fs[]) \\ rveq \\ fs[] \\ match_mp_tac enc_lines_again_simp_aligned \\ qspecl_then[`labs`,`ffis`,`pos`,`enc`,`lines`,`[]`,`T`]mp_tac enc_lines_again_simp_EQ \\ simp[] \\ pairarg_tac \\ rw[] - \\ metis_tac[]); + \\ metis_tac[] +QED (* invariant: all initial labels have annotated length 0 *) @@ -2810,11 +2990,12 @@ val sec_label_prefix_zero_def = Define` sec_label_prefix_zero (Section k ls) ⇔ label_prefix_zero ls`; val _ = export_rewrites["sec_label_prefix_zero_def"]; -Theorem label_prefix_zero_cons - `(label_prefix_zero (Label l1 l2 len::ls) ⇔ ((len = 0) ∧ label_prefix_zero ls)) ∧ +Theorem label_prefix_zero_cons: + (label_prefix_zero (Label l1 l2 len::ls) ⇔ ((len = 0) ∧ label_prefix_zero ls)) ∧ (label_prefix_zero (Asm a b c::ls) ⇔ T) ∧ - (label_prefix_zero (LabAsm d e f g::ls) ⇔ T)` - (rw[label_prefix_zero_def] + (label_prefix_zero (LabAsm d e f g::ls) ⇔ T) +Proof + rw[label_prefix_zero_def] \\ TRY ( Cases_on`n` \\ fs[] \\ first_x_assum(qspec_then`0`mp_tac) @@ -2832,44 +3013,52 @@ Theorem label_prefix_zero_cons \\ simp[] \\ qx_gen_tac`z` \\ strip_tac \\ first_x_assum(qspec_then`SUC z`mp_tac) - \\ simp[]); + \\ simp[] +QED (* establishing label_prefix_zero *) -Theorem label_prefix_zero_append_suff - `∀l1 l2. +Theorem label_prefix_zero_append_suff: + ∀l1 l2. label_prefix_zero l1 ∧ label_prefix_zero l2 ⇒ - label_prefix_zero (l1 ++ l2)` - (Induct + label_prefix_zero (l1 ++ l2) +Proof + Induct >- simp[label_prefix_zero_def] - \\ Cases \\ simp[label_prefix_zero_cons]); + \\ Cases \\ simp[label_prefix_zero_cons] +QED -Theorem label_prefix_zero_append_suff2 - `∀l1 l2. +Theorem label_prefix_zero_append_suff2: + ∀l1 l2. label_prefix_zero l1 ∧ EXISTS ($~ o is_Label) l1 ⇒ - label_prefix_zero (l1 ++ l2)` - (Induct + label_prefix_zero (l1 ++ l2) +Proof + Induct >- simp[label_prefix_zero_def] - \\ Cases \\ simp[label_prefix_zero_cons]); + \\ Cases \\ simp[label_prefix_zero_cons] +QED -Theorem lines_upd_lab_len_label_prefix_zero - `∀pos ls acc. +Theorem lines_upd_lab_len_label_prefix_zero: + ∀pos ls acc. (EVERY is_Label acc ⇒ EVEN pos) ∧ label_prefix_zero (REVERSE acc) ⇒ - label_prefix_zero (FST (lines_upd_lab_len pos ls acc))` - (recInduct lines_upd_lab_len_ind + label_prefix_zero (FST (lines_upd_lab_len pos ls acc)) +Proof + recInduct lines_upd_lab_len_ind \\ rw[lines_upd_lab_len_def] \\ first_x_assum match_mp_tac \\ fs[EVEN_ADD] \\ TRY ( match_mp_tac label_prefix_zero_append_suff \\ fs[] \\ fs[label_prefix_zero_def] \\ NO_TAC) \\ match_mp_tac label_prefix_zero_append_suff2 - \\ simp[EXISTS_REVERSE]); + \\ simp[EXISTS_REVERSE] +QED -Theorem upd_lab_len_label_prefix_zero - `∀pos ss. +Theorem upd_lab_len_label_prefix_zero: + ∀pos ss. EVEN pos ∧ EVERY sec_ends_with_label ss ⇒ - EVERY sec_label_prefix_zero (upd_lab_len pos ss)` - (recInduct upd_lab_len_ind + EVERY sec_label_prefix_zero (upd_lab_len pos ss) +Proof + recInduct upd_lab_len_ind \\ rw[upd_lab_len_def] \\ pairarg_tac \\ fs[] \\ conj_tac @@ -2880,37 +3069,42 @@ Theorem upd_lab_len_label_prefix_zero \\ qspecl_then[`pos`,`lines`,`[]`]mp_tac SND_lines_upd_lab_len \\ simp[EVEN_ADD] \\ qspecl_then[`pos`,`lines`,`[]`]mp_tac EVEN_sec_length_lines_upd_lab_len - \\ fs[sec_ends_with_label_def]); + \\ fs[sec_ends_with_label_def] +QED (* label_prefix_zero preservation *) -Theorem enc_lines_again_simp_label_prefix_zero - `∀labs ffis pos enc ls res ok. +Theorem enc_lines_again_simp_label_prefix_zero: + ∀labs ffis pos enc ls res ok. enc_lines_again_simp labs ffis pos enc ls = (res,ok) ∧ label_prefix_zero ls ⇒ - label_prefix_zero res` - (recInduct enc_lines_again_simp_ind + label_prefix_zero res +Proof + recInduct enc_lines_again_simp_ind \\ rw[enc_lines_again_simp_def] \\ rpt(pairarg_tac \\ fs[]) \\ fs[] - \\ rveq \\ fs[label_prefix_zero_cons]); + \\ rveq \\ fs[label_prefix_zero_cons] +QED -Theorem enc_secs_again_label_prefix_zero - `∀pos labs ffis enc lines res ok. +Theorem enc_secs_again_label_prefix_zero: + ∀pos labs ffis enc lines res ok. enc_secs_again pos labs ffis enc lines = (res,ok) ∧ EVERY sec_label_prefix_zero lines ⇒ - EVERY sec_label_prefix_zero res` - (recInduct enc_secs_again_ind + EVERY sec_label_prefix_zero res +Proof + recInduct enc_secs_again_ind \\ rw[enc_secs_again_def] \\ fs[] \\ rpt(pairarg_tac \\ fs[]) \\ rveq \\ fs[] \\ match_mp_tac enc_lines_again_simp_label_prefix_zero \\ qspecl_then[`labs`,`ffis`,`pos`,`enc`,`lines`,`[]`,`T`]mp_tac enc_lines_again_simp_EQ \\ simp[] \\ pairarg_tac \\ rw[] - \\ metis_tac[]); + \\ metis_tac[] +QED (* simple consequences of label_prefix_zero *) -Theorem line_length_pad_section - `∀nop ls acc. +Theorem line_length_pad_section: + ∀nop ls acc. LENGTH nop = 1 ∧ EVERY label_one ls ∧ EVERY line_length_leq ls ∧ @@ -2918,28 +3112,32 @@ Theorem line_length_pad_section EVERY is_Label acc ∧ label_prefix_zero ls ⇒ SUM (MAP line_length (pad_section nop ls acc)) = - SUM (MAP line_len ls) + SUM (MAP line_len acc)` - (recInduct pad_section_ind + SUM (MAP line_len ls) + SUM (MAP line_len acc) +Proof + recInduct pad_section_ind \\ rw[pad_section_def] \\ fs[MAP_REVERSE,SUM_REVERSE,line_length_def,LENGTH_pad_bytes,label_prefix_zero_cons] \\ fs[line_length_add_nop,line_len_add_nop] \\ qmatch_goalsub_abbrev_tac`pad_section nop xs acc'` \\ qspecl_then[`nop`,`xs`,`acc'`]mp_tac line_length_pad_section1 - \\ simp[Abbr`acc'`,line_length_def,LENGTH_pad_bytes]); + \\ simp[Abbr`acc'`,line_length_def,LENGTH_pad_bytes] +QED -Theorem label_zero_line_length_pad_section - `∀nop ls acc. +Theorem label_zero_line_length_pad_section: + ∀nop ls acc. 0 < LENGTH nop ∧ EVERY label_zero ls ∧ MAP line_length acc = MAP line_len acc ∧ EVERY line_length_leq ls ⇒ MAP line_length (pad_section nop ls acc) = - MAP line_len (REVERSE acc ++ ls)` - (recInduct pad_section_ind + MAP line_len (REVERSE acc ++ ls) +Proof + recInduct pad_section_ind \\ rw[pad_section_def,line_length_def,MAP_REVERSE] \\ fs[pad_section_def] - \\ fs[LENGTH_pad_bytes]); + \\ fs[LENGTH_pad_bytes] +QED (* invariant: lines encd with nops *) @@ -2975,12 +3173,14 @@ val lines_enc_with_nop_def = Define` line_enc_with_nop enc labs ffis pos l ∧ lines_enc_with_nop enc labs ffis (pos+line_length l) ls)`; -Theorem lines_enc_with_nop_append - `∀enc labs ffis pos l1 l2. +Theorem lines_enc_with_nop_append: + ∀enc labs ffis pos l1 l2. lines_enc_with_nop enc labs ffis pos (l1 ++ l2) ⇔ lines_enc_with_nop enc labs ffis pos l1 ∧ - lines_enc_with_nop enc labs ffis (pos + SUM (MAP line_length l1)) l2` - (Induct_on`l1` \\ rw[lines_enc_with_nop_def,EQ_IMP_THM]); + lines_enc_with_nop enc labs ffis (pos + SUM (MAP line_length l1)) l2 +Proof + Induct_on`l1` \\ rw[lines_enc_with_nop_def,EQ_IMP_THM] +QED val all_enc_with_nop_def = Define` (all_enc_with_nop enc labs ffis pos [] ⇔ T) ∧ @@ -2992,87 +3192,106 @@ val all_enc_with_nop_def = Define` val all_enc_with_nop_ind = theorem"all_enc_with_nop_ind"; -Theorem all_enc_with_nop_alt - `(all_enc_with_nop enc labs ffis pos [] ⇔ T) ∧ +Theorem all_enc_with_nop_alt: + (all_enc_with_nop enc labs ffis pos [] ⇔ T) ∧ (all_enc_with_nop enc labs ffis pos (Section k ls::ss) ⇔ lines_enc_with_nop enc labs ffis pos ls ∧ - all_enc_with_nop enc labs ffis (pos + SUM (MAP line_length ls)) ss)` - (rw[all_enc_with_nop_def] + all_enc_with_nop enc labs ffis (pos + SUM (MAP line_length ls)) ss) +Proof + rw[all_enc_with_nop_def] \\ map_every qid_spec_tac[`pos`,`ls`] \\ Induct \\ rw[all_enc_with_nop_def,lines_enc_with_nop_def] - \\ rw[EQ_IMP_THM]); + \\ rw[EQ_IMP_THM] +QED (* enc_with_nop implies length_ok *) -Theorem line_enc_with_nop_length_ok - `∀enc labs ffis pos line. - line_enc_with_nop enc labs ffis pos line ⇒ line_length_ok line` - (recInduct line_enc_with_nop_ind - \\ rw[line_enc_with_nop_def,line_length_ok_def,line_length_def,line_bytes_def]); - -Theorem lines_enc_with_nop_length_ok - `∀enc labs ffis pos ls. lines_enc_with_nop enc labs ffis pos ls ⇒ EVERY line_length_ok ls` - (Induct_on`ls` \\ simp[lines_enc_with_nop_def] +Theorem line_enc_with_nop_length_ok: + ∀enc labs ffis pos line. + line_enc_with_nop enc labs ffis pos line ⇒ line_length_ok line +Proof + recInduct line_enc_with_nop_ind + \\ rw[line_enc_with_nop_def,line_length_ok_def,line_length_def,line_bytes_def] +QED + +Theorem lines_enc_with_nop_length_ok: + ∀enc labs ffis pos ls. lines_enc_with_nop enc labs ffis pos ls ⇒ EVERY line_length_ok ls +Proof + Induct_on`ls` \\ simp[lines_enc_with_nop_def] \\ Cases \\ simp[line_length_ok_def,line_bytes_def,line_enc_with_nop_def,line_length_def] \\ rw[] \\ TRY(first_x_assum match_mp_tac \\ metis_tac[]) - \\ Cases_on`a` \\ fs[line_enc_with_nop_def]); + \\ Cases_on`a` \\ fs[line_enc_with_nop_def] +QED (* enc_with_nop implies label_zero *) -Theorem line_enc_with_nop_label_zero - `∀enc labs ffis pos line. - line_enc_with_nop enc labs ffis pos line ⇒ label_zero line` - (recInduct line_enc_with_nop_ind - \\ rw[line_enc_with_nop_def]); - -Theorem lines_enc_with_nop_label_zero - `∀enc labs ffis pos lines. - lines_enc_with_nop enc labs ffis pos lines ⇒ EVERY label_zero lines` - (Induct_on`lines` +Theorem line_enc_with_nop_label_zero: + ∀enc labs ffis pos line. + line_enc_with_nop enc labs ffis pos line ⇒ label_zero line +Proof + recInduct line_enc_with_nop_ind + \\ rw[line_enc_with_nop_def] +QED + +Theorem lines_enc_with_nop_label_zero: + ∀enc labs ffis pos lines. + lines_enc_with_nop enc labs ffis pos lines ⇒ EVERY label_zero lines +Proof + Induct_on`lines` \\ rw[lines_enc_with_nop_def] - \\ metis_tac[line_enc_with_nop_label_zero]); + \\ metis_tac[line_enc_with_nop_label_zero] +QED -Theorem all_enc_with_nop_label_zero - `∀enc labs ffis pos ls. +Theorem all_enc_with_nop_label_zero: + ∀enc labs ffis pos ls. all_enc_with_nop enc labs ffis pos ls ⇒ - EVERY sec_label_zero ls` - (recInduct all_enc_with_nop_ind + EVERY sec_label_zero ls +Proof + recInduct all_enc_with_nop_ind \\ rw[all_enc_with_nop_def,sec_label_zero_def] - \\ metis_tac[line_enc_with_nop_label_zero]); + \\ metis_tac[line_enc_with_nop_label_zero] +QED (* line_ok implies enc_with_nop *) -Theorem line_ok_line_enc_with_nop - `∀c labs ffis pos line. +Theorem line_ok_line_enc_with_nop: + ∀c labs ffis pos line. line_ok c labs ffis pos line ⇒ - line_enc_with_nop c.encode labs ffis pos line` - (recInduct line_ok_ind + line_enc_with_nop c.encode labs ffis pos line +Proof + recInduct line_ok_ind \\ rw[line_ok_def,line_enc_with_nop_def,get_label_def,lab_inst_def] \\ fs(bool_case_eq_thms) \\ imp_res_tac lab_lookup_IMP - \\ rw[line_ok_def,line_enc_with_nop_def,get_label_def,lab_inst_def]); + \\ rw[line_ok_def,line_enc_with_nop_def,get_label_def,lab_inst_def] +QED -Theorem lines_ok_lines_enc_with_nop - `∀c labs ffis pos lines. +Theorem lines_ok_lines_enc_with_nop: + ∀c labs ffis pos lines. lines_ok c labs ffis pos lines ⇒ - lines_enc_with_nop c.encode labs ffis pos lines` - (Induct_on`lines` \\ rw[lines_ok_def,lines_enc_with_nop_def] - \\ metis_tac[line_ok_line_enc_with_nop]); + lines_enc_with_nop c.encode labs ffis pos lines +Proof + Induct_on`lines` \\ rw[lines_ok_def,lines_enc_with_nop_def] + \\ metis_tac[line_ok_line_enc_with_nop] +QED (* establishing enc_with_nop *) -Theorem enc_with_nop_pad_bytes_length - `enc_with_nop enc x (pad_bytes (enc x) (LENGTH (enc x)) (enc (Inst Skip)))` - (rw[enc_with_nop_thm,pad_bytes_def] - \\ qexists_tac`0` \\ simp[REPLICATE] ) +Theorem enc_with_nop_pad_bytes_length: + enc_with_nop enc x (pad_bytes (enc x) (LENGTH (enc x)) (enc (Inst Skip))) +Proof + rw[enc_with_nop_thm,pad_bytes_def] + \\ qexists_tac`0` \\ simp[REPLICATE] +QED -Theorem enc_with_nop_pad_bytes - `nop = enc (Inst Skip) ∧ LENGTH (enc x) ≤ len ∧ +Theorem enc_with_nop_pad_bytes: + nop = enc (Inst Skip) ∧ LENGTH (enc x) ≤ len ∧ LENGTH (enc x) MOD (LENGTH nop) = 0 ∧ len MOD (LENGTH nop) = 0 ∧ 0 < LENGTH nop - ⇒ enc_with_nop enc x (pad_bytes (enc x) len nop)` - (rw[enc_with_nop_thm,pad_bytes_def] + ⇒ enc_with_nop enc x (pad_bytes (enc x) len nop) +Proof + rw[enc_with_nop_thm,pad_bytes_def] >- (qexists_tac`0` \\ simp[REPLICATE]) \\ simp[TAKE_APPEND2] \\ drule (GEN_ALL MOD_EQ_0_DIVISOR) @@ -3089,15 +3308,17 @@ Theorem enc_with_nop_pad_bytes \\ match_mp_tac TAKE_FLAT_REPLICATE_LEQ \\ simp[] \\ match_mp_tac LESS_EQ_TRANS \\ qexists_tac`a * LENGTH (enc (Inst Skip))` - \\ simp[]); + \\ simp[] +QED -Theorem lines_enc_with_nop_add_nop - `∀enc labs ffis pos ls. +Theorem lines_enc_with_nop_add_nop: + ∀enc labs ffis pos ls. LENGTH (enc (Inst Skip)) = 1 ∧ lines_enc_with_nop enc labs ffis pos (REVERSE ls) ⇒ lines_enc_with_nop enc labs ffis pos - (REVERSE (add_nop (enc (Inst Skip)) ls))` - (Induct_on`ls` + (REVERSE (add_nop (enc (Inst Skip)) ls)) +Proof + Induct_on`ls` \\ rw[lines_enc_with_nop_def,add_nop_def] \\ simp[add_nop_append,REVERSE_APPEND,lines_enc_with_nop_append,lines_enc_with_nop_def] \\ Cases_on`h`\\fs[add_nop_def,line_enc_with_nop_def,EVERY_REVERSE] @@ -3114,18 +3335,20 @@ Theorem lines_enc_with_nop_add_nop \\ qmatch_goalsub_rename_tac`REPLICATE z` \\ qexists_tac`SUC z` \\ rewrite_tac[REPLICATE_GENLIST] - \\ simp[GENLIST] ) + \\ simp[GENLIST] +QED -Theorem lines_enc_with_nop_pad_section1 - `∀nop code aux pos. +Theorem lines_enc_with_nop_pad_section1: + ∀nop code aux pos. nop = enc (Inst Skip) ∧ LENGTH nop = 1 ∧ lines_encd enc labs ffis (pos + (SUM (MAP line_len aux))) code ∧ lines_enc_with_nop enc labs ffis pos (REVERSE aux) ∧ ¬EVERY is_Label aux ∧ EVERY label_one code ⇒ - lines_enc_with_nop enc labs ffis pos (pad_section nop code aux)` - (recInduct pad_section_ind + lines_enc_with_nop enc labs ffis pos (pad_section nop code aux) +Proof + recInduct pad_section_ind \\ rw[pad_section_def,lines_enc_with_nop_append] \\ fs[lines_enc_with_nop_def,line_enc_with_nop_def] \\ first_x_assum match_mp_tac @@ -3147,17 +3370,19 @@ Theorem lines_enc_with_nop_pad_section1 \\ Cases_on`y` \\ fs[line_encd_def,line_enc_with_nop_def] \\ rveq \\ fs[MAP_REVERSE,SUM_REVERSE,LENGTH_pad_bytes] \\ qmatch_abbrev_tac`enc_with_nop enc x (pad_bytes (enc x) len nop)` - \\ match_mp_tac enc_with_nop_pad_bytes \\ fs[])); + \\ match_mp_tac enc_with_nop_pad_bytes \\ fs[]) +QED -Theorem lines_enc_with_nop_pad_section01 - `∀nop code aux pos. +Theorem lines_enc_with_nop_pad_section01: + ∀nop code aux pos. nop = enc (Inst Skip) ∧ 0 < LENGTH nop ∧ EVERY (line_aligned (LENGTH nop)) code ∧ lines_encd enc labs ffis (pos + SUM (MAP line_len aux)) code ∧ lines_enc_with_nop enc labs ffis pos (REVERSE aux) ∧ ¬EVERY is_Label aux ∧ EVERY label_zero code ⇒ - lines_enc_with_nop enc labs ffis pos (pad_section nop code aux)` - (recInduct pad_section_ind + lines_enc_with_nop enc labs ffis pos (pad_section nop code aux) +Proof + recInduct pad_section_ind \\ rw[pad_section_def,lines_enc_with_nop_def] \\ first_x_assum match_mp_tac \\ fs[lines_enc_with_nop_append,lines_enc_with_nop_def,line_enc_with_nop_def] @@ -3173,17 +3398,19 @@ Theorem lines_enc_with_nop_pad_section01 \\ first_x_assum(qspec_then`0`mp_tac) \\ rw[sec_length_sum_line_len] \\ fs[MAP_REVERSE,SUM_REVERSE] - \\ match_mp_tac enc_with_nop_pad_bytes \\ fs[]); + \\ match_mp_tac enc_with_nop_pad_bytes \\ fs[] +QED -Theorem lines_enc_with_nop_pad_section0 - `∀nop code aux pos. +Theorem lines_enc_with_nop_pad_section0: + ∀nop code aux pos. nop = enc (Inst Skip) ∧ 0 < LENGTH nop ∧ EVERY (line_aligned (LENGTH nop)) code ∧ lines_encd enc labs ffis (pos + SUM (MAP line_len aux)) code ∧ lines_enc_with_nop enc labs ffis pos (REVERSE aux) ∧ EVERY is_Label aux ∧ EVERY label_zero code ⇒ - lines_enc_with_nop enc labs ffis pos (pad_section nop code aux)` - (recInduct pad_section_ind + lines_enc_with_nop enc labs ffis pos (pad_section nop code aux) +Proof + recInduct pad_section_ind \\ rw[pad_section_def,lines_enc_with_nop_def] \\ TRY ( first_x_assum match_mp_tac @@ -3202,16 +3429,18 @@ Theorem lines_enc_with_nop_pad_section0 \\ first_x_assum(qspec_then`0`mp_tac) \\ rw[sec_length_sum_line_len] \\ fs[MAP_REVERSE,SUM_REVERSE] - \\ match_mp_tac enc_with_nop_pad_bytes \\ fs[]); + \\ match_mp_tac enc_with_nop_pad_bytes \\ fs[] +QED -Theorem lines_enc_with_nop_pad_section - `∀nop code aux pos. +Theorem lines_enc_with_nop_pad_section: + ∀nop code aux pos. nop = enc (Inst Skip) ∧ LENGTH nop = 1 ∧ lines_encd enc labs ffis (pos + SUM (MAP line_len aux)) code ∧ lines_enc_with_nop enc labs ffis pos (REVERSE aux) ∧ EVERY is_Label aux ∧ EVERY label_one code ∧ label_prefix_zero code ⇒ - lines_enc_with_nop enc labs ffis pos (pad_section nop code aux)` - (recInduct pad_section_ind + lines_enc_with_nop enc labs ffis pos (pad_section nop code aux) +Proof + recInduct pad_section_ind \\ rw[pad_section_def,lines_enc_with_nop_append] \\ rfs[EVERY_is_Label_add_nop,label_prefix_zero_cons] \\ TRY ( @@ -3227,18 +3456,20 @@ Theorem lines_enc_with_nop_pad_section \\ first_x_assum(qspec_then`0`mp_tac) \\ rw[sec_length_sum_line_len] \\ fs[MAP_REVERSE,SUM_REVERSE] - \\ match_mp_tac enc_with_nop_pad_bytes \\ fs[]); + \\ match_mp_tac enc_with_nop_pad_bytes \\ fs[] +QED -Theorem all_enc_with_nop_pad_code - `∀nop code pos. +Theorem all_enc_with_nop_pad_code: + ∀nop code pos. 0 < LENGTH nop ∧ nop = enc (Inst Skip) ∧ (LENGTH nop ≠ 1 ⇒ EVERY (sec_aligned (LENGTH nop)) code ∧ EVERY sec_label_zero code) ∧ EVERY sec_label_one code ∧ EVERY sec_length_leq code ∧ EVERY sec_label_prefix_zero code ∧ all_encd enc labs ffis pos code ⇒ - all_enc_with_nop enc labs ffis pos (pad_code nop code)` - (recInduct pad_code_ind + all_enc_with_nop enc labs ffis pos (pad_code nop code) +Proof + recInduct pad_code_ind \\ reverse(rw[pad_code_def,all_enc_with_nop_alt,all_encd_def]) \\ fs[] >- ( @@ -3254,7 +3485,8 @@ Theorem all_enc_with_nop_pad_code match_mp_tac lines_enc_with_nop_pad_section \\ fs[lines_enc_with_nop_def] ) \\ match_mp_tac lines_enc_with_nop_pad_section0 - \\ fs[sec_label_zero_def,lines_enc_with_nop_def]); + \\ fs[sec_label_zero_def,lines_enc_with_nop_def] +QED (* invariant: label annotation correctly records alignment *) @@ -3269,13 +3501,15 @@ val lab_len_pos_ok_def = Define` line_lab_len_pos_ok pos l ∧ lab_len_pos_ok (pos + line_len l) ls)`; -Theorem lab_len_pos_ok_append - `∀l1 pos l2. +Theorem lab_len_pos_ok_append: + ∀l1 pos l2. lab_len_pos_ok pos (l1 ++ l2) ⇔ lab_len_pos_ok pos l1 ∧ - lab_len_pos_ok (pos + SUM (MAP line_len l1)) l2` - (Induct \\ simp[lab_len_pos_ok_def] - \\ metis_tac[]); + lab_len_pos_ok (pos + SUM (MAP line_len l1)) l2 +Proof + Induct \\ simp[lab_len_pos_ok_def] + \\ metis_tac[] +QED val all_lab_len_pos_ok_def = Define` (all_lab_len_pos_ok _ [] ⇔ T) ∧ @@ -3287,72 +3521,83 @@ val all_lab_len_pos_ok_ind = theorem"all_lab_len_pos_ok_ind"; (* establishing pos_ok *) -Theorem lines_upd_lab_len_pos_ok - `∀pos lines. - lab_len_pos_ok pos (FST (lines_upd_lab_len pos lines []))` - (Induct_on`lines` +Theorem lines_upd_lab_len_pos_ok: + ∀pos lines. + lab_len_pos_ok pos (FST (lines_upd_lab_len pos lines [])) +Proof + Induct_on`lines` \\ simp[lines_upd_lab_len_def,lab_len_pos_ok_def] \\ reverse Cases \\ simp[lines_upd_lab_len_def] \\ simp[Once lines_upd_lab_len_AUX,lab_len_pos_ok_def] - \\ simp[line_lab_len_pos_ok_def] ) - -Theorem upd_lab_len_pos_ok - `∀pos code. - all_lab_len_pos_ok pos (upd_lab_len pos code)` - (recInduct upd_lab_len_ind + \\ simp[line_lab_len_pos_ok_def] +QED + +Theorem upd_lab_len_pos_ok: + ∀pos code. + all_lab_len_pos_ok pos (upd_lab_len pos code) +Proof + recInduct upd_lab_len_ind \\ rw[all_lab_len_pos_ok_def,upd_lab_len_def] \\ pairarg_tac \\ fs[all_lab_len_pos_ok_def] \\ qspecl_then[`pos`,`lines`,`[]`]mp_tac SND_lines_upd_lab_len \\ qspecl_then[`pos`,`lines`]mp_tac lines_upd_lab_len_pos_ok - \\ rw[sec_length_sum_line_len] \\ fs[]) + \\ rw[sec_length_sum_line_len] \\ fs[] +QED (* pos_ok preservation *) -Theorem enc_lines_again_simp_pos_ok - `∀labs ffis pos enc lines res. +Theorem enc_lines_again_simp_pos_ok: + ∀labs ffis pos enc lines res. enc_lines_again_simp labs ffis pos enc lines = (res,T) ∧ lab_len_pos_ok pos lines ⇒ - lab_len_pos_ok pos res` - (recInduct enc_lines_again_simp_ind + lab_len_pos_ok pos res +Proof + recInduct enc_lines_again_simp_ind \\ rw[enc_lines_again_simp_def] \\ fs[] \\ pairarg_tac \\ fs[] \\ rveq \\ fs[lab_len_pos_ok_def] - \\ fs[line_lab_len_pos_ok_def]); + \\ fs[line_lab_len_pos_ok_def] +QED -Theorem enc_secs_again_pos_ok - `∀pos labs ffis enc code res. +Theorem enc_secs_again_pos_ok: + ∀pos labs ffis enc code res. enc_secs_again pos labs ffis enc code = (res,T) ∧ all_lab_len_pos_ok pos code ⇒ - all_lab_len_pos_ok pos res` - (recInduct enc_secs_again_ind + all_lab_len_pos_ok pos res +Proof + recInduct enc_secs_again_ind \\ rw[enc_secs_again_def] \\ fs[] \\ rpt(pairarg_tac \\ fs[]) \\ rveq \\ qspecl_then[`labs`,`ffis`,`pos`,`enc`,`lines`,`[]`,`T`]mp_tac enc_lines_again_simp_EQ \\ rw[] \\ pairarg_tac \\ fs[] \\ rveq \\ imp_res_tac enc_lines_again_simp_len \\ fs[sec_length_sum_line_len,all_lab_len_pos_ok_def] - \\ imp_res_tac enc_lines_again_simp_pos_ok); + \\ imp_res_tac enc_lines_again_simp_pos_ok +QED -Theorem lab_len_pos_ok_even_prefix_zero - `∀pos ls. +Theorem lab_len_pos_ok_even_prefix_zero: + ∀pos ls. EVEN pos ∧ lab_len_pos_ok pos ls ⇒ - label_prefix_zero ls` - (Induct_on`ls` + label_prefix_zero ls +Proof + Induct_on`ls` >- rw[lab_len_pos_ok_def,label_prefix_zero_def] \\ Cases \\ rw[lab_len_pos_ok_def,label_prefix_zero_cons,line_lab_len_pos_ok_def] - \\ fs[] \\ metis_tac[]); + \\ fs[] \\ metis_tac[] +QED -Theorem pad_section_pos_ok - `∀nop lines aux pos. +Theorem pad_section_pos_ok: + ∀nop lines aux pos. lab_len_pos_ok (pos + SUM (MAP line_len aux)) lines ∧ lab_len_pos_ok pos (REVERSE aux) ∧ EVERY label_zero aux ∧ ((NULL aux ∨ is_Label (HD aux)) ⇒ label_prefix_zero lines) ⇒ - lab_len_pos_ok pos (pad_section nop lines aux)` - (recInduct pad_section_ind + lab_len_pos_ok pos (pad_section nop lines aux) +Proof + recInduct pad_section_ind \\ rw[pad_section_def,lab_len_pos_ok_def] \\ fs[pad_section_def] \\ first_x_assum match_mp_tac @@ -3376,32 +3621,36 @@ Theorem pad_section_pos_ok \\ pop_assum kall_tac \\ Cases_on`aux`\\fs[] \\ Cases_on`h` \\ fs[add_nop_def,lab_len_pos_ok_append] - \\ fs[lab_len_pos_ok_def,line_lab_len_pos_ok_def]); + \\ fs[lab_len_pos_ok_def,line_lab_len_pos_ok_def] +QED -Theorem line_len_pad_section - `∀nop xs aux. +Theorem line_len_pad_section: + ∀nop xs aux. LENGTH nop = 1 ∧ EVERY label_one xs ∧ (EVERY is_Label aux ⇒ label_prefix_zero xs) ⇒ SUM (MAP line_len (pad_section nop xs aux)) = - SUM (MAP line_len xs) + SUM (MAP line_len aux)` - (recInduct pad_section_ind + SUM (MAP line_len xs) + SUM (MAP line_len aux) +Proof + recInduct pad_section_ind \\ rw[pad_section_def,SUM_REVERSE,MAP_REVERSE,label_prefix_zero_cons] \\ fs[line_len_add_nop1] \\ `len=1` by decide_tac \\ fs[] \\ first_x_assum match_mp_tac - \\ metis_tac[NOT_EVERY]); + \\ metis_tac[NOT_EVERY] +QED -Theorem all_lab_len_pos_ok_pad_code - `∀nop code pos. +Theorem all_lab_len_pos_ok_pad_code: + ∀nop code pos. all_lab_len_pos_ok pos code ∧ (LENGTH nop ≠ 1 ⇒ EVERY sec_label_zero code) ∧ EVERY sec_label_one code ∧ EVERY sec_label_prefix_zero code ⇒ - all_lab_len_pos_ok pos (pad_code nop code)` - (recInduct pad_code_ind + all_lab_len_pos_ok pos (pad_code nop code) +Proof + recInduct pad_code_ind \\ rw[all_lab_len_pos_ok_def,pad_code_def] >- ( match_mp_tac pad_section_pos_ok @@ -3412,7 +3661,8 @@ Theorem all_lab_len_pos_ok_pad_code fs[sec_length_sum_line_len,sec_label_zero_def,line_len_pad_section0] ) \\ fs[sec_length_sum_line_len] \\ qspecl_then[`nop`,`xs`,`[]`]mp_tac line_len_pad_section - \\ simp[]); + \\ simp[] +QED (* invariant: jump offsets ok *) @@ -3427,12 +3677,14 @@ val lines_offset_ok_def = Define` line_offset_ok labs ffis pos l ∧ lines_offset_ok labs ffis (pos + line_len l) ls)`; -Theorem lines_offset_ok_append - `∀labs ffis pos l1 l2. +Theorem lines_offset_ok_append: + ∀labs ffis pos l1 l2. lines_offset_ok labs ffis pos (l1 ++ l2) ⇔ lines_offset_ok labs ffis pos l1 ∧ - lines_offset_ok labs ffis (pos + SUM (MAP line_len l1)) l2` - (Induct_on`l1` \\ rw[lines_offset_ok_def,EQ_IMP_THM]); + lines_offset_ok labs ffis (pos + SUM (MAP line_len l1)) l2 +Proof + Induct_on`l1` \\ rw[lines_offset_ok_def,EQ_IMP_THM] +QED val offset_ok_def = Define` (offset_ok labs ffis pos [] ⇔ T) ∧ @@ -3444,23 +3696,26 @@ val offset_ok_ind = theorem"offset_ok_ind"; (* establishing offset_ok *) -Theorem enc_lines_again_simp_offset_ok - `∀labs ffis pos enc lines res ok. +Theorem enc_lines_again_simp_offset_ok: + ∀labs ffis pos enc lines res ok. enc_lines_again_simp labs ffis pos enc lines = (res,ok) ⇒ - lines_offset_ok labs ffis pos res` - (ho_match_mp_tac enc_lines_again_simp_ind + lines_offset_ok labs ffis pos res +Proof + ho_match_mp_tac enc_lines_again_simp_ind \\ rw[enc_lines_again_simp_def] \\ fs[lines_offset_ok_def] \\ pairarg_tac \\ fs[] \\ rveq \\ fs[lines_offset_ok_def] - \\ fs[line_offset_ok_def]); + \\ fs[line_offset_ok_def] +QED -Theorem enc_secs_again_offset_ok - `∀pos labs ffis enc ls res ok. +Theorem enc_secs_again_offset_ok: + ∀pos labs ffis enc ls res ok. enc_secs_again pos labs ffis enc ls = (res,ok) ⇒ - offset_ok labs ffis pos res` - (ho_match_mp_tac enc_secs_again_ind + offset_ok labs ffis pos res +Proof + ho_match_mp_tac enc_secs_again_ind \\ rw[enc_secs_again_def] \\ fs[offset_ok_def] \\ pairarg_tac \\ fs[] @@ -3470,19 +3725,21 @@ Theorem enc_secs_again_offset_ok \\ simp[] \\ pairarg_tac \\ fs[] \\ strip_tac \\ rveq \\ fs[sec_length_sum_line_len] \\ match_mp_tac enc_lines_again_simp_offset_ok - \\ metis_tac[]); + \\ metis_tac[] +QED (* offset_ok preservation *) -Theorem lines_offset_ok_pad_section - `∀nop lines aux labs ffis pos. +Theorem lines_offset_ok_pad_section: + ∀nop lines aux labs ffis pos. lab_len_pos_ok (pos + SUM (MAP line_len aux)) lines ∧ lab_len_pos_ok pos (REVERSE aux) ∧ EVERY label_zero aux ∧ (¬NULL lines ∧ is_Label (HD lines) ∧ line_len (HD lines) = 1 ⇒ ¬NULL aux ∧ ¬is_Label (HD aux)) ∧ lines_offset_ok labs ffis pos (REVERSE aux ++ lines) ⇒ - lines_offset_ok labs ffis pos (pad_section nop lines aux)` - (recInduct pad_section_ind + lines_offset_ok labs ffis pos (pad_section nop lines aux) +Proof + recInduct pad_section_ind \\ rw[pad_section_def,lines_offset_ok_append,lines_offset_ok_def, lab_len_pos_ok_append,lab_len_pos_ok_def,line_lab_len_pos_ok_def] \\ fs[MAP_REVERSE,SUM_REVERSE,SUM_APPEND] @@ -3503,17 +3760,19 @@ Theorem lines_offset_ok_pad_section \\ Cases_on`xs` \\ fs[lab_len_pos_ok_def] \\ Cases_on`h` \\ fs[line_lab_len_pos_ok_def] \\ fs[EVEN_ADD] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem offset_ok_pad_code - `∀labs ffis pos code. +Theorem offset_ok_pad_code: + ∀labs ffis pos code. (LENGTH nop ≠ 1 ⇒ EVERY sec_label_zero code) ∧ EVERY sec_label_one code ∧ EVERY sec_label_prefix_zero code ∧ all_lab_len_pos_ok pos code ∧ offset_ok labs ffis pos code ⇒ - offset_ok labs ffis pos (pad_code nop code)` - (recInduct offset_ok_ind + offset_ok labs ffis pos (pad_code nop code) +Proof + recInduct offset_ok_ind \\ rw[offset_ok_def,pad_code_def,sec_label_zero_def] \\ fs[] \\ `SUM (MAP line_len (pad_section nop ls [])) = @@ -3528,7 +3787,8 @@ Theorem offset_ok_pad_code \\ disch_then match_mp_tac \\ spose_not_then strip_assume_tac \\ Cases_on`ls` \\ fs[] - \\ Cases_on`h` \\ fs[label_prefix_zero_cons]); + \\ Cases_on`h` \\ fs[label_prefix_zero_cons] +QED (* invariant: referenced labels exist *) @@ -3549,114 +3809,145 @@ val _ = overload_on("all_labs_exist",``λlabs code. EVERY (sec_labs_exist labs) (* labs_exist preservation *) -Theorem line_similar_line_labs_exist - `∀l1 l2. line_similar l1 l2 ⇒ (line_labs_exist labs l1 ⇔ line_labs_exist labs l2)` - (recInduct line_similar_ind - \\ rw[line_similar_def]); - -Theorem code_similar_all_labs_exist - `∀c1 c2. code_similar c1 c2 ⇒ (all_labs_exist labs c1 ⇔ all_labs_exist labs c2)` - (recInduct code_similar_ind +Theorem line_similar_line_labs_exist: + ∀l1 l2. line_similar l1 l2 ⇒ (line_labs_exist labs l1 ⇔ line_labs_exist labs l2) +Proof + recInduct line_similar_ind + \\ rw[line_similar_def] +QED + +Theorem code_similar_all_labs_exist: + ∀c1 c2. code_similar c1 c2 ⇒ (all_labs_exist labs c1 ⇔ all_labs_exist labs c2) +Proof + recInduct code_similar_ind \\ rw[code_similar_def] \\ fs[LIST_REL_EL_EQN, EVERY_MEM, MEM_EL] - \\ metis_tac[line_similar_line_labs_exist]); + \\ metis_tac[line_similar_line_labs_exist] +QED -Theorem all_labs_exist_pad_code[simp] - `∀nop code. all_labs_exist labs (pad_code nop code) ⇔ all_labs_exist labs code` - (metis_tac[code_similar_pad_code, code_similar_all_labs_exist, code_similar_refl]); +Theorem all_labs_exist_pad_code[simp]: + ∀nop code. all_labs_exist labs (pad_code nop code) ⇔ all_labs_exist labs code +Proof + metis_tac[code_similar_pad_code, code_similar_all_labs_exist, code_similar_refl] +QED -Theorem enc_lines_again_line_labs_exist - `∀labs ffis pos enc lines acc ok res ok' k. +Theorem enc_lines_again_line_labs_exist: + ∀labs ffis pos enc lines acc ok res ok' k. enc_lines_again labs ffis pos enc lines (acc,ok) = (res,ok') ∧ EVERY (line_labs_exist labs') acc ∧ EVERY (line_labs_exist labs') lines ⇒ - EVERY (line_labs_exist labs') res` - (recInduct enc_lines_again_ind + EVERY (line_labs_exist labs') res +Proof + recInduct enc_lines_again_ind \\ rw[enc_lines_again_def] - \\ rw[EVERY_REVERSE]); + \\ rw[EVERY_REVERSE] +QED -Theorem enc_secs_again_all_labs_exist - `∀pos ffis labs enc ls res ok k. +Theorem enc_secs_again_all_labs_exist: + ∀pos ffis labs enc ls res ok k. enc_secs_again pos ffis labs enc ls = (res,ok) ∧ all_labs_exist labs' ls ⇒ - all_labs_exist labs' res` - (recInduct enc_secs_again_ind + all_labs_exist labs' res +Proof + recInduct enc_secs_again_ind \\ rw[enc_secs_again_def] \\ rw[] \\ rpt(pairarg_tac \\ fs[]) \\ rw[] \\ match_mp_tac enc_lines_again_line_labs_exist - \\ asm_exists_tac \\ fs[]); + \\ asm_exists_tac \\ fs[] +QED -Theorem upd_lab_len_all_labs_exist - `∀pos code. all_labs_exist labs (upd_lab_len pos code) ⇔ all_labs_exist labs code` - (metis_tac[code_similar_upd_lab_len, code_similar_all_labs_exist, code_similar_refl]); +Theorem upd_lab_len_all_labs_exist: + ∀pos code. all_labs_exist labs (upd_lab_len pos code) ⇔ all_labs_exist labs code +Proof + metis_tac[code_similar_upd_lab_len, code_similar_all_labs_exist, code_similar_refl] +QED (* establishing labs_exist *) -Theorem line_similar_line_get_code_labels - `∀l1 l2. line_similar l1 l2 ⇒ line_get_code_labels l1 = line_get_code_labels l2` - (recInduct line_similar_ind - \\ rw[line_similar_def]); - -Theorem code_similar_get_code_labels - `∀c1 c2. code_similar c1 c2 ⇒ get_code_labels c1 = get_code_labels c2` - (recInduct code_similar_ind +Theorem line_similar_line_get_code_labels: + ∀l1 l2. line_similar l1 l2 ⇒ line_get_code_labels l1 = line_get_code_labels l2 +Proof + recInduct line_similar_ind + \\ rw[line_similar_def] +QED + +Theorem code_similar_get_code_labels: + ∀c1 c2. code_similar c1 c2 ⇒ get_code_labels c1 = get_code_labels c2 +Proof + recInduct code_similar_ind \\ rw[code_similar_def, get_code_labels_cons] \\ AP_THM_TAC \\ AP_TERM_TAC \\ rw[sec_get_code_labels_def] \\ AP_TERM_TAC \\ AP_TERM_TAC \\ AP_TERM_TAC \\ fs[Once EXTENSION,MEM_EL,LIST_REL_EL_EQN,PULL_EXISTS] - \\ metis_tac[line_similar_line_get_code_labels]); - -Theorem line_labs_exist_get_labels - `∀labs line. line_labs_exist labs line ⇔ line_get_labels line ⊆ labs_domain labs` - (recInduct line_labs_exist_ind - \\ rw[line_labs_exist_def, line_get_labels_def, labs_domain_def, SUBSET_DEF, FORALL_PROD]); - -Theorem sec_labs_exist_get_labels - `∀labs sec. sec_labs_exist labs sec ⇔ sec_get_labels sec ⊆ labs_domain labs` - (Cases_on`sec` + \\ metis_tac[line_similar_line_get_code_labels] +QED + +Theorem line_labs_exist_get_labels: + ∀labs line. line_labs_exist labs line ⇔ line_get_labels line ⊆ labs_domain labs +Proof + recInduct line_labs_exist_ind + \\ rw[line_labs_exist_def, line_get_labels_def, labs_domain_def, SUBSET_DEF, FORALL_PROD] +QED + +Theorem sec_labs_exist_get_labels: + ∀labs sec. sec_labs_exist labs sec ⇔ sec_get_labels sec ⊆ labs_domain labs +Proof + Cases_on`sec` \\ rw[sec_labs_exist_def, sec_get_labels_def, line_labs_exist_get_labels, EVERY_MEM, SUBSET_DEF, PULL_EXISTS] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem all_labs_exist_get_labels - `all_labs_exist labs code ⇔ get_labels code ⊆ labs_domain labs` - (rw[EVERY_MEM, sec_labs_exist_get_labels, get_labels_def, +Theorem all_labs_exist_get_labels: + all_labs_exist labs code ⇔ get_labels code ⊆ labs_domain labs +Proof + rw[EVERY_MEM, sec_labs_exist_get_labels, get_labels_def, SUBSET_DEF, PULL_EXISTS] - \\ metis_tac[]); - -Theorem line_similar_line_get_labels - `∀l1 l2. line_similar l1 l2 ⇒ (line_get_labels l1 = line_get_labels l2)` - (recInduct line_similar_ind - \\ rw[line_similar_def, line_get_labels_def]); - -Theorem code_similar_get_labels - `∀c1 c2. code_similar c1 c2 ⇒ get_labels c1 = get_labels c2` - (recInduct code_similar_ind + \\ metis_tac[] +QED + +Theorem line_similar_line_get_labels: + ∀l1 l2. line_similar l1 l2 ⇒ (line_get_labels l1 = line_get_labels l2) +Proof + recInduct line_similar_ind + \\ rw[line_similar_def, line_get_labels_def] +QED + +Theorem code_similar_get_labels: + ∀c1 c2. code_similar c1 c2 ⇒ get_labels c1 = get_labels c2 +Proof + recInduct code_similar_ind \\ rw[code_similar_def, get_labels_def, sec_get_labels_def] \\ AP_THM_TAC \\ AP_TERM_TAC \\ AP_TERM_TAC \\ simp[Once EXTENSION, PULL_EXISTS] \\ fs[LIST_REL_EL_EQN, MEM_EL] - \\ metis_tac[line_similar_line_get_labels]); - -Theorem get_labels_upd_lab_len[simp] - `get_labels (upd_lab_len pos code) = get_labels code` - (metis_tac[code_similar_get_labels, code_similar_upd_lab_len, code_similar_refl]); - -Theorem section_labels_line_get_code_labels - `∀pos lines aux new_pos labs. section_labels pos lines aux = (new_pos, labs) ⇒ - 0 INSERT set (MAP FST labs) = 0 INSERT set (MAP FST aux) ∪ BIGUNION (IMAGE line_get_code_labels (set lines))` - (recInduct section_labels_ind + \\ metis_tac[line_similar_line_get_labels] +QED + +Theorem get_labels_upd_lab_len[simp]: + get_labels (upd_lab_len pos code) = get_labels code +Proof + metis_tac[code_similar_get_labels, code_similar_upd_lab_len, code_similar_refl] +QED + +Theorem section_labels_line_get_code_labels: + ∀pos lines aux new_pos labs. section_labels pos lines aux = (new_pos, labs) ⇒ + 0 INSERT set (MAP FST labs) = 0 INSERT set (MAP FST aux) ∪ BIGUNION (IMAGE line_get_code_labels (set lines)) +Proof + recInduct section_labels_ind \\ rw[section_labels_def] \\ rw[EXTENSION] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem labs_domain_compute_labels_alt - `∀pos code labs. +Theorem labs_domain_compute_labels_alt: + ∀pos code labs. ALL_DISTINCT (MAP Section_num code) ∧ DISJOINT (domain labs) (set (MAP Section_num code)) ⇒ labs_domain (compute_labels_alt pos code labs) = - get_code_labels code ∪ labs_domain labs` - (recInduct compute_labels_alt_ind + get_code_labels code ∪ labs_domain labs +Proof + recInduct compute_labels_alt_ind \\ rw[compute_labels_alt_def] \\ pairarg_tac \\ fs[] \\ fs[labs_domain_insert, domain_fromAList] @@ -3668,7 +3959,8 @@ Theorem labs_domain_compute_labels_alt \\ simp[UNION_COMM] \\ AP_TERM_TAC \\ fs[Once EXTENSION,PULL_EXISTS, FORALL_PROD] - \\ metis_tac[]); + \\ metis_tac[] +QED (* invariant: labels aligned at even positions *) @@ -3687,17 +3979,19 @@ val lines_even_labels_def = Define` (is_Label y ⇒ EVEN pos) ∧ lines_even_labels (pos + line_len y) ys)`; -Theorem even_labels_alt - `(even_labels pos [] ⇔ T) ∧ +Theorem even_labels_alt: + (even_labels pos [] ⇔ T) ∧ (even_labels pos (Section _ ls::ss) ⇔ lines_even_labels pos ls ∧ - even_labels (pos + SUM (MAP line_len ls)) ss)` - (rw[even_labels_def] + even_labels (pos + SUM (MAP line_len ls)) ss) +Proof + rw[even_labels_def] \\ qid_spec_tac `pos` \\ Induct_on`ls` \\ rw[even_labels_def,lines_even_labels_def] \\ Cases_on`h` \\ fs[line_length_def] - \\ metis_tac[]); + \\ metis_tac[] +QED val even_labels_strong_def = Define` (even_labels_strong pos [] ⇔ T) ∧ @@ -3707,37 +4001,42 @@ val even_labels_strong_def = Define` (is_Label y ⇒ EVEN pos) ∧ even_labels_strong (pos + line_len y) (Section k ys::ls))`; -Theorem even_labels_ends_imp_strong - `∀pos code. +Theorem even_labels_ends_imp_strong: + ∀pos code. even_labels pos code ∧ EVERY sec_ends_with_label code ∧ EVERY sec_label_zero code ⇒ - even_labels_strong pos code` - (Induct_on`code` + even_labels_strong pos code +Proof + Induct_on`code` \\ simp[even_labels_def,even_labels_strong_def,sec_ends_with_label_def] \\ Cases \\ simp[sec_ends_with_label_def,sec_label_zero_def] \\ Induct_on`l` \\ fs[] \\ fs[even_labels_def,even_labels_strong_def] \\ Cases_on`l` \\ fs[even_labels_def,even_labels_strong_def] - \\ Cases \\ fs[EVEN_ADD] \\ rw[] \\ fs[]); + \\ Cases \\ fs[EVEN_ADD] \\ rw[] \\ fs[] +QED -Theorem ALOOKUP_section_labels_ignore - `∀pos lines acc. +Theorem ALOOKUP_section_labels_ignore: + ∀pos lines acc. ¬MEM n2 (MAP SND (extract_labels lines)) ⇒ ALOOKUP (SND (section_labels pos lines acc)) n2 = - ALOOKUP acc n2` - (recInduct section_labels_ind - \\ rw[section_labels_def] \\ fs[]); - -Theorem lines_ok_section_lab_lookup_even - `∀pos lines acc. + ALOOKUP acc n2 +Proof + recInduct section_labels_ind + \\ rw[section_labels_def] \\ fs[] +QED + +Theorem lines_ok_section_lab_lookup_even: + ∀pos lines acc. lines_ok c labs ffis pos lines ∧ (∀l2 x. ALOOKUP acc l2 = SOME x ⇒ EVEN x) ∧ ALOOKUP (SND (section_labels pos lines acc)) l2 = SOME x ⇒ - EVEN x` - (ho_match_mp_tac section_labels_ind + EVEN x +Proof + ho_match_mp_tac section_labels_ind \\ rw[lines_ok_def,section_labels_def,line_ok_def,line_length_def] \\ fs[] \\ TRY ( last_x_assum match_mp_tac \\ asm_exists_tac \\ fs[] \\ NO_TAC) \\ TRY ( last_x_assum match_mp_tac \\ rw[] \\ fs[] @@ -3746,7 +4045,8 @@ Theorem lines_ok_section_lab_lookup_even \\ Cases_on`xxx` \\ fs[line_ok_def] \\ rw[] \\ fs(bool_case_eq_thms) \\ imp_res_tac lab_lookup_IMP \\ rw[] \\ last_x_assum match_mp_tac \\ fs[] - \\ asm_exists_tac \\ fs[]) + \\ asm_exists_tac \\ fs[] +QED val all_enc_ok_split = Q.prove(` ∀c labs ffis pos k lines xs. @@ -3801,22 +4101,24 @@ val all_enc_ok_lab_lookup_even = Q.prove( \\ asm_exists_tac \\ fs[] \\ qexists_tac`[]` \\ simp[]); -Theorem line_ok_pre_light_imp_line_ok - `∀c labs ffis pos line. +Theorem line_ok_pre_light_imp_line_ok: + ∀c labs ffis pos line. line_ok_pre c line ∧ line_enc_with_nop c.encode labs ffis pos line ∧ line_offset_ok labs ffis pos line ∧ line_labs_exist labs line ∧ line_ok_light c line ∧ (is_Label line ⇒ EVEN pos) ⇒ - line_ok c labs ffis pos line` - (ho_match_mp_tac line_ok_ind + line_ok c labs ffis pos line +Proof + ho_match_mp_tac line_ok_ind \\ rw[line_ok_def,line_ok_light_def,get_label_def,lab_inst_def,line_enc_with_nop_def, line_ok_pre_def,line_offset_ok_def,get_jump_offset_def] \\ fs[] \\ CASE_TAC - \\ CASE_TAC \\ imp_res_tac lab_lookup_IMP \\ rveq \\ fs[]); + \\ CASE_TAC \\ imp_res_tac lab_lookup_IMP \\ rveq \\ fs[] +QED -Theorem all_enc_ok_pre_light_imp_all_enc_ok - `∀c labs ffis pos code. +Theorem all_enc_ok_pre_light_imp_all_enc_ok: + ∀c labs ffis pos code. all_enc_with_nop c.encode labs ffis pos code ∧ all_enc_ok_pre c code ∧ all_enc_ok_light c code ∧ @@ -3824,8 +4126,9 @@ Theorem all_enc_ok_pre_light_imp_all_enc_ok all_labs_exist labs code ∧ offset_ok labs ffis pos code ⇒ - all_enc_ok c labs ffis pos code` - (ho_match_mp_tac all_enc_ok_ind + all_enc_ok c labs ffis pos code +Proof + ho_match_mp_tac all_enc_ok_ind \\ rw[all_enc_ok_def,all_enc_with_nop_def, even_labels_strong_def,line_ok_pre_light_imp_line_ok, offset_ok_def,lines_offset_ok_def] @@ -3833,7 +4136,8 @@ Theorem all_enc_ok_pre_light_imp_all_enc_ok \\ imp_res_tac line_enc_with_nop_label_zero \\ fs[line_length_ok_def,line_length_def,sec_ends_with_label_def] \\ first_x_assum match_mp_tac - \\ Cases_on`y` \\ fs[even_labels_alt,line_length_def]); + \\ Cases_on`y` \\ fs[even_labels_alt,line_length_def] +QED (* val tm = ``[Label 0 1 0; Label 0 2 1; Label 0 3 0; Label 0 4 1]``; @@ -3845,11 +4149,12 @@ EVAL ``SUM (MAP line_length ^tm)`` EVAL ``SUM (MAP line_length ^tm2)`` *) -Theorem upd_lab_len_ends_with_label - `∀pos ss. +Theorem upd_lab_len_ends_with_label: + ∀pos ss. EVERY sec_ends_with_label ss ⇒ - EVERY sec_ends_with_label (upd_lab_len pos ss)` - (recInduct upd_lab_len_ind + EVERY sec_ends_with_label (upd_lab_len pos ss) +Proof + recInduct upd_lab_len_ind \\ rw[upd_lab_len_def] \\ fs[sec_ends_with_label_def] \\ qspecl_then[`pos`,`lines`,`[]`]mp_tac lines_upd_lab_len_similar @@ -3858,19 +4163,22 @@ Theorem upd_lab_len_ends_with_label \\ fs[LIST_REL_SNOC] \\ strip_tac \\ fs[SNOC_APPEND] \\ Cases_on`x` \\ Cases_on`x'` - \\ fs[line_similar_def,sec_ends_with_label_def]); + \\ fs[line_similar_def,sec_ends_with_label_def] +QED -Theorem lab_lookup_compute_labels_alt_ignore - `∀pos secs acc. +Theorem lab_lookup_compute_labels_alt_ignore: + ∀pos secs acc. ¬MEM n1 (MAP Section_num secs) ⇒ - lab_lookup n1 n2 (compute_labels_alt pos secs acc) = lab_lookup n1 n2 acc` - (recInduct compute_labels_alt_ind + lab_lookup n1 n2 (compute_labels_alt pos secs acc) = lab_lookup n1 n2 acc +Proof + recInduct compute_labels_alt_ind \\ rw[compute_labels_alt_def] \\ pairarg_tac \\ fs[] - \\ rw[lab_lookup_def,lookup_insert]); + \\ rw[lab_lookup_def,lookup_insert] +QED -Theorem ALOOKUP_section_labels - `∀pos lines acc pc. +Theorem ALOOKUP_section_labels: + ∀pos lines acc pc. EVERY (sec_label_ok n1) lines ∧ EVERY line_length_ok lines ∧ EVERY label_zero lines ∧ @@ -3882,8 +4190,9 @@ Theorem ALOOKUP_section_labels ((sec_pos_val pc pos lines = NONE ∧ i = pos + SUM (MAP line_length lines) ∧ pc = LENGTH (FILTER ($~ o is_Label) lines)) ∨ - sec_pos_val pc pos lines = SOME i)` - (ho_match_mp_tac section_labels_ind + sec_pos_val pc pos lines = SOME i) +Proof + ho_match_mp_tac section_labels_ind \\ rw[sec_pos_val_def] \\ fs[sec_loc_to_pc_cons] >- ( fs[sec_loc_to_pc_def] ) @@ -3910,7 +4219,8 @@ Theorem ALOOKUP_section_labels \\ Cases \\ strip_tac \\ res_tac \\ fs[] \\ simp[line_length_def]) \\ fs[section_labels_def,line_length_def,line_length_ok_def] - \\ rveq \\ fs[]); + \\ rveq \\ fs[] +QED val lab_lookup_compute_labels_test = Q.prove( `∀pos sec_list acc l1 l2 x2 c labs ffis nop. @@ -3988,74 +4298,86 @@ val lab_lookup_compute_labels_test = Q.prove( \\ qspecl_then[`lines`,`pos`]mp_tac sec_length_sum_line_length \\ rw[] \\ fs[] \\ first_x_assum match_mp_tac \\ asm_exists_tac \\ fs[]); -Theorem enc_lines_again_simp_ends_with_label - `∀labs ffis pos enc ls res ok. +Theorem enc_lines_again_simp_ends_with_label: + ∀labs ffis pos enc ls res ok. enc_lines_again_simp labs ffis pos enc ls = (res,ok) ∧ ¬NULL ls ∧ is_Label (LAST ls) ⇒ - ¬NULL res ∧ is_Label (LAST res)` - (recInduct enc_lines_again_simp_ind + ¬NULL res ∧ is_Label (LAST res) +Proof + recInduct enc_lines_again_simp_ind \\ rw[enc_lines_again_simp_def] \\ rpt(pairarg_tac \\ fs[]) \\ fs[] \\ rveq \\ fs[LAST_CONS_cond] \\ rw[] \\ fs[NULL_EQ] \\ rw[] \\ fs[] \\ every_case_tac \\ fs[] - \\ fs[enc_lines_again_simp_def]); + \\ fs[enc_lines_again_simp_def] +QED -Theorem enc_secs_again_ends_with_label - `∀pos labs ffis enc lines res ok. +Theorem enc_secs_again_ends_with_label: + ∀pos labs ffis enc lines res ok. enc_secs_again pos labs ffis enc lines = (res,ok) ∧ EVERY sec_ends_with_label lines ⇒ - EVERY sec_ends_with_label res` - (recInduct enc_secs_again_ind + EVERY sec_ends_with_label res +Proof + recInduct enc_secs_again_ind \\ rw[enc_secs_again_def] \\ fs[] \\ rpt(pairarg_tac \\ fs[]) \\ rveq \\ fs[] \\ fs[sec_ends_with_label_def] \\ match_mp_tac enc_lines_again_simp_ends_with_label \\ qspecl_then[`labs`,`ffis`,`pos`,`enc`,`lines`,`[]`,`T`]mp_tac enc_lines_again_simp_EQ \\ simp[] \\ pairarg_tac \\ rw[] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem enc_sec_list_ends_with_label - `∀enc code. +Theorem enc_sec_list_ends_with_label: + ∀enc code. EVERY sec_ends_with_label code ⇒ - EVERY sec_ends_with_label (enc_sec_list enc code)` - (Induct_on`code` \\ fs[enc_sec_list_def] + EVERY sec_ends_with_label (enc_sec_list enc code) +Proof + Induct_on`code` \\ fs[enc_sec_list_def] \\ Cases \\ fs[enc_sec_def,sec_ends_with_label_def] \\ Induct_on`l` \\ fs[LAST_CONS_cond] - \\ Cases \\ gen_tac \\ IF_CASES_TAC \\ fs[enc_line_def,NULL_EQ]); + \\ Cases \\ gen_tac \\ IF_CASES_TAC \\ fs[enc_line_def,NULL_EQ] +QED -Theorem lines_even_labels_append - `∀l1 l2 pos. +Theorem lines_even_labels_append: + ∀l1 l2 pos. lines_even_labels pos (l1 ++ l2) ⇔ lines_even_labels pos l1 ∧ - lines_even_labels (pos + SUM (MAP line_len l1)) l2` - (Induct \\ simp[lines_even_labels_def] + lines_even_labels (pos + SUM (MAP line_len l1)) l2 +Proof + Induct \\ simp[lines_even_labels_def] \\ fsrw_tac[DNF_ss][EQ_IMP_THM] \\ rw[] \\ full_simp_tac std_ss [ADD_COMM] \\ full_simp_tac std_ss [ADD_ASSOC] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem label_zero_pos_ok_lines_even_labels - `∀pos ls. +Theorem label_zero_pos_ok_lines_even_labels: + ∀pos ls. EVERY label_zero ls ∧ lab_len_pos_ok pos ls ⇒ - lines_even_labels pos ls` - (Induct_on`ls` \\ simp[lines_even_labels_def,lab_len_pos_ok_def] + lines_even_labels pos ls +Proof + Induct_on`ls` \\ simp[lines_even_labels_def,lab_len_pos_ok_def] \\ Cases \\ simp[line_lab_len_pos_ok_def] - \\ rpt strip_tac \\ rfs[]); + \\ rpt strip_tac \\ rfs[] +QED -Theorem label_zero_pos_ok_even_labels - `∀pos code. +Theorem label_zero_pos_ok_even_labels: + ∀pos code. EVERY sec_label_zero code ∧ all_lab_len_pos_ok pos code ⇒ - even_labels pos code` - (recInduct all_lab_len_pos_ok_ind + even_labels pos code +Proof + recInduct all_lab_len_pos_ok_ind \\ rw[all_lab_len_pos_ok_def,even_labels_alt, sec_length_sum_line_len,sec_label_zero_def] \\ match_mp_tac label_zero_pos_ok_lines_even_labels - \\ fs[]); + \\ fs[] +QED (* val code = ``[Label a1 b1 0; Label a2 b2 0; Asm x3 [b3] 1; Label a4 b4 1; Label a5 b5 0]`` @@ -4079,11 +4401,12 @@ Theorem label_zero_pos_ok_even_labels [Label a4 b4 0; Asm x3 [b3;nop] 2; Label a2 b2 0; Label a1 b1 0] *) -Theorem pad_code_ends_with_label - `∀nop ls. +Theorem pad_code_ends_with_label: + ∀nop ls. EVERY sec_ends_with_label ls ⇒ - EVERY sec_ends_with_label (pad_code nop ls)` - (recInduct pad_code_ind + EVERY sec_ends_with_label (pad_code nop ls) +Proof + recInduct pad_code_ind \\ simp[pad_code_def,sec_ends_with_label_def] \\ rpt gen_tac \\ ntac 2 strip_tac \\ qspecl_then[`nop`,`xs`,`[]`,`xs`]mp_tac line_similar_pad_section @@ -4092,24 +4415,28 @@ Theorem pad_code_ends_with_label \\ Q.ISPEC_THEN`xs`FULL_STRUCT_CASES_TAC SNOC_CASES \\ fs[] \\ rw[LIST_REL_SNOC,SNOC_APPEND] \\ fs[] \\ Cases_on`x` - \\ Cases_on`y` \\ fs[line_similar_def]); + \\ Cases_on`y` \\ fs[line_similar_def] +QED -Theorem enc_lines_again_section_labels - `∀labs ffis pos enc lines res acc. +Theorem enc_lines_again_section_labels: + ∀labs ffis pos enc lines res acc. enc_lines_again_simp labs ffis pos enc lines = (res,T) ⇒ - section_labels pos lines acc = section_labels pos res acc` - (recInduct enc_lines_again_simp_ind + section_labels pos lines acc = section_labels pos res acc +Proof + recInduct enc_lines_again_simp_ind \\ rw[enc_lines_again_simp_def,section_labels_def] \\ rpt(pairarg_tac \\ fs[]) - \\ rw[section_labels_def]); + \\ rw[section_labels_def] +QED -Theorem enc_secs_again_compute_labels - `∀pos labs ffis enc secs res acc. +Theorem enc_secs_again_compute_labels: + ∀pos labs ffis enc secs res acc. enc_secs_again pos labs ffis enc secs = (res,T) ⇒ compute_labels_alt pos res acc = - compute_labels_alt pos secs acc` - (recInduct enc_secs_again_ind + compute_labels_alt pos secs acc +Proof + recInduct enc_secs_again_ind \\ rw[enc_secs_again_def] \\ rpt(pairarg_tac \\ fs[]) \\ rw[compute_labels_alt_def] @@ -4119,7 +4446,8 @@ Theorem enc_secs_again_compute_labels \\ imp_res_tac enc_lines_again_section_labels \\ fs[] \\ rveq \\ AP_THM_TAC \\ qspecl_then[`pos`,`lines1`,`[]`]mp_tac section_labels_sec_length \\ rw[] - \\ rw[FUN_EQ_THM]); + \\ rw[FUN_EQ_THM] +QED (* val code = ``[Label 1 1 0; Label 1 2 0; Asm x3 [b3] 1; Label 1 3 1; Label 1 4 0]`` @@ -4143,16 +4471,17 @@ Theorem enc_secs_again_compute_labels [Label 1 3 0; Asm x3 [b3;nop] 2; Label 1 2 0; Label 1 1 0] *) -Theorem pad_section_labels - `∀nop lines aux pos labs. +Theorem pad_section_labels: + ∀nop lines aux pos labs. lab_len_pos_ok (pos + SUM (MAP line_len aux)) lines ∧ lab_len_pos_ok pos (REVERSE aux) ∧ EVERY label_zero aux ∧ (¬NULL lines ∧ is_Label (HD lines) ∧ line_len (HD lines) = 1 ⇒ ¬NULL aux ∧ ¬is_Label (HD aux)) ⇒ section_labels pos (pad_section nop lines aux) labs = - section_labels pos (REVERSE aux ++ lines) labs` - (recInduct pad_section_ind + section_labels pos (REVERSE aux ++ lines) labs +Proof + recInduct pad_section_ind \\ rw[section_labels_def,pad_section_def,section_labels_append, lab_len_pos_ok_append,lab_len_pos_ok_def,line_lab_len_pos_ok_def, label_prefix_zero_cons] @@ -4176,18 +4505,20 @@ Theorem pad_section_labels \\ Cases_on`xs` \\ fs[lab_len_pos_ok_def] \\ Cases_on`h` \\ fs[line_lab_len_pos_ok_def] \\ fs[EVEN_ADD] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem pad_code_compute_labels - `∀pos code acc. +Theorem pad_code_compute_labels: + ∀pos code acc. EVERY sec_label_one code ∧ (LENGTH nop ≠ 1 ⇒ EVERY sec_label_zero code) ∧ EVERY sec_label_prefix_zero code ∧ all_lab_len_pos_ok pos code ⇒ compute_labels_alt pos (pad_code nop code) acc = - compute_labels_alt pos code acc` - (recInduct compute_labels_alt_ind + compute_labels_alt pos code acc +Proof + recInduct compute_labels_alt_ind \\ rw[compute_labels_alt_def,pad_code_def,all_lab_len_pos_ok_def] \\ fs[sec_length_sum_line_len,sec_label_zero_def] \\ rpt(pairarg_tac \\ fs[]) @@ -4207,7 +4538,8 @@ Theorem pad_code_compute_labels spose_not_then strip_assume_tac \\ Cases_on`lines` \\ fs[] \\ Cases_on`h` \\ fs[label_prefix_zero_cons] ) - \\ simp[]); + \\ simp[] +QED val enc_lines_again_all_enc_ok_pre = Q.prove(` ∀labs ffis pos enc lines acc ok res ok' c. @@ -4270,13 +4602,14 @@ val EXP_IMP_ZERO_LT = Q.prove( `(2n ** y = x) ⇒ 0 < x`, metis_tac[bitTheory.TWOEXP_NOT_ZERO,NOT_ZERO_LT_ZERO]); -Theorem line_ok_alignment - `∀c labs ffis pos line. +Theorem line_ok_alignment: + ∀c labs ffis pos line. enc_ok c ∧ line_ok c labs ffis pos line ∧ ODD (line_length line) - ⇒ c.code_alignment = 0` - (ho_match_mp_tac line_ok_ind + ⇒ c.code_alignment = 0 +Proof + ho_match_mp_tac line_ok_ind \\ srw_tac[][line_ok_def,line_length_def,LET_THM] \\ full_simp_tac(srw_ss())[enc_ok_def] \\ TRY(Cases_on`b`) @@ -4291,18 +4624,21 @@ Theorem line_ok_alignment \\ full_simp_tac(srw_ss())[ODD_ADD,ODD_EVEN,EVEN_MULT] \\ imp_res_tac EXP_IMP_ZERO_LT \\ imp_res_tac MOD_EQ_0_DIVISOR - \\ full_simp_tac(srw_ss())[EVEN_MULT]); + \\ full_simp_tac(srw_ss())[EVEN_MULT] +QED -Theorem has_odd_inst_alignment - `∀c labs ffis pos code. +Theorem has_odd_inst_alignment: + ∀c labs ffis pos code. enc_ok c ∧ all_enc_ok c labs ffis pos code ∧ has_odd_inst code - ⇒ c.code_alignment = 0` - (ho_match_mp_tac all_enc_ok_ind + ⇒ c.code_alignment = 0 +Proof + ho_match_mp_tac all_enc_ok_ind \\ simp[all_enc_ok_def,has_odd_inst_def] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] - \\ metis_tac[line_ok_alignment,ODD_EVEN]); + \\ metis_tac[line_ok_alignment,ODD_EVEN] +QED val remove_labels_loop_thm = Q.prove( `∀n c init_pos init_labs ffis code code2 labs. @@ -4493,10 +4829,11 @@ val remove_labels_loop_thm = Q.prove( \\ fs [code_similar_upd_lab_len,Abbr`code2`] \\ metis_tac [code_similar_trans]); -Theorem loc_to_pc_enc_sec_list[simp] - `∀l1 l2 code. - loc_to_pc l1 l2 (enc_sec_list e code) = loc_to_pc l1 l2 code` - (simp[enc_sec_list_def] +Theorem loc_to_pc_enc_sec_list[simp]: + ∀l1 l2 code. + loc_to_pc l1 l2 (enc_sec_list e code) = loc_to_pc l1 l2 code +Proof + simp[enc_sec_list_def] >> (ho_match_mp_tac loc_to_pc_ind >> srw_tac[][] >> srw_tac[][Once loc_to_pc_def,enc_sec_def] @@ -4516,7 +4853,8 @@ Theorem loc_to_pc_enc_sec_list[simp] >> IF_CASES_TAC >- ( Cases_on`h`>>full_simp_tac(srw_ss())[enc_line_def,LET_THM] ) >> full_simp_tac(srw_ss())[] >> rev_full_simp_tac(srw_ss())[enc_sec_def] - >> BasicProvers.TOP_CASE_TAC >> full_simp_tac(srw_ss())[])); + >> BasicProvers.TOP_CASE_TAC >> full_simp_tac(srw_ss())[]) +QED val all_enc_ok_pre_enc_sec_list = Q.prove(` ∀code enc c. @@ -4526,9 +4864,8 @@ val all_enc_ok_pre_enc_sec_list = Q.prove(` Cases>>fs[enc_sec_def]>>rw[]>> Induct_on`l`>>fs[]>>Cases>>fs[enc_line_def,line_ok_pre_def]) -Theorem remove_labels_thm - ` - remove_labels clock conf init_pos init_labs ffi_names code = SOME (code2,labs) /\ +Theorem remove_labels_thm: + remove_labels clock conf init_pos init_labs ffi_names code = SOME (code2,labs) /\ enc_ok conf /\ EVERY sec_ends_with_label code /\ EVERY sec_labels_ok code /\ @@ -4547,8 +4884,9 @@ Theorem remove_labels_thm lab_lookup l1 l2 labs = SOME x) /\ !l1 l2 x2. loc_to_pc l1 l2 code = SOME x2 ==> - lab_lookup l1 l2 labs = SOME (pos_val x2 init_pos code2)` - (simp[remove_labels_def] + lab_lookup l1 l2 labs = SOME (pos_val x2 init_pos code2) +Proof + simp[remove_labels_def] >> strip_tac >> drule (GEN_ALL remove_labels_loop_thm) >> impl_tac @@ -4571,25 +4909,29 @@ Theorem remove_labels_thm code_similar_get_code_labels, code_similar_get_labels, code_similar_refl]) >> strip_tac >> simp[] >> full_simp_tac(srw_ss())[] - >> rw [] >> res_tac); + >> rw [] >> res_tac +QED -Theorem compute_labels_alt_domain_labs - `∀pos code labs. +Theorem compute_labels_alt_domain_labs: + ∀pos code labs. domain (compute_labels_alt pos code labs) = - IMAGE FST (get_code_labels code) ∪ domain labs` - (recInduct lab_to_targetTheory.compute_labels_alt_ind + IMAGE FST (get_code_labels code) ∪ domain labs +Proof + recInduct lab_to_targetTheory.compute_labels_alt_ind \\ rw[lab_to_targetTheory.compute_labels_alt_def] \\ pairarg_tac \\ fs[] \\ simp[labPropsTheory.get_code_labels_cons] \\ fs[labPropsTheory.sec_get_code_labels_def] \\ simp[GSYM IMAGE_COMPOSE, o_DEF] \\ simp[Once EXTENSION, PULL_EXISTS] - \\ metis_tac[]); - -Theorem remove_labels_loop_domain_labs - `∀a b c d e f g h. remove_labels_loop a b c d e f = SOME (g,h) ⇒ - domain h = IMAGE FST (get_code_labels f) ∪ domain d` - (recInduct lab_to_targetTheory.remove_labels_loop_ind + \\ metis_tac[] +QED + +Theorem remove_labels_loop_domain_labs: + ∀a b c d e f g h. remove_labels_loop a b c d e f = SOME (g,h) ⇒ + domain h = IMAGE FST (get_code_labels f) ∪ domain d +Proof + recInduct lab_to_targetTheory.remove_labels_loop_ind \\ rw[] \\ pop_assum mp_tac \\ simp[Once lab_to_targetTheory.remove_labels_loop_def] @@ -4606,26 +4948,30 @@ Theorem remove_labels_loop_domain_labs \\ metis_tac[ code_similar_upd_lab_len, code_similar_get_code_labels, - enc_secs_again_IMP_similar]); - -Theorem remove_labels_domain_labs - `remove_labels c t k init_labs f p = SOME (q,labs) ⇒ - domain labs = IMAGE FST (get_code_labels p) ∪ domain init_labs` - (rw[lab_to_targetTheory.remove_labels_def] + enc_secs_again_IMP_similar] +QED + +Theorem remove_labels_domain_labs: + remove_labels c t k init_labs f p = SOME (q,labs) ⇒ + domain labs = IMAGE FST (get_code_labels p) ∪ domain init_labs +Proof + rw[lab_to_targetTheory.remove_labels_def] \\ imp_res_tac remove_labels_loop_domain_labs \\ simp[] \\ metis_tac[code_similar_enc_sec_list, code_similar_refl, - code_similar_get_code_labels]); + code_similar_get_code_labels] +QED (** End syntactic stuff **) -Theorem LENGTH_prog_to_bytes - `∀code n c labs ffi pos. +Theorem LENGTH_prog_to_bytes: + ∀code n c labs ffi pos. all_enc_ok c labs ffi pos code ⇒ FOLDL (λpos sec. sec_length (Section_lines sec) pos) n code = - LENGTH (prog_to_bytes code) + n` - (recInduct prog_to_bytes_ind>> + LENGTH (prog_to_bytes code) + n +Proof + recInduct prog_to_bytes_ind>> fs[all_enc_ok_def,prog_to_bytes_def,sec_length_def]>>rw[] >- metis_tac[] @@ -4634,14 +4980,16 @@ Theorem LENGTH_prog_to_bytes TRY(Cases_on`a`)>> fs[line_ok_def,line_length_def]>> fs(bool_case_eq_thms) \\ imp_res_tac lab_lookup_IMP \\ rw[] >> - metis_tac[ADD_ASSOC]); + metis_tac[ADD_ASSOC] +QED -Theorem LENGTH_prog_to_bytes2 - `∀code n c labs ffi pos. +Theorem LENGTH_prog_to_bytes2: + ∀code n c labs ffi pos. all_enc_ok c labs ffi pos code ⇒ SUM (MAP (SUM o MAP line_length o Section_lines) code) = - LENGTH (prog_to_bytes code)` - (recInduct prog_to_bytes_ind>> + LENGTH (prog_to_bytes code) +Proof + recInduct prog_to_bytes_ind>> fs[all_enc_ok_def,prog_to_bytes_def,sec_length_def]>>rw[] >- metis_tac[] @@ -4650,22 +4998,29 @@ Theorem LENGTH_prog_to_bytes2 TRY(Cases_on`a`)>> fs[line_ok_def,line_length_def]>> fs(bool_case_eq_thms) \\ imp_res_tac lab_lookup_IMP \\ rw[]>> - metis_tac[ADD_ASSOC]); - -Theorem prog_to_bytes_APPEND ` - prog_to_bytes (c1++c2) = prog_to_bytes c1 ++ prog_to_bytes c2` - (fs[prog_to_bytes_MAP]); - -Theorem line_ok_line_byte_length ` - line_ok c labs ffi n l ⇒ - LENGTH (line_bytes l) = line_length l` - (Cases_on`l`>>EVAL_TAC>>rw[]); - -Theorem lines_ok_MAP_line_byte_length ` - ∀ls c labs ffi n. + metis_tac[ADD_ASSOC] +QED + +Theorem prog_to_bytes_APPEND: + prog_to_bytes (c1++c2) = prog_to_bytes c1 ++ prog_to_bytes c2 +Proof + fs[prog_to_bytes_MAP] +QED + +Theorem line_ok_line_byte_length: + line_ok c labs ffi n l ⇒ + LENGTH (line_bytes l) = line_length l +Proof + Cases_on`l`>>EVAL_TAC>>rw[] +QED + +Theorem lines_ok_MAP_line_byte_length: + ∀ls c labs ffi n. lines_ok c labs ffi n ls ⇒ - MAP LENGTH (MAP line_bytes ls) = MAP line_length ls` - (Induct>>rw[lines_ok_def]>> metis_tac[line_ok_line_byte_length]); + MAP LENGTH (MAP line_bytes ls) = MAP line_length ls +Proof + Induct>>rw[lines_ok_def]>> metis_tac[line_ok_line_byte_length] +QED val all_enc_ok_prog_to_bytes_EVEN = Q.prove(` ∀code n c labs ffi pos. @@ -4702,26 +5057,29 @@ val loc_to_pc_append = Q.prove(` rw[]>> rpt(TOP_CASE_TAC>>fs[])); -Theorem all_enc_ok_append - `∀conf labs ffi n c1 c2. +Theorem all_enc_ok_append: + ∀conf labs ffi n c1 c2. all_enc_ok conf labs ffi n c1 ∧ all_enc_ok conf labs ffi (n+LENGTH (prog_to_bytes c1)) c2 ⇒ - all_enc_ok conf labs ffi n (c1++c2)` - (Induct_on`c1`>>fs[prog_to_bytes_def,all_enc_ok_def] >> + all_enc_ok conf labs ffi n (c1++c2) +Proof + Induct_on`c1`>>fs[prog_to_bytes_def,all_enc_ok_def] >> Cases>>rw[]>> fs[all_enc_ok_cons]>> first_x_assum match_mp_tac>> fs[prog_to_bytes_MAP,LENGTH_FLAT]>> drule lines_ok_MAP_line_byte_length>> rw[]>> - metis_tac[ADD_COMM]); + metis_tac[ADD_COMM] +QED -Theorem extract_labels_loc_to_pc ` - !l1 l2 code. +Theorem extract_labels_loc_to_pc: + !l1 l2 code. EVERY sec_labels_ok code ∧ MEM (l1,l2) (FLAT (MAP (extract_labels o Section_lines) code)) ==> - ∃y. loc_to_pc l1 l2 code = SOME y` - (ho_match_mp_tac loc_to_pc_ind>>rw[]>> + ∃y. loc_to_pc l1 l2 code = SOME y +Proof + ho_match_mp_tac loc_to_pc_ind>>rw[]>> simp[Once loc_to_pc_def] >- (IF_CASES_TAC>- simp[]>> @@ -4737,31 +5095,35 @@ Theorem extract_labels_loc_to_pc ` rfs[markerTheory.Abbrev_def] >> Cases_on`h`>>fs[]>> - rw[]>>rfs[markerTheory.Abbrev_def]) + rw[]>>rfs[markerTheory.Abbrev_def] +QED -Theorem all_enc_ok_labs_mono ` - ∀conf labs ffi n c labs2. +Theorem all_enc_ok_labs_mono: + ∀conf labs ffi n c labs2. (∀l1 l2 x. lab_lookup l1 l2 labs = SOME x ⇒ lab_lookup l1 l2 labs2 = SOME x) ∧ all_enc_ok conf labs ffi n c ==> - all_enc_ok conf labs2 ffi n c` - (ho_match_mp_tac all_enc_ok_ind>>rw[]>> + all_enc_ok conf labs2 ffi n c +Proof + ho_match_mp_tac all_enc_ok_ind>>rw[]>> fs[all_enc_ok_def]>> Cases_on`y`>>fs[line_ok_def]>> Cases_on`a`>>fs[line_ok_def]>> fs(bool_case_eq_thms) \\ imp_res_tac lab_lookup_IMP \\ rw[]>> - metis_tac[]); + metis_tac[] +QED -Theorem pos_val_append ` - ∀c1 i pos c2. +Theorem pos_val_append: + ∀c1 i pos c2. EVERY sec_label_zero c2 ⇒ pos_val i pos (c1++c2) = if i <= (SUM (MAP (len_no_lab o Section_lines) c1)) then pos_val i pos c1 else - pos_val (i - (SUM (MAP (len_no_lab o Section_lines) c1))) (pos+ (SUM (MAP (SUM o MAP line_length o Section_lines) c1))) c2` - (Induct + pos_val (i - (SUM (MAP (len_no_lab o Section_lines) c1))) (pos+ (SUM (MAP (SUM o MAP line_length o Section_lines) c1))) c2 +Proof + Induct >- ( fs[pos_val_def]>>rw[]>> metis_tac[sec_label_zero_pos_val_0]) @@ -4777,32 +5139,38 @@ Theorem pos_val_append ` TOP_CASE_TAC>>fs[]>> `sec_pos_val i pos l = NONE` suffices_by fs[]>> match_mp_tac sec_pos_val_too_big>> - fs[]); + fs[] +QED -Theorem sec_pos_val_acc ` - ∀l n i. +Theorem sec_pos_val_acc: + ∀l n i. len_no_lab l ≤ i ⇒ - sec_pos_val i n l = NONE` - (Induct>> - rw[sec_pos_val_def]); - -Theorem pos_val_acc ` - ∀ls n. + sec_pos_val i n l = NONE +Proof + Induct>> + rw[sec_pos_val_def] +QED + +Theorem pos_val_acc: + ∀ls n. pos_val (SUM (MAP (len_no_lab o Section_lines) ls)) n ls = - n+ SUM (MAP (SUM o (MAP line_length) ∘ Section_lines) ls)` - (Induct>>fs[pos_val_thm]>> + n+ SUM (MAP (SUM o (MAP line_length) ∘ Section_lines) ls) +Proof + Induct>>fs[pos_val_thm]>> Cases>>rw[pos_val_thm]>> TOP_CASE_TAC >> fs[]>> qmatch_asmsub_abbrev_tac`sec_pos_val ll _ _`>> `sec_pos_val ll n' l = NONE` suffices_by fs[]>> match_mp_tac sec_pos_val_acc>> - fs[Abbr`ll`]); + fs[Abbr`ll`] +QED -Theorem pos_val_bound ` - ∀i pos code conf labs ffi n. +Theorem pos_val_bound: + ∀i pos code conf labs ffi n. all_enc_ok conf labs ffi n code ==> - pos_val i pos code ≤ pos + LENGTH(prog_to_bytes code)` - (ho_match_mp_tac pos_val_ind>> + pos_val i pos code ≤ pos + LENGTH(prog_to_bytes code) +Proof + ho_match_mp_tac pos_val_ind>> rw[]>>fs[prog_to_bytes_def,pos_val_def,all_enc_ok_def] >- metis_tac[] @@ -4813,25 +5181,29 @@ Theorem pos_val_bound ` metis_tac[])>> IF_CASES_TAC>- fs[]>> fs[]>> - metis_tac[]); + metis_tac[] +QED -Theorem sec_loc_to_pc_bound ` - ∀n xs x. +Theorem sec_loc_to_pc_bound: + ∀n xs x. sec_loc_to_pc n xs = SOME x ⇒ - x ≤ len_no_lab xs` - (ho_match_mp_tac sec_loc_to_pc_ind>>rw[]>> + x ≤ len_no_lab xs +Proof + ho_match_mp_tac sec_loc_to_pc_ind>>rw[]>> pop_assum mp_tac>> simp[Once sec_loc_to_pc_def]>> every_case_tac>>fs[]>> rw[]>> - res_tac>>fs[]); + res_tac>>fs[] +QED -Theorem loc_to_pc_bound ` - ∀code l1 l2 x. +Theorem loc_to_pc_bound: + ∀code l1 l2 x. EVERY sec_labels_ok code ∧ loc_to_pc l1 l2 code = SOME x ⇒ - x ≤ SUM (MAP (len_no_lab ∘ Section_lines) code)` - (Induct>>rw[]>>rfs[Once loc_to_pc_thm]>> + x ≤ SUM (MAP (len_no_lab ∘ Section_lines) code) +Proof + Induct>>rw[]>>rfs[Once loc_to_pc_thm]>> pop_assum mp_tac>> TOP_CASE_TAC>>fs[]>> TOP_CASE_TAC>>fs[] @@ -4842,7 +5214,8 @@ Theorem loc_to_pc_bound ` fs[]) >> rw[]>> - res_tac>>fs[]); + res_tac>>fs[] +QED val find_ffi_names_append = Q.prove(` ∀l1 l2. @@ -4857,22 +5230,28 @@ val find_ffi_names_append = Q.prove(` fs[MEM_FILTER,FILTER_APPEND]>> fs[]); -Theorem all_enc_ok_aligned_pos_val - `!(mc_conf : ('a, 'b, 'c) machine_config) labs code2 pc. +Theorem all_enc_ok_aligned_pos_val: + !(mc_conf : ('a, 'b, 'c) machine_config) labs code2 pc. all_enc_ok mc_conf.target.config labs mc_conf.ffi_names 0 code2 /\ (has_odd_inst code2 ==> mc_conf.target.config.code_alignment = 0) /\ encoder_correct mc_conf.target ==> - aligned mc_conf.target.config.code_alignment (n2w (pos_val pc 0 code2):'a word)` - (metis_tac [MOD_0_aligned,pos_val_MOD_0]); - -Theorem read_ffi_bytearrays_with_next_interfer[simp] - `read_ffi_bytearrays (mc with next_interfer := foo) = - read_ffi_bytearrays mc` - (rw[FUN_EQ_THM, read_ffi_bytearrays_def, read_ffi_bytearray_def]); - -Theorem read_ffi_bytearrays_shift_interfer[simp] - `read_ffi_bytearrays (shift_interfer x y) = read_ffi_bytearrays y` - (rw[shift_interfer_def]); + aligned mc_conf.target.config.code_alignment (n2w (pos_val pc 0 code2):'a word) +Proof + metis_tac [MOD_0_aligned,pos_val_MOD_0] +QED + +Theorem read_ffi_bytearrays_with_next_interfer[simp]: + read_ffi_bytearrays (mc with next_interfer := foo) = + read_ffi_bytearrays mc +Proof + rw[FUN_EQ_THM, read_ffi_bytearrays_def, read_ffi_bytearray_def] +QED + +Theorem read_ffi_bytearrays_shift_interfer[simp]: + read_ffi_bytearrays (shift_interfer x y) = read_ffi_bytearrays y +Proof + rw[shift_interfer_def] +QED val say = say0 "compile_correct"; @@ -5886,12 +6265,13 @@ val init_ok_def = Define ` ?code2 labs t1. state_rel (mc_conf,code2,labs,p) s t1 ms`; -Theorem machine_sem_EQ_sem - `!mc_conf p (ms:'state) ^s1. +Theorem machine_sem_EQ_sem: + !mc_conf p (ms:'state) ^s1. encoder_correct mc_conf.target /\ init_ok (mc_conf,p) s1 ms /\ semantics s1 <> Fail ==> - machine_sem mc_conf s1.ffi ms = { semantics s1 }` - (simp[GSYM AND_IMP_INTRO] >> + machine_sem mc_conf s1.ffi ms = { semantics s1 } +Proof + simp[GSYM AND_IMP_INTRO] >> rpt gen_tac >> ntac 2 strip_tac >> full_simp_tac(srw_ss())[init_ok_def] >> simp[semantics_def] >> @@ -6016,7 +6396,8 @@ Theorem machine_sem_EQ_sem \\ asm_exists_tac \\ full_simp_tac(srw_ss())[] \\ gen_tac \\ PairCases_on `y` \\ drule (GEN_ALL evaluate_add_clock) \\ full_simp_tac(srw_ss())[] - \\ every_case_tac \\ full_simp_tac(srw_ss())[]); + \\ every_case_tac \\ full_simp_tac(srw_ss())[] +QED (* val () = PolyML.SaveState.saveState "lab_to_target_syntactic"; @@ -6150,11 +6531,13 @@ val IMP_state_rel_make_init = Q.prove( (drule pos_val_0 \\ simp[]) \\ metis_tac[code_similar_sec_labels_ok]); -Theorem make_init_simp[simp] ` - (make_init a b d e f g h i j k l m n).ffi = b ∧ +Theorem make_init_simp[simp]: + (make_init a b d e f g h i j k l m n).ffi = b ∧ (make_init a b d e f g h i j k l m n).pc = 0 ∧ - (make_init a b d e f g h i j k l m n).code = j` - (EVAL_TAC); + (make_init a b d e f g h i j k l m n).code = j +Proof + EVAL_TAC +QED val semantics_make_init = save_thm("semantics_make_init", machine_sem_EQ_sem |> SPEC_ALL |> REWRITE_RULE [GSYM AND_IMP_INTRO] @@ -6171,25 +6554,29 @@ val semantics_make_init = save_thm("semantics_make_init", |> MATCH_MP (MATCH_MP IMP_LEMMA IMP_state_rel_make_init) |> DISCH_ALL |> REWRITE_RULE [AND_IMP_INTRO,GSYM CONJ_ASSOC]); -Theorem make_init_filter_skip - `semantics +Theorem make_init_filter_skip: + semantics (make_init mc_conf ffi io_regs cc_regs t m dm ms (filter_skip code) compile_lab cbpos cbspace((λ(a,b). (a,filter_skip b)) o coracle)) = semantics (make_init mc_conf ffi io_regs cc_regs t m dm ms code - (λc p. compile_lab c (filter_skip p)) cbpos cbspace coracle)` - (match_mp_tac (filter_skip_semantics)>> + (λc p. compile_lab c (filter_skip p)) cbpos cbspace coracle) +Proof + match_mp_tac (filter_skip_semantics)>> rw[]>> simp[make_init_def]>> - qexists_tac`compile_lab`>>fs[]); + qexists_tac`compile_lab`>>fs[] +QED (* TODO: move *) -Theorem find_ffi_names_filter_skip - `!code. find_ffi_names (filter_skip code) = find_ffi_names code` - (recInduct find_ffi_names_ind +Theorem find_ffi_names_filter_skip: + !code. find_ffi_names (filter_skip code) = find_ffi_names code +Proof + recInduct find_ffi_names_ind \\ fs [lab_filterTheory.filter_skip_def,find_ffi_names_def] \\ rpt strip_tac \\ every_case_tac - \\ fs [lab_filterTheory.not_skip_def,find_ffi_names_def]); + \\ fs [lab_filterTheory.not_skip_def,find_ffi_names_def] +QED val all_enc_ok_pre_filter_skip = Q.prove(` ∀code c. @@ -6198,23 +6585,28 @@ val all_enc_ok_pre_filter_skip = Q.prove(` Induct>>TRY(Cases)>>fs[lab_filterTheory.filter_skip_def]>>rw[]>> Induct_on`l`>>fs[]>>rw[]) -Theorem MAP_Section_num_filter_skip[simp] - `∀code. MAP Section_num (filter_skip code) = MAP Section_num code` - (Induct \\ simp[lab_filterTheory.filter_skip_def] - \\ Cases \\ fs[lab_filterTheory.filter_skip_def]); - -Theorem filter_skip_extract_labels[simp] - `∀code. MAP (extract_labels o Section_lines) (filter_skip code) = - MAP (extract_labels o Section_lines) code` - (Induct \\ simp[lab_filterTheory.filter_skip_def] +Theorem MAP_Section_num_filter_skip[simp]: + ∀code. MAP Section_num (filter_skip code) = MAP Section_num code +Proof + Induct \\ simp[lab_filterTheory.filter_skip_def] + \\ Cases \\ fs[lab_filterTheory.filter_skip_def] +QED + +Theorem filter_skip_extract_labels[simp]: + ∀code. MAP (extract_labels o Section_lines) (filter_skip code) = + MAP (extract_labels o Section_lines) code +Proof + Induct \\ simp[lab_filterTheory.filter_skip_def] \\ Cases \\ fs[lab_filterTheory.filter_skip_def] \\ Induct_on`l` \\ fs[] \\ Cases \\ fs[lab_filterTheory.not_skip_def] \\ - every_case_tac \\ fs[]); + every_case_tac \\ fs[] +QED -Theorem get_code_labels_filter_skip[simp] - `∀code. get_code_labels (filter_skip code) = get_code_labels code` - (recInduct lab_filterTheory.filter_skip_ind +Theorem get_code_labels_filter_skip[simp]: + ∀code. get_code_labels (filter_skip code) = get_code_labels code +Proof + recInduct lab_filterTheory.filter_skip_ind \\ rw[lab_filterTheory.filter_skip_def, get_code_labels_cons] \\ rw[sec_get_code_labels_def, LIST_TO_SET_FILTER] \\ AP_THM_TAC \\ AP_TERM_TAC @@ -6223,11 +6615,13 @@ Theorem get_code_labels_filter_skip[simp] >- metis_tac[] \\ asm_exists_tac \\ rw[] \\ fs[lab_filterTheory.not_skip_def] - \\ CASE_TAC \\ fs[]); + \\ CASE_TAC \\ fs[] +QED -Theorem get_labels_filter_skip[simp] - `∀code. get_labels (filter_skip code) = get_labels code` - (recInduct lab_filterTheory.filter_skip_ind +Theorem get_labels_filter_skip[simp]: + ∀code. get_labels (filter_skip code) = get_labels code +Proof + recInduct lab_filterTheory.filter_skip_ind \\ rw[lab_filterTheory.filter_skip_def, get_labels_def] \\ rw[sec_get_labels_def, LIST_TO_SET_FILTER] \\ AP_THM_TAC \\ AP_TERM_TAC @@ -6235,21 +6629,26 @@ Theorem get_labels_filter_skip[simp] >- metis_tac[] \\ asm_exists_tac \\ rw[] \\ fs[lab_filterTheory.not_skip_def] - \\ CASE_TAC \\ fs[line_get_labels_def]); + \\ CASE_TAC \\ fs[line_get_labels_def] +QED -Theorem implements_intro_gen - `(b /\ x <> Fail ==> y = {x}) ==> b ==> implements y {x}` - (full_simp_tac(srw_ss())[semanticsPropsTheory.implements_def] +Theorem implements_intro_gen: + (b /\ x <> Fail ==> y = {x}) ==> b ==> implements y {x} +Proof + full_simp_tac(srw_ss())[semanticsPropsTheory.implements_def] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] - \\ full_simp_tac(srw_ss())[semanticsPropsTheory.extend_with_resource_limit_def]); + \\ full_simp_tac(srw_ss())[semanticsPropsTheory.extend_with_resource_limit_def] +QED -Theorem find_ffi_names_ALL_DISTINCT ` - ∀code. ALL_DISTINCT (find_ffi_names code)` - (ho_match_mp_tac find_ffi_names_ind>>rw[find_ffi_names_def]>> +Theorem find_ffi_names_ALL_DISTINCT: + ∀code. ALL_DISTINCT (find_ffi_names code) +Proof + ho_match_mp_tac find_ffi_names_ind>>rw[find_ffi_names_def]>> TOP_CASE_TAC>>fs[find_ffi_names_def]>> TOP_CASE_TAC>>fs[find_ffi_names_def]>> fs[list_add_if_fresh_thm]>> - IF_CASES_TAC>>fs[ALL_DISTINCT_APPEND]); + IF_CASES_TAC>>fs[ALL_DISTINCT_APPEND] +QED (* -- *) val semantics_compile_lemma = Q.prove( @@ -6314,8 +6713,8 @@ val semantics_compile_lemma = Q.prove( |> MATCH_MP implements_intro_gen |> REWRITE_RULE [GSYM CONJ_ASSOC] -Theorem semantics_compile ` - mc_conf_ok mc_conf ∧ +Theorem semantics_compile: + mc_conf_ok mc_conf ∧ compiler_oracle_ok coracle c'.labels (LENGTH bytes) c.asm_conf mc_conf.ffi_names ∧ good_code c.asm_conf c.labels code ∧ c.asm_conf = mc_conf.target.config ∧ @@ -6327,8 +6726,9 @@ Theorem semantics_compile ` {semantics (make_init mc_conf ffi io_regs cc_regs t m (dm ∩ byte_aligned) ms code compile (mc_conf.target.get_pc ms + n2w (LENGTH bytes)) - cbspace coracle)}` - (rw[]>> + cbspace coracle)} +Proof + rw[]>> match_mp_tac ((GEN_ALL o MP_CANON) semanticsPropsTheory.implements_trans)>> qho_match_abbrev_tac`∃y. implements y {semantics (ss (dm ∩ byte_aligned))} ∧ P y` >> qexists_tac`{semantics (ss dm)}` >> @@ -6341,6 +6741,7 @@ Theorem semantics_compile ` simp[Abbr`P`,Abbr`ss`] \\ PURE_REWRITE_TAC[Once WORD_ADD_COMM] \\ match_mp_tac semantics_compile_lemma \\ - fs[good_code_def]); + fs[good_code_def] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/pat_to_closProofScript.sml b/compiler/backend/proofs/pat_to_closProofScript.sml index 042bb9d574..6025c1ff6a 100644 --- a/compiler/backend/proofs/pat_to_closProofScript.sml +++ b/compiler/backend/proofs/pat_to_closProofScript.sml @@ -49,51 +49,66 @@ val compile_state_def = Define` max_app := max_app |>`; -Theorem compile_state_const[simp] - `(compile_state max_app cc s).clock = s.clock ∧ +Theorem compile_state_const[simp]: + (compile_state max_app cc s).clock = s.clock ∧ (compile_state max_app cc s).ffi = s.ffi ∧ (compile_state max_app cc s).compile = cc ∧ (compile_state max_app cc s).max_app = max_app ∧ - (compile_state max_app cc s).compile_oracle = pure_co (λe. (MAP compile e,[])) o s.compile_oracle` - (EVAL_TAC); - -Theorem compile_state_dec_clock[simp] - `compile_state max_app cc (dec_clock y) = dec_clock 1 (compile_state max_app cc y)` - (EVAL_TAC >> simp[]) - -Theorem compile_state_with_clock[simp] - `compile_state max_app cc (s with clock := k) = compile_state max_app cc s with clock := k` - (EVAL_TAC >> simp[]) - -Theorem compile_state_with_refs_const[simp] - `(compile_state w cc (s with refs := r)).globals = (compile_state w cc s).globals ∧ - (compile_state w cc (s with refs := r)).code = (compile_state w cc s).code` - (EVAL_TAC); - -Theorem FLOOKUP_compile_state_refs - `FLOOKUP (compile_state w cc s).refs = - OPTION_MAP compile_sv o (combin$C store_lookup s.refs) ` - (rw[FUN_EQ_THM,compile_state_def,ALOOKUP_GENLIST,store_lookup_def] \\ rw[]); - -Theorem FDOM_compile_state_refs[simp] - `FDOM (compile_state w cc s).refs = count (LENGTH s.refs)` - (rw[compile_state_def,MAP_GENLIST,o_DEF,LIST_TO_SET_GENLIST]); - -Theorem compile_state_with_refs_snoc - `compile_state w cc (s with refs := s.refs ++ [x]) = + (compile_state max_app cc s).compile_oracle = pure_co (λe. (MAP compile e,[])) o s.compile_oracle +Proof + EVAL_TAC +QED + +Theorem compile_state_dec_clock[simp]: + compile_state max_app cc (dec_clock y) = dec_clock 1 (compile_state max_app cc y) +Proof + EVAL_TAC >> simp[] +QED + +Theorem compile_state_with_clock[simp]: + compile_state max_app cc (s with clock := k) = compile_state max_app cc s with clock := k +Proof + EVAL_TAC >> simp[] +QED + +Theorem compile_state_with_refs_const[simp]: + (compile_state w cc (s with refs := r)).globals = (compile_state w cc s).globals ∧ + (compile_state w cc (s with refs := r)).code = (compile_state w cc s).code +Proof + EVAL_TAC +QED + +Theorem FLOOKUP_compile_state_refs: + FLOOKUP (compile_state w cc s).refs = + OPTION_MAP compile_sv o (combin$C store_lookup s.refs) +Proof + rw[FUN_EQ_THM,compile_state_def,ALOOKUP_GENLIST,store_lookup_def] \\ rw[] +QED + +Theorem FDOM_compile_state_refs[simp]: + FDOM (compile_state w cc s).refs = count (LENGTH s.refs) +Proof + rw[compile_state_def,MAP_GENLIST,o_DEF,LIST_TO_SET_GENLIST] +QED + +Theorem compile_state_with_refs_snoc: + compile_state w cc (s with refs := s.refs ++ [x]) = compile_state w cc s with refs := - (compile_state w cc s).refs |+ (LENGTH s.refs, compile_sv x)` - (rw[compile_state_def,fmap_eq_flookup,FLOOKUP_UPDATE,ALOOKUP_GENLIST] - \\ rw[EL_APPEND1,EL_APPEND2]); + (compile_state w cc s).refs |+ (LENGTH s.refs, compile_sv x) +Proof + rw[compile_state_def,fmap_eq_flookup,FLOOKUP_UPDATE,ALOOKUP_GENLIST] + \\ rw[EL_APPEND1,EL_APPEND2] +QED (* semantic functions respect translation *) -Theorem do_eq - `(∀v1 v2. do_eq v1 v2 ≠ Eq_type_error ⇒ +Theorem do_eq: + (∀v1 v2. do_eq v1 v2 ≠ Eq_type_error ⇒ (do_eq v1 v2 = do_eq (compile_v v1) (compile_v v2))) ∧ (∀vs1 vs2. do_eq_list vs1 vs2 ≠ Eq_type_error ⇒ - (do_eq_list vs1 vs2 = do_eq_list (MAP compile_v vs1) (MAP compile_v vs2)))` - (ho_match_mp_tac patSemTheory.do_eq_ind >> + (do_eq_list vs1 vs2 = do_eq_list (MAP compile_v vs1) (MAP compile_v vs2))) +Proof + ho_match_mp_tac patSemTheory.do_eq_ind >> simp[patSemTheory.do_eq_def,closSemTheory.do_eq_def] >> conj_tac >- ( Cases >> Cases >> simp[lit_same_type_def,closSemTheory.do_eq_def] >> @@ -108,14 +123,16 @@ Theorem do_eq rw[]>>fs[]>>rfs[ETA_AX]>> BasicProvers.CASE_TAC>>fs[]>> rw[]>>fs[]>> - BasicProvers.CASE_TAC>>fs[]); + BasicProvers.CASE_TAC>>fs[] +QED val v_to_list_def = closSemTheory.v_to_list_def; -Theorem v_to_char_list - `∀v ls. (v_to_char_list v = SOME ls) ⇒ - (v_to_list (compile_v v) = SOME (MAP (Number o $& o ORD) ls))` - (ho_match_mp_tac v_to_char_list_ind >> +Theorem v_to_char_list: + ∀v ls. (v_to_char_list v = SOME ls) ⇒ + (v_to_list (compile_v v) = SOME (MAP (Number o $& o ORD) ls)) +Proof + ho_match_mp_tac v_to_char_list_ind >> simp[v_to_char_list_def,v_to_list_def] >> rw[] >> Cases_on`v`>>fs[v_to_char_list_def] >> @@ -126,57 +143,69 @@ Theorem v_to_char_list Cases_on`t`>>fs[v_to_char_list_def,v_to_list_def] >> Cases_on`t'`>>fs[v_to_char_list_def,v_to_list_def] >> rw[]>>fs[]>> - Cases_on`v_to_char_list h`>>fs[]>> rw[]) - -Theorem v_to_list - `∀v ls. (v_to_list v = SOME ls) ⇒ - (v_to_list (compile_v v) = SOME (MAP compile_v ls))` - (ho_match_mp_tac patSemTheory.v_to_list_ind >> + Cases_on`v_to_char_list h`>>fs[]>> rw[] +QED + +Theorem v_to_list: + ∀v ls. (v_to_list v = SOME ls) ⇒ + (v_to_list (compile_v v) = SOME (MAP compile_v ls)) +Proof + ho_match_mp_tac patSemTheory.v_to_list_ind >> simp[patSemTheory.v_to_list_def,v_to_list_def] >> - rw[] >> Cases_on`v_to_list v`>>fs[]>> rw[]) + rw[] >> Cases_on`v_to_list v`>>fs[]>> rw[] +QED -Theorem vs_to_string - `∀vs ws. vs_to_string vs = SOME ws ⇒ +Theorem vs_to_string: + ∀vs ws. vs_to_string vs = SOME ws ⇒ ∃wss. MAP compile_v vs = MAP ByteVector wss ∧ - FLAT wss = MAP (n2w o ORD) ws` - (ho_match_mp_tac vs_to_string_ind + FLAT wss = MAP (n2w o ORD) ws +Proof + ho_match_mp_tac vs_to_string_ind \\ rw[vs_to_string_def] \\ every_case_tac \\ fs[] \\ rveq \\ qmatch_goalsub_abbrev_tac`ByteVector ws1` - \\ qexists_tac`ws1::wss` \\ simp[]); - -Theorem Boolv[simp] - `compile_v (Boolv b) = Boolv b` - (Cases_on`b`>>EVAL_TAC) - -Theorem v_to_bytes - `v_to_bytes v = SOME ls ==> v_to_bytes (compile_v v) = SOME ls` - (simp[patSemTheory.v_to_bytes_def,v_to_bytes_def] + \\ qexists_tac`ws1::wss` \\ simp[] +QED + +Theorem Boolv[simp]: + compile_v (Boolv b) = Boolv b +Proof + Cases_on`b`>>EVAL_TAC +QED + +Theorem v_to_bytes: + v_to_bytes v = SOME ls ==> v_to_bytes (compile_v v) = SOME ls +Proof + simp[patSemTheory.v_to_bytes_def,v_to_bytes_def] \\ DEEP_INTRO_TAC some_intro \\ rw[] \\ imp_res_tac v_to_list \\ rw[MAP_MAP_o,o_DEF] \\ DEEP_INTRO_TAC some_intro \\ rw[] \\ imp_res_tac INJ_MAP_EQ \\ fs[INJ_DEF] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem v_to_words - `v_to_words v = SOME ls ==> v_to_words (compile_v v) = SOME ls` - (simp[patSemTheory.v_to_words_def,v_to_words_def] +Theorem v_to_words: + v_to_words v = SOME ls ==> v_to_words (compile_v v) = SOME ls +Proof + simp[patSemTheory.v_to_words_def,v_to_words_def] \\ DEEP_INTRO_TAC some_intro \\ rw[] \\ imp_res_tac v_to_list \\ rw[MAP_MAP_o,o_DEF] \\ DEEP_INTRO_TAC some_intro \\ rw[ETA_AX] \\ imp_res_tac INJ_MAP_EQ \\ fs[INJ_DEF] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem do_install - `patSem$do_install vs s = SOME (v1,v2) ∧ +Theorem do_install: + patSem$do_install vs s = SOME (v1,v2) ∧ s.compile = pure_cc (λe. (MAP compile e,[])) cc ==> closSem$do_install (MAP compile_v vs) (compile_state max_app cc s) = if s.clock = 0 then (Rerr (Rabort Rtimeout_error),compile_state max_app cc v2) - else (Rval (MAP compile v1),dec_clock 1(compile_state max_app cc v2))` - (simp[do_install_def,patSemTheory.do_install_def,case_eq_thms] + else (Rval (MAP compile v1),dec_clock 1(compile_state max_app cc v2)) +Proof + simp[do_install_def,patSemTheory.do_install_def,case_eq_thms] \\ simp[] \\ strip_tac \\ rveq \\ fs[] \\ imp_res_tac v_to_bytes \\ imp_res_tac v_to_words \\ rpt(pairarg_tac \\ fs[]) @@ -184,7 +213,8 @@ Theorem do_install \\ rfs[pure_cc_def] \\ fs[case_eq_thms,pair_case_eq,shift_seq_def,FUPDATE_LIST_THM] \\ rveq \\ fs[bool_case_eq,dec_clock_def] - \\ fs[state_component_equality,compile_state_def,pure_co_def,FUN_EQ_THM]); + \\ fs[state_component_equality,compile_state_def,pure_co_def,FUN_EQ_THM] +QED (* compiler correctness *) @@ -213,30 +243,36 @@ val LENGTH_eq = Q.prove( (2 = LENGTH ls ⇔ LENGTH ls = 2)`, Cases_on`ls`>>simp[]>> Cases_on`t`>>simp[LENGTH_NIL]); -Theorem list_to_v_compile - `!x xs. +Theorem list_to_v_compile: + !x xs. v_to_list x = SOME xs /\ v_to_list (compile_v x) = SOME (MAP compile_v xs) ==> - list_to_v (MAP compile_v xs) = compile_v (list_to_v xs)` - (ho_match_mp_tac patSemTheory.v_to_list_ind + list_to_v (MAP compile_v xs) = compile_v (list_to_v xs) +Proof + ho_match_mp_tac patSemTheory.v_to_list_ind \\ rw [patSemTheory.v_to_list_def] \\ fs [] \\ fs [list_to_v_def, patSemTheory.list_to_v_def, case_eq_thms] \\ rveq - \\ fs [v_to_list_def, case_eq_thms, list_to_v_def, patSemTheory.list_to_v_def]); + \\ fs [v_to_list_def, case_eq_thms, list_to_v_def, patSemTheory.list_to_v_def] +QED -Theorem list_to_v_compile_APPEND - `!xs ys. +Theorem list_to_v_compile_APPEND: + !xs ys. list_to_v (MAP compile_v xs) = compile_v (list_to_v xs) /\ list_to_v (MAP compile_v ys) = compile_v (list_to_v ys) ==> list_to_v (MAP compile_v (xs ++ ys)) = - compile_v (list_to_v (xs ++ ys))` - (Induct \\ rw [patSemTheory.list_to_v_def] - \\ fs [list_to_v_def, patSemTheory.list_to_v_def]); - -Theorem dest_WordToInt_SOME - `!w es x. dest_WordToInt w es = SOME x <=> - ?tra. es = [App tra (Op (WordToInt w)) [x]]` - (ho_match_mp_tac dest_WordToInt_ind - \\ fs [dest_WordToInt_def]); + compile_v (list_to_v (xs ++ ys)) +Proof + Induct \\ rw [patSemTheory.list_to_v_def] + \\ fs [list_to_v_def, patSemTheory.list_to_v_def] +QED + +Theorem dest_WordToInt_SOME: + !w es x. dest_WordToInt w es = SOME x <=> + ?tra. es = [App tra (Op (WordToInt w)) [x]] +Proof + ho_match_mp_tac dest_WordToInt_ind + \\ fs [dest_WordToInt_def] +QED val Rabort_Rtype_error_map_error = prove( ``Rabort Rtype_error = map_error_result compile_v e <=> @@ -247,15 +283,16 @@ val do_app_WordToInt_Rerr_IMP = prove( ``closSem$do_app WordToInt ws x = Rerr e ==> e = Rabort Rtype_error``, fs [do_app_def,case_eq_thms,pair_case_eq] \\ rw [] \\ fs []); -Theorem compile_evaluate - `0 < max_app ⇒ +Theorem compile_evaluate: + 0 < max_app ⇒ (∀env ^s es s' r. evaluate env s es = (s',r) ∧ s.compile = pure_cc (λe. (MAP pat_to_clos$compile e,[])) cc ∧ r ≠ Rerr (Rabort Rtype_error) ⇒ evaluate (MAP compile es,MAP compile_v env,compile_state max_app cc s) = - (map_result (MAP compile_v) compile_v r, compile_state max_app cc s'))` - (strip_tac >> + (map_result (MAP compile_v) compile_v r, compile_state max_app cc s')) +Proof + strip_tac >> ho_match_mp_tac patSemTheory.evaluate_ind >> strip_tac >- (rw[evaluate_pat_def,evaluate_def]>>rw[]) >> strip_tac >- ( @@ -587,14 +624,16 @@ Theorem compile_evaluate rw[] >> fs[EXISTS_MAP] >> fs[build_rec_env_pat_def,build_recc_def,MAP_GENLIST, combinTheory.o_DEF,ETA_AX,MAP_MAP_o,clos_env_def] >> - fsrw_tac[ETA_ss][] )); + fsrw_tac[ETA_ss][] ) +QED -Theorem compile_semantics - `0 < max_app ∧ st.compile = pure_cc (λe. (MAP compile e,[])) cc ∧ st.globals = [] ∧ st.refs = [] ⇒ +Theorem compile_semantics: + 0 < max_app ∧ st.compile = pure_cc (λe. (MAP compile e,[])) cc ∧ st.globals = [] ∧ st.refs = [] ⇒ semantics [] (st:('c,'ffi)patSem$state) es ≠ Fail ⇒ semantics st.ffi max_app FEMPTY (pure_co (λe. (MAP compile e,[])) o st.compile_oracle) cc (MAP compile es) = - semantics [] st es` - (strip_tac >> + semantics [] st es +Proof + strip_tac >> simp[patSemTheory.semantics_def] >> IF_CASES_TAC >> fs[] >> DEEP_INTRO_TAC some_intro >> simp[] >> @@ -672,13 +711,15 @@ Theorem compile_semantics qpat_abbrev_tac`s1 = compile_state _ _ _` \\ `s1 = s0 k` by ( simp[Abbr`s1`,Abbr`s0`,initial_state_def,compile_state_def] ) \\ - srw_tac[QI_ss][]) + srw_tac[QI_ss][] +QED (* more correctness properties *) -Theorem compile_contains_App_SOME - `0 < max_app ⇒ ∀e. ¬contains_App_SOME max_app [compile e]` - (strip_tac >> +Theorem compile_contains_App_SOME: + 0 < max_app ⇒ ∀e. ¬contains_App_SOME max_app [compile e] +Proof + strip_tac >> ho_match_mp_tac compile_ind >> simp[compile_def,contains_App_SOME_def,CopyByteStr_def,CopyByteAw8_def] >> rw[] >> srw_tac[ETA_ss][] >> @@ -690,11 +731,13 @@ Theorem compile_contains_App_SOME rw[contains_App_SOME_def] >> TOP_CASE_TAC >> fs[contains_App_SOME_def] >> rw[Once contains_App_SOME_EXISTS,EVERY_MAP] >> - fs[contains_App_SOME_def,EVERY_MEM,MEM_MAP,PULL_EXISTS]); + fs[contains_App_SOME_def,EVERY_MEM,MEM_MAP,PULL_EXISTS] +QED -Theorem compile_every_Fn_vs_NONE - `∀e. every_Fn_vs_NONE[compile e]` - (ho_match_mp_tac compile_ind >> +Theorem compile_every_Fn_vs_NONE: + ∀e. every_Fn_vs_NONE[compile e] +Proof + ho_match_mp_tac compile_ind >> rw[compile_def,CopyByteStr_def,CopyByteAw8_def] >> rw[Once every_Fn_vs_NONE_EVERY] >> simp[EVERY_REVERSE,EVERY_MAP] >> @@ -702,11 +745,13 @@ Theorem compile_every_Fn_vs_NONE rw[] >> rw[] >> TOP_CASE_TAC >> fs[] >> rw[Once every_Fn_vs_NONE_EVERY,EVERY_MAP,GSYM MAP_REVERSE] >> - fs[EVERY_MEM,MEM_MAP,PULL_EXISTS]); + fs[EVERY_MEM,MEM_MAP,PULL_EXISTS] +QED -Theorem set_globals_eq - `∀e. set_globals e = set_globals (compile e)` - (ho_match_mp_tac compile_ind >> +Theorem set_globals_eq: + ∀e. set_globals e = set_globals (compile e) +Proof + ho_match_mp_tac compile_ind >> rw[compile_def,patPropsTheory.op_gbag_def,op_gbag_def,elist_globals_reverse,CopyByteStr_def,CopyByteAw8_def] >> TRY @@ -728,11 +773,13 @@ Theorem set_globals_eq fs[LENGTH_eq,ETA_AX]>> TRY(pop_assum SUBST_ALL_TAC>>fs[bagTheory.COMM_BAG_UNION])>> Induct_on`n`>>fs[REPLICATE,op_gbag_def] >> - Induct_on`es`>>fs[]); + Induct_on`es`>>fs[] +QED -Theorem compile_esgc_free - `∀e. esgc_free e ⇒ esgc_free (compile e)` - (ho_match_mp_tac compile_ind >> +Theorem compile_esgc_free: + ∀e. esgc_free e ⇒ esgc_free (compile e) +Proof + ho_match_mp_tac compile_ind >> rw[compile_def,CopyByteStr_def,CopyByteAw8_def] >> fs[EVERY_REVERSE,EVERY_MAP,EVERY_MEM]>> fs[set_globals_eq,LENGTH_eq,REPLICATE_GENLIST,MEM_GENLIST,PULL_EXISTS] @@ -743,21 +790,26 @@ Theorem compile_esgc_free fs [dest_WordToInt_SOME] >> rw [] >> fs [EVERY_MEM,MEM_MAP,PULL_EXISTS] >> fs []) - >- (Induct_on`es`>>fs[set_globals_eq])); - -Theorem compile_distinct_setglobals - `∀e. BAG_ALL_DISTINCT (set_globals e) ⇒ - BAG_ALL_DISTINCT (set_globals (compile e))` - (fs[set_globals_eq]); - -Theorem compile_no_Labels - `!e. no_Labels (compile e)` - (ho_match_mp_tac compile_ind \\ rw [compile_def] + >- (Induct_on`es`>>fs[set_globals_eq]) +QED + +Theorem compile_distinct_setglobals: + ∀e. BAG_ALL_DISTINCT (set_globals e) ⇒ + BAG_ALL_DISTINCT (set_globals (compile e)) +Proof + fs[set_globals_eq] +QED + +Theorem compile_no_Labels: + !e. no_Labels (compile e) +Proof + ho_match_mp_tac compile_ind \\ rw [compile_def] \\ fs [EVERY_REVERSE,EVERY_REPLICATE] \\ TRY (fs [EVERY_MEM,MEM_MAP,PULL_EXISTS] \\ NO_TAC) \\ every_case_tac \\ fs [] \\ fs [EVERY_REVERSE,EVERY_REPLICATE] \\ fs [EVERY_MEM,MEM_MAP,PULL_EXISTS] - \\ EVAL_TAC \\ fs []); + \\ EVAL_TAC \\ fs [] +QED val _ = export_theory() diff --git a/compiler/backend/proofs/source_to_flatProofScript.sml b/compiler/backend/proofs/source_to_flatProofScript.sml index 676852d392..d24e8a0fe8 100644 --- a/compiler/backend/proofs/source_to_flatProofScript.sml +++ b/compiler/backend/proofs/source_to_flatProofScript.sml @@ -21,10 +21,12 @@ val compile_exps_length = Q.prove ( induct_on `es` >> rw [compile_exp_def]); -Theorem mapi_map - `!f g l. MAPi f (MAP g l) = MAPi (\i x. f i (g x)) l` - (Induct_on `l` >> - rw [combinTheory.o_DEF]); +Theorem mapi_map: + !f g l. MAPi f (MAP g l) = MAPi (\i x. f i (g x)) l +Proof + Induct_on `l` >> + rw [combinTheory.o_DEF] +QED val fst_lem = Q.prove ( `(λ(p1,p1',p2). p1) = FST`, @@ -45,10 +47,11 @@ val flookup_funion_submap = Q.prove ( rw [SUBMAP_DEF, FLOOKUP_DEF] >> metis_tac []); -Theorem FILTER_MAPi_ID - `∀ls f. FILTER P (MAPi f ls) = MAPi f ls ⇔ - (∀n. n < LENGTH ls ⇒ P (f n (EL n ls)))` - (Induct \\ reverse(rw[]) +Theorem FILTER_MAPi_ID: + ∀ls f. FILTER P (MAPi f ls) = MAPi f ls ⇔ + (∀n. n < LENGTH ls ⇒ P (f n (EL n ls))) +Proof + Induct \\ reverse(rw[]) >- ( qmatch_goalsub_abbrev_tac`a ⇔ b` \\ `¬a` @@ -61,7 +64,8 @@ Theorem FILTER_MAPi_ID \\ simp[Abbr`b`] \\ qexists_tac`0` \\ simp[] ) - \\ simp[Once FORALL_NUM, SimpRHS]); + \\ simp[Once FORALL_NUM, SimpRHS] +QED (* -- *) @@ -213,8 +217,8 @@ val (v_rel_rules, v_rel_ind, v_rel_cases) = Hol_reln ` ⇒ global_env_inv genv comp_map shadowers env)`; -Theorem v_rel_eqns - `(!genv l v. +Theorem v_rel_eqns: + (!genv l v. v_rel genv (Litv l) v ⇔ (v = Litv l)) ∧ (!genv vs v. @@ -252,15 +256,17 @@ Theorem v_rel_eqns (!x arity stamp. nsLookup env.c x = SOME (arity, stamp) ⇒ ∃cn. nsLookup comp_map.c x = SOME cn ∧ - FLOOKUP genv.c (cn,arity) = SOME stamp))` - (srw_tac[][semanticPrimitivesTheory.Boolv_def,flatSemTheory.Boolv_def] >> + FLOOKUP genv.c (cn,arity) = SOME stamp)) +Proof + srw_tac[][semanticPrimitivesTheory.Boolv_def,flatSemTheory.Boolv_def] >> srw_tac[][Once v_rel_cases] >> srw_tac[][Q.SPECL[`genv`,`nsEmpty`](CONJUNCT1(CONJUNCT2 v_rel_cases))] >> every_case_tac >> fs [genv_c_ok_def, has_bools_def] >> TRY eq_tac >> rw [] >> - metis_tac []); + metis_tac [] +QED val env_rel_dom = Q.prove ( `!genv env env'. @@ -742,14 +748,16 @@ val v_rel_lems = Q.prove ( every_case_tac >> simp [v_rel_eqns]); -Theorem list_to_v_v_rel - `!xs ys. +Theorem list_to_v_v_rel: + !xs ys. has_lists genv.c ∧ LIST_REL (v_rel genv) xs ys ⇒ - v_rel genv (list_to_v xs) (list_to_v ys)` - (Induct >> + v_rel genv (list_to_v xs) (list_to_v ys) +Proof + Induct >> rw [] >> fs [LIST_REL_EL_EQN, flatSemTheory.list_to_v_def, has_lists_def, - v_rel_eqns, semanticPrimitivesTheory.list_to_v_def]); + v_rel_eqns, semanticPrimitivesTheory.list_to_v_def] +QED val do_app = Q.prove ( `!genv s1 s2 op vs r s1_i1 vs_i1. @@ -1264,13 +1272,15 @@ val do_opapp = Q.prove ( namespaceTheory.nsBind_def] >> simp [Once v_rel_cases, namespaceTheory.nsEmpty_def])))); -Theorem pat_bindings_compile_pat[simp] -`!comp_map (p:ast$pat) vars. pat_bindings (compile_pat comp_map p) vars = pat_bindings p vars` - (ho_match_mp_tac compile_pat_ind >> +Theorem pat_bindings_compile_pat[simp]: + !comp_map (p:ast$pat) vars. pat_bindings (compile_pat comp_map p) vars = pat_bindings p vars +Proof + ho_match_mp_tac compile_pat_ind >> simp [compile_pat_def, astTheory.pat_bindings_def, pat_bindings_def] >> induct_on `ps` >> rw [] >> - fs [pat_bindings_def,astTheory.pat_bindings_def, PULL_FORALL]); + fs [pat_bindings_def,astTheory.pat_bindings_def, PULL_FORALL] +QED val eta2 = Q.prove ( `!f x. (\y. f x y) = f x`, @@ -3568,8 +3578,8 @@ val compile_decs_correct' = Q.prove ( metis_tac [SUBMAP_TRANS, subglobals_trans] )); -Theorem compile_decs_correct - `!s env ds s' r comp_map s_i1 idx ds_i1 next' genv. +Theorem compile_decs_correct: + !s env ds s' r comp_map s_i1 idx ds_i1 next' genv. evaluate$evaluate_decs s env ds = (s',r) ∧ r ≠ Rerr (Rabort Rtype_error) ∧ invariant genv idx s s_i1 ∧ @@ -3594,8 +3604,9 @@ Theorem compile_decs_correct ⇒ ?err_i1. r_i1 = SOME err_i1 ∧ - result_rel (\a b (c:'a). T) genv' (Rerr err) (Rerr err_i1))` - (rw [compile_prog_def, glob_alloc_def] >> + result_rel (\a b (c:'a). T) genv' (Rerr err) (Rerr err_i1)) +Proof + rw [compile_prog_def, glob_alloc_def] >> pairarg_tac >> fs [] >> rw [evaluate_decs_def, evaluate_dec_def, evaluate_def, do_app_def] >> @@ -3642,12 +3653,15 @@ Theorem compile_decs_correct strip_tac >> disch_then (qspec_then `n` mp_tac) >> simp [EL_APPEND_EQN] >> - rw []); + rw [] +QED -Theorem invariant_change_clock - `invariant genv env st1 st2 ⇒ - invariant genv env (st1 with clock := k) (st2 with clock := k)` - (srw_tac[][invariant_def] >> full_simp_tac(srw_ss())[s_rel_cases]) +Theorem invariant_change_clock: + invariant genv env st1 st2 ⇒ + invariant genv env (st1 with clock := k) (st2 with clock := k) +Proof + srw_tac[][invariant_def] >> full_simp_tac(srw_ss())[s_rel_cases] +QED (* TODO initial_ctors ⊆ FDOM genv.c could do and that follows from genv_c_ok *) @@ -3663,11 +3677,12 @@ val SND_eq = Q.prove( `SND x = y ⇔ ∃a. x = (a,y)`, Cases_on`x`\\rw[]); -Theorem compile_prog_correct - `precondition s1 env1 c ⇒ +Theorem compile_prog_correct: + precondition s1 env1 c ⇒ ¬semantics_prog s1 env1 prog Fail ⇒ - semantics_prog s1 env1 prog (semantics F T s1.ffi (SND (compile_prog c prog)))` - (rw[semantics_prog_def,SND_eq,precondition_def] + semantics_prog s1 env1 prog (semantics F T s1.ffi (SND (compile_prog c prog))) +Proof + rw[semantics_prog_def,SND_eq,precondition_def] \\ simp[flatSemTheory.semantics_def] \\ IF_CASES_TAC \\ fs[SND_eq] >- ( @@ -3816,7 +3831,8 @@ Theorem compile_prog_correct \\ pairarg_tac \\ fs[] \\ metis_tac[evaluatePropsTheory.evaluate_decs_ffi_mono_clock, evaluatePropsTheory.io_events_mono_def, - LESS_EQ_CASES,FST]); + LESS_EQ_CASES,FST] +QED (* - connect semantics theorems of flat-to-flat passes --------------------- *) @@ -3828,14 +3844,15 @@ val _ = set_grammar_ancestry "flat_exh_matchProof", "flat_reorder_matchProof"] @ grammar_ancestry); -Theorem compile_decs_tidx_thm - `!n1 next1 env1 ds1 n2 next2 env2 ds2. +Theorem compile_decs_tidx_thm: + !n1 next1 env1 ds1 n2 next2 env2 ds2. compile_decs n1 next1 env1 ds1 = (n2, next2, env2, ds2) ==> ALL_DISTINCT (get_tdecs ds2) /\ EVERY (\d. !t s. d = Dtype t s ==> next1.tidx <= t /\ t < next2.tidx) ds2 /\ - (next1.tidx = next2.tidx <=> get_tdecs ds2 = [])` - (ho_match_mp_tac compile_decs_ind + (next1.tidx = next2.tidx <=> get_tdecs ds2 = []) +Proof + ho_match_mp_tac compile_decs_ind \\ rw [compile_decs_def] \\ fs [get_tdecs_def] \\ rpt (pairarg_tac \\ fs []) \\ rw [] \\ fs [FILTER_APPEND, ALL_DISTINCT_APPEND, compile_exp_def, @@ -3861,25 +3878,29 @@ Theorem compile_decs_tidx_thm \\ (strip_tac \\ imp_res_tac get_tdecs_MEM \\ fs [] - \\ res_tac \\ fs [])); + \\ res_tac \\ fs []) +QED -Theorem compile_flat_correct - `EVERY (is_new_type init_ctors) prog /\ +Theorem compile_flat_correct: + EVERY (is_new_type init_ctors) prog /\ ALL_DISTINCT (get_tdecs prog) /\ semantics F T ffi prog <> Fail ==> - semantics F T ffi prog = semantics T F ffi (compile_flat prog)` - (rw [compile_flat_def] + semantics F T ffi prog = semantics T F ffi (compile_flat prog) +Proof + rw [compile_flat_def] \\ metis_tac [flat_uncheck_ctorsProofTheory.compile_decs_semantics, flat_elimProofTheory.flat_remove_semantics, flat_reorder_matchProofTheory.compile_decs_semantics, - flat_exh_matchProofTheory.compile_decs_semantics]); + flat_exh_matchProofTheory.compile_decs_semantics] +QED -Theorem compile_semantics - `source_to_flatProof$precondition s env c ⇒ +Theorem compile_semantics: + source_to_flatProof$precondition s env c ⇒ ¬semantics_prog s env prog Fail ⇒ - semantics_prog s env prog (semantics T F s.ffi (SND (compile c prog)))` - (rw [compile_def] \\ pairarg_tac \\ fs [] + semantics_prog s env prog (semantics T F s.ffi (SND (compile c prog))) +Proof + rw [compile_def] \\ pairarg_tac \\ fs [] \\ imp_res_tac compile_prog_correct \\ rfs [] \\ `semantics F T s.ffi p' <> Fail` by (CCONTR_TAC \\ fs []) \\ `semantics F T s.ffi p' = semantics T F s.ffi (compile_flat p')` @@ -3902,12 +3923,13 @@ Theorem compile_semantics \\ EVAL_TAC \\ fs [flookup_thm] \\ rw [] \\ CCONTR_TAC \\ fs []) \\ fs [glob_alloc_def, EVERY_MEM] - \\ res_tac \\ fs []); + \\ res_tac \\ fs [] +QED (* - esgc_free theorems for compile_exp ------------------------------------ *) -Theorem compile_exp_esgc_free - `(!tra env exp. +Theorem compile_exp_esgc_free: + (!tra env exp. nsAll (\_ v. esgc_free v /\ set_globals v = {||}) env.v ==> esgc_free (compile_exp tra env exp) /\ @@ -3926,8 +3948,9 @@ Theorem compile_exp_esgc_free nsAll (\_ v. esgc_free v /\ set_globals v = {||}) env.v ==> EVERY esgc_free (MAP (SND o SND) (compile_funs tra env funs)) /\ - elist_globals (MAP (SND o SND) (compile_funs tra env funs)) = {||})` - (ho_match_mp_tac compile_exp_ind + elist_globals (MAP (SND o SND) (compile_funs tra env funs)) = {||}) +Proof + ho_match_mp_tac compile_exp_ind \\ rpt conj_tac \\ rpt gen_tac \\ rpt disch_tac @@ -3970,14 +3993,16 @@ Theorem compile_exp_esgc_free \\ qid_spec_tac `ps` \\ Induct \\ rw [pat_tups_def, namespaceTheory.nsBindList_def] \\ last_x_assum drule - \\ fs [namespaceTheory.nsBindList_def, nsAll_nsBind]); + \\ fs [namespaceTheory.nsBindList_def, nsAll_nsBind] +QED (* - esgc_free theorems for compile_decs ----------------------------------- *) -Theorem set_globals_make_varls - `∀a b c d. flatProps$set_globals (make_varls a b c d) = - LIST_TO_BAG (MAP ((+)c) (COUNT_LIST (LENGTH d)))` - (recInduct source_to_flatTheory.make_varls_ind +Theorem set_globals_make_varls: + ∀a b c d. flatProps$set_globals (make_varls a b c d) = + LIST_TO_BAG (MAP ((+)c) (COUNT_LIST (LENGTH d))) +Proof + recInduct source_to_flatTheory.make_varls_ind \\ rw[source_to_flatTheory.make_varls_def] >- EVAL_TAC >- ( EVAL_TAC \\ rw[] \\ rw[EL_BAG] ) @@ -3985,34 +4010,44 @@ Theorem set_globals_make_varls \\ EVAL_TAC \\ AP_THM_TAC \\ simp[FUN_EQ_THM] - \\ simp[BAG_INSERT_UNION]); + \\ simp[BAG_INSERT_UNION] +QED -Theorem make_varls_esgc_free - `!n t idx xs. - esgc_free (make_varls n t idx xs)` - (ho_match_mp_tac make_varls_ind - \\ rw [make_varls_def]); +Theorem make_varls_esgc_free: + !n t idx xs. + esgc_free (make_varls n t idx xs) +Proof + ho_match_mp_tac make_varls_ind + \\ rw [make_varls_def] +QED -Theorem alloc_defs_set_globals - `!xs n next. elist_globals (MAP SND (alloc_defs n next xs)) = {||}` - (Induct \\ rw [alloc_defs_def, op_gbag_def]); +Theorem alloc_defs_set_globals: + !xs n next. elist_globals (MAP SND (alloc_defs n next xs)) = {||} +Proof + Induct \\ rw [alloc_defs_def, op_gbag_def] +QED -Theorem alloc_defs_esgc_free - `!xs n next. EVERY esgc_free (MAP SND (alloc_defs n next xs))` - (Induct \\ rw [alloc_defs_def, op_gbag_def]); +Theorem alloc_defs_esgc_free: + !xs n next. EVERY esgc_free (MAP SND (alloc_defs n next xs)) +Proof + Induct \\ rw [alloc_defs_def, op_gbag_def] +QED -Theorem nsAll_extend_env - `nsAll P e1.v /\ nsAll P e2.v ==> nsAll P (extend_env e1 e2).v` - (simp [extend_env_def, nsAll_nsAppend]); +Theorem nsAll_extend_env: + nsAll P e1.v /\ nsAll P e2.v ==> nsAll P (extend_env e1 e2).v +Proof + simp [extend_env_def, nsAll_nsAppend] +QED -Theorem compile_decs_esgc_free - `!n next env decs n1 next1 env1 decs1. +Theorem compile_decs_esgc_free: + !n next env decs n1 next1 env1 decs1. nsAll (\_ v. esgc_free v /\ set_globals v = {||}) env.v /\ compile_decs n next env decs = (n1, next1, env1, decs1) ==> EVERY esgc_free (MAP dest_Dlet (FILTER is_Dlet decs1)) /\ - nsAll (\_ v. esgc_free v /\ set_globals v = {||}) env1.v` - (ho_match_mp_tac compile_decs_ind + nsAll (\_ v. esgc_free v /\ set_globals v = {||}) env1.v +Proof + ho_match_mp_tac compile_decs_ind \\ rw [compile_decs_def] \\ fs [compile_exp_esgc_free, make_varls_esgc_free] \\ fs [EVERY_MAP, EVERY_FILTER, MAP_FILTER] @@ -4062,41 +4097,48 @@ Theorem compile_decs_esgc_free \\ fs [EVERY_MEM, lift_env_def] \\ last_x_assum mp_tac \\ impl_tac \\ rw [] - \\ irule nsAll_extend_env \\ fs []); + \\ irule nsAll_extend_env \\ fs [] +QED (* - the source_to_flat compiler produces things which are esgc_free ------- *) -Theorem compile_prog_esgc_free - `nsAll (\_ v. esgc_free v /\ set_globals v = {||}) c.mod_env.v /\ +Theorem compile_prog_esgc_free: + nsAll (\_ v. esgc_free v /\ set_globals v = {||}) c.mod_env.v /\ compile_prog c p = (c1, p1) ==> - EVERY esgc_free (MAP dest_Dlet (FILTER is_Dlet p1))` - (rw [compile_prog_def] + EVERY esgc_free (MAP dest_Dlet (FILTER is_Dlet p1)) +Proof + rw [compile_prog_def] \\ pairarg_tac \\ fs [] \\ rveq \\ fs [glob_alloc_def] - \\ metis_tac [compile_decs_esgc_free]); + \\ metis_tac [compile_decs_esgc_free] +QED -Theorem compile_flat_esgc_free - `EVERY esgc_free (MAP dest_Dlet (FILTER is_Dlet ds)) +Theorem compile_flat_esgc_free: + EVERY esgc_free (MAP dest_Dlet (FILTER is_Dlet ds)) ==> - EVERY esgc_free (MAP dest_Dlet (FILTER is_Dlet (compile_flat ds)))` - (rw [compile_flat_def, flat_exh_matchTheory.compile_def] + EVERY esgc_free (MAP dest_Dlet (FILTER is_Dlet (compile_flat ds))) +Proof + rw [compile_flat_def, flat_exh_matchTheory.compile_def] \\ drule flat_exh_matchProofTheory.compile_decs_esgc_free \\ disch_then (qspec_then `init_ctors` mp_tac) \\ rw [] \\ drule flat_elimProofTheory.remove_flat_prog_esgc_free \\ rw [] \\ rename1 `compile_decs (compile_decs ds1)` \\ irule flat_reorder_matchProofTheory.compile_decs_esgc_free \\ irule flat_uncheck_ctorsProofTheory.compile_decs_esgc_free - \\ rw[]); + \\ rw[] +QED -Theorem compile_esgc_free - `nsAll (\_ v. esgc_free v /\ set_globals v = {||}) c.mod_env.v /\ +Theorem compile_esgc_free: + nsAll (\_ v. esgc_free v /\ set_globals v = {||}) c.mod_env.v /\ compile c p = (c1, p1) ==> - EVERY esgc_free (MAP dest_Dlet (FILTER is_Dlet p1))` - (rw [compile_def] + EVERY esgc_free (MAP dest_Dlet (FILTER is_Dlet p1)) +Proof + rw [compile_def] \\ pairarg_tac \\ fs [] \\ rveq - \\ metis_tac [compile_prog_esgc_free, compile_flat_esgc_free]); + \\ metis_tac [compile_prog_esgc_free, compile_flat_esgc_free] +QED val mem_size_lemma = Q.prove ( `list_size sz xs < N ==> (MEM x xs ⇒ sz x < N)`, Induct_on `xs` \\ rw [list_size_def] \\ fs []); @@ -4115,26 +4157,29 @@ val num_bindings_def = tDefine"num_bindings" val _ = export_rewrites["num_bindings_def"]; -Theorem compile_decs_num_bindings - `∀n next env ds e f g p. compile_decs n next env ds = (e,f,g,p) ⇒ +Theorem compile_decs_num_bindings: + ∀n next env ds e f g p. compile_decs n next env ds = (e,f,g,p) ⇒ next.vidx ≤ f.vidx ∧ - SUM (MAP num_bindings ds) = f.vidx - next.vidx` - (recInduct source_to_flatTheory.compile_decs_ind + SUM (MAP num_bindings ds) = f.vidx - next.vidx +Proof + recInduct source_to_flatTheory.compile_decs_ind \\ rw[source_to_flatTheory.compile_decs_def] \\ rw[] \\ pairarg_tac \\ fsrw_tac[ETA_ss][] - \\ pairarg_tac \\ fs[] \\ rw[]); + \\ pairarg_tac \\ fs[] \\ rw[] +QED val COUNT_LIST_ADD_SYM = COUNT_LIST_ADD |> CONV_RULE (SIMP_CONV bool_ss [Once ADD_SYM]); -Theorem compile_decs_elist_globals - `∀n next env ds e f g p. +Theorem compile_decs_elist_globals: + ∀n next env ds e f g p. compile_decs n next env ds = (e,f,g,p) ∧ nsAll (λ_ v. esgc_free v ∧ set_globals v = {||}) env.v ⇒ elist_globals (MAP dest_Dlet (FILTER is_Dlet p)) = - LIST_TO_BAG (MAP ((+) next.vidx) (COUNT_LIST (SUM (MAP num_bindings ds))))` - (recInduct source_to_flatTheory.compile_decs_ind + LIST_TO_BAG (MAP ((+) next.vidx) (COUNT_LIST (SUM (MAP num_bindings ds)))) +Proof + recInduct source_to_flatTheory.compile_decs_ind \\ rw[source_to_flatTheory.compile_decs_def] \\ rw[set_globals_make_varls] \\ rw[compile_exp_esgc_free] @@ -4260,6 +4305,7 @@ Theorem compile_decs_elist_globals \\ rw[] \\ AP_TERM_TAC \\ fs[MAP_EQ_f] - )); + ) +QED val _ = export_theory (); diff --git a/compiler/backend/proofs/stack_allocProofScript.sml b/compiler/backend/proofs/stack_allocProofScript.sml index 6563034fbd..c7a8c07719 100644 --- a/compiler/backend/proofs/stack_allocProofScript.sml +++ b/compiler/backend/proofs/stack_allocProofScript.sml @@ -23,9 +23,10 @@ val _ = temp_bring_to_front_overload"compile"{Thy="stack_alloc",Name="compile"}; (* TODO: move and join with stack_remove *) -Theorem lsl_lsr - `w2n ((n:'a word)) * 2 ** a < dimword (:'a) ⇒ n << a >>> a = n` - (Cases_on`n` \\ simp[] +Theorem lsl_lsr: + w2n ((n:'a word)) * 2 ** a < dimword (:'a) ⇒ n << a >>> a = n +Proof + Cases_on`n` \\ simp[] \\ qmatch_assum_rename_tac`n < dimword _` \\ srw_tac[][] \\ REWRITE_TAC[GSYM wordsTheory.w2n_11] @@ -42,18 +43,21 @@ Theorem lsl_lsr \\ qmatch_asmsub_rename_tac`SUC n * 2 ** a` \\ qspecl_then[`a`,`2`,`SUC n`]mp_tac logrootTheory.LOG_EXP \\ simp[] ) - \\ simp[MULT_DIV]); - -Theorem bytes_in_word_word_shift - `good_dimindex(:'a) ∧ w2n (bytes_in_word:'a word) * w2n n < dimword(:'a) ⇒ - (bytes_in_word:'a word * n) >>> word_shift (:'a) = n` - (EVAL_TAC \\ srw_tac[][] \\ pop_assum mp_tac + \\ simp[MULT_DIV] +QED + +Theorem bytes_in_word_word_shift: + good_dimindex(:'a) ∧ w2n (bytes_in_word:'a word) * w2n n < dimword(:'a) ⇒ + (bytes_in_word:'a word * n) >>> word_shift (:'a) = n +Proof + EVAL_TAC \\ srw_tac[][] \\ pop_assum mp_tac \\ blastLib.BBLAST_TAC \\ simp[] \\ blastLib.BBLAST_TAC \\ srw_tac[][] \\ match_mp_tac lsl_lsr \\ simp[] \\ Cases_on`n`\\full_simp_tac(srw_ss())[word_lsl_n2w] - \\ full_simp_tac(srw_ss())[dimword_def]); + \\ full_simp_tac(srw_ss())[dimword_def] +QED (* ---- *) @@ -68,9 +72,11 @@ val prog_comp_lemma = Q.prove( `prog_comp = \(n,p). (n,FST (comp n (next_lab p 1) p))`, full_simp_tac(srw_ss())[FUN_EQ_THM,FORALL_PROD,prog_comp_def]); -Theorem FST_prog_comp[simp] - `FST (prog_comp pp) = FST pp` - (Cases_on`pp` \\ EVAL_TAC); +Theorem FST_prog_comp[simp]: + FST (prog_comp pp) = FST pp +Proof + Cases_on`pp` \\ EVAL_TAC +QED val lookup_IMP_lookup_compile = Q.prove( `lookup dest s.code = SOME x /\ dest ≠ gc_stub_location ==> @@ -99,13 +105,14 @@ val map_bitmap_APPEND = Q.prove( \\ Cases \\ full_simp_tac(srw_ss())[map_bitmap_def] \\ every_case_tac \\ full_simp_tac(srw_ss())[]); -Theorem filter_bitmap_map_bitmap - `!x t q xs xs1 z ys ys1. +Theorem filter_bitmap_map_bitmap: + !x t q xs xs1 z ys ys1. filter_bitmap x t = SOME (xs,xs1) /\ LENGTH q = LENGTH xs /\ map_bitmap x q t = SOME (ys,z,ys1) ==> - z = [] /\ ys1 = xs1` - (Induct + z = [] /\ ys1 = xs1 +Proof + Induct THEN1 ( fs[filter_bitmap_def,map_bitmap_def] ) \\ Cases_on `t` \\ Cases_on `q` \\ Cases \\ rewrite_tac [filter_bitmap_def] \\ simp_tac std_ss [map_bitmap_def] @@ -126,40 +133,47 @@ Theorem filter_bitmap_map_bitmap \\ rpt gen_tac \\ strip_tac \\ first_x_assum match_mp_tac \\ qexists_tac `t'` \\ full_simp_tac(srw_ss())[] - \\ qexists_tac `h'::t` \\ full_simp_tac(srw_ss())[]); + \\ qexists_tac `h'::t` \\ full_simp_tac(srw_ss())[] +QED val get_bits_def = Define ` get_bits w = GENLIST (\i. w ' i) (bit_length w − 1)` -Theorem bit_length_thm - `!w. ((w >>> bit_length w) = 0w) /\ !n. n < bit_length w ==> (w >>> n) <> 0w` - (HO_MATCH_MP_TAC bit_length_ind \\ srw_tac[][] +Theorem bit_length_thm: + !w. ((w >>> bit_length w) = 0w) /\ !n. n < bit_length w ==> (w >>> n) <> 0w +Proof + HO_MATCH_MP_TAC bit_length_ind \\ srw_tac[][] \\ once_rewrite_tac [bit_length_def] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[AC ADD_COMM ADD_ASSOC] \\ Cases_on `w = 0w` \\ full_simp_tac(srw_ss())[EVAL ``bit_length 0w``] \\ Cases_on `n` \\ full_simp_tac(srw_ss())[] \\ ntac 2 (pop_assum mp_tac) \\ once_rewrite_tac [bit_length_def] - \\ full_simp_tac(srw_ss())[ADD1] \\ srw_tac[][]); + \\ full_simp_tac(srw_ss())[ADD1] \\ srw_tac[][] +QED val word_lsr_dimindex = Q.prove( `(w:'a word) >>> dimindex (:'a) = 0w`, full_simp_tac(srw_ss())[]); -Theorem bit_length_LESS_EQ_dimindex - `bit_length (w:'a word) <= dimindex (:'a)` - (CCONTR_TAC \\ full_simp_tac(srw_ss())[GSYM NOT_LESS] +Theorem bit_length_LESS_EQ_dimindex: + bit_length (w:'a word) <= dimindex (:'a) +Proof + CCONTR_TAC \\ full_simp_tac(srw_ss())[GSYM NOT_LESS] \\ imp_res_tac bit_length_thm - \\ full_simp_tac(srw_ss())[word_lsr_dimindex]); + \\ full_simp_tac(srw_ss())[word_lsr_dimindex] +QED -Theorem shift_to_zero_word_msb - `(w:'a word) >>> n = 0w /\ word_msb w ==> dimindex (:'a) <= n` - (srw_tac [wordsLib.WORD_BIT_EQ_ss] [] +Theorem shift_to_zero_word_msb: + (w:'a word) >>> n = 0w /\ word_msb w ==> dimindex (:'a) <= n +Proof + srw_tac [wordsLib.WORD_BIT_EQ_ss] [] \\ CCONTR_TAC \\ qpat_x_assum `!xx.bb` mp_tac \\ fs [GSYM NOT_LESS] \\ qexists_tac `dimindex (:α) - 1 - n` - \\ simp []) + \\ simp [] +QED val word_msb_IMP_bit_length = Q.prove( `!h. word_msb (h:'a word) ==> (bit_length h = dimindex (:'a))`, @@ -189,13 +203,16 @@ val filter_bitmap_APPEND = Q.prove( \\ Cases \\ full_simp_tac(srw_ss())[filter_bitmap_def] \\ srw_tac[][] \\ rpt (CASE_TAC \\ full_simp_tac(srw_ss())[])); -Theorem bit_length_minus_1 - `w <> 0w ==> bit_length w − 1 = bit_length (w >>> 1)` - (simp [Once bit_length_def]); +Theorem bit_length_minus_1: + w <> 0w ==> bit_length w − 1 = bit_length (w >>> 1) +Proof + simp [Once bit_length_def] +QED -Theorem bit_length_eq_1 - `bit_length w = 1 <=> w = 1w` - (Cases_on `w = 1w` \\ full_simp_tac(srw_ss())[] THEN1 (EVAL_TAC \\ full_simp_tac(srw_ss())[]) +Theorem bit_length_eq_1: + bit_length w = 1 <=> w = 1w +Proof + Cases_on `w = 1w` \\ full_simp_tac(srw_ss())[] THEN1 (EVAL_TAC \\ full_simp_tac(srw_ss())[]) \\ once_rewrite_tac [bit_length_def] \\ srw_tac[][] \\ once_rewrite_tac [bit_length_def] \\ srw_tac[][] \\ pop_assum mp_tac @@ -203,11 +220,14 @@ Theorem bit_length_eq_1 \\ Cases_on `w` \\ full_simp_tac(srw_ss())[] \\ Cases_on `n` \\ full_simp_tac(srw_ss())[] \\ Cases_on `n'` \\ full_simp_tac(srw_ss())[] - \\ full_simp_tac(srw_ss())[DIV_EQ_X] \\ decide_tac); + \\ full_simp_tac(srw_ss())[DIV_EQ_X] \\ decide_tac +QED -Theorem word_and_one_eq_0_iff - `!w. ((w && 1w) = 0w) <=> ~(w ' 0)` - (srw_tac [wordsLib.WORD_BIT_EQ_ss] [wordsTheory.word_index]) +Theorem word_and_one_eq_0_iff: + !w. ((w && 1w) = 0w) <=> ~(w ' 0) +Proof + srw_tac [wordsLib.WORD_BIT_EQ_ss] [wordsTheory.word_index] +QED val split_num_forall_to_10 = Q.prove( `($! P) <=> P 0 /\ P 1 /\ P 2 /\ P 3 /\ P 4 /\ P 5 /\ @@ -223,19 +243,25 @@ val nine_less = DECIDE ``9 < n ==> n <> 0 /\ n <> 1 /\ n <> 2 /\ n <> 3 /\ n <> 4 /\ n <> 5 /\ n <> 6 /\ n <> 7 /\ n <> 8 /\ n <> 9n`` -Theorem word_shift_not_0 - `word_shift (:'a) <> 0` - (srw_tac[][word_shift_def] \\ full_simp_tac(srw_ss())[]); +Theorem word_shift_not_0: + word_shift (:'a) <> 0 +Proof + srw_tac[][word_shift_def] \\ full_simp_tac(srw_ss())[] +QED -Theorem select_lower_lemma - `(n -- 0) w = ((w:'a word) << (dimindex(:'a)-n-1)) >>> (dimindex(:'a)-n-1)` - (srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] [wordsTheory.word_index] +Theorem select_lower_lemma: + (n -- 0) w = ((w:'a word) << (dimindex(:'a)-n-1)) >>> (dimindex(:'a)-n-1) +Proof + srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] [wordsTheory.word_index] \\ Cases_on `i + (dimindex (:α) - n - 1) < dimindex (:α)` - \\ fs []); + \\ fs [] +QED -Theorem select_eq_select_0 - `k <= n ==> (n -- k) w = (n - k -- 0) (w >>> k)` - (srw_tac [wordsLib.WORD_BIT_EQ_ss] [] \\ eq_tac \\ rw []) +Theorem select_eq_select_0: + k <= n ==> (n -- k) w = (n - k -- 0) (w >>> k) +Proof + srw_tac [wordsLib.WORD_BIT_EQ_ss] [] \\ eq_tac \\ rw [] +QED val is_fwd_ptr_iff = Q.prove( `!w. is_fwd_ptr w <=> ?v. w = Word v /\ (v && 3w) = 0w`, @@ -260,38 +286,46 @@ val LUPDATE_LENGTH_ADD_LEMMA = Q.prove( init ++ old ++ [w] ++ st1`, mp_tac (LUPDATE_LENGTH |> Q.SPECL [`init++old`]) \\ fs []); -Theorem word_msb_IFF_lsr_EQ_0 - `word_msb h <=> (h >>> (dimindex (:'a) - 1) <> 0w:'a word)` - (srw_tac [wordsLib.WORD_BIT_EQ_ss] []) +Theorem word_msb_IFF_lsr_EQ_0: + word_msb h <=> (h >>> (dimindex (:'a) - 1) <> 0w:'a word) +Proof + srw_tac [wordsLib.WORD_BIT_EQ_ss] [] +QED -Theorem map_bitmap_IMP_LENGTH - `!x wl stack xs ys. +Theorem map_bitmap_IMP_LENGTH: + !x wl stack xs ys. map_bitmap x wl stack = SOME (xs,ys) ==> - LENGTH xs = LENGTH x` - (recInduct map_bitmap_ind \\ fs [map_bitmap_def] + LENGTH xs = LENGTH x +Proof + recInduct map_bitmap_ind \\ fs [map_bitmap_def] \\ rw [] \\ res_tac \\ fs [] - \\ every_case_tac \\ fs [] \\ rw [] \\ fs []); + \\ every_case_tac \\ fs [] \\ rw [] \\ fs [] +QED -Theorem filter_bitmap_IMP_LENGTH - `!x stack q r. +Theorem filter_bitmap_IMP_LENGTH: + !x stack q r. filter_bitmap x stack = SOME (q,r) ==> - LENGTH stack = LENGTH x + LENGTH r` - (recInduct filter_bitmap_ind \\ fs [filter_bitmap_def] + LENGTH stack = LENGTH x + LENGTH r +Proof + recInduct filter_bitmap_ind \\ fs [filter_bitmap_def] \\ rw [] \\ res_tac \\ fs [] - \\ every_case_tac \\ fs []); + \\ every_case_tac \\ fs [] +QED val EL_LENGTH_ADD_LEMMA = Q.prove( `!n xs y ys. LENGTH xs = n ==> EL n (xs ++ y::ys) = y`, fs [EL_LENGTH_APPEND]); -Theorem bytes_in_word_word_shift_n2w - `good_dimindex (:α) ∧ (dimindex(:'a) DIV 8) * n < dimword (:α) ⇒ - (bytes_in_word * n2w n) ⋙ word_shift (:α) = (n2w n):'a word` - (strip_tac \\ match_mp_tac bytes_in_word_word_shift +Theorem bytes_in_word_word_shift_n2w: + good_dimindex (:α) ∧ (dimindex(:'a) DIV 8) * n < dimword (:α) ⇒ + (bytes_in_word * n2w n) ⋙ word_shift (:α) = (n2w n):'a word +Proof + strip_tac \\ match_mp_tac bytes_in_word_word_shift \\ fs [bytes_in_word_def] \\ `(dimindex (:α) DIV 8) < dimword (:α) /\ n < dimword (:α)` by (rfs [labPropsTheory.good_dimindex_def,dimword_def] \\ rfs []) - \\ fs []); + \\ fs [] +QED val tac = simp [list_Seq_def,evaluate_def,inst_def,word_exp_def,get_var_def, wordLangTheory.word_op_def,mem_load_def,assign_def,set_var_def, @@ -364,8 +398,8 @@ val memcpy_code_thm = Q.prove( \\ once_rewrite_tac [split_num_forall_to_10] \\ full_simp_tac(srw_ss())[nine_less] \\ full_simp_tac(srw_ss())[GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB]) -Theorem memcpy_code_thm - `!w a b m dm b1 m1 (s:('a,'c,'b)stackSem$state). +Theorem memcpy_code_thm: + !w a b m dm b1 m1 (s:('a,'c,'b)stackSem$state). memcpy (w:'a word) a b m dm = (b1:'a word,m1,T) /\ s.memory = m /\ s.mdomain = dm /\ get_var 0 s = SOME (Word w) /\ @@ -378,12 +412,14 @@ Theorem memcpy_code_thm regs := s.regs |++ [(0,Word 0w); (1,r1); (2,Word (a + w * bytes_in_word)); - (3,Word b1)] |>)` - (Cases \\ full_simp_tac(srw_ss())[] + (3,Word b1)] |>) +Proof + Cases \\ full_simp_tac(srw_ss())[] \\ pop_assum mp_tac \\ qspec_tac (`n`,`n`) \\ full_simp_tac(srw_ss())[PULL_FORALL] \\ rpt strip_tac \\ match_mp_tac (memcpy_code_thm |> SIMP_RULE (srw_ss()) []) - \\ metis_tac []) + \\ metis_tac [] +QED (* gc_kind = Simple *) @@ -452,17 +488,21 @@ val word_gc_move_roots_bitmaps_def = Define ` | NONE => (ARB,ARB,ARB,ARB,F) | SOME stack => (stack,i2,pa2,m2,c2)` -Theorem word_gc_move_loop_F - `!k conf pb i pa old m dm i1 pa1 m1 c1. - word_gc_move_loop k conf (pb,i,pa,old,m,dm,F) = (i1,pa1,m1,c1) ==> ~c1` - (Induct \\ once_rewrite_tac [word_gc_move_loop_def] \\ fs [] \\ rw [] +Theorem word_gc_move_loop_F: + !k conf pb i pa old m dm i1 pa1 m1 c1. + word_gc_move_loop k conf (pb,i,pa,old,m,dm,F) = (i1,pa1,m1,c1) ==> ~c1 +Proof + Induct \\ once_rewrite_tac [word_gc_move_loop_def] \\ fs [] \\ rw [] \\ pairarg_tac \\ fs [] \\ IF_CASES_TAC \\ fs [] - \\ pairarg_tac \\ fs []); + \\ pairarg_tac \\ fs [] +QED -Theorem word_gc_move_loop_ok - `word_gc_move_loop k conf (pb,i,pa,old,m,dm,c) = (i1,pa1,m1,c1) ==> c1 ==> c` - (Cases_on `c` \\ fs [] \\ rw [] \\ imp_res_tac word_gc_move_loop_F \\ fs []); +Theorem word_gc_move_loop_ok: + word_gc_move_loop k conf (pb,i,pa,old,m,dm,c) = (i1,pa1,m1,c1) ==> c1 ==> c +Proof + Cases_on `c` \\ fs [] \\ rw [] \\ imp_res_tac word_gc_move_loop_F \\ fs [] +QED val gc_thm = Q.prove( `s.gc_fun = word_gc_fun conf /\ conf.gc_kind = Simple ==> @@ -550,13 +590,15 @@ val word_gc_move_roots_APPEND = Q.prove( \\ rveq \\ fs[] \\ EQ_TAC \\ fs[] \\ rw[]); -Theorem word_gc_move_roots_IMP_LENGTH - `!xs r0 r1 curr r2 dm ys i2 pa2 m2 c conf. +Theorem word_gc_move_roots_IMP_LENGTH: + !xs r0 r1 curr r2 dm ys i2 pa2 m2 c conf. word_gc_move_roots conf (xs,r0,r1,curr,r2,dm) = (ys,i2,pa2,m2,c) ==> - LENGTH ys = LENGTH xs` - (Induct \\ full_simp_tac(srw_ss())[word_gc_move_roots_def,LET_THM] \\ srw_tac[][] + LENGTH ys = LENGTH xs +Proof + Induct \\ full_simp_tac(srw_ss())[word_gc_move_roots_def,LET_THM] \\ srw_tac[][] \\ rpt (pairarg_tac \\ full_simp_tac(srw_ss())[]) - \\ rpt var_eq_tac \\ full_simp_tac(srw_ss())[] \\ res_tac); + \\ rpt var_eq_tac \\ full_simp_tac(srw_ss())[] \\ res_tac +QED val word_gc_move_roots_bitmaps = Q.prove( `!stack i1 pa1 m stack2 i2 pa2 m2. @@ -770,8 +812,8 @@ val word_gc_move_bitmap_unroll = Q.prove( \\ full_simp_tac(srw_ss())[map_bitmap_def] \\ rpt (CASE_TAC \\ full_simp_tac(srw_ss())[])); -Theorem word_gc_move_code_thm - `word_gc_move conf (w,i,pa,old,m,dm) = (w1,i1,pa1,m1,T) /\ +Theorem word_gc_move_code_thm: + word_gc_move conf (w,i,pa,old,m,dm) = (w1,i1,pa1,m1,T) /\ shift_length conf < dimindex (:'a) /\ word_shift (:'a) < dimindex (:'a) /\ 2 < dimindex (:'a) /\ conf.len_size <> 0 /\ (!w:'a word. w << word_shift (:'a) = w * bytes_in_word) /\ @@ -793,8 +835,9 @@ Theorem word_gc_move_code_thm (3,Word pa1); (4,Word i1); (5,w1); - (6,r6)] |>)` - (reverse (Cases_on `w`) \\ full_simp_tac(srw_ss())[word_gc_move_def] THEN1 + (6,r6)] |>) +Proof + reverse (Cases_on `w`) \\ full_simp_tac(srw_ss())[word_gc_move_def] THEN1 (srw_tac[][word_gc_move_code_def,evaluate_def] \\ full_simp_tac(srw_ss())[get_var_def] \\ tac \\ full_simp_tac(srw_ss())[state_component_equality] @@ -854,10 +897,11 @@ Theorem word_gc_move_code_thm \\ full_simp_tac(srw_ss())[nine_less] \\ `shift_length conf <> 0` by (EVAL_TAC \\ decide_tac) \\ full_simp_tac(srw_ss())[select_lower_lemma, - DECIDE ``n<>0 ==> m-(n-1)-1=m-n:num``]); + DECIDE ``n<>0 ==> m-(n-1)-1=m-n:num``] +QED -Theorem word_gc_move_list_code_thm - `!l a (s:('a,'c,'b)stackSem$state) pa1 pa old m1 m i1 i dm conf a1. +Theorem word_gc_move_list_code_thm: + !l a (s:('a,'c,'b)stackSem$state) pa1 pa old m1 m i1 i dm conf a1. word_gc_move_list conf (a:'a word,l,i,pa,old,m,dm) = (a1,i1,pa1,m1,T) /\ shift_length conf < dimindex (:'a) /\ word_shift (:'a) < dimindex (:'a) /\ 2 < dimindex (:'a) /\ conf.len_size <> 0 /\ @@ -884,8 +928,9 @@ Theorem word_gc_move_list_code_thm (5,r5); (6,r6); (7,Word 0w); - (8,Word a1)] |>)` - (Cases \\ Induct_on `n` \\ simp [] THEN1 + (8,Word a1)] |>) +Proof + Cases \\ Induct_on `n` \\ simp [] THEN1 (fs [Once word_gc_move_list_def] \\ rw [] \\ qexists_tac `0` \\ fs [word_gc_move_list_code_def,get_var_def] \\ tac @@ -939,7 +984,8 @@ Theorem word_gc_move_list_code_thm \\ full_simp_tac(srw_ss())[FUPDATE_LIST,GSYM fmap_EQ,FLOOKUP_DEF,EXTENSION, FUN_EQ_THM,FAPPLY_FUPDATE_THM] \\ once_rewrite_tac [split_num_forall_to_10] - \\ full_simp_tac(srw_ss())[nine_less]) + \\ full_simp_tac(srw_ss())[nine_less] +QED val word_gc_move_loop_code_thm = Q.prove( `!k pb1 i1 pa1 old1 m1 dm1 c1 i2 pa2 m2 (s:('a,'c,'b)stackSem$state). @@ -1055,8 +1101,8 @@ val word_gc_move_loop_code_thm = Q.prove( \\ once_rewrite_tac [split_num_forall_to_10] \\ full_simp_tac(srw_ss())[nine_less]); -Theorem word_gc_move_bitmap_code_thm - `!w stack (s:('a,'c,'b)stackSem$state) i pa curr m dm new stack1 a1 i1 pa1 m1 old. +Theorem word_gc_move_bitmap_code_thm: + !w stack (s:('a,'c,'b)stackSem$state) i pa curr m dm new stack1 a1 i1 pa1 m1 old. word_gc_move_bitmap conf (w,stack,i,pa,curr,m,dm) = SOME (new,stack1,i1,pa1,m1,T) /\ shift_length conf < dimindex (:'a) /\ word_shift (:'a) < dimindex (:'a) /\ @@ -1088,8 +1134,9 @@ Theorem word_gc_move_bitmap_code_thm (5,r5); (6,r6); (7,r7); - (8,Word (bytes_in_word * n2w (LENGTH (old ++ new))))] |>)` - (recInduct bit_length_ind \\ rpt strip_tac \\ fs [] + (8,Word (bytes_in_word * n2w (LENGTH (old ++ new))))] |>) +Proof + recInduct bit_length_ind \\ rpt strip_tac \\ fs [] \\ qpat_x_assum `word_gc_move_bitmap _ _ = _` mp_tac \\ once_rewrite_tac [word_gc_move_bitmap_unroll] \\ Cases_on `w = 0w` \\ fs [] THEN1 @@ -1196,20 +1243,23 @@ Theorem word_gc_move_bitmap_code_thm \\ full_simp_tac(srw_ss())[FUPDATE_LIST,GSYM fmap_EQ,FLOOKUP_DEF,EXTENSION, FUN_EQ_THM,FAPPLY_FUPDATE_THM] \\ once_rewrite_tac [split_num_forall_to_10] - \\ full_simp_tac(srw_ss())[nine_less]); + \\ full_simp_tac(srw_ss())[nine_less] +QED -Theorem word_gc_move_bitmaps_LENGTH - `word_gc_move_bitmaps conf (w,stack,bitmaps,i,pa,curr,m,dm) = +Theorem word_gc_move_bitmaps_LENGTH: + word_gc_move_bitmaps conf (w,stack,bitmaps,i,pa,curr,m,dm) = SOME (xs,stack1,i1,pa1,m1,T) ==> - LENGTH stack = LENGTH xs + LENGTH stack1` - (fs [word_gc_move_bitmaps_def] + LENGTH stack = LENGTH xs + LENGTH stack1 +Proof + fs [word_gc_move_bitmaps_def] \\ every_case_tac \\ fs [] \\ pairarg_tac \\ fs [] \\ every_case_tac \\ fs [] \\ rw [] \\ imp_res_tac map_bitmap_IMP_LENGTH \\ fs [] - \\ imp_res_tac filter_bitmap_IMP_LENGTH \\ fs []); + \\ imp_res_tac filter_bitmap_IMP_LENGTH \\ fs [] +QED -Theorem word_gc_move_bitmaps_code_thm - `!w bitmaps z stack (s:('a,'c,'b)stackSem$state) i pa curr m dm new +Theorem word_gc_move_bitmaps_code_thm: + !w bitmaps z stack (s:('a,'c,'b)stackSem$state) i pa curr m dm new stack1 a1 i1 pa1 m1 old. word_gc_move_bitmaps conf (Word w,stack,bitmaps,i,pa,curr,m,dm) = SOME (new,stack1,i1,pa1,m1,T) /\ @@ -1246,8 +1296,9 @@ Theorem word_gc_move_bitmaps_code_thm (6,r6); (7,r7); (8,Word (bytes_in_word * n2w (LENGTH (old ++ new)))); - (9,r9)] |>)` - (ntac 2 strip_tac \\ completeInduct_on `LENGTH bitmaps - w2n (w - 1w)` + (9,r9)] |>) +Proof + ntac 2 strip_tac \\ completeInduct_on `LENGTH bitmaps - w2n (w - 1w)` \\ rpt strip_tac \\ fs [] \\ rpt var_eq_tac \\ fs [PULL_FORALL] \\ qpat_x_assum `word_gc_move_bitmaps _ _ = _` (fn th => assume_tac th \\ mp_tac th) @@ -1320,10 +1371,11 @@ Theorem word_gc_move_bitmaps_code_thm \\ full_simp_tac(srw_ss())[FUPDATE_LIST,GSYM fmap_EQ,FLOOKUP_DEF,EXTENSION, FUN_EQ_THM,FAPPLY_FUPDATE_THM] \\ once_rewrite_tac [split_num_forall_to_10] - \\ full_simp_tac(srw_ss())[nine_less] \\ fs []) + \\ full_simp_tac(srw_ss())[nine_less] \\ fs [] +QED -Theorem word_gc_move_roots_bitmaps_code_thm - `!bitmaps (s:('a,'c,'b)stackSem$state) i pa curr m dm new +Theorem word_gc_move_roots_bitmaps_code_thm: + !bitmaps (s:('a,'c,'b)stackSem$state) i pa curr m dm new stack1 a1 i1 pa1 m1 old. word_gc_move_roots_bitmaps conf (stack,bitmaps,i,pa,curr,m,dm) = (stack1,i1,pa1,m1,T) /\ @@ -1361,8 +1413,9 @@ Theorem word_gc_move_roots_bitmaps_code_thm (6,r6); (7,r7); (8,r8); - (9,Word 0w)] |>)` - (completeInduct_on `LENGTH stack` + (9,Word 0w)] |>) +Proof + completeInduct_on `LENGTH stack` \\ rpt strip_tac \\ fs [PULL_FORALL] \\ rpt var_eq_tac \\ fs [] \\ qpat_x_assum `word_gc_move_roots_bitmaps _ _ = _` @@ -1455,10 +1508,11 @@ Theorem word_gc_move_roots_bitmaps_code_thm \\ full_simp_tac(srw_ss())[FUPDATE_LIST,GSYM fmap_EQ,FLOOKUP_DEF,EXTENSION, FUN_EQ_THM,FAPPLY_FUPDATE_THM] \\ once_rewrite_tac [split_num_forall_to_10] - \\ full_simp_tac(srw_ss())[nine_less] \\ fs []) + \\ full_simp_tac(srw_ss())[nine_less] \\ fs [] +QED -Theorem alloc_correct_lemma_Simple - `alloc w (s:('a,'c,'b)stackSem$state) = (r,t) /\ r <> SOME Error /\ +Theorem alloc_correct_lemma_Simple: + alloc w (s:('a,'c,'b)stackSem$state) = (r,t) /\ r <> SOME Error /\ s.gc_fun = word_gc_fun conf /\ conf.gc_kind = Simple /\ LENGTH s.bitmaps < dimword (:'a) - 1 /\ LENGTH s.stack * (dimindex (:'a) DIV 8) < dimword (:'a) /\ @@ -1478,8 +1532,9 @@ Theorem alloc_correct_lemma_Simple regs := l2; gc_fun := anything |>) /\ (r <> NONE ==> r = SOME (Halt (Word 1w))) /\ t.regs SUBMAP l2 /\ - (r = NONE ==> FLOOKUP l2 0 = SOME ret)` - (Cases_on `conf.gc_kind = Simple` \\ fs [] + (r = NONE ==> FLOOKUP l2 0 = SOME ret) +Proof + Cases_on `conf.gc_kind = Simple` \\ fs [] \\ Cases_on `s.gc_fun = word_gc_fun conf` \\ fs [] \\ fs [alloc_def] \\ `(set_store AllocSize (Word w) s).gc_fun = word_gc_fun conf` by (fs [set_store_def] \\ NO_TAC) @@ -1583,7 +1638,8 @@ Theorem alloc_correct_lemma_Simple \\ `TAKE t.stack_space (ys1 ++ ys2) = ys1` by metis_tac [TAKE_LENGTH_APPEND] \\ fs [fmap_EXT,EXTENSION] \\ rw [] \\ fs [FAPPLY_FUPDATE_THM] - \\ fs [SUBMAP_DEF] \\ rw [] \\ fs [] \\ eq_tac \\ strip_tac \\ fs []); + \\ fs [SUBMAP_DEF] \\ rw [] \\ fs [] \\ eq_tac \\ strip_tac \\ fs [] +QED (* gc_kind = Generational *) @@ -1919,25 +1975,29 @@ val word_gen_gc_partial_move_roots_APPEND = Q.prove( \\ pairarg_tac \\ fs[] \\ rveq \\ fs[] \\ EQ_TAC \\ fs[] \\ rw[]); -Theorem word_gen_gc_move_roots_IMP_LENGTH - `!xs r0 r1 r3 r4 curr r2 dm ys i2 pa2 m2 c conf ib2 pb2. +Theorem word_gen_gc_move_roots_IMP_LENGTH: + !xs r0 r1 r3 r4 curr r2 dm ys i2 pa2 m2 c conf ib2 pb2. word_gen_gc_move_roots conf (xs,r0,r1,r3,r4,curr,r2,dm) = (ys,i2,pa2,ib2,pb2,m2,c) ==> - LENGTH ys = LENGTH xs` - (Induct \\ full_simp_tac(srw_ss())[word_gen_gc_move_roots_def,LET_THM] + LENGTH ys = LENGTH xs +Proof + Induct \\ full_simp_tac(srw_ss())[word_gen_gc_move_roots_def,LET_THM] \\ srw_tac[][] \\ rpt (pairarg_tac \\ full_simp_tac(srw_ss())[]) - \\ rpt var_eq_tac \\ full_simp_tac(srw_ss())[] \\ res_tac); + \\ rpt var_eq_tac \\ full_simp_tac(srw_ss())[] \\ res_tac +QED -Theorem word_gen_gc_partial_move_roots_IMP_LENGTH - `!xs r0 r1 r3 r4 curr r2 dm ys i2 pa2 m2 c conf. +Theorem word_gen_gc_partial_move_roots_IMP_LENGTH: + !xs r0 r1 r3 r4 curr r2 dm ys i2 pa2 m2 c conf. word_gen_gc_partial_move_roots conf (xs,r0,r1,curr,r2,dm,r3,r4) = (ys,i2,pa2,m2,c) ==> - LENGTH ys = LENGTH xs` - (Induct \\ full_simp_tac(srw_ss())[word_gen_gc_partial_move_roots_def,LET_THM] + LENGTH ys = LENGTH xs +Proof + Induct \\ full_simp_tac(srw_ss())[word_gen_gc_partial_move_roots_def,LET_THM] \\ srw_tac[][] \\ rpt (pairarg_tac \\ full_simp_tac(srw_ss())[]) - \\ rpt var_eq_tac \\ full_simp_tac(srw_ss())[] \\ res_tac); + \\ rpt var_eq_tac \\ full_simp_tac(srw_ss())[] \\ res_tac +QED val word_gen_gc_move_roots_bitmaps = Q.prove( `!stack i1 pa1 m stack2 i2 pa2 m2. @@ -2360,8 +2420,8 @@ val word_gen_gc_partial_move_bitmap_unroll = Q.prove( \\ full_simp_tac(srw_ss())[map_bitmap_def] \\ rpt (CASE_TAC \\ full_simp_tac(srw_ss())[])); -Theorem word_gen_gc_move_code_thm - `word_gen_gc_move conf (w,i,pa,ib,pb,old,m,dm) = (w1,i1,pa1,ib1,pb1,m1,T) /\ +Theorem word_gen_gc_move_code_thm: + word_gen_gc_move conf (w,i,pa,ib,pb,old,m,dm) = (w1,i1,pa1,ib1,pb1,m1,T) /\ shift_length conf < dimindex (:'a) /\ word_shift (:'a) < dimindex (:'a) /\ 2 < dimindex (:'a) /\ conf.len_size <> 0 /\ (!w:'a word. w << word_shift (:'a) = w * bytes_in_word) /\ @@ -2393,8 +2453,9 @@ Theorem word_gen_gc_move_code_thm (3,Word pa1); (4,Word i1); (5,w1); - (6,r6)] |>)` - (reverse (Cases_on `w`) \\ full_simp_tac(srw_ss())[word_gen_gc_move_def] THEN1 + (6,r6)] |>) +Proof + reverse (Cases_on `w`) \\ full_simp_tac(srw_ss())[word_gen_gc_move_def] THEN1 (srw_tac[][word_gen_gc_move_code_def,evaluate_def] \\ full_simp_tac(srw_ss())[get_var_def] \\ tac \\ full_simp_tac(srw_ss())[state_component_equality] @@ -2510,10 +2571,11 @@ Theorem word_gen_gc_move_code_thm DECIDE ``n<>0 ==> m-(n-1)-1=m-n:num``] \\ qexists_tac `s.store ' (Temp 0w)` \\ qexists_tac `s.store ' (Temp 1w)` - \\ rw [] \\ fs [] \\ eq_tac \\ rw [] \\ fs []); + \\ rw [] \\ fs [] \\ eq_tac \\ rw [] \\ fs [] +QED -Theorem word_gen_gc_partial_move_code_thm - `word_gen_gc_partial_move conf (w,i,pa,old,m,dm,gs,rs) = (w1,i1,pa1,m1,T) /\ +Theorem word_gen_gc_partial_move_code_thm: + word_gen_gc_partial_move conf (w,i,pa,old,m,dm,gs,rs) = (w1,i1,pa1,m1,T) /\ shift_length conf < dimindex (:'a) /\ word_shift (:'a) < dimindex (:'a) /\ 2 < dimindex (:'a) /\ conf.len_size <> 0 /\ (!w:'a word. w << word_shift (:'a) = w * bytes_in_word) /\ @@ -2539,8 +2601,9 @@ Theorem word_gen_gc_partial_move_code_thm (3,Word pa1); (4,Word i1); (5,w1); - (6,r6)] |>)` - (reverse (Cases_on `w`) + (6,r6)] |>) +Proof + reverse (Cases_on `w`) \\ full_simp_tac(srw_ss())[word_gen_gc_partial_move_def] THEN1 (srw_tac[][word_gen_gc_partial_move_code_def,evaluate_def] \\ full_simp_tac(srw_ss())[get_var_def] \\ tac @@ -2633,10 +2696,11 @@ Theorem word_gen_gc_partial_move_code_thm \\ full_simp_tac(srw_ss())[nine_less] \\ `shift_length conf <> 0` by (EVAL_TAC \\ decide_tac) \\ full_simp_tac(srw_ss())[select_lower_lemma, - DECIDE ``n<>0 ==> m-(n-1)-1=m-n:num``]); + DECIDE ``n<>0 ==> m-(n-1)-1=m-n:num``] +QED -Theorem word_gen_gc_move_bitmap_code_thm - `!w stack (s:('a,'c,'b)stackSem$state) i pa ib pb curr m dm new stack1 +Theorem word_gen_gc_move_bitmap_code_thm: + !w stack (s:('a,'c,'b)stackSem$state) i pa ib pb curr m dm new stack1 a1 i1 pa1 ib1 pb1 m1 old. word_gen_gc_move_bitmap conf (w,stack,i,pa,ib,pb,curr,m,dm) = SOME (new,stack1,i1,pa1,ib1,pb1,m1,T) /\ @@ -2677,8 +2741,9 @@ Theorem word_gen_gc_move_bitmap_code_thm (5,r5); (6,r6); (7,r7); - (8,Word (bytes_in_word * n2w (LENGTH (old ++ new))))] |>)` - (recInduct bit_length_ind \\ rpt strip_tac \\ fs [] + (8,Word (bytes_in_word * n2w (LENGTH (old ++ new))))] |>) +Proof + recInduct bit_length_ind \\ rpt strip_tac \\ fs [] \\ qpat_x_assum `word_gen_gc_move_bitmap _ _ = _` mp_tac \\ once_rewrite_tac [word_gen_gc_move_bitmap_unroll] \\ Cases_on `w = 0w` \\ fs [] THEN1 @@ -2804,10 +2869,11 @@ Theorem word_gen_gc_move_bitmap_code_thm \\ once_rewrite_tac [split_num_forall_to_10] \\ full_simp_tac(srw_ss())[nine_less] \\ fs [] \\ qexists_tac `t0'` \\ qexists_tac `t1'` - \\ rw [] \\ fs [] \\ eq_tac \\ rw [] \\ fs []); + \\ rw [] \\ fs [] \\ eq_tac \\ rw [] \\ fs [] +QED -Theorem word_gen_gc_partial_move_bitmap_code_thm - `!w stack (s:('a,'c,'b)stackSem$state) i pa curr m dm new stack1 a1 i1 pa1 m1 old. +Theorem word_gen_gc_partial_move_bitmap_code_thm: + !w stack (s:('a,'c,'b)stackSem$state) i pa curr m dm new stack1 a1 i1 pa1 m1 old. word_gen_gc_partial_move_bitmap conf (w,stack,i,pa,curr,m,dm,gs,rs) = SOME (new,stack1,i1,pa1,m1,T) /\ shift_length conf < dimindex (:'a) /\ word_shift (:'a) < dimindex (:'a) /\ @@ -2842,8 +2908,9 @@ Theorem word_gen_gc_partial_move_bitmap_code_thm (5,r5); (6,r6); (7,r7); - (8,Word (bytes_in_word * n2w (LENGTH (old ++ new))))] |>)` - (recInduct bit_length_ind \\ rpt strip_tac \\ fs [] + (8,Word (bytes_in_word * n2w (LENGTH (old ++ new))))] |>) +Proof + recInduct bit_length_ind \\ rpt strip_tac \\ fs [] \\ qpat_x_assum `word_gen_gc_partial_move_bitmap _ _ = _` mp_tac \\ once_rewrite_tac [word_gen_gc_partial_move_bitmap_unroll] \\ Cases_on `w = 0w` \\ fs [] THEN1 @@ -2958,30 +3025,35 @@ Theorem word_gen_gc_partial_move_bitmap_code_thm \\ full_simp_tac(srw_ss())[FUPDATE_LIST,GSYM fmap_EQ,FLOOKUP_DEF,EXTENSION, FUN_EQ_THM,FAPPLY_FUPDATE_THM] \\ once_rewrite_tac [split_num_forall_to_10] - \\ full_simp_tac(srw_ss())[nine_less]); + \\ full_simp_tac(srw_ss())[nine_less] +QED -Theorem word_gen_gc_move_bitmaps_LENGTH - `word_gen_gc_move_bitmaps conf (w,stack,bitmaps,i,pa,ib,pb,curr,m,dm) = +Theorem word_gen_gc_move_bitmaps_LENGTH: + word_gen_gc_move_bitmaps conf (w,stack,bitmaps,i,pa,ib,pb,curr,m,dm) = SOME (xs,stack1,i1,pa1,ib1,pb1,m1,T) ==> - LENGTH stack = LENGTH xs + LENGTH stack1` - (fs [word_gen_gc_move_bitmaps_def] + LENGTH stack = LENGTH xs + LENGTH stack1 +Proof + fs [word_gen_gc_move_bitmaps_def] \\ every_case_tac \\ fs [] \\ pairarg_tac \\ fs [] \\ every_case_tac \\ fs [] \\ rw [] \\ imp_res_tac map_bitmap_IMP_LENGTH \\ fs [] - \\ imp_res_tac filter_bitmap_IMP_LENGTH \\ fs []); + \\ imp_res_tac filter_bitmap_IMP_LENGTH \\ fs [] +QED -Theorem word_gen_gc_partial_move_bitmaps_LENGTH - `word_gen_gc_partial_move_bitmaps conf (w,stack,bitmaps,i,pa,curr,m,dm,gs,rs) = +Theorem word_gen_gc_partial_move_bitmaps_LENGTH: + word_gen_gc_partial_move_bitmaps conf (w,stack,bitmaps,i,pa,curr,m,dm,gs,rs) = SOME (xs,stack1,i1,pa1,m1,T) ==> - LENGTH stack = LENGTH xs + LENGTH stack1` - (fs [word_gen_gc_partial_move_bitmaps_def] + LENGTH stack = LENGTH xs + LENGTH stack1 +Proof + fs [word_gen_gc_partial_move_bitmaps_def] \\ every_case_tac \\ fs [] \\ pairarg_tac \\ fs [] \\ every_case_tac \\ fs [] \\ rw [] \\ imp_res_tac map_bitmap_IMP_LENGTH \\ fs [] - \\ imp_res_tac filter_bitmap_IMP_LENGTH \\ fs []); + \\ imp_res_tac filter_bitmap_IMP_LENGTH \\ fs [] +QED -Theorem word_gen_gc_move_bitmaps_code_thm - `!w bitmaps z stack (s:('a,'c,'b)stackSem$state) i pa ib pb curr m dm new +Theorem word_gen_gc_move_bitmaps_code_thm: + !w bitmaps z stack (s:('a,'c,'b)stackSem$state) i pa ib pb curr m dm new stack1 a1 i1 pa1 ib1 pb1 m1 old. word_gen_gc_move_bitmaps conf (Word w,stack,bitmaps,i,pa,ib,pb,curr,m,dm) = SOME (new,stack1,i1,pa1,ib1,pb1,m1,T) /\ @@ -3026,8 +3098,9 @@ Theorem word_gen_gc_move_bitmaps_code_thm (6,r6); (7,r7); (8,Word (bytes_in_word * n2w (LENGTH (old ++ new)))); - (9,r9)] |>)` - (ntac 2 strip_tac \\ completeInduct_on `LENGTH bitmaps - w2n (w - 1w)` + (9,r9)] |>) +Proof + ntac 2 strip_tac \\ completeInduct_on `LENGTH bitmaps - w2n (w - 1w)` \\ rpt strip_tac \\ fs [] \\ rpt var_eq_tac \\ fs [PULL_FORALL] \\ qpat_x_assum `word_gen_gc_move_bitmaps _ _ = _` (fn th => assume_tac th \\ mp_tac th) @@ -3109,10 +3182,11 @@ Theorem word_gen_gc_move_bitmaps_code_thm \\ qexists_tac `t0'` \\ qexists_tac `t1'` \\ rw [] \\ fs [] \\ rw [] \\ fs [] - \\ eq_tac \\ rw[] \\ fs []); + \\ eq_tac \\ rw[] \\ fs [] +QED -Theorem word_gen_gc_partial_move_bitmaps_code_thm - `!w bitmaps z stack (s:('a,'c,'b)stackSem$state) i pa ib pb curr m dm new +Theorem word_gen_gc_partial_move_bitmaps_code_thm: + !w bitmaps z stack (s:('a,'c,'b)stackSem$state) i pa ib pb curr m dm new stack1 a1 i1 pa1 ib1 pb1 m1 old. word_gen_gc_partial_move_bitmaps conf (Word w,stack,bitmaps,i,pa,curr,m,dm,gs,rs) = @@ -3152,8 +3226,9 @@ Theorem word_gen_gc_partial_move_bitmaps_code_thm (6,r6); (7,r7); (8,Word (bytes_in_word * n2w (LENGTH (old ++ new)))); - (9,r9)] |>)` - (ntac 2 strip_tac \\ completeInduct_on `LENGTH bitmaps - w2n (w - 1w)` + (9,r9)] |>) +Proof + ntac 2 strip_tac \\ completeInduct_on `LENGTH bitmaps - w2n (w - 1w)` \\ rpt strip_tac \\ fs [] \\ rpt var_eq_tac \\ fs [PULL_FORALL] \\ qpat_x_assum `word_gen_gc_partial_move_bitmaps _ _ = _` (fn th => assume_tac th \\ mp_tac th) @@ -3228,10 +3303,11 @@ Theorem word_gen_gc_partial_move_bitmaps_code_thm \\ full_simp_tac(srw_ss())[FUPDATE_LIST,GSYM fmap_EQ,FLOOKUP_DEF,EXTENSION, FUN_EQ_THM,FAPPLY_FUPDATE_THM] \\ once_rewrite_tac [split_num_forall_to_10] - \\ full_simp_tac(srw_ss())[nine_less] \\ fs []); + \\ full_simp_tac(srw_ss())[nine_less] \\ fs [] +QED -Theorem word_gen_gc_move_roots_bitmaps_code_thm - `!bitmaps (s:('a,'c,'b)stackSem$state) i pa ib pb curr m dm new +Theorem word_gen_gc_move_roots_bitmaps_code_thm: + !bitmaps (s:('a,'c,'b)stackSem$state) i pa ib pb curr m dm new stack1 a1 i1 pa1 ib1 pb1 m1 old. word_gen_gc_move_roots_bitmaps conf (stack,bitmaps,i,pa,ib,pb,curr,m,dm) = (stack1,i1,pa1,ib1,pb1,m1,T) /\ @@ -3277,8 +3353,9 @@ Theorem word_gen_gc_move_roots_bitmaps_code_thm (6,r6); (7,r7); (8,r8); - (9,Word 0w)] |>)` - (completeInduct_on `LENGTH stack` + (9,Word 0w)] |>) +Proof + completeInduct_on `LENGTH stack` \\ rpt strip_tac \\ fs [PULL_FORALL] \\ rpt var_eq_tac \\ fs [] \\ qpat_x_assum `word_gen_gc_move_roots_bitmaps _ _ = _` @@ -3380,10 +3457,11 @@ Theorem word_gen_gc_move_roots_bitmaps_code_thm \\ once_rewrite_tac [split_num_forall_to_10] \\ full_simp_tac(srw_ss())[nine_less] \\ fs [] \\ qexists_tac `t0'` \\ qexists_tac `t1'` - \\ rw [] \\ fs [] \\ eq_tac \\ rw [] \\ fs []); + \\ rw [] \\ fs [] \\ eq_tac \\ rw [] \\ fs [] +QED -Theorem word_gen_gc_partial_move_roots_bitmaps_code_thm - `!bitmaps (s:('a,'c,'b)stackSem$state) i pa curr m dm new +Theorem word_gen_gc_partial_move_roots_bitmaps_code_thm: + !bitmaps (s:('a,'c,'b)stackSem$state) i pa curr m dm new stack1 a1 i1 pa1 m1 old. word_gen_gc_partial_move_roots_bitmaps conf (stack,bitmaps,i,pa,curr,m,dm,gs,rs) = (stack1,i1,pa1,m1,T) /\ @@ -3423,8 +3501,9 @@ Theorem word_gen_gc_partial_move_roots_bitmaps_code_thm (6,r6); (7,r7); (8,r8); - (9,Word 0w)] |>)` - (completeInduct_on `LENGTH stack` + (9,Word 0w)] |>) +Proof + completeInduct_on `LENGTH stack` \\ rpt strip_tac \\ fs [PULL_FORALL] \\ rpt var_eq_tac \\ fs [] \\ qpat_x_assum `word_gen_gc_partial_move_roots_bitmaps _ _ = _` @@ -3517,10 +3596,11 @@ Theorem word_gen_gc_partial_move_roots_bitmaps_code_thm \\ full_simp_tac(srw_ss())[FUPDATE_LIST,GSYM fmap_EQ,FLOOKUP_DEF,EXTENSION, FUN_EQ_THM,FAPPLY_FUPDATE_THM] \\ once_rewrite_tac [split_num_forall_to_10] - \\ full_simp_tac(srw_ss())[nine_less] \\ fs []); + \\ full_simp_tac(srw_ss())[nine_less] \\ fs [] +QED -Theorem word_gen_gc_move_list_code_thm - `!l a (s:('a,'c,'b)stackSem$state) pa1 pa old m1 m i1 i dm conf a1 ib ib1 pb pb1. +Theorem word_gen_gc_move_list_code_thm: + !l a (s:('a,'c,'b)stackSem$state) pa1 pa old m1 m i1 i dm conf a1 ib ib1 pb pb1. word_gen_gc_move_list conf (a:'a word,l,i,pa,ib,pb,old,m,dm) = (a1,i1,pa1,ib1,pb1,m1,T) /\ shift_length conf < dimindex (:'a) /\ word_shift (:'a) < dimindex (:'a) /\ @@ -3556,8 +3636,9 @@ Theorem word_gen_gc_move_list_code_thm (5,r5); (6,r6); (7,Word 0w); - (8,Word a1)] |>)` - (Cases \\ Induct_on `n` \\ simp [] THEN1 + (8,Word a1)] |>) +Proof + Cases \\ Induct_on `n` \\ simp [] THEN1 (fs [Once word_gen_gc_move_list_def] \\ rw [] \\ qexists_tac `0` \\ fs [word_gen_gc_move_list_code_def,get_var_def] \\ tac @@ -3619,10 +3700,11 @@ Theorem word_gen_gc_move_list_code_thm \\ once_rewrite_tac [split_num_forall_to_10] \\ full_simp_tac(srw_ss())[nine_less] \\ qexists_tac `t0'` \\ qexists_tac `t1'` - \\ rw [] \\ eq_tac \\ rw [] \\ fs []); + \\ rw [] \\ eq_tac \\ rw [] \\ fs [] +QED -Theorem word_gen_gc_partial_move_list_code_thm - `!l a (s:('a,'c,'b)stackSem$state) pa1 pa old m1 m i1 i dm conf a1 gs rs. +Theorem word_gen_gc_partial_move_list_code_thm: + !l a (s:('a,'c,'b)stackSem$state) pa1 pa old m1 m i1 i dm conf a1 gs rs. word_gen_gc_partial_move_list conf (a:'a word,l,i,pa,old,m,dm,gs,rs) = (a1,i1,pa1,m1,T) /\ shift_length conf < dimindex (:'a) /\ word_shift (:'a) < dimindex (:'a) /\ @@ -3652,8 +3734,9 @@ Theorem word_gen_gc_partial_move_list_code_thm (5,r5); (6,r6); (7,Word 0w); - (8,Word a1)] |>)` - (Cases \\ Induct_on `n` \\ simp [] THEN1 + (8,Word a1)] |>) +Proof + Cases \\ Induct_on `n` \\ simp [] THEN1 (fs [Once word_gen_gc_partial_move_list_def] \\ rw [] \\ qexists_tac `0` \\ fs [word_gen_gc_partial_move_list_code_def,get_var_def] \\ tac @@ -3707,7 +3790,8 @@ Theorem word_gen_gc_partial_move_list_code_thm \\ full_simp_tac(srw_ss())[FUPDATE_LIST,GSYM fmap_EQ,FLOOKUP_DEF,EXTENSION, FUN_EQ_THM,FAPPLY_FUPDATE_THM] \\ once_rewrite_tac [split_num_forall_to_10] - \\ full_simp_tac(srw_ss())[nine_less]); + \\ full_simp_tac(srw_ss())[nine_less] +QED val word_gen_gc_partial_move_ref_list_code_thm = Q.prove( `!k r2a1 r1a1 r2a2 i1 pa1 ib1 pb1 old1 m1 dm1 c1 i2 pa2 ib2 pb2 m2 (s:('a,'c,'b)stackSem$state). @@ -4342,12 +4426,14 @@ val word_sub_0_eq = prove( once_rewrite_tac [GSYM wordsTheory.WORD_EQ_NEG] \\ once_rewrite_tac [GSYM wordsTheory.WORD_EQ_SUB_ZERO] \\ fs []); -Theorem good_dimindex_byte_aligned_eq - `good_dimindex (:'a) ==> +Theorem good_dimindex_byte_aligned_eq: + good_dimindex (:'a) ==> (byte_aligned (w:'a word) <=> - ((w && (if dimindex (:'a) = 32 then 3w else 7w)) = 0w))` - (rw [labPropsTheory.good_dimindex_def] - \\ fs [alignmentTheory.byte_aligned_def,alignmentTheory.aligned_bitwise_and]); + ((w && (if dimindex (:'a) = 32 then 3w else 7w)) = 0w)) +Proof + rw [labPropsTheory.good_dimindex_def] + \\ fs [alignmentTheory.byte_aligned_def,alignmentTheory.aligned_bitwise_and] +QED val evaluate_SetNewTrigger = prove( ``evaluate (SetNewTrigger endh_reg ib_reg gen_sizes,s5) = (res,new_s) ==> @@ -4386,8 +4472,8 @@ val evaluate_SetNewTrigger = prove( \\ fs [GSYM PULL_EXISTS] \\ fs [FAPPLY_FUPDATE_THM] \\ metis_tac []); -Theorem alloc_correct_lemma_Generational - `alloc w (s:('a,'c,'b)stackSem$state) = (r,t) /\ r <> SOME Error /\ +Theorem alloc_correct_lemma_Generational: + alloc w (s:('a,'c,'b)stackSem$state) = (r,t) /\ r <> SOME Error /\ s.gc_fun = word_gc_fun conf /\ conf.gc_kind = ^kind /\ LENGTH s.bitmaps < dimword (:'a) - 1 /\ LENGTH s.stack * (dimindex (:'a) DIV 8) < dimword (:'a) /\ @@ -4407,8 +4493,9 @@ Theorem alloc_correct_lemma_Generational regs := l2; gc_fun := anything |>) /\ (r <> NONE ==> r = SOME (Halt (Word 1w))) /\ t.regs SUBMAP l2 /\ - (r = NONE ==> FLOOKUP l2 0 = SOME ret)` - (qspec_tac (`gen_sizes`,`gen_sizes`) + (r = NONE ==> FLOOKUP l2 0 = SOME ret) +Proof + qspec_tac (`gen_sizes`,`gen_sizes`) \\ Cases_on `?gen_sizes. conf.gc_kind = Generational gen_sizes` \\ fs [] \\ Cases_on `s.gc_fun = word_gc_fun conf` \\ fs [] \\ fs [alloc_def] \\ `(set_store AllocSize (Word w) s).gc_fun = word_gc_fun conf` by @@ -4750,7 +4837,8 @@ Theorem alloc_correct_lemma_Generational \\ `TAKE t.stack_space (ys1 ++ ys2) = ys1` by metis_tac [TAKE_LENGTH_APPEND] \\ fs [fmap_EXT,EXTENSION] \\ rw [] \\ fs [FAPPLY_FUPDATE_THM] - \\ fs [SUBMAP_DEF] \\ rw [] \\ fs [] \\ eq_tac \\ strip_tac \\ fs []); + \\ fs [SUBMAP_DEF] \\ rw [] \\ fs [] \\ eq_tac \\ strip_tac \\ fs [] +QED (* gc_kind = None *) @@ -4784,8 +4872,8 @@ val enc_dec_stack = prove( \\ pop_assum drule \\ fs [] \\ rw [] \\ res_tac \\ rveq \\ fs []); -Theorem alloc_correct_lemma_None - `alloc w (s:('a,'c,'b)stackSem$state) = (r,t) /\ r <> SOME Error /\ +Theorem alloc_correct_lemma_None: + alloc w (s:('a,'c,'b)stackSem$state) = (r,t) /\ r <> SOME Error /\ s.gc_fun = word_gc_fun conf /\ conf.gc_kind = None /\ LENGTH s.bitmaps < dimword (:'a) - 1 /\ LENGTH s.stack * (dimindex (:'a) DIV 8) < dimword (:'a) /\ @@ -4805,8 +4893,9 @@ Theorem alloc_correct_lemma_None regs := l2; gc_fun := anything |>) /\ (r <> NONE ==> r = SOME (Halt (Word 1w))) /\ t.regs SUBMAP l2 /\ - (r = NONE ==> FLOOKUP l2 0 = SOME ret)` - (Cases_on `conf.gc_kind = None` \\ fs [] + (r = NONE ==> FLOOKUP l2 0 = SOME ret) +Proof + Cases_on `conf.gc_kind = None` \\ fs [] \\ fs [word_gc_fun_def,word_gc_code_def] \\ rw [] \\ qpat_x_assum `alloc w s = (r,t)` mp_tac \\ fs [alloc_def,gc_def,set_store_def] @@ -4838,12 +4927,13 @@ Theorem alloc_correct_lemma_None \\ strip_tac \\ fs [] \\ pop_assum (assume_tac o GSYM) \\ fs [] \\ fs [TAKE_LENGTH_APPEND,DROP_LENGTH_APPEND] - \\ imp_res_tac enc_dec_stack \\ fs []); + \\ imp_res_tac enc_dec_stack \\ fs [] +QED (* --- *) -Theorem alloc_correct_lemma - `alloc w (s:('a,'c,'b)stackSem$state) = (r,t) /\ r <> SOME Error /\ +Theorem alloc_correct_lemma: + alloc w (s:('a,'c,'b)stackSem$state) = (r,t) /\ r <> SOME Error /\ s.gc_fun = word_gc_fun conf /\ LENGTH s.bitmaps < dimword (:'a) - 1 /\ LENGTH s.stack * (dimindex (:'a) DIV 8) < dimword (:'a) /\ @@ -4863,11 +4953,13 @@ Theorem alloc_correct_lemma regs := l2; gc_fun := anything |>) /\ (r <> NONE ==> r = SOME (Halt (Word 1w))) /\ t.regs SUBMAP l2 /\ - (r = NONE ==> FLOOKUP l2 0 = SOME ret)` - (Cases_on `conf.gc_kind` + (r = NONE ==> FLOOKUP l2 0 = SOME ret) +Proof + Cases_on `conf.gc_kind` THEN1 metis_tac [alloc_correct_lemma_None] THEN1 metis_tac [alloc_correct_lemma_Simple] - THEN1 metis_tac [alloc_correct_lemma_Generational]); + THEN1 metis_tac [alloc_correct_lemma_Generational] +QED val alloc_correct = Q.prove( `alloc w (s:('a,'c,'b)stackSem$state) = (r,t) /\ r <> SOME Error /\ @@ -4904,41 +4996,48 @@ val find_code_IMP_lookup = Q.prove( Cases_on `dest` \\ full_simp_tac(srw_ss())[find_code_def,FUN_EQ_THM] \\ every_case_tac \\ full_simp_tac(srw_ss())[] \\ metis_tac []); -Theorem alloc_length_stack - `alloc c s = (r,t) /\ s.gc_fun = word_gc_fun conf /\ +Theorem alloc_length_stack: + alloc c s = (r,t) /\ s.gc_fun = word_gc_fun conf /\ (!w. r <> SOME (Halt w)) ==> - LENGTH t.stack = LENGTH s.stack` - (fs [alloc_def,gc_def,set_store_def] \\ rw [] \\ fs [] + LENGTH t.stack = LENGTH s.stack +Proof + fs [alloc_def,gc_def,set_store_def] \\ rw [] \\ fs [] \\ every_case_tac \\ fs [] \\ rw [] \\ drule word_gc_fun_LENGTH \\ rw [] \\ fs [NOT_LESS] \\ drule LESS_EQ_LENGTH \\ strip_tac \\ fs [] \\ pop_assum (fn th => fs [GSYM th]) \\ fs [DROP_LENGTH_APPEND] - \\ metis_tac [dec_stack_length]); + \\ metis_tac [dec_stack_length] +QED -Theorem find_code_regs_SUBMAP - `r1 ⊑ r2 ∧ +Theorem find_code_regs_SUBMAP: + r1 ⊑ r2 ∧ find_code dest r1 c = SOME x ⇒ - find_code dest r2 c = SOME x` - (Cases_on`dest` \\ EVAL_TAC \\ rw[] + find_code dest r2 c = SOME x +Proof + Cases_on`dest` \\ EVAL_TAC \\ rw[] \\ imp_res_tac FLOOKUP_SUBMAP \\ every_case_tac \\ fs[] \\ res_tac \\ fs[] - \\ rw[] ); + \\ rw[] +QED -Theorem get_labels_comp - `!n p e. get_labels e SUBSET get_labels (FST (comp n p e))` - (recInduct comp_ind \\ rw [] +Theorem get_labels_comp: + !n p e. get_labels e SUBSET get_labels (FST (comp n p e)) +Proof + recInduct comp_ind \\ rw [] \\ Cases_on `p` \\ fs [] \\ once_rewrite_tac [comp_def] \\ fs [] \\ every_case_tac \\ fs [] \\ TRY pairarg_tac \\ fs [get_labels_def,SUBSET_DEF] \\ TRY pairarg_tac \\ fs [get_labels_def,SUBSET_DEF] - \\ rw [] \\ fs []); + \\ rw [] \\ fs [] +QED -Theorem loc_check_compile - `loc_check s.code (l1,l2) /\ +Theorem loc_check_compile: + loc_check s.code (l1,l2) /\ (!k prog. lookup k s.code = SOME prog ==> k ≠ gc_stub_location) ==> - loc_check (fromAList (compile c (toAList s.code))) (l1,l2)` - (fs [loc_check_def,domain_lookup] \\ rw [] \\ fs [] + loc_check (fromAList (compile c (toAList s.code))) (l1,l2) +Proof + fs [loc_check_def,domain_lookup] \\ rw [] \\ fs [] \\ fs [compile_def,lookup_fromAList,ALOOKUP_def,stubs_def] THEN1 (CASE_TAC \\ fs [ALOOKUP_MAP] @@ -4954,7 +5053,8 @@ Theorem loc_check_compile \\ pop_assum mp_tac \\ qspec_tac (`toAList s.code`,`xs`) \\ Induct \\ fs [FORALL_PROD,ALOOKUP_def,prog_comp_def] - \\ rw [] \\ metis_tac [get_labels_comp,SUBSET_DEF]); + \\ rw [] \\ metis_tac [get_labels_comp,SUBSET_DEF] +QED val SUBMAP_DOMSUB_both = Q.prove(` A SUBMAP B ⇒ @@ -5022,8 +5122,8 @@ val inst_correct = Q.prove(` fs[set_var_def,state_component_equality]>> metis_tac[SUBMAP_FUPDATE_both])); -Theorem comp_correct - `!p (s:('a,'c,'b)stackSem$state) r t m n c regs. +Theorem comp_correct: + !p (s:('a,'c,'b)stackSem$state) r t m n c regs. evaluate (p,s) = (r,t) /\ r <> SOME Error /\ alloc_arg p /\ (!k prog. lookup k s.code = SOME prog ==> k ≠ gc_stub_location /\ alloc_arg prog) /\ (∀n k p. MEM (k,p) (FST (SND (s.compile_oracle n))) ⇒ k ≠ gc_stub_location ∧ alloc_arg p) /\ @@ -5050,8 +5150,9 @@ Theorem comp_correct code := fromAList (stack_alloc$compile c (toAList t.code)) |>) /\ t.regs SUBMAP regs1 ∧ LENGTH t.bitmaps + LENGTH t.data_buffer.buffer + t.data_buffer.space_left < dimword(:'a) - 1 /\ - ((∀w. r ≠ SOME (Halt w)) ⇒ LENGTH t.stack * (dimindex (:'a) DIV 8) < dimword (:'a))` - (recInduct evaluate_ind + ((∀w. r ≠ SOME (Halt w)) ⇒ LENGTH t.stack * (dimindex (:'a) DIV 8) < dimword (:'a)) +Proof + recInduct evaluate_ind \\ conj_tac THEN1 (* Skip *) (full_simp_tac(srw_ss())[Once comp_def,evaluate_def] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[state_component_equality]) @@ -5543,7 +5644,8 @@ Theorem comp_correct \\ rw[state_component_equality] \\ match_mp_tac SUBMAP_mono_FUPDATE \\ rw[GSYM SUBMAP_DOMSUB_gen] - \\ metis_tac[SUBMAP_TRANS,SUBMAP_DOMSUB]); + \\ metis_tac[SUBMAP_TRANS,SUBMAP_DOMSUB] +QED val comp_correct_thm = comp_correct |> SPEC_ALL @@ -5556,8 +5658,8 @@ val with_same_regs_lemma = Q.prove( simp[state_component_equality]) val _ = augment_srw_ss[rewrites[with_same_regs_lemma]]; -Theorem compile_semantics - `(!k prog. lookup k s.code = SOME prog ==> k <> gc_stub_location /\ alloc_arg prog) /\ +Theorem compile_semantics: + (!k prog. lookup k s.code = SOME prog ==> k <> gc_stub_location /\ alloc_arg prog) /\ (∀n k p. MEM (k,p) (FST (SND (s.compile_oracle n))) ⇒ k ≠ gc_stub_location ∧ alloc_arg p) /\ (s:('a,'c,'b)stackSem$state).gc_fun = (word_gc_fun c:α gc_fun_type) /\ LENGTH s.bitmaps + LENGTH s.data_buffer.buffer + s.data_buffer.space_left < dimword (:α) − 1 ∧ @@ -5574,8 +5676,9 @@ Theorem compile_semantics use_store := T; use_stack := T; use_alloc := F |>) = - semantics start s` - (simp[GSYM AND_IMP_INTRO] >> ntac 6 strip_tac >> + semantics start s +Proof + simp[GSYM AND_IMP_INTRO] >> ntac 6 strip_tac >> simp[semantics_def] >> IF_CASES_TAC >> full_simp_tac(srw_ss())[] >> DEEP_INTRO_TAC some_intro >> full_simp_tac(srw_ss())[] >> @@ -5708,7 +5811,8 @@ Theorem compile_semantics simp[Abbr`ss`] >> ntac 3 strip_tac >> full_simp_tac(srw_ss())[] >> full_simp_tac(srw_ss())[IS_PREFIX_APPEND] >> - simp[EL_APPEND1]); + simp[EL_APPEND1] +QED (* TODO: does this have to initialize the data_buffer to empty? *) val make_init_def = Define ` @@ -5717,12 +5821,14 @@ val make_init_def = Define ` ; compile := λc. s.compile c o (MAP prog_comp) ; compile_oracle := oracle |>`; -Theorem prog_comp_lambda - `prog_comp = λ(n,p). ^(rhs (concl (SPEC_ALL prog_comp_def)))` - (srw_tac[][FUN_EQ_THM,prog_comp_def,LAMBDA_PROD,FORALL_PROD]); +Theorem prog_comp_lambda: + prog_comp = λ(n,p). ^(rhs (concl (SPEC_ALL prog_comp_def))) +Proof + srw_tac[][FUN_EQ_THM,prog_comp_def,LAMBDA_PROD,FORALL_PROD] +QED -Theorem make_init_semantics - `(!k prog. ALOOKUP code k = SOME prog ==> k <> gc_stub_location /\ alloc_arg prog) /\ +Theorem make_init_semantics: + (!k prog. ALOOKUP code k = SOME prog ==> k <> gc_stub_location /\ alloc_arg prog) /\ (∀n k p. MEM (k,p) (FST (SND (oracle n))) ⇒ k ≠ gc_stub_location ∧ alloc_arg p) /\ s.use_stack ∧ s.use_store ∧ ~s.use_alloc /\ s.code = fromAList (compile c code) /\ s.compile_oracle = (I ## MAP prog_comp ## I) o oracle /\ @@ -5731,8 +5837,9 @@ Theorem make_init_semantics ALL_DISTINCT (MAP FST code) /\ semantics start (make_init c (fromAList code) oracle s) <> Fail ==> semantics start (s:('a,'c,'ffi) stackSem$state) = - semantics start (make_init c (fromAList code) oracle s)` - (srw_tac[][] + semantics start (make_init c (fromAList code) oracle s) +Proof + srw_tac[][] \\ drule (CONV_RULE(LAND_CONV(move_conj_left(can dest_neg)))compile_semantics |> GEN_ALL) \\ disch_then (qspecl_then [`s.compile`,`c`,`s.gc_fun`] mp_tac) @@ -5745,11 +5852,12 @@ Theorem make_init_semantics \\ srw_tac[][] \\ srw_tac[][ALOOKUP_APPEND] \\ BasicProvers.CASE_TAC \\ simp[prog_comp_lambda,ALOOKUP_MAP_2] - \\ simp[ALOOKUP_toAList,lookup_fromAList]); + \\ simp[ALOOKUP_toAList,lookup_fromAList] +QED -Theorem next_lab_EQ_MAX - `!q (n:num) aux. next_lab q aux = MAX aux (next_lab q 0)` - (ho_match_mp_tac next_lab_ind>>Cases_on`q`>>rw[]>> +Theorem next_lab_EQ_MAX = Q.prove(` + !q (n:num) aux. next_lab q aux = MAX aux (next_lab q 0)`, + ho_match_mp_tac next_lab_ind>>Cases_on`q`>>rw[]>> once_rewrite_tac [next_lab_def]>> simp_tac (srw_ss()) [] >> every_case_tac >> @@ -5763,8 +5871,8 @@ val MAX_SIMP = prove( ``MAX n (MAX n m) = MAX n m``, fs [MAX_DEF]); -Theorem next_lab_thm - `!p. +Theorem next_lab_thm: + !p. next_lab (p:'a stackLang$prog) 1 = case p of | Seq p1 p2 => MAX (next_lab p1 1) (next_lab p2 1) @@ -5775,8 +5883,9 @@ Theorem next_lab_thm | Call (SOME (p,_,_,l2)) _ NONE => MAX (next_lab p 1) (l2 + 1) | Call (SOME (p,_,_,l2)) _ (SOME (p',_,l3)) => MAX (MAX (next_lab p 1) (next_lab p' 1)) (MAX l2 l3 + 1) - | _ => 1` - (Induct \\ simp [Once next_lab_def] \\ fs [] + | _ => 1 +Proof + Induct \\ simp [Once next_lab_def] \\ fs [] \\ once_rewrite_tac [next_lab_EQ_MAX] \\ once_rewrite_tac [next_lab_EQ_MAX] \\ once_rewrite_tac [next_lab_EQ_MAX] @@ -5786,19 +5895,22 @@ Theorem next_lab_thm \\ once_rewrite_tac [next_lab_EQ_MAX] \\ once_rewrite_tac [next_lab_EQ_MAX] \\ fs [AC MAX_ASSOC MAX_COMM,MAX_SIMP] - \\ fs [MAX_DEF]); + \\ fs [MAX_DEF] +QED -Theorem extract_labels_next_lab ` - ∀p (aux:num) e. +Theorem extract_labels_next_lab: + ∀p (aux:num) e. MEM e (extract_labels p) ⇒ - SND e < next_lab p 1` - (ho_match_mp_tac next_lab_ind>>Cases_on`p`>>rw[]>> + SND e < next_lab p 1 +Proof + ho_match_mp_tac next_lab_ind>>Cases_on`p`>>rw[]>> once_rewrite_tac [next_lab_thm]>>fs[extract_labels_def]>> fs[extract_labels_def]>> - BasicProvers.EVERY_CASE_TAC>>fs []>>fs[MAX_DEF]); + BasicProvers.EVERY_CASE_TAC>>fs []>>fs[MAX_DEF] +QED -Theorem stack_alloc_lab_pres ` - ∀n nl p aux. +Theorem stack_alloc_lab_pres: + ∀n nl p aux. EVERY (λ(l1,l2). l1 = n ∧ l2 ≠ 0) (extract_labels p) ∧ ALL_DISTINCT (extract_labels p) ∧ next_lab p 1 ≤ nl ⇒ @@ -5806,8 +5918,9 @@ Theorem stack_alloc_lab_pres ` EVERY (λ(l1,l2). l1 = n ∧ l2 ≠ 0) (extract_labels cp) ∧ ALL_DISTINCT (extract_labels cp) ∧ (∀lab. MEM lab (extract_labels cp) ⇒ MEM lab (extract_labels p) ∨ (nl ≤ SND lab ∧ SND lab < nl')) ∧ - nl ≤ nl'` - (HO_MATCH_MP_TAC comp_ind>>Cases_on`p`>>rw[]>> + nl ≤ nl' +Proof + HO_MATCH_MP_TAC comp_ind>>Cases_on`p`>>rw[]>> once_rewrite_tac [comp_def]>>fs[extract_labels_def] >- (BasicProvers.EVERY_CASE_TAC>>fs[]>>rveq>>fs[extract_labels_def]>> @@ -5843,14 +5956,16 @@ Theorem stack_alloc_lab_pres ` imp_res_tac extract_labels_next_lab>> fs[]) >> - res_tac>>fs[])); + res_tac>>fs[]) +QED -Theorem stack_alloc_comp_stack_asm_name ` - ∀n m p. +Theorem stack_alloc_comp_stack_asm_name: + ∀n m p. stack_asm_name c p ∧ stack_asm_remove (c:'a asm_config) p ⇒ let (p',m') = comp n m p in - stack_asm_name c p' ∧ stack_asm_remove (c:'a asm_config) p'` - (ho_match_mp_tac comp_ind>>Cases_on`p`>>rw[]>> + stack_asm_name c p' ∧ stack_asm_remove (c:'a asm_config) p' +Proof + ho_match_mp_tac comp_ind>>Cases_on`p`>>rw[]>> simp[Once comp_def] >- (Cases_on`o'`>- @@ -5863,10 +5978,11 @@ Theorem stack_alloc_comp_stack_asm_name ` fs[stack_asm_name_def,stack_asm_remove_def]) >> rpt(pairarg_tac>>fs[])>>rw[]>> - fs[stack_asm_name_def,stack_asm_remove_def]); + fs[stack_asm_name_def,stack_asm_remove_def] +QED -Theorem stack_alloc_stack_asm_convs ` - EVERY (λ(n,p). stack_asm_name c p) prog ∧ +Theorem stack_alloc_stack_asm_convs: + EVERY (λ(n,p). stack_asm_name c p) prog ∧ EVERY (λ(n,p). (stack_asm_remove (c:'a asm_config) p)) prog ∧ (* conf_ok is too strong, but we already have it anyway *) conf_ok (:'a) conf ∧ @@ -5878,8 +5994,9 @@ Theorem stack_alloc_stack_asm_convs ` c.valid_imm (INL Sub) 1w ⇒ EVERY (λ(n,p). stack_asm_name c p) (compile conf prog) ∧ - EVERY (λ(n,p). stack_asm_remove c p) (compile conf prog)` - (fs[compile_def]>>rw[]>> + EVERY (λ(n,p). stack_asm_remove c p) (compile conf prog) +Proof + fs[compile_def]>>rw[]>> TRY (EVAL_TAC>>every_case_tac >> EVAL_TAC>>every_case_tac >> fs [] >> EVAL_TAC >> @@ -5892,15 +6009,17 @@ Theorem stack_alloc_stack_asm_convs ` rw[]>>res_tac>> drule stack_alloc_comp_stack_asm_name>>fs[]>> disch_then(qspecl_then[`p_1`,`next_lab p_2 1`] assume_tac)>> - pairarg_tac>>fs[]); + pairarg_tac>>fs[] +QED -Theorem stack_alloc_reg_bound - `10 ≤ sp ∧ +Theorem stack_alloc_reg_bound: + 10 ≤ sp ∧ EVERY (\p. reg_bound p sp) (MAP SND prog1) ==> EVERY (\p. reg_bound p sp) - (MAP SND (compile dc prog1))` - (fs[stack_allocTheory.compile_def]>> + (MAP SND (compile dc prog1)) +Proof + fs[stack_allocTheory.compile_def]>> strip_tac>>CONJ_TAC >- (EVAL_TAC>>TOP_CASE_TAC>>EVAL_TAC>>fs[]>> @@ -5924,12 +6043,14 @@ Theorem stack_alloc_reg_bound TRY(ONCE_REWRITE_TAC [stack_allocTheory.comp_def]>> Cases_on`o'`>>TRY(PairCases_on`x`)>>fs[reg_bound_def]>> BasicProvers.EVERY_CASE_TAC)>> - rpt(pairarg_tac>>fs[reg_bound_def])); - -Theorem stack_alloc_call_args - `EVERY (λp. call_args p 1 2 3 4 0) (MAP SND prog1) ==> - EVERY (λp. call_args p 1 2 3 4 0) (MAP SND (compile dc prog1))` - (fs[stack_allocTheory.compile_def]>> + rpt(pairarg_tac>>fs[reg_bound_def]) +QED + +Theorem stack_alloc_call_args: + EVERY (λp. call_args p 1 2 3 4 0) (MAP SND prog1) ==> + EVERY (λp. call_args p 1 2 3 4 0) (MAP SND (compile dc prog1)) +Proof + fs[stack_allocTheory.compile_def]>> strip_tac>>CONJ_TAC >- (EVAL_TAC>>TOP_CASE_TAC>>EVAL_TAC>>fs[]>> @@ -5951,11 +6072,13 @@ Theorem stack_alloc_call_args TRY(ONCE_REWRITE_TAC [stack_allocTheory.comp_def]>> Cases_on`o'`>>TRY(PairCases_on`x`)>>fs[call_args_def]>> BasicProvers.EVERY_CASE_TAC)>> - rpt(pairarg_tac>>fs[call_args_def])); + rpt(pairarg_tac>>fs[call_args_def]) +QED -Theorem compile_has_fp_ops[simp] - `compile (dconf with has_fp_ops := b) code = compile dconf code` - (fs [compile_def,stubs_def,word_gc_code_def] +Theorem compile_has_fp_ops[simp]: + compile (dconf with has_fp_ops := b) code = compile dconf code +Proof + fs [compile_def,stubs_def,word_gc_code_def] \\ every_case_tac \\ fs [] \\ fs [data_to_wordTheory.small_shift_length_def, word_gc_move_code_def, @@ -5978,6 +6101,7 @@ Theorem compile_has_fp_ops[simp] word_gen_gc_partial_move_bitmaps_code_def, word_gen_gc_partial_move_bitmap_code_def, word_gen_gc_partial_move_data_code_def, - word_gen_gc_partial_move_ref_list_code_def]); + word_gen_gc_partial_move_ref_list_code_def] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/stack_namesProofScript.sml b/compiler/backend/proofs/stack_namesProofScript.sml index a8dde505d2..0581f88c2d 100644 --- a/compiler/backend/proofs/stack_namesProofScript.sml +++ b/compiler/backend/proofs/stack_namesProofScript.sml @@ -21,73 +21,92 @@ val rename_state_def = Define ` ; ffi_save_regs := IMAGE (find_name f) s.ffi_save_regs |>` -Theorem rename_state_with_clock - `rename_state c f (s with clock := k) = rename_state c f s with clock := k` - (EVAL_TAC); - -Theorem rename_state_const[simp] - `(rename_state c f s).memory = s.memory ∧ +Theorem rename_state_with_clock: + rename_state c f (s with clock := k) = rename_state c f s with clock := k +Proof + EVAL_TAC +QED + +Theorem rename_state_const[simp]: + (rename_state c f s).memory = s.memory ∧ (rename_state c f s).be = s.be ∧ (rename_state c f s).mdomain = s.mdomain ∧ (rename_state c f s).code_buffer = s.code_buffer ∧ (rename_state c f s).clock = s.clock ∧ (rename_state c f s).compile = c ∧ (rename_state c f s).use_stack = s.use_stack ∧ - (rename_state c f s).fp_regs = s.fp_regs` - (EVAL_TAC); - -Theorem rename_state_with_memory - `rename_state c f (s with memory := k) = rename_state c f s with memory := k` - (EVAL_TAC); - -Theorem dec_clock_rename_state - `dec_clock (rename_state c x y) = rename_state c x (dec_clock y)` - (EVAL_TAC >> simp[state_component_equality]); - -Theorem mem_load_rename_state[simp] - `mem_load x (rename_state c f s) = mem_load x s` - (EVAL_TAC); - -Theorem mem_store_rename_state[simp] - `mem_store x y (rename_state c f s) = OPTION_MAP (rename_state c f) (mem_store x y s)` - (EVAL_TAC >> rw[] >> EVAL_TAC >> rw[]); - -Theorem get_var_find_name[simp] - `BIJ (find_name f) UNIV UNIV ==> - get_var (find_name f v) (rename_state c f s) = get_var v s` - (fs [get_var_def,rename_state_def,FLOOKUP_DEF,MAP_KEYS_def] + (rename_state c f s).fp_regs = s.fp_regs +Proof + EVAL_TAC +QED + +Theorem rename_state_with_memory: + rename_state c f (s with memory := k) = rename_state c f s with memory := k +Proof + EVAL_TAC +QED + +Theorem dec_clock_rename_state: + dec_clock (rename_state c x y) = rename_state c x (dec_clock y) +Proof + EVAL_TAC >> simp[state_component_equality] +QED + +Theorem mem_load_rename_state[simp]: + mem_load x (rename_state c f s) = mem_load x s +Proof + EVAL_TAC +QED + +Theorem mem_store_rename_state[simp]: + mem_store x y (rename_state c f s) = OPTION_MAP (rename_state c f) (mem_store x y s) +Proof + EVAL_TAC >> rw[] >> EVAL_TAC >> rw[] +QED + +Theorem get_var_find_name[simp]: + BIJ (find_name f) UNIV UNIV ==> + get_var (find_name f v) (rename_state c f s) = get_var v s +Proof + fs [get_var_def,rename_state_def,FLOOKUP_DEF,MAP_KEYS_def] \\ rpt strip_tac \\ imp_res_tac BIJ_IMP_11 \\ fs [] \\ rw [] \\ fs [] \\ once_rewrite_tac [EQ_SYM_EQ] \\ match_mp_tac (MAP_KEYS_def |> SPEC_ALL |> CONJUNCT2 |> MP_CANON) - \\ fs [INJ_DEF]); + \\ fs [INJ_DEF] +QED -Theorem get_var_imm_find_name[simp] - `BIJ (find_name f) UNIV UNIV ⇒ +Theorem get_var_imm_find_name[simp]: + BIJ (find_name f) UNIV UNIV ⇒ get_var_imm (ri_find_name f ri) (rename_state c f s) = - get_var_imm ri s` - (Cases_on`ri`>>EVAL_TAC>>strip_tac>> + get_var_imm ri s +Proof + Cases_on`ri`>>EVAL_TAC>>strip_tac>> dep_rewrite.DEP_REWRITE_TAC[FLOOKUP_MAP_KEYS] >> conj_tac >- metis_tac[INJ_DEF,BIJ_IMP_11,IN_UNIV] >> DEEP_INTRO_TAC some_intro >> simp[] >> fs[GSYM tlookup_def] >> - metis_tac[BIJ_DEF,INJ_DEF,IN_UNIV,FLOOKUP_DEF]); - -Theorem FLOOKUP_rename_state_find_name[simp] - `BIJ (find_name f) UNIV UNIV ⇒ - FLOOKUP (rename_state c f s).regs (find_name f k) = FLOOKUP s.regs k` - (rw[BIJ_DEF] >> + metis_tac[BIJ_DEF,INJ_DEF,IN_UNIV,FLOOKUP_DEF] +QED + +Theorem FLOOKUP_rename_state_find_name[simp]: + BIJ (find_name f) UNIV UNIV ⇒ + FLOOKUP (rename_state c f s).regs (find_name f k) = FLOOKUP s.regs k +Proof + rw[BIJ_DEF] >> rw[rename_state_def] >> - simp[FLOOKUP_MAP_KEYS_MAPPED]); + simp[FLOOKUP_MAP_KEYS_MAPPED] +QED val prog_comp_eta = Q.prove( `prog_comp f = λ(x,y). (x,comp f y)`, rw[prog_comp_def,FUN_EQ_THM,FORALL_PROD]) -Theorem find_code_rename_state[simp] - `BIJ (find_name f) UNIV UNIV ⇒ +Theorem find_code_rename_state[simp]: + BIJ (find_name f) UNIV UNIV ⇒ find_code (dest_find_name f dest) (rename_state c f s).regs (rename_state c f s).code = - OPTION_MAP (comp f) (find_code dest s.regs s.code)` - (strip_tac >> + OPTION_MAP (comp f) (find_code dest s.regs s.code) +Proof + strip_tac >> Cases_on`dest`>>rw[find_code_def,rename_state_def,dest_find_name_def] >- ( simp[lookup_fromAList,compile_def,prog_comp_eta,ALOOKUP_MAP,ALOOKUP_toAList] >> metis_tac[] ) >> @@ -102,26 +121,32 @@ Theorem find_code_rename_state[simp] simp[lookup_fromAList,compile_def,prog_comp_eta,ALOOKUP_MAP,ALOOKUP_toAList] >> CASE_TAC >> simp[] >> CASE_TAC >> simp[] >> - metis_tac[]); + metis_tac[] +QED -Theorem set_var_find_name - `BIJ (find_name f) UNIV UNIV ⇒ +Theorem set_var_find_name: + BIJ (find_name f) UNIV UNIV ⇒ rename_state c f (set_var x y z) = - set_var (find_name f x) y (rename_state c f z)` - (rw[set_var_def,rename_state_def,state_component_equality] >> + set_var (find_name f x) y (rename_state c f z) +Proof + rw[set_var_def,rename_state_def,state_component_equality] >> match_mp_tac MAP_KEYS_FUPDATE >> - metis_tac[BIJ_IMP_11,INJ_DEF,IN_UNIV]); - -Theorem set_fp_var_find_name - `rename_state c f (set_fp_var x y z) = - set_fp_var x y (rename_state c f z)` - (rw[set_fp_var_def,rename_state_def,state_component_equality]) - -Theorem inst_rename - `BIJ (find_name f) UNIV UNIV ⇒ + metis_tac[BIJ_IMP_11,INJ_DEF,IN_UNIV] +QED + +Theorem set_fp_var_find_name: + rename_state c f (set_fp_var x y z) = + set_fp_var x y (rename_state c f z) +Proof + rw[set_fp_var_def,rename_state_def,state_component_equality] +QED + +Theorem inst_rename: + BIJ (find_name f) UNIV UNIV ⇒ inst (inst_find_name f i) (rename_state c f s) = - OPTION_MAP (rename_state c f) (inst i s)` - (rw[inst_def] >> + OPTION_MAP (rename_state c f) (inst i s) +Proof + rw[inst_def] >> rw[inst_find_name_def] >> CASE_TAC >> fs[] >- ( EVAL_TAC >> @@ -143,15 +168,20 @@ Theorem inst_rename rw[] >> fs[] >> rfs[] >> rw[set_var_find_name,set_fp_var_find_name] \\ every_case_tac \\ fs [wordLangTheory.word_op_def] \\ rw [] \\ fs [] \\ fs [BIJ_DEF,INJ_DEF] \\ res_tac - \\ fs [rename_state_with_memory]); + \\ fs [rename_state_with_memory] +QED -Theorem MAP_FST_compile[simp] - `MAP FST (stack_names$compile f c) = MAP FST c` - (rw[compile_def,MAP_MAP_o,MAP_EQ_f,prog_comp_def,FORALL_PROD]); +Theorem MAP_FST_compile[simp]: + MAP FST (stack_names$compile f c) = MAP FST c +Proof + rw[compile_def,MAP_MAP_o,MAP_EQ_f,prog_comp_def,FORALL_PROD] +QED -Theorem domain_rename_state_code[simp] - `domain (rename_state c f s).code = domain s.code` - (rw[rename_state_def,domain_fromAList,toAList_domain,EXTENSION]); +Theorem domain_rename_state_code[simp]: + domain (rename_state c f s).code = domain s.code +Proof + rw[rename_state_def,domain_fromAList,toAList_domain,EXTENSION] +QED val comp_STOP_While = Q.prove( `comp f (STOP (While cmp r1 ri c1)) = @@ -377,12 +407,13 @@ val comp_correct = Q.prove( simp[Once comp_def] >> fs[evaluate_def] >> simp[Once rename_state_def] >> rveq >> simp[] )); -Theorem compile_semantics - `BIJ (find_name f) UNIV UNIV /\ +Theorem compile_semantics: + BIJ (find_name f) UNIV UNIV /\ ~s.use_alloc /\ ~s.use_store /\ ~s.use_stack /\ s.compile = (λcfg. c cfg o (compile f)) ==> - semantics start (rename_state c f s) = semantics start s` - (simp[GSYM AND_IMP_INTRO] >> ntac 4 strip_tac >> + semantics start (rename_state c f s) = semantics start s +Proof + simp[GSYM AND_IMP_INTRO] >> ntac 4 strip_tac >> simp[semantics_def] >> simp[ comp_correct @@ -393,7 +424,8 @@ Theorem compile_semantics |> SIMP_RULE std_ss [rename_state_with_clock] |> UNDISCH_ALL] >> simp[rename_state_def] >> - srw_tac[QUANT_INST_ss[pair_default_qp]][]); + srw_tac[QUANT_INST_ss[pair_default_qp]][] +QED val compile_semantics_alt = Q.prove( `!s t. @@ -416,28 +448,32 @@ val make_init_def = Define ` *) ffi_save_regs := IMAGE (LINV (find_name f) UNIV) s.ffi_save_regs|>` -Theorem make_init_semantics - `~s.use_alloc /\ ~s.use_store /\ ~s.use_stack /\ +Theorem make_init_semantics: + ~s.use_alloc /\ ~s.use_store /\ ~s.use_stack /\ BIJ (find_name f) UNIV UNIV /\ ALL_DISTINCT (MAP FST code) /\ s.code = fromAList (compile f code) /\ s.compile_oracle = (I ## compile f ## I) o oracle ==> - semantics start s = semantics start (make_init f (fromAList code) oracle s)` - (fs [make_init_def] \\ rw [] + semantics start s = semantics start (make_init f (fromAList code) oracle s) +Proof + fs [make_init_def] \\ rw [] \\ match_mp_tac compile_semantics_alt \\ fs [] \\ fs [rename_state_def,state_component_equality] \\ `find_name f o LINV (find_name f) UNIV = I` by (imp_res_tac BIJ_LINV_INV \\ fs [FUN_EQ_THM]) \\ fs [GSYM IMAGE_COMPOSE] \\ fs [MAP_KEYS_BIJ_LINV] \\ fs [spt_eq_thm,wf_fromAList,lookup_fromAList,compile_def] - \\ rw[prog_comp_eta,ALOOKUP_MAP_2,ALOOKUP_toAList,lookup_fromAList]); - -Theorem stack_names_lab_pres ` - ∀f p. - extract_labels p = extract_labels (comp f p)` - (HO_MATCH_MP_TAC comp_ind>>Cases_on`p`>>rw[]>> + \\ rw[prog_comp_eta,ALOOKUP_MAP_2,ALOOKUP_toAList,lookup_fromAList] +QED + +Theorem stack_names_lab_pres: + ∀f p. + extract_labels p = extract_labels (comp f p) +Proof + HO_MATCH_MP_TAC comp_ind>>Cases_on`p`>>rw[]>> once_rewrite_tac [comp_def]>>fs[extract_labels_def]>> - BasicProvers.EVERY_CASE_TAC>>fs[]) + BasicProvers.EVERY_CASE_TAC>>fs[] +QED val names_ok_imp = Q.prove(` names_ok f c.reg_count c.avoid_regs ⇒ @@ -487,24 +523,27 @@ val stack_names_comp_stack_asm_ok = Q.prove(` >- metis_tac[names_ok_imp,asmTheory.reg_ok_def] >- metis_tac[names_ok_imp,asmTheory.reg_ok_def]); -Theorem stack_names_stack_asm_ok ` - EVERY (λ(n,p). stack_asm_name c p) prog ∧ +Theorem stack_names_stack_asm_ok: + EVERY (λ(n,p). stack_asm_name c p) prog ∧ names_ok f c.reg_count c.avoid_regs ∧ fixed_names f c ⇒ - EVERY (λ(n,p). stack_asm_ok c p) (compile f prog)` - (fs[EVERY_MAP,EVERY_MEM,FORALL_PROD,prog_comp_def,compile_def,MEM_MAP,EXISTS_PROD]>> + EVERY (λ(n,p). stack_asm_ok c p) (compile f prog) +Proof + fs[EVERY_MAP,EVERY_MEM,FORALL_PROD,prog_comp_def,compile_def,MEM_MAP,EXISTS_PROD]>> rw[]>> - metis_tac[stack_names_comp_stack_asm_ok]); + metis_tac[stack_names_comp_stack_asm_ok] +QED -Theorem stack_names_call_args ` - compile f p = p' ∧ +Theorem stack_names_call_args: + compile f p = p' ∧ EVERY (λp. call_args p 1 2 3 4 0) (MAP SND p) ==> EVERY (λp. call_args p (find_name f 1) (find_name f 2) (find_name f 3) (find_name f 4) - (find_name f 0)) (MAP SND p')` - (rw[]>>fs[compile_def]>> + (find_name f 0)) (MAP SND p') +Proof + rw[]>>fs[compile_def]>> fs[EVERY_MAP,EVERY_MEM,FORALL_PROD,prog_comp_def]>> rw[]>>res_tac>> pop_assum mp_tac>> rpt (pop_assum kall_tac)>> map_every qid_spec_tac[`p_2`,`f`]>> @@ -512,6 +551,7 @@ Theorem stack_names_call_args ` Cases_on`p_2`>>rw[]>> ONCE_REWRITE_TAC [comp_def]>> fs[call_args_def]>> - BasicProvers.EVERY_CASE_TAC>>fs[]); + BasicProvers.EVERY_CASE_TAC>>fs[] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/stack_removeProofScript.sml b/compiler/backend/proofs/stack_removeProofScript.sml index 71b2143b99..b2b2caa457 100644 --- a/compiler/backend/proofs/stack_removeProofScript.sml +++ b/compiler/backend/proofs/stack_removeProofScript.sml @@ -18,11 +18,12 @@ val _ = temp_overload_on ("num_stubs", ``stack_num_stubs``) (* TODO: move *) -Theorem word_list_exists_thm - `(word_list_exists a 0 = emp) /\ +Theorem word_list_exists_thm: + (word_list_exists a 0 = emp) /\ (word_list_exists a (SUC n) = - SEP_EXISTS w. one (a,w) * word_list_exists (a + bytes_in_word) n)` - (full_simp_tac(srw_ss())[word_list_exists_def,LENGTH_NIL,FUN_EQ_THM,ADD1, + SEP_EXISTS w. one (a,w) * word_list_exists (a + bytes_in_word) n) +Proof + full_simp_tac(srw_ss())[word_list_exists_def,LENGTH_NIL,FUN_EQ_THM,ADD1, SEP_EXISTS_THM,cond_STAR,word_list_def,SEP_CLAUSES] \\ srw_tac[][] \\ eq_tac \\ srw_tac[][] THEN1 @@ -31,66 +32,87 @@ Theorem word_list_exists_thm \\ qexists_tac `h` \\ full_simp_tac(srw_ss())[] \\ qexists_tac `t` \\ full_simp_tac(srw_ss())[SEP_CLAUSES]) \\ qexists_tac `w::xs` - \\ full_simp_tac(srw_ss())[word_list_def,ADD1,STAR_ASSOC,cond_STAR]); + \\ full_simp_tac(srw_ss())[word_list_def,ADD1,STAR_ASSOC,cond_STAR] +QED -Theorem word_list_exists_ADD - `!m n a. +Theorem word_list_exists_ADD: + !m n a. word_list_exists a (m + n) = word_list_exists a m * - word_list_exists (a + bytes_in_word * n2w m) n` - (Induct \\ full_simp_tac(srw_ss())[word_list_exists_thm,SEP_CLAUSES,ADD_CLAUSES] + word_list_exists (a + bytes_in_word * n2w m) n +Proof + Induct \\ full_simp_tac(srw_ss())[word_list_exists_thm,SEP_CLAUSES,ADD_CLAUSES] \\ full_simp_tac(srw_ss())[STAR_ASSOC,ADD1,GSYM word_add_n2w, - WORD_LEFT_ADD_DISTRIB]); + WORD_LEFT_ADD_DISTRIB] +QED -Theorem word_list_APPEND - `!xs ys a. +Theorem word_list_APPEND: + !xs ys a. word_list a (xs ++ ys) = - word_list a xs * word_list (a + bytes_in_word * n2w (LENGTH xs)) ys` - (Induct \\ full_simp_tac(srw_ss())[word_list_def,SEP_CLAUSES,STAR_ASSOC,ADD1,GSYM word_add_n2w] - \\ full_simp_tac(srw_ss())[WORD_LEFT_ADD_DISTRIB]); - -Theorem LESS_LENGTH_IMP_APPEND - `!xs n. n < LENGTH xs ==> ?ys zs. xs = ys ++ zs /\ LENGTH ys = n` - (Induct \\ full_simp_tac(srw_ss())[] \\ Cases_on `n` \\ full_simp_tac(srw_ss())[LENGTH_NIL] + word_list a xs * word_list (a + bytes_in_word * n2w (LENGTH xs)) ys +Proof + Induct \\ full_simp_tac(srw_ss())[word_list_def,SEP_CLAUSES,STAR_ASSOC,ADD1,GSYM word_add_n2w] + \\ full_simp_tac(srw_ss())[WORD_LEFT_ADD_DISTRIB] +QED + +Theorem LESS_LENGTH_IMP_APPEND: + !xs n. n < LENGTH xs ==> ?ys zs. xs = ys ++ zs /\ LENGTH ys = n +Proof + Induct \\ full_simp_tac(srw_ss())[] \\ Cases_on `n` \\ full_simp_tac(srw_ss())[LENGTH_NIL] \\ srw_tac[][] \\ res_tac \\ srw_tac[][] \\ pop_assum (fn th => simp [Once th]) - \\ qexists_tac `h::ys` \\ full_simp_tac(srw_ss())[]); - -Theorem call_FFI_LENGTH - `(call_FFI s i conf xs = FFI_return n ys) ==> (LENGTH ys = LENGTH xs)` - (srw_tac[][ffiTheory.call_FFI_def] - \\ every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][]); - -Theorem with_same_clock[simp] - `x with clock := x.clock = x` - (srw_tac[][state_component_equality]); - -Theorem set_var_set_var[simp] - `set_var x y (set_var x z w) = set_var x y w` - (EVAL_TAC \\ srw_tac[][state_component_equality]); - -Theorem get_var_set_var_same[simp] - `get_var x (set_var x y z) = SOME y` - (EVAL_TAC); - -Theorem get_var_set_var - `get_var x (set_var x' y z) = if x = x' then SOME y else get_var x z` - (EVAL_TAC \\ srw_tac[][]); - -Theorem bytes_in_word_word_shift - `good_dimindex(:'a) ∧ w2n (bytes_in_word:'a word) * w2n n < dimword(:'a) ⇒ - (bytes_in_word:'a word * n) >>> word_shift (:'a) = n` - (EVAL_TAC \\ srw_tac[][] \\ pop_assum mp_tac + \\ qexists_tac `h::ys` \\ full_simp_tac(srw_ss())[] +QED + +Theorem call_FFI_LENGTH: + (call_FFI s i conf xs = FFI_return n ys) ==> (LENGTH ys = LENGTH xs) +Proof + srw_tac[][ffiTheory.call_FFI_def] + \\ every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] +QED + +Theorem with_same_clock[simp]: + x with clock := x.clock = x +Proof + srw_tac[][state_component_equality] +QED + +Theorem set_var_set_var[simp]: + set_var x y (set_var x z w) = set_var x y w +Proof + EVAL_TAC \\ srw_tac[][state_component_equality] +QED + +Theorem get_var_set_var_same[simp]: + get_var x (set_var x y z) = SOME y +Proof + EVAL_TAC +QED + +Theorem get_var_set_var: + get_var x (set_var x' y z) = if x = x' then SOME y else get_var x z +Proof + EVAL_TAC \\ srw_tac[][] +QED + +Theorem bytes_in_word_word_shift: + good_dimindex(:'a) ∧ w2n (bytes_in_word:'a word) * w2n n < dimword(:'a) ⇒ + (bytes_in_word:'a word * n) >>> word_shift (:'a) = n +Proof + EVAL_TAC \\ srw_tac[][] \\ pop_assum mp_tac \\ blastLib.BBLAST_TAC \\ simp[] \\ blastLib.BBLAST_TAC \\ srw_tac[][] \\ match_mp_tac lsl_lsr \\ simp[] \\ Cases_on`n`\\full_simp_tac(srw_ss())[word_lsl_n2w] - \\ full_simp_tac(srw_ss())[dimword_def]); + \\ full_simp_tac(srw_ss())[dimword_def] +QED -Theorem word_offset_eq - `word_offset n = bytes_in_word * n2w n` - (full_simp_tac(srw_ss())[word_offset_def,word_mul_n2w,bytes_in_word_def]); +Theorem word_offset_eq: + word_offset n = bytes_in_word * n2w n +Proof + full_simp_tac(srw_ss())[word_offset_def,word_mul_n2w,bytes_in_word_def] +QED val memory_def = Define ` memory m dm = \s. s = fun2set (m, dm)`; @@ -180,13 +202,15 @@ val state_rel_with_clock = Q.prove( srw_tac[][] \\ full_simp_tac(srw_ss())[state_rel_def,dec_clock_def,empty_env_def] \\ rev_full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ res_tac \\ full_simp_tac(srw_ss())[]) -Theorem state_rel_const - `state_rel jump off k s t ⇒ +Theorem state_rel_const: + state_rel jump off k s t ⇒ t.code_buffer = s.code_buffer ∧ ¬t.use_stack ∧ s.use_stack ∧ t.compile_oracle = (λn. (I ## MAP (prog_comp jump off k) ## I (*K []*)) (s.compile_oracle n)) ∧ - s.compile = (λc p. t.compile c (MAP (prog_comp jump off k) p))` - (fs[state_rel_def]); + s.compile = (λc p. t.compile c (MAP (prog_comp jump off k) p)) +Proof + fs[state_rel_def] +QED val find_code_lemma = Q.prove( `state_rel jump off k s t1 /\ @@ -210,12 +234,14 @@ val find_code_lemma2 = Q.prove( \\ CASE_TAC \\ full_simp_tac(srw_ss())[] \\ res_tac \\ CASE_TAC \\ full_simp_tac(srw_ss())[] \\ res_tac); -Theorem state_rel_set_var[simp] - `state_rel jump off k s t1 /\ v < k ==> - state_rel jump off k (set_var v x s) (set_var v x t1)` - (fs[state_rel_def,set_var_def]>> strip_tac>> simp[] >> +Theorem state_rel_set_var[simp]: + state_rel jump off k s t1 /\ v < k ==> + state_rel jump off k (set_var v x s) (set_var v x t1) +Proof + fs[state_rel_def,set_var_def]>> strip_tac>> simp[] >> fs[FLOOKUP_UPDATE]>> - metis_tac[]); + metis_tac[] +QED val word_store_CurrHeap = Q.prove( `word_store base (s.store |+ (CurrHeap,x)) = word_store base s.store`, @@ -315,8 +341,8 @@ val write_bytearray_lemma = Q.prove( \\ imp_res_tac write_bytearray_IGNORE \\ full_simp_tac(srw_ss())[] \\ imp_res_tac write_bytearray_EQ \\ rev_full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[] \\ metis_tac []); -Theorem state_rel_get_var_k - `state_rel jump off k s t ⇒ +Theorem state_rel_get_var_k: + state_rel jump off k s t ⇒ ∃c:α word. get_var (k+1) t = SOME (Word c) ∧ dimindex (:α) DIV 8 * max_stack_alloc ≤ w2n c ∧ @@ -331,15 +357,17 @@ Theorem state_rel_get_var_k bytes_in_word * n2w (LENGTH s.data_buffer.buffer + LENGTH s.bitmaps)) s.data_buffer.space_left * word_store c s.store * - word_list c s.stack) (fun2set (t.memory,t.mdomain))` - (rw[state_rel_def] + word_list c s.stack) (fun2set (t.memory,t.mdomain)) +Proof + rw[state_rel_def] \\ pop_assum mp_tac \\ CASE_TAC \\ fs[] \\ CASE_TAC \\ fs[] - \\ simp[get_var_def]); + \\ simp[get_var_def] +QED -Theorem evaluate_single_stack_alloc - `state_rel jump off k s t1 ∧ +Theorem evaluate_single_stack_alloc: + state_rel jump off k s t1 ∧ ((r,s2) = if s.stack_space < n then (SOME (Halt (Word 2w)),empty_env s) else (NONE, s with stack_space := s.stack_space - n)) ∧ @@ -347,8 +375,9 @@ Theorem evaluate_single_stack_alloc ⇒ ∃ck t2. evaluate (single_stack_alloc jump k n,t1 with clock := t1.clock + ck) = (r,t2) ∧ - if s.stack_space < n then t2.ffi = s2.ffi else state_rel jump off k s2 t2` - (simp[single_stack_alloc_def] \\ + if s.stack_space < n then t2.ffi = s2.ffi else state_rel jump off k s2 t2 +Proof + simp[single_stack_alloc_def] \\ Cases_on`jump` \\ simp [evaluate_def,inst_def,assign_def,word_exp_def, wordLangTheory.word_op_def,GSYM get_var_def] @@ -464,17 +493,19 @@ Theorem evaluate_single_stack_alloc \\ dep_rewrite.DEP_REWRITE_TAC[GSYM n2w_sub] \\ simp[] \\ fs[bytes_in_word_def,word_mul_n2w] - \\ metis_tac[])); + \\ metis_tac[]) +QED -Theorem evaluate_stack_alloc - `∀jump k n r s s2 t1. +Theorem evaluate_stack_alloc: + ∀jump k n r s s2 t1. evaluate (StackAlloc n,s) = (r,s2) ∧ r ≠ SOME Error ∧ state_rel jump off k s t1 ⇒ ∃ck t2. evaluate (stack_alloc jump k n,t1 with clock := ck + t1.clock) = (r,t2) ∧ - if ∀w. r ≠ SOME (Halt w) then state_rel jump off k s2 t2 else t2.ffi = s2.ffi` - (ho_match_mp_tac stack_alloc_ind + if ∀w. r ≠ SOME (Halt w) then state_rel jump off k s2 t2 else t2.ffi = s2.ffi +Proof + ho_match_mp_tac stack_alloc_ind \\ srw_tac[][stackSemTheory.evaluate_def] \\ simp[Once stack_alloc_def] \\ IF_CASES_TAC \\ full_simp_tac(srw_ss())[] @@ -533,13 +564,15 @@ Theorem evaluate_stack_alloc \\ simp[Abbr`s'`] \\ IF_CASES_TAC \\ full_simp_tac(srw_ss())[] \\ IF_CASES_TAC \\ full_simp_tac(srw_ss())[] - \\ rveq \\ simp[]); + \\ rveq \\ simp[] +QED -Theorem state_rel_mem_load_imp - `state_rel jump off k s t ∧ +Theorem state_rel_mem_load_imp: + state_rel jump off k s t ∧ mem_load x s = SOME w ⇒ - mem_load x t = SOME w` - (srw_tac[][state_rel_def] + mem_load x t = SOME w +Proof + srw_tac[][state_rel_def] \\ every_case_tac \\ full_simp_tac(srw_ss())[] \\ fs[mem_load_def] \\ drule fun2set_STAR_IMP \\ strip_tac @@ -548,15 +581,17 @@ Theorem state_rel_mem_load_imp \\ drule fun2set_STAR_IMP \\ strip_tac \\ full_simp_tac(srw_ss())[memory_def] \\ full_simp_tac(srw_ss())[fun2set_def,EXTENSION,PULL_EXISTS,EXISTS_PROD,FORALL_PROD] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem state_rel_word_exp - `∀s e w. +Theorem state_rel_word_exp: + ∀s e w. state_rel jump off k s t ∧ reg_bound_exp e k ∧ word_exp s e = SOME w ⇒ - word_exp t e = SOME w` - (ho_match_mp_tac word_exp_ind + word_exp t e = SOME w +Proof + ho_match_mp_tac word_exp_ind \\ simp[word_exp_def] \\ rw[] \\ imp_res_tac state_rel_mem_load_imp @@ -580,38 +615,44 @@ Theorem state_rel_word_exp >- (qpat_x_assum`_ = SOME w`mp_tac \\ BasicProvers.TOP_CASE_TAC \\ full_simp_tac(srw_ss())[] \\ - res_tac \\ simp[])); + res_tac \\ simp[]) +QED -Theorem memory_write - `x IN sd /\ x IN dm /\ +Theorem memory_write: + x IN sd /\ x IN dm /\ (memory sm sd * p) (fun2set (m,dm)) ==> - (memory ((x =+ y) sm) sd * p) (fun2set ((x =+ y) m,dm))` - (srw_tac[][STAR_def,memory_def] + (memory ((x =+ y) sm) sd * p) (fun2set ((x =+ y) m,dm)) +Proof + srw_tac[][STAR_def,memory_def] \\ qexists_tac`v` \\ simp[] \\ full_simp_tac(srw_ss())[SPLIT_def] \\ full_simp_tac(srw_ss())[EXTENSION,IN_DISJOINT,IN_fun2set,FORALL_PROD] \\ full_simp_tac(srw_ss())[APPLY_UPDATE_THM] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem state_rel_mem_store - `state_rel jump off k s t ∧ +Theorem state_rel_mem_store: + state_rel jump off k s t ∧ mem_store x y s = SOME s' ∧ mem_store x y t = SOME t' ⇒ - state_rel jump off k s' t'` - (fs[mem_store_def] \\ srw_tac[][] + state_rel jump off k s' t' +Proof + fs[mem_store_def] \\ srw_tac[][] \\ fs[state_rel_def] \\ conj_tac >- metis_tac[] \\ conj_tac >- metis_tac[] \\ every_case_tac \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[GSYM STAR_ASSOC] \\ match_mp_tac memory_write - \\ full_simp_tac(srw_ss())[]); + \\ full_simp_tac(srw_ss())[] +QED -Theorem state_rel_mem_store_byte_aux - `state_rel jump off k s t ∧ mem_store_byte_aux s.memory s.mdomain s.be a b = SOME z ⇒ +Theorem state_rel_mem_store_byte_aux: + state_rel jump off k s t ∧ mem_store_byte_aux s.memory s.mdomain s.be a b = SOME z ⇒ ∃y. mem_store_byte_aux t.memory t.mdomain t.be a b = SOME y ∧ - state_rel jump off k (s with memory := z) (t with memory := y)` - (rw[state_rel_def,wordSemTheory.mem_store_byte_aux_def] + state_rel jump off k (s with memory := z) (t with memory := y) +Proof + rw[state_rel_def,wordSemTheory.mem_store_byte_aux_def] \\ ntac 2 (pop_assum mp_tac) \\ BasicProvers.TOP_CASE_TAC \\ fs[] \\ BasicProvers.TOP_CASE_TAC \\ fs[] @@ -626,7 +667,8 @@ Theorem state_rel_mem_store_byte_aux \\ simp[CONJ_ASSOC] \\ conj_tac >- metis_tac[] \\ match_mp_tac memory_write - \\ simp[]); + \\ simp[] +QED val state_rel_get_fp_var = Q.prove(` state_rel jump off k s t ⇒ @@ -639,15 +681,16 @@ val state_rel_set_fp_var = Q.prove(` rw[state_rel_def,set_fp_var_def]>>rfs[]>> res_tac >> fs[]); -Theorem state_rel_inst - `state_rel jump off k s t ∧ +Theorem state_rel_inst: + state_rel jump off k s t ∧ reg_bound_inst i k ∧ inst i s = SOME s' ⇒ ∃t'. inst i t = SOME t' ∧ - state_rel jump off k s' t'` - (simp[inst_def] + state_rel jump off k s' t' +Proof + simp[inst_def] \\ BasicProvers.TOP_CASE_TAC \\ full_simp_tac(srw_ss())[] \\ strip_tac @@ -734,29 +777,33 @@ Theorem state_rel_inst imp_res_tac state_rel_get_var >> fs[]>> rw[]>>fs[state_rel_set_var,state_rel_set_fp_var]>> rfs[]>> - rw[]>>fs[state_rel_set_var,state_rel_set_fp_var]); + rw[]>>fs[state_rel_set_var,state_rel_set_fp_var] +QED -Theorem stack_write - `∀stack base p m d a v. +Theorem stack_write: + ∀stack base p m d a v. (word_list base stack * p) (fun2set (m,d)) ∧ a < LENGTH stack ⇒ - (word_list base (LUPDATE v a stack) * p) (fun2set ((base + bytes_in_word * (n2w a) =+ v) m,d))` - (Induct \\ simp[word_list_def] \\ srw_tac[][] + (word_list base (LUPDATE v a stack) * p) (fun2set ((base + bytes_in_word * (n2w a) =+ v) m,d)) +Proof + Induct \\ simp[word_list_def] \\ srw_tac[][] \\ Cases_on`a`\\full_simp_tac(srw_ss())[LUPDATE_def] \\ full_simp_tac(srw_ss())[word_list_def] >- SEP_W_TAC \\ SEP_F_TAC \\ disch_then drule \\ simp[ADD1,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] - \\ srw_tac[star_ss][]); + \\ srw_tac[star_ss][] +QED -Theorem state_rel_stack_store - `state_rel jump off k s t ∧ st = s.stack ∧ +Theorem state_rel_stack_store: + state_rel jump off k s t ∧ st = s.stack ∧ FLOOKUP t.regs k = SOME (Word b) ∧ s.stack_space + n < LENGTH st ∧ b + bytes_in_word * n2w n = a ⇒ state_rel jump off k (s with stack := LUPDATE x (n + s.stack_space) st) - (t with memory := (a =+ x) t.memory)` - (simp[state_rel_def] + (t with memory := (a =+ x) t.memory) +Proof + simp[state_rel_def] \\ strip_tac \\ conj_tac >- metis_tac[] \\ conj_tac >- metis_tac[] @@ -767,13 +814,16 @@ Theorem state_rel_stack_store \\ REWRITE_TAC[Once STAR_COMM] \\ REWRITE_TAC[Once ADD_COMM] \\ match_mp_tac stack_write - \\ fsrw_tac[star_ss][AC ADD_COMM ADD_ASSOC]); + \\ fsrw_tac[star_ss][AC ADD_COMM ADD_ASSOC] +QED -Theorem lsl_word_shift - `good_dimindex (:'a) ==> - w ≪ word_shift (:α) = w * bytes_in_word:'a word` - (srw_tac[][WORD_MUL_LSL,word_shift_def,bytes_in_word_def, - labPropsTheory.good_dimindex_def]); +Theorem lsl_word_shift: + good_dimindex (:'a) ==> + w ≪ word_shift (:α) = w * bytes_in_word:'a word +Proof + srw_tac[][WORD_MUL_LSL,word_shift_def,bytes_in_word_def, + labPropsTheory.good_dimindex_def] +QED val get_labels_stack_free = Q.prove( `!k n. get_labels (stack_free k n) = {}`, @@ -800,30 +850,35 @@ val get_labels_downshift = Q.prove( \\ once_rewrite_tac [downshift_def] \\ rw [] \\ fs [get_labels_def]); -Theorem get_labels_comp - `!jump off k e. get_labels (comp jump off k e) = get_labels e` - (recInduct comp_ind \\ rw [] \\ Cases_on `p` +Theorem get_labels_comp: + !jump off k e. get_labels (comp jump off k e) = get_labels e +Proof + recInduct comp_ind \\ rw [] \\ Cases_on `p` \\ once_rewrite_tac [comp_def] \\ fs [get_labels_def] \\ rw [] \\ fs [get_labels_def,list_Seq_def] \\ every_case_tac \\ fs [get_labels_stack_alloc,get_labels_stack_free,stack_store_def,stack_load_def,get_labels_def] - \\ metis_tac[get_labels_upshift,get_labels_downshift]) + \\ metis_tac[get_labels_upshift,get_labels_downshift] +QED -Theorem code_rel_loc_check - `code_rel jump off k c1 c2 /\ loc_check c1 (l1,l2) ==> loc_check c2 (l1,l2)` - (fs [loc_check_def,code_rel_def,domain_lookup,PULL_EXISTS] \\ rw [] +Theorem code_rel_loc_check: + code_rel jump off k c1 c2 /\ loc_check c1 (l1,l2) ==> loc_check c2 (l1,l2) +Proof + fs [loc_check_def,code_rel_def,domain_lookup,PULL_EXISTS] \\ rw [] \\ res_tac \\ fs [] \\ disj2_tac - \\ asm_exists_tac \\ fs [get_labels_comp]); + \\ asm_exists_tac \\ fs [get_labels_comp] +QED -Theorem evaluate_single_stack_free - `state_rel jump off k s t1 ∧ +Theorem evaluate_single_stack_free: + state_rel jump off k s t1 ∧ ((r,s2) = (NONE, s with stack_space := s.stack_space + n)) ∧ ¬(LENGTH s.stack < s.stack_space + n) ∧ n ≠ 0 ∧ n ≤ max_stack_alloc ⇒ ∃ck t2. - evaluate (single_stack_free k n,t1 with clock := t1.clock + ck) = (r,t2) ∧ state_rel jump off k s2 t2` - (simp[single_stack_free_def,evaluate_def,inst_def,assign_def,word_exp_def, + evaluate (single_stack_free k n,t1 with clock := t1.clock + ck) = (r,t2) ∧ state_rel jump off k s2 t2 +Proof + simp[single_stack_free_def,evaluate_def,inst_def,assign_def,word_exp_def, wordLangTheory.word_op_def,GSYM get_var_def] \\ strip_tac \\ imp_res_tac state_rel_get_var_k @@ -835,17 +890,19 @@ Theorem evaluate_single_stack_free \\ simp[FLOOKUP_UPDATE] \\ rw[] >> TRY (metis_tac[]) \\ simp[word_offset_def,bytes_in_word_def,word_mul_n2w,word_add_n2w] - \\ simp[RIGHT_ADD_DISTRIB,GSYM word_add_n2w]) + \\ simp[RIGHT_ADD_DISTRIB,GSYM word_add_n2w] +QED -Theorem evaluate_stack_free - `∀k n r s s2 t1. +Theorem evaluate_stack_free: + ∀k n r s s2 t1. evaluate (StackFree n,s) = (r,s2) ∧ r ≠ SOME Error ∧ state_rel jump off k s t1 ⇒ ∃ck t2. evaluate (stack_free k n,t1 with clock := ck + t1.clock) = (r,t2) ∧ - state_rel jump off k s2 t2` - (ho_match_mp_tac stack_free_ind + state_rel jump off k s2 t2 +Proof + ho_match_mp_tac stack_free_ind \\ srw_tac[][stackSemTheory.evaluate_def] \\ simp[Once stack_free_def] \\ IF_CASES_TAC \\ full_simp_tac(srw_ss())[] @@ -878,7 +935,8 @@ Theorem evaluate_stack_free \\ disch_then(qspec_then`ck'`mp_tac) \\ rveq \\ fs[] \\ ntac 2 strip_tac - \\ qexists_tac`ck+ck'`\\simp[]); + \\ qexists_tac`ck+ck'`\\simp[] +QED val evaluate_upshift = Q.prove(` ∀r n st w. @@ -1073,9 +1131,11 @@ val store_write_lemma = Q.prove(` first_x_assum ACCEPT_TAC))>> fs[store_list_def]); -Theorem prog_comp_eta - `prog_comp = \jump off k (n,p). (n,comp jump off k p)` - (srw_tac[][FUN_EQ_THM,prog_comp_def,FORALL_PROD,LAMBDA_PROD]); +Theorem prog_comp_eta: + prog_comp = \jump off k (n,p). (n,comp jump off k p) +Proof + srw_tac[][FUN_EQ_THM,prog_comp_def,FORALL_PROD,LAMBDA_PROD] +QED val comp_correct = Q.prove( `!p s1 r s2 t1 k off jump. @@ -1887,10 +1947,11 @@ val comp_correct = Q.prove( \\ full_simp_tac(srw_ss())[labPropsTheory.good_dimindex_def,word_shift_def,FLOOKUP_UPDATE] \\ full_simp_tac(srw_ss())[mem_load_def] \\ full_simp_tac(srw_ss())[GSYM mem_load_def] \\ full_simp_tac(srw_ss())[GSYM set_var_def])); -Theorem compile_semantics - `state_rel jump off k s1 s2 /\ semantics start s1 <> Fail ==> - semantics start s2 ∈ extend_with_resource_limit { semantics start s1 }` - (simp[GSYM AND_IMP_INTRO] \\ strip_tac +Theorem compile_semantics: + state_rel jump off k s1 s2 /\ semantics start s1 <> Fail ==> + semantics start s2 ∈ extend_with_resource_limit { semantics start s1 } +Proof + simp[GSYM AND_IMP_INTRO] \\ strip_tac \\ simp[semantics_def] \\ IF_CASES_TAC \\ full_simp_tac(srw_ss())[] \\ DEEP_INTRO_TAC some_intro \\ full_simp_tac(srw_ss())[] @@ -2080,7 +2141,8 @@ Theorem compile_semantics ntac 3 strip_tac >> full_simp_tac(srw_ss())[] >> rev_full_simp_tac(srw_ss())[] >> full_simp_tac(srw_ss())[IS_PREFIX_APPEND] >> - simp[EL_APPEND1]); + simp[EL_APPEND1] +QED (* init code *) @@ -2102,8 +2164,8 @@ val mem_val_def = Define ` (mem_val regs (INL w) = Word w) /\ (mem_val (regs:num |-> 'a word_loc) (INR n) = regs ' n)` -Theorem store_list_code_thm - `!xs s w frame ys m dm. +Theorem store_list_code_thm: + !xs s w frame ys m dm. (word_list w ys * frame) (fun2set (m,dm)) /\ m = s.memory /\ dm = s.mdomain /\ (LENGTH ys = LENGTH xs) /\ a <> t /\ @@ -2114,8 +2176,9 @@ Theorem store_list_code_thm evaluate (store_list_code a t xs,s) = (NONE,s with <| memory := m1; regs := s.regs |++ - [(a,Word (w + bytes_in_word * n2w (LENGTH xs)));(t,r1)] |>)` - (simp_tac std_ss [] + [(a,Word (w + bytes_in_word * n2w (LENGTH xs)));(t,r1)] |>) +Proof + simp_tac std_ss [] \\ Induct \\ fs [] THEN1 (fs [word_list_def,SEP_CLAUSES,store_list_code_def,LENGTH_NIL] \\ tac @@ -2185,7 +2248,8 @@ Theorem store_list_code_thm \\ rw [] \\ res_tac \\ fs [FAPPLY_FUPDATE_THM]) \\ fs [] \\ fs [finite_mapTheory.fmap_EXT,state_component_equality, - FAPPLY_FUPDATE_THM,FUPDATE_LIST,EXTENSION])) + FAPPLY_FUPDATE_THM,FUPDATE_LIST,EXTENSION]) +QED val halt_tac = tac \\ fs [labPropsTheory.good_dimindex_def] @@ -2224,9 +2288,11 @@ val IN_addresses = Q.prove( \\ fs [ADD1,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] \\ metis_tac []); -Theorem addresses_thm - `!n a. addresses a n = { a + n2w i * bytes_in_word | i < n }` - (rw[EXTENSION, IN_addresses] \\ metis_tac[]); +Theorem addresses_thm: + !n a. addresses a n = { a + n2w i * bytes_in_word | i < n } +Proof + rw[EXTENSION, IN_addresses] \\ metis_tac[] +QED val memory_addresses = Q.prove( `!n (a:'a word) (m:'a word -> 'a word_loc). @@ -2263,13 +2329,15 @@ val MAP_mem_val_MAP_INL = Q.prove( `!ws f. MAP (mem_val f) (MAP INL ws) = MAP Word ws`, Induct \\ fs [mem_val_def]); -Theorem word_list_EQ_rev - `!xs a. word_list a xs = - word_list_rev (a + n2w (LENGTH xs) * bytes_in_word) (REVERSE xs)` - (recInduct SNOC_INDUCT \\ fs [REVERSE_SNOC] +Theorem word_list_EQ_rev: + !xs a. word_list a xs = + word_list_rev (a + n2w (LENGTH xs) * bytes_in_word) (REVERSE xs) +Proof + recInduct SNOC_INDUCT \\ fs [REVERSE_SNOC] \\ fs [SNOC_APPEND,word_list_APPEND,word_list_rev_def,word_list_def] \\ rw [SEP_CLAUSES,ADD1,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] - \\ fs [AC STAR_COMM STAR_ASSOC]) + \\ fs [AC STAR_COMM STAR_ASSOC] +QED val word_list_and_rev_join_lemma = Q.prove( `(b = a + n2w (LENGTH xs + LENGTH ys) * bytes_in_word) /\ @@ -2290,11 +2358,12 @@ val INSERT_DELETE_EQ_DELETE = Q.prove( `(x INSERT s) DELETE x = s DELETE x`, fs [EXTENSION] \\ metis_tac []); -Theorem word_list_exists_addresses - `!n a. (dimindex(:'a) DIV 8) * n < dimword (:'a) /\ +Theorem word_list_exists_addresses: + !n a. (dimindex(:'a) DIV 8) * n < dimword (:'a) /\ good_dimindex (:'a) ==> - word_list_exists a n (fun2set (m1,addresses (a:'a word) n))` - (Induct + word_list_exists a n (fun2set (m1,addresses (a:'a word) n)) +Proof + Induct THEN1 (fs [word_list_exists_thm,fun2set_def,emp_def,addresses_def]) \\ fs [word_list_exists_thm,emp_def,addresses_def,INSERT_DELETE_EQ_DELETE, SEP_EXISTS_THM,MULT_CLAUSES,set_sepTheory.one_fun2set] @@ -2307,7 +2376,8 @@ Theorem word_list_exists_addresses \\ rw [] \\ fs [bytes_in_word_def,word_mul_n2w,word_add_n2w] \\ sg `(i * (dimindex (:'a) DIV 8) + dimindex (:'a) DIV 8) < dimword (:'a)` \\ fs [] - \\ fs [labPropsTheory.good_dimindex_def,dimword_def] \\ rfs [] \\ fs []); + \\ fs [labPropsTheory.good_dimindex_def,dimword_def] \\ rfs [] \\ fs [] +QED val init_reduce_def = Define ` init_reduce gen_gc jump off k code bitmaps data_sp coracle (s:('a,'c,'ffi)stackSem$state) = @@ -2415,13 +2485,14 @@ val byte_aligned_bytes_in_word_MULT = Q.prove( \\ fs [WORD_MUL_LSL]); (* The extra b equality makes this work better with SEP_NEQ_TAC *) -Theorem word_list_wrap ` - good_dimindex (:'a) ∧ +Theorem word_list_wrap: + good_dimindex (:'a) ∧ dimword(:'a) DIV (dimindex(:'a) DIV 8) < LENGTH ls ⇒ ∃x xs y ys b. word_list (a:'a word) ls = word_list a (x::xs) * word_list b (y::ys) ∧ - b = a` - (rw[]>> + b = a +Proof + rw[]>> `∃r.r < LENGTH ls ∧ 0 < r ∧ a + bytes_in_word * n2w r = a` by (fs[addressTheory.WORD_EQ_ADD_CANCEL,bytes_in_word_def,word_mul_n2w]>> `0 > @@ -2433,7 +2504,8 @@ Theorem word_list_wrap ` `0 < LENGTH (DROP r ls)` by fs[]>> Cases_on`DROP r ls`>>fs[]>> Cases_on`ls`>>fs[]>> - metis_tac[]); + metis_tac[] +QED val sub_rewrite = Q.prove(` ptr <= ptr' ⇒ @@ -2448,18 +2520,20 @@ val div_rewrite = Q.prove(` rw[]>> fs[DIV_EQ_0]); -Theorem push_if - `(if b then f x else f y) = f (if b then x else y) /\ - (if b then f x else g x) = (if b then f else g) x` - (rw []); +Theorem push_if: + (if b then f x else f y) = f (if b then x else y) /\ + (if b then f x else g x) = (if b then f else g) x +Proof + rw [] +QED val fmap_simp_lemma1 = prove( ``g |+ (0n,x) |+ (5,y) |+ (0,z) = g |+ (0,z) |+ (5,y)``, fs [fmap_EXT] \\ rw [] \\ fs [EXTENSION,FAPPLY_FUPDATE_THM] \\ rw [] \\ fs [] \\ metis_tac []); -Theorem init_code_thm - `init_code_pre k bitmaps data_sp s /\ code_rel jump off k code s.code /\ +Theorem init_code_thm: + init_code_pre k bitmaps data_sp s /\ code_rel jump off k code s.code /\ s.compile_oracle = (I ## MAP (prog_comp jump off k) ## I) o coracle /\ (∀n i p. MEM (i,p) (FST(SND(coracle n))) ⇒ reg_bound p k ∧ num_stubs ≤ i+1) ∧ lookup stack_err_lab s.code = SOME (halt_inst 2w) /\ @@ -2475,8 +2549,9 @@ Theorem init_code_thm state_rel jump off k (init_reduce gen_gc jump off k code bitmaps data_sp coracle t) t /\ t.ffi = s.ffi /\ init_prop gen_gc max_heap data_sp - (init_reduce gen_gc jump off k code bitmaps data_sp coracle t)` - (simp_tac std_ss [init_code_pre_def] \\ strip_tac + (init_reduce gen_gc jump off k code bitmaps data_sp coracle t) +Proof + simp_tac std_ss [init_code_pre_def] \\ strip_tac \\ `k <> 3 /\ k <> 4 /\ k <> 5` by decide_tac \\ full_simp_tac std_ss [init_code_def,LET_DEF] \\ qpat_abbrev_tac `max_heap_w = if _ then _ else _` @@ -2945,7 +3020,8 @@ Theorem init_code_thm strip_tac>> pop_assum SUBST_ALL_TAC>> SEP_NEQ_TAC>>fs[]) - \\ simp [] \\ match_mp_tac word_list_exists_addresses \\ fs []); + \\ simp [] \\ match_mp_tac word_list_exists_addresses \\ fs [] +QED val make_init_opt_def = Define ` make_init_opt gen_gc max_heap bitmaps data_sp coracle jump off k code (s:('a,'c,'ffi)stackSem$state) = @@ -2960,8 +3036,8 @@ val init_pre_def = Define ` (Call NONE (INL start) NONE)) /\ init_code_pre k bitmaps data_sp s /\ max_stack_alloc ≤ max_heap` -Theorem evaluate_init_code - `init_pre gen_gc max_heap bitmaps data_sp k start s /\ +Theorem evaluate_init_code: + init_pre gen_gc max_heap bitmaps data_sp k start s /\ s.compile_oracle = ((I ## MAP (prog_comp jump off k) ## I) o coracle) /\ (∀n i p. MEM (i,p) (FST(SND(coracle n))) ⇒ reg_bound p k ∧ num_stubs ≤ i+1) ∧ lookup stack_err_lab s.code = SOME (halt_inst 2w) /\ @@ -2972,18 +3048,22 @@ Theorem evaluate_init_code make_init_opt gen_gc max_heap bitmaps data_sp coracle jump off k code s = NONE | (NONE,t) => ?r. make_init_opt gen_gc max_heap bitmaps data_sp coracle jump off k code s = SOME r /\ state_rel jump off k r t /\ t.ffi = s.ffi - | _ => F` - (strip_tac \\ fs [init_pre_def] + | _ => F +Proof + strip_tac \\ fs [init_pre_def] \\ drule init_code_thm \\ fs [] \\ impl_tac >- metis_tac[] \\ CASE_TAC \\ CASE_TAC \\ fs [make_init_opt_def] - \\ strip_tac \\ fs[]); + \\ strip_tac \\ fs[] +QED -Theorem clock_neutral_store_list_code - `!xs n k. clock_neutral (store_list_code n k xs)` - (Induct \\ fs [clock_neutral_def,store_list_code_def] - \\ Cases \\ fs [clock_neutral_def,store_list_code_def,list_Seq_def]); +Theorem clock_neutral_store_list_code: + !xs n k. clock_neutral (store_list_code n k xs) +Proof + Induct \\ fs [clock_neutral_def,store_list_code_def] + \\ Cases \\ fs [clock_neutral_def,store_list_code_def,list_Seq_def] +QED val evaluate_init_code_clock = Q.prove( `evaluate (init_code gen_gc max_heap k,s) = (res,t) ==> @@ -2994,17 +3074,19 @@ val evaluate_init_code_clock = Q.prove( \\ fs [clock_neutral_def,init_code_def,halt_inst_def, list_Seq_def,init_memory_def,clock_neutral_store_list_code]); -Theorem evaluate_init_code_ffi - `evaluate (init_code gen_gc max_heap k,(s:('a,'c,'ffi) stackSem$state)) = (res,t) ==> +Theorem evaluate_init_code_ffi: + evaluate (init_code gen_gc max_heap k,(s:('a,'c,'ffi) stackSem$state)) = (res,t) ==> evaluate (init_code gen_gc max_heap k,s with ffi := c) = - (res,(t with ffi := c):('a,'c,'ffi) stackSem$state)` - (srw_tac[][] \\ match_mp_tac evaluate_ffi_neutral \\ fs [] + (res,(t with ffi := c):('a,'c,'ffi) stackSem$state) +Proof + srw_tac[][] \\ match_mp_tac evaluate_ffi_neutral \\ fs [] \\ fs [clock_neutral_def,init_code_def] \\ rw [] \\ fs [clock_neutral_def,init_code_def,halt_inst_def, - list_Seq_def,init_memory_def,clock_neutral_store_list_code]); + list_Seq_def,init_memory_def,clock_neutral_store_list_code] +QED -Theorem init_semantics - `lookup stack_err_lab s.code = SOME (halt_inst 2w) /\ +Theorem init_semantics: + lookup stack_err_lab s.code = SOME (halt_inst 2w) /\ code_rel jump off k code s.code /\ init_pre gen_gc max_heap bitmaps data_sp k start s ∧ s.compile_oracle = ((I ## MAP (prog_comp jump off k) ## I) o coracle) /\ @@ -3017,8 +3099,9 @@ Theorem init_semantics | (NONE,t) => (semantics 0 s = semantics start t) /\ ?r. make_init_opt gen_gc max_heap bitmaps data_sp coracle jump off k code s = SOME r /\ state_rel jump off k r t - | _ => F` - (srw_tac[][] + | _ => F +Proof + srw_tac[][] \\ qhdtm_x_assum`init_pre` (fn th => assume_tac th \\ mp_tac th) \\ simp_tac std_ss [init_pre_def] \\ rw [] \\ imp_res_tac evaluate_init_code @@ -3077,32 +3160,37 @@ Theorem init_semantics \\ Cases_on `k' = 0` \\ full_simp_tac(srw_ss())[] THEN1 (full_simp_tac(srw_ss())[evaluate_def,empty_env_def] \\ every_case_tac \\ full_simp_tac(srw_ss())[]) - \\ every_case_tac \\ full_simp_tac(srw_ss())[]); + \\ every_case_tac \\ full_simp_tac(srw_ss())[] +QED -Theorem make_init_opt_SOME_semantics - `init_pre gen_gc max_heap bitmaps data_sp k start s2 /\ +Theorem make_init_opt_SOME_semantics: + init_pre gen_gc max_heap bitmaps data_sp k start s2 /\ s2.compile_oracle = ((I ## MAP (prog_comp jump off k) ## I) o coracle) /\ (∀n i p. MEM (i,p) (FST(SND(coracle n))) ⇒ reg_bound p k ∧ num_stubs ≤ i+1) ∧ code_rel jump off k code s2.code /\ lookup stack_err_lab s2.code = SOME (halt_inst 2w) /\ make_init_opt gen_gc max_heap bitmaps data_sp coracle jump off k code s2 = SOME s1 /\ semantics start s1 <> Fail ==> - semantics 0 s2 IN extend_with_resource_limit {semantics start s1}` - (srw_tac[][] \\ imp_res_tac init_semantics \\ pop_assum (assume_tac o SPEC_ALL) + semantics 0 s2 IN extend_with_resource_limit {semantics start s1} +Proof + srw_tac[][] \\ imp_res_tac init_semantics \\ pop_assum (assume_tac o SPEC_ALL) \\ every_case_tac \\ full_simp_tac(srw_ss())[] \\ match_mp_tac (GEN_ALL compile_semantics) - \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ metis_tac []); + \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ metis_tac [] +QED -Theorem make_init_opt_NONE_semantics - `init_pre gen_gc max_heap bitmaps data_sp k start s2 /\ code_rel jump off k code s2.code /\ +Theorem make_init_opt_NONE_semantics: + init_pre gen_gc max_heap bitmaps data_sp k start s2 /\ code_rel jump off k code s2.code /\ s2.compile_oracle = ((I ## MAP (prog_comp jump off k) ## I) o coracle) /\ (∀n i p. MEM (i,p) (FST(SND(coracle n))) ⇒ reg_bound p k ∧ num_stubs ≤ i+1) ∧ lookup stack_err_lab s2.code = SOME (halt_inst 2w) /\ make_init_opt gen_gc max_heap bitmaps data_sp coracle jump off k code s2 = NONE ==> - semantics 0 s2 = Terminate Resource_limit_hit s2.ffi.io_events` - (srw_tac[][] \\ imp_res_tac init_semantics \\ pop_assum (assume_tac o SPEC_ALL) + semantics 0 s2 = Terminate Resource_limit_hit s2.ffi.io_events +Proof + srw_tac[][] \\ imp_res_tac init_semantics \\ pop_assum (assume_tac o SPEC_ALL) \\ every_case_tac \\ full_simp_tac(srw_ss())[] - \\ full_simp_tac(srw_ss())[extend_with_resource_limit_def]); + \\ full_simp_tac(srw_ss())[extend_with_resource_limit_def] +QED val IMP_code_rel = Q.prove( `EVERY (\(n,p). reg_bound p k /\ num_stubs ≤ n+1) code1 /\ @@ -3180,14 +3268,15 @@ val propagate_these_def = Define` (w2n (-1w * ptr2 + ptr4) DIV w2n (bytes_in_word:'a word))) (fun2set (s.memory,s.mdomain))`; -Theorem make_init_semantics - `discharge_these jump off gen_gc max_heap k start coracle code s2 /\ +Theorem make_init_semantics: + discharge_these jump off gen_gc max_heap k start coracle code s2 /\ propagate_these s2 bitmaps data_sp /\ make_init_opt gen_gc max_heap (bitmaps:'a word list) data_sp coracle jump off k (fromAList code) s2 = SOME s1 /\ semantics start s1 <> Fail ==> - semantics 0 s2 IN extend_with_resource_limit {semantics start s1}` - (rw[discharge_these_def] + semantics 0 s2 IN extend_with_resource_limit {semantics start s1} +Proof + rw[discharge_these_def] \\ imp_res_tac IMP_code_rel \\ imp_res_tac make_init_opt_SOME_semantics \\ pop_assum kall_tac @@ -3205,15 +3294,17 @@ Theorem make_init_semantics fs[init_pre_def,init_code_pre_def,propagate_these_def] \\ simp[lookup_fromAList,compile_def,ALOOKUP_APPEND] \\ EVAL_TAC ) - \\ rw[]); + \\ rw[] +QED -Theorem make_init_semantics_fail - `discharge_these jump off gen_gc max_heap k start coracle code s2 /\ +Theorem make_init_semantics_fail: + discharge_these jump off gen_gc max_heap k start coracle code s2 /\ propagate_these s2 bitmaps data_sp /\ make_init_opt gen_gc max_heap (bitmaps:'a word list) data_sp coracle jump off k (fromAList code) s2 = NONE ==> - semantics 0 s2 = Terminate Resource_limit_hit s2.ffi.io_events` - (rw[discharge_these_def] + semantics 0 s2 = Terminate Resource_limit_hit s2.ffi.io_events +Proof + rw[discharge_these_def] \\ imp_res_tac IMP_code_rel \\ imp_res_tac make_init_opt_NONE_semantics \\ pop_assum kall_tac @@ -3230,80 +3321,102 @@ Theorem make_init_semantics_fail fs[init_pre_def,init_code_pre_def,propagate_these_def] \\ simp[lookup_fromAList,compile_def,ALOOKUP_APPEND] \\ EVAL_TAC ) - \\ rw[]); + \\ rw[] +QED -Theorem make_init_any_ffi - `(make_init_any gen_gc max_heap bitmaps data_sp coracle jump off k code s).ffi = - (s:('a,'c,'ffi) stackSem$state).ffi` - (fs [make_init_any_def,make_init_opt_def,init_reduce_def] +Theorem make_init_any_ffi: + (make_init_any gen_gc max_heap bitmaps data_sp coracle jump off k code s).ffi = + (s:('a,'c,'ffi) stackSem$state).ffi +Proof + fs [make_init_any_def,make_init_opt_def,init_reduce_def] \\ every_case_tac \\ fs [] \\ imp_res_tac evaluate_init_code_ffi \\ pop_assum (qspec_then `s.ffi` mp_tac) \\ `s with ffi := s.ffi = s` by fs [state_component_equality] - \\ fs [] \\ fs [state_component_equality]); + \\ fs [] \\ fs [state_component_equality] +QED -Theorem make_init_any_bitmaps - `(make_init_any gen_gc max_heap bitmaps data_sp coracle jump off k code s).bitmaps = +Theorem make_init_any_bitmaps: + (make_init_any gen_gc max_heap bitmaps data_sp coracle jump off k code s).bitmaps = if IS_SOME (make_init_opt gen_gc max_heap bitmaps data_sp coracle jump off k code s) - then bitmaps else [4w]` - (fs [make_init_any_def,make_init_opt_def,init_reduce_def] - \\ every_case_tac \\ fs []); - -Theorem make_init_any_use_stack - `(make_init_any gen_gc max_heap bitmaps data_sp coracle jump off k code s).use_stack` - (fs [make_init_any_def,make_init_opt_def,init_reduce_def] - \\ every_case_tac \\ fs []); - -Theorem make_init_any_use_store - `(make_init_any gen_gc max_heap bitmaps data_sp coracle jump off k code s).use_store` - (fs [make_init_any_def,make_init_opt_def,init_reduce_def] - \\ every_case_tac \\ fs []); - -Theorem make_init_any_use_alloc - `~(make_init_any gen_gc max_heap bitmaps data_sp coracle jump off k code s).use_alloc` - (fs [make_init_any_def,make_init_opt_def,init_reduce_def] - \\ every_case_tac \\ fs []); - -Theorem make_init_any_code - `(make_init_any gen_gc max_heap bitmaps data_sp coracle jump off k code s).code = code` - (fs [make_init_any_def,make_init_opt_def,init_reduce_def] - \\ every_case_tac \\ fs []); - -Theorem make_init_any_stack_limit - `LENGTH ((make_init_any gen_gc max_heap (bitmaps:'a word list) data_sp coracle jump off k code s).stack) * - (dimindex (:'a) DIV 8) < dimword (:'a)` - (fs [make_init_any_def] + then bitmaps else [4w] +Proof + fs [make_init_any_def,make_init_opt_def,init_reduce_def] + \\ every_case_tac \\ fs [] +QED + +Theorem make_init_any_use_stack: + (make_init_any gen_gc max_heap bitmaps data_sp coracle jump off k code s).use_stack +Proof + fs [make_init_any_def,make_init_opt_def,init_reduce_def] + \\ every_case_tac \\ fs [] +QED + +Theorem make_init_any_use_store: + (make_init_any gen_gc max_heap bitmaps data_sp coracle jump off k code s).use_store +Proof + fs [make_init_any_def,make_init_opt_def,init_reduce_def] + \\ every_case_tac \\ fs [] +QED + +Theorem make_init_any_use_alloc: + ~(make_init_any gen_gc max_heap bitmaps data_sp coracle jump off k code s).use_alloc +Proof + fs [make_init_any_def,make_init_opt_def,init_reduce_def] + \\ every_case_tac \\ fs [] +QED + +Theorem make_init_any_code: + (make_init_any gen_gc max_heap bitmaps data_sp coracle jump off k code s).code = code +Proof + fs [make_init_any_def,make_init_opt_def,init_reduce_def] + \\ every_case_tac \\ fs [] +QED + +Theorem make_init_any_stack_limit: + LENGTH ((make_init_any gen_gc max_heap (bitmaps:'a word list) data_sp coracle jump off k code s).stack) * + (dimindex (:'a) DIV 8) < dimword (:'a) +Proof + fs [make_init_any_def] \\ reverse (every_case_tac \\ fs [LENGTH_read_mem]) \\ fs [make_init_opt_def] \\ reverse (every_case_tac \\ fs [LENGTH_read_mem]) \\ fs [init_prop_def] \\ fs [dimword_def] \\ fs [DIV_LT_X] \\ match_mp_tac LESS_EQ_LESS_TRANS \\ qexists_tac `8 * dimindex (:'a)` \\ fs [] - \\ fs [X_LT_EXP_X_IFF]); + \\ fs [X_LT_EXP_X_IFF] +QED -Theorem make_init_any_compile_oracle - `(make_init_any ggc max_heap bitmaps data_sp coracle jump off k code s).compile_oracle = coracle` - (fs [make_init_any_def,make_init_opt_def,init_reduce_def] - \\ every_case_tac \\ fs []); +Theorem make_init_any_compile_oracle: + (make_init_any ggc max_heap bitmaps data_sp coracle jump off k code s).compile_oracle = coracle +Proof + fs [make_init_any_def,make_init_opt_def,init_reduce_def] + \\ every_case_tac \\ fs [] +QED (* -Theorem make_init_any_data_buffer - `(make_init_any ggc max_heap bitmaps data_sp coracle jump off k code s).data_buffer = - the correct thing on the success branch (which needs to be set on the fail branch too)` - (fs [make_init_any_def,make_init_opt_def,init_reduce_def] - \\ every_case_tac \\ fs []); +Theorem make_init_any_data_buffer: + (make_init_any ggc max_heap bitmaps data_sp coracle jump off k code s).data_buffer = + the correct thing on the success branch (which needs to be set on the fail branch too) +Proof + fs [make_init_any_def,make_init_opt_def,init_reduce_def] + \\ every_case_tac \\ fs [] +QED *) (* Syntactic *) -Theorem FST_prog_comp[simp] - `FST (prog_comp jump off k pp) = FST pp` - (Cases_on`pp` \\ EVAL_TAC); - -Theorem stack_remove_lab_pres ` - ∀jump off k p. - extract_labels p = extract_labels (comp jump off k p)` - (ho_match_mp_tac comp_ind>>Cases_on`p`>>rw[]>> +Theorem FST_prog_comp[simp]: + FST (prog_comp jump off k pp) = FST pp +Proof + Cases_on`pp` \\ EVAL_TAC +QED + +Theorem stack_remove_lab_pres: + ∀jump off k p. + extract_labels p = extract_labels (comp jump off k p) +Proof + ho_match_mp_tac comp_ind>>Cases_on`p`>>rw[]>> once_rewrite_tac [comp_def]>>fs[extract_labels_def]>> TRY(IF_CASES_TAC)>> fs[extract_labels_def,stack_store_def,stack_load_def] @@ -3328,10 +3441,11 @@ Theorem stack_remove_lab_pres ` fs[extract_labels_def]>> first_assum match_mp_tac>> fs[max_stack_alloc_def]) - >- EVAL_TAC); + >- EVAL_TAC +QED -Theorem stack_remove_comp_stack_asm_name ` - ∀jump off k p. +Theorem stack_remove_comp_stack_asm_name: + ∀jump off k p. stack_asm_name c p ∧ stack_asm_remove (c:'a asm_config) p ∧ addr_offset_ok c 0w ∧ good_dimindex (:'a) ∧ @@ -3344,8 +3458,9 @@ Theorem stack_remove_comp_stack_asm_name ` reg_name (k+1) c ∧ reg_name k c ∧ off = c.addr_offset ⇒ - stack_asm_name c (comp jump off k p)` - (ho_match_mp_tac comp_ind>>Cases_on`p`>>rw[]>> + stack_asm_name c (comp jump off k p) +Proof + ho_match_mp_tac comp_ind>>Cases_on`p`>>rw[]>> simp[Once comp_def]>> rw[]>> fs[stack_asm_name_def,inst_name_def,stack_asm_remove_def,addr_name_def,arith_name_def,reg_imm_name_def,stackLangTheory.list_Seq_def] @@ -3391,10 +3506,10 @@ Theorem stack_remove_comp_stack_asm_name ` simp[Once upshift_def,Once downshift_def]>>rw[]>> fs[stack_asm_name_def,inst_name_def,arith_name_def,reg_imm_name_def,word_offset_def]>> first_x_assum match_mp_tac>>fs[max_stack_alloc_def] - ); +QED -Theorem stack_remove_stack_asm_name ` - EVERY (λ(n,p). stack_asm_name c p) prog ∧ +Theorem stack_remove_stack_asm_name: + EVERY (λ(n,p). stack_asm_name c p) prog ∧ EVERY (λ(n,p). (stack_asm_remove (c:'a asm_config) p)) prog ∧ addr_offset_ok c 0w ∧ good_dimindex (:'a) ∧ @@ -3410,8 +3525,9 @@ Theorem stack_remove_stack_asm_name ` reg_name (k+1) c ∧ reg_name k c ⇒ EVERY (λ(n,p). stack_asm_name c p) - (compile jump c.addr_offset gen_gc max_heap k start prog)` - (rw[compile_def] + (compile jump c.addr_offset gen_gc max_heap k start prog) +Proof + rw[compile_def] >- (fs[labPropsTheory.good_dimindex_def]>>EVAL_TAC>>fs[]>>rw[]>>EVAL_TAC>>fs[reg_name_def]>> pairarg_tac>>fs[asmTheory.offset_ok_def]>> @@ -3419,23 +3535,27 @@ Theorem stack_remove_stack_asm_name ` EVAL_TAC>>fs[]) >> fs[EVERY_MAP,EVERY_MEM,FORALL_PROD,prog_comp_def]>> - metis_tac[stack_remove_comp_stack_asm_name]); + metis_tac[stack_remove_comp_stack_asm_name] +QED -Theorem upshift_downshift_call_args ` - ∀n n0. +Theorem upshift_downshift_call_args: + ∀n n0. call_args (upshift n n0) 1 2 3 4 0 ∧ - call_args (downshift n n0) 1 2 3 4 0` - (completeInduct_on`n0`>> + call_args (downshift n n0) 1 2 3 4 0 +Proof + completeInduct_on`n0`>> simp[Once stack_removeTheory.upshift_def,Once stack_removeTheory.downshift_def]>> strip_tac>>IF_CASES_TAC>> fs[call_args_def]>> - first_assum match_mp_tac>>EVAL_TAC>>fs[]); + first_assum match_mp_tac>>EVAL_TAC>>fs[] +QED -Theorem stack_remove_call_args - `compile jump off gen_gc n k pos p = p' /\ +Theorem stack_remove_call_args: + compile jump off gen_gc n k pos p = p' /\ EVERY (λp. call_args p 1 2 3 4 0) (MAP SND p) ==> - EVERY (λp. call_args p 1 2 3 4 0) (MAP SND p')` - (rw[]>> + EVERY (λp. call_args p 1 2 3 4 0) (MAP SND p') +Proof + rw[]>> unabbrev_all_tac>>fs[]>> EVAL_TAC>> fs[EVERY_MAP,EVERY_MEM,FORALL_PROD,stack_removeTheory.prog_comp_def]>> @@ -3461,6 +3581,7 @@ Theorem stack_remove_call_args first_assum match_mp_tac>> EVAL_TAC>>fs[]>>NO_TAC)>> simp[stack_removeTheory.stack_store_def,stack_removeTheory.stack_load_def,call_args_def,upshift_downshift_call_args] - >- EVAL_TAC)); + >- EVAL_TAC) +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/stack_to_labProofScript.sml b/compiler/backend/proofs/stack_to_labProofScript.sml index 332c29698f..f427a133a5 100644 --- a/compiler/backend/proofs/stack_to_labProofScript.sml +++ b/compiler/backend/proofs/stack_to_labProofScript.sml @@ -21,25 +21,33 @@ val get_reg_value_def = targetSemTheory.get_reg_value_def; (* TODO: move *) -Theorem word_sh_word_shift - `word_sh a b c = SOME z ⇒ z = word_shift a b c` - (EVAL_TAC >> srw_tac[][] >> every_case_tac >> full_simp_tac(srw_ss())[] >> - EVAL_TAC >> srw_tac[][]); - -Theorem assert_T[simp] - `assert T s = s` - (srw_tac[][assert_def,state_component_equality]); - -Theorem word_cmp_word_cmp - `(word_cmp cmp (Word w1) (Word w2) = SOME T) ⇔ word_cmp cmp w1 w2` - (Cases_on`cmp`>>srw_tac[][labSemTheory.word_cmp_def]>> - srw_tac[][asmTheory.word_cmp_def]); - -Theorem asm_fetch_aux_no_label - `∀pc code. - asm_fetch_aux pc code = SOME (Label l1 l2 x) ⇒ F` - (ho_match_mp_tac asm_fetch_aux_ind >> - srw_tac[][asm_fetch_aux_def] >> Cases_on`y`>>full_simp_tac(srw_ss())[]); +Theorem word_sh_word_shift: + word_sh a b c = SOME z ⇒ z = word_shift a b c +Proof + EVAL_TAC >> srw_tac[][] >> every_case_tac >> full_simp_tac(srw_ss())[] >> + EVAL_TAC >> srw_tac[][] +QED + +Theorem assert_T[simp]: + assert T s = s +Proof + srw_tac[][assert_def,state_component_equality] +QED + +Theorem word_cmp_word_cmp: + (word_cmp cmp (Word w1) (Word w2) = SOME T) ⇔ word_cmp cmp w1 w2 +Proof + Cases_on`cmp`>>srw_tac[][labSemTheory.word_cmp_def]>> + srw_tac[][asmTheory.word_cmp_def] +QED + +Theorem asm_fetch_aux_no_label: + ∀pc code. + asm_fetch_aux pc code = SOME (Label l1 l2 x) ⇒ F +Proof + ho_match_mp_tac asm_fetch_aux_ind >> + srw_tac[][asm_fetch_aux_def] >> Cases_on`y`>>full_simp_tac(srw_ss())[] +QED val dest_to_loc_def = Define` dest_to_loc regs dest = @@ -49,32 +57,42 @@ val dest_to_loc'_def = Define` dest_to_loc' regs dest = case dest of INL p => p | INR r => case regs r of Loc loc _ => loc`; -Theorem find_code_lookup - `find_code dest regs code = SOME p ⇒ +Theorem find_code_lookup: + find_code dest regs code = SOME p ⇒ lookup (dest_to_loc regs dest) code = SOME p ∧ - (∀r. dest = INR r ⇒ r ∈ FDOM regs)` - (Cases_on`dest`>>srw_tac[][find_code_def,dest_to_loc_def] >> - every_case_tac >> full_simp_tac(srw_ss())[] >> full_simp_tac(srw_ss())[FLOOKUP_DEF] >> srw_tac[][]); - -Theorem not_is_Label_compile_jump[simp] - `is_Label (compile_jump dest) ⇔ F` - (Cases_on`dest`>>EVAL_TAC); - -Theorem word_cmp_not_NONE[simp] - `word_cmp cmp (Word w1) (Word w2) ≠ NONE` - (Cases_on`cmp`>>srw_tac[][labSemTheory.word_cmp_def]); - -Theorem word_cmp_negate[simp] - `asm$word_cmp (negate cmp) w1 w2 ⇔ ¬word_cmp cmp w1 w2` - (Cases_on`cmp`>>EVAL_TAC); - -Theorem word_cmp_negate[simp] - `labSem$word_cmp (negate cmp) (w1) (w2) = - OPTION_MAP $~ (labSem$word_cmp cmp (w1) (w2))` - (Cases_on`word_cmp cmp (w1) (w2)`>>fs[]>> + (∀r. dest = INR r ⇒ r ∈ FDOM regs) +Proof + Cases_on`dest`>>srw_tac[][find_code_def,dest_to_loc_def] >> + every_case_tac >> full_simp_tac(srw_ss())[] >> full_simp_tac(srw_ss())[FLOOKUP_DEF] >> srw_tac[][] +QED + +Theorem not_is_Label_compile_jump[simp]: + is_Label (compile_jump dest) ⇔ F +Proof + Cases_on`dest`>>EVAL_TAC +QED + +Theorem word_cmp_not_NONE[simp]: + word_cmp cmp (Word w1) (Word w2) ≠ NONE +Proof + Cases_on`cmp`>>srw_tac[][labSemTheory.word_cmp_def] +QED + +Theorem word_cmp_negate[simp]: + asm$word_cmp (negate cmp) w1 w2 ⇔ ¬word_cmp cmp w1 w2 +Proof + Cases_on`cmp`>>EVAL_TAC +QED + +Theorem word_cmp_negate[simp]: + labSem$word_cmp (negate cmp) (w1) (w2) = + OPTION_MAP $~ (labSem$word_cmp cmp (w1) (w2)) +Proof + Cases_on`word_cmp cmp (w1) (w2)`>>fs[]>> Cases_on`word_cmp (negate cmp) (w1) (w2)`>>fs[] >> Cases_on`w1`>>Cases_on`w2`>>fs[word_cmp_def]>> - Cases_on`cmp`>>fs[word_cmp_def]>>rw[]); + Cases_on`cmp`>>fs[word_cmp_def]>>rw[] +QED (* -- Lemmas about code_installed, loc_to_pc and asm_fetch_aux -- *) @@ -88,12 +106,14 @@ val code_installed_def = Define` asm_fetch_aux n code = SOME x ∧ code_installed (n+1) xs code)`; -Theorem code_installed_append_imp - `∀l1 pc l2 code. code_installed pc (l1 ++ l2) code ⇒ +Theorem code_installed_append_imp: + ∀l1 pc l2 code. code_installed pc (l1 ++ l2) code ⇒ code_installed pc l1 code ∧ - code_installed (pc+LENGTH (FILTER ($~ o is_Label) l1)) l2 code` - (Induct>>simp[code_installed_def]>>srw_tac[][] >> - res_tac >> fsrw_tac[ARITH_ss][ADD1]); + code_installed (pc+LENGTH (FILTER ($~ o is_Label) l1)) l2 code +Proof + Induct>>simp[code_installed_def]>>srw_tac[][] >> + res_tac >> fsrw_tac[ARITH_ss][ADD1] +QED val code_installed_get_labels_IMP = Q.prove( `!e n q pc. @@ -140,11 +160,12 @@ val asm_fetch_aux_SOME_isPREFIX = Q.prove(` rw[]>>fs[IS_PREFIX_APPEND]>> metis_tac[asm_fetch_aux_SOME_append]); -Theorem loc_to_pc_APPEND ` - ∀n m code pc code2. +Theorem loc_to_pc_APPEND: + ∀n m code pc code2. loc_to_pc n m code = SOME pc ⇒ - loc_to_pc n m (code ++ code2) = SOME pc` - (ho_match_mp_tac loc_to_pc_ind>>rw[] + loc_to_pc n m (code ++ code2) = SOME pc +Proof + ho_match_mp_tac loc_to_pc_ind>>rw[] >- fs[loc_to_pc_def] >> @@ -158,34 +179,41 @@ Theorem loc_to_pc_APPEND ` rw[]>>rfs[]>>qpat_x_assum`_=SOME pc` mp_tac>> simp[Once loc_to_pc_def]>>fs[]>> TOP_CASE_TAC>>rw[]>> - fs[]); + fs[] +QED -Theorem code_installed_APPEND ` - ∀ls pc code code2. +Theorem code_installed_APPEND: + ∀ls pc code code2. code_installed pc ls code ==> - code_installed pc ls (code ++ code2)` - (Induct>>simp[code_installed_def]>> rw[] + code_installed pc ls (code ++ code2) +Proof + Induct>>simp[code_installed_def]>> rw[] >- (TOP_CASE_TAC>>fs[is_Label_def]>> metis_tac[loc_to_pc_APPEND]) >> - metis_tac[asm_fetch_aux_SOME_append]); + metis_tac[asm_fetch_aux_SOME_append] +QED -Theorem code_installed_isPREFIX ` - ∀ls pc code code2. +Theorem code_installed_isPREFIX: + ∀ls pc code code2. code_installed pc ls code ∧ code ≼ code2 ==> - code_installed pc ls code2` - (rw[]>> + code_installed pc ls code2 +Proof + rw[]>> fs[IS_PREFIX_APPEND]>> - metis_tac[code_installed_APPEND]); + metis_tac[code_installed_APPEND] +QED -Theorem loc_to_pc_isPREFIX ` - ∀n m code pc code2. +Theorem loc_to_pc_isPREFIX: + ∀n m code pc code2. loc_to_pc n m code = SOME pc /\ code ≼ code2 ==> - loc_to_pc n m code2 = SOME pc` - (rw[]>>fs[IS_PREFIX_APPEND]>>metis_tac[loc_to_pc_APPEND]); + loc_to_pc n m code2 = SOME pc +Proof + rw[]>>fs[IS_PREFIX_APPEND]>>metis_tac[loc_to_pc_APPEND] +QED val MAP_prog_to_section_FST = Q.prove(` MAP (λs. case s of Section n v => n) (MAP prog_to_section prog) = @@ -193,31 +221,36 @@ val MAP_prog_to_section_FST = Q.prove(` match_mp_tac LIST_EQ>>rw[EL_MAP]>>Cases_on`EL x prog`>>fs[prog_to_section_def]>> pairarg_tac>>fs[]); -Theorem MAP_prog_to_section_Section_num ` - MAP Section_num (MAP prog_to_section prog) = - MAP FST prog` - (fs[GSYM MAP_prog_to_section_FST, MAP_EQ_f]>> - Cases>>fs[]); +Theorem MAP_prog_to_section_Section_num: + MAP Section_num (MAP prog_to_section prog) = + MAP FST prog +Proof + fs[GSYM MAP_prog_to_section_FST, MAP_EQ_f]>> + Cases>>fs[] +QED (* Appending on the other side *) -Theorem asm_fetch_aux_SOME_append2 ` - ∀pc code l code2. +Theorem asm_fetch_aux_SOME_append2: + ∀pc code l code2. asm_fetch_aux pc code2 = SOME l ⇒ asm_fetch_aux - (LENGTH (FLAT (MAP (FILTER ($~ o is_Label) o Section_lines) code))+ pc) (code++code2) = SOME l` - (Induct_on`code`>>fs[]>> + (LENGTH (FLAT (MAP (FILTER ($~ o is_Label) o Section_lines) code))+ pc) (code++code2) = SOME l +Proof + Induct_on`code`>>fs[]>> Cases>> - Induct_on`l`>>fs[asm_fetch_aux_def]>>rw[]>>fs[ADD1]); + Induct_on`l`>>fs[asm_fetch_aux_def]>>rw[]>>fs[ADD1] +QED (* loc_to_pc on the other side *) -Theorem loc_to_pc_append2 ` - ∀k ll code code2 pc. +Theorem loc_to_pc_append2: + ∀k ll code code2 pc. ¬MEM k (MAP Section_num code) /\ EVERY sec_labels_ok code ∧ loc_to_pc k ll code2 = SOME pc ⇒ loc_to_pc k ll (code++code2) = - SOME (pc + (LENGTH (FLAT (MAP (FILTER ($~ o is_Label) o Section_lines) code))))` - (Induct_on`code`>>fs[]>> + SOME (pc + (LENGTH (FLAT (MAP (FILTER ($~ o is_Label) o Section_lines) code)))) +Proof + Induct_on`code`>>fs[]>> Cases>>Induct_on`l`>>fs[] >- fs[loc_to_pc_def] @@ -227,18 +260,20 @@ Theorem loc_to_pc_append2 ` (simp[Once loc_to_pc_def]>>fs[]) >> simp[Once loc_to_pc_def]>> - res_tac>>fs[]); + res_tac>>fs[] +QED -Theorem code_installed_append2 ` - ∀lines pc c1 c2 k. +Theorem code_installed_append2: + ∀lines pc c1 c2 k. ¬MEM k (MAP Section_num c1) /\ EVERY sec_labels_ok c1 ∧ EVERY (sec_label_ok k) lines ∧ code_installed pc lines c2 ==> code_installed (LENGTH (FLAT (MAP (FILTER ($~ o is_Label) o Section_lines) c1))+ pc) - lines (c1 ++ c2)` - (Induct>>fs[code_installed_def]>> + lines (c1 ++ c2) +Proof + Induct>>fs[code_installed_def]>> rpt strip_tac>> IF_CASES_TAC >- @@ -256,21 +291,24 @@ Theorem code_installed_append2 ` fs[]>> first_x_assum drule>> rpt(disch_then drule)>> - fs[]); + fs[] +QED -Theorem ALOOKUP_PARTITION ` - ∀ls n v. +Theorem ALOOKUP_PARTITION: + ∀ls n v. ALOOKUP ls n = SOME v ⇒ ∃ls1 ls2. ls = ls1 ++ [(n,v)] ++ ls2 ∧ - ¬MEM n (MAP FST ls1)` - (Induct>>fs[]>>Cases>>fs[]>>rw[] + ¬MEM n (MAP FST ls1) +Proof + Induct>>fs[]>>Cases>>fs[]>>rw[] >- (qexists_tac`[]`>> simp[]) >> first_x_assum drule>>rw[]>> - qexists_tac`(q,r)::ls1`>>simp[]); + qexists_tac`(q,r)::ls1`>>simp[] +QED val code_installed'_def = Define ` (code_installed' n [] code ⇔ T) /\ @@ -278,46 +316,54 @@ val code_installed'_def = Define ` if is_Label x then code_installed' n xs code else asm_fetch_aux n code = SOME x ∧ code_installed' (n + 1) xs code)`; -Theorem code_installed'_cons_label - `!lines pos. +Theorem code_installed'_cons_label: + !lines pos. is_Label h ==> code_installed' pos lines (Section n (h::xs)::other) = - code_installed' pos lines (Section n xs::other)` - (Induct \\ fs [code_installed'_def] - \\ rw [] \\ fs [labSemTheory.asm_fetch_aux_def]); - -Theorem code_installed'_cons_non_label - `!lines pos. + code_installed' pos lines (Section n xs::other) +Proof + Induct \\ fs [code_installed'_def] + \\ rw [] \\ fs [labSemTheory.asm_fetch_aux_def] +QED + +Theorem code_installed'_cons_non_label = Q.prove(` + !lines pos. ~is_Label h ==> code_installed' (pos+1) lines (Section n (h::xs)::other) = - code_installed' pos lines (Section n xs::other)` - (Induct \\ fs [code_installed'_def] + code_installed' pos lines (Section n xs::other)`, + Induct \\ fs [code_installed'_def] \\ rw [] \\ fs [labSemTheory.asm_fetch_aux_def]) |> Q.SPECL [`lines`,`0`] |> SIMP_RULE std_ss []; -Theorem code_installed'_simp - `!lines. code_installed' 0 lines (Section n (lines ++ rest)::other)` - (Induct \\ fs [code_installed'_def] +Theorem code_installed'_simp: + !lines. code_installed' 0 lines (Section n (lines ++ rest)::other) +Proof + Induct \\ fs [code_installed'_def] \\ fs [labSemTheory.asm_fetch_aux_def] \\ rpt strip_tac \\ IF_CASES_TAC - \\ fs [code_installed'_cons_label,code_installed'_cons_non_label]); + \\ fs [code_installed'_cons_label,code_installed'_cons_non_label] +QED -Theorem loc_to_pc_skip_section - `!lines. +Theorem loc_to_pc_skip_section: + !lines. n <> p ==> loc_to_pc n 0 (Section p lines :: xs) = case loc_to_pc n 0 xs of | NONE => NONE - | SOME k => SOME (k + LENGTH (FILTER (\x. ~(is_Label x)) lines))` - (Induct \\ once_rewrite_tac [labSemTheory.loc_to_pc_def] \\ fs [] + | SOME k => SOME (k + LENGTH (FILTER (\x. ~(is_Label x)) lines)) +Proof + Induct \\ once_rewrite_tac [labSemTheory.loc_to_pc_def] \\ fs [] THEN1 (every_case_tac \\ fs []) - \\ strip_tac \\ IF_CASES_TAC \\ fs [] \\ CASE_TAC \\ fs []); + \\ strip_tac \\ IF_CASES_TAC \\ fs [] \\ CASE_TAC \\ fs [] +QED -Theorem asm_fetch_aux_add - `!ys pc rest. +Theorem asm_fetch_aux_add: + !ys pc rest. asm_fetch_aux (pc + LENGTH (FILTER (λx. ¬is_Label x) ys)) - (Section pos ys::rest) = asm_fetch_aux pc rest` - (Induct \\ fs [labSemTheory.asm_fetch_aux_def,ADD1]); + (Section pos ys::rest) = asm_fetch_aux pc rest +Proof + Induct \\ fs [labSemTheory.asm_fetch_aux_def,ADD1] +QED val labs_correct_def = Define ` (labs_correct n [] code ⇔ T) /\ @@ -330,25 +376,29 @@ val labs_correct_def = Define ` val is_Label_def = labSemTheory.is_Label_def -Theorem code_installed_eq - `!pc xs code. +Theorem code_installed_eq: + !pc xs code. code_installed pc xs code <=> - code_installed' pc xs code /\ labs_correct pc xs code` - (Induct_on `xs` + code_installed' pc xs code /\ labs_correct pc xs code +Proof + Induct_on `xs` \\ fs [code_installed_def,code_installed'_def,labs_correct_def] \\ ntac 3 strip_tac \\ fs [] \\ IF_CASES_TAC \\ fs [] \\ Cases_on `h` \\ fs [is_Label_def] - \\ rw [] \\ eq_tac \\ fs []); + \\ rw [] \\ eq_tac \\ fs [] +QED -Theorem code_installed_cons - `!xs ys pos pc. +Theorem code_installed_cons: + !xs ys pos pc. code_installed' pc xs rest ==> code_installed' (pc + LENGTH (FILTER (λx. ¬is_Label x) ys)) xs - (Section pos ys :: rest)` - (Induct \\ fs [] \\ fs [code_installed'_def] + (Section pos ys :: rest) +Proof + Induct \\ fs [] \\ fs [code_installed'_def] \\ ntac 4 strip_tac \\ IF_CASES_TAC \\ fs [] - \\ rw [] \\ res_tac \\ fs [asm_fetch_aux_add]); + \\ rw [] \\ res_tac \\ fs [asm_fetch_aux_add] +QED val code_installed_prog_to_section_lemma = Q.prove( `!prog4 n prog3. @@ -368,12 +418,13 @@ val code_installed_prog_to_section_lemma = Q.prove( val extract_labels_def = labPropsTheory.extract_labels_def val extract_labels_append = labPropsTheory.extract_labels_append -Theorem labs_correct_hd ` - ∀extra l. +Theorem labs_correct_hd: + ∀extra l. ALL_DISTINCT (extract_labels (extra++l)) ∧ EVERY (λ(l1,l2). l1 = n ∧ l2 ≠ 0) (extract_labels (extra++l)) ⇒ - labs_correct (LENGTH (FILTER (\x. ~(is_Label x)) extra)) l (Section n (extra++l) ::code)` - (Induct_on`l`>>fs[labs_correct_def]>>rw[] + labs_correct (LENGTH (FILTER (\x. ~(is_Label x)) extra)) l (Section n (extra++l) ::code) +Proof + Induct_on`l`>>fs[labs_correct_def]>>rw[] >- (first_x_assum(qspec_then `extra++[h]` mp_tac)>> Cases_on`h`>>fs[extract_labels_def,labSemTheory.is_Label_def,FILTER_APPEND]>> @@ -395,7 +446,8 @@ Theorem labs_correct_hd ` >> first_x_assum(qspec_then `extra++[h]` mp_tac)>> Cases_on`h`>>fs[extract_labels_def,FILTER_APPEND]>> - metis_tac[APPEND_ASSOC,APPEND]); + metis_tac[APPEND_ASSOC,APPEND] +QED val labels_ok_def = Define` labels_ok code ⇔ @@ -406,13 +458,14 @@ val labels_ok_def = Define` EVERY (λ(l1,l2). l1 = n ∧ l2 ≠ 0) labs ∧ ALL_DISTINCT labs) code`; -Theorem labels_ok_imp - `∀code. +Theorem labels_ok_imp: + ∀code. labels_ok code ⇒ EVERY sec_labels_ok code ∧ ALL_DISTINCT (MAP Section_num code) ∧ - EVERY (ALL_DISTINCT o extract_labels o Section_lines) code` - (Induct_on`code` \\ simp[] + EVERY (ALL_DISTINCT o extract_labels o Section_lines) code +Proof + Induct_on`code` \\ simp[] \\ Cases \\ simp[] \\ fs[labels_ok_def] \\ strip_tac \\ fs[] @@ -423,16 +476,18 @@ Theorem labels_ok_imp \\ first_x_assum(qspec_then`sec`mp_tac) \\ simp[] \\ CASE_TAC \\ fs[] ) \\ Induct_on`l` \\ fs[] - \\ Cases \\ fs[]); + \\ Cases \\ fs[] +QED -Theorem labels_ok_labs_correct ` - ∀code. +Theorem labels_ok_labs_correct: + ∀code. labels_ok code ⇒ EVERY ( λs. case s of Section n lines => case loc_to_pc n 0 code of SOME pc => labs_correct pc lines code - | _ => T) code` - (Induct>>fs[labels_ok_def]>>Cases_on`h`>>fs[]>> + | _ => T) code +Proof + Induct>>fs[labels_ok_def]>>Cases_on`h`>>fs[]>> rw[] >- (once_rewrite_tac[labSemTheory.loc_to_pc_def]>>fs[]>> @@ -491,23 +546,27 @@ Theorem labels_ok_labs_correct ` >- (Cases_on`h`>>fs[ALL_DISTINCT,extract_labels_def]) >> - fs[]); + fs[] +QED -Theorem labs_correct_append ` - ∀ls pc. +Theorem labs_correct_append: + ∀ls pc. labs_correct pc (ls ++ rest) code ⇒ - labs_correct pc ls code` - (Induct>>fs[labs_correct_def]>>rw[]); + labs_correct pc ls code +Proof + Induct>>fs[labs_correct_def]>>rw[] +QED -Theorem code_installed_prog_to_section - `!prog4 n prog3. +Theorem code_installed_prog_to_section: + !prog4 n prog3. labels_ok (MAP prog_to_section prog4) ∧ ALOOKUP prog4 n = SOME prog3 ==> ?pc. code_installed pc (append (FST (flatten prog3 n (next_lab prog3 1)))) (MAP prog_to_section prog4) /\ - loc_to_pc n 0 (MAP prog_to_section prog4) = SOME pc` - (rpt strip_tac \\ fs [code_installed_eq] + loc_to_pc n 0 (MAP prog_to_section prog4) = SOME pc +Proof + rpt strip_tac \\ fs [code_installed_eq] \\ drule code_installed_prog_to_section_lemma \\ strip_tac \\ asm_exists_tac \\ fs [] \\ imp_res_tac labels_ok_labs_correct @@ -517,7 +576,8 @@ Theorem code_installed_prog_to_section \\ impl_tac >- metis_tac[] \\ BasicProvers.TOP_CASE_TAC>>fs[stack_to_labTheory.prog_to_section_def] \\ pairarg_tac>>fs[]>>rveq>>fs[] - \\ metis_tac[labs_correct_append]); + \\ metis_tac[labs_correct_append] +QED (* -- End code_installed lemmas -- *) @@ -561,81 +621,104 @@ val state_rel_def = Define` ¬s.use_store ∧ ¬s.use_alloc`; -Theorem loc_check_IMP_loc_to_pc - `loc_check s.code (l1,l2) /\ state_rel s t1 ==> - ?v. loc_to_pc l1 l2 t1.code = SOME v` - (rw [loc_check_def] \\ fs [state_rel_def,EXTENSION]>> +Theorem loc_check_IMP_loc_to_pc: + loc_check s.code (l1,l2) /\ state_rel s t1 ==> + ?v. loc_to_pc l1 l2 t1.code = SOME v +Proof + rw [loc_check_def] \\ fs [state_rel_def,EXTENSION]>> qpat_x_assum`!x._ ⇔ _`(qspec_then `l1` assume_tac)>> rfs[]>> fs [domain_lookup] \\ res_tac \\ fs [] - \\ imp_res_tac code_installed_get_labels_IMP \\ fs []); - -Theorem state_rel_dec_clock - `state_rel s t ⇒ state_rel (dec_clock s) (dec_clock t)` - (srw_tac[][state_rel_def,stackSemTheory.dec_clock_def,labSemTheory.dec_clock_def] >> - metis_tac[]); - -Theorem state_rel_with_pc - `state_rel s t ⇒ state_rel s (upd_pc pc t)` - (srw_tac[][state_rel_def,upd_pc_def] >> - metis_tac[]); - -Theorem state_rel_with_clock - `state_rel s t ⇒ state_rel (s with clock := k) (t with clock := k)` - (srw_tac[][state_rel_def] >> metis_tac[]); - -Theorem set_var_upd_reg - `state_rel s t ⇒ - state_rel (set_var a b s) (upd_reg a b t)` - (srw_tac[][state_rel_def,upd_reg_def,set_var_def,FUN_EQ_THM,APPLY_UPDATE_THM,FLOOKUP_UPDATE] >> - srw_tac[][]>>full_simp_tac(srw_ss())[]>>rev_full_simp_tac(srw_ss())[] \\ metis_tac []); - -Theorem set_var_Word_upd_reg[simp] - `state_rel s t ⇒ - state_rel (set_var a (Word b) s) (upd_reg a (Word b) t)` - (METIS_TAC[set_var_upd_reg,wordSemTheory.is_word_def]) - -Theorem set_fp_var_upd_fp_reg - `state_rel s t ⇒ - state_rel (set_fp_var a b s) (upd_fp_reg a b t)` - (srw_tac[][state_rel_def,upd_fp_reg_def,set_fp_var_def,FUN_EQ_THM,APPLY_UPDATE_THM,FLOOKUP_UPDATE] >> - srw_tac[][]>>full_simp_tac(srw_ss())[]>>rev_full_simp_tac(srw_ss())[] \\ metis_tac []) - -Theorem mem_store_upd_mem - `state_rel s t ∧ mem_store x y s = SOME s1 ⇒ - state_rel s1 (upd_mem x y t)` - (srw_tac[][state_rel_def,upd_mem_def,stackSemTheory.mem_store_def,FUN_EQ_THM,APPLY_UPDATE_THM] >> + \\ imp_res_tac code_installed_get_labels_IMP \\ fs [] +QED + +Theorem state_rel_dec_clock: + state_rel s t ⇒ state_rel (dec_clock s) (dec_clock t) +Proof + srw_tac[][state_rel_def,stackSemTheory.dec_clock_def,labSemTheory.dec_clock_def] >> + metis_tac[] +QED + +Theorem state_rel_with_pc: + state_rel s t ⇒ state_rel s (upd_pc pc t) +Proof + srw_tac[][state_rel_def,upd_pc_def] >> + metis_tac[] +QED + +Theorem state_rel_with_clock: + state_rel s t ⇒ state_rel (s with clock := k) (t with clock := k) +Proof + srw_tac[][state_rel_def] >> metis_tac[] +QED + +Theorem set_var_upd_reg: + state_rel s t ⇒ + state_rel (set_var a b s) (upd_reg a b t) +Proof + srw_tac[][state_rel_def,upd_reg_def,set_var_def,FUN_EQ_THM,APPLY_UPDATE_THM,FLOOKUP_UPDATE] >> + srw_tac[][]>>full_simp_tac(srw_ss())[]>>rev_full_simp_tac(srw_ss())[] \\ metis_tac [] +QED + +Theorem set_var_Word_upd_reg[simp]: + state_rel s t ⇒ + state_rel (set_var a (Word b) s) (upd_reg a (Word b) t) +Proof + METIS_TAC[set_var_upd_reg,wordSemTheory.is_word_def] +QED + +Theorem set_fp_var_upd_fp_reg: + state_rel s t ⇒ + state_rel (set_fp_var a b s) (upd_fp_reg a b t) +Proof + srw_tac[][state_rel_def,upd_fp_reg_def,set_fp_var_def,FUN_EQ_THM,APPLY_UPDATE_THM,FLOOKUP_UPDATE] >> + srw_tac[][]>>full_simp_tac(srw_ss())[]>>rev_full_simp_tac(srw_ss())[] \\ metis_tac [] +QED + +Theorem mem_store_upd_mem: + state_rel s t ∧ mem_store x y s = SOME s1 ⇒ + state_rel s1 (upd_mem x y t) +Proof + srw_tac[][state_rel_def,upd_mem_def,stackSemTheory.mem_store_def,FUN_EQ_THM,APPLY_UPDATE_THM] >> srw_tac[][APPLY_UPDATE_THM] >> rev_full_simp_tac(srw_ss())[] >> fs[] >- metis_tac[] >> - first_x_assum(qspec_then`k` assume_tac)>>rfs[]); + first_x_assum(qspec_then`k` assume_tac)>>rfs[] +QED -Theorem state_rel_read_reg_FLOOKUP_regs - `state_rel s t ∧ +Theorem state_rel_read_reg_FLOOKUP_regs: + state_rel s t ∧ FLOOKUP s.regs x = SOME y ⇒ - y = read_reg x t` - (srw_tac[][state_rel_def]>>full_simp_tac(srw_ss())[FLOOKUP_DEF]); + y = read_reg x t +Proof + srw_tac[][state_rel_def]>>full_simp_tac(srw_ss())[FLOOKUP_DEF] +QED -Theorem state_rel_read_fp_reg_FLOOKUP_fp_regs - `state_rel s t ∧ +Theorem state_rel_read_fp_reg_FLOOKUP_fp_regs: + state_rel s t ∧ get_fp_var n s = SOME x ⇒ - x = read_fp_reg n t` - (srw_tac[][state_rel_def,get_fp_var_def,read_fp_reg_def]>> - full_simp_tac(srw_ss())[FLOOKUP_DEF]); - -Theorem state_rel_get_var_imm - `state_rel s t ∧ + x = read_fp_reg n t +Proof + srw_tac[][state_rel_def,get_fp_var_def,read_fp_reg_def]>> + full_simp_tac(srw_ss())[FLOOKUP_DEF] +QED + +Theorem state_rel_get_var_imm: + state_rel s t ∧ get_var_imm r s = SOME x ⇒ - reg_imm r t = x` - (Cases_on`r` \\ srw_tac[][get_var_imm_def] \\ full_simp_tac(srw_ss())[get_var_def] - \\ metis_tac[state_rel_read_reg_FLOOKUP_regs]) - -Theorem inst_correct - `inst i s1 = SOME s2 ∧ + reg_imm r t = x +Proof + Cases_on`r` \\ srw_tac[][get_var_imm_def] \\ full_simp_tac(srw_ss())[get_var_def] + \\ metis_tac[state_rel_read_reg_FLOOKUP_regs] +QED + +Theorem inst_correct: + inst i s1 = SOME s2 ∧ state_rel s1 t1 ⇒ - state_rel s2 (asm_inst i t1)` - (simp[inst_def] >> + state_rel s2 (asm_inst i t1) +Proof + simp[inst_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][assign_def,word_exp_def] >> srw_tac[][] >> full_simp_tac(srw_ss())[LET_THM,get_vars_def,get_var_def] >> @@ -729,22 +812,26 @@ Theorem inst_correct \\ disch_then (assume_tac o SYM) \\ fs[] ) \\ `s1.memory = t1.mem ∧ t1.mem_domain = s1.mdomain ∧ t1.be = s1.be` by fs[state_rel_def] \\ fs[] \\ strip_tac) >> - fs[get_fp_var_def]>>res_tac>>fs[]); + fs[get_fp_var_def]>>res_tac>>fs[] +QED -Theorem flatten_leq - `∀x y z. z ≤ SND (SND (flatten x y z))` - (ho_match_mp_tac flatten_ind >> srw_tac[][]>> +Theorem flatten_leq: + ∀x y z. z ≤ SND (SND (flatten x y z)) +Proof + ho_match_mp_tac flatten_ind >> srw_tac[][]>> ONCE_REWRITE_TAC[flatten_def] >> CASE_TAC >> simp[] >> full_simp_tac(srw_ss())[] >> TRY CASE_TAC >> full_simp_tac(srw_ss())[] >> every_case_tac >> fs[] >> pairarg_tac >> fs[] >> TRY pairarg_tac >> full_simp_tac(srw_ss())[] >> - rw[]); + rw[] +QED -Theorem no_ret_correct - `∀p y z. FST(SND(flatten p y z)) ⇒ ∀s. IS_SOME (FST (evaluate (p,s)))` - (ho_match_mp_tac flatten_ind >> rw[] >> +Theorem no_ret_correct: + ∀p y z. FST(SND(flatten p y z)) ⇒ ∀s. IS_SOME (FST (evaluate (p,s))) +Proof + ho_match_mp_tac flatten_ind >> rw[] >> pop_assum mp_tac \\ Cases_on`p`>>simp[Once flatten_def,stackSemTheory.evaluate_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> @@ -754,20 +841,23 @@ Theorem no_ret_correct TRY pairarg_tac >> fs[] >> rw[] >> fs[stackSemTheory.evaluate_def] >> fs[Q.SPEC`Skip`flatten_def] >> every_case_tac >> fs[] >> - METIS_TAC[NOT_SOME_NONE,FST,option_CASES]); + METIS_TAC[NOT_SOME_NONE,FST,option_CASES] +QED val s = ``s:('a,'c,'ffi) labSem$state``; -Theorem compile_jump_correct - `asm_fetch_aux pc code = SOME (compile_jump dest) ∧ +Theorem compile_jump_correct: + asm_fetch_aux pc code = SOME (compile_jump dest) ∧ loc_to_pc (dest_to_loc' regs dest) 0 code = SOME pc' ∧ (∀r. dest = INR r ⇒ ∃p. read_reg r s = Loc p 0) ∧ ^s.pc = pc ∧ s.code = code ∧ s.regs = regs ∧ s.clock ≠ 0 ⇒ - evaluate s = evaluate (upd_pc pc' (dec_clock s))` - (Cases_on`dest`>>srw_tac[][compile_jump_def,dest_to_loc'_def] >> + evaluate s = evaluate (upd_pc pc' (dec_clock s)) +Proof + Cases_on`dest`>>srw_tac[][compile_jump_def,dest_to_loc'_def] >> simp[Once labSemTheory.evaluate_def,asm_fetch_def,get_pc_value_def] >> - CASE_TAC >> full_simp_tac(srw_ss())[]); + CASE_TAC >> full_simp_tac(srw_ss())[] +QED val _ = Datatype` result_view = Vloc num num | Vtimeout | Verr`; @@ -847,12 +937,14 @@ val finish_tac = (* Proving that stack_to_lab generates labels_ok *) val sextract_labels_def = stackPropsTheory.extract_labels_def -Theorem next_lab_non_zero ` - ∀p. 1 ≤ next_lab p 1` - (once_rewrite_tac [next_lab_EQ_MAX] \\ fs [MAX_DEF]); +Theorem next_lab_non_zero: + ∀p. 1 ≤ next_lab p 1 +Proof + once_rewrite_tac [next_lab_EQ_MAX] \\ fs [MAX_DEF] +QED -Theorem stack_to_lab_lab_pres ` - ∀p n nl. +Theorem stack_to_lab_lab_pres: + ∀p n nl. EVERY (λ(l1,l2). l1 = n ∧ l2 ≠ 0) (extract_labels p) ∧ ALL_DISTINCT (extract_labels p) ∧ next_lab p 1 ≤ nl ⇒ @@ -860,8 +952,9 @@ Theorem stack_to_lab_lab_pres ` EVERY (λ(l1,l2). l1 = n ∧ l2 ≠ 0) (extract_labels (append cp)) ∧ ALL_DISTINCT (extract_labels (append cp)) ∧ (∀lab. MEM lab (extract_labels (append cp)) ⇒ MEM lab (extract_labels p) ∨ (nl ≤ SND lab ∧ SND lab < nl')) ∧ - nl ≤ nl'` - (HO_MATCH_MP_TAC flatten_ind>>Cases_on`p`>>rw[]>> + nl ≤ nl' +Proof + HO_MATCH_MP_TAC flatten_ind>>Cases_on`p`>>rw[]>> once_rewrite_tac [flatten_def]>>fs[extract_labels_def,sextract_labels_def] >- (Cases_on`s`>>BasicProvers.EVERY_CASE_TAC>>fs[]>>rveq>>fs[extract_labels_def,sextract_labels_def,compile_jump_def]>> @@ -899,16 +992,18 @@ Theorem stack_to_lab_lab_pres ` CCONTR_TAC>>fs[]>> res_tac>>fs[]>> imp_res_tac extract_labels_next_lab>>fs[])>> - metis_tac[])); + metis_tac[]) +QED -Theorem prog_to_section_labels_ok ` - EVERY (λn,p. +Theorem prog_to_section_labels_ok: + EVERY (λn,p. let labs = extract_labels p in EVERY (λ(l1,l2).l1 = n ∧ l2 ≠ 0) labs ∧ ALL_DISTINCT labs) prog ∧ ALL_DISTINCT (MAP FST prog) ⇒ - labels_ok (MAP prog_to_section prog)` - (strip_tac>> + labels_ok (MAP prog_to_section prog) +Proof + strip_tac>> fs[labels_ok_def,MAP_prog_to_section_FST,Once EVERY_MEM,FORALL_PROD,MEM_MAP,PULL_EXISTS]>> rw[]>>fs[prog_to_section_def]>> first_x_assum drule>> rw[]>> @@ -922,10 +1017,11 @@ Theorem prog_to_section_labels_ok ` >> fs[ALL_DISTINCT_APPEND]>> CCONTR_TAC>>fs[]>>res_tac>>fs[]>> - imp_res_tac extract_labels_next_lab>>fs[]); + imp_res_tac extract_labels_next_lab>>fs[] +QED -Theorem flatten_correct - `∀prog s1 r s2 n l (t1:('a,'c,'ffi)labSem$state). +Theorem flatten_correct: + ∀prog s1 r s2 n l (t1:('a,'c,'ffi)labSem$state). evaluate (prog,s1) = (r,s2) ∧ r ≠ SOME Error ∧ state_rel s1 t1 ∧ call_args prog t1.ptr_reg t1.len_reg t1.ptr2_reg t1.len2_reg t1.link_reg ∧ @@ -956,8 +1052,9 @@ Theorem flatten_correct w = t2.pc ∧ state_rel s2 t2 | SOME Vtimeout => t2.ffi = s2.ffi ∧ t2.clock = 0 - | _ => F` - (recInduct stackSemTheory.evaluate_ind >> + | _ => F +Proof + recInduct stackSemTheory.evaluate_ind >> conj_tac >- ( srw_tac[][stackSemTheory.evaluate_def,flatten_def] >> qexists_tac`0`>>simp[] >> @@ -2153,10 +2250,11 @@ Theorem flatten_correct \\ fs[state_rel_def,set_var_def,FLOOKUP_UPDATE,APPLY_UPDATE_THM] \\ srw_tac[][] \\ res_tac \\ fs []) >> srw_tac[][stackSemTheory.evaluate_def] >> - full_simp_tac(srw_ss())[state_rel_def]); + full_simp_tac(srw_ss())[state_rel_def] +QED -Theorem flatten_call_correct - `evaluate (Call NONE (INL start) NONE,s1) = (res,s2) ∧ +Theorem flatten_call_correct: + evaluate (Call NONE (INL start) NONE,s1) = (res,s2) ∧ state_rel (s1:(α,'c,'ffi)stackSem$state) t1 ∧ loc_to_pc start 0 t1.code = SOME t1.pc ∧ res ≠ SOME Error ∧ @@ -2182,8 +2280,9 @@ Theorem flatten_call_correct *) t2.ffi = s2.ffi ∧ r2 ≠ Error ∧ (res = SOME TimeOut ⇒ r2 = TimeOut) - (* (FST (evaluate (t1 with clock := t1.clock - 1 + ck)) ≠ Error)*)` - (srw_tac[][stackSemTheory.evaluate_def] >> + (* (FST (evaluate (t1 with clock := t1.clock - 1 + ck)) ≠ Error)*) +Proof + srw_tac[][stackSemTheory.evaluate_def] >> last_x_assum mp_tac >> BasicProvers.TOP_CASE_TAC >> full_simp_tac(srw_ss())[] >> BasicProvers.TOP_CASE_TAC >> full_simp_tac(srw_ss())[] >- ( @@ -2235,7 +2334,8 @@ Theorem flatten_call_correct disch_then drule >> strip_tac >> ntac 6 (first_x_assum(qspec_then`ck'`mp_tac)) >> rw[] \\ - qexists_tac`ck+ck'`>>simp[]); + qexists_tac`ck+ck'`>>simp[] +QED val halt_assum_def = Define ` halt_assum (:('ffi#'c)) code <=> @@ -2244,13 +2344,14 @@ val halt_assum_def = Define ` ∃t. evaluate (Call NONE (INL 1) NONE,s) = (SOME (Halt (Word 0w)),t) /\ t.ffi = s.ffi /\ t.clock = s.clock - 1`; -Theorem flatten_semantics - `halt_assum (:'ffi#'c) (s1:(α,'c,'ffi)stackSem$state).code /\ +Theorem flatten_semantics: + halt_assum (:'ffi#'c) (s1:(α,'c,'ffi)stackSem$state).code /\ state_rel s1 (s2:('a,'c,'ffi)labSem$state) /\ loc_to_pc start 0 s2.code = SOME s2.pc /\ semantics start s1 <> Fail ==> - semantics s2 = semantics start s1` - (simp[GSYM AND_IMP_INTRO,halt_assum_def] >> strip_tac >> + semantics s2 = semantics start s1 +Proof + simp[GSYM AND_IMP_INTRO,halt_assum_def] >> strip_tac >> ntac 2 strip_tac >> simp[stackSemTheory.semantics_def] >> IF_CASES_TAC >> full_simp_tac(srw_ss())[] >> @@ -2432,7 +2533,8 @@ Theorem flatten_semantics simp[]>>strip_tac>> qexists_tac`k+1`>>full_simp_tac(srw_ss())[]>> full_simp_tac(srw_ss())[IS_PREFIX_APPEND]>> simp[]>> - simp[EL_APPEND1]); + simp[EL_APPEND1] +QED val make_init_def = Define ` make_init code coracle regs save_regs (s:('a,'c,'ffi) labSem$state) = @@ -2477,32 +2579,38 @@ val full_make_init_def = Define` (make_init data_conf (fromAList code) coracle s1, make_init_opt ggc max_heap bitmaps data_sp coracle1 jump offset sp (fromAList code1) s2)`; -Theorem full_make_init_buffer ` - (FST(full_make_init a b c d e f g h i j k)).code_buffer.buffer = [] ∧ - (FST(full_make_init a b c d e f g h i j k)).data_buffer.buffer = []` - (fs [full_make_init_def,stack_allocProofTheory.make_init_def, +Theorem full_make_init_buffer: + (FST(full_make_init a b c d e f g h i j k)).code_buffer.buffer = [] ∧ + (FST(full_make_init a b c d e f g h i j k)).data_buffer.buffer = [] +Proof + fs [full_make_init_def,stack_allocProofTheory.make_init_def, stack_removeProofTheory.make_init_any_def] >> every_case_tac>>fs[]>> EVAL_TAC>> pop_assum mp_tac>>fs[stack_removeProofTheory.make_init_opt_def]>> every_case_tac>>rw[]>> - fs [stack_removeProofTheory.init_prop_def]); - -Theorem full_make_init_ffi ` - (FST(full_make_init a b c d e f g h i j k)).ffi = h.ffi` - (fs [full_make_init_def,stack_allocProofTheory.make_init_def] >> - fs [stack_removeProofTheory.make_init_any_ffi] \\ EVAL_TAC); - -Theorem full_make_init_compile - `(FST(full_make_init a b c d e f g h i j k)).compile = - (λc. (λp. h.compile c (MAP prog_to_section (MAP (prog_comp a.reg_names) (MAP (prog_comp a.jump e d) p)))) o MAP prog_comp)` - (fs [full_make_init_def,stack_allocProofTheory.make_init_def] + fs [stack_removeProofTheory.init_prop_def] +QED + +Theorem full_make_init_ffi: + (FST(full_make_init a b c d e f g h i j k)).ffi = h.ffi +Proof + fs [full_make_init_def,stack_allocProofTheory.make_init_def] >> + fs [stack_removeProofTheory.make_init_any_ffi] \\ EVAL_TAC +QED + +Theorem full_make_init_compile: + (FST(full_make_init a b c d e f g h i j k)).compile = + (λc. (λp. h.compile c (MAP prog_to_section (MAP (prog_comp a.reg_names) (MAP (prog_comp a.jump e d) p)))) o MAP prog_comp) +Proof + fs [full_make_init_def,stack_allocProofTheory.make_init_def] \\ simp[stack_removeProofTheory.make_init_any_def, stack_removeProofTheory.make_init_opt_def] \\ every_case_tac \\ fs[] \\ imp_res_tac stackPropsTheory.evaluate_consts \\ fs[] \\ EVAL_TAC \\ fs[] - \\ EVAL_TAC \\ fs[]); + \\ EVAL_TAC \\ fs[] +QED val memory_assumption_def = Define` memory_assumption rnames (bitmaps:'a word list) data_sp t = @@ -2562,8 +2670,8 @@ val FLOOKUP_fp_regs = Q.prove( recInduct SNOC_INDUCT \\ fs [FUPDATE_LIST,FOLDL_SNOC,MAP_SNOC] \\ fs [FLOOKUP_UPDATE] \\ rw [] \\ Cases_on `x = n` \\ fs [read_fp_reg_def]);*) -Theorem state_rel_make_init - `state_rel (make_init code coracle regs save_regs s) (s:('a,'c,'ffi) labSem$state) <=> +Theorem state_rel_make_init: + state_rel (make_init code coracle regs save_regs s) (s:('a,'c,'ffi) labSem$state) <=> (∀n prog. lookup n code = SOME (prog) ⇒ call_args prog s.ptr_reg s.len_reg s.ptr2_reg s.len2_reg s.link_reg ∧ @@ -2586,10 +2694,12 @@ Theorem state_rel_make_init EVERY sec_labels_ok s.code ∧ (∀k i n. k ∈ save_regs ⇒ s.io_regs n i k = NONE) ∧ (∀k n. k ∈ save_regs ⇒ s.cc_regs n k = NONE) ∧ - (∀x. x ∈ s.mem_domain ⇒ w2n x MOD (dimindex (:α) DIV 8) = 0)` - (fs [state_rel_def,make_init_def,FLOOKUP_regs] + (∀x. x ∈ s.mem_domain ⇒ w2n x MOD (dimindex (:α) DIV 8) = 0) +Proof + fs [state_rel_def,make_init_def,FLOOKUP_regs] \\ eq_tac \\ strip_tac \\ fs [] - \\ metis_tac [FLOOKUP_regs]); + \\ metis_tac [FLOOKUP_regs] +QED val MAP_FST_compile_compile = Q.prove( `MAP FST (compile jump off gen max_heap k InitGlobals_location @@ -2604,12 +2714,14 @@ val MAP_FST_compile_compile = Q.prove( val sextract_labels_def = stackPropsTheory.extract_labels_def -Theorem next_lab_non_zero ` - ∀p. 1 ≤ next_lab p 1` - (once_rewrite_tac [next_lab_EQ_MAX] \\ fs [MAX_DEF]); +Theorem next_lab_non_zero: + ∀p. 1 ≤ next_lab p 1 +Proof + once_rewrite_tac [next_lab_EQ_MAX] \\ fs [MAX_DEF] +QED -Theorem stack_to_lab_lab_pres ` - ∀p n nl. +Theorem stack_to_lab_lab_pres: + ∀p n nl. EVERY (λ(l1,l2). l1 = n ∧ l2 ≠ 0) (extract_labels p) ∧ ALL_DISTINCT (extract_labels p) ∧ next_lab p 1 ≤ nl ⇒ @@ -2617,8 +2729,9 @@ Theorem stack_to_lab_lab_pres ` EVERY (λ(l1,l2). l1 = n ∧ l2 ≠ 0) (extract_labels (append cp)) ∧ ALL_DISTINCT (extract_labels (append cp)) ∧ (∀lab. MEM lab (extract_labels (append cp)) ⇒ MEM lab (extract_labels p) ∨ (nl ≤ SND lab ∧ SND lab < nl')) ∧ - nl ≤ nl'` - (HO_MATCH_MP_TAC flatten_ind>>Cases_on`p`>>rw[]>> + nl ≤ nl' +Proof + HO_MATCH_MP_TAC flatten_ind>>Cases_on`p`>>rw[]>> once_rewrite_tac [flatten_def]>>fs[extract_labels_def,sextract_labels_def] >- (Cases_on`s`>>BasicProvers.EVERY_CASE_TAC>>fs[]>>rveq>>fs[extract_labels_def,sextract_labels_def,compile_jump_def]>> @@ -2656,7 +2769,8 @@ Theorem stack_to_lab_lab_pres ` CCONTR_TAC>>fs[]>> res_tac>>fs[]>> imp_res_tac extract_labels_next_lab>>fs[])>> - metis_tac[])); + metis_tac[]) +QED val MAP_prog_to_section_FST = Q.prove(` MAP (λs. case s of Section n v => n) (MAP prog_to_section prog) = @@ -2670,15 +2784,16 @@ val extract_label_store_list_code = Q.prove(` ho_match_mp_tac stack_removeTheory.store_list_code_ind>> EVAL_TAC>>fs[]); -Theorem stack_to_lab_compile_lab_pres ` - EVERY (λn. n ≠ 0 ∧ n ≠ 1 ∧ n ≠ 2 ∧ n ≠ gc_stub_location) (MAP FST prog) ∧ +Theorem stack_to_lab_compile_lab_pres: + EVERY (λn. n ≠ 0 ∧ n ≠ 1 ∧ n ≠ 2 ∧ n ≠ gc_stub_location) (MAP FST prog) ∧ EVERY (λn,p. let labs = extract_labels p in EVERY (λ(l1,l2).l1 = n ∧ l2 ≠ 0) labs ∧ ALL_DISTINCT labs) prog ∧ ALL_DISTINCT (MAP FST prog) ⇒ - labels_ok (compile c c2 c3 sp offset prog)` - (rw[labels_ok_def,stack_to_labTheory.compile_def] + labels_ok (compile c c2 c3 sp offset prog) +Proof + rw[labels_ok_def,stack_to_labTheory.compile_def] >- (fs[MAP_prog_to_section_FST,MAP_FST_compile_compile]>> fs[EVERY_MEM]>>CCONTR_TAC>>fs[]>>res_tac>>fs[] >> @@ -2714,7 +2829,8 @@ Theorem stack_to_lab_compile_lab_pres ` metis_tac[LESS_EQ_TRANS,next_lab_non_zero]) >> CCONTR_TAC>>fs[]>>res_tac>>fs[]>> - imp_res_tac extract_labels_next_lab>>fs[]); + imp_res_tac extract_labels_next_lab>>fs[] +QED val compile_no_stubs_def = Define` compile_no_stubs f jump offset sp prog = @@ -2734,8 +2850,8 @@ val good_code_def = Define` EVERY (λ(l1,l2). l1 = n ∧ l2 ≠ 0) (extract_labels p) ∧ ALL_DISTINCT (extract_labels p)) code`; -Theorem full_make_init_semantics - `full_make_init stack_conf data_conf max_heap sp offset +Theorem full_make_init_semantics: + full_make_init stack_conf data_conf max_heap sp offset (bitmaps:'a word list) code t save_regs data_sp coracle = (s,opt) ∧ good_dimindex(:'a) ∧ t.code = stack_to_lab$compile stack_conf data_conf max_heap sp offset code ∧ @@ -2764,8 +2880,9 @@ Theorem full_make_init_semantics semantics InitGlobals_location s ≠ Fail ⇒ implements {semantics t} {semantics InitGlobals_location s} | NONE => - semantics t = Terminate Resource_limit_hit t.ffi.io_events` - (srw_tac[][full_make_init_def] + semantics t = Terminate Resource_limit_hit t.ffi.io_events +Proof + srw_tac[][full_make_init_def] \\ last_x_assum mp_tac \\ LET_ELIM_TAC (* Prove the syntactic things for the oracle sequences *) \\ `semantics 0 s2 ≠ Fail ⇒ semantics t = semantics 0 s2` @@ -2973,12 +3090,15 @@ Theorem full_make_init_semantics \\ strip_tac \\ `semantics 0 s2 ≠ Fail` suffices_by metis_tac[] \\ strip_tac \\ fs[implements_def] - \\ rfs[extend_with_resource_limit_def]); + \\ rfs[extend_with_resource_limit_def] +QED -Theorem EVERY_sec_ends_with_label_MAP_prog_to_section[simp] - `∀prog. EVERY sec_ends_with_label (MAP prog_to_section prog)` - (Induct \\ simp[] \\ Cases \\ simp[prog_to_section_def] - \\ pairarg_tac \\ fs[sec_ends_with_label_def]); +Theorem EVERY_sec_ends_with_label_MAP_prog_to_section[simp]: + ∀prog. EVERY sec_ends_with_label (MAP prog_to_section prog) +Proof + Induct \\ simp[] \\ Cases \\ simp[prog_to_section_def] + \\ pairarg_tac \\ fs[sec_ends_with_label_def] +QED val stack_asm_ok_def = stackPropsTheory.stack_asm_ok_def @@ -3013,22 +3133,24 @@ val flatten_line_ok_pre = Q.prove(` pop_assum mp_tac>>EVAL_TAC>> fs[]); -Theorem compile_all_enc_ok_pre - `byte_offset_ok c 0w ∧ +Theorem compile_all_enc_ok_pre: + byte_offset_ok c 0w ∧ EVERY (λ(n,p).stack_asm_ok c p) prog ⇒ - all_enc_ok_pre c (MAP prog_to_section prog)` - (fs[EVERY_MEM,MEM_MAP,FORALL_PROD,EXISTS_PROD]>>rw[]>> + all_enc_ok_pre c (MAP prog_to_section prog) +Proof + fs[EVERY_MEM,MEM_MAP,FORALL_PROD,EXISTS_PROD]>>rw[]>> fs[prog_to_section_def]>>pairarg_tac>>rw[] >- metis_tac[flatten_line_ok_pre] - >- EVAL_TAC); + >- EVAL_TAC +QED (* stack_name renames registers to obey non-clashing names It should be sufficient that the incoming nregs < reg_count - avoid_regs, and that the mapping target for these avoids bad regs *) -Theorem stack_to_lab_compile_all_enc_ok ` - EVERY (λ(n,p). stack_asm_name c p) prog ∧ +Theorem stack_to_lab_compile_all_enc_ok: + EVERY (λ(n,p). stack_asm_name c p) prog ∧ EVERY (λ(n,p). stack_asm_remove c p) prog ∧ names_ok c1.reg_names (c:'a asm_config).reg_count c.avoid_regs ∧ fixed_names c1.reg_names c ∧ @@ -3042,15 +3164,17 @@ Theorem stack_to_lab_compile_all_enc_ok ` (∀s. addr_offset_ok c (store_offset s)) ∧ reg_name 10 c ∧ reg_name (sp + 2) c ∧ reg_name (sp + 1) c ∧ reg_name sp c ∧ conf_ok (:'a) c2 ⇒ - all_enc_ok_pre c (compile c1 c2 c3 sp c.addr_offset prog)` - (rw[stack_to_labTheory.compile_def]>> + all_enc_ok_pre c (compile c1 c2 c3 sp c.addr_offset prog) +Proof + rw[stack_to_labTheory.compile_def]>> match_mp_tac compile_all_enc_ok_pre>>fs[]>> match_mp_tac stack_names_stack_asm_ok>>fs[]>> match_mp_tac stack_remove_stack_asm_name>>fs[stackPropsTheory.reg_name_def]>> - match_mp_tac stack_alloc_stack_asm_convs>>fs[stackPropsTheory.reg_name_def]); + match_mp_tac stack_alloc_stack_asm_convs>>fs[stackPropsTheory.reg_name_def] +QED -Theorem IMP_init_store_ok - `max_heap = 2 * max_heap_limit (:'a) c1 -1 /\ +Theorem IMP_init_store_ok: + max_heap = 2 * max_heap_limit (:'a) c1 -1 /\ (fmis,xxx) = full_make_init stack_conf c1 max_heap sp offset (bitmaps:'a word list) code s save_regs data_sp coracle ==> init_store_ok c1 @@ -3058,8 +3182,9 @@ Theorem IMP_init_store_ok fmis.memory fmis.mdomain fmis.code_buffer - fmis.data_buffer` - (strip_tac \\ rveq \\ + fmis.data_buffer +Proof + strip_tac \\ rveq \\ fs [full_make_init_def,stack_allocProofTheory.make_init_def, stack_removeProofTheory.make_init_any_def] \\ CASE_TAC \\ fs [] THEN1 @@ -3079,11 +3204,11 @@ Theorem IMP_init_store_ok stack_removeProofTheory.word_list_exists_ADD] \\ qexists_tac`len` \\ fs [FLOOKUP_DEF,DOMSUB_FAPPLY_THM,FAPPLY_FUPDATE_THM] - \\ Cases_on `c1.gc_kind` \\ fs [is_gen_gc_def]); + \\ Cases_on `c1.gc_kind` \\ fs [is_gen_gc_def] +QED -Theorem IMP_init_state_ok - ` - 4 < kkk /\ +Theorem IMP_init_state_ok: + 4 < kkk /\ (bitmaps:'a word list) = 4w::t ∧ good_dimindex (:α) /\ (∀n. @@ -3102,8 +3227,9 @@ Theorem IMP_init_state_ok bm0)) (word_oracle n)) ∧ (full_make_init sc dc max_heap stk stoff bitmaps p6 lab_st save_regs data_sp stack_oracle = (fmis,SOME xxx)) ==> - init_state_ok kkk fmis word_oracle` - (fs [full_make_init_def,stack_allocProofTheory.make_init_def, + init_state_ok kkk fmis word_oracle +Proof + fs [full_make_init_def,stack_allocProofTheory.make_init_def, stack_removeProofTheory.make_init_any_def] \\ strip_tac \\ every_case_tac \\ fs [] \\ fs [word_to_stackProofTheory.init_state_ok_def,data_to_word_gcProofTheory.gc_fun_ok_word_gc_fun] @@ -3121,16 +3247,19 @@ Theorem IMP_init_state_ok fs[data_to_word_gcProofTheory.gc_fun_ok_word_gc_fun] >> qhdtm_x_assum `make_init_opt` mp_tac>> simp[stack_removeProofTheory.make_init_opt_def]>> - every_case_tac>>fs[stack_removeProofTheory.init_reduce_def]>>rw[]>>fs[]); + every_case_tac>>fs[stack_removeProofTheory.init_reduce_def]>>rw[]>>fs[] +QED -Theorem full_make_init_has_fp_ops[simp] - `full_make_init stack_conf +Theorem full_make_init_has_fp_ops[simp]: + full_make_init stack_conf (dconf with has_fp_ops := b) mheap sp offset bitmaps code s save_regs dsp cor = full_make_init stack_conf dconf - mheap sp offset bitmaps code s save_regs dsp cor` - (rewrite_tac [full_make_init_def] \\ fs [] - \\ fs [stack_allocProofTheory.make_init_def]); + mheap sp offset bitmaps code s save_regs dsp cor +Proof + rewrite_tac [full_make_init_def] \\ fs [] + \\ fs [stack_allocProofTheory.make_init_def] +QED val complex_get_code_labels_def = Define ` (complex_get_code_labels (Seq p1 p2) = complex_get_code_labels p1 UNION complex_get_code_labels p2) /\ @@ -3149,15 +3278,16 @@ val complex_get_code_labels_def = Define ` (complex_get_code_labels _ = {})` val _ = export_rewrites["complex_get_code_labels_def"]; -Theorem complex_flatten_labels ` - ∀p n m. +Theorem complex_flatten_labels: + ∀p n m. let pp = set(append (FST (flatten p n m))) in BIGUNION (IMAGE line_get_labels pp) ⊆ (n,0) INSERT IMAGE (λn2. (n,n2)) (BIGUNION (IMAGE line_get_code_labels pp)) ∪ - complex_get_code_labels p` - (recInduct flatten_ind >> rw[]>> + complex_get_code_labels p +Proof + recInduct flatten_ind >> rw[]>> once_rewrite_tac [flatten_def]>> Cases_on `p`>> fs[line_get_labels_def,get_code_labels_def]>> @@ -3191,17 +3321,19 @@ Theorem complex_flatten_labels ` match_mp_tac SUBSET_TRANS>> asm_exists_tac>> rw[]>> - metis_tac[SUBSET_UNION,SUBSET_OF_INSERT,SUBSET_TRANS])); + metis_tac[SUBSET_UNION,SUBSET_OF_INSERT,SUBSET_TRANS]) +QED -Theorem flatten_labels - `∀m n p l x y. +Theorem flatten_labels: + ∀m n p l x y. flatten m n p = (l,x,y) ∧ EVERY (sec_label_ok n) (append l) ⇒ BIGUNION (IMAGE line_get_labels (set (append l))) ⊆ sec_get_code_labels (Section n (append l)) ∪ - get_code_labels m` - (recInduct stack_to_labTheory.flatten_ind + get_code_labels m +Proof + recInduct stack_to_labTheory.flatten_ind \\ rpt gen_tac \\ strip_tac \\ rw[Once stack_to_labTheory.flatten_def] \\ qabbrev_tac`XXX = debug p` @@ -3239,14 +3371,16 @@ Theorem flatten_labels \\ fs[CaseEq"bool"] \\ rveq \\ fsrw_tac[DNF_ss][labPropsTheory.line_get_labels_def, labPropsTheory.line_get_code_labels_def] - \\ metis_tac[] )); + \\ metis_tac[] ) +QED -Theorem get_labels_MAP_prog_to_section_SUBSET_code_labels_lemma - `∀p. EVERY sec_labels_ok (MAP prog_to_section p) ⇒ +Theorem get_labels_MAP_prog_to_section_SUBSET_code_labels_lemma: + ∀p. EVERY sec_labels_ok (MAP prog_to_section p) ⇒ get_labels (MAP prog_to_section p) ⊆ get_code_labels (MAP prog_to_section p) ∪ - BIGUNION (IMAGE get_code_labels (set (MAP SND p)))` - (Induct \\ simp[FORALL_PROD] >- (EVAL_TAC \\ simp[]) + BIGUNION (IMAGE get_code_labels (set (MAP SND p))) +Proof + Induct \\ simp[FORALL_PROD] >- (EVAL_TAC \\ simp[]) \\ rw[stack_to_labTheory.prog_to_section_def] \\ pairarg_tac \\ fs[labPropsTheory.get_labels_cons, labPropsTheory.get_code_labels_cons] \\ simp[labPropsTheory.sec_get_labels_def, labPropsTheory.sec_get_code_labels_def] @@ -3257,7 +3391,8 @@ Theorem get_labels_MAP_prog_to_section_SUBSET_code_labels_lemma \\ simp[] \\ simp[SUBSET_DEF, PULL_EXISTS, labPropsTheory.sec_get_code_labels_def] \\ rw[] \\ first_x_assum drule \\ rw[] - \\ metis_tac[]); + \\ metis_tac[] +QED val prog_to_section_preserves_MAP_FST = Q.prove(` ∀p. @@ -3269,26 +3404,29 @@ val prog_to_section_preserves_MAP_FST = Q.prove(` simp[labPropsTheory.get_code_labels_cons, labPropsTheory.sec_get_code_labels_def]>> fs[SUBSET_DEF]); -Theorem prog_to_section_labels ` - prog_to_section (n,p) = pp ⇒ +Theorem prog_to_section_labels: + prog_to_section (n,p) = pp ⇒ sec_get_labels pp ⊆ - sec_get_code_labels pp ∪ complex_get_code_labels p` - (rw[prog_to_section_def]>>pairarg_tac>>fs[]>> + sec_get_code_labels pp ∪ complex_get_code_labels p +Proof + rw[prog_to_section_def]>>pairarg_tac>>fs[]>> qspecl_then [`p`,`n`,`next_lab p 1`] assume_tac complex_flatten_labels>> rfs[]>> fs[sec_get_labels_def,sec_get_code_labels_def,line_get_labels_def]>> rw[]>> match_mp_tac SUBSET_TRANS>> asm_exists_tac>>fs[]>> - metis_tac[SUBSET_UNION,SUBSET_OF_INSERT,SUBSET_TRANS]); + metis_tac[SUBSET_UNION,SUBSET_OF_INSERT,SUBSET_TRANS] +QED -Theorem flatten_preserves_handler_labels - `∀m n p l x y. +Theorem flatten_preserves_handler_labels: + ∀m n p l x y. flatten m n p = (l,x,y) ⇒ stack_get_handler_labels n m ⊆ - sec_get_code_labels (Section n (append l))` - (recInduct stack_to_labTheory.flatten_ind + sec_get_code_labels (Section n (append l)) +Proof + recInduct stack_to_labTheory.flatten_ind \\ rpt gen_tac \\ strip_tac \\ rw[Once stack_to_labTheory.flatten_def] \\ qabbrev_tac`XXX = FOO p` @@ -3320,13 +3458,15 @@ Theorem flatten_preserves_handler_labels rpt (pairarg_tac \\ fs[]) \\ rveq \\ fs[SUBSET_DEF, PULL_EXISTS, CaseEq"bool"] \\ rveq \\ fs[labPropsTheory.line_get_code_labels_def, labPropsTheory.sec_get_code_labels_def,stack_get_handler_labels_def] - \\ metis_tac[] )); + \\ metis_tac[] ) +QED -Theorem MAP_prog_to_section_preserves_handler_labels - `∀p. +Theorem MAP_prog_to_section_preserves_handler_labels: + ∀p. BIGUNION (set (MAP (λ(n,pp). stack_get_handler_labels n pp) p)) ⊆ - get_code_labels (MAP prog_to_section p)` - (Induct \\ simp[FORALL_PROD] + get_code_labels (MAP prog_to_section p) +Proof + Induct \\ simp[FORALL_PROD] \\ simp[stack_to_labTheory.prog_to_section_def] \\ rpt gen_tac \\ pairarg_tac \\ fs[] @@ -3336,21 +3476,24 @@ Theorem MAP_prog_to_section_preserves_handler_labels \\ rw[SUBSET_DEF, PULL_EXISTS, EXISTS_PROD, FORALL_PROD] \\ first_x_assum drule \\ rw[labPropsTheory.sec_get_code_labels_def] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem get_labels_MAP_prog_to_section_SUBSET_code_labels -`∀p. EVERY sec_labels_ok (MAP prog_to_section p) ∧ +Theorem get_labels_MAP_prog_to_section_SUBSET_code_labels: + ∀p. EVERY sec_labels_ok (MAP prog_to_section p) ∧ stack_good_code_labels p ⇒ get_labels (MAP prog_to_section p) ⊆ - get_code_labels (MAP prog_to_section p)` - (rw[stack_good_code_labels_def]>> + get_code_labels (MAP prog_to_section p) +Proof + rw[stack_good_code_labels_def]>> drule get_labels_MAP_prog_to_section_SUBSET_code_labels_lemma >> strip_tac >> match_mp_tac SUBSET_TRANS>> asm_exists_tac>> simp[]>> match_mp_tac SUBSET_TRANS>> asm_exists_tac>> rw[]>> - metis_tac[MAP_prog_to_section_preserves_handler_labels,prog_to_section_preserves_MAP_FST]); + metis_tac[MAP_prog_to_section_preserves_handler_labels,prog_to_section_preserves_MAP_FST] +QED (* TODO: move these when the actual needed theorem is clearer... - e.g.: do we need a LIST_REL on the labels before/after each code @@ -3365,13 +3508,15 @@ val get_code_labels_comp = Q.prove( \\ every_case_tac \\ fs [] \\ fs[stack_namesTheory.dest_find_name_def]); -Theorem stack_names_get_code_labels ` - LIST_REL (λcp p. complex_get_code_labels cp = complex_get_code_labels p) - (MAP SND (stack_names$compile f prog)) (MAP SND prog)` - (rw[LIST_REL_EL_EQN,stack_namesTheory.compile_def]>> +Theorem stack_names_get_code_labels: + LIST_REL (λcp p. complex_get_code_labels cp = complex_get_code_labels p) + (MAP SND (stack_names$compile f prog)) (MAP SND prog) +Proof + rw[LIST_REL_EL_EQN,stack_namesTheory.compile_def]>> fs[MAP_MAP_o,o_DEF,LAMBDA_PROD,stack_namesTheory.prog_comp_def]>> fs[EL_MAP]>>pairarg_tac>>fs[]>> - metis_tac[get_code_labels_comp]); + metis_tac[get_code_labels_comp] +QED (* stack_remove *) val get_code_labels_comp = Q.prove( @@ -3612,13 +3757,14 @@ val stack_alloc_stack_good_code_labels = Q.prove(` metis_tac[]); (* stack_to_lab *) -Theorem stack_to_lab_stack_good_code_labels ` - compile stack_conf data_conf max_heap sp offset prog = prog' ∧ +Theorem stack_to_lab_stack_good_code_labels: + compile stack_conf data_conf max_heap sp offset prog = prog' ∧ MEM InitGlobals_location (MAP FST prog) ∧ stack_good_code_labels prog ∧ EVERY sec_labels_ok prog' ⇒ - get_labels prog' ⊆ get_code_labels prog'` - (rw[stack_to_labTheory.compile_def]>> + get_labels prog' ⊆ get_code_labels prog' +Proof + rw[stack_to_labTheory.compile_def]>> match_mp_tac get_labels_MAP_prog_to_section_SUBSET_code_labels >> simp[]>> match_mp_tac stack_names_stack_good_code_labels>> @@ -3630,6 +3776,7 @@ Theorem stack_to_lab_stack_good_code_labels ` metis_tac[]) >> match_mp_tac stack_alloc_stack_good_code_labels>> - fs[]); + fs[] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/word_allocProofScript.sml b/compiler/backend/proofs/word_allocProofScript.sml index 369e054b33..8b18c103f9 100644 --- a/compiler/backend/proofs/word_allocProofScript.sml +++ b/compiler/backend/proofs/word_allocProofScript.sml @@ -14,9 +14,11 @@ val _ = Parse.bring_to_front_overload"numset_list_insert"{Thy="word_alloc",Name= val _ = Parse.hide"mem"; (*TODO: Move?*) -Theorem SUBSET_OF_INSERT -`!s x. s ⊆ x INSERT s` - (srw_tac[][SUBSET_DEF]); +Theorem SUBSET_OF_INSERT: + !s x. s ⊆ x INSERT s +Proof + srw_tac[][SUBSET_DEF] +QED val INJ_UNION = Q.prove( `!f A B. @@ -135,11 +137,13 @@ val strong_locals_rel_def = Define` n ∈ ls ∧ lookup n slocs = SOME v ⇒ lookup (f n) tlocs = SOME v`; -Theorem domain_numset_list_insert ` - ∀ls locs. - domain (numset_list_insert ls locs) = domain locs UNION set ls` - (Induct>>full_simp_tac(srw_ss())[numset_list_insert_def]>>srw_tac[][]>> - metis_tac[INSERT_UNION_EQ,UNION_COMM]); +Theorem domain_numset_list_insert: + ∀ls locs. + domain (numset_list_insert ls locs) = domain locs UNION set ls +Proof + Induct>>full_simp_tac(srw_ss())[numset_list_insert_def]>>srw_tac[][]>> + metis_tac[INSERT_UNION_EQ,UNION_COMM] +QED val strong_locals_rel_get_var = Q.prove(` strong_locals_rel f live st.locals cst.locals ∧ @@ -193,8 +197,8 @@ val apply_nummap_key_domain = Q.prove(` full_simp_tac(srw_ss())[MEM_MAP,MAP_MAP_o,EXTENSION,EXISTS_PROD]>> metis_tac[MEM_toAList,domain_lookup]); -Theorem cut_env_lemma ` - ∀names sloc tloc x f. +Theorem cut_env_lemma: + ∀names sloc tloc x f. INJ f (domain names) UNIV ∧ cut_env names sloc = SOME x ∧ strong_locals_rel f (domain names) sloc tloc @@ -203,8 +207,9 @@ Theorem cut_env_lemma ` domain y = IMAGE f (domain x) ∧ strong_locals_rel f (domain names) x y ∧ INJ f (domain x) UNIV ∧ - domain x = domain names` - (rpt strip_tac>> + domain x = domain names +Proof + rpt strip_tac>> full_simp_tac(srw_ss())[domain_inter,cut_env_def,apply_nummap_key_domain ,strong_locals_rel_def]>> CONJ_ASM1_TAC>- @@ -223,7 +228,8 @@ Theorem cut_env_lemma ` EVERY_CASE_TAC>> full_simp_tac(srw_ss())[ALOOKUP_NONE,MEM_MAP,FORALL_PROD]>>metis_tac[]) >> - full_simp_tac(srw_ss())[domain_inter,SUBSET_INTER_ABSORPTION,INTER_COMM]) + full_simp_tac(srw_ss())[domain_inter,SUBSET_INTER_ABSORPTION,INTER_COMM] +QED val LENGTH_list_rerrange = Q.prove(` LENGTH (list_rearrange mover xs) = LENGTH xs`, @@ -250,10 +256,12 @@ val GENLIST_MAP = Q.prove( \\ `k < LENGTH l /\ k <= LENGTH l` by DECIDE_TAC \\ full_simp_tac(srw_ss())[EL_MAP]); -Theorem list_rearrange_MAP - `!l f m. list_rearrange m (MAP f l) = MAP f (list_rearrange m l)` - (SRW_TAC [] [list_rearrange_def] \\ MATCH_MP_TAC GENLIST_MAP \\ - full_simp_tac(srw_ss())[BIJ_DEF,INJ_DEF]); +Theorem list_rearrange_MAP: + !l f m. list_rearrange m (MAP f l) = MAP f (list_rearrange m l) +Proof + SRW_TAC [] [list_rearrange_def] \\ MATCH_MP_TAC GENLIST_MAP \\ + full_simp_tac(srw_ss())[BIJ_DEF,INJ_DEF] +QED val ALL_DISTINCT_FST = ALL_DISTINCT_MAP |> Q.ISPEC `FST` @@ -336,8 +344,8 @@ val env_to_list_perm = Q.prove(` full_simp_tac(srw_ss())[FUN_EQ_THM]); (*Proves s_val_eq and some extra conditions on the resulting lists*) -Theorem push_env_s_val_eq ` - ∀tperm. +Theorem push_env_s_val_eq: + ∀tperm. st.handler = cst.handler ∧ st.stack = cst.stack ∧ domain y = IMAGE f (domain x) ∧ @@ -356,8 +364,9 @@ Theorem push_env_s_val_eq ` (∀x y. MEM x (MAP FST l') ∧ MEM y (MAP FST l') ∧ f x = f y ⇒ x = y) ) ∧ s_val_eq (push_env x b (st with permute:=perm)).stack - (push_env y b' cst).stack` - (srw_tac[][]>>Cases_on`b`>> + (push_env y b' cst).stack +Proof + srw_tac[][]>>Cases_on`b`>> TRY(PairCases_on`x'`>>Cases_on`b'`>>full_simp_tac(srw_ss())[]>>PairCases_on`x'`>>full_simp_tac(srw_ss())[])>> (full_simp_tac(srw_ss())[push_env_def]>> imp_res_tac env_to_list_perm>> @@ -380,12 +389,13 @@ Theorem push_env_s_val_eq ` `MAP SND (MAP (λx,y.f x,y) q) = MAP SND q` by (full_simp_tac(srw_ss())[MAP_MAP_o]>>AP_THM_TAC>>AP_TERM_TAC>>full_simp_tac(srw_ss())[FUN_EQ_THM]>> srw_tac[][]>>Cases_on`x'`>>full_simp_tac(srw_ss())[])>> - metis_tac[])); + metis_tac[]) +QED (*TODO: Maybe move to props? gc doesn't touch other components*) -Theorem gc_frame ` - gc st = SOME st' +Theorem gc_frame: + gc st = SOME st' ⇒ st'.fp_regs = st.fp_regs ∧ st'.mdomain = st.mdomain ∧ @@ -401,13 +411,15 @@ Theorem gc_frame ` st'.code_buffer = st.code_buffer ∧ st'.data_buffer = st.data_buffer ∧ st'.permute = st.permute ∧ - st'.termdep = st.termdep` - (full_simp_tac(srw_ss())[gc_def,LET_THM]>>EVERY_CASE_TAC>> - full_simp_tac(srw_ss())[state_component_equality]); + st'.termdep = st.termdep +Proof + full_simp_tac(srw_ss())[gc_def,LET_THM]>>EVERY_CASE_TAC>> + full_simp_tac(srw_ss())[state_component_equality] +QED (*Convenient rewrite for pop_env*) -Theorem s_key_eq_val_eq_pop_env ` - pop_env s = SOME s' ∧ +Theorem s_key_eq_val_eq_pop_env: + pop_env s = SOME s' ∧ s_key_eq s.stack ((StackFrame ls opt)::keys) ∧ s_val_eq s.stack vals ⇒ @@ -417,8 +429,9 @@ Theorem s_key_eq_val_eq_pop_env ` s_key_eq s'.stack keys ∧ s_val_eq s'.stack rest ∧ case opt of NONE => s'.handler = s.handler - | SOME (h,l1,l2) => s'.handler = h` - (strip_tac>> + | SOME (h,l1,l2) => s'.handler = h +Proof + strip_tac>> full_simp_tac(srw_ss())[pop_env_def]>> EVERY_CASE_TAC>> Cases_on`vals`>> @@ -426,17 +439,19 @@ Theorem s_key_eq_val_eq_pop_env ` Cases_on`h`>>Cases_on`o'`>> full_simp_tac(srw_ss())[s_frame_key_eq_def,s_frame_val_eq_def]>> full_simp_tac(srw_ss())[state_component_equality]>> - metis_tac[ZIP_MAP_FST_SND_EQ]); + metis_tac[ZIP_MAP_FST_SND_EQ] +QED (*Less powerful form*) -Theorem ALOOKUP_key_remap_2 ` - ∀ls vals f. +Theorem ALOOKUP_key_remap_2: + ∀ls vals f. (∀x y. MEM x ls ∧ MEM y ls ∧ f x = f y ⇒ x = y) ∧ LENGTH ls = LENGTH vals ∧ ALOOKUP (ZIP (ls,vals)) n = SOME v ⇒ - ALOOKUP (ZIP (MAP f ls,vals)) (f n) = SOME v` - (Induct>>srw_tac[][]>> + ALOOKUP (ZIP (MAP f ls,vals)) (f n) = SOME v +Proof + Induct>>srw_tac[][]>> Cases_on`vals`>>full_simp_tac(srw_ss())[]>> Cases_on`h=n`>>full_simp_tac(srw_ss())[]>> `MEM n ls` by @@ -445,7 +460,8 @@ Theorem ALOOKUP_key_remap_2 ` full_simp_tac(srw_ss())[]>> metis_tac[MEM_EL])>> first_assum(qspecl_then[`h`,`n`] assume_tac)>> - IF_CASES_TAC>>full_simp_tac(srw_ss())[]); + IF_CASES_TAC>>full_simp_tac(srw_ss())[] +QED val lookup_alist_insert = sptreeTheory.lookup_alist_insert |> INST_TYPE [alpha|->``:'a word_loc``] @@ -468,31 +484,37 @@ val env_to_list_keys = Q.prove(` >> full_simp_tac(srw_ss())[mem_list_rearrange,QSORT_MEM,MEM_toAList,domain_lookup]); -Theorem list_rearrange_keys ` - list_rearrange perm (ls:('a,'b) alist) = e ⇒ - set(MAP FST e) = set(MAP FST ls)` - (rw[]>>fs[EXTENSION]>> - metis_tac[MEM_toAList,mem_list_rearrange,MEM_MAP]); +Theorem list_rearrange_keys: + list_rearrange perm (ls:('a,'b) alist) = e ⇒ + set(MAP FST e) = set(MAP FST ls) +Proof + rw[]>>fs[EXTENSION]>> + metis_tac[MEM_toAList,mem_list_rearrange,MEM_MAP] +QED -Theorem pop_env_frame - `s_val_eq r'.stack st' ∧ +Theorem pop_env_frame: + s_val_eq r'.stack st' ∧ s_key_eq y'.stack y''.stack ∧ pop_env (r' with stack:= st') = SOME y'' ∧ pop_env r' = SOME y' ⇒ - word_state_eq_rel y' y''` - (full_simp_tac(srw_ss())[pop_env_def]>>EVERY_CASE_TAC>> + word_state_eq_rel y' y'' +Proof + full_simp_tac(srw_ss())[pop_env_def]>>EVERY_CASE_TAC>> full_simp_tac(srw_ss())[s_val_eq_def,s_frame_val_eq_def,word_state_eq_rel_def ,state_component_equality]>> srw_tac[][]>>rev_full_simp_tac(srw_ss())[]>> - metis_tac[s_val_and_key_eq]); - -Theorem key_map_implies - `MAP (λx,y.f x,y) l' = l - ⇒ MAP f (MAP FST l') = MAP FST l` - (srw_tac[][]>>match_mp_tac LIST_EQ>> + metis_tac[s_val_and_key_eq] +QED + +Theorem key_map_implies: + MAP (λx,y.f x,y) l' = l + ⇒ MAP f (MAP FST l') = MAP FST l +Proof + srw_tac[][]>>match_mp_tac LIST_EQ>> srw_tac[][EL_MAP]>> - Cases_on`EL x l'`>>full_simp_tac(srw_ss())[]); + Cases_on`EL x l'`>>full_simp_tac(srw_ss())[] +QED (*Main proof of liveness theorem starts here*) @@ -529,20 +551,23 @@ val apply_colour_exp_lemma = Q.prove( qpat_x_assum`A=SOME res`mp_tac>>TOP_CASE_TAC>>rw[]>> fs[]); -Theorem get_fp_var_perm[simp] - `get_fp_var r (st with permute:= p) = get_fp_var r st` - (EVAL_TAC); +Theorem get_fp_var_perm[simp]: + get_fp_var r (st with permute:= p) = get_fp_var r st +Proof + EVAL_TAC +QED -Theorem strong_locals_rel_insert - ` - INJ f (n INSERT l) UNIV /\ +Theorem strong_locals_rel_insert: + INJ f (n INSERT l) UNIV /\ strong_locals_rel f (l DELETE n) st cst ⇒ - strong_locals_rel f l (insert n v st) (insert (f n) v cst)` - (rw[strong_locals_rel_def]>>fs[lookup_insert]>> + strong_locals_rel f l (insert n v st) (insert (f n) v cst) +Proof + rw[strong_locals_rel_def]>>fs[lookup_insert]>> Cases_on`n'=n`>>fs[]>> IF_CASES_TAC>> fs[INJ_DEF]>> - metis_tac[domain_lookup]); + metis_tac[domain_lookup] +QED (*Frequently used tactics*) val exists_tac = qexists_tac`cst.permute`>> @@ -574,8 +599,8 @@ val toAList_not_empty = Q.prove(` full_simp_tac(srw_ss())[GSYM toAList_domain]); (*liveness theorem*) -Theorem evaluate_apply_colour -`∀prog st cst f live. +Theorem evaluate_apply_colour: + ∀prog st cst f live. colouring_ok f prog live ∧ word_state_eq_rel (st:('a,'c,'ffi) wordSem$state) cst ∧ strong_locals_rel f (domain (get_live prog live)) st.locals cst.locals @@ -589,8 +614,9 @@ Theorem evaluate_apply_colour (case res of NONE => strong_locals_rel f (domain live) rst.locals rcst.locals - | SOME _ => rst.locals = rcst.locals )` - ((*Induct on size of program*) + | SOME _ => rst.locals = rcst.locals ) +Proof + (*Induct on size of program*) completeInduct_on`prog_size (K 0) prog`>> rpt strip_tac>> full_simp_tac(srw_ss())[PULL_FORALL,evaluate_def]>> @@ -1329,7 +1355,8 @@ Theorem evaluate_apply_colour FULL_CASE_TAC>>full_simp_tac(srw_ss())[]>> Cases_on`call_FFI st.ffi s x'' x'`>>full_simp_tac(srw_ss())[strong_locals_rel_def]>> srw_tac[][]>>simp[call_env_def]>> - metis_tac[domain_lookup])); + metis_tac[domain_lookup]) +QED (* TODO: get_clash_sets, made redundant by clash tree *) @@ -1397,12 +1424,13 @@ val get_clash_sets_tl = Q.prove( >- metis_tac[INJ_UNION,domain_union,INJ_SUBSET,SUBSET_UNION] >- metis_tac[INJ_UNION,domain_union,INJ_SUBSET,SUBSET_UNION]); -Theorem colouring_ok_alt_thm -`∀f prog live. +Theorem colouring_ok_alt_thm: + ∀f prog live. colouring_ok_alt f prog live ⇒ - colouring_ok f prog live` - (ho_match_mp_tac (fetch "-" "colouring_ok_ind")>> + colouring_ok f prog live +Proof + ho_match_mp_tac (fetch "-" "colouring_ok_ind")>> srw_tac[][]>> full_simp_tac(srw_ss())[get_clash_sets_def,colouring_ok_alt_def,colouring_ok_def,LET_THM] >- @@ -1431,7 +1459,8 @@ Theorem colouring_ok_alt_thm EVERY_CASE_TAC>> full_simp_tac(srw_ss())[LET_THM]>> Cases_on`get_clash_sets prog live`>> - full_simp_tac(srw_ss())[UNCURRY]); + full_simp_tac(srw_ss())[UNCURRY] +QED val fs1 = full_simp_tac(srw_ss())[LET_THM, get_clash_sets_def, every_var_def, get_live_def, domain_numset_list_insert, @@ -1450,13 +1479,14 @@ val every_var_exp_get_live_exp = Q.prove( (* (*Every variable is in some clash set*) -Theorem every_var_in_get_clash_set -`∀prog live. +Theorem every_var_in_get_clash_set: + ∀prog live. let (hd,clash_sets) = get_clash_sets prog live in let ls = hd::clash_sets in (∀x. x ∈ domain live ⇒ in_clash_sets ls x) ∧ - (every_var (in_clash_sets ls) prog)` - (completeInduct_on`prog_size (K 0) prog`>> + (every_var (in_clash_sets ls) prog) +Proof + completeInduct_on`prog_size (K 0) prog`>> ntac 2 (full_simp_tac(srw_ss())[Once PULL_FORALL])>> rpt strip_tac>> Cases_on`prog`>>fs1>> @@ -1615,7 +1645,8 @@ Theorem every_var_in_get_clash_set full_simp_tac(srw_ss())[domain_union]>>metis_tac[domain_union])>> TRY(HINT_EXISTS_TAC>>metis_tac[domain_union])>> TRY(qexists_tac`insert n () (union q' q)`>> - full_simp_tac(srw_ss())[domain_union]>>metis_tac[domain_union]))); + full_simp_tac(srw_ss())[domain_union]>>metis_tac[domain_union])) +QED full_simp_tac(srw_ss())[domain_union]>>metis_tac[domain_union])) >- @@ -1640,20 +1671,21 @@ Theorem every_var_in_get_clash_set *) (* Proofs for check_clash_tree *) -Theorem check_col_INJ - ` - check_col f numset = SOME (q,r) ⇒ +Theorem check_col_INJ: + check_col f numset = SOME (q,r) ⇒ q = numset ∧ INJ f (domain q) UNIV ∧ - domain r = IMAGE f (domain q)` - (rw[check_col_def,GSYM MAP_MAP_o] + domain r = IMAGE f (domain q) +Proof + rw[check_col_def,GSYM MAP_MAP_o] >- (fs[INJ_DEF,domain_lookup,FORALL_PROD,GSYM MEM_toAList]>>rw[]>> fs[EL_ALL_DISTINCT_EL_EQ,MEM_EL,EL_MAP]>> metis_tac[FST]) >> fs[domain_fromAList,EXTENSION,MEM_MAP,EXISTS_PROD,MEM_toAList]>> - fs[domain_lookup]); + fs[domain_lookup] +QED val wf_insert_swap = Q.prove(` wf (t:num_set) ⇒ @@ -1675,8 +1707,8 @@ val numset_list_insert_swap = Q.prove(` res_tac>> fs[wf_insert,wf_insert_swap]); -Theorem check_partial_col_INJ - `∀ls f live flive live' flive'. +Theorem check_partial_col_INJ: + ∀ls f live flive live' flive'. wf live ∧ domain flive = IMAGE f (domain live) ∧ INJ f (domain live) UNIV ∧ @@ -1684,8 +1716,9 @@ Theorem check_partial_col_INJ wf live' ∧ live' = numset_list_insert ls live ∧ INJ f (domain live') UNIV ∧ - domain flive' = IMAGE f (domain live')` - (Induct>>fs[check_partial_col_def,numset_list_insert_def]>> + domain flive' = IMAGE f (domain live') +Proof + Induct>>fs[check_partial_col_def,numset_list_insert_def]>> ntac 6 strip_tac>> TOP_CASE_TAC>>fs[]>>strip_tac >- @@ -1724,7 +1757,8 @@ Theorem check_partial_col_INJ (dep_rewrite.DEP_REWRITE_TAC[spt_eq_thm]>> simp[wf_insert,lookup_insert]>> rw[])>> - fs[]); + fs[] +QED val domain_insert_eq_union = Q.prove(` domain (insert num () live) = domain (union (insert num () LN) live)`, @@ -1829,8 +1863,8 @@ val subset_tac = HINT_EXISTS_TAC>>fs[domain_numset_list_insert_eq_union,SUBSET_DEF]>> simp[domain_union]; -Theorem clash_tree_colouring_ok ` - ∀prog f live flive livein flivein. +Theorem clash_tree_colouring_ok: + ∀prog f live flive livein flivein. wf_cutsets prog ∧ wf live ∧ domain flive = IMAGE f (domain live) ∧ @@ -1841,8 +1875,9 @@ Theorem clash_tree_colouring_ok ` INJ f (domain livein) UNIV ∧ colouring_ok f prog live ∧ livein = get_live prog live ∧ - domain flivein = IMAGE f (domain livein))` - (ho_match_mp_tac get_clash_tree_ind>>fs[get_clash_tree_def,check_clash_tree_def,colouring_ok_def,get_live_def,get_writes_def]>>rw[] + domain flivein = IMAGE f (domain livein)) +Proof + ho_match_mp_tac get_clash_tree_ind>>fs[get_clash_tree_def,check_clash_tree_def,colouring_ok_def,get_live_def,get_writes_def]>>rw[] >- fs[hide_def,numset_list_delete_def,check_partial_col_def] >- @@ -2142,7 +2177,8 @@ Theorem clash_tree_colouring_ok ` rveq>> imp_res_tac check_col_INJ>> rveq>> - fs[numset_list_insert_swap,wf_def,wf_union])); + fs[numset_list_insert_swap,wf_def,wf_union]) +QED (*Actually, it should probably be exactly 0,2,4,6...*) val even_starting_locals_def = Define` @@ -2219,8 +2255,8 @@ val total_colour_rw = Q.prove(` IF_CASES_TAC>>simp[]>> metis_tac[is_phy_var_def,EVEN_MOD2,EVEN_EXISTS,TWOxDIV2]); -Theorem select_reg_alloc_correct ` - !alg spillcosts k heu_moves tree forced. +Theorem select_reg_alloc_correct: + !alg spillcosts k heu_moves tree forced. EVERY (\r1,r2. in_clash_tree tree r1 /\ in_clash_tree tree r2) forced ==> ?spcol livein flivein. select_reg_alloc alg spillcosts k heu_moves tree forced = Success spcol /\ @@ -2235,20 +2271,20 @@ Theorem select_reg_alloc_correct ` T ) /\ (!r. r IN domain spcol ==> in_clash_tree tree r) /\ - EVERY (\r1,r2. (sp_default spcol) r1 = (sp_default spcol) r2 ==> r1 = r2) forced` - - (simp [select_reg_alloc_def] >> rpt strip_tac >> + EVERY (\r1,r2. (sp_default spcol) r1 = (sp_default spcol) r2 ==> r1 = r2) forced +Proof + simp [select_reg_alloc_def] >> rpt strip_tac >> qabbrev_tac`algg = if alg ≤ 1 then Simple else IRC` >> drule linear_scan_reg_alloc_correct >> disch_then (qspecl_then [`k`, `heu_moves`] assume_tac) >> drule reg_alloc_correct >> disch_then (qspecl_then [`algg`, `spillcosts`, `k`, `heu_moves`] assume_tac) >> rw [] >> fs [] -) +QED (*Prove the full correctness theorem for word_alloc*) -Theorem word_alloc_correct ` - ∀fc c alg prog k col_opt st. +Theorem word_alloc_correct: + ∀fc c alg prog k col_opt st. even_starting_locals st.locals ∧ wf_cutsets prog ⇒ @@ -2260,8 +2296,9 @@ Theorem word_alloc_correct ` word_state_eq_rel rst rcst ∧ case res of NONE => T - | SOME _ => rst.locals = rcst.locals` - (srw_tac[][]>> + | SOME _ => rst.locals = rcst.locals +Proof + srw_tac[][]>> qpat_abbrev_tac`cprog = word_alloc _ _ _ _ _ _`>> full_simp_tac(srw_ss())[word_alloc_def]>> pop_assum mp_tac>>LET_ELIM_TAC>> @@ -2321,7 +2358,8 @@ Theorem word_alloc_correct ` rw[]>> qexists_tac`perm'`>>rw[]>> fs[]>> - FULL_CASE_TAC>>fs[]); + FULL_CASE_TAC>>fs[] +QED val apply_colour_exp_I = Q.prove(` ∀f exp. @@ -2413,8 +2451,8 @@ val strong_locals_rel_I_insert_insert = Q.prove(` rw[strong_locals_rel_def,lookup_insert]>> IF_CASES_TAC>>fs[]); -Theorem evaluate_remove_dead -`∀prog live prog' livein st t res rst. +Theorem evaluate_remove_dead: + ∀prog live prog' livein st t res rst. strong_locals_rel I (domain livein) st.locals t ∧ evaluate (prog,st) = (res,rst) ∧ remove_dead prog live = (prog',livein) ∧ @@ -2423,8 +2461,9 @@ Theorem evaluate_remove_dead evaluate(prog',st with locals := t) = (res,rst with locals:=t') ∧ (case res of NONE => strong_locals_rel I (domain live) rst.locals t' - | SOME _ => rst.locals = t')` - (ho_match_mp_tac remove_dead_ind>>rw[]>> + | SOME _ => rst.locals = t') +Proof + ho_match_mp_tac remove_dead_ind>>rw[]>> fs[remove_dead_def]>> rpt var_eq_tac>>fs[get_live_def,evaluate_def,state_component_equality,set_var_def] >- @@ -2793,7 +2832,8 @@ Theorem evaluate_remove_dead rpt strip_tac >> rveq >> fs[state_component_equality]>> rveq>>fs[]>> rpt(qpat_x_assum `_ (call_env _ _) = _` (mp_tac o GSYM))>> - simp[call_env_def])); + simp[call_env_def]) +QED (*SSA Proof*) val size_tac = impl_tac>- (full_simp_tac(srw_ss())[prog_size_def]>>DECIDE_TAC) @@ -4222,8 +4262,8 @@ val get_var_set_vars_notin = Q.prove(` imp_res_tac ALOOKUP_ZIP_MEM>> fs[]); -Theorem ssa_cc_trans_correct -`∀prog st cst ssa na. +Theorem ssa_cc_trans_correct: + ∀prog st cst ssa na. word_state_eq_rel st cst ∧ ssa_locals_rel na ssa st.locals cst.locals ∧ (*The following 3 assumptions are from the transform properties and @@ -4242,8 +4282,9 @@ Theorem ssa_cc_trans_correct (case res of NONE => ssa_locals_rel na' ssa' rst.locals rcst.locals - | SOME _ => rst.locals = rcst.locals )` - (completeInduct_on`prog_size (K 0) prog`>> + | SOME _ => rst.locals = rcst.locals ) +Proof + completeInduct_on`prog_size (K 0) prog`>> rpt strip_tac>> full_simp_tac(srw_ss())[PULL_FORALL,evaluate_def]>> Cases_on`prog` @@ -6033,7 +6074,8 @@ Theorem ssa_cc_trans_correct full_simp_tac(srw_ss())[]>>DECIDE_TAC))>> full_simp_tac(srw_ss())[LET_THM]>> srw_tac[][]>> - Cases_on`evaluate(ret_mov,rcstt)`>>unabbrev_all_tac>>full_simp_tac(srw_ss())[state_component_equality,word_state_eq_rel_def]); + Cases_on`evaluate(ret_mov,rcstt)`>>unabbrev_all_tac>>full_simp_tac(srw_ss())[state_component_equality,word_state_eq_rel_def] +QED (*For starting up*) val setup_ssa_props = Q.prove(` @@ -6129,10 +6171,11 @@ val max_var_inst_max = Q.prove(` TRY(IF_CASES_TAC)>>full_simp_tac(srw_ss())[]>> DECIDE_TAC); -Theorem max_var_max ` - ∀prog. - every_var (λx. x ≤ max_var prog) prog` - (ho_match_mp_tac max_var_ind>> +Theorem max_var_max: + ∀prog. + every_var (λx. x ≤ max_var prog) prog +Proof + ho_match_mp_tac max_var_ind>> srw_tac[][every_var_def,max_var_def]>> TRY(Cases_on`ri`)>>full_simp_tac(srw_ss())[every_var_imm_def]>> rpt IF_CASES_TAC>>full_simp_tac(srw_ss())[]>> @@ -6183,7 +6226,8 @@ Theorem max_var_max ` TRY(res_tac>>DECIDE_TAC) >> fs[list_max_def]>> - res_tac>>every_case_tac>>fs[]); + res_tac>>every_case_tac>>fs[] +QED val limit_var_props = Q.prove(` limit_var prog = lim ⇒ @@ -6221,8 +6265,8 @@ val limit_var_props = Q.prove(` full_simp_tac(srw_ss())[]); (*Full correctness theorem*) -Theorem full_ssa_cc_trans_correct -`∀prog st n. +Theorem full_ssa_cc_trans_correct: + ∀prog st n. domain st.locals = set (even_list n) ⇒ ∃perm'. let (res,rst) = evaluate(prog,st with permute:=perm') in @@ -6232,8 +6276,9 @@ Theorem full_ssa_cc_trans_correct word_state_eq_rel rst rcst ∧ (case res of NONE => T - | SOME _ => rst.locals = rcst.locals )` - (srw_tac[][]>> + | SOME _ => rst.locals = rcst.locals ) +Proof + srw_tac[][]>> qpat_abbrev_tac`sprog = full_ssa_cc_trans n prog`>> full_simp_tac(srw_ss())[full_ssa_cc_trans_def]>> pop_assum mp_tac>>LET_ELIM_TAC>> @@ -6252,7 +6297,8 @@ Theorem full_ssa_cc_trans_correct srw_tac[][]>> qexists_tac`perm'`>>srw_tac[][]>> full_simp_tac(srw_ss())[LET_THM]>> - FULL_CASE_TAC>>full_simp_tac(srw_ss())[]); + FULL_CASE_TAC>>full_simp_tac(srw_ss())[] +QED (* Prove that the ssa form sets up pre_alloc_conventions and preserves some syntactic conventions @@ -6292,13 +6338,14 @@ val fix_inconsistencies_conventions = Q.prove(` (*Prove that the transform sets up arbitrary programs with the appropriate conventions*) -Theorem ssa_cc_trans_pre_alloc_conventions -`∀prog ssa na. +Theorem ssa_cc_trans_pre_alloc_conventions: + ∀prog ssa na. is_alloc_var na ∧ ssa_map_ok na ssa ⇒ let (prog',ssa',na') = ssa_cc_trans prog ssa na in - pre_alloc_conventions prog'` - (completeInduct_on`wordLang$prog_size (K 0) prog`>> + pre_alloc_conventions prog' +Proof + completeInduct_on`wordLang$prog_size (K 0) prog`>> rpt strip_tac>> full_simp_tac(srw_ss())[PULL_FORALL,LET_THM]>> Cases_on`prog`>> @@ -6480,7 +6527,8 @@ Theorem ssa_cc_trans_pre_alloc_conventions `na+(4*aa+2) = aa * 4 + (na+2)` by fs[]>> pop_assum SUBST1_TAC>> DEP_REWRITE_TAC [MOD_TIMES]>> - fs[]); + fs[] +QED val setup_ssa_props_2 = Q.prove(` is_alloc_var lim ⇒ @@ -6498,17 +6546,19 @@ val setup_ssa_props_2 = Q.prove(` full_simp_tac(srw_ss())[ssa_map_ok_def,lookup_def]>> imp_res_tac list_next_var_rename_props>>NO_TAC)); -Theorem full_ssa_cc_trans_pre_alloc_conventions -`∀n prog. - pre_alloc_conventions (full_ssa_cc_trans n prog)` - (full_simp_tac(srw_ss())[full_ssa_cc_trans_def,pre_alloc_conventions_def,list_next_var_rename_move_def]>>LET_ELIM_TAC>> +Theorem full_ssa_cc_trans_pre_alloc_conventions: + ∀n prog. + pre_alloc_conventions (full_ssa_cc_trans n prog) +Proof + full_simp_tac(srw_ss())[full_ssa_cc_trans_def,pre_alloc_conventions_def,list_next_var_rename_move_def]>>LET_ELIM_TAC>> full_simp_tac(srw_ss())[Abbr`lim'`]>> imp_res_tac limit_var_props>> imp_res_tac setup_ssa_props_2>> pop_assum(qspecl_then [`prog`,`n`] assume_tac)>>rev_full_simp_tac(srw_ss())[LET_THM]>> imp_res_tac ssa_cc_trans_props>> Q.ISPECL_THEN [`prog`,`ssa`,`na`] assume_tac ssa_cc_trans_pre_alloc_conventions>> - rev_full_simp_tac(srw_ss())[pre_alloc_conventions_def,every_stack_var_def,call_arg_convention_def,LET_THM]); + rev_full_simp_tac(srw_ss())[pre_alloc_conventions_def,every_stack_var_def,call_arg_convention_def,LET_THM] +QED val fake_moves_wf_cutsets = Q.prove(` ∀ls A B C L R D E G. @@ -6540,16 +6590,18 @@ val ssa_cc_trans_wf_cutsets = Q.prove(` rpt(pairarg_tac>>fs[])>>rveq>>fs[wf_cutsets_def,wf_fromAList]>> metis_tac[fake_moves_wf_cutsets]); -Theorem full_ssa_cc_trans_wf_cutsets ` - ∀n prog. - wf_cutsets (full_ssa_cc_trans n prog)` - (fs[full_ssa_cc_trans_def,setup_ssa_def,list_next_var_rename_move_def]>> +Theorem full_ssa_cc_trans_wf_cutsets: + ∀n prog. + wf_cutsets (full_ssa_cc_trans n prog) +Proof + fs[full_ssa_cc_trans_def,setup_ssa_def,list_next_var_rename_move_def]>> rw[]>>pairarg_tac>>fs[]>> pairarg_tac>>fs[]>> pairarg_tac>>fs[]>> rveq>>fs[wf_cutsets_def]>> Q.ISPECL_THEN [`prog`,`ssa`,`n'`] assume_tac ssa_cc_trans_wf_cutsets>> - rfs[]); + rfs[] +QED val fake_moves_distinct_tar_reg = Q.prove(` ∀ls ssal ssar na l r a b c conf. @@ -6668,10 +6720,11 @@ val ssa_cc_trans_distinct_tar_reg = Q.prove(` LET_ELIM_TAC>>full_simp_tac(srw_ss())[EQ_SYM_EQ,every_inst_def]>> metis_tac[fake_moves_distinct_tar_reg]); -Theorem full_ssa_cc_trans_distinct_tar_reg ` - ∀n prog. - every_inst distinct_tar_reg (full_ssa_cc_trans n prog)` - (srw_tac[][]>> +Theorem full_ssa_cc_trans_distinct_tar_reg: + ∀n prog. + every_inst distinct_tar_reg (full_ssa_cc_trans n prog) +Proof + srw_tac[][]>> full_simp_tac(srw_ss())[full_ssa_cc_trans_def]>> LET_ELIM_TAC>> simp[every_inst_def]>>CONJ_TAC @@ -6690,7 +6743,8 @@ Theorem full_ssa_cc_trans_distinct_tar_reg ` impl_tac>- (rev_full_simp_tac(srw_ss())[]>>match_mp_tac every_var_mono>>HINT_EXISTS_TAC>>full_simp_tac(srw_ss())[]>> DECIDE_TAC)>> - full_simp_tac(srw_ss())[]); + full_simp_tac(srw_ss())[] +QED val fake_moves_conventions2 = Q.prove(` ∀ls ssal ssar na l r a b c conf. @@ -6746,13 +6800,15 @@ val ssa_cc_trans_flat_exp_conventions = Q.prove(` rpt (pop_assum mp_tac)>> LET_ELIM_TAC>>full_simp_tac(srw_ss())[]>> metis_tac[fake_moves_conventions2,flat_exp_conventions_def]); -Theorem full_ssa_cc_trans_flat_exp_conventions ` - ∀prog n. +Theorem full_ssa_cc_trans_flat_exp_conventions: + ∀prog n. flat_exp_conventions prog ⇒ - flat_exp_conventions (full_ssa_cc_trans n prog)` - (full_simp_tac(srw_ss())[full_ssa_cc_trans_def,setup_ssa_def,list_next_var_rename_move_def]>> + flat_exp_conventions (full_ssa_cc_trans n prog) +Proof + full_simp_tac(srw_ss())[full_ssa_cc_trans_def,setup_ssa_def,list_next_var_rename_move_def]>> LET_ELIM_TAC>>unabbrev_all_tac>>full_simp_tac(srw_ss())[flat_exp_conventions_def,EQ_SYM_EQ]>> - metis_tac[ssa_cc_trans_flat_exp_conventions,FST]); + metis_tac[ssa_cc_trans_flat_exp_conventions,FST] +QED val ssa_cc_trans_full_inst_ok_less = Q.prove(` ∀prog ssa na c. @@ -6869,11 +6925,12 @@ val ssa_cc_trans_full_inst_ok_less = Q.prove(` metis_tac[convention_partitions]) >- metis_tac[fake_moves_conventions2,full_inst_ok_less_def]); -Theorem full_ssa_cc_trans_full_inst_ok_less ` - ∀prog n c. +Theorem full_ssa_cc_trans_full_inst_ok_less: + ∀prog n c. full_inst_ok_less c prog ⇒ - full_inst_ok_less c (full_ssa_cc_trans n prog)` - (full_simp_tac(srw_ss())[full_ssa_cc_trans_def,list_next_var_rename_move_def]>> + full_inst_ok_less c (full_ssa_cc_trans n prog) +Proof + full_simp_tac(srw_ss())[full_ssa_cc_trans_def,list_next_var_rename_move_def]>> LET_ELIM_TAC>> fs[markerTheory.Abbrev_def]>> imp_res_tac (GSYM limit_var_props)>> @@ -6884,7 +6941,8 @@ Theorem full_ssa_cc_trans_full_inst_ok_less ` Q.SPECL_THEN [`prog`,`ssa`,`n'`,`c`] mp_tac ssa_cc_trans_full_inst_ok_less>> impl_tac>>fs[]>> match_mp_tac every_var_mono>> - HINT_EXISTS_TAC>>fs[]); + HINT_EXISTS_TAC>>fs[] +QED (* word_alloc syntactic stuff *) @@ -6957,29 +7015,34 @@ val call_arg_convention_preservation = Q.prove(` rev_full_simp_tac(srw_ss())[]); (*Composing with a function using apply_colour*) -Theorem every_var_inst_apply_colour_inst ` - ∀P inst Q f. +Theorem every_var_inst_apply_colour_inst: + ∀P inst Q f. every_var_inst P inst ∧ (∀x. P x ⇒ Q (f x)) ⇒ - every_var_inst Q (apply_colour_inst f inst)` - (ho_match_mp_tac every_var_inst_ind>>srw_tac[][every_var_inst_def]>> + every_var_inst Q (apply_colour_inst f inst) +Proof + ho_match_mp_tac every_var_inst_ind>>srw_tac[][every_var_inst_def]>> TRY(Cases_on`ri`>>full_simp_tac(srw_ss())[apply_colour_imm_def])>> - EVERY_CASE_TAC>>full_simp_tac(srw_ss())[every_var_imm_def]); + EVERY_CASE_TAC>>full_simp_tac(srw_ss())[every_var_imm_def] +QED -Theorem every_var_exp_apply_colour_exp ` - ∀P exp Q f. +Theorem every_var_exp_apply_colour_exp: + ∀P exp Q f. every_var_exp P exp ∧ (∀x. P x ⇒ Q (f x)) ⇒ - every_var_exp Q (apply_colour_exp f exp)` - (ho_match_mp_tac every_var_exp_ind>>srw_tac[][every_var_exp_def]>> - full_simp_tac(srw_ss())[EVERY_MAP,EVERY_MEM]); + every_var_exp Q (apply_colour_exp f exp) +Proof + ho_match_mp_tac every_var_exp_ind>>srw_tac[][every_var_exp_def]>> + full_simp_tac(srw_ss())[EVERY_MAP,EVERY_MEM] +QED -Theorem every_var_apply_colour ` - ∀P prog Q f. +Theorem every_var_apply_colour: + ∀P prog Q f. every_var P prog ∧ (∀x. P x ⇒ Q (f x)) ⇒ - every_var Q (apply_colour f prog)` - (ho_match_mp_tac every_var_ind>>srw_tac[][every_var_def]>> + every_var Q (apply_colour f prog) +Proof + ho_match_mp_tac every_var_ind>>srw_tac[][every_var_def]>> full_simp_tac(srw_ss())[MAP_ZIP,(GEN_ALL o SYM o SPEC_ALL) MAP_MAP_o]>> full_simp_tac(srw_ss())[EVERY_MAP,EVERY_MEM] >- @@ -7008,19 +7071,22 @@ Theorem every_var_apply_colour ` full_simp_tac(srw_ss())[domain_fromAList,MEM_MAP,ZIP_MAP]>>srw_tac[][]>> Cases_on`y'`>>full_simp_tac(srw_ss())[MEM_toAList,domain_lookup]) >> - metis_tac[every_var_exp_apply_colour_exp]); + metis_tac[every_var_exp_apply_colour_exp] +QED -Theorem every_stack_var_apply_colour ` - ∀P prog Q f. +Theorem every_stack_var_apply_colour: + ∀P prog Q f. every_stack_var P prog ∧ (∀x. P x ⇒ Q (f x)) ⇒ - every_stack_var Q (apply_colour f prog)` - (ho_match_mp_tac every_stack_var_ind>>srw_tac[][every_stack_var_def] + every_stack_var Q (apply_colour f prog) +Proof + ho_match_mp_tac every_stack_var_ind>>srw_tac[][every_stack_var_def] >> (EVERY_CASE_TAC>>unabbrev_all_tac>>full_simp_tac(srw_ss())[every_stack_var_def,EVERY_MAP,EVERY_MEM]>> full_simp_tac(srw_ss())[every_name_def,EVERY_MEM,toAList_domain]>> srw_tac[][]>>full_simp_tac(srw_ss())[domain_fromAList,MEM_MAP,ZIP_MAP]>> - Cases_on`y'`>>full_simp_tac(srw_ss())[MEM_toAList,domain_lookup])); + Cases_on`y'`>>full_simp_tac(srw_ss())[MEM_toAList,domain_lookup]) +QED val every_var_exp_get_reads_exp = Q.prove(` ∀exp. every_var_exp (λx. MEM x (get_reads_exp exp)) exp`, @@ -7091,11 +7157,12 @@ val oracle_colour_ok_conventions = Q.prove(` first_x_assum drule>>rw[]>> metis_tac[is_phy_var_def,EVEN_MOD2,EVEN_EXISTS,TWOxDIV2]); -Theorem pre_post_conventions_word_alloc ` - ∀fc c alg prog k col_opt. +Theorem pre_post_conventions_word_alloc: + ∀fc c alg prog k col_opt. pre_alloc_conventions prog ⇒ - post_alloc_conventions k (word_alloc fc c alg k prog col_opt)` - (rpt strip_tac>>fs[word_alloc_def]>> + post_alloc_conventions k (word_alloc fc c alg k prog col_opt) +Proof + rpt strip_tac>>fs[word_alloc_def]>> reverse TOP_CASE_TAC>>fs[] >- metis_tac[oracle_colour_ok_conventions] @@ -7128,7 +7195,8 @@ Theorem pre_post_conventions_word_alloc ` qexists_tac `in_clash_tree tree` >> rw[]>> first_x_assum drule>>fs[]>>rw[]>> fs[total_colour_def,sp_default_def,domain_lookup]>>rfs[]>> - metis_tac[is_phy_var_def,EVEN_MOD2,EVEN_EXISTS,TWOxDIV2]); + metis_tac[is_phy_var_def,EVEN_MOD2,EVEN_EXISTS,TWOxDIV2] +QED (*word_alloc preserves syntactic conventions*) val word_alloc_two_reg_inst_lem = Q.prove(` @@ -7142,13 +7210,15 @@ val word_alloc_two_reg_inst_lem = Q.prove(` >> EVERY_CASE_TAC>>unabbrev_all_tac>>full_simp_tac(srw_ss())[every_inst_def]); -Theorem word_alloc_two_reg_inst ` - ∀fc c alg k prog col_opt. +Theorem word_alloc_two_reg_inst: + ∀fc c alg k prog col_opt. every_inst two_reg_inst prog ⇒ - every_inst two_reg_inst (word_alloc fc c alg k prog col_opt)` - (full_simp_tac(srw_ss())[word_alloc_def,oracle_colour_ok_def]>> + every_inst two_reg_inst (word_alloc fc c alg k prog col_opt) +Proof + full_simp_tac(srw_ss())[word_alloc_def,oracle_colour_ok_def]>> srw_tac[][]>>EVERY_CASE_TAC>>full_simp_tac(srw_ss())[LET_THM]>> - metis_tac[word_alloc_two_reg_inst_lem]); + metis_tac[word_alloc_two_reg_inst_lem] +QED val word_alloc_flat_exp_conventions_lem = Q.prove(` ∀f prog. @@ -7160,13 +7230,15 @@ val word_alloc_flat_exp_conventions_lem = Q.prove(` >> Cases_on`exp`>>full_simp_tac(srw_ss())[flat_exp_conventions_def]); -Theorem word_alloc_flat_exp_conventions ` - ∀fc c alg k prog col_opt. +Theorem word_alloc_flat_exp_conventions: + ∀fc c alg k prog col_opt. flat_exp_conventions prog ⇒ - flat_exp_conventions (word_alloc fc c alg k prog col_opt)` - (full_simp_tac(srw_ss())[word_alloc_def,oracle_colour_ok_def]>> + flat_exp_conventions (word_alloc fc c alg k prog col_opt) +Proof + full_simp_tac(srw_ss())[word_alloc_def,oracle_colour_ok_def]>> srw_tac[][]>>EVERY_CASE_TAC>>full_simp_tac(srw_ss())[LET_THM]>> - metis_tac[word_alloc_flat_exp_conventions_lem]); + metis_tac[word_alloc_flat_exp_conventions_lem] +QED val word_alloc_full_inst_ok_less_lem = Q.prove(` ∀f prog c. @@ -7205,11 +7277,12 @@ val forced_distinct_col = Q.prove(` fs[total_colour_rw]>> metis_tac[]); -Theorem word_alloc_full_inst_ok_less ` - ∀fc alg k prog col_opt c. +Theorem word_alloc_full_inst_ok_less: + ∀fc alg k prog col_opt c. full_inst_ok_less c prog ⇒ - full_inst_ok_less c (word_alloc fc c alg k prog col_opt)` - (fs[word_alloc_def,oracle_colour_ok_def]>> + full_inst_ok_less c (word_alloc fc c alg k prog col_opt) +Proof + fs[word_alloc_def,oracle_colour_ok_def]>> rpt strip_tac>> pairarg_tac>>fs[]>> qpat_abbrev_tac`forced = get_forced _ _ _`>> @@ -7225,7 +7298,8 @@ Theorem word_alloc_full_inst_ok_less ` match_mp_tac forced_distinct_col>>rfs[]>> unabbrev_all_tac>> match_mp_tac get_forced_pairwise_distinct>> - simp[]); + simp[] +QED (* label preservation theorems *) val fake_moves_no_labs = Q.prove(` @@ -7237,10 +7311,11 @@ val fake_moves_no_labs = Q.prove(` EVERY_CASE_TAC>>fs[]>>rveq>>fs[extract_labels_def]>> metis_tac[]); -Theorem full_ssa_cc_trans_lab_pres ` - ∀prog n. - extract_labels prog = extract_labels (full_ssa_cc_trans n prog)` - (rw[full_ssa_cc_trans_def,setup_ssa_def,list_next_var_rename_move_def]>> +Theorem full_ssa_cc_trans_lab_pres: + ∀prog n. + extract_labels prog = extract_labels (full_ssa_cc_trans n prog) +Proof + rw[full_ssa_cc_trans_def,setup_ssa_def,list_next_var_rename_move_def]>> ntac 3 (pairarg_tac>>fs[])>>rveq>>fs[extract_labels_def]>> pop_assum kall_tac >> pop_assum mp_tac>> map_every qid_spec_tac (rev[`prog`,`ssa`,`n'`,`prog'`,`ssa'`,`na'`])>> @@ -7255,7 +7330,8 @@ Theorem full_ssa_cc_trans_lab_pres ` fs[extract_labels_def]) >> imp_res_tac fake_moves_no_labs>> - fs[]); + fs[] +QED val apply_colour_lab_pres = Q.prove(` ∀col prog. @@ -7263,31 +7339,35 @@ val apply_colour_lab_pres = Q.prove(` ho_match_mp_tac apply_colour_ind>>fs[extract_labels_def]>>rw[]>> EVERY_CASE_TAC>>fs[]); -Theorem word_alloc_lab_pres ` - extract_labels prog = extract_labels (word_alloc fc c alg k prog col_opt)` - (fs[word_alloc_def,oracle_colour_ok_def]>> +Theorem word_alloc_lab_pres: + extract_labels prog = extract_labels (word_alloc fc c alg k prog col_opt) +Proof + fs[word_alloc_def,oracle_colour_ok_def]>> EVERY_CASE_TAC>>fs[]>> TRY(pairarg_tac)>>fs[]>> EVERY_CASE_TAC>>fs[]>> - metis_tac[apply_colour_lab_pres]); + metis_tac[apply_colour_lab_pres] +QED (* every remove_dead syntactic theorem proved together *) val convs = [flat_exp_conventions_def,full_inst_ok_less_def,every_inst_def,pre_alloc_conventions_def,call_arg_convention_def,every_stack_var_def,every_var_def,extract_labels_def,wf_cutsets_def]; -Theorem remove_dead_conventions - `∀p live c k. +Theorem remove_dead_conventions: + ∀p live c k. let comp = FST (remove_dead p live) in (flat_exp_conventions p ⇒ flat_exp_conventions comp) ∧ (full_inst_ok_less c p ⇒ full_inst_ok_less c comp) ∧ (pre_alloc_conventions p ⇒ pre_alloc_conventions comp) ∧ (every_inst distinct_tar_reg p ⇒ every_inst distinct_tar_reg comp) ∧ (wf_cutsets p ⇒ wf_cutsets comp) ∧ - (extract_labels p = extract_labels comp)` - (ho_match_mp_tac remove_dead_ind>>rw[]>> + (extract_labels p = extract_labels comp) +Proof + ho_match_mp_tac remove_dead_ind>>rw[]>> fs[remove_dead_def]>> rpt IF_CASES_TAC>>fs convs>> rpt(pairarg_tac>>fs[])>> rw[]>> fs convs>> - EVERY_CASE_TAC>>fs convs); + EVERY_CASE_TAC>>fs convs +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/word_bignumProofScript.sml b/compiler/backend/proofs/word_bignumProofScript.sml index 78ddaeb4bb..77e43136db 100644 --- a/compiler/backend/proofs/word_bignumProofScript.sml +++ b/compiler/backend/proofs/word_bignumProofScript.sml @@ -157,15 +157,17 @@ val eval_cases = ``Eval rec s1 (Loop r vs p) s2``, ``Eval rec s1 (LoopBody p) s2``] |> LIST_CONJ; -Theorem Eval_NONE_IMP - `!s1 c s2 p. Eval NONE s1 c s2 ==> Eval (SOME p) s1 c s2` - (qsuff_tac +Theorem Eval_NONE_IMP: + !s1 c s2 p. Eval NONE s1 c s2 ==> Eval (SOME p) s1 c s2 +Proof + qsuff_tac `!r s1 c s2. Eval r s1 c s2 ==> Eval r s1 c s2 /\ !p. r = NONE ==> Eval (SOME p) s1 c s2` THEN1 metis_tac [] \\ ho_match_mp_tac eval_ind \\ rw [] - \\ once_rewrite_tac [eval_cases] \\ fs [] \\ metis_tac []); + \\ once_rewrite_tac [eval_cases] \\ fs [] \\ metis_tac [] +QED (* verification of compiler to wordLang *) @@ -303,14 +305,16 @@ val syntax_ok_def = Define ` syntax_ok (LoopBody body) = syntax_ok_aux body /\ syntax_ok p = syntax_ok_aux p` -Theorem evaluate_Seq_Seq - `!p1 p2 p3 t1. - wordSem$evaluate (Seq p1 (Seq p2 p3),t1) = evaluate (Seq (Seq p1 p2) p3,t1)` - (Induct +Theorem evaluate_Seq_Seq: + !p1 p2 p3 t1. + wordSem$evaluate (Seq p1 (Seq p2 p3),t1) = evaluate (Seq (Seq p1 p2) p3,t1) +Proof + Induct \\ fs [evaluate_def] \\ rw [] \\ every_case_tac \\ fs [] \\ pairarg_tac \\ fs [] - \\ rw []); + \\ rw [] +QED val env_to_list_insert_0_LN = prove( ``env_to_list (insert 0 ret_val LN) p = ([0,ret_val],(\n. p (n+1)))``, @@ -435,11 +439,13 @@ val LESS_LENGTH_IMP_APPEND = prove( Induct \\ fs [] \\ Cases_on `n` \\ fs [LENGTH_NIL] \\ rw [] \\ res_tac \\ fs [] \\ qexists_tac `h::ys` \\ fs []); -Theorem word_list_APPEND - `!xs ys a. word_list a (xs ++ ys) = - word_list a xs * word_list (a + n2w (LENGTH xs) * bytes_in_word) ys` - (Induct \\ full_simp_tac(srw_ss())[word_list_def,SEP_CLAUSES,STAR_ASSOC,ADD1, - GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB]); +Theorem word_list_APPEND: + !xs ys a. word_list a (xs ++ ys) = + word_list a xs * word_list (a + n2w (LENGTH xs) * bytes_in_word) ys +Proof + Induct \\ full_simp_tac(srw_ss())[word_list_def,SEP_CLAUSES,STAR_ASSOC,ADD1, + GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] +QED val shift_eq_bytes_in_word = prove( ``good_dimindex (:'a) ==> @@ -574,8 +580,8 @@ val LIST_REL_lemma = prove( LIST_REL Q xs ys``, Induct \\ fs [] \\ rpt strip_tac \\ rveq \\ fs []); -Theorem compile_thm - `!rec s1 prog s2. +Theorem compile_thm: + !rec s1 prog s2. Eval rec s1 prog s2 ==> !n l i cs p1 l1 i1 cs1 cs2 t1 (ret_val:'a word_loc) p9. compile n l i cs prog = (p1,l1,i1,cs1) /\ @@ -602,8 +608,9 @@ Theorem compile_thm 0 < i1 /\ t2.stack = t1.stack /\ get_var 0 t2 = SOME ret_val /\ - state_rel s t2 cs2 t0 frame /\ t2.code = t1.code` - (ho_match_mp_tac eval_ind \\ rpt strip_tac + state_rel s t2 cs2 t0 frame /\ t2.code = t1.code +Proof + ho_match_mp_tac eval_ind \\ rpt strip_tac THEN1 (* Skip *) (fs [compile_def] \\ rveq \\ fs [evaluate_def] \\ qexists_tac `t1` \\ fs []) @@ -1108,7 +1115,8 @@ Theorem compile_thm \\ fs [] \\ qexists_tac `t2'` \\ fs [] \\ fs [call_env_def,wordSemTheory.dec_clock_def] \\ fs [evaluate_def] - \\ every_case_tac \\ fs [])); + \\ every_case_tac \\ fs []) +QED val good_code_def = Define ` good_code cs3 = @@ -1348,18 +1356,22 @@ val dec_clock_thm = prove( ``dec_clock s = clock_write (s.clock - 1) s``, EVAL_TAC); -Theorem array_write_cancel[simp] - `array_write n (s.arrays n) s = s` - (fs [array_write_def,fetch "-" "state_component_equality", - APPLY_UPDATE_THM,FUN_EQ_THM]); - -Theorem reg_write_cancel[simp] - `(n IN FDOM s.regs ==> reg_write n (SOME (s.regs ' n)) s = s) /\ - (~(n IN FDOM s.regs) ==> reg_write n NONE s = s)` - (fs [reg_write_def,fetch "-" "state_component_equality", +Theorem array_write_cancel[simp]: + array_write n (s.arrays n) s = s +Proof + fs [array_write_def,fetch "-" "state_component_equality", + APPLY_UPDATE_THM,FUN_EQ_THM] +QED + +Theorem reg_write_cancel[simp]: + (n IN FDOM s.regs ==> reg_write n (SOME (s.regs ' n)) s = s) /\ + (~(n IN FDOM s.regs) ==> reg_write n NONE s = s) +Proof + fs [reg_write_def,fetch "-" "state_component_equality", FAPPLY_FUPDATE_THM,fmap_EXT,EXTENSION,DOMSUB_FAPPLY_THM] \\ rw[] \\ rw [] \\ fs [] \\ eq_tac \\ rw [] \\ fs [] - \\ strip_tac \\ fs []); + \\ strip_tac \\ fs [] +QED val state_eq_lemma = prove( ``(s0 = s1) <=> @@ -1370,56 +1382,70 @@ val state_eq_lemma = prove( fs [fetch "-" "state_component_equality",fmap_EXT,FUN_EQ_THM] \\ rw [] \\ eq_tac \\ rw []); -Theorem clock_write_simp[simp] - `(clock_write n s).regs = s.regs /\ +Theorem clock_write_simp[simp]: + (clock_write n s).regs = s.regs /\ (clock_write n s).arrays = s.arrays /\ - (clock_write n s).clock = n` - (fs [clock_write_def]); + (clock_write n s).clock = n +Proof + fs [clock_write_def] +QED -Theorem dec_clock_write_simp[simp] - `(dec_clock s).regs = s.regs /\ +Theorem dec_clock_write_simp[simp]: + (dec_clock s).regs = s.regs /\ (dec_clock s).arrays = s.arrays /\ - (dec_clock s).clock = s.clock - 1` - (fs [dec_clock_def]); + (dec_clock s).clock = s.clock - 1 +Proof + fs [dec_clock_def] +QED -Theorem reg_write_simp[simp] - `(reg_write n NONE s).regs = s.regs \\ n /\ +Theorem reg_write_simp[simp]: + (reg_write n NONE s).regs = s.regs \\ n /\ (reg_write n (SOME w) s).regs = s.regs |+ (n,w) /\ (reg_write n v s).arrays = s.arrays /\ - (reg_write n v s).clock = s.clock` - (Cases_on `v` \\ fs [reg_write_def]); + (reg_write n v s).clock = s.clock +Proof + Cases_on `v` \\ fs [reg_write_def] +QED -Theorem reg_write_simp_alt - `((reg_write n NONE s).regs ' m = if n = m then FEMPTY ' m else s.regs ' m) /\ +Theorem reg_write_simp_alt: + ((reg_write n NONE s).regs ' m = if n = m then FEMPTY ' m else s.regs ' m) /\ ((reg_write n (SOME w) s).regs ' m = if n = m then w else s.regs ' m) /\ (FDOM (reg_write n NONE s).regs = FDOM s.regs DELETE n) /\ - (FDOM (reg_write n (SOME w) s).regs = n INSERT FDOM s.regs)` - (fs [reg_write_def,DOMSUB_FAPPLY_THM,FAPPLY_FUPDATE_THM] \\ rw []); + (FDOM (reg_write n (SOME w) s).regs = n INSERT FDOM s.regs) +Proof + fs [reg_write_def,DOMSUB_FAPPLY_THM,FAPPLY_FUPDATE_THM] \\ rw [] +QED -Theorem array_write_simp[simp] - `(array_write n w s).regs = s.regs /\ +Theorem array_write_simp[simp]: + (array_write n w s).regs = s.regs /\ (array_write n w s).arrays = (n =+ w) s.arrays /\ - (array_write n w s).clock = s.clock` - (fs [array_write_def]); + (array_write n w s).clock = s.clock +Proof + fs [array_write_def] +QED -Theorem delete_vars_simp[simp] - `!vs. +Theorem delete_vars_simp[simp]: + !vs. (delete_vars vs s).clock = s.clock /\ (delete_vars vs s).arrays = s.arrays /\ (FLOOKUP (delete_vars vs s).regs n = if MEM n vs then NONE else FLOOKUP s.regs n) /\ ((n IN FDOM (delete_vars vs s).regs) = - if MEM n vs then F else (n IN FDOM s.regs))` - (Induct \\ fs [delete_vars_def,FLOOKUP_DEF] + if MEM n vs then F else (n IN FDOM s.regs)) +Proof + Induct \\ fs [delete_vars_def,FLOOKUP_DEF] \\ rw [DOMSUB_FAPPLY_THM] \\ fs [] - \\ eq_tac \\ rw []); + \\ eq_tac \\ rw [] +QED val write_simps = LIST_CONJ [array_write_simp, reg_write_simp, dec_clock_write_simp, clock_write_simp] -Theorem FLOOKUP_DOMSUB[simp] - `FLOOKUP (f \\ n) m = if m = n then NONE else FLOOKUP f m` - (fs [FLOOKUP_DEF] \\ rw [] \\ fs [DOMSUB_FAPPLY_THM]); +Theorem FLOOKUP_DOMSUB[simp]: + FLOOKUP (f \\ n) m = if m = n then NONE else FLOOKUP f m +Proof + fs [FLOOKUP_DEF] \\ rw [] \\ fs [DOMSUB_FAPPLY_THM] +QED val s_var = Corr_def |> concl |> dest_forall |> snd |> dest_forall |> fst @@ -2014,13 +2040,15 @@ val _ = (Teq (concl const_def)) orelse failwith "derive_corr_thm failed"; val mc_fac_init_corr = snd (derive_corr_thm mc_fac_init_code_def); val mc_fac_final_corr = snd (derive_corr_thm mc_fac_final_code_def); -Theorem mc_fac_corr - `Corr mc_fac_code s +Theorem mc_fac_corr: + Corr mc_fac_code s (INR (let (l,r1) = mc_fac (s.clock-1,s.regs ' 1) in delete_vars [3;0;2] (clock_write l (reg_write 1 (SOME r1) s)))) - (1 ∈ FDOM s.regs ∧ mc_fac_pre (s.clock-1,s.regs ' 1) ∧ s.clock <> 0)` - (all_tac); + (1 ∈ FDOM s.regs ∧ mc_fac_pre (s.clock-1,s.regs ' 1) ∧ s.clock <> 0) +Proof + all_tac +QED val th = let val raw_th = mc_fac_corr |> SIMP_RULE std_ss [LET_THM] diff --git a/compiler/backend/proofs/word_elimProofScript.sml b/compiler/backend/proofs/word_elimProofScript.sml index c292b19749..9a2fc59f7a 100644 --- a/compiler/backend/proofs/word_elimProofScript.sml +++ b/compiler/backend/proofs/word_elimProofScript.sml @@ -15,9 +15,10 @@ val _ = Parse.bring_to_front_overload"domain"{Thy="sptree",Name="domain"}; (**************************** ANALYSIS LEMMAS *****************************) -Theorem wf_find_word_ref - `∀ prog tree . find_word_ref prog = tree ⇒ wf tree` - (recInduct find_word_ref_ind >> +Theorem wf_find_word_ref: + ∀ prog tree . find_word_ref prog = tree ⇒ wf tree +Proof + recInduct find_word_ref_ind >> rw[find_word_ref_def, wf_union, wf_def, wf_insert] >> TRY(CASE_TAC) >> rw[wf_def, wf_insert] >- (Cases_on `ret` >> Cases_on `handler` >> fs[wf_union, wf_def] >> @@ -28,56 +29,61 @@ Theorem wf_find_word_ref PairCases_on `x'` >> fs[wf_union, wf_insert, wf_def] >> PairCases_on `x''` >> fs[wf_insert, wf_union, wf_def]) -); +QED -Theorem wf_analyse_word_code - `∀ l t . analyse_word_code l = t ⇒ wf t` - (Induct >- (rw[analyse_word_code_def] >> rw[wf_def]) +Theorem wf_analyse_word_code: + ∀ l t . analyse_word_code l = t ⇒ wf t +Proof + Induct >- (rw[analyse_word_code_def] >> rw[wf_def]) >> Cases_on `h` >> Cases_on `r` >> rw[analyse_word_code_def] >> rw[wf_insert] -); +QED -Theorem lookup_analyse_word_code - `∀ code n arity prog. ALOOKUP code n = SOME (arity, prog) - ⇒ lookup n (analyse_word_code code) = SOME (find_word_ref prog)` - (Induct >> fs[FORALL_PROD] >> fs[analyse_word_code_def] >> +Theorem lookup_analyse_word_code: + ∀ code n arity prog. ALOOKUP code n = SOME (arity, prog) + ⇒ lookup n (analyse_word_code code) = SOME (find_word_ref prog) +Proof + Induct >> fs[FORALL_PROD] >> fs[analyse_word_code_def] >> fs[lookup_insert] >> rw[] -); +QED -Theorem remove_word_code_thm - `∀ n reachable v l . n ∈ domain reachable ∧ MEM (n, v) l - ⇒ MEM (n, v) (remove_word_code reachable l)` - (Induct_on `l` >> rw[] >> fs[remove_word_code_def] >> fs[domain_lookup] >> +Theorem remove_word_code_thm: + ∀ n reachable v l . n ∈ domain reachable ∧ MEM (n, v) l + ⇒ MEM (n, v) (remove_word_code reachable l) +Proof + Induct_on `l` >> rw[] >> fs[remove_word_code_def] >> fs[domain_lookup] >> Cases_on `IS_SOME (lookup (FST h) reachable)` >> fs[] -); +QED -Theorem remove_word_code_thm - `∀ n reachable:num_set l . ALL_DISTINCT (MAP FST l) +Theorem remove_word_code_thm: + ∀ n reachable:num_set l . ALL_DISTINCT (MAP FST l) ⇒ ∀ v . (n ∈ domain reachable ∧ MEM (n, v) l ⇔ - MEM (n, v) (remove_word_code reachable l))` - (rw[] >> EQ_TAC >> rw[] + MEM (n, v) (remove_word_code reachable l)) +Proof + rw[] >> EQ_TAC >> rw[] >- (Induct_on `l` >> rw[] >> fs[remove_word_code_def] >> fs[domain_lookup] >> Cases_on `IS_SOME (lookup (FST h) reachable)` >> fs[]) >> fs[remove_word_code_def] >- (Induct_on `l` >> rw[] >> fs[domain_lookup, IS_SOME_EXISTS]) >- (fs[MEM_MAP, MEM_FILTER] >> qexists_tac `y` >> rw[]) -); +QED -Theorem analyse_word_code_reachable_thm - `∀ (code : (num, num # α prog) alist) t start n tree. +Theorem analyse_word_code_reachable_thm: + ∀ (code : (num, num # α prog) alist) t start n tree. analyse_word_code code = t ∧ start = insert n () (LN:num_set) ∧ domain start ⊆ domain tree ∧ tree = mk_wf_set_tree t ⇒ domain (closure_spt start tree) = - {a | ∃ n . is_reachable tree n a ∧ n ∈ domain start}` - (rw[] >> fs[domain_insert] >> + {a | ∃ n . is_reachable tree n a ∧ n ∈ domain start} +Proof + rw[] >> fs[domain_insert] >> qspecl_then [`mk_wf_set_tree (analyse_word_code code)`, `insert n () LN`] mp_tac closure_spt_thm >> `wf_set_tree(mk_wf_set_tree (analyse_word_code code))` by metis_tac[mk_wf_set_tree_thm] >> rw[] >> rw[wf_insert, wf_def] -); +QED @@ -110,19 +116,21 @@ val no_install_code_def = Define ` ∀ k n p . lookup k code = SOME (n, p) ⇒ no_install p ` -Theorem no_install_find_code - `∀ code dest args args1 expr . +Theorem no_install_find_code: + ∀ code dest args args1 expr . no_install_code code ∧ find_code dest args code = SOME (args1, expr) - ⇒ no_install expr` - (rw[no_install_code_def] >> Cases_on `dest` >> fs[find_code_def] >> + ⇒ no_install expr +Proof + rw[no_install_code_def] >> Cases_on `dest` >> fs[find_code_def] >> EVERY_CASE_TAC >> metis_tac[] -); +QED -Theorem no_install_evaluate_const_code - `∀ prog s result s1 . evaluate (prog, s) = (result, s1) ∧ +Theorem no_install_evaluate_const_code: + ∀ prog s result s1 . evaluate (prog, s) = (result, s1) ∧ no_install prog ∧ no_install_code s.code - ⇒ s.code = s1.code` - (recInduct evaluate_ind >> rw[] >> qpat_x_assum `evaluate _ = _` mp_tac >> + ⇒ s.code = s1.code +Proof + recInduct evaluate_ind >> rw[] >> qpat_x_assum `evaluate _ = _` mp_tac >> fs[evaluate_def] >- (EVERY_CASE_TAC >> fs[] >> rw[] >> imp_res_tac alloc_const >> fs[]) >- (fs[get_vars_def, set_vars_def] >> EVERY_CASE_TAC >> @@ -150,7 +158,7 @@ Theorem no_install_evaluate_const_code >- (fs[no_install_def, dec_clock_def, call_env_def, push_env_def, cut_env_def, pop_env_def, set_var_def] >> EVERY_CASE_TAC >> rw[] >> fs[] >> metis_tac[no_install_find_code]) -); +QED @@ -162,10 +170,11 @@ val dest_word_loc_def = Define ` (dest_word_loc (_:'a word_loc) = NONE) ` -Theorem dest_word_loc_thm - `∀ wl n1 . dest_word_loc wl = SOME n1 ⇒ ∃ n0 . wl = Loc n1 n0` - (Cases_on `wl` >> fs[dest_word_loc_def] -); +Theorem dest_word_loc_thm: + ∀ wl n1 . dest_word_loc wl = SOME n1 ⇒ ∃ n0 . wl = Loc n1 n0 +Proof + Cases_on `wl` >> fs[dest_word_loc_def] +QED val dest_result_loc_def = Define ` (dest_result_loc (SOME (Result w (Loc n n0))) = {n}) ∧ @@ -188,22 +197,24 @@ val get_locals_def = Define ` (* locals : ('a word_loc) num_map *) | NONE => t) ` -Theorem get_locals_thm - `∀ t n1 n0 locs . +Theorem get_locals_thm: + ∀ t n1 n0 locs . (∃ n . lookup n (t:('a word_loc) num_map) = SOME (Loc n1 n0)) ∧ - locs = get_locals t ⇒ n1 ∈ domain locs` - (Induct >> rw[lookup_def, get_locals_def, dest_word_loc_def, domain_union] + locs = get_locals t ⇒ n1 ∈ domain locs +Proof + Induct >> rw[lookup_def, get_locals_def, dest_word_loc_def, domain_union] >- (fs[lookup_def] >> Cases_on `EVEN n` >> fs[] >> metis_tac[]) >- (Cases_on `dest_word_loc a` >> fs[] >> rw[domain_union] >> fs[lookup_def] >> Cases_on `n = 0` >> fs[] >> rveq >> fs[dest_word_loc_def] >> Cases_on `a` >> fs[dest_word_loc_def] >> Cases_on `EVEN n` >> fs[] >> metis_tac[]) -); +QED -Theorem domain_get_locals_lookup - `∀ n t . n ∈ domain (get_locals t) ⇔ ∃ k n1 . lookup k t = SOME (Loc n n1)` - (rw[] >> reverse (EQ_TAC) >> rw[] +Theorem domain_get_locals_lookup: + ∀ n t . n ∈ domain (get_locals t) ⇔ ∃ k n1 . lookup k t = SOME (Loc n n1) +Proof + rw[] >> reverse (EQ_TAC) >> rw[] >- (match_mp_tac get_locals_thm >> fs[PULL_EXISTS] >> qexists_tac `t` >> qexists_tac `n1` >> qexists_tac `k` >> fs[]) >> Induct_on `t` @@ -229,29 +240,31 @@ Theorem domain_get_locals_lookup once_rewrite_tac[MULT_COMM] >> fs[DIV_MULT]) >- (qexists_tac `2 * k + 1` >> fs[EVEN_DOUBLE, EVEN_ADD] >> once_rewrite_tac[MULT_COMM] >> fs[MULT_DIV]))) -); +QED -Theorem get_locals_insert_Loc - `∀ k n1 n0 (locals : ('a word_loc) num_map). +Theorem get_locals_insert_Loc: + ∀ k n1 n0 (locals : ('a word_loc) num_map). domain (get_locals (insert k (Loc n1 n0) locals)) ⊆ - domain (get_locals locals) ∪ {n1}` - (rw[] >> fs[SUBSET_DEF] >> rw[domain_get_locals_lookup] >> + domain (get_locals locals) ∪ {n1} +Proof + rw[] >> fs[SUBSET_DEF] >> rw[domain_get_locals_lookup] >> fs[lookup_insert] >> rw[] >> Cases_on `k' = k` >> fs[] >> disj1_tac >> qexists_tac `k'` >> qexists_tac `n1'` >> fs[] -); +QED -Theorem get_locals_insert - `∀ k v (locals : ('a word_loc) num_map). +Theorem get_locals_insert: + ∀ k v (locals : ('a word_loc) num_map). domain (get_locals (insert k v locals)) ⊆ domain (get_locals locals) - ∪ (case dest_word_loc v of | NONE => {} | SOME n => {n})` - (reverse(Cases_on `v`) >> fs[dest_word_loc_def] + ∪ (case dest_word_loc v of | NONE => {} | SOME n => {n}) +Proof + reverse(Cases_on `v`) >> fs[dest_word_loc_def] >- fs[get_locals_insert_Loc] >- (rw[] >> fs[SUBSET_DEF] >> rw[domain_get_locals_lookup] >> fs[lookup_insert] >> rw[] >> Cases_on `k' = k` >> fs[] >> qexists_tac `k'` >> qexists_tac `n1` >> fs[]) -); +QED val get_store_def = Define ` (* store : store_name |-> 'a word_loc *) get_store (st:store_name |-> 'a word_loc) = @@ -260,25 +273,27 @@ val get_store_def = Define ` (* store : store_name |-> 'a word_loc *) FOLDL (λ acc loc . insert loc () acc) LN locList ` -Theorem domain_get_store - `∀ n store . n ∈ domain (get_store store) ⇔ - (∃ k n1 . FLOOKUP store k = SOME (Loc n n1))` - (fs[get_store_def] >> fs[MEM_MAP, MEM_FILTER] >> +Theorem domain_get_store: + ∀ n store . n ∈ domain (get_store store) ⇔ + (∃ k n1 . FLOOKUP store k = SOME (Loc n n1)) +Proof + fs[get_store_def] >> fs[MEM_MAP, MEM_FILTER] >> rw[IN_FRANGE_FLOOKUP, PULL_EXISTS] >> EQ_TAC >> rw[] >- (Cases_on `y'` >> fs[dest_word_loc_def] >> metis_tac[]) >- (qexists_tac `Loc n n1` >> qexists_tac `k` >> fs[dest_word_loc_def]) -); +QED -Theorem get_store_update - `∀ store k v . +Theorem get_store_update: + ∀ store k v . domain (get_store (store |+ (k,v))) ⊆ domain (get_store store) - ∪ (case dest_word_loc v of | NONE => {} | SOME n => {n})` - (Cases_on `v` >> fs[dest_word_loc_def] >> rw[] >> fs[SUBSET_DEF] >> + ∪ (case dest_word_loc v of | NONE => {} | SOME n => {n}) +Proof + Cases_on `v` >> fs[dest_word_loc_def] >> rw[] >> fs[SUBSET_DEF] >> rw[domain_get_store] >> fs[lookup_insert] >> rw[] >> fs[FLOOKUP_UPDATE] >> Cases_on `k = k'` >> fs[] >| [ALL_TAC, disj1_tac] >> qexists_tac `k'` >> qexists_tac `n1` >> fs[] -); +QED val get_num_wordloc_alist_def = Define ` get_num_wordloc_alist (l: (num, 'a word_loc) alist) = @@ -286,21 +301,23 @@ val get_num_wordloc_alist_def = Define ` FOLDL (λ acc loc . insert loc () acc) LN locs ` -Theorem get_num_wordloc_alist_thm - `∀ n e l . (∃ n0 . MEM (Loc n n0) (MAP SND l)) ⇔ - n ∈ domain (get_num_wordloc_alist l)` - (fs[get_num_wordloc_alist_def] >> fs[MEM_MAP, MEM_FILTER] >> +Theorem get_num_wordloc_alist_thm: + ∀ n e l . (∃ n0 . MEM (Loc n n0) (MAP SND l)) ⇔ + n ∈ domain (get_num_wordloc_alist l) +Proof + fs[get_num_wordloc_alist_def] >> fs[MEM_MAP, MEM_FILTER] >> rw[] >> EQ_TAC >> rw[] >- (qexists_tac `dest_word_loc (Loc n n0)` >> fs[dest_word_loc_def] >> qexists_tac `y` >> metis_tac[dest_word_loc_def]) >- (Cases_on `SND y'` >> fs[dest_word_loc_def] >> qexists_tac `n0` >> qexists_tac `y'` >> fs[]) -); +QED -Theorem get_num_wordloc_alist_get_locals - `∀ e . - domain (get_locals (fromAList e)) ⊆ domain (get_num_wordloc_alist e)` - (Induct >> rw[] >> +Theorem get_num_wordloc_alist_get_locals: + ∀ e . + domain (get_locals (fromAList e)) ⊆ domain (get_num_wordloc_alist e) +Proof + Induct >> rw[] >> fs[fromAList_def, get_num_wordloc_alist_def, domain_def, get_locals_def] >> Cases_on `h` >> Cases_on `r` >> fs[dest_word_loc_def, fromAList_def] >- (qspecl_then [`q`, `Word c`, `(fromAList e)`] mp_tac get_locals_insert >> @@ -309,7 +326,7 @@ Theorem get_num_wordloc_alist_get_locals mp_tac get_locals_insert >> rw[dest_word_loc_def] >> fs[Once INSERT_SING_UNION] >> rw[Once UNION_COMM] >> fs[SUBSET_DEF] >> metis_tac[]) -); +QED val get_stack_def = Define ` (* stack : ('a stack_frame) list *) (get_stack [] = LN:num_set) ∧ @@ -319,53 +336,58 @@ val get_stack_def = Define ` (* stack : ('a stack_frame) list *) val get_stack_ind = theorem "get_stack_ind"; -Theorem get_stack_hd_thm - `∀ stack dr l opt t . domain (get_stack stack) ⊆ dr ∧ +Theorem get_stack_hd_thm: + ∀ stack dr l opt t . domain (get_stack stack) ⊆ dr ∧ stack = StackFrame l opt::t ⇒ domain (get_locals (fromAList l)) ⊆ dr ∧ - domain (get_stack t) ⊆ dr` - (recInduct get_stack_ind >> rw[] + domain (get_stack t) ⊆ dr +Proof + recInduct get_stack_ind >> rw[] >- (Cases_on `e` >> fs[get_stack_def, domain_union, fromAList_def, get_locals_def] >> fs[get_stack_def, domain_union, fromAList_def] >> metis_tac[get_num_wordloc_alist_get_locals, SUBSET_TRANS]) >- fs[get_stack_def, domain_union] -); +QED -Theorem get_stack_LASTN - `∀ stack n . domain (get_stack (LASTN n stack)) ⊆ domain (get_stack stack)` - (recInduct get_stack_ind >> rw[get_stack_def, LASTN_ALT] >> +Theorem get_stack_LASTN: + ∀ stack n . domain (get_stack (LASTN n stack)) ⊆ domain (get_stack stack) +Proof + recInduct get_stack_ind >> rw[get_stack_def, LASTN_ALT] >> Cases_on `SUC (LENGTH xs) ≤ n` >> fs[get_stack_def, domain_union] \\ fs[SUBSET_DEF] \\ metis_tac[] -); +QED -Theorem get_stack_CONS - `∀ h t . domain (get_stack [h]) ⊆ domain (get_stack (h::t)) ∧ - domain (get_stack t) ⊆ domain (get_stack (h::t))` - (Cases_on `h` >> fs[get_stack_def, domain_union] -); +Theorem get_stack_CONS: + ∀ h t . domain (get_stack [h]) ⊆ domain (get_stack (h::t)) ∧ + domain (get_stack t) ⊆ domain (get_stack (h::t)) +Proof + Cases_on `h` >> fs[get_stack_def, domain_union] +QED -Theorem get_stack_enc_stack - `∀ stack reachable . domain (get_stack stack) ⊆ domain reachable +Theorem get_stack_enc_stack: + ∀ stack reachable . domain (get_stack stack) ⊆ domain reachable ⇒ ∀ e . MEM e (enc_stack stack) ⇒ (case dest_word_loc e of | NONE => {} | SOME n => {n}) ⊆ - domain reachable` - (recInduct get_stack_ind >> rw[enc_stack_def, get_stack_def, domain_union] + domain reachable +Proof + recInduct get_stack_ind >> rw[enc_stack_def, get_stack_def, domain_union] >- (last_x_assum kall_tac >> Cases_on `e'` >> fs[dest_word_loc_def] >> qsuff_tac `n ∈ domain (get_num_wordloc_alist e)` >> fs[SUBSET_DEF] >> imp_res_tac get_num_wordloc_alist_thm) >- res_tac -); +QED -Theorem get_stack_dec_stack - `∀ locs stack reachable new_stack . +Theorem get_stack_dec_stack: + ∀ locs stack reachable new_stack . (∀ n n0 . MEM (Loc n n0) locs ⇒ n ∈ domain reachable) ∧ domain (get_stack stack) ⊆ domain reachable ∧ dec_stack locs stack = SOME new_stack - ⇒ domain (get_stack new_stack) ⊆ domain reachable` - (ho_match_mp_tac dec_stack_ind >> rw[] + ⇒ domain (get_stack new_stack) ⊆ domain reachable +Proof + ho_match_mp_tac dec_stack_ind >> rw[] >- (fs[dec_stack_def] >> rveq >> fs[get_stack_def]) >- (`∀ n n0 . MEM (Loc n n0) (DROP (LENGTH l) locs) ⇒ n ∈ domain reachable` by metis_tac[MEM_DROP_IMP] >> @@ -383,12 +405,13 @@ Theorem get_stack_dec_stack fs[MEM_EL] >> qexists_tac `n` >> fs[]) >- res_tac) >- fs[dec_stack_def] -); +QED -Theorem s_val_eq_get_stack - `∀ stack1 stack2 . s_val_eq stack1 stack2 - ⇒ get_stack stack1 = get_stack stack2` - (recInduct get_stack_ind >> rw[] >> Cases_on `stack2` >> +Theorem s_val_eq_get_stack: + ∀ stack1 stack2 . s_val_eq stack1 stack2 + ⇒ get_stack stack1 = get_stack stack2 +Proof + recInduct get_stack_ind >> rw[] >> Cases_on `stack2` >> fs[s_val_eq_def] >> Cases_on `h` >> fs[s_frame_val_eq_def, get_stack_def] >> first_x_assum drule >> rw[] >> Cases_on `v0` >> Cases_on `o'` >> @@ -396,7 +419,7 @@ Theorem s_val_eq_get_stack `MAP (dest_word_loc o SND) e = MAP (dest_word_loc o SND) l` by rw[GSYM MAP_MAP_o] >> fs[] >> fs[get_num_wordloc_alist_def] -); +QED val get_memory_def = Define ` (* 'a word -> 'a word_loc *) get_memory (mem:'a word -> 'a word_loc) (mdom:'a word set) = @@ -405,19 +428,21 @@ val get_memory_def = Define ` (* 'a word -> 'a word_loc *) FOLDL (λ acc loc . insert loc () acc) LN locList ` -Theorem FINITE_mdom_mem - `∀ mdom . FINITE mdom ⇒ FINITE {mem x | x ∈ mdom}` - (ho_match_mp_tac FINITE_INDUCT >> +Theorem FINITE_mdom_mem: + ∀ mdom . FINITE mdom ⇒ FINITE {mem x | x ∈ mdom} +Proof + ho_match_mp_tac FINITE_INDUCT >> rw[] >> qsuff_tac `{mem x | x = e ∨ x ∈ mdom} = mem e INSERT {mem x | x ∈ mdom}` >- rw[] >> fs[EXTENSION] >> metis_tac[] -); +QED -Theorem domain_get_memory - `∀ mem (mdom : 'a word set) n . (n ∈ domain (get_memory mem mdom) - ⇔ (∃ k n1 . k ∈ mdom ∧ mem k = Loc n n1))` - (fs[get_memory_def, IMAGE_DEF] >> fs[FILTER_MAP, MAP_MAP_o] >> rw[] >> +Theorem domain_get_memory: + ∀ mem (mdom : 'a word set) n . (n ∈ domain (get_memory mem mdom) + ⇔ (∃ k n1 . k ∈ mdom ∧ mem k = Loc n n1)) +Proof + fs[get_memory_def, IMAGE_DEF] >> fs[FILTER_MAP, MAP_MAP_o] >> rw[] >> `FINITE mdom` by metis_tac[WORD_FINITE] >> fs[MEM_MAP, MEM_FILTER] >> `FINITE {mem x | x ∈ mdom}` by metis_tac[FINITE_mdom_mem] >> @@ -425,19 +450,20 @@ Theorem domain_get_memory EQ_TAC >> rw[] >- (Cases_on `mem x` >> fs[dest_word_loc_def] >> metis_tac[]) >- (qexists_tac `Loc n n1` >> fs[dest_word_loc_def] >> metis_tac[]) -); +QED -Theorem get_memory_update - `∀ k v (memory : 'a word -> 'a word_loc) (mdomain : 'a word set) . +Theorem get_memory_update: + ∀ k v (memory : 'a word -> 'a word_loc) (mdomain : 'a word set) . (domain (get_memory ((k =+ v) memory) mdomain)) ⊆ (domain (get_memory memory mdomain)) - ∪ (case (dest_word_loc v) of | NONE => {} | SOME n => {n})` - (Cases_on `v` >> fs[dest_word_loc_def] >> rw[] >> fs[SUBSET_DEF] >> + ∪ (case (dest_word_loc v) of | NONE => {} | SOME n => {n}) +Proof + Cases_on `v` >> fs[dest_word_loc_def] >> rw[] >> fs[SUBSET_DEF] >> rw[domain_get_memory] >> fs[lookup_insert] >> rw[] >> fs[APPLY_UPDATE_THM] >> Cases_on `k' = k` >> fs[] >| [ALL_TAC, disj1_tac] >> qexists_tac `k'` >> qexists_tac `n1` >> fs[] -); +QED val find_loc_state_def = Define` find_loc_state s = @@ -448,12 +474,13 @@ val find_loc_state_def = Define` union (union loc sto) (union sta mem) ` -Theorem domain_find_loc_state - `∀ s . domain (find_loc_state s) = +Theorem domain_find_loc_state: + ∀ s . domain (find_loc_state s) = domain (get_locals s.locals) ∪ domain (get_store s.store) ∪ - domain (get_stack s.stack) ∪ domain (get_memory s.memory s.mdomain)` - (rw[find_loc_state_def, domain_union, UNION_ASSOC] -); + domain (get_stack s.stack) ∪ domain (get_memory s.memory s.mdomain) +Proof + rw[find_loc_state_def, domain_union, UNION_ASSOC] +QED val code_rel_def = Define` code_rel (reachable:num_set) s_code @@ -504,54 +531,60 @@ val word_state_rel_def = Define ` (**************************** OTHER LEMMAS *****************************) -Theorem EL_APPEND - `∀ n x e x1 . EL n x = e ∧ n < LENGTH x ⇒ EL n (x ⧺ [x1]) = e` - (Induct_on `x` >> rw[Once EL] >> Cases_on `n` >> rw[] -); - -Theorem ALOOKUP_ZIP_SUCCESS - `∀ x y k v . LENGTH x = LENGTH y - ⇒ ALOOKUP (ZIP (x, y)) k = SOME v ⇒ MEM v y` - (rw[] >> imp_res_tac ALOOKUP_MEM >> fs[MEM_EL] >> drule EL_ZIP >> rw[] >> +Theorem EL_APPEND: + ∀ n x e x1 . EL n x = e ∧ n < LENGTH x ⇒ EL n (x ⧺ [x1]) = e +Proof + Induct_on `x` >> rw[Once EL] >> Cases_on `n` >> rw[] +QED + +Theorem ALOOKUP_ZIP_SUCCESS: + ∀ x y k v . LENGTH x = LENGTH y + ⇒ ALOOKUP (ZIP (x, y)) k = SOME v ⇒ MEM v y +Proof + rw[] >> imp_res_tac ALOOKUP_MEM >> fs[MEM_EL] >> drule EL_ZIP >> rw[] >> pop_assum (qspec_then `n` mp_tac) >> rw[] >> imp_res_tac LENGTH_ZIP >> rfs[] >> fs[] >> qexists_tac `n` >> fs[] -); +QED -Theorem get_vars_locals - `∀ args s x y. get_vars args s = SOME x ∧ MEM y x - ⇒ ∃ n . lookup n s.locals = SOME y` - (Induct >- (rw[get_vars_def] >> fs[MEM]) >> +Theorem get_vars_locals: + ∀ args s x y. get_vars args s = SOME x ∧ MEM y x + ⇒ ∃ n . lookup n s.locals = SOME y +Proof + Induct >- (rw[get_vars_def] >> fs[MEM]) >> strip_tac >> strip_tac >> strip_tac >> strip_tac >> simp[get_vars_def] >> Cases_on `get_var h s` >> simp[] >> Cases_on `get_vars args s` >> simp[] >> fs[get_var_def] >> first_x_assum (qspecl_then [`s`, `x''`, `y`] mp_tac) >> rw[] >> Cases_on `MEM y x''` >- metis_tac[] >> fs[MEM] >> rveq >> qexists_tac `h` >> fs[] -); +QED -Theorem get_vars_get_locals - `∀ args s x n n1. get_vars args s = SOME x ∧ MEM (Loc n n1) x - ⇒ n ∈ domain (get_locals s.locals)` - (ASSUME_TAC get_vars_locals >> +Theorem get_vars_get_locals: + ∀ args s x n n1. get_vars args s = SOME x ∧ MEM (Loc n n1) x + ⇒ n ∈ domain (get_locals s.locals) +Proof + ASSUME_TAC get_vars_locals >> strip_tac >> strip_tac >> strip_tac >> strip_tac >> strip_tac >> first_x_assum (qspecl_then [`args`, `s`, `x`, `Loc n n1`] mp_tac) >> rw[] >> fs[] >> imp_res_tac get_locals_thm >> metis_tac[] -); +QED -Theorem get_locals_fromList2 - `∀ args s x t . get_vars args s = SOME x ∧ x ≠ [] ∧ t = fromList2 x - ⇒ domain (get_locals t) ⊆ domain (get_locals s.locals)` - (rw[] >> rw[SUBSET_DEF] >> +Theorem get_locals_fromList2: + ∀ args s x t . get_vars args s = SOME x ∧ x ≠ [] ∧ t = fromList2 x + ⇒ domain (get_locals t) ⊆ domain (get_locals s.locals) +Proof + rw[] >> rw[SUBSET_DEF] >> qspecl_then [`x'`, `fromList2 x`] mp_tac domain_get_locals_lookup >> rw[] >> `MEM (Loc x' n1) x` by (fs[fromList2_value] >> qexists_tac `k` >> fs[]) >> metis_tac[get_vars_get_locals] -); +QED -Theorem get_locals_fromList2_extension - `∀ x y ys. x ∈ domain (get_locals (fromList2 ys)) - ⇒ x ∈ domain (get_locals (fromList2 (ys ⧺ [y])))` - (rw[] >> fs[domain_get_locals_lookup] >> qexists_tac `k` >> +Theorem get_locals_fromList2_extension: + ∀ x y ys. x ∈ domain (get_locals (fromList2 ys)) + ⇒ x ∈ domain (get_locals (fromList2 (ys ⧺ [y]))) +Proof + rw[] >> fs[domain_get_locals_lookup] >> qexists_tac `k` >> qexists_tac `n1` >> Induct_on `ys` >> rw[] >- (fs[fromList2_def, lookup_def]) >> fs[lookup_fromList2, lookup_fromList] >> @@ -561,27 +594,29 @@ Theorem get_locals_fromList2_extension fs[MULT_DIV]) >> fs[] >> imp_res_tac EL_APPEND >> `LENGTH (h::ys) = SUC (LENGTH ys)` by (Induct_on `ys` >> rw[]) >> fs[] -); +QED -Theorem get_locals_fromList2_FRONT - `∀ args s x xf t . get_vars args s = SOME x ∧ +Theorem get_locals_fromList2_FRONT: + ∀ args s x xf t . get_vars args s = SOME x ∧ x ≠ [] ∧ xf = FRONT x ∧ t = fromList2 xf - ⇒ domain (get_locals t) ⊆ domain (get_locals s.locals)` - (rw[] >> match_mp_tac SUBSET_TRANS >> + ⇒ domain (get_locals t) ⊆ domain (get_locals s.locals) +Proof + rw[] >> match_mp_tac SUBSET_TRANS >> qexists_tac `domain (get_locals (fromList2 x))` >> reverse(CONJ_TAC) >- metis_tac[get_locals_fromList2] >- (`∃ y ys . x = SNOC y ys` by metis_tac[SNOC_CASES] >> FULL_SIMP_TAC std_ss [FRONT_SNOC] >> fs[SNOC_APPEND] >> rw[SUBSET_DEF] >> imp_res_tac get_locals_fromList2_extension >> fs[]) -); +QED -Theorem get_memory_write_bytearray_lemma - `∀ mem mdom reachable c r be . +Theorem get_memory_write_bytearray_lemma: + ∀ mem mdom reachable c r be . domain(get_memory mem mdom) ⊆ domain reachable ⇒ domain (get_memory (write_bytearray c r mem mdom be) mdom) ⊆ - domain reachable` - (Induct_on `r` >> fs[write_bytearray_def] >> rw[] >> + domain reachable +Proof + Induct_on `r` >> fs[write_bytearray_def] >> rw[] >> fs[mem_store_byte_aux_def] >> Cases_on `write_bytearray (c + 1w) r mem mdom be (byte_align c)` >> fs[] >> Cases_on `byte_align c ∈ mdom` >> fs[] >> first_x_assum drule >> rw[] >> @@ -590,60 +625,65 @@ Theorem get_memory_write_bytearray_lemma `write_bytearray (c + 1w) r mem mdom be`, `mdom`] mp_tac get_memory_update >> rw[dest_word_loc_def] >> metis_tac[SUBSET_TRANS] -); +QED -Theorem stack_list_rearrange_lemma - `∀ s dr locs opt . +Theorem stack_list_rearrange_lemma: + ∀ s dr locs opt . domain (get_locals s.locals) ⊆ dr ∧ domain (get_stack s.stack) ⊆ dr ⇒ domain (get_stack (StackFrame (list_rearrange (s.permute 0) (QSORT key_val_compare (toAList (inter s.locals locs)))) opt::s.stack)) - ⊆ dr` - (rw[] >> fs[get_stack_def, domain_union] >> rw[SUBSET_DEF] >> + ⊆ dr +Proof + rw[] >> fs[get_stack_def, domain_union] >> rw[SUBSET_DEF] >> imp_res_tac get_num_wordloc_alist_thm >> fs[MEM_MAP] >> fs[mem_list_rearrange, QSORT_MEM] >> Cases_on `y` >> fs[MEM_toAList] >> fs[lookup_inter] >> Cases_on `lookup q s.locals` >> fs[] >> Cases_on `lookup q locs` >> fs[] >> rveq >> fs[SUBSET_DEF, domain_get_locals_lookup] >> metis_tac[] -); +QED -Theorem remove_word_code_thm_FST - `∀ n reachable:num_set l . ALL_DISTINCT (MAP FST l) +Theorem remove_word_code_thm_FST: + ∀ n reachable:num_set l . ALL_DISTINCT (MAP FST l) ⇒ (n ∈ domain reachable ∧ MEM n (MAP FST l) ⇔ - MEM n (MAP FST (remove_word_code reachable l)))` - (rw[] >> EQ_TAC >> rw[] + MEM n (MAP FST (remove_word_code reachable l))) +Proof + rw[] >> EQ_TAC >> rw[] >- (Induct_on `l` >> rw[] >> fs[remove_word_code_def] >> fs[domain_lookup] >> Cases_on `IS_SOME (lookup (FST h) reachable)` >> fs[]) >> fs[remove_word_code_def] >- (Induct_on `l` >> rw[] >> fs[domain_lookup, IS_SOME_EXISTS]) >- (fs[MEM_MAP, MEM_FILTER] >> qexists_tac `y` >> rw[]) -); +QED -Theorem remove_word_code_MAP_FST_lemma - `∀ reachable:num_set (l: (ctor_id, ctor_id # α prog) alist) . +Theorem remove_word_code_MAP_FST_lemma: + ∀ reachable:num_set (l: (ctor_id, ctor_id # α prog) alist) . MAP FST (FILTER (λx. IS_SOME (lookup (FST x) reachable)) l) = - FILTER (λx. IS_SOME (lookup x reachable)) (MAP FST l)` - (Induct_on `l` >> rw[] -); - -Theorem word_state_rel_word_exp - `∀ s1 exp s2 reachable . word_state_rel reachable s1 s2 - ⇒ word_exp s1 exp = word_exp s2 exp` - (recInduct word_exp_ind >> rw[word_exp_def] + FILTER (λx. IS_SOME (lookup x reachable)) (MAP FST l) +Proof + Induct_on `l` >> rw[] +QED + +Theorem word_state_rel_word_exp: + ∀ s1 exp s2 reachable . word_state_rel reachable s1 s2 + ⇒ word_exp s1 exp = word_exp s2 exp +Proof + recInduct word_exp_ind >> rw[word_exp_def] >- (fs[word_state_rel_def]) >- (fs[word_state_rel_def]) >- (first_x_assum drule >> rw[] >> PURE_TOP_CASE_TAC >> rw[] >> PURE_TOP_CASE_TAC >> fs[] >> fs[mem_load_def, word_state_rel_def]) >- (`MAP (λ a . word_exp s a) wexps = MAP (λ a . word_exp s2 a) wexps` by (fs[MAP_EQ_f] >> metis_tac[]) >> fs[]) >- (first_x_assum drule >> rw[]) -); +QED -Theorem word_state_rel_inst_NONE - `∀ reachable s t i . word_state_rel reachable s t - ⇒ (inst i s = NONE ⇔ inst i t = NONE)` - (rw[] >> fs[word_state_rel_def] >> Cases_on `i` >> fs[inst_def] +Theorem word_state_rel_inst_NONE: + ∀ reachable s t i . word_state_rel reachable s t + ⇒ (inst i s = NONE ⇔ inst i t = NONE) +Proof + rw[] >> fs[word_state_rel_def] >> Cases_on `i` >> fs[inst_def] >- (fs[assign_def] >> `word_exp s (Const c) = word_exp t (Const c)` by metis_tac[word_state_rel_word_exp, word_state_rel_def] >> @@ -670,12 +710,13 @@ Theorem word_state_rel_inst_NONE rfs[mem_store_def]) >- (fs[get_fp_var_def, set_var_def, set_fp_var_def, get_var_def] >> EVERY_CASE_TAC >> fs[]) -); +QED -Theorem word_state_rel_inst_SOME - `∀ reachable s t i s1 t1 . word_state_rel reachable s t ⇒ - (inst i s = SOME s1 ∧ inst i t = SOME t1 ⇒ word_state_rel reachable s1 t1)` - (fs[inst_def] >> Cases_on `i` >> fs[] +Theorem word_state_rel_inst_SOME: + ∀ reachable s t i s1 t1 . word_state_rel reachable s t ⇒ + (inst i s = SOME s1 ∧ inst i t = SOME t1 ⇒ word_state_rel reachable s1 t1) +Proof + fs[inst_def] >> Cases_on `i` >> fs[] >- (fs[assign_def] >> fs[word_exp_def] >> fs[set_var_def] >> fs[word_state_rel_def] >> rw[] >> fs[domain_find_loc_state] >> qspecl_then [`n`, `Word c`, `s.locals`] mp_tac get_locals_insert >> @@ -849,13 +890,14 @@ Theorem word_state_rel_inst_SOME `insert n (Word ((31 >< 0) x)) s.locals`] mp_tac get_locals_insert >> rw[dest_word_loc_def] >> imp_res_tac SUBSET_TRANS) -); +QED -Theorem word_state_rel_jump_exc - `∀ reachable s t s1 l1 l2 . word_state_rel reachable s t +Theorem word_state_rel_jump_exc: + ∀ reachable s t s1 l1 l2 . word_state_rel reachable s t ==> jump_exc s = SOME (s1, l1, l2) - ⇒ ∃ t1 . jump_exc t = SOME (t1, l1, l2) ∧ word_state_rel reachable s1 t1` - (strip_tac >> strip_tac >> strip_tac >> strip_tac >> strip_tac >> + ⇒ ∃ t1 . jump_exc t = SOME (t1, l1, l2) ∧ word_state_rel reachable s1 t1 +Proof + strip_tac >> strip_tac >> strip_tac >> strip_tac >> strip_tac >> strip_tac >> strip_tac >> fs[jump_exc_def] >> `s.handler = t.handler ∧ s.stack = t.stack` by fs[word_state_rel_def] >> fs[] >> @@ -864,13 +906,14 @@ Theorem word_state_rel_jump_exc `domain (get_stack (StackFrame l (SOME (q,l1,l2))::t')) ⊆ domain reachable` by metis_tac[get_stack_LASTN,SUBSET_TRANS] >> drule get_stack_hd_thm >> rw[] -); +QED -Theorem word_state_rel_gc - `∀ reachable s t s1 . +Theorem word_state_rel_gc: + ∀ reachable s t s1 . word_state_rel reachable s t ∧ gc_no_new_locs s.gc_fun ⇒ - gc s = SOME s1 ⇒ ∃ t1 . gc t = SOME t1 ∧ word_state_rel reachable s1 t1` - (rw[] >> qpat_assum `word_state_rel _ _ _` mp_tac >> + gc s = SOME s1 ⇒ ∃ t1 . gc t = SOME t1 ∧ word_state_rel reachable s1 t1 +Proof + rw[] >> qpat_assum `word_state_rel _ _ _` mp_tac >> SIMP_TAC std_ss [Once word_state_rel_def] >> strip_tac >> qpat_x_assum `gc _ = _` mp_tac >> full_simp_tac (srw_ss())[gc_def] >> fs[] >> @@ -879,15 +922,16 @@ Theorem word_state_rel_gc fs[word_state_rel_def] >> rw[] >> fs[] >> fs[gc_no_new_locs_def, domain_find_loc_state] >> first_x_assum drule >> disch_then drule >> rw[] >> imp_res_tac SUBSET_TRANS -); +QED -Theorem word_state_rel_alloc - `∀ reachable s t res c n s1 . word_state_rel reachable s t ∧ +Theorem word_state_rel_alloc: + ∀ reachable s t res c n s1 . word_state_rel reachable s t ∧ res ≠ SOME Error ∧ gc_no_new_locs s.gc_fun ⇒ alloc c n s = (res, s1) ⇒ ∃ t1 . alloc c n t = (res, t1) ∧ word_state_rel reachable s1 t1 ∧ - dest_result_loc res ⊆ domain reachable` - (rw[] >> qpat_assum `word_state_rel _ _ _` mp_tac >> + dest_result_loc res ⊆ domain reachable +Proof + rw[] >> qpat_assum `word_state_rel _ _ _` mp_tac >> SIMP_TAC std_ss [Once word_state_rel_def] >> strip_tac >> qpat_x_assum `alloc _ _ _ = _` mp_tac >> fs[alloc_def] >> fs[cut_env_def, domain_find_loc_state] >> @@ -926,14 +970,14 @@ Theorem word_state_rel_alloc >- (fs[get_locals_def, get_stack_def]) >- (drule get_stack_hd_thm >> rw[] >> metis_tac[]) >- (fs[get_locals_def, get_stack_def]) -); +QED (**************************** MAIN LEMMAS *****************************) -Theorem word_removal_lemma - `∀ program state result new_state reachable removed_state . +Theorem word_removal_lemma: + ∀ program state result new_state reachable removed_state . wordSem$evaluate (program, state) = (result, new_state) ∧ result ≠ SOME Error ∧ word_state_rel reachable state removed_state ∧ gc_no_new_locs state.gc_fun ∧ @@ -944,8 +988,9 @@ Theorem word_removal_lemma ⇒ ∃ s . wordSem$evaluate (program, removed_state) = (result, s) ∧ word_state_rel reachable new_state s ∧ - (dest_result_loc result) ⊆ domain (reachable)` - (recInduct wordSemTheory.evaluate_ind >> reverse(rw[]) >> + (dest_result_loc result) ⊆ domain (reachable) +Proof + recInduct wordSemTheory.evaluate_ind >> reverse(rw[]) >> qpat_x_assum `evaluate _ = _` mp_tac >> qpat_assum `word_state_rel _ _ _` mp_tac >> SIMP_TAC std_ss [Once word_state_rel_def] >> strip_tac >> @@ -1607,12 +1652,12 @@ Theorem word_removal_lemma simp[wordSemTheory.evaluate_def] >> rw[] >> fs[word_state_rel_def, dest_result_loc_def] ) -); +QED (**************************** WORD_REMOVAL_THM *****************************) -Theorem word_removal_thm - `∀ start state result new_state r reachable code1. +Theorem word_removal_thm: + ∀ start state result new_state r reachable code1. wordSem$evaluate (Call NONE (SOME start) [0] NONE, state) = (result, new_state) ∧ result ≠ SOME Error ∧ state.code = fromAList code1 ∧ @@ -1624,8 +1669,9 @@ Theorem word_removal_thm ⇒ ∃ s . wordSem$evaluate (Call NONE (SOME start) [0] NONE, state with code := - fromAList (remove_word_code reachable code1)) = (result, s)` - (rpt strip_tac >> + fromAList (remove_word_code reachable code1)) = (result, s) +Proof + rpt strip_tac >> drule word_removal_lemma >> disch_then drule >> strip_tac >> pop_assum (qspecl_then [`reachable`, @@ -1678,6 +1724,6 @@ Theorem word_removal_thm fs[lookup_fromAList] >> drule lookup_analyse_word_code >> rw[] >> fs[domain_lookup] >> drule lookup_mk_wf_set_tree >> rw[] >> fs[]) -); +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/word_gcFunctionsScript.sml b/compiler/backend/proofs/word_gcFunctionsScript.sml index 6e90fd1f87..7172aab339 100644 --- a/compiler/backend/proofs/word_gcFunctionsScript.sml +++ b/compiler/backend/proofs/word_gcFunctionsScript.sml @@ -10,22 +10,28 @@ val _ = new_theory "word_gcFunctions" val shift_def = backend_commonTheory.word_shift_def; (* move candidates *) -Theorem bytes_in_word_mul_eq_shift - `good_dimindex (:'a) ==> - (bytes_in_word * w = (w << shift (:'a)):'a word)` - (fs [bytes_in_word_def,shift_def,WORD_MUL_LSL,word_mul_n2w] - \\ fs [labPropsTheory.good_dimindex_def,dimword_def] \\ rw [] \\ rfs []); - -Theorem word_or_eq_0 - `(w || v) = 0w <=> w = 0w /\ v = 0w` - (fs [fcpTheory.CART_EQ,fcpTheory.FCP_BETA,word_or_def,word_index] - \\ rw [] \\ eq_tac \\ rw [] \\ fs []); +Theorem bytes_in_word_mul_eq_shift: + good_dimindex (:'a) ==> + (bytes_in_word * w = (w << shift (:'a)):'a word) +Proof + fs [bytes_in_word_def,shift_def,WORD_MUL_LSL,word_mul_n2w] + \\ fs [labPropsTheory.good_dimindex_def,dimword_def] \\ rw [] \\ rfs [] +QED + +Theorem word_or_eq_0: + (w || v) = 0w <=> w = 0w /\ v = 0w +Proof + fs [fcpTheory.CART_EQ,fcpTheory.FCP_BETA,word_or_def,word_index] + \\ rw [] \\ eq_tac \\ rw [] \\ fs [] +QED val IMP_EQ_DISJ = METIS_PROVE [] ``(b1 ==> b2) <=> ~b1 \/ b2`` -Theorem shift_length_has_fp_ops[simp] - `shift_length (conf with has_fp_ops := b) = shift_length conf` - (EVAL_TAC); +Theorem shift_length_has_fp_ops[simp]: + shift_length (conf with has_fp_ops := b) = shift_length conf +Proof + EVAL_TAC +QED (* ------------------------------------------------------- definition and verification of GC functions @@ -122,36 +128,42 @@ val word_gen_gc_partial_move_list_def = Define ` let (a2,i2,pa2,m2,c2) = word_gen_gc_partial_move_list conf (a+bytes_in_word,l-1w,i1,pa1,old,m1,dm,gs,rs) in (a2,i2,pa2,m2,a IN dm /\ c1 /\ c2)` -Theorem word_gen_gc_partial_move_list_zero ` - word_gen_gc_partial_move_list conf (a,0w,i,pa,old,m,dm,gs,rs) = (a,i,pa,m,T)` - (fs[Once word_gen_gc_partial_move_list_def]); +Theorem word_gen_gc_partial_move_list_zero: + word_gen_gc_partial_move_list conf (a,0w,i,pa,old,m,dm,gs,rs) = (a,i,pa,m,T) +Proof + fs[Once word_gen_gc_partial_move_list_def] +QED -Theorem word_gen_gc_partial_move_list_suc ` - word_gen_gc_partial_move_list conf (a,(n2w(SUC l):'a word),i,pa,old,m,dm,gs,rs) = +Theorem word_gen_gc_partial_move_list_suc: + word_gen_gc_partial_move_list conf (a,(n2w(SUC l):'a word),i,pa,old,m,dm,gs,rs) = if n2w(SUC l) = (0w:'a word) then (a,i,pa,m,T) else let w = m a in let (w1,i1,pa1,m1,c1) = word_gen_gc_partial_move conf (w,i,pa,old,m,dm,gs,rs) in let m1 = (a =+ w1) m1 in let (a2,i2,pa2,m2,c2) = word_gen_gc_partial_move_list conf (a+bytes_in_word,n2w l,i1,pa1,old,m1,dm,gs,rs) in - (a2,i2,pa2,m2,a IN dm /\ c1 /\ c2)` - (CONV_TAC(RATOR_CONV(RAND_CONV(PURE_ONCE_REWRITE_CONV[word_gen_gc_partial_move_list_def]))) - >> fs[n2w_SUC]); - -Theorem word_gen_gc_partial_move_list_append ` - !a l l' i pa old m dm gs rs conf. + (a2,i2,pa2,m2,a IN dm /\ c1 /\ c2) +Proof + CONV_TAC(RATOR_CONV(RAND_CONV(PURE_ONCE_REWRITE_CONV[word_gen_gc_partial_move_list_def]))) + >> fs[n2w_SUC] +QED + +Theorem word_gen_gc_partial_move_list_append: + !a l l' i pa old m dm gs rs conf. (l+l' < dimword (:'a)) ==> ( word_gen_gc_partial_move_list conf (a,(n2w(l+l'):'a word),i,pa,old,m,dm,gs,rs) = let (a2,i2,pa2,m2,c2) = word_gen_gc_partial_move_list conf (a,n2w l,i,pa,old,m,dm,gs,rs) in let (a3,i3,pa3,m3,c3) = word_gen_gc_partial_move_list conf (a2,n2w l',i2,pa2,old,m2,dm,gs,rs) in - (a3,i3,pa3,m3,(c2 /\ c3)))` - (Induct_on `l` + (a3,i3,pa3,m3,(c2 /\ c3))) +Proof + Induct_on `l` >> rpt strip_tac >> fs[] >> ntac 2 (pairarg_tac >> fs[]) >- fs[word_gen_gc_partial_move_list_zero] >> fs[word_gen_gc_partial_move_list_suc,GSYM ADD_SUC] >> ntac 4 (pairarg_tac >> fs[]) - >> rfs[] >> metis_tac[]) + >> rfs[] >> metis_tac[] +QED val word_gc_move_loop_def = Define ` word_gc_move_loop k conf (pb,i,pa,old,m,dm,c) = @@ -448,12 +460,13 @@ val word_gc_fun_def = Define ` (Temp 6w, Word 0w)] in if c2 then SOME (TL roots1,m1,s1) else NONE)` -Theorem word_gc_move_roots_IMP_EVERY2 - `!xs ys pa m i c1 m1 pa1 i1 old dm c. +Theorem word_gc_move_roots_IMP_EVERY2: + !xs ys pa m i c1 m1 pa1 i1 old dm c. word_gc_move_roots c (xs,i,pa,old,m,dm) = (ys,i1,pa1,m1,c1) ==> EVERY2 (\x y. (isWord x <=> isWord y) /\ - (is_gc_word_const x ==> x = y)) xs ys` - (Induct \\ full_simp_tac(srw_ss())[word_gc_move_roots_def] + (is_gc_word_const x ==> x = y)) xs ys +Proof + Induct \\ full_simp_tac(srw_ss())[word_gc_move_roots_def] \\ full_simp_tac(srw_ss())[IMP_EQ_DISJ,word_gc_fun_def] \\ srw_tac[][] \\ CCONTR_TAC \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ res_tac \\ full_simp_tac(srw_ss())[GSYM IMP_EQ_DISJ,word_gc_fun_def] \\ srw_tac[][] \\ res_tac @@ -463,15 +476,17 @@ Theorem word_gc_move_roots_IMP_EVERY2 \\ UNABBREV_ALL_TAC \\ srw_tac[][] \\ pop_assum mp_tac \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ CCONTR_TAC \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ fs[isWord_def,word_simpProofTheory.is_gc_word_const_def, - word_simpTheory.is_gc_const_def]); + word_simpTheory.is_gc_const_def] +QED -Theorem word_gen_gc_move_roots_IMP_EVERY2 - `!xs ys pa m i ib pb c1 m1 pa1 i1 ib1 pb1 old dm c. +Theorem word_gen_gc_move_roots_IMP_EVERY2: + !xs ys pa m i ib pb c1 m1 pa1 i1 ib1 pb1 old dm c. word_gen_gc_move_roots c (xs,i,pa,ib,pb,old,m,dm) = (ys,i1,pa1,ib1,pb1,m1,c1) ==> EVERY2 (\x y. (isWord x <=> isWord y) /\ - (is_gc_word_const x ==> x = y)) xs ys` - (Induct \\ full_simp_tac(srw_ss())[word_gen_gc_move_roots_def] + (is_gc_word_const x ==> x = y)) xs ys +Proof + Induct \\ full_simp_tac(srw_ss())[word_gen_gc_move_roots_def] \\ full_simp_tac(srw_ss())[IMP_EQ_DISJ] \\ srw_tac[][] \\ CCONTR_TAC \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ res_tac \\ full_simp_tac(srw_ss())[GSYM IMP_EQ_DISJ] \\ srw_tac[][] \\ res_tac @@ -483,15 +498,17 @@ Theorem word_gen_gc_move_roots_IMP_EVERY2 \\ UNABBREV_ALL_TAC \\ srw_tac[][] \\ pop_assum mp_tac \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ CCONTR_TAC \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ fs[isWord_def,word_simpProofTheory.is_gc_word_const_def, - word_simpTheory.is_gc_const_def]); + word_simpTheory.is_gc_const_def] +QED -Theorem word_gen_gc_partial_move_roots_IMP_EVERY2 - `!xs ys pa m i gs rs c1 m1 pa1 i1 old dm c. +Theorem word_gen_gc_partial_move_roots_IMP_EVERY2: + !xs ys pa m i gs rs c1 m1 pa1 i1 old dm c. word_gen_gc_partial_move_roots c (xs,i,pa,old,m,dm,gs,rs) = (ys,i1,pa1,m1,c1) ==> EVERY2 (\x y. (isWord x <=> isWord y) /\ - (is_gc_word_const x ==> x = y)) xs ys` - (Induct \\ full_simp_tac(srw_ss())[word_gen_gc_partial_move_roots_def] + (is_gc_word_const x ==> x = y)) xs ys +Proof + Induct \\ full_simp_tac(srw_ss())[word_gen_gc_partial_move_roots_def] \\ full_simp_tac(srw_ss())[IMP_EQ_DISJ] \\ srw_tac[][] \\ CCONTR_TAC \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ res_tac \\ full_simp_tac(srw_ss())[GSYM IMP_EQ_DISJ] \\ srw_tac[][] \\ res_tac @@ -504,12 +521,14 @@ Theorem word_gen_gc_partial_move_roots_IMP_EVERY2 \\ UNABBREV_ALL_TAC \\ srw_tac[][] \\ pop_assum mp_tac \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ CCONTR_TAC \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ fs[isWord_def,word_simpProofTheory.is_gc_word_const_def, - word_simpTheory.is_gc_const_def]); - -Theorem word_gc_IMP_EVERY2 - `word_gc_fun c (xs,m,dm,st) = SOME (ys,m1,s1) ==> - EVERY2 (\x y. (isWord x <=> isWord y) /\ (is_gc_word_const x ==> x = y)) xs ys` - (full_simp_tac(srw_ss())[word_gc_fun_def,LET_THM,word_gc_fun_def, + word_simpTheory.is_gc_const_def] +QED + +Theorem word_gc_IMP_EVERY2: + word_gc_fun c (xs,m,dm,st) = SOME (ys,m1,s1) ==> + EVERY2 (\x y. (isWord x <=> isWord y) /\ (is_gc_word_const x ==> x = y)) xs ys +Proof + full_simp_tac(srw_ss())[word_gc_fun_def,LET_THM,word_gc_fun_def, word_full_gc_def,word_gen_gc_def,word_gen_gc_partial_def, word_gen_gc_partial_full_def] \\ TOP_CASE_TAC \\ fs [] @@ -525,160 +544,203 @@ Theorem word_gc_IMP_EVERY2 \\ imp_res_tac word_gc_move_roots_IMP_EVERY2 \\ imp_res_tac word_gen_gc_move_roots_IMP_EVERY2 \\ imp_res_tac word_gen_gc_partial_move_roots_IMP_EVERY2 - \\ Cases_on `roots` \\ fs []); + \\ Cases_on `roots` \\ fs [] +QED -Theorem word_gc_fun_LENGTH - `word_gc_fun c (xs,m,dm,s) = SOME (zs,m1,s1) ==> LENGTH xs = LENGTH zs` - (srw_tac[][] \\ drule word_gc_IMP_EVERY2 - \\ srw_tac[][] \\ imp_res_tac EVERY2_LENGTH); +Theorem word_gc_fun_LENGTH: + word_gc_fun c (xs,m,dm,s) = SOME (zs,m1,s1) ==> LENGTH xs = LENGTH zs +Proof + srw_tac[][] \\ drule word_gc_IMP_EVERY2 + \\ srw_tac[][] \\ imp_res_tac EVERY2_LENGTH +QED (* lemmas about has_fp_ops *) -Theorem word_gc_fun_assum_has_fp_ops[simp] - `word_gc_fun_assum (conf with has_fp_ops := b) s = - word_gc_fun_assum conf s` - (EVAL_TAC \\ fs []); - -Theorem word_gc_move_has_fp_ops[simp] - `!x. word_gc_move (conf with has_fp_ops := b) x = - word_gc_move conf x` - (simp_tac std_ss [FORALL_PROD] \\ Cases +Theorem word_gc_fun_assum_has_fp_ops[simp]: + word_gc_fun_assum (conf with has_fp_ops := b) s = + word_gc_fun_assum conf s +Proof + EVAL_TAC \\ fs [] +QED + +Theorem word_gc_move_has_fp_ops[simp]: + !x. word_gc_move (conf with has_fp_ops := b) x = + word_gc_move conf x +Proof + simp_tac std_ss [FORALL_PROD] \\ Cases \\ simp_tac std_ss [FORALL_PROD,word_gc_move_def] - \\ fs [ptr_to_addr_def,update_addr_def,small_shift_length_def,decode_length_def]); - -Theorem word_gen_gc_move_has_fp_ops[simp] - `!x. word_gen_gc_move (conf with has_fp_ops := b) x = - word_gen_gc_move conf x` - (simp_tac std_ss [FORALL_PROD] \\ Cases + \\ fs [ptr_to_addr_def,update_addr_def,small_shift_length_def,decode_length_def] +QED + +Theorem word_gen_gc_move_has_fp_ops[simp]: + !x. word_gen_gc_move (conf with has_fp_ops := b) x = + word_gen_gc_move conf x +Proof + simp_tac std_ss [FORALL_PROD] \\ Cases \\ simp_tac std_ss [FORALL_PROD,word_gen_gc_move_def] - \\ fs [ptr_to_addr_def,update_addr_def,small_shift_length_def,decode_length_def]); - -Theorem word_gen_gc_partial_move_has_fp_ops[simp] - `!x. word_gen_gc_partial_move (conf with has_fp_ops := b) x = - word_gen_gc_partial_move conf x` - (simp_tac std_ss [FORALL_PROD] \\ Cases + \\ fs [ptr_to_addr_def,update_addr_def,small_shift_length_def,decode_length_def] +QED + +Theorem word_gen_gc_partial_move_has_fp_ops[simp]: + !x. word_gen_gc_partial_move (conf with has_fp_ops := b) x = + word_gen_gc_partial_move conf x +Proof + simp_tac std_ss [FORALL_PROD] \\ Cases \\ simp_tac std_ss [FORALL_PROD,word_gen_gc_partial_move_def] - \\ fs [ptr_to_addr_def,update_addr_def,small_shift_length_def,decode_length_def]); - -Theorem word_gc_move_list_has_fp_ops[simp] - `!conf x. word_gc_move_list (conf with has_fp_ops := b) x = - word_gc_move_list conf x` - (simp_tac std_ss [FORALL_PROD] + \\ fs [ptr_to_addr_def,update_addr_def,small_shift_length_def,decode_length_def] +QED + +Theorem word_gc_move_list_has_fp_ops[simp]: + !conf x. word_gc_move_list (conf with has_fp_ops := b) x = + word_gc_move_list conf x +Proof + simp_tac std_ss [FORALL_PROD] \\ recInduct (fetch "-" "word_gc_move_list_ind") \\ rw [] \\ once_rewrite_tac [word_gc_move_list_def] \\ rw [] - \\ rpt (pairarg_tac \\ fs [])); - -Theorem word_gen_gc_move_list_has_fp_ops[simp] - `!conf x. word_gen_gc_move_list (conf with has_fp_ops := b) x = - word_gen_gc_move_list conf x` - (simp_tac std_ss [FORALL_PROD] + \\ rpt (pairarg_tac \\ fs []) +QED + +Theorem word_gen_gc_move_list_has_fp_ops[simp]: + !conf x. word_gen_gc_move_list (conf with has_fp_ops := b) x = + word_gen_gc_move_list conf x +Proof + simp_tac std_ss [FORALL_PROD] \\ recInduct (fetch "-" "word_gen_gc_move_list_ind") \\ rw [] \\ once_rewrite_tac [word_gen_gc_move_list_def] \\ rw [] - \\ rpt (pairarg_tac \\ fs [])); - -Theorem word_gen_gc_partial_move_list_has_fp_ops[simp] - `!conf x. word_gen_gc_partial_move_list (conf with has_fp_ops := b) x = - word_gen_gc_partial_move_list conf x` - (simp_tac std_ss [FORALL_PROD] + \\ rpt (pairarg_tac \\ fs []) +QED + +Theorem word_gen_gc_partial_move_list_has_fp_ops[simp]: + !conf x. word_gen_gc_partial_move_list (conf with has_fp_ops := b) x = + word_gen_gc_partial_move_list conf x +Proof + simp_tac std_ss [FORALL_PROD] \\ recInduct (fetch "-" "word_gen_gc_partial_move_list_ind") \\ rw [] \\ once_rewrite_tac [word_gen_gc_partial_move_list_def] \\ rw [] - \\ rpt (pairarg_tac \\ fs [])); - -Theorem word_gc_move_roots_has_fp_ops[simp] - `!conf x. word_gc_move_roots (conf with has_fp_ops := b) x = - word_gc_move_roots conf x` - (simp_tac std_ss [FORALL_PROD] + \\ rpt (pairarg_tac \\ fs []) +QED + +Theorem word_gc_move_roots_has_fp_ops[simp]: + !conf x. word_gc_move_roots (conf with has_fp_ops := b) x = + word_gc_move_roots conf x +Proof + simp_tac std_ss [FORALL_PROD] \\ recInduct (fetch "-" "word_gc_move_roots_ind") \\ rw [] \\ once_rewrite_tac [word_gc_move_roots_def] \\ rw [] - \\ rpt (pairarg_tac \\ fs [])); - -Theorem word_gen_gc_move_roots_has_fp_ops[simp] - `!conf x. word_gen_gc_move_roots (conf with has_fp_ops := b) x = - word_gen_gc_move_roots conf x` - (simp_tac std_ss [FORALL_PROD] + \\ rpt (pairarg_tac \\ fs []) +QED + +Theorem word_gen_gc_move_roots_has_fp_ops[simp]: + !conf x. word_gen_gc_move_roots (conf with has_fp_ops := b) x = + word_gen_gc_move_roots conf x +Proof + simp_tac std_ss [FORALL_PROD] \\ recInduct (fetch "-" "word_gen_gc_move_roots_ind") \\ rw [] \\ once_rewrite_tac [word_gen_gc_move_roots_def] \\ rw [] - \\ rpt (pairarg_tac \\ fs [])); - -Theorem word_gen_gc_partial_move_roots_has_fp_ops[simp] - `!conf x. word_gen_gc_partial_move_roots (conf with has_fp_ops := b) x = - word_gen_gc_partial_move_roots conf x` - (simp_tac std_ss [FORALL_PROD] + \\ rpt (pairarg_tac \\ fs []) +QED + +Theorem word_gen_gc_partial_move_roots_has_fp_ops[simp]: + !conf x. word_gen_gc_partial_move_roots (conf with has_fp_ops := b) x = + word_gen_gc_partial_move_roots conf x +Proof + simp_tac std_ss [FORALL_PROD] \\ recInduct (fetch "-" "word_gen_gc_partial_move_roots_ind") \\ rw [] \\ once_rewrite_tac [word_gen_gc_partial_move_roots_def] \\ rw [] - \\ rpt (pairarg_tac \\ fs [])); - -Theorem word_gc_move_loop_has_fp_ops[simp] - `!n conf x. word_gc_move_loop n (conf with has_fp_ops := b) x = - word_gc_move_loop n conf x` - (simp_tac std_ss [FORALL_PROD] + \\ rpt (pairarg_tac \\ fs []) +QED + +Theorem word_gc_move_loop_has_fp_ops[simp]: + !n conf x. word_gc_move_loop n (conf with has_fp_ops := b) x = + word_gc_move_loop n conf x +Proof + simp_tac std_ss [FORALL_PROD] \\ Induct \\ rw [] \\ once_rewrite_tac [word_gc_move_loop_def] \\ fs [] - \\ fs [ptr_to_addr_def,update_addr_def,small_shift_length_def,decode_length_def]); - -Theorem word_gen_gc_partial_move_data_has_fp_ops[simp] - `!n conf x. word_gen_gc_partial_move_data (conf with has_fp_ops := b) n x = - word_gen_gc_partial_move_data conf n x` - (simp_tac std_ss [FORALL_PROD] + \\ fs [ptr_to_addr_def,update_addr_def,small_shift_length_def,decode_length_def] +QED + +Theorem word_gen_gc_partial_move_data_has_fp_ops[simp]: + !n conf x. word_gen_gc_partial_move_data (conf with has_fp_ops := b) n x = + word_gen_gc_partial_move_data conf n x +Proof + simp_tac std_ss [FORALL_PROD] \\ Induct \\ rw [] \\ once_rewrite_tac [word_gen_gc_partial_move_data_def] \\ fs [] - \\ fs [ptr_to_addr_def,update_addr_def,small_shift_length_def,decode_length_def]); - -Theorem word_gen_gc_move_data_has_fp_ops[simp] - `!n conf x. word_gen_gc_move_data (conf with has_fp_ops := b) n x = - word_gen_gc_move_data conf n x` - (simp_tac std_ss [FORALL_PROD] + \\ fs [ptr_to_addr_def,update_addr_def,small_shift_length_def,decode_length_def] +QED + +Theorem word_gen_gc_move_data_has_fp_ops[simp]: + !n conf x. word_gen_gc_move_data (conf with has_fp_ops := b) n x = + word_gen_gc_move_data conf n x +Proof + simp_tac std_ss [FORALL_PROD] \\ Induct \\ rw [] \\ once_rewrite_tac [word_gen_gc_move_data_def] \\ fs [] - \\ fs [ptr_to_addr_def,update_addr_def,small_shift_length_def,decode_length_def]); - -Theorem word_gen_gc_move_refs_has_fp_ops[simp] - `!n conf x. word_gen_gc_move_refs (conf with has_fp_ops := b) n x = - word_gen_gc_move_refs conf n x` - (simp_tac std_ss [FORALL_PROD] + \\ fs [ptr_to_addr_def,update_addr_def,small_shift_length_def,decode_length_def] +QED + +Theorem word_gen_gc_move_refs_has_fp_ops[simp]: + !n conf x. word_gen_gc_move_refs (conf with has_fp_ops := b) n x = + word_gen_gc_move_refs conf n x +Proof + simp_tac std_ss [FORALL_PROD] \\ Induct \\ rw [] \\ once_rewrite_tac [word_gen_gc_move_refs_def] \\ fs [] - \\ fs [ptr_to_addr_def,update_addr_def,small_shift_length_def,decode_length_def]); - -Theorem word_gen_gc_partial_move_ref_list_has_fp_ops[simp] - `!n conf x. word_gen_gc_partial_move_ref_list n (conf with has_fp_ops := b) x = - word_gen_gc_partial_move_ref_list n conf x` - (simp_tac std_ss [FORALL_PROD] + \\ fs [ptr_to_addr_def,update_addr_def,small_shift_length_def,decode_length_def] +QED + +Theorem word_gen_gc_partial_move_ref_list_has_fp_ops[simp]: + !n conf x. word_gen_gc_partial_move_ref_list n (conf with has_fp_ops := b) x = + word_gen_gc_partial_move_ref_list n conf x +Proof + simp_tac std_ss [FORALL_PROD] \\ Induct \\ rw [] \\ once_rewrite_tac [word_gen_gc_partial_move_ref_list_def] \\ fs [] - \\ fs [ptr_to_addr_def,update_addr_def,small_shift_length_def,decode_length_def]); - -Theorem word_gen_gc_move_loop_has_fp_ops[simp] - `!n conf x. word_gen_gc_move_loop (conf with has_fp_ops := b) n x = - word_gen_gc_move_loop conf n x` - (simp_tac std_ss [FORALL_PROD] + \\ fs [ptr_to_addr_def,update_addr_def,small_shift_length_def,decode_length_def] +QED + +Theorem word_gen_gc_move_loop_has_fp_ops[simp]: + !n conf x. word_gen_gc_move_loop (conf with has_fp_ops := b) n x = + word_gen_gc_move_loop conf n x +Proof + simp_tac std_ss [FORALL_PROD] \\ Induct \\ rw [] \\ once_rewrite_tac [word_gen_gc_move_loop_def] \\ fs [] - \\ fs [ptr_to_addr_def,update_addr_def,small_shift_length_def,decode_length_def]); - -Theorem word_full_gc_has_fp_ops[simp] - `!x. word_full_gc (conf with has_fp_ops := b) x = - word_full_gc conf x` - (simp_tac std_ss [FORALL_PROD] - \\ rewrite_tac [word_full_gc_def] \\ fs []); - -Theorem word_gen_gc_partial_full_has_fp_ops[simp] - `!x. word_gen_gc_partial_full (conf with has_fp_ops := b) x = - word_gen_gc_partial_full conf x` - (simp_tac std_ss [FORALL_PROD] + \\ fs [ptr_to_addr_def,update_addr_def,small_shift_length_def,decode_length_def] +QED + +Theorem word_full_gc_has_fp_ops[simp]: + !x. word_full_gc (conf with has_fp_ops := b) x = + word_full_gc conf x +Proof + simp_tac std_ss [FORALL_PROD] + \\ rewrite_tac [word_full_gc_def] \\ fs [] +QED + +Theorem word_gen_gc_partial_full_has_fp_ops[simp]: + !x. word_gen_gc_partial_full (conf with has_fp_ops := b) x = + word_gen_gc_partial_full conf x +Proof + simp_tac std_ss [FORALL_PROD] \\ rewrite_tac [word_gen_gc_partial_full_def] - \\ fs [word_gen_gc_partial_def]); - -Theorem word_gen_gc_has_fp_ops[simp] - `!x. word_gen_gc (conf with has_fp_ops := b) x = - word_gen_gc conf x` - (simp_tac std_ss [FORALL_PROD] + \\ fs [word_gen_gc_partial_def] +QED + +Theorem word_gen_gc_has_fp_ops[simp]: + !x. word_gen_gc (conf with has_fp_ops := b) x = + word_gen_gc conf x +Proof + simp_tac std_ss [FORALL_PROD] \\ rewrite_tac [word_gen_gc_def] - \\ fs [word_gen_gc_partial_def]); - -Theorem word_gc_fun_has_fp_ops[simp] - `word_gc_fun (conf with has_fp_ops := b) = word_gc_fun conf` - (fs [word_gc_fun_def,FUN_EQ_THM,FORALL_PROD] - \\ Cases_on `conf.gc_kind` \\ fs []); + \\ fs [word_gen_gc_partial_def] +QED + +Theorem word_gc_fun_has_fp_ops[simp]: + word_gc_fun (conf with has_fp_ops := b) = word_gc_fun conf +Proof + fs [word_gc_fun_def,FUN_EQ_THM,FORALL_PROD] + \\ Cases_on `conf.gc_kind` \\ fs [] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/word_instProofScript.sml b/compiler/backend/proofs/word_instProofScript.sml index cad4c444e2..7943b05b72 100644 --- a/compiler/backend/proofs/word_instProofScript.sml +++ b/compiler/backend/proofs/word_instProofScript.sml @@ -574,8 +574,8 @@ val locals_rm = Q.prove(` The inst-selected program gives same result but with possibly more locals used *) -Theorem inst_select_thm ` - ∀c temp prog st res rst loc. +Theorem inst_select_thm: + ∀c temp prog st res rst loc. evaluate (prog,st) = (res,rst) ∧ every_var (λx. x < temp) prog ∧ res ≠ SOME Error ∧ @@ -584,8 +584,9 @@ Theorem inst_select_thm ` evaluate (inst_select c temp prog,st with locals:=loc) = (res,rst with locals:=loc') ∧ case res of NONE => locals_rel temp rst.locals loc' - | SOME _ => rst.locals = loc'` - (ho_match_mp_tac inst_select_ind>>srw_tac[][]>> + | SOME _ => rst.locals = loc' +Proof + ho_match_mp_tac inst_select_ind>>srw_tac[][]>> full_simp_tac(srw_ss())[inst_select_def,locals_rel_evaluate_thm] >- (full_simp_tac(srw_ss())[evaluate_def]>>last_x_assum mp_tac>>FULL_CASE_TAC>>srw_tac[][]>> @@ -799,7 +800,8 @@ Theorem inst_select_thm ` Cases_on`res`>>full_simp_tac(srw_ss())[]>> qexists_tac`loc''`>>metis_tac[]) >> - full_simp_tac(srw_ss())[state_component_equality]); + full_simp_tac(srw_ss())[state_component_equality] +QED (* inst_select syntax *) val inst_select_exp_flat_exp_conventions = Q.prove(` @@ -808,14 +810,16 @@ val inst_select_exp_flat_exp_conventions = Q.prove(` ho_match_mp_tac inst_select_exp_ind>>srw_tac[][]>>full_simp_tac(srw_ss())[inst_select_exp_def,flat_exp_conventions_def,LET_THM]>> EVERY_CASE_TAC>>full_simp_tac(srw_ss())[flat_exp_conventions_def,inst_select_exp_def,LET_THM]); -Theorem inst_select_flat_exp_conventions ` - ∀c temp prog. - flat_exp_conventions (inst_select c temp prog)` - (ho_match_mp_tac inst_select_ind >>srw_tac[][]>> +Theorem inst_select_flat_exp_conventions: + ∀c temp prog. + flat_exp_conventions (inst_select c temp prog) +Proof + ho_match_mp_tac inst_select_ind >>srw_tac[][]>> full_simp_tac(srw_ss())[flat_exp_conventions_def,inst_select_def,LET_THM]>> EVERY_CASE_TAC>> full_simp_tac(srw_ss())[flat_exp_conventions_def]>> - metis_tac[inst_select_exp_flat_exp_conventions]); + metis_tac[inst_select_exp_flat_exp_conventions] +QED (*Less restrictive version of inst_ok guaranteed by inst_select*) val inst_select_exp_full_inst_ok_less = Q.prove(` @@ -827,28 +831,31 @@ val inst_select_exp_full_inst_ok_less = Q.prove(` every_case_tac>>fs[full_inst_ok_less_def,inst_ok_less_def,inst_select_exp_def,LET_THM] ); -Theorem inst_select_full_inst_ok_less ` - ∀c temp prog. +Theorem inst_select_full_inst_ok_less: + ∀c temp prog. addr_offset_ok c 0w ∧ every_inst (inst_ok_less c) prog ⇒ - full_inst_ok_less c (inst_select c temp prog)` - (ho_match_mp_tac inst_select_ind>> + full_inst_ok_less c (inst_select c temp prog) +Proof + ho_match_mp_tac inst_select_ind>> rw[inst_select_def,full_inst_ok_less_def,every_inst_def]>> EVERY_CASE_TAC>> fs[inst_select_def,full_inst_ok_less_def,inst_ok_less_def,every_inst_def]>> - metis_tac[inst_select_exp_full_inst_ok_less]); + metis_tac[inst_select_exp_full_inst_ok_less] +QED (* three_to_two_reg semantics *) (*Semantics preservation*) -Theorem three_to_two_reg_correct ` - ∀prog s res s'. +Theorem three_to_two_reg_correct: + ∀prog s res s'. every_inst distinct_tar_reg prog ∧ evaluate (prog,s) = (res,s') ∧ res ≠ SOME Error ⇒ - evaluate(three_to_two_reg prog,s) = (res,s')` - (ho_match_mp_tac three_to_two_reg_ind>> + evaluate(three_to_two_reg prog,s) = (res,s') +Proof + ho_match_mp_tac three_to_two_reg_ind>> srw_tac[][]>>full_simp_tac(srw_ss())[three_to_two_reg_def,evaluate_def,state_component_equality]>> TRY (ntac 2 (pop_assum mp_tac)>>full_simp_tac(srw_ss())[inst_def,assign_def,word_exp_def,get_vars_def,get_var_def,set_vars_def,alist_insert_def,the_words_def]>> @@ -883,43 +890,54 @@ Theorem three_to_two_reg_correct ` full_simp_tac(srw_ss())[push_env_def,LET_THM]>> EVERY_CASE_TAC>>full_simp_tac(srw_ss())[]>> res_tac>>full_simp_tac(srw_ss())[]>> - rev_full_simp_tac(srw_ss())[]); + rev_full_simp_tac(srw_ss())[] +QED (* Syntactic three_to_two_reg *) -Theorem three_to_two_reg_two_reg_inst ` - ∀prog. every_inst two_reg_inst (three_to_two_reg prog)` - (ho_match_mp_tac three_to_two_reg_ind>>srw_tac[][]>>full_simp_tac(srw_ss())[every_inst_def,two_reg_inst_def,three_to_two_reg_def,LET_THM]>>EVERY_CASE_TAC>>full_simp_tac(srw_ss())[]); - -Theorem three_to_two_reg_wf_cutsets - `∀prog. wf_cutsets prog ⇒ wf_cutsets (three_to_two_reg prog)` - (ho_match_mp_tac three_to_two_reg_ind>>srw_tac[][]>> - full_simp_tac(srw_ss())[wf_cutsets_def,three_to_two_reg_def,LET_THM]>>EVERY_CASE_TAC>>full_simp_tac(srw_ss())[]); - -Theorem three_to_two_reg_pre_alloc_conventions - `∀prog. pre_alloc_conventions prog ⇒ pre_alloc_conventions (three_to_two_reg prog)` - (ho_match_mp_tac three_to_two_reg_ind>>srw_tac[][]>> +Theorem three_to_two_reg_two_reg_inst: + ∀prog. every_inst two_reg_inst (three_to_two_reg prog) +Proof + ho_match_mp_tac three_to_two_reg_ind>>srw_tac[][]>>full_simp_tac(srw_ss())[every_inst_def,two_reg_inst_def,three_to_two_reg_def,LET_THM]>>EVERY_CASE_TAC>>full_simp_tac(srw_ss())[] +QED + +Theorem three_to_two_reg_wf_cutsets: + ∀prog. wf_cutsets prog ⇒ wf_cutsets (three_to_two_reg prog) +Proof + ho_match_mp_tac three_to_two_reg_ind>>srw_tac[][]>> + full_simp_tac(srw_ss())[wf_cutsets_def,three_to_two_reg_def,LET_THM]>>EVERY_CASE_TAC>>full_simp_tac(srw_ss())[] +QED + +Theorem three_to_two_reg_pre_alloc_conventions: + ∀prog. pre_alloc_conventions prog ⇒ pre_alloc_conventions (three_to_two_reg prog) +Proof + ho_match_mp_tac three_to_two_reg_ind>>srw_tac[][]>> full_simp_tac(srw_ss())[pre_alloc_conventions_def,every_stack_var_def,three_to_two_reg_def,LET_THM,call_arg_convention_def,inst_arg_convention_def]>> FULL_CASE_TAC>>fs[]>> PairCases_on`x`>>fs[]>> FULL_CASE_TAC>>fs[]>> - PairCases_on`x`>>fs[]); - -Theorem three_to_two_reg_flat_exp_conventions - `∀prog. flat_exp_conventions prog ⇒ flat_exp_conventions (three_to_two_reg prog)` - (ho_match_mp_tac three_to_two_reg_ind>>srw_tac[][]>> - full_simp_tac(srw_ss())[flat_exp_conventions_def,three_to_two_reg_def,LET_THM]>>EVERY_CASE_TAC>>full_simp_tac(srw_ss())[]); - -Theorem three_to_two_reg_full_inst_ok_less - `∀prog. full_inst_ok_less c prog ⇒ - full_inst_ok_less c (three_to_two_reg prog)` - (ho_match_mp_tac three_to_two_reg_ind>>srw_tac[][]>> + PairCases_on`x`>>fs[] +QED + +Theorem three_to_two_reg_flat_exp_conventions: + ∀prog. flat_exp_conventions prog ⇒ flat_exp_conventions (three_to_two_reg prog) +Proof + ho_match_mp_tac three_to_two_reg_ind>>srw_tac[][]>> + full_simp_tac(srw_ss())[flat_exp_conventions_def,three_to_two_reg_def,LET_THM]>>EVERY_CASE_TAC>>full_simp_tac(srw_ss())[] +QED + +Theorem three_to_two_reg_full_inst_ok_less: + ∀prog. full_inst_ok_less c prog ⇒ + full_inst_ok_less c (three_to_two_reg prog) +Proof + ho_match_mp_tac three_to_two_reg_ind>>srw_tac[][]>> full_simp_tac(srw_ss())[three_to_two_reg_def,LET_THM]>>EVERY_CASE_TAC>>fs[full_inst_ok_less_def] >- (Cases_on`bop`>>Cases_on`ri`>>fs[full_inst_ok_less_def,inst_ok_less_def,every_inst_def]) >- (Cases_on`n`>>fs[inst_ok_less_def]) >> - metis_tac[inst_ok_less_def]); + metis_tac[inst_ok_less_def] +QED (* label preservation stuff *) val inst_select_exp_no_lab = Q.prove(` @@ -928,17 +946,21 @@ val inst_select_exp_no_lab = Q.prove(` ho_match_mp_tac inst_select_exp_ind>>rw[inst_select_exp_def]>>fs[extract_labels_def]>> rpt(TOP_CASE_TAC>>fs[extract_labels_def,inst_select_exp_def])) -Theorem inst_select_lab_pres ` - ∀c temp prog. - extract_labels prog = extract_labels (inst_select c temp prog)` - (ho_match_mp_tac inst_select_ind>>rw[inst_select_def,extract_labels_def]>> +Theorem inst_select_lab_pres: + ∀c temp prog. + extract_labels prog = extract_labels (inst_select c temp prog) +Proof + ho_match_mp_tac inst_select_ind>>rw[inst_select_def,extract_labels_def]>> TRY(metis_tac[inst_select_exp_no_lab])>> EVERY_CASE_TAC>>fs[extract_labels_def]>> - TRY(metis_tac[inst_select_exp_no_lab])); - -Theorem three_to_two_reg_lab_pres ` - ∀prog. - extract_labels prog = extract_labels (three_to_two_reg prog)` - (ho_match_mp_tac three_to_two_reg_ind>>rw[three_to_two_reg_def,extract_labels_def]>>EVERY_CASE_TAC>>fs[]); + TRY(metis_tac[inst_select_exp_no_lab]) +QED + +Theorem three_to_two_reg_lab_pres: + ∀prog. + extract_labels prog = extract_labels (three_to_two_reg prog) +Proof + ho_match_mp_tac three_to_two_reg_ind>>rw[three_to_two_reg_def,extract_labels_def]>>EVERY_CASE_TAC>>fs[] +QED val _ = export_theory (); diff --git a/compiler/backend/proofs/word_removeProofScript.sml b/compiler/backend/proofs/word_removeProofScript.sml index 28327a5d6a..8b1215977e 100644 --- a/compiler/backend/proofs/word_removeProofScript.sml +++ b/compiler/backend/proofs/word_removeProofScript.sml @@ -17,8 +17,8 @@ val compile_state_def = Define` compile := c |>`; -Theorem compile_state_const[simp] - `(compile_state clk c s).locals = s.locals ∧ +Theorem compile_state_const[simp]: + (compile_state clk c s).locals = s.locals ∧ (compile_state clk c s).permute = s.permute ∧ (compile_state clk c s).ffi = s.ffi ∧ (compile_state clk c s).code_buffer = s.code_buffer ∧ @@ -35,16 +35,20 @@ Theorem compile_state_const[simp] (compile_state clk c s).mdomain = s.mdomain ∧ (compile_state clk c s).be = s.be ∧ (compile_state clk c s).gc_fun = s.gc_fun ∧ - (compile_state clk c s).handler = s.handler` - (EVAL_TAC); - -Theorem find_code_map_I[simp] - `find_code d l (map (I ## f) t) = OPTION_MAP (I ## f) (find_code d l t)` - (Cases_on`d` \\ rw[find_code_def,lookup_map] - \\ rpt(TOP_CASE_TAC \\ fs[])); - -Theorem compile_state_update[simp] - `compile_state clk c s with stack updated_by f1 = compile_state clk c (s with stack updated_by f1) ∧ + (compile_state clk c s).handler = s.handler +Proof + EVAL_TAC +QED + +Theorem find_code_map_I[simp]: + find_code d l (map (I ## f) t) = OPTION_MAP (I ## f) (find_code d l t) +Proof + Cases_on`d` \\ rw[find_code_def,lookup_map] + \\ rpt(TOP_CASE_TAC \\ fs[]) +QED + +Theorem compile_state_update[simp]: + compile_state clk c s with stack updated_by f1 = compile_state clk c (s with stack updated_by f1) ∧ compile_state clk c s with permute updated_by f2 = compile_state clk c (s with permute updated_by f2) ∧ compile_state clk c s with ffi updated_by f10 = compile_state clk c (s with ffi updated_by f10) ∧ compile_state clk c s with data_buffer updated_by f9 = compile_state clk c (s with data_buffer updated_by f9) ∧ @@ -54,111 +58,158 @@ Theorem compile_state_update[simp] compile_state clk c s with memory updated_by f5 = compile_state clk c (s with memory updated_by f5) ∧ compile_state clk c s with store updated_by f4 = compile_state clk c (s with store updated_by f4) ∧ compile_state clk c s with fp_regs updated_by f11 = compile_state clk c (s with fp_regs updated_by f11) ∧ - compile_state clk c s with handler updated_by f3 = compile_state clk c (s with handler updated_by f3)` - (EVAL_TAC); - -Theorem get_var_compile_state[simp] - `get_var x (compile_state clk c s) = get_var x s` - (EVAL_TAC); - -Theorem get_fp_var_compile_state[simp] - `get_fp_var x (compile_state clk c s) = get_fp_var x s` - (EVAL_TAC); - -Theorem get_vars_compile_state[simp] - `∀xs s. get_vars xs (compile_state clk c s) = get_vars xs s` - (Induct \\ rw[get_vars_def]); - -Theorem set_var_compile_state[simp] - `set_var x y (compile_state clk c s) = compile_state clk c (set_var x y s)` - (rw[set_var_def]); - -Theorem set_fp_var_compile_state[simp] - `set_fp_var x y (compile_state clk c s) = compile_state clk c (set_fp_var x y s)` - (rw[set_fp_var_def]); - -Theorem set_vars_compile_state[simp] - `set_vars xs ys (compile_state clk c s) = compile_state clk c (set_vars xs ys s)` - (EVAL_TAC); - -Theorem set_store_compile_state[simp] - `set_store x y (compile_state clk c s) = compile_state clk c (set_store x y s)` - (EVAL_TAC); - -Theorem push_env_compile_state[simp] - `push_env env h (compile_state clk c s) = compile_state clk c (push_env env h s)` - (Cases_on`h` \\ TRY(PairCases_on`x`) \\ rw[push_env_def,UNCURRY]); - -Theorem pop_env_compile_state[simp] - `pop_env (compile_state clk c s) = OPTION_MAP (compile_state clk c) (pop_env s)` - (rw[pop_env_def] \\ ntac 4 (CASE_TAC \\ fs[])); - -Theorem call_env_compile_state[simp] - `call_env x (compile_state clk c z) = compile_state clk c (call_env x z)` - (EVAL_TAC); - -Theorem has_space_compile_state[simp] - `has_space n (compile_state clk c s) = has_space n s` - (EVAL_TAC); - -Theorem gc_compile_state[simp] - `gc (compile_state clk c s) = OPTION_MAP (compile_state clk c) (gc s)` - (rw[gc_def] \\ ntac 4 (CASE_TAC \\ simp[])); - -Theorem alloc_compile_state[simp] - `alloc w names (compile_state clk c s) = (I ## compile_state clk c) (alloc w names s)` - (rw[alloc_def] \\ ntac 6 (CASE_TAC \\ fs[])); - -Theorem mem_load_compile_state[simp] - `mem_load w (compile_state clk c s) = mem_load w s` - (EVAL_TAC); - -Theorem mem_store_compile_state[simp] - `mem_store x y (compile_state clk c s) = OPTION_MAP (compile_state clk c) (mem_store x y s)` - (rw[mem_store_def]); - -Theorem word_exp_compile_state[simp] - `∀s y. word_exp (compile_state clk c s) y = word_exp s y` - (recInduct word_exp_ind + compile_state clk c s with handler updated_by f3 = compile_state clk c (s with handler updated_by f3) +Proof + EVAL_TAC +QED + +Theorem get_var_compile_state[simp]: + get_var x (compile_state clk c s) = get_var x s +Proof + EVAL_TAC +QED + +Theorem get_fp_var_compile_state[simp]: + get_fp_var x (compile_state clk c s) = get_fp_var x s +Proof + EVAL_TAC +QED + +Theorem get_vars_compile_state[simp]: + ∀xs s. get_vars xs (compile_state clk c s) = get_vars xs s +Proof + Induct \\ rw[get_vars_def] +QED + +Theorem set_var_compile_state[simp]: + set_var x y (compile_state clk c s) = compile_state clk c (set_var x y s) +Proof + rw[set_var_def] +QED + +Theorem set_fp_var_compile_state[simp]: + set_fp_var x y (compile_state clk c s) = compile_state clk c (set_fp_var x y s) +Proof + rw[set_fp_var_def] +QED + +Theorem set_vars_compile_state[simp]: + set_vars xs ys (compile_state clk c s) = compile_state clk c (set_vars xs ys s) +Proof + EVAL_TAC +QED + +Theorem set_store_compile_state[simp]: + set_store x y (compile_state clk c s) = compile_state clk c (set_store x y s) +Proof + EVAL_TAC +QED + +Theorem push_env_compile_state[simp]: + push_env env h (compile_state clk c s) = compile_state clk c (push_env env h s) +Proof + Cases_on`h` \\ TRY(PairCases_on`x`) \\ rw[push_env_def,UNCURRY] +QED + +Theorem pop_env_compile_state[simp]: + pop_env (compile_state clk c s) = OPTION_MAP (compile_state clk c) (pop_env s) +Proof + rw[pop_env_def] \\ ntac 4 (CASE_TAC \\ fs[]) +QED + +Theorem call_env_compile_state[simp]: + call_env x (compile_state clk c z) = compile_state clk c (call_env x z) +Proof + EVAL_TAC +QED + +Theorem has_space_compile_state[simp]: + has_space n (compile_state clk c s) = has_space n s +Proof + EVAL_TAC +QED + +Theorem gc_compile_state[simp]: + gc (compile_state clk c s) = OPTION_MAP (compile_state clk c) (gc s) +Proof + rw[gc_def] \\ ntac 4 (CASE_TAC \\ simp[]) +QED + +Theorem alloc_compile_state[simp]: + alloc w names (compile_state clk c s) = (I ## compile_state clk c) (alloc w names s) +Proof + rw[alloc_def] \\ ntac 6 (CASE_TAC \\ fs[]) +QED + +Theorem mem_load_compile_state[simp]: + mem_load w (compile_state clk c s) = mem_load w s +Proof + EVAL_TAC +QED + +Theorem mem_store_compile_state[simp]: + mem_store x y (compile_state clk c s) = OPTION_MAP (compile_state clk c) (mem_store x y s) +Proof + rw[mem_store_def] +QED + +Theorem word_exp_compile_state[simp]: + ∀s y. word_exp (compile_state clk c s) y = word_exp s y +Proof + recInduct word_exp_ind \\ rw[word_exp_def] \\ fsrw_tac[ETA_ss][] \\ `MAP (word_exp (compile_state clk c s)) wexps = MAP (word_exp s) wexps` - by fs[MAP_EQ_f] \\ fs[]); - -Theorem assign_compile_state[simp] - `assign x y (compile_state clk c s) = OPTION_MAP (compile_state clk c) (assign x y s)` - (rw[assign_def] \\ CASE_TAC \\ fs[]); - -Theorem inst_compile_state[simp] - `inst i (compile_state clk c s) = OPTION_MAP (compile_state clk c) (inst i s)` - (rw[inst_def] \\ rpt(TOP_CASE_TAC \\ fs[]) \\ fs[]); - -Theorem compile_state_dec_clock[simp] - `s.clock ≠ 0 ⇒ (compile_state clk c (dec_clock s) = dec_clock (compile_state clk c s))` - (EVAL_TAC \\ rw[state_component_equality]); - -Theorem jump_exc_compile_state[simp] - `jump_exc (compile_state clk c s) = OPTION_MAP (compile_state clk c ## I) (jump_exc s)` - (rw[jump_exc_def] \\ ntac 5 (CASE_TAC \\ fs[])); - -Theorem get_var_imm_compile_state[simp] - `get_var_imm x (compile_state clk c s) = get_var_imm x s` - (Cases_on`x` \\ rw[get_var_imm_def]); - -Theorem push_env_case_handler[simp] - `push_env x (case handler of NONE => NONE | SOME (v,prog,l1,l2) => SOME (v, f prog, l1,l2)) = push_env x handler` - (CASE_TAC \\ rw[push_env_def] - \\ split_pair_case_tac \\ rw[push_env_def,FUN_EQ_THM]); - -Theorem word_remove_correct - `∀prog st res rst. + by fs[MAP_EQ_f] \\ fs[] +QED + +Theorem assign_compile_state[simp]: + assign x y (compile_state clk c s) = OPTION_MAP (compile_state clk c) (assign x y s) +Proof + rw[assign_def] \\ CASE_TAC \\ fs[] +QED + +Theorem inst_compile_state[simp]: + inst i (compile_state clk c s) = OPTION_MAP (compile_state clk c) (inst i s) +Proof + rw[inst_def] \\ rpt(TOP_CASE_TAC \\ fs[]) \\ fs[] +QED + +Theorem compile_state_dec_clock[simp]: + s.clock ≠ 0 ⇒ (compile_state clk c (dec_clock s) = dec_clock (compile_state clk c s)) +Proof + EVAL_TAC \\ rw[state_component_equality] +QED + +Theorem jump_exc_compile_state[simp]: + jump_exc (compile_state clk c s) = OPTION_MAP (compile_state clk c ## I) (jump_exc s) +Proof + rw[jump_exc_def] \\ ntac 5 (CASE_TAC \\ fs[]) +QED + +Theorem get_var_imm_compile_state[simp]: + get_var_imm x (compile_state clk c s) = get_var_imm x s +Proof + Cases_on`x` \\ rw[get_var_imm_def] +QED + +Theorem push_env_case_handler[simp]: + push_env x (case handler of NONE => NONE | SOME (v,prog,l1,l2) => SOME (v, f prog, l1,l2)) = push_env x handler +Proof + CASE_TAC \\ rw[push_env_def] + \\ split_pair_case_tac \\ rw[push_env_def,FUN_EQ_THM] +QED + +Theorem word_remove_correct: + ∀prog st res rst. evaluate (prog,st) = (res,rst) ∧ st.compile = (λcfg. c cfg o (MAP (I ## I ## remove_must_terminate))) ∧ res ≠ SOME Error ⇒ ∃clk. evaluate (remove_must_terminate prog, compile_state clk c st) = - (res, compile_state 0 c rst)` - (recInduct evaluate_ind + (res, compile_state 0 c rst) +Proof + recInduct evaluate_ind \\ rw[evaluate_def,remove_must_terminate_def] \\ TRY ( (* Seq *) qmatch_goalsub_rename_tac`remove_must_terminate _` \\ @@ -281,7 +332,8 @@ Theorem word_remove_correct \\ fs[case_eq_thms] \\ rveq \\ fs[domain_map] \\ rpt(pairarg_tac \\ fs[]) - \\ metis_tac[]); + \\ metis_tac[] +QED (* syntactic preservation all in one go *) val convs = [flat_exp_conventions_def, full_inst_ok_less_def, @@ -289,15 +341,16 @@ val convs = [flat_exp_conventions_def, full_inst_ok_less_def, wordLangTheory.every_stack_var_def, wordLangTheory.every_var_def, extract_labels_def] -Theorem remove_must_terminate_conventions ` - ∀p c k. +Theorem remove_must_terminate_conventions: + ∀p c k. let comp = remove_must_terminate p in (flat_exp_conventions p ⇒ flat_exp_conventions comp) ∧ (full_inst_ok_less c p ⇒ full_inst_ok_less c comp) ∧ (post_alloc_conventions k p ⇒ post_alloc_conventions k comp) ∧ (every_inst two_reg_inst p ⇒ every_inst two_reg_inst comp) ∧ - (extract_labels p = extract_labels comp)` - (ho_match_mp_tac remove_must_terminate_ind>>rw[]>> + (extract_labels p = extract_labels comp) +Proof + ho_match_mp_tac remove_must_terminate_ind>>rw[]>> fs[remove_must_terminate_def]>>fs convs>> TRY (rename1`args = A`>> @@ -307,6 +360,7 @@ Theorem remove_must_terminate_conventions ` PairCases_on`x`>>fs[]>> metis_tac[])>> EVERY_CASE_TAC>>fs[]>> - metis_tac[]) + metis_tac[] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/word_simpProofScript.sml b/compiler/backend/proofs/word_simpProofScript.sml index 22fba0c2aa..ef0183ec1c 100644 --- a/compiler/backend/proofs/word_simpProofScript.sml +++ b/compiler/backend/proofs/word_simpProofScript.sml @@ -16,19 +16,25 @@ val labels_rel_def = Define ` (ALL_DISTINCT old_labs ==> ALL_DISTINCT new_labs) /\ set new_labs SUBSET set old_labs`; -Theorem labels_rel_refl[simp] - `!xs. labels_rel xs xs` - (fs [labels_rel_def]); - -Theorem labels_rel_APPEND - `labels_rel xs xs1 /\ labels_rel ys ys1 ==> - labels_rel (xs++ys) (xs1++ys1)` - (fs [labels_rel_def,ALL_DISTINCT_APPEND,SUBSET_DEF] \\ metis_tac []); - -Theorem PERM_IMP_labels_rel - `PERM xs ys ==> labels_rel ys xs` - (fs [labels_rel_def] \\ rw [] \\ fs [SUBSET_DEF] - \\ metis_tac [ALL_DISTINCT_PERM,MEM_PERM]); +Theorem labels_rel_refl[simp]: + !xs. labels_rel xs xs +Proof + fs [labels_rel_def] +QED + +Theorem labels_rel_APPEND: + labels_rel xs xs1 /\ labels_rel ys ys1 ==> + labels_rel (xs++ys) (xs1++ys1) +Proof + fs [labels_rel_def,ALL_DISTINCT_APPEND,SUBSET_DEF] \\ metis_tac [] +QED + +Theorem PERM_IMP_labels_rel: + PERM xs ys ==> labels_rel ys xs +Proof + fs [labels_rel_def] \\ rw [] \\ fs [SUBSET_DEF] + \\ metis_tac [ALL_DISTINCT_PERM,MEM_PERM] +QED val labels_rel_TRANS = Q.prove( `labels_rel xs ys /\ labels_rel ys zs ==> labels_rel xs zs`, @@ -36,22 +42,29 @@ val labels_rel_TRANS = Q.prove( (** verification of Seq_assoc **) -Theorem evaluate_SmartSeq - `evaluate (SmartSeq p1 p2,s) = evaluate (Seq p1 p2,^s)` - (rw [SmartSeq_def,evaluate_def]); - -Theorem evaluate_Seq_Skip - `!p1 s. evaluate (Seq p1 Skip,s) = evaluate (p1,^s)` - (Induct \\ fs [evaluate_def] \\ rw [] - \\ rpt (pairarg_tac \\ fs [] \\ rw [] \\ fs [])); - -Theorem evaluate_Skip_Seq - `evaluate (Seq Skip p,s) = evaluate (p,^s)` - (fs [evaluate_def]); - -Theorem evaluate_Seq_assoc_lemma - `!p1 p2 s. evaluate (Seq_assoc p1 p2,s) = evaluate (Seq p1 p2,^s)` - (HO_MATCH_MP_TAC Seq_assoc_ind \\ fs [] \\ rw [] +Theorem evaluate_SmartSeq: + evaluate (SmartSeq p1 p2,s) = evaluate (Seq p1 p2,^s) +Proof + rw [SmartSeq_def,evaluate_def] +QED + +Theorem evaluate_Seq_Skip: + !p1 s. evaluate (Seq p1 Skip,s) = evaluate (p1,^s) +Proof + Induct \\ fs [evaluate_def] \\ rw [] + \\ rpt (pairarg_tac \\ fs [] \\ rw [] \\ fs []) +QED + +Theorem evaluate_Skip_Seq: + evaluate (Seq Skip p,s) = evaluate (p,^s) +Proof + fs [evaluate_def] +QED + +Theorem evaluate_Seq_assoc_lemma: + !p1 p2 s. evaluate (Seq_assoc p1 p2,s) = evaluate (Seq p1 p2,^s) +Proof + HO_MATCH_MP_TAC Seq_assoc_ind \\ fs [] \\ rw [] \\ fs [evaluate_SmartSeq,Seq_assoc_def,evaluate_Seq_Skip,evaluate_def] \\ (rpt (pairarg_tac \\ fs [] \\ rw [] \\ fs [])) \\ Cases_on `get_vars args s1` \\ fs [] @@ -60,57 +73,75 @@ Theorem evaluate_Seq_assoc_lemma \\ Cases_on `handler` \\ fs [] \\ fs [add_ret_loc_def] \\ PairCases_on `x'` \\ fs[add_ret_loc_def] - \\ PairCases_on `x''` \\ fs[add_ret_loc_def,push_env_def]) - -Theorem evaluate_Seq_assoc - `!p s. evaluate (Seq_assoc Skip p,s) = evaluate (p,^s)` - (fs [evaluate_Seq_assoc_lemma,evaluate_def]); - -Theorem extract_labels_SmartSeq - `extract_labels (SmartSeq p1 p2) = extract_labels (Seq p1 p2)` - (rw [SmartSeq_def,extract_labels_def]); - -Theorem extract_labels_Seq_assoc_lemma - `!p1 p2. extract_labels (Seq_assoc p1 p2) = - extract_labels p1 ++ extract_labels p2` - (HO_MATCH_MP_TAC Seq_assoc_ind \\ fs [] \\ rw [] + \\ PairCases_on `x''` \\ fs[add_ret_loc_def,push_env_def] +QED + +Theorem evaluate_Seq_assoc: + !p s. evaluate (Seq_assoc Skip p,s) = evaluate (p,^s) +Proof + fs [evaluate_Seq_assoc_lemma,evaluate_def] +QED + +Theorem extract_labels_SmartSeq: + extract_labels (SmartSeq p1 p2) = extract_labels (Seq p1 p2) +Proof + rw [SmartSeq_def,extract_labels_def] +QED + +Theorem extract_labels_Seq_assoc_lemma: + !p1 p2. extract_labels (Seq_assoc p1 p2) = + extract_labels p1 ++ extract_labels p2 +Proof + HO_MATCH_MP_TAC Seq_assoc_ind \\ fs [] \\ rw [] \\ fs [Seq_assoc_def,extract_labels_def,extract_labels_SmartSeq] \\ Cases_on `ret_prog` \\ Cases_on `handler` \\ fs [] \\ PairCases_on `x` \\ fs [] - \\ PairCases_on `x'` \\ fs []); + \\ PairCases_on `x'` \\ fs [] +QED -Theorem extract_labels_Seq_assoc - `extract_labels (Seq_assoc Skip p) = extract_labels p` - (fs [extract_labels_Seq_assoc_lemma,extract_labels_def]); +Theorem extract_labels_Seq_assoc: + extract_labels (Seq_assoc Skip p) = extract_labels p +Proof + fs [extract_labels_Seq_assoc_lemma,extract_labels_def] +QED (** verification of simp_if **) -Theorem dest_If_Eq_Imm_thm - `dest_If_Eq_Imm x2 = SOME (n,w,p1,p2) <=> - x2 = If Equal n (Imm w) p1 p2` - (Cases_on `x2` \\ fs [dest_If_Eq_Imm_def,dest_If_def] - \\ every_case_tac \\ fs []); - -Theorem dest_If_thm - `dest_If x2 = SOME (g1,g2,g3,g4,g5) <=> x2 = If g1 g2 g3 g4 g5` - (Cases_on `x2` \\ fs [dest_If_def]); - -Theorem dest_Seq_IMP - `dest_Seq p1 = (x1,x2) ==> evaluate (p1,s) = evaluate (Seq x1 x2,^s)` - (Cases_on `p1` \\ fs [SmartSeq_def,dest_Seq_def] - \\ rw [] \\ fs [evaluate_Skip_Seq]); - -Theorem dest_Seq_Assign_Const_IMP - `dest_Seq_Assign_Const v p = SOME (q,w) ==> - evaluate (p,s) = evaluate (Seq q (Assign v (Const w)),^s)` - (fs [dest_Seq_Assign_Const_def] \\ pairarg_tac \\ fs [] +Theorem dest_If_Eq_Imm_thm: + dest_If_Eq_Imm x2 = SOME (n,w,p1,p2) <=> + x2 = If Equal n (Imm w) p1 p2 +Proof + Cases_on `x2` \\ fs [dest_If_Eq_Imm_def,dest_If_def] + \\ every_case_tac \\ fs [] +QED + +Theorem dest_If_thm: + dest_If x2 = SOME (g1,g2,g3,g4,g5) <=> x2 = If g1 g2 g3 g4 g5 +Proof + Cases_on `x2` \\ fs [dest_If_def] +QED + +Theorem dest_Seq_IMP: + dest_Seq p1 = (x1,x2) ==> evaluate (p1,s) = evaluate (Seq x1 x2,^s) +Proof + Cases_on `p1` \\ fs [SmartSeq_def,dest_Seq_def] + \\ rw [] \\ fs [evaluate_Skip_Seq] +QED + +Theorem dest_Seq_Assign_Const_IMP: + dest_Seq_Assign_Const v p = SOME (q,w) ==> + evaluate (p,s) = evaluate (Seq q (Assign v (Const w)),^s) +Proof + fs [dest_Seq_Assign_Const_def] \\ pairarg_tac \\ fs [] \\ Cases_on `p2` \\ fs [] \\ Cases_on `e` \\ fs [] - \\ rw [] \\ imp_res_tac dest_Seq_IMP \\ fs []); - -Theorem evaluate_apply_if_opt - `apply_if_opt p1 p2 = SOME x ==> - evaluate (Seq p1 p2,s) = evaluate (x,^s)` - (fs [apply_if_opt_def] + \\ rw [] \\ imp_res_tac dest_Seq_IMP \\ fs [] +QED + +Theorem evaluate_apply_if_opt: + apply_if_opt p1 p2 = SOME x ==> + evaluate (Seq p1 p2,s) = evaluate (x,^s) +Proof + fs [apply_if_opt_def] \\ pairarg_tac \\ fs [] \\ every_case_tac \\ fs [] \\ fs [dest_If_Eq_Imm_thm] \\ strip_tac \\ rveq @@ -133,11 +164,13 @@ Theorem evaluate_apply_if_opt \\ pairarg_tac \\ fs [] \\ rveq \\ fs [] \\ IF_CASES_TAC \\ fs [] \\ pairarg_tac \\ fs [] \\ fs [] \\ Cases_on `res' = NONE` \\ fs [word_exp_def] \\ rveq - \\ fs [get_var_def,set_var_def,asmTheory.word_cmp_def]); + \\ fs [get_var_def,set_var_def,asmTheory.word_cmp_def] +QED -Theorem evaluate_simp_if - `!p s. evaluate (simp_if p,s) = evaluate (p,^s)` - (HO_MATCH_MP_TAC simp_if_ind \\ fs [simp_if_def,evaluate_def] \\ rw [] +Theorem evaluate_simp_if: + !p s. evaluate (simp_if p,s) = evaluate (p,^s) +Proof + HO_MATCH_MP_TAC simp_if_ind \\ fs [simp_if_def,evaluate_def] \\ rw [] THEN1 (CASE_TAC \\ fs [evaluate_def] \\ imp_res_tac evaluate_apply_if_opt \\ fs [] @@ -147,33 +180,40 @@ Theorem evaluate_simp_if \\ Cases_on `ret_prog` \\ fs [] \\ Cases_on `handler` \\ fs [] \\ fs [add_ret_loc_def] \\ PairCases_on `x'` \\ fs[add_ret_loc_def,push_env_def] - \\ TRY (PairCases_on `x''`) \\ fs[add_ret_loc_def,push_env_def]); + \\ TRY (PairCases_on `x''`) \\ fs[add_ret_loc_def,push_env_def] +QED (* -Theorem simp_if_works - `IS_SOME (apply_if_opt +Theorem simp_if_works: + IS_SOME (apply_if_opt (If Less 5 (Imm 5w) (Assign 3 (Const 5w)) (Assign 3 (Const (4w:word32)))) - (If Equal 3 (Imm (4w:word32)) (Raise 1) (Raise 2)))` - (EVAL_TAC); *) - -Theorem extract_labels_apply_if_opt - `apply_if_opt p1 p2 = SOME p ==> - PERM (extract_labels p) (extract_labels p1 ++ extract_labels p2)` - (fs [apply_if_opt_def] + (If Equal 3 (Imm (4w:word32)) (Raise 1) (Raise 2))) +Proof + EVAL_TAC +QED *) + +Theorem extract_labels_apply_if_opt: + apply_if_opt p1 p2 = SOME p ==> + PERM (extract_labels p) (extract_labels p1 ++ extract_labels p2) +Proof + fs [apply_if_opt_def] \\ every_case_tac \\ fs [] \\ pairarg_tac \\ fs [] \\ every_case_tac \\ fs [] \\ rw [] \\ fs [dest_If_thm,dest_If_Eq_Imm_thm] \\ rveq \\ fs [extract_labels_def,extract_labels_SmartSeq] \\ Cases_on `p1` \\ fs [dest_Seq_def] \\ rveq \\ fs [extract_labels_def] - \\ metis_tac[PERM_APPEND,APPEND_ASSOC,PERM_APPEND_IFF]) + \\ metis_tac[PERM_APPEND,APPEND_ASSOC,PERM_APPEND_IFF] +QED -Theorem extract_labels_simp_if - `!p. PERM (extract_labels (simp_if p)) (extract_labels p)` - (HO_MATCH_MP_TAC simp_if_ind \\ fs [simp_if_def] \\ rw [] +Theorem extract_labels_simp_if: + !p. PERM (extract_labels (simp_if p)) (extract_labels p) +Proof + HO_MATCH_MP_TAC simp_if_ind \\ fs [simp_if_def] \\ rw [] \\ fs [extract_labels_def] \\ every_case_tac \\ fs [extract_labels_def] \\ imp_res_tac extract_labels_apply_if_opt - \\ metis_tac[PERM_APPEND,PERM_TRANS,PERM_APPEND_IFF]) + \\ metis_tac[PERM_APPEND,PERM_TRANS,PERM_APPEND_IFF] +QED (** verification of const_fp **) @@ -191,32 +231,41 @@ val sf_gc_consts_def = Define ` sf_gc_consts (StackFrame sv h) (StackFrame sw h') = (EVERY2 (\(ak, av) (bk, bv). (ak = bk) /\ (is_gc_word_const av ==> bv = av)) sv sw /\ h = h')`; -Theorem sf_gc_consts_refl - `!x. sf_gc_consts x x` - (Cases_on `x` \\ rw [sf_gc_consts_def] \\ irule EVERY2_refl \\ Cases_on `x` \\ rw []); - -Theorem sf_gc_consts_trans - `!a b c. sf_gc_consts a b /\ sf_gc_consts b c ==> - sf_gc_consts a c` - (Cases_on `a` \\ Cases_on `b` \\ Cases_on `c` \\ rw [sf_gc_consts_def] \\ +Theorem sf_gc_consts_refl: + !x. sf_gc_consts x x +Proof + Cases_on `x` \\ rw [sf_gc_consts_def] \\ irule EVERY2_refl \\ Cases_on `x` \\ rw [] +QED + +Theorem sf_gc_consts_trans: + !a b c. sf_gc_consts a b /\ sf_gc_consts b c ==> + sf_gc_consts a c +Proof + Cases_on `a` \\ Cases_on `b` \\ Cases_on `c` \\ rw [sf_gc_consts_def] \\ irule EVERY2_trans \\ conj_tac >- (Cases_on `x` \\ Cases_on `y` \\ Cases_on `z` \\ fs []) - >- (asm_exists_tac \\ rw [])); + >- (asm_exists_tac \\ rw []) +QED (* Assign *) -Theorem strip_const_thm - `!xs x s. strip_const xs = SOME x ==> MAP (\a. word_exp s a) xs = MAP (SOME o Word) x` - (Induct \\ TRY (Cases_on `h`) \\ fs [strip_const_def, word_exp_def] \\ CASE_TAC \\ fs []); - -Theorem the_words_thm - `!x. the_words (MAP (SOME o Word) x) = SOME x` - (Induct \\ rw [the_words_def]); - -Theorem const_fp_exp_word_exp - `!e cs s. (!v w. lookup v cs = SOME w ==> get_var v s = SOME (Word w)) ==> - word_exp s (const_fp_exp e cs) = word_exp s e` - (ho_match_mp_tac const_fp_exp_ind \\ rw [const_fp_exp_def] +Theorem strip_const_thm: + !xs x s. strip_const xs = SOME x ==> MAP (\a. word_exp s a) xs = MAP (SOME o Word) x +Proof + Induct \\ TRY (Cases_on `h`) \\ fs [strip_const_def, word_exp_def] \\ CASE_TAC \\ fs [] +QED + +Theorem the_words_thm: + !x. the_words (MAP (SOME o Word) x) = SOME x +Proof + Induct \\ rw [the_words_def] +QED + +Theorem const_fp_exp_word_exp: + !e cs s. (!v w. lookup v cs = SOME w ==> get_var v s = SOME (Word w)) ==> + word_exp s (const_fp_exp e cs) = word_exp s e +Proof + ho_match_mp_tac const_fp_exp_ind \\ rw [const_fp_exp_def] >- (CASE_TAC \\ rw [word_exp_def] \\ fs [get_var_def]) >- @@ -228,13 +277,15 @@ Theorem const_fp_exp_word_exp rw [MAP_MAP_o, o_DEF, word_exp_def, SIMP_RULE std_ss [o_DEF] the_words_thm]) >- (CASE_TAC \\ CASE_TAC \\ rw [word_exp_def] \\ every_case_tac \\ - res_tac \\ qpat_x_assum `_ = word_exp s e` (assume_tac o GSYM) \\ fs [word_exp_def])); + res_tac \\ qpat_x_assum `_ = word_exp s e` (assume_tac o GSYM) \\ fs [word_exp_def]) +QED -Theorem const_fp_exp_word_exp_const - `!e cs s c. (!v w. lookup v cs = SOME w ==> get_var v s = SOME (Word w)) /\ +Theorem const_fp_exp_word_exp_const: + !e cs s c. (!v w. lookup v cs = SOME w ==> get_var v s = SOME (Word w)) /\ const_fp_exp e cs = Const c ==> - word_exp s e = SOME (Word c)` - (ho_match_mp_tac const_fp_exp_ind \\ rw [const_fp_exp_def] + word_exp s e = SOME (Word c) +Proof + ho_match_mp_tac const_fp_exp_ind \\ rw [const_fp_exp_def] >- (* Var *) (every_case_tac \\ rw [word_exp_def] \\ fs [get_var_def]) @@ -253,45 +304,53 @@ Theorem const_fp_exp_word_exp_const qpat_x_assum `!c. _` (qspec_then `c'` assume_tac) \\ fs []) >- (* Others *) - (rw [word_exp_def])); + (rw [word_exp_def]) +QED (* Move *) -Theorem set_vars_move_NONE - `!moves x s s' v. +Theorem set_vars_move_NONE: + !moves x s s' v. set_vars (MAP FST moves) x s = s' /\ ALOOKUP moves v = NONE ==> - get_var v s' = get_var v s` - (Induct \\ Induct_on `x` \\ fs [set_vars_def, get_var_def, alist_insert_def] \\ rw [] \\ + get_var v s' = get_var v s +Proof + Induct \\ Induct_on `x` \\ fs [set_vars_def, get_var_def, alist_insert_def] \\ rw [] \\ Cases_on `h'` \\ rw [] \\ Cases_on `q = v`\\ fs [] \\ - rw [lookup_insert] \\ first_assum match_mp_tac \\ fs []); + rw [lookup_insert] \\ first_assum match_mp_tac \\ fs [] +QED -Theorem set_vars_move_SOME - `!moves x v w s s'. +Theorem set_vars_move_SOME: + !moves x v w s s'. set_vars (MAP FST moves) x s = s' /\ get_vars (MAP SND moves) s = SOME x /\ ALOOKUP moves v = SOME w ==> - get_var v s' = get_var w s` - (Induct \\ rw [] \\ Cases_on `h` \\ + get_var v s' = get_var w s +Proof + Induct \\ rw [] \\ Cases_on `h` \\ fs [get_var_def, get_vars_def, set_vars_def] \\ - every_case_tac \\ fs [] \\ rw [alist_insert_def, lookup_insert]); + every_case_tac \\ fs [] \\ rw [alist_insert_def, lookup_insert] +QED -Theorem get_var_move_thm - `!s s' moves x v. +Theorem get_var_move_thm: + !s s' moves x v. get_vars (MAP SND moves) s = SOME x /\ set_vars (MAP FST moves) x s = s' ==> get_var v s' = case ALOOKUP moves v of | SOME w => get_var w s - | NONE => get_var v s` - (rw [] \\ CASE_TAC \\ metis_tac [set_vars_move_SOME, set_vars_move_NONE]); + | NONE => get_var v s +Proof + rw [] \\ CASE_TAC \\ metis_tac [set_vars_move_SOME, set_vars_move_NONE] +QED -Theorem lookup_const_fp_move_cs_NONE - `!moves v cs cs'. +Theorem lookup_const_fp_move_cs_NONE: + !moves v cs cs'. ALOOKUP moves v = NONE /\ lookup v cs = lookup v cs' ==> - lookup v (const_fp_move_cs moves cs cs') = lookup v cs'` - (Induct \\ rw [const_fp_move_cs_def] \\ fs [] \\ + lookup v (const_fp_move_cs moves cs cs') = lookup v cs' +Proof + Induct \\ rw [const_fp_move_cs_def] \\ fs [] \\ qsuff_tac `ALOOKUP moves v = NONE` >- (Cases_on `h` \\ rw [] \\ `q <> v` by (fs [ALOOKUP_def]) \\ every_case_tac \\ rw [] @@ -301,23 +360,27 @@ Theorem lookup_const_fp_move_cs_NONE (qsuff_tac `lookup v cs = lookup v (insert q x cs')` \\ rw [lookup_insert])) >- - (Cases_on `h` \\ fs [] \\ Cases_on `q = v` \\ fs [])); + (Cases_on `h` \\ fs [] \\ Cases_on `q = v` \\ fs []) +QED -Theorem lookup_const_fp_move_cs_SOME_part - `!moves q cs cs' x. +Theorem lookup_const_fp_move_cs_SOME_part: + !moves q cs cs' x. ¬MEM q (MAP FST moves) /\ lookup q cs' = x ==> - lookup q (const_fp_move_cs moves cs cs') = x` - (Induct \\ rw [const_fp_move_cs_def] \\ CASE_TAC \\ rw [lookup_delete, lookup_insert]); + lookup q (const_fp_move_cs moves cs cs') = x +Proof + Induct \\ rw [const_fp_move_cs_def] \\ CASE_TAC \\ rw [lookup_delete, lookup_insert] +QED (* TODO: In need of cleanup *) -Theorem lookup_const_fp_move_cs_SOME - `!moves v w cs cs'. +Theorem lookup_const_fp_move_cs_SOME: + !moves v w cs cs'. ALOOKUP moves v = SOME w /\ ALL_DISTINCT (MAP FST moves) /\ lookup v cs = lookup v cs' ==> - lookup v (const_fp_move_cs moves cs cs') = lookup w cs` - (Induct + lookup v (const_fp_move_cs moves cs cs') = lookup w cs +Proof + Induct >- (rw [ALOOKUP_def]) @@ -336,170 +399,222 @@ Theorem lookup_const_fp_move_cs_SOME >- (`lookup v cs = lookup v (insert q x cs')` by (rw [lookup_insert]) \\ - fs [])))); + fs []))) +QED -Theorem lookup_const_fp_move_cs - `!v moves cs. +Theorem lookup_const_fp_move_cs: + !v moves cs. ALL_DISTINCT (MAP FST moves) ==> lookup v (const_fp_move_cs moves cs cs) = case ALOOKUP moves v of | SOME w => lookup w cs - | NONE => lookup v cs` - (rw [] \\ CASE_TAC \\ metis_tac [lookup_const_fp_move_cs_SOME, - lookup_const_fp_move_cs_NONE]); + | NONE => lookup v cs +Proof + rw [] \\ CASE_TAC \\ metis_tac [lookup_const_fp_move_cs_SOME, + lookup_const_fp_move_cs_NONE] +QED (* If *) -Theorem get_var_imm_cs_imp_get_var_imm - `!x y s cs. (!v w. lookup v cs = SOME w ==> get_var v s = SOME (Word w)) /\ +Theorem get_var_imm_cs_imp_get_var_imm: + !x y s cs. (!v w. lookup v cs = SOME w ==> get_var v s = SOME (Word w)) /\ get_var_imm_cs x cs = SOME y ==> - get_var_imm x s = SOME (Word y)` - (rw [] \\ Cases_on `x` \\ fs [get_var_imm_cs_def, get_var_imm_def]); + get_var_imm x s = SOME (Word y) +Proof + rw [] \\ Cases_on `x` \\ fs [get_var_imm_cs_def, get_var_imm_def] +QED (* Helpful lemmas about locals *) -Theorem get_var_set_var_thm - `!k1 k2 v s. get_var k1 (set_var k2 v s) = - if k1 = k2 then SOME v else get_var k1 s` - (rw [get_var_def, set_var_def, lookup_insert]); - -Theorem get_var_set_store_thm - `!v w x s. get_var v (set_store w x s) = get_var v s` - (rw [get_var_def, set_store_def]); - -Theorem get_var_mem_store_thm - `!v addr x s. mem_store addr x s = SOME s' ==> - get_var v s' = get_var v s` - (rw [mem_store_def] \\ rw [get_var_def]); - -Theorem cs_delete_if_set - `!x v1 v2 s cs w. +Theorem get_var_set_var_thm: + !k1 k2 v s. get_var k1 (set_var k2 v s) = + if k1 = k2 then SOME v else get_var k1 s +Proof + rw [get_var_def, set_var_def, lookup_insert] +QED + +Theorem get_var_set_store_thm: + !v w x s. get_var v (set_store w x s) = get_var v s +Proof + rw [get_var_def, set_store_def] +QED + +Theorem get_var_mem_store_thm: + !v addr x s. mem_store addr x s = SOME s' ==> + get_var v s' = get_var v s +Proof + rw [mem_store_def] \\ rw [get_var_def] +QED + +Theorem cs_delete_if_set: + !x v1 v2 s cs w. (!v w. lookup v cs = SOME w ==> get_var v s = SOME (Word w)) /\ lookup v2 (delete v1 cs) = SOME w ==> - get_var v2 (set_var v1 x s) = SOME (Word w)` - (rw [get_var_set_var_thm] \\ fs [lookup_delete]); + get_var v2 (set_var v1 x s) = SOME (Word w) +Proof + rw [get_var_set_var_thm] \\ fs [lookup_delete] +QED -Theorem cs_delete_if_set_x2 - `!x1 x2 v1 v2 v3 s cs w. +Theorem cs_delete_if_set_x2: + !x1 x2 v1 v2 v3 s cs w. (!v w. lookup v cs = SOME w ==> get_var v s = SOME (Word w)) /\ lookup v3 (delete v2 (delete v1 cs)) = SOME w ==> - get_var v3 (set_var v2 x2 (set_var v1 x1 s)) = SOME (Word w)` - (rw [] \\ irule cs_delete_if_set \\ metis_tac [cs_delete_if_set]); + get_var v3 (set_var v2 x2 (set_var v1 x1 s)) = SOME (Word w) +Proof + rw [] \\ irule cs_delete_if_set \\ metis_tac [cs_delete_if_set] +QED (* Lookup thms *) -Theorem lookup_inter_eq_some - `!m1 m2 k x. lookup k (inter_eq m1 m2) = SOME x ==> - lookup k m1 = SOME x /\ lookup k m2 = SOME x` - (rw [lookup_inter_eq] \\ every_case_tac \\ fs []); - -Theorem lookup_filter_v_SOME - `!t k v f. lookup k (filter_v f t) = SOME v ==> f v` - (rewrite_tac [lookup_filter_v] \\ rpt gen_tac \\ TOP_CASE_TAC \\ rw [] \\ rw []); - -Theorem lookup_filter_v_SOME_imp - `!t k v f. lookup k (filter_v f t) = SOME v ==> - lookup k t = SOME v` - (rewrite_tac [lookup_filter_v] \\ rpt gen_tac \\ TOP_CASE_TAC \\ rw []); +Theorem lookup_inter_eq_some: + !m1 m2 k x. lookup k (inter_eq m1 m2) = SOME x ==> + lookup k m1 = SOME x /\ lookup k m2 = SOME x +Proof + rw [lookup_inter_eq] \\ every_case_tac \\ fs [] +QED + +Theorem lookup_filter_v_SOME: + !t k v f. lookup k (filter_v f t) = SOME v ==> f v +Proof + rewrite_tac [lookup_filter_v] \\ rpt gen_tac \\ TOP_CASE_TAC \\ rw [] \\ rw [] +QED + +Theorem lookup_filter_v_SOME_imp: + !t k v f. lookup k (filter_v f t) = SOME v ==> + lookup k t = SOME v +Proof + rewrite_tac [lookup_filter_v] \\ rpt gen_tac \\ TOP_CASE_TAC \\ rw [] +QED (* LIST_REL/EVERY2 thms *) -Theorem LIST_REL_prefix - `!R l1 l2 l1' l2'. LIST_REL R (l1 ++ l2) (l1' ++ l2') /\ +Theorem LIST_REL_prefix: + !R l1 l2 l1' l2'. LIST_REL R (l1 ++ l2) (l1' ++ l2') /\ LENGTH l1 = LENGTH l1' ==> - LIST_REL R l1 l1'` - (Induct_on `l1` \\ Cases_on `l1'` \\ fs [] \\ rw [] \\ first_assum irule \\ rw [] \\ metis_tac []); + LIST_REL R l1 l1' +Proof + Induct_on `l1` \\ Cases_on `l1'` \\ fs [] \\ rw [] \\ first_assum irule \\ rw [] \\ metis_tac [] +QED -Theorem LIST_REL_append_left - `!l0 l1 l2 R. +Theorem LIST_REL_append_left: + !l0 l1 l2 R. LIST_REL R (l0 ++ l1) l2 ==> LIST_REL R l0 (TAKE (LENGTH l0) l2) /\ - LIST_REL R l1 (DROP (LENGTH l0) l2)` - (rpt gen_tac \\ DISCH_TAC \\ imp_res_tac LIST_REL_LENGTH \\ irule LIST_REL_APPEND_IMP \\ fs []); + LIST_REL R l1 (DROP (LENGTH l0) l2) +Proof + rpt gen_tac \\ DISCH_TAC \\ imp_res_tac LIST_REL_LENGTH \\ irule LIST_REL_APPEND_IMP \\ fs [] +QED (* Stack thms *) -Theorem push_env_set_store_stack - `!x1 x2 x3 x4 s. (push_env x1 x2 (set_store x3 x4 s)).stack = (push_env x1 x2 s).stack` - (Cases_on `x2` \\ TRY (PairCases_on `x`) \\ rw [push_env_def, set_store_def] \\ pairarg_tac \\ fs []); - -Theorem push_env_stack_gc - `!s ls h. (push_env ls h s).gc_fun = s.gc_fun` - (Cases_on `h` \\ TRY (PairCases_on `x`) \\ - rw [push_env_def, env_to_list_def]); - -Theorem pop_env_stack_gc - `!s. pop_env s = SOME s' ==> s'.gc_fun = s.gc_fun` - (rw [pop_env_def] \\ every_case_tac \\ fs [] \\ rw []); - -Theorem ALOOKUP_LIST_REL_sf_gc_consts - `!l1 l2 k v. +Theorem push_env_set_store_stack: + !x1 x2 x3 x4 s. (push_env x1 x2 (set_store x3 x4 s)).stack = (push_env x1 x2 s).stack +Proof + Cases_on `x2` \\ TRY (PairCases_on `x`) \\ rw [push_env_def, set_store_def] \\ pairarg_tac \\ fs [] +QED + +Theorem push_env_stack_gc: + !s ls h. (push_env ls h s).gc_fun = s.gc_fun +Proof + Cases_on `h` \\ TRY (PairCases_on `x`) \\ + rw [push_env_def, env_to_list_def] +QED + +Theorem pop_env_stack_gc: + !s. pop_env s = SOME s' ==> s'.gc_fun = s.gc_fun +Proof + rw [pop_env_def] \\ every_case_tac \\ fs [] \\ rw [] +QED + +Theorem ALOOKUP_LIST_REL_sf_gc_consts: + !l1 l2 k v. LIST_REL (\(ak, av) (bk, bv). ak = bk /\ (is_gc_word_const av ==> bv = av)) l1 l2 /\ is_gc_word_const v /\ ALOOKUP l1 k = SOME v ==> - ALOOKUP l2 k = SOME v` - (Induct_on `l2` + ALOOKUP l2 k = SOME v +Proof + Induct_on `l2` >- (rpt gen_tac \\ rpt strip_tac \\ fs [] \\ rveq \\ fs [ALOOKUP_def]) \\ rw [] \\ Cases_on `h` \\ Cases_on `x` \\ fs [ALOOKUP_def] \\ rveq \\ TOP_CASE_TAC \\ fs [] \\ - first_assum irule \\ rw [] \\ asm_exists_tac \\ rw []); + first_assum irule \\ rw [] \\ asm_exists_tac \\ rw [] +QED -Theorem ALL_DISTINCT_PERM_FST - `!l. ALL_DISTINCT (MAP FST l) /\ PERM l (f l) ==> ALL_DISTINCT (MAP FST (f l))` - (rw [] \\ +Theorem ALL_DISTINCT_PERM_FST: + !l. ALL_DISTINCT (MAP FST l) /\ PERM l (f l) ==> ALL_DISTINCT (MAP FST (f l)) +Proof + rw [] \\ `PERM (MAP FST l) (MAP FST (f l))` by (rw [PERM_MAP]) \\ drule ALL_DISTINCT_PERM \\ - rw []); + rw [] +QED -Theorem ALOOKUP_LIST_REL_value_rel - `!f l' l k v. LIST_REL (\(ak, av) (bk, bv). (ak = bk) /\ (f av ==> bv = av)) l' l /\ +Theorem ALOOKUP_LIST_REL_value_rel: + !f l' l k v. LIST_REL (\(ak, av) (bk, bv). (ak = bk) /\ (f av ==> bv = av)) l' l /\ ALOOKUP l' k = SOME v /\ f v ==> - ALOOKUP l k = SOME v` - (Induct_on `l` \\ Cases_on `l'` \\ rw [] \\ - Cases_on `h'` \\ Cases_on `h` \\ fs [] \\ rw [] \\ fs [] \\ res_tac); - -Theorem ALOOKUP_ALL_DISTINCT_FST_PERM - `!l1 l2. ALL_DISTINCT (MAP FST l1) /\ PERM l1 l2 ==> ALOOKUP l1 = ALOOKUP l2` - (rw [] \\ irule ALOOKUP_ALL_DISTINCT_PERM_same \\ rw [PERM_LIST_TO_SET, PERM_MAP]); - -Theorem ALOOKUP_ALL_DISTINCT_FST_PERM_SOME - `!l1 f k v. ALL_DISTINCT (MAP FST l1) /\ + ALOOKUP l k = SOME v +Proof + Induct_on `l` \\ Cases_on `l'` \\ rw [] \\ + Cases_on `h'` \\ Cases_on `h` \\ fs [] \\ rw [] \\ fs [] \\ res_tac +QED + +Theorem ALOOKUP_ALL_DISTINCT_FST_PERM: + !l1 l2. ALL_DISTINCT (MAP FST l1) /\ PERM l1 l2 ==> ALOOKUP l1 = ALOOKUP l2 +Proof + rw [] \\ irule ALOOKUP_ALL_DISTINCT_PERM_same \\ rw [PERM_LIST_TO_SET, PERM_MAP] +QED + +Theorem ALOOKUP_ALL_DISTINCT_FST_PERM_SOME: + !l1 f k v. ALL_DISTINCT (MAP FST l1) /\ PERM l1 (f l1) /\ ALOOKUP l1 k = SOME v ==> - ALOOKUP (f l1) k = SOME v` - (metis_tac [ALOOKUP_ALL_DISTINCT_FST_PERM]); - -Theorem push_env_gc_fun - `!s x h. (push_env x h s).gc_fun = s.gc_fun` - (Cases_on `h` \\ fs [] \\ TRY (PairCases_on `x`) \\ rw [push_env_def, env_to_list_def]); - -Theorem pop_env_gc_fun - `!s s'. pop_env s = SOME s' ==> s'.gc_fun = s.gc_fun` - (rw [pop_env_def] \\ every_case_tac \\ fs [] \\ rw []); - -Theorem pop_env_gc_fun_const_ok - `!s s'. pop_env s = SOME s' /\ gc_fun_const_ok s.gc_fun ==> - gc_fun_const_ok s'.gc_fun` - (metis_tac [pop_env_gc_fun]); - -(*Theorem call_env_push_env_dec_clock - `!s s'. s' = (call_env x0 (push_env x1 x2 (dec_clock s))) ==> s'.gc_fun = s.gc_fun` - (rw [dec_clock_def, call_env_def] \\ metis_tac [push_env_gc_fun]);*) - -Theorem evaluate_gc_fun_const_ok - `!p s res s'. evaluate (p, s) = (res, s') /\ gc_fun_const_ok s.gc_fun ==> - gc_fun_const_ok s'.gc_fun` - (metis_tac[evaluate_consts]); + ALOOKUP (f l1) k = SOME v +Proof + metis_tac [ALOOKUP_ALL_DISTINCT_FST_PERM] +QED + +Theorem push_env_gc_fun: + !s x h. (push_env x h s).gc_fun = s.gc_fun +Proof + Cases_on `h` \\ fs [] \\ TRY (PairCases_on `x`) \\ rw [push_env_def, env_to_list_def] +QED + +Theorem pop_env_gc_fun: + !s s'. pop_env s = SOME s' ==> s'.gc_fun = s.gc_fun +Proof + rw [pop_env_def] \\ every_case_tac \\ fs [] \\ rw [] +QED + +Theorem pop_env_gc_fun_const_ok: + !s s'. pop_env s = SOME s' /\ gc_fun_const_ok s.gc_fun ==> + gc_fun_const_ok s'.gc_fun +Proof + metis_tac [pop_env_gc_fun] +QED + +(*Theorem call_env_push_env_dec_clock: + !s s'. s' = (call_env x0 (push_env x1 x2 (dec_clock s))) ==> s'.gc_fun = s.gc_fun +Proof + rw [dec_clock_def, call_env_def] \\ metis_tac [push_env_gc_fun] +QED*) + +Theorem evaluate_gc_fun_const_ok: + !p s res s'. evaluate (p, s) = (res, s') /\ gc_fun_const_ok s.gc_fun ==> + gc_fun_const_ok s'.gc_fun +Proof + metis_tac[evaluate_consts] +QED val get_above_handler_def = Define ` get_above_handler s = case EL (LENGTH s.stack - (s.handler + 1)) s.stack of | StackFrame _ (SOME (h,_,_)) => h`; -Theorem enc_stack_dec_stack_is_gc_word_const - `!s s' s'l. +Theorem enc_stack_dec_stack_is_gc_word_const: + !s s' s'l. LIST_REL (\a b. is_gc_word_const a ==> b = a) (enc_stack s) s'l /\ dec_stack s'l s = SOME s' ==> - LIST_REL sf_gc_consts s s'` - (Induct >- (rw [enc_stack_def] \\ fs [dec_stack_def]) \\ + LIST_REL sf_gc_consts s s' +Proof + Induct >- (rw [enc_stack_def] \\ fs [dec_stack_def]) \\ Cases_on `h` \\ rw [enc_stack_def] \\ fs [dec_stack_def] \\ every_case_tac \\ fs [] \\ rw [] >- (rw [sf_gc_consts_def] \\ @@ -525,88 +640,114 @@ Theorem enc_stack_dec_stack_is_gc_word_const rw [MAP_ZIP] \\ imp_res_tac LIST_REL_append_left \\ fs [])) >- (last_assum irule \\ asm_exists_tac \\ rw [] \\ - imp_res_tac LIST_REL_append_left \\ fs [])); + imp_res_tac LIST_REL_append_left \\ fs []) +QED -Theorem gc_fun_sf_gc_consts - `!s s'l s' gc_fun memory memory' mdomain store store'. +Theorem gc_fun_sf_gc_consts: + !s s'l s' gc_fun memory memory' mdomain store store'. gc_fun_const_ok gc_fun /\ gc_fun (enc_stack s, memory, mdomain, store) = SOME (s'l, memory', store') /\ dec_stack s'l s = SOME s' ==> - LIST_REL sf_gc_consts s s'` - (rw [] \\ imp_res_tac gc_fun_const_ok_def \\ fs [] \\ - metis_tac [enc_stack_dec_stack_is_gc_word_const]); - -Theorem gc_sf_gc_consts - `!s s'. gc_fun_const_ok s.gc_fun /\ gc s = SOME s' ==> LIST_REL sf_gc_consts s.stack s'.stack` - (rw [gc_def] \\ every_case_tac \\ fs [] \\ imp_res_tac gc_fun_sf_gc_consts \\ rw []); - -Theorem gc_handler - `!s s'. gc s = SOME s' ==> s'.handler = s.handler` - (rw [gc_def] \\ every_case_tac \\ rw [] \\ rw []); - -Theorem sf_gc_consts_get_above_handler - `!s s'. LIST_REL sf_gc_consts s.stack s'.stack /\ + LIST_REL sf_gc_consts s s' +Proof + rw [] \\ imp_res_tac gc_fun_const_ok_def \\ fs [] \\ + metis_tac [enc_stack_dec_stack_is_gc_word_const] +QED + +Theorem gc_sf_gc_consts: + !s s'. gc_fun_const_ok s.gc_fun /\ gc s = SOME s' ==> LIST_REL sf_gc_consts s.stack s'.stack +Proof + rw [gc_def] \\ every_case_tac \\ fs [] \\ imp_res_tac gc_fun_sf_gc_consts \\ rw [] +QED + +Theorem gc_handler: + !s s'. gc s = SOME s' ==> s'.handler = s.handler +Proof + rw [gc_def] \\ every_case_tac \\ rw [] \\ rw [] +QED + +Theorem sf_gc_consts_get_above_handler: + !s s'. LIST_REL sf_gc_consts s.stack s'.stack /\ s'.handler = s.handler /\ s.handler < LENGTH s.stack ==> - get_above_handler s' = get_above_handler s` - (rw [get_above_handler_def] \\ imp_res_tac EVERY2_LENGTH \\ + get_above_handler s' = get_above_handler s +Proof + rw [get_above_handler_def] \\ imp_res_tac EVERY2_LENGTH \\ `sf_gc_consts (EL (LENGTH s'.stack − (s.handler + 1)) s.stack) (EL (LENGTH s'.stack − (s.handler + 1)) s'.stack)` - by (fs [LIST_REL_EL_EQN]) \\ every_case_tac \\ fs [sf_gc_consts_def]); + by (fs [LIST_REL_EL_EQN]) \\ every_case_tac \\ fs [sf_gc_consts_def] +QED -Theorem LIST_REL_call_Result - `!s s' s'' s''' env handler. +Theorem LIST_REL_call_Result: + !s s' s'' s''' env handler. LIST_REL sf_gc_consts (push_env env handler s).stack s''.stack /\ pop_env s'' = SOME s''' /\ s''.handler = (push_env env handler s).handler ==> - LIST_REL sf_gc_consts s.stack s'''.stack /\ s'''.handler = s.handler` - (rpt gen_tac \\ strip_tac \\ + LIST_REL sf_gc_consts s.stack s'''.stack /\ s'''.handler = s.handler +Proof + rpt gen_tac \\ strip_tac \\ Cases_on `handler` \\ TRY (PairCases_on `x`) \\ fs [push_env_def, pop_env_def] \\ pairarg_tac \\ fs [] \\ - every_case_tac \\ fs [] \\ rw [] \\ rfs [] \\ qpat_x_assum `_ = x` (assume_tac o GSYM) \\ fs [sf_gc_consts_def]); + every_case_tac \\ fs [] \\ rw [] \\ rfs [] \\ qpat_x_assum `_ = x` (assume_tac o GSYM) \\ fs [sf_gc_consts_def] +QED -Theorem get_above_handler_call_env_push_env_dec_clock - `!s s' s'' args env x0 x1 x2 x3. +Theorem get_above_handler_call_env_push_env_dec_clock: + !s s' s'' args env x0 x1 x2 x3. s' = call_env args (push_env env (SOME (x0,x1,x2,x3)) (dec_clock s)) /\ s''.handler = get_above_handler s' ==> - s''.handler = s.handler` - (rw [call_env_def, push_env_def, dec_clock_def] \\ pairarg_tac \\ fs [get_above_handler_def] \\ - `SUC (LENGTH s.stack) − (LENGTH s.stack + 1) = 0` by (rw[]) \\ asm_rewrite_tac [] \\ rw []); - -Theorem call_env_push_env_dec_clock_handler_length - `!s s' args env x0 x1 x2 x3. s' = call_env args (push_env env (SOME (x0,x1,x2,x3)) (dec_clock s)) ==> - s'.handler < LENGTH s'.stack` - (rw [call_env_def, push_env_def, dec_clock_def] \\ pairarg_tac \\ fs []); - -Theorem EVERY2_trans_LASTN_sf_gc_consts - `!l l' l'' n R. n <= LENGTH l /\ LIST_REL sf_gc_consts l l' /\ LIST_REL sf_gc_consts (LASTN n l') l'' ==> - LIST_REL sf_gc_consts (LASTN n l) l''` - (rw [] \\ irule EVERY2_trans \\ conj_tac >- metis_tac [sf_gc_consts_trans] \\ - qexists_tac `LASTN n l'` \\ rw [list_rel_lastn]); - -Theorem LIST_REL_push_env - `!R s s' env h. LIST_REL R (push_env env h s).stack s'.stack ==> LIST_REL R s.stack (TL s'.stack)` - (Cases_on `h` \\ TRY (PairCases_on `x`) \\ rw [push_env_def] \\ pairarg_tac \\ fs []); - -Theorem LASTN_LENGTH_CONS - `!l h. LASTN (LENGTH l) (h::l) = l` - (rw [] \\ `h::l = [h] ++ l` by (rw[]) \\ asm_rewrite_tac [] \\ irule LASTN_LENGTH_APPEND); - -Theorem LASTN_TL_res - `!l n h t. n < LENGTH l /\ LASTN (n + 1) l = (h::t) ==> t = LASTN n l` - (rw [] \\ `n + 1 <= LENGTH l` by (DECIDE_TAC) \\ fs [LASTN_DROP, DROP_EL_CONS]); - -Theorem HD_LASTN - `!l n. 0 < n /\ n <= LENGTH l ==> HD (LASTN n l) = EL (LENGTH l - n) l` - (rw [] \\ imp_res_tac LASTN_DROP \\ ASSUME_TAC (Q.SPEC `0` EL_DROP) \\ fs []); - -Theorem push_env_pop_env_locals_thm - `!^s s' s'':('a,'c,'ffi) wordSem$state s''' env names (handler:(num # 'a prog # num # num) option). + s''.handler = s.handler +Proof + rw [call_env_def, push_env_def, dec_clock_def] \\ pairarg_tac \\ fs [get_above_handler_def] \\ + `SUC (LENGTH s.stack) − (LENGTH s.stack + 1) = 0` by (rw[]) \\ asm_rewrite_tac [] \\ rw [] +QED + +Theorem call_env_push_env_dec_clock_handler_length: + !s s' args env x0 x1 x2 x3. s' = call_env args (push_env env (SOME (x0,x1,x2,x3)) (dec_clock s)) ==> + s'.handler < LENGTH s'.stack +Proof + rw [call_env_def, push_env_def, dec_clock_def] \\ pairarg_tac \\ fs [] +QED + +Theorem EVERY2_trans_LASTN_sf_gc_consts: + !l l' l'' n R. n <= LENGTH l /\ LIST_REL sf_gc_consts l l' /\ LIST_REL sf_gc_consts (LASTN n l') l'' ==> + LIST_REL sf_gc_consts (LASTN n l) l'' +Proof + rw [] \\ irule EVERY2_trans \\ conj_tac >- metis_tac [sf_gc_consts_trans] \\ + qexists_tac `LASTN n l'` \\ rw [list_rel_lastn] +QED + +Theorem LIST_REL_push_env: + !R s s' env h. LIST_REL R (push_env env h s).stack s'.stack ==> LIST_REL R s.stack (TL s'.stack) +Proof + Cases_on `h` \\ TRY (PairCases_on `x`) \\ rw [push_env_def] \\ pairarg_tac \\ fs [] +QED + +Theorem LASTN_LENGTH_CONS: + !l h. LASTN (LENGTH l) (h::l) = l +Proof + rw [] \\ `h::l = [h] ++ l` by (rw[]) \\ asm_rewrite_tac [] \\ irule LASTN_LENGTH_APPEND +QED + +Theorem LASTN_TL_res: + !l n h t. n < LENGTH l /\ LASTN (n + 1) l = (h::t) ==> t = LASTN n l +Proof + rw [] \\ `n + 1 <= LENGTH l` by (DECIDE_TAC) \\ fs [LASTN_DROP, DROP_EL_CONS] +QED + +Theorem HD_LASTN: + !l n. 0 < n /\ n <= LENGTH l ==> HD (LASTN n l) = EL (LENGTH l - n) l +Proof + rw [] \\ imp_res_tac LASTN_DROP \\ ASSUME_TAC (Q.SPEC `0` EL_DROP) \\ fs [] +QED + +Theorem push_env_pop_env_locals_thm: + !^s s' s'':('a,'c,'ffi) wordSem$state s''' env names (handler:(num # 'a prog # num # num) option). cut_env names s.locals = SOME env /\ push_env env handler s = s' /\ LIST_REL sf_gc_consts s'.stack s''.stack /\ pop_env s'' = SOME s''' ==> - (!v w. get_var v s = SOME w /\ is_gc_word_const w /\ lookup v names <> NONE ==> get_var v s''' = SOME w)` - (Cases_on `handler` \\ TRY (PairCases_on `x`) \\ rw [push_env_def, env_to_list_def] \\ + (!v w. get_var v s = SOME w /\ is_gc_word_const w /\ lookup v names <> NONE ==> get_var v s''' = SOME w) +Proof + Cases_on `handler` \\ TRY (PairCases_on `x`) \\ rw [push_env_def, env_to_list_def] \\ fs [LIST_REL_def] \\ Cases_on `y` \\ fs [sf_gc_consts_def, pop_env_def] \\ rfs [] \\ rveq \\ fs [] \\ rw [get_var_def, lookup_fromAList] \\ @@ -618,10 +759,11 @@ Theorem push_env_pop_env_locals_thm >- (irule ALL_DISTINCT_PERM_FST \\ fs [QSORT_PERM]) >- (irule ALOOKUP_ALL_DISTINCT_FST_PERM_SOME \\ fs [ALOOKUP_toAList, QSORT_PERM, ALOOKUP_toAList] \\ fs [cut_env_def, get_var_def] \\ rw [lookup_inter_EQ]) - >- (irule PERM_list_rearrange \\ metis_tac [ALL_DISTINCT_MAP, QSORT_PERM, ALL_DISTINCT_PERM]))); + >- (irule PERM_list_rearrange \\ metis_tac [ALL_DISTINCT_MAP, QSORT_PERM, ALL_DISTINCT_PERM])) +QED -Theorem evaluate_sf_gc_consts - `!p s s' res. +Theorem evaluate_sf_gc_consts: + !p s s' res. evaluate (p, s) = (res, s') /\ gc_fun_const_ok s.gc_fun ==> (case res of | NONE => @@ -634,8 +776,9 @@ Theorem evaluate_sf_gc_consts s.handler < LENGTH s.stack ==> LIST_REL sf_gc_consts (LASTN s.handler s.stack) s'.stack /\ s'.handler = get_above_handler s - | _ => T)` - (recInduct evaluate_ind \\ reverse (rpt conj_tac) + | _ => T) +Proof + recInduct evaluate_ind \\ reverse (rpt conj_tac) >- (** Call **) (rpt gen_tac \\ rpt DISCH_TAC \\ rpt gen_tac \\ DISCH_TAC \\ fs [evaluate_def] \\ @@ -752,21 +895,25 @@ Theorem evaluate_sf_gc_consts (rw [evaluate_def, alloc_def] \\ every_case_tac \\ fs [] \\ imp_res_tac gc_sf_gc_consts \\ fs [push_env_def, set_store_def, pop_env_def] \\ pairarg_tac \\ fs [] \\ res_tac \\ Cases_on `y` \\ fs [sf_gc_consts_def] \\ - rveq \\ fs [] \\ imp_res_tac gc_handler \\ rw [])); + rveq \\ fs [] \\ imp_res_tac gc_handler \\ rw []) +QED -Theorem get_var_set_fp_var[simp] - `get_var x (set_fp_var y v s) = get_var x s` - (fs[get_var_def,set_fp_var_def]); +Theorem get_var_set_fp_var[simp]: + get_var x (set_fp_var y v s) = get_var x s +Proof + fs[get_var_def,set_fp_var_def] +QED -Theorem evaluate_const_fp_loop - `!p cs p' cs' s res s'. +Theorem evaluate_const_fp_loop: + !p cs p' cs' s res s'. evaluate (p, s) = (res, s') /\ const_fp_loop p cs = (p', cs') /\ gc_fun_const_ok s.gc_fun /\ (!v w. lookup v cs = SOME w ==> get_var v s = SOME (Word w)) ==> evaluate (p', s) = (res, s') /\ - (res = NONE ==> (!v w. lookup v cs' = SOME w ==> get_var v s' = SOME (Word w)))` - (ho_match_mp_tac const_fp_loop_ind \\ (rpt conj_tac) + (res = NONE ==> (!v w. lookup v cs' = SOME w ==> get_var v s' = SOME (Word w))) +Proof + ho_match_mp_tac const_fp_loop_ind \\ (rpt conj_tac) >- (** Move **) (fs [const_fp_loop_def, evaluate_def] \\ rw [const_fp_move_cs_def] \\ every_case_tac \\ fs [] \\ @@ -926,18 +1073,22 @@ Theorem evaluate_const_fp_loop \\ (** Remaining: Raise, Return and Tick, buffer writes**) rw[const_fp_loop_def,evaluate_def] \\ fs[case_eq_thms,evaluate_def] \\ - rw[dec_clock_def]); + rw[dec_clock_def] +QED -Theorem evaluate_const_fp - `!p s. gc_fun_const_ok s.gc_fun ==> evaluate (const_fp p, s) = evaluate (p, s)` - (rw [const_fp_def] \\ imp_res_tac evaluate_const_fp_loop \\ +Theorem evaluate_const_fp: + !p s. gc_fun_const_ok s.gc_fun ==> evaluate (const_fp p, s) = evaluate (p, s) +Proof + rw [const_fp_def] \\ imp_res_tac evaluate_const_fp_loop \\ last_assum (qspec_then `LN` assume_tac) \\ fs [lookup_def] \\ Cases_on `const_fp_loop p LN` \\ simp [] \\ res_tac \\ - Cases_on `evaluate (p, s)` \\ res_tac) + Cases_on `evaluate (p, s)` \\ res_tac +QED -Theorem extract_labels_const_fp - `labels_rel (extract_labels p) (extract_labels (const_fp p))` - (fs [const_fp_def] \\ Cases_on `const_fp_loop p LN` +Theorem extract_labels_const_fp: + labels_rel (extract_labels p) (extract_labels (const_fp p)) +Proof + fs [const_fp_def] \\ Cases_on `const_fp_loop p LN` \\ rename1 `const_fp_loop p cs = (p1,cs1)` \\ fs [] \\ pop_assum mp_tac \\ qspec_tac (`cs1`,`cs1`) \\ qspec_tac (`p1`,`p1`) @@ -964,13 +1115,15 @@ Theorem extract_labels_const_fp \\ rpt (pairarg_tac \\ fs []) \\ rw [] \\ fs [extract_labels_def] \\ TRY (match_mp_tac labels_rel_APPEND \\ fs []) - \\ fs [labels_rel_def,ALL_DISTINCT_APPEND,SUBSET_DEF]); + \\ fs [labels_rel_def,ALL_DISTINCT_APPEND,SUBSET_DEF] +QED -Theorem every_inst_inst_ok_less_const_fp - `∀prog. +Theorem every_inst_inst_ok_less_const_fp: + ∀prog. every_inst (inst_ok_less ac) prog ⇒ - every_inst (inst_ok_less ac) (const_fp prog)` - (strip_tac + every_inst (inst_ok_less ac) (const_fp prog) +Proof + strip_tac \\ fs [const_fp_def] \\ Cases_on `const_fp_loop prog LN` \\ rename1 `const_fp_loop p cs = (p1,cs1)` \\ fs [] \\ pop_assum mp_tac @@ -980,23 +1133,28 @@ Theorem every_inst_inst_ok_less_const_fp \\ fs [const_fp_loop_def] \\ rw [] \\ fs [every_inst_def] \\ every_case_tac \\ rw [] \\ fs [every_inst_def] \\ pairarg_tac \\ fs [] \\ rw [] \\ fs [every_inst_def] - \\ pairarg_tac \\ fs [] \\ rw [] \\ fs [every_inst_def]); + \\ pairarg_tac \\ fs [] \\ rw [] \\ fs [every_inst_def] +QED (* putting it all together *) -Theorem compile_exp_thm - `wordSem$evaluate (prog,^s) = (res,s2) /\ res <> SOME Error /\ +Theorem compile_exp_thm: + wordSem$evaluate (prog,^s) = (res,s2) /\ res <> SOME Error /\ gc_fun_const_ok s.gc_fun ==> - evaluate (word_simp$compile_exp prog,s) = (res,s2)` - (fs [word_simpTheory.compile_exp_def,evaluate_simp_if,evaluate_Seq_assoc, - evaluate_const_fp]); - -Theorem extract_labels_compile_exp[simp] - `!p. labels_rel (extract_labels p) - (extract_labels (word_simp$compile_exp p))` - (fs [word_simpTheory.compile_exp_def]>> + evaluate (word_simp$compile_exp prog,s) = (res,s2) +Proof + fs [word_simpTheory.compile_exp_def,evaluate_simp_if,evaluate_Seq_assoc, + evaluate_const_fp] +QED + +Theorem extract_labels_compile_exp[simp]: + !p. labels_rel (extract_labels p) + (extract_labels (word_simp$compile_exp p)) +Proof + fs [word_simpTheory.compile_exp_def]>> metis_tac[extract_labels_simp_if,extract_labels_Seq_assoc,PERM_TRANS, - extract_labels_const_fp,PERM_IMP_labels_rel,labels_rel_TRANS]); + extract_labels_const_fp,PERM_IMP_labels_rel,labels_rel_TRANS] +QED val dest_Seq_no_inst = Q.prove(` ∀prog. @@ -1029,12 +1187,14 @@ val Seq_assoc_no_inst = Q.prove(` fs[every_inst_def]>> every_case_tac>>fs[]) -Theorem compile_exp_no_inst ` - ∀prog. +Theorem compile_exp_no_inst: + ∀prog. every_inst (inst_ok_less ac) prog ⇒ - every_inst (inst_ok_less ac) (compile_exp prog)` - (fs[compile_exp_def]>> + every_inst (inst_ok_less ac) (compile_exp prog) +Proof + fs[compile_exp_def]>> metis_tac[simp_if_no_inst,Seq_assoc_no_inst,every_inst_def, - every_inst_inst_ok_less_const_fp]) + every_inst_inst_ok_less_const_fp] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/word_to_stackProofScript.sml b/compiler/backend/proofs/word_to_stackProofScript.sml index 6b90bd45d2..62d4700774 100644 --- a/compiler/backend/proofs/word_to_stackProofScript.sml +++ b/compiler/backend/proofs/word_to_stackProofScript.sml @@ -24,29 +24,38 @@ val index_list_def = Define ` (index_list [] n = []) /\ (index_list (x::xs) n = (n + LENGTH xs,x) :: index_list xs n)` -Theorem LENGTH_index_list - `!l n. LENGTH (index_list l n) = LENGTH l` - (Induct \\ fs [index_list_def]); - -Theorem EL_index_list - `!xs i. i < LENGTH xs ==> - (EL i (index_list xs k) = (k + LENGTH xs - i - 1, EL i xs))` - (Induct \\ fs [index_list_def] - \\ rpt strip_tac \\ Cases_on `i` \\ fs [] \\ decide_tac); - -Theorem EL_index_list2 - `∀xs i. i < LENGTH xs ==> - (EL i (index_list xs k) = (k + LENGTH xs - (i+1), EL i xs))` - (Induct \\ fs [index_list_def] - \\ rpt strip_tac \\ Cases_on `i` \\ fs [] \\ decide_tac); - -Theorem MAP_SND_index_list - `!xs k. MAP SND (index_list xs k) = xs` - (Induct \\ fs [index_list_def]); - -Theorem MAP_FST_index_list - `∀xs k. MAP FST (index_list xs k) = REVERSE (MAP ($+ k) (COUNT_LIST (LENGTH xs)))` - (Induct \\ simp[index_list_def,COUNT_LIST_def,MAP_MAP_o] +Theorem LENGTH_index_list: + !l n. LENGTH (index_list l n) = LENGTH l +Proof + Induct \\ fs [index_list_def] +QED + +Theorem EL_index_list: + !xs i. i < LENGTH xs ==> + (EL i (index_list xs k) = (k + LENGTH xs - i - 1, EL i xs)) +Proof + Induct \\ fs [index_list_def] + \\ rpt strip_tac \\ Cases_on `i` \\ fs [] \\ decide_tac +QED + +Theorem EL_index_list2: + ∀xs i. i < LENGTH xs ==> + (EL i (index_list xs k) = (k + LENGTH xs - (i+1), EL i xs)) +Proof + Induct \\ fs [index_list_def] + \\ rpt strip_tac \\ Cases_on `i` \\ fs [] \\ decide_tac +QED + +Theorem MAP_SND_index_list: + !xs k. MAP SND (index_list xs k) = xs +Proof + Induct \\ fs [index_list_def] +QED + +Theorem MAP_FST_index_list: + ∀xs k. MAP FST (index_list xs k) = REVERSE (MAP ($+ k) (COUNT_LIST (LENGTH xs))) +Proof + Induct \\ simp[index_list_def,COUNT_LIST_def,MAP_MAP_o] \\ simp[LIST_EQ_REWRITE] \\ rw[] \\ Cases_on`x < LENGTH xs` >- ( @@ -65,42 +74,52 @@ Theorem MAP_FST_index_list \\ Cases_on`LENGTH xs` \\ simp[] \\ simp[EL_REVERSE,LENGTH_COUNT_LIST] - \\ simp[COUNT_LIST_def]); + \\ simp[COUNT_LIST_def] +QED -Theorem index_list_eq_ZIP - `index_list xs k = ZIP(REVERSE(MAP($+ k)(COUNT_LIST (LENGTH xs))),xs)` - (metis_tac[MAP_FST_index_list,MAP_SND_index_list,ZIP_MAP_FST_SND_EQ]); +Theorem index_list_eq_ZIP: + index_list xs k = ZIP(REVERSE(MAP($+ k)(COUNT_LIST (LENGTH xs))),xs) +Proof + metis_tac[MAP_FST_index_list,MAP_SND_index_list,ZIP_MAP_FST_SND_EQ] +QED -Theorem IMP_filter_bitmap_EQ_SOME_NIL - `!xs ys zs. +Theorem IMP_filter_bitmap_EQ_SOME_NIL: + !xs ys zs. (LENGTH xs = LENGTH ys) /\ zs = MAP FST (FILTER SND (ZIP (ys, xs))) ==> - (filter_bitmap xs ys = SOME (zs,[]))` - (Induct \\ Cases_on `ys` \\ fs [filter_bitmap_def] - \\ Cases \\ fs [filter_bitmap_def]); - -Theorem filter_bitmap_length - `∀bs ls xs ys. + (filter_bitmap xs ys = SOME (zs,[])) +Proof + Induct \\ Cases_on `ys` \\ fs [filter_bitmap_def] + \\ Cases \\ fs [filter_bitmap_def] +QED + +Theorem filter_bitmap_length: + ∀bs ls xs ys. filter_bitmap bs ls = SOME(xs,ys) ⇒ - LENGTH xs ≤ LENGTH bs` - (ho_match_mp_tac filter_bitmap_ind>>fs[filter_bitmap_def]>>rw[]>> + LENGTH xs ≤ LENGTH bs +Proof + ho_match_mp_tac filter_bitmap_ind>>fs[filter_bitmap_def]>>rw[]>> EVERY_CASE_TAC>>rveq>>fs[]>>res_tac>> - rveq>>fs[]>>DECIDE_TAC) + rveq>>fs[]>>DECIDE_TAC +QED -Theorem filter_bitmap_length_input - `∀xs ys ls. filter_bitmap xs ys = SOME ls ⇒ LENGTH xs ≤ LENGTH ys` - (ho_match_mp_tac filter_bitmap_ind +Theorem filter_bitmap_length_input: + ∀xs ys ls. filter_bitmap xs ys = SOME ls ⇒ LENGTH xs ≤ LENGTH ys +Proof + ho_match_mp_tac filter_bitmap_ind \\ simp[filter_bitmap_def,LENGTH_NIL_SYM] \\ rw[] - \\ every_case_tac \\ fs[]); + \\ every_case_tac \\ fs[] +QED -Theorem filter_bitmap_MAP_IMP - `∀ys xs l. +Theorem filter_bitmap_MAP_IMP: + ∀ys xs l. filter_bitmap ys (MAP SND xs) = SOME (MAP SND l,[]) ∧ filter_bitmap ys (MAP FST xs) = SOME (MAP FST l,[]) ⇒ - filter_bitmap ys xs = SOME (l,[])` - (Induct \\ Cases_on`xs` \\ fs[filter_bitmap_def] + filter_bitmap ys xs = SOME (l,[]) +Proof + Induct \\ Cases_on`xs` \\ fs[filter_bitmap_def] \\ Cases \\ fs[filter_bitmap_def] \\ rpt strip_tac \\ every_case_tac \\ fs[] \\ rw[] \\ Cases_on`l` \\ fs[] @@ -109,54 +128,67 @@ Theorem filter_bitmap_MAP_IMP \\ impl_tac >- metis_tac[] \\ simp[] \\ rw[] - \\ metis_tac[PAIR]); + \\ metis_tac[PAIR] +QED -Theorem filter_bitmap_IMP_MAP_SND - `!ys xs l. +Theorem filter_bitmap_IMP_MAP_SND: + !ys xs l. filter_bitmap ys xs = SOME (l,[]) ==> - filter_bitmap ys (MAP SND xs) = SOME (MAP SND l,[])` - (Induct \\ Cases_on `xs` \\ fs [filter_bitmap_def] + filter_bitmap ys (MAP SND xs) = SOME (MAP SND l,[]) +Proof + Induct \\ Cases_on `xs` \\ fs [filter_bitmap_def] \\ Cases \\ fs [filter_bitmap_def] \\ rpt strip_tac \\ EVERY_CASE_TAC \\ fs [] \\ rw [] - \\ res_tac \\ fs []); + \\ res_tac \\ fs [] +QED -Theorem filter_bitmap_IMP_MAP_FST - `!ys xs l. +Theorem filter_bitmap_IMP_MAP_FST: + !ys xs l. filter_bitmap ys xs = SOME (l,[]) ==> - filter_bitmap ys (MAP FST xs) = SOME (MAP FST l,[])` - (Induct \\ Cases_on `xs` \\ fs [filter_bitmap_def] + filter_bitmap ys (MAP FST xs) = SOME (MAP FST l,[]) +Proof + Induct \\ Cases_on `xs` \\ fs [filter_bitmap_def] \\ Cases \\ fs [filter_bitmap_def] \\ rpt strip_tac \\ EVERY_CASE_TAC \\ fs [] \\ rw [] - \\ res_tac \\ fs []); + \\ res_tac \\ fs [] +QED -Theorem filter_bitmap_TAKE_LENGTH_IMP - `!h5 x4 l. +Theorem filter_bitmap_TAKE_LENGTH_IMP: + !h5 x4 l. filter_bitmap h5 (TAKE (LENGTH h5) x4) = SOME (MAP SND l,[]) ==> - filter_bitmap h5 x4 = SOME (MAP SND l,DROP (LENGTH h5) x4)` - (Induct \\ Cases_on `x4` \\ fs [filter_bitmap_def] + filter_bitmap h5 x4 = SOME (MAP SND l,DROP (LENGTH h5) x4) +Proof + Induct \\ Cases_on `x4` \\ fs [filter_bitmap_def] \\ Cases \\ fs [filter_bitmap_def] \\ rpt strip_tac \\ EVERY_CASE_TAC \\ fs [] \\ rw [] - \\ Cases_on `l` \\ fs [] \\ rw [] \\ res_tac \\ fs []); - -Theorem filter_bitmap_lemma - `filter_bitmap h5 (index_list (TAKE (LENGTH h5) x4) k) = SOME (l,[]) ==> - filter_bitmap h5 x4 = SOME (MAP SND l, DROP (LENGTH h5) x4)` - (rpt strip_tac \\ imp_res_tac filter_bitmap_IMP_MAP_SND - \\ fs [MAP_SND_index_list] \\ imp_res_tac filter_bitmap_TAKE_LENGTH_IMP); - -Theorem filter_bitmap_MEM - `∀b ls ls' x. + \\ Cases_on `l` \\ fs [] \\ rw [] \\ res_tac \\ fs [] +QED + +Theorem filter_bitmap_lemma: + filter_bitmap h5 (index_list (TAKE (LENGTH h5) x4) k) = SOME (l,[]) ==> + filter_bitmap h5 x4 = SOME (MAP SND l, DROP (LENGTH h5) x4) +Proof + rpt strip_tac \\ imp_res_tac filter_bitmap_IMP_MAP_SND + \\ fs [MAP_SND_index_list] \\ imp_res_tac filter_bitmap_TAKE_LENGTH_IMP +QED + +Theorem filter_bitmap_MEM: + ∀b ls ls' x. filter_bitmap b ls = SOME (ls',[]) ∧ - MEM x ls' ⇒ MEM x ls` - (ho_match_mp_tac filter_bitmap_ind>> + MEM x ls' ⇒ MEM x ls +Proof + ho_match_mp_tac filter_bitmap_ind>> rw[filter_bitmap_def]>> EVERY_CASE_TAC>>fs[]>>rveq>> - fs[MEM]) + fs[MEM] +QED -Theorem get_var_set_var[simp] ` - stackSem$get_var k (set_var k v st) = SOME v` - (fs[stackSemTheory.get_var_def,stackSemTheory.set_var_def]>> - fs[FLOOKUP_UPDATE]) +Theorem get_var_set_var[simp]: + stackSem$get_var k (set_var k v st) = SOME v +Proof + fs[stackSemTheory.get_var_def,stackSemTheory.set_var_def]>> + fs[FLOOKUP_UPDATE] +QED val MEM_TAKE = Q.prove( `!xs n x. MEM x (TAKE n xs) ==> MEM x xs`, @@ -166,15 +198,19 @@ val MEM_LASTN_ALT = Q.prove( `!xs n x. MEM x (LASTN n xs) ==> MEM x xs`, fs [LASTN_def] \\ rw [] \\ imp_res_tac MEM_TAKE \\ fs []); -Theorem clock_add_0[simp] - `((t with clock := t.clock + 0) = t:('a,'c,'ffi) stackSem$state) /\ - ((t with clock := t.clock) = t:('a,'c,'ffi) stackSem$state)` - (fs [stackSemTheory.state_component_equality]); +Theorem clock_add_0[simp]: + ((t with clock := t.clock + 0) = t:('a,'c,'ffi) stackSem$state) /\ + ((t with clock := t.clock) = t:('a,'c,'ffi) stackSem$state) +Proof + fs [stackSemTheory.state_component_equality] +QED -Theorem DROP_DROP_EQ - `!n m xs. DROP m (DROP n xs) = DROP (m + n) xs` - (Induct \\ fs [] \\ Cases_on `xs` \\ fs [] - \\ rpt strip_tac \\ rpt (AP_TERM_TAC ORELSE AP_THM_TAC) \\ decide_tac); +Theorem DROP_DROP_EQ: + !n m xs. DROP m (DROP n xs) = DROP (m + n) xs +Proof + Induct \\ fs [] \\ Cases_on `xs` \\ fs [] + \\ rpt strip_tac \\ rpt (AP_TERM_TAC ORELSE AP_THM_TAC) \\ decide_tac +QED val TAKE_TAKE_MIN = Q.prove( `!xs m n. TAKE n (TAKE m xs) = TAKE (MIN m n) xs`, @@ -190,13 +226,15 @@ val DROP_TAKE_NIL = Q.prove( `DROP n (TAKE n xs) = []`, rw[DROP_NIL,LENGTH_TAKE_EQ]); -Theorem TAKE_LUPDATE[simp] - `!xs n x i. TAKE n (LUPDATE x i xs) = LUPDATE x i (TAKE n xs)` - (Induct \\ fs [LUPDATE_def] \\ Cases_on `i` \\ fs [LUPDATE_def] \\ rw [LUPDATE_def] +Theorem TAKE_LUPDATE[simp]: + !xs n x i. TAKE n (LUPDATE x i xs) = LUPDATE x i (TAKE n xs) +Proof + Induct \\ fs [LUPDATE_def] \\ Cases_on `i` \\ fs [LUPDATE_def] \\ rw [LUPDATE_def] >- (Cases_on`n`>>fs[LUPDATE_def]) >> - Cases_on`n'`>>fs[LUPDATE_def]); + Cases_on`n'`>>fs[LUPDATE_def] +QED local val DROP_LUPDATE_lemma1 = Q.prove( @@ -211,13 +249,15 @@ local Induct \\ fs [LUPDATE_def] \\ rw [] \\ Cases_on `m` \\ fs [LUPDATE_def]) in - Theorem DROP_LUPDATE - `!n h m xs. + Theorem DROP_LUPDATE: + !n h m xs. DROP n (LUPDATE h m xs) = - if m < n then DROP n xs else LUPDATE h (m - n) (DROP n xs)` - (rw [DROP_LUPDATE_lemma2] + if m < n then DROP n xs else LUPDATE h (m - n) (DROP n xs) +Proof + rw [DROP_LUPDATE_lemma2] \\ match_mp_tac DROP_LUPDATE_lemma1 - \\ fs [NOT_LESS]) + \\ fs [NOT_LESS] +QED end val MIN_ADD = Q.prove( @@ -228,13 +268,17 @@ val list_LUPDATE_def = Define ` (list_LUPDATE [] n ys = ys) /\ (list_LUPDATE (x::xs) n ys = list_LUPDATE xs (n+1) (LUPDATE x n ys))` -Theorem LENGTH_list_LUPDATE[simp] - `!xs n ys. LENGTH (list_LUPDATE xs n ys) = LENGTH ys` - (Induct \\ fs [list_LUPDATE_def]); +Theorem LENGTH_list_LUPDATE[simp]: + !xs n ys. LENGTH (list_LUPDATE xs n ys) = LENGTH ys +Proof + Induct \\ fs [list_LUPDATE_def] +QED -Theorem TAKE_list_LUPDATE[simp] - `!ys xs n i. TAKE n (list_LUPDATE ys i xs) = list_LUPDATE ys i (TAKE n xs)` - (Induct \\ fs [list_LUPDATE_def]); +Theorem TAKE_list_LUPDATE[simp]: + !ys xs n i. TAKE n (list_LUPDATE ys i xs) = list_LUPDATE ys i (TAKE n xs) +Proof + Induct \\ fs [list_LUPDATE_def] +QED val LLOOKUP_list_LUPDATE_IGNORE = Q.prove( `!xs i n ys. @@ -263,34 +307,42 @@ val DROP_list_LUPDATE_IGNORE = Q.prove( \\ `LENGTH xs + (i+1) <= n /\ i < n` by decide_tac \\ fs [DROP_LUPDATE]); -Theorem list_LUPDATE_NIL[simp] - `!xs i. list_LUPDATE xs i [] = []` - (Induct \\ fs [list_LUPDATE_def,LUPDATE_def]); +Theorem list_LUPDATE_NIL[simp]: + !xs i. list_LUPDATE xs i [] = [] +Proof + Induct \\ fs [list_LUPDATE_def,LUPDATE_def] +QED val LUPDATE_TAKE_LEMMA = Q.prove( `!xs n w. LUPDATE w n xs = TAKE n xs ++ LUPDATE w 0 (DROP n xs)`, Induct \\ Cases_on `n` \\ fs [LUPDATE_def]); -Theorem list_LUPDATE_TAKE_DROP - `!xs (ys:'a list) n. - list_LUPDATE xs n ys = TAKE n ys ++ list_LUPDATE xs 0 (DROP n ys)` - (Induct \\ simp_tac std_ss [Once list_LUPDATE_def] +Theorem list_LUPDATE_TAKE_DROP: + !xs (ys:'a list) n. + list_LUPDATE xs n ys = TAKE n ys ++ list_LUPDATE xs 0 (DROP n ys) +Proof + Induct \\ simp_tac std_ss [Once list_LUPDATE_def] \\ once_rewrite_tac [list_LUPDATE_def] THEN1 fs [] \\ pop_assum (fn th => once_rewrite_tac [th]) \\ fs [DROP_LUPDATE,DROP_DROP_EQ,AC ADD_COMM ADD_ASSOC] \\ simp_tac std_ss [Once LUPDATE_TAKE_LEMMA,TAKE_TAKE_MIN] \\ rpt strip_tac \\ `MIN (n + 1) n = n` by (fs [MIN_DEF] \\ decide_tac) \\ fs [] - \\ AP_TERM_TAC \\ fs [TAKE_DROP_EQ,AC ADD_COMM ADD_ASSOC]); - -Theorem list_LUPDATE_0_CONS[simp] - `!xs x ys y. list_LUPDATE (x::xs) 0 (y::ys) = x :: list_LUPDATE xs 0 ys` - (fs [list_LUPDATE_def,LUPDATE_def] - \\ simp_tac std_ss [Once list_LUPDATE_TAKE_DROP] \\ fs []); - -Theorem list_LUPDATE_APPEND - `!xs ys zs. - LENGTH xs = LENGTH ys ==> (list_LUPDATE xs 0 (ys ++ zs) = xs ++ zs)` - (Induct \\ Cases_on `ys` \\ fs [list_LUPDATE_def]); + \\ AP_TERM_TAC \\ fs [TAKE_DROP_EQ,AC ADD_COMM ADD_ASSOC] +QED + +Theorem list_LUPDATE_0_CONS[simp]: + !xs x ys y. list_LUPDATE (x::xs) 0 (y::ys) = x :: list_LUPDATE xs 0 ys +Proof + fs [list_LUPDATE_def,LUPDATE_def] + \\ simp_tac std_ss [Once list_LUPDATE_TAKE_DROP] \\ fs [] +QED + +Theorem list_LUPDATE_APPEND: + !xs ys zs. + LENGTH xs = LENGTH ys ==> (list_LUPDATE xs 0 (ys ++ zs) = xs ++ zs) +Proof + Induct \\ Cases_on `ys` \\ fs [list_LUPDATE_def] +QED (* move to stackProps? *) @@ -314,11 +366,13 @@ val LENGTH_word_list_lemma = Q.prove( \\ imp_res_tac DIV_ADD_1 \\ fsrw_tac[] [] \\ AP_THM_TAC \\ AP_TERM_TAC \\ decide_tac); -Theorem LENGTH_word_list - `!xs d. LENGTH (word_list xs d) = - if d = 0 then 1 else (LENGTH xs - 1) DIV d + 1` - (rw [] THEN1 (once_rewrite_tac [word_list_def] \\ fs []) - \\ match_mp_tac LENGTH_word_list_lemma \\ decide_tac); +Theorem LENGTH_word_list: + !xs d. LENGTH (word_list xs d) = + if d = 0 then 1 else (LENGTH xs - 1) DIV d + 1 +Proof + rw [] THEN1 (once_rewrite_tac [word_list_def] \\ fs []) + \\ match_mp_tac LENGTH_word_list_lemma \\ decide_tac +QED (* move to wordProps? *) @@ -374,36 +428,42 @@ val abs_stack_def = Define` val abs_stack_ind = theorem"abs_stack_ind"; -Theorem read_bitmap_append_extra - `∀l1 l2 bits. +Theorem read_bitmap_append_extra: + ∀l1 l2 bits. read_bitmap l1 = SOME bits ⇒ - read_bitmap (l1 ++ l2) = SOME bits` - (Induct >> simp[read_bitmap_def] + read_bitmap (l1 ++ l2) = SOME bits +Proof + Induct >> simp[read_bitmap_def] \\ rpt gen_tac \\ IF_CASES_TAC \\ simp[] \\ BasicProvers.CASE_TAC >> simp[] \\ BasicProvers.CASE_TAC >> simp[] - \\ fs[] \\ rfs[]); + \\ fs[] \\ rfs[] +QED -Theorem full_read_bitmap_append - `∀bitmaps w bits more_bitmaps. +Theorem full_read_bitmap_append: + ∀bitmaps w bits more_bitmaps. full_read_bitmap bitmaps w = SOME bits ⇒ - full_read_bitmap (bitmaps ++ more_bitmaps) w = SOME bits` - (recInduct full_read_bitmap_ind + full_read_bitmap (bitmaps ++ more_bitmaps) w = SOME bits +Proof + recInduct full_read_bitmap_ind \\ rw[full_read_bitmap_def] \\ rw[DROP_APPEND] - \\ metis_tac[read_bitmap_append_extra]); + \\ metis_tac[read_bitmap_append_extra] +QED -Theorem abs_stack_bitmaps_prefix - `∀bitmaps frames stack lens more_bitmaps result. +Theorem abs_stack_bitmaps_prefix: + ∀bitmaps frames stack lens more_bitmaps result. abs_stack bitmaps frames stack lens = SOME result ⇒ - abs_stack (bitmaps ++ more_bitmaps) frames stack lens = SOME result` - (recInduct abs_stack_ind + abs_stack (bitmaps ++ more_bitmaps) frames stack lens = SOME result +Proof + recInduct abs_stack_ind \\ rw[abs_stack_def] \\ fs[case_eq_thms] \\ rveq \\ imp_res_tac full_read_bitmap_append - \\ simp[]); + \\ simp[] +QED val MAP_FST_def = Define ` MAP_FST f xs = MAP (\(x,y). (f x, y)) xs` @@ -706,22 +766,25 @@ val APPEND_LEMMA = Q.prove( \\ imp_res_tac LESS_EQ_LENGTH \\ rw [] \\ metis_tac []); -Theorem read_bitmap_write_bitmap - `8 ≤ dimindex (:α) ⇒ +Theorem read_bitmap_write_bitmap: + 8 ≤ dimindex (:α) ⇒ read_bitmap ((write_bitmap names k f'):α word list) = - SOME (GENLIST (λx. MEM x (MAP (λ(r,y). f' - 1 - (r DIV 2 - k)) (toAList names))) f')` - (rw[write_bitmap_def] + SOME (GENLIST (λx. MEM x (MAP (λ(r,y). f' - 1 - (r DIV 2 - k)) (toAList names))) f') +Proof + rw[write_bitmap_def] \\ imp_res_tac read_bitmap_word_list \\ first_x_assum(qspec_then`[]`mp_tac) - \\ simp[]); + \\ simp[] +QED -Theorem read_bitmap_insert_bitmap - `∀bs bs' i. +Theorem read_bitmap_insert_bitmap: + ∀bs bs' i. i < dimword (:α) ∧ IS_SOME (read_bitmap bm) ∧ insert_bitmap bm (bs:α word list) = (bs',i) - ⇒ read_bitmap (DROP (i MOD dimword (:α)) bs') = read_bitmap bm` - (Induct >> simp[insert_bitmap_def] \\ rw[] \\ simp[] + ⇒ read_bitmap (DROP (i MOD dimword (:α)) bs') = read_bitmap bm +Proof + Induct >> simp[insert_bitmap_def] \\ rw[] \\ simp[] >- ( fs[IS_PREFIX_APPEND,IS_SOME_EXISTS] \\ match_mp_tac read_bitmap_append_extra @@ -731,14 +794,17 @@ Theorem read_bitmap_insert_bitmap \\ REWRITE_TAC[GSYM ADD1] \\ REWRITE_TAC[DROP] \\ first_x_assum match_mp_tac - \\ simp[]); + \\ simp[] +QED -Theorem insert_bitmap_length - `∀ls ls' i. insert_bitmap bm ls = (ls',i) ⇒ i ≤ LENGTH ls ∧ LENGTH ls ≤ LENGTH ls'` - (Induct >> simp[insert_bitmap_def] +Theorem insert_bitmap_length: + ∀ls ls' i. insert_bitmap bm ls = (ls',i) ⇒ i ≤ LENGTH ls ∧ LENGTH ls ≤ LENGTH ls' +Proof + Induct >> simp[insert_bitmap_def] \\ rw[] >> simp[] \\ pairarg_tac >> fs[] - \\ rw[] >> simp[]); + \\ rw[] >> simp[] +QED (* @@ -808,19 +874,23 @@ val SORTED_IMP_EQ_LISTS = Q.prove( \\ imp_res_tac SORTED_FST_LESS_IMP \\ rpt strip_tac \\ fs [] \\ fs [])); -Theorem transitive_key_val_compare - `transitive key_val_compare` - (fs[transitive_def,key_val_compare_def,FORALL_PROD,LET_DEF] +Theorem transitive_key_val_compare: + transitive key_val_compare +Proof + fs[transitive_def,key_val_compare_def,FORALL_PROD,LET_DEF] \\ rpt strip_tac \\ EVERY_CASE_TAC \\ TRY decide_tac - \\ imp_res_tac WORD_LESS_EQ_TRANS \\ fs []) + \\ imp_res_tac WORD_LESS_EQ_TRANS \\ fs [] +QED -Theorem total_key_val_compare - `total key_val_compare` - (fs[total_def,key_val_compare_def,FORALL_PROD,LET_DEF] +Theorem total_key_val_compare: + total key_val_compare +Proof + fs[total_def,key_val_compare_def,FORALL_PROD,LET_DEF] \\ rpt strip_tac \\ EVERY_CASE_TAC \\ TRY decide_tac \\ CCONTR_TAC \\ fs [] \\ TRY decide_tac \\ fs [GSYM WORD_NOT_LESS] - \\ wordsLib.WORD_DECIDE_TAC) + \\ wordsLib.WORD_DECIDE_TAC +QED val SORTS_QSORT_key_val_compare = Q.prove( `SORTS QSORT key_val_compare`, @@ -2109,32 +2179,38 @@ val LASTN_HD = Q.prove(` `SUC (LENGTH ls) -x = SUC(LENGTH ls - x)` by DECIDE_TAC>> simp[]) -Theorem insert_bitmap_isPREFIX - `∀bs bs' i. insert_bitmap bm bs = (bs',i) ⇒ bs ≼ bs'` - (Induct +Theorem insert_bitmap_isPREFIX: + ∀bs bs' i. insert_bitmap bm bs = (bs',i) ⇒ bs ≼ bs' +Proof + Induct \\ rw[insert_bitmap_def,LET_THM] \\ fs[IS_PREFIX_APPEND] \\ pairarg_tac \\ fs[] - \\ rveq \\ simp[]); + \\ rveq \\ simp[] +QED -Theorem wLive_isPREFIX - `∀a bs c q bs'. wLive a bs c = (q,bs') ⇒ bs ≼ bs'` - (rw[] +Theorem wLive_isPREFIX: + ∀a bs c q bs'. wLive a bs c = (q,bs') ⇒ bs ≼ bs' +Proof + rw[] \\ PairCases_on`c` \\ fs[wLive_def,LET_THM] \\ Cases_on`c1=0` \\ fs[] \\ pairarg_tac \\ fs[] \\ rw[] - \\ imp_res_tac insert_bitmap_isPREFIX); + \\ imp_res_tac insert_bitmap_isPREFIX +QED -Theorem comp_IMP_isPREFIX - `∀c1 bs r q1 bs'. comp c1 bs r = (q1,bs') ==> bs ≼ bs'` - (ho_match_mp_tac comp_ind +Theorem comp_IMP_isPREFIX: + ∀c1 bs r q1 bs'. comp c1 bs r = (q1,bs') ==> bs ≼ bs' +Proof + ho_match_mp_tac comp_ind \\ rw[comp_def,LET_THM] \\ every_case_tac \\ fs[] \\ rpt (pairarg_tac >> fs[]) \\ rveq - \\ metis_tac[IS_PREFIX_TRANS,wLive_isPREFIX]); + \\ metis_tac[IS_PREFIX_TRANS,wLive_isPREFIX] +QED val compile_prog_isPREFIX = Q.prove( `compile_prog x y k bs = (prog,bs1) ==> bs ≼ bs1`, @@ -2143,59 +2219,70 @@ val compile_prog_isPREFIX = Q.prove( \\ imp_res_tac comp_IMP_isPREFIX \\ imp_res_tac IS_PREFIX_TRANS \\ fs []); -Theorem compile_word_to_stack_isPREFIX - `!code k bs progs1 bs1. - compile_word_to_stack k code bs = (progs1,bs1) ==> bs ≼ bs1` - (Induct \\ fs [compile_word_to_stack_def,FORALL_PROD,LET_THM] \\ rw [] +Theorem compile_word_to_stack_isPREFIX: + !code k bs progs1 bs1. + compile_word_to_stack k code bs = (progs1,bs1) ==> bs ≼ bs1 +Proof + Induct \\ fs [compile_word_to_stack_def,FORALL_PROD,LET_THM] \\ rw [] \\ pairarg_tac \\ fs [] \\ pairarg_tac \\ fs [] \\ rw [] \\ res_tac \\ fs [] \\ imp_res_tac compile_prog_isPREFIX - \\ imp_res_tac IS_PREFIX_TRANS \\ fs []); - -Theorem compile_word_to_stack_bitmaps - `word_to_stack$compile c p = (c2,prog1) ==> - (case c2.bitmaps of [] => F | h::v1 => 4w = h)` - (fs [word_to_stackTheory.compile_def] \\ pairarg_tac \\ fs [] \\ rw [] \\ fs [] + \\ imp_res_tac IS_PREFIX_TRANS \\ fs [] +QED + +Theorem compile_word_to_stack_bitmaps: + word_to_stack$compile c p = (c2,prog1) ==> + (case c2.bitmaps of [] => F | h::v1 => 4w = h) +Proof + fs [word_to_stackTheory.compile_def] \\ pairarg_tac \\ fs [] \\ rw [] \\ fs [] \\ imp_res_tac compile_word_to_stack_isPREFIX - \\ Cases_on `bitmaps` \\ fs []); - -Theorem EVEN_DIV2_INJ - `EVEN x ∧ EVEN y ∧ DIV2 x = DIV2 y ⇒ x = y` - (srw_tac[][EVEN_EXISTS,DIV2_def,MULT_COMM] - \\ fs[MULT_DIV]); - -Theorem wMoveAux_thm - `evaluate (wMoveAux [] kf,s) = (NONE,s) ∧ + \\ Cases_on `bitmaps` \\ fs [] +QED + +Theorem EVEN_DIV2_INJ: + EVEN x ∧ EVEN y ∧ DIV2 x = DIV2 y ⇒ x = y +Proof + srw_tac[][EVEN_EXISTS,DIV2_def,MULT_COMM] + \\ fs[MULT_DIV] +QED + +Theorem wMoveAux_thm: + evaluate (wMoveAux [] kf,s) = (NONE,s) ∧ evaluate (wMoveAux (x::xs) kf,s) = - evaluate (Seq (wMoveSingle x kf) (wMoveAux xs kf), s)` - (rw[wMoveAux_def] >- rw[stackSemTheory.evaluate_def] + evaluate (Seq (wMoveSingle x kf) (wMoveAux xs kf), s) +Proof + rw[wMoveAux_def] >- rw[stackSemTheory.evaluate_def] \\ Cases_on`xs` >> rw[wMoveAux_def] \\ rw[stackSemTheory.evaluate_def] \\ pairarg_tac - \\ rw[]); + \\ rw[] +QED val with_same_locals = save_thm("with_same_locals[simp]", EQT_ELIM(SIMP_CONV(srw_ss())[state_component_equality]``s with locals := s.locals = (s:('a,'b,'c) wordSem$state)``)); -Theorem state_rel_get_var_imp - `state_rel k f f' s t lens ∧ get_var (2 * x) s = SOME v ∧ x < k ⇒ FLOOKUP t.regs x = SOME v` - (simp[state_rel_def] +Theorem state_rel_get_var_imp: + state_rel k f f' s t lens ∧ get_var (2 * x) s = SOME v ∧ x < k ⇒ FLOOKUP t.regs x = SOME v +Proof + simp[state_rel_def] \\ strip_tac \\ fs[wordSemTheory.get_var_def] \\ first_x_assum drule \\ simp[EVEN_MULT] \\ ONCE_REWRITE_TAC[MULT_COMM] \\ simp[MULT_DIV] - \\ rw[]); + \\ rw[] +QED -Theorem state_rel_get_var_imp2 - `state_rel k f f' s t lens ∧ +Theorem state_rel_get_var_imp2: + state_rel k f f' s t lens ∧ get_var (2 * x) s = SOME v ∧ ¬(x < k) ⇒ - (EL (t.stack_space + (f + k - (x + 1))) t.stack = v)` - (simp[state_rel_def] + (EL (t.stack_space + (f + k - (x + 1))) t.stack = v) +Proof + simp[state_rel_def] \\ strip_tac \\ fs[wordSemTheory.get_var_def] \\ first_x_assum drule @@ -2207,21 +2294,25 @@ Theorem state_rel_get_var_imp2 \\ qhdtm_x_assum`EL`mp_tac \\ simp[EL_TAKE] \\ simp[EL_DROP] - \\ simp[ADD_COMM]); - -Theorem state_rel_set_var_k[simp] - `(state_rel k f f' s (set_var (k+1) v t) lens ⇔ state_rel k f f' s t lens) ∧ - (state_rel k f f' s (set_var k v t) lens ⇔ state_rel k f f' s t lens)` - (conj_tac + \\ simp[ADD_COMM] +QED + +Theorem state_rel_set_var_k[simp]: + (state_rel k f f' s (set_var (k+1) v t) lens ⇔ state_rel k f f' s t lens) ∧ + (state_rel k f f' s (set_var k v t) lens ⇔ state_rel k f f' s t lens) +Proof + conj_tac \\ simp[state_rel_def,EQ_IMP_THM,stackSemTheory.set_var_def] \\ ntac 2 strip_tac \\ fs[FLOOKUP_UPDATE] - \\ metis_tac[DECIDE``¬(k + 1n < k) ∧ ¬(k < k)``]); - -Theorem state_rel_set_var - `state_rel k f f' s t lens ∧ x < k ⇒ - state_rel k f f' (set_var (2*x) v s) (set_var x v t) lens` - (simp[state_rel_def,stackSemTheory.set_var_def,wordSemTheory.set_var_def] + \\ metis_tac[DECIDE``¬(k + 1n < k) ∧ ¬(k < k)``] +QED + +Theorem state_rel_set_var: + state_rel k f f' s t lens ∧ x < k ⇒ + state_rel k f f' (set_var (2*x) v s) (set_var x v t) lens +Proof + simp[state_rel_def,stackSemTheory.set_var_def,wordSemTheory.set_var_def] \\ strip_tac \\ fs[lookup_insert,FLOOKUP_UPDATE,wf_insert] \\ CONJ_TAC THEN1 metis_tac[] @@ -2236,13 +2327,15 @@ Theorem state_rel_set_var \\ rveq \\ fs[bitTheory.DIV_MULT_THM2] \\ `EVEN n` by metis_tac[] - \\ fs[EVEN_MOD2]); + \\ fs[EVEN_MOD2] +QED -Theorem state_rel_set_var2 - `state_rel k f f' s t lens ∧ ¬(x < k) ∧ x < f' + k ∧ st = t.stack ∧ sp = t.stack_space ⇒ +Theorem state_rel_set_var2: + state_rel k f f' s t lens ∧ ¬(x < k) ∧ x < f' + k ∧ st = t.stack ∧ sp = t.stack_space ⇒ state_rel k f f' (set_var (2*x) v s) - (t with stack := LUPDATE v (sp + (f + k − (x + 1))) st) lens` - (simp[state_rel_def,stackSemTheory.set_var_def,wordSemTheory.set_var_def] + (t with stack := LUPDATE v (sp + (f + k − (x + 1))) st) lens +Proof + simp[state_rel_def,stackSemTheory.set_var_def,wordSemTheory.set_var_def] \\ strip_tac \\ `0>fs[]>>DECIDE_TAC) @@ -2278,10 +2371,11 @@ Theorem state_rel_set_var2 \\ simp[MULT_DIV] \\ ntac 2 strip_tac \\ rw[] - \\ fsrw_tac[ARITH_ss][]); + \\ fsrw_tac[ARITH_ss][] +QED -Theorem wMoveSingle_thm - `state_rel k f f' s t lens ∧ +Theorem wMoveSingle_thm: + state_rel k f f' s t lens ∧ (case x of NONE => get_var (k+1) t = SOME v | SOME x => get_var (x * 2) s = SOME v ) ∧ (case y of SOME x => x < f' + k | _ => T) @@ -2290,8 +2384,9 @@ Theorem wMoveSingle_thm evaluate (wMoveSingle (format_var k y,format_var k x) (k,f,f'), t) = (NONE,t') ∧ state_rel k f f' (case y of NONE => s | SOME y => set_var (y*2) v s) t' lens ∧ (y = NONE ⇒ get_var (k+1) t' = SOME v) ∧ - (y ≠ NONE ⇒ get_var (k+1) t' = get_var (k+1) t)` - (rw[wMoveSingle_def] + (y ≠ NONE ⇒ get_var (k+1) t' = get_var (k+1) t) +Proof + rw[wMoveSingle_def] \\ Cases_on`y` \\ simp[format_var_def] \\ Cases_on`x` \\ fs[format_var_def] >- ( @@ -2386,27 +2481,32 @@ Theorem wMoveSingle_thm EVAL_TAC \\ rw[] \\ `F` by decide_tac ) \\ match_mp_tac state_rel_set_var2 - \\ simp[]))) + \\ simp[])) +QED -Theorem IS_SOME_get_vars_set_var - `∀ls s. +Theorem IS_SOME_get_vars_set_var: + ∀ls s. IS_SOME (wordSem$get_vars ls s) ⇒ - IS_SOME (get_vars ls (set_var k v s))` - (Induct \\ simp[get_vars_def] + IS_SOME (get_vars ls (set_var k v s)) +Proof + Induct \\ simp[get_vars_def] \\ rw[] \\ every_case_tac \\ fs[IS_SOME_EXISTS,PULL_EXISTS] \\ rpt (pop_assum mp_tac) \\ EVAL_TAC \\ simp[lookup_insert] \\ rw[] - \\ res_tac \\ fs[]); - -Theorem IS_SOME_get_vars_EVERY - `∀xs s. - IS_SOME (wordSem$get_vars xs s) ⇔ EVERY (λx. IS_SOME (get_var x s)) xs` - (Induct \\ simp[get_vars_def,EVERY_MEM] + \\ res_tac \\ fs[] +QED + +Theorem IS_SOME_get_vars_EVERY: + ∀xs s. + IS_SOME (wordSem$get_vars xs s) ⇔ EVERY (λx. IS_SOME (get_var x s)) xs +Proof + Induct \\ simp[get_vars_def,EVERY_MEM] \\ rw[] \\ every_case_tac \\ fs[EVERY_MEM] - \\ metis_tac[IS_SOME_EXISTS,NOT_SOME_NONE,option_CASES]); + \\ metis_tac[IS_SOME_EXISTS,NOT_SOME_NONE,option_CASES] +QED -Theorem evaluate_wMoveAux_seqsem - `∀ms s t r. +Theorem evaluate_wMoveAux_seqsem: + ∀ms s t r. state_rel k f f' s t lens ∧ (∀i v. r (SOME i) = SOME v ⇔ get_var (2*i) s = SOME v) ∧ (∀v. r NONE = SOME v ⇒ get_var (k+1) t = SOME v) ∧ @@ -2426,8 +2526,9 @@ Theorem evaluate_wMoveAux_seqsem (set_vars (MAP ($* 2 o THE) (FILTER IS_SOME (MAP FST (REVERSE ms)))) (MAP THE (MAP (seqsem ms r) (FILTER IS_SOME (MAP FST (REVERSE ms))))) - s) t' lens` - (Induct + s) t' lens +Proof + Induct \\ simp[wMoveAux_thm] >- simp[set_vars_def,alist_insert_def] \\ qx_gen_tac`h` @@ -2556,14 +2657,17 @@ Theorem evaluate_wMoveAux_seqsem \\ BasicProvers.FULL_CASE_TAC \\ fs[] ) \\ qmatch_rename_tac`v = THE (r z)` \\ Cases_on`z` \\ fs[] - \\ res_tac \\ fs[]); - -Theorem evaluate_SeqStackFree - `s.use_stack /\ s.stack_space <= LENGTH s.stack ==> - evaluate (SeqStackFree n p,s) = evaluate (Seq (StackFree n) p,s)` - (RW_TAC std_ss [SeqStackFree_def,stackSemTheory.evaluate_def] + \\ res_tac \\ fs[] +QED + +Theorem evaluate_SeqStackFree: + s.use_stack /\ s.stack_space <= LENGTH s.stack ==> + evaluate (SeqStackFree n p,s) = evaluate (Seq (StackFree n) p,s) +Proof + RW_TAC std_ss [SeqStackFree_def,stackSemTheory.evaluate_def] THEN1 (`F` by decide_tac) - \\ AP_TERM_TAC \\ fs [stackSemTheory.state_component_equality]); + \\ AP_TERM_TAC \\ fs [stackSemTheory.state_component_equality] +QED val get_vars_eq = Q.prove( `∀ls z. @@ -2685,19 +2789,25 @@ val compile_result_NOT_2 = Q.prove( Cases_on `x` \\ fs [compile_result_def] \\ rw [good_dimindex_def] \\ fs [dimword_def]); -Theorem MAP_o_THE_FILTER_IS_SOME - `MAP (f o THE) (FILTER IS_SOME ls) = - MAP (THE o OPTION_MAP f) (FILTER IS_SOME ls)` - (simp[MAP_EQ_f,MEM_FILTER,IS_SOME_EXISTS,PULL_EXISTS]); - -Theorem MAP_OPTION_MAP_FILTER_IS_SOME - `MAP (OPTION_MAP (f:α->α)) (FILTER IS_SOME ls) = - FILTER IS_SOME (MAP (OPTION_MAP f) ls)` - (match_mp_tac MAP_FILTER \\ Cases \\ simp[]); - -Theorem MAP_FILTER_IS_SOME - `MAP f (FILTER IS_SOME ls) = MAP (f o SOME o THE) (FILTER IS_SOME ls)` - (simp[MAP_EQ_f,MEM_FILTER,IS_SOME_EXISTS,PULL_EXISTS]); +Theorem MAP_o_THE_FILTER_IS_SOME: + MAP (f o THE) (FILTER IS_SOME ls) = + MAP (THE o OPTION_MAP f) (FILTER IS_SOME ls) +Proof + simp[MAP_EQ_f,MEM_FILTER,IS_SOME_EXISTS,PULL_EXISTS] +QED + +Theorem MAP_OPTION_MAP_FILTER_IS_SOME: + MAP (OPTION_MAP (f:α->α)) (FILTER IS_SOME ls) = + FILTER IS_SOME (MAP (OPTION_MAP f) ls) +Proof + match_mp_tac MAP_FILTER \\ Cases \\ simp[] +QED + +Theorem MAP_FILTER_IS_SOME: + MAP f (FILTER IS_SOME ls) = MAP (f o SOME o THE) (FILTER IS_SOME ls) +Proof + simp[MAP_EQ_f,MEM_FILTER,IS_SOME_EXISTS,PULL_EXISTS] +QED val TIMES2_DIV2_lemma = Q.prove( `windmill moves ∧ @@ -2730,13 +2840,17 @@ val TIMES2_DIV2_lemma = Q.prove( \\ simp[MEM_MAP,EXISTS_PROD] \\ metis_tac[]); -Theorem PAIR_MAP_SOME_SWAP - `(SOME ## SOME) o (f ## g) = (OPTION_MAP f ## OPTION_MAP g) o (SOME ## SOME)` - (rw[FUN_EQ_THM,FORALL_PROD]); +Theorem PAIR_MAP_SOME_SWAP: + (SOME ## SOME) o (f ## g) = (OPTION_MAP f ## OPTION_MAP g) o (SOME ## SOME) +Proof + rw[FUN_EQ_THM,FORALL_PROD] +QED -Theorem IS_SOME_o_OPTION_MAP - `IS_SOME o OPTION_MAP f = IS_SOME` - (simp[FUN_EQ_THM] \\ Cases \\ simp[]); +Theorem IS_SOME_o_OPTION_MAP: + IS_SOME o OPTION_MAP f = IS_SOME +Proof + simp[FUN_EQ_THM] \\ Cases \\ simp[] +QED val parsem_parmove_DIV2_lemma = Q.prove( `windmill moves ∧ @@ -2788,12 +2902,13 @@ val parsem_parmove_DIV2_lemma = Q.prove( \\ simp[] \\ disch_then kall_tac \\ rveq \\ fs[]); -Theorem ALOOKUP_MAP_any - `∀f k h ls a x. +Theorem ALOOKUP_MAP_any: + ∀f k h ls a x. (INJ k (a INSERT (set (MAP FST ls))) UNIV) ∧ (∀x y. MEM (x,y) ls ⇒ f (x,y) = (k x, h (k x) y)) ∧ k a = x ⇒ - ALOOKUP (MAP f ls) x = OPTION_MAP (h x) (ALOOKUP ls a)` - (ntac 3 gen_tac + ALOOKUP (MAP f ls) x = OPTION_MAP (h x) (ALOOKUP ls a) +Proof + ntac 3 gen_tac \\ Induct \\ simp[] \\ Cases \\ simp[] \\ rw[] @@ -2806,20 +2921,24 @@ Theorem ALOOKUP_MAP_any \\ simp[] \\ qhdtm_x_assum`INJ`mp_tac \\ REWRITE_TAC[INJ_DEF,IN_INSERT,MEM_MAP] - \\ PROVE_TAC[FST,PAIR]); + \\ PROVE_TAC[FST,PAIR] +QED -Theorem wf_alist_insert - `∀xs ys z. wf z ⇒ wf (alist_insert xs ys z)` - (ho_match_mp_tac alist_insert_ind \\ rw[alist_insert_def] \\ fs[wf_insert]); +Theorem wf_alist_insert: + ∀xs ys z. wf z ⇒ wf (alist_insert xs ys z) +Proof + ho_match_mp_tac alist_insert_ind \\ rw[alist_insert_def] \\ fs[wf_insert] +QED -Theorem ALOOKUP_MAP_INJ_FST - `∀ls f x k. +Theorem ALOOKUP_MAP_INJ_FST: + ∀ls f x k. INJ (FST o f) (x INSERT set ls) UNIV ∧ FST (f x) = k ⇒ ALOOKUP (MAP f ls) k = - ALOOKUP (MAP (λx. (x, SND(f x))) ls) x` - (Induct \\ simp[] + ALOOKUP (MAP (λx. (x, SND(f x))) ls) x +Proof + Induct \\ simp[] \\ rpt gen_tac \\ strip_tac \\ Cases_on`f h` \\ simp[] \\ Cases_on`f x` \\ fs[] @@ -2837,15 +2956,18 @@ Theorem ALOOKUP_MAP_INJ_FST \\ simp[] \\ disch_then match_mp_tac \\ qhdtm_x_assum`INJ`mp_tac \\ REWRITE_TAC[INJ_DEF,IN_INSERT,IN_UNIV] - \\ metis_tac[]); - -Theorem ALOOKUP_ID_TABULATE - `ALOOKUP (MAP (λx. (x,x)) ls) x = - if MEM x ls then SOME x else NONE` - (Induct_on`ls`\\simp[]\\rw[]\\fs[]); - -Theorem alist_insert_get_vars - `∀moves s x ls. + \\ metis_tac[] +QED + +Theorem ALOOKUP_ID_TABULATE: + ALOOKUP (MAP (λx. (x,x)) ls) x = + if MEM x ls then SOME x else NONE +Proof + Induct_on`ls`\\simp[]\\rw[]\\fs[] +QED + +Theorem alist_insert_get_vars: + ∀moves s x ls. ALL_DISTINCT (MAP FST moves) ∧ get_vars (MAP SND moves) s = SOME x ∧ ALL_DISTINCT (FILTER IS_SOME ls) ∧ @@ -2856,8 +2978,9 @@ Theorem alist_insert_get_vars alist_insert (MAP THE (FILTER IS_SOME ls)) (MAP (λx. THE (get_var (THE (ALOOKUP moves (THE x))) s)) (FILTER IS_SOME ls)) s.locals = - alist_insert (MAP FST moves) x s.locals` - (Induct \\ simp[wordSemTheory.get_vars_def] + alist_insert (MAP FST moves) x s.locals +Proof + Induct \\ simp[wordSemTheory.get_vars_def] >- ( rw[] \\ `FILTER IS_SOME ls = []` @@ -2931,7 +3054,8 @@ Theorem alist_insert_get_vars >- ( IF_CASES_TAC \\ fs[] \\ fs[get_var_def] ) - \\ IF_CASES_TAC \\ fs[]); + \\ IF_CASES_TAC \\ fs[] +QED val wf_fromList2 = Q.prove(` ∀ls. wf(fromList2 ls)`, @@ -2939,25 +3063,28 @@ val wf_fromList2 = Q.prove(` fs[fromList2_def,FOLDL_SNOC,wf_def]>>rw[]>> pairarg_tac>>fs[wf_insert]) -Theorem wStackLoad_append - `wStackLoad (l1 ++ l2) = wStackLoad l1 o (wStackLoad l2)` - (qid_spec_tac`l2` +Theorem wStackLoad_append: + wStackLoad (l1 ++ l2) = wStackLoad l1 o (wStackLoad l2) +Proof + qid_spec_tac`l2` \\ simp[FUN_EQ_THM] \\ CONV_TAC SWAP_FORALL_CONV \\ qid_spec_tac`l1` \\ ho_match_mp_tac wStackLoad_ind - \\ simp[wStackLoad_def]); + \\ simp[wStackLoad_def] +QED -Theorem wRegWrite1_thm1 - `state_rel k f f' s t lens ∧ +Theorem wRegWrite1_thm1: + state_rel k f f' s t lens ∧ m < f' + k ∧ (∀n. n ≤ k ⇒ evaluate (kont n, t) = (NONE, set_var n v t)) ⇒ ∃t'. evaluate (wRegWrite1 kont (2 * m) (k,f,f'), t) = (NONE, t') ∧ - state_rel k f f' (set_var (2 * m) v s) t' lens` - (rw[wRegWrite1_def,LET_THM,TWOxDIV2] + state_rel k f f' (set_var (2 * m) v s) t' lens +Proof + rw[wRegWrite1_def,LET_THM,TWOxDIV2] >- ( metis_tac[ state_rel_set_var, LESS_OR_EQ] ) \\ rw[stackSemTheory.evaluate_def] >- fs[state_rel_def] @@ -2966,18 +3093,20 @@ Theorem wRegWrite1_thm1 Cases_on`f'`>>fs[]) \\ simp[] \\ match_mp_tac state_rel_set_var2 - \\ simp[]); + \\ simp[] +QED -Theorem wRegWrite1_thm2 - `state_rel k f f' s t lens ∧ +Theorem wRegWrite1_thm2: + state_rel k f f' s t lens ∧ m < f' + k ∧ (∀n. n ≤ k ⇒ evaluate (kont n, t) = (NONE, set_var 0 v' (set_var n v t))) ⇒ ∃t'. evaluate (wRegWrite1 kont (2 * m) (k,f,f'), t) = (NONE, t') ∧ - state_rel k f f' (set_var 0 v' (set_var (2 * m) v s)) t' lens` - (rw[wRegWrite1_def,LET_THM,TWOxDIV2] + state_rel k f f' (set_var 0 v' (set_var (2 * m) v s)) t' lens +Proof + rw[wRegWrite1_def,LET_THM,TWOxDIV2] >- (match_mp_tac (state_rel_set_var |> Q.GEN`x`|>Q.SPEC`0`|>SIMP_RULE std_ss[])>> fs[]>> @@ -2999,18 +3128,20 @@ Theorem wRegWrite1_thm2 match_mp_tac (state_rel_set_var |> Q.GEN`x`|>Q.SPEC`0`|>SIMP_RULE std_ss[])>> fs[] \\ match_mp_tac state_rel_set_var2 - \\ simp[]); + \\ simp[] +QED -Theorem wRegWrite2_thm1 - `state_rel k f f' s t lens ∧ +Theorem wRegWrite2_thm1: + state_rel k f f' s t lens ∧ m < f' + k ∧ (∀n. n ≤ k+1 ⇒ evaluate (kont n, t) = (NONE, set_var n v t)) ⇒ ∃t'. evaluate (wRegWrite2 kont (2 * m) (k,f,f'), t) = (NONE, t') ∧ - state_rel k f f' (set_var (2 * m) v s) t' lens` - (rw[wRegWrite2_def,LET_THM,TWOxDIV2] + state_rel k f f' (set_var (2 * m) v s) t' lens +Proof + rw[wRegWrite2_def,LET_THM,TWOxDIV2] >- ( metis_tac[ state_rel_set_var, LESS_OR_EQ] ) \\ rw[stackSemTheory.evaluate_def] >- fs[state_rel_def] @@ -3019,21 +3150,24 @@ Theorem wRegWrite2_thm1 Cases_on`f'`>>fs[]) \\ simp[] \\ match_mp_tac state_rel_set_var2 - \\ simp[]); + \\ simp[] +QED -Theorem state_rel_mem_store - `state_rel k f f' s t lens ∧ +Theorem state_rel_mem_store: + state_rel k f f' s t lens ∧ mem_store a b s = SOME s' ⇒ ∃t'. mem_store a b t = SOME t' ∧ - state_rel k f f' s' t' lens` - (simp[state_rel_def,stackSemTheory.mem_store_def,wordSemTheory.mem_store_def] - \\ strip_tac \\ rveq \\ simp[] \\ metis_tac[]); + state_rel k f f' s' t' lens +Proof + simp[state_rel_def,stackSemTheory.mem_store_def,wordSemTheory.mem_store_def] + \\ strip_tac \\ rveq \\ simp[] \\ metis_tac[] +QED (* TODO: Delete? -Theorem wRegWrite1_thm2 - `state_rel k f f' s t lens ∧ +Theorem wRegWrite1_thm2: + state_rel k f f' s t lens ∧ m < f' + k ∧ get_var (2 * m) s = SOME w ∧ mem_store a w s = SOME s' ∧ @@ -3042,8 +3176,9 @@ Theorem wRegWrite1_thm2 ⇒ ∃t'. evaluate (wRegWrite1 kont (2 * m) (k,f,f'), t) = (NONE, t') ∧ - state_rel k f f' s' t' lens` - (rw[wRegWrite1_def,LET_THM,TWOxDIV2] \\ fs[] + state_rel k f f' s' t' lens +Proof + rw[wRegWrite1_def,LET_THM,TWOxDIV2] \\ fs[] >- ( drule (GEN_ALL state_rel_get_var_imp) \\ ONCE_REWRITE_TAC[MULT_COMM] @@ -3070,12 +3205,13 @@ Theorem wRegWrite1_thm2 \\ fs[state_rel_def] \\ Cases_on`f = 0`\\fs[] \\ decide_tac ) - \\ fs[]); + \\ fs[] +QED *) (* -Theorem wRegWrite1_thm2 - `state_rel k f f' s t lens ∧ +Theorem wRegWrite1_thm2: + state_rel k f f' s t lens ∧ mem_store a b s = SOME s' ∧ m < f' + k ∧ (∀n. n ≤ k ⇒ @@ -3084,8 +3220,9 @@ Theorem wRegWrite1_thm2 ⇒ ∃t'. evaluate (wRegWrite1 kont (2 * m) (k,f,f'), t) = (NONE, t') ∧ - state_rel k f f' s' t' lens` - (rw[wRegWrite1_def,LET_THM,TWOxDIV2] + state_rel k f f' s' t' lens +Proof + rw[wRegWrite1_def,LET_THM,TWOxDIV2] \\ `s.memory = t.memory ∧ s.mdomain = t.mdomain` by fs[state_rel_def] >- ( first_x_assum(qspec_then`m`mp_tac) @@ -3115,11 +3252,12 @@ Theorem wRegWrite1_thm2 \\ simp[] \\ rveq \\ fs[state_rel_def] - \\ metis_tac[]); + \\ metis_tac[] +QED *) -Theorem wStackLoad_thm1 - `wReg1 (2 * n1) (k,f,f') = (l,n2) ∧ +Theorem wStackLoad_thm1: + wReg1 (2 * n1) (k,f,f') = (l,n2) ∧ get_var (2*n1) (s:('a,'a word list # 'c,'ffi)state) = SOME x ∧ state_rel k f f' s t lens ∧ (n1 < k ⇒ ∃t'. evaluate (kont n1, t) = (NONE, t') ∧ state_rel k f f' s' t' lens) ∧ @@ -3128,18 +3266,20 @@ Theorem wStackLoad_thm1 ⇒ ∃t'. evaluate (wStackLoad l (kont n2),t) = (NONE,t') ∧ - state_rel k f f' s' t' lens` - (simp[wReg1_def,TWOxDIV2] + state_rel k f f' s' t' lens +Proof + simp[wReg1_def,TWOxDIV2] \\ rw[] \\ rw[wStackLoad_def] \\ fs[] \\ rw[stackSemTheory.evaluate_def] \\ fs[state_rel_def,LET_THM,get_var_def]>> res_tac>> fs[TWOxDIV2]>>rfs[]>> Cases_on`f'`>>fs[]>> - DECIDE_TAC); + DECIDE_TAC +QED -Theorem wStackLoad_thm2 - `wReg2 (2 * n1) (k,f,f') = (l,n2) ∧ +Theorem wStackLoad_thm2: + wReg2 (2 * n1) (k,f,f') = (l,n2) ∧ get_var (2*n1) (s:('a,'a word list # 'c,'ffi)state) = SOME x ∧ state_rel k f f' s t lens ∧ (n1 < k ⇒ ∃t'. evaluate (kont n1, t) = (NONE, t') ∧ state_rel k f f' s' t' lens) ∧ @@ -3148,15 +3288,17 @@ Theorem wStackLoad_thm2 ⇒ ∃t'. evaluate (wStackLoad l (kont n2),t) = (NONE,t') ∧ - state_rel k f f' s' t' lens` - (simp[wReg2_def,TWOxDIV2] + state_rel k f f' s' t' lens +Proof + simp[wReg2_def,TWOxDIV2] \\ rw[] \\ rw[wStackLoad_def] \\ fs[] \\ rw[stackSemTheory.evaluate_def] \\ fs[state_rel_def,LET_THM,get_var_def]>> res_tac>> fs[TWOxDIV2]>>rfs[]>> Cases_on`f'`>>fs[]>> - DECIDE_TAC); + DECIDE_TAC +QED val map_var_def = tDefine"map_var"` (map_var f (Var num) = Var (f num)) ∧ @@ -3171,29 +3313,36 @@ val map_var_def = tDefine"map_var"` \\ EVAL_TAC \\ simp[] \\ res_tac \\ simp[]); val _ = export_rewrites["map_var_def"]; -Theorem the_words_EVERY_IS_SOME_Word - `∀ls x. the_words ls = SOME x ⇒ ∀a. MEM a ls ⇒ ∃w. a = SOME (Word w)` - (Induct \\ EVAL_TAC \\ rw[] \\ every_case_tac \\ fs[]); +Theorem the_words_EVERY_IS_SOME_Word: + ∀ls x. the_words ls = SOME x ⇒ ∀a. MEM a ls ⇒ ∃w. a = SOME (Word w) +Proof + Induct \\ EVAL_TAC \\ rw[] \\ every_case_tac \\ fs[] +QED -Theorem the_words_SOME_eq - `∀ls x. the_words ls = SOME x ⇒ x = MAP (λx. case x of SOME (Word y) => y) ls` - (Induct \\ EVAL_TAC \\ rw[] \\ every_case_tac \\ fs[]); +Theorem the_words_SOME_eq: + ∀ls x. the_words ls = SOME x ⇒ x = MAP (λx. case x of SOME (Word y) => y) ls +Proof + Induct \\ EVAL_TAC \\ rw[] \\ every_case_tac \\ fs[] +QED -Theorem the_words_MAP_exists - `∀ls x a f. +Theorem the_words_MAP_exists: + ∀ls x a f. the_words (MAP f ls) = SOME x ∧ MEM a ls ⇒ - ∃w. f a = SOME (Word w)` - (Induct>>EVAL_TAC>>rw[]>> - every_case_tac>>fs[]) - -Theorem word_exp_thm1 - `∀s e x. word_exp s e = SOME (Word x) ∧ + ∃w. f a = SOME (Word w) +Proof + Induct>>EVAL_TAC>>rw[]>> + every_case_tac>>fs[] +QED + +Theorem word_exp_thm1: + ∀s e x. word_exp s e = SOME (Word x) ∧ every_var_exp is_phy_var e ∧ DIV2 (max_var_exp e) < k ∧ state_rel k f f' s t lens ⇒ - word_exp t (map_var DIV2 e) = SOME x` - (ho_match_mp_tac word_exp_ind + word_exp t (map_var DIV2 e) = SOME x +Proof + ho_match_mp_tac word_exp_ind \\ simp[word_exp_def,stackSemTheory.word_exp_def] \\ rw[wordLangTheory.every_var_exp_def,reg_allocTheory.is_phy_var_def,GSYM EVEN_MOD2,EVEN_EXISTS,wordLangTheory.max_var_exp_def] \\ fs[EVERY_MAP,EVERY_MEM] \\ rw[] @@ -3268,15 +3417,17 @@ Theorem word_exp_thm1 \\ fs[DIV2_def] \\ ntac 2 strip_tac \\ first_x_assum drule - \\ simp[]) + \\ simp[] +QED -Theorem word_exp_thm2 - `∀s e x. word_exp s e = SOME (Word x) ∧ +Theorem word_exp_thm2: + ∀s e x. word_exp s e = SOME (Word x) ∧ state_rel k f f' s t lens ∧ every_var_exp ($= (2 * v)) e ∧ ¬(v < k) ⇒ - word_exp (set_var k (EL (t.stack_space + (f + k - (v + 1))) t.stack) t) (map_var (K k) e) = SOME x` - (ho_match_mp_tac word_exp_ind + word_exp (set_var k (EL (t.stack_space + (f + k - (v + 1))) t.stack) t) (map_var (K k) e) = SOME x +Proof + ho_match_mp_tac word_exp_ind \\ simp[word_exp_def,stackSemTheory.word_exp_def] \\ rw[wordLangTheory.every_var_exp_def,reg_allocTheory.is_phy_var_def,GSYM EVEN_MOD2,EVEN_EXISTS,wordLangTheory.max_var_exp_def] \\ fs[EVERY_MAP,EVERY_MEM] \\ rw[] @@ -3309,18 +3460,20 @@ Theorem word_exp_thm2 rw[]>> imp_res_tac the_words_MAP_exists>> fs[]>>res_tac>> - simp[]); + simp[] +QED -Theorem word_exp_thm3 - `∀s e x. word_exp s e = SOME (Word x) ∧ +Theorem word_exp_thm3: + ∀s e x. word_exp s e = SOME (Word x) ∧ state_rel k f f' s t lens ∧ every_var_exp (λx. x = 2*v1 ∨ x = 2*v2) e ∧ v1 < k ∧ ¬(v2 < k) ⇒ word_exp (set_var (k+1) (EL (t.stack_space + (f + k - (v2 + 1))) t.stack) t) - (map_var (λx. if x = 2*v2 then k+1 else DIV2 x) e) = SOME x` - (ho_match_mp_tac word_exp_ind + (map_var (λx. if x = 2*v2 then k+1 else DIV2 x) e) = SOME x +Proof + ho_match_mp_tac word_exp_ind \\ simp[word_exp_def,stackSemTheory.word_exp_def] \\ rw[wordLangTheory.every_var_exp_def,reg_allocTheory.is_phy_var_def,GSYM EVEN_MOD2,EVEN_EXISTS,wordLangTheory.max_var_exp_def] \\ fs[EVERY_MAP,EVERY_MEM] \\ rw[] @@ -3353,18 +3506,20 @@ Theorem word_exp_thm3 rw[]>> imp_res_tac the_words_MAP_exists>> fs[]>>res_tac>> - simp[]); + simp[] +QED -Theorem word_exp_thm4 - `∀s e x. word_exp s e = SOME (Word x) ∧ +Theorem word_exp_thm4: + ∀s e x. word_exp s e = SOME (Word x) ∧ state_rel k f f' s t lens ∧ every_var_exp (λx. x = 2*v1 ∨ x = 2*v2) e ∧ v1 < k ∧ ¬(v2 < k) ⇒ word_exp (set_var k (EL (t.stack_space + (f + k - (v2 + 1))) t.stack) t) - (map_var (λx. if x = 2*v2 then k else DIV2 x) e) = SOME x` - (ho_match_mp_tac word_exp_ind + (map_var (λx. if x = 2*v2 then k else DIV2 x) e) = SOME x +Proof + ho_match_mp_tac word_exp_ind \\ simp[word_exp_def,stackSemTheory.word_exp_def] \\ rw[wordLangTheory.every_var_exp_def,reg_allocTheory.is_phy_var_def,GSYM EVEN_MOD2,EVEN_EXISTS,wordLangTheory.max_var_exp_def] \\ fs[EVERY_MAP,EVERY_MEM] \\ rw[] @@ -3397,10 +3552,11 @@ Theorem word_exp_thm4 rw[]>> imp_res_tac the_words_MAP_exists>> fs[]>>res_tac>> - simp[]) + simp[] +QED -Theorem word_exp_thm5 - `∀s e x. word_exp s e = SOME (Word x) ∧ +Theorem word_exp_thm5: + ∀s e x. word_exp s e = SOME (Word x) ∧ state_rel k f f' s t lens ∧ every_var_exp (λx. x = 2*v1 ∨ x = 2*v2) e ∧ ¬(v1 < k) ∧ ¬(v2 < k) @@ -3408,8 +3564,9 @@ Theorem word_exp_thm5 word_exp (set_var (k+1) (EL (t.stack_space + (f + k - (v2 + 1))) t.stack) (set_var k (EL (t.stack_space + (f + k - (v1 + 1))) t.stack) t)) - (map_var (λx. if x = 2*v1 then k else k+1) e) = SOME x` - (ho_match_mp_tac word_exp_ind + (map_var (λx. if x = 2*v1 then k else k+1) e) = SOME x +Proof + ho_match_mp_tac word_exp_ind \\ simp[word_exp_def,stackSemTheory.word_exp_def] \\ rw[wordLangTheory.every_var_exp_def,reg_allocTheory.is_phy_var_def,GSYM EVEN_MOD2,EVEN_EXISTS,wordLangTheory.max_var_exp_def] \\ fs[EVERY_MAP,EVERY_MEM] \\ rw[] @@ -3442,10 +3599,11 @@ Theorem word_exp_thm5 rw[]>> imp_res_tac the_words_MAP_exists>> fs[]>>res_tac>> - simp[]) + simp[] +QED -Theorem word_exp_thm6 - `∀s e x. word_exp s e = SOME (Word x) ∧ +Theorem word_exp_thm6: + ∀s e x. word_exp s e = SOME (Word x) ∧ state_rel k f f' s t lens ∧ e = Op b [Var (2 * v1); Var (2 * v1)] ∧ ¬(v1 < k) @@ -3453,8 +3611,9 @@ Theorem word_exp_thm6 word_exp (set_var (k+1) (EL (t.stack_space + (f + k - (v1 + 1))) t.stack) (set_var k (EL (t.stack_space + (f + k - (v1 + 1))) t.stack) t)) - (Op b [Var k; Var (k+1)]) = SOME x` - (ho_match_mp_tac word_exp_ind + (Op b [Var k; Var (k+1)]) = SOME x +Proof + ho_match_mp_tac word_exp_ind \\ simp[word_exp_def,stackSemTheory.word_exp_def] \\ rw[wordLangTheory.every_var_exp_def,reg_allocTheory.is_phy_var_def,GSYM EVEN_MOD2,EVEN_EXISTS,wordLangTheory.max_var_exp_def] \\ fs[EVERY_MAP,EVERY_MEM] \\ rw[] @@ -3469,49 +3628,66 @@ Theorem word_exp_thm6 \\ first_x_assum drule \\ simp[TWOxDIV2] \\ simp[LLOOKUP_THM,EL_TAKE,EL_DROP] - \\ simp[ADD_COMM] ); - -Theorem set_var_with_memory - `stackSem$set_var a b c with memory := m = set_var a b (c with memory := m)` - (EVAL_TAC); - -Theorem set_var_memory[simp] - `(stackSem$set_var a b c).memory = c.memory` - (EVAL_TAC) - -Theorem state_rel_with_memory - `state_rel k f f' s t lens ⇒ - state_rel k f f' (s with memory := m) (t with memory := m) lens` - (simp[state_rel_def] + \\ simp[ADD_COMM] +QED + +Theorem set_var_with_memory: + stackSem$set_var a b c with memory := m = set_var a b (c with memory := m) +Proof + EVAL_TAC +QED + +Theorem set_var_memory[simp]: + (stackSem$set_var a b c).memory = c.memory +Proof + EVAL_TAC +QED + +Theorem state_rel_with_memory: + state_rel k f f' s t lens ⇒ + state_rel k f f' (s with memory := m) (t with memory := m) lens +Proof + simp[state_rel_def] \\ strip_tac \\ simp[] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem set_var_swap - `a ≠ a' ⇒ stackSem$set_var a b (set_var a' b' c) = set_var a' b' (set_var a b c)` - (EVAL_TAC \\ simp[stackSemTheory.state_component_equality,fmap_eq_flookup,FLOOKUP_UPDATE] - \\ rw[] \\ rw[]); - -Theorem set_var_cancel - `stackSem$set_var a b (set_var a b c) = set_var a b c` - (EVAL_TAC \\ simp[stackSemTheory.state_component_equality]); +Theorem set_var_swap: + a ≠ a' ⇒ stackSem$set_var a b (set_var a' b' c) = set_var a' b' (set_var a b c) +Proof + EVAL_TAC \\ simp[stackSemTheory.state_component_equality,fmap_eq_flookup,FLOOKUP_UPDATE] + \\ rw[] \\ rw[] +QED -Theorem word_exp_Op_SOME_Word - `word_exp s (Op op wexps) = SOME x ⇒ ∃w. x = Word w` - (rw[word_exp_def] \\ every_case_tac \\ fs[]); +Theorem set_var_cancel: + stackSem$set_var a b (set_var a b c) = set_var a b c +Proof + EVAL_TAC \\ simp[stackSemTheory.state_component_equality] +QED -Theorem state_rel_get_fp_var - `state_rel k f f' s t lens ⇒ - get_fp_var n s = get_fp_var n t` - (fs[state_rel_def,get_fp_var_def,stackSemTheory.get_fp_var_def]); +Theorem word_exp_Op_SOME_Word: + word_exp s (Op op wexps) = SOME x ⇒ ∃w. x = Word w +Proof + rw[word_exp_def] \\ every_case_tac \\ fs[] +QED -Theorem state_rel_set_fp_var - `state_rel k f f' s t lens ⇒ - state_rel k f f' (set_fp_var n v s) (set_fp_var n v t) lens` - (fs[state_rel_def,set_fp_var_def,stackSemTheory.set_fp_var_def]>>rw[]>> - metis_tac[]); +Theorem state_rel_get_fp_var: + state_rel k f f' s t lens ⇒ + get_fp_var n s = get_fp_var n t +Proof + fs[state_rel_def,get_fp_var_def,stackSemTheory.get_fp_var_def] +QED -Theorem evaluate_wInst - `∀i s t s'. +Theorem state_rel_set_fp_var: + state_rel k f f' s t lens ⇒ + state_rel k f f' (set_fp_var n v s) (set_fp_var n v t) lens +Proof + fs[state_rel_def,set_fp_var_def,stackSemTheory.set_fp_var_def]>>rw[]>> + metis_tac[] +QED + +Theorem evaluate_wInst: + ∀i s t s'. inst i s = SOME s' ∧ every_var_inst is_phy_var i ∧ max_var_inst i < 2 * f' + 2 * k ∧ @@ -3520,8 +3696,9 @@ Theorem evaluate_wInst ⇒ ∃t'. evaluate (wInst i (k,f,f'), t) = (NONE,t') ∧ - state_rel k f f' s' t' lens` - (simp[inst_def] + state_rel k f f' s' t' lens +Proof + simp[inst_def] \\ rpt gen_tac \\ BasicProvers.TOP_CASE_TAC \\ simp[wInst_def,stackSemTheory.evaluate_def,stackSemTheory.inst_def] @@ -4184,16 +4361,20 @@ Theorem evaluate_wInst >> every_case_tac>>fs[stackSemTheory.evaluate_def,stackSemTheory.inst_def]>> imp_res_tac state_rel_get_fp_var>> - rw[]>>fs[state_rel_set_fp_var])); - -Theorem set_store_set_var - `stackSem$set_store a b (set_var c d e) = set_var c d (set_store a b e)` - (EVAL_TAC); - -Theorem state_rel_set_store - `state_rel k f f' s t lens ∧ v ≠ Handler ⇒ - state_rel k f f' (set_store v x s) (set_store v x t) lens` - (simp[state_rel_def] + rw[]>>fs[state_rel_set_fp_var]) +QED + +Theorem set_store_set_var: + stackSem$set_store a b (set_var c d e) = set_var c d (set_store a b e) +Proof + EVAL_TAC +QED + +Theorem state_rel_set_store: + state_rel k f f' s t lens ∧ v ≠ Handler ⇒ + state_rel k f f' (set_store v x s) (set_store v x t) lens +Proof + simp[state_rel_def] \\ strip_tac \\ fs[wordSemTheory.set_store_def,stackSemTheory.set_store_def] \\ simp[FLOOKUP_UPDATE] @@ -4202,7 +4383,8 @@ Theorem state_rel_set_store simp[fmap_eq_flookup] \\ simp[FLOOKUP_UPDATE,DOMSUB_FLOOKUP_THM] \\ rw[] ) - \\ metis_tac[]); + \\ metis_tac[] +QED (*For calls*) val get_vars_fromList2_eq = Q.prove(` @@ -4252,41 +4434,51 @@ val lookup_fromList2_prefix = Q.prove(` fs[IS_PREFIX_APPEND]>> fs[EL_APPEND1]) -Theorem list_max_APPEND ` - ∀a b. - list_max (a++b) = MAX (list_max a) (list_max b)` - (Induct>>fs[list_max_def,LET_THM,MAX_DEF]>>rw[]>> - DECIDE_TAC) - -Theorem list_max_SNOC ` - list_max (SNOC x ls) = MAX x (list_max ls)` - (fs[SNOC_APPEND,list_max_APPEND,list_max_def,LET_THM,MAX_DEF]>> - DECIDE_TAC) - -Theorem list_max_GENLIST_evens ` - ∀n. list_max (GENLIST (λx. 2*x) n) = 2*(n-1)` - (Induct>> +Theorem list_max_APPEND: + ∀a b. + list_max (a++b) = MAX (list_max a) (list_max b) +Proof + Induct>>fs[list_max_def,LET_THM,MAX_DEF]>>rw[]>> + DECIDE_TAC +QED + +Theorem list_max_SNOC: + list_max (SNOC x ls) = MAX x (list_max ls) +Proof + fs[SNOC_APPEND,list_max_APPEND,list_max_def,LET_THM,MAX_DEF]>> + DECIDE_TAC +QED + +Theorem list_max_GENLIST_evens: + ∀n. list_max (GENLIST (λx. 2*x) n) = 2*(n-1) +Proof + Induct>> fs[list_max_def]>>rw[]>> fs[GENLIST,list_max_SNOC,MAX_DEF]>> - DECIDE_TAC) + DECIDE_TAC +QED -Theorem list_max_GENLIST_evens2 ` - ∀n. list_max (GENLIST (λx. 2*(x+1)) n) = 2*n` - (Induct>> +Theorem list_max_GENLIST_evens2: + ∀n. list_max (GENLIST (λx. 2*(x+1)) n) = 2*n +Proof + Induct>> fs[list_max_def]>>rw[]>> fs[GENLIST,list_max_SNOC,MAX_DEF]>> - DECIDE_TAC) + DECIDE_TAC +QED -Theorem evaluate_wStackLoad_seq - `∀ls prog s. +Theorem evaluate_wStackLoad_seq: + ∀ls prog s. evaluate(wStackLoad ls prog,s) = - evaluate (Seq (wStackLoad ls Skip) prog,s)` - (Induct>>rw[]>>fs[stackSemTheory.evaluate_def,wStackLoad_def,LET_THM]>>rw[]>> + evaluate (Seq (wStackLoad ls Skip) prog,s) +Proof + Induct>>rw[]>>fs[stackSemTheory.evaluate_def,wStackLoad_def,LET_THM]>>rw[]>> Cases_on`h`>> simp[wStackLoad_def]>> pop_assum (qspec_then`prog` assume_tac)>> simp[stackSemTheory.evaluate_def]>> - EVERY_CASE_TAC>>fs[]); + EVERY_CASE_TAC>>fs[] +QED val evaluate_wStackLoad_wReg1 = Q.prove(` wReg1 r (k,f,f') = (x ,r') ∧ @@ -4639,23 +4831,29 @@ val state_rel_code_domain = Q.prove(` strip_tac>>fs[state_rel_def,SUBSET_DEF,domain_lookup,EXISTS_PROD]>> metis_tac[]); -Theorem get_labels_wStackLoad - `!xs p. get_labels (wStackLoad xs p) = get_labels p` - (Induct \\ fs [wStackLoad_def] - \\ Cases \\ fs [wStackLoad_def,get_labels_def]); - -Theorem loc_check_SUBSET ` - subspt s t ⇒ - loc_check s ⊆ loc_check t` - (fs[SUBSET_DEF,IN_DEF,loc_check_def,FORALL_PROD,subspt_def]>>rw[]>> - metis_tac[domain_lookup,IN_DEF]); - -Theorem MAP_FST_compile_word_to_stack - `∀k ps bm ps' bm'. - compile_word_to_stack k ps bm = (ps',bm') ⇒ MAP FST ps' = MAP FST ps` - (recInduct compile_word_to_stack_ind +Theorem get_labels_wStackLoad: + !xs p. get_labels (wStackLoad xs p) = get_labels p +Proof + Induct \\ fs [wStackLoad_def] + \\ Cases \\ fs [wStackLoad_def,get_labels_def] +QED + +Theorem loc_check_SUBSET: + subspt s t ⇒ + loc_check s ⊆ loc_check t +Proof + fs[SUBSET_DEF,IN_DEF,loc_check_def,FORALL_PROD,subspt_def]>>rw[]>> + metis_tac[domain_lookup,IN_DEF] +QED + +Theorem MAP_FST_compile_word_to_stack: + ∀k ps bm ps' bm'. + compile_word_to_stack k ps bm = (ps',bm') ⇒ MAP FST ps' = MAP FST ps +Proof + recInduct compile_word_to_stack_ind \\ rw[compile_word_to_stack_def] - \\ rpt(pairarg_tac \\ fs[]) \\ rw[]); + \\ rpt(pairarg_tac \\ fs[]) \\ rw[] +QED val compile_word_to_stack_IMP_ALOOKUP = Q.prove( `!code k bs progs bitmaps n arg_count word_prog x. @@ -4794,8 +4992,8 @@ val Install_tac = \\ rveq \\ fs[TWOxDIV2] \\ rfs[] -Theorem comp_correct - `!(prog:'a wordLang$prog) (s:('a,'a word list # 'c,'ffi) wordSem$state) k f f' res s1 t bs lens. +Theorem comp_correct: + !(prog:'a wordLang$prog) (s:('a,'a word list # 'c,'ffi) wordSem$state) k f f' res s1 t bs lens. (wordSem$evaluate (prog,s) = (res,s1)) /\ res <> SOME Error /\ state_rel k f f' s t lens /\ post_alloc_conventions k prog /\ @@ -4814,8 +5012,9 @@ Theorem comp_correct (*lens might be wrong*) | SOME (Result _ y) => state_rel k 0 0 s1 t1 lens /\ FLOOKUP t1.regs 1 = SOME y | SOME (Exception _ y) => state_rel k 0 0 (push_locals s1) t1 (LASTN (s.handler+1) lens) /\ FLOOKUP t1.regs 1 = SOME y - | SOME _ => s1.ffi = t1.ffi /\ s1.clock = t1.clock` - (recInduct evaluate_ind \\ REPEAT STRIP_TAC \\ fs[get_labels_def] + | SOME _ => s1.ffi = t1.ffi /\ s1.clock = t1.clock +Proof + recInduct evaluate_ind \\ REPEAT STRIP_TAC \\ fs[get_labels_def] THEN1 (* Skip *) (qexists_tac `0` \\ fs [wordSemTheory.evaluate_def, stackSemTheory.evaluate_def,comp_def] \\ rw []) @@ -6732,7 +6931,8 @@ Theorem comp_correct IF_CASES_TAC>>fs[]>>rveq>> fs[]>> strip_tac>> - fs[state_rel_def])); + fs[state_rel_def]) +QED val evaluate_Seq_Skip = Q.prove( `stackSem$evaluate (Seq Skip p,s) = evaluate (p,s)`, @@ -6770,9 +6970,11 @@ val comp_Call = Q.prove( \\ IF_CASES_TAC \\ fs [] \\ every_case_tac \\ fs [state_rel_def,push_locals_def,LET_DEF]); -Theorem state_rel_with_clock - `state_rel a 0 0 s t lens ⇒ state_rel a 0 0 (s with clock := k) (t with clock := k) lens` - (rw[state_rel_def]\\metis_tac[]); +Theorem state_rel_with_clock: + state_rel a 0 0 s t lens ⇒ state_rel a 0 0 (s with clock := k) (t with clock := k) lens +Proof + rw[state_rel_def]\\metis_tac[] +QED val s = ``(s:(α,α word list # γ,'ffi)wordSem$state)``; val s' = ``(s:(α,'c,'ffi)stackSem$state)``; @@ -6787,10 +6989,11 @@ val clock_simps = fun drule0 th = first_assum(mp_tac o MATCH_MP (ONCE_REWRITE_RULE[GSYM AND_IMP_INTRO] th)) -Theorem state_rel_IMP_semantics - `state_rel k 0 0 ^s ^t lens /\ semantics s start <> Fail ==> - semantics start t IN extend_with_resource_limit { semantics s start }` - (simp[GSYM AND_IMP_INTRO] >> ntac 1 strip_tac >> +Theorem state_rel_IMP_semantics: + state_rel k 0 0 ^s ^t lens /\ semantics s start <> Fail ==> + semantics start t IN extend_with_resource_limit { semantics s start } +Proof + simp[GSYM AND_IMP_INTRO] >> ntac 1 strip_tac >> `2 MOD (dimword(:'a)) ≠ 0` by ( fs[state_rel_def] >> `8 < dimword(:'a)` by (assume_tac dimindex_lt_dimword >> simp[]) >> @@ -6993,7 +7196,8 @@ Theorem state_rel_IMP_semantics CASE_TAC>>simp[]) >> REV_FULL_SIMP_TAC(srw_ss()++ARITH_ss)[]>> fsrw_tac[ARITH_ss][IS_PREFIX_APPEND]>> - simp[EL_APPEND1]); + simp[EL_APPEND1] +QED val init_state_ok_def = Define ` init_state_ok k ^t coracle <=> @@ -7072,16 +7276,17 @@ val init_state_ok_semantics = |> (fn th => (MATCH_MP th (UNDISCH init_state_ok_IMP_state_rel))) |> DISCH_ALL |> SIMP_RULE std_ss [AND_IMP_INTRO,GSYM CONJ_ASSOC] -Theorem compile_semantics - `^t.code = fromAList (SND (compile asm_conf code)) /\ +Theorem compile_semantics: + ^t.code = fromAList (SND (compile asm_conf code)) /\ k = (asm_conf.reg_count - (5 + LENGTH asm_conf.avoid_regs)) /\ init_state_ok k t coracle /\ (ALOOKUP code raise_stub_location = NONE) /\ (FST (compile asm_conf code)).bitmaps ≼ t.bitmaps /\ EVERY (λn,m,prog. flat_exp_conventions prog /\ post_alloc_conventions (asm_conf.reg_count - (5 + LENGTH asm_conf.avoid_regs)) prog) code /\ semantics (make_init k t (fromAList code) coracle) start <> Fail ==> semantics start t IN - extend_with_resource_limit {semantics (make_init k t (fromAList code) coracle) start}` - (rw [compile_def] \\ match_mp_tac (GEN_ALL init_state_ok_semantics) + extend_with_resource_limit {semantics (make_init k t (fromAList code) coracle) start} +Proof + rw [compile_def] \\ match_mp_tac (GEN_ALL init_state_ok_semantics) \\ fs [compile_word_to_stack_def,lookup_fromAList,LET_THM,domain_fromAList] \\ rw [] \\ fs [] \\ TRY (pairarg_tac \\ fs []) \\ imp_res_tac MAP_FST_compile_word_to_stack \\ fs[] @@ -7091,7 +7296,8 @@ Theorem compile_semantics fs[EVERY_MEM,FORALL_PROD]>> metis_tac[]) \\ match_mp_tac compile_word_to_stack_IMP_ALOOKUP - \\ metis_tac []); + \\ metis_tac [] +QED val stack_move_no_labs = Q.prove(` ∀n a b c p. @@ -7100,10 +7306,11 @@ val stack_move_no_labs = Q.prove(` Induct>>rw[stack_move_def]>> EVAL_TAC>>metis_tac[]) -Theorem word_to_stack_lab_pres ` - ∀p bs kf. - extract_labels p = extract_labels (FST (comp p bs kf))` - (ho_match_mp_tac comp_ind>> +Theorem word_to_stack_lab_pres: + ∀p bs kf. + extract_labels p = extract_labels (FST (comp p bs kf)) +Proof + ho_match_mp_tac comp_ind>> rw[comp_def,extract_labels_def,wordPropsTheory.extract_labels_def]>> TRY(PairCases_on`kf`)>>TRY(PairCases_on`kf'`)>> fs[wReg1_def,wRegImm2_def] @@ -7147,10 +7354,11 @@ Theorem word_to_stack_lab_pres ` EVERY_CASE_TAC>>fs[]>>rveq>>fs[]>>EVAL_TAC) >- (EVAL_TAC>>EVERY_CASE_TAC>>EVAL_TAC) >> rpt(pairarg_tac \\ fs[wReg2_def]) - \\ every_case_tac \\ rw[] \\ EVAL_TAC); + \\ every_case_tac \\ rw[] \\ EVAL_TAC +QED -Theorem word_to_stack_compile_lab_pres ` - EVERY (λn,m,p. +Theorem word_to_stack_compile_lab_pres: + EVERY (λn,m,p. let labs = extract_labels p in EVERY (λ(l1,l2).l1 = n ∧ l2 ≠ 0) labs ∧ ALL_DISTINCT labs) prog ⇒ @@ -7159,8 +7367,9 @@ Theorem word_to_stack_compile_lab_pres ` EVERY (λn,p. let labs = extract_labels p in EVERY (λ(l1,l2).l1 = n ∧ l2 ≠ 0) labs ∧ - ALL_DISTINCT labs) p` - (fs[compile_def]>>pairarg_tac>>rw[]>> + ALL_DISTINCT labs) p +Proof + fs[compile_def]>>pairarg_tac>>rw[]>> pairarg_tac>>fs[]>>rveq>>fs[]>> EVAL_TAC>> qabbrev_tac`b=[4w]`>>pop_assum kall_tac>> @@ -7182,10 +7391,11 @@ Theorem word_to_stack_compile_lab_pres ` FULL_SIMP_TAC std_ss [compile_prog_def,LET_THM]>> qpat_abbrev_tac`m = if _ then _ else _`>> pairarg_tac>>rw[]>>EVAL_TAC>> - metis_tac[FST,word_to_stack_lab_pres]) + metis_tac[FST,word_to_stack_lab_pres] +QED -Theorem compile_word_to_stack_lab_pres - `∀p b q r. +Theorem compile_word_to_stack_lab_pres: + ∀p b q r. compile_word_to_stack k p b = (q,r) ∧ EVERY (λ(l,m,e). EVERY (λ(l1,l2). (l1 = l) ∧ (l2 ≠ 0)) (extract_labels e) ∧ @@ -7193,8 +7403,9 @@ Theorem compile_word_to_stack_lab_pres ⇒ EVERY (λ(l,e). EVERY (λ(l1,l2). (l1 = l) ∧ (l2 ≠ 0)) (extract_labels e) ∧ - ALL_DISTINCT (extract_labels e)) q` - (Induct + ALL_DISTINCT (extract_labels e)) q +Proof + Induct \\ simp[word_to_stackTheory.compile_word_to_stack_def] \\ simp[FORALL_PROD] \\ rw[word_to_stackTheory.compile_word_to_stack_def] @@ -7206,7 +7417,8 @@ Theorem compile_word_to_stack_lab_pres \\ pairarg_tac \\ fs[] \\ rveq \\ EVAL_TAC \\ pop_assum mp_tac \\ specl_args_of_then``word_to_stack$comp``word_to_stack_lab_pres mp_tac - \\ ntac 2 strip_tac \\ fs[]); + \\ ntac 2 strip_tac \\ fs[] +QED val EVEN_DIV_2_props = Q.prove(` a MOD 2 = 0 ∧ b MOD 2 = 0 ⇒ @@ -7243,15 +7455,16 @@ val wLive_stack_asm_name = Q.prove(` rpt(pairarg_tac>>fs[])>> rveq>>EVAL_TAC>>fs[]) -Theorem word_to_stack_stack_asm_name_lem ` - ∀p bs kf c. +Theorem word_to_stack_stack_asm_name_lem: + ∀p bs kf c. post_alloc_conventions (FST kf) p ∧ full_inst_ok_less c p ∧ (c.two_reg_arith ⇒ every_inst two_reg_inst p) ∧ (FST kf)+1 < c.reg_count - LENGTH c.avoid_regs ∧ 4 < (FST kf) ⇒ - stack_asm_name c (FST (comp p bs kf))` - (ho_match_mp_tac comp_ind>>rw[]>>fs[comp_def,stack_asm_name_def] + stack_asm_name c (FST (comp p bs kf)) +Proof + ho_match_mp_tac comp_ind>>rw[]>>fs[comp_def,stack_asm_name_def] >- (PairCases_on`kf`>>fs[wMove_def]>> qpat_abbrev_tac`ls = parmove f`>> @@ -7327,7 +7540,8 @@ Theorem word_to_stack_stack_asm_name_lem ` EVAL_TAC>>rw[]>> EVAL_TAC>>rw[]) >> PairCases_on`kf` \\ EVAL_TAC - \\ rw[] \\ EVAL_TAC \\ fs[]); + \\ rw[] \\ EVAL_TAC \\ fs[] +QED val call_dest_stack_asm_remove = Q.prove(` (FST k)+1 < c.reg_count - LENGTH c.avoid_regs ∧ @@ -7353,11 +7567,12 @@ val wLive_stack_asm_remove = Q.prove(` rpt(pairarg_tac>>fs[])>> rveq>>EVAL_TAC>>fs[]) -Theorem word_to_stack_stack_asm_remove_lem ` - ∀(p:'a wordLang$prog) bs kf (c:'a asm_config). +Theorem word_to_stack_stack_asm_remove_lem: + ∀(p:'a wordLang$prog) bs kf (c:'a asm_config). (FST kf)+1 < c.reg_count - LENGTH c.avoid_regs ⇒ - stack_asm_remove c (FST (comp p bs kf))` - (ho_match_mp_tac comp_ind>>rw[]>>fs[comp_def,stack_asm_remove_def] + stack_asm_remove c (FST (comp p bs kf)) +Proof + ho_match_mp_tac comp_ind>>rw[]>>fs[comp_def,stack_asm_remove_def] >- (PairCases_on`kf`>>fs[wMove_def]>> qpat_abbrev_tac`ls = parmove f`>> @@ -7418,16 +7633,18 @@ Theorem word_to_stack_stack_asm_remove_lem ` \\ rpt(pairarg_tac \\ fs[]) \\ PairCases_on`kf` \\ fs[wReg1_def,wReg2_def] \\ every_case_tac \\ fs[] \\ rw[] - \\ EVAL_TAC \\ fs[]) + \\ EVAL_TAC \\ fs[] +QED -Theorem word_to_stack_stack_asm_convs ` - EVERY (λ(n,m,p). +Theorem word_to_stack_stack_asm_convs: + EVERY (λ(n,m,p). full_inst_ok_less c p ∧ (c.two_reg_arith ⇒ every_inst two_reg_inst p) ∧ post_alloc_conventions (c.reg_count - (LENGTH c.avoid_regs +5)) p) progs ∧ 4 < (c.reg_count - (LENGTH c.avoid_regs +5)) ⇒ - EVERY (λ(n,p). stack_asm_name c p ∧ stack_asm_remove c p) (SND(compile c progs))` - (fs[compile_def]>>pairarg_tac>>rw[] + EVERY (λ(n,p). stack_asm_name c p ∧ stack_asm_remove c p) (SND(compile c progs)) +Proof + fs[compile_def]>>pairarg_tac>>rw[] >- (EVAL_TAC>>fs[]) >- (EVAL_TAC>>fs[]) >> @@ -7447,18 +7664,22 @@ Theorem word_to_stack_stack_asm_convs ` rfs[Abbr`kf`]>> rw[]>>EVAL_TAC>>fs[]) >> - metis_tac[]); + metis_tac[] +QED -Theorem stack_move_alloc_arg ` - ∀n st off i p. +Theorem stack_move_alloc_arg: + ∀n st off i p. alloc_arg p ⇒ - alloc_arg (stack_move n st off i p)` - (Induct>>rw[stack_move_def,alloc_arg_def]); - -Theorem word_to_stack_alloc_arg ` - ∀p n args. - alloc_arg (FST(word_to_stack$comp p n args))` - (recInduct comp_ind >> + alloc_arg (stack_move n st off i p) +Proof + Induct>>rw[stack_move_def,alloc_arg_def] +QED + +Theorem word_to_stack_alloc_arg: + ∀p n args. + alloc_arg (FST(word_to_stack$comp p n args)) +Proof + recInduct comp_ind >> fs[comp_def,alloc_arg_def,FORALL_PROD,wRegWrite1_def,wLive_def]>> rw[]>>fs[alloc_arg_def] >- @@ -7497,21 +7718,25 @@ Theorem word_to_stack_alloc_arg ` >> rpt(pairarg_tac>>fs[alloc_arg_def])>>rveq>>fs[alloc_arg_def] >> fs[wReg1_def,wReg2_def] - >> every_case_tac \\ fs[] \\ rw[alloc_arg_def,wStackLoad_def]); + >> every_case_tac \\ fs[] \\ rw[alloc_arg_def,wStackLoad_def] +QED -Theorem stack_move_reg_bound ` - ∀n st off i p k. +Theorem stack_move_reg_bound: + ∀n st off i p k. i < k ∧ reg_bound p k ⇒ - reg_bound (stack_move n st off i p) k` - (Induct>>rw[stack_move_def,reg_bound_def]); + reg_bound (stack_move n st off i p) k +Proof + Induct>>rw[stack_move_def,reg_bound_def] +QED -Theorem word_to_stack_reg_bound ` - ∀p n args. +Theorem word_to_stack_reg_bound: + ∀p n args. post_alloc_conventions (FST args) p ∧ 4 ≤ FST args ⇒ - reg_bound (FST(word_to_stack$comp p n args)) (FST args+2)` - (recInduct comp_ind >>fs[comp_def,reg_bound_def,FORALL_PROD,wRegWrite1_def,wLive_def]>>rw[]>> + reg_bound (FST(word_to_stack$comp p n args)) (FST args+2) +Proof + recInduct comp_ind >>fs[comp_def,reg_bound_def,FORALL_PROD,wRegWrite1_def,wLive_def]>>rw[]>> fs[reg_bound_def,convs_def] >- (fs[wMove_def]>> @@ -7553,19 +7778,23 @@ Theorem word_to_stack_reg_bound ` >- (rpt(pairarg_tac>>fs[reg_bound_def])>>rveq>>fs[reg_bound_def]) \\ rpt(pairarg_tac>>fs[reg_bound_def])>>rveq>>fs[reg_bound_def] \\ fs[wReg1_def,wReg2_def] - \\ every_case_tac \\ fs[] \\ rw[] \\ EVAL_TAC \\ fs[]); + \\ every_case_tac \\ fs[] \\ rw[] \\ EVAL_TAC \\ fs[] +QED -Theorem stack_move_call_args ` - ∀n st off i p. +Theorem stack_move_call_args: + ∀n st off i p. call_args p 1 2 3 4 0 ⇒ - call_args (stack_move n st off i p) 1 2 3 4 0` - (Induct>>rw[stack_move_def,call_args_def]); + call_args (stack_move n st off i p) 1 2 3 4 0 +Proof + Induct>>rw[stack_move_def,call_args_def] +QED -Theorem word_to_stack_call_args ` - ∀p n args. +Theorem word_to_stack_call_args: + ∀p n args. post_alloc_conventions (FST args) p ⇒ - call_args (FST(word_to_stack$comp p n args)) 1 2 3 4 0` - (ho_match_mp_tac comp_ind >> + call_args (FST(word_to_stack$comp p n args)) 1 2 3 4 0 +Proof + ho_match_mp_tac comp_ind >> fs[comp_def,call_args_def,FORALL_PROD,wRegWrite1_def,wLive_def,convs_def]>>rw[]>> fs[call_args_def] >- @@ -7605,37 +7834,41 @@ Theorem word_to_stack_call_args ` >- (rpt(pairarg_tac>>fs[call_args_def])>>rveq>>fs[call_args_def]) \\ rpt(pairarg_tac>>fs[call_args_def])>>rveq>>fs[call_args_def] \\ fs[wReg1_def,wReg2_def] - \\ every_case_tac \\ fs[] \\ rw[] \\ EVAL_TAC \\ fs[]); + \\ every_case_tac \\ fs[] \\ rw[] \\ EVAL_TAC \\ fs[] +QED val reg_bound_ind = stackPropsTheory.reg_bound_ind val reg_bound_def = stackPropsTheory.reg_bound_def val reg_bound_inst_def = stackPropsTheory.reg_bound_inst_def -Theorem reg_bound_mono ` - ∀p k k'. +Theorem reg_bound_mono: + ∀p k k'. reg_bound p k ∧ k ≤ k' ⇒ - reg_bound p k'` - (ho_match_mp_tac reg_bound_ind>>rw[reg_bound_def]>> + reg_bound p k' +Proof + ho_match_mp_tac reg_bound_ind>>rw[reg_bound_def]>> rpt(TOP_CASE_TAC>>fs[])>> Cases_on`i`>> TRY(Cases_on`a`)>> TRY(Cases_on`m`)>> TRY(Cases_on`f`)>> fs[reg_bound_inst_def]>> - rpt(TOP_CASE_TAC>>fs[])); + rpt(TOP_CASE_TAC>>fs[]) +QED (* Gluing all the conventions together *) -Theorem word_to_stack_stack_convs ` - word_to_stack$compile ac p = (c',p') ∧ +Theorem word_to_stack_stack_convs: + word_to_stack$compile ac p = (c',p') ∧ EVERY (post_alloc_conventions k) (MAP (SND o SND) p) ∧ k = (ac.reg_count- (5 +LENGTH ac.avoid_regs)) ∧ 4 ≤ k ⇒ EVERY alloc_arg (MAP SND p') ∧ EVERY (λp. reg_bound p (k+2)) (MAP SND p') ∧ - EVERY (λp. call_args p 1 2 3 4 0) (MAP SND p')` - (fs[EVERY_MEM,GSYM FORALL_AND_THM,GSYM IMP_CONJ_THM]>> + EVERY (λp. call_args p 1 2 3 4 0) (MAP SND p') +Proof + fs[EVERY_MEM,GSYM FORALL_AND_THM,GSYM IMP_CONJ_THM]>> ntac 3 strip_tac>> fs[compile_def]>> pairarg_tac>>fs[]>>rveq>>fs[] @@ -7676,10 +7909,11 @@ Theorem word_to_stack_stack_convs ` >> fs[AND_IMP_INTRO]>> first_x_assum match_mp_tac>> - metis_tac[]); + metis_tac[] +QED -Theorem compile_word_to_stack_convs - `∀p bm q bm'. +Theorem compile_word_to_stack_convs: + ∀p bm q bm'. compile_word_to_stack k p bm = (q,bm') ∧ EVERY (λ(n,m,p). full_inst_ok_less c p ∧ @@ -7691,8 +7925,9 @@ Theorem compile_word_to_stack_convs stack_asm_remove c y ∧ alloc_arg y ∧ reg_bound y (k+2) ∧ - call_args y 1 2 3 4 0) q` - (Induct>>fs[FORALL_PROD,compile_word_to_stack_def]>> + call_args y 1 2 3 4 0) q +Proof + Induct>>fs[FORALL_PROD,compile_word_to_stack_def]>> rpt strip_tac>> FULL_SIMP_TAC (srw_ss())[compile_prog_def]>> rpt(pairarg_tac \\ fs[]) \\ rveq @@ -7710,7 +7945,8 @@ Theorem compile_word_to_stack_convs \\ conj_tac >- (EVAL_TAC \\ metis_tac[word_to_stack_alloc_arg,FST]) \\ conj_tac >- (EVAL_TAC \\ metis_tac[word_to_stack_reg_bound,FST,LESS_OR_EQ]) \\ conj_tac >- (EVAL_TAC \\ metis_tac[word_to_stack_call_args,FST]) - \\ metis_tac[]); + \\ metis_tac[] +QED (* this is the only property needed of the wRegs *) val get_code_labels_wReg = Q.prove(` @@ -7811,11 +8047,12 @@ val compile_word_to_stack_code_labels = Q.prove(` fs[SUBSET_DEF]>> metis_tac[]); -Theorem word_to_stack_good_code_labels ` - compile asm_conf progs = (bs,prog') ∧ +Theorem word_to_stack_good_code_labels: + compile asm_conf progs = (bs,prog') ∧ good_code_labels progs ⇒ - stack_good_code_labels prog'` - (fs[word_to_stackTheory.compile_def]>> + stack_good_code_labels prog' +Proof + fs[word_to_stackTheory.compile_def]>> rpt(pairarg_tac>>fs[])>> fs[good_code_labels_def,stack_good_code_labels_def]>> rw[]>> @@ -7832,6 +8069,7 @@ Theorem word_to_stack_good_code_labels ` (match_mp_tac IMAGE_SUBSET_gen>> asm_exists_tac>>simp[SUBSET_DEF]) >> - fs[SUBSET_DEF]); + fs[SUBSET_DEF] +QED val _ = export_theory(); diff --git a/compiler/backend/proofs/word_to_wordProofScript.sml b/compiler/backend/proofs/word_to_wordProofScript.sml index 71471d7c32..ef4cbf849f 100644 --- a/compiler/backend/proofs/word_to_wordProofScript.sml +++ b/compiler/backend/proofs/word_to_wordProofScript.sml @@ -20,13 +20,15 @@ val is_phy_var_tac = val rmd_thms = (remove_dead_conventions |>SIMP_RULE std_ss [LET_THM,FORALL_AND_THM])|>CONJUNCTS -Theorem FST_compile_single[simp] - `FST (compile_single a b c d e) = FST (FST e)` - (PairCases_on`e` \\ EVAL_TAC); +Theorem FST_compile_single[simp]: + FST (compile_single a b c d e) = FST (FST e) +Proof + PairCases_on`e` \\ EVAL_TAC +QED (*Chains up compile_single theorems*) -Theorem compile_single_lem ` - ∀prog n st. +Theorem compile_single_lem: + ∀prog n st. domain st.locals = set(even_list n) ∧ gc_fun_const_ok st.gc_fun ⇒ @@ -39,8 +41,9 @@ Theorem compile_single_lem ` word_state_eq_rel rst rcst ∧ case res of SOME _ => rst.locals = rcst.locals - | _ => T` - (full_simp_tac(srw_ss())[compile_single_def,LET_DEF]>>srw_tac[][]>> + | _ => T +Proof + full_simp_tac(srw_ss())[compile_single_def,LET_DEF]>>srw_tac[][]>> qpat_abbrev_tac`p1 = inst_select A B C`>> qpat_abbrev_tac`p2 = full_ssa_cc_trans n p1`>> TRY( @@ -93,7 +96,8 @@ Theorem compile_single_lem ` Cases_on`res`>>full_simp_tac(srw_ss())[]) >> pairarg_tac>>full_simp_tac(srw_ss())[word_state_eq_rel_def,state_component_equality]>> - FULL_CASE_TAC>>full_simp_tac(srw_ss())[]>>rev_full_simp_tac(srw_ss())[]); + FULL_CASE_TAC>>full_simp_tac(srw_ss())[]>>rev_full_simp_tac(srw_ss())[] +QED val tac = fs[evaluate_def,state_component_equality]>> @@ -582,9 +586,8 @@ val compile_single_correct = Q.prove(` (tac>> Cases_on`call_FFI st.ffi s x'' x'`>>simp[])); -Theorem compile_word_to_word_thm - ` - code_rel (st:('a,'c,'ffi) wordSem$state).code l ∧ +Theorem compile_word_to_word_thm: + code_rel (st:('a,'c,'ffi) wordSem$state).code l ∧ (domain st.code = domain l) ∧ (st.compile = λconf progs. cc conf (MAP (λp. full_compile_single tt kk aa co (p,NONE)) progs)) ∧ @@ -602,8 +605,9 @@ Theorem compile_word_to_word_thm compile_oracle := coracle |>) in - res1 = res /\ rst1.clock = rst.clock /\ rst1.ffi = rst.ffi` - (simp[]>>rw[]>> + res1 = res /\ rst1.clock = rst.clock /\ rst1.ffi = rst.ffi +Proof + simp[]>>rw[]>> qpat_abbrev_tac`prog = Call _ _ _ _`>> drule compile_single_correct>>fs[]>> disch_then(qspecl_then[`prog`,`λconf. cc conf o ((MAP (I ## I ## remove_must_terminate)))`] mp_tac)>> @@ -627,13 +631,14 @@ Theorem compile_word_to_word_thm Cases_on`st.compile_oracle x`>> fs[MAP_MAP_o,o_DEF,LAMBDA_PROD,full_compile_single_def]>> rw[MAP_EQ_f,FORALL_PROD]>>pairarg_tac>>fs[])>> - fs[]>>fs[state_component_equality]); + fs[]>>fs[state_component_equality] +QED val rmt_thms = (remove_must_terminate_conventions|>SIMP_RULE std_ss [LET_THM,FORALL_AND_THM])|>CONJUNCTS (* syntax going into stackLang *) -Theorem compile_to_word_conventions ` - let (_,progs) = compile wc ac p in +Theorem compile_to_word_conventions: + let (_,progs) = compile wc ac p in MAP FST progs = MAP FST p ∧ EVERY2 labels_rel (MAP (extract_labels o SND o SND) p) (MAP (extract_labels o SND o SND) progs) ∧ @@ -642,8 +647,9 @@ Theorem compile_to_word_conventions ` post_alloc_conventions (ac.reg_count - (5+LENGTH ac.avoid_regs)) prog ∧ (EVERY (λ(n,m,prog). every_inst (inst_ok_less ac) prog) p ∧ addr_offset_ok ac 0w ⇒ full_inst_ok_less ac prog) ∧ - (ac.two_reg_arith ⇒ every_inst two_reg_inst prog)) progs` - (fs[compile_def]>>pairarg_tac>>fs[]>> + (ac.two_reg_arith ⇒ every_inst two_reg_inst prog)) progs +Proof + fs[compile_def]>>pairarg_tac>>fs[]>> pairarg_tac>>fs[]>>rveq>>rw[]>> `LENGTH n_oracles = LENGTH p` by (fs[next_n_oracle_def]>>metis_tac[LENGTH_GENLIST]) @@ -697,6 +703,7 @@ Theorem compile_to_word_conventions ` rw[]>> match_mp_tac (el 4 rmt_thms)>> match_mp_tac word_alloc_two_reg_inst>> - fs[three_to_two_reg_two_reg_inst]) + fs[three_to_two_reg_two_reg_inst] +QED val _ = export_theory(); diff --git a/compiler/backend/reg_alloc/linear_scanScript.sml b/compiler/backend/reg_alloc/linear_scanScript.sml index a9ba8a175d..70f623979b 100644 --- a/compiler/backend/reg_alloc/linear_scanScript.sml +++ b/compiler/backend/reg_alloc/linear_scanScript.sml @@ -1239,10 +1239,12 @@ val map_colors_sub_def = Define ` (map_colors_sub (x::xs) = do fx <- colors_sub x; fxs <- map_colors_sub xs; return (fx::fxs) od)` -Theorem map_colors_sub_eq - `map_colors_sub = st_ex_MAP colors_sub` - (once_rewrite_tac [FUN_EQ_THM] - \\ Induct \\ fs [map_colors_sub_def,st_ex_MAP_def]); +Theorem map_colors_sub_eq: + map_colors_sub = st_ex_MAP colors_sub +Proof + once_rewrite_tac [FUN_EQ_THM] + \\ Induct \\ fs [map_colors_sub_def,st_ex_MAP_def] +QED val res = m_translate spill_register_def; val res = m_translate MAP_colors_def; diff --git a/compiler/backend/reg_alloc/parmoveScript.sml b/compiler/backend/reg_alloc/parmoveScript.sml index 088d816231..d9fd029634 100644 --- a/compiler/backend/reg_alloc/parmoveScript.sml +++ b/compiler/backend/reg_alloc/parmoveScript.sml @@ -45,9 +45,11 @@ val _ = overload_on("\226\150\183*",``RTC $▷``); val windmill_def = Define ` windmill (moves:('a # 'a) list) = ALL_DISTINCT (MAP FST moves)`; -Theorem windmill_cons - `windmill (x::ls) ⇔ ¬MEM (FST x) (MAP FST ls) ∧ windmill ls` - (rw[windmill_def]) +Theorem windmill_cons: + windmill (x::ls) ⇔ ¬MEM (FST x) (MAP FST ls) ∧ windmill ls +Proof + rw[windmill_def] +QED val path_def = Define` (path [] ⇔ T) ∧ (path [_] ⇔ T) ∧ @@ -55,19 +57,23 @@ val path_def = Define` (b = b') ∧ path ((b,a)::p))`; val _ = export_rewrites["path_def"]; -Theorem path_change_start - `∀y z x. path (SNOC x y) ∧ FST x = FST z ⇒ path (SNOC z y)` - (simp[SNOC_APPEND] >> +Theorem path_change_start: + ∀y z x. path (SNOC x y) ∧ FST x = FST z ⇒ path (SNOC z y) +Proof + simp[SNOC_APPEND] >> Induct >> simp[] >> Cases >> simp[] >> Cases_on`y`>>fs[] >- ( Cases >> Cases >> simp[] >> rw[] ) >> - Cases_on`h`>>simp[] >> rw[] >> metis_tac[]) + Cases_on`h`>>simp[] >> rw[] >> metis_tac[] +QED -Theorem path_tail - `∀t h. path (h::t) ⇒ path t` - (Induct >> simp[] >> - Cases >> Cases >> simp[]) +Theorem path_tail: + ∀t h. path (h::t) ⇒ path t +Proof + Induct >> simp[] >> + Cases >> Cases >> simp[] +QED val path_imp_mem = Q.prove( `path (x::y) ⇒ @@ -112,51 +118,62 @@ val wf_def = Define` path σ`; val _ = overload_on(UnicodeChars.turnstile,``wf``); -Theorem wf_init - `windmill μ ∧ +Theorem wf_init: + windmill μ ∧ EVERY IS_SOME (MAP FST μ) ∧ EVERY IS_SOME (MAP SND μ) ⇒ - ⊢ (μ,[],[])` - (rw[wf_def,path_def]) + ⊢ (μ,[],[]) +Proof + rw[wf_def,path_def] +QED (* The invariant is preserved *) -Theorem wf_step - `∀s1 s2. s1 ▷ s2 ⇒ ⊢ s1 ⇒ ⊢ s2` - (ho_match_mp_tac step_ind >> rw[] >> +Theorem wf_step: + ∀s1 s2. s1 ▷ s2 ⇒ ⊢ s1 ⇒ ⊢ s2 +Proof + ho_match_mp_tac step_ind >> rw[] >> fs[wf_def,windmill_def,ALL_DISTINCT_APPEND] >> fs[GSYM SNOC_APPEND,FRONT_DEF] >> TRY (match_mp_tac path_change_start) >> - metis_tac[FST,path_tail]); + metis_tac[FST,path_tail] +QED -Theorem wf_steps - `∀s1 s2. ⊢ s1 ∧ s1 ▷* s2 ⇒ ⊢ s2` - (ho_match_mp_tac RTC_lifts_invariants >> - metis_tac[wf_step]) +Theorem wf_steps: + ∀s1 s2. ⊢ s1 ∧ s1 ▷* s2 ⇒ ⊢ s2 +Proof + ho_match_mp_tac RTC_lifts_invariants >> + metis_tac[wf_step] +QED (* semantics of moves *) val parsem_def = Define` parsem μ ρ = ρ =++ (ZIP(MAP FST μ, MAP (ρ o SND) μ))`; -Theorem parsem_nil[simp] - `parsem [] = I` - (rw[parsem_def,FUN_EQ_THM,UPDATE_LIST_THM]); - -Theorem parsem_cons - `¬MEM x (MAP FST μ) ⇒ - parsem ((x,y)::μ) ρ = (x =+ ρ y) (parsem μ ρ)` - (rw[parsem_def,UPDATE_LIST_THM] >> +Theorem parsem_nil[simp]: + parsem [] = I +Proof + rw[parsem_def,FUN_EQ_THM,UPDATE_LIST_THM] +QED + +Theorem parsem_cons: + ¬MEM x (MAP FST μ) ⇒ + parsem ((x,y)::μ) ρ = (x =+ ρ y) (parsem μ ρ) +Proof + rw[parsem_def,UPDATE_LIST_THM] >> simp[FUN_EQ_THM,APPLY_UPDATE_THM,APPLY_UPDATE_LIST_ALOOKUP] >> rw[] >> BasicProvers.CASE_TAC >> imp_res_tac ALOOKUP_MEM >> fs[MEM_MAP,MEM_ZIP,FORALL_PROD] >> - rw[] >> fs[MEM_EL,EL_MAP] >> metis_tac[PAIR,FST]); + rw[] >> fs[MEM_EL,EL_MAP] >> metis_tac[PAIR,FST] +QED -Theorem independence - `∀μ1 s d μ2 μ. +Theorem independence: + ∀μ1 s d μ2 μ. windmill μ ∧ μ = μ1 ++ [(d,s)] ++ μ2 ⇒ - parsem μ = parsem ([(d,s)]++μ1++μ2)` - (Induct >> simp[] >> Cases >> rw[] >> + parsem μ = parsem ([(d,s)]++μ1++μ2) +Proof + Induct >> simp[] >> Cases >> rw[] >> full_simp_tac std_ss [windmill_cons] >> simp[parsem_cons,FUN_EQ_THM] >> `¬MEM d (MAP FST ((q,r)::(μ1 ++ μ2)))` by ( @@ -164,11 +181,13 @@ Theorem independence simp[parsem_cons] >> full_simp_tac std_ss [MAP,MEM] >> `¬MEM q (MAP FST (μ1 ++ μ2))` by fs[] >> - simp[parsem_cons,APPLY_UPDATE_THM] >> rw[]); + simp[parsem_cons,APPLY_UPDATE_THM] >> rw[] +QED -Theorem parsem_perm - `windmill l1 ∧ PERM l1 l2 ⇒ parsem l1 = parsem l2` - (rw[] >> +Theorem parsem_perm: + windmill l1 ∧ PERM l1 l2 ⇒ parsem l1 = parsem l2 +Proof + rw[] >> Q.ISPEC_THEN`λl. if windmill l then parsem l else ARB`mp_tac PERM_lifts_equalities >> simp[] >> @@ -208,31 +227,37 @@ Theorem parsem_perm metis_tac[PERM_APPEND,APPEND_ASSOC,PERM_APPEND_IFF,ALL_DISTINCT_PERM]) >> `windmill l2` by metis_tac[windmill_def,ALL_DISTINCT_PERM,PERM_MAP] >> disch_then(fn th => first_x_assum(mp_tac o MATCH_MP th)) >> - simp[]) + simp[] +QED -Theorem parsem_untouched - `∀ρ μ x. windmill μ ∧ ¬MEM x (MAP FST μ) ⇒ parsem μ ρ x = ρ x` - (gen_tac >> Induct >> simp[] >> +Theorem parsem_untouched: + ∀ρ μ x. windmill μ ∧ ¬MEM x (MAP FST μ) ⇒ parsem μ ρ x = ρ x +Proof + gen_tac >> Induct >> simp[] >> Cases >> rw[] >> `¬MEM q (MAP FST μ)` by fs[windmill_def] >> simp[parsem_cons,APPLY_UPDATE_THM] >> first_x_assum match_mp_tac >> - fs[windmill_def]) + fs[windmill_def] +QED -Theorem parsem_change_env - `(¬MEM x (MAP FST μ) ⇒ ρ1 x = ρ2 x) ∧ +Theorem parsem_change_env: + (¬MEM x (MAP FST μ) ⇒ ρ1 x = ρ2 x) ∧ MAP (ρ1 o SND) μ = MAP (ρ2 o SND) μ ⇒ - parsem μ ρ1 x = parsem μ ρ2 x` - (rw[parsem_def,APPLY_UPDATE_LIST_ALOOKUP] >> + parsem μ ρ1 x = parsem μ ρ2 x +Proof + rw[parsem_def,APPLY_UPDATE_LIST_ALOOKUP] >> BasicProvers.CASE_TAC >> first_x_assum match_mp_tac >> imp_res_tac ALOOKUP_FAILS >> fs[MEM_MAP,FORALL_PROD,MEM_ZIP,MEM_EL] >> - metis_tac[EL_MAP,FST]) - -Theorem parsem_NoRead - `NoRead μ x ⇒ - parsem ((x,y)::μ) ρ = parsem μ ((x =+ ρ y) ρ)` - (rw[parsem_def,APPLY_UPDATE_LIST_ALOOKUP,FUN_EQ_THM,ALOOKUP_APPEND,APPLY_UPDATE_THM,REVERSE_ZIP] >> + metis_tac[EL_MAP,FST] +QED + +Theorem parsem_NoRead: + NoRead μ x ⇒ + parsem ((x,y)::μ) ρ = parsem μ ((x =+ ρ y) ρ) +Proof + rw[parsem_def,APPLY_UPDATE_LIST_ALOOKUP,FUN_EQ_THM,ALOOKUP_APPEND,APPLY_UPDATE_THM,REVERSE_ZIP] >> simp[GSYM MAP_REVERSE,ALOOKUP_ZIP_MAP_SND] >> qpat_abbrev_tac`z = ALOOKUP X Y` >> Cases_on`z`>>rw[APPLY_UPDATE_THM] >> @@ -243,13 +268,15 @@ Theorem parsem_NoRead Cases_on`p`>>fs[]>> fs[MAP_REVERSE,GSYM REVERSE_ZIP] >> fs[MEM_ZIP,MEM_MAP,MEM_EL,EXISTS_PROD] >> - metis_tac[]) + metis_tac[] +QED -Theorem parsem_MAP_INJ - `∀ms. windmill ms ∧ +Theorem parsem_MAP_INJ: + ∀ms. windmill ms ∧ INJ f (set (MAP FST ms ++ MAP SND ms)) UNIV ⇒ - ∀x. MEM x (MAP FST ms) ⇒ parsem (MAP (f ## f) ms) r (f x) = parsem ms (r o f) x` - (simp[windmill_def] + ∀x. MEM x (MAP FST ms) ⇒ parsem (MAP (f ## f) ms) r (f x) = parsem ms (r o f) x +Proof + simp[windmill_def] \\ Induct \\ simp[] \\ Cases \\ strip_tac \\ fs[] \\ qmatch_assum_rename_tac`¬MEM x (MAP FST ms)` @@ -275,7 +302,8 @@ Theorem parsem_MAP_INJ \\ simp[] \\ qhdtm_x_assum`INJ`mp_tac \\ REWRITE_TAC[INJ_DEF,IN_INSERT,IN_UNION] - \\ metis_tac[]); + \\ metis_tac[] +QED val seqsem_def = Define` (seqsem [] ρ = ρ) ∧ @@ -283,27 +311,35 @@ val seqsem_def = Define` val seqsem_ind = theorem"seqsem_ind"; -Theorem seqsem_append - `∀l1 l2. seqsem (l1 ++ l2) = seqsem l2 o seqsem l1` - (Induct >> fs[FUN_EQ_THM,seqsem_def] >> Cases >> simp[seqsem_def]) +Theorem seqsem_append: + ∀l1 l2. seqsem (l1 ++ l2) = seqsem l2 o seqsem l1 +Proof + Induct >> fs[FUN_EQ_THM,seqsem_def] >> Cases >> simp[seqsem_def] +QED -Theorem seqsem_move_unchanged - `∀ms r. ¬MEM k (MAP FST ms) ⇒ seqsem ms r k = r k` - (ho_match_mp_tac seqsem_ind - \\ rw[seqsem_def,APPLY_UPDATE_THM]); +Theorem seqsem_move_unchanged: + ∀ms r. ¬MEM k (MAP FST ms) ⇒ seqsem ms r k = r k +Proof + ho_match_mp_tac seqsem_ind + \\ rw[seqsem_def,APPLY_UPDATE_THM] +QED (* semantics of the state *) val sem_def = Define` sem (μ,σ,τ) ρ = parsem (μ++σ) (seqsem (REVERSE τ) ρ)`; -Theorem sem_init - `sem (μ,[],[]) = parsem μ` - (rw[FUN_EQ_THM,sem_def,seqsem_def]) +Theorem sem_init: + sem (μ,[],[]) = parsem μ +Proof + rw[FUN_EQ_THM,sem_def,seqsem_def] +QED -Theorem sem_final - `sem ([],[],τ) = seqsem (REVERSE τ)` - (rw[sem_def,FUN_EQ_THM,parsem_def,UPDATE_LIST_THM]) +Theorem sem_final: + sem ([],[],τ) = seqsem (REVERSE τ) +Proof + rw[sem_def,FUN_EQ_THM,parsem_def,UPDATE_LIST_THM] +QED (* semantic preservation *) @@ -390,28 +426,32 @@ val step_sem = Q.prove( match_mp_tac parsem_NoRead >> rw[]); -Theorem steps_sem - `∀s1 s2. s1 ▷* s2 ∧ ⊢ s1 ⇒ (∀ρ. sem s1 ρ ≡ sem s2 ρ)` - (simp[GSYM AND_IMP_INTRO] >> +Theorem steps_sem: + ∀s1 s2. s1 ▷* s2 ∧ ⊢ s1 ⇒ (∀ρ. sem s1 ρ ≡ sem s2 ρ) +Proof + simp[GSYM AND_IMP_INTRO] >> ho_match_mp_tac RTC_INDUCT >> conj_tac >- simp[eqenv_def] >> rw[] >> imp_res_tac wf_step >> fs[] >> imp_res_tac step_sem >> - fs[eqenv_def] ); + fs[eqenv_def] +QED -Theorem steps_correct - `windmill μ ∧ +Theorem steps_correct: + windmill μ ∧ EVERY IS_SOME (MAP FST μ) ∧ EVERY IS_SOME (MAP SND μ) ∧ (μ,[],[]) ▷* ([],[],τ) ⇒ - ∀ρ. parsem μ ρ ≡ seqsem (REVERSE τ) ρ` - (rw[] >> + ∀ρ. parsem μ ρ ≡ seqsem (REVERSE τ) ρ +Proof + rw[] >> imp_res_tac steps_sem >> pop_assum mp_tac >> impl_tac >- simp[wf_def] >> - simp[sem_def,seqsem_def]); + simp[sem_def,seqsem_def] +QED (* deterministic algorithm *) @@ -454,10 +494,12 @@ val dstep_step = Q.prove( match_mp_tac RTC_SUBSET >> rw[step_cases] >> metis_tac[CONS_APPEND,APPEND] ); -Theorem dsteps_steps - `∀s1 s2. s1 ↪* s2 ⇒ ⊢ s1 ⇒ s1 ▷* s2` - (ho_match_mp_tac RTC_INDUCT >> rw[] >> - metis_tac[dstep_step,wf_steps,RTC_CASES_RTC_TWICE]) +Theorem dsteps_steps: + ∀s1 s2. s1 ↪* s2 ⇒ ⊢ s1 ⇒ s1 ▷* s2 +Proof + ho_match_mp_tac RTC_INDUCT >> rw[] >> + metis_tac[dstep_step,wf_steps,RTC_CASES_RTC_TWICE] +QED (* functional algorithm *) @@ -523,9 +565,10 @@ val tac = res_tac >> fsrw_tac[ARITH_ss][] >> metis_tac[SND,PAIR]) -Theorem fstep_dstep - `(∀τ. s ≠ ([],[],τ)) ⇒ s ↪ fstep s` - (rw[fstep_def] >> +Theorem fstep_dstep: + (∀τ. s ≠ ([],[],τ)) ⇒ s ↪ fstep s +Proof + rw[fstep_def] >> every_case_tac >> fs[NULL_LENGTH,LENGTH_NIL] >> simp[splitAtPki_def] >- ( simp[UNCURRY] >> simp[dstep_cases] ) @@ -536,7 +579,8 @@ Theorem fstep_dstep Q.ISPEC_THEN`t`FULL_STRUCT_CASES_TAC SNOC_CASES >> fs[] >> Cases_on`x`>>fs[] ) >> TRY (rw[dstep_cases]>>NO_TAC) - >> tac) + >> tac +QED val pmov_def = tDefine"pmov"` pmov s = case s of @@ -572,23 +616,27 @@ val pmov_def = tDefine"pmov"` val pmov_ind = theorem"pmov_ind"; -Theorem pmov_dsteps - `∀s. s ↪* pmov s` - (ho_match_mp_tac pmov_ind >> +Theorem pmov_dsteps: + ∀s. s ↪* pmov s +Proof + ho_match_mp_tac pmov_ind >> rw[] >> PairCases_on`s` >> ONCE_REWRITE_TAC[pmov_def] >> every_case_tac >> simp[] >> rw[] >> fs[] >> simp[Once RTC_CASES1] >> disj2_tac >> ONCE_REWRITE_TAC[CONJ_COMM] >> first_assum(match_exists_tac o concl) >> simp[] >> - match_mp_tac fstep_dstep >> simp[]) + match_mp_tac fstep_dstep >> simp[] +QED -Theorem pmov_final - `∀s. ∃τ. pmov s = ([],[],τ)` - (ho_match_mp_tac pmov_ind >> +Theorem pmov_final: + ∀s. ∃τ. pmov s = ([],[],τ) +Proof + ho_match_mp_tac pmov_ind >> rw[] >> PairCases_on`s` >> ONCE_REWRITE_TAC[pmov_def] >> - every_case_tac >> simp[]); + every_case_tac >> simp[] +QED (* The top-level parallel move compiler *) @@ -596,11 +644,12 @@ val parmove_def = Define ` parmove (xs:('a # 'a) list) = REVERSE(SND(SND(pmov (MAP (\(x,y). (SOME x, SOME y)) xs, [],[]))))`; -Theorem parmove_correct - `windmill xs ⇒ +Theorem parmove_correct: + windmill xs ⇒ ∀ρ. seqsem (parmove xs) ρ ≡ - parsem (MAP (\(x,y). (SOME x, SOME y)) xs) ρ` - (rw[parmove_def] >> + parsem (MAP (\(x,y). (SOME x, SOME y)) xs) ρ +Proof + rw[parmove_def] >> qpat_abbrev_tac`μ = MAP _ xs` >> `∃τ. pmov (μ,[],[]) = ([],[],τ)` by metis_tac[pmov_final] >> simp[] >> @@ -618,15 +667,17 @@ Theorem parmove_correct strip_tac >> match_mp_tac eqenv_sym >> match_mp_tac steps_correct >> - fs[wf_def]); + fs[wf_def] +QED (* the compiler does not invent new moves *) -Theorem MEM_MAP_FST_SND_SND_pmov - `∀p x. +Theorem MEM_MAP_FST_SND_SND_pmov: + ∀p x. MEM (SOME x) (MAP FST (SND(SND(pmov p)))) ⇒ - MEM (SOME x) (MAP FST (FST p ++ FST(SND p) ++ SND(SND p)))` - (ho_match_mp_tac pmov_ind + MEM (SOME x) (MAP FST (FST p ++ FST(SND p) ++ SND(SND p))) +Proof + ho_match_mp_tac pmov_ind \\ simp[] \\ gen_tac \\ PairCases_on`p` @@ -672,22 +723,26 @@ Theorem MEM_MAP_FST_SND_SND_pmov \\ qmatch_assum_rename_tac`¬ NULL ls` \\ Q.ISPEC_THEN`ls`FULL_STRUCT_CASES_TAC SNOC_CASES \\ fs[] - \\ fs[MAP_SNOC] ) + \\ fs[MAP_SNOC] +QED -Theorem MEM_MAP_FST_parmove - `MEM (SOME x) (MAP FST (parmove mvs)) ⇒ MEM x (MAP FST mvs)` - (rw[parmove_def] +Theorem MEM_MAP_FST_parmove: + MEM (SOME x) (MAP FST (parmove mvs)) ⇒ MEM x (MAP FST mvs) +Proof + rw[parmove_def] \\ fs[MEM_MAP] \\ imp_res_tac(SIMP_RULE std_ss [MEM_MAP,PULL_EXISTS] MEM_MAP_FST_SND_SND_pmov) \\ fs[MEM_MAP,UNCURRY] \\ rw[] \\ fs[] - \\ metis_tac[]) + \\ metis_tac[] +QED -Theorem MEM_MAP_SND_SND_SND_pmov - `∀p x. +Theorem MEM_MAP_SND_SND_SND_pmov: + ∀p x. MEM (SOME x) (MAP SND (SND(SND(pmov p)))) ⇒ - MEM (SOME x) (MAP SND (FST p ++ FST(SND p) ++ SND(SND p)))` - (ho_match_mp_tac pmov_ind + MEM (SOME x) (MAP SND (FST p ++ FST(SND p) ++ SND(SND p))) +Proof + ho_match_mp_tac pmov_ind \\ simp[] \\ gen_tac \\ PairCases_on`p` @@ -733,16 +788,19 @@ Theorem MEM_MAP_SND_SND_SND_pmov \\ qmatch_assum_rename_tac`¬ NULL ls` \\ Q.ISPEC_THEN`ls`FULL_STRUCT_CASES_TAC SNOC_CASES \\ fs[] - \\ fs[MAP_SNOC] ) + \\ fs[MAP_SNOC] +QED -Theorem MEM_MAP_SND_parmove - `MEM (SOME x) (MAP SND (parmove mvs)) ⇒ MEM x (MAP SND mvs)` - (rw[parmove_def] +Theorem MEM_MAP_SND_parmove: + MEM (SOME x) (MAP SND (parmove mvs)) ⇒ MEM x (MAP SND mvs) +Proof + rw[parmove_def] \\ fs[MEM_MAP] \\ imp_res_tac(SIMP_RULE std_ss [MEM_MAP,PULL_EXISTS] MEM_MAP_SND_SND_SND_pmov) \\ fs[MEM_MAP,UNCURRY] \\ rw[] \\ fs[] - \\ metis_tac[]) + \\ metis_tac[] +QED (* the compiler does not use uninitialised temporaries *) @@ -755,24 +813,29 @@ val _ = export_rewrites["not_use_temp_before_assign_def"]; val not_use_temp_before_assign_ind = theorem"not_use_temp_before_assign_ind"; -Theorem not_use_temp_before_assign_append - `∀l1 l2. +Theorem not_use_temp_before_assign_append: + ∀l1 l2. (not_use_temp_before_assign (l1 ++ l2) ⇔ not_use_temp_before_assign l1 ∧ - (EVERY IS_SOME (MAP FST l1) ⇒ not_use_temp_before_assign l2))` - (ho_match_mp_tac not_use_temp_before_assign_ind \\ simp[]); + (EVERY IS_SOME (MAP FST l1) ⇒ not_use_temp_before_assign l2)) +Proof + ho_match_mp_tac not_use_temp_before_assign_ind \\ simp[] +QED -Theorem not_use_temp_before_assign_insert - `∀l1 l2. +Theorem not_use_temp_before_assign_insert: + ∀l1 l2. not_use_temp_before_assign (l1 ++ l2) ⇒ - not_use_temp_before_assign (l1 ++ [(SOME x, SOME y)] ++ l2)` - (ho_match_mp_tac not_use_temp_before_assign_ind \\ simp[]); + not_use_temp_before_assign (l1 ++ [(SOME x, SOME y)] ++ l2) +Proof + ho_match_mp_tac not_use_temp_before_assign_ind \\ simp[] +QED -Theorem not_use_temp_before_assign_thm - `∀ls. not_use_temp_before_assign ls = +Theorem not_use_temp_before_assign_thm: + ∀ls. not_use_temp_before_assign ls = ∀i. find_index NONE (MAP SND ls) 0 = SOME i ⇒ - ∃j. find_index NONE (MAP FST ls) 0 = SOME j ∧ j < i` - (ho_match_mp_tac not_use_temp_before_assign_ind + ∃j. find_index NONE (MAP FST ls) 0 = SOME j ∧ j < i +Proof + ho_match_mp_tac not_use_temp_before_assign_ind \\ simp[] \\ simp[find_index_def] \\ rw[find_index_APPEND] @@ -787,15 +850,17 @@ Theorem not_use_temp_before_assign_thm \\ Q.ISPECL_THEN[`l2`]mp_tac find_index_shift_0 \\ disch_then(qspecl_then[`NONE`,`1`]mp_tac) \\ disch_then SUBST_ALL_TAC - \\ rw[EQ_IMP_THM,PULL_EXISTS]); + \\ rw[EQ_IMP_THM,PULL_EXISTS] +QED -Theorem step_not_use_temp_before_assign - `∀s1 s2. s1 ▷ s2 ⇒ +Theorem step_not_use_temp_before_assign: + ∀s1 s2. s1 ▷ s2 ⇒ ⊢ s1 ∧ not_use_temp_before_assign (REVERSE(FST(SND s1) ++ SND(SND s1))) ⇒ - not_use_temp_before_assign (REVERSE(FST(SND s2) ++ SND(SND s2)))` - (ho_match_mp_tac step_ind + not_use_temp_before_assign (REVERSE(FST(SND s2) ++ SND(SND s2))) +Proof + ho_match_mp_tac step_ind \\ simp[not_use_temp_before_assign_append] \\ simp[MAP_REVERSE,EVERY_REVERSE,REVERSE_APPEND] \\ conj_tac @@ -813,37 +878,43 @@ Theorem step_not_use_temp_before_assign \\ fs[not_use_temp_before_assign_append] \\ rfs[] \\ rw[] - \\ fs[MAP_REVERSE,EVERY_REVERSE]); + \\ fs[MAP_REVERSE,EVERY_REVERSE] +QED -Theorem steps_not_use_temp_before_assign - `∀s1 s2. +Theorem steps_not_use_temp_before_assign: + ∀s1 s2. (λs1. ⊢ s1 ∧ not_use_temp_before_assign (REVERSE (FST (SND s1) ++ SND (SND s1)))) s1 ∧ s1 ▷* s2 ⇒ - (λs1. ⊢ s1 ∧ not_use_temp_before_assign (REVERSE (FST (SND s1) ++ SND (SND s1)))) s2` - (match_mp_tac RTC_lifts_invariants + (λs1. ⊢ s1 ∧ not_use_temp_before_assign (REVERSE (FST (SND s1) ++ SND (SND s1)))) s2 +Proof + match_mp_tac RTC_lifts_invariants \\ simp[] - \\ metis_tac[wf_step,step_not_use_temp_before_assign]); - -Theorem pmov_not_use_temp_before_assign - `∀p i. ⊢ p ∧ not_use_temp_before_assign (REVERSE (FST (SND p) ++ SND (SND p))) - ⇒ not_use_temp_before_assign (REVERSE (FST (SND (pmov p)) ++ SND (SND (pmov p))))` - (rw[] + \\ metis_tac[wf_step,step_not_use_temp_before_assign] +QED + +Theorem pmov_not_use_temp_before_assign: + ∀p i. ⊢ p ∧ not_use_temp_before_assign (REVERSE (FST (SND p) ++ SND (SND p))) + ⇒ not_use_temp_before_assign (REVERSE (FST (SND (pmov p)) ++ SND (SND (pmov p)))) +Proof + rw[] \\ qspec_then`p`assume_tac pmov_dsteps \\ drule dsteps_steps \\ simp[] \\ strip_tac \\ drule (ONCE_REWRITE_RULE[CONJ_COMM] steps_not_use_temp_before_assign) - \\ simp[]); + \\ simp[] +QED -Theorem parmove_not_use_temp_before_assign - `windmill mvs ⇒ +Theorem parmove_not_use_temp_before_assign: + windmill mvs ⇒ case find_index NONE (MAP SND (parmove mvs)) 0 of NONE => T | SOME i => case find_index NONE (MAP FST (parmove mvs)) 0 of NONE => F - | SOME j => ¬(i ≤ j)` - (strip_tac + | SOME j => ¬(i ≤ j) +Proof + strip_tac \\ simp[parmove_def] \\ qpat_abbrev_tac`ls = REVERSE _` \\ `not_use_temp_before_assign ls` @@ -863,45 +934,53 @@ Theorem parmove_not_use_temp_before_assign \\ simp[MAP_MAP_o,o_DEF,UNCURRY] \\ simp[GSYM MAP_MAP_o,GSYM o_DEF] \\ match_mp_tac ALL_DISTINCT_MAP_INJ - \\ simp[] ); + \\ simp[] +QED (* the compiler preserves all-distinct variables *) -Theorem ALL_DISTINCT_step - `∀s1 s2. s1 ▷ s2 ⇒ +Theorem ALL_DISTINCT_step: + ∀s1 s2. s1 ▷ s2 ⇒ ALL_DISTINCT (FILTER IS_SOME (MAP FST (FST s1 ++ FST (SND s1) ++ (SND (SND s1))))) ⇒ - ALL_DISTINCT (FILTER IS_SOME (MAP FST (FST s2 ++ FST (SND s2) ++ (SND (SND s2)))))` - (ho_match_mp_tac step_ind + ALL_DISTINCT (FILTER IS_SOME (MAP FST (FST s2 ++ FST (SND s2) ++ (SND (SND s2))))) +Proof + ho_match_mp_tac step_ind \\ simp[] \\ rpt conj_tac \\ simp[FILTER_APPEND,ALL_DISTINCT_APPEND,MEM_FILTER] \\ rw[] \\ fs[ALL_DISTINCT_APPEND,MEM_FILTER] - \\ metis_tac[IS_SOME_DEF]); + \\ metis_tac[IS_SOME_DEF] +QED -Theorem ALL_DISTINCT_steps - `∀s1 s2. +Theorem ALL_DISTINCT_steps: + ∀s1 s2. (λs1. ALL_DISTINCT (FILTER IS_SOME (MAP FST (FST s1 ++ FST (SND s1) ++ (SND (SND s1)))))) s1 ∧ s1 ▷* s2 ⇒ - (λs1. ALL_DISTINCT (FILTER IS_SOME (MAP FST (FST s1 ++ FST (SND s1) ++ (SND (SND s1)))))) s2` - (match_mp_tac RTC_lifts_invariants + (λs1. ALL_DISTINCT (FILTER IS_SOME (MAP FST (FST s1 ++ FST (SND s1) ++ (SND (SND s1)))))) s2 +Proof + match_mp_tac RTC_lifts_invariants \\ simp[] - \\ PROVE_TAC[ALL_DISTINCT_step,MAP_APPEND]); - -Theorem ALL_DISTINCT_pmov - `∀p. ⊢p ∧ ALL_DISTINCT (FILTER IS_SOME (MAP FST (FST p ++ FST (SND p) ++ SND (SND p)))) ⇒ - ALL_DISTINCT (FILTER IS_SOME (MAP FST (FST (pmov p) ++ FST (SND (pmov p)) ++ SND (SND (pmov p)))))` - (rw[] + \\ PROVE_TAC[ALL_DISTINCT_step,MAP_APPEND] +QED + +Theorem ALL_DISTINCT_pmov: + ∀p. ⊢p ∧ ALL_DISTINCT (FILTER IS_SOME (MAP FST (FST p ++ FST (SND p) ++ SND (SND p)))) ⇒ + ALL_DISTINCT (FILTER IS_SOME (MAP FST (FST (pmov p) ++ FST (SND (pmov p)) ++ SND (SND (pmov p))))) +Proof + rw[] \\ qspec_then`p`assume_tac pmov_dsteps \\ drule dsteps_steps \\ simp[] \\ strip_tac \\ drule (ONCE_REWRITE_RULE[CONJ_COMM] ALL_DISTINCT_steps) - \\ simp[]); + \\ simp[] +QED -Theorem ALL_DISTINCT_parmove - `ALL_DISTINCT (MAP FST mvs) ⇒ - ALL_DISTINCT (FILTER IS_SOME (MAP FST (parmove mvs)))` - (rw[parmove_def, +Theorem ALL_DISTINCT_parmove: + ALL_DISTINCT (MAP FST mvs) ⇒ + ALL_DISTINCT (FILTER IS_SOME (MAP FST (parmove mvs))) +Proof + rw[parmove_def, FILTER_REVERSE,MAP_REVERSE,ALL_DISTINCT_REVERSE] \\ qmatch_goalsub_abbrev_tac`pmov p` \\ qspec_then`p`mp_tac ALL_DISTINCT_pmov @@ -915,43 +994,51 @@ Theorem ALL_DISTINCT_parmove \\ match_mp_tac ALL_DISTINCT_MAP_INJ \\ simp[] ) \\ qspec_then`p`strip_assume_tac pmov_final - \\ simp[]); + \\ simp[] +QED (* the compiler retains all non-trivial moves *) val state_to_list_def = Define` state_to_list p = APPEND (FST p) (FST(SND p)) ++ SND(SND p)`; -Theorem step_preserves_moves - `∀s1 s2. s1 ▷ s2 ⇒ +Theorem step_preserves_moves: + ∀s1 s2. s1 ▷ s2 ⇒ ∀x. (∃y. MEM (x,y) (state_to_list s1) ∧ x ≠ y) ⇒ - (∃y. MEM (x,y) (state_to_list s2) ∧ x ≠ y)` - (ho_match_mp_tac step_ind - \\ rw[state_to_list_def] \\ metis_tac[]); - -Theorem steps_preserves_moves - `∀s1 s2. + (∃y. MEM (x,y) (state_to_list s2) ∧ x ≠ y) +Proof + ho_match_mp_tac step_ind + \\ rw[state_to_list_def] \\ metis_tac[] +QED + +Theorem steps_preserves_moves: + ∀s1 s2. (λs1. (∃y. MEM (x,y) (state_to_list s1) ∧ x ≠ y)) s1 ∧ s1 ▷* s2 ⇒ - (λs1. (∃y. MEM (x,y) (state_to_list s1) ∧ x ≠ y)) s2` - (match_mp_tac RTC_lifts_invariants \\ simp[] - \\ PROVE_TAC[step_preserves_moves]); - -Theorem pmov_preserves_moves - `∀p. ⊢p ∧ MEM (x,y) (state_to_list p) ∧ x ≠ y ⇒ - MEM x (MAP FST (state_to_list (pmov p)))` - (rw[] + (λs1. (∃y. MEM (x,y) (state_to_list s1) ∧ x ≠ y)) s2 +Proof + match_mp_tac RTC_lifts_invariants \\ simp[] + \\ PROVE_TAC[step_preserves_moves] +QED + +Theorem pmov_preserves_moves: + ∀p. ⊢p ∧ MEM (x,y) (state_to_list p) ∧ x ≠ y ⇒ + MEM x (MAP FST (state_to_list (pmov p))) +Proof + rw[] \\ qspec_then`p`assume_tac pmov_dsteps \\ drule dsteps_steps \\ simp[] \\ strip_tac \\ drule (ONCE_REWRITE_RULE[CONJ_COMM] steps_preserves_moves) \\ simp[MEM_MAP,EXISTS_PROD] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem parmove_preserves_moves - `windmill moves ∧ MEM (x,y) moves ∧ x ≠ y ⇒ MEM (SOME x) (MAP FST (parmove moves))` - (rw[parmove_def,MAP_REVERSE] +Theorem parmove_preserves_moves: + windmill moves ∧ MEM (x,y) moves ∧ x ≠ y ⇒ MEM (SOME x) (MAP FST (parmove moves)) +Proof + rw[parmove_def,MAP_REVERSE] \\ qmatch_goalsub_abbrev_tac`pmov p` \\ qspec_then`p`(mp_tac o Q.GENL[`x`,`y`]) pmov_preserves_moves \\ qspec_then`p`strip_assume_tac pmov_final @@ -966,7 +1053,8 @@ Theorem parmove_preserves_moves \\ simp[GSYM o_DEF,GSYM MAP_MAP_o] \\ match_mp_tac ALL_DISTINCT_MAP_INJ \\ simp[] ) - \\ simp[]); + \\ simp[] +QED (* mapping an injective function over compiled moves *) @@ -980,9 +1068,10 @@ val inj_on_state_def = Define` (∀x y. MEM x ls ∧ MEM y ls ∧ f x = f y ⇒ x = y) ∧ (∀x. f x = NONE ⇔ x = NONE)`; -Theorem step_inj_on_state - `∀s1 s2. s1 ▷ s2 ⇒ inj_on_state f s1 ⇒ inj_on_state f s2` - (ho_match_mp_tac step_ind +Theorem step_inj_on_state: + ∀s1 s2. s1 ▷ s2 ⇒ inj_on_state f s1 ⇒ inj_on_state f s2 +Proof + ho_match_mp_tac step_ind \\ rpt conj_tac \\ simp[inj_on_state_def] \\ rw[] @@ -993,15 +1082,19 @@ Theorem step_inj_on_state \\ (Cases_on`x=NONE` >- metis_tac[]) \\ (Cases_on`y=NONE` >- metis_tac[]) \\ first_x_assum match_mp_tac - \\ fs[state_to_list_def]); - -Theorem steps_inj_on_state - `∀s1 s2. inj_on_state f s1 ∧ s1 ▷* s2 ⇒ inj_on_state f s2` - (match_mp_tac RTC_lifts_invariants \\ metis_tac[step_inj_on_state]); - -Theorem step_MAP_INJ - `∀s1 s2. s1 ▷ s2 ⇒ inj_on_state f s1 ⇒ map_state f s1 ▷ map_state f s2` - (ho_match_mp_tac step_ind + \\ fs[state_to_list_def] +QED + +Theorem steps_inj_on_state: + ∀s1 s2. inj_on_state f s1 ∧ s1 ▷* s2 ⇒ inj_on_state f s2 +Proof + match_mp_tac RTC_lifts_invariants \\ metis_tac[step_inj_on_state] +QED + +Theorem step_MAP_INJ: + ∀s1 s2. s1 ▷ s2 ⇒ inj_on_state f s1 ⇒ map_state f s1 ▷ map_state f s2 +Proof + ho_match_mp_tac step_ind \\ simp[map_state_def] \\ conj_tac >- ( @@ -1053,7 +1146,8 @@ Theorem step_MAP_INJ \\ simp[] \\ simp[state_to_list_def] \\ simp[MEM_MAP,EXISTS_PROD] - \\ metis_tac[] ) + \\ metis_tac[] +QED val steps_MAP_INJ = Q.prove( `∀s1 s2. s1 ▷* s2 ⇒ @@ -1065,9 +1159,10 @@ val steps_MAP_INJ = Q.prove( \\ fs[] \\ metis_tac[step_MAP_INJ,RTC_RULES]); -Theorem fstep_MAP_INJ - `∀p. inj_on_state f p ⇒ fstep (map_state f p) = map_state f (fstep p)` - (gen_tac \\ strip_tac +Theorem fstep_MAP_INJ: + ∀p. inj_on_state f p ⇒ fstep (map_state f p) = map_state f (fstep p) +Proof + gen_tac \\ strip_tac \\ PairCases_on`p` \\ simp[fstep_def] \\ match_mp_tac EQ_SYM @@ -1127,12 +1222,14 @@ Theorem fstep_MAP_INJ \\ qmatch_goalsub_rename_tac`LAST (h::t)` \\ `MEM (LAST (h::t)) (h::t)` by simp[MEM_LAST] \\ fs[] - \\ metis_tac[]); - -Theorem pmov_MAP_INJ - `∀p. ⊢ p ∧ inj_on_state f p - ⇒ pmov (map_state f p) = map_state f (pmov p)` - (ho_match_mp_tac pmov_ind + \\ metis_tac[] +QED + +Theorem pmov_MAP_INJ: + ∀p. ⊢ p ∧ inj_on_state f p + ⇒ pmov (map_state f p) = map_state f (pmov p) +Proof + ho_match_mp_tac pmov_ind \\ gen_tac \\ PairCases_on`p` \\ simp[] @@ -1162,14 +1259,16 @@ Theorem pmov_MAP_INJ \\ fs[map_state_def,LET_THM,Abbr`p`] \\ match_mp_tac EQ_SYM \\ first_x_assum match_mp_tac - \\ metis_tac[steps_inj_on_state,wf_steps] ) + \\ metis_tac[steps_inj_on_state,wf_steps] +QED -Theorem parmove_MAP_INJ - `(let ls1 = MAP FST ls ++ MAP SND ls in (∀x y. MEM x ls1 ∧ MEM y ls1 ∧ f x = f y ⇒ x = y)) ∧ +Theorem parmove_MAP_INJ: + (let ls1 = MAP FST ls ++ MAP SND ls in (∀x y. MEM x ls1 ∧ MEM y ls1 ∧ f x = f y ⇒ x = y)) ∧ windmill ls ⇒ - parmove (MAP (f ## f) ls) = MAP (OPTION_MAP f ## OPTION_MAP f) (parmove ls)` - (rw[parmove_def,MAP_REVERSE] + parmove (MAP (f ## f) ls) = MAP (OPTION_MAP f ## OPTION_MAP f) (parmove ls) +Proof + rw[parmove_def,MAP_REVERSE] \\ match_mp_tac EQ_SYM \\ qmatch_goalsub_abbrev_tac`pmov p` \\ match_mp_tac EQ_SYM @@ -1200,6 +1299,7 @@ Theorem parmove_MAP_INJ \\ simp[] \\ qspec_then`p`strip_assume_tac pmov_final \\ fs[] - \\ simp[map_state_def]); + \\ simp[map_state_def] +QED val _ = export_theory(); diff --git a/compiler/backend/reg_alloc/proofs/linear_scanProofScript.sml b/compiler/backend/reg_alloc/proofs/linear_scanProofScript.sml index 2f04e0755e..c3b73b36a1 100644 --- a/compiler/backend/reg_alloc/proofs/linear_scanProofScript.sml +++ b/compiler/backend/reg_alloc/proofs/linear_scanProofScript.sml @@ -21,39 +21,44 @@ val _ = hide "state"; (* TODO: clean up this file: e.g., move things upstream *) -Theorem set_MAP_FST_toAList_eq_domain - `!s. set (MAP FST (toAList s)) = domain s` - (rw [EXTENSION, MEM_MAP, EXISTS_PROD, MEM_toAList, domain_lookup]); - -Theorem numset_list_insert_FOLDL - `!l live. numset_list_insert l live = FOLDL (\live x. insert x () live) live l` - (Induct_on `l` >> rw [numset_list_insert_def] -); - -Theorem numset_list_insert_nottailrec_FOLDR - `!l live. numset_list_insert_nottailrec l live = FOLDR (\x live. insert x () live) live l` - (Induct_on `l` >> rw [numset_list_insert_nottailrec_def] -); - -Theorem both_numset_list_insert_equal - `!l live. - numset_list_insert l live = numset_list_insert_nottailrec (REVERSE l) live` - - (rw [numset_list_insert_FOLDL, numset_list_insert_nottailrec_FOLDR, FOLDR_FOLDL_REVERSE] -); - -Theorem domain_numset_list_insert - `!l s. domain (numset_list_insert l s) = set l UNION domain s` - (Induct_on `l` >> +Theorem set_MAP_FST_toAList_eq_domain: + !s. set (MAP FST (toAList s)) = domain s +Proof + rw [EXTENSION, MEM_MAP, EXISTS_PROD, MEM_toAList, domain_lookup] +QED + +Theorem numset_list_insert_FOLDL: + !l live. numset_list_insert l live = FOLDL (\live x. insert x () live) live l +Proof + Induct_on `l` >> rw [numset_list_insert_def] +QED + +Theorem numset_list_insert_nottailrec_FOLDR: + !l live. numset_list_insert_nottailrec l live = FOLDR (\x live. insert x () live) live l +Proof + Induct_on `l` >> rw [numset_list_insert_nottailrec_def] +QED + +Theorem both_numset_list_insert_equal: + !l live. + numset_list_insert l live = numset_list_insert_nottailrec (REVERSE l) live +Proof + rw [numset_list_insert_FOLDL, numset_list_insert_nottailrec_FOLDR, FOLDR_FOLDL_REVERSE] +QED + +Theorem domain_numset_list_insert: + !l s. domain (numset_list_insert l s) = set l UNION domain s +Proof + Induct_on `l` >> rw [numset_list_insert_def] >> metis_tac [numset_list_insert_def, INSERT_UNION_EQ, UNION_COMM] -); +QED (* why breaking encapsulation like this? To get rid of the assumption `wf s` *) -Theorem lookup_insert_id - `!x (y:unit) s. lookup x s = SOME () ==> s = insert x () s` - - (recInduct insert_ind >> +Theorem lookup_insert_id: + !x (y:unit) s. lookup x s = SOME () ==> s = insert x () s +Proof + recInduct insert_ind >> rw [] THEN1 ( imp_res_tac domain_lookup >> @@ -77,14 +82,14 @@ Theorem lookup_insert_id once_rewrite_tac [insert_def] >> rw [] ) -); +QED -Theorem numset_list_insert_FILTER - `!l live. +Theorem numset_list_insert_FILTER: + !l live. numset_list_insert (FILTER (λx. lookup x live = NONE) l) live = - numset_list_insert l live` - - (sg `!x l live. lookup x live = SOME () ==> lookup x (numset_list_insert_nottailrec l live) = SOME ()` THEN1 ( + numset_list_insert l live +Proof + sg `!x l live. lookup x live = SOME () ==> lookup x (numset_list_insert_nottailrec l live) = SOME ()` THEN1 ( Induct_on `l` >> rw [numset_list_insert_nottailrec_def, lookup_insert] ) >> @@ -95,23 +100,24 @@ Theorem numset_list_insert_FILTER rw [numset_list_insert_nottailrec_def] >> Cases_on `lookup h live` >> fs [NOT_SOME_NONE] >> simp [lookup_insert_id] -); +QED -Theorem domain_numset_list_delete - `!l s. domain (numset_list_delete l s) = (domain s) DIFF (set l)` - (Induct_on `l` >> +Theorem domain_numset_list_delete: + !l s. domain (numset_list_delete l s) = (domain s) DIFF (set l) +Proof + Induct_on `l` >> rw [numset_list_delete_def, DIFF_INSERT] -); +QED -Theorem check_partial_col_success_INJ_lemma - `!l live flive f. +Theorem check_partial_col_success_INJ_lemma: + !l live flive f. domain flive = IMAGE f (domain live) /\ INJ f (domain live) UNIV /\ check_partial_col f l live flive = SOME (live',flive') ==> - INJ f (set l UNION domain live) UNIV` - - (Induct_on `l` >> rw [] >> + INJ f (set l UNION domain live) UNIV +Proof + Induct_on `l` >> rw [] >> fs [check_partial_col_def] >> Cases_on `lookup h live` THEN1 ( Cases_on `lookup (f h) flive` >> fs [] >> @@ -130,47 +136,46 @@ Theorem check_partial_col_success_INJ_lemma `h IN (set l) UNION (domain live)` by metis_tac [SUBSET_DEF, SUBSET_UNION] >> `!(x : num) s. x IN s ==> x INSERT s = s` by metis_tac [INSERT_applied, IN_DEF, EXTENSION] >> metis_tac [] -); +QED -Theorem check_partial_col_success_INJ ` - !l live flive f. +Theorem check_partial_col_success_INJ: + !l live flive f. domain flive = IMAGE f (domain live) /\ INJ f (domain live) UNIV /\ check_partial_col f l live flive = SOME (live',flive') ==> INJ f (set l UNION domain live) UNIV /\ - INJ f (domain live') UNIV` - - (rw [] >> + INJ f (domain live') UNIV +Proof + rw [] >> `domain live' = set l UNION domain live` by metis_tac [check_partial_col_domain, FST] >> metis_tac [check_partial_col_success_INJ_lemma] -); +QED -Theorem check_partial_col_input_monotone - `!f live1 flive1 live2 flive2 l v. +Theorem check_partial_col_input_monotone: + !f live1 flive1 live2 flive2 l v. IMAGE f (domain live1) = domain flive1 /\ IMAGE f (domain live2) = domain flive2 ==> domain live1 SUBSET domain live2 ==> INJ f (domain live2) UNIV ==> check_partial_col f l live2 flive2 = SOME v ==> ?livein1 flivein1. check_partial_col f l live1 flive1 = SOME (livein1, flivein1) - ` - - (rw [] >> +Proof + rw [] >> PairCases_on `v` >> `INJ f (set l UNION domain live2) UNIV` by metis_tac [check_partial_col_success_INJ] >> `set l UNION domain live1 SUBSET set l UNION domain live2` by fs [SUBSET_DEF] >> `INJ f (set l UNION domain live1) UNIV` by metis_tac [INJ_SUBSET, UNIV_SUBSET] >> metis_tac [check_partial_col_success] -); +QED -Theorem numset_list_delete_IMAGE - `!f l live flive v. +Theorem numset_list_delete_IMAGE: + !f l live flive v. domain flive = IMAGE f (domain live) ==> INJ f (domain live) UNIV ==> check_partial_col f l live flive = SOME v ==> - domain (numset_list_delete (MAP f l) flive) = IMAGE f (domain (numset_list_delete l live))` - - (rw [] >> + domain (numset_list_delete (MAP f l) flive) = IMAGE f (domain (numset_list_delete l live)) +Proof + rw [] >> PairCases_on `v` >> `INJ f (set l UNION domain live) UNIV` by metis_tac [check_partial_col_success_INJ] >> rw [domain_numset_list_delete, EXTENSION] >> @@ -185,81 +190,81 @@ Theorem numset_list_delete_IMAGE CCONTR_TAC >> fs [MEM_MAP, INJ_IFF] >> metis_tac [] ) -); +QED -Theorem check_partial_col_IMAGE ` - !f l live flive live' flive'. +Theorem check_partial_col_IMAGE: + !f l live flive live' flive'. (domain flive) = IMAGE f (domain live) ==> check_partial_col f l live flive = SOME (live', flive') ==> (domain flive') = IMAGE f (domain live') - ` - - (Induct_on `l` >> +Proof + Induct_on `l` >> fs [check_partial_col_def] >> rw [] >> Cases_on`lookup h live` >> Cases_on`lookup (f h) flive` >> fs [] >> `domain (insert (f h) () flive) = IMAGE f (domain (insert h () live))` by rw [domain_insert] >> metis_tac [] -); - -Theorem branch_domain ` - !(live1 : num_set) (live2 : num_set). - set (MAP FST (toAList (difference live2 live1))) UNION domain live1 = domain live1 UNION domain live2` +QED - (`!(live1 : num_set) (live2 : num_set). set (MAP FST (toAList (difference live2 live1))) = domain (difference live2 live1)` by rw [EXTENSION, MEM_MAP, MEM_toAList, EXISTS_PROD, domain_lookup] >> +Theorem branch_domain: + !(live1 : num_set) (live2 : num_set). + set (MAP FST (toAList (difference live2 live1))) UNION domain live1 = domain live1 UNION domain live2 +Proof + `!(live1 : num_set) (live2 : num_set). set (MAP FST (toAList (difference live2 live1))) = domain (difference live2 live1)` by rw [EXTENSION, MEM_MAP, MEM_toAList, EXISTS_PROD, domain_lookup] >> `!(s : num -> bool) (t : num -> bool). t DIFF s UNION s = s UNION t` by (rw [EXTENSION] >> Cases_on `x IN t` >> rw []) >> rw [domain_difference] -); +QED -Theorem check_partial_col_branch_domain ` - !(live1 : num_set) (live2 : num_set) flive1 liveout fliveout. +Theorem check_partial_col_branch_domain: + !(live1 : num_set) (live2 : num_set) flive1 liveout fliveout. check_partial_col f (MAP FST (toAList (difference live2 live1))) live1 flive1 = SOME (liveout, fliveout) ==> - domain liveout = domain live1 UNION domain live2` - (metis_tac [branch_domain, check_partial_col_domain, FST] -); + domain liveout = domain live1 UNION domain live2 +Proof + metis_tac [branch_domain, check_partial_col_domain, FST] +QED -Theorem check_partial_col_branch_comm - `!f live1 flive1 live2 flive2 a b. +Theorem check_partial_col_branch_comm: + !f live1 flive1 live2 flive2 a b. INJ f (domain live1) UNIV ==> domain flive1 = IMAGE f (domain live1) /\ domain flive2 = IMAGE f (domain live2) ==> check_partial_col f (MAP FST (toAList (difference live2 live1))) live1 flive1 = SOME (a, b) ==> - ?c d. check_partial_col f (MAP FST (toAList (difference live1 live2))) live2 flive2 = SOME (c, d)` - - (rw [] >> + ?c d. check_partial_col f (MAP FST (toAList (difference live1 live2))) live2 flive2 = SOME (c, d) +Proof + rw [] >> `domain a = domain live1 UNION domain live2` by metis_tac [check_partial_col_domain, branch_domain, FST] >> `INJ f (domain live1 UNION domain live2) UNIV` by metis_tac [check_partial_col_success_INJ] >> `set (MAP FST (toAList (difference live1 live2))) UNION domain live2 = domain live1 UNION domain live2` by metis_tac [UNION_COMM, domain_difference, branch_domain] >> metis_tac [check_partial_col_success] -); +QED -Theorem check_partial_col_list_monotone - `!f live flive (s1 : num_set) (s2 : num_set) a b. +Theorem check_partial_col_list_monotone: + !f live flive (s1 : num_set) (s2 : num_set) a b. domain flive = IMAGE f (domain live) ==> INJ f (domain live) UNIV ==> domain s1 SUBSET domain s2 ==> check_partial_col f (MAP FST (toAList s2)) live flive= SOME (a, b) ==> - ?c d. check_partial_col f (MAP FST (toAList s1)) live flive = SOME (c, d)` - - (rw [] >> + ?c d. check_partial_col f (MAP FST (toAList s1)) live flive = SOME (c, d) +Proof + rw [] >> `!(s : num_set). set (MAP FST (toAList s)) = domain s` by rw [EXTENSION, MEM_MAP, MEM_toAList, EXISTS_PROD, domain_lookup] >> `INJ f (domain a) UNIV` by metis_tac [check_partial_col_success_INJ] >> `domain a = (domain s2 UNION domain live)` by metis_tac [check_partial_col_domain, FST] >> `domain s1 UNION domain live SUBSET domain a` by fs [SUBSET_DEF] >> `INJ f (domain s1 UNION domain live) UNIV` by metis_tac [INJ_SUBSET, UNIV_SUBSET] >> metis_tac [check_partial_col_success] -); +QED -Theorem check_live_tree_success ` - !lt live flive live' flive' f. +Theorem check_live_tree_success: + !lt live flive live' flive' f. domain flive = IMAGE f (domain live) /\ INJ f (domain live) UNIV /\ check_live_tree f lt live flive = SOME (live',flive') ==> domain flive' = IMAGE f (domain live') /\ - INJ f (domain live') UNIV` - - (Induct_on `lt` + INJ f (domain live') UNIV +Proof + Induct_on `lt` (* Writes *) THEN1 ( @@ -300,21 +305,23 @@ Theorem check_live_tree_success ` `INJ f (domain livein2) UNIV` by metis_tac [] >> metis_tac [] ) -); +QED -Theorem ALL_DISTINCT_INJ_MAP - `!f l. ALL_DISTINCT (MAP f l) ==> INJ f (set l) UNIV` - (Induct_on `l` >> rw [INJ_INSERT] >> +Theorem ALL_DISTINCT_INJ_MAP: + !f l. ALL_DISTINCT (MAP f l) ==> INJ f (set l) UNIV +Proof + Induct_on `l` >> rw [INJ_INSERT] >> `MEM (f y) (MAP f l)` by metis_tac [MEM_MAP] >> `~(MEM (f y) (MAP f l))` by metis_tac [] -); +QED -Theorem check_col_output - `!f live live' flive'. +Theorem check_col_output: + !f live live' flive'. check_col f live = SOME (live', flive') ==> domain flive' = IMAGE f (domain live') /\ - INJ f (domain live') UNIV` - (rw [check_col_def] + INJ f (domain live') UNIV +Proof + rw [check_col_def] THEN1 ( rw [EXTENSION, domain_fromAList, MEM_MAP] >> rw [MEM_toAList, EXISTS_PROD, domain_lookup, PULL_EXISTS] @@ -324,31 +331,31 @@ Theorem check_col_output `set (MAP FST (toAList live)) = domain live` by rw [EXTENSION, MEM_MAP, MEM_toAList, EXISTS_PROD, domain_lookup] >> metis_tac [] ) -); +QED -Theorem check_col_success - `!f live. +Theorem check_col_success: + !f live. INJ f (domain live) UNIV ==> - ?flive. check_col f live = SOME (live, flive)` - - (rw [check_col_def] >> + ?flive. check_col f live = SOME (live, flive) +Proof + rw [check_col_def] >> sg `!x y. MEM x (MAP FST (toAList live)) /\ MEM y (MAP FST (toAList live)) /\ (f x = f y) ==> (x = y)` THEN1 ( rw [MEM_toAList, MEM_MAP, EXISTS_PROD] >> `x IN domain live /\ y IN domain live` by rw [domain_lookup] >> fs [INJ_DEF] ) >> metis_tac [ALL_DISTINCT_MAP_INJ, MAP_MAP_o, ALL_DISTINCT_MAP_FST_toAList] -); +QED -Theorem check_clash_tree_output ` - !f ct live flive livein flivein. +Theorem check_clash_tree_output: + !f ct live flive livein flivein. domain flive = IMAGE f (domain live) /\ INJ f (domain live) UNIV /\ check_clash_tree f ct live flive = SOME (livein, flivein) ==> domain flivein = IMAGE f (domain livein) /\ - INJ f (domain livein) UNIV` - - (Induct_on `ct` >> + INJ f (domain livein) UNIV +Proof + Induct_on `ct` >> simp [check_clash_tree_def] (* Delta *) @@ -387,19 +394,18 @@ Theorem check_clash_tree_output ` `domain ft2_out = IMAGE f (domain t2_out) /\ INJ f (domain t2_out) UNIV` by metis_tac [] >> metis_tac [] ) -); +QED -Theorem get_live_tree_correct_lemma - `!f live flive live' flive' ct livein' flivein'. +Theorem get_live_tree_correct_lemma: + !f live flive live' flive' ct livein' flivein'. IMAGE f (domain live) = domain flive /\ IMAGE f (domain live') = domain flive' ==> INJ f (domain live') UNIV ==> domain live SUBSET domain live' ==> check_live_tree f (get_live_tree ct) live' flive' = SOME (livein', flivein') ==> ?livein flivein. check_clash_tree f ct live flive = SOME (livein, flivein) /\ domain livein SUBSET domain livein' - ` - - (Induct_on `ct` +Proof + Induct_on `ct` (* Delta *) THEN1 ( @@ -506,32 +512,32 @@ Theorem get_live_tree_correct_lemma `INJ f (domain livein2) UNIV` by metis_tac [check_live_tree_success] >> metis_tac [] ) -); +QED -Theorem get_live_tree_correct - `!f live flive ct livein flivein. +Theorem get_live_tree_correct: + !f live flive ct livein flivein. IMAGE f (domain live) = domain flive ==> INJ f (domain live) UNIV ==> check_live_tree f (get_live_tree ct) live flive = SOME (livein, flivein) ==> ?livein' flivein'. check_clash_tree f ct live flive = SOME (livein', flivein') - ` - (metis_tac [get_live_tree_correct_lemma, SUBSET_REFL] -); +Proof + metis_tac [get_live_tree_correct_lemma, SUBSET_REFL] +QED -Theorem get_live_tree_correct_LN - `!f ct livein flivein. +Theorem get_live_tree_correct_LN: + !f ct livein flivein. check_live_tree f (get_live_tree ct) LN LN = SOME (livein, flivein) ==> ?livein' flivein'. check_clash_tree f ct LN LN = SOME (livein', flivein') - ` - (rw [get_live_tree_correct] -); +Proof + rw [get_live_tree_correct] +QED -Theorem check_partial_col_numset_list_insert - `!f l live flive liveout fliveout. +Theorem check_partial_col_numset_list_insert: + !f l live flive liveout fliveout. check_partial_col f l live flive = SOME (liveout, fliveout) ==> - liveout = numset_list_insert l live` - - (Induct_on `l` >> + liveout = numset_list_insert l live +Proof + Induct_on `l` >> rw [numset_list_insert_def, check_partial_col_def] >> Cases_on `lookup h live` >> fs [] THEN1 ( @@ -542,14 +548,14 @@ Theorem check_partial_col_numset_list_insert `live = insert h () live` by rw [lookup_insert_id] >> metis_tac [] ) -); +QED -Theorem check_live_tree_eq_get_live_backward - `!f lt live flive liveout fliveout. +Theorem check_live_tree_eq_get_live_backward: + !f lt live flive liveout fliveout. check_live_tree f lt live flive = SOME (liveout, fliveout) ==> - liveout = get_live_backward lt live` - - (Induct_on `lt` >> + liveout = get_live_backward lt live +Proof + Induct_on `lt` >> rw [check_live_tree_def, get_live_backward_def] (* Writes *) THEN1 ( @@ -571,48 +577,50 @@ Theorem check_live_tree_eq_get_live_backward res_tac >> metis_tac [] ) -); +QED -Theorem fix_domination_fixes_domination - `!lt. domain (get_live_backward (fix_domination lt) LN) = EMPTY` - (rw [get_live_backward_def, fix_domination_def, domain_numset_list_delete] >> +Theorem fix_domination_fixes_domination: + !lt. domain (get_live_backward (fix_domination lt) LN) = EMPTY +Proof + rw [get_live_backward_def, fix_domination_def, domain_numset_list_delete] >> rw [EXTENSION, MEM_MAP, MEM_toAList, EXISTS_PROD, domain_lookup] -); +QED -Theorem fix_domination_check_live_tree - `!f lt liveout fliveout. +Theorem fix_domination_check_live_tree: + !f lt liveout fliveout. check_live_tree f (fix_domination lt) LN LN = SOME (liveout, fliveout) ==> - ?liveout' fliveout'. check_live_tree f lt LN LN = SOME (liveout', fliveout')` - - (rw [check_live_tree_def, fix_domination_def] >> + ?liveout' fliveout'. check_live_tree f lt LN LN = SOME (liveout', fliveout') +Proof + rw [check_live_tree_def, fix_domination_def] >> Cases_on `check_live_tree f lt LN LN` >> fs [] >> Cases_on `x` >> fs [] -); +QED -Theorem size_of_live_tree_positive - `!lt. 0 <= size_of_live_tree lt` - (Induct_on `lt` >> rw [size_of_live_tree_def] -); +Theorem size_of_live_tree_positive: + !lt. 0 <= size_of_live_tree lt +Proof + Induct_on `lt` >> rw [size_of_live_tree_def] +QED -Theorem check_number_property_strong_monotone_weak - `!P Q lt n live. +Theorem check_number_property_strong_monotone_weak: + !P Q lt n live. (!n' live'. P n' live' ==> Q n' live') /\ check_number_property_strong P lt n live ==> - check_number_property_strong Q lt n live` - - (Induct_on `lt` >> + check_number_property_strong Q lt n live +Proof + Induct_on `lt` >> rw [check_number_property_strong_def] >> res_tac >> simp [] -); +QED -Theorem check_number_property_strong_monotone - `!P Q lt n live. +Theorem check_number_property_strong_monotone: + !P Q lt n live. (!n' live'. (n - size_of_live_tree lt) <= n' /\ P n' live' ==> Q n' live') /\ check_number_property_strong P lt n live ==> - check_number_property_strong Q lt n live` - - (Induct_on `lt` >> + check_number_property_strong Q lt n live +Proof + Induct_on `lt` >> simp [check_number_property_strong_def, size_of_live_tree_def] (* Branch & Seq *) >> ( @@ -635,35 +643,35 @@ Theorem check_number_property_strong_monotone metis_tac [] ) ) -); +QED -Theorem check_number_property_strong_end - `!P lt n live. +Theorem check_number_property_strong_end: + !P lt n live. check_number_property_strong P lt n live ==> - P (n - size_of_live_tree lt) (get_live_backward lt live)` - - (Induct_on `lt` >> + P (n - size_of_live_tree lt) (get_live_backward lt live) +Proof + Induct_on `lt` >> rw [check_number_property_strong_def, get_live_backward_def, size_of_live_tree_def] >> (* Seq *) res_tac >> `n - size_of_live_tree lt' - size_of_live_tree lt = n - (size_of_live_tree lt + size_of_live_tree lt')` by intLib.COOPER_TAC >> metis_tac [] -); +QED -Theorem check_number_property_monotone_weak - `!P Q lt n live. +Theorem check_number_property_monotone_weak: + !P Q lt n live. (!n' live'. P n' live' ==> Q n' live') /\ check_number_property P lt n live ==> - check_number_property Q lt n live` - - (Induct_on `lt` >> + check_number_property Q lt n live +Proof + Induct_on `lt` >> rw [check_number_property_def] >> res_tac >> simp [] -); +QED -Theorem lookup_numset_list_add_if - `!r l v s. +Theorem lookup_numset_list_add_if: + !r l v s. lookup r (numset_list_add_if l v s P) = if MEM r l then case lookup r s of @@ -674,9 +682,8 @@ Theorem lookup_numset_list_add_if SOME v else lookup r s - ` - - (Induct_on `l` >> +Proof + Induct_on `l` >> simp [numset_list_add_if_def] >> rpt gen_tac >> Cases_on `lookup h s` >> fs [] @@ -690,11 +697,11 @@ Theorem lookup_numset_list_add_if ) >> Cases_on `P v x` >> fs [] >> simp [lookup_insert] -); +QED -Theorem lookup_numset_list_add_if_lt - `!r l v s. +Theorem lookup_numset_list_add_if_lt: + !r l v s. lookup r (numset_list_add_if_lt l v s) = if MEM r l then case lookup r s of @@ -705,13 +712,13 @@ Theorem lookup_numset_list_add_if_lt SOME v else lookup r s - ` - (simp [numset_list_add_if_lt_def] >> +Proof + simp [numset_list_add_if_lt_def] >> rw [lookup_numset_list_add_if] -); +QED -Theorem lookup_numset_list_add_if_gt - `!r l v s. +Theorem lookup_numset_list_add_if_gt: + !r l v s. lookup r (numset_list_add_if_gt l v s) = if MEM r l then case lookup r s of @@ -722,14 +729,15 @@ Theorem lookup_numset_list_add_if_gt SOME v else lookup r s - ` - (simp [numset_list_add_if_gt_def] >> +Proof + simp [numset_list_add_if_gt_def] >> rw [lookup_numset_list_add_if] -); +QED -Theorem domain_numset_list_add_if - `!l v s P. domain (numset_list_add_if l v s P) = set l UNION domain s` - (Induct_on `l` >> +Theorem domain_numset_list_add_if: + !l v s P. domain (numset_list_add_if l v s P) = set l UNION domain s +Proof + Induct_on `l` >> rw [numset_list_add_if_def] >> Cases_on `lookup h s` THEN1 ( @@ -741,58 +749,61 @@ Theorem domain_numset_list_add_if rw [EXTENSION] >> metis_tac [] ) -); +QED -Theorem domain_numset_list_add_if_lt - `!l v s. domain (numset_list_add_if_lt l v s) = set l UNION domain s` - (rw [numset_list_add_if_lt_def, domain_numset_list_add_if] -); +Theorem domain_numset_list_add_if_lt: + !l v s. domain (numset_list_add_if_lt l v s) = set l UNION domain s +Proof + rw [numset_list_add_if_lt_def, domain_numset_list_add_if] +QED -Theorem domain_numset_list_add_if_gt - `!l v s. domain (numset_list_add_if_gt l v s) = set l UNION domain s` - (rw [numset_list_add_if_gt_def, domain_numset_list_add_if] -); +Theorem domain_numset_list_add_if_gt: + !l v s. domain (numset_list_add_if_gt l v s) = set l UNION domain s +Proof + rw [numset_list_add_if_gt_def, domain_numset_list_add_if] +QED -Theorem lookup_numset_list_delete - `!l s x. lookup x (numset_list_delete l s) = if MEM x l then NONE else lookup x s` - (Induct_on `l` >> +Theorem lookup_numset_list_delete: + !l s x. lookup x (numset_list_delete l s) = if MEM x l then NONE else lookup x s +Proof + Induct_on `l` >> rw [numset_list_delete_def, lookup_delete] >> fs [] -); +QED -Theorem get_intervals_nout - `!lt n_in beg_in end_in n_out beg_out end_out. +Theorem get_intervals_nout: + !lt n_in beg_in end_in n_out beg_out end_out. (n_out, beg_out, end_out) = get_intervals lt n_in beg_in end_in ==> - n_out = n_in - (size_of_live_tree lt)` - - (Induct_on `lt` >> + n_out = n_in - (size_of_live_tree lt) +Proof + Induct_on `lt` >> rw [get_intervals_def, size_of_live_tree_def] >> rpt (pairarg_tac >> fs []) >> `n_out = n2 - (size_of_live_tree lt)` by metis_tac [] >> `n2 = n_in - (size_of_live_tree lt')` by metis_tac [] >> intLib.COOPER_TAC -); +QED -Theorem get_intervals_withlive_nout - `!lt n_in beg_in end_in n_out beg_out end_out live. +Theorem get_intervals_withlive_nout: + !lt n_in beg_in end_in n_out beg_out end_out live. (n_out, beg_out, end_out) = get_intervals_withlive lt n_in beg_in end_in live ==> - n_out = n_in - (size_of_live_tree lt)` - - (Induct_on `lt` >> + n_out = n_in - (size_of_live_tree lt) +Proof + Induct_on `lt` >> rw [get_intervals_withlive_def, size_of_live_tree_def] >> rpt (pairarg_tac >> fs []) >> `n_out = n2 - (size_of_live_tree lt)` by metis_tac [] >> `n2 = n_in - (size_of_live_tree lt')` by metis_tac [] >> rveq >> intLib.COOPER_TAC -); +QED -Theorem get_intervals_intend_augment - `!lt n_in beg_in end_in n_out beg_out end_out. +Theorem get_intervals_intend_augment: + !lt n_in beg_in end_in n_out beg_out end_out. (n_out, beg_out, end_out) = get_intervals lt n_in beg_in end_in ==> - !r v. lookup r end_in = SOME v ==> (?v'. lookup r end_out = SOME v' /\ v <= v')` - - (Induct_on `lt` >> + !r v. lookup r end_in = SOME v ==> (?v'. lookup r end_out = SOME v' /\ v <= v') +Proof + Induct_on `lt` >> rw [get_intervals_def] (* Writes *) THEN1 ( @@ -808,14 +819,14 @@ Theorem get_intervals_intend_augment `?v''. lookup r end_out = SOME v'' /\ v' <= v''` by metis_tac [] >> rw [] >> intLib.COOPER_TAC -); +QED -Theorem check_number_property_intend - `!end_out lt n_in live_in. +Theorem check_number_property_intend: + !end_out lt n_in live_in. check_number_property (\n (live : num_set). !r. r IN domain live ==> ?v. lookup r end_out = SOME v /\ n+1 <= v) lt n_in live_in ==> - !r. r IN domain (get_live_backward lt live_in) ==> ?v. lookup r end_out = SOME v /\ n_in-(size_of_live_tree lt) <= v` - - (Induct_on `lt` >> + !r. r IN domain (get_live_backward lt live_in) ==> ?v. lookup r end_out = SOME v /\ n_in-(size_of_live_tree lt) <= v +Proof + Induct_on `lt` >> rw [check_number_property_def, get_live_backward_def, size_of_live_tree_def] (* Writes *) THEN1 ( @@ -841,15 +852,15 @@ Theorem check_number_property_intend res_tac >> rw [] >> intLib.COOPER_TAC ) -); +QED -Theorem get_intervals_live_less_end - `!lt n_in beg_in end_in live_in n_out beg_out end_out. +Theorem get_intervals_live_less_end: + !lt n_in beg_in end_in live_in n_out beg_out end_out. (n_out, beg_out, end_out) = get_intervals lt n_in beg_in end_in /\ (!r. r IN domain live_in ==> ?v. lookup r end_in = SOME v /\ n_in <= v) ==> - check_number_property (\n (live : num_set). !r. r IN domain live ==> ?v. lookup r end_out = SOME v /\ n+1 <= v) lt n_in live_in` - - (Induct_on `lt` >> + check_number_property (\n (live : num_set). !r. r IN domain live ==> ?v. lookup r end_out = SOME v /\ n+1 <= v) lt n_in live_in +Proof + Induct_on `lt` >> simp [get_intervals_def, check_number_property_def] >> rpt gen_tac >> strip_tac >> rveq (* Writes *) @@ -898,16 +909,16 @@ Theorem get_intervals_live_less_end `!r. r IN domain (get_live_backward lt' live_in) ==> ?v. lookup r int_end2 = SOME v /\ n_in - size_of_live_tree lt' <= v` by metis_tac [check_number_property_intend] >> metis_tac [] ) -); +QED -Theorem get_intervals_withlive_intbeg_reduce - `!lt n_in beg_in end_in n_out beg_out end_out live. +Theorem get_intervals_withlive_intbeg_reduce: + !lt n_in beg_in end_in n_out beg_out end_out live. (n_out, beg_out, end_out) = get_intervals_withlive lt n_in beg_in end_in live /\ (!r v. lookup r beg_in = SOME v ==> n_in <= v) ==> (!r. option_CASE (lookup r beg_out) n_out (\x.x) <= option_CASE (lookup r beg_in) n_in (\x.x)) /\ - (!r v. lookup r beg_out = SOME v ==> n_out <= v)` - - (Induct_on `lt` >> + (!r v. lookup r beg_out = SOME v ==> n_out <= v) +Proof + Induct_on `lt` >> simp [get_intervals_withlive_def] >> rpt gen_tac >> strip_tac (* Writes *) @@ -982,23 +993,24 @@ Theorem get_intervals_withlive_intbeg_reduce ) THEN1 res_tac ) -); +QED -Theorem get_intervals_withlive_intbeg_nout - `!lt n_in beg_in end_in n_out beg_out end_out live. +Theorem get_intervals_withlive_intbeg_nout: + !lt n_in beg_in end_in n_out beg_out end_out live. (n_out, beg_out, end_out) = get_intervals_withlive lt n_in beg_in end_in live /\ (!r v. lookup r beg_in = SOME v ==> n_in <= v) ==> - (!r v. lookup r beg_out = SOME v ==> n_out <= v)` - (metis_tac [get_intervals_withlive_intbeg_reduce] -); + (!r v. lookup r beg_out = SOME v ==> n_out <= v) +Proof + metis_tac [get_intervals_withlive_intbeg_reduce] +QED -Theorem get_intervals_intbeg_nout - `!lt n_in beg_in end_in n_out beg_out end_out. +Theorem get_intervals_intbeg_nout: + !lt n_in beg_in end_in n_out beg_out end_out. (n_out, beg_out, end_out) = get_intervals lt n_in beg_in end_in /\ (!r v. lookup r beg_in = SOME v ==> n_in <= v) ==> - (!r v. lookup r beg_out = SOME v ==> n_out <= v)` - - (Induct_on `lt` >> + (!r v. lookup r beg_out = SOME v ==> n_out <= v) +Proof + Induct_on `lt` >> rw [get_intervals_def] (* Writes *) THEN1 ( @@ -1018,16 +1030,16 @@ Theorem get_intervals_intbeg_nout `!r v. lookup r int_beg2 = SOME v ==> n2 <= v` by metis_tac [] >> `!r v. lookup r beg_out = SOME v ==> n_out <= v` by metis_tac [] >> res_tac -); +QED -Theorem get_intervals_withlive_live_intbeg - `!lt n_in beg_in end_in live n_out beg_out end_out. +Theorem get_intervals_withlive_live_intbeg: + !lt n_in beg_in end_in live n_out beg_out end_out. (n_out, beg_out, end_out) = get_intervals_withlive lt n_in beg_in end_in live /\ (!r. r IN domain live ==> r NOTIN domain beg_in) ==> - (!r. r IN domain (get_live_backward lt live) ==> r NOTIN domain beg_out)` - - (Induct_on `lt` >> + (!r. r IN domain (get_live_backward lt live) ==> r NOTIN domain beg_out) +Proof + Induct_on `lt` >> rw [get_intervals_withlive_def, get_live_backward_def] (* Writes *) THEN1 fs [domain_numset_list_delete, domain_numset_list_add_if_lt] @@ -1049,16 +1061,16 @@ Theorem get_intervals_withlive_live_intbeg res_tac >> metis_tac [] ) -); +QED -Theorem get_intervals_withlive_beg_less_live - `!lt n_in beg_in end_in live_in n_out beg_out end_out. +Theorem get_intervals_withlive_beg_less_live: + !lt n_in beg_in end_in live_in n_out beg_out end_out. (n_out, beg_out, end_out) = get_intervals_withlive lt n_in beg_in end_in live_in /\ (!r v. lookup r beg_in = SOME v ==> n_in <= v) /\ (!r. r IN domain live_in ==> r NOTIN domain beg_in) ==> - check_number_property_strong (\n (live : num_set). !r. r IN domain live ==> option_CASE (lookup r beg_out) n_out (\x.x) <= n) lt n_in live_in` - - (Induct_on `lt` >> + check_number_property_strong (\n (live : num_set). !r. r IN domain live ==> option_CASE (lookup r beg_out) n_out (\x.x) <= n) lt n_in live_in +Proof + Induct_on `lt` >> simp [get_intervals_withlive_def, get_live_backward_def, check_number_property_strong_def] >> rpt (gen_tac ORELSE disch_tac) (* Writes *) @@ -1182,42 +1194,44 @@ Theorem get_intervals_withlive_beg_less_live metis_tac [] ) ) -); +QED -Theorem get_intervals_withlive_n_eq_get_intervals_n - `!lt n beg end beg' end' n1 beg1 end1 n2 beg2 end2 live. +Theorem get_intervals_withlive_n_eq_get_intervals_n: + !lt n beg end beg' end' n1 beg1 end1 n2 beg2 end2 live. (n1, beg1, end1) = get_intervals lt n beg end /\ (n2, beg2, end2) = get_intervals_withlive lt n beg' end' live ==> - n1 = n2` - (Induct_on `lt` >> + n1 = n2 +Proof + Induct_on `lt` >> rw [get_intervals_def, get_intervals_withlive_def] >> rpt (pairarg_tac >> fs []) >> metis_tac [] -); +QED -Theorem get_intervals_withlive_end_eq_get_intervals_end - `!lt n beg beg' end n1 beg1 end1 n2 beg2 end2 live. +Theorem get_intervals_withlive_end_eq_get_intervals_end: + !lt n beg beg' end n1 beg1 end1 n2 beg2 end2 live. (n1, beg1, end1) = get_intervals lt n beg end /\ (n2, beg2, end2) = get_intervals_withlive lt n beg' end live ==> - end1 = end2` - (Induct_on `lt` >> + end1 = end2 +Proof + Induct_on `lt` >> rw [get_intervals_def, get_intervals_withlive_def] >> rpt (pairarg_tac >> fs []) >> `n2' = n2''` by metis_tac [get_intervals_withlive_n_eq_get_intervals_n] >> rveq >> metis_tac [] -); +QED -Theorem get_intervals_withlive_beg_eq_get_intervals_beg_when_some - `!lt n beg beg' end n1 beg1 end1 n2 beg2 end2 live. +Theorem get_intervals_withlive_beg_eq_get_intervals_beg_when_some: + !lt n beg beg' end n1 beg1 end1 n2 beg2 end2 live. (n1, beg1, end1) = get_intervals lt n beg end /\ (n2, beg2, end2) = get_intervals_withlive lt n beg' end live /\ (!r v. lookup r beg = SOME v ==> n <= v) /\ (!r v. lookup r beg' = SOME v ==> n <= v) /\ (!r v1 v2. lookup r beg = SOME v1 /\ lookup r beg' = SOME v2 ==> v1 = v2) ==> - !r v1 v2. lookup r beg1 = SOME v1 /\ lookup r beg2 = SOME v2 ==> v1 = v2` - - (Induct_on `lt` >> + !r v1 v2. lookup r beg1 = SOME v1 /\ lookup r beg2 = SOME v2 ==> v1 = v2 +Proof + Induct_on `lt` >> REWRITE_TAC [get_intervals_def, get_intervals_withlive_def, LET_THM] >> rpt gen_tac >> strip_tac (* Writes *) @@ -1272,16 +1286,16 @@ Theorem get_intervals_withlive_beg_eq_get_intervals_beg_when_some res_tac >> metis_tac [] ) -); +QED -Theorem get_intervals_withlive_beg_subset_get_intervals_beg - `!lt n beg_in1 beg_in2 end n1 beg_out1 end1 n2 beg_out2 end2 live. +Theorem get_intervals_withlive_beg_subset_get_intervals_beg: + !lt n beg_in1 beg_in2 end n1 beg_out1 end1 n2 beg_out2 end2 live. (n1, beg_out1, end1) = get_intervals_withlive lt n beg_in1 end live /\ (n2, beg_out2, end2) = get_intervals lt n beg_in2 end /\ domain beg_in1 SUBSET domain beg_in2 ==> - domain beg_out1 SUBSET domain beg_out2` - - (Induct_on `lt` >> + domain beg_out1 SUBSET domain beg_out2 +Proof + Induct_on `lt` >> rw [get_intervals_withlive_def, get_intervals_def] (* Writes *) THEN1 ( @@ -1312,14 +1326,14 @@ Theorem get_intervals_withlive_beg_subset_get_intervals_beg THEN1 ( metis_tac [] ) -); +QED -Theorem get_intervals_beg_subset_registers - `!lt n_in beg_in end_in n_out beg_out end_out. +Theorem get_intervals_beg_subset_registers: + !lt n_in beg_in end_in n_out beg_out end_out. (n_out, beg_out, end_out) = get_intervals lt n_in beg_in end_in ==> - domain beg_out SUBSET (domain beg_in UNION (live_tree_registers lt))` - - (Induct_on `lt` >> + domain beg_out SUBSET (domain beg_in UNION (live_tree_registers lt)) +Proof + Induct_on `lt` >> rw [get_intervals_def, live_tree_registers_def] THEN1 rw [domain_numset_list_add_if_lt] >> @@ -1328,17 +1342,17 @@ Theorem get_intervals_beg_subset_registers `domain beg_out SUBSET (domain int_beg2 UNION (live_tree_registers lt))` by metis_tac [] >> fs [SUBSET_DEF] >> metis_tac [] -); +QED (* This theorem looks like lipschitz continuity: it says something like f(x+y) <= f(x)+y *) -Theorem get_intervals_withlive_beg_lipschitz - `!lt n1 beg1 end1 live n2 beg2 end2 (s : int num_map) nout1 begout1 endout1 nout2 begout2 endout2. +Theorem get_intervals_withlive_beg_lipschitz: + !lt n1 beg1 end1 live n2 beg2 end2 (s : int num_map) nout1 begout1 endout1 nout2 begout2 endout2. (nout1, begout1, endout1) = get_intervals_withlive lt n1 beg1 end1 live /\ (nout2, begout2, endout2) = get_intervals_withlive lt n2 beg2 end2 live /\ domain beg2 SUBSET domain beg1 UNION domain s ==> - domain begout2 SUBSET domain begout1 UNION domain s` - - (Induct_on `lt` >> + domain begout2 SUBSET domain begout1 UNION domain s +Proof + Induct_on `lt` >> rw [get_intervals_withlive_def] (* Writes *) THEN1 ( @@ -1365,15 +1379,15 @@ Theorem get_intervals_withlive_beg_lipschitz `domain int_beg2 SUBSET domain int_beg2' UNION domain s` by metis_tac [] >> metis_tac [] ) -); +QED -Theorem get_intervals_withlive_registers_subset_beg - `!lt n_in beg_in end_in n_out beg_out end_out live_in. +Theorem get_intervals_withlive_registers_subset_beg: + !lt n_in beg_in end_in n_out beg_out end_out live_in. domain end_in SUBSET domain beg_in UNION domain live_in /\ (n_out, beg_out, end_out) = get_intervals_withlive lt n_in beg_in end_in live_in ==> - domain end_out SUBSET domain beg_out UNION domain (get_live_backward lt live_in)` - - (Induct_on `lt` >> + domain end_out SUBSET domain beg_out UNION domain (get_live_backward lt live_in) +Proof + Induct_on `lt` >> rw [get_intervals_withlive_def, get_live_backward_def] (* Writes *) @@ -1426,14 +1440,14 @@ Theorem get_intervals_withlive_registers_subset_beg `domain int_end2 SUBSET domain int_beg2 UNION domain (get_live_backward lt' live_in)` by metis_tac [] >> metis_tac [] ) -); +QED -Theorem get_intervals_withlive_live_tree_registers_subset_endout - `!lt n_in beg_in end_in live_in n_out beg_out end_out. +Theorem get_intervals_withlive_live_tree_registers_subset_endout: + !lt n_in beg_in end_in live_in n_out beg_out end_out. (n_out, beg_out, end_out) = get_intervals_withlive lt n_in beg_in end_in live_in ==> - domain end_in UNION live_tree_registers lt SUBSET domain end_out` - - (Induct_on `lt` >> + domain end_in UNION live_tree_registers lt SUBSET domain end_out +Proof + Induct_on `lt` >> simp [get_intervals_withlive_def, live_tree_registers_def] >> rpt (gen_tac ORELSE disch_tac) (* Writes *) @@ -1459,15 +1473,15 @@ Theorem get_intervals_withlive_live_tree_registers_subset_endout `domain int_end2 UNION live_tree_registers lt SUBSET domain int_end1` by metis_tac [] >> fs [SUBSET_DEF] ) -); +QED -Theorem get_intervals_domain_eq_live_tree_registers - `!lt n beg end. +Theorem get_intervals_domain_eq_live_tree_registers: + !lt n beg end. (n, beg, end) = get_intervals (fix_domination lt) 0 LN LN ==> domain beg = live_tree_registers (fix_domination lt) /\ - domain end = live_tree_registers (fix_domination lt)` - - (rpt (gen_tac ORELSE disch_tac) >> + domain end = live_tree_registers (fix_domination lt) +Proof + rpt (gen_tac ORELSE disch_tac) >> `domain (get_live_backward (fix_domination lt) LN) = EMPTY` by rw [fix_domination_fixes_domination] >> sg `?n' beg' end'. (n', beg', end') = get_intervals_withlive (fix_domination lt) 0 LN LN LN` THEN1 ( `?x. x = get_intervals_withlive (fix_domination lt) 0 LN LN LN` by rw [] >> @@ -1485,15 +1499,15 @@ Theorem get_intervals_domain_eq_live_tree_registers rfs [] >> fs [SUBSET_DEF, EXTENSION] >> rw [] >> eq_tac >> rw [] -); +QED -Theorem get_intervals_withlive_domain_eq_live_tree_registers - `!lt n beg end. +Theorem get_intervals_withlive_domain_eq_live_tree_registers: + !lt n beg end. (n, beg, end) = get_intervals_withlive (fix_domination lt) 0 LN LN LN ==> domain beg = live_tree_registers (fix_domination lt) /\ - domain end = live_tree_registers (fix_domination lt)` - - (rpt (gen_tac ORELSE disch_tac) >> + domain end = live_tree_registers (fix_domination lt) +Proof + rpt (gen_tac ORELSE disch_tac) >> `domain (get_live_backward (fix_domination lt) LN) = EMPTY` by rw [fix_domination_fixes_domination] >> sg `?n' beg' end'. (n', beg', end') = get_intervals (fix_domination lt) 0 LN LN` THEN1 ( `?x. x = get_intervals (fix_domination lt) 0 LN LN` by rw [] >> @@ -1511,15 +1525,15 @@ Theorem get_intervals_withlive_domain_eq_live_tree_registers rfs [] >> fs [SUBSET_DEF, EXTENSION] >> rw [] >> eq_tac >> rw [] -); +QED -Theorem get_intervals_withlive_beg_eq_get_intervals_beg - `!lt n beg end n' beg' end'. +Theorem get_intervals_withlive_beg_eq_get_intervals_beg: + !lt n beg end n' beg' end'. (n, beg, end) = get_intervals_withlive (fix_domination lt) 0 LN LN LN /\ (n', beg', end') = get_intervals (fix_domination lt) 0 LN LN ==> - !(r:num). lookup r beg = lookup r beg'` - - (rw [] >> + !(r:num). lookup r beg = lookup r beg' +Proof + rw [] >> imp_res_tac get_intervals_withlive_domain_eq_live_tree_registers >> imp_res_tac get_intervals_domain_eq_live_tree_registers >> `domain beg = domain beg'` by rw [] >> @@ -1532,14 +1546,14 @@ Theorem get_intervals_withlive_beg_eq_get_intervals_beg THEN1 metis_tac [domain_lookup] THEN1 metis_tac [domain_lookup] THEN1 metis_tac [] -); +QED -Theorem get_intervals_end_increase - `!lt n_in beg_in end_in n_out beg_out end_out. +Theorem get_intervals_end_increase: + !lt n_in beg_in end_in n_out beg_out end_out. (n_out, beg_out, end_out) = get_intervals lt n_in beg_in end_in ==> - domain end_in SUBSET domain end_out` - - (Induct_on `lt` >> + domain end_in SUBSET domain end_out +Proof + Induct_on `lt` >> rw [get_intervals_def] (* Writes *) THEN1 rw [domain_numset_list_add_if_gt] @@ -1551,15 +1565,15 @@ Theorem get_intervals_end_increase `domain end_in SUBSET domain int_end2` by metis_tac [] >> `domain int_end2 SUBSET domain end_out` by metis_tac [] >> fs [SUBSET_DEF] -); +QED -Theorem check_number_property_subset_endout - `!lt n_in beg_in end_in live_in n_out beg_out end_out. +Theorem check_number_property_subset_endout: + !lt n_in beg_in end_in live_in n_out beg_out end_out. (n_out, beg_out, end_out) = get_intervals lt n_in beg_in end_in /\ domain live_in SUBSET domain end_in ==> - check_number_property_strong (\n (live:num_set). domain live SUBSET domain end_out) lt n_in live_in` - - (Induct_on `lt` >> + check_number_property_strong (\n (live:num_set). domain live SUBSET domain end_out) lt n_in live_in +Proof + Induct_on `lt` >> simp [get_intervals_def, check_number_property_strong_def] >> rpt (gen_tac ORELSE disch_tac) @@ -1608,14 +1622,14 @@ Theorem check_number_property_subset_endout imp_res_tac check_number_property_strong_end >> fs [] >> metis_tac [] ) -); +QED -Theorem get_intervals_beg_less_live - `!lt live_in n_out beg_out end_out. +Theorem get_intervals_beg_less_live: + !lt live_in n_out beg_out end_out. (n_out, beg_out, end_out) = get_intervals (fix_domination lt) 0 LN LN ==> - check_number_property_strong (\n (live : num_set). !r. r IN domain live ==> option_CASE (lookup r beg_out) n_out (\x.x) <= n) (fix_domination lt) 0 LN` - - (rw [] >> + check_number_property_strong (\n (live : num_set). !r. r IN domain live ==> option_CASE (lookup r beg_out) n_out (\x.x) <= n) (fix_domination lt) 0 LN +Proof + rw [] >> sg `?n_out' beg_out' end_out'. (n_out', beg_out', end_out') = get_intervals_withlive (fix_domination lt) 0 LN LN LN` THEN1 ( `?x. x = get_intervals_withlive (fix_domination lt) 0 LN LN LN` by rw [] >> PairCases_on `x` >> @@ -1632,16 +1646,16 @@ Theorem get_intervals_beg_less_live qabbrev_tac `P = \n (live : num_set). !r. r IN domain live ==> option_CASE (lookup r beg_out) n_out (\x.x) <= n` >> qabbrev_tac `Q = \n (live : num_set). !r. r IN domain live ==> option_CASE (lookup r beg_out') n_out (\x.x) <= n` >> rw [] -); +QED -Theorem get_intervals_intbeg_reduce - `!lt n_in beg_in end_in n_out beg_out end_out live. +Theorem get_intervals_intbeg_reduce: + !lt n_in beg_in end_in n_out beg_out end_out live. (n_out, beg_out, end_out) = get_intervals lt n_in beg_in end_in /\ (!r v. lookup r beg_in = SOME v ==> n_in <= v) ==> (!r. option_CASE (lookup r beg_out) n_out (\x.x) <= option_CASE (lookup r beg_in) n_in (\x.x)) /\ - (!r v. lookup r beg_out = SOME v ==> n_out <= v)` - - (Induct_on `lt` >> + (!r v. lookup r beg_out = SOME v ==> n_out <= v) +Proof + Induct_on `lt` >> simp [get_intervals_def] >> rpt gen_tac >> strip_tac (* Writes *) @@ -1680,16 +1694,16 @@ Theorem get_intervals_intbeg_reduce fs [] ) ) -); +QED -Theorem check_startlive_prop_monotone - `!lt beg ndef end beg' ndef' end' n_in. +Theorem check_startlive_prop_monotone: + !lt beg ndef end beg' ndef' end' n_in. (!r. option_CASE (lookup r beg') ndef' (\x.x) <= option_CASE (lookup r beg) ndef (\x.x)) /\ (!r v. lookup r end = SOME v ==> (?v'. lookup r end' = SOME v' /\ v <= v')) /\ check_startlive_prop lt n_in beg end ndef ==> - check_startlive_prop lt n_in beg' end' ndef'` - - (Induct_on `lt` >> + check_startlive_prop lt n_in beg' end' ndef' +Proof + Induct_on `lt` >> rw [check_startlive_prop_def] >> ( CASE_TAC ORELSE res_tac >> @@ -1697,16 +1711,16 @@ Theorem check_startlive_prop_monotone rfs [] >> intLib.COOPER_TAC ) -); +QED -Theorem check_startlive_prop_augment_ndef - `!lt n_in beg_out end_out ndef. +Theorem check_startlive_prop_augment_ndef: + !lt n_in beg_out end_out ndef. check_startlive_prop lt n_in beg_out end_out ndef /\ ndef <= ndef' /\ ndef' <= n_in - size_of_live_tree lt==> - check_startlive_prop lt n_in beg_out end_out ndef'` - - (Induct_on `lt` >> + check_startlive_prop lt n_in beg_out end_out ndef' +Proof + Induct_on `lt` >> simp [check_startlive_prop_def, size_of_live_tree_def] >> rpt gen_tac >> strip_tac (* Writes *) @@ -1723,15 +1737,15 @@ Theorem check_startlive_prop_augment_ndef `ndef' <= n_in - size_of_live_tree lt'` by intLib.COOPER_TAC >> metis_tac [] ) -); +QED -Theorem get_intervals_check_startlive_prop - `!lt n_in beg_in end_in n_out beg_out end_out. +Theorem get_intervals_check_startlive_prop: + !lt n_in beg_in end_in n_out beg_out end_out. (n_out, beg_out, end_out) = get_intervals lt n_in beg_in end_in /\ (!r v. lookup r beg_in = SOME v ==> n_in <= v) ==> - check_startlive_prop lt n_in beg_out end_out n_out` - - (Induct_on `lt` >> + check_startlive_prop lt n_in beg_out end_out n_out +Proof + Induct_on `lt` >> simp [get_intervals_def, check_startlive_prop_def] >> rpt (gen_tac ORELSE disch_tac) (* Writes *) @@ -1753,18 +1767,19 @@ Theorem get_intervals_check_startlive_prop rw [] >> metis_tac [check_startlive_prop_monotone] ) -); +QED -Theorem exists_point_inside_interval_interval_intersect - `!l1 r1 l2 r2 v. +Theorem exists_point_inside_interval_interval_intersect: + !l1 r1 l2 r2 v. point_inside_interval (l1, r1) v /\ point_inside_interval (l2, r2) v ==> - interval_intersect (l1, r1) (l2, r2)` - (rw [point_inside_interval_def, interval_intersect_def] >> + interval_intersect (l1, r1) (l2, r2) +Proof + rw [point_inside_interval_def, interval_intersect_def] >> intLib.COOPER_TAC -); +QED -Theorem check_intervals_check_live_tree_lemma - `!lt n_in beg_out end_out f live flive. +Theorem check_intervals_check_live_tree_lemma: + !lt n_in beg_out end_out f live flive. check_startlive_prop lt n_in beg_out end_out (n_in - size_of_live_tree lt) /\ check_number_property_strong (\n (live' : num_set). !r. r IN domain live' ==> option_CASE (lookup r beg_out) n_out (\x.x) <= n) lt n_in live /\ check_number_property (\n (live' : num_set). !r. r IN domain live' ==> ?v. lookup r end_out = SOME v /\ n+1 <= v) lt n_in live /\ @@ -1774,9 +1789,9 @@ Theorem check_intervals_check_live_tree_lemma check_intervals f beg_out end_out /\ domain flive = IMAGE f (domain live) /\ INJ f (domain live) UNIV ==> - ?liveout fliveout. check_live_tree f lt live flive = SOME (liveout, fliveout)` - - (Induct_on `lt` >> + ?liveout fliveout. check_live_tree f lt live flive = SOME (liveout, fliveout) +Proof + Induct_on `lt` >> rw [check_number_property_def, check_number_property_strong_def, check_live_tree_def, check_startlive_prop_def, live_tree_registers_def] (* Writes *) @@ -1915,15 +1930,15 @@ Theorem check_intervals_check_live_tree_lemma ) >> rw [] ) -); +QED -Theorem check_intervals_check_live_tree - `!lt n_out beg_out end_out f. +Theorem check_intervals_check_live_tree: + !lt n_out beg_out end_out f. (n_out, beg_out, end_out) = get_intervals (fix_domination lt) 0 LN LN /\ check_intervals f beg_out end_out ==> - ?liveout fliveout. check_live_tree f (fix_domination lt) LN LN = SOME (liveout, fliveout)` - - (rw [] >> + ?liveout fliveout. check_live_tree f (fix_domination lt) LN LN = SOME (liveout, fliveout) +Proof + rw [] >> imp_res_tac get_intervals_check_startlive_prop >> imp_res_tac get_intervals_beg_less_live >> imp_res_tac get_intervals_live_less_end >> @@ -1937,15 +1952,15 @@ Theorem check_intervals_check_live_tree `INJ f (domain (LN : num_set)) UNIV` by rw [] >> imp_res_tac get_intervals_nout >> metis_tac [check_intervals_check_live_tree_lemma] -); +QED -Theorem get_intervals_ct_aux_live - `!ct n_in beg_in end_in live_in live_in' n_out beg_out end_out live_out. +Theorem get_intervals_ct_aux_live: + !ct n_in beg_in end_in live_in live_in' n_out beg_out end_out live_out. domain live_in = domain live_in' /\ (n_out, beg_out, end_out, live_out) = get_intervals_ct_aux ct n_in beg_in end_in live_in ==> - domain live_out = domain (get_live_backward (get_live_tree ct) live_in')` - - (Induct_on `ct` >> + domain live_out = domain (get_live_backward (get_live_tree ct) live_in') +Proof + Induct_on `ct` >> rw [get_live_backward_def, get_intervals_ct_aux_def, get_live_tree_def] THEN1 rw [domain_numset_list_insert, domain_numset_list_delete] THEN1 ( @@ -1964,14 +1979,14 @@ Theorem get_intervals_ct_aux_live rpt (pairarg_tac >> fs []) >> metis_tac [] ) -); +QED -Theorem get_intervals_ct_aux_int - `!ct n_in beg_in end_in live_in n_out beg_out end_out live_out. +Theorem get_intervals_ct_aux_int: + !ct n_in beg_in end_in live_in n_out beg_out end_out live_out. (n_out, beg_out, end_out, live_out) = get_intervals_ct_aux ct n_in beg_in end_in live_in ==> - (n_out, beg_out, end_out) = get_intervals (get_live_tree ct) n_in beg_in end_in` - - (Induct_on `ct` >> + (n_out, beg_out, end_out) = get_intervals (get_live_tree ct) n_in beg_in end_in +Proof + Induct_on `ct` >> rw [get_intervals_ct_aux_def, get_live_tree_def, get_intervals_def] THEN1 intLib.COOPER_TAC THEN1 ( @@ -1988,16 +2003,16 @@ Theorem get_intervals_ct_aux_int fs [] >> rveq >> metis_tac [] ) -); +QED -Theorem get_intervals_ct_eq - `!ct int_beg1 int_beg2 int_end1 int_end2 n1 n2. +Theorem get_intervals_ct_eq: + !ct int_beg1 int_beg2 int_end1 int_end2 n1 n2. (n1, int_beg1, int_end1) = get_intervals_ct ct /\ (n2, int_beg2, int_end2) = get_intervals (fix_domination (get_live_tree ct)) 0 LN LN ==> (!r. lookup r int_beg1 = lookup r int_beg2) /\ - (!r. lookup r int_end1 = lookup r int_end2)` - - (simp [get_intervals_def, fix_domination_def, get_intervals_ct_def] >> + (!r. lookup r int_end1 = lookup r int_end2) +Proof + simp [get_intervals_def, fix_domination_def, get_intervals_ct_def] >> rpt gen_tac >> strip_tac >> rpt (pairarg_tac >> fs []) >> `get_intervals (get_live_tree ct) 0 LN LN = (n, int_beg, int_end)` by metis_tac [get_intervals_ct_aux_int] >> @@ -2005,97 +2020,117 @@ Theorem get_intervals_ct_eq Cases_on `get_live_backward (get_live_tree ct) LN = LN` >> fs [] >> fs [get_intervals_def] >> simp [lookup_numset_list_add_if_lt, lookup_numset_list_add_if_gt, set_MAP_FST_toAList_eq_domain] -); +QED -Theorem colors_sub_eqn[simp] ` - colors_sub n s = +Theorem colors_sub_eqn[simp]: + colors_sub n s = if n < LENGTH s.colors then (Success (EL n s.colors),s) else - (Failure (Subscript),s)` - (rw[colors_sub_def]>> - fs[Marray_sub_def]); - -Theorem update_colors_eqn[simp] ` - update_colors n t s = + (Failure (Subscript),s) +Proof + rw[colors_sub_def]>> + fs[Marray_sub_def] +QED + +Theorem update_colors_eqn[simp]: + update_colors n t s = if n < LENGTH s.colors then (Success (),s with colors := LUPDATE t n s.colors) else - (Failure (Subscript),s)` - (rw[update_colors_def]>> - fs[Marray_update_def]); - -Theorem int_beg_sub_eqn[simp] - `int_beg_sub n s = + (Failure (Subscript),s) +Proof + rw[update_colors_def]>> + fs[Marray_update_def] +QED + +Theorem int_beg_sub_eqn[simp]: + int_beg_sub n s = if n < LENGTH s.int_beg then (Success (EL n s.int_beg),s) else - (Failure (Subscript),s)` - (rw[int_beg_sub_def]>> - fs[Marray_sub_def]); - -Theorem update_int_beg_eqn[simp] - `update_int_beg n t s = + (Failure (Subscript),s) +Proof + rw[int_beg_sub_def]>> + fs[Marray_sub_def] +QED + +Theorem update_int_beg_eqn[simp]: + update_int_beg n t s = if n < LENGTH s.int_beg then (Success (),s with int_beg := LUPDATE t n s.int_beg) else - (Failure (Subscript),s)` - (rw[update_int_beg_def]>> - fs[Marray_update_def]); - -Theorem int_end_sub_eqn[simp] - `int_end_sub n s = + (Failure (Subscript),s) +Proof + rw[update_int_beg_def]>> + fs[Marray_update_def] +QED + +Theorem int_end_sub_eqn[simp]: + int_end_sub n s = if n < LENGTH s.int_end then (Success (EL n s.int_end),s) else - (Failure (Subscript),s)` - (rw[int_end_sub_def]>> - fs[Marray_sub_def]); - -Theorem update_int_end_eqn[simp] - `update_int_end n t s = + (Failure (Subscript),s) +Proof + rw[int_end_sub_def]>> + fs[Marray_sub_def] +QED + +Theorem update_int_end_eqn[simp]: + update_int_end n t s = if n < LENGTH s.int_end then (Success (),s with int_end := LUPDATE t n s.int_end) else - (Failure (Subscript),s)` - (rw[update_int_end_def]>> - fs[Marray_update_def]); - -Theorem sorted_regs_sub_eqn[simp] - `sorted_regs_sub n s = + (Failure (Subscript),s) +Proof + rw[update_int_end_def]>> + fs[Marray_update_def] +QED + +Theorem sorted_regs_sub_eqn[simp]: + sorted_regs_sub n s = if n < LENGTH s.sorted_regs then (Success (EL n s.sorted_regs),s) else - (Failure (Subscript),s)` - (rw[sorted_regs_sub_def]>> - fs[Marray_sub_def]); - -Theorem update_sorted_regs_eqn[simp] - `update_sorted_regs n t s = + (Failure (Subscript),s) +Proof + rw[sorted_regs_sub_def]>> + fs[Marray_sub_def] +QED + +Theorem update_sorted_regs_eqn[simp]: + update_sorted_regs n t s = if n < LENGTH s.sorted_regs then (Success (),s with sorted_regs := LUPDATE t n s.sorted_regs) else - (Failure (Subscript),s)` - (rw[update_sorted_regs_def]>> - fs[Marray_update_def]); - -Theorem sorted_moves_sub_eqn[simp] - `sorted_moves_sub n s = + (Failure (Subscript),s) +Proof + rw[update_sorted_regs_def]>> + fs[Marray_update_def] +QED + +Theorem sorted_moves_sub_eqn[simp]: + sorted_moves_sub n s = if n < LENGTH s.sorted_moves then (Success (EL n s.sorted_moves),s) else - (Failure (Subscript),s)` - (rw[sorted_moves_sub_def]>> - fs[Marray_sub_def]); - -Theorem update_sorted_moves_eqn[simp] - `update_sorted_moves n t s = + (Failure (Subscript),s) +Proof + rw[sorted_moves_sub_def]>> + fs[Marray_sub_def] +QED + +Theorem update_sorted_moves_eqn[simp]: + update_sorted_moves n t s = if n < LENGTH s.sorted_moves then (Success (),s with sorted_moves := LUPDATE t n s.sorted_moves) else - (Failure (Subscript),s)` - (rw[update_sorted_moves_def]>> - fs[Marray_update_def]); + (Failure (Subscript),s) +Proof + rw[update_sorted_moves_def]>> + fs[Marray_update_def] +QED val msimps = [st_ex_bind_def,st_ex_return_def]; @@ -2112,25 +2147,27 @@ val find_reg_exchange_step_def = Define` (insert col1 fcol1 (insert col2 fcol2 exch), insert fcol1 col1 (insert fcol2 col2 invexch)) `; -Theorem find_reg_exchange_FOLDL - `!l colors exch invexch sth. +Theorem find_reg_exchange_FOLDL: + !l colors exch invexch sth. (!r. MEM r l ==> r < LENGTH sth.colors) ==> - find_reg_exchange l exch invexch sth = (Success (FOLDL (\a b. find_reg_exchange_step sth.colors b a) (exch, invexch) l), sth)` - (Induct_on `l` >> + find_reg_exchange l exch invexch sth = (Success (FOLDL (\a b. find_reg_exchange_step sth.colors b a) (exch, invexch) l), sth) +Proof + Induct_on `l` >> rw [FOLDL, find_reg_exchange_def, find_reg_exchange_step_def, lookup_default_id_def] >> rw msimps -); +QED -Theorem lookup_default_id_insert - `!s k1 k2 v. - lookup_default_id (insert k2 v s) k1 = if k1 = k2 then v else lookup_default_id s k1` - (rw [lookup_default_id_def, lookup_insert] -); +Theorem lookup_default_id_insert: + !s k1 k2 v. + lookup_default_id (insert k2 v s) k1 = if k1 = k2 then v else lookup_default_id s k1 +Proof + rw [lookup_default_id_def, lookup_insert] +QED val id_def = Define `id x = x` -Theorem find_reg_exchange_FOLDR_correct - `!l colors exch invexch k. +Theorem find_reg_exchange_FOLDR_correct: + !l colors exch invexch k. ALL_DISTINCT (MAP (\r. EL r colors) l) /\ (!r. MEM r l ==> is_phy_var r) /\ (exch, invexch) = FOLDR (\a b. find_reg_exchange_step colors a b) (LN, LN) l ==> @@ -2141,9 +2178,9 @@ Theorem find_reg_exchange_FOLDR_correct ((!r. MEM r l ==> r DIV 2 < k) ==> (!c. k <= c /\ (!r. MEM r l ==> c <> EL r colors) ==> k <= lookup_default_id exch c)) /\ ((!r. MEM r l ==> (k <= EL r colors /\ k <= r DIV 2)) ==> - (!c. c < k ==> lookup_default_id exch c = c))` - - (Induct_on `l` >> + (!c. c < k ==> lookup_default_id exch c = c)) +Proof + Induct_on `l` >> simp [FOLDR, FUN_EQ_THM] >> rpt gen_tac @@ -2244,10 +2281,10 @@ Theorem find_reg_exchange_FOLDR_correct `h DIV 2 < k` by metis_tac [FUN_EQ_THM, o_DEF] >> fs [] ) -); +QED -Theorem find_reg_exchange_correct - `!l sth k. +Theorem find_reg_exchange_correct: + !l sth k. ALL_DISTINCT (MAP (\r. EL r sth.colors) l) /\ (!r. MEM r l ==> is_phy_var r) /\ (!r. MEM r l ==> r < LENGTH sth.colors) ==> @@ -2259,9 +2296,9 @@ Theorem find_reg_exchange_correct ((!r. MEM r l ==> r DIV 2 < k) ==> (!c. k <= c /\ (!r. MEM r l ==> c <> EL r sth.colors) ==> k <= lookup_default_id exch c)) /\ ((!r. MEM r l ==> (k <= EL r sth.colors /\ k <= r DIV 2)) ==> - (!c. c < k ==> lookup_default_id exch c = c))` - - (simp [find_reg_exchange_FOLDL, GSYM FOLDR_REVERSE] >> + (!c. c < k ==> lookup_default_id exch c = c)) +Proof + simp [find_reg_exchange_FOLDL, GSYM FOLDR_REVERSE] >> rpt gen_tac >> strip_tac >> `?x. x = FOLDR (\b a. find_reg_exchange_step sth.colors b a) (LN, LN) (REVERSE l)` by rw [] >> PairCases_on `x` >> @@ -2274,18 +2311,18 @@ Theorem find_reg_exchange_correct fs [MEM_REVERSE, MAP_REVERSE] >> qspecl_then [`l'`, `sth.colors`, `x0`, `x1`, `k`] assume_tac find_reg_exchange_FOLDR_correct >> rfs [] -); +QED -Theorem MAP_colors_eq_lemma - `!sth n f. +Theorem MAP_colors_eq_lemma: + !sth n f. n <= LENGTH sth.colors ==> ?sthout. (Success (), sthout) = MAP_colors f n sth /\ LENGTH sth.colors = LENGTH sthout.colors /\ sthout.int_beg = sth.int_beg /\ sthout.int_end = sth.int_end /\ (!n'. n' < n ==> EL n' sthout.colors = f (EL n' sth.colors)) /\ - (!n'. n <= n' ==> EL n' sthout.colors = EL n' sth.colors)` - - (Induct_on `n` >> + (!n'. n <= n' ==> EL n' sthout.colors = EL n' sth.colors) +Proof + Induct_on `n` >> rw [MAP_colors_def] >> rw msimps >> `?sth'. sth' = sth with colors := LUPDATE (f (EL n sth.colors)) n sth.colors` by rw [] >> `n <= LENGTH sth'.colors` by rw [] >> @@ -2313,21 +2350,22 @@ Theorem MAP_colors_eq_lemma res_tac >> rw [EL_LUPDATE] ) -); +QED -Theorem MAP_colors_eq - `!sth f. +Theorem MAP_colors_eq: + !sth f. ?sthout. (Success (), sthout) = MAP_colors f (LENGTH sth.colors) sth /\ (!n. n < LENGTH sth.colors ==> EL n sthout.colors = f (EL n sth.colors)) /\ LENGTH sth.colors = LENGTH sthout.colors /\ - sthout.int_beg = sth.int_beg /\ sthout.int_end = sth.int_end` - (rw [] >> + sthout.int_beg = sth.int_beg /\ sthout.int_end = sth.int_end +Proof + rw [] >> `LENGTH sth.colors <= LENGTH sth.colors` by rw [] >> metis_tac [MAP_colors_eq_lemma] -); +QED -Theorem apply_reg_exchange_correct - `!l sth k. +Theorem apply_reg_exchange_correct: + !l sth k. ALL_DISTINCT (MAP (\r. EL r sth.colors) l) /\ (!r. MEM r l ==> is_phy_var r) /\ (!r. MEM r l ==> r < LENGTH sth.colors) ==> @@ -2341,9 +2379,9 @@ Theorem apply_reg_exchange_correct ((!r. MEM r l ==> r DIV 2 < k) ==> (!r. r < LENGTH sth.colors /\ k <= EL r sth.colors /\ (!r'. MEM r' l ==> EL r sth.colors <> EL r' sth.colors) ==> k <= EL r sthout.colors)) /\ ((!r. MEM r l ==> (k <= EL r sth.colors /\ k <= r DIV 2)) ==> - (!r. r < LENGTH sth.colors /\ EL r sth.colors < k ==> EL r sthout.colors = EL r sth.colors))` - - (rpt gen_tac >> strip_tac >> + (!r. r < LENGTH sth.colors /\ EL r sth.colors < k ==> EL r sthout.colors = EL r sth.colors)) +Proof + rpt gen_tac >> strip_tac >> fs [apply_reg_exchange_def] >> fs msimps >> drule find_reg_exchange_correct >> @@ -2364,17 +2402,18 @@ Theorem apply_reg_exchange_correct qpat_x_assum `!c. id _` kall_tac >> fs [id_def] ) -); +QED val less_FST_def = Define` less_FST (x:int#num) y = (FST x <= FST y) `; -Theorem transitive_less_FST - `transitive less_FST` - (rw [transitive_def, less_FST_def] >> +Theorem transitive_less_FST: + transitive less_FST +Proof + rw [transitive_def, less_FST_def] >> intLib.COOPER_TAC -); +QED val good_linear_scan_state_def = Define` good_linear_scan_state st sth l (pos:int) forced mincol = ( @@ -2414,15 +2453,15 @@ in |> SIMP_RULE bool_ss [AND_IMP_INTRO] end -Theorem remove_inactive_intervals_invariants - `!beg st sth l pos forced mincol. +Theorem remove_inactive_intervals_invariants: + !beg st sth l pos forced mincol. good_linear_scan_state st sth l pos forced mincol /\ pos <= beg ==> ?stout. (Success stout, sth) = remove_inactive_intervals beg st sth /\ good_linear_scan_state stout sth l beg forced mincol /\ - stout.colormax = st.colormax` - - (recInduct remove_inactive_intervals_ind >> + stout.colormax = st.colormax +Proof + recInduct remove_inactive_intervals_ind >> rw [] >> once_rewrite_tac [remove_inactive_intervals_def] >> rw msimps >> @@ -2520,16 +2559,16 @@ Theorem remove_inactive_intervals_invariants intLib.COOPER_TAC ) ) -); +QED -Theorem add_active_interval_output - `!lin x lout. +Theorem add_active_interval_output: + !lin x lout. SORTED less_FST lin /\ lout = add_active_interval (e,r) lin ==> SORTED less_FST lout /\ - ?l1 l2. lin = l1 ++ l2 /\ lout = l1 ++ (e,r)::l2` - - (Induct_on `lin` >> + ?l1 l2. lin = l1 ++ l2 /\ lout = l1 ++ (e,r)::l2 +Proof + Induct_on `lin` >> rw [add_active_interval_def] THEN1 ( @@ -2553,15 +2592,15 @@ Theorem add_active_interval_output qexists_tac `h::l1` >> qexists_tac `l2` >> rw [] ) -); +QED -Theorem find_color_in_list_output - `!forbidden col l rest. +Theorem find_color_in_list_output: + !forbidden col l rest. find_color_in_list l forbidden = SOME (col, rest) ==> MEM col l /\ col NOTIN domain forbidden /\ - ?l1 l2. rest = l1 ++ l2 /\ l = l1 ++ col::l2` - - (NTAC 2 gen_tac >> + ?l1 l2. rest = l1 ++ l2 /\ l = l1 ++ col::l2 +Proof + NTAC 2 gen_tac >> Induct_on `l` >> rpt gen_tac >> simp [find_color_in_list_def] >> @@ -2582,10 +2621,10 @@ Theorem find_color_in_list_output qexists_tac `l2` >> rw [] ) -); +QED -Theorem find_color_in_colornum_invariants - `!st forbidden sth l pos forced mincol. +Theorem find_color_in_colornum_invariants: + !st forbidden sth l pos forced mincol. good_linear_scan_state st sth l pos forced mincol /\ domain forbidden SUBSET {EL r sth.colors | r | MEM r l} /\ find_color_in_colornum st forbidden = (stout, SOME col) ==> @@ -2593,9 +2632,9 @@ Theorem find_color_in_colornum_invariants st.colornum <= col /\ col < stout.colornum /\ st.colornum <= stout.colornum /\ col NOTIN domain forbidden /\ - st = stout with <| colorpool := st.colorpool; colornum := st.colornum |>` - - (rw [find_color_in_colornum_def] >> rw [] + st = stout with <| colorpool := st.colorpool; colornum := st.colornum |> +Proof + rw [find_color_in_colornum_def] >> rw [] THEN1 ( fs [good_linear_scan_state_def'] >> rveq >> @@ -2619,19 +2658,19 @@ Theorem find_color_in_colornum_invariants rfs [] ) THEN1 rw [linear_scan_state_component_equality] -); +QED -Theorem find_color_invariants - `!st forbidden stout col sth l pos forced mincol. +Theorem find_color_invariants: + !st forbidden stout col sth l pos forced mincol. good_linear_scan_state st sth l pos forced mincol /\ domain forbidden SUBSET {EL r sth.colors | r | MEM r l} /\ find_color st forbidden = (stout, SOME col) ==> good_linear_scan_state (stout with colorpool updated_by (\l. col::l)) sth l pos forced mincol /\ col < stout.colornum /\ col NOTIN domain forbidden /\ - st = stout with <| colorpool := st.colorpool; colornum := st.colornum |>` - - (rpt gen_tac >> + st = stout with <| colorpool := st.colorpool; colornum := st.colornum |> +Proof + rpt gen_tac >> simp [find_color_def] >> Cases_on `find_color_in_list st.colorpool forbidden` >> simp [] >> strip_tac @@ -2656,27 +2695,28 @@ Theorem find_color_invariants fs [good_linear_scan_state_def', EVERY_MEM] >> metis_tac [] ) -); +QED -Theorem update_color_active_colors_same - `!e reg active regcol colors. - MAP (\e,r. EL r (LUPDATE regcol reg colors)) (FILTER (\e,r. r <> reg) active) = MAP (\e,r. EL r colors) (FILTER (\e,r. r <> reg) active)` - (Induct_on `active` >> +Theorem update_color_active_colors_same: + !e reg active regcol colors. + MAP (\e,r. EL r (LUPDATE regcol reg colors)) (FILTER (\e,r. r <> reg) active) = MAP (\e,r. EL r colors) (FILTER (\e,r. r <> reg) active) +Proof + Induct_on `active` >> rw [] >> pairarg_tac >> rw [EL_LUPDATE] >> fs [] -); +QED -Theorem forced_update_stack_color_lemma - `!(colors : num list) (stacknum : num) l r2 r1. +Theorem forced_update_stack_color_lemma: + !(colors : num list) (stacknum : num) l r2 r1. EVERY (\r. EL r colors < stacknum) l /\ MEM r2 l /\ r1 < LENGTH colors /\ EL r1 (LUPDATE stacknum r1 colors) = EL r2 (LUPDATE stacknum r1 colors) ==> - r1 = r2` - - ((* recast injectivity to make simplifier (much!) faster *) + r1 = r2 +Proof + (* recast injectivity to make simplifier (much!) faster *) ‘∀(colors:num list) stacknum l r2 r1. EVERY (λr. EL r colors < stacknum) l ∧ MEM r2 l ∧ r1 < LENGTH colors ⇒ (EL r1 (LUPDATE stacknum r1 colors) = EL r2 (LUPDATE stacknum r1 colors) ⇔ @@ -2684,7 +2724,7 @@ Theorem forced_update_stack_color_lemma Induct_on `l` >> rw [] >- fs[EL_LUPDATE] >- metis_tac [] -); +QED (* TODO: this should be part of the standard library, but I couldn't find it *) val IS_SPARSE_SUBLIST_def = Define` @@ -2697,50 +2737,56 @@ val IS_SPARSE_SUBLIST_def = Define` ((x=y /\ IS_SPARSE_SUBLIST xs ys) \/ IS_SPARSE_SUBLIST (x::xs) ys) )` -Theorem FILTER_IS_SPARSE_SUBLIST - `!l. IS_SPARSE_SUBLIST (FILTER P l) l` - (Induct_on `l` >> +Theorem FILTER_IS_SPARSE_SUBLIST: + !l. IS_SPARSE_SUBLIST (FILTER P l) l +Proof + Induct_on `l` >> rw [IS_SPARSE_SUBLIST_def] >> Cases_on `FILTER P l` >> rw [IS_SPARSE_SUBLIST_def] -); +QED -Theorem MEM_SPARSE_SUBLIST - `!l1 l2 x. IS_SPARSE_SUBLIST l1 l2 /\ MEM x l1 ==> MEM x l2` - (Induct_on `l1` >> +Theorem MEM_SPARSE_SUBLIST: + !l1 l2 x. IS_SPARSE_SUBLIST l1 l2 /\ MEM x l1 ==> MEM x l2 +Proof + Induct_on `l1` >> rw [IS_SPARSE_SUBLIST_def] >> Induct_on `l2` >> fs [IS_SPARSE_SUBLIST_def] >> rw [] >> rw [] -); +QED -Theorem IS_SPARSE_SUBLIST_APPEND_LEFT - `!l1 l2 l. IS_SPARSE_SUBLIST l1 l2 ==> IS_SPARSE_SUBLIST (l ++ l1) (l ++ l2)` - (Induct_on `l` >> +Theorem IS_SPARSE_SUBLIST_APPEND_LEFT: + !l1 l2 l. IS_SPARSE_SUBLIST l1 l2 ==> IS_SPARSE_SUBLIST (l ++ l1) (l ++ l2) +Proof + Induct_on `l` >> rw [IS_SPARSE_SUBLIST_def] -); +QED -Theorem IS_SPARSE_SUBLIST_APPEND_RIGHT - `!l1 l2 l. IS_SPARSE_SUBLIST l1 l2 ==> IS_SPARSE_SUBLIST (l1 ++ l) (l2 ++ l)` - (Induct_on `l1` >> +Theorem IS_SPARSE_SUBLIST_APPEND_RIGHT: + !l1 l2 l. IS_SPARSE_SUBLIST l1 l2 ==> IS_SPARSE_SUBLIST (l1 ++ l) (l2 ++ l) +Proof + Induct_on `l1` >> rw [IS_SPARSE_SUBLIST_def] >> Induct_on `l2` >> rw [IS_SPARSE_SUBLIST_def] >> Induct_on `l` >> rw [IS_SPARSE_SUBLIST_def] -); +QED -Theorem MAP_IS_SPARSE_SUBLIST - `!l1 l2. IS_SPARSE_SUBLIST l1 l2 ==> IS_SPARSE_SUBLIST (MAP f l1) (MAP f l2)` - (Induct_on `l1` >> +Theorem MAP_IS_SPARSE_SUBLIST: + !l1 l2. IS_SPARSE_SUBLIST l1 l2 ==> IS_SPARSE_SUBLIST (MAP f l1) (MAP f l2) +Proof + Induct_on `l1` >> Induct_on `l2` >> rw [IS_SPARSE_SUBLIST_def] >> rfs [] -); +QED -Theorem ALL_DISTINCT_IS_SPARSE_SUBLIST - `!l1 l2. ALL_DISTINCT l2 /\ IS_SPARSE_SUBLIST l1 l2 ==> ALL_DISTINCT l1` - (Induct_on `l1` >> +Theorem ALL_DISTINCT_IS_SPARSE_SUBLIST: + !l1 l2. ALL_DISTINCT l2 /\ IS_SPARSE_SUBLIST l1 l2 ==> ALL_DISTINCT l1 +Proof + Induct_on `l1` >> rw [IS_SPARSE_SUBLIST_def] THEN1 ( Induct_on `l2` >> fs [IS_SPARSE_SUBLIST_def] >> rw [] @@ -2754,10 +2800,10 @@ Theorem ALL_DISTINCT_IS_SPARSE_SUBLIST Induct_on `l2` >> fs [IS_SPARSE_SUBLIST_def] >> rw [] >> res_tac ) -); +QED -Theorem spill_register_FILTER_invariants_hidden - `!st sth l pos forced reg mincol. +Theorem spill_register_FILTER_invariants_hidden: + !st sth l pos forced reg mincol. id (~(is_phy_var reg) \/ ~(MEM reg l)) /\ good_linear_scan_state st sth l pos forced mincol /\ reg < LENGTH sth.colors /\ @@ -2768,9 +2814,9 @@ Theorem spill_register_FILTER_invariants_hidden (!r. r <> reg ==> EL r sth.colors = EL r sthout.colors) /\ stout.colormax = st.colormax /\ sthout.int_beg = sth.int_beg /\ sthout.int_end = sth.int_end /\ - st.colormax <= EL reg sthout.colors` - - (rw [spill_register_def] >> rw msimps >> + st.colormax <= EL reg sthout.colors +Proof + rw [spill_register_def] >> rw msimps >> fs [good_linear_scan_state_def'] >> rpt strip_tac THEN1 ((* 24 *) @@ -2865,22 +2911,23 @@ Theorem spill_register_FILTER_invariants_hidden ) THEN1 (* 2 *) simp [EL_LUPDATE] THEN1 (* 1 *) simp [EL_LUPDATE] -); +QED val spill_register_FILTER_invariants = spill_register_FILTER_invariants_hidden |> REWRITE_RULE [id_def] |> curry save_thm "spill_register_FILTER_invariants" -Theorem FILTER_MEM_active - `!(reg:num) l. (!(e:int). ~(MEM (e,reg) l)) ==> FILTER (\e,r. r <> reg) l = l` - (Induct_on `l` >> rw [] >> +Theorem FILTER_MEM_active: + !(reg:num) l. (!(e:int). ~(MEM (e,reg) l)) ==> FILTER (\e,r. r <> reg) l = l +Proof + Induct_on `l` >> rw [] >> pairarg_tac >> fs [] >> metis_tac [] -); +QED -Theorem spill_register_invariants - `!st sth l pos forced reg mincol. +Theorem spill_register_invariants: + !st sth l pos forced reg mincol. (!e. ~(MEM (e,reg) st.active)) /\ (~(is_phy_var reg) \/ ~(MEM reg l)) /\ good_linear_scan_state st sth l pos forced mincol /\ @@ -2892,13 +2939,13 @@ Theorem spill_register_invariants sthout.int_beg = sth.int_beg /\ sthout.int_end = sth.int_end /\ (!r. r <> reg ==> EL r sth.colors = EL r sthout.colors) /\ stout.colormax = st.colormax /\ - st.colormax <= EL reg sthout.colors` - - (rw [] >> + st.colormax <= EL reg sthout.colors +Proof + rw [] >> `FILTER (\e,r. r <> reg) st.active = st.active` by simp [FILTER_MEM_active] >> `st = st with active := FILTER (\e,r. r <> reg) st.active` by simp [linear_scan_state_component_equality] >> metis_tac [spill_register_FILTER_invariants] -); +QED val edges_to_adjlist_step_def = Define` edges_to_adjlist_step sth (a,b) acc = @@ -2910,11 +2957,12 @@ val edges_to_adjlist_step_def = Define` insert a (b::(the [] (lookup a acc))) acc `; -Theorem edges_to_adjlist_FOLDL - `!forced sth acc. +Theorem edges_to_adjlist_FOLDL: + !forced sth acc. EVERY (\r1,r2. r1 < LENGTH sth.int_beg /\ r2 < LENGTH sth.int_beg) forced ==> - edges_to_adjlist forced acc sth = (Success (FOLDL (\acc pair. edges_to_adjlist_step sth pair acc) acc forced), sth)` - (Induct_on `forced` + edges_to_adjlist forced acc sth = (Success (FOLDL (\acc pair. edges_to_adjlist_step sth pair acc) acc forced), sth) +Proof + Induct_on `forced` THEN1 rw (edges_to_adjlist_def::msimps) >> rw [] >> PairCases_on `h` >> fs [] >> @@ -2922,7 +2970,7 @@ Theorem edges_to_adjlist_FOLDL fs [LEX_DEF] >> rw msimps >> every_case_tac -); +QED val forbidden_is_from_forced_def = Define` forbidden_is_from_forced forced (int_beg : int list) reg forbidden = @@ -2950,11 +2998,11 @@ val forbidden_is_from_map_color_forced_def = Define` EL reg2 colors IN domain forbidden `; -Theorem edges_to_adjlist_FOLDR_output - `!forced sth. - !reg. forbidden_is_from_forced forced sth.int_beg reg (the [] (lookup reg (FOLDR (\pair acc. edges_to_adjlist_step sth pair acc) LN forced)))` - - (simp [forbidden_is_from_forced_def] >> +Theorem edges_to_adjlist_FOLDR_output: + !forced sth. + !reg. forbidden_is_from_forced forced sth.int_beg reg (the [] (lookup reg (FOLDR (\pair acc. edges_to_adjlist_step sth pair acc) LN forced))) +Proof + simp [forbidden_is_from_forced_def] >> Induct_on `forced` THEN1 rw [forbidden_is_from_forced_def, lookup_def, the_def] >> simp [] >> @@ -3012,53 +3060,53 @@ Theorem edges_to_adjlist_FOLDR_output fs [lookup_insert, the_def] >> fs [] >> metis_tac [] ) -); +QED -Theorem edges_to_adjlist_output - `!forced sth. +Theorem edges_to_adjlist_output: + !forced sth. EVERY (\r1,r2. r1 < LENGTH sth.int_beg /\ r2 < LENGTH sth.int_beg) forced ==> ?adjlist. edges_to_adjlist forced LN sth = (Success adjlist, sth) /\ - !reg. forbidden_is_from_forced forced sth.int_beg reg (the [] (lookup reg adjlist))` - - (rw [edges_to_adjlist_FOLDL, GSYM FOLDR_REVERSE] >> + !reg. forbidden_is_from_forced forced sth.int_beg reg (the [] (lookup reg adjlist)) +Proof + rw [edges_to_adjlist_FOLDL, GSYM FOLDR_REVERSE] >> qspecl_then [`REVERSE forced`, `sth`, `reg`] assume_tac edges_to_adjlist_FOLDR_output >> fs [forbidden_is_from_forced_def] -); +QED -Theorem state_invariants_remove_head - `!st sth reg l pos forced mincol. +Theorem state_invariants_remove_head: + !st sth reg l pos forced mincol. MEM reg l /\ good_linear_scan_state st sth (reg::l) pos forced mincol ==> - good_linear_scan_state st sth l pos forced mincol` - - (rw [] >> + good_linear_scan_state st sth l pos forced mincol +Proof + rw [] >> `!r. r = reg \/ MEM r l <=> MEM r l` by metis_tac [] >> rw [good_linear_scan_state_def'] >> fs [good_linear_scan_state_def'] >> every_case_tac >> fs [] -); +QED -Theorem find_last_stealable_success - `!forbidden sth active. +Theorem find_last_stealable_success: + !forbidden sth active. EVERY (\e,r. r < LENGTH sth.colors) active ==> - ?optout. find_last_stealable active forbidden sth = (Success optout, sth)` - - (NTAC 2 gen_tac >> + ?optout. find_last_stealable active forbidden sth = (Success optout, sth) +Proof + NTAC 2 gen_tac >> Induct_on `active` >> rw [find_last_stealable_def] >> simp msimps >> fs [] >> every_case_tac >> PairCases_on `h` >> rfs [] -); +QED -Theorem find_last_stealable_output - `!forbidden sth active steal rest. +Theorem find_last_stealable_output: + !forbidden sth active steal rest. find_last_stealable active forbidden sth = (Success (SOME (steal, rest)), sth) ==> ~is_phy_var (SND steal) /\ lookup (EL (SND steal) sth.colors) forbidden = NONE /\ - ?l1 l2. rest = l1 ++ l2 /\ active = l1 ++ steal::l2` - - (NTAC 2 gen_tac >> + ?l1 l2. rest = l1 ++ l2 /\ active = l1 ++ steal::l2 +Proof + NTAC 2 gen_tac >> Induct_on `active` >> rw [find_last_stealable_def] >> simp msimps >> fs msimps @@ -3082,20 +3130,20 @@ Theorem find_last_stealable_output rw [] ) ) -); +QED -Theorem good_linear_scan_state_active_length_colors - `!st sth l pos forced mincol. +Theorem good_linear_scan_state_active_length_colors: + !st sth l pos forced mincol. good_linear_scan_state st sth l pos forced mincol ==> - EVERY (\e,r. r < LENGTH sth.colors) st.active` - - (rw [good_linear_scan_state_def', EVERY_MEM] >> + EVERY (\e,r. r < LENGTH sth.colors) st.active +Proof + rw [good_linear_scan_state_def', EVERY_MEM] >> res_tac >> rpt (pairarg_tac >> fs []) -); +QED -Theorem color_register_eq - `!st reg col rend. +Theorem color_register_eq: + !st reg col rend. color_register st reg col rend = do update_colors reg col; @@ -3105,15 +3153,16 @@ Theorem color_register_eq ; phyregs := if is_phy_var reg then (insert col ()) st.phyregs else st.phyregs |> ) - od` - (rw [color_register_def] >> fs msimps >> + od +Proof + rw [color_register_def] >> fs msimps >> rw [FUN_EQ_THM] >> every_case_tac >> simp [linear_scan_state_component_equality] -); +QED -Theorem color_register_invariants - `!st sth l pos forced reg col forbidden mincol. +Theorem color_register_invariants: + !st sth l pos forced reg col forbidden mincol. good_linear_scan_state st sth l pos forced mincol /\ forbidden_is_from_map_color_forced forced l sth.colors reg forbidden /\ col NOTIN domain forbidden /\ @@ -3131,9 +3180,9 @@ Theorem color_register_invariants LENGTH sthout.colors = LENGTH sth.colors /\ sthout.int_beg = sth.int_beg /\ sthout.int_end = sth.int_end /\ (!r. r <> reg ==> EL r sth.colors = EL r sthout.colors) /\ - stout.colormax = st.colormax` - - (rpt strip_tac >> simp [color_register_eq] >> simp msimps >> + stout.colormax = st.colormax +Proof + rpt strip_tac >> simp [color_register_eq] >> simp msimps >> fs [good_linear_scan_state_def'] >> rpt strip_tac THEN1 ( @@ -3311,10 +3360,10 @@ Theorem color_register_invariants metis_tac [] ) THEN1 simp [EL_LUPDATE] -); +QED -Theorem find_spill_invariants - `!st sth l forbidden forced reg force mincol. +Theorem find_spill_invariants: + !st sth l forbidden forced reg force mincol. ~MEM reg l /\ good_linear_scan_state st sth l (EL reg sth.int_beg) forced mincol /\ reg < LENGTH sth.colors /\ @@ -3327,9 +3376,9 @@ Theorem find_spill_invariants sthout.int_beg = sth.int_beg /\ sthout.int_end = sth.int_end /\ (!r. ~MEM r (reg::l) ==> EL r sthout.colors = EL r sth.colors) /\ (!r. MEM r l /\ is_phy_var r ==> EL r sthout.colors = EL r sth.colors) /\ - stout.colormax = st.colormax` - - (rw [find_spill_def] >> simp msimps >> + stout.colormax = st.colormax +Proof + rw [find_spill_def] >> simp msimps >> `!e. ~(MEM (e,reg) st.active)` by (CCONTR_TAC >> fs [good_linear_scan_state_def', EVERY_MEM, FORALL_PROD]) >> imp_res_tac good_linear_scan_state_active_length_colors >> `?optsteal. find_last_stealable st.active forbidden sth = (Success optsteal, sth)` by metis_tac [find_last_stealable_success] >> @@ -3427,10 +3476,10 @@ Theorem find_spill_invariants ) >> fs [] >> metis_tac [] -); +QED -Theorem linear_reg_alloc_step_aux_invariants - `!st sth l preferred (forbidden:num_set) forced reg force mincol. +Theorem linear_reg_alloc_step_aux_invariants: + !st sth l preferred (forbidden:num_set) forced reg force mincol. ~MEM reg l /\ good_linear_scan_state st sth l (EL reg sth.int_beg) forced mincol /\ reg < LENGTH sth.colors /\ @@ -3444,9 +3493,9 @@ Theorem linear_reg_alloc_step_aux_invariants sthout.int_beg = sth.int_beg /\ sthout.int_end = sth.int_end /\ (!r. ~MEM r (reg::l) ==> EL r sthout.colors = EL r sth.colors) /\ (!r. MEM r l /\ is_phy_var r ==> EL r sthout.colors = EL r sth.colors) /\ - stout.colormax = st.colormax` - - (rw [linear_reg_alloc_step_aux_def] >> + stout.colormax = st.colormax +Proof + rw [linear_reg_alloc_step_aux_def] >> Cases_on `find_color_in_list (FILTER (\c. MEM c st.colorpool) preferred) forbidden` >> fs [] THEN1 ( Cases_on `find_color st forbidden` >> fs [] >> @@ -3491,22 +3540,23 @@ Theorem linear_reg_alloc_step_aux_invariants rfs [] >> metis_tac [] ) -); +QED -Theorem st_ex_MAP_colors_sub - `!l sth. +Theorem st_ex_MAP_colors_sub: + !l sth. EVERY (\r. r < LENGTH sth.colors) l ==> - st_ex_MAP colors_sub l sth = (Success (MAP (\r. EL r sth.colors) l), sth)` - (Induct_on `l` >> rw (st_ex_MAP_def::msimps) -); + st_ex_MAP colors_sub l sth = (Success (MAP (\r. EL r sth.colors) l), sth) +Proof + Induct_on `l` >> rw (st_ex_MAP_def::msimps) +QED val phystack_on_stack_def = Define` phystack_on_stack l st sth = !r. MEM r l /\ is_phy_var r /\ 2*st.colormax <= r ==> st.colormax <= EL r sth.colors `; -Theorem linear_reg_alloc_step_pass1_invariants - `!st sth l moves forced_adj forced reg pos mincol. +Theorem linear_reg_alloc_step_pass1_invariants: + !st sth l moves forced_adj forced reg pos mincol. ~MEM reg l /\ good_linear_scan_state st sth l pos forced mincol /\ pos <= (EL reg sth.int_beg) /\ @@ -3523,9 +3573,9 @@ Theorem linear_reg_alloc_step_pass1_invariants (!r. ~MEM r (reg::l) ==> EL r sthout.colors = EL r sth.colors) /\ (!r. MEM r l /\ is_phy_var r ==> EL r sthout.colors = EL r sth.colors) /\ (phystack_on_stack l st sth ==> phystack_on_stack (reg::l) stout sthout) /\ - stout.colormax = st.colormax` - - (rw [linear_reg_alloc_step_pass1_def] >> + stout.colormax = st.colormax +Proof + rw [linear_reg_alloc_step_pass1_def] >> simp msimps >> qspecl_then [`EL reg sth.int_beg`, `st`, `sth`, `l`, `pos`, `forced`, `mincol`] assume_tac remove_inactive_intervals_invariants >> rfs [] >> qpat_x_assum `(_,_) = _` (fn th => assume_tac (GSYM th)) >> @@ -3584,10 +3634,10 @@ Theorem linear_reg_alloc_step_pass1_invariants simp [phystack_on_stack_def] >> metis_tac [] ) -); +QED -Theorem linear_reg_alloc_step_pass2_invariants - `!st sth l moves forced_adj forced reg pos mincol. +Theorem linear_reg_alloc_step_pass2_invariants: + !st sth l moves forced_adj forced reg pos mincol. ~MEM reg l /\ good_linear_scan_state st sth l pos forced mincol /\ pos <= (EL reg sth.int_beg) /\ @@ -3603,9 +3653,9 @@ Theorem linear_reg_alloc_step_pass2_invariants sthout.int_beg = sth.int_beg /\ sthout.int_end = sth.int_end /\ (!r. ~MEM r (reg::l) ==> EL r sthout.colors = EL r sth.colors) /\ (!r. MEM r l /\ is_phy_var r ==> EL r sthout.colors = EL r sth.colors) /\ - stout.colormax = st.colormax` - - (rw [linear_reg_alloc_step_pass2_def] >> + stout.colormax = st.colormax +Proof + rw [linear_reg_alloc_step_pass2_def] >> simp msimps >> qspecl_then [`EL reg sth.int_beg`, `st`, `sth`, `l`, `pos`, `forced`, `mincol`] assume_tac remove_inactive_intervals_invariants >> rfs [] >> qpat_x_assum `(_,_) = _` (fn th => assume_tac (GSYM th)) >> @@ -3639,27 +3689,29 @@ Theorem linear_reg_alloc_step_pass2_invariants `forbidden`, `forced`, `reg`, `F`] assume_tac linear_reg_alloc_step_aux_invariants >> rfs [] ) -); +QED (* TODO: move *) val intbeg_less_def = Define` intbeg_less (int_beg : int list) r1 r2 = ($< LEX $<=) (EL r1 int_beg, r1) (EL r2 int_beg, r2) `; -Theorem intbeg_less_transitive - `!int_beg. transitive (intbeg_less int_beg)` - (rw [transitive_def, intbeg_less_def, LEX_DEF] >> +Theorem intbeg_less_transitive: + !int_beg. transitive (intbeg_less int_beg) +Proof + rw [transitive_def, intbeg_less_def, LEX_DEF] >> intLib.COOPER_TAC -); +QED -Theorem intbeg_less_total - `!int_beg. total (intbeg_less int_beg)` - (rw [total_def, intbeg_less_def, LEX_DEF] >> +Theorem intbeg_less_total: + !int_beg. total (intbeg_less int_beg) +Proof + rw [total_def, intbeg_less_def, LEX_DEF] >> intLib.COOPER_TAC -); +QED -Theorem st_ex_FOLDL_linear_reg_alloc_step_passn_invariants_lemma - `!regl st sth l pos b moves forced_adj forced mincol. +Theorem st_ex_FOLDL_linear_reg_alloc_step_passn_invariants_lemma: + !regl st sth l pos b moves forced_adj forced mincol. SORTED (intbeg_less sth.int_beg) regl /\ (!r1 r2. MEM r1 l /\ MEM r2 regl ==> intbeg_less sth.int_beg r1 r2) /\ ALL_DISTINCT regl /\ @@ -3678,9 +3730,9 @@ Theorem st_ex_FOLDL_linear_reg_alloc_step_passn_invariants_lemma sthout.int_beg = sth.int_beg /\ sthout.int_end = sth.int_end /\ (!r. ~MEM r (l++regl) ==> EL r sthout.colors = EL r sth.colors) /\ (b ==> (phystack_on_stack l st sth ==> phystack_on_stack ((REVERSE regl) ++ l) stout sthout)) /\ - stout.colormax = st.colormax` - - (Induct_on `regl` + stout.colormax = st.colormax +Proof + Induct_on `regl` THEN1 ( rw (st_ex_FOLDL_def::msimps) >> qexists_tac `pos` >> @@ -3741,10 +3793,10 @@ Theorem st_ex_FOLDL_linear_reg_alloc_step_passn_invariants_lemma first_x_assum (qspecl_then [`stmid`, `sthmid`, `h::l`, `EL h sth.int_beg`, `b`, `moves`, `forced_adj`, `forced`, `mincol`] assume_tac) >> rfs [] >> fs [] >> rfs [] >> metis_tac [] -); +QED -Theorem st_ex_FOLDL_linear_reg_alloc_step_passn_invariants - `!regl st sth pos b moves forced_adj forced mincol. +Theorem st_ex_FOLDL_linear_reg_alloc_step_passn_invariants: + !regl st sth pos b moves forced_adj forced mincol. SORTED (intbeg_less sth.int_beg) regl /\ ALL_DISTINCT regl /\ good_linear_scan_state st sth [] pos forced mincol /\ @@ -3761,33 +3813,36 @@ Theorem st_ex_FOLDL_linear_reg_alloc_step_passn_invariants sthout.int_beg = sth.int_beg /\ sthout.int_end = sth.int_end /\ (!r. ~MEM r regl ==> EL r sthout.colors = EL r sth.colors) /\ (b ==> phystack_on_stack (REVERSE regl) stout sthout) /\ - stout.colormax = st.colormax` - - (rpt strip_tac >> + stout.colormax = st.colormax +Proof + rpt strip_tac >> qspecl_then [`regl`, `st`, `sth`, `[]`, `pos`, `b`] assume_tac st_ex_FOLDL_linear_reg_alloc_step_passn_invariants_lemma >> `phystack_on_stack [] st sth` by simp [phystack_on_stack_def] >> fs [] -); +QED -Theorem swap_regs_eq - `!sth i1 i2. +Theorem swap_regs_eq: + !sth i1 i2. i1 < LENGTH sth.sorted_regs /\ i2 < LENGTH sth.sorted_regs ==> ?sthout. swap_regs i1 i2 sth = (Success (), sthout) /\ - sthout = sth with sorted_regs := LUPDATE (EL i1 sth.sorted_regs) i2 (LUPDATE (EL i2 sth.sorted_regs) i1 sth.sorted_regs)` - (rw (swap_regs_def::msimps) -); + sthout = sth with sorted_regs := LUPDATE (EL i1 sth.sorted_regs) i2 (LUPDATE (EL i2 sth.sorted_regs) i1 sth.sorted_regs) +Proof + rw (swap_regs_def::msimps) +QED (* TODO: move *) -Theorem if_thm - `!b x y z. (if b then x else y) = z <=> ((b /\ x = z) \/ (~b /\ y=z))` - (rw [] -); +Theorem if_thm: + !b x y z. (if b then x else y) = z <=> ((b /\ x = z) \/ (~b /\ y=z)) +Proof + rw [] +QED -Theorem split_at_indice_sing - `!l i. +Theorem split_at_indice_sing: + !l i. i < LENGTH l ==> - ?l1 x l2. l = l1 ++ [x] ++ l2 /\ LENGTH l1 = i` - (Induct_on `l` >> + ?l1 x l2. l = l1 ++ [x] ++ l2 /\ LENGTH l1 = i +Proof + Induct_on `l` >> rw [] >> Cases_on `i` THEN1 ( qexists_tac `[]` >> @@ -3802,13 +3857,14 @@ Theorem split_at_indice_sing qexists_tac `x` >> qexists_tac `l2` >> rw [] -); +QED -Theorem split_at_indice - `!l i. +Theorem split_at_indice: + !l i. i <= LENGTH l ==> - ?l1 l2. l = l1 ++ l2 /\ LENGTH l1 = i` - (Induct_on `l` >> + ?l1 l2. l = l1 ++ l2 /\ LENGTH l1 = i +Proof + Induct_on `l` >> rw [] >> Cases_on `i` THEN1 ( qexists_tac `[]` >> @@ -3821,14 +3877,15 @@ Theorem split_at_indice qexists_tac `h::l1` >> qexists_tac `l2` >> rw [] -); +QED -Theorem swap_perm_lemma - `!l i1 i2. +Theorem swap_perm_lemma: + !l i1 i2. i1 < LENGTH l /\ i2 < LENGTH l ==> - PERM l (LUPDATE (EL i1 l) i2 (LUPDATE (EL i2 l) i1 l))` - (rw [] >> + PERM l (LUPDATE (EL i1 l) i2 (LUPDATE (EL i2 l) i1 l)) +Proof + rw [] >> Cases_on `i1 = i2` THEN1 fs [LUPDATE_SAME] >> rpt (first_x_assum mp_tac) >> simp [] >> @@ -3855,31 +3912,33 @@ Theorem swap_perm_lemma ASM_REWRITE_TAC [] >> REWRITE_TAC [lupdate_append2] >> metis_tac [PERM_APPEND, PERM_APPEND_IFF, APPEND_ASSOC] -); +QED -Theorem LUPDATE_TAKE - `!n x y l. x < n /\ n <= LENGTH l ==> TAKE n (LUPDATE y x l) = LUPDATE y x (TAKE n l)` - (Induct_on `l` >> +Theorem LUPDATE_TAKE: + !n x y l. x < n /\ n <= LENGTH l ==> TAKE n (LUPDATE y x l) = LUPDATE y x (TAKE n l) +Proof + Induct_on `l` >> rw [] >> simp [LIST_EQ_REWRITE] >> Cases >> rw [EL_TAKE, EL_LUPDATE] -); +QED -Theorem swap_regs_perm - `!sth i1 i2 sthout. +Theorem swap_regs_perm: + !sth i1 i2 sthout. swap_regs i1 i2 sth = (Success (), sthout) ==> - (!n. i1 < n /\ i2 < n /\ n <= LENGTH sth.sorted_regs ==> PERM (TAKE n sth.sorted_regs) (TAKE n sthout.sorted_regs))` - (rw (swap_regs_def::msimps) >> + (!n. i1 < n /\ i2 < n /\ n <= LENGTH sth.sorted_regs ==> PERM (TAKE n sth.sorted_regs) (TAKE n sthout.sorted_regs)) +Proof + rw (swap_regs_def::msimps) >> fs [case_eq_thms] >> fs [if_thm] >> fs [linear_scan_hidden_state_component_equality] >> qpat_x_assum `_ = sthout.sorted_regs` (fn th => assume_tac (GSYM th)) >> `let l = TAKE n sth.sorted_regs in PERM l (LUPDATE (EL i1 l) i2 (LUPDATE (EL i2 l) i1 l))` by simp [swap_perm_lemma] >> rfs [EL_TAKE, LUPDATE_TAKE] -); +QED -Theorem partition_regs_correct - `!l rpiv begrpiv r sth. +Theorem partition_regs_correct: + !l rpiv begrpiv r sth. (!i. l <= i /\ i < r ==> EL i sth.sorted_regs < LENGTH sth.int_beg) /\ l <= LENGTH sth.sorted_regs /\ r <= LENGTH sth.sorted_regs ==> @@ -3894,9 +3953,9 @@ Theorem partition_regs_correct ($< LEX $<=) (EL reg sth.int_beg, reg) (begrpiv, rpiv)) /\ (!ind. mid <= ind /\ ind < r ==> let reg = EL ind sthout.sorted_regs in - ($< LEX $<=) (begrpiv, rpiv) (EL reg sth.int_beg, reg))` - - (recInduct partition_regs_ind >> + ($< LEX $<=) (begrpiv, rpiv) (EL reg sth.int_beg, reg)) +Proof + recInduct partition_regs_ind >> rpt strip_tac >> once_rewrite_tac [partition_regs_def] >> rw msimps @@ -3955,29 +4014,29 @@ Theorem partition_regs_correct ) ) ) -); +QED -Theorem PERM_EVERY_EQ - `!P l1 l2. +Theorem PERM_EVERY_EQ: + !P l1 l2. PERM l1 l2 ==> - (EVERY P l1 <=> EVERY P l2)` - - (rw [EVERY_MEM] >> + (EVERY P l1 <=> EVERY P l2) +Proof + rw [EVERY_MEM] >> eq_tac >> rw [] >> imp_res_tac PERM_MEM_EQ >> rw [] -); +QED -Theorem qsort_regs_prop_lemma - `!(P : num -> bool) l1 l2 l r. +Theorem qsort_regs_prop_lemma: + !(P : num -> bool) l1 l2 l r. l <= LENGTH l1 /\ r <= LENGTH l1 /\ (!ind. ind < l \/ r <= ind ==> EL ind l2 = EL ind l1) /\ (!ind. l <= ind /\ ind < r ==> P (EL ind l1)) /\ PERM l1 l2 ==> - (!ind. l <= ind /\ ind < r ==> P (EL ind l2))` - - (rpt gen_tac >> strip_tac >> + (!ind. l <= ind /\ ind < r ==> P (EL ind l2)) +Proof + rpt gen_tac >> strip_tac >> imp_res_tac PERM_LENGTH >> reverse (Cases_on `l <= r`) THEN1 fs [] >> `?l1_12 l1_3. l1 = l1_12 ++ l1_3 /\ LENGTH l1_12 = r` by metis_tac [split_at_indice] >> @@ -4010,10 +4069,10 @@ Theorem qsort_regs_prop_lemma fs [EVERY_EL] >> rw [] >> fs [EL_APPEND_EQN] -); +QED -Theorem qsort_regs_correct - `!l r sth. +Theorem qsort_regs_correct: + !l r sth. (!i. l <= i /\ i < r ==> EL i sth.sorted_regs < LENGTH sth.int_beg) /\ l <= LENGTH sth.sorted_regs /\ r <= LENGTH sth.sorted_regs ==> @@ -4026,9 +4085,9 @@ Theorem qsort_regs_correct let reg1 = EL i1 sthout.sorted_regs in let reg2 = EL i2 sthout.sorted_regs in ($< LEX $<=) (EL reg1 sth.int_beg, reg1) (EL reg2 sth.int_beg, reg2) - )` - - (recInduct qsort_regs_ind >> + ) +Proof + recInduct qsort_regs_ind >> rpt strip_tac >> once_rewrite_tac [qsort_regs_def] >> rw msimps @@ -4190,40 +4249,42 @@ Theorem qsort_regs_correct rw [LEX_DEF] >> intLib.COOPER_TAC ) -); +QED -Theorem swap_moves_eq - `!sth i1 i2. +Theorem swap_moves_eq: + !sth i1 i2. i1 < LENGTH sth.sorted_moves /\ i2 < LENGTH sth.sorted_moves ==> ?sthout. swap_moves i1 i2 sth = (Success (), sthout) /\ - sthout = sth with sorted_moves := LUPDATE (EL i1 sth.sorted_moves) i2 (LUPDATE (EL i2 sth.sorted_moves) i1 sth.sorted_moves)` - (rw (swap_moves_def::msimps) -); + sthout = sth with sorted_moves := LUPDATE (EL i1 sth.sorted_moves) i2 (LUPDATE (EL i2 sth.sorted_moves) i1 sth.sorted_moves) +Proof + rw (swap_moves_def::msimps) +QED -Theorem swap_moves_correct - `!sth i1 i2. +Theorem swap_moves_correct: + !sth i1 i2. i1 < LENGTH sth.sorted_moves /\ i2 < LENGTH sth.sorted_moves ==> ?sthout. swap_moves i1 i2 sth = (Success (), sthout) /\ sthout = sth with sorted_moves := sthout.sorted_moves /\ LENGTH sthout.sorted_moves = LENGTH sth.sorted_moves /\ - (!n. i1 < n /\ i2 < n /\ n <= LENGTH sth.sorted_moves ==> PERM (TAKE n sth.sorted_moves) (TAKE n sthout.sorted_moves))` - (rw (swap_moves_def::msimps) >> + (!n. i1 < n /\ i2 < n /\ n <= LENGTH sth.sorted_moves ==> PERM (TAKE n sth.sorted_moves) (TAKE n sthout.sorted_moves)) +Proof + rw (swap_moves_def::msimps) >> fs [case_eq_thms] >> fs [if_thm] >> `let l = TAKE n sth.sorted_moves in PERM l (LUPDATE (EL i1 l) i2 (LUPDATE (EL i2 l) i1 l))` by simp [swap_perm_lemma] >> rfs [EL_TAKE, LUPDATE_TAKE] -); +QED -Theorem partition_moves_correct - `!l ppiv r sth. +Theorem partition_moves_correct: + !l ppiv r sth. l <= LENGTH sth.sorted_moves /\ r <= LENGTH sth.sorted_moves ==> ?mid sthout. partition_moves l ppiv r sth = (Success mid, sthout) /\ (l <= r ==> l <= mid /\ mid <= r) /\ sthout = sth with sorted_moves := sthout.sorted_moves /\ LENGTH sthout.sorted_moves = LENGTH sth.sorted_moves /\ - (!n. l <= n /\ r <= n /\ n <= LENGTH sth.sorted_moves ==> PERM (TAKE n sth.sorted_moves) (TAKE n sthout.sorted_moves))` - - (recInduct partition_moves_ind >> + (!n. l <= n /\ r <= n /\ n <= LENGTH sth.sorted_moves ==> PERM (TAKE n sth.sorted_moves) (TAKE n sthout.sorted_moves)) +Proof + recInduct partition_moves_ind >> rw [] >> once_rewrite_tac [partition_moves_def] >> rw msimps @@ -4244,18 +4305,18 @@ Theorem partition_moves_correct rpt (first_x_assum (qspec_then `n` assume_tac)) >> rfs [] >> metis_tac [PERM_TRANS] -); +QED -Theorem qsort_moves_correct - `!l r sth. +Theorem qsort_moves_correct: + !l r sth. l <= LENGTH sth.sorted_moves /\ r <= LENGTH sth.sorted_moves ==> ?sthout. qsort_moves l r sth = (Success (), sthout) /\ sthout = sth with sorted_moves := sthout.sorted_moves /\ LENGTH sthout.sorted_moves = LENGTH sth.sorted_moves /\ - (!n. l <= n /\ r <= n /\ n <= LENGTH sth.sorted_moves ==> PERM (TAKE n sth.sorted_moves) (TAKE n sthout.sorted_moves))` - - (recInduct qsort_moves_ind >> + (!n. l <= n /\ r <= n /\ n <= LENGTH sth.sorted_moves ==> PERM (TAKE n sth.sorted_moves) (TAKE n sthout.sorted_moves)) +Proof + recInduct qsort_moves_ind >> rw [] >> once_rewrite_tac [qsort_moves_def] >> rw msimps @@ -4278,12 +4339,13 @@ Theorem qsort_moves_correct rpt (first_x_assum (qspec_then `n` assume_tac)) >> rfs [] >> metis_tac [PERM_TRANS] -); +QED -Theorem list_minimum - `!f (l:num list). ?(x:int). EVERY (\y. x <= f y) l` - (gen_tac >> Induct_on `l` >> +Theorem list_minimum: + !f (l:num list). ?(x:int). EVERY (\y. x <= f y) l +Proof + gen_tac >> Induct_on `l` >> rw [] >> Cases_on `x <= f h` THEN1 ( @@ -4296,40 +4358,40 @@ Theorem list_minimum rw [] >> res_tac >> intLib.COOPER_TAC ) -); +QED -Theorem linear_reg_alloc_pass1_initial_state_invariants - `!sth reglist forced k st. +Theorem linear_reg_alloc_pass1_initial_state_invariants: + !sth reglist forced k st. LENGTH sth.int_beg = LENGTH sth.colors /\ LENGTH sth.int_end = LENGTH sth.colors ==> ?pos. good_linear_scan_state (linear_reg_alloc_pass1_initial_state k) sth [] pos forced 0 /\ - EVERY (\r. pos <= EL r sth.int_beg) reglist` - - (rw [good_linear_scan_state_def', linear_reg_alloc_pass1_initial_state_def] >> rw [] >> + EVERY (\r. pos <= EL r sth.int_beg) reglist +Proof + rw [good_linear_scan_state_def', linear_reg_alloc_pass1_initial_state_def] >> rw [] >> qspecl_then [`\r. EL r sth.int_beg`, `reglist`] assume_tac list_minimum >> fs [] >> qexists_tac `x` >> rw [] >> Induct_on `forced` >> rw [] >> pairarg_tac >> rw [] -); +QED -Theorem linear_reg_alloc_pass2_initial_state_invariants - `!sth reglist forced k nreg st. +Theorem linear_reg_alloc_pass2_initial_state_invariants: + !sth reglist forced k nreg st. LENGTH sth.int_beg = LENGTH sth.colors /\ LENGTH sth.int_end = LENGTH sth.colors ==> ?pos. good_linear_scan_state (linear_reg_alloc_pass2_initial_state k nreg) sth [] pos forced k /\ - EVERY (\r. pos <= EL r sth.int_beg) reglist` - - (rw [good_linear_scan_state_def', linear_reg_alloc_pass2_initial_state_def] >> rw [] >> + EVERY (\r. pos <= EL r sth.int_beg) reglist +Proof + rw [good_linear_scan_state_def', linear_reg_alloc_pass2_initial_state_def] >> rw [] >> qspecl_then [`\r. EL r sth.int_beg`, `reglist`] assume_tac list_minimum >> fs [] >> qexists_tac `x` >> rw [] >> Induct_on `forced` >> rw [] >> pairarg_tac >> rw [] -); +QED -Theorem st_ex_FILTER_good_stack - `!reglist sth k. +Theorem st_ex_FILTER_good_stack: + !reglist sth k. EVERY (\r. r < LENGTH sth.colors) reglist ==> st_ex_FILTER_good (\r. do @@ -4337,83 +4399,91 @@ Theorem st_ex_FILTER_good_stack return (is_stack_var r \/ k <= col); od ) reglist sth = - (Success (FILTER (\r. is_stack_var r \/ k <= EL r sth.colors) reglist), sth)` - - (simp msimps >> + (Success (FILTER (\r. is_stack_var r \/ k <= EL r sth.colors) reglist), sth) +Proof + simp msimps >> Induct_on `reglist` >> rw (st_ex_FILTER_good_def::msimps) -); +QED -Theorem lookup_fromAList_MAP_not_NONE - `!r l. lookup r (fromAList (MAP (\r. (r,())) l)) <> NONE <=> MEM r l` - (rw [] >> +Theorem lookup_fromAList_MAP_not_NONE: + !r l. lookup r (fromAList (MAP (\r. (r,())) l)) <> NONE <=> MEM r l +Proof + rw [] >> Cases_on `lookup r (fromAList (MAP (\r. (r,())) l))` >> fs [] THEN1 fs [lookup_NONE_domain, domain_fromAList, MEM_MAP, FORALL_PROD] THEN1 ( `r IN domain (fromAList (MAP (\r. (r,())) l))` by fs [domain_lookup] >> fs [domain_fromAList, MEM_MAP, EXISTS_PROD] ) -); +QED -Theorem PERM_PARTITION - `!P l. PERM l ((FILTER (\x. P x) l) ++ (FILTER (\x. ~P x) l))` - (rw [PERM_DEF, FILTER_APPEND, FILTER_FILTER] >> +Theorem PERM_PARTITION: + !P l. PERM l ((FILTER (\x. P x) l) ++ (FILTER (\x. ~P x) l)) +Proof + rw [PERM_DEF, FILTER_APPEND, FILTER_FILTER] >> simp [METIS_PROVE [] ``!a b. a=b /\ P b <=> a=b /\ P a``] >> Cases_on `P x` >> simp [] >> metis_tac [FUN_EQ_THM] -); +QED -Theorem forbidden_is_from_forced_take_sublist - `EVERY (\r1,r2. MEM r1 l /\ MEM r2 l) forced /\ +Theorem forbidden_is_from_forced_take_sublist: + EVERY (\r1,r2. MEM r1 l /\ MEM r2 l) forced /\ (!r. forbidden_is_from_forced forced int_beg r (the [] (lookup r forced_adj))) ==> - (!r. forbidden_is_from_forced_sublist l forced int_beg r (the [] (lookup r forced_adj)))` - (rw [forbidden_is_from_forced_def, forbidden_is_from_forced_sublist_def, GSYM intbeg_less_def, EVERY_MEM, FORALL_PROD] >> + (!r. forbidden_is_from_forced_sublist l forced int_beg r (the [] (lookup r forced_adj))) +Proof + rw [forbidden_is_from_forced_def, forbidden_is_from_forced_sublist_def, GSYM intbeg_less_def, EVERY_MEM, FORALL_PROD] >> metis_tac [] -); +QED -Theorem good_linear_scan_state_REVERSE - `!st sth l pos forced mincol. +Theorem good_linear_scan_state_REVERSE: + !st sth l pos forced mincol. good_linear_scan_state st sth (REVERSE l) pos forced mincol <=> - good_linear_scan_state st sth l pos forced mincol` - (rw [good_linear_scan_state_def'] >> + good_linear_scan_state st sth l pos forced mincol +Proof + rw [good_linear_scan_state_def'] >> eq_tac >> rw [EVERY_REVERSE, FILTER_REVERSE, MAP_REVERSE, ALL_DISTINCT_REVERSE] -); - -Theorem phystack_on_stack_REVERSE - `!l st sth. phystack_on_stack (REVERSE l) st sth <=> phystack_on_stack l st sth` - (rw [phystack_on_stack_def] -); - -Theorem FILTER_remove_MEM_l - `!P l. FILTER (\x. P x /\ MEM x l) l = FILTER (\x. P x) l` - (sg `!P l1 l2. (!x. MEM x l1 ==> MEM x l2) ==> FILTER (\x. P x /\ MEM x l2) l1 = FILTER (\x. P x) l1` THEN1 ( +QED + +Theorem phystack_on_stack_REVERSE: + !l st sth. phystack_on_stack (REVERSE l) st sth <=> phystack_on_stack l st sth +Proof + rw [phystack_on_stack_def] +QED + +Theorem FILTER_remove_MEM_l: + !P l. FILTER (\x. P x /\ MEM x l) l = FILTER (\x. P x) l +Proof + sg `!P l1 l2. (!x. MEM x l1 ==> MEM x l2) ==> FILTER (\x. P x /\ MEM x l2) l1 = FILTER (\x. P x) l1` THEN1 ( Induct_on `l1` >> rw [] ) >> metis_tac [] -); +QED -Theorem le_div_2 - `!k r. k <= r DIV 2 <=> 2*k <= r` - (intLib.COOPER_TAC -); +Theorem le_div_2: + !k r. k <= r DIV 2 <=> 2*k <= r +Proof + intLib.COOPER_TAC +QED -Theorem lt_div_2 - `!k r. r DIV 2 < k <=> r < 2*k` - (intLib.COOPER_TAC -); +Theorem lt_div_2: + !k r. r DIV 2 < k <=> r < 2*k +Proof + intLib.COOPER_TAC +QED -Theorem list_to_sorted_regs_correct - `!l n sth. +Theorem list_to_sorted_regs_correct: + !l n sth. n + LENGTH l <= LENGTH sth.sorted_regs ==> ?sthout. (Success (), sthout) = list_to_sorted_regs l n sth /\ LENGTH sthout.sorted_regs = LENGTH sth.sorted_regs /\ sthout = sth with sorted_regs := sthout.sorted_regs /\ TAKE n sthout.sorted_regs = TAKE n sth.sorted_regs /\ - TAKE (LENGTH l) (DROP n sthout.sorted_regs) = l` - - (Induct_on `l` >> + TAKE (LENGTH l) (DROP n sthout.sorted_regs) = l +Proof + Induct_on `l` >> rw (linear_scan_hidden_state_component_equality::list_to_sorted_regs_def::msimps) THEN1 ( qexists_tac `sth` >> @@ -4440,14 +4510,14 @@ Theorem list_to_sorted_regs_correct rpt (first_x_assum (qspec_then `x` assume_tac)) >> rfs [EL_TAKE, EL_DROP, ADD1] ) -); +QED -Theorem sorted_regs_to_list_correct - `!n last sth. +Theorem sorted_regs_to_list_correct: + !n last sth. last <= LENGTH sth.sorted_regs ==> - sorted_regs_to_list n last sth = (Success (TAKE (last-n) (DROP n sth.sorted_regs)), sth)` - - (recInduct sorted_regs_to_list_ind >> + sorted_regs_to_list n last sth = (Success (TAKE (last-n) (DROP n sth.sorted_regs)), sth) +Proof + recInduct sorted_regs_to_list_ind >> rw [] >> once_rewrite_tac [sorted_regs_to_list_def] >> rw msimps >> @@ -4457,18 +4527,18 @@ Theorem sorted_regs_to_list_correct simp [LIST_EQ_REWRITE] >> Cases >> rw [EL_TAKE, EL_DROP, ADD1] -); +QED -Theorem list_to_sorted_moves_correct - `!l n sth. +Theorem list_to_sorted_moves_correct: + !l n sth. n + LENGTH l <= LENGTH sth.sorted_moves ==> ?sthout. (Success (), sthout) = list_to_sorted_moves l n sth /\ LENGTH sthout.sorted_moves = LENGTH sth.sorted_moves /\ sthout = sth with sorted_moves := sthout.sorted_moves /\ TAKE n sthout.sorted_moves = TAKE n sth.sorted_moves /\ - TAKE (LENGTH l) (DROP n sthout.sorted_moves) = l` - - (Induct_on `l` >> + TAKE (LENGTH l) (DROP n sthout.sorted_moves) = l +Proof + Induct_on `l` >> rw (linear_scan_hidden_state_component_equality::list_to_sorted_moves_def::msimps) THEN1 ( qexists_tac `sth` >> @@ -4495,14 +4565,14 @@ Theorem list_to_sorted_moves_correct rpt (first_x_assum (qspec_then `x` assume_tac)) >> rfs [EL_TAKE, EL_DROP, ADD1] ) -); +QED -Theorem sorted_moves_to_list_correct - `!n last sth. +Theorem sorted_moves_to_list_correct: + !n last sth. last <= LENGTH sth.sorted_moves ==> - sorted_moves_to_list n last sth = (Success (TAKE (last-n) (DROP n sth.sorted_moves)), sth)` - - (recInduct sorted_moves_to_list_ind >> + sorted_moves_to_list n last sth = (Success (TAKE (last-n) (DROP n sth.sorted_moves)), sth) +Proof + recInduct sorted_moves_to_list_ind >> rw [] >> once_rewrite_tac [sorted_moves_to_list_def] >> rw msimps >> @@ -4512,10 +4582,10 @@ Theorem sorted_moves_to_list_correct simp [LIST_EQ_REWRITE] >> Cases >> rw [EL_TAKE, EL_DROP, ADD1] -); +QED -Theorem linear_reg_alloc_intervals_correct - `!k forced moves reglist_unsorted sth. +Theorem linear_reg_alloc_intervals_correct: + !k forced moves reglist_unsorted sth. EVERY (\r1,r2. MEM r1 reglist_unsorted /\ MEM r2 reglist_unsorted) forced /\ EVERY (\r1,r2. r1 < LENGTH sth.colors /\ r2 < LENGTH sth.colors) (MAP SND moves) /\ EVERY (\r. r < LENGTH sth.colors) reglist_unsorted /\ @@ -4541,9 +4611,9 @@ Theorem linear_reg_alloc_intervals_correct T ) reglist_unsorted /\ EVERY (\r1,r2. EL r1 sthout.colors = EL r2 sthout.colors ==> r1 = r2) forced /\ - LENGTH sthout.colors = LENGTH sth.colors` - - (rw (linear_reg_alloc_intervals_def::msimps) >> + LENGTH sthout.colors = LENGTH sth.colors +Proof + rw (linear_reg_alloc_intervals_def::msimps) >> qspecl_then [`reglist_unsorted`, `0`, `sth`] assume_tac list_to_sorted_regs_correct >> rfs [linear_scan_hidden_state_component_equality] >> @@ -4935,7 +5005,7 @@ Theorem linear_reg_alloc_intervals_correct fs [] ) ) -); +QED val good_bijection_state_def = Define` good_bijection_state st regset = ( @@ -4958,19 +5028,20 @@ val good_bijection_state_def = Define` ) `; -Theorem convention_partitions_or - `!r. ( is_phy_var r /\ ~is_stack_var r /\ ~is_alloc_var r) \/ +Theorem convention_partitions_or: + !r. ( is_phy_var r /\ ~is_stack_var r /\ ~is_alloc_var r) \/ (~is_phy_var r /\ is_stack_var r /\ ~is_alloc_var r) \/ - (~is_phy_var r /\ ~is_stack_var r /\ is_alloc_var r)` - (metis_tac [convention_partitions] -); + (~is_phy_var r /\ ~is_stack_var r /\ is_alloc_var r) +Proof + metis_tac [convention_partitions] +QED -Theorem find_bijection_invariants - `!st r regset. +Theorem find_bijection_invariants: + !st r regset. good_bijection_state st regset ==> - good_bijection_state (find_bijection_step st r) (r INSERT regset)` - - (simp [find_bijection_step_def] >> + good_bijection_state (find_bijection_step st r) (r INSERT regset) +Proof + simp [find_bijection_step_def] >> rpt strip_tac >> Cases_on `lookup r st.bij <> NONE` THEN1 ( `r IN domain st.bij` by metis_tac [option_nchotomy, domain_lookup] >> @@ -5065,37 +5136,38 @@ Theorem find_bijection_invariants qspec_then `r` assume_tac convention_partitions_or >> fs [] >> rw [the_def, lookup_insert] ) -); +QED -Theorem FOLDL_find_bijection_invariants - `!st l regset. +Theorem FOLDL_find_bijection_invariants: + !st l regset. good_bijection_state st regset ==> - good_bijection_state (FOLDL find_bijection_step st l) (set l UNION regset)` - - (Induct_on `l` >> + good_bijection_state (FOLDL find_bijection_step st l) (set l UNION regset) +Proof + Induct_on `l` >> rw [] >> `good_bijection_state (find_bijection_step st h) (h INSERT regset)` by simp [find_bijection_invariants] >> first_x_assum (qspecl_then [`find_bijection_step st h`, `h INSERT regset`] assume_tac) >> rfs [] >> `(h INSERT set l) UNION regset = (set l UNION (h INSERT regset))` by (rw [EXTENSION] >> metis_tac []) >> simp [] -); +QED -Theorem foldi_find_bijection_invariants - `!st s regset. +Theorem foldi_find_bijection_invariants: + !st s regset. good_bijection_state st regset ==> - good_bijection_state (foldi (\r v acc. find_bijection_step acc r) 0 st s) (domain s UNION regset)` - (rw [foldi_FOLDR_toAList] >> + good_bijection_state (foldi (\r v acc. find_bijection_step acc r) 0 st s) (domain s UNION regset) +Proof + rw [foldi_FOLDR_toAList] >> `FOLDR (\(r,v) acc. find_bijection_step acc r) st (toAList s) = FOLDR (\r acc. find_bijection_step acc r) st (MAP FST (toAList s))` by simp [FOLDR_MAP, LAMBDA_PROD] >> `(\a b. find_bijection_step a b) = find_bijection_step` by rw [FUN_EQ_THM] >> fs [FOLDR_FOLDL_REVERSE] >> once_rewrite_tac [GSYM set_MAP_FST_toAList_eq_domain] >> once_rewrite_tac [GSYM LIST_TO_SET_REVERSE] >> simp [FOLDL_find_bijection_invariants] -); +QED -Theorem in_clash_tree_set_eq - `(!w r. in_clash_tree (Delta w r) = set w UNION set r) /\ +Theorem in_clash_tree_set_eq: + (!w r. in_clash_tree (Delta w r) = set w UNION set r) /\ (!names. in_clash_tree (Set names) = domain names) /\ (!name_opt t1 t2. in_clash_tree (Branch name_opt t1 t2) = @@ -5103,19 +5175,20 @@ Theorem in_clash_tree_set_eq | SOME names => domain names UNION in_clash_tree t1 UNION in_clash_tree t2 | NONE => in_clash_tree t1 UNION in_clash_tree t2 ) /\ - (!t1 t2. in_clash_tree (Seq t1 t2) = in_clash_tree t1 UNION in_clash_tree t2)` - (rw [in_clash_tree_def, EXTENSION, IN_DEF] >> + (!t1 t2. in_clash_tree (Seq t1 t2) = in_clash_tree t1 UNION in_clash_tree t2) +Proof + rw [in_clash_tree_def, EXTENSION, IN_DEF] >> CASE_TAC >> rw [UNION_DEF, IN_DEF] >> metis_tac [] -); +QED -Theorem find_bijection_clash_tree_invariants - `!st ct regset. +Theorem find_bijection_clash_tree_invariants: + !st ct regset. good_bijection_state st regset ==> - good_bijection_state (find_bijection_clash_tree st ct) (in_clash_tree ct UNION regset)` - - (Induct_on `ct` >> + good_bijection_state (find_bijection_clash_tree st ct) (in_clash_tree ct UNION regset) +Proof + Induct_on `ct` >> rw [find_bijection_clash_tree_def] THEN1 ( simp [in_clash_tree_set_eq, GSYM UNION_ASSOC] >> @@ -5135,12 +5208,13 @@ Theorem find_bijection_clash_tree_invariants simp [in_clash_tree_set_eq] >> metis_tac [UNION_COMM, UNION_ASSOC] ) -); +QED -Theorem find_bijection_init_invariants - `good_bijection_state find_bijection_init EMPTY` - (simp [good_bijection_state_def, find_bijection_init_def, sp_inverts_def, lookup_def, is_stack_var_def, is_alloc_var_def, the_def] -); +Theorem find_bijection_init_invariants: + good_bijection_state find_bijection_init EMPTY +Proof + simp [good_bijection_state_def, find_bijection_init_def, sp_inverts_def, lookup_def, is_stack_var_def, is_alloc_var_def, the_def] +QED val sptree_eq_list_def = Define` sptree_eq_list (s : int num_map) l = !i. @@ -5149,17 +5223,17 @@ val sptree_eq_list_def = Define` (EL i l <= 0 <=> lookup i s = SOME (EL i l)) ` -Theorem numset_list_add_if_lt_monad_correct - `!int_beg sth l v. +Theorem numset_list_add_if_lt_monad_correct: + !int_beg sth l v. v <= 0 /\ sptree_eq_list int_beg sth.int_beg /\ EVERY (\r. r < LENGTH sth.int_beg) l ==> ?sthout. numset_list_add_if_lt_monad l v sth = (Success (), sthout) /\ sptree_eq_list (numset_list_add_if_lt l v int_beg) sthout.int_beg /\ sthout = sth with int_beg := sthout.int_beg /\ - LENGTH sthout.int_beg = LENGTH sth.int_beg` - - (Induct_on `l` >> + LENGTH sthout.int_beg = LENGTH sth.int_beg +Proof + Induct_on `l` >> rw ([numset_list_add_if_lt_def, numset_list_add_if_def, numset_list_add_if_lt_monad_def] @ msimps) >> fs [GSYM numset_list_add_if_lt_def] >> `!(n : int). ~(0 < n) <=> n <= 0` by intLib.COOPER_TAC >> @@ -5168,19 +5242,19 @@ Theorem numset_list_add_if_lt_monad_correct impl_tac THEN1 rw [EL_LUPDATE, lookup_insert] >> rw [] ) -); +QED -Theorem numset_list_add_if_gt_monad_correct - `!int_end sth l v. +Theorem numset_list_add_if_gt_monad_correct: + !int_end sth l v. v <= 0 /\ sptree_eq_list int_end sth.int_end /\ EVERY (\r. r < LENGTH sth.int_end) l ==> ?sthout. numset_list_add_if_gt_monad l v sth = (Success (), sthout) /\ sptree_eq_list (numset_list_add_if_gt l v int_end) sthout.int_end /\ sthout = sth with int_end := sthout.int_end /\ - LENGTH sthout.int_end = LENGTH sth.int_end` - - (Induct_on `l` >> + LENGTH sthout.int_end = LENGTH sth.int_end +Proof + Induct_on `l` >> rw ([numset_list_add_if_gt_def, numset_list_add_if_def, numset_list_add_if_gt_monad_def] @ msimps) >> fs [GSYM numset_list_add_if_gt_def] >> `!(n : int). ~(0 < n) <=> n <= 0` by intLib.COOPER_TAC >> @@ -5189,10 +5263,10 @@ Theorem numset_list_add_if_gt_monad_correct impl_tac THEN1 rw [EL_LUPDATE, lookup_insert] >> rw [] ) -); +QED -Theorem get_intervals_ct_monad_aux_correct - `!ct sth live n int_beg int_end nout int_begout int_endout liveout. +Theorem get_intervals_ct_monad_aux_correct: + !ct sth live n int_beg int_end nout int_begout int_endout liveout. n <= 0 /\ sptree_eq_list int_beg sth.int_beg /\ sptree_eq_list int_end sth.int_end /\ @@ -5207,9 +5281,9 @@ Theorem get_intervals_ct_monad_aux_correct LENGTH sthout.int_end = LENGTH sth.int_end /\ (!r. r IN domain liveout ==> r < LENGTH sth.int_beg) /\ sthout = sth with <| int_beg := sthout.int_beg ; int_end := sthout.int_end |> /\ - nout <= 0` - - (Induct_on `ct` >> + nout <= 0 +Proof + Induct_on `ct` >> rw ([get_intervals_ct_monad_aux_def, get_intervals_ct_aux_def] @ msimps) THEN1 ( @@ -5283,10 +5357,10 @@ Theorem get_intervals_ct_monad_aux_correct strip_tac >> rw [] >> rfs [linear_scan_hidden_state_component_equality] ) -); +QED -Theorem get_intervals_ct_monad_correct - `!ct sth n int_beg int_end. +Theorem get_intervals_ct_monad_correct: + !ct sth n int_beg int_end. (!i. i < LENGTH sth.int_beg ==> 0 < EL i sth.int_beg) /\ (!i. i < LENGTH sth.int_end ==> 0 < EL i sth.int_end) /\ get_intervals_ct ct = (n, int_beg, int_end) /\ @@ -5297,9 +5371,9 @@ Theorem get_intervals_ct_monad_correct sptree_eq_list int_end sthout.int_end /\ LENGTH sthout.int_beg = LENGTH sth.int_beg /\ LENGTH sthout.int_end = LENGTH sth.int_end /\ - sthout = sth with <| int_beg := sthout.int_beg ; int_end := sthout.int_end |>` - - (`!(n : int). ~(n <= 0) <=> 0 < n` by intLib.COOPER_TAC >> + sthout = sth with <| int_beg := sthout.int_beg ; int_end := sthout.int_end |> +Proof + `!(n : int). ~(n <= 0) <=> 0 < n` by intLib.COOPER_TAC >> rw (get_intervals_ct_monad_def :: get_intervals_ct_def :: msimps) >> rpt (pairarg_tac >> fs []) >> rename1 `get_intervals_ct_aux _ _ _ _ _ = (n1, int_beg1, int_end1, live)` >> @@ -5320,12 +5394,12 @@ Theorem get_intervals_ct_monad_correct strip_tac >> simp [] >> rename1 `_ = (Success _, sth2)` >> fs [linear_scan_hidden_state_component_equality] -); - -Theorem in_clash_tree_eq_live_tree_registers - `!ct r. in_clash_tree ct r <=> r IN (live_tree_registers (get_live_tree ct))` +QED - (Induct_on `ct` >> +Theorem in_clash_tree_eq_live_tree_registers: + !ct r. in_clash_tree ct r <=> r IN (live_tree_registers (get_live_tree ct)) +Proof + Induct_on `ct` >> rw [in_clash_tree_def, live_tree_registers_def, get_live_tree_def, set_MAP_FST_toAList_eq_domain] THEN1 metis_tac [] THEN1 ( @@ -5334,34 +5408,36 @@ Theorem in_clash_tree_eq_live_tree_registers simp [MEM_MAP, EXISTS_PROD, MEM_toAList, domain_lookup] >> metis_tac [] ) -); +QED -Theorem get_live_backward_in_live_tree_registers - `!lt live. domain (get_live_backward lt live) SUBSET domain live UNION live_tree_registers lt` - (Induct_on `lt` >> +Theorem get_live_backward_in_live_tree_registers: + !lt live. domain (get_live_backward lt live) SUBSET domain live UNION live_tree_registers lt +Proof + Induct_on `lt` >> simp [get_live_backward_def, live_tree_registers_def, domain_numset_list_delete, domain_numset_list_insert, branch_domain] >> fs [SUBSET_DEF] >> metis_tac [] -); +QED -Theorem fix_domination_live_tree_registers - `!lt. live_tree_registers (fix_domination lt) = live_tree_registers lt` - (rw [fix_domination_def, live_tree_registers_def] >> +Theorem fix_domination_live_tree_registers: + !lt. live_tree_registers (fix_domination lt) = live_tree_registers lt +Proof + rw [fix_domination_def, live_tree_registers_def] >> `set (MAP FST (toAList (get_live_backward lt LN))) = domain (get_live_backward lt LN)` by rw [EXTENSION, MEM_MAP, EXISTS_PROD, MEM_toAList, domain_lookup] >> qspecl_then [`lt`, `LN`] assume_tac get_live_backward_in_live_tree_registers >> fs [SUBSET_DEF, EXTENSION] >> metis_tac [] -); +QED -Theorem get_intervals_beg_less_end - `!lt n_in beg_in end_in n_out beg_out end_out. +Theorem get_intervals_beg_less_end: + !lt n_in beg_in end_in n_out beg_out end_out. (!r. r IN domain beg_in ==> the 0 (lookup r beg_in) <= the 0 (lookup r end_in)) /\ domain beg_in SUBSET domain end_in /\ (n_out, beg_out, end_out) = get_intervals lt n_in beg_in end_in ==> (!r. r IN domain beg_out ==> the 0 (lookup r beg_out) <= the 0 (lookup r end_out)) /\ - domain beg_out SUBSET domain end_out` - - (Induct_on `lt` >> + domain beg_out SUBSET domain end_out +Proof + Induct_on `lt` >> simp [get_intervals_def] >> rpt gen_tac >> strip_tac THEN1 ( @@ -5403,10 +5479,10 @@ Theorem get_intervals_beg_less_end rpt (pairarg_tac >> fs []) >> `!r. r IN domain int_beg2 ==> the 0 (lookup r int_beg2) <= the 0 (lookup r int_end2)` by metis_tac [] >> metis_tac [] -); +QED -Theorem linear_reg_alloc_without_renaming_correct - `!k moves ct forced. +Theorem linear_reg_alloc_without_renaming_correct: + !k moves ct forced. (!i. i < LENGTH sth.int_beg ==> 0 < EL i sth.int_beg) /\ (!i. i < LENGTH sth.int_end ==> 0 < EL i sth.int_end) /\ LENGTH sth.int_end = LENGTH sth.int_beg /\ @@ -5435,9 +5511,9 @@ Theorem linear_reg_alloc_without_renaming_correct T ) /\ EVERY (\r1,r2. EL r1 sthout.colors = EL r2 sthout.colors ==> r1 = r2) forced /\ - LENGTH sthout.colors = LENGTH sth.colors` - - (rw msimps >> + LENGTH sthout.colors = LENGTH sth.colors +Proof + rw msimps >> `?n int_beg int_end. get_intervals_ct ct = (n, int_beg, int_end)` by simp [GSYM EXISTS_PROD] >> qspecl_then [`ct`, `sth`, `n`, `int_beg`, `int_end`] mp_tac get_intervals_ct_monad_correct >> impl_tac THEN1 rw [] >> @@ -5497,18 +5573,18 @@ Theorem linear_reg_alloc_without_renaming_correct impl_tac THEN1 rw [] >> strip_tac >> rw [] >> fs [EVERY_MEM] -); +QED -Theorem check_col_apply_bijection - `!(cutset:num_set) livein flivein f. +Theorem check_col_apply_bijection: + !(cutset:num_set) livein flivein f. (!r. r IN bijdom ==> (appbij r) IN bijcodom /\ appinvbij (appbij r) = r) /\ (!r. r IN bijcodom ==> (appinvbij r) IN bijdom /\ appbij (appinvbij r) = r) /\ domain cutset SUBSET bijdom /\ check_col f (foldi (\r _ acc. insert (appbij r) () acc) 0 LN cutset) = SOME (livein, flivein) ==> ?livein' flivein'. check_col (\r. f (appbij r)) cutset = SOME (livein', flivein') /\ - domain livein' = IMAGE appinvbij (domain livein)` - - (simp [check_col_def] >> + domain livein' = IMAGE appinvbij (domain livein) +Proof + simp [check_col_def] >> rpt gen_tac >> strip_tac >> fs [MAP_o, foldi_FOLDR_toAList] >> `FOLDR (\(r,_) acc. insert (appbij r) () acc) LN (toAList cutset) = FOLDR (\r acc. insert (appbij r) () acc) LN (MAP FST (toAList cutset))` by rw [FOLDR_MAP, LAMBDA_PROD] >> @@ -5533,11 +5609,11 @@ Theorem check_col_apply_bijection rw [EXTENSION] >> metis_tac [SUBSET_DEF] ) -); +QED -Theorem check_partial_col_apply_bijection - `!l live flive live' flive' livein flivein. +Theorem check_partial_col_apply_bijection: + !l live flive live' flive' livein flivein. (!r. r IN bijdom ==> (appbij r) IN bijcodom /\ appinvbij (appbij r) = r) /\ (!r. r IN bijcodom ==> (appinvbij r) IN bijdom /\ appbij (appinvbij r) = r) /\ (set l) SUBSET bijdom /\ @@ -5548,9 +5624,9 @@ Theorem check_partial_col_apply_bijection INJ f (domain live) UNIV /\ check_partial_col f (MAP appbij l) live flive = SOME (livein, flivein) ==> ?livein' flivein'. check_partial_col (\r. f (appbij r)) l live' flive' = SOME (livein', flivein') /\ - domain livein' = IMAGE appinvbij (domain livein)` - - (Induct_on `l` >> + domain livein' = IMAGE appinvbij (domain livein) +Proof + Induct_on `l` >> rw [check_partial_col_def] >> `domain flive' = domain flive` by (rw [EXTENSION] >> fs [] >> metis_tac [SUBSET_DEF]) >> fs [case_eq_thms] @@ -5579,13 +5655,14 @@ Theorem check_partial_col_apply_bijection `appinvbij (appbij h) IN domain live'` by (fs [] >> metis_tac []) >> rfs [domain_lookup] ) -); +QED -Theorem check_clash_tree_output_subset - `!ct live flive livein flivein. +Theorem check_clash_tree_output_subset: + !ct live flive livein flivein. check_clash_tree f ct live flive = SOME (livein, flivein) ==> - domain livein SUBSET domain live UNION in_clash_tree ct` - (Induct_on `ct` >> + domain livein SUBSET domain live UNION in_clash_tree ct +Proof + Induct_on `ct` >> rw [check_clash_tree_def, in_clash_tree_set_eq] >> fs [case_eq_thms] THEN1 ( @@ -5607,12 +5684,12 @@ Theorem check_clash_tree_output_subset fs [SUBSET_DEF] >> metis_tac [] ) -); - -Theorem domain_apply_bij_set - `!s bij. domain (foldi (λr _ acc. insert (the 0 (lookup r bij)) () acc) 0 LN s) = IMAGE (\r. the 0n (lookup r bij)) (domain s)` +QED - (rw [foldi_FOLDR_toAList] >> +Theorem domain_apply_bij_set: + !s bij. domain (foldi (λr _ acc. insert (the 0 (lookup r bij)) () acc) 0 LN s) = IMAGE (\r. the 0n (lookup r bij)) (domain s) +Proof + rw [foldi_FOLDR_toAList] >> `FOLDR (\(r,_) acc. insert (the 0 (lookup r bij)) () acc) LN (toAList s) = FOLDR (\r acc. insert (the 0 (lookup r bij)) () acc) LN (MAP FST (toAList s))` by rw [FOLDR_MAP, LAMBDA_PROD] >> simp [] >> `domain s = set (MAP FST (toAList s))` by simp [set_MAP_FST_toAList_eq_domain] >> @@ -5623,14 +5700,14 @@ Theorem domain_apply_bij_set qpat_x_assum `domain _ = set _` kall_tac >> Induct_on `l` >> rw [] -); +QED -Theorem in_clash_tree_apply_bij - `!bij ct. +Theorem in_clash_tree_apply_bij: + !bij ct. in_clash_tree ct SUBSET domain bij ==> - in_clash_tree (apply_bij_on_clash_tree ct bij) = IMAGE (\r. the 0n (lookup r bij)) (in_clash_tree ct)` - - (Induct_on `ct` >> + in_clash_tree (apply_bij_on_clash_tree ct bij) = IMAGE (\r. the 0n (lookup r bij)) (in_clash_tree ct) +Proof + Induct_on `ct` >> rw [apply_bij_on_clash_tree_def, in_clash_tree_set_eq, LIST_TO_SET_MAP] THEN1 ( simp [domain_apply_bij_set] @@ -5641,10 +5718,10 @@ Theorem in_clash_tree_apply_bij simp [domain_apply_bij_set] >> fs [] ) -); +QED -Theorem check_clash_tree_apply_bijection - `!bij invbij f ct live flive live' flive' livein flivein. +Theorem check_clash_tree_apply_bijection: + !bij invbij f ct live flive live' flive' livein flivein. sp_inverts bij invbij /\ sp_inverts invbij bij /\ in_clash_tree ct SUBSET domain bij /\ @@ -5655,9 +5732,9 @@ Theorem check_clash_tree_apply_bijection INJ f (domain live) UNIV /\ check_clash_tree f (apply_bij_on_clash_tree ct bij) live flive = SOME (livein, flivein) ==> ?livein' flivein'. check_clash_tree (\r. f (the 0n (lookup r bij))) ct live' flive' = SOME (livein', flivein') /\ - domain livein' = IMAGE (\r. the 0n (lookup r invbij)) (domain livein)` - - (NTAC 3 gen_tac >> + domain livein' = IMAGE (\r. the 0n (lookup r invbij)) (domain livein) +Proof + NTAC 3 gen_tac >> Induct_on `ct` >> rw [apply_bij_on_clash_tree_def, check_clash_tree_def] >> ( TRY (rename1 `Branch optcutset ct1 ct2`) >> @@ -5798,10 +5875,10 @@ Theorem check_clash_tree_apply_bijection ) >> rw [] ) -); +QED -Theorem extract_coloration_output - `!bij invbij sth l acc. +Theorem extract_coloration_output: + !bij invbij sth l acc. sp_inverts bij invbij /\ sp_inverts invbij bij /\ EVERY (\r. r IN domain invbij) l /\ @@ -5812,9 +5889,9 @@ Theorem extract_coloration_output lookup r col = SOME (EL (the 0 (lookup r bij)) sth.colors) else lookup r col = lookup r acc) /\ - domain col SUBSET domain bij UNION domain acc` - - (NTAC 3 gen_tac >> + domain col SUBSET domain bij UNION domain acc +Proof + NTAC 3 gen_tac >> Induct_on `l` >> rw [extract_coloration_def] >> simp msimps >> fs [] >> @@ -5852,24 +5929,25 @@ Theorem extract_coloration_output fs [the_def, SUBSET_DEF] >> metis_tac [] ) -); +QED (* TODO: move *) -Theorem LENGTH_toAList - `!s. LENGTH (toAList s) = size s` - (sg `!s l n. LENGTH (foldi (\k v a. (k,v)::a) n l s) = size s + LENGTH l` THEN1 ( +Theorem LENGTH_toAList: + !s. LENGTH (toAList s) = size s +Proof + sg `!s l n. LENGTH (foldi (\k v a. (k,v)::a) n l s) = size s + LENGTH l` THEN1 ( Induct_on `s` >> rw [foldi_def] ) >> rw [toAList_def] -); +QED -Theorem check_col_equal_col - `!s f1 f2. +Theorem check_col_equal_col: + !s f1 f2. (!r. r IN domain s ==> f1 r = f2 r) ==> - check_col f1 s = check_col f2 s` - - (rpt strip_tac >> + check_col f1 s = check_col f2 s +Proof + rpt strip_tac >> sg `MAP (f1 o FST) (toAList s) = MAP (f2 o FST) (toAList s)` THEN1 ( simp [LIST_EQ_REWRITE] >> rw [EL_MAP] >> @@ -5879,25 +5957,25 @@ Theorem check_col_equal_col fs [set_MAP_FST_toAList_eq_domain] ) >> simp [check_col_def] -); +QED -Theorem check_partial_col_equal_col - `!l live flive f1 f2. +Theorem check_partial_col_equal_col: + !l live flive f1 f2. (!r. MEM r l ==> f1 r = f2 r) ==> - check_partial_col f1 l live flive = check_partial_col f2 l live flive` - - (Induct_on `l` >> + check_partial_col f1 l live flive = check_partial_col f2 l live flive +Proof + Induct_on `l` >> rw [check_partial_col_def] >> metis_tac [] -); +QED -Theorem check_clash_tree_equal_col - `!f1 f2 ct live flive. +Theorem check_clash_tree_equal_col: + !f1 f2 ct live flive. (!r. r IN in_clash_tree ct ==> f1 r = f2 r) /\ (!r. r IN domain live ==> f1 r = f2 r) ==> - check_clash_tree f1 ct live flive = check_clash_tree f2 ct live flive` - - (NTAC 2 gen_tac >> + check_clash_tree f1 ct live flive = check_clash_tree f2 ct live flive +Proof + NTAC 2 gen_tac >> Induct_on `ct` >> rw [] >> TRY (rename1 `Branch optcutset ct1 ct2`) >> TRY (rename1 `Seq ct1 ct2`) >> @@ -5943,11 +6021,11 @@ Theorem check_clash_tree_equal_col fs [SUBSET_DEF] >> metis_tac [] ) -); +QED -Theorem linear_scan_reg_alloc_correct - `!k moves ct forced. +Theorem linear_scan_reg_alloc_correct: + !k moves ct forced. EVERY (\r1,r2. in_clash_tree ct r1 /\ in_clash_tree ct r2) forced ==> ?col livein flivein. linear_scan_reg_alloc k moves ct forced = Success col /\ @@ -5962,9 +6040,9 @@ Theorem linear_scan_reg_alloc_correct T ) /\ (!r. r IN domain col ==> in_clash_tree ct r) /\ - EVERY (\r1,r2. (sp_default col) r1 = (sp_default col) r2 ==> r1 = r2) forced` - - (rpt strip_tac >> + EVERY (\r1,r2. (sp_default col) r1 = (sp_default col) r2 ==> r1 = r2) forced +Proof + rpt strip_tac >> simp [linear_scan_reg_alloc_def, run_linear_reg_alloc_intervals_def, run_i_linear_scan_hidden_state_def, run_def, linear_reg_alloc_and_extract_coloration_def] >> `?bijstate. find_bijection_clash_tree find_bijection_init ct = bijstate` by simp [] >> @@ -6168,6 +6246,6 @@ Theorem linear_scan_reg_alloc_correct fs [domain_lookup] >> rfs [the_def, good_bijection_state_def, sp_inverts_def] >> metis_tac [SOME_11] ) -); +QED val _ = export_theory (); diff --git a/compiler/backend/reg_alloc/proofs/reg_allocProofScript.sml b/compiler/backend/reg_alloc/proofs/reg_allocProofScript.sml index a2f2b0958d..701b5bb619 100644 --- a/compiler/backend/reg_alloc/proofs/reg_allocProofScript.sml +++ b/compiler/backend/reg_alloc/proofs/reg_allocProofScript.sml @@ -92,15 +92,19 @@ val case_eq_thms = pair_case_eq:: List.map (prove_case_eq_thm o get_thms) [``:('a,'b) exc``,``:tag``,``:'a list``,``:'a option``] |> LIST_CONJ |> curry save_thm "case_eq_thms" -Theorem tag_case_st ` - !t. - (tag_CASE t a b c) f = (tag_CASE t (λn. a n f) (b f) (c f))` - (Cases>>fs[]); - -Theorem list_case_st ` - !t. - (list_CASE t a b) f = (list_CASE t (a f) (λx y.b x y f))` - (Cases>>fs[]); +Theorem tag_case_st: + !t. + (tag_CASE t a b c) f = (tag_CASE t (λn. a n f) (b f) (c f)) +Proof + Cases>>fs[] +QED + +Theorem list_case_st: + !t. + (list_CASE t a b) f = (list_CASE t (a f) (λx y.b x y f)) +Proof + Cases>>fs[] +QED (* --- TODO: These lemmas should be automatically generated for each array used! @@ -113,118 +117,142 @@ Theorem list_case_st ` ---*) (* Rewriting lemmas for array "sub" *) -Theorem Msub_eqn[simp] ` - ∀e n ls v. +Theorem Msub_eqn[simp]: + ∀e n ls v. Msub e n ls = if n < LENGTH ls then Success (EL n ls) - else Failure e` - (ho_match_mp_tac Msub_ind>>rw[]>> + else Failure e +Proof + ho_match_mp_tac Msub_ind>>rw[]>> simp[Once Msub_def]>> Cases_on`ls`>>fs[]>> IF_CASES_TAC>>fs[]>> - Cases_on`n`>>fs[]); + Cases_on`n`>>fs[] +QED -Theorem adj_ls_sub_eqn[simp] ` - adj_ls_sub n s = +Theorem adj_ls_sub_eqn[simp]: + adj_ls_sub n s = if n < LENGTH s.adj_ls then (Success (EL n s.adj_ls),s) else - (Failure (Subscript),s)` - (rw[adj_ls_sub_def]>> - fs[Marray_sub_def]); - -Theorem node_tag_sub_eqn[simp] ` - node_tag_sub n s = + (Failure (Subscript),s) +Proof + rw[adj_ls_sub_def]>> + fs[Marray_sub_def] +QED + +Theorem node_tag_sub_eqn[simp]: + node_tag_sub n s = if n < LENGTH s.node_tag then (Success (EL n s.node_tag),s) else - (Failure (Subscript),s)` - (rw[node_tag_sub_def]>> - fs[Marray_sub_def]); - -Theorem degrees_sub_eqn[simp] ` - degrees_sub n s = + (Failure (Subscript),s) +Proof + rw[node_tag_sub_def]>> + fs[Marray_sub_def] +QED + +Theorem degrees_sub_eqn[simp]: + degrees_sub n s = if n < LENGTH s.degrees then (Success (EL n s.degrees),s) else - (Failure (Subscript),s)` - (rw[degrees_sub_def]>> - fs[Marray_sub_def]); - -Theorem coalesced_sub[simp] ` - coalesced_sub n s = + (Failure (Subscript),s) +Proof + rw[degrees_sub_def]>> + fs[Marray_sub_def] +QED + +Theorem coalesced_sub[simp]: + coalesced_sub n s = if n < LENGTH s.coalesced then (Success (EL n s.coalesced),s) else - (Failure Subscript,s)` - (rw[coalesced_sub_def]>>fs[Marray_sub_def]); + (Failure Subscript,s) +Proof + rw[coalesced_sub_def]>>fs[Marray_sub_def] +QED -Theorem move_related_sub[simp] ` - move_related_sub n s = +Theorem move_related_sub[simp]: + move_related_sub n s = if n < LENGTH s.move_related then (Success (EL n s.move_related),s) else - (Failure Subscript,s)` - (rw[move_related_sub_def]>>fs[Marray_sub_def]); + (Failure Subscript,s) +Proof + rw[move_related_sub_def]>>fs[Marray_sub_def] +QED (* Rewriting lemmas for array "update" *) -Theorem Mupdate_eqn[simp] ` - ∀e x n ls. +Theorem Mupdate_eqn[simp]: + ∀e x n ls. Mupdate e x n ls = if n < LENGTH ls then Success (LUPDATE x n ls) else - Failure e` - (ho_match_mp_tac Mupdate_ind>>rw[]>> + Failure e +Proof + ho_match_mp_tac Mupdate_ind>>rw[]>> simp[Once Mupdate_def]>> Cases_on`ls`>>fs[]>> IF_CASES_TAC>>fs[LUPDATE_def]>> - Cases_on`n`>>fs[LUPDATE_def]); + Cases_on`n`>>fs[LUPDATE_def] +QED -Theorem update_adj_ls_eqn[simp] ` - update_adj_ls n t s = +Theorem update_adj_ls_eqn[simp]: + update_adj_ls n t s = if n < LENGTH s.adj_ls then (Success (),s with adj_ls := LUPDATE t n s.adj_ls) else - (Failure (Subscript),s)` - (rw[update_adj_ls_def]>> - fs[Marray_update_def]); - -Theorem update_node_tag_eqn[simp] ` - update_node_tag n t s = + (Failure (Subscript),s) +Proof + rw[update_adj_ls_def]>> + fs[Marray_update_def] +QED + +Theorem update_node_tag_eqn[simp]: + update_node_tag n t s = if n < LENGTH s.node_tag then (Success (),s with node_tag := LUPDATE t n s.node_tag) else - (Failure (Subscript),s)` - (rw[update_node_tag_def]>> - fs[Marray_update_def]); - -Theorem update_degrees_eqn[simp] ` - update_degrees n t s = + (Failure (Subscript),s) +Proof + rw[update_node_tag_def]>> + fs[Marray_update_def] +QED + +Theorem update_degrees_eqn[simp]: + update_degrees n t s = if n < LENGTH s.degrees then (Success (),s with degrees := LUPDATE t n s.degrees) else - (Failure (Subscript),s)` - (rw[update_degrees_def]>> - fs[Marray_update_def]); - -Theorem update_coalesced_eqn[simp] ` - update_coalesced n t s = + (Failure (Subscript),s) +Proof + rw[update_degrees_def]>> + fs[Marray_update_def] +QED + +Theorem update_coalesced_eqn[simp]: + update_coalesced n t s = if n < LENGTH s.coalesced then (Success (),s with coalesced := LUPDATE t n s.coalesced) else - (Failure (Subscript),s)` - (rw[update_coalesced_def]>> - fs[Marray_update_def]); - -Theorem update_move_related_eqn[simp] ` - update_move_related n t s = + (Failure (Subscript),s) +Proof + rw[update_coalesced_def]>> + fs[Marray_update_def] +QED + +Theorem update_move_related_eqn[simp]: + update_move_related n t s = if n < LENGTH s.move_related then (Success (),s with move_related := LUPDATE t n s.move_related) else - (Failure (Subscript),s)` - (rw[update_move_related_def]>> - fs[Marray_update_def]); + (Failure (Subscript),s) +Proof + rw[update_move_related_def]>> + fs[Marray_update_def] +QED (* --- *) @@ -233,46 +261,55 @@ Theorem update_move_related_eqn[simp] ` (* This asserts, e.g. that the monadic map of (\i.node_tag_sub i) returns success if the input list were all within range *) -Theorem st_ex_MAP_node_tag_sub ` - ∀ls s. +Theorem st_ex_MAP_node_tag_sub: + ∀ls s. EVERY (λv. v < LENGTH s.node_tag) ls ⇒ - st_ex_MAP node_tag_sub ls s = (Success (MAP (λi. EL i s.node_tag) ls),s)` - (Induct>>fs[st_ex_MAP_def]>>fs msimps); + st_ex_MAP node_tag_sub ls s = (Success (MAP (λi. EL i s.node_tag) ls),s) +Proof + Induct>>fs[st_ex_MAP_def]>>fs msimps +QED -Theorem st_ex_MAP_adj_ls_sub ` - ∀ls s. +Theorem st_ex_MAP_adj_ls_sub: + ∀ls s. EVERY (λv. v < LENGTH s.adj_ls) ls ⇒ - st_ex_MAP adj_ls_sub ls s = (Success (MAP (λi. EL i s.adj_ls) ls),s)` - (Induct>>fs[st_ex_MAP_def]>>fs msimps); + st_ex_MAP adj_ls_sub ls s = (Success (MAP (λi. EL i s.adj_ls) ls),s) +Proof + Induct>>fs[st_ex_MAP_def]>>fs msimps +QED -Theorem st_ex_MAP_degrees_sub ` - ∀ls s. +Theorem st_ex_MAP_degrees_sub: + ∀ls s. EVERY (λv. v < LENGTH s.degrees) ls ⇒ - st_ex_MAP degrees_sub ls s = (Success (MAP (λi. EL i s.degrees) ls),s)` - (Induct>>fs[st_ex_MAP_def]>>fs msimps); + st_ex_MAP degrees_sub ls s = (Success (MAP (λi. EL i s.degrees) ls),s) +Proof + Induct>>fs[st_ex_MAP_def]>>fs msimps +QED (* --- *) (* --- the main (core) correctness proofs start here --- *) -Theorem remove_colours_frame ` - ∀adjs ks s res s'. +Theorem remove_colours_frame: + ∀adjs ks s res s'. remove_colours adjs ks s = (res,s') ⇒ - s = s'` - (ho_match_mp_tac remove_colours_ind>>rw[remove_colours_def]>> + s = s' +Proof + ho_match_mp_tac remove_colours_ind>>rw[remove_colours_def]>> fs msimps>> pop_assum mp_tac >> IF_CASES_TAC>> simp[]>> rw[]>>fs [case_eq_thms,tag_case_st]>> rw[]>>fs[]>> - metis_tac[]); + metis_tac[] +QED -Theorem remove_colours_success ` - ∀adjs ks s ls s'. +Theorem remove_colours_success: + ∀adjs ks s ls s'. remove_colours adjs ks s = (Success ls,s') ⇒ Abbrev(set ls ⊆ set ks ∧ ∀n. MEM n adjs ∧ n < LENGTH s'.node_tag ⇒ case EL n s.node_tag of Fixed c => ¬MEM c ls - | _ => T)` - (ho_match_mp_tac remove_colours_ind>>rw[remove_colours_def]>> + | _ => T) +Proof + ho_match_mp_tac remove_colours_ind>>rw[remove_colours_def]>> fs msimps >- (rw[markerTheory.Abbrev_def]>>TOP_CASE_TAC>>fs[]) @@ -294,7 +331,8 @@ Theorem remove_colours_success ` CCONTR_TAC>> fs[SUBSET_DEF]>> first_x_assum drule>> - IF_CASES_TAC>>rw[]>>fs[MEM_FILTER]); + IF_CASES_TAC>>rw[]>>fs[MEM_FILTER] +QED val no_clash_LUPDATE_Stemp = Q.prove(` no_clash adjls tags ⇒ @@ -350,8 +388,8 @@ val remove_colours_succeeds = Q.prove(` first_x_assum(qspec_then`n` assume_tac)>>fs[]>> rfs[]); -Theorem assign_Atemp_tag_correct ` - good_ra_state s ∧ +Theorem assign_Atemp_tag_correct: + good_ra_state s ∧ no_clash s.adj_ls s.node_tag ∧ good_pref pref ∧ n < s.dim ⇒ @@ -363,8 +401,9 @@ Theorem assign_Atemp_tag_correct ` else EL m s'.node_tag = EL m s.node_tag) ∧ no_clash s'.adj_ls s'.node_tag ∧ good_ra_state s' ∧ - s' = s with node_tag := s'.node_tag` - (rw[assign_Atemp_tag_def]>> + s' = s with node_tag := s'.node_tag +Proof + rw[assign_Atemp_tag_def]>> pop_assum mp_tac>> simp msimps>> fs[good_ra_state_def]>> @@ -392,7 +431,8 @@ Theorem assign_Atemp_tag_correct ` rw[]>>first_x_assum drule>> fs[]>> TOP_CASE_TAC>>fs[]>> - metis_tac[]); + metis_tac[] +QED val assign_Atemps_FOREACH_lem = Q.prove(` ∀ls s ks prefs. @@ -434,8 +474,8 @@ val assign_Atemps_FOREACH_lem = Q.prove(` strip_tac>>IF_CASES_TAC>>fs[]>> metis_tac[])); -Theorem assign_Atemps_correct ` - ∀k ls prefs s. +Theorem assign_Atemps_correct: + ∀k ls prefs s. good_ra_state s ∧ good_pref prefs ∧ no_clash s.adj_ls s.node_tag ==> @@ -448,8 +488,9 @@ Theorem assign_Atemps_correct ` (* The next one is probably necessary for coloring correctness *) !m. m < LENGTH s.node_tag ∧ EL m s.node_tag ≠ Atemp ⇒ - EL m s'.node_tag = EL m s.node_tag` - (rw[assign_Atemps_def,get_dim_def]>> + EL m s'.node_tag = EL m s.node_tag +Proof + rw[assign_Atemps_def,get_dim_def]>> simp msimps>> qmatch_goalsub_abbrev_tac`st_ex_FOREACH lsf`>> qpat_abbrev_tac`ks = (GENLIST _ k)`>> @@ -477,7 +518,8 @@ Theorem assign_Atemps_correct ` rw[]>> rpt(first_x_assum(qspec_then`m` assume_tac))>>rfs[]>> fs[ra_state_component_equality]>> - rfs[]); + rfs[] +QED val SORTED_HEAD_LT = Q.prove(` ∀ls. @@ -491,12 +533,13 @@ val SORTED_HEAD_LT = Q.prove(` Cases_on`ls`>>full_simp_tac(srw_ss())[SORTED_DEF]>>DECIDE_TAC); (* Correctness for the second step *) -Theorem unbound_colour_correct ` - ∀ls k k'. +Theorem unbound_colour_correct: + ∀ls k k'. SORTED (λx y.x ≤ y) ls ==> k ≤ unbound_colour k ls ∧ - ~MEM (unbound_colour k ls) ls` - (Induct>>fs[unbound_colour_def]>>rw[]>> + ~MEM (unbound_colour k ls) ls +Proof + Induct>>fs[unbound_colour_def]>>rw[]>> fs[]>> imp_res_tac SORTED_TL>> first_x_assum drule>>rw[] @@ -507,10 +550,11 @@ Theorem unbound_colour_correct ` >- (first_x_assum(qspec_then`h+1` assume_tac)>>fs[]) >> - first_x_assum(qspec_then`k` assume_tac)>>fs[]); + first_x_assum(qspec_then`k` assume_tac)>>fs[] +QED -Theorem assign_Stemp_tag_correct ` - good_ra_state s ∧ +Theorem assign_Stemp_tag_correct: + good_ra_state s ∧ no_clash s.adj_ls s.node_tag ∧ n < s.dim ⇒ ∃s'. @@ -521,8 +565,9 @@ Theorem assign_Stemp_tag_correct ` else EL m s'.node_tag = EL m s.node_tag) ∧ no_clash s'.adj_ls s'.node_tag ∧ good_ra_state s' ∧ - s' = s with node_tag := s'.node_tag` - (rw[assign_Stemp_tag_def]>>simp msimps>> + s' = s with node_tag := s'.node_tag +Proof + rw[assign_Stemp_tag_def]>>simp msimps>> reverse IF_CASES_TAC >- fs[good_ra_state_def]>> simp[]>> TOP_CASE_TAC>>simp msimps>> @@ -550,7 +595,8 @@ Theorem assign_Stemp_tag_correct ` fs[Abbr`ls`,QSORT_MEM,MEM_MAP]>> first_x_assum(qspec_then`Fixed k'` assume_tac)>>fs[tag_col_def]>> pop_assum(qspec_then`EL n' (EL n s.adj_ls)` assume_tac)>>fs[]>> - metis_tac[MEM_EL]); + metis_tac[MEM_EL] +QED (* Almost exactly the same as the FOREACH for Atemps *) val assign_Stemps_FOREACH_lem = Q.prove(` @@ -591,8 +637,8 @@ val assign_Stemps_FOREACH_lem = Q.prove(` strip_tac>>IF_CASES_TAC>>fs[]>> metis_tac[])); -Theorem assign_Stemps_correct ` - good_ra_state s ∧ +Theorem assign_Stemps_correct: + good_ra_state s ∧ no_clash s.adj_ls s.node_tag ⇒ ∃s'. assign_Stemps k s = (Success (),s') ∧ @@ -604,8 +650,9 @@ Theorem assign_Stemps_correct ` if EL m s.node_tag = Stemp then ∃k'. EL m s'.node_tag = Fixed k' ∧ k ≤ k' else - EL m s'.node_tag = EL m s.node_tag` - (rw[assign_Stemps_def]>> + EL m s'.node_tag = EL m s.node_tag +Proof + rw[assign_Stemps_def]>> simp msimps>> simp [get_dim_def]>> drule assign_Stemps_FOREACH_lem>> @@ -617,7 +664,8 @@ Theorem assign_Stemps_correct ` strip_tac>> fs[Abbr`ls`,MEM_GENLIST]>> fs[good_ra_state_def]>> - metis_tac[]); + metis_tac[] +QED (* -- Random sanity checks that will be needed at some point -- *) @@ -634,16 +682,18 @@ val first_match_col_correct = Q.prove(` TOP_CASE_TAC>>fs[]>> IF_CASES_TAC>>fs[]); -Theorem good_pref_biased_pref ` - ∀t. good_pref (biased_pref t)` - (rw[good_pref_def,biased_pref_def]>> +Theorem good_pref_biased_pref: + ∀t. good_pref (biased_pref t) +Proof + rw[good_pref_def,biased_pref_def]>> fs[get_dim_def]>>simp msimps>> IF_CASES_TAC>>fs[good_ra_state_def]>> TOP_CASE_TAC>>fs[handle_Subscript_def]>> cases_on`lookup n t`>>fs[]>> qmatch_goalsub_abbrev_tac`first_match_col _ ls _`>> Q.ISPECL_THEN [`ls`,`ks`,`s`] assume_tac first_match_col_correct>>fs[]>> - EVERY_CASE_TAC>>fs[]); + EVERY_CASE_TAC>>fs[] +QED (* Checking that the bijection produced is correct *) @@ -665,15 +715,17 @@ val sp_inverts_def = Define` lookup m f = SOME fm ⇒ lookup fm g = SOME m` -Theorem sp_inverts_insert ` - sp_inverts f g ∧ +Theorem sp_inverts_insert: + sp_inverts f g ∧ x ∉ domain f ∧ y ∉ domain g ⇒ - sp_inverts (insert x y f) (insert y x g)` - (rw[sp_inverts_def,lookup_insert]>> + sp_inverts (insert x y f) (insert y x g) +Proof + rw[sp_inverts_def,lookup_insert]>> pop_assum mp_tac>> IF_CASES_TAC>> rw[]>> CCONTR_TAC >> fs[]>> first_x_assum drule>> - fs[domain_lookup]); + fs[domain_lookup] +QED val list_remap_domain = Q.prove(` ∀ls ta fa n ta' fa' n'. @@ -802,12 +854,13 @@ val list_remap_wf = Q.prove(` rpt (disch_then drule)>> fs[wf_insert]); -Theorem mk_bij_aux_wf ` - ∀ct ta fa n ta' fa' n'. +Theorem mk_bij_aux_wf: + ∀ct ta fa n ta' fa' n'. mk_bij_aux ct (ta,fa,n) = (ta',fa',n') /\ wf ta ∧ wf fa ⇒ - Abbrev(wf ta' ∧ wf fa')` - (Induct>>rw[mk_bij_aux_def] + Abbrev(wf ta' ∧ wf fa') +Proof + Induct>>rw[mk_bij_aux_def] >- (Cases_on`list_remap l0 (ta,fa,n)`>>Cases_on`r`>> simp[markerTheory.Abbrev_def]>> @@ -838,7 +891,8 @@ Theorem mk_bij_aux_wf ` fs[]>> last_x_assum drule>> simp[markerTheory.Abbrev_def]>> strip_tac>> - last_x_assum drule >> simp[markerTheory.Abbrev_def]); + last_x_assum drule >> simp[markerTheory.Abbrev_def] +QED (* Properties of the graph manipulating functions All of these simultaneously prove success @@ -862,11 +916,13 @@ val is_subgraph_refl= Q.store_thm("is_subgraph_refl",` is_subgraph s s`, rw[is_subgraph_def]); -Theorem is_subgraph_trans ` - is_subgraph s s' ∧ +Theorem is_subgraph_trans: + is_subgraph s s' ∧ is_subgraph s' s'' ==> - is_subgraph s s''` - (rw[is_subgraph_def]); + is_subgraph s s'' +Proof + rw[is_subgraph_def] +QED (* TODO quick sanity check: move to proof file when done *) val hide_def = Define` @@ -928,28 +984,32 @@ val sorted_insert_correct_lem = Q.prove(` simp[hide_def]>> metis_tac[]); -Theorem sorted_insert_correct ` - ∀ls. +Theorem sorted_insert_correct: + ∀ls. SORTED $> ls ⇒ SORTED $> (sorted_insert x [] ls) ∧ ∀z. - MEM z (sorted_insert x [] ls) ⇔ x = z ∨ MEM z ls` - (ntac 2 strip_tac>> + MEM z (sorted_insert x [] ls) ⇔ x = z ∨ MEM z ls +Proof + ntac 2 strip_tac>> drule sorted_insert_correct_lem>> - disch_then(qspec_then `[]` assume_tac)>>rfs[hide_def]); + disch_then(qspec_then `[]` assume_tac)>>rfs[hide_def] +QED -Theorem sorted_mem_correct ` - ∀ls. +Theorem sorted_mem_correct: + ∀ls. SORTED $> ls ⇒ - (sorted_mem x ls ⇔ MEM x ls)` - (Induct>>rw[sorted_mem_def]>> + (sorted_mem x ls ⇔ MEM x ls) +Proof + Induct>>rw[sorted_mem_def]>> fs[GT_sorted_eq]>> rw[EQ_IMP_THM]>> simp[NOT_GREATER]>> - first_x_assum drule>>fs[]); + first_x_assum drule>>fs[] +QED -Theorem insert_edge_succeeds ` - good_ra_state s ∧ +Theorem insert_edge_succeeds: + good_ra_state s ∧ y < s.dim ∧ x < s.dim ⇒ ∃s'. insert_edge x y s = (Success (),s') ∧ @@ -957,8 +1017,8 @@ Theorem insert_edge_succeeds ` s' = s with adj_ls := s'.adj_ls ∧ ∀a b. (has_edge s'.adj_ls a b ⇔ - (a = x ∧ b = y) ∨ (a = y ∧ b = x) ∨ (has_edge s.adj_ls a b))` - ( + (a = x ∧ b = y) ∨ (a = y ∧ b = x) ∨ (has_edge s.adj_ls a b)) +Proof rw[good_ra_state_def,insert_edge_def]>>fs msimps>> CONJ_TAC>- ( match_mp_tac IMP_EVERY_LUPDATE>> @@ -986,10 +1046,11 @@ Theorem insert_edge_succeeds ` rw[has_edge_def]>> simp[EL_LUPDATE]>> fs[EVERY_MEM]>> - rw[]>>metis_tac[sorted_insert_correct,MEM_EL]) + rw[]>>metis_tac[sorted_insert_correct,MEM_EL] +QED -Theorem list_insert_edge_succeeds ` - ∀ys x s. +Theorem list_insert_edge_succeeds: + ∀ys x s. good_ra_state s ∧ x < s.dim ∧ EVERY ( λy. y < s.dim) ys ⇒ @@ -1000,8 +1061,9 @@ Theorem list_insert_edge_succeeds ` (has_edge s'.adj_ls a b ⇔ (a = x ∧ MEM b ys) ∨ (b = x ∧ MEM a ys) ∨ - (has_edge s.adj_ls a b))` - (Induct>>rw[list_insert_edge_def]>>fs msimps + (has_edge s.adj_ls a b)) +Proof + Induct>>rw[list_insert_edge_def]>>fs msimps >- fs[ra_state_component_equality]>> drule (GEN_ALL insert_edge_succeeds)>> @@ -1009,21 +1071,23 @@ Theorem list_insert_edge_succeeds ` last_x_assum drule>> qpat_x_assum`s' = _` SUBST_ALL_TAC>>fs[]>> disch_then (qspec_then`x` strip_assume_tac)>>rfs[]>> - rw[]>>metis_tac[]); + rw[]>>metis_tac[] +QED (* From here onwards we stop characterizing s'.adj_ls exactly although it could be done *) -Theorem clique_insert_edge_succeeds ` - ∀ls s. +Theorem clique_insert_edge_succeeds: + ∀ls s. good_ra_state s ∧ EVERY ( λy. y < s.dim) ls ==> ∃s'. clique_insert_edge ls s = (Success (),s') ∧ good_ra_state s' ∧ s' = s with adj_ls := s'.adj_ls ∧ is_clique ls s'.adj_ls ∧ - is_subgraph s.adj_ls s'.adj_ls` - (Induct>>rw[clique_insert_edge_def]>>fs msimps + is_subgraph s.adj_ls s'.adj_ls +Proof + Induct>>rw[clique_insert_edge_def]>>fs msimps >- fs[ra_state_component_equality,is_subgraph_def,is_clique_def]>> drule list_insert_edge_succeeds>> @@ -1038,10 +1102,11 @@ Theorem clique_insert_edge_succeeds ` fs[EVERY_MEM]) >> match_mp_tac (GEN_ALL is_subgraph_trans)>> - qexists_tac`s'.adj_ls`>>fs[is_subgraph_def]); + qexists_tac`s'.adj_ls`>>fs[is_subgraph_def] +QED -Theorem extend_clique_succeeds ` - ∀ls cli s. +Theorem extend_clique_succeeds: + ∀ls cli s. good_ra_state s ∧ is_clique cli s.adj_ls ∧ EVERY ( λy. y < s.dim) ls ∧ @@ -1053,8 +1118,9 @@ Theorem extend_clique_succeeds ` s' = s with adj_ls := s'.adj_ls ∧ set cli' = set (cli++ls) ∧ is_clique cli' s'.adj_ls ∧ - is_subgraph s.adj_ls s'.adj_ls` - (Induct>>rw[extend_clique_def]>>fs msimps + is_subgraph s.adj_ls s'.adj_ls +Proof + Induct>>rw[extend_clique_def]>>fs msimps >- simp[ra_state_component_equality,is_subgraph_def] >- @@ -1073,7 +1139,8 @@ Theorem extend_clique_succeeds ` fs[]>> CONJ_TAC>- (simp[EXTENSION]>>metis_tac[])>> - fs[is_subgraph_def]); + fs[is_subgraph_def] +QED (* The col needed to get colouring satisfactory can be generated from the node tags @@ -1092,15 +1159,16 @@ val INJ_less = Q.prove(` INJ f s t`, metis_tac[INJ_DEF,SUBSET_DEF]); -Theorem check_partial_col_success ` - ∀ls live flive col. +Theorem check_partial_col_success: + ∀ls live flive col. domain flive = IMAGE col (domain live) ∧ INJ col (set ls ∪ domain live) UNIV ⇒ ∃livein flivein. check_partial_col col ls live flive = SOME (livein,flivein) ∧ - domain flivein = IMAGE col (domain livein)` - (Induct>>fs[check_partial_col_def]>>rw[]>> + domain flivein = IMAGE col (domain livein) +Proof + Induct>>fs[check_partial_col_def]>>rw[]>> TOP_CASE_TAC>>fs[] >- (`h ∉ domain live` by fs[domain_lookup]>> @@ -1131,25 +1199,29 @@ Theorem check_partial_col_success ` impl_tac>- (match_mp_tac INJ_less>> HINT_EXISTS_TAC>>fs[SUBSET_DEF])>> - rw[]>>fs[EXTENSION]); + rw[]>>fs[EXTENSION] +QED -Theorem INJ_COMPOSE_IMAGE ` - ∀a b u. +Theorem INJ_COMPOSE_IMAGE: + ∀a b u. INJ f a b ∧ INJ g (IMAGE f a) u ⇒ - INJ (g o f) a u` - (rw[]>> + INJ (g o f) a u +Proof + rw[]>> match_mp_tac INJ_COMPOSE>> - metis_tac[INJ_IMAGE]); + metis_tac[INJ_IMAGE] +QED -Theorem colouring_satisfactory_cliques ` - ∀ls g (f:num->num). +Theorem colouring_satisfactory_cliques: + ∀ls g (f:num->num). ALL_DISTINCT ls ∧ EVERY (λx. x < LENGTH g) ls ∧ colouring_satisfactory f g ∧ is_clique ls g ⇒ - ALL_DISTINCT (MAP f ls)` - (Induct>>fs[is_clique_def,colouring_satisfactory_def]>> + ALL_DISTINCT (MAP f ls) +Proof + Induct>>fs[is_clique_def,colouring_satisfactory_def]>> rw[] >- (fs[MEM_MAP]>>rw[]>> @@ -1158,7 +1230,8 @@ Theorem colouring_satisfactory_cliques ` fs[has_edge_def]>> metis_tac[]) >> - first_x_assum(qspecl_then [`g`,`f`] mp_tac)>>rev_full_simp_tac(srw_ss())[]); + first_x_assum(qspecl_then [`g`,`f`] mp_tac)>>rev_full_simp_tac(srw_ss())[] +QED val domain_eq_IMAGE = Q.prove(` domain s = IMAGE FST (set(toAList s))`, @@ -1181,17 +1254,19 @@ val is_clique_subgraph = Q.prove(` is_clique ls s'`, fs[is_clique_def,is_subgraph_def]); -Theorem domain_numset_list_delete ` - ∀l live. +Theorem domain_numset_list_delete: + ∀l live. domain (numset_list_delete l live) = - domain live DIFF set l` - (Induct>>fs[numset_list_delete_def]>>rw[]>> + domain live DIFF set l +Proof + Induct>>fs[numset_list_delete_def]>>rw[]>> fs[EXTENSION]>> - metis_tac[]); + metis_tac[] +QED (* The success theorem is separated here *) -Theorem mk_graph_succeeds ` - ∀ct ta liveout s. +Theorem mk_graph_succeeds: + ∀ct ta liveout s. good_ra_state s ∧ (∀x. in_clash_tree ct x ⇒ ta x < s.dim) ∧ INJ ta ({x | in_clash_tree ct x}) (count (LENGTH s.adj_ls)) ∧ @@ -1205,8 +1280,9 @@ Theorem mk_graph_succeeds ` (EVERY (λy.y < s.dim) livein) ∧ ALL_DISTINCT livein ∧ set livein SUBSET set liveout ∪ IMAGE ta {x | in_clash_tree ct x} ∧ - is_subgraph s.adj_ls s'.adj_ls` - (Induct>> + is_subgraph s.adj_ls s'.adj_ls +Proof + Induct>> rw[in_clash_tree_def,mk_graph_def]>>fs msimps >- (drule extend_clique_succeeds>> @@ -1304,15 +1380,18 @@ Theorem mk_graph_succeeds ` qpat_x_assum`s' = _` SUBST_ALL_TAC>>fs[]>> CONJ_TAC>- (fs[SUBSET_DEF]>>metis_tac[])>> - metis_tac[is_subgraph_trans]); + metis_tac[is_subgraph_trans] +QED -Theorem colouring_satisfactory_subgraph ` - colouring_satisfactory f h ∧ +Theorem colouring_satisfactory_subgraph: + colouring_satisfactory f h ∧ is_subgraph g h ⇒ - colouring_satisfactory f g` - (fs[colouring_satisfactory_def,is_subgraph_def]>>rw[]>> + colouring_satisfactory f g +Proof + fs[colouring_satisfactory_def,is_subgraph_def]>>rw[]>> fs[has_edge_def]>> - metis_tac[]); + metis_tac[] +QED val ALL_DISTINCT_set_INJ = Q.prove(` ∀ls col. @@ -1350,28 +1429,32 @@ val UNION_DIFF_3 = Q.prove(` rw[EXTENSION]>> metis_tac[]); -Theorem check_partial_col_domain ` - ∀ls f live flive v. +Theorem check_partial_col_domain: + ∀ls f live flive v. check_partial_col f ls live flive = SOME v ⇒ - domain (FST v) = set ls ∪ domain live` - (Induct>>fs[check_partial_col_def]>>rw[]>>EVERY_CASE_TAC>>fs[]>> + domain (FST v) = set ls ∪ domain live +Proof + Induct>>fs[check_partial_col_def]>>rw[]>>EVERY_CASE_TAC>>fs[]>> first_x_assum drule>> fs[EXTENSION]>> - metis_tac[domain_lookup]); + metis_tac[domain_lookup] +QED -Theorem check_clash_tree_domain ` - ∀ct f live flive live' flive'. +Theorem check_clash_tree_domain: + ∀ct f live flive live' flive'. check_clash_tree f ct live flive = SOME (live',flive') ⇒ - domain live' ⊆ domain live ∪ {x | in_clash_tree ct x}` - (Induct>>fs[check_clash_tree_def,in_clash_tree_def]>> + domain live' ⊆ domain live ∪ {x | in_clash_tree ct x} +Proof + Induct>>fs[check_clash_tree_def,in_clash_tree_def]>> rw[]>>fs[case_eq_thms,FORALL_PROD,check_col_def]>> rw[]>>imp_res_tac check_partial_col_domain>> fs[SUBSET_DEF,domain_numset_list_delete,toAList_domain,domain_difference]>> - metis_tac[]); + metis_tac[] +QED (* the correctness theorem for mk_graph *) -Theorem mk_graph_check_clash_tree ` - ∀ct ta livelist s livelist' s' col live flive. +Theorem mk_graph_check_clash_tree: + ∀ct ta livelist s livelist' s' col live flive. mk_graph ta ct livelist s = (Success livelist',s') ∧ colouring_satisfactory col s'.adj_ls ∧ INJ ta ({x | in_clash_tree ct x} ∪ domain live) (count (LENGTH s.adj_ls)) ∧ @@ -1384,8 +1467,9 @@ Theorem mk_graph_check_clash_tree ` ∃livein flivein. check_clash_tree (col o ta) ct live flive = SOME (livein,flivein) ∧ IMAGE ta (domain livein) = set livelist' ∧ - domain flivein = IMAGE (col o ta) (domain livein)` - (Induct>>rw[mk_graph_def,check_clash_tree_def]>>fs msimps>> + domain flivein = IMAGE (col o ta) (domain livein) +Proof + Induct>>rw[mk_graph_def,check_clash_tree_def]>>fs msimps>> fs[case_eq_thms,in_clash_tree_def]>>rw[] >- ( drule extend_clique_succeeds>> disch_then drule>> @@ -1723,12 +1807,13 @@ Theorem mk_graph_check_clash_tree ` fs[EVERY_MEM,SUBSET_DEF,good_ra_state_def]>> qpat_x_assum`s''=_` SUBST_ALL_TAC>>fs[])>> strip_tac>>fs[SUBSET_DEF]>> - metis_tac[]); + metis_tac[] +QED (* This precise characterization is needed to show that the forced edges correctly force any two to be distinct *) -Theorem extend_graph_succeeds ` - ∀forced:(num,num)alist f s. +Theorem extend_graph_succeeds: + ∀forced:(num,num)alist f s. good_ra_state s ∧ EVERY (λx,y.f x < s.dim ∧ f y < s.dim) forced ==> ∃s'. @@ -1738,8 +1823,9 @@ Theorem extend_graph_succeeds ` ∀a b. (has_edge s'.adj_ls a b ⇔ (∃x y. f x = a ∧ f y = b ∧ MEM (y,x) forced) ∨ - (∃x y. f x = a ∧ f y = b ∧ MEM (x,y) forced) ∨ (has_edge s.adj_ls a b))` - (Induct>>fs[extend_graph_def]>>fs msimps + (∃x y. f x = a ∧ f y = b ∧ MEM (x,y) forced) ∨ (has_edge s.adj_ls a b)) +Proof + Induct>>fs[extend_graph_def]>>fs msimps >- rw[ra_state_component_equality] >> @@ -1750,7 +1836,8 @@ Theorem extend_graph_succeeds ` first_x_assum (qspecl_then [`f`,`s'`] assume_tac)>>rfs[]>> fs[ra_state_component_equality]>>rfs[]>> fs[good_ra_state_def]>> - metis_tac[]); + metis_tac[] +QED (* Again, this characterization is only needed for the conventions, but not for the correctness theorem *) @@ -1799,8 +1886,8 @@ val mk_tags_st_ex_FOREACH_lem = Q.prove(` (`¬is_alloc_var (fa h) ∧ ¬ is_stack_var (fa h)` by fs[is_stack_var_def,is_alloc_var_def]>> metis_tac[convention_partitions])); -Theorem mk_tags_succeeds ` - good_ra_state s ∧ +Theorem mk_tags_succeeds: + good_ra_state s ∧ n = s.dim ⇒ ∃s'. mk_tags n fa s = (Success (),s') ∧ @@ -1810,19 +1897,23 @@ Theorem mk_tags_succeeds ` x < n ∧ y = fa x ⇒ if is_phy_var y then EL x s'.node_tag = Fixed (y DIV 2) else if is_stack_var y then EL x s'.node_tag = Stemp - else EL x s'.node_tag = Atemp` - (rw[mk_tags_def]>>fs msimps>> + else EL x s'.node_tag = Atemp +Proof + rw[mk_tags_def]>>fs msimps>> drule mk_tags_st_ex_FOREACH_lem>> qpat_abbrev_tac`ls = GENLIST _ _`>> disch_then(qspecl_then[`ls`,`fa`] mp_tac)>>impl_tac>> unabbrev_all_tac>>fs[EVERY_GENLIST]>>rw[]>>simp[]>> - fs[MEM_GENLIST]); + fs[MEM_GENLIST] +QED (* copied from word-to-stack proof*) -Theorem TWOxDIV2 - `2 * x DIV 2 = x` - (ONCE_REWRITE_TAC[MULT_COMM] - \\ simp[MULT_DIV]); +Theorem TWOxDIV2: + 2 * x DIV 2 = x +Proof + ONCE_REWRITE_TAC[MULT_COMM] + \\ simp[MULT_DIV] +QED val extract_color_st_ex_MAP_lem = Q.prove(` ∀ls s. @@ -1832,13 +1923,14 @@ val extract_color_st_ex_MAP_lem = Q.prove(` Induct>>fs[st_ex_MAP_def]>>fs msimps>>rw[]>> Cases_on`h`>>fs[]); -Theorem extract_color_succeeds ` - good_ra_state s ∧ +Theorem extract_color_succeeds: + good_ra_state s ∧ (∀x y. lookup x ta = SOME y ==> y < s.dim) /\ wf ta ==> extract_color ta s = - (Success (map (λv. extract_tag (EL v s.node_tag)) ta ),s)` - (rw[extract_color_def]>> + (Success (map (λv. extract_tag (EL v s.node_tag)) ta ),s) +Proof + rw[extract_color_def]>> simp[Once st_ex_bind_def,Once st_ex_return_def]>> simp[Once st_ex_bind_def]>> Q.ISPECL_THEN [`toAList ta`,`s`] mp_tac extract_color_st_ex_MAP_lem>> @@ -1848,7 +1940,8 @@ Theorem extract_color_succeeds ` rw[]>>simp msimps>> simp[GSYM map_fromAList]>> drule fromAList_toAList>> - simp[]); + simp[] +QED (* Here are the proofs about the "heuristic steps" *) @@ -2733,36 +2826,41 @@ val do_alloc1_success = Q.prove(` rw[]>>simp[get_stack_def]>> fs[Abbr`sss`,Abbr`ss`]); -Theorem no_clash_colouring_satisfactory ` - no_clash adjls node_tag ∧ +Theorem no_clash_colouring_satisfactory: + no_clash adjls node_tag ∧ LENGTH adjls = LENGTH node_tag ∧ EVERY (λn. n ≠ Stemp ∧ n ≠ Atemp) node_tag ⇒ colouring_satisfactory (λf. if f < LENGTH node_tag then extract_tag (EL f node_tag) - else 0) adjls` - (rw[no_clash_def,colouring_satisfactory_def]>> + else 0) adjls +Proof + rw[no_clash_def,colouring_satisfactory_def]>> fs[has_edge_def]>> first_x_assum (qspecl_then[`f`,`f'`] mp_tac)>>simp[]>> fs[EVERY_EL]>> TOP_CASE_TAC>>rfs[]>> TOP_CASE_TAC>>rfs[]>> - fs[extract_tag_def]); + fs[extract_tag_def] +QED -Theorem check_partial_col_same_dom ` - ∀ls f g t ft. +Theorem check_partial_col_same_dom: + ∀ls f g t ft. (∀x. MEM x ls ⇒ f x = g x) ⇒ - check_partial_col f ls t ft = check_partial_col g ls t ft` - (Induct>>fs[check_partial_col_def]>>rw[]>> - metis_tac[]); - -Theorem check_clash_tree_same_dom ` - ∀ct f g live flive. + check_partial_col f ls t ft = check_partial_col g ls t ft +Proof + Induct>>fs[check_partial_col_def]>>rw[]>> + metis_tac[] +QED + +Theorem check_clash_tree_same_dom: + ∀ct f g live flive. (∀x. in_clash_tree ct x ∨ x ∈ domain live ⇒ f x = g x) ⇒ check_clash_tree f ct live flive = - check_clash_tree g ct live flive` - (Induct>>fs[in_clash_tree_def,check_clash_tree_def]>>rw[] + check_clash_tree g ct live flive +Proof + Induct>>fs[in_clash_tree_def,check_clash_tree_def]>>rw[] >- metis_tac[check_partial_col_same_dom,MAP_EQ_f] >- @@ -2795,43 +2893,49 @@ Theorem check_clash_tree_same_dom ` first_x_assum match_mp_tac>> drule check_clash_tree_domain>> fs[SUBSET_DEF]>> - metis_tac[]); + metis_tac[] +QED val opt_split = Q.prove(` a ≠ NONE ⇔ a = SOME ()`, Cases_on`a`>>fs[]); -Theorem INJ_IMG_lookup ` - ∀x. INJ g UNIV UNIV ∧ +Theorem INJ_IMG_lookup: + ∀x. INJ g UNIV UNIV ∧ domain (gt:num_set) = IMAGE g (domain ft) ⇒ - lookup (g x) gt = lookup x ft` - (fs[EXTENSION,domain_lookup,INJ_DEF]>>rw[]>> + lookup (g x) gt = lookup x ft +Proof + fs[EXTENSION,domain_lookup,INJ_DEF]>>rw[]>> Cases_on`lookup x ft`>> CCONTR_TAC>>fs[opt_split]>> - metis_tac[NOT_SOME_NONE]) + metis_tac[NOT_SOME_NONE] +QED -Theorem check_partial_col_INJ ` - ∀ls t ft gt. +Theorem check_partial_col_INJ: + ∀ls t ft gt. INJ g UNIV UNIV ∧ domain gt = IMAGE g (domain ft) ⇒ case check_partial_col f ls t ft of NONE => check_partial_col (g o f) ls t gt = NONE | SOME (tt,ftt) => ∃gtt. check_partial_col (g o f) ls t gt = SOME(tt,gtt) ∧ - domain gtt = IMAGE g (domain ftt)` - (Induct>>fs[check_partial_col_def]>>rw[]>> + domain gtt = IMAGE g (domain ftt) +Proof + Induct>>fs[check_partial_col_def]>>rw[]>> Cases_on`lookup h t`>>fs[]>> drule INJ_IMG_lookup>>rfs[]>> - FULL_CASE_TAC>>fs[]); + FULL_CASE_TAC>>fs[] +QED -Theorem check_col_INJ ` - INJ g UNIV UNIV ==> +Theorem check_col_INJ: + INJ g UNIV UNIV ==> case check_col f (s:num_set) of NONE => check_col (g o f) s = NONE | SOME (t,ft) => ∃gt. check_col (g o f) s = SOME (t,gt) ∧ - domain gt = IMAGE g (domain ft)` - (fs[check_col_def]>> + domain gt = IMAGE g (domain ft) +Proof + fs[check_col_def]>> strip_tac>> fs[GSYM MAP_MAP_o]>> qpat_abbrev_tac`ls = MAP f _`>> @@ -2845,10 +2949,11 @@ Theorem check_col_INJ ` simp[LIST_TO_SET_MAP,IMAGE_IMAGE]>> AP_THM_TAC>> AP_TERM_TAC>> - simp[FUN_EQ_THM]); + simp[FUN_EQ_THM] +QED -Theorem check_clash_tree_INJ ` - ∀ct f g live flive glive. +Theorem check_clash_tree_INJ: + ∀ct f g live flive glive. INJ g UNIV UNIV ∧ domain glive = IMAGE g (domain flive) ==> @@ -2857,8 +2962,9 @@ Theorem check_clash_tree_INJ ` | SOME (liveout,fliveout) => ∃gliveout. check_clash_tree (g o f) ct live glive = SOME(liveout,gliveout) ∧ - domain gliveout = IMAGE g (domain fliveout)` - (Induct>>fs[check_clash_tree_def]>>rw[] + domain gliveout = IMAGE g (domain fliveout) +Proof + Induct>>fs[check_clash_tree_def]>>rw[] >- (drule check_partial_col_INJ>> disch_then drule>> disch_then(qspecl_then[`l`,`live`] mp_tac)>> @@ -2898,11 +3004,12 @@ Theorem check_clash_tree_INJ ` first_x_assum drule>> disch_then drule>> disch_then (qspecl_then[`f`,`q`] mp_tac)>> - TOP_CASE_TAC>>simp[]); + TOP_CASE_TAC>>simp[] +QED (* The top-most correctness theorem *) -Theorem do_reg_alloc_correct ` - ∀alg sc k moves ct forced st ta fa n. +Theorem do_reg_alloc_correct: + ∀alg sc k moves ct forced st ta fa n. mk_bij ct = (ta,fa,n)==> st.adj_ls = REPLICATE n [] ==> st.node_tag = REPLICATE n Atemp ==> @@ -2929,8 +3036,9 @@ Theorem do_reg_alloc_correct ` else T) ∧ (!x. x ∈ domain spcol ⇒ in_clash_tree ct x) ∧ - EVERY (λ(x,y). (sp_default spcol) x = (sp_default spcol) y ⇒ x=y) forced` - (rw[do_reg_alloc_def,init_ra_state_def,mk_bij_def]>>fs msimps>> + EVERY (λ(x,y). (sp_default spcol) x = (sp_default spcol) y ⇒ x=y) forced +Proof + rw[do_reg_alloc_def,init_ra_state_def,mk_bij_def]>>fs msimps>> `(λ(ta,fa,n). (ta,fa,n)) (mk_bij_aux ct (LN,LN,0)) = (mk_bij_aux ct (LN,LN,0))` by (Cases_on `mk_bij_aux ct (LN,LN,0)`>>Cases_on `r`>>fs[])>> first_x_assum(fn x => fs[x])>> drule mk_bij_aux_domain>>rw[]>> @@ -3115,15 +3223,16 @@ Theorem do_reg_alloc_correct ` qpat_x_assum`extract_tag _ = _ ` mp_tac>> rpt(pop_assum kall_tac)>> fs[extract_tag_def]>> - every_case_tac>>simp[]); + every_case_tac>>simp[] +QED fun first_prove_imp thms = (first_assum(fn x => sg `^(fst(dest_imp(concl x)))`) >- (fs thms) >> POP_ASSUM(fn x => fs[x])); (* The top-most correctness theorem *) -Theorem reg_alloc_correct ` - ∀alg sc k moves ct forced. +Theorem reg_alloc_correct: + ∀alg sc k moves ct forced. (* Needs to be proved in wordLang *) EVERY (λx,y.in_clash_tree ct x ∧ in_clash_tree ct y) forced ==> ∃spcol livein flivein. @@ -3138,8 +3247,9 @@ Theorem reg_alloc_correct ` else T) ∧ (!x. x ∈ domain spcol ⇒ in_clash_tree ct x) ∧ - EVERY (λ(x,y). (sp_default spcol) x = (sp_default spcol) y ⇒ x=y) forced` - (rw[reg_alloc_def]>> + EVERY (λ(x,y). (sp_default spcol) x = (sp_default spcol) y ⇒ x=y) forced +Proof + rw[reg_alloc_def]>> Cases_on `mk_bij ct`>>Cases_on`r`>>rw[]>> rw[reg_alloc_aux_def,run_ira_state_def,run_def]>> qmatch_goalsub_abbrev_tac `do_reg_alloc _ _ _ _ _ _ _ st` >> @@ -3150,7 +3260,8 @@ Theorem reg_alloc_correct ` first_prove_imp [Abbr `st`,ra_state_component_equality] >> first_prove_imp [Abbr `st`,ra_state_component_equality] >> first_prove_imp [Abbr `st`,ra_state_component_equality] >> - first_x_assum drule); + first_x_assum drule +QED (* --- --- *) val _ = export_theory (); diff --git a/compiler/backend/reg_alloc/reg_allocScript.sml b/compiler/backend/reg_alloc/reg_allocScript.sml index 84d470909f..b5f011ef6f 100644 --- a/compiler/backend/reg_alloc/reg_allocScript.sml +++ b/compiler/backend/reg_alloc/reg_allocScript.sml @@ -1059,11 +1059,12 @@ val is_phy_var_def = Define` val is_alloc_var_def = Define` is_alloc_var (n:num) = (n MOD 4 = 1)`; -Theorem convention_partitions ` - ∀n. (is_stack_var n ⇔ (¬is_phy_var n) ∧ ¬(is_alloc_var n)) ∧ +Theorem convention_partitions: + ∀n. (is_stack_var n ⇔ (¬is_phy_var n) ∧ ¬(is_alloc_var n)) ∧ (is_phy_var n ⇔ (¬is_stack_var n) ∧ ¬(is_alloc_var n)) ∧ - (is_alloc_var n ⇔ (¬is_phy_var n) ∧ ¬(is_stack_var n))` - (rw[is_stack_var_def,is_phy_var_def,is_alloc_var_def,EQ_IMP_THM] + (is_alloc_var n ⇔ (¬is_phy_var n) ∧ ¬(is_stack_var n)) +Proof + rw[is_stack_var_def,is_phy_var_def,is_alloc_var_def,EQ_IMP_THM] \\ `n MOD 2 = (n MOD 4) MOD 2` by (ONCE_REWRITE_TAC [GSYM (EVAL ``2*2:num``)] \\ fs [arithmeticTheory.MOD_MULT_MOD]) @@ -1071,7 +1072,8 @@ Theorem convention_partitions ` \\ `n MOD 4 < 4` by fs [] \\ IMP_RES_TAC (DECIDE ``n < 4 ==> (n = 0) \/ (n = 1) \/ (n = 2) \/ (n = 3:num)``) - \\ fs []); + \\ fs [] +QED (* Set the tags according to wordLang conventions *) val mk_tags_def = Define` diff --git a/compiler/backend/riscv/proofs/riscv_configProofScript.sml b/compiler/backend/riscv/proofs/riscv_configProofScript.sml index d7e99e6a5c..a1aee4cd7b 100644 --- a/compiler/backend/riscv/proofs/riscv_configProofScript.sml +++ b/compiler/backend/riscv/proofs/riscv_configProofScript.sml @@ -22,9 +22,10 @@ val names_tac = \\ REWRITE_TAC[SUBSET_DEF] \\ EVAL_TAC \\ rpt strip_tac \\ rveq \\ EVAL_TAC -Theorem riscv_backend_config_ok ` - backend_config_ok riscv_backend_config` - (simp[backend_config_ok_def]>>rw[]>>TRY(EVAL_TAC>>NO_TAC) +Theorem riscv_backend_config_ok: + backend_config_ok riscv_backend_config +Proof + simp[backend_config_ok_def]>>rw[]>>TRY(EVAL_TAC>>NO_TAC) >- fs[riscv_backend_config_def] >- (EVAL_TAC>> blastLib.FULL_BBLAST_TAC) >- names_tac @@ -38,11 +39,13 @@ Theorem riscv_backend_config_ok ` \\ fs[stack_removeTheory.max_stack_alloc_def] \\ EVAL_TAC>>fs[] \\ match_mp_tac bitTheory.NOT_BIT_GT_TWOEXP - \\ fs[]) + \\ fs[] +QED -Theorem riscv_machine_config_ok - `is_riscv_machine_config mc ⇒ mc_conf_ok mc` - (rw[lab_to_targetProofTheory.mc_conf_ok_def,is_riscv_machine_config_def] +Theorem riscv_machine_config_ok: + is_riscv_machine_config mc ⇒ mc_conf_ok mc +Proof + rw[lab_to_targetProofTheory.mc_conf_ok_def,is_riscv_machine_config_def] >- EVAL_TAC >- simp[riscv_targetProofTheory.riscv_encoder_correct] >- EVAL_TAC @@ -50,14 +53,17 @@ Theorem riscv_machine_config_ok >- EVAL_TAC >- EVAL_TAC >- EVAL_TAC - >- metis_tac[asmPropsTheory.encoder_correct_def,asmPropsTheory.target_ok_def,riscv_encoder_correct]); + >- metis_tac[asmPropsTheory.encoder_correct_def,asmPropsTheory.target_ok_def,riscv_encoder_correct] +QED -Theorem riscv_init_ok - `is_riscv_machine_config mc ⇒ - mc_init_ok riscv_backend_config mc` - (rw[mc_init_ok_def] \\ +Theorem riscv_init_ok: + is_riscv_machine_config mc ⇒ + mc_init_ok riscv_backend_config mc +Proof + rw[mc_init_ok_def] \\ fs[is_riscv_machine_config_def] \\ - EVAL_TAC); + EVAL_TAC +QED val is_riscv_machine_config_mc = riscv_init_ok |> concl |> dest_imp |> #1 diff --git a/compiler/backend/semantics/backendPropsScript.sml b/compiler/backend/semantics/backendPropsScript.sml index 1ae6db053e..bfce24a7f8 100644 --- a/compiler/backend/semantics/backendPropsScript.sml +++ b/compiler/backend/semantics/backendPropsScript.sml @@ -29,23 +29,31 @@ val state_co_def = Define ` in (cfg,progs)))`; -Theorem FST_state_co - `FST (state_co f co n) = SND(FST(co n))` - (rw[state_co_def,UNCURRY]); - -Theorem SND_state_co - `SND (state_co f co n) = SND (f (FST(FST(co n))) (SND(co n)))` - (EVAL_TAC \\ pairarg_tac \\ fs[] \\ rw[UNCURRY]); +Theorem FST_state_co: + FST (state_co f co n) = SND(FST(co n)) +Proof + rw[state_co_def,UNCURRY] +QED + +Theorem SND_state_co: + SND (state_co f co n) = SND (f (FST(FST(co n))) (SND(co n))) +Proof + EVAL_TAC \\ pairarg_tac \\ fs[] \\ rw[UNCURRY] +QED val pure_co_def = Define ` pure_co f = I ## f`; -Theorem SND_pure_co[simp] - `SND (pure_co co x) = co (SND x)` - (Cases_on`x` \\ EVAL_TAC); - -Theorem FST_pure_co[simp] - `FST (pure_co co x) = FST x` - (Cases_on`x` \\ EVAL_TAC); +Theorem SND_pure_co[simp]: + SND (pure_co co x) = co (SND x) +Proof + Cases_on`x` \\ EVAL_TAC +QED + +Theorem FST_pure_co[simp]: + FST (pure_co co x) = FST x +Proof + Cases_on`x` \\ EVAL_TAC +QED val _ = export_theory(); diff --git a/compiler/backend/semantics/bviPropsScript.sml b/compiler/backend/semantics/bviPropsScript.sml index 9f497b5211..c1e97a3bfe 100644 --- a/compiler/backend/semantics/bviPropsScript.sml +++ b/compiler/backend/semantics/bviPropsScript.sml @@ -6,64 +6,96 @@ local open bvlPropsTheory in end; val _ = new_theory"bviProps"; -Theorem initial_state_simp[simp] - `(initial_state f c co cc k).code = c ∧ +Theorem initial_state_simp[simp]: + (initial_state f c co cc k).code = c ∧ (initial_state f c co cc k).ffi = f ∧ (initial_state f c co cc k).clock = k ∧ (initial_state f c co cc k).compile = cc ∧ (initial_state f c co cc k).compile_oracle = co ∧ (initial_state f c co cc k).refs = FEMPTY ∧ - (initial_state f c co cc k).global = NONE` - (srw_tac[][initial_state_def]); - -Theorem initial_state_with_simp[simp] - `initial_state f c co cc k with clock := k1 = initial_state f c co cc k1 ∧ - initial_state f c co cc k with code := c1 = initial_state f c1 co cc k` - (EVAL_TAC); - -Theorem bvl_to_bvi_id - `bvl_to_bvi (bvi_to_bvl s) s = s` - (EVAL_TAC \\ full_simp_tac(srw_ss())[bviSemTheory.state_component_equality]); - -Theorem bvl_to_bvi_with_refs - `bvl_to_bvi (x with refs := y) z = bvl_to_bvi x z with <| refs := y |>` - (EVAL_TAC) - -Theorem bvl_to_bvi_with_clock - `bvl_to_bvi (x with clock := y) z = bvl_to_bvi x z with <| clock := y |>` - (EVAL_TAC) - -Theorem bvl_to_bvi_with_ffi - `bvl_to_bvi (x with ffi := y) z = bvl_to_bvi x z with ffi := y` - (EVAL_TAC) - -Theorem bvl_to_bvi_code[simp] - `(bvl_to_bvi x y).code = y.code` - (EVAL_TAC) - -Theorem bvl_to_bvi_clock[simp] - `(bvl_to_bvi x y).clock = x.clock` - (EVAL_TAC) - -Theorem bvi_to_bvl_refs[simp] - `(bvi_to_bvl x).refs = x.refs` (EVAL_TAC) - -Theorem bvi_to_bvl_code[simp] - `(bvi_to_bvl x).code = map (K ARB) x.code` (EVAL_TAC) - -Theorem bvi_to_bvl_clock[simp] - `(bvi_to_bvl x).clock = x.clock` (EVAL_TAC) - -Theorem bvi_to_bvl_ffi[simp] - `(bvi_to_bvl x).ffi = x.ffi` (EVAL_TAC); - -Theorem bvi_to_bvl_to_bvi_with_ffi - `bvl_to_bvi (bvi_to_bvl x with ffi := f) x = x with ffi := f` - (EVAL_TAC \\ rw[state_component_equality]); - -Theorem domain_bvi_to_bvl_code[simp] - `domain (bvi_to_bvl s).code = domain s.code` - (srw_tac[][bvi_to_bvl_def,domain_map]) + (initial_state f c co cc k).global = NONE +Proof + srw_tac[][initial_state_def] +QED + +Theorem initial_state_with_simp[simp]: + initial_state f c co cc k with clock := k1 = initial_state f c co cc k1 ∧ + initial_state f c co cc k with code := c1 = initial_state f c1 co cc k +Proof + EVAL_TAC +QED + +Theorem bvl_to_bvi_id: + bvl_to_bvi (bvi_to_bvl s) s = s +Proof + EVAL_TAC \\ full_simp_tac(srw_ss())[bviSemTheory.state_component_equality] +QED + +Theorem bvl_to_bvi_with_refs: + bvl_to_bvi (x with refs := y) z = bvl_to_bvi x z with <| refs := y |> +Proof + EVAL_TAC +QED + +Theorem bvl_to_bvi_with_clock: + bvl_to_bvi (x with clock := y) z = bvl_to_bvi x z with <| clock := y |> +Proof + EVAL_TAC +QED + +Theorem bvl_to_bvi_with_ffi: + bvl_to_bvi (x with ffi := y) z = bvl_to_bvi x z with ffi := y +Proof + EVAL_TAC +QED + +Theorem bvl_to_bvi_code[simp]: + (bvl_to_bvi x y).code = y.code +Proof + EVAL_TAC +QED + +Theorem bvl_to_bvi_clock[simp]: + (bvl_to_bvi x y).clock = x.clock +Proof + EVAL_TAC +QED + +Theorem bvi_to_bvl_refs[simp]: + (bvi_to_bvl x).refs = x.refs +Proof +EVAL_TAC +QED + +Theorem bvi_to_bvl_code[simp]: + (bvi_to_bvl x).code = map (K ARB) x.code +Proof +EVAL_TAC +QED + +Theorem bvi_to_bvl_clock[simp]: + (bvi_to_bvl x).clock = x.clock +Proof +EVAL_TAC +QED + +Theorem bvi_to_bvl_ffi[simp]: + (bvi_to_bvl x).ffi = x.ffi +Proof +EVAL_TAC +QED + +Theorem bvi_to_bvl_to_bvi_with_ffi: + bvl_to_bvi (bvi_to_bvl x with ffi := f) x = x with ffi := f +Proof + EVAL_TAC \\ rw[state_component_equality] +QED + +Theorem domain_bvi_to_bvl_code[simp]: + domain (bvi_to_bvl s).code = domain s.code +Proof + srw_tac[][bvi_to_bvl_def,domain_map] +QED val list_thms = { nchotomy = list_nchotomy, case_def = list_case_def }; val option_thms = { nchotomy = option_nchotomy, case_def = option_case_def }; @@ -101,41 +133,48 @@ val evaluate_LENGTH = Q.prove( val _ = save_thm("evaluate_LENGTH", evaluate_LENGTH); -Theorem evaluate_IMP_LENGTH - `(evaluate (xs,s,env) = (Rval res,s1)) ==> (LENGTH xs = LENGTH res)` - (REPEAT STRIP_TAC \\ MP_TAC (SPEC_ALL evaluate_LENGTH) \\ full_simp_tac(srw_ss())[]); +Theorem evaluate_IMP_LENGTH: + (evaluate (xs,s,env) = (Rval res,s1)) ==> (LENGTH xs = LENGTH res) +Proof + REPEAT STRIP_TAC \\ MP_TAC (SPEC_ALL evaluate_LENGTH) \\ full_simp_tac(srw_ss())[] +QED -Theorem evaluate_SING_IMP - `(evaluate ([x],env,s1) = (Rval vs,s2)) ==> ?w. vs = [w]` - (REPEAT STRIP_TAC \\ IMP_RES_TAC evaluate_IMP_LENGTH +Theorem evaluate_SING_IMP: + (evaluate ([x],env,s1) = (Rval vs,s2)) ==> ?w. vs = [w] +Proof + REPEAT STRIP_TAC \\ IMP_RES_TAC evaluate_IMP_LENGTH \\ Cases_on `vs` \\ FULL_SIMP_TAC (srw_ss()) [] - \\ Cases_on `t` \\ FULL_SIMP_TAC (srw_ss()) []); + \\ Cases_on `t` \\ FULL_SIMP_TAC (srw_ss()) [] +QED -Theorem evaluate_CONS - `evaluate (x::xs,env,s) = +Theorem evaluate_CONS: + evaluate (x::xs,env,s) = case evaluate ([x],env,s) of | (Rval v,s2) => (case evaluate (xs,env,s2) of | (Rval vs,s1) => (Rval (HD v::vs),s1) | t => t) - | t => t` - (Cases_on `xs` \\ full_simp_tac(srw_ss())[evaluate_def] + | t => t +Proof + Cases_on `xs` \\ full_simp_tac(srw_ss())[evaluate_def] \\ Cases_on `evaluate ([x],env,s)` \\ full_simp_tac(srw_ss())[evaluate_def] \\ Cases_on `q` \\ full_simp_tac(srw_ss())[evaluate_def] \\ IMP_RES_TAC evaluate_IMP_LENGTH \\ Cases_on `a` \\ full_simp_tac(srw_ss())[] - \\ Cases_on `t` \\ full_simp_tac(srw_ss())[]); + \\ Cases_on `t` \\ full_simp_tac(srw_ss())[] +QED -Theorem evaluate_SNOC - `!xs env s x. +Theorem evaluate_SNOC: + !xs env s x. evaluate (SNOC x xs,env,s) = case evaluate (xs,env,s) of | (Rval vs,s2) => (case evaluate ([x],env,s2) of | (Rval v,s1) => (Rval (vs ++ v),s1) | t => t) - | t => t` - (Induct THEN1 + | t => t +Proof + Induct THEN1 (full_simp_tac(srw_ss())[SNOC_APPEND,evaluate_def] \\ REPEAT STRIP_TAC \\ Cases_on `evaluate ([x],env,s)` \\ Cases_on `q` \\ full_simp_tac(srw_ss())[]) \\ full_simp_tac(srw_ss())[SNOC_APPEND,APPEND] @@ -146,84 +185,119 @@ Theorem evaluate_SNOC \\ Cases_on `evaluate ([x],env,r')` \\ Cases_on `q` \\ full_simp_tac(srw_ss())[evaluate_def] \\ IMP_RES_TAC evaluate_IMP_LENGTH \\ Cases_on `a''` \\ full_simp_tac(srw_ss())[LENGTH] - \\ REV_FULL_SIMP_TAC std_ss [LENGTH_NIL] \\ full_simp_tac(srw_ss())[]); + \\ REV_FULL_SIMP_TAC std_ss [LENGTH_NIL] \\ full_simp_tac(srw_ss())[] +QED -Theorem evaluate_APPEND - `!xs env s ys. +Theorem evaluate_APPEND: + !xs env s ys. evaluate (xs ++ ys,env,s) = case evaluate (xs,env,s) of (Rval vs,s2) => (case evaluate (ys,env,s2) of (Rval ws,s1) => (Rval (vs ++ ws),s1) | res => res) - | res => res` - (Induct \\ full_simp_tac(srw_ss())[APPEND,evaluate_def] \\ REPEAT STRIP_TAC + | res => res +Proof + Induct \\ full_simp_tac(srw_ss())[APPEND,evaluate_def] \\ REPEAT STRIP_TAC >- every_case_tac \\ ONCE_REWRITE_TAC [evaluate_CONS] - \\ every_case_tac \\ full_simp_tac(srw_ss())[]); + \\ every_case_tac \\ full_simp_tac(srw_ss())[] +QED val inc_clock_def = Define ` inc_clock n (s:('c,'ffi) bviSem$state) = s with clock := s.clock + n`; -Theorem inc_clock_ZERO - `!s. inc_clock 0 s = s` - (full_simp_tac(srw_ss())[inc_clock_def,state_component_equality]); - -Theorem inc_clock_ADD - `inc_clock n (inc_clock m s) = inc_clock (n+m) s` - (full_simp_tac(srw_ss())[inc_clock_def,state_component_equality,AC ADD_ASSOC ADD_COMM]); - -Theorem inc_clock_refs[simp] - `(inc_clock n s).refs = s.refs` (EVAL_TAC) - -Theorem inc_clock_code[simp] - `(inc_clock n s).code = s.code` (EVAL_TAC) - -Theorem inc_clock_global[simp] - `(inc_clock n s).global = s.global` - (srw_tac[][inc_clock_def]) - -Theorem inc_clock_ffi[simp] - `(inc_clock n s).ffi = s.ffi` - (srw_tac[][inc_clock_def]) - -Theorem inc_clock_clock[simp] - `(inc_clock n s).clock = s.clock + n` - (srw_tac[][inc_clock_def]) - -Theorem dec_clock_global[simp] - `(dec_clock n s).global = s.global` - (srw_tac[][dec_clock_def]) - -Theorem dec_clock_ffi[simp] - `(dec_clock n s).ffi = s.ffi` - (srw_tac[][dec_clock_def]) - -Theorem dec_clock_refs[simp] - `(dec_clock n s).refs = s.refs` - (srw_tac[][dec_clock_def]) - -Theorem dec_clock_with_code[simp] - `bviSem$dec_clock n (s with code := c) = dec_clock n s with code := c` - (EVAL_TAC ); - -Theorem dec_clock_code[simp] - `(dec_clock n s).code = s.code` - (srw_tac[][dec_clock_def]) - -Theorem dec_clock_inv_clock - `¬(t1.clock < ticks + 1) ==> - (dec_clock (ticks + 1) (inc_clock c t1) = inc_clock c (dec_clock (ticks + 1) t1))` - (full_simp_tac(srw_ss())[dec_clock_def,inc_clock_def,state_component_equality] \\ DECIDE_TAC); - -Theorem dec_clock_inv_clock1 - `t1.clock <> 0 ==> - (dec_clock 1 (inc_clock c t1) = inc_clock c (dec_clock 1 t1))` - (full_simp_tac(srw_ss())[dec_clock_def,inc_clock_def,state_component_equality] \\ DECIDE_TAC); - -Theorem dec_clock0[simp] - `!n (s:('c,'ffi) bviSem$state). dec_clock 0 s = s` - (simp [dec_clock_def, state_component_equality]); +Theorem inc_clock_ZERO: + !s. inc_clock 0 s = s +Proof + full_simp_tac(srw_ss())[inc_clock_def,state_component_equality] +QED + +Theorem inc_clock_ADD: + inc_clock n (inc_clock m s) = inc_clock (n+m) s +Proof + full_simp_tac(srw_ss())[inc_clock_def,state_component_equality,AC ADD_ASSOC ADD_COMM] +QED + +Theorem inc_clock_refs[simp]: + (inc_clock n s).refs = s.refs +Proof +EVAL_TAC +QED + +Theorem inc_clock_code[simp]: + (inc_clock n s).code = s.code +Proof +EVAL_TAC +QED + +Theorem inc_clock_global[simp]: + (inc_clock n s).global = s.global +Proof + srw_tac[][inc_clock_def] +QED + +Theorem inc_clock_ffi[simp]: + (inc_clock n s).ffi = s.ffi +Proof + srw_tac[][inc_clock_def] +QED + +Theorem inc_clock_clock[simp]: + (inc_clock n s).clock = s.clock + n +Proof + srw_tac[][inc_clock_def] +QED + +Theorem dec_clock_global[simp]: + (dec_clock n s).global = s.global +Proof + srw_tac[][dec_clock_def] +QED + +Theorem dec_clock_ffi[simp]: + (dec_clock n s).ffi = s.ffi +Proof + srw_tac[][dec_clock_def] +QED + +Theorem dec_clock_refs[simp]: + (dec_clock n s).refs = s.refs +Proof + srw_tac[][dec_clock_def] +QED + +Theorem dec_clock_with_code[simp]: + bviSem$dec_clock n (s with code := c) = dec_clock n s with code := c +Proof + EVAL_TAC +QED + +Theorem dec_clock_code[simp]: + (dec_clock n s).code = s.code +Proof + srw_tac[][dec_clock_def] +QED + +Theorem dec_clock_inv_clock: + ¬(t1.clock < ticks + 1) ==> + (dec_clock (ticks + 1) (inc_clock c t1) = inc_clock c (dec_clock (ticks + 1) t1)) +Proof + full_simp_tac(srw_ss())[dec_clock_def,inc_clock_def,state_component_equality] \\ DECIDE_TAC +QED + +Theorem dec_clock_inv_clock1: + t1.clock <> 0 ==> + (dec_clock 1 (inc_clock c t1) = inc_clock c (dec_clock 1 t1)) +Proof + full_simp_tac(srw_ss())[dec_clock_def,inc_clock_def,state_component_equality] \\ DECIDE_TAC +QED + +Theorem dec_clock0[simp]: + !n (s:('c,'ffi) bviSem$state). dec_clock 0 s = s +Proof + simp [dec_clock_def, state_component_equality] +QED val do_app_inv_clock = Q.prove( `case do_app op (REVERSE a) s of @@ -243,11 +317,12 @@ val do_app_inv_clock = Q.prove( \\ rfs [] \\ fs[state_component_equality] \\ fs[] \\ rw[] \\ fs[] \\ fs[bvlSemTheory.state_component_equality] \\ fs[] \\ rw[] \\ fs[]); -Theorem evaluate_inv_clock - `!xs env t1 res t2 n. +Theorem evaluate_inv_clock: + !xs env t1 res t2 n. (evaluate (xs,env,t1) = (res,t2)) /\ res <> Rerr(Rabort Rtimeout_error) ==> - (evaluate (xs,env,inc_clock n t1) = (res,inc_clock n t2))` - (SIMP_TAC std_ss [] \\ recInduct evaluate_ind \\ REPEAT STRIP_TAC + (evaluate (xs,env,inc_clock n t1) = (res,inc_clock n t2)) +Proof + SIMP_TAC std_ss [] \\ recInduct evaluate_ind \\ REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[evaluate_def] THEN1 (`?res5 s5. evaluate ([x],env,s) = (res5,s5)` by METIS_TAC [PAIR] \\ `?res6 s6. evaluate (y::xs,env,s5) = (res6,s6)` by METIS_TAC [PAIR] @@ -285,28 +360,34 @@ Theorem evaluate_inv_clock \\ Cases_on `q'` \\ full_simp_tac(srw_ss())[] \\ SRW_TAC [] [] \\ TRY(Cases_on`e` \\ full_simp_tac(srw_ss())[] \\ Cases_on`a'` \\ full_simp_tac(srw_ss())[] \\ srw_tac[][]) \\ RES_TAC \\ TRY (full_simp_tac(srw_ss())[inc_clock_def] \\ decide_tac) - \\ Cases_on `handler` \\ full_simp_tac(srw_ss())[] \\ srw_tac[][])); - -Theorem do_app_code - `!op s1 s2. (do_app op a s1 = Rval (x0,s2)) /\ op <> Install ==> (s2.code = s1.code)` - (rw[do_app_def,case_eq_thms,pair_case_eq,bvl_to_bvi_def] \\ rw[] \\ - fs[do_app_aux_def,case_eq_thms] \\ rw[]); - -Theorem do_app_oracle - `!op s1 s2. (do_app op a s1 = Rval (x0,s2)) /\ op <> Install ==> + \\ Cases_on `handler` \\ full_simp_tac(srw_ss())[] \\ srw_tac[][]) +QED + +Theorem do_app_code: + !op s1 s2. (do_app op a s1 = Rval (x0,s2)) /\ op <> Install ==> (s2.code = s1.code) +Proof + rw[do_app_def,case_eq_thms,pair_case_eq,bvl_to_bvi_def] \\ rw[] \\ + fs[do_app_aux_def,case_eq_thms] \\ rw[] +QED + +Theorem do_app_oracle: + !op s1 s2. (do_app op a s1 = Rval (x0,s2)) /\ op <> Install ==> (s2.compile_oracle = s1.compile_oracle) /\ - (s2.compile = s1.compile)` - (rw[do_app_def,case_eq_thms,pair_case_eq,bvl_to_bvi_def] \\ rw[] \\ - fs[do_app_aux_def,case_eq_thms] \\ rw[]); - -Theorem evaluate_code - `!xs env s1 vs s2. + (s2.compile = s1.compile) +Proof + rw[do_app_def,case_eq_thms,pair_case_eq,bvl_to_bvi_def] \\ rw[] \\ + fs[do_app_aux_def,case_eq_thms] \\ rw[] +QED + +Theorem evaluate_code: + !xs env s1 vs s2. (evaluate (xs,env,s1) = (vs,s2)) ==> ∃n. s2.compile_oracle = shift_seq n s1.compile_oracle ∧ s2.code = FOLDL union s1.code (MAP (fromAList o SND) - (GENLIST s1.compile_oracle n))` - (recInduct evaluate_ind \\ rw [evaluate_def] + (GENLIST s1.compile_oracle n)) +Proof + recInduct evaluate_ind \\ rw [evaluate_def] \\ fs[case_eq_thms,pair_case_eq,bool_case_eq,bvlPropsTheory.case_eq_thms] \\ rveq \\ fs[shift_seq_def,dec_clock_def] \\ rfs[] \\ TRY (qexists_tac`0` \\ srw_tac[ETA_ss][] \\ NO_TAC) @@ -333,14 +414,17 @@ Theorem evaluate_code \\ qexists_tac`1+n` \\ rfs[GENLIST_APPEND,FOLDL_APPEND] ) \\ imp_res_tac do_app_code \\ rfs[] \\ imp_res_tac do_app_oracle \\ rfs[] - \\ qexists_tac`n` \\ fs[]); + \\ qexists_tac`n` \\ fs[] +QED -Theorem evaluate_code_mono - `!xs env s1 vs s2. +Theorem evaluate_code_mono: + !xs env s1 vs s2. (evaluate (xs,env,s1) = (vs,s2)) ==> - subspt s1.code s2.code` - (rw[] \\ imp_res_tac evaluate_code - \\ rw[] \\ metis_tac[subspt_FOLDL_union]); + subspt s1.code s2.code +Proof + rw[] \\ imp_res_tac evaluate_code + \\ rw[] \\ metis_tac[subspt_FOLDL_union] +QED val evaluate_global_mono_lemma = Q.prove( `∀xs env s. IS_SOME s.global ⇒ IS_SOME((SND (evaluate (xs,env,s))).global)`, @@ -353,57 +437,70 @@ val evaluate_global_mono_lemma = Q.prove( \\ every_case_tac \\ fs [do_install_def] \\ rw [] \\ fs []); -Theorem evaluate_global_mono - `∀xs env s res t. (evaluate (xs,env,s) = (res,t)) ⇒ IS_SOME s.global ⇒ IS_SOME t.global` - (METIS_TAC[SND,evaluate_global_mono_lemma]); +Theorem evaluate_global_mono: + ∀xs env s res t. (evaluate (xs,env,s) = (res,t)) ⇒ IS_SOME s.global ⇒ IS_SOME t.global +Proof + METIS_TAC[SND,evaluate_global_mono_lemma] +QED -Theorem do_app_err - `do_app op vs s = Rerr e ⇒ (e = Rabort Rtype_error) +Theorem do_app_err: + do_app op vs s = Rerr e ⇒ (e = Rabort Rtype_error) \/ - (?i x. op = FFI i /\ e = Rabort (Rffi_error x)) ` - (rw[bviSemTheory.do_app_def,case_eq_thms,pair_case_eq] >> + (?i x. op = FFI i /\ e = Rabort (Rffi_error x)) +Proof + rw[bviSemTheory.do_app_def,case_eq_thms,pair_case_eq] >> imp_res_tac bvlPropsTheory.do_app_err >> - fs [do_install_def,UNCURRY] \\ every_case_tac \\ fs []); - -Theorem do_app_aux_const - `do_app_aux op vs s = SOME (SOME (y,z)) ⇒ - z.clock = s.clock` - (rw[do_app_aux_def,case_eq_thms] >> rw[]); - -Theorem do_app_with_code - `bviSem$do_app op vs s = Rval (r,s') ⇒ + fs [do_install_def,UNCURRY] \\ every_case_tac \\ fs [] +QED + +Theorem do_app_aux_const: + do_app_aux op vs s = SOME (SOME (y,z)) ⇒ + z.clock = s.clock +Proof + rw[do_app_aux_def,case_eq_thms] >> rw[] +QED + +Theorem do_app_with_code: + bviSem$do_app op vs s = Rval (r,s') ⇒ domain s.code ⊆ domain c ∧ op ≠ Install ⇒ - do_app op vs (s with code := c) = Rval (r,s' with code := c)` - (rw [do_app_def,do_app_aux_def,case_eq_thms,pair_case_eq] + do_app op vs (s with code := c) = Rval (r,s' with code := c) +Proof + rw [do_app_def,do_app_aux_def,case_eq_thms,pair_case_eq] \\ fs[bvl_to_bvi_def,bvi_to_bvl_def,bvlSemTheory.do_app_def,case_eq_thms] \\ rw[] \\ fs[] \\ rw[] \\ fs[case_eq_thms,pair_case_eq] \\ rw[] - \\ fs[SUBSET_DEF]); + \\ fs[SUBSET_DEF] +QED -Theorem do_app_with_code_err - `bviSem$do_app op vs s = Rerr e ⇒ +Theorem do_app_with_code_err: + bviSem$do_app op vs s = Rerr e ⇒ (domain c ⊆ domain s.code ∨ e ≠ Rabort Rtype_error) ∧ op ≠ Install ⇒ - do_app op vs (s with code := c) = Rerr e` - (rw [do_app_def,do_app_aux_def,case_eq_thms,pair_case_eq] + do_app op vs (s with code := c) = Rerr e +Proof + rw [do_app_def,do_app_aux_def,case_eq_thms,pair_case_eq] \\ fs[bvl_to_bvi_def,bvi_to_bvl_def,bvlSemTheory.do_app_def,case_eq_thms] \\ rw[] \\ fs[] \\ rw[] \\ fs[case_eq_thms,pair_case_eq] \\ rw[] - \\ fs[SUBSET_DEF] \\ strip_tac \\ res_tac); + \\ fs[SUBSET_DEF] \\ strip_tac \\ res_tac +QED (* -Theorem find_code_add_code - `bvlSem$find_code dest a (fromAList code) = SOME x ⇒ - find_code dest a (fromAList (code ++ extra)) = SOME x` - (Cases_on`dest`>>srw_tac[][bvlSemTheory.find_code_def] >> +Theorem find_code_add_code: + bvlSem$find_code dest a (fromAList code) = SOME x ⇒ + find_code dest a (fromAList (code ++ extra)) = SOME x +Proof + Cases_on`dest`>>srw_tac[][bvlSemTheory.find_code_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> - full_simp_tac(srw_ss())[lookup_fromAList,ALOOKUP_APPEND] >> srw_tac[][]); + full_simp_tac(srw_ss())[lookup_fromAList,ALOOKUP_APPEND] >> srw_tac[][] +QED -Theorem evaluate_add_code - `∀xs env s r s'. +Theorem evaluate_add_code: + ∀xs env s r s'. evaluate (xs,env,s) = (r,s') ∧ r ≠ Rerr (Rabort Rtype_error) ∧ s.code = fromAList code ⇒ evaluate (xs,env,s with code := fromAList (code ++ extra)) = - (r,s' with code := fromAList (code ++ extra))` - (recInduct evaluate_ind >> + (r,s' with code := fromAList (code ++ extra)) +Proof + recInduct evaluate_ind >> srw_tac[][evaluate_def] >> TRY ( rename1`Boolv T = HD _` >> @@ -436,38 +533,46 @@ Theorem evaluate_add_code imp_res_tac find_code_add_code >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> NO_TAC) >> every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> rev_full_simp_tac(srw_ss())[] >> srw_tac[][] >> - imp_res_tac evaluate_code_const >> full_simp_tac(srw_ss())[] >> rev_full_simp_tac(srw_ss())[]); + imp_res_tac evaluate_code_const >> full_simp_tac(srw_ss())[] >> rev_full_simp_tac(srw_ss())[] +QED *) -Theorem do_app_aux_with_clock - `do_app_aux op vs (s with clock := c) = - OPTION_MAP (OPTION_MAP (λ(x,y). (x,y with clock := c))) (do_app_aux op vs s)` - (srw_tac[][do_app_aux_def] >> - every_case_tac >> fs[]); - -Theorem do_app_change_clock - `(do_app op args s1 = Rval (res,s2)) ==> - (do_app op args (s1 with clock := ck) = Rval (res,s2 with clock := ck))` - (rw[do_app_def,do_app_aux_with_clock,case_eq_thms,pair_case_eq,PULL_EXISTS] +Theorem do_app_aux_with_clock: + do_app_aux op vs (s with clock := c) = + OPTION_MAP (OPTION_MAP (λ(x,y). (x,y with clock := c))) (do_app_aux op vs s) +Proof + srw_tac[][do_app_aux_def] >> + every_case_tac >> fs[] +QED + +Theorem do_app_change_clock: + (do_app op args s1 = Rval (res,s2)) ==> + (do_app op args (s1 with clock := ck) = Rval (res,s2 with clock := ck)) +Proof + rw[do_app_def,do_app_aux_with_clock,case_eq_thms,pair_case_eq,PULL_EXISTS] \\ imp_res_tac bvlPropsTheory.do_app_change_clock \\ fs[bvi_to_bvl_def,bvl_to_bvi_def] - \\ fs [do_install_def,UNCURRY] \\ every_case_tac \\ fs []); + \\ fs [do_install_def,UNCURRY] \\ every_case_tac \\ fs [] +QED -Theorem do_app_change_clock_err - `bviSem$do_app op vs s = Rerr e ⇒ - do_app op vs (s with clock := c) = Rerr e` - (rw[do_app_def,do_app_aux_with_clock,case_eq_thms,pair_case_eq,PULL_EXISTS] +Theorem do_app_change_clock_err: + bviSem$do_app op vs s = Rerr e ⇒ + do_app op vs (s with clock := c) = Rerr e +Proof + rw[do_app_def,do_app_aux_with_clock,case_eq_thms,pair_case_eq,PULL_EXISTS] \\ imp_res_tac bvlPropsTheory.do_app_change_clock_err \\ fs[bvi_to_bvl_def,bvl_to_bvi_def] - \\ fs [do_install_def,UNCURRY] \\ every_case_tac \\ fs []); + \\ fs [do_install_def,UNCURRY] \\ every_case_tac \\ fs [] +QED -Theorem evaluate_add_clock - `!exps env s1 res s2. +Theorem evaluate_add_clock: + !exps env s1 res s2. evaluate (exps,env,s1) = (res, s2) ∧ res ≠ Rerr(Rabort Rtimeout_error) ⇒ - !ck. evaluate (exps,env,inc_clock ck s1) = (res, inc_clock ck s2)` - (recInduct evaluate_ind >> + !ck. evaluate (exps,env,inc_clock ck s1) = (res, inc_clock ck s2) +Proof + recInduct evaluate_ind >> srw_tac[][evaluate_def] >- (Cases_on `evaluate ([x], env,s)` >> full_simp_tac(srw_ss())[] >> Cases_on `q` >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> @@ -509,33 +614,40 @@ Theorem evaluate_add_clock fsrw_tac[ARITH_ss][] >> `ck + r.clock - (ticks + 1) = r.clock - (ticks + 1) + ck` by srw_tac [ARITH_ss] [ADD1] >> full_simp_tac(srw_ss())[] >> - rpt(first_x_assum(qspec_then`ck`mp_tac))>> srw_tac[][])); - -Theorem do_app_aux_io_events_mono - `do_app_aux op vs s = SOME (SOME (x,y)) ⇒ - s.ffi.io_events ≼ y.ffi.io_events` - (rw[do_app_aux_def,case_eq_thms] \\ rw[]); - -Theorem do_app_io_events_mono - `do_app op vs s1 = Rval (x,s2) ⇒ - s1.ffi.io_events ≼ s2.ffi.io_events` - (rw[do_app_def,case_eq_thms,pair_case_eq] + rpt(first_x_assum(qspec_then`ck`mp_tac))>> srw_tac[][]) +QED + +Theorem do_app_aux_io_events_mono: + do_app_aux op vs s = SOME (SOME (x,y)) ⇒ + s.ffi.io_events ≼ y.ffi.io_events +Proof + rw[do_app_aux_def,case_eq_thms] \\ rw[] +QED + +Theorem do_app_io_events_mono: + do_app op vs s1 = Rval (x,s2) ⇒ + s1.ffi.io_events ≼ s2.ffi.io_events +Proof + rw[do_app_def,case_eq_thms,pair_case_eq] \\ fs[bvl_to_bvi_def,bvi_to_bvl_def] \\ imp_res_tac bvlPropsTheory.do_app_io_events_mono \\ fs[] \\ imp_res_tac do_app_aux_io_events_mono \\ fs[] \\ fs [do_install_def,UNCURRY] \\ every_case_tac \\ fs [] - \\ rw [] \\ fs []); + \\ rw [] \\ fs [] +QED -Theorem evaluate_io_events_mono - `!exps env s1 res s2. +Theorem evaluate_io_events_mono: + !exps env s1 res s2. evaluate (exps,env,s1) = (res, s2) ⇒ - s1.ffi.io_events ≼ s2.ffi.io_events` - (recInduct evaluate_ind >> + s1.ffi.io_events ≼ s2.ffi.io_events +Proof + recInduct evaluate_ind >> srw_tac[][evaluate_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> rev_full_simp_tac(srw_ss())[] >> - metis_tac[IS_PREFIX_TRANS,do_app_io_events_mono]) + metis_tac[IS_PREFIX_TRANS,do_app_io_events_mono] +QED val do_app_inc_clock = Q.prove( `do_app op vs (inc_clock x y) = @@ -557,15 +669,18 @@ val dec_clock_inc_clock = Q.prove( `¬(s.clock < n) ⇒ dec_clock n (inc_clock x s) = inc_clock x (dec_clock n s)`, simp[state_component_equality,inc_clock_def,dec_clock_def]) -Theorem inc_clock_eq_0[simp] - `(inc_clock extra s).clock = 0 ⇔ s.clock = 0 ∧ extra = 0` - (srw_tac[][inc_clock_def]) +Theorem inc_clock_eq_0[simp]: + (inc_clock extra s).clock = 0 ⇔ s.clock = 0 ∧ extra = 0 +Proof + srw_tac[][inc_clock_def] +QED -Theorem evaluate_add_to_clock_io_events_mono - `∀exps env s extra. +Theorem evaluate_add_to_clock_io_events_mono: + ∀exps env s extra. (SND(evaluate(exps,env,s))).ffi.io_events ≼ - (SND(evaluate(exps,env,inc_clock extra s))).ffi.io_events` - (recInduct evaluate_ind >> + (SND(evaluate(exps,env,inc_clock extra s))).ffi.io_events +Proof + recInduct evaluate_ind >> srw_tac[][evaluate_def] >> TRY ( rename1`Boolv T` >> @@ -585,7 +700,8 @@ Theorem evaluate_add_to_clock_io_events_mono fsrw_tac[ARITH_ss][dec_clock_inc_clock,inc_clock_ZERO] >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> metis_tac[evaluate_io_events_mono,SND,IS_PREFIX_TRANS,PAIR, - inc_clock_ffi,dec_clock_ffi]); + inc_clock_ffi,dec_clock_ffi] +QED val take_drop_lem = Q.prove ( `!skip env. @@ -607,13 +723,14 @@ val take_drop_lem = Q.prove ( srw_tac[][EL_DROP] >> srw_tac [ARITH_ss] []); -Theorem evaluate_genlist_vars - `!skip env n (st:('c,'ffi) bviSem$state). +Theorem evaluate_genlist_vars: + !skip env n (st:('c,'ffi) bviSem$state). n + skip ≤ LENGTH env ⇒ evaluate (GENLIST (λarg. Var (arg + skip)) n, env, st) = - (Rval (TAKE n (DROP skip env)), st)` - (Induct_on `n` >> + (Rval (TAKE n (DROP skip env)), st) +Proof + Induct_on `n` >> srw_tac[][evaluate_def, DROP_LENGTH_NIL, GSYM ADD1] >> srw_tac[][Once GENLIST_CONS] >> srw_tac[][Once evaluate_CONS, evaluate_def] >> @@ -631,7 +748,8 @@ Theorem evaluate_genlist_vars by (Cases_on `DROP skip env` >> full_simp_tac(srw_ss())[] >> decide_tac) >> - metis_tac [take_drop_lem]); + metis_tac [take_drop_lem] +QED val get_code_labels_def = tDefine"get_code_labels" `(get_code_labels (Var _) = {}) ∧ diff --git a/compiler/backend/semantics/bviSemScript.sml b/compiler/backend/semantics/bviSemScript.sml index c88cee7eb9..b090e17066 100644 --- a/compiler/backend/semantics/bviSemScript.sml +++ b/compiler/backend/semantics/bviSemScript.sml @@ -201,10 +201,11 @@ val evaluate_ind = theorem"evaluate_ind"; (* We prove that the clock never increases. *) -Theorem do_app_const - `(bviSem$do_app op args s1 = Rval (res,s2)) ==> - (s2.clock = s1.clock)` - (SIMP_TAC std_ss [do_app_def,do_install_def] +Theorem do_app_const: + (bviSem$do_app op args s1 = Rval (res,s2)) ==> + (s2.clock = s1.clock) +Proof + SIMP_TAC std_ss [do_app_def,do_install_def] \\ IF_CASES_TAC THEN1 (ntac 2 (every_case_tac \\ fs [UNCURRY]) \\ rw [] \\ fs []) \\ Cases_on `do_app_aux op args s1` \\ fs [] @@ -217,21 +218,26 @@ Theorem do_app_const \\ Cases_on `x'` \\ fs [] \\ fs [do_app_aux_def] \\ BasicProvers.EVERY_CASE_TAC - \\ fs [LET_DEF] \\ SRW_TAC [] [] \\ fs []); + \\ fs [LET_DEF] \\ SRW_TAC [] [] \\ fs [] +QED -Theorem evaluate_clock - `!xs env s1 vs s2. - (bviSem$evaluate (xs,env,s1) = (vs,s2)) ==> s2.clock <= s1.clock` - (recInduct evaluate_ind >> rw[evaluate_def] >> +Theorem evaluate_clock: + !xs env s1 vs s2. + (bviSem$evaluate (xs,env,s1) = (vs,s2)) ==> s2.clock <= s1.clock +Proof + recInduct evaluate_ind >> rw[evaluate_def] >> every_case_tac >> fs[dec_clock_def] >> rw[] >> rfs[] >> imp_res_tac fix_clock_IMP >> - imp_res_tac do_app_const >> fs[]); + imp_res_tac do_app_const >> fs[] +QED -Theorem fix_clock_evaluate - `fix_clock s (evaluate (xs,env,s)) = evaluate (xs,env,s)` - (Cases_on `evaluate(xs,env,s)` \\ fs [fix_clock_def] +Theorem fix_clock_evaluate: + fix_clock s (evaluate (xs,env,s)) = evaluate (xs,env,s) +Proof + Cases_on `evaluate(xs,env,s)` \\ fs [fix_clock_def] \\ imp_res_tac evaluate_clock - \\ fs [MIN_DEF,theorem "state_component_equality"]); + \\ fs [MIN_DEF,theorem "state_component_equality"] +QED (* Finally, we remove fix_clock from the induction and definition theorems. *) diff --git a/compiler/backend/semantics/bvlPropsScript.sml b/compiler/backend/semantics/bvlPropsScript.sml index 711443d16e..b829aa64e1 100644 --- a/compiler/backend/semantics/bvlPropsScript.sml +++ b/compiler/backend/semantics/bvlPropsScript.sml @@ -8,17 +8,23 @@ val _ = new_theory"bvlProps"; val s = ``(s:('c,'ffi) bvlSem$state)`` -Theorem with_same_code[simp] - `^s with code := s.code = s` - (srw_tac[][bvlSemTheory.state_component_equality]) - -Theorem with_same_clock[simp] - `(st:('a,'b) bvlSem$state) with clock := st.clock = st` - (rw[bvlSemTheory.state_component_equality]); - -Theorem dec_clock_with_code[simp] - `bvlSem$dec_clock n (s with code := c) = dec_clock n s with code := c` - (EVAL_TAC ); +Theorem with_same_code[simp]: + ^s with code := s.code = s +Proof + srw_tac[][bvlSemTheory.state_component_equality] +QED + +Theorem with_same_clock[simp]: + (st:('a,'b) bvlSem$state) with clock := st.clock = st +Proof + rw[bvlSemTheory.state_component_equality] +QED + +Theorem dec_clock_with_code[simp]: + bvlSem$dec_clock n (s with code := c) = dec_clock n s with code := c +Proof + EVAL_TAC +QED fun get_thms ty = { case_def = TypeBase.case_def_of ty, nchotomy = TypeBase.nchotomy_of ty } val case_eq_thms = LIST_CONJ (closSemTheory.case_eq_thms:: @@ -53,8 +59,8 @@ val do_app_cases_err = save_thm ("do_app_cases_err", SIMP_CONV (srw_ss()++COND_elim_ss) [LET_THM, case_eq_thms] THENC ALL_CONV)); -Theorem do_app_Rval_swap - `do_app op a (s1:('a,'b) bvlSem$state) = Rval (x0,x1) /\ op <> Install /\ +Theorem do_app_Rval_swap: + do_app op a (s1:('a,'b) bvlSem$state) = Rval (x0,x1) /\ op <> Install /\ (domain s1.code) SUBSET (domain t1.code) ==> do_app op a ((t1:('c,'d) bvlSem$state) with @@ -62,20 +68,23 @@ Theorem do_app_Rval_swap clock := s1.clock; ffi := s1.ffi |>) = Rval (x0,t1 with <| globals := x1.globals; refs := x1.refs; - clock := x1.clock; ffi := x1.ffi |>)` - (rw[do_app_cases_val] \\ rfs[SUBSET_DEF] \\ fs [] - \\ strip_tac \\ res_tac \\ fs []); - -Theorem do_app_with_code - `bvlSem$do_app op vs s = Rval (r,s') /\ op <> Install ⇒ + clock := x1.clock; ffi := x1.ffi |>) +Proof + rw[do_app_cases_val] \\ rfs[SUBSET_DEF] \\ fs [] + \\ strip_tac \\ res_tac \\ fs [] +QED + +Theorem do_app_with_code: + bvlSem$do_app op vs s = Rval (r,s') /\ op <> Install ⇒ domain s.code ⊆ domain c ⇒ do_app op vs (s with <| code := c ; compile := cc ; compile_oracle := co |>) = Rval (r,s' with <| code := c ; compile := cc - ; compile_oracle := co |>) ` - (rpt strip_tac + ; compile_oracle := co |>) +Proof + rpt strip_tac \\ qmatch_goalsub_abbrev_tac `do_app _ _ s4` \\ drule (do_app_Rval_swap |> INST_TYPE [delta|->beta,gamma|->alpha] |> GEN_ALL) \\ disch_then (qspec_then `s4` mp_tac) @@ -83,7 +92,8 @@ Theorem do_app_with_code \\ qmatch_goalsub_abbrev_tac `do_app _ _ s1 = Rval (_,s2) ==> do_app _ _ t1 = Rval (_,t2)` \\ qsuff_tac `t1 = s1 /\ t2 = s2` \\ rw [] - \\ unabbrev_all_tac \\ fs [state_component_equality]); + \\ unabbrev_all_tac \\ fs [state_component_equality] +QED val do_app_Rerr_swap = time store_thm("do_app_Rerr_swap", ``do_app op a (s1:('a,'b) bvlSem$state) = Rerr e /\ op <> Install /\ @@ -95,20 +105,23 @@ val do_app_Rerr_swap = time store_thm("do_app_Rerr_swap", Cases_on `op` \\ rw[do_app_cases_err] \\ rfs[SUBSET_DEF] \\ fs [] \\ strip_tac \\ res_tac \\ fs []); -Theorem do_app_with_code_err_not_Install - `bvlSem$do_app op vs s = Rerr e /\ op <> Install ⇒ +Theorem do_app_with_code_err_not_Install: + bvlSem$do_app op vs s = Rerr e /\ op <> Install ⇒ (domain c ⊆ domain s.code ∨ e ≠ Rabort Rtype_error) ⇒ do_app op vs (s with <| code := c ; compile := cc - ; compile_oracle := co |>) = Rerr e` - (rw [Once do_app_cases_err] >> rw [do_app_def] >> fs [SUBSET_DEF] >> - fs [do_install_def,case_eq_thms,UNCURRY]); - -Theorem do_app_with_code_err - `bvlSem$do_app op vs s = Rerr e ⇒ + ; compile_oracle := co |>) = Rerr e +Proof + rw [Once do_app_cases_err] >> rw [do_app_def] >> fs [SUBSET_DEF] >> + fs [do_install_def,case_eq_thms,UNCURRY] +QED + +Theorem do_app_with_code_err: + bvlSem$do_app op vs s = Rerr e ⇒ (domain c = domain s.code ∨ e ≠ Rabort Rtype_error) ⇒ - do_app op vs (s with code := c) = Rerr e` - (rw [Once do_app_cases_err] >> rw [do_app_def] >> fs [SUBSET_DEF] >> + do_app op vs (s with code := c) = Rerr e +Proof + rw [Once do_app_cases_err] >> rw [do_app_def] >> fs [SUBSET_DEF] >> fs [do_install_def,case_eq_thms,UNCURRY] >> rveq \\ fs [PULL_EXISTS] \\ CCONTR_TAC \\ fs [] @@ -117,33 +130,45 @@ Theorem do_app_with_code_err \\ Cases_on `s.compile (FST (s.compile_oracle 0)) args` \\ fs [] \\ PairCases_on `x` \\ fs [] \\ Cases_on `v6` \\ fs [] - \\ rveq \\ fs [] \\ rfs []); + \\ rveq \\ fs [] \\ rfs [] +QED -Theorem initial_state_simp[simp] - `(initial_state f c co cc k).code = c ∧ +Theorem initial_state_simp[simp]: + (initial_state f c co cc k).code = c ∧ (initial_state f c co cc k).ffi = f ∧ (initial_state f c co cc k).clock = k ∧ (initial_state f c co cc k).compile = cc ∧ (initial_state f c co cc k).compile_oracle = co ∧ (initial_state f c co cc k).refs = FEMPTY ∧ - (initial_state f c co cc k).globals = []` - (srw_tac[][initial_state_def]); - -Theorem initial_state_with_simp[simp] - `initial_state f c co cc k with clock := k1 = initial_state f c co cc k1 ∧ - initial_state f c co cc k with code := c1 = initial_state f c1 co cc k` - (EVAL_TAC); - -Theorem bool_to_tag_11[simp] - `bool_to_tag b1 = bool_to_tag b2 ⇔ (b1 = b2)` - (srw_tac[][bool_to_tag_def] >> EVAL_TAC >> simp[]) - -Theorem Boolv_11[simp] `bvlSem$Boolv b1 = Boolv b2 ⇔ b1 = b2` (EVAL_TAC>>srw_tac[][]); - -Theorem find_code_EVERY_IMP - `(find_code dest a (r:('c,'ffi) bvlSem$state).code = SOME (q,t)) ==> - EVERY P a ==> EVERY P q` - (Cases_on `dest` \\ full_simp_tac(srw_ss())[find_code_def] \\ REPEAT STRIP_TAC + (initial_state f c co cc k).globals = [] +Proof + srw_tac[][initial_state_def] +QED + +Theorem initial_state_with_simp[simp]: + initial_state f c co cc k with clock := k1 = initial_state f c co cc k1 ∧ + initial_state f c co cc k with code := c1 = initial_state f c1 co cc k +Proof + EVAL_TAC +QED + +Theorem bool_to_tag_11[simp]: + bool_to_tag b1 = bool_to_tag b2 ⇔ (b1 = b2) +Proof + srw_tac[][bool_to_tag_def] >> EVAL_TAC >> simp[] +QED + +Theorem Boolv_11[simp]: + bvlSem$Boolv b1 = Boolv b2 ⇔ b1 = b2 +Proof +EVAL_TAC>>srw_tac[][] +QED + +Theorem find_code_EVERY_IMP: + (find_code dest a (r:('c,'ffi) bvlSem$state).code = SOME (q,t)) ==> + EVERY P a ==> EVERY P q +Proof + Cases_on `dest` \\ full_simp_tac(srw_ss())[find_code_def] \\ REPEAT STRIP_TAC \\ BasicProvers.EVERY_CASE_TAC \\ SRW_TAC [] [] \\ full_simp_tac(srw_ss())[] \\ BasicProvers.EVERY_CASE_TAC \\ SRW_TAC [] [] \\ full_simp_tac(srw_ss())[] \\ `?x1 l1. a = SNOC x1 l1` by METIS_TAC [SNOC_CASES] \\ full_simp_tac(srw_ss())[] @@ -151,14 +176,17 @@ Theorem find_code_EVERY_IMP \\ BasicProvers.EVERY_CASE_TAC \\ SRW_TAC [] [] \\ full_simp_tac(srw_ss())[] \\ BasicProvers.EVERY_CASE_TAC \\ SRW_TAC [] [] \\ full_simp_tac(srw_ss())[] \\ BasicProvers.EVERY_CASE_TAC \\ SRW_TAC [] [] \\ full_simp_tac(srw_ss())[] - \\ FULL_SIMP_TAC std_ss [GSYM SNOC_APPEND,FRONT_SNOC]); + \\ FULL_SIMP_TAC std_ss [GSYM SNOC_APPEND,FRONT_SNOC] +QED -Theorem do_app_err - `do_app op vs s = Rerr e ⇒ (e = Rabort Rtype_error) +Theorem do_app_err: + do_app op vs s = Rerr e ⇒ (e = Rabort Rtype_error) \/ - (?i x. op = FFI i /\ e = Rabort (Rffi_error x)) ` - (rw [do_app_cases_err,do_install_def,UNCURRY] >> fs [] - \\ every_case_tac \\ fs []); + (?i x. op = FFI i /\ e = Rabort (Rffi_error x)) +Proof + rw [do_app_cases_err,do_install_def,UNCURRY] >> fs [] + \\ every_case_tac \\ fs [] +QED val evaluate_LENGTH = Q.prove( `!xs s env. (\(xs,s,env). @@ -174,35 +202,40 @@ val evaluate_LENGTH = Q.prove( val _ = save_thm("evaluate_LENGTH", evaluate_LENGTH); -Theorem evaluate_IMP_LENGTH - `(evaluate (xs,s,env) = (Rval res,s1)) ==> (LENGTH xs = LENGTH res)` - (REPEAT STRIP_TAC \\ MP_TAC (SPEC_ALL evaluate_LENGTH) \\ full_simp_tac(srw_ss())[]); +Theorem evaluate_IMP_LENGTH: + (evaluate (xs,s,env) = (Rval res,s1)) ==> (LENGTH xs = LENGTH res) +Proof + REPEAT STRIP_TAC \\ MP_TAC (SPEC_ALL evaluate_LENGTH) \\ full_simp_tac(srw_ss())[] +QED -Theorem evaluate_CONS - `evaluate (x::xs,env,s) = +Theorem evaluate_CONS: + evaluate (x::xs,env,s) = case evaluate ([x],env,s) of | (Rval v,s2) => (case evaluate (xs,env,s2) of | (Rval vs,s1) => (Rval (HD v::vs),s1) | t => t) - | t => t` - (Cases_on `xs` \\ full_simp_tac(srw_ss())[evaluate_def] + | t => t +Proof + Cases_on `xs` \\ full_simp_tac(srw_ss())[evaluate_def] \\ Cases_on `evaluate ([x],env,s)` \\ full_simp_tac(srw_ss())[evaluate_def] \\ Cases_on `q` \\ full_simp_tac(srw_ss())[evaluate_def] \\ IMP_RES_TAC evaluate_IMP_LENGTH \\ Cases_on `a` \\ full_simp_tac(srw_ss())[] - \\ Cases_on `t` \\ full_simp_tac(srw_ss())[]); + \\ Cases_on `t` \\ full_simp_tac(srw_ss())[] +QED -Theorem evaluate_SNOC - `!xs env s x. +Theorem evaluate_SNOC: + !xs env s x. evaluate (SNOC x xs,env,s) = case evaluate (xs,env,s) of | (Rval vs,s2) => (case evaluate ([x],env,s2) of | (Rval v,s1) => (Rval (vs ++ v),s1) | t => t) - | t => t` - (Induct THEN1 + | t => t +Proof + Induct THEN1 (full_simp_tac(srw_ss())[SNOC_APPEND,evaluate_def] \\ REPEAT STRIP_TAC \\ Cases_on `evaluate ([x],env,s)` \\ Cases_on `q` \\ full_simp_tac(srw_ss())[]) \\ full_simp_tac(srw_ss())[SNOC_APPEND,APPEND] @@ -213,35 +246,41 @@ Theorem evaluate_SNOC \\ Cases_on `evaluate ([x],env,r')` \\ Cases_on `q` \\ full_simp_tac(srw_ss())[evaluate_def] \\ IMP_RES_TAC evaluate_IMP_LENGTH \\ Cases_on `a''` \\ full_simp_tac(srw_ss())[LENGTH] - \\ REV_FULL_SIMP_TAC std_ss [LENGTH_NIL] \\ full_simp_tac(srw_ss())[]); + \\ REV_FULL_SIMP_TAC std_ss [LENGTH_NIL] \\ full_simp_tac(srw_ss())[] +QED -Theorem evaluate_APPEND - `!xs env s ys. +Theorem evaluate_APPEND: + !xs env s ys. evaluate (xs ++ ys,env,s) = case evaluate (xs,env,s) of (Rval vs,s2) => (case evaluate (ys,env,s2) of (Rval ws,s1) => (Rval (vs ++ ws),s1) | res => res) - | res => res` - (Induct \\ full_simp_tac(srw_ss())[APPEND,evaluate_def] \\ REPEAT STRIP_TAC + | res => res +Proof + Induct \\ full_simp_tac(srw_ss())[APPEND,evaluate_def] \\ REPEAT STRIP_TAC THEN1 REPEAT BasicProvers.CASE_TAC \\ ONCE_REWRITE_TAC [evaluate_CONS] - \\ REPEAT BasicProvers.CASE_TAC \\ full_simp_tac(srw_ss())[]); - -Theorem evaluate_SING - `(evaluate ([x],env,s) = (Rval a,p1)) ==> ?d1. a = [d1]` - (REPEAT STRIP_TAC \\ IMP_RES_TAC evaluate_IMP_LENGTH - \\ Cases_on `a` \\ full_simp_tac(srw_ss())[LENGTH_NIL]); - -Theorem evaluate_code - `!xs env s1 vs s2. + \\ REPEAT BasicProvers.CASE_TAC \\ full_simp_tac(srw_ss())[] +QED + +Theorem evaluate_SING: + (evaluate ([x],env,s) = (Rval a,p1)) ==> ?d1. a = [d1] +Proof + REPEAT STRIP_TAC \\ IMP_RES_TAC evaluate_IMP_LENGTH + \\ Cases_on `a` \\ full_simp_tac(srw_ss())[LENGTH_NIL] +QED + +Theorem evaluate_code: + !xs env s1 vs s2. (evaluate (xs,env,s1) = (vs,s2)) ==> ∃n. s2.compile_oracle = shift_seq n s1.compile_oracle ∧ s2.code = FOLDL union s1.code (MAP (fromAList o SND) - (GENLIST s1.compile_oracle n))` - (recInduct evaluate_ind \\ rw [] + (GENLIST s1.compile_oracle n)) +Proof + recInduct evaluate_ind \\ rw [] \\ pop_assum (mp_tac o SIMP_RULE std_ss[evaluate_def]) THEN1 (rw [] \\ qexists_tac `0` \\ fs [shift_seq_def,FUN_EQ_THM]) @@ -302,47 +341,57 @@ Theorem evaluate_code \\ qexists_tac `n'+n` \\ rewrite_tac [GENLIST_APPEND,FOLDL_APPEND,MAP_APPEND] \\ fs [dec_clock_def,shift_seq_def,FUN_EQ_THM] - \\ simp_tac std_ss [Once ADD_COMM] \\ fs []) + \\ simp_tac std_ss [Once ADD_COMM] \\ fs [] +QED -Theorem evaluate_mono - `!xs env s1 vs s2. +Theorem evaluate_mono: + !xs env s1 vs s2. (evaluate (xs,env,s1) = (vs,s2)) ==> - subspt s1.code s2.code` - (rw[] \\ imp_res_tac evaluate_code - \\ rw[] \\ metis_tac[subspt_FOLDL_union]); - -Theorem evaluate_mk_tick - `!exp env s n. + subspt s1.code s2.code +Proof + rw[] \\ imp_res_tac evaluate_code + \\ rw[] \\ metis_tac[subspt_FOLDL_union] +QED + +Theorem evaluate_mk_tick: + !exp env s n. evaluate ([mk_tick n exp], env, s) = if s.clock < n then (Rerr(Rabort Rtimeout_error), s with clock := 0) else - evaluate ([exp], env, dec_clock n s)` - (Induct_on `n` >> + evaluate ([exp], env, dec_clock n s) +Proof + Induct_on `n` >> srw_tac[][mk_tick_def, evaluate_def, dec_clock_def, FUNPOW] >> full_simp_tac(srw_ss())[mk_tick_def, evaluate_def, dec_clock_def] >> srw_tac[][] >> full_simp_tac (srw_ss()++ARITH_ss) [dec_clock_def, ADD1] >- (`s.clock = n` by decide_tac >> - full_simp_tac(srw_ss())[])); + full_simp_tac(srw_ss())[]) +QED -Theorem evaluate_MAP_Const - `!exps. +Theorem evaluate_MAP_Const: + !exps. evaluate (MAP (K (Op (Const i) [])) (exps:'a list),env,t1) = - (Rval (MAP (K (Number i)) exps),t1)` - (Induct \\ full_simp_tac(srw_ss())[evaluate_def,evaluate_CONS,do_app_def]); + (Rval (MAP (K (Number i)) exps),t1) +Proof + Induct \\ full_simp_tac(srw_ss())[evaluate_def,evaluate_CONS,do_app_def] +QED -Theorem evaluate_Bool[simp] - `evaluate ([Bool b],env,s) = (Rval [Boolv b],s)` - (EVAL_TAC) +Theorem evaluate_Bool[simp]: + evaluate ([Bool b],env,s) = (Rval [Boolv b],s) +Proof + EVAL_TAC +QED fun split_tac q = Cases_on q \\ Cases_on `q` \\ FULL_SIMP_TAC (srw_ss()) [] -Theorem evaluate_expand_env - `!xs a s env. +Theorem evaluate_expand_env: + !xs a s env. FST (evaluate (xs,a,s)) <> Rerr(Rabort Rtype_error) ==> - (evaluate (xs,a ++ env,s) = evaluate (xs,a,s))` - (recInduct evaluate_ind \\ REPEAT STRIP_TAC \\ POP_ASSUM MP_TAC + (evaluate (xs,a ++ env,s) = evaluate (xs,a,s)) +Proof + recInduct evaluate_ind \\ REPEAT STRIP_TAC \\ POP_ASSUM MP_TAC \\ ONCE_REWRITE_TAC [evaluate_def] \\ ASM_SIMP_TAC std_ss [] THEN1 (split_tac `evaluate ([x],env,s)` \\ split_tac `evaluate (y::xs,env,r)`) THEN1 (Cases_on `n < LENGTH env` \\ FULL_SIMP_TAC (srw_ss()) [] @@ -353,76 +402,102 @@ Theorem evaluate_expand_env THEN1 (split_tac `evaluate ([x1],env,s1)` \\ BasicProvers.CASE_TAC >> simp[]) THEN1 (split_tac `evaluate (xs,env,s)`) THEN1 (SRW_TAC [] []) - THEN1 (split_tac `evaluate (xs,env,s1)`)); + THEN1 (split_tac `evaluate (xs,env,s1)`) +QED val inc_clock_def = Define ` inc_clock ck s = s with clock := s.clock + ck`; -Theorem inc_clock_code - `!n ^s. (inc_clock n s).code = s.code` - (srw_tac[][inc_clock_def]); - -Theorem inc_clock_refs - `!n ^s. (inc_clock n s).refs = s.refs` - (srw_tac[][inc_clock_def]); - -Theorem inc_clock_ffi[simp] - `!n ^s. (inc_clock n s).ffi = s.ffi` - (srw_tac[][inc_clock_def]); - -Theorem inc_clock_clock[simp] - `!n ^s. (inc_clock n s).clock = s.clock + n` - (srw_tac[][inc_clock_def]); - -Theorem inc_clock0 - `!n ^s. inc_clock 0 s = s` - (simp [inc_clock_def, state_component_equality]); +Theorem inc_clock_code: + !n ^s. (inc_clock n s).code = s.code +Proof + srw_tac[][inc_clock_def] +QED + +Theorem inc_clock_refs: + !n ^s. (inc_clock n s).refs = s.refs +Proof + srw_tac[][inc_clock_def] +QED + +Theorem inc_clock_ffi[simp]: + !n ^s. (inc_clock n s).ffi = s.ffi +Proof + srw_tac[][inc_clock_def] +QED + +Theorem inc_clock_clock[simp]: + !n ^s. (inc_clock n s).clock = s.clock + n +Proof + srw_tac[][inc_clock_def] +QED + +Theorem inc_clock0: + !n ^s. inc_clock 0 s = s +Proof + simp [inc_clock_def, state_component_equality] +QED val _ = export_rewrites ["inc_clock_refs", "inc_clock_code", "inc_clock0"]; -Theorem inc_clock_add - `inc_clock k1 (inc_clock k2 s) = inc_clock (k1 + k2) s` - (simp[inc_clock_def,state_component_equality]); - -Theorem dec_clock_code - `!n ^s. (dec_clock n s).code = s.code` - (srw_tac[][dec_clock_def]); - -Theorem dec_clock_refs - `!n ^s. (dec_clock n s).refs = s.refs` - (srw_tac[][dec_clock_def]); - -Theorem dec_clock_ffi[simp] - `!n ^s. (dec_clock n s).ffi = s.ffi` - (srw_tac[][dec_clock_def]); - -Theorem dec_clock0 - `!n ^s. dec_clock 0 s = s` - (simp [dec_clock_def, state_component_equality]); +Theorem inc_clock_add: + inc_clock k1 (inc_clock k2 s) = inc_clock (k1 + k2) s +Proof + simp[inc_clock_def,state_component_equality] +QED + +Theorem dec_clock_code: + !n ^s. (dec_clock n s).code = s.code +Proof + srw_tac[][dec_clock_def] +QED + +Theorem dec_clock_refs: + !n ^s. (dec_clock n s).refs = s.refs +Proof + srw_tac[][dec_clock_def] +QED + +Theorem dec_clock_ffi[simp]: + !n ^s. (dec_clock n s).ffi = s.ffi +Proof + srw_tac[][dec_clock_def] +QED + +Theorem dec_clock0: + !n ^s. dec_clock 0 s = s +Proof + simp [dec_clock_def, state_component_equality] +QED val _ = export_rewrites ["dec_clock_refs", "dec_clock_code", "dec_clock0"]; -Theorem do_app_change_clock - `(do_app op args s1 = Rval (res,s2)) ==> - (do_app op args (s1 with clock := ck) = Rval (res,s2 with clock := ck))` - (rw [do_app_cases_val,UNCURRY,do_install_def] - \\ every_case_tac \\ fs []); - -Theorem do_app_change_clock_err - `(do_app op args s1 = Rerr e) ==> - (do_app op args (s1 with clock := ck) = Rerr e)` - (disch_then (strip_assume_tac o SIMP_RULE (srw_ss()) [do_app_cases_err]) +Theorem do_app_change_clock: + (do_app op args s1 = Rval (res,s2)) ==> + (do_app op args (s1 with clock := ck) = Rval (res,s2 with clock := ck)) +Proof + rw [do_app_cases_val,UNCURRY,do_install_def] + \\ every_case_tac \\ fs [] +QED + +Theorem do_app_change_clock_err: + (do_app op args s1 = Rerr e) ==> + (do_app op args (s1 with clock := ck) = Rerr e) +Proof + disch_then (strip_assume_tac o SIMP_RULE (srw_ss()) [do_app_cases_err]) \\ rveq \\ asm_simp_tac (srw_ss()) [do_app_def] \\ fs [] \\ every_case_tac \\ fs [] \\ rveq \\ fs [] - \\ fs [do_install_def,UNCURRY] \\ every_case_tac \\ fs [] \\ rw [] \\ fs []); + \\ fs [do_install_def,UNCURRY] \\ every_case_tac \\ fs [] \\ rw [] \\ fs [] +QED -Theorem evaluate_add_clock - `!exps env s1 res s2. +Theorem evaluate_add_clock: + !exps env s1 res s2. evaluate (exps,env,s1) = (res, s2) ∧ res ≠ Rerr(Rabort Rtimeout_error) ⇒ - !ck. evaluate (exps,env,inc_clock ck s1) = (res, inc_clock ck s2)` - (recInduct evaluate_ind >> + !ck. evaluate (exps,env,inc_clock ck s1) = (res, inc_clock ck s2) +Proof + recInduct evaluate_ind >> srw_tac[][evaluate_def] >- (Cases_on `evaluate ([x], env,s)` >> full_simp_tac(srw_ss())[] >> Cases_on `q` >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> @@ -469,38 +544,49 @@ Theorem evaluate_add_clock srw_tac[][] >- decide_tac >> `r.clock + ck - (ticks + 1) = r.clock - (ticks + 1) + ck` by srw_tac [ARITH_ss] [ADD1] >> - metis_tac [])); + metis_tac []) +QED -Theorem evaluate_add_clock_initial_state - `evaluate (es,env,initial_state ffi code co cc k) = (r,s') ∧ +Theorem evaluate_add_clock_initial_state: + evaluate (es,env,initial_state ffi code co cc k) = (r,s') ∧ r ≠ Rerr (Rabort Rtimeout_error) ⇒ ∀extra. evaluate (es,env,initial_state ffi code co cc (k + extra)) = - (r,s' with clock := s'.clock + extra)` - (rpt strip_tac + (r,s' with clock := s'.clock + extra) +Proof + rpt strip_tac \\ drule (GEN_ALL evaluate_add_clock) \\ fs [] - \\ fs [bvlSemTheory.initial_state_def,inc_clock_def]); - -Theorem do_app_io_events_mono - `do_app op vs s1 = Rval (x,s2) ⇒ - s1.ffi.io_events ≼ s2.ffi.io_events` - (rw [do_app_cases_val] >> + \\ fs [bvlSemTheory.initial_state_def,inc_clock_def] +QED + +Theorem do_app_io_events_mono: + do_app op vs s1 = Rval (x,s2) ⇒ + s1.ffi.io_events ≼ s2.ffi.io_events +Proof + rw [do_app_cases_val] >> fs[ffiTheory.call_FFI_def,case_eq_thms] >> every_case_tac \\ fs[] \\ rw[] \\ rfs[do_install_def,UNCURRY] >> - every_case_tac \\ fs[] \\ rw[] \\ rfs[do_install_def,UNCURRY]); + every_case_tac \\ fs[] \\ rw[] \\ rfs[do_install_def,UNCURRY] +QED -Theorem evaluate_io_events_mono - `!exps env s1 res s2. +Theorem evaluate_io_events_mono: + !exps env s1 res s2. evaluate (exps,env,s1) = (res, s2) ⇒ - s1.ffi.io_events ≼ s2.ffi.io_events` - (recInduct evaluate_ind >> + s1.ffi.io_events ≼ s2.ffi.io_events +Proof + recInduct evaluate_ind >> srw_tac[][evaluate_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> rev_full_simp_tac(srw_ss())[] >> - metis_tac[IS_PREFIX_TRANS,do_app_io_events_mono]) + metis_tac[IS_PREFIX_TRANS,do_app_io_events_mono] +QED -Theorem Boolv_11[simp] `bvlSem$Boolv b1 = Boolv b2 ⇔ b1 = b2` (EVAL_TAC>>srw_tac[][]); +Theorem Boolv_11[simp]: + bvlSem$Boolv b1 = Boolv b2 ⇔ b1 = b2 +Proof +EVAL_TAC>>srw_tac[][] +QED val do_app_inc_clock = Q.prove( `do_app op vs (inc_clock x y) = @@ -522,11 +608,12 @@ val dec_clock_inc_clock = Q.prove( `¬(s.clock < n) ⇒ dec_clock n (inc_clock x s) = inc_clock x (dec_clock n s)`, simp[state_component_equality,inc_clock_def,dec_clock_def]) -Theorem evaluate_add_to_clock_io_events_mono - `∀exps env s extra. +Theorem evaluate_add_to_clock_io_events_mono: + ∀exps env s extra. (SND(evaluate(exps,env,s))).ffi.io_events ≼ - (SND(evaluate(exps,env,inc_clock extra s))).ffi.io_events` - (recInduct evaluate_ind >> + (SND(evaluate(exps,env,inc_clock extra s))).ffi.io_events +Proof + recInduct evaluate_ind >> srw_tac[][evaluate_def] >> TRY ( rename1`Boolv T` >> @@ -542,7 +629,8 @@ Theorem evaluate_add_to_clock_io_events_mono TRY(fsrw_tac[ARITH_ss][] >>NO_TAC) >> full_simp_tac(srw_ss())[dec_clock_inc_clock] >> metis_tac[evaluate_io_events_mono,SND,IS_PREFIX_TRANS,Boolv_11,PAIR, - inc_clock_ffi,dec_clock_ffi]); + inc_clock_ffi,dec_clock_ffi] +QED val take_drop_lem = Q.prove ( `!skip env. @@ -564,13 +652,14 @@ val take_drop_lem = Q.prove ( srw_tac[][EL_DROP] >> srw_tac [ARITH_ss] []); -Theorem evaluate_genlist_vars - `!skip env n st. +Theorem evaluate_genlist_vars: + !skip env n st. n + skip ≤ LENGTH env ⇒ evaluate (GENLIST (λarg. Var (arg + skip)) n, env, st) = - (Rval (TAKE n (DROP skip env)), st)` - (Induct_on `n` >> + (Rval (TAKE n (DROP skip env)), st) +Proof + Induct_on `n` >> srw_tac[][evaluate_def, DROP_LENGTH_NIL, GSYM ADD1] >> srw_tac[][Once GENLIST_CONS] >> srw_tac[][Once evaluate_CONS, evaluate_def] >> @@ -588,14 +677,16 @@ Theorem evaluate_genlist_vars by (Cases_on `DROP skip env` >> full_simp_tac(srw_ss())[] >> decide_tac) >> - metis_tac [take_drop_lem]); + metis_tac [take_drop_lem] +QED -Theorem evaluate_var_reverse - `!xs env ys (st:('c,'ffi) bvlSem$state). +Theorem evaluate_var_reverse: + !xs env ys (st:('c,'ffi) bvlSem$state). evaluate (MAP Var xs, env, st) = (Rval ys, st) ⇒ - evaluate (REVERSE (MAP Var xs), env, st) = (Rval (REVERSE ys), st)` - (Induct_on `xs` >> + evaluate (REVERSE (MAP Var xs), env, st) = (Rval (REVERSE ys), st) +Proof + Induct_on `xs` >> srw_tac[][evaluate_def] >> full_simp_tac(srw_ss())[evaluate_APPEND] >> pop_assum (mp_tac o SIMP_RULE (srw_ss()) [Once evaluate_CONS]) >> @@ -605,26 +696,31 @@ Theorem evaluate_var_reverse BasicProvers.EVERY_CASE_TAC >> srw_tac[][] >> res_tac >> - full_simp_tac(srw_ss())[]); + full_simp_tac(srw_ss())[] +QED -Theorem evaluate_genlist_vars_rev - `!skip env n st. +Theorem evaluate_genlist_vars_rev: + !skip env n st. n + skip ≤ LENGTH env ⇒ evaluate (REVERSE (GENLIST (λarg. Var (arg + skip)) n), env, st) = - (Rval (REVERSE (TAKE n (DROP skip env))), st)` - (srw_tac[][] >> + (Rval (REVERSE (TAKE n (DROP skip env))), st) +Proof + srw_tac[][] >> imp_res_tac evaluate_genlist_vars >> pop_assum (qspec_then `st` assume_tac) >> `GENLIST (λarg. Var (arg + skip):bvl$exp) n = MAP Var (GENLIST (\arg. arg + skip) n)` by srw_tac[][MAP_GENLIST, combinTheory.o_DEF] >> full_simp_tac(srw_ss())[] >> - metis_tac [evaluate_var_reverse]); + metis_tac [evaluate_var_reverse] +QED -Theorem do_app_refs_SUBSET - `(do_app op a r = Rval (q,t)) ==> FDOM r.refs SUBSET FDOM t.refs` - (rw [do_app_cases_val] >> +Theorem do_app_refs_SUBSET: + (do_app op a r = Rval (q,t)) ==> FDOM r.refs SUBSET FDOM t.refs +Proof + rw [do_app_cases_val] >> fs [SUBSET_DEF,IN_INSERT,dec_clock_def,do_install_def] >> - fs [UNCURRY] >> every_case_tac >> fs [] \\ rw [] \\ fs []); + fs [UNCURRY] >> every_case_tac >> fs [] \\ rw [] \\ fs [] +QED val evaluate_refs_SUBSET_lemma = Q.prove( `!xs env s. FDOM s.refs SUBSET FDOM (SND (evaluate (xs,env,s))).refs`, @@ -635,9 +731,11 @@ val evaluate_refs_SUBSET_lemma = Q.prove( \\ full_simp_tac(srw_ss())[dec_clock_def] \\ full_simp_tac(srw_ss())[] \\ IMP_RES_TAC do_app_refs_SUBSET \\ full_simp_tac(srw_ss())[SUBSET_DEF]); -Theorem evaluate_refs_SUBSET - `(evaluate (xs,env,s) = (res,t)) ==> FDOM s.refs SUBSET FDOM t.refs` - (REPEAT STRIP_TAC \\ MP_TAC (SPEC_ALL evaluate_refs_SUBSET_lemma) \\ full_simp_tac(srw_ss())[]); +Theorem evaluate_refs_SUBSET: + (evaluate (xs,env,s) = (res,t)) ==> FDOM s.refs SUBSET FDOM t.refs +Proof + REPEAT STRIP_TAC \\ MP_TAC (SPEC_ALL evaluate_refs_SUBSET_lemma) \\ full_simp_tac(srw_ss())[] +QED val get_vars_def = Define ` (get_vars [] env = SOME []) /\ @@ -654,16 +752,18 @@ val isVar_def = Define ` val destVar_def = Define ` (destVar ((Var n):bvl$exp) = n)`; -Theorem evaluate_Var_list - `!l. EVERY isVar l ==> +Theorem evaluate_Var_list: + !l. EVERY isVar l ==> (evaluate (l,env,s) = (Rerr(Rabort Rtype_error),s)) \/ ?vs. (evaluate (l,env,s) = (Rval vs,s)) /\ (get_vars (MAP destVar l) env = SOME vs) /\ - (LENGTH vs = LENGTH l)` - (Induct \\ full_simp_tac(srw_ss())[evaluate_def,get_vars_def] \\ Cases \\ full_simp_tac(srw_ss())[isVar_def] + (LENGTH vs = LENGTH l) +Proof + Induct \\ full_simp_tac(srw_ss())[evaluate_def,get_vars_def] \\ Cases \\ full_simp_tac(srw_ss())[isVar_def] \\ ONCE_REWRITE_TAC [evaluate_CONS] \\ full_simp_tac(srw_ss())[evaluate_def] \\ Cases_on `n < LENGTH env` \\ full_simp_tac(srw_ss())[] - \\ REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[destVar_def]); + \\ REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[destVar_def] +QED val bVarBound_def = tDefine "bVarBound" ` (bVarBound n [] <=> T) /\ @@ -705,15 +805,19 @@ val bEvery_def = tDefine "bEvery" ` val _ = export_rewrites["bEvery_def","bVarBound_def"]; -Theorem bVarBound_EVERY - `∀ls. bVarBound P ls ⇔ EVERY (λe. bVarBound P [e]) ls` - (Induct >> simp[] >> Cases >> simp[] >> - Cases_on`ls`>>simp[]); +Theorem bVarBound_EVERY: + ∀ls. bVarBound P ls ⇔ EVERY (λe. bVarBound P [e]) ls +Proof + Induct >> simp[] >> Cases >> simp[] >> + Cases_on`ls`>>simp[] +QED -Theorem bEvery_EVERY - `∀ls. bEvery P ls ⇔ EVERY (λe. bEvery P [e]) ls` - (Induct >> simp[] >> Cases >> simp[] >> - Cases_on`ls`>>simp[]); +Theorem bEvery_EVERY: + ∀ls. bEvery P ls ⇔ EVERY (λe. bEvery P [e]) ls +Proof + Induct >> simp[] >> Cases >> simp[] >> + Cases_on`ls`>>simp[] +QED val get_code_labels_def = tDefine"get_code_labels" `(get_code_labels (bvl$Var _) = {}) ∧ @@ -732,8 +836,10 @@ val get_code_labels_def = tDefine"get_code_labels" \\ simp[] \\ res_tac \\ simp[]); val get_code_labels_def = get_code_labels_def |> SIMP_RULE (srw_ss()++ETA_ss)[] |> curry save_thm "get_code_labels_def[simp,compute]" -Theorem mk_tick_code_labels[simp] - `!n x. get_code_labels (mk_tick n x) = get_code_labels x` - (Induct \\ rw [] \\ fs [bvlTheory.mk_tick_def, FUNPOW_SUC]); +Theorem mk_tick_code_labels[simp]: + !n x. get_code_labels (mk_tick n x) = get_code_labels x +Proof + Induct \\ rw [] \\ fs [bvlTheory.mk_tick_def, FUNPOW_SUC] +QED val _ = export_theory(); diff --git a/compiler/backend/semantics/bvlSemScript.sml b/compiler/backend/semantics/bvlSemScript.sml index ffdb32455c..9fa4a966f4 100644 --- a/compiler/backend/semantics/bvlSemScript.sml +++ b/compiler/backend/semantics/bvlSemScript.sml @@ -477,39 +477,49 @@ val case_eq_thms = LIST_CONJ (pair_case_eq::bool_case_eq::(List.map prove_case_e ffi_result_thms])) |> curry save_thm"case_eq_thms"; -Theorem do_app_const - `(bvlSem$do_app op args s1 = Rval (res,s2)) ==> +Theorem do_app_const: + (bvlSem$do_app op args s1 = Rval (res,s2)) ==> (s2.clock = s1.clock) /\ (op <> Install ==> s2.code = s1.code /\ s2.compile = s1.compile /\ - s2.compile_oracle = s1.compile_oracle)` - (rw[do_app_def,case_eq_thms,PULL_EXISTS,do_install_def,UNCURRY] \\ rw[]); + s2.compile_oracle = s1.compile_oracle) +Proof + rw[do_app_def,case_eq_thms,PULL_EXISTS,do_install_def,UNCURRY] \\ rw[] +QED -Theorem bvl_do_app_Ref[simp] - `do_app Ref vs s = Rval +Theorem bvl_do_app_Ref[simp]: + do_app Ref vs s = Rval (RefPtr (LEAST ptr. ptr ∉ FDOM s.refs), s with refs := - s.refs |+ ((LEAST ptr. ptr ∉ FDOM s.refs),ValueArray vs))` - (fs [do_app_def,LET_THM] \\ every_case_tac \\ fs []); - -Theorem bvl_do_app_Cons[simp] - `do_app (Cons tag) vs s = Rval (Block tag vs,s)` - (fs [do_app_def,LET_THM] \\ every_case_tac \\ fs []); - -Theorem evaluate_clock - `!xs env s1 vs s2. - (evaluate (xs,env,s1) = (vs,s2)) ==> s2.clock <= s1.clock` - (recInduct evaluate_ind >> rw[evaluate_def] >> + s.refs |+ ((LEAST ptr. ptr ∉ FDOM s.refs),ValueArray vs)) +Proof + fs [do_app_def,LET_THM] \\ every_case_tac \\ fs [] +QED + +Theorem bvl_do_app_Cons[simp]: + do_app (Cons tag) vs s = Rval (Block tag vs,s) +Proof + fs [do_app_def,LET_THM] \\ every_case_tac \\ fs [] +QED + +Theorem evaluate_clock: + !xs env s1 vs s2. + (evaluate (xs,env,s1) = (vs,s2)) ==> s2.clock <= s1.clock +Proof + recInduct evaluate_ind >> rw[evaluate_def] >> every_case_tac >> full_simp_tac(srw_ss())[dec_clock_def] >> rw[] >> rfs[] >> imp_res_tac fix_clock_IMP >> fs[] >> - imp_res_tac do_app_const >> fs[]); + imp_res_tac do_app_const >> fs[] +QED -Theorem fix_clock_evaluate - `fix_clock s (evaluate (xs,env,s)) = evaluate (xs,env,s)` - (Cases_on `evaluate (xs,env,s)` \\ fs [fix_clock_def] +Theorem fix_clock_evaluate: + fix_clock s (evaluate (xs,env,s)) = evaluate (xs,env,s) +Proof + Cases_on `evaluate (xs,env,s)` \\ fs [fix_clock_def] \\ imp_res_tac evaluate_clock - \\ fs [MIN_DEF,theorem "state_component_equality"]); + \\ fs [MIN_DEF,theorem "state_component_equality"] +QED (* Finally, we remove fix_clock from the induction and definition theorems. *) diff --git a/compiler/backend/semantics/closPropsScript.sml b/compiler/backend/semantics/closPropsScript.sml index b91111c42f..3486f7075c 100644 --- a/compiler/backend/semantics/closPropsScript.sml +++ b/compiler/backend/semantics/closPropsScript.sml @@ -5,34 +5,45 @@ open preamble closLangTheory closSemTheory backendPropsTheory val _ = new_theory"closProps" -Theorem with_same_clock[simp] - `(s:('c,'ffi) closSem$state) with clock := s.clock = s` - (srw_tac[][closSemTheory.state_component_equality]) - -Theorem dec_clock_code - `(dec_clock x y).code = y.code` - (EVAL_TAC); - -Theorem dec_clock_ffi - `(dec_clock x y).ffi = y.ffi` - (EVAL_TAC); - -Theorem dec_clock_compile_oracle[simp] - `(closSem$dec_clock n s).compile_oracle = s.compile_oracle` - (EVAL_TAC); - -Theorem dec_clock_compile[simp] - `(closSem$dec_clock n s).compile = s.compile` - (EVAL_TAC); - -Theorem list_to_v_EVERY_APPEND - `!(x: closSem$v) y xs ys. +Theorem with_same_clock[simp]: + (s:('c,'ffi) closSem$state) with clock := s.clock = s +Proof + srw_tac[][closSemTheory.state_component_equality] +QED + +Theorem dec_clock_code: + (dec_clock x y).code = y.code +Proof + EVAL_TAC +QED + +Theorem dec_clock_ffi: + (dec_clock x y).ffi = y.ffi +Proof + EVAL_TAC +QED + +Theorem dec_clock_compile_oracle[simp]: + (closSem$dec_clock n s).compile_oracle = s.compile_oracle +Proof + EVAL_TAC +QED + +Theorem dec_clock_compile[simp]: + (closSem$dec_clock n s).compile = s.compile +Proof + EVAL_TAC +QED + +Theorem list_to_v_EVERY_APPEND: + !(x: closSem$v) y xs ys. v_to_list x = SOME xs /\ v_to_list y = SOME ys /\ (!t l. P (Block t l) <=> EVERY P l) /\ P x /\ P y ==> - P (list_to_v (xs ++ ys))` - (ho_match_mp_tac v_to_list_ind \\ rw [v_to_list_def, case_eq_thms] \\ fs [] + P (list_to_v (xs ++ ys)) +Proof + ho_match_mp_tac v_to_list_ind \\ rw [v_to_list_def, case_eq_thms] \\ fs [] >- (qpat_x_assum `v_to_list _ = _` mp_tac \\ pop_assum mp_tac @@ -42,7 +53,8 @@ Theorem list_to_v_EVERY_APPEND \\ fs [list_to_v_def]) \\ rfs [] \\ res_tac - \\ fs [list_to_v_def]) + \\ fs [list_to_v_def] +QED val ref_rel_def = Define` (ref_rel R (ValueArray vs) (ValueArray ws) ⇔ LIST_REL R vs ws) ∧ @@ -50,10 +62,12 @@ val ref_rel_def = Define` (ref_rel _ _ _ = F)` val _ = export_rewrites["ref_rel_def"]; -Theorem ref_rel_simp[simp] - `(ref_rel R (ValueArray vs) y ⇔ ∃ws. y = ValueArray ws ∧ LIST_REL R vs ws) ∧ - (ref_rel R (ByteArray f bs) y ⇔ y = ByteArray f bs)` - (Cases_on`y`>>simp[ref_rel_def] >> srw_tac[][EQ_IMP_THM]) +Theorem ref_rel_simp[simp]: + (ref_rel R (ValueArray vs) y ⇔ ∃ws. y = ValueArray ws ∧ LIST_REL R vs ws) ∧ + (ref_rel R (ByteArray f bs) y ⇔ y = ByteArray f bs) +Proof + Cases_on`y`>>simp[ref_rel_def] >> srw_tac[][EQ_IMP_THM] +QED val code_locs_def = tDefine "code_locs" ` (code_locs [] = []) /\ @@ -104,27 +118,35 @@ val code_locs_def = tDefine "code_locs" ` full_simp_tac(srw_ss())[exp_size_def] >> decide_tac); -Theorem code_locs_cons - `∀x xs. code_locs (x::xs) = code_locs [x] ++ code_locs xs` - (gen_tac >> Cases >> simp[code_locs_def]); +Theorem code_locs_cons: + ∀x xs. code_locs (x::xs) = code_locs [x] ++ code_locs xs +Proof + gen_tac >> Cases >> simp[code_locs_def] +QED -Theorem code_locs_append - `!l1 l2. code_locs (l1 ++ l2) = code_locs l1 ++ code_locs l2` - (Induct >> simp[code_locs_def] >> +Theorem code_locs_append: + !l1 l2. code_locs (l1 ++ l2) = code_locs l1 ++ code_locs l2 +Proof + Induct >> simp[code_locs_def] >> simp[Once code_locs_cons] >> - simp[Once code_locs_cons,SimpRHS]); - -Theorem code_locs_map - `!xs f. code_locs (MAP f xs) = FLAT (MAP (\x. code_locs [f x]) xs)` - (Induct \\ full_simp_tac(srw_ss())[code_locs_def] - \\ ONCE_REWRITE_TAC [code_locs_cons] \\ full_simp_tac(srw_ss())[code_locs_def]); - -Theorem BIGUNION_MAP_code_locs_SND_SND - `BIGUNION (set (MAP (set ∘ code_locs ∘ (λx. [SND (SND x)])) xs)) = - set (code_locs (MAP (SND o SND) xs))` - (Induct_on `xs` \\ fs [code_locs_def] + simp[Once code_locs_cons,SimpRHS] +QED + +Theorem code_locs_map: + !xs f. code_locs (MAP f xs) = FLAT (MAP (\x. code_locs [f x]) xs) +Proof + Induct \\ full_simp_tac(srw_ss())[code_locs_def] + \\ ONCE_REWRITE_TAC [code_locs_cons] \\ full_simp_tac(srw_ss())[code_locs_def] +QED + +Theorem BIGUNION_MAP_code_locs_SND_SND: + BIGUNION (set (MAP (set ∘ code_locs ∘ (λx. [SND (SND x)])) xs)) = + set (code_locs (MAP (SND o SND) xs)) +Proof + Induct_on `xs` \\ fs [code_locs_def] \\ once_rewrite_tac [code_locs_cons] - \\ fs [code_locs_def]); + \\ fs [code_locs_def] +QED val contains_App_SOME_def = tDefine "contains_App_SOME" ` (contains_App_SOME max_app [] ⇔ F) /\ @@ -167,10 +189,12 @@ val contains_App_SOME_def = tDefine "contains_App_SOME" ` full_simp_tac(srw_ss())[exp_size_def] >> decide_tac); -Theorem contains_App_SOME_EXISTS - `∀ls max_app. contains_App_SOME max_app ls ⇔ EXISTS (λx. contains_App_SOME max_app [x]) ls` - (Induct >> simp[contains_App_SOME_def] >> - Cases_on`ls`>>full_simp_tac(srw_ss())[contains_App_SOME_def]) +Theorem contains_App_SOME_EXISTS: + ∀ls max_app. contains_App_SOME max_app ls ⇔ EXISTS (λx. contains_App_SOME max_app [x]) ls +Proof + Induct >> simp[contains_App_SOME_def] >> + Cases_on`ls`>>full_simp_tac(srw_ss())[contains_App_SOME_def] +QED val every_Fn_SOME_def = tDefine "every_Fn_SOME" ` (every_Fn_SOME [] ⇔ T) ∧ @@ -215,14 +239,18 @@ val every_Fn_SOME_def = tDefine "every_Fn_SOME" ` decide_tac); val _ = export_rewrites["every_Fn_SOME_def"]; -Theorem every_Fn_SOME_EVERY - `∀ls. every_Fn_SOME ls ⇔ EVERY (λx. every_Fn_SOME [x]) ls` - (Induct >> simp[every_Fn_SOME_def] >> - Cases_on`ls`>>full_simp_tac(srw_ss())[every_Fn_SOME_def]) +Theorem every_Fn_SOME_EVERY: + ∀ls. every_Fn_SOME ls ⇔ EVERY (λx. every_Fn_SOME [x]) ls +Proof + Induct >> simp[every_Fn_SOME_def] >> + Cases_on`ls`>>full_simp_tac(srw_ss())[every_Fn_SOME_def] +QED -Theorem every_Fn_SOME_APPEND[simp] - `every_Fn_SOME (l1 ++ l2) ⇔ every_Fn_SOME l1 ∧ every_Fn_SOME l2` - (once_rewrite_tac[every_Fn_SOME_EVERY] \\ rw[]); +Theorem every_Fn_SOME_APPEND[simp]: + every_Fn_SOME (l1 ++ l2) ⇔ every_Fn_SOME l1 ∧ every_Fn_SOME l2 +Proof + once_rewrite_tac[every_Fn_SOME_EVERY] \\ rw[] +QED val every_Fn_vs_NONE_def = tDefine "every_Fn_vs_NONE" ` (every_Fn_vs_NONE [] ⇔ T) ∧ @@ -267,19 +295,25 @@ val every_Fn_vs_NONE_def = tDefine "every_Fn_vs_NONE" ` decide_tac); val _ = export_rewrites["every_Fn_vs_NONE_def"]; -Theorem every_Fn_vs_NONE_EVERY - `∀ls. every_Fn_vs_NONE ls ⇔ EVERY (λx. every_Fn_vs_NONE [x]) ls` - (Induct >> simp[every_Fn_vs_NONE_def] >> - Cases_on`ls`>>full_simp_tac(srw_ss())[every_Fn_vs_NONE_def]) - -Theorem IMP_every_Fn_vs_NONE_TAKE - `every_Fn_vs_NONE ls ⇒ every_Fn_vs_NONE (TAKE n ls)` - (once_rewrite_tac[every_Fn_vs_NONE_EVERY] - \\ Cases_on`n <= LENGTH ls` \\ simp[EVERY_TAKE, TAKE_LENGTH_TOO_LONG]); - -Theorem every_Fn_vs_NONE_APPEND[simp] - `every_Fn_vs_NONE (l1 ++ l2) ⇔ every_Fn_vs_NONE l1 ∧ every_Fn_vs_NONE l2` - (once_rewrite_tac[every_Fn_vs_NONE_EVERY] \\ rw[]); +Theorem every_Fn_vs_NONE_EVERY: + ∀ls. every_Fn_vs_NONE ls ⇔ EVERY (λx. every_Fn_vs_NONE [x]) ls +Proof + Induct >> simp[every_Fn_vs_NONE_def] >> + Cases_on`ls`>>full_simp_tac(srw_ss())[every_Fn_vs_NONE_def] +QED + +Theorem IMP_every_Fn_vs_NONE_TAKE: + every_Fn_vs_NONE ls ⇒ every_Fn_vs_NONE (TAKE n ls) +Proof + once_rewrite_tac[every_Fn_vs_NONE_EVERY] + \\ Cases_on`n <= LENGTH ls` \\ simp[EVERY_TAKE, TAKE_LENGTH_TOO_LONG] +QED + +Theorem every_Fn_vs_NONE_APPEND[simp]: + every_Fn_vs_NONE (l1 ++ l2) ⇔ every_Fn_vs_NONE l1 ∧ every_Fn_vs_NONE l2 +Proof + once_rewrite_tac[every_Fn_vs_NONE_EVERY] \\ rw[] +QED val every_Fn_vs_SOME_def = tDefine "every_Fn_vs_SOME" ` (every_Fn_vs_SOME [] ⇔ T) ∧ @@ -324,14 +358,18 @@ val every_Fn_vs_SOME_def = tDefine "every_Fn_vs_SOME" ` decide_tac); val _ = export_rewrites["every_Fn_vs_SOME_def"]; -Theorem every_Fn_vs_SOME_EVERY - `∀ls. every_Fn_vs_SOME ls ⇔ EVERY (λx. every_Fn_vs_SOME [x]) ls` - (Induct >> simp[every_Fn_vs_SOME_def] >> - Cases_on`ls`>>full_simp_tac(srw_ss())[every_Fn_vs_SOME_def]) +Theorem every_Fn_vs_SOME_EVERY: + ∀ls. every_Fn_vs_SOME ls ⇔ EVERY (λx. every_Fn_vs_SOME [x]) ls +Proof + Induct >> simp[every_Fn_vs_SOME_def] >> + Cases_on`ls`>>full_simp_tac(srw_ss())[every_Fn_vs_SOME_def] +QED -Theorem every_Fn_vs_SOME_APPEND[simp] - `every_Fn_vs_SOME (l1 ++ l2) ⇔ every_Fn_vs_SOME l1 ∧ every_Fn_vs_SOME l2` - (once_rewrite_tac[every_Fn_vs_SOME_EVERY] \\ rw[]); +Theorem every_Fn_vs_SOME_APPEND[simp]: + every_Fn_vs_SOME (l1 ++ l2) ⇔ every_Fn_vs_SOME l1 ∧ every_Fn_vs_SOME l2 +Proof + once_rewrite_tac[every_Fn_vs_SOME_EVERY] \\ rw[] +QED val fv_def = tDefine "fv" ` (fv n [] <=> F) /\ @@ -363,17 +401,22 @@ val fv_def = tDefine "fv" ` val fv_ind = theorem"fv_ind"; -Theorem fv_append[simp] - `∀v l1. fv v (l1 ++ l2) ⇔ fv v l1 ∨ fv v l2` - (ho_match_mp_tac fv_ind +Theorem fv_append[simp]: + ∀v l1. fv v (l1 ++ l2) ⇔ fv v l1 ∨ fv v l2 +Proof + ho_match_mp_tac fv_ind \\ rpt strip_tac \\ rw[fv_def] \\ fs[] \\ rw[EQ_IMP_THM] \\ rw[] - \\ Cases_on`l2`\\fs[fv_def]); + \\ Cases_on`l2`\\fs[fv_def] +QED -Theorem fv_nil[simp] - `fv v [] ⇔ F` (rw[fv_def]) +Theorem fv_nil[simp]: + fv v [] ⇔ F +Proof +rw[fv_def] +QED val fv1_def = Define`fv1 v e = fv v [e]`; val fv1_intro = save_thm("fv1_intro[simp]",GSYM fv1_def) @@ -381,27 +424,37 @@ val fv1_thm = fv_def |> SIMP_RULE (srw_ss())[] |> curry save_thm "fv1_thm" -Theorem fv_cons[simp] - `fv v (x::xs) ⇔ fv1 v x ∨ fv v xs` - (metis_tac[CONS_APPEND,fv_append,fv1_def]); - -Theorem fv_exists - `∀ls. fv v ls ⇔ EXISTS (fv1 v) ls` - (Induct \\ fs[] \\ rw[Once fv_cons]); - -Theorem fv_MAPi - `∀l x f. fv x (MAPi f l) ⇔ ∃n. n < LENGTH l ∧ fv x [f n (EL n l)]` - (Induct >> simp[fv_def] >> simp[] >> dsimp[indexedListsTheory.LT_SUC]); - -Theorem fv_GENLIST_Var - `∀n. fv v (GENLIST (Var tra) n) ⇔ v < n` - (Induct \\ simp[fv_def,GENLIST,SNOC_APPEND] - \\ rw[fv_def]); +Theorem fv_cons[simp]: + fv v (x::xs) ⇔ fv1 v x ∨ fv v xs +Proof + metis_tac[CONS_APPEND,fv_append,fv1_def] +QED + +Theorem fv_exists: + ∀ls. fv v ls ⇔ EXISTS (fv1 v) ls +Proof + Induct \\ fs[] \\ rw[Once fv_cons] +QED + +Theorem fv_MAPi: + ∀l x f. fv x (MAPi f l) ⇔ ∃n. n < LENGTH l ∧ fv x [f n (EL n l)] +Proof + Induct >> simp[fv_def] >> simp[] >> dsimp[indexedListsTheory.LT_SUC] +QED + +Theorem fv_GENLIST_Var: + ∀n. fv v (GENLIST (Var tra) n) ⇔ v < n +Proof + Induct \\ simp[fv_def,GENLIST,SNOC_APPEND] + \\ rw[fv_def] +QED -Theorem fv_REPLICATE[simp] - `fv n (REPLICATE m e) ⇔ 0 < m ∧ fv1 n e` - (Induct_on `m` >> simp[REPLICATE, fv_def,fv1_thm] >> - simp[] >> metis_tac[]); +Theorem fv_REPLICATE[simp]: + fv n (REPLICATE m e) ⇔ 0 < m ∧ fv1 n e +Proof + Induct_on `m` >> simp[REPLICATE, fv_def,fv1_thm] >> + simp[] >> metis_tac[] +QED val v_ind = TypeBase.induction_of``:closSem$v`` @@ -413,28 +466,36 @@ val v_ind = |> Q.GEN`P` |> curry save_thm "v_ind"; -Theorem do_app_err - `∀op ls s e. +Theorem do_app_err: + ∀op ls s e. do_app op ls s = Rerr e ⇒ - (op ≠ Equal ⇒ ∃a. e = Rabort a)` - (Cases >> + (op ≠ Equal ⇒ ∃a. e = Rabort a) +Proof + Cases >> srw_tac[][do_app_def,case_eq_thms] >> fs[case_eq_thms,bool_case_eq,pair_case_eq] >> rw[] - \\ every_case_tac \\ fs [] \\ rveq \\ fs []); + \\ every_case_tac \\ fs [] \\ rveq \\ fs [] +QED -Theorem Boolv_11[simp] `closSem$Boolv b1 = Boolv b2 ⇔ b1 = b2` (EVAL_TAC>>srw_tac[][]); +Theorem Boolv_11[simp]: + closSem$Boolv b1 = Boolv b2 ⇔ b1 = b2 +Proof +EVAL_TAC>>srw_tac[][] +QED -Theorem do_eq_list_rel - `∀l1 l2 l3 l4. +Theorem do_eq_list_rel: + ∀l1 l2 l3 l4. LENGTH l1 = LENGTH l2 ∧ LENGTH l3 = LENGTH l4 ∧ LIST_REL (λp1 p2. UNCURRY do_eq p1 = UNCURRY do_eq p2) (ZIP(l1,l2)) (ZIP(l3,l4)) ⇒ - closSem$do_eq_list l1 l2 = do_eq_list l3 l4` - (Induct >> simp[LENGTH_NIL_SYM] >- ( + closSem$do_eq_list l1 l2 = do_eq_list l3 l4 +Proof + Induct >> simp[LENGTH_NIL_SYM] >- ( simp[GSYM AND_IMP_INTRO, ZIP_EQ_NIL] ) >> gen_tac >> Cases >> simp[PULL_EXISTS] >> Cases >> simp[LENGTH_NIL_SYM] >> Cases >> simp[CONJUNCT2 do_eq_def] >> - strip_tac >> BasicProvers.CASE_TAC >> srw_tac[][]); + strip_tac >> BasicProvers.CASE_TAC >> srw_tac[][] +QED val evaluate_LENGTH_ind = evaluate_ind @@ -454,48 +515,57 @@ val evaluate_LENGTH = prove(evaluate_LENGTH_ind |> concl |> rand, val _ = save_thm("evaluate_LENGTH", evaluate_LENGTH); -Theorem evaluate_IMP_LENGTH - `(evaluate (xs,s,env) = (Rval res,s1)) ==> (LENGTH xs = LENGTH res)` - (REPEAT STRIP_TAC +Theorem evaluate_IMP_LENGTH: + (evaluate (xs,s,env) = (Rval res,s1)) ==> (LENGTH xs = LENGTH res) +Proof + REPEAT STRIP_TAC \\ (evaluate_LENGTH |> CONJUNCT1 |> Q.ISPECL_THEN [`xs`,`s`,`env`] MP_TAC) - \\ full_simp_tac(srw_ss())[]); + \\ full_simp_tac(srw_ss())[] +QED -Theorem evaluate_app_IMP_LENGTH - `(evaluate_app x1 x2 x3 x4 = (Rval res,s1)) ==> (LENGTH res = 1)` - (REPEAT STRIP_TAC +Theorem evaluate_app_IMP_LENGTH: + (evaluate_app x1 x2 x3 x4 = (Rval res,s1)) ==> (LENGTH res = 1) +Proof + REPEAT STRIP_TAC \\ (evaluate_LENGTH |> CONJUNCT2 |> Q.ISPECL_THEN [`x1`,`x2`,`x3`,`x4`] MP_TAC) - \\ full_simp_tac(srw_ss())[]); - -Theorem evaluate_SING - `(evaluate ([x],s,env) = (Rval r,s2)) ==> ?r1. r = [r1]` - (REPEAT STRIP_TAC \\ IMP_RES_TAC evaluate_IMP_LENGTH - \\ Cases_on `r` \\ full_simp_tac(srw_ss())[] \\ Cases_on `t` \\ full_simp_tac(srw_ss())[]); - -Theorem evaluate_CONS - `evaluate (x::xs,env,s) = + \\ full_simp_tac(srw_ss())[] +QED + +Theorem evaluate_SING: + (evaluate ([x],s,env) = (Rval r,s2)) ==> ?r1. r = [r1] +Proof + REPEAT STRIP_TAC \\ IMP_RES_TAC evaluate_IMP_LENGTH + \\ Cases_on `r` \\ full_simp_tac(srw_ss())[] \\ Cases_on `t` \\ full_simp_tac(srw_ss())[] +QED + +Theorem evaluate_CONS: + evaluate (x::xs,env,s) = case evaluate ([x],env,s) of | (Rval v,s2) => (case evaluate (xs,env,s2) of | (Rval vs,s1) => (Rval (HD v::vs),s1) | t => t) - | t => t` - (Cases_on `xs` \\ full_simp_tac(srw_ss())[evaluate_def] + | t => t +Proof + Cases_on `xs` \\ full_simp_tac(srw_ss())[evaluate_def] \\ Cases_on `evaluate ([x],env,s)` \\ full_simp_tac(srw_ss())[evaluate_def] \\ Cases_on `q` \\ full_simp_tac(srw_ss())[evaluate_def] \\ IMP_RES_TAC evaluate_IMP_LENGTH \\ Cases_on `a` \\ full_simp_tac(srw_ss())[] - \\ Cases_on `t` \\ full_simp_tac(srw_ss())[]); + \\ Cases_on `t` \\ full_simp_tac(srw_ss())[] +QED -Theorem evaluate_SNOC - `!xs env s x. +Theorem evaluate_SNOC: + !xs env s x. evaluate (SNOC x xs,env,s) = case evaluate (xs,env,s) of | (Rval vs,s2) => (case evaluate ([x],env,s2) of | (Rval v,s1) => (Rval (vs ++ v),s1) | t => t) - | t => t` - (Induct THEN1 + | t => t +Proof + Induct THEN1 (full_simp_tac(srw_ss())[SNOC_APPEND,evaluate_def] \\ REPEAT STRIP_TAC \\ Cases_on `evaluate ([x],env,s)` \\ Cases_on `q` \\ full_simp_tac(srw_ss())[]) \\ full_simp_tac(srw_ss())[SNOC_APPEND,APPEND] @@ -506,7 +576,8 @@ Theorem evaluate_SNOC \\ Cases_on `evaluate ([x],env,r')` \\ Cases_on `q` \\ full_simp_tac(srw_ss())[evaluate_def] \\ IMP_RES_TAC evaluate_IMP_LENGTH \\ Cases_on `a''` \\ full_simp_tac(srw_ss())[LENGTH] - \\ REV_FULL_SIMP_TAC std_ss [LENGTH_NIL] \\ full_simp_tac(srw_ss())[]); + \\ REV_FULL_SIMP_TAC std_ss [LENGTH_NIL] \\ full_simp_tac(srw_ss())[] +QED val evaluate_const_ind = evaluate_ind @@ -517,13 +588,15 @@ val evaluate_const_ind = (case evaluate_app x1 x2 x3 x4 of (_,s1) => (s1.max_app = x4.max_app))`; -Theorem do_install_const - `do_install vs s = (res,s') ⇒ +Theorem do_install_const: + do_install vs s = (res,s') ⇒ s'.max_app = s.max_app ∧ - s'.ffi = s.ffi` - (rw[do_install_def,case_eq_thms] + s'.ffi = s.ffi +Proof + rw[do_install_def,case_eq_thms] \\ pairarg_tac \\ fs[bool_case_eq,case_eq_thms,pair_case_eq] - \\ rw[]); + \\ rw[] +QED val evaluate_const_lemma = prove( evaluate_const_ind |> concl |> rand, @@ -537,19 +610,23 @@ val evaluate_const_lemma = prove( \\ full_simp_tac(srw_ss())[dec_clock_def]) |> SIMP_RULE std_ss [FORALL_PROD] -Theorem evaluate_const - `(evaluate (xs,env,s) = (res,s1)) ==> - (s1.max_app = s.max_app)` - (REPEAT STRIP_TAC +Theorem evaluate_const: + (evaluate (xs,env,s) = (res,s1)) ==> + (s1.max_app = s.max_app) +Proof + REPEAT STRIP_TAC \\ (evaluate_const_lemma |> CONJUNCT1 |> Q.ISPECL_THEN [`xs`,`env`,`s`] mp_tac) - \\ full_simp_tac(srw_ss())[]); - -Theorem evaluate_app_const - `(evaluate_app x1 x2 x3 x4 = (res,s1)) ==> - (s1.max_app = x4.max_app)` - (REPEAT STRIP_TAC + \\ full_simp_tac(srw_ss())[] +QED + +Theorem evaluate_app_const: + (evaluate_app x1 x2 x3 x4 = (res,s1)) ==> + (s1.max_app = x4.max_app) +Proof + REPEAT STRIP_TAC \\ (evaluate_const_lemma |> CONJUNCT2 |> Q.ISPECL_THEN [`x1`,`x2`,`x3`,`x4`] mp_tac) - \\ full_simp_tac(srw_ss())[]); + \\ full_simp_tac(srw_ss())[] +QED val evaluate_code_ind = evaluate_ind @@ -650,68 +727,82 @@ val evaluate_code_lemma = prove( \\ metis_tac []) |> SIMP_RULE std_ss [FORALL_PROD]; -Theorem evaluate_code - `(evaluate (xs,env,s) = (res,s1)) ==> +Theorem evaluate_code: + (evaluate (xs,env,s) = (res,s1)) ==> ∃n. s1.compile_oracle = shift_seq n s.compile_oracle ∧ let ls = FLAT (MAP (SND o SND) (GENLIST s.compile_oracle n)) in s1.code = s.code |++ ls ∧ ALL_DISTINCT (MAP FST ls) ∧ - DISJOINT (FDOM s.code) (set (MAP FST ls))` - (REPEAT STRIP_TAC + DISJOINT (FDOM s.code) (set (MAP FST ls)) +Proof + REPEAT STRIP_TAC \\ (evaluate_code_lemma |> CONJUNCT1 |> Q.ISPECL_THEN [`xs`,`env`,`s`] mp_tac) - \\ fs[]); + \\ fs[] +QED -Theorem evaluate_app_code - `(evaluate_app lopt f args s = (res,s1)) ==> +Theorem evaluate_app_code: + (evaluate_app lopt f args s = (res,s1)) ==> ∃n. s1.compile_oracle = shift_seq n s.compile_oracle ∧ let ls = FLAT (MAP (SND o SND) (GENLIST s.compile_oracle n)) in s1.code = s.code |++ ls ∧ ALL_DISTINCT (MAP FST ls) ∧ - DISJOINT (FDOM s.code) (set (MAP FST ls))` - (REPEAT STRIP_TAC + DISJOINT (FDOM s.code) (set (MAP FST ls)) +Proof + REPEAT STRIP_TAC \\ (evaluate_code_lemma |> CONJUNCT2 |> Q.ISPECL_THEN [`lopt`,`f`,`args`,`s`] mp_tac) - \\ fs[]); + \\ fs[] +QED -Theorem evaluate_mono - `!xs env s1 vs s2. +Theorem evaluate_mono: + !xs env s1 vs s2. (evaluate (xs,env,s1) = (vs,s2)) ==> - s1.code SUBMAP s2.code` - (rw[] \\ imp_res_tac evaluate_code \\ fs[] + s1.code SUBMAP s2.code +Proof + rw[] \\ imp_res_tac evaluate_code \\ fs[] \\ rw[DISTINCT_FUPDATE_LIST_UNION] - \\ match_mp_tac SUBMAP_FUNION \\ rw[]); + \\ match_mp_tac SUBMAP_FUNION \\ rw[] +QED -Theorem evaluate_MAP_Op_Const - `∀f env s ls. +Theorem evaluate_MAP_Op_Const: + ∀f env s ls. evaluate (MAP (λx. Op tra (Const (f x)) []) ls,env,s) = - (Rval (MAP (Number o f) ls),s)` - (ntac 3 gen_tac >> Induct >> + (Rval (MAP (Number o f) ls),s) +Proof + ntac 3 gen_tac >> Induct >> simp[evaluate_def] >> simp[Once evaluate_CONS] >> - simp[evaluate_def,do_app_def]) - -Theorem evaluate_REPLICATE_Op_AllocGlobal - `∀n env s. evaluate (REPLICATE n (Op tra AllocGlobal []),env,s) = - (Rval (GENLIST (K Unit) n),s with globals := s.globals ++ GENLIST (K NONE) n)` - (Induct >> simp[evaluate_def,REPLICATE] >- ( + simp[evaluate_def,do_app_def] +QED + +Theorem evaluate_REPLICATE_Op_AllocGlobal: + ∀n env s. evaluate (REPLICATE n (Op tra AllocGlobal []),env,s) = + (Rval (GENLIST (K Unit) n),s with globals := s.globals ++ GENLIST (K NONE) n) +Proof + Induct >> simp[evaluate_def,REPLICATE] >- ( simp[state_component_equality] ) >> simp[Once evaluate_CONS,evaluate_def,do_app_def,GENLIST_CONS] >> - simp[state_component_equality]) + simp[state_component_equality] +QED -Theorem lookup_vars_NONE - `!vs. (lookup_vars vs env = NONE) <=> ?v. MEM v vs /\ LENGTH env <= v` - (Induct \\ full_simp_tac(srw_ss())[lookup_vars_def] +Theorem lookup_vars_NONE: + !vs. (lookup_vars vs env = NONE) <=> ?v. MEM v vs /\ LENGTH env <= v +Proof + Induct \\ full_simp_tac(srw_ss())[lookup_vars_def] \\ REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[] \\ Cases_on `h < LENGTH env` \\ full_simp_tac(srw_ss())[NOT_LESS] \\ Cases_on `lookup_vars vs env` \\ full_simp_tac(srw_ss())[] THEN1 METIS_TAC [] - \\ CCONTR_TAC \\ full_simp_tac(srw_ss())[] \\ METIS_TAC [NOT_LESS]); + \\ CCONTR_TAC \\ full_simp_tac(srw_ss())[] \\ METIS_TAC [NOT_LESS] +QED -Theorem lookup_vars_SOME - `!vs env xs. +Theorem lookup_vars_SOME: + !vs env xs. (lookup_vars vs env = SOME xs) ==> - (LENGTH vs = LENGTH xs)` - (Induct \\ full_simp_tac(srw_ss())[lookup_vars_def] \\ REPEAT STRIP_TAC - \\ Cases_on `lookup_vars vs env` \\ full_simp_tac(srw_ss())[] \\ SRW_TAC [] [] \\ RES_TAC); + (LENGTH vs = LENGTH xs) +Proof + Induct \\ full_simp_tac(srw_ss())[lookup_vars_def] \\ REPEAT STRIP_TAC + \\ Cases_on `lookup_vars vs env` \\ full_simp_tac(srw_ss())[] \\ SRW_TAC [] [] \\ RES_TAC +QED val lookup_vars_MEM = Q.prove( `!ys n x (env2:closSem$v list). @@ -723,12 +814,14 @@ val lookup_vars_MEM = Q.prove( \\ Cases_on `n` \\ full_simp_tac(srw_ss())[] \\ SRW_TAC [] [] \\ full_simp_tac(srw_ss())[]) |> SPEC_ALL |> curry save_thm "lookup_vars_MEM"; -Theorem clock_lemmas -`!s. (s with clock := s.clock) = s` - (srw_tac[][state_component_equality]); +Theorem clock_lemmas: + !s. (s with clock := s.clock) = s +Proof + srw_tac[][state_component_equality] +QED -Theorem evaluate_app_rw -`(!args loc_opt f s. +Theorem evaluate_app_rw: + (!args loc_opt f s. args ≠ [] ⇒ evaluate_app loc_opt f args s = case dest_closure s.max_app loc_opt f args of @@ -744,19 +837,21 @@ Theorem evaluate_app_rw case evaluate ([exp],env,dec_clock (LENGTH args - LENGTH rest_args) s) of | (Rval [v], s1) => evaluate_app loc_opt v rest_args s1 - | res => res)` - (Cases_on `args` >> - full_simp_tac(srw_ss())[evaluate_def]); + | res => res) +Proof + Cases_on `args` >> + full_simp_tac(srw_ss())[evaluate_def] +QED -Theorem EVERY_pure_correct - `(∀t es E (s:('c,'ffi) closSem$state). t = (es,E,s) ∧ EVERY closLang$pure es ⇒ +Theorem EVERY_pure_correct = Q.prove(` + (∀t es E (s:('c,'ffi) closSem$state). t = (es,E,s) ∧ EVERY closLang$pure es ⇒ case evaluate(es, E, s) of (Rval vs, s') => s' = s ∧ LENGTH vs = LENGTH es | (Rerr (Rraise a), _) => F | (Rerr (Rabort a), _) => a = Rtype_error) ∧ (∀(n: num option) (v:closSem$v) - (vl : closSem$v list) (s : ('c,'ffi) closSem$state). T)` - (ho_match_mp_tac evaluate_ind >> simp[pure_def] >> + (vl : closSem$v list) (s : ('c,'ffi) closSem$state). T)`, + ho_match_mp_tac evaluate_ind >> simp[pure_def] >> rpt strip_tac >> simp[evaluate_def] >- (every_case_tac >> full_simp_tac(srw_ss())[] >> rpt (qpat_x_assum `_ ==> _` mp_tac) >> simp[] >> full_simp_tac(srw_ss())[] >> @@ -834,11 +929,12 @@ val do_app_cases_ffi_error = save_thm ("do_app_cases_ffi_error", SIMP_CONV (srw_ss()++COND_elim_ss++boolSimps.DNF_ss) [LET_THM, case_eq_thms] THENC ALL_CONV)); -Theorem dest_closure_none_loc -`!max_app l cl vs v e env rest. +Theorem dest_closure_none_loc: + !max_app l cl vs v e env rest. (dest_closure max_app l cl vs = SOME (Partial_app v) ⇒ l = NONE) ∧ - (dest_closure max_app l cl vs = SOME (Full_app e env rest) ∧ rest ≠ [] ⇒ l = NONE)` - (rpt gen_tac >> + (dest_closure max_app l cl vs = SOME (Full_app e env rest) ∧ rest ≠ [] ⇒ l = NONE) +Proof + rpt gen_tac >> simp [dest_closure_def] >> Cases_on `cl` >> simp [] >> @@ -850,7 +946,8 @@ Theorem dest_closure_none_loc Cases_on `EL n l1` >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> - rev_full_simp_tac(srw_ss())[DROP_NIL]); + rev_full_simp_tac(srw_ss())[DROP_NIL] +QED val is_closure_def = Define ` (is_closure (Closure _ _ _ _ _) ⇔ T) ∧ @@ -891,14 +988,15 @@ val rec_clo_ok_def = Define ` (rec_clo_ok (Closure _ _ _ _ _) ⇔ T)`; val _ = export_rewrites ["rec_clo_ok_def"] -Theorem dest_closure_full_length -`!max_app l v vs e args rest. +Theorem dest_closure_full_length: + !max_app l v vs e args rest. dest_closure max_app l v vs = SOME (Full_app e args rest) ⇒ LENGTH (clo_to_partial_args v) < clo_to_num_params v ∧ LENGTH vs + LENGTH (clo_to_partial_args v) = clo_to_num_params v + LENGTH rest ∧ - LENGTH args = clo_to_num_params v + LENGTH (clo_to_env v)` - (rpt gen_tac >> + LENGTH args = clo_to_num_params v + LENGTH (clo_to_env v) +Proof + rpt gen_tac >> simp [dest_closure_def] >> BasicProvers.EVERY_CASE_TAC >> full_simp_tac(srw_ss())[is_closure_def, clo_to_partial_args_def, clo_to_num_params_def, clo_to_env_def] @@ -908,15 +1006,17 @@ Theorem dest_closure_full_length Cases_on `EL n l1` >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> - simp []); + simp [] +QED -Theorem evaluate_app_clock_less -`!loc_opt f args s1 vs s2. +Theorem evaluate_app_clock_less: + !loc_opt f args s1 vs s2. args ≠ [] ∧ evaluate_app loc_opt f args s1 = (Rval vs, s2) ⇒ - s2.clock < s1.clock` - (srw_tac[][] >> + s2.clock < s1.clock +Proof + srw_tac[][] >> rev_full_simp_tac(srw_ss())[evaluate_app_rw] >> BasicProvers.EVERY_CASE_TAC >> full_simp_tac(srw_ss())[] >> @@ -930,12 +1030,15 @@ Theorem evaluate_app_clock_less TRY decide_tac >> Cases_on `args` >> full_simp_tac(srw_ss())[] >> - decide_tac); + decide_tac +QED -Theorem clo_add_partial_args_nil[simp] -`!x. is_closure x ⇒ clo_add_partial_args [] x = x` - (Cases_on `x` >> - srw_tac[][is_closure_def, clo_add_partial_args_def]); +Theorem clo_add_partial_args_nil[simp]: + !x. is_closure x ⇒ clo_add_partial_args [] x = x +Proof + Cases_on `x` >> + srw_tac[][is_closure_def, clo_add_partial_args_def] +QED val clo_can_apply_def = Define ` clo_can_apply loc cl num_args ⇔ @@ -951,19 +1054,24 @@ check_closures cl cl' ⇔ !loc num_args. clo_can_apply loc cl num_args ⇒ clo_can_apply loc cl' num_args`; -Theorem dest_closure_partial_is_closure - `dest_closure max_app l v vs = SOME (Partial_app v') ⇒ - is_closure v'` - (dsimp[dest_closure_def, case_eq_thms, bool_case_eq, is_closure_def, UNCURRY]); - -Theorem is_closure_add_partial_args_nil - `is_closure v ⇒ (clo_add_partial_args [] v = v)` - (Cases_on `v` >> simp[]); - -Theorem evaluate_app_clock0 - `s0.clock = 0 ∧ args ≠ [] ⇒ - evaluate_app lopt r args s0 ≠ (Rval vs, s)` - (strip_tac >> `∃a1 args0. args = a1::args0` by (Cases_on `args` >> full_simp_tac(srw_ss())[]) >> +Theorem dest_closure_partial_is_closure: + dest_closure max_app l v vs = SOME (Partial_app v') ⇒ + is_closure v' +Proof + dsimp[dest_closure_def, case_eq_thms, bool_case_eq, is_closure_def, UNCURRY] +QED + +Theorem is_closure_add_partial_args_nil: + is_closure v ⇒ (clo_add_partial_args [] v = v) +Proof + Cases_on `v` >> simp[] +QED + +Theorem evaluate_app_clock0: + s0.clock = 0 ∧ args ≠ [] ⇒ + evaluate_app lopt r args s0 ≠ (Rval vs, s) +Proof + strip_tac >> `∃a1 args0. args = a1::args0` by (Cases_on `args` >> full_simp_tac(srw_ss())[]) >> simp[evaluate_def] >> Cases_on `dest_closure s0.max_app lopt r (a1::args0)` >> simp[] >> rename1 `dest_closure s0.max_app lopt r (a1::args0) = SOME c` >> @@ -971,13 +1079,15 @@ Theorem evaluate_app_clock0 rename1 `dest_closure max_app lopt r (a1::args0) = SOME (Full_app b env rest)` >> srw_tac[][] >> `SUC (LENGTH args0) ≤ LENGTH rest` by simp[] >> - imp_res_tac dest_closure_full_length >> lfs[]) + imp_res_tac dest_closure_full_length >> lfs[] +QED -Theorem evaluate_app_clock_drop - `∀args f lopt s0 s vs. +Theorem evaluate_app_clock_drop: + ∀args f lopt s0 s vs. evaluate_app lopt f args s0 = (Rval vs, s) ⇒ - s.clock + LENGTH args ≤ s0.clock` - (gen_tac >> completeInduct_on `LENGTH args` >> + s.clock + LENGTH args ≤ s0.clock +Proof + gen_tac >> completeInduct_on `LENGTH args` >> full_simp_tac (srw_ss() ++ DNF_ss) [] >> qx_gen_tac `args` >> `args = [] ∨ ∃a1 as. args = a1::as` by (Cases_on `args` >> simp[]) >> dsimp[evaluate_def, case_eq_thms, bool_case_eq, pair_case_eq, dec_clock_def] >> @@ -989,117 +1099,139 @@ Theorem evaluate_app_clock_drop `LENGTH args' < SUC (LENGTH as)` by (imp_res_tac dest_closure_full_length >> lfs[]) >> `s.clock + LENGTH args' ≤ s1.clock` by metis_tac[] >> - imp_res_tac evaluate_clock >> full_simp_tac(srw_ss())[] >> simp[])) + imp_res_tac evaluate_clock >> full_simp_tac(srw_ss())[] >> simp[]) +QED -Theorem dest_closure_is_closure - `dest_closure max_app lopt f vs = SOME r ⇒ is_closure f` - (Cases_on `f` >> simp[is_closure_def, dest_closure_def]); +Theorem dest_closure_is_closure: + dest_closure max_app lopt f vs = SOME r ⇒ is_closure f +Proof + Cases_on `f` >> simp[is_closure_def, dest_closure_def] +QED -Theorem stage_partial_app - `is_closure c ∧ +Theorem stage_partial_app: + is_closure c ∧ dest_closure max_app NONE v (rest ++ used) = SOME (Partial_app (clo_add_partial_args rest c)) ⇒ dest_closure max_app NONE c rest = - SOME (Partial_app (clo_add_partial_args rest c))` - (Cases_on `v` >> simp[dest_closure_def, case_eq_thms, bool_case_eq, UNCURRY] >> + SOME (Partial_app (clo_add_partial_args rest c)) +Proof + Cases_on `v` >> simp[dest_closure_def, case_eq_thms, bool_case_eq, UNCURRY] >> Cases_on `c` >> - simp[clo_add_partial_args_def, is_closure_def, check_loc_def]); + simp[clo_add_partial_args_def, is_closure_def, check_loc_def] +QED -Theorem dest_closure_full_addargs - `dest_closure max_app NONE c vs = SOME (Full_app b env r) ∧ +Theorem dest_closure_full_addargs: + dest_closure max_app NONE c vs = SOME (Full_app b env r) ∧ LENGTH more + LENGTH vs ≤ max_app ⇒ - dest_closure max_app NONE c (more ++ vs) = SOME (Full_app b env (more ++ r))` - (Cases_on `c` >> csimp[dest_closure_def, bool_case_eq, revdroprev, UNCURRY] >> + dest_closure max_app NONE c (more ++ vs) = SOME (Full_app b env (more ++ r)) +Proof + Cases_on `c` >> csimp[dest_closure_def, bool_case_eq, revdroprev, UNCURRY] >> simp[DROP_APPEND1, revdroprev, TAKE_APPEND1, TAKE_APPEND2] >> - simp[check_loc_def]); + simp[check_loc_def] +QED -Theorem evaluate_append -`!es1 es2 env s. +Theorem evaluate_append: + !es1 es2 env s. evaluate (es1 ++ es2, env, s) = case evaluate (es1, env, s) of | (Rval vs1, s') => (case evaluate (es2, env, s') of | (Rval vs2, s'') => (Rval (vs1++vs2), s'') | x => x) - | x => x` - (Induct_on `es1` >> + | x => x +Proof + Induct_on `es1` >> srw_tac[][evaluate_def] >- ( every_case_tac >> srw_tac[][]) >> ONCE_REWRITE_TAC [evaluate_CONS] >> every_case_tac >> - srw_tac[][]); + srw_tac[][] +QED -Theorem evaluate_GENLIST_Var - `∀n env s. +Theorem evaluate_GENLIST_Var: + ∀n env s. evaluate (GENLIST (Var tra) n, env, s) = if n ≤ LENGTH env then (Rval (TAKE n env),s) else - (Rerr (Rabort Rtype_error),s)` - (Induct \\ simp[evaluate_def,GENLIST,SNOC_APPEND,evaluate_append] + (Rerr (Rabort Rtype_error),s) +Proof + Induct \\ simp[evaluate_def,GENLIST,SNOC_APPEND,evaluate_append] \\ rw[] \\ REWRITE_TAC[GSYM SNOC_APPEND] \\ match_mp_tac SNOC_EL_TAKE - \\ simp[]); + \\ simp[] +QED -Theorem evaluate_length_imp -`evaluate (es,env,s1) = (Rval vs, s2) ⇒ LENGTH es = LENGTH vs` - (srw_tac[][] >> +Theorem evaluate_length_imp: + evaluate (es,env,s1) = (Rval vs, s2) ⇒ LENGTH es = LENGTH vs +Proof + srw_tac[][] >> Q.ISPECL_THEN [`es`, `env`, `s1`] mp_tac (hd (CONJUNCTS evaluate_LENGTH)) >> - srw_tac[][]); + srw_tac[][] +QED -Theorem evaluate_app_length_imp -`evaluate_app l f args s = (Rval vs, s2) ⇒ LENGTH vs = 1` - (srw_tac[][] >> +Theorem evaluate_app_length_imp: + evaluate_app l f args s = (Rval vs, s2) ⇒ LENGTH vs = 1 +Proof + srw_tac[][] >> Q.ISPECL_THEN [`l`, `f`, `args`, `s`] mp_tac (hd (tl (CONJUNCTS evaluate_LENGTH))) >> - srw_tac[][]); + srw_tac[][] +QED -Theorem dest_closure_none_append -`!max_app l f args1 args2. +Theorem dest_closure_none_append: + !max_app l f args1 args2. dest_closure max_app NONE f args2 = NONE ⇒ - dest_closure max_app NONE f (args1 ++ args2) = NONE` - (srw_tac[][dest_closure_def] >> + dest_closure max_app NONE f (args1 ++ args2) = NONE +Proof + srw_tac[][dest_closure_def] >> Cases_on `f` >> full_simp_tac(srw_ss())[check_loc_def] >> srw_tac[][] >> full_simp_tac(srw_ss())[LET_THM] >> every_case_tac >> full_simp_tac(srw_ss())[] >> - simp []); + simp [] +QED -Theorem dest_closure_none_append2 -`!max_app l f args1 args2. +Theorem dest_closure_none_append2: + !max_app l f args1 args2. LENGTH args1 + LENGTH args2 ≤ max_app ∧ dest_closure max_app NONE f (args1 ++ args2) = NONE ⇒ - dest_closure max_app NONE f args2 = NONE` - (srw_tac[][dest_closure_def] >> + dest_closure max_app NONE f args2 = NONE +Proof + srw_tac[][dest_closure_def] >> Cases_on `f` >> full_simp_tac(srw_ss())[check_loc_def] >> srw_tac[][] >> full_simp_tac(srw_ss())[LET_THM] >> every_case_tac >> full_simp_tac(srw_ss())[] >> - simp []); + simp [] +QED -Theorem dest_closure_rest_length -`dest_closure max_app NONE f args = SOME (Full_app e l rest) ⇒ LENGTH rest < LENGTH args` - (simp [dest_closure_def] >> +Theorem dest_closure_rest_length: + dest_closure max_app NONE f args = SOME (Full_app e l rest) ⇒ LENGTH rest < LENGTH args +Proof + simp [dest_closure_def] >> Cases_on `f` >> simp [check_loc_def] >- (srw_tac[][] >> simp []) >> Cases_on `EL n l1` - >- (srw_tac[][] >> simp [])); + >- (srw_tac[][] >> simp []) +QED -Theorem dest_closure_partial_twice -`∀max_app f args1 args2 cl res. +Theorem dest_closure_partial_twice: + ∀max_app f args1 args2 cl res. LENGTH args1 + LENGTH args2 ≤ max_app ∧ dest_closure max_app NONE f (args1 ++ args2) = res ∧ dest_closure max_app NONE f args2 = SOME (Partial_app cl) ⇒ - dest_closure max_app NONE cl args1 = res` - (simp [dest_closure_def] >> + dest_closure max_app NONE cl args1 = res +Proof + simp [dest_closure_def] >> Cases_on `f` >> simp [check_loc_def] >- ( @@ -1137,16 +1269,18 @@ Theorem dest_closure_partial_twice >- ( Q.ISPECL_THEN [`REVERSE args2`, `q - LENGTH l`] mp_tac DROP_LENGTH_TOO_LONG >> srw_tac[][] >> - full_simp_tac (srw_ss()++ARITH_ss) [])); + full_simp_tac (srw_ss()++ARITH_ss) []) +QED -Theorem evaluate_app_append -`!args2 f args1 s. +Theorem evaluate_app_append: + !args2 f args1 s. LENGTH (args1 ++ args2) ≤ s.max_app ⇒ evaluate_app NONE f (args1 ++ args2) s = case evaluate_app NONE f args2 s of | (Rval vs1, s1) => evaluate_app NONE (HD vs1) args1 s1 - | err => err` - (gen_tac >> + | err => err +Proof + gen_tac >> completeInduct_on `LENGTH args2` >> srw_tac[][] >> Cases_on `args1++args2 = []` @@ -1197,21 +1331,25 @@ Theorem evaluate_app_append srw_tac[][] >> pop_assum (qspecl_then [`h`, `args1`, `r`] mp_tac) >> imp_res_tac evaluate_const >> fs[dec_clock_def] >> - simp [])); + simp []) +QED val revnil = Q.prove(`[] = REVERSE l ⇔ l = []`, CONV_TAC (LAND_CONV (REWR_CONV EQ_SYM_EQ)) >> simp[]) -Theorem dest_closure_full_maxapp - `dest_closure max_app NONE c vs = SOME (Full_app b env r) ∧ r ≠ [] ⇒ - LENGTH vs ≤ max_app` - (Cases_on `c` >> simp[dest_closure_def, check_loc_def, UNCURRY]); +Theorem dest_closure_full_maxapp: + dest_closure max_app NONE c vs = SOME (Full_app b env r) ∧ r ≠ [] ⇒ + LENGTH vs ≤ max_app +Proof + Cases_on `c` >> simp[dest_closure_def, check_loc_def, UNCURRY] +QED -Theorem dest_closure_full_split' - `dest_closure max_app loc v vs = SOME (Full_app e env rest) ⇒ +Theorem dest_closure_full_split': + dest_closure max_app loc v vs = SOME (Full_app e env rest) ⇒ ∃used. - vs = rest ++ used ∧ dest_closure max_app loc v used = SOME (Full_app e env [])` - (simp[dest_closure_def] >> Cases_on `v` >> + vs = rest ++ used ∧ dest_closure max_app loc v used = SOME (Full_app e env []) +Proof + simp[dest_closure_def] >> Cases_on `v` >> simp[bool_case_eq, revnil, DROP_NIL, DECIDE ``0n >= x ⇔ x = 0``, UNCURRY, NOT_LESS, DECIDE ``x:num >= y ⇔ y ≤ x``, DECIDE ``¬(x:num ≤ y) ⇔ y < x``] >- (strip_tac >> rename1 `TAKE (n - LENGTH l) (REVERSE vs)` >> @@ -1234,17 +1372,19 @@ Theorem dest_closure_full_split' by simp[] >> pop_assum (fn th => CONV_TAC (LAND_CONV (ONCE_REWRITE_CONV[th]))) >> simp[TAKE_APPEND1]) >> - Cases_on `loc` >> lfs[check_loc_def]) + Cases_on `loc` >> lfs[check_loc_def] +QED -Theorem dest_closure_partial_split -`!max_app v1 vs v2 n. +Theorem dest_closure_partial_split: + !max_app v1 vs v2 n. dest_closure max_app NONE v1 vs = SOME (Partial_app v2) ∧ n ≤ LENGTH vs ⇒ ?v3. dest_closure max_app NONE v1 (DROP n vs) = SOME (Partial_app v3) ∧ - v2 = clo_add_partial_args (TAKE n vs) v3` - (srw_tac[][dest_closure_def] >> + v2 = clo_add_partial_args (TAKE n vs) v3 +Proof + srw_tac[][dest_closure_def] >> Cases_on `v1` >> simp [] >> full_simp_tac(srw_ss())[check_loc_def] @@ -1260,47 +1400,57 @@ Theorem dest_closure_partial_split simp [] >> Cases_on `LENGTH vs + LENGTH l < q` >> full_simp_tac(srw_ss())[] >> - decide_tac); + decide_tac +QED -Theorem dest_closure_partial_split' - `∀max_app n v vs cl. +Theorem dest_closure_partial_split': + ∀max_app n v vs cl. dest_closure max_app NONE v vs = SOME (Partial_app cl) ∧ n ≤ LENGTH vs ⇒ ∃cl0 used rest. vs = rest ++ used ∧ LENGTH rest = n ∧ dest_closure max_app NONE v used = SOME (Partial_app cl0) ∧ - cl = clo_add_partial_args rest cl0` - (rpt strip_tac >> + cl = clo_add_partial_args rest cl0 +Proof + rpt strip_tac >> IMP_RES_THEN (IMP_RES_THEN (qx_choose_then `cl0` strip_assume_tac)) (REWRITE_RULE [GSYM AND_IMP_INTRO] dest_closure_partial_split) >> - map_every qexists_tac [`cl0`, `DROP n vs`, `TAKE n vs`] >> simp[]); + map_every qexists_tac [`cl0`, `DROP n vs`, `TAKE n vs`] >> simp[] +QED -Theorem dest_closure_NONE_Full_to_Partial - `dest_closure max_app NONE v (l1 ++ l2) = SOME (Full_app b env []) ∧ l1 ≠ [] ⇒ +Theorem dest_closure_NONE_Full_to_Partial: + dest_closure max_app NONE v (l1 ++ l2) = SOME (Full_app b env []) ∧ l1 ≠ [] ⇒ ∃cl. dest_closure max_app NONE v l2 = SOME (Partial_app cl) ∧ - dest_closure max_app NONE cl l1 = SOME (Full_app b env [])` - (Cases_on `v` >> + dest_closure max_app NONE cl l1 = SOME (Full_app b env []) +Proof + Cases_on `v` >> dsimp[dest_closure_def, bool_case_eq, revnil, DROP_NIL, GREATER_EQ, check_loc_def, UNCURRY] >> srw_tac[][] >> `0 < LENGTH l1` by (Cases_on `l1` >> full_simp_tac(srw_ss())[]) >> simp[] >> - simp[TAKE_APPEND2] >> Cases_on `l2` >> full_simp_tac(srw_ss())[]); + simp[TAKE_APPEND2] >> Cases_on `l2` >> full_simp_tac(srw_ss())[] +QED -Theorem dec_clock_with_clock[simp] - `dec_clock s with clock := y = s with clock := y` - (EVAL_TAC) +Theorem dec_clock_with_clock[simp]: + dec_clock s with clock := y = s with clock := y +Proof + EVAL_TAC +QED fun get_thms ty = { case_def = TypeBase.case_def_of ty, nchotomy = TypeBase.nchotomy_of ty } val case_eq_thms = pair_case_eq::bool_case_eq::list_case_eq::option_case_eq::map (prove_case_eq_thm o get_thms) [``:'a ffi_result``,``:v``,``:'a ref``,``:closLang$op``,``:word_size``, ``:eq_result``, ``:('a,'b) result``, ``:'a error_result``, ``:app_kind``] |> LIST_CONJ -Theorem do_app_ffi_error_IMP - `do_app op vs s = Rerr (Rabort (Rffi_error f)) ==> ?i. op = FFI i` - (fs [case_eq_thms,do_app_def] \\ rw [] \\ fs []); - -Theorem do_app_add_to_clock - `(do_app op vs (s with clock := s.clock + extra) = - map_result (λ(v,s). (v,s with clock := s.clock + extra)) I (do_app op vs s))` - (Cases_on`do_app op vs s` >> +Theorem do_app_ffi_error_IMP: + do_app op vs s = Rerr (Rabort (Rffi_error f)) ==> ?i. op = FFI i +Proof + fs [case_eq_thms,do_app_def] \\ rw [] \\ fs [] +QED + +Theorem do_app_add_to_clock: + (do_app op vs (s with clock := s.clock + extra) = + map_result (λ(v,s). (v,s with clock := s.clock + extra)) I (do_app op vs s)) +Proof + Cases_on`do_app op vs s` >> TRY(rename1`Rerr e`>>Cases_on`e`)>> TRY(rename1`Rval a`>>Cases_on`a`)>> TRY(rename1`Rabort a`>>Cases_on`a`)>> @@ -1320,38 +1470,47 @@ Theorem do_app_add_to_clock \\ simp [Once do_app_def] \\ fs [case_eq_thms] \\ rpt strip_tac \\ fs [] - \\ rveq \\ simp [do_app_def]); + \\ rveq \\ simp [do_app_def] +QED -Theorem do_install_add_to_clock - `do_install vs s = (Rval e,s') ⇒ +Theorem do_install_add_to_clock: + do_install vs s = (Rval e,s') ⇒ do_install vs (s with clock := s.clock + extra) = - (Rval e, s' with clock := s'.clock + extra)` - (rw[do_install_def,case_eq_thms] + (Rval e, s' with clock := s'.clock + extra) +Proof + rw[do_install_def,case_eq_thms] \\ pairarg_tac \\ fs[case_eq_thms,pair_case_eq,bool_case_eq] - \\ rw[] \\ fs[]); + \\ rw[] \\ fs[] +QED -Theorem do_install_type_error_add_to_clock - `do_install vs s = (Rerr(Rabort Rtype_error),t) ⇒ +Theorem do_install_type_error_add_to_clock: + do_install vs s = (Rerr(Rabort Rtype_error),t) ⇒ do_install vs (s with clock := s.clock + extra) = - (Rerr(Rabort Rtype_error),t with clock := t.clock + extra)` - (rw[do_install_def,case_eq_thms] \\ fs [] + (Rerr(Rabort Rtype_error),t with clock := t.clock + extra) +Proof + rw[do_install_def,case_eq_thms] \\ fs [] \\ pairarg_tac \\ fs[case_eq_thms,pair_case_eq,bool_case_eq] - \\ rw[] \\ fs[]); + \\ rw[] \\ fs[] +QED -Theorem do_install_not_Rraise[simp] - `do_install vs s = (res,t) ==> res ≠ Rerr(Rraise r)` - (rw[do_install_def,case_eq_thms,UNCURRY,bool_case_eq,pair_case_eq]); +Theorem do_install_not_Rraise[simp]: + do_install vs s = (res,t) ==> res ≠ Rerr(Rraise r) +Proof + rw[do_install_def,case_eq_thms,UNCURRY,bool_case_eq,pair_case_eq] +QED -Theorem do_install_not_Rffi_error[simp] - `do_install vs s = (res,t) ==> res ≠ Rerr(Rabort (Rffi_error f))` - (rw[do_install_def,case_eq_thms,UNCURRY,bool_case_eq,pair_case_eq]); +Theorem do_install_not_Rffi_error[simp]: + do_install vs s = (res,t) ==> res ≠ Rerr(Rabort (Rffi_error f)) +Proof + rw[do_install_def,case_eq_thms,UNCURRY,bool_case_eq,pair_case_eq] +QED val s = ``s:('c,'ffi) closSem$state``; -Theorem evaluate_add_to_clock - `(∀p es env ^s r s'. +Theorem evaluate_add_to_clock: + (∀p es env ^s r s'. p = (es,env,s) ∧ evaluate (es,env,s) = (r,s') ∧ r ≠ Rerr (Rabort Rtimeout_error) ⇒ @@ -1361,8 +1520,9 @@ Theorem evaluate_add_to_clock evaluate_app loc_opt v rest_args s = (r,s') ∧ r ≠ Rerr (Rabort Rtimeout_error) ⇒ evaluate_app loc_opt v rest_args (s with clock := s.clock + extra) = - (r,s' with clock := s'.clock + extra))` - (ho_match_mp_tac evaluate_ind >> + (r,s' with clock := s'.clock + extra)) +Proof + ho_match_mp_tac evaluate_ind >> srw_tac[][evaluate_def] >> full_simp_tac(srw_ss())[evaluate_def] >> TRY ( rename1`Boolv T` >> @@ -1401,7 +1561,8 @@ Theorem evaluate_add_to_clock imp_res_tac do_install_not_Rraise >> fs [] >> imp_res_tac do_install_not_Rffi_error >> fs [] >> rename1`Rerr(Rabort abt)` >> Cases_on`abt` \\ fs[] >> - imp_res_tac do_install_type_error_add_to_clock \\ fs[]); + imp_res_tac do_install_type_error_add_to_clock \\ fs[] +QED val evaluate_add_clock = save_thm("evaluate_add_clock", evaluate_add_to_clock @@ -1409,15 +1570,17 @@ val evaluate_add_clock = save_thm("evaluate_add_clock", |> SPEC_ALL |> UNDISCH |> Q.GEN `extra` |> DISCH_ALL |> GEN_ALL); -Theorem evaluate_add_clock_initial_state - `evaluate (es,env,initial_state ffi ma code co cc k) = (r,s') ∧ +Theorem evaluate_add_clock_initial_state: + evaluate (es,env,initial_state ffi ma code co cc k) = (r,s') ∧ r ≠ Rerr (Rabort Rtimeout_error) ⇒ ∀extra. evaluate (es,env,initial_state ffi ma code co cc (k + extra)) = - (r,s' with clock := s'.clock + extra)` - (rw [] \\ drule evaluate_add_clock \\ fs [] + (r,s' with clock := s'.clock + extra) +Proof + rw [] \\ drule evaluate_add_clock \\ fs [] \\ disch_then (qspec_then `extra` mp_tac) - \\ fs [initial_state_def]); + \\ fs [initial_state_def] +QED val do_app_io_events_mono = Q.prove( `do_app op vs s = Rval(v,s') ⇒ @@ -1430,13 +1593,15 @@ val do_app_io_events_mono = Q.prove( full_simp_tac(srw_ss())[ffiTheory.call_FFI_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][]); -Theorem evaluate_io_events_mono - `(∀p. ((SND(SND p)):('c,'ffi) closSem$state).ffi.io_events ≼ (SND (evaluate p)).ffi.io_events) ∧ +Theorem evaluate_io_events_mono: + (∀p. ((SND(SND p)):('c,'ffi) closSem$state).ffi.io_events ≼ (SND (evaluate p)).ffi.io_events) ∧ (∀loc_opt v rest ^s. - s.ffi.io_events ≼ (SND(evaluate_app loc_opt v rest s)).ffi.io_events)` - (ho_match_mp_tac evaluate_ind >> srw_tac[][evaluate_def] >> + s.ffi.io_events ≼ (SND(evaluate_app loc_opt v rest s)).ffi.io_events) +Proof + ho_match_mp_tac evaluate_ind >> srw_tac[][evaluate_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> rev_full_simp_tac(srw_ss())[] >> full_simp_tac(srw_ss())[dec_clock_def] >> - metis_tac[IS_PREFIX_TRANS,do_app_io_events_mono,do_install_const]); + metis_tac[IS_PREFIX_TRANS,do_app_io_events_mono,do_install_const] +QED val evaluate_io_events_mono_imp = Q.prove( `evaluate (es,env,s) = (r,s') ⇒ @@ -1462,15 +1627,16 @@ val tac = rveq >> fs[] >> metis_tac[evaluate_io_events_mono,with_clock_ffi,FST,SND,IS_PREFIX_TRANS,lemma,Boolv_11,lemma2,lemma3] -Theorem evaluate_add_to_clock_io_events_mono - `(∀p es env ^s. +Theorem evaluate_add_to_clock_io_events_mono: + (∀p es env ^s. p = (es,env,s) ⇒ (SND(evaluate p)).ffi.io_events ≼ (SND(evaluate (es,env,s with clock := s.clock + extra))).ffi.io_events) ∧ (∀l v r ^s. (SND(evaluate_app l v r s)).ffi.io_events ≼ - (SND(evaluate_app l v r (s with clock := s.clock + extra))).ffi.io_events)` - (ho_match_mp_tac evaluate_ind >> srw_tac[][evaluate_def] >> + (SND(evaluate_app l v r (s with clock := s.clock + extra))).ffi.io_events) +Proof + ho_match_mp_tac evaluate_ind >> srw_tac[][evaluate_def] >> TRY ( rename1`Boolv T` >> qmatch_assum_rename_tac`IS_SOME _.ffi.final_event` >> @@ -1484,39 +1650,48 @@ Theorem evaluate_add_to_clock_io_events_mono fsrw_tac[ARITH_ss][] >> tac) >> unabbrev_all_tac >> full_simp_tac(srw_ss())[LET_THM] >> every_case_tac >> full_simp_tac(srw_ss())[evaluate_def] >> - tac) - -Theorem do_app_never_timesout[simp] - `do_app op args s ≠ Rerr (Rabort Rtimeout_error)` - (Cases_on `op` >> Cases_on `args` >> - simp[do_app_def, case_eq_thms, bool_case_eq, pair_case_eq]); - -Theorem evaluate_timeout_clocks0 - `(∀v (s:('c,'ffi) closSem$state). + tac +QED + +Theorem do_app_never_timesout[simp]: + do_app op args s ≠ Rerr (Rabort Rtimeout_error) +Proof + Cases_on `op` >> Cases_on `args` >> + simp[do_app_def, case_eq_thms, bool_case_eq, pair_case_eq] +QED + +Theorem evaluate_timeout_clocks0: + (∀v (s:('c,'ffi) closSem$state). evaluate v = (Rerr (Rabort Rtimeout_error), s) ⇒ s.clock = 0) ∧ (∀locopt v env (s:('c,'ffi) closSem$state) s'. evaluate_app locopt v env s = (Rerr (Rabort Rtimeout_error), s') ⇒ - s'.clock = 0)` - (ho_match_mp_tac evaluate_ind >> rpt conj_tac >> + s'.clock = 0) +Proof + ho_match_mp_tac evaluate_ind >> rpt conj_tac >> dsimp[evaluate_def, case_eq_thms, pair_case_eq, bool_case_eq] >> rw[] >> pop_assum mp_tac >> simp_tac (srw_ss()) [do_install_def,case_eq_thms,bool_case_eq,pair_case_eq,UNCURRY,LET_THM] >> - rw[] >> fs []); + rw[] >> fs [] +QED val _ = export_rewrites ["closLang.exp_size_def"] -Theorem exp_size_MEM - `(∀e elist. MEM e elist ⇒ exp_size e < exp3_size elist) ∧ - (∀x e ealist. MEM (x,e) ealist ⇒ exp_size e < exp1_size ealist)` - (conj_tac >| [Induct_on `elist`, Induct_on `ealist`] >> dsimp[] >> - rpt strip_tac >> res_tac >> simp[]); - -Theorem evaluate_eq_nil[simp] - `closSem$evaluate(es,env,s0) = (Rval [], s) ⇔ s0 = s ∧ es = []` - (Cases_on `es` >> simp[evaluate_def] >> +Theorem exp_size_MEM: + (∀e elist. MEM e elist ⇒ exp_size e < exp3_size elist) ∧ + (∀x e ealist. MEM (x,e) ealist ⇒ exp_size e < exp1_size ealist) +Proof + conj_tac >| [Induct_on `elist`, Induct_on `ealist`] >> dsimp[] >> + rpt strip_tac >> res_tac >> simp[] +QED + +Theorem evaluate_eq_nil[simp]: + closSem$evaluate(es,env,s0) = (Rval [], s) ⇔ s0 = s ∧ es = [] +Proof + Cases_on `es` >> simp[evaluate_def] >> strip_tac >> rename1 `evaluate(h::t, env, s0)` >> Q.ISPECL_THEN [`h::t`, `env`, `s0`] mp_tac (CONJUNCT1 evaluate_LENGTH) >> - simp[]); + simp[] +QED (* finding the SetGlobal operations *) @@ -1525,14 +1700,18 @@ val op_gbag_def = Define` op_gbag _ = {||} `; -Theorem exp2_size_rw[simp] - `exp2_size h = 1 + FST h + exp_size (SND h)` - (Cases_on `h` >> simp[]) +Theorem exp2_size_rw[simp]: + exp2_size h = 1 + FST h + exp_size (SND h) +Proof + Cases_on `h` >> simp[] +QED -Theorem exp1_size_rw[simp] - `exp1_size fbinds = - exp3_size (MAP SND fbinds) + SUM (MAP FST fbinds) + LENGTH fbinds` - (Induct_on `fbinds` >> simp[]); +Theorem exp1_size_rw[simp]: + exp1_size fbinds = + exp3_size (MAP SND fbinds) + SUM (MAP FST fbinds) + LENGTH fbinds +Proof + Induct_on `fbinds` >> simp[] +QED val set_globals_def = tDefine "set_globals" ` (set_globals (Var _ _) = {||}) ∧ @@ -1561,10 +1740,12 @@ val _ = export_rewrites ["set_globals_def"] include calls to SetGlobal, for foo = {(e)xpr, (v)alue, (r)esult, and (s)tate} *) -Theorem v_size_lemma - `MEM (v:closSem$v) vl ⇒ v_size v < v1_size vl` - (Induct_on `vl` >> dsimp[v_size_def] >> rpt strip_tac >> - res_tac >> simp[]); +Theorem v_size_lemma: + MEM (v:closSem$v) vl ⇒ v_size v < v1_size vl +Proof + Induct_on `vl` >> dsimp[v_size_def] >> rpt strip_tac >> + res_tac >> simp[] +QED (* value is setglobal-closure free *) val vsgc_free_def = tDefine "vsgc_free" ` @@ -1583,13 +1764,17 @@ val vsgc_free_def = save_thm( "vsgc_free_def[simp]", SIMP_RULE (bool_ss ++ ETA_ss) [] vsgc_free_def) -Theorem vsgc_free_Unit[simp] - `vsgc_free Unit` - (simp[Unit_def]); +Theorem vsgc_free_Unit[simp]: + vsgc_free Unit +Proof + simp[Unit_def] +QED -Theorem vsgc_free_Boolv[simp] - `vsgc_free (Boolv b)` - (simp[Boolv_def]); +Theorem vsgc_free_Boolv[simp]: + vsgc_free (Boolv b) +Proof + simp[Boolv_def] +QED (* result is setglobal-closure free *) val rsgc_free_def = Define` @@ -1627,53 +1812,73 @@ val ssgc_free_def = Define` elist_globals (MAP (SND o SND) aux) = {||}) `; -Theorem ssgc_free_clockupd[simp] - `ssgc_free (s with clock updated_by f) = ssgc_free s` - (simp[ssgc_free_def]) - -Theorem ssgc_free_dec_clock[simp] - `ssgc_free (dec_clock n s) ⇔ ssgc_free s` - (simp[dec_clock_def]) - -Theorem elglobals_EQ_EMPTY - `elist_globals l = {||} ⇔ ∀e. MEM e l ⇒ set_globals e = {||}` - (Induct_on `l` >> dsimp[]); - -Theorem set_globals_empty_esgc_free - `set_globals e = {||} ⇒ esgc_free e` - (completeInduct_on `exp_size e` >> fs[PULL_FORALL] >> Cases >> +Theorem ssgc_free_clockupd[simp]: + ssgc_free (s with clock updated_by f) = ssgc_free s +Proof + simp[ssgc_free_def] +QED + +Theorem ssgc_free_dec_clock[simp]: + ssgc_free (dec_clock n s) ⇔ ssgc_free s +Proof + simp[dec_clock_def] +QED + +Theorem elglobals_EQ_EMPTY: + elist_globals l = {||} ⇔ ∀e. MEM e l ⇒ set_globals e = {||} +Proof + Induct_on `l` >> dsimp[] +QED + +Theorem set_globals_empty_esgc_free: + set_globals e = {||} ⇒ esgc_free e +Proof + completeInduct_on `exp_size e` >> fs[PULL_FORALL] >> Cases >> simp[] >> strip_tac >> rveq >> fs[AND_IMP_INTRO] >> simp[EVERY_MEM, elglobals_EQ_EMPTY, MEM_MAP] >> rw[] >> rw[] >> - first_x_assum irule >> simp[] >> imp_res_tac exp_size_MEM >> simp[]) - -Theorem elist_globals_append - `∀a b. elist_globals (a++b) = - elist_globals a ⊎ elist_globals b` - (Induct>>fs[set_globals_def,ASSOC_BAG_UNION]) -Theorem elist_globals_FOLDR - `elist_globals es = FOLDR BAG_UNION {||} (MAP set_globals es)` - (Induct_on `es` >> simp[]); - -Theorem elist_globals_reverse - `∀ls. elist_globals (REVERSE ls) = elist_globals ls` - (Induct>>fs[set_globals_def,elist_globals_append,COMM_BAG_UNION]) + first_x_assum irule >> simp[] >> imp_res_tac exp_size_MEM >> simp[] +QED + +Theorem elist_globals_append: + ∀a b. elist_globals (a++b) = + elist_globals a ⊎ elist_globals b +Proof + Induct>>fs[set_globals_def,ASSOC_BAG_UNION] +QED +Theorem elist_globals_FOLDR: + elist_globals es = FOLDR BAG_UNION {||} (MAP set_globals es) +Proof + Induct_on `es` >> simp[] +QED + +Theorem elist_globals_reverse: + ∀ls. elist_globals (REVERSE ls) = elist_globals ls +Proof + Induct>>fs[set_globals_def,elist_globals_append,COMM_BAG_UNION] +QED val ignore_table_def = Define` ignore_table f st (code,aux) = let (st',code') = f st code in (st',(code',aux))`; -Theorem ignore_table_imp - `ignore_table f st p = (st',p') ⇒ SND p' = SND p` - (Cases_on`p` \\ EVAL_TAC - \\ pairarg_tac \\ rw[] \\ rw[]); - -Theorem SND_SND_ignore_table - `SND (SND (ignore_table f st p)) = SND p` - (Cases_on`p` \\ EVAL_TAC \\ pairarg_tac \\ fs[]); - -Theorem FST_SND_ignore_table - `FST (SND (ignore_table f st p)) = SND (f st (FST p))` - (Cases_on`p` \\ EVAL_TAC \\ pairarg_tac \\ fs[]); +Theorem ignore_table_imp: + ignore_table f st p = (st',p') ⇒ SND p' = SND p +Proof + Cases_on`p` \\ EVAL_TAC + \\ pairarg_tac \\ rw[] \\ rw[] +QED + +Theorem SND_SND_ignore_table: + SND (SND (ignore_table f st p)) = SND p +Proof + Cases_on`p` \\ EVAL_TAC \\ pairarg_tac \\ fs[] +QED + +Theorem FST_SND_ignore_table: + FST (SND (ignore_table f st p)) = SND (f st (FST p)) +Proof + Cases_on`p` \\ EVAL_TAC \\ pairarg_tac \\ fs[] +QED (* generic do_app compile proof *) @@ -1683,11 +1888,13 @@ val isClos_def = Define ` isClos _ = F` val _ = export_rewrites ["isClos_def"]; -Theorem isClos_cases - `isClos x <=> +Theorem isClos_cases: + isClos x <=> (?x1 x2 x3 x4 x5. x = Closure x1 x2 x3 x4 x5) \/ - (?y1 y2 y3 y4 y5. x = Recclosure y1 y2 y3 y4 y5)` - (Cases_on `x` \\ fs []); + (?y1 y2 y3 y4 y5. x = Recclosure y1 y2 y3 y4 y5) +Proof + Cases_on `x` \\ fs [] +QED val simple_val_rel_def = Define ` simple_val_rel vr <=> @@ -1748,13 +1955,17 @@ val simple_state_rel_def = Define ` sr s t /\ LIST_REL (OPTREL vr) xs ys ==> sr (s with globals := xs) (t with globals := ys))` -Theorem simple_state_rel_ffi - `simple_state_rel vr sr /\ sr s t ==> s.ffi = t.ffi` - (fs [simple_state_rel_def]); +Theorem simple_state_rel_ffi: + simple_state_rel vr sr /\ sr s t ==> s.ffi = t.ffi +Proof + fs [simple_state_rel_def] +QED -Theorem simple_state_rel_fdom - `simple_state_rel vr sr /\ sr s t ==> FDOM s.refs = FDOM t.refs` - (fs [simple_state_rel_def]); +Theorem simple_state_rel_fdom: + simple_state_rel vr sr /\ sr s t ==> FDOM s.refs = FDOM t.refs +Proof + fs [simple_state_rel_def] +QED val simple_state_rel_update_ffi = prove( ``simple_state_rel vr sr /\ sr s t ==> @@ -1878,32 +2089,35 @@ val v_rel_do_eq = prove( \\ Cases_on `do_eq y1 y2` \\ fs [] \\ Cases_on `b` \\ fs []); -Theorem simple_state_rel_FLOOKUP_refs_IMP - `simple_state_rel vr sr /\ sr s t /\ +Theorem simple_state_rel_FLOOKUP_refs_IMP: + simple_state_rel vr sr /\ sr s t /\ FLOOKUP t.refs p = x ==> case x of | NONE => FLOOKUP s.refs p = NONE | SOME (ByteArray f bs) => FLOOKUP s.refs p = SOME (ByteArray f bs) | SOME (ValueArray vs) => - ?xs. FLOOKUP s.refs p = SOME (ValueArray xs) /\ LIST_REL vr xs vs` - (fs [simple_state_rel_def] \\ Cases_on `x` \\ rw [] - \\ res_tac \\ fs [] \\ rename1 `_ = SOME yy` \\ Cases_on `yy` \\ fs []); + ?xs. FLOOKUP s.refs p = SOME (ValueArray xs) /\ LIST_REL vr xs vs +Proof + fs [simple_state_rel_def] \\ Cases_on `x` \\ rw [] + \\ res_tac \\ fs [] \\ rename1 `_ = SOME yy` \\ Cases_on `yy` \\ fs [] +QED val refs_ffi_lemma = prove( ``((s:('c,'ffi) closSem$state) with <|refs := refs'; ffi := ffi'|>) = ((s with refs := refs') with ffi := ffi')``, fs []); -Theorem simple_val_rel_list - `!x x1 xs vr. +Theorem simple_val_rel_list: + !x x1 xs vr. simple_val_rel vr /\ vr x x1 /\ v_to_list x1 = SOME xs ==> ?xs1. vr (list_to_v xs1) (list_to_v xs) /\ - v_to_list x = SOME xs1` - (recInduct v_to_list_ind \\ rw [] + v_to_list x = SOME xs1 +Proof + recInduct v_to_list_ind \\ rw [] \\ fs [v_to_list_def, list_to_v_def] \\ rfs [simple_val_rel_alt] \\ rw [] \\ rfs [] \\ Cases_on `x1` \\ fs [] \\ rfs [] \\ rw [] @@ -1914,35 +2128,40 @@ Theorem simple_val_rel_list \\ fs [list_to_v_def, PULL_EXISTS] \\ first_x_assum drule \\ rpt (disch_then drule \\ fs []) \\ rw [] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem simple_val_rel_APPEND - `!xs1 ys1 xs2 ys2 vr. +Theorem simple_val_rel_APPEND: + !xs1 ys1 xs2 ys2 vr. simple_val_rel vr /\ vr (list_to_v xs1) (list_to_v xs2) /\ vr (list_to_v ys1) (list_to_v ys2) ==> - vr (list_to_v (xs1++ys1)) (list_to_v (xs2++ys2))` - (Induct \\ rw [] + vr (list_to_v (xs1++ys1)) (list_to_v (xs2++ys2)) +Proof + Induct \\ rw [] \\ rfs [simple_val_rel_alt] \\ fs [list_to_v_def] \\ Cases_on `xs2` \\ rfs [list_to_v_def] \\ first_x_assum drule \\ fs [PULL_EXISTS] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem vr_list_NONE - `!x x1 vr. +Theorem vr_list_NONE: + !x x1 vr. simple_val_rel vr /\ vr x x1 /\ v_to_list x1 = NONE ==> - v_to_list x = NONE` - (recInduct v_to_list_ind \\ rw [] + v_to_list x = NONE +Proof + recInduct v_to_list_ind \\ rw [] \\ Cases_on `x1` \\ rfs [simple_val_rel_alt] \\ fs [v_to_list_def] \\ rw [] \\ fs [v_to_list_def, case_eq_thms] \\ TRY (first_x_assum drule) \\ rpt (disch_then drule \\ fs []) - \\ rw [] \\ metis_tac [isClos_def]); + \\ rw [] \\ metis_tac [isClos_def] +QED val _ = print "The following proof is slow due to Rerr cases.\n" val simple_val_rel_do_app_rev = time store_thm("simple_val_rel_do_app_rev", @@ -2112,20 +2331,22 @@ val simple_val_rel_do_app_rev = time store_thm("simple_val_rel_do_app_rev", \\ asm_exists_tac \\ fs [LIST_REL_REPLICATE_same]) \\ Cases_on `opp` \\ fs []); -Theorem simple_val_rel_do_app - `simple_val_rel vr /\ simple_state_rel vr sr ==> +Theorem simple_val_rel_do_app: + simple_val_rel vr /\ simple_state_rel vr sr ==> sr s (t:('c,'ffi) closSem$state) /\ LIST_REL vr xs ys ==> case do_app opp xs s of | Rerr err1 => (?err2. do_app opp ys t = Rerr err2 /\ exc_rel vr err1 err2) | Rval (x,s1) => ?y t1. vr x y /\ sr s1 t1 /\ - do_app opp ys t = Rval (y,t1)` - (rpt strip_tac + do_app opp ys t = Rval (y,t1) +Proof + rpt strip_tac \\ mp_tac simple_val_rel_do_app_rev \\ fs [] \\ Cases_on `do_app opp xs s` \\ fs [] \\ Cases_on `do_app opp ys t` \\ fs [] \\ TRY (PairCases_on `a` \\ fs []) - \\ TRY (PairCases_on `a'` \\ fs [])); + \\ TRY (PairCases_on `a'` \\ fs []) +QED (* a generic semantics preservation lemma *) @@ -2133,9 +2354,11 @@ val FST_EQ_LEMMA = prove( ``FST x = y <=> ?y1. x = (y,y1)``, Cases_on `x` \\ fs []); -Theorem initial_state_max_app[simp] - `(initial_state ffi max_app code co cc k).max_app = max_app` - (EVAL_TAC); +Theorem initial_state_max_app[simp]: + (initial_state ffi max_app code co cc k).max_app = max_app +Proof + EVAL_TAC +QED val eval_sim_def = Define ` eval_sim ffi max_app code1 co1 cc1 es1 code2 co2 cc2 es2 rel allow_fail = @@ -2160,13 +2383,14 @@ val initial_state_with_clock = prove( initial_state ffi ma code co cc (k + ck)``, fs [initial_state_def]); -Theorem IMP_semantics_eq - `eval_sim ffi max_app code1 co1 cc1 es1 code2 co2 cc2 es2 rel F /\ +Theorem IMP_semantics_eq: + eval_sim ffi max_app code1 co1 cc1 es1 code2 co2 cc2 es2 rel F /\ semantics (ffi:'ffi ffi_state) max_app code1 co1 cc1 es1 <> Fail ==> rel code1 co1 cc1 es1 code2 co2 cc2 es2 ==> semantics ffi max_app code2 co2 cc2 es2 = - semantics ffi max_app code1 co1 cc1 es1` - (rewrite_tac [GSYM AND_IMP_INTRO] + semantics ffi max_app code1 co1 cc1 es1 +Proof + rewrite_tac [GSYM AND_IMP_INTRO] \\ strip_tac \\ simp [Once semantics_def] \\ IF_CASES_TAC \\ fs [] \\ disch_then kall_tac @@ -2316,14 +2540,16 @@ Theorem IMP_semantics_eq \\ qunabbrev_tac `ffi1` \\ metis_tac [evaluate_add_to_clock_io_events_mono, - initial_state_with_clock,SND,ADD_SYM]); + initial_state_with_clock,SND,ADD_SYM] +QED -Theorem IMP_semantics_eq_no_fail - `eval_sim ffi max_app code1 co1 cc1 es1 code2 co2 cc2 es2 rel T ==> +Theorem IMP_semantics_eq_no_fail: + eval_sim ffi max_app code1 co1 cc1 es1 code2 co2 cc2 es2 rel T ==> rel code1 co1 cc1 es1 code2 co2 cc2 es2 ==> semantics ffi max_app code2 co2 cc2 es2 = - semantics ffi max_app code1 co1 cc1 es1` - (strip_tac + semantics ffi max_app code1 co1 cc1 es1 +Proof + strip_tac \\ once_rewrite_tac [EQ_SYM_EQ] \\ simp [Once semantics_def] \\ rw [] THEN1 @@ -2467,7 +2693,8 @@ Theorem IMP_semantics_eq_no_fail \\ qunabbrev_tac `ffi1` \\ metis_tac [evaluate_add_to_clock_io_events_mono, - initial_state_with_clock,SND,ADD_SYM]); + initial_state_with_clock,SND,ADD_SYM] +QED val CURRY_I_rel_def = Define` CURRY_I_rel s1 s2 ⇔ @@ -2480,13 +2707,14 @@ val CURRY_I_rel_def = Define` s1.code = s2.code ∧ s1.max_app = s2.max_app`; -Theorem do_install_CURRY_I - `do_install xs z1 = (r,s1) ∧ r ≠ Rerr (Rabort Rtype_error) ∧ +Theorem do_install_CURRY_I: + do_install xs z1 = (r,s1) ∧ r ≠ Rerr (Rabort Rtype_error) ∧ CURRY_I_rel z1 z2 ⇒ ∃s2. do_install xs z2 = (r,s2) ∧ - CURRY_I_rel s1 s2` - (rw[closSemTheory.do_install_def] + CURRY_I_rel s1 s2 +Proof + rw[closSemTheory.do_install_def] \\ fs[CaseEq"list",CaseEq"option"] \\ rw[] \\ pairarg_tac \\ fs[] \\ pairarg_tac \\ fs[] @@ -2505,7 +2733,8 @@ Theorem do_install_CURRY_I \\ pairarg_tac \\ fs[] \\ IF_CASES_TAC \\ fs[] \\ rveq \\ fs[] \\ IF_CASES_TAC \\ fs[CaseEq"bool"] \\ rveq \\ fs[CURRY_I_rel_def, FUN_EQ_THM] - \\ fs[backendPropsTheory.state_cc_def, backendPropsTheory.state_co_def]); + \\ fs[backendPropsTheory.state_cc_def, backendPropsTheory.state_co_def] +QED val do_app_lemma_simp = prove( ``(exc_rel $= err1 err2 <=> err1 = err2) /\ @@ -2526,26 +2755,30 @@ val do_app_lemma = |> Q.INST [`opp`|->`op`,`s`|->`s1`,`t`|->`s2`,`ys`|->`xs`] |> SIMP_RULE std_ss [do_app_lemma_simp] -Theorem do_app_CURRY_I_Rerr - `∀op xs s1 s2 r. +Theorem do_app_CURRY_I_Rerr: + ∀op xs s1 s2 r. do_app op xs s1 = Rerr r ∧ CURRY_I_rel s1 s2 ⇒ - do_app op xs s2 = Rerr r` - (rw [] \\ imp_res_tac do_app_lemma - \\ pop_assum (assume_tac o SPEC_ALL) \\ rfs []); - -Theorem do_app_CURRY_I_Rval - `∀op xs s1 s2 r z1. + do_app op xs s2 = Rerr r +Proof + rw [] \\ imp_res_tac do_app_lemma + \\ pop_assum (assume_tac o SPEC_ALL) \\ rfs [] +QED + +Theorem do_app_CURRY_I_Rval: + ∀op xs s1 s2 r z1. do_app op xs s1 = Rval (r,z1) ∧ CURRY_I_rel s1 s2 ⇒ ∃z2. do_app op xs s2 = Rval (r,z2) ∧ - CURRY_I_rel z1 z2` - (rw [] \\ imp_res_tac do_app_lemma - \\ pop_assum (assume_tac o SPEC_ALL) \\ rfs []); + CURRY_I_rel z1 z2 +Proof + rw [] \\ imp_res_tac do_app_lemma + \\ pop_assum (assume_tac o SPEC_ALL) \\ rfs [] +QED -Theorem evaluate_CURRY_I - `(∀p x y (z1:('a # 'c, 'ffi)closSem$state) r s1 s2 (z2:('c,'ffi)closSem$state). +Theorem evaluate_CURRY_I: + (∀p x y (z1:('a # 'c, 'ffi)closSem$state) r s1 s2 (z2:('c,'ffi)closSem$state). p = (x,y,z1) ∧ closSem$evaluate (x,y,z1) = (r,s1) ∧ r ≠ Rerr (Rabort Rtype_error) ∧ @@ -2561,8 +2794,9 @@ Theorem evaluate_CURRY_I ⇒ ∃s2. evaluate_app w x y z2 = (r,s2) ∧ - CURRY_I_rel s1 s2)` - (ho_match_mp_tac closSemTheory.evaluate_ind + CURRY_I_rel s1 s2) +Proof + ho_match_mp_tac closSemTheory.evaluate_ind \\ rw[closSemTheory.evaluate_def] \\ TRY ( fs[closSemTheory.evaluate_def, @@ -2600,13 +2834,15 @@ Theorem evaluate_CURRY_I \\ NO_TAC ) \\ imp_res_tac do_app_CURRY_I_Rval \\ fs[] - \\ imp_res_tac do_app_CURRY_I_Rerr); + \\ imp_res_tac do_app_CURRY_I_Rerr +QED -Theorem semantics_CURRY_I - `semantics ffi max_app code co (state_cc (CURRY I) cc) es ≠ Fail ⇒ +Theorem semantics_CURRY_I: + semantics ffi max_app code co (state_cc (CURRY I) cc) es ≠ Fail ⇒ semantics ffi max_app code (state_co (CURRY I) co) cc es = - semantics ffi max_app code co (state_cc (CURRY I) cc) es` - (rw[] + semantics ffi max_app code co (state_cc (CURRY I) cc) es +Proof + rw[] \\ irule IMP_semantics_eq \\ rw[eval_sim_def] \\ qexists_tac`K (K (K (K (K (K (K (K T)))))))` \\ rw[] @@ -2621,19 +2857,24 @@ Theorem semantics_CURRY_I \\ simp[Abbr`sz`] \\ EVAL_TAC ) \\ strip_tac \\ fs[] - \\ imp_res_tac CURRY_I_rel_def); + \\ imp_res_tac CURRY_I_rel_def +QED -Theorem semantics_nil[simp] - `semantics ffi maxapp code co cc [] = Terminate Success ffi.io_events` - (rw[semantics_def, evaluate_def] +Theorem semantics_nil[simp]: + semantics ffi maxapp code co cc [] = Terminate Success ffi.io_events +Proof + rw[semantics_def, evaluate_def] \\ DEEP_INTRO_TAC some_intro - \\ rw[] \\ EVAL_TAC); + \\ rw[] \\ EVAL_TAC +QED -Theorem find_code_SUBMAP - `find_code dest vs code1 = SOME p ∧ code1 ⊑ code2 ⇒ - find_code dest vs code2 = SOME p` - (rw[closSemTheory.find_code_def, CaseEq"option", pair_case_eq] - \\ imp_res_tac FLOOKUP_SUBMAP); +Theorem find_code_SUBMAP: + find_code dest vs code1 = SOME p ∧ code1 ⊑ code2 ⇒ + find_code dest vs code2 = SOME p +Proof + rw[closSemTheory.find_code_def, CaseEq"option", pair_case_eq] + \\ imp_res_tac FLOOKUP_SUBMAP +QED val SUBMAP_rel_def = Define` SUBMAP_rel z1 z2 ⇔ @@ -2641,20 +2882,23 @@ val SUBMAP_rel_def = Define` (∀n. DISJOINT (FDOM z2.code) (set (MAP FST (SND (SND (z1.compile_oracle n))))) ∧ (∀m. m < n ⇒ DISJOINT (set (MAP FST (SND (SND (z1.compile_oracle m))))) (set (MAP FST (SND (SND (z1.compile_oracle n)))))))*)`; -Theorem find_code_SUBMAP_rel - `find_code dest vs s1.code = SOME p ∧ SUBMAP_rel s1 s2 ⇒ - find_code dest vs s2.code = SOME p` - (rw[SUBMAP_rel_def] - \\ imp_res_tac find_code_SUBMAP); +Theorem find_code_SUBMAP_rel: + find_code dest vs s1.code = SOME p ∧ SUBMAP_rel s1 s2 ⇒ + find_code dest vs s2.code = SOME p +Proof + rw[SUBMAP_rel_def] + \\ imp_res_tac find_code_SUBMAP +QED (* -Theorem do_install_SUBMAP - `do_install xs z1 = (r,s1) ∧ r ≠ Rerr (Rabort Rtype_error) ∧ +Theorem do_install_SUBMAP: + do_install xs z1 = (r,s1) ∧ r ≠ Rerr (Rabort Rtype_error) ∧ SUBMAP_rel z1 z2 ⇒ ∃s2. do_install xs z2 = (r,s2) ∧ - SUBMAP_rel s1 s2` - (rw[closSemTheory.do_install_def] + SUBMAP_rel s1 s2 +Proof + rw[closSemTheory.do_install_def] \\ fs[CaseEq"list",CaseEq"option"] \\ rw[] \\ pairarg_tac \\ fs[] \\ pairarg_tac \\ fs[] @@ -2675,7 +2919,8 @@ Theorem do_install_SUBMAP \\ fs[IN_DISJOINT, FDOM_FUPDATE_LIST] \\ CCONTR_TAC \\ fs[] \\ first_x_assum(qspec_then`0`mp_tac) \\ simp[] - \\ metis_tac[]); + \\ metis_tac[] +QED *) val do_app_lemma_simp = prove( @@ -2699,26 +2944,30 @@ val do_app_lemma = |> Q.INST [`opp`|->`op`,`s`|->`s1`,`t`|->`s2`,`ys`|->`xs`] |> SIMP_RULE std_ss [do_app_lemma_simp] -Theorem do_app_SUBMAP_Rerr - `∀op xs s1 s2 r. +Theorem do_app_SUBMAP_Rerr: + ∀op xs s1 s2 r. do_app op xs s1 = Rerr r ∧ SUBMAP_rel s1 s2 ⇒ - do_app op xs s2 = Rerr r` - (rw [] \\ imp_res_tac do_app_lemma - \\ pop_assum (assume_tac o SPEC_ALL) \\ rfs []); - -Theorem do_app_SUBMAP_Rval - `∀op xs s1 s2 r z1. + do_app op xs s2 = Rerr r +Proof + rw [] \\ imp_res_tac do_app_lemma + \\ pop_assum (assume_tac o SPEC_ALL) \\ rfs [] +QED + +Theorem do_app_SUBMAP_Rval: + ∀op xs s1 s2 r z1. do_app op xs s1 = Rval (r,z1) ∧ SUBMAP_rel s1 s2 ⇒ ∃z2. do_app op xs s2 = Rval (r,z2) ∧ - SUBMAP_rel z1 z2` - (rw [] \\ imp_res_tac do_app_lemma - \\ pop_assum (assume_tac o SPEC_ALL) \\ rfs []); + SUBMAP_rel z1 z2 +Proof + rw [] \\ imp_res_tac do_app_lemma + \\ pop_assum (assume_tac o SPEC_ALL) \\ rfs [] +QED -Theorem evaluate_code_SUBMAP - `(∀p x y (z1:('c, 'ffi)closSem$state) r s1 s2 (z2:('c,'ffi)closSem$state). +Theorem evaluate_code_SUBMAP: + (∀p x y (z1:('c, 'ffi)closSem$state) r s1 s2 (z2:('c,'ffi)closSem$state). p = (x,y,z1) ∧ closSem$evaluate (x,y,z1) = (r,s1) ∧ r ≠ Rerr (Rabort Rtype_error) ∧ @@ -2734,8 +2983,9 @@ Theorem evaluate_code_SUBMAP ⇒ ∃s2. evaluate_app w x y z2 = (r,s2) ∧ - SUBMAP_rel s1 s2)` - (ho_match_mp_tac closSemTheory.evaluate_ind + SUBMAP_rel s1 s2) +Proof + ho_match_mp_tac closSemTheory.evaluate_ind \\ rw[closSemTheory.evaluate_def] \\ TRY ( rename1`dest_closure` @@ -2806,7 +3056,8 @@ Theorem evaluate_code_SUBMAP *) \\ imp_res_tac do_app_SUBMAP_Rval \\ fs[] - \\ imp_res_tac do_app_SUBMAP_Rerr); + \\ imp_res_tac do_app_SUBMAP_Rerr +QED val obeys_max_app_def = tDefine"obeys_max_app"` (obeys_max_app m (Var _ _) ⇔ T) ∧ @@ -2913,10 +3164,12 @@ val _ = overload_on("any_dests",``app_call_dests NONE``); val app_call_dests_ind = theorem"app_call_dests_ind"; -Theorem app_call_dests_cons - `∀y x. app_call_dests opt (x::y) = - app_call_dests opt [x] ∪ app_call_dests opt y` - (Induct \\ rw[app_call_dests_def]); +Theorem app_call_dests_cons: + ∀y x. app_call_dests opt (x::y) = + app_call_dests opt [x] ∪ app_call_dests opt y +Proof + Induct \\ rw[app_call_dests_def] +QED val any_dest_cons = save_thm("any_dest_cons", app_call_dests_cons |> Q.INST [`opt`|->`NONE`]); @@ -2925,12 +3178,14 @@ val call_dest_cons = save_thm("call_dest_cons", val app_dest_cons = save_thm("app_dest_cons", app_call_dests_cons |> Q.INST [`opt`|->`SOME F`]); -Theorem app_call_dests_append - `∀l1 l2. app_call_dests opt (l1 ++ l2) = - app_call_dests opt l1 ∪ app_call_dests opt l2` - (Induct_on `l1` \\ fs [app_call_dests_def] +Theorem app_call_dests_append: + ∀l1 l2. app_call_dests opt (l1 ++ l2) = + app_call_dests opt l1 ∪ app_call_dests opt l2 +Proof + Induct_on `l1` \\ fs [app_call_dests_def] \\ once_rewrite_tac [app_call_dests_cons] - \\ fs [AC UNION_COMM UNION_ASSOC]); + \\ fs [AC UNION_COMM UNION_ASSOC] +QED val any_dest_append = save_thm("any_dest_append", app_call_dests_append |> Q.INST [`opt`|->`NONE`]); @@ -2939,20 +3194,24 @@ val call_dest_append = save_thm("call_dest_append", val app_dest_append = save_thm("app_dest_append", app_call_dests_append |> Q.INST [`opt`|->`SOME F`]); -Theorem app_call_dests_map - `∀ls. app_call_dests opt (MAP f ls) = - BIGUNION (set (MAP (λx. app_call_dests opt [f x]) ls))` - (Induct \\ rw[app_call_dests_def] - \\ rw[Once app_call_dests_cons]); - -Theorem any_dests_call_dests_app_dests - `!xs. any_dests xs = call_dests xs UNION app_dests xs` - (qid_spec_tac `opt:bool option` +Theorem app_call_dests_map: + ∀ls. app_call_dests opt (MAP f ls) = + BIGUNION (set (MAP (λx. app_call_dests opt [f x]) ls)) +Proof + Induct \\ rw[app_call_dests_def] + \\ rw[Once app_call_dests_cons] +QED + +Theorem any_dests_call_dests_app_dests: + !xs. any_dests xs = call_dests xs UNION app_dests xs +Proof + qid_spec_tac `opt:bool option` \\ ho_match_mp_tac app_call_dests_ind \\ fs [app_call_dests_def] \\ rw [] \\ fs [AC UNION_COMM UNION_ASSOC] \\ Cases_on `opt = SOME F` \\ fs [] - \\ fs [EXTENSION] \\ rw[] \\ eq_tac \\ rw [] \\ fs []); + \\ fs [EXTENSION] \\ rw[] \\ eq_tac \\ rw [] \\ fs [] +QED val get_code_labels_def = tDefine"get_code_labels" ` (get_code_labels (Var _ _) = {}) ∧ @@ -2999,11 +3258,12 @@ val get_code_labels_def = val code_locs_ind = theorem"code_locs_ind"; -Theorem get_code_labels_code_locs - `∀xs. EVERY no_Labels xs ∧ every_Fn_SOME xs ⇒ +Theorem get_code_labels_code_locs: + ∀xs. EVERY no_Labels xs ∧ every_Fn_SOME xs ⇒ BIGUNION (set (MAP get_code_labels xs)) = - set (code_locs xs) ∪ any_dests xs` - (recInduct code_locs_ind + set (code_locs xs) ∪ any_dests xs +Proof + recInduct code_locs_ind \\ rw[code_locs_def, app_call_dests_def] \\ fs[] >- ( rw[EXTENSION] \\ metis_tac[] ) >- ( rw[EXTENSION] \\ metis_tac[] ) @@ -3023,6 +3283,7 @@ Theorem get_code_labels_code_locs \\ rw[EXTENSION, MEM_GENLIST, MEM_MAP, PULL_EXISTS, code_locs_map, MEM_FLAT] \\ metis_tac[] ) >- ( rw[EXTENSION] \\ metis_tac[] ) - >- ( rw[EXTENSION] \\ metis_tac[] )); + >- ( rw[EXTENSION] \\ metis_tac[] ) +QED val _ = export_theory(); diff --git a/compiler/backend/semantics/closSemScript.sml b/compiler/backend/semantics/closSemScript.sml index 317c9b2658..b76472ae58 100644 --- a/compiler/backend/semantics/closSemScript.sml +++ b/compiler/backend/semantics/closSemScript.sml @@ -505,15 +505,19 @@ val case_eq_thms = LIST_CONJ (map prove_case_eq_thm val _ = save_thm ("case_eq_thms", case_eq_thms); -Theorem do_install_clock - `do_install vs s = (Rval e,s') ⇒ 0 < s.clock ∧ s'.clock = s.clock-1` - (rw[do_install_def,case_eq_thms] - \\ pairarg_tac \\ fs[case_eq_thms,pair_case_eq,bool_case_eq]); - -Theorem do_install_clock_less_eq - `do_install vs s = (res,s') ⇒ s'.clock <= s.clock` - (rw[do_install_def,case_eq_thms] \\ fs [] - \\ pairarg_tac \\ fs[case_eq_thms,pair_case_eq,bool_case_eq]); +Theorem do_install_clock: + do_install vs s = (Rval e,s') ⇒ 0 < s.clock ∧ s'.clock = s.clock-1 +Proof + rw[do_install_def,case_eq_thms] + \\ pairarg_tac \\ fs[case_eq_thms,pair_case_eq,bool_case_eq] +QED + +Theorem do_install_clock_less_eq: + do_install vs s = (res,s') ⇒ s'.clock <= s.clock +Proof + rw[do_install_def,case_eq_thms] \\ fs [] + \\ pairarg_tac \\ fs[case_eq_thms,pair_case_eq,bool_case_eq] +QED val evaluate_def = tDefine "evaluate" ` (evaluate ([],env:closSem$v list,^s) = (Rval [],s)) /\ @@ -645,16 +649,18 @@ val evaluate_app_NIL = save_thm( (* We prove that the clock never increases. *) -Theorem do_app_const - `(do_app op args s1 = Rval (res,s2)) ==> +Theorem do_app_const: + (do_app op args s1 = Rval (res,s2)) ==> (s2.clock = s1.clock) /\ (s2.max_app = s1.max_app) /\ (s2.code = s1.code) /\ (s2.compile_oracle = s1.compile_oracle) /\ - (s2.compile = s1.compile)` - (simp[do_app_def,case_eq_thms] + (s2.compile = s1.compile) +Proof + simp[do_app_def,case_eq_thms] \\ strip_tac \\ fs[] \\ rveq \\ fs[] - \\ every_case_tac \\ fs[] \\ rveq \\ fs[]); + \\ every_case_tac \\ fs[] \\ rveq \\ fs[] +QED val evaluate_ind = theorem"evaluate_ind"; @@ -674,18 +680,22 @@ val evaluate_clock_help = Q.prove ( \\ IMP_RES_TAC do_install_clock_less_eq \\ FULL_SIMP_TAC (srw_ss()) [dec_clock_def] \\ TRY DECIDE_TAC); -Theorem evaluate_clock -`(!xs env s1 vs s2. +Theorem evaluate_clock: + (!xs env s1 vs s2. (evaluate (xs,env,s1) = (vs,s2)) ==> s2.clock <= s1.clock) ∧ (!loc_opt f args s1 vs s2. - (evaluate_app loc_opt f args s1 = (vs,s2)) ==> s2.clock <= s1.clock)` -(metis_tac [evaluate_clock_help, SND]); - -Theorem fix_clock_evaluate - `fix_clock s (evaluate (xs,env,s)) = evaluate (xs,env,s)` - (Cases_on `evaluate (xs,env,s)` \\ fs [fix_clock_def] + (evaluate_app loc_opt f args s1 = (vs,s2)) ==> s2.clock <= s1.clock) +Proof +metis_tac [evaluate_clock_help, SND] +QED + +Theorem fix_clock_evaluate: + fix_clock s (evaluate (xs,env,s)) = evaluate (xs,env,s) +Proof + Cases_on `evaluate (xs,env,s)` \\ fs [fix_clock_def] \\ imp_res_tac evaluate_clock - \\ fs [MIN_DEF,theorem "state_component_equality"]); + \\ fs [MIN_DEF,theorem "state_component_equality"] +QED (* Finally, we remove fix_clock from the induction and definition theorems. *) diff --git a/compiler/backend/semantics/dataPropsScript.sml b/compiler/backend/semantics/dataPropsScript.sml index a992235bd1..31c6a791a3 100644 --- a/compiler/backend/semantics/dataPropsScript.sml +++ b/compiler/backend/semantics/dataPropsScript.sml @@ -7,74 +7,96 @@ val _ = new_theory"dataProps"; val s = ``s:('c,'ffi) dataSem$state`` -Theorem initial_state_simp[simp] - `(initial_state f c co cc k).clock = k ∧ +Theorem initial_state_simp[simp]: + (initial_state f c co cc k).clock = k ∧ (initial_state f c co cc k).locals = LN ∧ (initial_state f c co cc k).code = c ∧ (initial_state f c co cc k).ffi = f ∧ (initial_state f c co cc k).compile_oracle = co ∧ (initial_state f c co cc k).compile = cc ∧ - (initial_state f c co cc k).stack = []` - (srw_tac[][initial_state_def]); + (initial_state f c co cc k).stack = [] +Proof + srw_tac[][initial_state_def] +QED -Theorem initial_state_with_simp[simp] - `(initial_state f c co cc k with clock := k' = initial_state f c co cc k') ∧ +Theorem initial_state_with_simp[simp]: + (initial_state f c co cc k with clock := k' = initial_state f c co cc k') ∧ (initial_state f c co cc k with stack := [] = initial_state f c co cc k) ∧ - (initial_state f c co cc k with locals := LN = initial_state f c co cc k)` - (srw_tac[][initial_state_def]); - -Theorem Boolv_11[simp] - `dataSem$Boolv b1 = Boolv b2 ⇔ b1 = b2` - (EVAL_TAC>>srw_tac[][]); - -Theorem with_same_locals - `(s with locals := s.locals) = s` - (full_simp_tac(srw_ss())[state_component_equality]); + (initial_state f c co cc k with locals := LN = initial_state f c co cc k) +Proof + srw_tac[][initial_state_def] +QED + +Theorem Boolv_11[simp]: + dataSem$Boolv b1 = Boolv b2 ⇔ b1 = b2 +Proof + EVAL_TAC>>srw_tac[][] +QED + +Theorem with_same_locals: + (s with locals := s.locals) = s +Proof + full_simp_tac(srw_ss())[state_component_equality] +QED val var_corr_def = Define ` var_corr env corr t <=> EVERY2 (\v x. get_var v t = SOME x) corr env`; -Theorem get_vars_thm - `!vs a t2. var_corr a vs t2 ==> (get_vars vs t2 = SOME a)` - (Induct \\ Cases_on `a` \\ FULL_SIMP_TAC std_ss [get_vars_def] +Theorem get_vars_thm: + !vs a t2. var_corr a vs t2 ==> (get_vars vs t2 = SOME a) +Proof + Induct \\ Cases_on `a` \\ FULL_SIMP_TAC std_ss [get_vars_def] \\ FULL_SIMP_TAC (srw_ss()) [var_corr_def] \\ REPEAT STRIP_TAC - \\ RES_TAC \\ FULL_SIMP_TAC std_ss []); - -Theorem get_vars_append - `∀l1 l2 s. get_vars (l1 ++ l2) s = OPTION_BIND (get_vars l1 s)(λy1. OPTION_BIND (get_vars l2 s)(λy2. SOME(y1 ++ y2)))` - (Induct >> simp[get_vars_def,OPTION_BIND_SOME,ETA_AX] >> srw_tac[][] >> - BasicProvers.EVERY_CASE_TAC >> full_simp_tac(srw_ss())[]); - -Theorem get_vars_reverse - `∀ls s ys. get_vars ls s = SOME ys ⇒ get_vars (REVERSE ls) s = SOME (REVERSE ys)` - (Induct >> simp[get_vars_def] >> srw_tac[][get_vars_append] >> + \\ RES_TAC \\ FULL_SIMP_TAC std_ss [] +QED + +Theorem get_vars_append: + ∀l1 l2 s. get_vars (l1 ++ l2) s = OPTION_BIND (get_vars l1 s)(λy1. OPTION_BIND (get_vars l2 s)(λy2. SOME(y1 ++ y2))) +Proof + Induct >> simp[get_vars_def,OPTION_BIND_SOME,ETA_AX] >> srw_tac[][] >> + BasicProvers.EVERY_CASE_TAC >> full_simp_tac(srw_ss())[] +QED + +Theorem get_vars_reverse: + ∀ls s ys. get_vars ls s = SOME ys ⇒ get_vars (REVERSE ls) s = SOME (REVERSE ys) +Proof + Induct >> simp[get_vars_def] >> srw_tac[][get_vars_append] >> BasicProvers.EVERY_CASE_TAC >> full_simp_tac(srw_ss())[] >> - srw_tac[][get_vars_def]); + srw_tac[][get_vars_def] +QED -Theorem EVERY_get_vars - `!args s1 s2. +Theorem EVERY_get_vars: + !args s1 s2. EVERY (\a. lookup a s1 = lookup a s2) args ==> - (get_vars args s1 = get_vars args s2)` - (Induct \\ full_simp_tac(srw_ss())[get_vars_def,get_var_def] \\ REPEAT STRIP_TAC - \\ RES_TAC \\ FULL_SIMP_TAC std_ss []); - -Theorem get_vars_IMP_domain - `!args x s vs. MEM x args /\ (get_vars args s = SOME vs) ==> - x IN domain s` - (Induct \\ full_simp_tac(srw_ss())[get_vars_def,get_var_def] \\ REPEAT STRIP_TAC + (get_vars args s1 = get_vars args s2) +Proof + Induct \\ full_simp_tac(srw_ss())[get_vars_def,get_var_def] \\ REPEAT STRIP_TAC + \\ RES_TAC \\ FULL_SIMP_TAC std_ss [] +QED + +Theorem get_vars_IMP_domain: + !args x s vs. MEM x args /\ (get_vars args s = SOME vs) ==> + x IN domain s +Proof + Induct \\ full_simp_tac(srw_ss())[get_vars_def,get_var_def] \\ REPEAT STRIP_TAC \\ every_case_tac \\ full_simp_tac(srw_ss())[] \\ SRW_TAC [] [] - \\ full_simp_tac(srw_ss())[domain_lookup]); - -Theorem cut_state_opt_with_const - `(cut_state_opt x (y with stack := z) = OPTION_MAP (λs. s with stack := z) (cut_state_opt x y)) ∧ - (cut_state_opt x (y with clock := k) = OPTION_MAP (λs. s with clock := k) (cut_state_opt x y))` - (EVAL_TAC >> every_case_tac >> simp[]); - -Theorem consume_space_add_space - `consume_space k (add_space t k with locals := env1) = - SOME (t with <| locals := env1 ; space := 0 |>)` - (full_simp_tac(srw_ss())[consume_space_def,add_space_def,state_component_equality] \\ DECIDE_TAC); + \\ full_simp_tac(srw_ss())[domain_lookup] +QED + +Theorem cut_state_opt_with_const: + (cut_state_opt x (y with stack := z) = OPTION_MAP (λs. s with stack := z) (cut_state_opt x y)) ∧ + (cut_state_opt x (y with clock := k) = OPTION_MAP (λs. s with clock := k) (cut_state_opt x y)) +Proof + EVAL_TAC >> every_case_tac >> simp[] +QED + +Theorem consume_space_add_space: + consume_space k (add_space t k with locals := env1) = + SOME (t with <| locals := env1 ; space := 0 |>) +Proof + full_simp_tac(srw_ss())[consume_space_def,add_space_def,state_component_equality] \\ DECIDE_TAC +QED val consume_space_with_stack = Q.prove( `consume_space x (y with stack := z) = OPTION_MAP (λs. s with stack := z) (consume_space x y)`, @@ -155,47 +177,57 @@ val do_app_aux_const = Q.store_thm("do_app_aux_const", , PULL_EXISTS, UNCURRY,consume_space_def] \\ fs []); -Theorem do_app_err - `do_app op vs s = Rerr e ⇒ (e = Rabort Rtype_error) +Theorem do_app_err: + do_app op vs s = Rerr e ⇒ (e = Rabort Rtype_error) \/ - (?i x. op = FFI i /\ e = Rabort (Rffi_error x)) ` - (rw [ do_app_def,case_eq_thms + (?i x. op = FFI i /\ e = Rabort (Rffi_error x)) +Proof + rw [ do_app_def,case_eq_thms , do_install_def,do_space_def,with_fresh_ts_def , PULL_EXISTS, UNCURRY,consume_space_def] \\ fs [] - \\ METIS_TAC [do_app_aux_err]); + \\ METIS_TAC [do_app_aux_err] +QED -Theorem do_app_const - `do_app op vs x = Rval (y,z) ⇒ +Theorem do_app_const: + do_app op vs x = Rval (y,z) ⇒ z.stack = x.stack ∧ z.handler = x.handler ∧ z.locals = x.locals ∧ - z.clock = x.clock ∧ z.compile = x.compile` - (rw [ do_app_def,do_app_aux_def,case_eq_thms + z.clock = x.clock ∧ z.compile = x.compile +Proof + rw [ do_app_def,do_app_aux_def,case_eq_thms , do_install_def,do_space_def,with_fresh_ts_def , PULL_EXISTS, UNCURRY,consume_space_def] - \\ fs []); + \\ fs [] +QED -Theorem do_app_locals - `(do_app op x s = Rval (q,r)) ==> +Theorem do_app_locals: + (do_app op x s = Rval (q,r)) ==> (do_app op x (s with locals := extra) = - Rval (q,r with locals := extra))` - (rw [ do_app_def,do_app_aux_def,case_eq_thms + Rval (q,r with locals := extra)) +Proof + rw [ do_app_def,do_app_aux_def,case_eq_thms , do_install_def,do_space_def,with_fresh_ts_def , PULL_EXISTS, UNCURRY,consume_space_def] - \\ fs []); + \\ fs [] +QED -Theorem do_space_alt - `do_space op l s = +Theorem do_space_alt: + do_space op l s = if op_space_reset op then SOME (s with space := 0) - else consume_space (op_space_req op l) s` - (full_simp_tac(srw_ss())[do_space_def] \\ SRW_TAC [] [consume_space_def] - \\ full_simp_tac(srw_ss())[state_component_equality] \\ fs[] \\ DECIDE_TAC); - -Theorem Seq_Skip - `evaluate (Seq c Skip,s) = evaluate (c,s)` - (full_simp_tac(srw_ss())[evaluate_def] \\ Cases_on `evaluate (c,s)` \\ full_simp_tac(srw_ss())[LET_DEF] \\ SRW_TAC [] []); - -Theorem evaluate_stack_swap - `!c ^s. + else consume_space (op_space_req op l) s +Proof + full_simp_tac(srw_ss())[do_space_def] \\ SRW_TAC [] [consume_space_def] + \\ full_simp_tac(srw_ss())[state_component_equality] \\ fs[] \\ DECIDE_TAC +QED + +Theorem Seq_Skip: + evaluate (Seq c Skip,s) = evaluate (c,s) +Proof + full_simp_tac(srw_ss())[evaluate_def] \\ Cases_on `evaluate (c,s)` \\ full_simp_tac(srw_ss())[LET_DEF] \\ SRW_TAC [] [] +QED + +Theorem evaluate_stack_swap: + !c ^s. case evaluate (c,s) of | (SOME (Rerr(Rabort Rtype_error)),s1) => T | (SOME (Rerr(Rabort a)),s1) => (s1.stack = []) /\ @@ -215,8 +247,9 @@ Theorem evaluate_stack_swap | (res,s1) => (s1.stack = s.stack) /\ (s1.handler = s.handler) /\ (!xs. (LENGTH s.stack = LENGTH xs) ==> evaluate (c,s with stack := xs) = - (res, s1 with stack := xs))` - (recInduct evaluate_ind \\ REPEAT STRIP_TAC + (res, s1 with stack := xs)) +Proof + recInduct evaluate_ind \\ REPEAT STRIP_TAC THEN1 full_simp_tac(srw_ss())[evaluate_def] THEN1 ( full_simp_tac(srw_ss())[evaluate_def] >> EVAL_TAC >> @@ -428,39 +461,46 @@ Theorem evaluate_stack_swap \\ FIRST_X_ASSUM (MP_TAC o Q.SPEC `xs`) \\ SRW_TAC [] [] \\ full_simp_tac(srw_ss())[] \\ REV_FULL_SIMP_TAC std_ss [] \\ POP_ASSUM (fn th => full_simp_tac(srw_ss())[GSYM th]) - \\ REPEAT AP_TERM_TAC \\ full_simp_tac(srw_ss())[dataSemTheory.state_component_equality]))); + \\ REPEAT AP_TERM_TAC \\ full_simp_tac(srw_ss())[dataSemTheory.state_component_equality])) +QED -Theorem evaluate_stack - `!c ^s. +Theorem evaluate_stack: + !c ^s. case evaluate (c,s) of | (SOME (Rerr(Rabort Rtype_error)),s1) => T | (SOME (Rerr(Rabort _)),s1) => (s1.stack = []) | (SOME (Rerr _),s1) => (?s2. (jump_exc s = SOME s2) /\ (s2.locals = s1.locals) /\ (s2.stack = s1.stack) /\ (s2.handler = s1.handler)) - | (_,s1) => (s1.stack = s.stack) /\ (s1.handler = s.handler)` - (REPEAT STRIP_TAC \\ ASSUME_TAC (SPEC_ALL evaluate_stack_swap) - \\ every_case_tac \\ full_simp_tac(srw_ss())[]); - -Theorem evaluate_NONE_jump_exc - `(evaluate (c,^s) = (NONE,u1)) /\ (jump_exc u1 = SOME x) ==> + | (_,s1) => (s1.stack = s.stack) /\ (s1.handler = s.handler) +Proof + REPEAT STRIP_TAC \\ ASSUME_TAC (SPEC_ALL evaluate_stack_swap) + \\ every_case_tac \\ full_simp_tac(srw_ss())[] +QED + +Theorem evaluate_NONE_jump_exc: + (evaluate (c,^s) = (NONE,u1)) /\ (jump_exc u1 = SOME x) ==> (jump_exc s = SOME (s with <| stack := x.stack ; handler := x.handler ; - locals := x.locals |>))` - (REPEAT STRIP_TAC \\ MP_TAC (Q.SPECL [`c`,`s`] evaluate_stack) \\ full_simp_tac(srw_ss())[] + locals := x.locals |>)) +Proof + REPEAT STRIP_TAC \\ MP_TAC (Q.SPECL [`c`,`s`] evaluate_stack) \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[jump_exc_def] \\ REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[] \\ every_case_tac >> full_simp_tac(srw_ss())[] - \\ SRW_TAC [] []); + \\ SRW_TAC [] [] +QED -Theorem evaluate_NONE_jump_exc_ALT - `(evaluate (c,^s) = (NONE,u1)) /\ (jump_exc s = SOME x) ==> +Theorem evaluate_NONE_jump_exc_ALT: + (evaluate (c,^s) = (NONE,u1)) /\ (jump_exc s = SOME x) ==> (jump_exc u1 = SOME (u1 with <| stack := x.stack ; handler := x.handler ; - locals := x.locals |>))` - (REPEAT STRIP_TAC \\ MP_TAC (Q.SPECL [`c`,`s`] evaluate_stack) \\ full_simp_tac(srw_ss())[] + locals := x.locals |>)) +Proof + REPEAT STRIP_TAC \\ MP_TAC (Q.SPECL [`c`,`s`] evaluate_stack) \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[jump_exc_def] \\ REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[] \\ every_case_tac >> full_simp_tac(srw_ss())[] - \\ SRW_TAC [] []); + \\ SRW_TAC [] [] +QED val evaluate_locals_LN_lemma = Q.prove( `!c ^s. @@ -474,59 +514,72 @@ val evaluate_locals_LN_lemma = Q.prove( \\ SRW_TAC [] [] \\ full_simp_tac(srw_ss())[LET_DEF] \\ SRW_TAC [] [] \\ full_simp_tac(srw_ss())[] \\ Cases_on`a`>>full_simp_tac(srw_ss())[]); -Theorem evaluate_locals_LN - `!c ^s res t. +Theorem evaluate_locals_LN: + !c ^s res t. (evaluate (c,s) = (res,t)) /\ res <> NONE /\ res <> SOME (Rerr(Rabort Rtype_error)) ==> - (t.locals = LN) \/ ?t. res = SOME (Rerr(Rraise t))` - (REPEAT STRIP_TAC \\ MP_TAC (SPEC_ALL evaluate_locals_LN_lemma) \\ full_simp_tac(srw_ss())[]); + (t.locals = LN) \/ ?t. res = SOME (Rerr(Rraise t)) +Proof + REPEAT STRIP_TAC \\ MP_TAC (SPEC_ALL evaluate_locals_LN_lemma) \\ full_simp_tac(srw_ss())[] +QED val locals_ok_def = Define ` locals_ok l1 l2 = !v x. (sptree$lookup v l1 = SOME x) ==> (sptree$lookup v l2 = SOME x)`; -Theorem locals_ok_IMP - `locals_ok l1 l2 ==> domain l1 SUBSET domain l2` - (full_simp_tac(srw_ss())[locals_ok_def,SUBSET_DEF,domain_lookup] \\ METIS_TAC []); +Theorem locals_ok_IMP: + locals_ok l1 l2 ==> domain l1 SUBSET domain l2 +Proof + full_simp_tac(srw_ss())[locals_ok_def,SUBSET_DEF,domain_lookup] \\ METIS_TAC [] +QED -Theorem locals_ok_refl - `!l. locals_ok l l` - (full_simp_tac(srw_ss())[locals_ok_def]); +Theorem locals_ok_refl: + !l. locals_ok l l +Proof + full_simp_tac(srw_ss())[locals_ok_def] +QED -Theorem locals_ok_cut_env - `locals_ok l1 l2 /\ +Theorem locals_ok_cut_env: + locals_ok l1 l2 /\ (cut_env names l1 = SOME x) ==> - (cut_env names l2 = SOME x)` - (full_simp_tac(srw_ss())[cut_env_def] \\ SRW_TAC [] [] + (cut_env names l2 = SOME x) +Proof + full_simp_tac(srw_ss())[cut_env_def] \\ SRW_TAC [] [] THEN1 (IMP_RES_TAC locals_ok_IMP \\ IMP_RES_TAC SUBSET_TRANS) \\ full_simp_tac(srw_ss())[lookup_inter_alt] \\ SRW_TAC [] [] \\ full_simp_tac(srw_ss())[locals_ok_def,domain_lookup,SUBSET_DEF,PULL_EXISTS] - \\ full_simp_tac(srw_ss())[oneTheory.one] \\ RES_TAC \\ RES_TAC \\ full_simp_tac(srw_ss())[]); + \\ full_simp_tac(srw_ss())[oneTheory.one] \\ RES_TAC \\ RES_TAC \\ full_simp_tac(srw_ss())[] +QED -Theorem locals_ok_get_var - `locals_ok s l /\ +Theorem locals_ok_get_var: + locals_ok s l /\ (get_var x s = SOME w) ==> - (get_var x l = SOME w)` - (full_simp_tac(srw_ss())[locals_ok_def,get_var_def]); + (get_var x l = SOME w) +Proof + full_simp_tac(srw_ss())[locals_ok_def,get_var_def] +QED -Theorem locals_ok_get_vars - `!x w. +Theorem locals_ok_get_vars: + !x w. locals_ok s l /\ (get_vars x s = SOME w) ==> - (get_vars x l = SOME w)` - (Induct \\ full_simp_tac(srw_ss())[get_vars_def] \\ REPEAT STRIP_TAC + (get_vars x l = SOME w) +Proof + Induct \\ full_simp_tac(srw_ss())[get_vars_def] \\ REPEAT STRIP_TAC \\ Cases_on `get_var h s` \\ full_simp_tac(srw_ss())[] \\ Cases_on `get_vars x s` \\ full_simp_tac(srw_ss())[] - \\ IMP_RES_TAC locals_ok_get_var \\ full_simp_tac(srw_ss())[]); + \\ IMP_RES_TAC locals_ok_get_var \\ full_simp_tac(srw_ss())[] +QED -Theorem evaluate_locals - `!c s res s2 vars l. +Theorem evaluate_locals: + !c s res s2 vars l. res <> SOME (Rerr(Rabort Rtype_error)) /\ (evaluate (c,s) = (res,s2)) /\ locals_ok s.locals l ==> ?w. (evaluate (c, s with locals := l) = (res,if res = NONE then s2 with locals := w else s2)) /\ - locals_ok s2.locals w` - (recInduct evaluate_ind \\ REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[evaluate_def] + locals_ok s2.locals w +Proof + recInduct evaluate_ind \\ REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[evaluate_def] THEN1 (* Skip *) (METIS_TAC []) THEN1 (* Move *) (Cases_on `get_var src s.locals` \\ full_simp_tac(srw_ss())[] \\ SRW_TAC [] [] @@ -610,23 +663,27 @@ Theorem evaluate_locals \\ full_simp_tac(srw_ss())[state_component_equality,dec_clock_def,call_env_def,push_env_def]) \\ Cases_on `s.clock = 0` \\ full_simp_tac(srw_ss())[] \\ SRW_TAC [] [] \\ full_simp_tac(srw_ss())[call_env_def,locals_ok_def,lookup_def,fromList_def] - \\ full_simp_tac(srw_ss())[] \\ METIS_TAC [locals_ok_refl,with_same_locals])); + \\ full_simp_tac(srw_ss())[] \\ METIS_TAC [locals_ok_refl,with_same_locals]) +QED -Theorem funpow_dec_clock_clock - `!n s. FUNPOW dec_clock n s = (s with clock := s.clock - n)` - (Induct_on `n` >> +Theorem funpow_dec_clock_clock: + !n s. FUNPOW dec_clock n s = (s with clock := s.clock - n) +Proof + Induct_on `n` >> srw_tac[][FUNPOW, state_component_equality, dec_clock_def, ADD1] >> - decide_tac); + decide_tac +QED -Theorem evaluate_mk_ticks - `!p s n. +Theorem evaluate_mk_ticks: + !p s n. evaluate (mk_ticks n p, s) = if s.clock < n then (SOME (Rerr(Rabort Rtimeout_error)), s with <| clock := 0; locals := fromList []; stack := [] |>) else - evaluate (p, FUNPOW dec_clock n s)` - (Induct_on `n` >> + evaluate (p, FUNPOW dec_clock n s) +Proof + Induct_on `n` >> srw_tac[][evaluate_def, mk_ticks_def, FUNPOW] >> full_simp_tac(srw_ss())[mk_ticks_def, evaluate_def] >> srw_tac[][funpow_dec_clock_clock, dec_clock_def] >> @@ -635,10 +692,11 @@ Theorem evaluate_mk_ticks `s.clock - (n+1) = 0` by decide_tac >> srw_tac[][] >> full_simp_tac(srw_ss())[ADD1, LESS_OR_EQ] >> - full_simp_tac (srw_ss()++ARITH_ss) []); + full_simp_tac (srw_ss()++ARITH_ss) [] +QED -Theorem FUNPOW_dec_clock_code[simp] - `((FUNPOW dec_clock n t).code = t.code) /\ +Theorem FUNPOW_dec_clock_code[simp]: + ((FUNPOW dec_clock n t).code = t.code) /\ ((FUNPOW dec_clock n t).stack = t.stack) /\ ((FUNPOW dec_clock n t).handler = t.handler) /\ ((FUNPOW dec_clock n t).refs = t.refs) /\ @@ -647,34 +705,43 @@ Theorem FUNPOW_dec_clock_code[simp] ((FUNPOW dec_clock n t).locals = t.locals) /\ ((FUNPOW dec_clock n t).compile = t.compile) /\ ((FUNPOW dec_clock n t).compile_oracle = t.compile_oracle) /\ - ((FUNPOW dec_clock n t).clock = t.clock - n)` - (Induct_on `n` \\ full_simp_tac(srw_ss())[FUNPOW_SUC,dec_clock_def] \\ DECIDE_TAC); - -Theorem jump_exc_NONE - `(jump_exc (t with locals := x) = NONE <=> jump_exc t = NONE) /\ - (jump_exc (t with clock := c) = NONE <=> jump_exc t = NONE)` - (FULL_SIMP_TAC (srw_ss()) [jump_exc_def] \\ REPEAT STRIP_TAC - \\ every_case_tac \\ FULL_SIMP_TAC std_ss []); - -Theorem jump_exc_IMP - `(jump_exc s = SOME t) ==> + ((FUNPOW dec_clock n t).clock = t.clock - n) +Proof + Induct_on `n` \\ full_simp_tac(srw_ss())[FUNPOW_SUC,dec_clock_def] \\ DECIDE_TAC +QED + +Theorem jump_exc_NONE: + (jump_exc (t with locals := x) = NONE <=> jump_exc t = NONE) /\ + (jump_exc (t with clock := c) = NONE <=> jump_exc t = NONE) +Proof + FULL_SIMP_TAC (srw_ss()) [jump_exc_def] \\ REPEAT STRIP_TAC + \\ every_case_tac \\ FULL_SIMP_TAC std_ss [] +QED + +Theorem jump_exc_IMP: + (jump_exc s = SOME t) ==> s.handler < LENGTH s.stack /\ ?n e xs. (LASTN (s.handler + 1) s.stack = Exc e n::xs) /\ - (t = s with <|handler := n; locals := e; stack := xs|>)` - (SIMP_TAC std_ss [jump_exc_def] + (t = s with <|handler := n; locals := e; stack := xs|>) +Proof + SIMP_TAC std_ss [jump_exc_def] \\ Cases_on `LASTN (s.handler + 1) s.stack` \\ full_simp_tac(srw_ss())[] - \\ Cases_on `h` \\ full_simp_tac(srw_ss())[]); + \\ Cases_on `h` \\ full_simp_tac(srw_ss())[] +QED -Theorem do_app_Rerr - `dataSem$do_app op vs s = Rerr e ⇒ (e = Rabort Rtype_error) +Theorem do_app_Rerr: + dataSem$do_app op vs s = Rerr e ⇒ (e = Rabort Rtype_error) \/ - (?i x. op = FFI i /\ e = Rabort (Rffi_error x)) ` - (strip_tac \\ imp_res_tac do_app_err \\ fs []); - -Theorem do_app_with_clock - `do_app op vs (s with clock := z) = - map_result (λ(x,y). (x,y with clock := z)) I (do_app op vs s)` - (Cases_on `op = Install` THEN1 + (?i x. op = FFI i /\ e = Rabort (Rffi_error x)) +Proof + strip_tac \\ imp_res_tac do_app_err \\ fs [] +QED + +Theorem do_app_with_clock: + do_app op vs (s with clock := z) = + map_result (λ(x,y). (x,y with clock := z)) I (do_app op vs s) +Proof + Cases_on `op = Install` THEN1 (fs [do_app_def,do_install_def] \\ every_case_tac \\ fs [] \\ pairarg_tac \\ fs [] @@ -688,12 +755,14 @@ Theorem do_app_with_clock ffiTheory.ffi_result_case_eq,ffiTheory.oracle_result_case_eq, semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq, pair_case_eq,consume_space_def] >> - rveq >> fs [])); - -Theorem do_app_change_clock - `(do_app op args s1 = Rval (res,s2)) ==> - (do_app op args (s1 with clock := ck) = Rval (res,s2 with clock := ck))` - (Cases_on `op = Install` THEN1 + rveq >> fs []) +QED + +Theorem do_app_change_clock: + (do_app op args s1 = Rval (res,s2)) ==> + (do_app op args (s1 with clock := ck) = Rval (res,s2 with clock := ck)) +Proof + Cases_on `op = Install` THEN1 (fs [do_app_def,do_install_def] \\ every_case_tac \\ fs [] \\ pairarg_tac \\ fs [] @@ -706,12 +775,14 @@ Theorem do_app_change_clock ffiTheory.ffi_result_case_eq,ffiTheory.oracle_result_case_eq, semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq, pair_case_eq,consume_space_def] >> - rveq >> fs [])); - -Theorem do_app_change_clock_err - `(do_app op args s1 = Rerr e) ==> - (do_app op args (s1 with clock := ck) = Rerr e)` - (Cases_on `op = Install` THEN1 + rveq >> fs []) +QED + +Theorem do_app_change_clock_err: + (do_app op args s1 = Rerr e) ==> + (do_app op args (s1 with clock := ck) = Rerr e) +Proof + Cases_on `op = Install` THEN1 (fs [do_app_def,do_install_def] \\ every_case_tac \\ fs [] \\ pairarg_tac \\ fs [] @@ -724,27 +795,35 @@ Theorem do_app_change_clock_err ffiTheory.ffi_result_case_eq,ffiTheory.oracle_result_case_eq, semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq, pair_case_eq,consume_space_def] >> - rveq >> fs [])); - -Theorem cut_state_eq_some - `cut_state names s = SOME y ⇔ ∃z. cut_env names s.locals = SOME z ∧ y = s with locals := z` - (srw_tac[][cut_state_def] >> every_case_tac >> full_simp_tac(srw_ss())[EQ_IMP_THM]); - -Theorem cut_state_eq_none - `cut_state names s = NONE ⇔ cut_env names s.locals = NONE` - (srw_tac[][cut_state_def] >> every_case_tac >> full_simp_tac(srw_ss())[EQ_IMP_THM]); - -Theorem with_same_clock[simp] - `^s with clock := s.clock = s` - (srw_tac[][state_component_equality]); - -Theorem evaluate_add_clock - `!exps s1 res s2. + rveq >> fs []) +QED + +Theorem cut_state_eq_some: + cut_state names s = SOME y ⇔ ∃z. cut_env names s.locals = SOME z ∧ y = s with locals := z +Proof + srw_tac[][cut_state_def] >> every_case_tac >> full_simp_tac(srw_ss())[EQ_IMP_THM] +QED + +Theorem cut_state_eq_none: + cut_state names s = NONE ⇔ cut_env names s.locals = NONE +Proof + srw_tac[][cut_state_def] >> every_case_tac >> full_simp_tac(srw_ss())[EQ_IMP_THM] +QED + +Theorem with_same_clock[simp]: + ^s with clock := s.clock = s +Proof + srw_tac[][state_component_equality] +QED + +Theorem evaluate_add_clock: + !exps s1 res s2. evaluate (exps,s1) = (res, s2) ∧ res ≠ SOME(Rerr(Rabort Rtimeout_error)) ⇒ - !ck. evaluate (exps,s1 with clock := s1.clock + ck) = (res, s2 with clock := s2.clock + ck)` - (recInduct evaluate_ind >> srw_tac[][evaluate_def] + !ck. evaluate (exps,s1 with clock := s1.clock + ck) = (res, s2 with clock := s2.clock + ck) +Proof + recInduct evaluate_ind >> srw_tac[][evaluate_def] >- ( every_case_tac >> full_simp_tac(srw_ss())[get_var_def,set_var_def] >> srw_tac[][] >> full_simp_tac(srw_ss())[] ) >- ( @@ -778,29 +857,37 @@ Theorem evaluate_add_clock fsrw_tac[ARITH_ss][call_env_def,dec_clock_def,push_env_def,pop_env_def,set_var_def] >> first_x_assum(qspec_then`ck`mp_tac) >> simp[] >> every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> rev_full_simp_tac(srw_ss())[] >> full_simp_tac(srw_ss())[] >> - spose_not_then strip_assume_tac >> full_simp_tac(srw_ss())[])) - -Theorem set_var_const[simp] - `(set_var x y z).ffi = z.ffi ∧ - (set_var x y z).clock = z.clock` - (EVAL_TAC) - -Theorem set_var_with_const - `(set_var x y (z with clock := k)) = set_var x y z with clock := k` - (EVAL_TAC) - -Theorem cut_state_opt_const - `cut_state_opt x y = SOME z ⇒ + spose_not_then strip_assume_tac >> full_simp_tac(srw_ss())[]) +QED + +Theorem set_var_const[simp]: + (set_var x y z).ffi = z.ffi ∧ + (set_var x y z).clock = z.clock +Proof + EVAL_TAC +QED + +Theorem set_var_with_const: + (set_var x y (z with clock := k)) = set_var x y z with clock := k +Proof + EVAL_TAC +QED + +Theorem cut_state_opt_const: + cut_state_opt x y = SOME z ⇒ z.ffi = y.ffi ∧ - z.global = y.global` - (EVAL_TAC >> + z.global = y.global +Proof + EVAL_TAC >> every_case_tac >> EVAL_TAC >> - srw_tac[][] >> srw_tac[][]); - -Theorem do_app_io_events_mono - `do_app x y z = Rval (a,b) ⇒ - z.ffi.io_events ≼ b.ffi.io_events` - (Cases_on `x = Install` THEN1 + srw_tac[][] >> srw_tac[][] +QED + +Theorem do_app_io_events_mono: + do_app x y z = Rval (a,b) ⇒ + z.ffi.io_events ≼ b.ffi.io_events +Proof + Cases_on `x = Install` THEN1 (fs [do_app_def,do_install_def] \\ every_case_tac \\ fs [] \\ pairarg_tac \\ fs [] @@ -814,64 +901,84 @@ Theorem do_app_io_events_mono ffiTheory.ffi_result_case_eq,ffiTheory.oracle_result_case_eq, semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq, pair_case_eq,consume_space_def] >> - rveq >> fs [])); - -Theorem call_env_const[simp] - `(call_env x y).ffi = y.ffi ∧ - (call_env x y).clock = y.clock` - (EVAL_TAC); - -Theorem call_env_with_const - `(call_env x (y with clock := z)) = call_env x y with clock := z` - (EVAL_TAC); - -Theorem dec_clock_const[simp] - `(dec_clock s).ffi = s.ffi` - (EVAL_TAC); - -Theorem add_space_const[simp] - `(add_space s k).ffi = s.ffi` - (EVAL_TAC); - -Theorem push_env_const[simp] - `(push_env x y z).ffi = z.ffi ∧ - (push_env x y z).clock = z.clock` - (Cases_on`y`>> EVAL_TAC); - -Theorem push_env_with_const - `(push_env x y (z with clock := k)) = (push_env x y z) with clock := k` - (Cases_on`y`>>EVAL_TAC); - -Theorem pop_env_const - `pop_env a = SOME b ⇒ - b.ffi = a.ffi` - (EVAL_TAC >> + rveq >> fs []) +QED + +Theorem call_env_const[simp]: + (call_env x y).ffi = y.ffi ∧ + (call_env x y).clock = y.clock +Proof + EVAL_TAC +QED + +Theorem call_env_with_const: + (call_env x (y with clock := z)) = call_env x y with clock := z +Proof + EVAL_TAC +QED + +Theorem dec_clock_const[simp]: + (dec_clock s).ffi = s.ffi +Proof + EVAL_TAC +QED + +Theorem add_space_const[simp]: + (add_space s k).ffi = s.ffi +Proof + EVAL_TAC +QED + +Theorem push_env_const[simp]: + (push_env x y z).ffi = z.ffi ∧ + (push_env x y z).clock = z.clock +Proof + Cases_on`y`>> EVAL_TAC +QED + +Theorem push_env_with_const: + (push_env x y (z with clock := k)) = (push_env x y z) with clock := k +Proof + Cases_on`y`>>EVAL_TAC +QED + +Theorem pop_env_const: + pop_env a = SOME b ⇒ + b.ffi = a.ffi +Proof + EVAL_TAC >> every_case_tac >> EVAL_TAC >> - srw_tac[][] >> srw_tac[][]); + srw_tac[][] >> srw_tac[][] +QED -Theorem evaluate_io_events_mono - `!exps s1 res s2. +Theorem evaluate_io_events_mono: + !exps s1 res s2. evaluate (exps,s1) = (res, s2) ⇒ - s1.ffi.io_events ≼ s2.ffi.io_events` - (recInduct evaluate_ind >> srw_tac[][evaluate_def] >> + s1.ffi.io_events ≼ s2.ffi.io_events +Proof + recInduct evaluate_ind >> srw_tac[][evaluate_def] >> every_case_tac >> full_simp_tac(srw_ss())[LET_THM] >> srw_tac[][] >> rev_full_simp_tac(srw_ss())[] >> TRY (pairarg_tac >> full_simp_tac(srw_ss())[] >> every_case_tac >> full_simp_tac(srw_ss())[])>> imp_res_tac cut_state_opt_const >>full_simp_tac(srw_ss())[] >> imp_res_tac pop_env_const >>full_simp_tac(srw_ss())[] >> imp_res_tac jump_exc_IMP >> full_simp_tac(srw_ss())[] >> imp_res_tac do_app_io_events_mono >>full_simp_tac(srw_ss())[] >> rev_full_simp_tac(srw_ss())[] >> - metis_tac[IS_PREFIX_TRANS]); + metis_tac[IS_PREFIX_TRANS] +QED -Theorem with_clock_ffi - `(^s with clock := y).ffi = s.ffi` - (EVAL_TAC) +Theorem with_clock_ffi: + (^s with clock := y).ffi = s.ffi +Proof + EVAL_TAC +QED -Theorem evaluate_add_clock_io_events_mono - `∀exps s extra. +Theorem evaluate_add_clock_io_events_mono: + ∀exps s extra. (SND(evaluate(exps,s))).ffi.io_events ≼ - (SND(evaluate(exps,s with clock := s.clock + extra))).ffi.io_events` - (recInduct evaluate_ind >> + (SND(evaluate(exps,s with clock := s.clock + extra))).ffi.io_events +Proof + recInduct evaluate_ind >> srw_tac[][evaluate_def,LET_THM] >> TRY ( rename1`find_code` >> @@ -896,11 +1003,13 @@ Theorem evaluate_add_clock_io_events_mono rveq >> full_simp_tac(srw_ss())[] >> imp_res_tac evaluate_io_events_mono >> rev_full_simp_tac(srw_ss())[] >> fs [] >> imp_res_tac jump_exc_IMP >> rw[jump_exc_NONE] >> - metis_tac[evaluate_io_events_mono,IS_PREFIX_TRANS,SND,PAIR]); + metis_tac[evaluate_io_events_mono,IS_PREFIX_TRANS,SND,PAIR] +QED -Theorem semantics_Div_IMP_LPREFIX - `semantics ffi prog co cc start = Diverge l ==> LPREFIX (fromList ffi.io_events) l` - (simp[semantics_def] +Theorem semantics_Div_IMP_LPREFIX: + semantics ffi prog co cc start = Diverge l ==> LPREFIX (fromList ffi.io_events) l +Proof + simp[semantics_def] \\ IF_CASES_TAC \\ fs[] \\ DEEP_INTRO_TAC some_intro \\ fs[] \\ rw[] @@ -921,21 +1030,26 @@ Theorem semantics_Div_IMP_LPREFIX \\ qspecl_then[`k1`,`k2`]mp_tac LESS_EQ_CASES \\ simp[LESS_EQ_EXISTS] \\ metis_tac[evaluate_add_clock_io_events_mono, - initial_state_simp,initial_state_with_simp]); + initial_state_simp,initial_state_with_simp] +QED -Theorem semantics_Term_IMP_PREFIX - `semantics ffi prog co cc start = Terminate tt l ==> ffi.io_events ≼ l` - (simp[semantics_def] \\ IF_CASES_TAC \\ fs[] +Theorem semantics_Term_IMP_PREFIX: + semantics ffi prog co cc start = Terminate tt l ==> ffi.io_events ≼ l +Proof + simp[semantics_def] \\ IF_CASES_TAC \\ fs[] \\ DEEP_INTRO_TAC some_intro \\ fs[] \\ rw[] - \\ imp_res_tac evaluate_io_events_mono \\ fs[]); - -Theorem Resource_limit_hit_implements_semantics - `implements {Terminate Resource_limit_hit ffi.io_events} - {semantics ffi (fromAList prog) co cc start}` - (fs [implements_def,extend_with_resource_limit_def] + \\ imp_res_tac evaluate_io_events_mono \\ fs[] +QED + +Theorem Resource_limit_hit_implements_semantics: + implements {Terminate Resource_limit_hit ffi.io_events} + {semantics ffi (fromAList prog) co cc start} +Proof + fs [implements_def,extend_with_resource_limit_def] \\ Cases_on `semantics ffi (fromAList prog) co cc start` \\ fs [] \\ imp_res_tac semantics_Div_IMP_LPREFIX \\ fs [] - \\ imp_res_tac semantics_Term_IMP_PREFIX \\ fs []); + \\ imp_res_tac semantics_Term_IMP_PREFIX \\ fs [] +QED val get_code_labels_def = Define` (get_code_labels (Call r d a h) = @@ -952,12 +1066,14 @@ val good_code_labels_def = Define` (BIGUNION (set (MAP (λ(n,m,pp). (get_code_labels pp)) p))) ⊆ (set (MAP FST p))` -Theorem get_code_labels_mk_ticks - `∀n m. get_code_labels (mk_ticks n m) ⊆ get_code_labels m` - (Induct +Theorem get_code_labels_mk_ticks: + ∀n m. get_code_labels (mk_ticks n m) ⊆ get_code_labels m +Proof + Induct \\ rw[dataLangTheory.mk_ticks_def] \\ rw[FUNPOW] \\ fs[dataLangTheory.mk_ticks_def] \\ first_x_assum (qspec_then`Seq Tick m`mp_tac) - \\ rw[]); + \\ rw[] +QED val _ = export_theory(); diff --git a/compiler/backend/semantics/dataSemScript.sml b/compiler/backend/semantics/dataSemScript.sml index 3518db9b21..c60c99248a 100644 --- a/compiler/backend/semantics/dataSemScript.sml +++ b/compiler/backend/semantics/dataSemScript.sml @@ -607,9 +607,10 @@ val case_eq_thms = LIST_CONJ (pair_case_eq::bool_case_eq::(List.map prove_case_e ffi_result_thms])) |> curry save_thm"case_eq_thms"; -Theorem do_app_clock - `(dataSem$do_app op args s1 = Rval (res,s2)) ==> s2.clock <= s1.clock` - (rw[ do_app_def +Theorem do_app_clock: + (dataSem$do_app op args s1 = Rval (res,s2)) ==> s2.clock <= s1.clock +Proof + rw[ do_app_def , do_app_aux_def , do_space_def , consume_space_def @@ -618,11 +619,13 @@ Theorem do_app_clock , PULL_EXISTS , with_fresh_ts_def ,UNCURRY] - \\ rw[]); + \\ rw[] +QED -Theorem evaluate_clock -`!xs s1 vs s2. (evaluate (xs,s1) = (vs,s2)) ==> s2.clock <= s1.clock` - (recInduct evaluate_ind >> rw[evaluate_def] >> +Theorem evaluate_clock: + !xs s1 vs s2. (evaluate (xs,s1) = (vs,s2)) ==> s2.clock <= s1.clock +Proof + recInduct evaluate_ind >> rw[evaluate_def] >> every_case_tac >> full_simp_tac(srw_ss())[set_var_def,cut_state_opt_def,cut_state_def,call_env_def,dec_clock_def,add_space_def,jump_exc_def,push_env_clock] >> rw[] >> rfs[] >> imp_res_tac fix_clock_IMP >> fs[] >> @@ -632,22 +635,27 @@ Theorem evaluate_clock every_case_tac >> rw[] >> simp[] >> rfs[] >> first_assum(split_uncurry_arg_tac o lhs o concl) >> full_simp_tac(srw_ss())[] \\ every_case_tac >> full_simp_tac(srw_ss())[] - \\ imp_res_tac fix_clock_IMP >> full_simp_tac(srw_ss())[] >> simp[] >> rfs[]); + \\ imp_res_tac fix_clock_IMP >> full_simp_tac(srw_ss())[] >> simp[] >> rfs[] +QED -Theorem fix_clock_evaluate - `fix_clock s (evaluate (xs,s)) = evaluate (xs,s)` - (Cases_on `evaluate (xs,s)` \\ fs [fix_clock_def] +Theorem fix_clock_evaluate: + fix_clock s (evaluate (xs,s)) = evaluate (xs,s) +Proof + Cases_on `evaluate (xs,s)` \\ fs [fix_clock_def] \\ imp_res_tac evaluate_clock - \\ fs [MIN_DEF,theorem "state_component_equality"]); - -Theorem fix_clock_evaluate_call - `fix_clock s (evaluate (prog,call_env args1 (push_env env h (dec_clock s)))) = - (evaluate (prog,call_env args1 (push_env env h (dec_clock s))))` - (Cases_on `(evaluate (prog,call_env args1 (push_env env h (dec_clock s))))` + \\ fs [MIN_DEF,theorem "state_component_equality"] +QED + +Theorem fix_clock_evaluate_call: + fix_clock s (evaluate (prog,call_env args1 (push_env env h (dec_clock s)))) = + (evaluate (prog,call_env args1 (push_env env h (dec_clock s)))) +Proof + Cases_on `(evaluate (prog,call_env args1 (push_env env h (dec_clock s))))` >> fs [fix_clock_def] >> imp_res_tac evaluate_clock >> fs[MIN_DEF,theorem "state_component_equality",call_env_def,dec_clock_def,push_env_clock] - >> imp_res_tac push_env_clock); + >> imp_res_tac push_env_clock +QED (* Finally, we remove fix_clock from the induction and definition theorems. *) diff --git a/compiler/backend/semantics/flatPropsScript.sml b/compiler/backend/semantics/flatPropsScript.sml index db7c5d7354..63944a80e8 100644 --- a/compiler/backend/semantics/flatPropsScript.sml +++ b/compiler/backend/semantics/flatPropsScript.sml @@ -9,31 +9,36 @@ in end val _ = new_theory"flatProps" -Theorem ctor_same_type_OPTREL - `∀c1 c2. ctor_same_type c1 c2 ⇔ OPTREL (inv_image $= SND) c1 c2` - (Cases \\ Cases \\ simp[OPTREL_def,ctor_same_type_def] +Theorem ctor_same_type_OPTREL: + ∀c1 c2. ctor_same_type c1 c2 ⇔ OPTREL (inv_image $= SND) c1 c2 +Proof + Cases \\ Cases \\ simp[OPTREL_def,ctor_same_type_def] \\ rename1`_ (SOME p1) (SOME p2)` \\ Cases_on`p1` \\ Cases_on`p2` - \\ EVAL_TAC); - -Theorem pat_bindings_accum - `(∀p acc. flatSem$pat_bindings p acc = pat_bindings p [] ⧺ acc) ∧ - ∀ps acc. pats_bindings ps acc = pats_bindings ps [] ⧺ acc` - (ho_match_mp_tac flatLangTheory.pat_induction >> + \\ EVAL_TAC +QED + +Theorem pat_bindings_accum: + (∀p acc. flatSem$pat_bindings p acc = pat_bindings p [] ⧺ acc) ∧ + ∀ps acc. pats_bindings ps acc = pats_bindings ps [] ⧺ acc +Proof + ho_match_mp_tac flatLangTheory.pat_induction >> rw [] >> REWRITE_TAC [flatSemTheory.pat_bindings_def] >> - metis_tac [APPEND, APPEND_ASSOC]); + metis_tac [APPEND, APPEND_ASSOC] +QED -Theorem pmatch_extend - `(!cenv s p v env env' env''. +Theorem pmatch_extend: + (!cenv s p v env env' env''. pmatch cenv s p v env = Match env' ⇒ ?env''. env' = env'' ++ env ∧ MAP FST env'' = pat_bindings p []) ∧ (!cenv s ps vs env env' env''. pmatch_list cenv s ps vs env = Match env' ⇒ - ?env''. env' = env'' ++ env ∧ MAP FST env'' = pats_bindings ps [])` - (ho_match_mp_tac pmatch_ind >> + ?env''. env' = env'' ++ env ∧ MAP FST env'' = pats_bindings ps []) +Proof + ho_match_mp_tac pmatch_ind >> srw_tac[][pat_bindings_def, pmatch_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> @@ -41,99 +46,117 @@ Theorem pmatch_extend res_tac >> qexists_tac `env'''++env''` >> srw_tac[][] >> - metis_tac [pat_bindings_accum]); + metis_tac [pat_bindings_accum] +QED -Theorem pmatch_bindings - `(∀cenv s p v env r. +Theorem pmatch_bindings: + (∀cenv s p v env r. flatSem$pmatch cenv s p v env = Match r ⇒ MAP FST r = pat_bindings p [] ++ MAP FST env) ∧ ∀cenv s ps vs env r. flatSem$pmatch_list cenv s ps vs env = Match r ⇒ - MAP FST r = pats_bindings ps [] ++ MAP FST env` - (ho_match_mp_tac flatSemTheory.pmatch_ind >> + MAP FST r = pats_bindings ps [] ++ MAP FST env +Proof + ho_match_mp_tac flatSemTheory.pmatch_ind >> rw [pmatch_def, pat_bindings_def] >> rw [] >> every_case_tac >> fs [] >> - prove_tac [pat_bindings_accum]); + prove_tac [pat_bindings_accum] +QED -Theorem pmatch_length - `∀cenv s p v env r. +Theorem pmatch_length: + ∀cenv s p v env r. flatSem$pmatch cenv s p v env = Match r ⇒ - LENGTH r = LENGTH (pat_bindings p []) + LENGTH env` - (rw [] >> + LENGTH r = LENGTH (pat_bindings p []) + LENGTH env +Proof + rw [] >> imp_res_tac pmatch_bindings >> - metis_tac [LENGTH_APPEND, LENGTH_MAP]); + metis_tac [LENGTH_APPEND, LENGTH_MAP] +QED -Theorem pmatch_any_match - `(∀cenv s p v env env'. pmatch cenv s p v env = Match env' ⇒ +Theorem pmatch_any_match: + (∀cenv s p v env env'. pmatch cenv s p v env = Match env' ⇒ ∀env. ∃env'. pmatch cenv s p v env = Match env') ∧ (∀cenv s ps vs env env'. pmatch_list cenv s ps vs env = Match env' ⇒ - ∀env. ∃env'. pmatch_list cenv s ps vs env = Match env')` - (ho_match_mp_tac pmatch_ind >> + ∀env. ∃env'. pmatch_list cenv s ps vs env = Match env') +Proof + ho_match_mp_tac pmatch_ind >> srw_tac[][pmatch_def] >> fs[] >> pop_assum mp_tac >> BasicProvers.CASE_TAC >> full_simp_tac(srw_ss())[] >> strip_tac >> full_simp_tac(srw_ss())[] >> BasicProvers.CASE_TAC >> full_simp_tac(srw_ss())[] >> - metis_tac[semanticPrimitivesTheory.match_result_distinct]) + metis_tac[semanticPrimitivesTheory.match_result_distinct] +QED -Theorem pmatch_any_no_match - `(∀cenv s p v env. pmatch cenv s p v env = No_match ⇒ +Theorem pmatch_any_no_match: + (∀cenv s p v env. pmatch cenv s p v env = No_match ⇒ ∀env. pmatch cenv s p v env = No_match) ∧ (∀cenv s ps vs env. pmatch_list cenv s ps vs env = No_match ⇒ - ∀env. pmatch_list cenv s ps vs env = No_match)` - (ho_match_mp_tac pmatch_ind >> + ∀env. pmatch_list cenv s ps vs env = No_match) +Proof + ho_match_mp_tac pmatch_ind >> srw_tac[][pmatch_def] >> fs[] >> pop_assum mp_tac >> BasicProvers.CASE_TAC >> full_simp_tac(srw_ss())[] >> strip_tac >> full_simp_tac(srw_ss())[] >> BasicProvers.CASE_TAC >> full_simp_tac(srw_ss())[] >> imp_res_tac pmatch_any_match >> - metis_tac[semanticPrimitivesTheory.match_result_distinct]) + metis_tac[semanticPrimitivesTheory.match_result_distinct] +QED -Theorem pmatch_any_match_error - `(∀cenv s p v env. pmatch cenv s p v env = Match_type_error ⇒ +Theorem pmatch_any_match_error: + (∀cenv s p v env. pmatch cenv s p v env = Match_type_error ⇒ ∀env. pmatch cenv s p v env = Match_type_error) ∧ (∀cenv s ps vs env. pmatch_list cenv s ps vs env = Match_type_error ⇒ - ∀env. pmatch_list cenv s ps vs env = Match_type_error)` - (srw_tac[][] >> qmatch_abbrev_tac`X = Y` >> Cases_on`X` >> full_simp_tac(srw_ss())[markerTheory.Abbrev_def] >> + ∀env. pmatch_list cenv s ps vs env = Match_type_error) +Proof + srw_tac[][] >> qmatch_abbrev_tac`X = Y` >> Cases_on`X` >> full_simp_tac(srw_ss())[markerTheory.Abbrev_def] >> metis_tac[semanticPrimitivesTheory.match_result_distinct - ,pmatch_any_no_match,pmatch_any_match]); - -Theorem pmatch_list_pairwise - `∀ps vs cenv s env env'. pmatch_list cenv s ps vs env = Match env' ⇒ - EVERY2 (λp v. ∀env. ∃env'. pmatch cenv s p v env = Match env') ps vs` - (Induct >> Cases_on`vs` >> simp[pmatch_def] >> + ,pmatch_any_no_match,pmatch_any_match] +QED + +Theorem pmatch_list_pairwise: + ∀ps vs cenv s env env'. pmatch_list cenv s ps vs env = Match env' ⇒ + EVERY2 (λp v. ∀env. ∃env'. pmatch cenv s p v env = Match env') ps vs +Proof + Induct >> Cases_on`vs` >> simp[pmatch_def] >> rpt gen_tac >> BasicProvers.CASE_TAC >> strip_tac >> - res_tac >> simp[] >> metis_tac[pmatch_any_match]) + res_tac >> simp[] >> metis_tac[pmatch_any_match] +QED -Theorem pmatch_list_snoc_nil[simp] - `∀p ps v vs cenv s env. +Theorem pmatch_list_snoc_nil[simp]: + ∀p ps v vs cenv s env. (pmatch_list cenv s [] (SNOC v vs) env = Match_type_error) ∧ - (pmatch_list cenv s (SNOC p ps) [] env = Match_type_error)` - (Cases_on`ps`>>Cases_on`vs`>>simp[pmatch_def]); + (pmatch_list cenv s (SNOC p ps) [] env = Match_type_error) +Proof + Cases_on`ps`>>Cases_on`vs`>>simp[pmatch_def] +QED -Theorem pmatch_list_snoc - `∀ps vs p v cenv s env. LENGTH ps = LENGTH vs ⇒ +Theorem pmatch_list_snoc: + ∀ps vs p v cenv s env. LENGTH ps = LENGTH vs ⇒ pmatch_list cenv s (SNOC p ps) (SNOC v vs) env = case pmatch_list cenv s ps vs env of | Match env' => pmatch cenv s p v env' - | res => res` - (Induct >> Cases_on`vs` >> simp[pmatch_def] >> srw_tac[][] >> - BasicProvers.CASE_TAC); - -Theorem pmatch_append - `(∀cenv s p v env n. + | res => res +Proof + Induct >> Cases_on`vs` >> simp[pmatch_def] >> srw_tac[][] >> + BasicProvers.CASE_TAC +QED + +Theorem pmatch_append: + (∀cenv s p v env n. (pmatch cenv s p v env = map_match (combin$C APPEND (DROP n env)) (pmatch cenv s p v (TAKE n env)))) ∧ (∀cenv s ps vs env n. (pmatch_list cenv s ps vs env = - map_match (combin$C APPEND (DROP n env)) (pmatch_list cenv s ps vs (TAKE n env))))` - (ho_match_mp_tac pmatch_ind >> + map_match (combin$C APPEND (DROP n env)) (pmatch_list cenv s ps vs (TAKE n env)))) +Proof + ho_match_mp_tac pmatch_ind >> srw_tac[][pmatch_def] \\ fs[] >- ( BasicProvers.CASE_TAC >> full_simp_tac(srw_ss())[] >> BasicProvers.CASE_TAC >> full_simp_tac(srw_ss())[]) >> @@ -142,7 +165,8 @@ Theorem pmatch_append strip_tac >> res_tac >> qmatch_assum_rename_tac`pmatch cenv s p v (TAKE n env) = Match env1` >> pop_assum(qspec_then`LENGTH env1`mp_tac) >> - simp_tac(srw_ss())[rich_listTheory.TAKE_LENGTH_APPEND,rich_listTheory.DROP_LENGTH_APPEND]); + simp_tac(srw_ss())[rich_listTheory.TAKE_LENGTH_APPEND,rich_listTheory.DROP_LENGTH_APPEND] +QED val pmatch_nil = save_thm("pmatch_nil", LIST_CONJ [ @@ -167,55 +191,68 @@ val build_rec_env_help_lem = Q.prove ( srw_tac[][]); (* Alternate definition for build_rec_env *) -Theorem build_rec_env_merge - `∀funs funs' env env'. +Theorem build_rec_env_merge: + ∀funs funs' env env'. build_rec_env funs env env' = - MAP (λ(fn,n,e). (fn, Recclosure env funs fn)) funs ++ env'` - (srw_tac[][build_rec_env_def, build_rec_env_help_lem]); + MAP (λ(fn,n,e). (fn, Recclosure env funs fn)) funs ++ env' +Proof + srw_tac[][build_rec_env_def, build_rec_env_help_lem] +QED (* -Theorem Boolv_11[simp] `Boolv b1 = Boolv b2 ⇔ (b1 = b2)` (srw_tac[][Boolv_def]); +Theorem Boolv_11[simp]: + Boolv b1 = Boolv b2 ⇔ (b1 = b2) +Proof +srw_tac[][Boolv_def] +QED *) val Unitv_simp = save_thm("Unitv_simp[simp]", CONJ (EVAL``Unitv T``) (EVAL ``Unitv F``)); -Theorem evaluate_length - `(∀env (s:'ffi flatSem$state) ls s' vs. +Theorem evaluate_length: + (∀env (s:'ffi flatSem$state) ls s' vs. evaluate env s ls = (s',Rval vs) ⇒ LENGTH vs = LENGTH ls) ∧ (∀env (s:'ffi flatSem$state) v pes ev s' vs. - evaluate_match env s v pes ev = (s', Rval vs) ⇒ LENGTH vs = 1)` - (ho_match_mp_tac evaluate_ind >> + evaluate_match env s v pes ev = (s', Rval vs) ⇒ LENGTH vs = 1) +Proof + ho_match_mp_tac evaluate_ind >> srw_tac[][evaluate_def] >> srw_tac[][] >> - every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][]); + every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] +QED -Theorem evaluate_cons - `flatSem$evaluate env s (e::es) = +Theorem evaluate_cons: + flatSem$evaluate env s (e::es) = (case evaluate env s [e] of | (s,Rval v) => (case evaluate env s es of | (s,Rval vs) => (s,Rval (v++vs)) | r => r) - | r => r)` - (Cases_on`es`>>srw_tac[][evaluate_def] >> + | r => r) +Proof + Cases_on`es`>>srw_tac[][evaluate_def] >> every_case_tac >> full_simp_tac(srw_ss())[evaluate_def] >> imp_res_tac evaluate_length >> - full_simp_tac(srw_ss())[SING_HD]); - -Theorem evaluate_sing - `(evaluate env s [e] = (s',Rval vs) ⇒ ∃y. vs = [y]) ∧ - (evaluate_match env s v pes ev = (s',Rval vs) ⇒ ∃y. vs = [y])` - (srw_tac[][] >> imp_res_tac evaluate_length >> full_simp_tac(srw_ss())[] >> metis_tac[SING_HD]) - -Theorem evaluate_append - `evaluate env s (l1 ++ l2) = + full_simp_tac(srw_ss())[SING_HD] +QED + +Theorem evaluate_sing: + (evaluate env s [e] = (s',Rval vs) ⇒ ∃y. vs = [y]) ∧ + (evaluate_match env s v pes ev = (s',Rval vs) ⇒ ∃y. vs = [y]) +Proof + srw_tac[][] >> imp_res_tac evaluate_length >> full_simp_tac(srw_ss())[] >> metis_tac[SING_HD] +QED + +Theorem evaluate_append: + evaluate env s (l1 ++ l2) = case evaluate env s l1 of | (s,Rval v1) => (case evaluate env s l2 of | (s,Rval v2) => (s,Rval(v1++v2)) | r => r) - | r => r` - (map_every qid_spec_tac[`l2`,`s`] >> Induct_on`l1` >> + | r => r +Proof + map_every qid_spec_tac[`l2`,`s`] >> Induct_on`l1` >> srw_tac[][evaluate_def] >- ( every_case_tac >> full_simp_tac(srw_ss())[] ) >> srw_tac[][Once evaluate_cons] >> @@ -223,7 +260,8 @@ Theorem evaluate_append srw_tac[][Once evaluate_cons] >> BasicProvers.CASE_TAC >> full_simp_tac(srw_ss())[] >> Cases_on`r`>>full_simp_tac(srw_ss())[] >> - every_case_tac >> full_simp_tac(srw_ss())[]); + every_case_tac >> full_simp_tac(srw_ss())[] +QED val c_updated_by = Q.prove ( `((env:flatSem$environment) with c updated_by f) = (env with c := f env.c)`, @@ -233,14 +271,15 @@ val env_lemma = Q.prove ( `((env:flatSem$environment) with c := env.c) = env`, rw [environment_component_equality]); -Theorem evaluate_decs_append - `!env s ds1 s1 cenv1 s2 cenv2 r ds2. +Theorem evaluate_decs_append: + !env s ds1 s1 cenv1 s2 cenv2 r ds2. evaluate_decs env s ds1 = (s1,cenv1,NONE) ∧ evaluate_decs (env with c updated_by $UNION cenv1) s1 ds2 = (s2,cenv2,r) ⇒ - evaluate_decs env s (ds1++ds2) = (s2,cenv2 ∪ cenv1,r)` - (induct_on `ds1` >> + evaluate_decs env s (ds1++ds2) = (s2,cenv2 ∪ cenv1,r) +Proof + induct_on `ds1` >> rw [evaluate_decs_def] >> fs [Once c_updated_by, env_lemma] >> every_case_tac >> @@ -250,19 +289,22 @@ Theorem evaluate_decs_append simp [] >> fs [UNION_ASSOC] >> disch_then drule >> - fs [Once c_updated_by]); + fs [Once c_updated_by] +QED -Theorem evaluate_decs_append_err - `!env s d s' cenv' err_i1 ds. +Theorem evaluate_decs_append_err: + !env s d s' cenv' err_i1 ds. evaluate_decs env s d = (s',cenv',SOME err_i1) ⇒ - evaluate_decs env s (d++ds) = (s',cenv',SOME err_i1)` - (induct_on `d` >> + evaluate_decs env s (d++ds) = (s',cenv',SOME err_i1) +Proof + induct_on `d` >> rw [evaluate_decs_def] >> every_case_tac >> fs [] >> rw [] >> - metis_tac [PAIR_EQ]); + metis_tac [PAIR_EQ] +QED val do_app_add_to_clock = Q.prove ( `do_app cc s op es = SOME (t, r) @@ -280,8 +322,8 @@ val do_app_add_to_clock_NONE = Q.prove ( \\ rpt (pairarg_tac \\ fs []) \\ fs [bool_case_eq, case_eq_thms]); -Theorem evaluate_add_to_clock - `(∀env (s:'ffi flatSem$state) es s' r. +Theorem evaluate_add_to_clock: + (∀env (s:'ffi flatSem$state) es s' r. evaluate env s es = (s',r) ∧ r ≠ Rerr (Rabort Rtimeout_error) ⇒ evaluate env (s with clock := s.clock + extra) es = @@ -290,8 +332,9 @@ Theorem evaluate_add_to_clock evaluate_match env s pes v err_v = (s',r) ∧ r ≠ Rerr (Rabort Rtimeout_error) ⇒ evaluate_match env (s with clock := s.clock + extra) pes v err_v = - (s' with clock := s'.clock + extra,r))` - (ho_match_mp_tac evaluate_ind \\ rw [evaluate_def] + (s' with clock := s'.clock + extra,r)) +Proof + ho_match_mp_tac evaluate_ind \\ rw [evaluate_def] \\ fs [case_eq_thms, pair_case_eq] \\ rw [] \\ fs [PULL_EXISTS] \\ rw [] \\ fs [] \\ fs [case_eq_thms, pair_case_eq, bool_case_eq] \\ rw [] @@ -300,7 +343,8 @@ Theorem evaluate_add_to_clock \\ map_every imp_res_tac [do_app_add_to_clock_NONE, do_app_add_to_clock] \\ fs [] - \\ every_case_tac \\ fs []); + \\ every_case_tac \\ fs [] +QED val evaluate_dec_add_to_clock = Q.prove( `∀d env s s' r. @@ -314,16 +358,18 @@ val evaluate_dec_add_to_clock = Q.prove( \\ rw [] \\ rfs [] >> fs []); -Theorem evaluate_decs_add_to_clock - `∀decs env s s' c r. +Theorem evaluate_decs_add_to_clock: + ∀decs env s s' c r. r ≠ SOME (Rabort Rtimeout_error) ∧ evaluate_decs env s decs = (s',c,r) ⇒ evaluate_decs env (s with clock := s.clock + extra) decs = - (s' with clock := s'.clock + extra,c,r)` - (Induct \\ rw [evaluate_decs_def] + (s' with clock := s'.clock + extra,c,r) +Proof + Induct \\ rw [evaluate_decs_def] \\ fs [case_eq_thms, pair_case_eq] \\ rw [] \\ fs [PULL_EXISTS] \\ imp_res_tac evaluate_dec_add_to_clock \\ fs [] - \\ metis_tac []); + \\ metis_tac [] +QED (* val evaluate_prompt_add_to_clock = Q.prove( @@ -360,53 +406,62 @@ val evaluate_prompts_add_to_clock = Q.prove( first_x_assum(drule o ONCE_REWRITE_RULE[CONJ_COMM]) >> simp[]); -Theorem evaluate_prog_add_to_clock - `∀prog env s s' r. +Theorem evaluate_prog_add_to_clock: + ∀prog env s s' r. evaluate_prog env s prog = (s',r) ∧ r ≠ SOME (Rabort Rtimeout_error) ⇒ evaluate_prog env (s with clock := s.clock + extra) prog = - (s' with clock := s'.clock + extra,r)` - (srw_tac[][evaluate_prog_def] >> full_simp_tac(srw_ss())[LET_THM] >> + (s' with clock := s'.clock + extra,r) +Proof + srw_tac[][evaluate_prog_def] >> full_simp_tac(srw_ss())[LET_THM] >> pairarg_tac >> full_simp_tac(srw_ss())[] >> rveq >> imp_res_tac evaluate_prompts_add_to_clock >> rev_full_simp_tac(srw_ss())[] >> - rpt(first_x_assum(qspec_then`extra`mp_tac))>>simp[]); + rpt(first_x_assum(qspec_then`extra`mp_tac))>>simp[] +QED *) -Theorem do_app_io_events_mono - `do_app cc (s:'ffi flatSem$state) op vs = SOME (t, r) ⇒ - s.ffi.io_events ≼ t.ffi.io_events` - (rw [do_app_def] \\ fs [case_eq_thms, pair_case_eq, bool_case_eq] +Theorem do_app_io_events_mono: + do_app cc (s:'ffi flatSem$state) op vs = SOME (t, r) ⇒ + s.ffi.io_events ≼ t.ffi.io_events +Proof + rw [do_app_def] \\ fs [case_eq_thms, pair_case_eq, bool_case_eq] \\ rw [] \\ fs [] \\ rpt (pairarg_tac \\ fs []) \\ rw [] \\ fs [semanticPrimitivesTheory.store_assign_def, semanticPrimitivesTheory.store_lookup_def, ffiTheory.call_FFI_def] - \\ rw [] \\ every_case_tac \\ fs [] \\ rw []); + \\ rw [] \\ every_case_tac \\ fs [] \\ rw [] +QED -Theorem evaluate_io_events_mono - `(∀env (s:'ffi flatSem$state) es. +Theorem evaluate_io_events_mono: + (∀env (s:'ffi flatSem$state) es. s.ffi.io_events ≼ (FST (evaluate env s es)).ffi.io_events) ∧ (∀env (s:'ffi flatSem$state) pes v err_v. - s.ffi.io_events ≼ (FST (evaluate_match env s pes v err_v)).ffi.io_events)` - (ho_match_mp_tac evaluate_ind \\ rw [evaluate_def] + s.ffi.io_events ≼ (FST (evaluate_match env s pes v err_v)).ffi.io_events) +Proof + ho_match_mp_tac evaluate_ind \\ rw [evaluate_def] \\ every_case_tac \\ fs [] \\ rfs [] \\ fs [dec_clock_def] \\ imp_res_tac do_app_io_events_mono \\ fs [] - \\ metis_tac [IS_PREFIX_TRANS]); + \\ metis_tac [IS_PREFIX_TRANS] +QED -Theorem with_clock_ffi - `(s with clock := k).ffi = s.ffi` - (EVAL_TAC) +Theorem with_clock_ffi: + (s with clock := k).ffi = s.ffi +Proof + EVAL_TAC +QED -Theorem evaluate_add_to_clock_io_events_mono - `(∀env (s:'ffi flatSem$state) es extra. +Theorem evaluate_add_to_clock_io_events_mono: + (∀env (s:'ffi flatSem$state) es extra. (FST (evaluate env s es)).ffi.io_events ≼ (FST (evaluate env (s with clock := s.clock + extra) es)).ffi.io_events) ∧ (∀env (s:'ffi flatSem$state) pes v err_v extra. (FST (evaluate_match env s pes v err_v)).ffi.io_events ≼ - (FST (evaluate_match env (s with clock := s.clock + extra) pes v err_v)).ffi.io_events)` - (ho_match_mp_tac evaluate_ind \\ rw [evaluate_def] \\ fs [] + (FST (evaluate_match env (s with clock := s.clock + extra) pes v err_v)).ffi.io_events) +Proof + ho_match_mp_tac evaluate_ind \\ rw [evaluate_def] \\ fs [] \\ rpt (PURE_FULL_CASE_TAC \\ fs []) \\ rfs [] \\ map_every imp_res_tac [evaluate_add_to_clock, evaluate_io_events_mono, @@ -417,19 +472,23 @@ Theorem evaluate_add_to_clock_io_events_mono \\ metis_tac [IS_PREFIX_TRANS, FST, PAIR, evaluate_io_events_mono, with_clock_ffi, - do_app_io_events_mono]); - -Theorem evaluate_dec_io_events_mono - `∀z x y. - y.ffi.io_events ≼ (FST (evaluate_dec x y z)).ffi.io_events` - (Cases \\ rw [evaluate_dec_def] \\ every_case_tac \\ fs [] \\ rw [] - \\ metis_tac [evaluate_io_events_mono, FST]); - -Theorem evaluate_dec_add_to_clock_io_events_mono - `∀prog env (s:'ffi flatSem$state) extra. + do_app_io_events_mono] +QED + +Theorem evaluate_dec_io_events_mono: + ∀z x y. + y.ffi.io_events ≼ (FST (evaluate_dec x y z)).ffi.io_events +Proof + Cases \\ rw [evaluate_dec_def] \\ every_case_tac \\ fs [] \\ rw [] + \\ metis_tac [evaluate_io_events_mono, FST] +QED + +Theorem evaluate_dec_add_to_clock_io_events_mono: + ∀prog env (s:'ffi flatSem$state) extra. (FST (evaluate_dec env s prog)).ffi.io_events ≼ - (FST (evaluate_dec env (s with clock := s.clock + extra) prog)).ffi.io_events` - (Cases \\ rw [evaluate_dec_def] \\ fs [] + (FST (evaluate_dec env (s with clock := s.clock + extra) prog)).ffi.io_events +Proof + Cases \\ rw [evaluate_dec_def] \\ fs [] \\ split_pair_case_tac \\ fs [] \\ split_pair_case_tac \\ fs [] \\ qmatch_assum_abbrev_tac `evaluate ee (s with clock := _) pp = _` @@ -437,21 +496,25 @@ Theorem evaluate_dec_add_to_clock_io_events_mono [`ee`,`s`,`pp`,`extra`] mp_tac (CONJUNCT1 evaluate_add_to_clock_io_events_mono) \\ rw [] \\ fs [] - \\ every_case_tac \\ fs []) - -Theorem evaluate_decs_io_events_mono - `∀prog env s s' x y. evaluate_decs env s prog = (s',x,y) ⇒ - s.ffi.io_events ≼ s'.ffi.io_events` - (Induct \\ rw [evaluate_decs_def] + \\ every_case_tac \\ fs [] +QED + +Theorem evaluate_decs_io_events_mono: + ∀prog env s s' x y. evaluate_decs env s prog = (s',x,y) ⇒ + s.ffi.io_events ≼ s'.ffi.io_events +Proof + Induct \\ rw [evaluate_decs_def] \\ every_case_tac \\ fs [] \\ rw [] \\ res_tac \\ fs [] - \\ metis_tac [IS_PREFIX_TRANS, FST, evaluate_dec_io_events_mono]); + \\ metis_tac [IS_PREFIX_TRANS, FST, evaluate_dec_io_events_mono] +QED -Theorem evaluate_decs_add_to_clock_io_events_mono - `∀prog env s extra. +Theorem evaluate_decs_add_to_clock_io_events_mono: + ∀prog env s extra. (FST (evaluate_decs env s prog)).ffi.io_events ≼ - (FST (evaluate_decs env (s with clock := s.clock + extra) prog)).ffi.io_events` - (Induct \\ rw [evaluate_decs_def] \\ every_case_tac \\ fs [] + (FST (evaluate_decs env (s with clock := s.clock + extra) prog)).ffi.io_events +Proof + Induct \\ rw [evaluate_decs_def] \\ every_case_tac \\ fs [] \\ qmatch_assum_abbrev_tac `evaluate_dec ee (ss with clock := extra + _) pp = _` \\ qispl_then @@ -460,50 +523,58 @@ Theorem evaluate_decs_add_to_clock_io_events_mono \\ rw [] \\ fs [] \\ imp_res_tac evaluate_dec_add_to_clock \\ fs [] \\ imp_res_tac evaluate_decs_io_events_mono \\ fs [] - \\ metis_tac [IS_PREFIX_TRANS, FST]); + \\ metis_tac [IS_PREFIX_TRANS, FST] +QED (* -Theorem evaluate_prompt_io_events_mono - `∀x y z. evaluate_prompt x y z = (a,b) ⇒ +Theorem evaluate_prompt_io_events_mono: + ∀x y z. evaluate_prompt x y z = (a,b) ⇒ y.ffi.io_events ≼ a.ffi.io_events ∧ - (IS_SOME y.ffi.final_event ⇒ a.ffi = y.ffi)` - (Cases_on`z`>>srw_tac[][evaluate_prompt_def] >> + (IS_SOME y.ffi.final_event ⇒ a.ffi = y.ffi) +Proof + Cases_on`z`>>srw_tac[][evaluate_prompt_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> full_simp_tac(srw_ss())[LET_THM] >> pairarg_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> - imp_res_tac evaluate_decs_io_events_mono); + imp_res_tac evaluate_decs_io_events_mono +QED -Theorem evaluate_prompt_add_to_clock_io_events_mono - `∀env s prog extra. +Theorem evaluate_prompt_add_to_clock_io_events_mono: + ∀env s prog extra. (FST (evaluate_prompt env s prog)).ffi.io_events ≼ (FST (evaluate_prompt env (s with clock := s.clock + extra) prog)).ffi.io_events ∧ (IS_SOME ((FST (evaluate_prompt env s prog)).ffi.final_event) ⇒ (FST (evaluate_prompt env (s with clock := s.clock + extra) prog)).ffi = - (FST (evaluate_prompt env s prog)).ffi)` - (Cases_on`prog`>>srw_tac[][evaluate_prompt_def]>> + (FST (evaluate_prompt env s prog)).ffi) +Proof + Cases_on`prog`>>srw_tac[][evaluate_prompt_def]>> every_case_tac >> full_simp_tac(srw_ss())[LET_THM] >> TRY pairarg_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> qmatch_assum_abbrev_tac`evaluate_decs ee (ss with clock := _ + extra) pp = _` >> qispl_then[`ee`,`ss`,`pp`,`extra`]mp_tac evaluate_decs_add_to_clock_io_events_mono >> - simp[]); + simp[] +QED -Theorem evaluate_prompts_io_events_mono - `∀prog env s s' x y. evaluate_prompts env s prog = (s',x,y) ⇒ +Theorem evaluate_prompts_io_events_mono: + ∀prog env s s' x y. evaluate_prompts env s prog = (s',x,y) ⇒ s.ffi.io_events ≼ s'.ffi.io_events ∧ - (IS_SOME s.ffi.final_event ⇒ s'.ffi = s.ffi)` - (Induct >> srw_tac[][evaluate_prompts_def] >> + (IS_SOME s.ffi.final_event ⇒ s'.ffi = s.ffi) +Proof + Induct >> srw_tac[][evaluate_prompts_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> imp_res_tac evaluate_prompt_io_events_mono >> res_tac >> full_simp_tac(srw_ss())[] >> - metis_tac[IS_PREFIX_TRANS]); + metis_tac[IS_PREFIX_TRANS] +QED -Theorem evaluate_prompts_add_to_clock_io_events_mono - `∀env s prog extra. +Theorem evaluate_prompts_add_to_clock_io_events_mono: + ∀env s prog extra. (FST (evaluate_prompts env s prog)).ffi.io_events ≼ (FST (evaluate_prompts env (s with clock := s.clock + extra) prog)).ffi.io_events ∧ (IS_SOME ((FST (evaluate_prompts env s prog)).ffi.final_event) ⇒ (FST (evaluate_prompts env (s with clock := s.clock + extra) prog)).ffi = - (FST (evaluate_prompts env s prog)).ffi)` - (Induct_on`prog` >> srw_tac[][evaluate_prompts_def] >> + (FST (evaluate_prompts env s prog)).ffi) +Proof + Induct_on`prog` >> srw_tac[][evaluate_prompts_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> qmatch_assum_abbrev_tac`evaluate_prompt ee (ss with clock := _ + extra) pp = _` >> qispl_then[`ee`,`ss`,`pp`,`extra`]mp_tac evaluate_prompt_add_to_clock_io_events_mono >> @@ -514,32 +585,36 @@ Theorem evaluate_prompts_add_to_clock_io_events_mono qmatch_assum_abbrev_tac`evaluate_prompts eee sss prog = _` >> last_x_assum(qspecl_then[`eee`,`sss`,`extra`]mp_tac)>>simp[Abbr`sss`]>> fsrw_tac[ARITH_ss][] >> srw_tac[][] >> full_simp_tac(srw_ss())[] >> - metis_tac[IS_PREFIX_TRANS,FST]); + metis_tac[IS_PREFIX_TRANS,FST] +QED -Theorem evaluate_prog_add_to_clock_io_events_mono - `∀env s prog extra. +Theorem evaluate_prog_add_to_clock_io_events_mono: + ∀env s prog extra. (FST (evaluate_prog env s prog)).ffi.io_events ≼ (FST (evaluate_prog env (s with clock := s.clock + extra) prog)).ffi.io_events ∧ (IS_SOME ((FST (evaluate_prog env s prog)).ffi.final_event) ⇒ (FST (evaluate_prog env (s with clock := s.clock + extra) prog)).ffi = - (FST (evaluate_prog env s prog)).ffi)` - (srw_tac[][evaluate_prog_def] >> full_simp_tac(srw_ss())[LET_THM] >> - metis_tac[evaluate_prompts_add_to_clock_io_events_mono,FST]); + (FST (evaluate_prog env s prog)).ffi) +Proof + srw_tac[][evaluate_prog_def] >> full_simp_tac(srw_ss())[LET_THM] >> + metis_tac[evaluate_prompts_add_to_clock_io_events_mono,FST] +QED *) val bind_locals_list_def = Define` bind_locals_list ts ks = list$MAP2 (λt x. (flatLang$Var_local t x)) ts ks`; -Theorem evaluate_vars - `!env s kvs env' ks vs ts. +Theorem evaluate_vars: + !env s kvs env' ks vs ts. ALL_DISTINCT (MAP FST kvs) ∧ DISJOINT (set (MAP FST kvs)) (set (MAP FST env')) ∧ env.v = env' ++ kvs ∧ ks = MAP FST kvs ∧ vs = MAP SND kvs ∧ LENGTH ts = LENGTH ks ⇒ - evaluate env s (bind_locals_list ts ks) = (s,Rval vs)` - (induct_on `kvs` >> fs[bind_locals_list_def]>> + evaluate env s (bind_locals_list ts ks) = (s,Rval vs) +Proof + induct_on `kvs` >> fs[bind_locals_list_def]>> srw_tac[][evaluate_def] >> Cases_on`ts`>>fs[]>> srw_tac[][Once evaluate_cons,evaluate_def] >> @@ -548,16 +623,19 @@ Theorem evaluate_vars reverse BasicProvers.CASE_TAC >> imp_res_tac ALOOKUP_MEM >- metis_tac[MEM_MAP,FST] >> first_x_assum(qspecl_then[`env`,`s`]mp_tac) >> - full_simp_tac(srw_ss())[DISJOINT_SYM]); + full_simp_tac(srw_ss())[DISJOINT_SYM] +QED (* -Theorem with_same_v[simp] - `env with v := env.v = env` - (srw_tac[][environment_component_equality]); +Theorem with_same_v[simp]: + env with v := env.v = env +Proof + srw_tac[][environment_component_equality] +QED *) -Theorem pmatch_evaluate_vars - `(!env refs p v evs env' ts. +Theorem pmatch_evaluate_vars: + (!env refs p v evs env' ts. refs = s.refs ∧ flatSem$pmatch env s.refs p v evs = Match env' ∧ ALL_DISTINCT (pat_bindings p (MAP FST evs)) ∧ @@ -570,8 +648,9 @@ Theorem pmatch_evaluate_vars ALL_DISTINCT (pats_bindings ps (MAP FST evs)) ∧ LENGTH ts = LENGTH (pats_bindings ps (MAP FST evs)) ⇒ - flatSem$evaluate (env with v := env') s (bind_locals_list ts (pats_bindings ps (MAP FST evs))) = (s,Rval (MAP SND env')))` - (ho_match_mp_tac pmatch_ind >> + flatSem$evaluate (env with v := env') s (bind_locals_list ts (pats_bindings ps (MAP FST evs))) = (s,Rval (MAP SND env'))) +Proof + ho_match_mp_tac pmatch_ind >> srw_tac[][pat_bindings_def, pmatch_def] >- ( match_mp_tac evaluate_vars >> srw_tac[][] >> @@ -600,119 +679,141 @@ Theorem pmatch_evaluate_vars srw_tac[][] >> metis_tac [pat_bindings_accum]) >> fsrw_tac[QUANT_INST_ss[record_default_qp]][] >> - rev_full_simp_tac(srw_ss())[])); + rev_full_simp_tac(srw_ss())[]) +QED -Theorem pmatch_evaluate_vars_lem - `∀p v bindings env s ts. +Theorem pmatch_evaluate_vars_lem: + ∀p v bindings env s ts. pmatch env s.refs p v [] = Match bindings ∧ ALL_DISTINCT (pat_bindings p []) ∧ LENGTH ts = LENGTH (pat_bindings p []) ⇒ - evaluate (env with v := bindings) s (bind_locals_list ts (pat_bindings p [])) = (s,Rval (MAP SND bindings))` - (rw [] >> + evaluate (env with v := bindings) s (bind_locals_list ts (pat_bindings p [])) = (s,Rval (MAP SND bindings)) +Proof + rw [] >> imp_res_tac pmatch_evaluate_vars >> - fs []); + fs [] +QED (* -Theorem evaluate_append - `∀env s s1 s2 e1 e2 v1 v2. +Theorem evaluate_append: + ∀env s s1 s2 e1 e2 v1 v2. evaluate env s e1 = (s1, Rval v1) ∧ evaluate env s1 e2 = (s2, Rval v2) ⇒ - evaluate env s (e1++e2) = (s2, Rval (v1++v2))` - (Induct_on`e1`>>srw_tac[][evaluate_def] >> + evaluate env s (e1++e2) = (s2, Rval (v1++v2)) +Proof + Induct_on`e1`>>srw_tac[][evaluate_def] >> full_simp_tac(srw_ss())[Once evaluate_cons] >> every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> - res_tac >> full_simp_tac(srw_ss())[]); + res_tac >> full_simp_tac(srw_ss())[] +QED -Theorem evaluate_vars_reverse - `!env s es s' vs. +Theorem evaluate_vars_reverse: + !env s es s' vs. evaluate env s (MAP (Var_local tra) es) = (s, Rval vs) ⇒ - evaluate env s (MAP (Var_local tra) (REVERSE es)) = (s, Rval (REVERSE vs))` - (induct_on `es` >> srw_tac[][evaluate_def] >> srw_tac[][] >> + evaluate env s (MAP (Var_local tra) (REVERSE es)) = (s, Rval (REVERSE vs)) +Proof + induct_on `es` >> srw_tac[][evaluate_def] >> srw_tac[][] >> pop_assum mp_tac >> srw_tac[][Once evaluate_cons] >> every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> full_simp_tac(srw_ss())[evaluate_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> match_mp_tac evaluate_append >> - srw_tac[][evaluate_def]); + srw_tac[][evaluate_def] +QED val tids_of_decs_def = Define` tids_of_decs ds = set (FLAT (MAP (λd. case d of Dtype mn tds => MAP (mk_id mn o FST o SND) tds | _ => []) ds))`; -Theorem tids_of_decs_thm - `(tids_of_decs [] = {}) ∧ +Theorem tids_of_decs_thm: + (tids_of_decs [] = {}) ∧ (tids_of_decs (d::ds) = tids_of_decs ds ∪ - case d of Dtype mn tds => set (MAP (mk_id mn o FST o SND) tds) | _ => {})` - (simp[tids_of_decs_def] >> + case d of Dtype mn tds => set (MAP (mk_id mn o FST o SND) tds) | _ => {}) +Proof + simp[tids_of_decs_def] >> every_case_tac >> simp[] >> - metis_tac[UNION_COMM]); - -Theorem dec_clock_const[simp] - `(dec_clock s).defined_types = s.defined_types ∧ - (dec_clock s).defined_mods = s.defined_mods` - (EVAL_TAC) + metis_tac[UNION_COMM] +QED + +Theorem dec_clock_const[simp]: + (dec_clock s).defined_types = s.defined_types ∧ + (dec_clock s).defined_mods = s.defined_mods +Proof + EVAL_TAC +QED *) (* -Theorem evaluate_state_const - `(∀env (s:'ffi flatSem$state) ls s' vs. +Theorem evaluate_state_const: + (∀env (s:'ffi flatSem$state) ls s' vs. flatSem$evaluate env s ls = (s',vs) ⇒ s'.next_type_id = s.next_type_id ∧ s'.next_exn_id = s.next_exn_id) ∧ (∀env (s:'ffi flatSem$state) v pes ev s' vs. evaluate_match env s v pes ev = (s', vs) ⇒ s'.next_type_id = s.next_type_id ∧ - s'.next_exn_id = s.next_exn_id)` - (ho_match_mp_tac evaluate_ind >> + s'.next_exn_id = s.next_exn_id) +Proof + ho_match_mp_tac evaluate_ind >> srw_tac[][evaluate_def] >> srw_tac[][] >> every_case_tac >> full_simp_tac(srw_ss())[] >> imp_res_tac do_app_const >> - srw_tac[][dec_clock_def] >> metis_tac []); + srw_tac[][dec_clock_def] >> metis_tac [] +QED *) (* -Theorem evaluate_dec_state_const - `∀env st d res. evaluate_dec env st d = res ⇒ - (FST res).defined_mods = st.defined_mods` - (Cases_on`d`>>srw_tac[][evaluate_dec_def] >> srw_tac[][] >> +Theorem evaluate_dec_state_const: + ∀env st d res. evaluate_dec env st d = res ⇒ + (FST res).defined_mods = st.defined_mods +Proof + Cases_on`d`>>srw_tac[][evaluate_dec_def] >> srw_tac[][] >> BasicProvers.CASE_TAC >> full_simp_tac(srw_ss())[] >> imp_res_tac evaluate_state_const >> - every_case_tac >> full_simp_tac(srw_ss())[]); - -Theorem evaluate_decs_state_const - `∀env st ds res. evaluate_decs env st ds = res ⇒ - (FST res).defined_mods = st.defined_mods` - (Induct_on`ds`>>srw_tac[][evaluate_decs_def] >> srw_tac[][] >> + every_case_tac >> full_simp_tac(srw_ss())[] +QED + +Theorem evaluate_decs_state_const: + ∀env st ds res. evaluate_decs env st ds = res ⇒ + (FST res).defined_mods = st.defined_mods +Proof + Induct_on`ds`>>srw_tac[][evaluate_decs_def] >> srw_tac[][] >> every_case_tac >> full_simp_tac(srw_ss())[] >> imp_res_tac evaluate_dec_state_const >> full_simp_tac(srw_ss())[] >> `∀x f.(x with globals updated_by f).defined_mods = x.defined_mods` by simp[] >> - metis_tac[FST]); - -Theorem evaluate_dec_tids_acc - `∀env st d res. evaluate_dec env st d = res ⇒ - st.defined_types ⊆ (FST res).defined_types` - (Cases_on`d`>>srw_tac[][evaluate_dec_def] >> srw_tac[][] >> + metis_tac[FST] +QED + +Theorem evaluate_dec_tids_acc: + ∀env st d res. evaluate_dec env st d = res ⇒ + st.defined_types ⊆ (FST res).defined_types +Proof + Cases_on`d`>>srw_tac[][evaluate_dec_def] >> srw_tac[][] >> BasicProvers.CASE_TAC >> imp_res_tac evaluate_state_const >> - every_case_tac >> srw_tac[][]); - -Theorem evaluate_decs_tids_acc - `∀env st ds res. evaluate_decs env st ds = res ⇒ - st.defined_types ⊆ (FST res).defined_types` - (Induct_on`ds`>>srw_tac[][evaluate_decs_def]>>srw_tac[][]>> + every_case_tac >> srw_tac[][] +QED + +Theorem evaluate_decs_tids_acc: + ∀env st ds res. evaluate_decs env st ds = res ⇒ + st.defined_types ⊆ (FST res).defined_types +Proof + Induct_on`ds`>>srw_tac[][evaluate_decs_def]>>srw_tac[][]>> every_case_tac >> full_simp_tac(srw_ss())[]>> imp_res_tac evaluate_dec_tids_acc >> full_simp_tac(srw_ss())[] >> `∀x f.(x with globals updated_by f).defined_types = x.defined_types` by simp[] >> - metis_tac[FST,SUBSET_TRANS]); + metis_tac[FST,SUBSET_TRANS] +QED -Theorem evaluate_decs_tids - `∀env st ds res. evaluate_decs env st ds = res ⇒ +Theorem evaluate_decs_tids: + ∀env st ds res. evaluate_decs env st ds = res ⇒ SND(SND(SND res)) = NONE ⇒ - {id | TypeId id ∈ (FST res).defined_types} = (tids_of_decs ds) ∪ {id | TypeId id ∈ st.defined_types}` - (Induct_on`ds`>>srw_tac[][evaluate_decs_def]>>full_simp_tac(srw_ss())[tids_of_decs_thm]>> + {id | TypeId id ∈ (FST res).defined_types} = (tids_of_decs ds) ∪ {id | TypeId id ∈ st.defined_types} +Proof + Induct_on`ds`>>srw_tac[][evaluate_decs_def]>>full_simp_tac(srw_ss())[tids_of_decs_thm]>> every_case_tac>>full_simp_tac(srw_ss())[evaluate_dec_def,LET_THM]>>srw_tac[][]>> every_case_tac>>full_simp_tac(srw_ss())[]>>srw_tac[][]>> full_simp_tac(srw_ss())[EXTENSION,semanticPrimitivesTheory.type_defs_to_new_tdecs_def,MEM_MAP,PULL_EXISTS,UNCURRY] >> @@ -720,20 +821,23 @@ Theorem evaluate_decs_tids last_x_assum(qspecl_then[`env'`,`st'`]mp_tac)>>srw_tac[][]>> unabbrev_all_tac >> full_simp_tac(srw_ss())[]>> full_simp_tac(srw_ss())[EXTENSION,semanticPrimitivesTheory.type_defs_to_new_tdecs_def,MEM_MAP,PULL_EXISTS,UNCURRY] >> - metis_tac[evaluate_state_const]); + metis_tac[evaluate_state_const] +QED -Theorem evaluate_decs_tids_disjoint - `∀env st ds res. evaluate_decs env st ds = res ⇒ +Theorem evaluate_decs_tids_disjoint: + ∀env st ds res. evaluate_decs env st ds = res ⇒ SND(SND(SND res)) = NONE ⇒ - DISJOINT (IMAGE TypeId (tids_of_decs ds)) st.defined_types` - (Induct_on`ds`>>srw_tac[][evaluate_decs_def]>>full_simp_tac(srw_ss())[tids_of_decs_thm]>> + DISJOINT (IMAGE TypeId (tids_of_decs ds)) st.defined_types +Proof + Induct_on`ds`>>srw_tac[][evaluate_decs_def]>>full_simp_tac(srw_ss())[tids_of_decs_thm]>> every_case_tac >> full_simp_tac(srw_ss())[evaluate_dec_def,LET_THM] >> srw_tac[][] >> every_case_tac>>full_simp_tac(srw_ss())[]>>srw_tac[][]>> qmatch_assum_abbrev_tac`evaluate_decs env' st' _ = _` >> last_x_assum(qspecl_then[`env'`,`st'`]mp_tac)>>srw_tac[][]>> unabbrev_all_tac >> full_simp_tac(srw_ss())[]>> full_simp_tac(srw_ss())[semanticPrimitivesTheory.type_defs_to_new_tdecs_def,IN_DISJOINT,MEM_MAP,UNCURRY] >> - metis_tac[evaluate_state_const]); + metis_tac[evaluate_state_const] +QED val tids_of_prompt_def = Define` tids_of_prompt (Prompt _ ds) = tids_of_decs ds`; @@ -751,46 +855,55 @@ val evaluate_prompt_tids_acc = Q.prove( Cases_on`p`>>srw_tac[][evaluate_prompt_def]>>full_simp_tac(srw_ss())[]>> metis_tac[evaluate_decs_tids_acc,FST]); -Theorem evaluate_prompt_tids - `∀env s p res. evaluate_prompt env s p = res ⇒ +Theorem evaluate_prompt_tids: + ∀env s p res. evaluate_prompt env s p = res ⇒ SND(SND(SND res)) = NONE ⇒ - {id | TypeId id ∈ (FST res).defined_types} = (tids_of_prompt p) ∪ {id | TypeId id ∈ s.defined_types}` - (Cases_on`p`>>srw_tac[][evaluate_prompt_def]>>full_simp_tac(srw_ss())[tids_of_prompt_def]>> full_simp_tac(srw_ss())[LET_THM,UNCURRY] >> - metis_tac[evaluate_decs_tids]); + {id | TypeId id ∈ (FST res).defined_types} = (tids_of_prompt p) ∪ {id | TypeId id ∈ s.defined_types} +Proof + Cases_on`p`>>srw_tac[][evaluate_prompt_def]>>full_simp_tac(srw_ss())[tids_of_prompt_def]>> full_simp_tac(srw_ss())[LET_THM,UNCURRY] >> + metis_tac[evaluate_decs_tids] +QED (* -Theorem evaluate_prompt_mods_disjoint - `∀env s p res. evaluate_prompt env s p = res ⇒ +Theorem evaluate_prompt_mods_disjoint: + ∀env s p res. evaluate_prompt env s p = res ⇒ SND(SND(SND res)) = NONE ⇒ - ∀mn ds. p = Prompt (SOME mn) ds ⇒ mn ∉ s.defined_mods` - (Cases_on`p`>>srw_tac[][evaluate_prompt_def]>>full_simp_tac(srw_ss())[]); + ∀mn ds. p = Prompt (SOME mn) ds ⇒ mn ∉ s.defined_mods +Proof + Cases_on`p`>>srw_tac[][evaluate_prompt_def]>>full_simp_tac(srw_ss())[] +QED *) *) (* val s = ``s:'ffi flatSem$state``; -Theorem evaluate_globals - `(∀env ^s es s' r. evaluate env s es = (s',r) ⇒ s'.globals = s.globals) ∧ +Theorem evaluate_globals: + (∀env ^s es s' r. evaluate env s es = (s',r) ⇒ s'.globals = s.globals) ∧ (∀env ^s pes v err_v s' r. evaluate_match env s pes v err_v = (s',r) ⇒ - s'.globals = s.globals)` - (ho_match_mp_tac evaluate_ind >> + s'.globals = s.globals) +Proof + ho_match_mp_tac evaluate_ind >> srw_tac[][evaluate_def] >> - every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> full_simp_tac(srw_ss())[] >> rev_full_simp_tac(srw_ss())[] >> full_simp_tac(srw_ss())[dec_clock_def]); + every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> full_simp_tac(srw_ss())[] >> rev_full_simp_tac(srw_ss())[] >> full_simp_tac(srw_ss())[dec_clock_def] +QED -Theorem evaluate_dec_globals - `∀env st d res. evaluate_dec env st d = res ⇒ - (FST res).globals = st.globals` - (Cases_on`d`>>srw_tac[][evaluate_dec_def] >> srw_tac[][] >> +Theorem evaluate_dec_globals: + ∀env st d res. evaluate_dec env st d = res ⇒ + (FST res).globals = st.globals +Proof + Cases_on`d`>>srw_tac[][evaluate_dec_def] >> srw_tac[][] >> BasicProvers.CASE_TAC >> full_simp_tac(srw_ss())[] >> imp_res_tac evaluate_globals >> - every_case_tac >> full_simp_tac(srw_ss())[]); - -Theorem evaluate_decs_globals - `∀decs env st res. evaluate_decs env st decs = res ⇒ - (FST res).globals = st.globals ++ MAP SOME (FST(SND(SND res)))` - (Induct \\ rw[evaluate_decs_def] \\ rw[] + every_case_tac >> full_simp_tac(srw_ss())[] +QED + +Theorem evaluate_decs_globals: + ∀decs env st res. evaluate_decs env st decs = res ⇒ + (FST res).globals = st.globals ++ MAP SOME (FST(SND(SND res))) +Proof + Induct \\ rw[evaluate_decs_def] \\ rw[] \\ BasicProvers.TOP_CASE_TAC \\ imp_res_tac evaluate_dec_globals \\ reverse BasicProvers.TOP_CASE_TAC >- fs[] @@ -798,7 +911,8 @@ Theorem evaluate_decs_globals \\ BasicProvers.TOP_CASE_TAC \\ res_tac \\ BasicProvers.TOP_CASE_TAC \\ fs[] - \\ BasicProvers.TOP_CASE_TAC \\ fs[]); + \\ BasicProvers.TOP_CASE_TAC \\ fs[] +QED *) val evaluate_decs_add_to_clock_initial_state = Q.prove( @@ -845,13 +959,14 @@ val eval_sim_def = Define ` (!v. res1 = SOME (Rraise v) ==> ?v1. res2 = SOME (Rraise v1)) /\ (!a. res1 = SOME (Rabort a) ==> res2 = SOME (Rabort a))`; -Theorem IMP_semantics_eq - `eval_sim ffi exh1 ctor1 ds1 exh2 ctor2 ds2 rel F /\ +Theorem IMP_semantics_eq: + eval_sim ffi exh1 ctor1 ds1 exh2 ctor2 ds2 rel F /\ semantics exh1 ctor1 (ffi:'ffi ffi_state) ds1 <> Fail ==> rel ds1 ds2 ==> semantics exh1 ctor1 ffi ds1 = - semantics exh2 ctor2 ffi ds2` - (rewrite_tac [GSYM AND_IMP_INTRO] + semantics exh2 ctor2 ffi ds2 +Proof + rewrite_tac [GSYM AND_IMP_INTRO] \\ strip_tac \\ simp [Once semantics_def] \\ IF_CASES_TAC \\ fs [SND_SND_lemma] \\ disch_then kall_tac @@ -981,7 +1096,8 @@ Theorem IMP_semantics_eq \\ qunabbrev_tac `ffi1` \\ metis_tac [evaluate_decs_add_to_clock_io_events_mono, - initial_state_with_clock, FST, ADD_SYM]); + initial_state_with_clock, FST, ADD_SYM] +QED val op_gbag_def = Define ` op_gbag (GlobalVarInit n) = BAG_INSERT n {||} /\ @@ -1036,17 +1152,23 @@ val esgc_free_def = tDefine "esgc_free" ` val esgc_free_def = save_thm("esgc_free_def[simp,compute]", SIMP_RULE (bool_ss ++ ETA_ss) [] esgc_free_def) -Theorem elist_globals_eq_empty - `elist_globals l = {||} ⇔ ∀e. MEM e l ⇒ set_globals e = {||}` - (Induct_on`l` \\ rw[set_globals_def] \\ rw[EQ_IMP_THM] \\ rw[]); - -Theorem elist_globals_append - `elist_globals (xs ++ ys) = elist_globals xs ⊎ elist_globals ys` - (Induct_on `xs` \\ rw [BAG_UNION, FUN_EQ_THM, EMPTY_BAG]); - -Theorem elist_globals_FOLDR - `elist_globals es = FOLDR BAG_UNION {||} (MAP set_globals es)` - (Induct_on `es` >> simp[]); +Theorem elist_globals_eq_empty: + elist_globals l = {||} ⇔ ∀e. MEM e l ⇒ set_globals e = {||} +Proof + Induct_on`l` \\ rw[set_globals_def] \\ rw[EQ_IMP_THM] \\ rw[] +QED + +Theorem elist_globals_append: + elist_globals (xs ++ ys) = elist_globals xs ⊎ elist_globals ys +Proof + Induct_on `xs` \\ rw [BAG_UNION, FUN_EQ_THM, EMPTY_BAG] +QED + +Theorem elist_globals_FOLDR: + elist_globals es = FOLDR BAG_UNION {||} (MAP set_globals es) +Proof + Induct_on `es` >> simp[] +QED val is_Dlet_def = Define ` (is_Dlet (Dlet _) <=> T) /\ diff --git a/compiler/backend/semantics/flatSemScript.sml b/compiler/backend/semantics/flatSemScript.sml index 3e8e56b010..51e20693b9 100644 --- a/compiler/backend/semantics/flatSemScript.sml +++ b/compiler/backend/semantics/flatSemScript.sml @@ -430,12 +430,14 @@ val do_if_def = Define ` else NONE)`; -Theorem do_if_either_or - `do_if v e1 e2 = SOME e ⇒ e = e1 ∨ e = e2` - (simp [do_if_def] +Theorem do_if_either_or: + do_if v e1 e2 = SOME e ⇒ e = e1 ∨ e = e2 +Proof + simp [do_if_def] THEN1 (Cases_on `v = Boolv T` THENL [simp [], - Cases_on `v = Boolv F` THEN simp []])) + Cases_on `v = Boolv F` THEN simp []]) +QED val pat_bindings_def = Define ` (pat_bindings Pany already_bound = already_bound) ∧ @@ -633,24 +635,30 @@ val do_app_cases = save_thm ("do_app_cases", SIMP_CONV (srw_ss()++COND_elim_ss) [LET_THM, eqs] THENC ALL_CONV)); -Theorem do_app_const - `do_app cc s op vs = SOME (s',r) ⇒ s.clock = s'.clock` - (rw [do_app_cases] >> +Theorem do_app_const: + do_app cc s op vs = SOME (s',r) ⇒ s.clock = s'.clock +Proof + rw [do_app_cases] >> rw [] >> - rfs []); - -Theorem evaluate_clock - `(∀env (s1:'a state) e r s2. evaluate env s1 e = (s2,r) ⇒ s2.clock ≤ s1.clock) ∧ - (∀env (s1:'a state) v pes v_err r s2. evaluate_match env s1 v pes v_err = (s2,r) ⇒ s2.clock ≤ s1.clock)` - (ho_match_mp_tac evaluate_ind >> rw[evaluate_def] >> + rfs [] +QED + +Theorem evaluate_clock: + (∀env (s1:'a state) e r s2. evaluate env s1 e = (s2,r) ⇒ s2.clock ≤ s1.clock) ∧ + (∀env (s1:'a state) v pes v_err r s2. evaluate_match env s1 v pes v_err = (s2,r) ⇒ s2.clock ≤ s1.clock) +Proof + ho_match_mp_tac evaluate_ind >> rw[evaluate_def] >> every_case_tac >> fs[dec_clock_def] >> rw[] >> rfs[] >> - imp_res_tac fix_clock_IMP >> imp_res_tac do_app_const >> fs[]); + imp_res_tac fix_clock_IMP >> imp_res_tac do_app_const >> fs[] +QED -Theorem fix_clock_evaluate - `fix_clock s (evaluate env s e) = evaluate env s e` - (Cases_on `evaluate env s e` \\ fs [fix_clock_def] +Theorem fix_clock_evaluate: + fix_clock s (evaluate env s e) = evaluate env s e +Proof + Cases_on `evaluate env s e` \\ fs [fix_clock_def] \\ imp_res_tac evaluate_clock - \\ fs [MIN_DEF,theorem "state_component_equality"]); + \\ fs [MIN_DEF,theorem "state_component_equality"] +QED val evaluate_def = save_thm("evaluate_def[compute]", REWRITE_RULE [fix_clock_evaluate] evaluate_def); diff --git a/compiler/backend/semantics/labPropsScript.sml b/compiler/backend/semantics/labPropsScript.sml index e227a45212..672eb2819a 100644 --- a/compiler/backend/semantics/labPropsScript.sml +++ b/compiler/backend/semantics/labPropsScript.sml @@ -16,10 +16,12 @@ val _ = export_rewrites["extract_labels_def"]; val extract_labels_ind = theorem"extract_labels_ind"; -Theorem extract_labels_append ` - ∀A B. - extract_labels (A++B) = extract_labels A ++ extract_labels B` - (Induct>>fs[extract_labels_def]>>Cases_on`h`>>rw[extract_labels_def]); +Theorem extract_labels_append: + ∀A B. + extract_labels (A++B) = extract_labels A ++ extract_labels B +Proof + Induct>>fs[extract_labels_def]>>Cases_on`h`>>rw[extract_labels_def] +QED val labs_of_def = Define` labs_of (LocValue _ (Lab n1 n2)) = {(n1,n2)} ∧ @@ -39,9 +41,11 @@ val sec_get_labels_def = Define` val get_labels_def = Define` get_labels code = BIGUNION (IMAGE sec_get_labels (set code))`; -Theorem get_labels_cons - `get_labels (x::xs) = sec_get_labels x ∪ get_labels xs` - (rw[get_labels_def]); +Theorem get_labels_cons: + get_labels (x::xs) = sec_get_labels x ∪ get_labels xs +Proof + rw[get_labels_def] +QED val line_get_code_labels_def = Define` line_get_code_labels (Label _ l _) = {l} ∧ @@ -56,24 +60,32 @@ val sec_get_code_labels_def = Define` val get_code_labels_def = Define` get_code_labels code = BIGUNION (IMAGE sec_get_code_labels (set code))`; -Theorem get_code_labels_nil[simp] - `get_code_labels [] = {}` (EVAL_TAC \\ rw[]); +Theorem get_code_labels_nil[simp]: + get_code_labels [] = {} +Proof +EVAL_TAC \\ rw[] +QED -Theorem get_code_labels_cons - `get_code_labels (s::secs) = sec_get_code_labels s ∪ get_code_labels secs` - (rw[get_code_labels_def]); +Theorem get_code_labels_cons: + get_code_labels (s::secs) = sec_get_code_labels s ∪ get_code_labels secs +Proof + rw[get_code_labels_def] +QED val sec_ends_with_label_def = Define` sec_ends_with_label (Section _ ls) ⇔ ¬NULL ls ∧ is_Label (LAST ls)`; -Theorem reg_imm_with_clock[simp] - `reg_imm r (s with clock := z) = reg_imm r s` - (Cases_on`r`>>EVAL_TAC); +Theorem reg_imm_with_clock[simp]: + reg_imm r (s with clock := z) = reg_imm r s +Proof + Cases_on`r`>>EVAL_TAC +QED -Theorem asm_inst_with_clock[simp] - `asm_inst i (s with clock := z) = asm_inst i s with clock := z` - (Cases_on`i`>>EVAL_TAC +Theorem asm_inst_with_clock[simp]: + asm_inst i (s with clock := z) = asm_inst i s with clock := z +Proof + Cases_on`i`>>EVAL_TAC >- (Cases_on`a`>>EVAL_TAC >> every_case_tac >> fs[] >> @@ -87,22 +99,29 @@ Theorem asm_inst_with_clock[simp] >> Cases_on`f`>>EVAL_TAC>> every_case_tac>>fs[]>> - EVAL_TAC>>fs[]); + EVAL_TAC>>fs[] +QED -Theorem read_reg_inc_pc[simp] - `read_reg r (inc_pc s) = read_reg r s` - (EVAL_TAC); +Theorem read_reg_inc_pc[simp]: + read_reg r (inc_pc s) = read_reg r s +Proof + EVAL_TAC +QED -Theorem with_same_clock[simp] - `(s with clock := s.clock) = s` - (rw[state_component_equality]); +Theorem with_same_clock[simp]: + (s with clock := s.clock) = s +Proof + rw[state_component_equality] +QED -Theorem inc_pc_dec_clock - `inc_pc (dec_clock x) = dec_clock (inc_pc x)` - (EVAL_TAC); +Theorem inc_pc_dec_clock: + inc_pc (dec_clock x) = dec_clock (inc_pc x) +Proof + EVAL_TAC +QED -Theorem update_simps[simp] - `((labSem$upd_pc x s).ffi = s.ffi) /\ +Theorem update_simps[simp]: + ((labSem$upd_pc x s).ffi = s.ffi) /\ ((labSem$dec_clock s).ffi = s.ffi) /\ ((labSem$upd_pc x s).pc = x) /\ ((labSem$dec_clock s).pc = s.pc) /\ @@ -147,11 +166,13 @@ Theorem update_simps[simp] ((labSem$inc_pc s).regs = s.regs) ∧ ((labSem$inc_pc s).fp_regs = s.fp_regs) ∧ ((labSem$inc_pc s).pc = s.pc + 1) ∧ - ((labSem$inc_pc s).ffi = s.ffi)` - (EVAL_TAC); + ((labSem$inc_pc s).ffi = s.ffi) +Proof + EVAL_TAC +QED -Theorem binop_upd_consts[simp] - `(labSem$binop_upd a b c d x).mem_domain = x.mem_domain ∧ +Theorem binop_upd_consts[simp]: + (labSem$binop_upd a b c d x).mem_domain = x.mem_domain ∧ (labSem$binop_upd a b c d x).ptr_reg = x.ptr_reg ∧ (labSem$binop_upd a b c d x).ptr2_reg = x.ptr2_reg ∧ (labSem$binop_upd a b c d x).len_reg = x.len_reg ∧ @@ -166,11 +187,13 @@ Theorem binop_upd_consts[simp] (labSem$binop_upd a b c d x).compile_oracle = x.compile_oracle ∧ (labSem$binop_upd a b c d x).code_buffer = x.code_buffer ∧ (labSem$binop_upd a b c d x).pc = x.pc ∧ - (labSem$binop_upd a b c d x).ffi = x.ffi` - (Cases_on`b`>>EVAL_TAC); + (labSem$binop_upd a b c d x).ffi = x.ffi +Proof + Cases_on`b`>>EVAL_TAC +QED -Theorem arith_upd_consts[simp] - `(labSem$arith_upd a x).mem_domain = x.mem_domain ∧ +Theorem arith_upd_consts[simp]: + (labSem$arith_upd a x).mem_domain = x.mem_domain ∧ (labSem$arith_upd a x).ptr_reg = x.ptr_reg ∧ (labSem$arith_upd a x).ptr2_reg = x.ptr2_reg ∧ (labSem$arith_upd a x).len_reg = x.len_reg ∧ @@ -185,12 +208,14 @@ Theorem arith_upd_consts[simp] (labSem$arith_upd a x).compile_oracle = x.compile_oracle ∧ (labSem$arith_upd a x).code_buffer = x.code_buffer ∧ (labSem$arith_upd a x).pc = x.pc ∧ - (labSem$arith_upd a x).ffi = x.ffi` - (Cases_on`a` >> EVAL_TAC >> - every_case_tac >> EVAL_TAC >> rw[]); + (labSem$arith_upd a x).ffi = x.ffi +Proof + Cases_on`a` >> EVAL_TAC >> + every_case_tac >> EVAL_TAC >> rw[] +QED -Theorem fp_upd_consts[simp] - `(labSem$fp_upd f x).mem_domain = x.mem_domain ∧ +Theorem fp_upd_consts[simp]: + (labSem$fp_upd f x).mem_domain = x.mem_domain ∧ (labSem$fp_upd f x).ptr_reg = x.ptr_reg ∧ (labSem$fp_upd f x).len_reg = x.len_reg ∧ (labSem$fp_upd f x).ptr2_reg = x.ptr2_reg ∧ @@ -205,18 +230,22 @@ Theorem fp_upd_consts[simp] (labSem$fp_upd f x).mem = x.mem ∧ (labSem$fp_upd f x).io_regs = x.io_regs ∧ (labSem$fp_upd f x).pc = x.pc ∧ - (labSem$fp_upd f x).ffi = x.ffi` - (Cases_on`f` >> EVAL_TAC >> - every_case_tac >> EVAL_TAC >> rw[]); + (labSem$fp_upd f x).ffi = x.ffi +Proof + Cases_on`f` >> EVAL_TAC >> + every_case_tac >> EVAL_TAC >> rw[] +QED val line_length_def = Define ` (line_length (Label k1 k2 l) = if l = 0 then 0 else 1) /\ (line_length (Asm b bytes l) = LENGTH bytes) /\ (line_length (LabAsm a w bytes l) = LENGTH bytes)` -Theorem LENGTH_line_bytes[simp] - `!x2. ~is_Label x2 ==> (LENGTH (line_bytes x2) = line_length x2)` - (Cases \\ fs [is_Label_def,line_bytes_def,line_length_def] \\ rw []); +Theorem LENGTH_line_bytes[simp]: + !x2. ~is_Label x2 ==> (LENGTH (line_bytes x2) = line_length x2) +Proof + Cases \\ fs [is_Label_def,line_bytes_def,line_length_def] \\ rw [] +QED val good_dimindex_def = Define ` good_dimindex (:'a) <=> dimindex (:'a) = 32 \/ dimindex (:'a) = 64`; @@ -260,10 +289,11 @@ val DIV_EQ_DIV_IMP = Q.prove( \\ rpt strip_tac \\ pop_assum (fn th => once_rewrite_tac [th]) \\ fs []); -Theorem get_byte_set_byte_diff - `good_dimindex (:'a) /\ a <> a' /\ (byte_align a = byte_align a') ==> - (get_byte a (set_byte (a':'a word) b w be) be = get_byte a w be)` - (fs [get_byte_def,set_byte_def,LET_DEF] \\ rpt strip_tac +Theorem get_byte_set_byte_diff: + good_dimindex (:'a) /\ a <> a' /\ (byte_align a = byte_align a') ==> + (get_byte a (set_byte (a':'a word) b w be) be = get_byte a w be) +Proof + fs [get_byte_def,set_byte_def,LET_DEF] \\ rpt strip_tac \\ `byte_index a be <> byte_index a' be` by (fs [good_dimindex_def] THENL @@ -305,16 +335,18 @@ Theorem get_byte_set_byte_diff \\ Cases_on `w ' (i' + byte_index a be)` \\ fs [] \\ imp_res_tac byte_index_LESS_IMP \\ fs [w2w] \\ TRY (match_mp_tac NOT_w2w_bit) - \\ fs [] \\ decide_tac) + \\ fs [] \\ decide_tac +QED fun get_thms ty = { case_def = TypeBase.case_def_of ty, nchotomy = TypeBase.nchotomy_of ty } val case_eq_thms = pair_case_eq::bool_case_eq::map (prove_case_eq_thm o get_thms) [``:'a line``,``:'a option``,``:'a asm_with_lab``,``:'a asm_or_cbw``,``:'a asm``, ``:'a word_loc``,``:'a list``,``:'a sec``,``:'a ffi_result``] |> LIST_CONJ |> curry save_thm "case_eq_thms" -Theorem evaluate_io_events_mono - `∀s1 r s2. evaluate s1 = (r,s2) ⇒ s1.ffi.io_events ≼ s2.ffi.io_events` - (ho_match_mp_tac evaluate_ind >> rw[] >> +Theorem evaluate_io_events_mono: + ∀s1 r s2. evaluate s1 = (r,s2) ⇒ s1.ffi.io_events ≼ s2.ffi.io_events +Proof + ho_match_mp_tac evaluate_ind >> rw[] >> Cases_on`s1.clock=0`>-fs[Once evaluate_def]>>fs[]>> qhdtm_x_assum`evaluate`mp_tac >> simp[Once evaluate_def] >> @@ -332,13 +364,15 @@ Theorem evaluate_io_events_mono \\ Cases_on `s1.compile_oracle 0` \\ fs [] \\ fs[case_eq_thms] \\ rveq \\ fs [] \\ first_x_assum match_mp_tac - \\ qpat_x_assum `(_,_) = _` (assume_tac o GSYM) \\ fs []); + \\ qpat_x_assum `(_,_) = _` (assume_tac o GSYM) \\ fs [] +QED -Theorem evaluate_ADD_clock - `!s res r k. +Theorem evaluate_ADD_clock: + !s res r k. evaluate s = (res,r) /\ res <> TimeOut ==> - evaluate (s with clock := s.clock + k) = (res,r with clock := r.clock + k)` - (ho_match_mp_tac evaluate_ind >> rw[] >> + evaluate (s with clock := s.clock + k) = (res,r with clock := r.clock + k) +Proof + ho_match_mp_tac evaluate_ind >> rw[] >> qhdtm_x_assum`evaluate`mp_tac >> simp[Once evaluate_def] >> IF_CASES_TAC >> fs[] >> strip_tac >> @@ -347,13 +381,15 @@ Theorem evaluate_ADD_clock fs[inc_pc_def,dec_clock_def,asm_inst_consts,upd_pc_def,get_pc_value_def,get_ret_Loc_def,upd_reg_def] >> fsrw_tac[ARITH_ss][] >> rw[] >> fs[] >> rfs[] >> TRY pairarg_tac >> fs[case_eq_thms] >> rw[]>> - first_x_assum(qspec_then`k`mp_tac)>>simp[]); + first_x_assum(qspec_then`k`mp_tac)>>simp[] +QED -Theorem evaluate_add_clock_io_events_mono - `∀s. +Theorem evaluate_add_clock_io_events_mono: + ∀s. (SND(evaluate s)).ffi.io_events ≼ - (SND(evaluate (s with clock := s.clock + extra))).ffi.io_events` - (ho_match_mp_tac evaluate_ind >> + (SND(evaluate (s with clock := s.clock + extra))).ffi.io_events +Proof + ho_match_mp_tac evaluate_ind >> rpt gen_tac >> strip_tac >> CONV_TAC(DEPTH_CONV(REWR_CONV evaluate_def)) >> simp[] >> @@ -387,14 +423,15 @@ Theorem evaluate_add_clock_io_events_mono every_case_tac >> fs[] >> fs[inc_pc_def,dec_clock_def,asm_inst_consts,upd_pc_def,get_pc_value_def,get_ret_Loc_def,upd_reg_def] >> fsrw_tac[ARITH_ss][] >> rw[] >> fs[] >> rfs[] >> - rev_full_simp_tac(srw_ss()++ARITH_ss)[]); + rev_full_simp_tac(srw_ss()++ARITH_ss)[] +QED val align_dm_def = Define ` align_dm (s:('a,'c,'ffi) labSem$state) = (s with mem_domain := s.mem_domain INTER byte_aligned)` -Theorem align_dm_const[simp] - `(align_dm s).clock = s.clock ∧ +Theorem align_dm_const[simp]: + (align_dm s).clock = s.clock ∧ (align_dm s).pc = s.pc ∧ (align_dm s).code = s.code ∧ (align_dm s).mem = s.mem ∧ @@ -409,59 +446,84 @@ Theorem align_dm_const[simp] (align_dm s).compile = s.compile ∧ (align_dm s).compile_oracle = s.compile_oracle ∧ (align_dm s).ffi = s.ffi ∧ - (align_dm s).failed = s.failed` - (EVAL_TAC); - -Theorem align_dm_with_clock - `align_dm (s with clock := k) = align_dm s with clock := k` - (EVAL_TAC); - -Theorem asm_fetch_align_dm[simp] - `asm_fetch (align_dm s) = asm_fetch s` - (rw[asm_fetch_def]); - -Theorem read_reg_align_dm[simp] - `read_reg n (align_dm s) = read_reg n s` - (EVAL_TAC); - -Theorem upd_reg_align_dm[simp] - `upd_reg x y (align_dm s) = align_dm (upd_reg x y s)` - (EVAL_TAC); - -Theorem upd_mem_align_dm[simp] - `upd_mem x y (align_dm s) = align_dm (upd_mem x y s)` - (EVAL_TAC); - -Theorem binop_upd_align_dm[simp] - `binop_upd x y z w (align_dm s) = align_dm (binop_upd x y z w s)` - (Cases_on`y` \\ simp[binop_upd_def]); - -Theorem reg_imm_align_dm[simp] - `reg_imm r (align_dm s) = reg_imm r s` - (Cases_on`r` \\ EVAL_TAC); - -Theorem assert_align_dm[simp] - `assert b (align_dm s) = align_dm (assert b s)` - (EVAL_TAC); - -Theorem arith_upd_align_dm[simp] - `arith_upd x (align_dm s) = align_dm (arith_upd x s)` - (Cases_on`x` \\ rw[arith_upd_def] - \\ every_case_tac \\ fs[]); - -Theorem fp_upd_align_dm[simp] - `fp_upd f (align_dm s) = align_dm (fp_upd f s)` - (Cases_on`f` \\ EVAL_TAC - \\ every_case_tac \\ fs[] \\ EVAL_TAC \\fs[]); - -Theorem addr_align_dm[simp] - `addr a (align_dm s) = addr a s` - (Cases_on`a` \\ EVAL_TAC); - -Theorem mem_load_align_dm - `good_dimindex (:α) ⇒ - mem_load n (a:α addr) (align_dm s) = align_dm (mem_load n a s)` - (strip_tac + (align_dm s).failed = s.failed +Proof + EVAL_TAC +QED + +Theorem align_dm_with_clock: + align_dm (s with clock := k) = align_dm s with clock := k +Proof + EVAL_TAC +QED + +Theorem asm_fetch_align_dm[simp]: + asm_fetch (align_dm s) = asm_fetch s +Proof + rw[asm_fetch_def] +QED + +Theorem read_reg_align_dm[simp]: + read_reg n (align_dm s) = read_reg n s +Proof + EVAL_TAC +QED + +Theorem upd_reg_align_dm[simp]: + upd_reg x y (align_dm s) = align_dm (upd_reg x y s) +Proof + EVAL_TAC +QED + +Theorem upd_mem_align_dm[simp]: + upd_mem x y (align_dm s) = align_dm (upd_mem x y s) +Proof + EVAL_TAC +QED + +Theorem binop_upd_align_dm[simp]: + binop_upd x y z w (align_dm s) = align_dm (binop_upd x y z w s) +Proof + Cases_on`y` \\ simp[binop_upd_def] +QED + +Theorem reg_imm_align_dm[simp]: + reg_imm r (align_dm s) = reg_imm r s +Proof + Cases_on`r` \\ EVAL_TAC +QED + +Theorem assert_align_dm[simp]: + assert b (align_dm s) = align_dm (assert b s) +Proof + EVAL_TAC +QED + +Theorem arith_upd_align_dm[simp]: + arith_upd x (align_dm s) = align_dm (arith_upd x s) +Proof + Cases_on`x` \\ rw[arith_upd_def] + \\ every_case_tac \\ fs[] +QED + +Theorem fp_upd_align_dm[simp]: + fp_upd f (align_dm s) = align_dm (fp_upd f s) +Proof + Cases_on`f` \\ EVAL_TAC + \\ every_case_tac \\ fs[] \\ EVAL_TAC \\fs[] +QED + +Theorem addr_align_dm[simp]: + addr a (align_dm s) = addr a s +Proof + Cases_on`a` \\ EVAL_TAC +QED + +Theorem mem_load_align_dm: + good_dimindex (:α) ⇒ + mem_load n (a:α addr) (align_dm s) = align_dm (mem_load n a s) +Proof + strip_tac \\ simp[mem_load_def] \\ every_case_tac \\ fs[] \\ AP_TERM_TAC @@ -489,34 +551,40 @@ Theorem mem_load_align_dm \\ first_assum (CHANGED_TAC o SUBST1_TAC) \\ CONV_TAC(RAND_CONV(SIMP_CONV(srw_ss())[])) \\ match_mp_tac LESS_MOD - \\ metis_tac[Q.SPECL[`8`,`n`](MP_CANON DIVISION) |> SIMP_RULE(srw_ss())[],ADD_0])); + \\ metis_tac[Q.SPECL[`8`,`n`](MP_CANON DIVISION) |> SIMP_RULE(srw_ss())[],ADD_0]) +QED -Theorem mem_load_byte_aux_align_dm - `mem_load_byte_aux s.mem s.mem_domain be x = SOME y ⇒ - mem_load_byte_aux s.mem (align_dm s).mem_domain be x = SOME y` - (rw[mem_load_byte_aux_def] +Theorem mem_load_byte_aux_align_dm: + mem_load_byte_aux s.mem s.mem_domain be x = SOME y ⇒ + mem_load_byte_aux s.mem (align_dm s).mem_domain be x = SOME y +Proof + rw[mem_load_byte_aux_def] \\ every_case_tac \\ fs[] \\ fs[align_dm_def] \\ last_x_assum mp_tac \\ simp[] \\ fs[IN_DEF,alignmentTheory.byte_aligned_def,alignmentTheory.byte_align_def] - \\ fs[alignmentTheory.aligned_align]); + \\ fs[alignmentTheory.aligned_align] +QED -Theorem mem_load_byte_align_dm - `good_dimindex (:α) ⇒ - mem_load_byte n (a:α addr) (align_dm s) = align_dm (mem_load_byte n a s)` - (strip_tac +Theorem mem_load_byte_align_dm: + good_dimindex (:α) ⇒ + mem_load_byte n (a:α addr) (align_dm s) = align_dm (mem_load_byte n a s) +Proof + strip_tac \\ simp[mem_load_byte_def] \\ every_case_tac \\ fs[] \\ imp_res_tac mem_load_byte_aux_align_dm \\ fs[] \\ fs[mem_load_byte_aux_def] \\ fs[align_dm_def] - \\ every_case_tac \\ fs[]); + \\ every_case_tac \\ fs[] +QED -Theorem mem_store_align_dm - `good_dimindex (:α) ⇒ - mem_store n (a:α addr) (align_dm s) = align_dm (mem_store n a s)` - (strip_tac +Theorem mem_store_align_dm: + good_dimindex (:α) ⇒ + mem_store n (a:α addr) (align_dm s) = align_dm (mem_store n a s) +Proof + strip_tac \\ simp[mem_store_def] \\ every_case_tac \\ fs[] \\ AP_TERM_TAC @@ -544,68 +612,88 @@ Theorem mem_store_align_dm \\ first_assum (CHANGED_TAC o SUBST1_TAC) \\ CONV_TAC(RAND_CONV(SIMP_CONV(srw_ss())[])) \\ match_mp_tac LESS_MOD - \\ metis_tac[Q.SPECL[`8`,`n`](MP_CANON DIVISION) |> SIMP_RULE(srw_ss())[],ADD_0])); + \\ metis_tac[Q.SPECL[`8`,`n`](MP_CANON DIVISION) |> SIMP_RULE(srw_ss())[],ADD_0]) +QED -Theorem mem_store_byte_aux_align_dm - `mem_store_byte_aux mem s.mem_domain be x c = SOME y ⇒ - mem_store_byte_aux mem (align_dm s).mem_domain be x c = SOME y` - (rw[mem_store_byte_aux_def] +Theorem mem_store_byte_aux_align_dm: + mem_store_byte_aux mem s.mem_domain be x c = SOME y ⇒ + mem_store_byte_aux mem (align_dm s).mem_domain be x c = SOME y +Proof + rw[mem_store_byte_aux_def] \\ every_case_tac \\ fs[] \\ fs[align_dm_def] \\ last_x_assum mp_tac \\ simp[] \\ fs[IN_DEF,alignmentTheory.byte_aligned_def,alignmentTheory.byte_align_def] - \\ fs[alignmentTheory.aligned_align]); + \\ fs[alignmentTheory.aligned_align] +QED -Theorem mem_store_byte_align_dm - `good_dimindex (:α) ⇒ - mem_store_byte n (a:α addr) (align_dm s) = align_dm (mem_store_byte n a s)` - (strip_tac +Theorem mem_store_byte_align_dm: + good_dimindex (:α) ⇒ + mem_store_byte n (a:α addr) (align_dm s) = align_dm (mem_store_byte n a s) +Proof + strip_tac \\ simp[mem_store_byte_def] \\ every_case_tac \\ fs[] \\ imp_res_tac mem_store_byte_aux_align_dm \\ fs[] \\ fs[mem_store_byte_aux_def] \\ fs[align_dm_def] - \\ every_case_tac \\ fs[]); + \\ every_case_tac \\ fs[] +QED -Theorem mem_op_align_dm - `good_dimindex (:α) ⇒ - mem_op m n (a:α addr) (align_dm s) = align_dm (mem_op m n a s)` - (Cases_on`m` +Theorem mem_op_align_dm: + good_dimindex (:α) ⇒ + mem_op m n (a:α addr) (align_dm s) = align_dm (mem_op m n a s) +Proof + Cases_on`m` \\ simp[mem_op_def, mem_load_align_dm,mem_load_byte_align_dm, - mem_store_align_dm,mem_store_byte_align_dm]); + mem_store_align_dm,mem_store_byte_align_dm] +QED -Theorem asm_inst_align_dm - `good_dimindex (:α) ⇒ - asm_inst (i:α inst) (align_dm s) = align_dm (asm_inst i s)` - (Cases_on`i` \\ simp[asm_inst_def,mem_op_align_dm]); +Theorem asm_inst_align_dm: + good_dimindex (:α) ⇒ + asm_inst (i:α inst) (align_dm s) = align_dm (asm_inst i s) +Proof + Cases_on`i` \\ simp[asm_inst_def,mem_op_align_dm] +QED -Theorem dec_clock_align_dm[simp] - `dec_clock (align_dm s) = align_dm (dec_clock s)` - (EVAL_TAC); +Theorem dec_clock_align_dm[simp]: + dec_clock (align_dm s) = align_dm (dec_clock s) +Proof + EVAL_TAC +QED -Theorem inc_pc_align_dm[simp] - `inc_pc (align_dm s) = align_dm (inc_pc s)` - (EVAL_TAC); +Theorem inc_pc_align_dm[simp]: + inc_pc (align_dm s) = align_dm (inc_pc s) +Proof + EVAL_TAC +QED -Theorem upd_pc_align_dm[simp] - `upd_pc p (align_dm s) = align_dm (upd_pc p s)` - (EVAL_TAC); +Theorem upd_pc_align_dm[simp]: + upd_pc p (align_dm s) = align_dm (upd_pc p s) +Proof + EVAL_TAC +QED -Theorem get_pc_value_align_dm[simp] - `get_pc_value x (align_dm s) = get_pc_value x s` - (EVAL_TAC \\ every_case_tac); +Theorem get_pc_value_align_dm[simp]: + get_pc_value x (align_dm s) = get_pc_value x s +Proof + EVAL_TAC \\ every_case_tac +QED -Theorem get_ret_Loc_align_dm[simp] - `get_ret_Loc (align_dm s) = get_ret_Loc s` - (EVAL_TAC); +Theorem get_ret_Loc_align_dm[simp]: + get_ret_Loc (align_dm s) = get_ret_Loc s +Proof + EVAL_TAC +QED -Theorem read_bytearray_mem_load_byte_aux_align_dm[simp] - `∀y x. +Theorem read_bytearray_mem_load_byte_aux_align_dm[simp]: + ∀y x. read_bytearray x y (mem_load_byte_aux s.mem (align_dm s).mem_domain s.be) = - read_bytearray x y (mem_load_byte_aux s.mem s.mem_domain s.be)` - (Induct \\ rw[read_bytearray_def] + read_bytearray x y (mem_load_byte_aux s.mem s.mem_domain s.be) +Proof + Induct \\ rw[read_bytearray_def] \\ match_mp_tac EQ_SYM \\ BasicProvers.TOP_CASE_TAC >- ( @@ -613,12 +701,14 @@ Theorem read_bytearray_mem_load_byte_aux_align_dm[simp] \\ Cases_on`s.mem (byte_align x)` \\ fs[] \\ simp[align_dm_def] ) \\ imp_res_tac mem_load_byte_aux_align_dm - \\ simp[]); + \\ simp[] +QED -Theorem write_bytearray_align_dm[simp] - `∀y x. write_bytearray x y s.mem (align_dm s).mem_domain s.be = - write_bytearray x y s.mem s.mem_domain s.be` - (Induct \\ rw[write_bytearray_def] +Theorem write_bytearray_align_dm[simp]: + ∀y x. write_bytearray x y s.mem (align_dm s).mem_domain s.be = + write_bytearray x y s.mem s.mem_domain s.be +Proof + Induct \\ rw[write_bytearray_def] \\ match_mp_tac EQ_SYM \\ BasicProvers.TOP_CASE_TAC >- ( @@ -627,14 +717,16 @@ Theorem write_bytearray_align_dm[simp] \\ pop_assum mp_tac \\ BasicProvers.TOP_CASE_TAC \\ fs[] \\ simp[align_dm_def] ) - \\ imp_res_tac mem_store_byte_aux_align_dm \\ fs[]); + \\ imp_res_tac mem_store_byte_aux_align_dm \\ fs[] +QED -Theorem evaluate_align_dm - `good_dimindex(:α) ⇒ +Theorem evaluate_align_dm: + good_dimindex(:α) ⇒ ∀(s:(α,'c,'ffi) labSem$state). evaluate (align_dm s) = - let (r,s') = evaluate s in (r, align_dm s')` - (strip_tac + let (r,s') = evaluate s in (r, align_dm s') +Proof + strip_tac \\ ho_match_mp_tac evaluate_ind \\ rpt strip_tac \\ simp[Once evaluate_def] @@ -656,12 +748,14 @@ Theorem evaluate_align_dm \\ simp[Once evaluate_def,SimpRHS] \\ simp[case_eq_thms] \\ rpt(pairarg_tac \\ fs[] \\ rveq \\ fs[]) \\ fs[align_dm_def,case_eq_thms] - \\ rveq \\ fs[] \\ pairarg_tac \\ fs[] \\ rfs[]); + \\ rveq \\ fs[] \\ pairarg_tac \\ fs[] \\ rfs[] +QED -Theorem implements_align_dm - `good_dimindex(:α) ⇒ - implements {semantics (s:(α,'c,'ffi) labSem$state)} {semantics (align_dm s)}` - (strip_tac +Theorem implements_align_dm: + good_dimindex(:α) ⇒ + implements {semantics (s:(α,'c,'ffi) labSem$state)} {semantics (align_dm s)} +Proof + strip_tac \\ irule implements_intro \\ qexists_tac`T` \\ simp[] \\ simp[semantics_def,GSYM align_dm_with_clock] @@ -671,7 +765,8 @@ Theorem implements_align_dm \\ strip_tac \\ rpt (AP_TERM_TAC ORELSE AP_THM_TAC) \\ simp[FUN_EQ_THM] - \\ METIS_TAC[]); + \\ METIS_TAC[] +QED (* asm_ok checks coming into lab_to_target *) val line_ok_pre_def = Define` @@ -697,40 +792,48 @@ val sec_labels_ok_def = Define` sec_labels_ok (Section k ls) ⇔ EVERY (sec_label_ok k) ls`; val _ = export_rewrites["sec_labels_ok_def"]; -Theorem sec_label_ok_extract_labels - `EVERY (sec_label_ok n1) lines ∧ +Theorem sec_label_ok_extract_labels: + EVERY (sec_label_ok n1) lines ∧ MEM (n1',n2) (extract_labels lines) ⇒ - n1' = n1 ∧ n2 ≠ 0` - (Induct_on`lines` \\ simp[] - \\ Cases \\ rw[] \\ fs[]); + n1' = n1 ∧ n2 ≠ 0 +Proof + Induct_on`lines` \\ simp[] + \\ Cases \\ rw[] \\ fs[] +QED -Theorem EVERY_sec_label_ok - `EVERY (λ(l1,l2). l1 = n ∧ l2 ≠ 0) (extract_labels l) (*∧ +Theorem EVERY_sec_label_ok: + EVERY (λ(l1,l2). l1 = n ∧ l2 ≠ 0) (extract_labels l) (*∧ ALL_DISTINCT (extract_labels l) *)⇔ - EVERY (sec_label_ok n) l` - (Induct_on`l`>>simp[extract_labels_def]>> - Cases>>simp[extract_labels_def]); + EVERY (sec_label_ok n) l +Proof + Induct_on`l`>>simp[extract_labels_def]>> + Cases>>simp[extract_labels_def] +QED -Theorem line_get_code_labels_extract_labels - `∀l. +Theorem line_get_code_labels_extract_labels: + ∀l. BIGUNION (IMAGE line_get_code_labels (set l)) = - IMAGE SND (set (extract_labels l))` - (recInduct extract_labels_ind + IMAGE SND (set (extract_labels l)) +Proof + recInduct extract_labels_ind \\ rw[extract_labels_def] - \\ rw[EXTENSION]); + \\ rw[EXTENSION] +QED -Theorem get_code_labels_extract_labels - `∀code. +Theorem get_code_labels_extract_labels: + ∀code. EVERY sec_labels_ok code ⇒ get_code_labels code = IMAGE (λs. (Section_num s, 0)) (set code) ∪ - set (FLAT (MAP (extract_labels o Section_lines) code))` - (Induct \\ simp[get_code_labels_cons] \\ Cases + set (FLAT (MAP (extract_labels o Section_lines) code)) +Proof + Induct \\ simp[get_code_labels_cons] \\ Cases \\ rw[sec_get_code_labels_def, LIST_TO_SET_FLAT] \\ rw[line_get_code_labels_extract_labels] \\ rw[UNION_ASSOC] \\ AP_THM_TAC \\ AP_TERM_TAC \\ rw[Once EXTENSION, EXISTS_PROD, FORALL_PROD] - \\ metis_tac[sec_label_ok_extract_labels]); + \\ metis_tac[sec_label_ok_extract_labels] +QED val _ = export_theory(); diff --git a/compiler/backend/semantics/labSemScript.sml b/compiler/backend/semantics/labSemScript.sml index 107aab12b6..e1e6cf9527 100644 --- a/compiler/backend/semantics/labSemScript.sml +++ b/compiler/backend/semantics/labSemScript.sml @@ -308,8 +308,8 @@ val loc_to_pc_def = Define ` | NONE => NONE | SOME pos => SOME (pos + 1:num))`; -Theorem asm_inst_consts - `((asm_inst i s).pc = s.pc) /\ +Theorem asm_inst_consts: + ((asm_inst i s).pc = s.pc) /\ ((asm_inst i s).code = s.code) /\ ((asm_inst i s).clock = s.clock) /\ ((asm_inst i s).ffi = s.ffi) ∧ @@ -317,8 +317,9 @@ Theorem asm_inst_consts ((asm_inst i s).len_reg = s.len_reg) ∧ ((asm_inst i s).ptr2_reg = s.ptr2_reg) ∧ ((asm_inst i s).len2_reg = s.len2_reg) ∧ - ((asm_inst i s).link_reg = s.link_reg)` - (Cases_on `i` \\ fs [asm_inst_def,upd_reg_def,arith_upd_def] + ((asm_inst i s).link_reg = s.link_reg) +Proof + Cases_on `i` \\ fs [asm_inst_def,upd_reg_def,arith_upd_def] >- (Cases_on `a` \\ fs [asm_inst_def,upd_reg_def,arith_upd_def] @@ -333,7 +334,8 @@ Theorem asm_inst_consts >> Cases_on`f` \\ fs[fp_upd_def,upd_reg_def,upd_fp_reg_def,assert_def] - \\ BasicProvers.EVERY_CASE_TAC \\ fs[upd_fp_reg_def]) ; + \\ BasicProvers.EVERY_CASE_TAC \\ fs[upd_fp_reg_def] +QED ; val get_pc_value_def = Define ` get_pc_value lab (s:('a,'c,'ffi) labSem$state) = diff --git a/compiler/backend/semantics/patPropsScript.sml b/compiler/backend/semantics/patPropsScript.sml index a5b47f9ddd..c0cde7d924 100644 --- a/compiler/backend/semantics/patPropsScript.sml +++ b/compiler/backend/semantics/patPropsScript.sml @@ -8,7 +8,11 @@ val _ = new_theory"patProps" val evaluate_lit = save_thm("evaluate_lit[simp]", EVAL``patSem$evaluate env s [Lit tra l]``) -Theorem Boolv_11[simp] `patSem$Boolv b1 = Boolv b2 ⇔ b1 = b2` (EVAL_TAC>>srw_tac[][]); +Theorem Boolv_11[simp]: + patSem$Boolv b1 = Boolv b2 ⇔ b1 = b2 +Proof +EVAL_TAC>>srw_tac[][] +QED val Boolv_disjoint = save_thm("Boolv_disjoint",EVAL``patSem$Boolv T = Boolv F``); @@ -28,73 +32,88 @@ val no_closures_def = tDefine"no_closures"` simp[v_size_def]>>srw_tac[][]>>res_tac>>simp[]) val _ = export_rewrites["no_closures_def"]; -Theorem no_closures_Boolv[simp] - `no_closures (Boolv b)` - (EVAL_TAC); - -Theorem evaluate_raise_rval - `∀env s e s' v. patSem$evaluate env s [Raise tra e] ≠ (s', Rval v)` - (EVAL_TAC >> srw_tac[][] >> every_case_tac >> simp[]) +Theorem no_closures_Boolv[simp]: + no_closures (Boolv b) +Proof + EVAL_TAC +QED + +Theorem evaluate_raise_rval: + ∀env s e s' v. patSem$evaluate env s [Raise tra e] ≠ (s', Rval v) +Proof + EVAL_TAC >> srw_tac[][] >> every_case_tac >> simp[] +QED val _ = export_rewrites["evaluate_raise_rval"] -Theorem evaluate_length - `∀env s ls s' vs. - evaluate env s ls = (s',Rval vs) ⇒ LENGTH vs = LENGTH ls` - (ho_match_mp_tac evaluate_ind >> rw[evaluate_def] +Theorem evaluate_length: + ∀env s ls s' vs. + evaluate env s ls = (s',Rval vs) ⇒ LENGTH vs = LENGTH ls +Proof + ho_match_mp_tac evaluate_ind >> rw[evaluate_def] \\ fs[case_eq_thms,pair_case_eq,bool_case_eq] \\ rw[] \\ fs[] \\ TRY(qpat_x_assum`(_,_) = _`(assume_tac o SYM)) \\ fs[] \\ rename1`list_result lr` - \\ Cases_on`lr` \\ fs[] \\ rw[]); + \\ Cases_on`lr` \\ fs[] \\ rw[] +QED -Theorem evaluate_cons - `evaluate env s (e::es) = +Theorem evaluate_cons: + evaluate env s (e::es) = (case evaluate env s [e] of | (s,Rval v) => (case evaluate env s es of | (s,Rval vs) => (s,Rval (v++vs)) | r => r) - | r => r)` - (Cases_on`es`>>srw_tac[][evaluate_def] >> + | r => r) +Proof + Cases_on`es`>>srw_tac[][evaluate_def] >> every_case_tac >> full_simp_tac(srw_ss())[evaluate_def] >> - imp_res_tac evaluate_length >> full_simp_tac(srw_ss())[SING_HD]); + imp_res_tac evaluate_length >> full_simp_tac(srw_ss())[SING_HD] +QED -Theorem evaluate_sing - `evaluate env s [e] = (s',Rval vs) ⇒ ∃y. vs = [y]` - (srw_tac[][] >> imp_res_tac evaluate_length >> full_simp_tac(srw_ss())[] >> metis_tac[SING_HD]) +Theorem evaluate_sing: + evaluate env s [e] = (s',Rval vs) ⇒ ∃y. vs = [y] +Proof + srw_tac[][] >> imp_res_tac evaluate_length >> full_simp_tac(srw_ss())[] >> metis_tac[SING_HD] +QED -Theorem evaluate_append_Rval - `∀l1 env s l2 s' vs. +Theorem evaluate_append_Rval: + ∀l1 env s l2 s' vs. evaluate env s (l1 ++ l2) = (s',Rval vs) ⇒ ∃s1 v1 v2. evaluate env s l1 = (s1,Rval v1) ∧ evaluate env s1 l2 = (s',Rval v2) ∧ - vs = v1++v2` - (Induct >> simp[evaluate_def,Once evaluate_cons] >> + vs = v1++v2 +Proof + Induct >> simp[evaluate_def,Once evaluate_cons] >> srw_tac[][] >> simp[Once evaluate_cons] >> every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> res_tac >> - srw_tac[][] >> full_simp_tac(srw_ss())[] >> srw_tac[][]); + srw_tac[][] >> full_simp_tac(srw_ss())[] >> srw_tac[][] +QED -Theorem evaluate_append_Rval_iff - `∀l1 env s l2 s' vs. +Theorem evaluate_append_Rval_iff: + ∀l1 env s l2 s' vs. evaluate env s (l1 ++ l2) = (s',Rval vs) ⇔ ∃s1 v1 v2. evaluate env s l1 = (s1,Rval v1) ∧ evaluate env s1 l2 = (s',Rval v2) ∧ - vs = v1++v2` - (srw_tac[][] >> EQ_TAC >- MATCH_ACCEPT_TAC evaluate_append_Rval >> + vs = v1++v2 +Proof + srw_tac[][] >> EQ_TAC >- MATCH_ACCEPT_TAC evaluate_append_Rval >> map_every qid_spec_tac[`vs`,`s`] >> Induct_on`l1`>>srw_tac[][evaluate_def,Once evaluate_cons] >> srw_tac[][] >> srw_tac[][Once evaluate_cons] >> every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> full_simp_tac(srw_ss())[PULL_EXISTS] >> - res_tac >> full_simp_tac(srw_ss())[]); + res_tac >> full_simp_tac(srw_ss())[] +QED -Theorem evaluate_append_Rerr - `∀l1 env s l2 s' e. +Theorem evaluate_append_Rerr: + ∀l1 env s l2 s' e. evaluate env s (l1 ++ l2) = (s',Rerr e) ⇔ (evaluate env s l1 = (s', Rerr e) ∨ ∃s1 v1. evaluate env s l1 = (s1, Rval v1) ∧ - evaluate env s1 l2 = (s', Rerr e))` - (Induct >> srw_tac[][evaluate_def] >> + evaluate env s1 l2 = (s', Rerr e)) +Proof + Induct >> srw_tac[][evaluate_def] >> srw_tac[][Once evaluate_cons] >> MATCH_MP_TAC EQ_SYM >> srw_tac[][Once evaluate_cons] >> MATCH_MP_TAC EQ_SYM >> every_case_tac >> simp[] >> @@ -103,17 +122,19 @@ Theorem evaluate_append_Rerr spose_not_then strip_assume_tac >> srw_tac[][] >> full_simp_tac(srw_ss())[] >> full_simp_tac(srw_ss())[evaluate_append_Rval_iff] >> first_x_assum(qspecl_then[`env`,`q`,`l2`]mp_tac) >> - simp[] >> metis_tac[]); + simp[] >> metis_tac[] +QED -Theorem evaluate_append - `evaluate env s (l1 ++ l2) = +Theorem evaluate_append: + evaluate env s (l1 ++ l2) = case evaluate env s l1 of | (s,Rval v1) => (case evaluate env s l2 of | (s,Rval v2) => (s,Rval(v1++v2)) | r => r) - | r => r` - (map_every qid_spec_tac[`l2`,`s`] >> Induct_on`l1` >> + | r => r +Proof + map_every qid_spec_tac[`l2`,`s`] >> Induct_on`l1` >> srw_tac[][evaluate_def] >- ( every_case_tac >> full_simp_tac(srw_ss())[] ) >> srw_tac[][Once evaluate_cons] >> @@ -121,16 +142,20 @@ Theorem evaluate_append srw_tac[][Once evaluate_cons] >> BasicProvers.CASE_TAC >> full_simp_tac(srw_ss())[] >> Cases_on`r`>>full_simp_tac(srw_ss())[] >> - every_case_tac >> full_simp_tac(srw_ss())[]); - -Theorem dec_clock_with_clock[simp] - `dec_clock s with clock := y = s with clock := y` - (EVAL_TAC); - -Theorem do_app_add_to_clock - `(do_app (s with clock := s.clock + extra) op vs = - OPTION_MAP (λ(s',r). (s' with clock := s'.clock + extra,r)) (do_app s op vs))` - (Cases_on`do_app s op vs` + every_case_tac >> full_simp_tac(srw_ss())[] +QED + +Theorem dec_clock_with_clock[simp]: + dec_clock s with clock := y = s with clock := y +Proof + EVAL_TAC +QED + +Theorem do_app_add_to_clock: + (do_app (s with clock := s.clock + extra) op vs = + OPTION_MAP (λ(s',r). (s' with clock := s'.clock + extra,r)) (do_app s op vs)) +Proof + Cases_on`do_app s op vs` \\ ((pop_assum(strip_assume_tac o CONV_RULE(REWR_CONV do_app_cases_none))) ORELSE(pop_assum(strip_assume_tac o CONV_RULE(REWR_CONV do_app_cases)))) \\ rw[do_app_def] >> @@ -138,34 +163,42 @@ Theorem do_app_add_to_clock semanticPrimitivesTheory.store_lookup_def, semanticPrimitivesTheory.store_assign_def] >> srw_tac[][] - >> every_case_tac \\ fs[] \\ rw[] \\ rfs[]); - -Theorem do_app_const - `do_app s op vs = SOME (s',r) ⇒ s'.compile = s.compile` - (rw[do_app_def,case_eq_thms,bool_case_eq,UNCURRY,pair_case_eq] \\ rw[]); - -Theorem do_install_with_clock - `do_install vs (s with clock := k) = - OPTION_MAP (λ(e,s'). (e, s' with clock := k)) (do_install vs s)` - (rw[do_install_def] \\ rpt(PURE_TOP_CASE_TAC \\ fs[UNCURRY])); - -Theorem do_install_const - `do_install vs s = SOME (e,s') ⇒ s'.ffi = s.ffi ∧ s'.clock = s.clock ∧ s'.compile = s.compile` - (rw[do_install_def,case_eq_thms,UNCURRY,pair_case_eq] \\ rw[]); - -Theorem evaluate_add_to_clock - `∀env s es s' r. + >> every_case_tac \\ fs[] \\ rw[] \\ rfs[] +QED + +Theorem do_app_const: + do_app s op vs = SOME (s',r) ⇒ s'.compile = s.compile +Proof + rw[do_app_def,case_eq_thms,bool_case_eq,UNCURRY,pair_case_eq] \\ rw[] +QED + +Theorem do_install_with_clock: + do_install vs (s with clock := k) = + OPTION_MAP (λ(e,s'). (e, s' with clock := k)) (do_install vs s) +Proof + rw[do_install_def] \\ rpt(PURE_TOP_CASE_TAC \\ fs[UNCURRY]) +QED + +Theorem do_install_const: + do_install vs s = SOME (e,s') ⇒ s'.ffi = s.ffi ∧ s'.clock = s.clock ∧ s'.compile = s.compile +Proof + rw[do_install_def,case_eq_thms,UNCURRY,pair_case_eq] \\ rw[] +QED + +Theorem evaluate_add_to_clock: + ∀env s es s' r. evaluate env s es = (s',r) ∧ r ≠ Rerr (Rabort Rtimeout_error) ⇒ evaluate env (s with clock := s.clock + extra) es = - (s' with clock := s'.clock + extra,r)` - (ho_match_mp_tac evaluate_ind >> + (s' with clock := s'.clock + extra,r) +Proof + ho_match_mp_tac evaluate_ind >> srw_tac[][evaluate_def,case_eq_thms,pair_case_eq] >> full_simp_tac(srw_ss())[do_app_add_to_clock,do_install_with_clock,case_eq_thms,pair_case_eq,bool_case_eq] >> srw_tac[][] >> rev_full_simp_tac(srw_ss())[] >> rev_full_simp_tac(srw_ss()++ARITH_ss)[dec_clock_def] >> imp_res_tac do_install_const >> fs [] \\ rfs[] -); +QED val do_app_io_events_mono = Q.prove( `do_app s op vs = SOME(s',r) ⇒ @@ -180,11 +213,13 @@ val do_app_io_events_mono = Q.prove( full_simp_tac(srw_ss())[ffiTheory.call_FFI_def,IS_SOME_EXISTS] >> every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][]); -Theorem evaluate_io_events_mono - `∀env s es. s.ffi.io_events ≼ (FST (evaluate env s es)).ffi.io_events` - (ho_match_mp_tac evaluate_ind >> srw_tac[][evaluate_def] >> +Theorem evaluate_io_events_mono: + ∀env s es. s.ffi.io_events ≼ (FST (evaluate env s es)).ffi.io_events +Proof + ho_match_mp_tac evaluate_ind >> srw_tac[][evaluate_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> rev_full_simp_tac(srw_ss())[] >> full_simp_tac(srw_ss())[dec_clock_def] >> - metis_tac[IS_PREFIX_TRANS,do_app_io_events_mono,do_install_const]); + metis_tac[IS_PREFIX_TRANS,do_app_io_events_mono,do_install_const] +QED val evaluate_io_events_mono_imp = Q.prove( `evaluate env s es = (s',r) ⇒ @@ -195,11 +230,12 @@ val with_clock_ffi = Q.prove( `(s with clock := k).ffi = s.ffi`,EVAL_TAC) val lemma = DECIDE``x ≠ 0n ⇒ x - 1 + y = x + y - 1`` -Theorem evaluate_add_to_clock_io_events_mono - `∀env s es. +Theorem evaluate_add_to_clock_io_events_mono: + ∀env s es. (FST(evaluate env s es)).ffi.io_events ≼ - (FST(evaluate env (s with clock := s.clock + extra) es)).ffi.io_events` - (ho_match_mp_tac evaluate_ind >> srw_tac[][evaluate_def] >> + (FST(evaluate env (s with clock := s.clock + extra) es)).ffi.io_events +Proof + ho_match_mp_tac evaluate_ind >> srw_tac[][evaluate_def] >> every_case_tac >> fsrw_tac[][] >> imp_res_tac evaluate_add_to_clock >> rev_full_simp_tac(srw_ss())[] >> fsrw_tac[][] >> srw_tac[][] >> imp_res_tac evaluate_io_events_mono_imp >> fsrw_tac[][] >> srw_tac[][] >> @@ -210,27 +246,31 @@ Theorem evaluate_add_to_clock_io_events_mono rveq >> fsrw_tac[][do_install_with_clock] >> rpt(first_x_assum(qspec_then`extra`mp_tac) \\ srw_tac[][]) >> rev_full_simp_tac(srw_ss())[] >> TRY(rfs[] \\ fs[] \\ NO_TAC) \\ - metis_tac[evaluate_io_events_mono,with_clock_ffi,FST,IS_PREFIX_TRANS,lemma]) - -Theorem evaluate_const - `∀env s xs res s'. - evaluate env s xs = (s',res) ⇒ s'.compile = s.compile` - (ho_match_mp_tac evaluate_ind + metis_tac[evaluate_io_events_mono,with_clock_ffi,FST,IS_PREFIX_TRANS,lemma] +QED + +Theorem evaluate_const: + ∀env s xs res s'. + evaluate env s xs = (s',res) ⇒ s'.compile = s.compile +Proof + ho_match_mp_tac evaluate_ind \\ rw[evaluate_def,case_eq_thms,pair_case_eq,bool_case_eq] \\ fs[] \\ rfs[patSemTheory.dec_clock_def] \\ imp_res_tac do_install_const \\ fs[] \\ imp_res_tac do_app_const \\ fs[] - \\ metis_tac[]); + \\ metis_tac[] +QED (* -Theorem not_evaluate_list_append - `∀l1 ck env s l2 res. +Theorem not_evaluate_list_append: + ∀l1 ck env s l2 res. (∀res. ¬evaluate_list ck env s (l1 ++ l2) res) ⇔ ((∀res. ¬evaluate_list ck env s l1 res) ∨ ∃s1 v1. evaluate_list ck env s l1 (s1, Rval v1) ∧ - (∀res. ¬evaluate_list ck env s1 l2 res))` - (Induct >- ( + (∀res. ¬evaluate_list ck env s1 l2 res)) +Proof + Induct >- ( srw_tac[][EQ_IMP_THM] >- ( full_simp_tac(srw_ss())[Once(CONJUNCT2(evaluate_cases))] >> simp[Once(CONJUNCT2(evaluate_cases))] >> @@ -263,7 +303,8 @@ Theorem not_evaluate_list_append metis_tac[evaluate_determ,PAIR_EQ,pair_CASES, semanticPrimitivesTheory.result_11, semanticPrimitivesTheory.result_nchotomy, - semanticPrimitivesTheory.result_distinct] ) + semanticPrimitivesTheory.result_distinct] +QED *) open bagTheory @@ -294,23 +335,31 @@ val set_globals_def = tDefine "set_globals"` rw[]); val _ = export_rewrites ["set_globals_def"] -Theorem elist_globals_append - `∀a b. elist_globals (a++b) = - elist_globals a ⊎ elist_globals b` - (Induct>>fs[set_globals_def,ASSOC_BAG_UNION]) - -Theorem elist_globals_reverse - `∀ls. elist_globals (REVERSE ls) = elist_globals ls` - (Induct>>fs[set_globals_def,elist_globals_append,COMM_BAG_UNION]) - -Theorem elist_globals_FOLDR - `elist_globals es = FOLDR BAG_UNION {||} (MAP set_globals es)` - (Induct_on `es` >> simp[]); - -Theorem exp_size_MEM - `(∀elist e. MEM e elist ⇒ exp_size e < patLang$exp1_size elist)` - (Induct>>rw[]>>fs[patLangTheory.exp_size_def]>>rw[]>> - res_tac>>fs[]) +Theorem elist_globals_append: + ∀a b. elist_globals (a++b) = + elist_globals a ⊎ elist_globals b +Proof + Induct>>fs[set_globals_def,ASSOC_BAG_UNION] +QED + +Theorem elist_globals_reverse: + ∀ls. elist_globals (REVERSE ls) = elist_globals ls +Proof + Induct>>fs[set_globals_def,elist_globals_append,COMM_BAG_UNION] +QED + +Theorem elist_globals_FOLDR: + elist_globals es = FOLDR BAG_UNION {||} (MAP set_globals es) +Proof + Induct_on `es` >> simp[] +QED + +Theorem exp_size_MEM: + (∀elist e. MEM e elist ⇒ exp_size e < patLang$exp1_size elist) +Proof + Induct>>rw[]>>fs[patLangTheory.exp_size_def]>>rw[]>> + res_tac>>fs[] +QED val esgc_free_def = tDefine "esgc_free" ` (esgc_free (Raise _ e) ⇔ esgc_free e) ∧ diff --git a/compiler/backend/semantics/patSemScript.sml b/compiler/backend/semantics/patSemScript.sml index e6ae99db48..0a09012985 100644 --- a/compiler/backend/semantics/patSemScript.sml +++ b/compiler/backend/semantics/patSemScript.sml @@ -444,9 +444,11 @@ val eqs = LIST_CONJ (map prove_case_eq_thm val case_eq_thms = save_thm("case_eq_thms",eqs); -Theorem do_install_clock - `do_install vs s = SOME (e,s') ⇒ s'.clock = s.clock` - (rw[do_install_def,UNCURRY,eqs,pair_case_eq] \\ rw[]); +Theorem do_install_clock: + do_install vs s = SOME (e,s') ⇒ s'.clock = s.clock +Proof + rw[do_install_def,UNCURRY,eqs,pair_case_eq] \\ rw[] +QED val do_app_cases = save_thm("do_app_cases", ``patSem$do_app s op vs = SOME x`` |> @@ -468,12 +470,14 @@ val do_if_def = Define ` if v = Boolv T then SOME e1 else if v = Boolv F then SOME e2 else NONE`; -Theorem do_if_either_or - `do_if v e1 e2 = SOME e ⇒ e = e1 ∨ e = e2` - (simp [do_if_def] +Theorem do_if_either_or: + do_if v e1 e2 = SOME e ⇒ e = e1 ∨ e = e2 +Proof + simp [do_if_def] THEN1 (Cases_on `v = Boolv T` THENL [simp [], - Cases_on `v = Boolv F` THEN simp []])) + Cases_on `v = Boolv F` THEN simp []]) +QED val dec_clock_def = Define` dec_clock s = s with clock := s.clock -1`; @@ -565,27 +569,32 @@ val evaluate_def = tDefine "evaluate"` val evaluate_ind = theorem"evaluate_ind" -Theorem do_app_clock - `patSem$do_app s op vs = SOME(s',r) ==> s.clock = s'.clock` - (rpt strip_tac THEN fs[do_app_cases] >> rw[] \\ +Theorem do_app_clock: + patSem$do_app s op vs = SOME(s',r) ==> s.clock = s'.clock +Proof + rpt strip_tac THEN fs[do_app_cases] >> rw[] \\ fs[LET_THM,semanticPrimitivesTheory.store_alloc_def,semanticPrimitivesTheory.store_assign_def] - \\ rw[] \\ rfs[]); + \\ rw[] \\ rfs[] +QED -Theorem evaluate_clock - `(∀env s1 e r s2. evaluate env s1 e = (s2,r) ⇒ s2.clock ≤ s1.clock)` - (ho_match_mp_tac evaluate_ind >> rw[evaluate_def,eqs,pair_case_eq,bool_case_eq] >> +Theorem evaluate_clock: + (∀env s1 e r s2. evaluate env s1 e = (s2,r) ⇒ s2.clock ≤ s1.clock) +Proof + ho_match_mp_tac evaluate_ind >> rw[evaluate_def,eqs,pair_case_eq,bool_case_eq] >> fs[dec_clock_def] >> rw[] >> rfs[] >> imp_res_tac fix_clock_IMP >> imp_res_tac do_app_clock >> imp_res_tac do_install_clock >> fs[EQ_SYM_EQ] >> res_tac >> rfs[] -); +QED -Theorem fix_clock_evaluate - `fix_clock s (evaluate env s e) = evaluate env s e` - (Cases_on `evaluate env s e` \\ fs [fix_clock_def] +Theorem fix_clock_evaluate: + fix_clock s (evaluate env s e) = evaluate env s e +Proof + Cases_on `evaluate env s e` \\ fs [fix_clock_def] \\ imp_res_tac evaluate_clock - \\ fs [MIN_DEF,theorem "state_component_equality"]); + \\ fs [MIN_DEF,theorem "state_component_equality"] +QED val evaluate_def = save_thm("evaluate_def[compute]", REWRITE_RULE [fix_clock_evaluate] evaluate_def); diff --git a/compiler/backend/semantics/stackPropsScript.sml b/compiler/backend/semantics/stackPropsScript.sml index bc860a7ec3..7bedf992de 100644 --- a/compiler/backend/semantics/stackPropsScript.sml +++ b/compiler/backend/semantics/stackPropsScript.sml @@ -13,8 +13,8 @@ val case_eq_thms = pair_case_eq::bool_case_eq::map (prove_case_eq_thm o get_thms [``:'a option``,``:'a list``,``:'a word_loc``,``:'a inst``, ``:binop``, ``:'a reg_imm`` ,``:'a arith``,``:'a addr``,``:memop``,``:'a result``,``:'a ffi_result``] |> LIST_CONJ |> curry save_thm "case_eq_thms" -Theorem set_store_const[simp] - `(set_store x y z).ffi = z.ffi ∧ +Theorem set_store_const[simp]: + (set_store x y z).ffi = z.ffi ∧ (set_store x y z).clock = z.clock ∧ (set_store x y z).use_alloc = z.use_alloc ∧ (set_store x y z).use_store = z.use_store ∧ @@ -27,15 +27,19 @@ Theorem set_store_const[simp] (set_store x y z).data_buffer = z.data_buffer ∧ (set_store x y z).code_buffer = z.code_buffer ∧ (set_store x y z).compile = z.compile ∧ - (set_store x y z).compile_oracle = z.compile_oracle` - (EVAL_TAC); - -Theorem set_store_with_const[simp] - `set_store x y (z with clock := a) = set_store x y z with clock := a` - (EVAL_TAC); - -Theorem set_var_const[simp] - `(set_var x y z).ffi = z.ffi ∧ + (set_store x y z).compile_oracle = z.compile_oracle +Proof + EVAL_TAC +QED + +Theorem set_store_with_const[simp]: + set_store x y (z with clock := a) = set_store x y z with clock := a +Proof + EVAL_TAC +QED + +Theorem set_var_const[simp]: + (set_var x y z).ffi = z.ffi ∧ (set_var x y z).clock = z.clock ∧ (set_var x y z).use_alloc = z.use_alloc ∧ (set_var x y z).use_store = z.use_store ∧ @@ -48,20 +52,26 @@ Theorem set_var_const[simp] (set_var x y z).compile = z.compile ∧ (set_var x y z).compile_oracle = z.compile_oracle ∧ (set_var x y z).stack = z.stack ∧ - (set_var x y z).stack_space = z.stack_space` - (EVAL_TAC); - -Theorem set_var_with_const[simp] - `set_var x y (z with clock := k) = set_var x y z with clock := k ∧ - set_var x y (z with stack_space := k) = set_var x y z with stack_space := k` - (EVAL_TAC); - -Theorem get_var_imm_with_const[simp] - `get_var_imm x (y with clock := k) = get_var_imm x y` - (Cases_on`x`>>EVAL_TAC); - -Theorem empty_env_const[simp] - `(empty_env x).ffi = x.ffi ∧ + (set_var x y z).stack_space = z.stack_space +Proof + EVAL_TAC +QED + +Theorem set_var_with_const[simp]: + set_var x y (z with clock := k) = set_var x y z with clock := k ∧ + set_var x y (z with stack_space := k) = set_var x y z with stack_space := k +Proof + EVAL_TAC +QED + +Theorem get_var_imm_with_const[simp]: + get_var_imm x (y with clock := k) = get_var_imm x y +Proof + Cases_on`x`>>EVAL_TAC +QED + +Theorem empty_env_const[simp]: + (empty_env x).ffi = x.ffi ∧ (empty_env x).clock = x.clock ∧ (empty_env z).use_alloc = z.use_alloc ∧ (empty_env z).use_store = z.use_store ∧ @@ -74,15 +84,19 @@ Theorem empty_env_const[simp] (empty_env z).data_buffer = z.data_buffer ∧ (empty_env z).code_buffer = z.code_buffer ∧ (empty_env z).compile = z.compile ∧ - (empty_env z).compile_oracle = z.compile_oracle` - (EVAL_TAC) - -Theorem empty_env_with_const[simp] - `empty_env (x with clock := y) = empty_env x with clock := y` - (EVAL_TAC); - -Theorem alloc_const - `alloc w s = (r,t) ⇒ t.ffi = s.ffi ∧ + (empty_env z).compile_oracle = z.compile_oracle +Proof + EVAL_TAC +QED + +Theorem empty_env_with_const[simp]: + empty_env (x with clock := y) = empty_env x with clock := y +Proof + EVAL_TAC +QED + +Theorem alloc_const: + alloc w s = (r,t) ⇒ t.ffi = s.ffi ∧ t.clock = s.clock ∧ t.use_alloc = s.use_alloc ∧ t.use_store = s.use_store ∧ @@ -95,43 +109,57 @@ Theorem alloc_const t.compile = s.compile ∧ t.data_buffer = s.data_buffer ∧ t.code_buffer = s.code_buffer ∧ - t.compile_oracle = s.compile_oracle` - (srw_tac[][alloc_def,gc_def,LET_THM] >> - every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][]); - -Theorem gc_with_const[simp] - `gc (x with clock := k) = OPTION_MAP (λs. s with clock := k) (gc x)` - (srw_tac[][gc_def] >> every_case_tac >> full_simp_tac(srw_ss())[]); - -Theorem alloc_with_const[simp] - `alloc x (y with clock := z) = (I ## (λs. s with clock := z))(alloc x y)` - (srw_tac[][alloc_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> rev_full_simp_tac(srw_ss())[]); - -Theorem mem_load_with_const[simp] - `mem_load x (y with clock := k) = mem_load x y` - (EVAL_TAC) - -Theorem mem_load_with_const[simp] - `mem_store x y (z with clock := k) = OPTION_MAP(λs. s with clock := k)(mem_store x y z)` - (EVAL_TAC >> srw_tac[][]); - -Theorem word_exp_with_const[simp] - `∀s y k. word_exp (s with clock := k) y = word_exp s y` - (ho_match_mp_tac word_exp_ind >> srw_tac[][word_exp_def] >> + t.compile_oracle = s.compile_oracle +Proof + srw_tac[][alloc_def,gc_def,LET_THM] >> + every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] +QED + +Theorem gc_with_const[simp]: + gc (x with clock := k) = OPTION_MAP (λs. s with clock := k) (gc x) +Proof + srw_tac[][gc_def] >> every_case_tac >> full_simp_tac(srw_ss())[] +QED + +Theorem alloc_with_const[simp]: + alloc x (y with clock := z) = (I ## (λs. s with clock := z))(alloc x y) +Proof + srw_tac[][alloc_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> rev_full_simp_tac(srw_ss())[] +QED + +Theorem mem_load_with_const[simp]: + mem_load x (y with clock := k) = mem_load x y +Proof + EVAL_TAC +QED + +Theorem mem_load_with_const[simp]: + mem_store x y (z with clock := k) = OPTION_MAP(λs. s with clock := k)(mem_store x y z) +Proof + EVAL_TAC >> srw_tac[][] +QED + +Theorem word_exp_with_const[simp]: + ∀s y k. word_exp (s with clock := k) y = word_exp s y +Proof + ho_match_mp_tac word_exp_ind >> srw_tac[][word_exp_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> full_simp_tac(srw_ss())[EVERY_MEM,EXISTS_MEM] >> unabbrev_all_tac >> full_simp_tac(srw_ss())[MEM_MAP,PULL_EXISTS] >> res_tac >> full_simp_tac(srw_ss())[IS_SOME_EXISTS] >> full_simp_tac(srw_ss())[] >> rpt AP_TERM_TAC >> - simp[MAP_EQ_f]); + simp[MAP_EQ_f] +QED -Theorem assign_with_const[simp] - `assign x y (s with clock := k) = OPTION_MAP (λs. s with clock := k) (assign x y s)` - (srw_tac[][assign_def] >> every_case_tac >> full_simp_tac(srw_ss())[]); +Theorem assign_with_const[simp]: + assign x y (s with clock := k) = OPTION_MAP (λs. s with clock := k) (assign x y s) +Proof + srw_tac[][assign_def] >> every_case_tac >> full_simp_tac(srw_ss())[] +QED -Theorem inst_const - `inst i s = SOME t ⇒ +Theorem inst_const: + inst i s = SOME t ⇒ t.ffi = s.ffi ∧ t.clock = s.clock ∧ t.use_alloc = s.use_alloc ∧ @@ -143,23 +171,27 @@ Theorem inst_const t.mdomain = s.mdomain ∧ t.bitmaps = s.bitmaps ∧ t.compile = s.compile ∧ - t.compile_oracle = s.compile_oracle` - (Cases_on`i`>>srw_tac[][inst_def,assign_def] >> + t.compile_oracle = s.compile_oracle +Proof + Cases_on`i`>>srw_tac[][inst_def,assign_def] >> every_case_tac >> full_simp_tac(srw_ss())[set_fp_var_def,set_var_def,word_exp_def,LET_THM] >> srw_tac[][] >> full_simp_tac(srw_ss())[mem_store_def] >> srw_tac[][] >> - fs[get_vars_def]>>every_case_tac>>fs[state_component_equality]); + fs[get_vars_def]>>every_case_tac>>fs[state_component_equality] +QED -Theorem inst_with_const[simp] - `inst i (s with clock := k) = OPTION_MAP (λs. s with clock := k) (inst i s)` - (srw_tac[][inst_def] >> +Theorem inst_with_const[simp]: + inst i (s with clock := k) = OPTION_MAP (λs. s with clock := k) (inst i s) +Proof + srw_tac[][inst_def] >> CASE_TAC >> full_simp_tac(srw_ss())[] >> every_case_tac >> full_simp_tac(srw_ss())[get_var_def] >> rveq >> full_simp_tac(srw_ss())[]>> fs[get_vars_def,get_var_def,get_fp_var_def,set_fp_var_def]>> every_case_tac>>fs[]>> - rw[]>>fs[]>>rw[]>>fs[]); + rw[]>>fs[]>>rw[]>>fs[] +QED -Theorem dec_clock_const[simp] - `(dec_clock s).ffi = s.ffi ∧ +Theorem dec_clock_const[simp]: + (dec_clock s).ffi = s.ffi ∧ (dec_clock z).use_alloc = z.use_alloc ∧ (dec_clock z).use_store = z.use_store ∧ (dec_clock z).use_stack = z.use_stack ∧ @@ -169,11 +201,13 @@ Theorem dec_clock_const[simp] (dec_clock z).mdomain = z.mdomain ∧ (dec_clock z).bitmaps = z.bitmaps ∧ (dec_clock z).compile = z.compile ∧ - (dec_clock z).compile_oracle = z.compile_oracle` - (EVAL_TAC); + (dec_clock z).compile_oracle = z.compile_oracle +Proof + EVAL_TAC +QED -Theorem evaluate_consts - `!c s r s1. +Theorem evaluate_consts: + !c s r s1. evaluate (c,s) = (r,s1) ==> s1.use_alloc = s.use_alloc /\ s1.use_store = s.use_store /\ @@ -181,8 +215,9 @@ Theorem evaluate_consts s1.be = s.be /\ s1.gc_fun = s.gc_fun /\ s1.mdomain = s.mdomain /\ - s1.compile = s.compile` - (recInduct evaluate_ind >> + s1.compile = s.compile +Proof + recInduct evaluate_ind >> rpt conj_tac >> simp[evaluate_def] >> rpt gen_tac >> @@ -192,16 +227,18 @@ Theorem evaluate_consts (strip_tac >> var_eq_tac >> rveq >> full_simp_tac(srw_ss())[]) ORELSE (CASE_TAC >> full_simp_tac(srw_ss())[]) ORELSE (pairarg_tac >> simp[]))>> - (every_case_tac>>fs[]>>rw[])); + (every_case_tac>>fs[]>>rw[]) +QED -Theorem evaluate_code_bitmaps - `∀c s r s1. +Theorem evaluate_code_bitmaps: + ∀c s r s1. evaluate (c,s) = (r,s1) ⇒ ∃n. s1.compile_oracle = shift_seq n s.compile_oracle ∧ s1.code = FOLDL union s.code (MAP (fromAList o FST o SND) (GENLIST s.compile_oracle n)) ∧ - s1.bitmaps = s.bitmaps ++ FLAT (MAP (SND o SND) (GENLIST s.compile_oracle n))` - (recInduct evaluate_ind >> + s1.bitmaps = s.bitmaps ++ FLAT (MAP (SND o SND) (GENLIST s.compile_oracle n)) +Proof + recInduct evaluate_ind >> rw[evaluate_def] >> TRY(qexists_tac`0` \\ fsrw_tac[ETA_ss][shift_seq_def] \\ NO_TAC) \\ TRY( @@ -271,24 +308,28 @@ Theorem evaluate_code_bitmaps pairarg_tac \\ fs[] \\ fs[case_eq_thms,empty_env_def]>>rw[]>> TRY(qexists_tac`0` \\ fsrw_tac[ETA_ss][shift_seq_def] \\ NO_TAC) \\ - qexists_tac`1` \\ fsrw_tac[ETA_ss][shift_seq_def])); + qexists_tac`1` \\ fsrw_tac[ETA_ss][shift_seq_def]) +QED -Theorem evaluate_mono ` - ∀c s r s1. +Theorem evaluate_mono: + ∀c s r s1. evaluate (c,s) = (r,s1) ⇒ isPREFIX s.bitmaps s1.bitmaps ∧ - subspt s.code s1.code` - (rw[] \\ + subspt s.code s1.code +Proof + rw[] \\ imp_res_tac evaluate_code_bitmaps \\ rw[] \\ - metis_tac[subspt_FOLDL_union]); + metis_tac[subspt_FOLDL_union] +QED -Theorem evaluate_io_events_mono - `!exps s1 res s2. +Theorem evaluate_io_events_mono: + !exps s1 res s2. evaluate (exps,s1) = (res, s2) ⇒ - s1.ffi.io_events ≼ s2.ffi.io_events` - (recInduct evaluate_ind >> + s1.ffi.io_events ≼ s2.ffi.io_events +Proof + recInduct evaluate_ind >> srw_tac[][evaluate_def] >> every_case_tac >> full_simp_tac(srw_ss())[LET_THM] >> TRY pairarg_tac >> full_simp_tac(srw_ss())[] >> @@ -298,13 +339,15 @@ Theorem evaluate_io_events_mono every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> TRY (CHANGED_TAC(full_simp_tac(srw_ss())[ffiTheory.call_FFI_def]) >> every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] ) >> - metis_tac[IS_PREFIX_TRANS]); + metis_tac[IS_PREFIX_TRANS] +QED -Theorem evaluate_add_clock - `∀p s r s'. +Theorem evaluate_add_clock: + ∀p s r s'. evaluate (p,s) = (r,s') ∧ r ≠ SOME TimeOut ⇒ - evaluate (p,s with clock := s.clock + extra) = (r,s' with clock := s'.clock + extra)` - (recInduct evaluate_ind >> + evaluate (p,s with clock := s.clock + extra) = (r,s' with clock := s'.clock + extra) +Proof + recInduct evaluate_ind >> srw_tac[][evaluate_def] >> full_simp_tac(srw_ss())[LET_THM] >> TRY ( rename1`find_code dest (_ \\ _)` >> @@ -380,17 +423,21 @@ Theorem evaluate_add_clock TRY ( rename1`call_FFI` >> pairarg_tac >> full_simp_tac(srw_ss())[] >> rveq >> simp[] ) >> - metis_tac[]); + metis_tac[] +QED -Theorem with_clock_ffi - `(s with clock := k).ffi = s.ffi` - (EVAL_TAC); +Theorem with_clock_ffi: + (s with clock := k).ffi = s.ffi +Proof + EVAL_TAC +QED -Theorem evaluate_add_clock_io_events_mono - `∀e s. +Theorem evaluate_add_clock_io_events_mono: + ∀e s. (SND(evaluate(e,s))).ffi.io_events ≼ - (SND(evaluate(e,s with clock := s.clock + extra))).ffi.io_events` - (recInduct evaluate_ind >> + (SND(evaluate(e,s with clock := s.clock + extra))).ffi.io_events +Proof + recInduct evaluate_ind >> srw_tac[][evaluate_def] >> full_simp_tac(srw_ss())[LET_THM,get_var_def] >> TRY BasicProvers.TOP_CASE_TAC >> full_simp_tac(srw_ss())[] >> TRY ( @@ -429,7 +476,8 @@ Theorem evaluate_add_clock_io_events_mono rename1 `buffer_flush _ _ _ = _`>> pairarg_tac>>fs[]>> every_case_tac >> fs[get_var_def])>> - metis_tac[IS_PREFIX_TRANS,evaluate_io_events_mono,PAIR]); + metis_tac[IS_PREFIX_TRANS,evaluate_io_events_mono,PAIR] +QED val clock_neutral_def = Define ` (clock_neutral (Seq p1 p2) <=> clock_neutral p1 /\ clock_neutral p2) /\ @@ -465,41 +513,48 @@ val inst_clock_neutral_ffi = Q.prove( \\ full_simp_tac(srw_ss())[mem_load_def,get_var_def,mem_store_def,get_fp_var_def] \\ srw_tac[][state_component_equality])); -Theorem evaluate_clock_neutral - `!prog s res t. +Theorem evaluate_clock_neutral: + !prog s res t. evaluate (prog,s) = (res,t) /\ clock_neutral prog ==> - evaluate (prog,s with clock := c) = (res,t with clock := c)` - (recInduct evaluate_ind \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] + evaluate (prog,s with clock := c) = (res,t with clock := c) +Proof + recInduct evaluate_ind \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[evaluate_def,get_var_def,clock_neutral_def] THEN1 (every_case_tac \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[]) THEN1 (every_case_tac \\ imp_res_tac inst_clock_neutral \\ full_simp_tac(srw_ss())[]) THEN1 (Cases_on `evaluate (c1,s)` \\ full_simp_tac(srw_ss())[LET_THM] \\ every_case_tac \\ full_simp_tac(srw_ss())[]) \\ `get_var_imm ri (s with clock := c) = get_var_imm ri s` by (Cases_on `ri` \\ full_simp_tac(srw_ss())[get_var_imm_def,get_var_def]) - \\ every_case_tac \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[set_var_def]); + \\ every_case_tac \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[set_var_def] +QED -Theorem evaluate_ffi_neutral - `!prog s res t. +Theorem evaluate_ffi_neutral: + !prog s res t. evaluate (prog,s) = (res,t) /\ clock_neutral prog ==> - evaluate (prog,s with ffi := c) = (res,t with ffi := c)` - (recInduct evaluate_ind \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] + evaluate (prog,s with ffi := c) = (res,t with ffi := c) +Proof + recInduct evaluate_ind \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[evaluate_def,get_var_def,clock_neutral_def] THEN1 (every_case_tac \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[empty_env_def]) THEN1 (every_case_tac \\ imp_res_tac inst_clock_neutral_ffi \\ full_simp_tac(srw_ss())[]) THEN1 (Cases_on `evaluate (c1,s)` \\ full_simp_tac(srw_ss())[LET_THM] \\ every_case_tac \\ full_simp_tac(srw_ss())[]) \\ `get_var_imm ri (s with ffi := c) = get_var_imm ri s` by (Cases_on `ri` \\ full_simp_tac(srw_ss())[get_var_imm_def,get_var_def]) - \\ every_case_tac \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[set_var_def]); + \\ every_case_tac \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[set_var_def] +QED -Theorem semantics_Terminate_IMP_PREFIX - `semantics start s1 = Terminate x l ==> isPREFIX s1.ffi.io_events l` - (full_simp_tac(srw_ss())[semantics_def,LET_DEF] \\ IF_CASES_TAC \\ full_simp_tac(srw_ss())[] +Theorem semantics_Terminate_IMP_PREFIX: + semantics start s1 = Terminate x l ==> isPREFIX s1.ffi.io_events l +Proof + full_simp_tac(srw_ss())[semantics_def,LET_DEF] \\ IF_CASES_TAC \\ full_simp_tac(srw_ss())[] \\ DEEP_INTRO_TAC some_intro \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] - \\ imp_res_tac evaluate_io_events_mono \\ full_simp_tac(srw_ss())[]); + \\ imp_res_tac evaluate_io_events_mono \\ full_simp_tac(srw_ss())[] +QED -Theorem semantics_Diverge_IMP_LPREFIX - `semantics start s1 = Diverge l ==> LPREFIX (fromList s1.ffi.io_events) l` - (simp[semantics_def] >> IF_CASES_TAC >> full_simp_tac(srw_ss())[] >> +Theorem semantics_Diverge_IMP_LPREFIX: + semantics start s1 = Diverge l ==> LPREFIX (fromList s1.ffi.io_events) l +Proof + simp[semantics_def] >> IF_CASES_TAC >> full_simp_tac(srw_ss())[] >> DEEP_INTRO_TAC some_intro >> srw_tac[][] >> qmatch_abbrev_tac`LPREFIX l1 (build_lprefix_lub l2)` >> `l1 ∈ l2 ∧ lprefix_chain l2` suffices_by metis_tac[build_lprefix_lub_thm,lprefix_lub_def] >> @@ -516,34 +571,39 @@ Theorem semantics_Diverge_IMP_LPREFIX simp[LESS_EQ_EXISTS] >> metis_tac[evaluate_add_clock_io_events_mono, EVAL``(s with clock := k).clock``, - EVAL``((s with clock := k) with clock := k2) = (s with clock := k2)``]); + EVAL``((s with clock := k) with clock := k2) = (s with clock := k2)``] +QED -Theorem map_bitmap_length ` - ∀a b c x y z. +Theorem map_bitmap_length: + ∀a b c x y z. map_bitmap a b c = SOME(x,y,z) ⇒ LENGTH c = LENGTH x + LENGTH z ∧ - LENGTH x = LENGTH a` - (Induct>>rw[]>> + LENGTH x = LENGTH a +Proof + Induct>>rw[]>> Cases_on`b`>>TRY(Cases_on`h`)>>Cases_on`c`>> fs[map_bitmap_def]>> TRY(qpat_x_assum`A=x` (SUBST_ALL_TAC o SYM))>> TRY(qpat_x_assum`A=y` (SUBST_ALL_TAC o SYM))>> fs[LENGTH_NIL]>> pop_assum mp_tac>>every_case_tac>>rw[]>>res_tac>> - fs[]>>DECIDE_TAC); + fs[]>>DECIDE_TAC +QED -Theorem dec_stack_length ` - ∀bs enc orig_stack new_stack. +Theorem dec_stack_length: + ∀bs enc orig_stack new_stack. dec_stack bs enc orig_stack = SOME new_stack ⇒ - LENGTH orig_stack = LENGTH new_stack` - (ho_match_mp_tac stackSemTheory.dec_stack_ind>> + LENGTH orig_stack = LENGTH new_stack +Proof + ho_match_mp_tac stackSemTheory.dec_stack_ind>> fs[stackSemTheory.dec_stack_def,LENGTH_NIL]>>rw[]>> pop_assum mp_tac>> Cases_on`w`>>fs[full_read_bitmap_def]>> every_case_tac>>fs[]>> rw[]>> imp_res_tac map_bitmap_length>> - simp[]>>metis_tac[]) + simp[]>>metis_tac[] +QED val extract_labels_def = Define` (extract_labels (Call ret dest h) = @@ -563,14 +623,16 @@ val extract_labels_def = Define` (extract_labels e2 ++ extract_labels e3)) ∧ (extract_labels _ = [])` -Theorem find_code_IMP_get_labels - `find_code d r code = SOME e ==> - get_labels e SUBSET loc_check code` - (Cases_on `d` +Theorem find_code_IMP_get_labels: + find_code d r code = SOME e ==> + get_labels e SUBSET loc_check code +Proof + Cases_on `d` \\ fs [stackSemTheory.find_code_def,SUBSET_DEF,IN_DEF, loc_check_def,FORALL_PROD] \\ every_case_tac \\ fs [] - \\ metis_tac []); + \\ metis_tac [] +QED (* TODO: This is not updated for Install, CBW and DBW *) (* asm_ok out of stack_names *) diff --git a/compiler/backend/semantics/stackSemScript.sml b/compiler/backend/semantics/stackSemScript.sml index 5a3c53ba1d..367a564ba3 100644 --- a/compiler/backend/semantics/stackSemScript.sml +++ b/compiler/backend/semantics/stackSemScript.sml @@ -44,24 +44,28 @@ val map_bitmap_def = Define ` | SOME (xs,ys,zs) => SOME (t::xs,ys,zs)) /\ (map_bitmap _ _ _ = NONE)` -Theorem filter_bitmap_LENGTH - `!bs xs x y. (filter_bitmap bs xs = SOME (x,y)) ==> LENGTH y <= LENGTH xs` - (Induct \\ fs [filter_bitmap_def] \\ Cases_on `xs` \\ TRY (Cases_on `h`) +Theorem filter_bitmap_LENGTH: + !bs xs x y. (filter_bitmap bs xs = SOME (x,y)) ==> LENGTH y <= LENGTH xs +Proof + Induct \\ fs [filter_bitmap_def] \\ Cases_on `xs` \\ TRY (Cases_on `h`) \\ fs [filter_bitmap_def] \\ Cases \\ fs [filter_bitmap_def] \\ REPEAT STRIP_TAC \\ RES_TAC \\ res_tac \\ BasicProvers.EVERY_CASE_TAC \\ fs [] \\ SRW_TAC [] [] - \\ res_tac \\ decide_tac); + \\ res_tac \\ decide_tac +QED -Theorem map_bitmap_LENGTH - `!t1 t2 t3 x y z. (map_bitmap t1 t2 t3 = SOME (x,y,z)) ==> +Theorem map_bitmap_LENGTH: + !t1 t2 t3 x y z. (map_bitmap t1 t2 t3 = SOME (x,y,z)) ==> LENGTH y ≤ LENGTH t2 ∧ - LENGTH z <= LENGTH t3` - (Induct \\ fs [map_bitmap_def] \\ Cases_on `t2` \\ Cases_on `t3` + LENGTH z <= LENGTH t3 +Proof + Induct \\ fs [map_bitmap_def] \\ Cases_on `t2` \\ Cases_on `t3` \\ TRY (Cases_on `h`) \\ fs [map_bitmap_def] \\ Cases \\ fs [map_bitmap_def] \\ REPEAT STRIP_TAC \\ RES_TAC \\ res_tac \\ BasicProvers.EVERY_CASE_TAC \\ fs [] \\ SRW_TAC [] [] - \\ res_tac \\ fs[] \\ decide_tac); + \\ res_tac \\ fs[] \\ decide_tac +QED val read_bitmap_def = Define ` (read_bitmap [] = NONE) /\ @@ -741,22 +745,26 @@ val evaluate_ind = theorem"evaluate_ind"; (* We prove that the clock never increases. *) -Theorem gc_clock - `!s1 s2. (gc s1 = SOME s2) ==> s2.clock <= s1.clock` - (fs [gc_def,LET_DEF] \\ SRW_TAC [] [] +Theorem gc_clock: + !s1 s2. (gc s1 = SOME s2) ==> s2.clock <= s1.clock +Proof + fs [gc_def,LET_DEF] \\ SRW_TAC [] [] \\ every_case_tac >> fs[] - \\ SRW_TAC [] [] \\ fs []); + \\ SRW_TAC [] [] \\ fs [] +QED -Theorem alloc_clock - `!xs s1 vs s2. (alloc x s1 = (vs,s2)) ==> s2.clock <= s1.clock` - (SIMP_TAC std_ss [alloc_def] \\ REPEAT STRIP_TAC +Theorem alloc_clock: + !xs s1 vs s2. (alloc x s1 = (vs,s2)) ==> s2.clock <= s1.clock +Proof + SIMP_TAC std_ss [alloc_def] \\ REPEAT STRIP_TAC \\ every_case_tac \\ SRW_TAC [] [] \\ fs [] \\ Q.ABBREV_TAC `s3 = set_store AllocSize (Word x) s1` \\ `s3.clock=s1.clock` by (Q.UNABBREV_TAC`s3`>>fs[set_store_def]) \\ IMP_RES_TAC gc_clock \\ fs [] \\ UNABBREV_ALL_TAC \\ fs [] \\ Cases_on `x'` \\ fs [] \\ SRW_TAC [] [] - \\ EVAL_TAC \\ decide_tac); + \\ EVAL_TAC \\ decide_tac +QED val inst_clock = Q.prove( `inst i s = SOME s2 ==> s2.clock <= s.clock`, @@ -765,9 +773,10 @@ val inst_clock = Q.prove( \\ fs [mem_store_def] \\ SRW_TAC [] []\\ EVAL_TAC \\ fs[]); -Theorem evaluate_clock - `!xs s1 vs s2. (evaluate (xs,s1) = (vs,s2)) ==> s2.clock <= s1.clock` - (recInduct evaluate_ind \\ REPEAT STRIP_TAC +Theorem evaluate_clock: + !xs s1 vs s2. (evaluate (xs,s1) = (vs,s2)) ==> s2.clock <= s1.clock +Proof + recInduct evaluate_ind \\ REPEAT STRIP_TAC \\ POP_ASSUM MP_TAC \\ ONCE_REWRITE_TAC [evaluate_def] \\ FULL_SIMP_TAC std_ss [STOP_def] \\ TRY BasicProvers.TOP_CASE_TAC \\ fs [] @@ -780,13 +789,16 @@ Theorem evaluate_clock \\ every_case_tac \\ fs [] \\ imp_res_tac fix_clock_IMP \\ fs [] \\ imp_res_tac LESS_EQ_TRANS \\ fs [] \\ rfs [] - \\ TRY decide_tac)); + \\ TRY decide_tac) +QED -Theorem fix_clock_evaluate - `fix_clock s (evaluate (xs,s)) = evaluate (xs,s)` - (Cases_on `evaluate (xs,s)` \\ fs [fix_clock_def] +Theorem fix_clock_evaluate: + fix_clock s (evaluate (xs,s)) = evaluate (xs,s) +Proof + Cases_on `evaluate (xs,s)` \\ fs [fix_clock_def] \\ imp_res_tac evaluate_clock - \\ fs [MIN_DEF,GSYM NOT_LESS,theorem "state_component_equality"]); + \\ fs [MIN_DEF,GSYM NOT_LESS,theorem "state_component_equality"] +QED val evaluate_def = save_thm("evaluate_def[compute]", REWRITE_RULE [fix_clock_evaluate] evaluate_def); diff --git a/compiler/backend/semantics/targetPropsScript.sml b/compiler/backend/semantics/targetPropsScript.sml index e81a3bd8d0..74fb7706ed 100644 --- a/compiler/backend/semantics/targetPropsScript.sml +++ b/compiler/backend/semantics/targetPropsScript.sml @@ -168,8 +168,8 @@ val enc_ok_not_empty = Q.prove( `enc_ok c /\ asm_ok w c ==> (c.encode w <> [])`, METIS_TAC [listTheory.LENGTH_NIL,enc_ok_def]); -Theorem asm_step_IMP_evaluate_step - `!c s1 ms1 io i s2. +Theorem asm_step_IMP_evaluate_step = Q.prove(` + !c s1 ms1 io i s2. encoder_correct c.target /\ (c.prog_addresses = s1.mem_domain) /\ interference_ok c.next_interfer (c.target.proj s1.mem_domain) /\ @@ -178,8 +178,8 @@ Theorem asm_step_IMP_evaluate_step target_state_rel c.target (s1:'a asm_state) (ms1:'state) ==> ?l ms2. !k. (evaluate c io (k + l) ms1 = evaluate (shift_interfer l c) io k ms2) /\ - target_state_rel c.target s2 ms2 /\ l <> 0` - (full_simp_tac(srw_ss()) [encoder_correct_def, target_ok_def, LET_DEF] + target_state_rel c.target s2 ms2 /\ l <> 0`, + full_simp_tac(srw_ss()) [encoder_correct_def, target_ok_def, LET_DEF] \\ rw[] \\ first_x_assum drule \\ disch_then drule @@ -242,11 +242,12 @@ Theorem asm_step_IMP_evaluate_step (* basic properties *) -Theorem evaluate_add_clock - `∀mc_conf ffi k ms k1 r ms1 st1. +Theorem evaluate_add_clock: + ∀mc_conf ffi k ms k1 r ms1 st1. evaluate mc_conf ffi k ms = (r,ms1,st1) /\ r <> TimeOut ==> - evaluate mc_conf ffi (k + k1) ms = (r,ms1,st1)` - (ho_match_mp_tac evaluate_ind >> srw_tac[][] >> + evaluate mc_conf ffi (k + k1) ms = (r,ms1,st1) +Proof + ho_match_mp_tac evaluate_ind >> srw_tac[][] >> qhdtm_x_assum`evaluate` mp_tac >> simp[Once evaluate_def] >> IF_CASES_TAC >> full_simp_tac(srw_ss())[] >> @@ -261,12 +262,14 @@ Theorem evaluate_add_clock BasicProvers.CASE_TAC >> full_simp_tac(srw_ss())[] >> BasicProvers.CASE_TAC >> full_simp_tac(srw_ss())[] >> BasicProvers.CASE_TAC >> full_simp_tac(srw_ss())[] >> - BasicProvers.CASE_TAC >> full_simp_tac(srw_ss())[]); + BasicProvers.CASE_TAC >> full_simp_tac(srw_ss())[] +QED -Theorem evaluate_io_events_mono - `∀mc_conf ffi k ms. - ffi.io_events ≼ (SND(SND(evaluate mc_conf ffi k ms))).io_events` - (ho_match_mp_tac evaluate_ind >> +Theorem evaluate_io_events_mono: + ∀mc_conf ffi k ms. + ffi.io_events ≼ (SND(SND(evaluate mc_conf ffi k ms))).io_events +Proof + ho_match_mp_tac evaluate_ind >> rpt gen_tac >> strip_tac >> simp[Once evaluate_def] >> IF_CASES_TAC >> full_simp_tac(srw_ss())[] >> @@ -281,14 +284,16 @@ Theorem evaluate_io_events_mono full_simp_tac(srw_ss())[call_FFI_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> rpt var_eq_tac >> full_simp_tac(srw_ss())[] >> - full_simp_tac(srw_ss())[IS_PREFIX_APPEND]); + full_simp_tac(srw_ss())[IS_PREFIX_APPEND] +QED -Theorem evaluate_add_clock_io_events_mono - `∀mc_conf ffi k ms k'. +Theorem evaluate_add_clock_io_events_mono: + ∀mc_conf ffi k ms k'. k ≤ k' ⇒ (SND(SND(evaluate mc_conf ffi k ms))).io_events ≼ - (SND(SND(evaluate mc_conf ffi k' ms))).io_events` - (ho_match_mp_tac evaluate_ind >> + (SND(SND(evaluate mc_conf ffi k' ms))).io_events +Proof + ho_match_mp_tac evaluate_ind >> rpt gen_tac >> strip_tac >> rpt gen_tac >> strip_tac >> simp_tac(srw_ss())[Once evaluate_def] >> @@ -307,11 +312,13 @@ Theorem evaluate_add_clock_io_events_mono \\ CONV_TAC (RAND_CONV (SIMP_CONV std_ss [Once evaluate_def])) \\ fs [apply_oracle_def] \\ BasicProvers.TOP_CASE_TAC >> fs [] - \\ METIS_TAC[evaluate_io_events_mono]); + \\ METIS_TAC[evaluate_io_events_mono] +QED -Theorem machine_sem_total - `∃b. machine_sem mc st ms b` - (Cases_on`∃k t. FST (evaluate mc st k ms) = Halt t` +Theorem machine_sem_total: + ∃b. machine_sem mc st ms b +Proof + Cases_on`∃k t. FST (evaluate mc st k ms) = Halt t` >- ( fs[] \\ qexists_tac`Terminate t (SND(SND(evaluate mc st k ms))).io_events` @@ -334,22 +341,25 @@ Theorem machine_sem_total \\ irule prefix_chain_lprefix_chain \\ simp[prefix_chain_def, PULL_EXISTS] \\ qx_genl_tac[`k1`,`k2`] - \\ metis_tac[LESS_EQ_CASES,evaluate_add_clock_io_events_mono]); + \\ metis_tac[LESS_EQ_CASES,evaluate_add_clock_io_events_mono] +QED -Theorem read_ffi_bytearray_IMP_SUBSET_prog_addresses - `(read_ffi_bytearray mc a l ms = SOME bytes) ==> +Theorem read_ffi_bytearray_IMP_SUBSET_prog_addresses: + (read_ffi_bytearray mc a l ms = SOME bytes) ==> all_words (mc.target.get_reg ms a) (LENGTH bytes) SUBSET - mc.prog_addresses` - (fs [targetSemTheory.read_ffi_bytearray_def] + mc.prog_addresses +Proof + fs [targetSemTheory.read_ffi_bytearray_def] \\ qspec_tac (`mc.target.get_reg ms a`,`x`) \\ qspec_tac (`(w2n (mc.target.get_reg ms l))`,`n`) \\ qspec_tac (`bytes`,`res`) \\ Induct_on `n` \\ fs [read_bytearray_def,all_words_def] \\ rw [] \\ fs[option_case_eq] \\ rveq \\ fs [] - \\ fs [all_words_def]); + \\ fs [all_words_def] +QED -Theorem encoder_correct_asm_step_target_state_rel - `encoder_correct t ∧ +Theorem encoder_correct_asm_step_target_state_rel: + encoder_correct t ∧ target_state_rel t s1 ms ∧ asm_step t.config s1 i s2 ⇒ @@ -361,8 +371,9 @@ Theorem encoder_correct_asm_step_target_state_rel (t.get_pc (FUNPOW t.next j ms) ∈ all_pcs (LENGTH (t.config.encode i)) s1.pc t.config.code_alignment) ∧ (t.state_ok (FUNPOW t.next j ms))) ∧ - (∀j x. j ≤ n ∧ x ∉ s1.mem_domain ⇒ (t.get_byte (FUNPOW t.next j ms) x = t.get_byte ms x))` - (rw[asmPropsTheory.encoder_correct_def] + (∀j x. j ≤ n ∧ x ∉ s1.mem_domain ⇒ (t.get_byte (FUNPOW t.next j ms) x = t.get_byte ms x)) +Proof + rw[asmPropsTheory.encoder_correct_def] \\ first_x_assum drule \\ disch_then drule \\ strip_tac @@ -396,15 +407,17 @@ Theorem encoder_correct_asm_step_target_state_rel \\ qho_match_abbrev_tac`P ms (FUNPOW t.next (SUC m) ms)` \\ irule FUNPOW_refl_trans_chain \\ fs[ADD1,Abbr`P`] - \\ simp[reflexive_def,transitive_def]); + \\ simp[reflexive_def,transitive_def] +QED -Theorem encoder_correct_RTC_asm_step_target_state_rel - `encoder_correct t ∧ +Theorem encoder_correct_RTC_asm_step_target_state_rel: + encoder_correct t ∧ target_state_rel t s1 ms ∧ RTC (λs1 s2. ∃i. asm_step t.config s1 i s2) s1 s2 ⇒ - ∃n. target_state_rel t s2 (FUNPOW t.next n ms)` - (strip_tac + ∃n. target_state_rel t s2 (FUNPOW t.next n ms) +Proof + strip_tac \\ first_assum(mp_then (Pat`RTC`) mp_tac (GEN_ALL RTC_lifts_invariants)) \\ disch_then ho_match_mp_tac \\ reverse conj_tac @@ -414,6 +427,7 @@ Theorem encoder_correct_RTC_asm_step_target_state_rel \\ disch_then drule \\ disch_then drule \\ rw[GSYM FUNPOW_ADD] - \\ asm_exists_tac \\ rw[]); + \\ asm_exists_tac \\ rw[] +QED val _ = export_theory(); diff --git a/compiler/backend/semantics/wordPropsScript.sml b/compiler/backend/semantics/wordPropsScript.sml index 98e33a5426..d3dba4a4c9 100644 --- a/compiler/backend/semantics/wordPropsScript.sml +++ b/compiler/backend/semantics/wordPropsScript.sml @@ -20,14 +20,16 @@ val _ = new_theory "wordProps"; (* TODO: move *) -Theorem mem_list_rearrange ` - ∀ls x f. MEM x (list_rearrange f ls) ⇔ MEM x ls` - (full_simp_tac(srw_ss())[MEM_EL]>>srw_tac[][wordSemTheory.list_rearrange_def]>> +Theorem mem_list_rearrange: + ∀ls x f. MEM x (list_rearrange f ls) ⇔ MEM x ls +Proof + full_simp_tac(srw_ss())[MEM_EL]>>srw_tac[][wordSemTheory.list_rearrange_def]>> imp_res_tac BIJ_IFF_INV>> full_simp_tac(srw_ss())[BIJ_DEF,INJ_DEF,SURJ_DEF]>> srw_tac[][EQ_IMP_THM]>>full_simp_tac(srw_ss())[EL_GENLIST] >- metis_tac[]>> - qexists_tac `g n`>>full_simp_tac(srw_ss())[]); + qexists_tac `g n`>>full_simp_tac(srw_ss())[] +QED val GENLIST_I = GENLIST_EL |> Q.SPECL [`xs`,`\i. EL i xs`,`LENGTH xs`] @@ -37,26 +39,30 @@ val ALL_DISTINCT_EL = ``ALL_DISTINCT xs`` |> ONCE_REWRITE_CONV [GSYM GENLIST_I] |> SIMP_RULE std_ss [ALL_DISTINCT_GENLIST] -Theorem PERM_list_rearrange - `!f xs. ALL_DISTINCT xs ==> PERM xs (list_rearrange f xs)` - (srw_tac[][] \\ match_mp_tac PERM_ALL_DISTINCT +Theorem PERM_list_rearrange: + !f xs. ALL_DISTINCT xs ==> PERM xs (list_rearrange f xs) +Proof + srw_tac[][] \\ match_mp_tac PERM_ALL_DISTINCT \\ full_simp_tac(srw_ss())[mem_list_rearrange] \\ full_simp_tac(srw_ss())[wordSemTheory.list_rearrange_def] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[ALL_DISTINCT_GENLIST] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[BIJ_DEF,INJ_DEF,SURJ_DEF] - \\ full_simp_tac(srw_ss())[ALL_DISTINCT_EL]); + \\ full_simp_tac(srw_ss())[ALL_DISTINCT_EL] +QED -Theorem PERM_ALL_DISTINCT_MAP - `!xs ys. PERM xs ys ==> +Theorem PERM_ALL_DISTINCT_MAP: + !xs ys. PERM xs ys ==> ALL_DISTINCT (MAP f xs) ==> - ALL_DISTINCT (MAP f ys) /\ !x. MEM x ys <=> MEM x xs` - (full_simp_tac(srw_ss())[MEM_PERM] \\ srw_tac[][] + ALL_DISTINCT (MAP f ys) /\ !x. MEM x ys <=> MEM x xs +Proof + full_simp_tac(srw_ss())[MEM_PERM] \\ srw_tac[][] \\ `PERM (MAP f xs) (MAP f ys)` by full_simp_tac(srw_ss())[PERM_MAP] - \\ metis_tac [ALL_DISTINCT_PERM]) + \\ metis_tac [ALL_DISTINCT_PERM] +QED -Theorem ALL_DISTINCT_MEM_IMP_ALOOKUP_SOME - `!xs x y. ALL_DISTINCT (MAP FST xs) /\ MEM (x,y) xs ==> ALOOKUP xs x = SOME y` - (Induct \\ full_simp_tac(srw_ss())[] +Theorem ALL_DISTINCT_MEM_IMP_ALOOKUP_SOME = Q.prove(` + !xs x y. ALL_DISTINCT (MAP FST xs) /\ MEM (x,y) xs ==> ALOOKUP xs x = SOME y`, + Induct \\ full_simp_tac(srw_ss())[] \\ Cases \\ full_simp_tac(srw_ss())[ALOOKUP_def] \\ srw_tac[][] \\ res_tac \\ full_simp_tac(srw_ss())[MEM_MAP,FORALL_PROD] \\ rev_full_simp_tac(srw_ss())[]) |> SPEC_ALL @@ -72,23 +78,27 @@ val case_eq_thms = pair_case_eq::bool_case_eq::map (prove_case_eq_thm o get_thms [``:'a option``,``:'a list``,``:'a word_loc``,``:'a inst`` ,``:'a arith``,``:'a addr``,``:memop``,``:'a result``,``:'a ffi_result``] |> LIST_CONJ |> curry save_thm "case_eq_thms" -Theorem set_store_const[simp] - `(set_store x y z).clock = z.clock ∧ +Theorem set_store_const[simp]: + (set_store x y z).clock = z.clock ∧ (set_store x y z).ffi = z.ffi ∧ (set_store x y z).compile = z.compile ∧ (set_store x y z).compile_oracle = z.compile_oracle ∧ (set_store x y z).be = z.be ∧ (set_store x y z).data_buffer = z.data_buffer ∧ (set_store x y z).code_buffer = z.code_buffer ∧ - (set_store x y z).code = z.code` - (EVAL_TAC); - -Theorem set_store_with_const[simp] - `(set_store x y (z with clock := k)) = set_store x y z with clock := k` - (EVAL_TAC); - -Theorem push_env_const[simp] - `(push_env x y z).clock = z.clock ∧ + (set_store x y z).code = z.code +Proof + EVAL_TAC +QED + +Theorem set_store_with_const[simp]: + (set_store x y (z with clock := k)) = set_store x y z with clock := k +Proof + EVAL_TAC +QED + +Theorem push_env_const[simp]: + (push_env x y z).clock = z.clock ∧ (push_env x y z).ffi = z.ffi ∧ (push_env x y z).termdep = z.termdep ∧ (push_env x y z).data_buffer = z.data_buffer ∧ @@ -97,22 +107,26 @@ Theorem push_env_const[simp] (push_env x y z).compile_oracle = z.compile_oracle ∧ (push_env x y z).gc_fun = z.gc_fun ∧ (push_env x y z).be = z.be ∧ - (push_env x y z).code = z.code` - (Cases_on`y`>>simp[push_env_def,UNCURRY] >> + (push_env x y z).code = z.code +Proof + Cases_on`y`>>simp[push_env_def,UNCURRY] >> rename1`SOME p` >> PairCases_on`p` >> - srw_tac[][push_env_def] >> srw_tac[][]); - -Theorem push_env_with_const[simp] - `(push_env x y (z with clock := k) = push_env x y z with clock := k) ∧ - (push_env x y (z with locals := l) = push_env x y z with locals := l)` - (Cases_on`y`>>srw_tac[][push_env_def] >- simp[state_component_equality] >> + srw_tac[][push_env_def] >> srw_tac[][] +QED + +Theorem push_env_with_const[simp]: + (push_env x y (z with clock := k) = push_env x y z with clock := k) ∧ + (push_env x y (z with locals := l) = push_env x y z with locals := l) +Proof + Cases_on`y`>>srw_tac[][push_env_def] >- simp[state_component_equality] >> rename1`SOME p` >> PairCases_on`p` >> - srw_tac[][push_env_def] >> simp[state_component_equality]); + srw_tac[][push_env_def] >> simp[state_component_equality] +QED -Theorem pop_env_const - `pop_env x = SOME y ⇒ +Theorem pop_env_const: + pop_env x = SOME y ⇒ y.clock = x.clock /\ y.ffi = x.ffi ∧ y.be = x.be ∧ @@ -120,17 +134,21 @@ Theorem pop_env_const y.compile_oracle = x.compile_oracle ∧ y.data_buffer = x.data_buffer ∧ y.code_buffer = x.code_buffer ∧ - y.code = x.code` - (srw_tac[][pop_env_def] >> - every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][]); - -Theorem pop_env_with_const[simp] - `pop_env (z with clock := k) = OPTION_MAP (λs. s with clock := k) (pop_env z) ∧ - pop_env (z with locals := l) = pop_env z` - (srw_tac[][pop_env_def] >> every_case_tac >> full_simp_tac(srw_ss())[]); - -Theorem call_env_const[simp] - `(call_env x y).clock = y.clock ∧ + y.code = x.code +Proof + srw_tac[][pop_env_def] >> + every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] +QED + +Theorem pop_env_with_const[simp]: + pop_env (z with clock := k) = OPTION_MAP (λs. s with clock := k) (pop_env z) ∧ + pop_env (z with locals := l) = pop_env z +Proof + srw_tac[][pop_env_def] >> every_case_tac >> full_simp_tac(srw_ss())[] +QED + +Theorem call_env_const[simp]: + (call_env x y).clock = y.clock ∧ (call_env x y).compile_oracle = y.compile_oracle ∧ (call_env x y).compile = y.compile ∧ (call_env x y).be = y.be ∧ @@ -138,19 +156,25 @@ Theorem call_env_const[simp] (call_env x y).ffi = y.ffi ∧ (call_env x y).code = y.code ∧ (call_env x y).code_buffer = y.code_buffer ∧ - (call_env x y).data_buffer = y.data_buffer` - (EVAL_TAC); - -Theorem call_env_with_const[simp] - `call_env x (y with clock := k) = call_env x y with clock := k` - (EVAL_TAC); - -Theorem has_space_with_const[simp] - `has_space x (y with clock := k) = has_space x y` - (EVAL_TAC); - -Theorem gc_const - `gc x = SOME y ⇒ + (call_env x y).data_buffer = y.data_buffer +Proof + EVAL_TAC +QED + +Theorem call_env_with_const[simp]: + call_env x (y with clock := k) = call_env x y with clock := k +Proof + EVAL_TAC +QED + +Theorem has_space_with_const[simp]: + has_space x (y with clock := k) = has_space x y +Proof + EVAL_TAC +QED + +Theorem gc_const: + gc x = SOME y ⇒ y.clock = x.clock ∧ y.ffi = x.ffi ∧ y.code = x.code ∧ @@ -158,21 +182,25 @@ Theorem gc_const y.code_buffer = x.code_buffer ∧ y.data_buffer = x.data_buffer ∧ y.compile = x.compile ∧ - y.compile_oracle = x.compile_oracle` - (simp[gc_def] >> - every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> srw_tac[][]); - -Theorem gc_with_const[simp] - `gc (x with clock := k) = OPTION_MAP (λs. s with clock := k) (gc x) ∧ - gc (x with locals := l) = OPTION_MAP (λs. s with locals := l) (gc x)` - (EVAL_TAC >> + y.compile_oracle = x.compile_oracle +Proof + simp[gc_def] >> + every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> srw_tac[][] +QED + +Theorem gc_with_const[simp]: + gc (x with clock := k) = OPTION_MAP (λs. s with clock := k) (gc x) ∧ + gc (x with locals := l) = OPTION_MAP (λs. s with locals := l) (gc x) +Proof + EVAL_TAC >> CASE_TAC >> EVAL_TAC >> CASE_TAC >> EVAL_TAC >> CASE_TAC >> EVAL_TAC >> - CASE_TAC >> EVAL_TAC); + CASE_TAC >> EVAL_TAC +QED -Theorem alloc_const - `alloc c names s = (r,s') ⇒ +Theorem alloc_const: + alloc c names s = (r,s') ⇒ s'.clock = s.clock ∧ s'.ffi = s.ffi ∧ s'.code = s.code ∧ @@ -180,100 +208,124 @@ Theorem alloc_const s'.code_buffer = s.code_buffer ∧ s'.data_buffer = s.data_buffer ∧ s'.compile = s.compile ∧ - s'.compile_oracle = s.compile_oracle` - (srw_tac[][alloc_def] >> + s'.compile_oracle = s.compile_oracle +Proof + srw_tac[][alloc_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> imp_res_tac pop_env_const >> full_simp_tac(srw_ss())[] >> - imp_res_tac gc_const >> full_simp_tac(srw_ss())[]); - -Theorem alloc_with_const[simp] - `alloc c names (s with clock := k) = - (λ(r,s). (r,s with clock := k)) (alloc c names s)` - (srw_tac[][alloc_def] >> + imp_res_tac gc_const >> full_simp_tac(srw_ss())[] +QED + +Theorem alloc_with_const[simp]: + alloc c names (s with clock := k) = + (λ(r,s). (r,s with clock := k)) (alloc c names s) +Proof + srw_tac[][alloc_def] >> CASE_TAC >> full_simp_tac(srw_ss())[] >> CASE_TAC >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> CASE_TAC >> full_simp_tac(srw_ss())[] >> CASE_TAC >> full_simp_tac(srw_ss())[] >> CASE_TAC >> full_simp_tac(srw_ss())[] >> - CASE_TAC >> full_simp_tac(srw_ss())[]); + CASE_TAC >> full_simp_tac(srw_ss())[] +QED -Theorem get_var_with_const[simp] - `get_var x (y with clock := k) = get_var x y /\ +Theorem get_var_with_const[simp]: + get_var x (y with clock := k) = get_var x y /\ get_var x (y with permute := p) = get_var x y /\ get_var x (y with code_buffer := cb) = get_var x y /\ get_var x (y with data_buffer := db) = get_var x y /\ get_var x (y with code := cc) = get_var x y /\ get_var x (y with compile_oracle := co) = get_var x y /\ get_var x (y with compile := ccc) = get_var x y /\ - get_var x (y with stack := xs) = get_var x y` - (EVAL_TAC); + get_var x (y with stack := xs) = get_var x y +Proof + EVAL_TAC +QED -Theorem get_vars_with_const[simp] - `get_vars x (y with clock := k) = get_vars x y /\ +Theorem get_vars_with_const[simp]: + get_vars x (y with clock := k) = get_vars x y /\ get_vars x (y with permute := p) = get_vars x y /\ get_vars x (y with code_buffer := cb) = get_vars x y /\ get_vars x (y with data_buffer := db) = get_vars x y /\ get_vars x (y with code := cc) = get_vars x y /\ get_vars x (y with compile_oracle := co) = get_vars x y /\ get_vars x (y with compile := ccc) = get_vars x y /\ - get_vars x (y with stack := xs) = get_vars x y` - (Induct_on`x`>>srw_tac[][get_vars_def]); - -Theorem get_fp_var_with_const[simp] - `get_fp_var x (y with clock := k) = get_fp_var x y` - (EVAL_TAC); - -Theorem set_var_const[simp] - `(set_var x y z).clock = z.clock ∧ + get_vars x (y with stack := xs) = get_vars x y +Proof + Induct_on`x`>>srw_tac[][get_vars_def] +QED + +Theorem get_fp_var_with_const[simp]: + get_fp_var x (y with clock := k) = get_fp_var x y +Proof + EVAL_TAC +QED + +Theorem set_var_const[simp]: + (set_var x y z).clock = z.clock ∧ (set_var x y z).be = z.be ∧ (set_var x y z).ffi = z.ffi ∧ (set_var x y z).compile = z.compile ∧ (set_var x y z).compile_oracle = z.compile_oracle ∧ (set_var x y z).code_buffer = z.code_buffer ∧ (set_var x y z).data_buffer = z.data_buffer ∧ - (set_var x y z).stack = z.stack` - (EVAL_TAC); + (set_var x y z).stack = z.stack +Proof + EVAL_TAC +QED -Theorem set_fp_var_const[simp] - `(set_fp_var x y z).clock = z.clock ∧ +Theorem set_fp_var_const[simp]: + (set_fp_var x y z).clock = z.clock ∧ (set_fp_var x y z).ffi = z.ffi ∧ - (set_fp_var x y z).stack = z.stack` - (EVAL_TAC); - -Theorem set_var_with_const[simp] - `set_var x y (z with clock := k) = set_var x y z with clock := k /\ - set_var x y (z with permute := p) = set_var x y z with permute := p` - (EVAL_TAC); - -Theorem set_fp_var_with_const[simp] - `set_fp_var x y (z with clock := k) = set_fp_var x y z with clock := k` - (EVAL_TAC); - -Theorem set_vars_const[simp] - `(set_vars x y z).clock = z.clock ∧ + (set_fp_var x y z).stack = z.stack +Proof + EVAL_TAC +QED + +Theorem set_var_with_const[simp]: + set_var x y (z with clock := k) = set_var x y z with clock := k /\ + set_var x y (z with permute := p) = set_var x y z with permute := p +Proof + EVAL_TAC +QED + +Theorem set_fp_var_with_const[simp]: + set_fp_var x y (z with clock := k) = set_fp_var x y z with clock := k +Proof + EVAL_TAC +QED + +Theorem set_vars_const[simp]: + (set_vars x y z).clock = z.clock ∧ (set_vars x y z).compile_oracle = z.compile_oracle ∧ (set_vars x y z).code = z.code ∧ (set_vars x y z).code_buffer = z.code_buffer ∧ (set_vars x y z).data_buffer = z.data_buffer ∧ (set_vars x y z).compile = z.compile ∧ (set_vars x y z).be = z.be ∧ - (set_vars x y z).ffi = z.ffi` - (EVAL_TAC); - -Theorem set_vars_with_const[simp] - `set_vars x y (z with clock := k) = set_vars x y z with clock := k /\ - set_vars x y (z with permute := p) = set_vars x y z with permute := p` - (EVAL_TAC); - -Theorem mem_load_with_const[simp] - `mem_load x (y with clock := k) = mem_load x y ∧ + (set_vars x y z).ffi = z.ffi +Proof + EVAL_TAC +QED + +Theorem set_vars_with_const[simp]: + set_vars x y (z with clock := k) = set_vars x y z with clock := k /\ + set_vars x y (z with permute := p) = set_vars x y z with permute := p +Proof + EVAL_TAC +QED + +Theorem mem_load_with_const[simp]: + mem_load x (y with clock := k) = mem_load x y ∧ mem_load x (y with code := c) = mem_load x y ∧ mem_load x (y with compile_oracle := co) = mem_load x y ∧ - mem_load x (y with compile := cc) = mem_load x y` - (EVAL_TAC); + mem_load x (y with compile := cc) = mem_load x y +Proof + EVAL_TAC +QED -Theorem mem_store_const_full - `mem_store x y z = SOME a ⇒ +Theorem mem_store_const_full: + mem_store x y z = SOME a ⇒ a.clock = z.clock ∧ a.be = z.be ∧ a.ffi = z.ffi ∧ @@ -283,26 +335,33 @@ Theorem mem_store_const_full a.data_buffer = z.data_buffer ∧ a.compile = z.compile ∧ a.compile_oracle = z.compile_oracle ∧ - a.stack = z.stack` - (EVAL_TAC >> srw_tac[][] >> srw_tac[][]); + a.stack = z.stack +Proof + EVAL_TAC >> srw_tac[][] >> srw_tac[][] +QED -Theorem mem_store_const - `mem_store x y z = SOME a ⇒ +Theorem mem_store_const: + mem_store x y z = SOME a ⇒ a.clock = z.clock ∧ - a.ffi = z.ffi` - (metis_tac [mem_store_const_full]); - -Theorem mem_store_with_const[simp] - `mem_store x z (y with clock := k) = OPTION_MAP (λs. s with clock := k) (mem_store x z y)` - (EVAL_TAC >> every_case_tac >> simp[]); - -Theorem word_exp_with_const[simp] - `∀x y k c co cc. + a.ffi = z.ffi +Proof + metis_tac [mem_store_const_full] +QED + +Theorem mem_store_with_const[simp]: + mem_store x z (y with clock := k) = OPTION_MAP (λs. s with clock := k) (mem_store x z y) +Proof + EVAL_TAC >> every_case_tac >> simp[] +QED + +Theorem word_exp_with_const[simp]: + ∀x y k c co cc. word_exp (x with clock := k) y = word_exp x y ∧ word_exp (x with code := c) y = word_exp x y ∧ word_exp (x with compile_oracle := co) y = word_exp x y ∧ - word_exp (x with compile := cc) y = word_exp x y` - (recInduct word_exp_ind >> + word_exp (x with compile := cc) y = word_exp x y +Proof + recInduct word_exp_ind >> rw[word_exp_def] >> every_case_tac >> fs[]>> ntac 2 (pop_assum mp_tac)>> @@ -310,10 +369,11 @@ Theorem word_exp_with_const[simp] qpat_abbrev_tac`ls' = MAP A B`>> `ls = ls'` by (unabbrev_all_tac>>fs[MAP_EQ_f]) >> - rw[]); + rw[] +QED -Theorem assign_const_full - `assign x y z = SOME a ⇒ +Theorem assign_const_full: + assign x y z = SOME a ⇒ a.code = z.code ∧ a.code_buffer = z.code_buffer ∧ a.data_buffer = z.data_buffer ∧ @@ -322,25 +382,33 @@ Theorem assign_const_full a.clock = z.clock ∧ a.ffi = z.ffi ∧ a.handler = z.handler ∧ - a.stack = z.stack` - (EVAL_TAC >> every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> srw_tac[][]); + a.stack = z.stack +Proof + EVAL_TAC >> every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> srw_tac[][] +QED -Theorem assign_const - `assign x y z = SOME a ⇒ +Theorem assign_const: + assign x y z = SOME a ⇒ a.clock = z.clock ∧ - a.ffi = z.ffi` - (metis_tac [assign_const_full]); - -Theorem assign_with_const[simp] - `assign x y (z with clock := k) = OPTION_MAP (λs. s with clock := k) (assign x y z)` - (EVAL_TAC >> every_case_tac >> EVAL_TAC >> full_simp_tac(srw_ss())[]); - -Theorem inst_with_const[simp] - `inst i (s with clock := k) = OPTION_MAP (λs. s with clock := k) (inst i s)` - (rw[inst_def] >> every_case_tac >> full_simp_tac(srw_ss())[]); - -Theorem inst_const_full - `inst i s = SOME s' ⇒ + a.ffi = z.ffi +Proof + metis_tac [assign_const_full] +QED + +Theorem assign_with_const[simp]: + assign x y (z with clock := k) = OPTION_MAP (λs. s with clock := k) (assign x y z) +Proof + EVAL_TAC >> every_case_tac >> EVAL_TAC >> full_simp_tac(srw_ss())[] +QED + +Theorem inst_with_const[simp]: + inst i (s with clock := k) = OPTION_MAP (λs. s with clock := k) (inst i s) +Proof + rw[inst_def] >> every_case_tac >> full_simp_tac(srw_ss())[] +QED + +Theorem inst_const_full: + inst i s = SOME s' ⇒ s'.code = s.code ∧ s'.code_buffer = s.code_buffer ∧ s'.data_buffer = s.data_buffer ∧ @@ -349,34 +417,44 @@ Theorem inst_const_full s'.clock = s.clock ∧ s'.ffi = s.ffi ∧ s'.handler = s.handler ∧ - s'.stack = s.stack` - (rw[inst_def, set_var_def,set_fp_var_def] >> + s'.stack = s.stack +Proof + rw[inst_def, set_var_def,set_fp_var_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> imp_res_tac assign_const_full >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> - imp_res_tac mem_store_const_full >> full_simp_tac(srw_ss())[] >> srw_tac[][]); + imp_res_tac mem_store_const_full >> full_simp_tac(srw_ss())[] >> srw_tac[][] +QED -Theorem inst_const - `inst i s = SOME s' ⇒ +Theorem inst_const: + inst i s = SOME s' ⇒ s'.clock = s.clock ∧ - s'.ffi = s.ffi` - (metis_tac [inst_const_full]); + s'.ffi = s.ffi +Proof + metis_tac [inst_const_full] +QED -Theorem jump_exc_const - `jump_exc s = SOME (x,y) ⇒ +Theorem jump_exc_const: + jump_exc s = SOME (x,y) ⇒ x.clock = s.clock ∧ - x.ffi = s.ffi` - (EVAL_TAC >> every_case_tac >> EVAL_TAC >> srw_tac[][] >> srw_tac[][]); - -Theorem jump_exc_with_const[simp] - `jump_exc (s with clock := k) = OPTION_MAP (λ(s,t). (s with clock := k, t)) (jump_exc s)` - (EVAL_TAC >> every_case_tac >> EVAL_TAC); - -Theorem get_var_imm_with_const[simp] - `get_var_imm x (y with clock := k) = get_var_imm x y` - (Cases_on`x`>>EVAL_TAC); - -Theorem dec_clock_const[simp] - `(dec_clock s).be = s.be /\ + x.ffi = s.ffi +Proof + EVAL_TAC >> every_case_tac >> EVAL_TAC >> srw_tac[][] >> srw_tac[][] +QED + +Theorem jump_exc_with_const[simp]: + jump_exc (s with clock := k) = OPTION_MAP (λ(s,t). (s with clock := k, t)) (jump_exc s) +Proof + EVAL_TAC >> every_case_tac >> EVAL_TAC +QED + +Theorem get_var_imm_with_const[simp]: + get_var_imm x (y with clock := k) = get_var_imm x y +Proof + Cases_on`x`>>EVAL_TAC +QED + +Theorem dec_clock_const[simp]: + (dec_clock s).be = s.be /\ (dec_clock s).ffi = s.ffi /\ (dec_clock s).code = s.code /\ (dec_clock s).code_buffer = s.code_buffer /\ @@ -384,16 +462,19 @@ Theorem dec_clock_const[simp] (dec_clock s).compile_oracle = s.compile_oracle ∧ (dec_clock s).stack = s.stack ∧ (dec_clock s).permute = s.permute ∧ - (dec_clock s).compile = s.compile` - (EVAL_TAC); + (dec_clock s).compile = s.compile +Proof + EVAL_TAC +QED (* Standard add clock lemma for FBS *) -Theorem evaluate_add_clock - `∀p s r s'. +Theorem evaluate_add_clock: + ∀p s r s'. evaluate (p,s) = (r,s') ∧ r ≠ SOME TimeOut ⇒ - evaluate (p,s with clock := s.clock + extra) = (r,s' with clock := s'.clock + extra)` - (recInduct evaluate_ind >> + evaluate (p,s with clock := s.clock + extra) = (r,s' with clock := s'.clock + extra) +Proof + recInduct evaluate_ind >> srw_tac[][evaluate_def] >> TRY CASE_TAC >> full_simp_tac(srw_ss())[] >> rveq >> full_simp_tac(srw_ss())[] >> rveq >> TRY CASE_TAC >> full_simp_tac(srw_ss())[] >> @@ -445,7 +526,8 @@ Theorem evaluate_add_clock imp_res_tac jump_exc_const >> full_simp_tac(srw_ss())[] >> rev_full_simp_tac(srw_ss())[] >>fsrw_tac[ARITH_ss][] >> rev_full_simp_tac(srw_ss()++ARITH_ss)[]>>rveq>>full_simp_tac(srw_ss())[]>> - metis_tac[]); + metis_tac[] +QED val tac = EVERY_CASE_TAC>>full_simp_tac(srw_ss())[state_component_equality] val tac2 = @@ -461,11 +543,12 @@ val tac2 = The number of clock ticks is fixed for any program, and can be characterized by st.clock - rst.clock *) -Theorem evaluate_dec_clock - `∀prog st res rst. +Theorem evaluate_dec_clock: + ∀prog st res rst. evaluate(prog,st) = (res,rst) ⇒ - evaluate(prog,st with clock:=st.clock-rst.clock) = (res,rst with clock:=0)` - (recInduct evaluate_ind >>srw_tac[][evaluate_def]>>full_simp_tac(srw_ss())[call_env_def,dec_clock_def] + evaluate(prog,st with clock:=st.clock-rst.clock) = (res,rst with clock:=0) +Proof + recInduct evaluate_ind >>srw_tac[][evaluate_def]>>full_simp_tac(srw_ss())[call_env_def,dec_clock_def] >- (tac>>imp_res_tac alloc_const>>full_simp_tac(srw_ss())[]) >- tac >- (TOP_CASE_TAC>>full_simp_tac(srw_ss())[]>> assume_tac inst_const>>tac) @@ -538,16 +621,18 @@ Theorem evaluate_dec_clock first_x_assum(qspec_then`r'.clock-rst.clock` mp_tac)>> simp[]) >> - tac2); + tac2 +QED (* IO and clock monotonicity *) -Theorem evaluate_io_events_mono - `!exps s1 res s2. +Theorem evaluate_io_events_mono: + !exps s1 res s2. evaluate (exps,s1) = (res, s2) ⇒ - s1.ffi.io_events ≼ s2.ffi.io_events` - (recInduct evaluate_ind >> ntac 5 strip_tac >> + s1.ffi.io_events ≼ s2.ffi.io_events +Proof + recInduct evaluate_ind >> ntac 5 strip_tac >> rpt conj_tac >> rpt gen_tac >> full_simp_tac(srw_ss())[evaluate_def] >> @@ -566,17 +651,21 @@ Theorem evaluate_io_events_mono rveq >> full_simp_tac(srw_ss())[] >> TRY (CHANGED_TAC(full_simp_tac(srw_ss())[ffiTheory.call_FFI_def]) >> every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] ) >> - metis_tac[IS_PREFIX_TRANS]); + metis_tac[IS_PREFIX_TRANS] +QED -Theorem with_clock_ffi - `(s with clock := y).ffi = s.ffi` - (EVAL_TAC); +Theorem with_clock_ffi: + (s with clock := y).ffi = s.ffi +Proof + EVAL_TAC +QED -Theorem evaluate_add_clock_io_events_mono - `∀exps s extra. +Theorem evaluate_add_clock_io_events_mono: + ∀exps s extra. (SND(evaluate(exps,s))).ffi.io_events ≼ - (SND(evaluate(exps,s with clock := s.clock + extra))).ffi.io_events` - (recInduct evaluate_ind >> + (SND(evaluate(exps,s with clock := s.clock + extra))).ffi.io_events +Proof + recInduct evaluate_ind >> srw_tac[][evaluate_def,LET_THM] >> TRY ( rename1`find_code` >> @@ -685,11 +774,12 @@ Theorem evaluate_add_clock_io_events_mono imp_res_tac evaluate_add_clock >> full_simp_tac(srw_ss())[] >> rveq >> full_simp_tac(srw_ss())[] >> imp_res_tac evaluate_io_events_mono >> rev_full_simp_tac(srw_ss())[] >> - metis_tac[evaluate_io_events_mono,IS_PREFIX_TRANS,SND,PAIR]); + metis_tac[evaluate_io_events_mono,IS_PREFIX_TRANS,SND,PAIR] +QED (*code and gc_fun are unchanged across eval*) -Theorem pop_env_code_gc_fun_clock ` - pop_env r = SOME x ⇒ +Theorem pop_env_code_gc_fun_clock: + pop_env r = SOME x ⇒ r.code = x.code ∧ r.code_buffer = x.code_buffer ∧ r.data_buffer = x.data_buffer ∧ @@ -698,11 +788,13 @@ Theorem pop_env_code_gc_fun_clock ` r.be = x.be ∧ r.mdomain = x.mdomain ∧ r.compile = x.compile ∧ - r.compile_oracle = x.compile_oracle` - (fs[pop_env_def]>>EVERY_CASE_TAC>>fs[state_component_equality]); + r.compile_oracle = x.compile_oracle +Proof + fs[pop_env_def]>>EVERY_CASE_TAC>>fs[state_component_equality] +QED -Theorem alloc_code_gc_fun_const ` - alloc x names s = (res,t) ⇒ +Theorem alloc_code_gc_fun_const: + alloc x names s = (res,t) ⇒ t.code = s.code /\ t.code_buffer = s.code_buffer /\ t.data_buffer = s.data_buffer /\ @@ -710,25 +802,27 @@ Theorem alloc_code_gc_fun_const ` t.mdomain = s.mdomain /\ t.be = s.be ∧ t.compile = s.compile ∧ - t.compile_oracle = s.compile_oracle` - (fs[alloc_def,gc_def,LET_THM]>>EVERY_CASE_TAC>> + t.compile_oracle = s.compile_oracle +Proof + fs[alloc_def,gc_def,LET_THM]>>EVERY_CASE_TAC>> fs[call_env_def,push_env_def,LET_THM,env_to_list_def,set_store_def,state_component_equality]>> - imp_res_tac pop_env_code_gc_fun_clock>>fs[]); + imp_res_tac pop_env_code_gc_fun_clock>>fs[] +QED val inst_code_gc_fun_const = Q.prove(` inst i s = SOME t ⇒ s.code = t.code /\ s.gc_fun = t.gc_fun /\ s.mdomain = t.mdomain /\ s.be = t.be ∧ s.compile = t.compile`, Cases_on`i`>>fs[inst_def,assign_def]>>EVERY_CASE_TAC>>fs[set_var_def,state_component_equality,mem_store_def,set_fp_var_def]); -Theorem evaluate_consts - `!xs s1 vs s2. +Theorem evaluate_consts: + !xs s1 vs s2. evaluate (xs,s1) = (vs,s2) ==> s1.gc_fun = s2.gc_fun /\ s1.mdomain = s2.mdomain /\ s1.be = s2.be ∧ s1.compile = s2.compile - ` - (recInduct evaluate_ind>>fs[evaluate_def,LET_THM]>>reverse (rpt conj_tac>>rpt gen_tac>>rpt DISCH_TAC) +Proof + recInduct evaluate_ind>>fs[evaluate_def,LET_THM]>>reverse (rpt conj_tac>>rpt gen_tac>>rpt DISCH_TAC) >- (rename1 `bad_dest_args _ _`>> pop_assum mp_tac>> @@ -746,19 +840,22 @@ Theorem evaluate_consts EVERY_CASE_TAC>>fs[set_vars_def,state_component_equality,set_var_def,set_store_def,mem_store_def,call_env_def,dec_clock_def]>> TRY(pairarg_tac>>fs[])>> EVERY_CASE_TAC>>fs[set_vars_def,state_component_equality,set_var_def,set_store_def,mem_store_def,call_env_def,dec_clock_def]>> - metis_tac[alloc_code_gc_fun_const,inst_code_gc_fun_const,state_component_equality]); + metis_tac[alloc_code_gc_fun_const,inst_code_gc_fun_const,state_component_equality] +QED (* TODO: monotonicity *) (* -- *) -Theorem get_vars_length_lemma - `!ls s y. get_vars ls s = SOME y ==> - LENGTH y = LENGTH ls` - (Induct>>full_simp_tac(srw_ss())[get_vars_def]>> +Theorem get_vars_length_lemma: + !ls s y. get_vars ls s = SOME y ==> + LENGTH y = LENGTH ls +Proof + Induct>>full_simp_tac(srw_ss())[get_vars_def]>> Cases_on`get_var h s`>>full_simp_tac(srw_ss())[]>> Cases_on`get_vars ls s`>>full_simp_tac(srw_ss())[]>> - metis_tac[LENGTH]); + metis_tac[LENGTH] +QED (*--Stack Swap Lemma--*) @@ -791,15 +888,19 @@ val s_key_eq_def = Define` (s_key_eq _ _ = F)` (*Reflexive*) -Theorem s_key_eq_refl - `!ls .s_key_eq ls ls = T` - (Induct >> srw_tac[][s_key_eq_def]>> - Cases_on`h`>> Cases_on`o'`>>srw_tac[][s_frame_key_eq_def]); - -Theorem s_val_eq_refl - `!ls.s_val_eq ls ls = T` - (Induct >> srw_tac[][s_val_eq_def]>> - Cases_on`h`>> Cases_on`o'`>>srw_tac[][s_frame_val_eq_def]); +Theorem s_key_eq_refl: + !ls .s_key_eq ls ls = T +Proof + Induct >> srw_tac[][s_key_eq_def]>> + Cases_on`h`>> Cases_on`o'`>>srw_tac[][s_frame_key_eq_def] +QED + +Theorem s_val_eq_refl: + !ls.s_val_eq ls ls = T +Proof + Induct >> srw_tac[][s_val_eq_def]>> + Cases_on`h`>> Cases_on`o'`>>srw_tac[][s_frame_val_eq_def] +QED (*transitive*) val s_frame_key_eq_trans = Q.prove( @@ -809,12 +910,14 @@ val s_frame_key_eq_trans = Q.prove( Cases_on`o'`>>Cases_on`o''`>>Cases_on`o'''`>> full_simp_tac(srw_ss())[s_frame_key_eq_def]); -Theorem s_key_eq_trans - `!a b c. s_key_eq a b /\ s_key_eq b c ==> - s_key_eq a c` - (Induct>> +Theorem s_key_eq_trans: + !a b c. s_key_eq a b /\ s_key_eq b c ==> + s_key_eq a c +Proof + Induct>> Cases_on`b`>>Cases_on`c`>>full_simp_tac(srw_ss())[s_key_eq_def]>> - srw_tac[][]>>metis_tac[s_frame_key_eq_trans]); + srw_tac[][]>>metis_tac[s_frame_key_eq_trans] +QED val s_frame_val_eq_trans = Q.prove( `!a b c. s_frame_val_eq a b /\ s_frame_val_eq b c ==> @@ -835,31 +938,37 @@ val s_frame_key_eq_sym = Q.prove( `!a b. s_frame_key_eq a b <=> s_frame_key_eq b a`, Cases>>Cases>>Cases_on`o'`>>Cases_on`o''`>>full_simp_tac(srw_ss())[s_frame_key_eq_def,EQ_SYM_EQ]); -Theorem s_key_eq_sym - `!a b. s_key_eq a b <=> s_key_eq b a` - (Induct>> Cases_on`b`>>full_simp_tac(srw_ss())[s_key_eq_def]>> - strip_tac>>metis_tac[s_frame_key_eq_sym]); +Theorem s_key_eq_sym: + !a b. s_key_eq a b <=> s_key_eq b a +Proof + Induct>> Cases_on`b`>>full_simp_tac(srw_ss())[s_key_eq_def]>> + strip_tac>>metis_tac[s_frame_key_eq_sym] +QED val s_frame_val_eq_sym = Q.prove( `!a b. s_frame_val_eq a b <=> s_frame_val_eq b a`, Cases>>Cases>>Cases_on`o'`>>Cases_on`o''`>>full_simp_tac(srw_ss())[s_frame_val_eq_def,EQ_SYM_EQ]); -Theorem s_val_eq_sym - `!a b. s_val_eq a b <=> s_val_eq b a` - (Induct>> Cases_on`b`>>full_simp_tac(srw_ss())[s_val_eq_def]>> - strip_tac>>metis_tac[s_frame_val_eq_sym]); +Theorem s_val_eq_sym: + !a b. s_val_eq a b <=> s_val_eq b a +Proof + Induct>> Cases_on`b`>>full_simp_tac(srw_ss())[s_val_eq_def]>> + strip_tac>>metis_tac[s_frame_val_eq_sym] +QED val s_frame_val_and_key_eq = Q.prove( `!s t. s_frame_val_eq s t /\ s_frame_key_eq s t ==> s = t`, Cases>>Cases>>Cases_on`o'`>>Cases_on`o''`>> full_simp_tac(srw_ss())[s_frame_val_eq_def,s_frame_key_eq_def,LIST_EQ_MAP_PAIR]); -Theorem s_val_and_key_eq - `!s t. s_val_eq s t /\ s_key_eq s t ==> s =t` - (Induct>- +Theorem s_val_and_key_eq: + !s t. s_val_eq s t /\ s_key_eq s t ==> s =t +Proof + Induct>- (Cases>>full_simp_tac(srw_ss())[s_val_eq_def])>> srw_tac[][]>> - Cases_on`t`>>full_simp_tac(srw_ss())[s_val_eq_def,s_key_eq_def,s_frame_val_and_key_eq]); + Cases_on`t`>>full_simp_tac(srw_ss())[s_val_eq_def,s_key_eq_def,s_frame_val_and_key_eq] +QED val dec_stack_stack_key_eq = Q.prove( `!wl st st'. dec_stack wl st = SOME st' ==> s_key_eq st st'`, @@ -870,11 +979,13 @@ val dec_stack_stack_key_eq = Q.prove( full_simp_tac(srw_ss())[s_key_eq_def,s_frame_key_eq_def,MAP_ZIP,NOT_LESS]); (*gc preserves the stack_key relation*) -Theorem gc_s_key_eq - `!s x. gc s = SOME x ==> s_key_eq s.stack x.stack` - (srw_tac[][gc_def] >>full_simp_tac(srw_ss())[LET_THM]>>every_case_tac>>full_simp_tac(srw_ss())[]>> +Theorem gc_s_key_eq: + !s x. gc s = SOME x ==> s_key_eq s.stack x.stack +Proof + srw_tac[][gc_def] >>full_simp_tac(srw_ss())[LET_THM]>>every_case_tac>>full_simp_tac(srw_ss())[]>> IMP_RES_TAC dec_stack_stack_key_eq>> - full_simp_tac(srw_ss())[state_component_equality]>>rev_full_simp_tac(srw_ss())[]); + full_simp_tac(srw_ss())[state_component_equality]>>rev_full_simp_tac(srw_ss())[] +QED val s_val_eq_enc_stack = Q.prove( `!st st'. s_val_eq st st' ==> enc_stack st = enc_stack st'`, @@ -900,12 +1011,13 @@ val s_val_eq_dec_stack = Q.prove( (*gc succeeds on all stacks related by stack_val and there are relations in the result*) -Theorem gc_s_val_eq - `!s x st y. s_val_eq s.stack st /\ +Theorem gc_s_val_eq: + !s x st y. s_val_eq s.stack st /\ gc s = SOME y ==> ?z. gc (s with stack := st) = SOME (y with stack := z) /\ - s_val_eq y.stack z /\ s_key_eq z st` - (srw_tac[][gc_def]>>full_simp_tac(srw_ss())[LET_THM]>> + s_val_eq y.stack z /\ s_key_eq z st +Proof + srw_tac[][gc_def]>>full_simp_tac(srw_ss())[LET_THM]>> SIMP_TAC std_ss [markerTheory.Abbrev_def]>> IMP_RES_TAC s_val_eq_enc_stack>>full_simp_tac(srw_ss())[]>> qpat_x_assum `x = SOME y` mp_tac>> @@ -914,18 +1026,20 @@ Theorem gc_s_val_eq strip_tac>>full_simp_tac(srw_ss())[]>> IMP_RES_TAC dec_stack_stack_key_eq>> IMP_RES_TAC s_key_eq_sym>> - Q.EXISTS_TAC`y'`>>full_simp_tac(srw_ss())[state_component_equality]>>rev_full_simp_tac(srw_ss())[]); + Q.EXISTS_TAC`y'`>>full_simp_tac(srw_ss())[state_component_equality]>>rev_full_simp_tac(srw_ss())[] +QED (*Slightly more general theorem allows the unused locals to be differnt*) -Theorem gc_s_val_eq_word_state - `!s tlocs tstack y. +Theorem gc_s_val_eq_word_state: + !s tlocs tstack y. s_val_eq s.stack tstack /\ gc s = SOME y ==> ?zlocs zstack. gc (s with <|stack:=tstack;locals:=tlocs|>) = SOME (y with <|stack:=zstack;locals:=zlocs|>) /\ - s_val_eq y.stack zstack /\ s_key_eq zstack tstack` - (srw_tac[][gc_def]>>full_simp_tac(srw_ss())[LET_THM]>> + s_val_eq y.stack zstack /\ s_key_eq zstack tstack +Proof + srw_tac[][gc_def]>>full_simp_tac(srw_ss())[LET_THM]>> SIMP_TAC std_ss [markerTheory.Abbrev_def]>> IMP_RES_TAC s_val_eq_enc_stack>>full_simp_tac(srw_ss())[]>> qpat_x_assum `x = SOME y` mp_tac>> @@ -936,12 +1050,12 @@ Theorem gc_s_val_eq_word_state IMP_RES_TAC s_key_eq_sym>> Q.EXISTS_TAC`tlocs`>> Q.EXISTS_TAC`y'`>> - full_simp_tac(srw_ss())[state_component_equality]>>rev_full_simp_tac(srw_ss())[]); + full_simp_tac(srw_ss())[state_component_equality]>>rev_full_simp_tac(srw_ss())[] +QED (*Most generalised gc_s_val_eq*) -Theorem gc_s_val_eq_gen -` - !s t s'. +Theorem gc_s_val_eq_gen: + !s t s'. s.gc_fun = t.gc_fun ∧ s.memory = t.memory ∧ s.mdomain = t.mdomain ∧ @@ -953,32 +1067,36 @@ Theorem gc_s_val_eq_gen s_val_eq s'.stack t'.stack ∧ s_key_eq t.stack t'.stack ∧ t'.memory = s'.memory ∧ - t'.store = s'.store` - (srw_tac[][]>> + t'.store = s'.store +Proof + srw_tac[][]>> full_simp_tac(srw_ss())[gc_def,LET_THM]>> IMP_RES_TAC s_val_eq_enc_stack>> every_case_tac>>rev_full_simp_tac(srw_ss())[]>> IMP_RES_TAC s_val_eq_dec_stack>>full_simp_tac(srw_ss())[]>> qpat_x_assum`A=s'` (SUBST_ALL_TAC o SYM)>> IMP_RES_TAC dec_stack_stack_key_eq>>full_simp_tac(srw_ss())[]>> - metis_tac[s_val_eq_sym]); + metis_tac[s_val_eq_sym] +QED (*pushing and popping maintain the stack_key relation*) -Theorem push_env_pop_env_s_key_eq - `∀s t x b. s_key_eq (push_env x b s).stack t.stack ⇒ +Theorem push_env_pop_env_s_key_eq: + ∀s t x b. s_key_eq (push_env x b s).stack t.stack ⇒ ∃l ls opt. t.stack = (StackFrame l opt)::ls ∧ ∃y. (pop_env t = SOME y ∧ y.locals = fromAList l ∧ domain x = domain y.locals ∧ - s_key_eq s.stack y.stack)` - (srw_tac[][]>>Cases_on`b`>>TRY(PairCases_on`x'`)>>full_simp_tac(srw_ss())[push_env_def]>> + s_key_eq s.stack y.stack) +Proof + srw_tac[][]>>Cases_on`b`>>TRY(PairCases_on`x'`)>>full_simp_tac(srw_ss())[push_env_def]>> full_simp_tac(srw_ss())[LET_THM,env_to_list_def]>>Cases_on`t.stack`>> full_simp_tac(srw_ss())[s_key_eq_def,pop_env_def]>>BasicProvers.EVERY_CASE_TAC>> full_simp_tac(srw_ss())[domain_fromAList,s_frame_key_eq_def]>> qpat_x_assum `A = MAP FST l` (SUBST1_TAC o SYM)>> full_simp_tac(srw_ss())[EXTENSION,mem_list_rearrange,MEM_MAP,QSORT_MEM,MEM_toAList - ,EXISTS_PROD,domain_lookup]); + ,EXISTS_PROD,domain_lookup] +QED val get_vars_stack_swap = Q.prove( `!l s t. s.locals = t.locals ==> @@ -992,15 +1110,19 @@ val get_vars_stack_swap_simp = Q.prove( `(s with stack:=xs).locals = s.locals` by full_simp_tac(srw_ss())[]>> metis_tac[get_vars_stack_swap]); -Theorem s_val_eq_length - `!s t. s_val_eq s t ==> LENGTH s = LENGTH t` - (Induct>>Cases>>full_simp_tac(srw_ss())[s_val_eq_def,LENGTH]>> - Cases>>full_simp_tac(srw_ss())[s_val_eq_def]); +Theorem s_val_eq_length: + !s t. s_val_eq s t ==> LENGTH s = LENGTH t +Proof + Induct>>Cases>>full_simp_tac(srw_ss())[s_val_eq_def,LENGTH]>> + Cases>>full_simp_tac(srw_ss())[s_val_eq_def] +QED -Theorem s_key_eq_length - `!s t. s_key_eq s t ==> LENGTH s = LENGTH t` - (Induct>>Cases>>full_simp_tac(srw_ss())[s_key_eq_def,LENGTH]>> - Cases>>full_simp_tac(srw_ss())[s_key_eq_def]); +Theorem s_key_eq_length: + !s t. s_key_eq s t ==> LENGTH s = LENGTH t +Proof + Induct>>Cases>>full_simp_tac(srw_ss())[s_key_eq_def,LENGTH]>> + Cases>>full_simp_tac(srw_ss())[s_key_eq_def] +QED val s_val_eq_APPEND = Q.prove( `!s t x y. (s_val_eq s t /\ s_val_eq x y)==> s_val_eq (s++x) (t++y)`, @@ -1054,9 +1176,11 @@ val s_key_eq_LASTN = Q.prove( IMP_RES_TAC s_key_eq_TAKE>> metis_tac[s_key_eq_REVERSE]); -Theorem s_key_eq_tail - `!a b c d. s_key_eq (a::b) (c::d) ==> s_key_eq b d` - (full_simp_tac(srw_ss())[s_key_eq_def]); +Theorem s_key_eq_tail: + !a b c d. s_key_eq (a::b) (c::d) ==> s_key_eq b d +Proof + full_simp_tac(srw_ss())[s_key_eq_def] +QED val s_val_eq_tail = Q.prove( `!a b c d. s_val_eq (a::b) (c::d) ==> s_val_eq b d`, @@ -1075,22 +1199,26 @@ val s_key_eq_LASTN_exists = Q.prove( full_simp_tac(srw_ss())[s_key_eq_def]>> Cases_on`h`>>Cases_on`o'`>>full_simp_tac(srw_ss())[s_frame_key_eq_def]); -Theorem s_val_eq_LASTN_exists - `!s t n e y xs. s_val_eq s t /\ +Theorem s_val_eq_LASTN_exists: + !s t n e y xs. s_val_eq s t /\ LASTN n s = StackFrame e (SOME y)::xs ==> ?e' ls. LASTN n t = StackFrame e' (SOME y)::ls /\ MAP SND e' = MAP SND e - /\ s_val_eq xs ls` - (rpt strip_tac>> + /\ s_val_eq xs ls +Proof + rpt strip_tac>> IMP_RES_TAC s_val_eq_LASTN>> first_x_assum (qspec_then `n` assume_tac)>> rev_full_simp_tac(srw_ss())[]>> Cases_on`LASTN n t`>> full_simp_tac(srw_ss())[s_val_eq_def]>> - Cases_on`h`>>Cases_on`o'`>>full_simp_tac(srw_ss())[s_frame_val_eq_def]); + Cases_on`h`>>Cases_on`o'`>>full_simp_tac(srw_ss())[s_frame_val_eq_def] +QED -Theorem LASTN_LENGTH_cond - `!n xs. n = LENGTH xs ==> LASTN n xs =xs` - (metis_tac[LASTN_LENGTH_ID] ); +Theorem LASTN_LENGTH_cond: + !n xs. n = LENGTH xs ==> LASTN n xs =xs +Proof + metis_tac[LASTN_LENGTH_ID] +QED val handler_eq = Q.prove( `x with handler := x.handler = x`, full_simp_tac(srw_ss())[state_component_equality]); @@ -1112,8 +1240,8 @@ val word_exp_stack_swap = Q.prove( every_case_tac>>full_simp_tac(srw_ss())[]); (*Stack swap theorem for evaluate*) -Theorem evaluate_stack_swap ` - !c s. +Theorem evaluate_stack_swap: + !c s. case evaluate (c,s) of | (SOME Error,s1) => T | (SOME (FinalFFI e),s1) => s1.stack = [] /\ s1.locals = LN /\ @@ -1158,8 +1286,9 @@ Theorem evaluate_stack_swap ` ?st. evaluate (c,s with stack := xs) = (res, s1 with stack := st) /\ s_val_eq s1.stack st /\ - s_key_eq xs st)` - (ho_match_mp_tac (evaluate_ind |> Q.SPEC`UNCURRY P` |> SIMP_RULE (srw_ss())[] |> Q.GEN`P`) >> srw_tac[][] + s_key_eq xs st) +Proof + ho_match_mp_tac (evaluate_ind |> Q.SPEC`UNCURRY P` |> SIMP_RULE (srw_ss())[] |> Q.GEN`P`) >> srw_tac[][] >-(*Skip*) (full_simp_tac(srw_ss())[evaluate_def,s_key_eq_refl]>>srw_tac[][]>>HINT_EXISTS_TAC>>full_simp_tac(srw_ss())[s_key_eq_refl]) >-(*Alloc*) @@ -1733,7 +1862,8 @@ Theorem evaluate_stack_swap ` first_x_assum (qspec_then `frame` assume_tac)>> first_x_assum(qspec_then `frame::xs` assume_tac)>> rev_full_simp_tac(srw_ss())[call_env_def]>> - `LENGTH xs = LENGTH s.stack` by full_simp_tac(srw_ss())[s_val_eq_length]>> full_simp_tac(srw_ss())[])); + `LENGTH xs = LENGTH s.stack` by full_simp_tac(srw_ss())[s_val_eq_length]>> full_simp_tac(srw_ss())[]) +QED (*--Stack Swap Lemma DONE--*) @@ -1747,17 +1877,21 @@ val ignore_perm = Q.prove(` ∀st. st with permute := st.permute = st` , srw_tac[][]>>full_simp_tac(srw_ss())[state_component_equality]); -Theorem get_vars_perm ` - ∀args.get_vars args (st with permute:=perm) = get_vars args st` - (Induct>>srw_tac[][get_vars_def,get_var_def]); +Theorem get_vars_perm: + ∀args.get_vars args (st with permute:=perm) = get_vars args st +Proof + Induct>>srw_tac[][get_vars_def,get_var_def] +QED -Theorem pop_env_perm ` - pop_env (rst with permute:=perm) = +Theorem pop_env_perm: + pop_env (rst with permute:=perm) = (case pop_env rst of NONE => NONE - | SOME rst' => SOME (rst' with permute:=perm))` - (full_simp_tac(srw_ss())[pop_env_def]>>every_case_tac>> - full_simp_tac(srw_ss())[state_component_equality]); + | SOME rst' => SOME (rst' with permute:=perm)) +Proof + full_simp_tac(srw_ss())[pop_env_def]>>every_case_tac>> + full_simp_tac(srw_ss())[state_component_equality] +QED val gc_perm = Q.prove(` gc st = SOME x ⇒ @@ -1765,39 +1899,53 @@ val gc_perm = Q.prove(` full_simp_tac(srw_ss())[gc_def,LET_THM]>>every_case_tac>> full_simp_tac(srw_ss())[state_component_equality]); -Theorem get_var_perm ` - get_var n (st with permute:=perm) = - (get_var n st)` (full_simp_tac(srw_ss())[get_var_def]); - -Theorem get_fp_var_perm ` - get_fp_var n (st with permute:=perm) = - (get_fp_var n st)` (full_simp_tac(srw_ss())[get_fp_var_def]); - -Theorem get_var_imm_perm ` - get_var_imm n (st with permute:=perm) = - (get_var_imm n st)` - (Cases_on`n`>> - fs[get_var_imm_def]); - -Theorem set_var_perm[simp] ` - set_var v x (s with permute:=perm) = - (set_var v x s) with permute:=perm` - (full_simp_tac(srw_ss())[set_var_def]); - -Theorem set_fp_var_perm ` - set_fp_var v x (s with permute:=perm) = - (set_fp_var v x s) with permute:=perm` - (full_simp_tac(srw_ss())[set_fp_var_def]); +Theorem get_var_perm: + get_var n (st with permute:=perm) = + (get_var n st) +Proof +full_simp_tac(srw_ss())[get_var_def] +QED + +Theorem get_fp_var_perm: + get_fp_var n (st with permute:=perm) = + (get_fp_var n st) +Proof +full_simp_tac(srw_ss())[get_fp_var_def] +QED + +Theorem get_var_imm_perm: + get_var_imm n (st with permute:=perm) = + (get_var_imm n st) +Proof + Cases_on`n`>> + fs[get_var_imm_def] +QED + +Theorem set_var_perm[simp]: + set_var v x (s with permute:=perm) = + (set_var v x s) with permute:=perm +Proof + full_simp_tac(srw_ss())[set_var_def] +QED + +Theorem set_fp_var_perm: + set_fp_var v x (s with permute:=perm) = + (set_fp_var v x s) with permute:=perm +Proof + full_simp_tac(srw_ss())[set_fp_var_def] +QED val get_vars_perm = Q.prove(` ∀ls. get_vars ls (st with permute:=perm) = (get_vars ls st)`, Induct>>full_simp_tac(srw_ss())[get_vars_def,get_var_perm]); -Theorem set_vars_perm[simp] ` - ∀ls. set_vars ls x (st with permute := perm) = - (set_vars ls x st) with permute:=perm` - (full_simp_tac(srw_ss())[set_vars_def]); +Theorem set_vars_perm[simp]: + ∀ls. set_vars ls x (st with permute := perm) = + (set_vars ls x st) with permute:=perm +Proof + full_simp_tac(srw_ss())[set_vars_def] +QED val word_state_rewrites = Q.prove(` (st with clock:=A) with permute:=B = @@ -1811,17 +1959,19 @@ val perm_assum_tac = (first_x_assum(qspec_then`perm`assume_tac)>> `(λn. perm' n) = perm'` by full_simp_tac(srw_ss())[FUN_EQ_THM]>> simp[]); -Theorem word_exp_perm[simp] ` - ∀s exp. word_exp (s with permute:=perm) exp = - word_exp s exp` - (ho_match_mp_tac word_exp_ind>>srw_tac[][word_exp_def] +Theorem word_exp_perm[simp]: + ∀s exp. word_exp (s with permute:=perm) exp = + word_exp s exp +Proof + ho_match_mp_tac word_exp_ind>>srw_tac[][word_exp_def] >- (every_case_tac>>full_simp_tac(srw_ss())[mem_load_def]) >> qpat_abbrev_tac`ls = MAP A B`>> qpat_abbrev_tac`ls' = MAP A B`>> `ls = ls'` by - (unabbrev_all_tac>>fs[MAP_EQ_f])>> fs[]); + (unabbrev_all_tac>>fs[MAP_EQ_f])>> fs[] +QED val mem_store_perm = Q.prove(` mem_store a (w:'a word_loc) (s with permute:=perm) = @@ -1842,14 +1992,15 @@ val jump_exc_perm = Q.prove(` (*For any target result permute, we can find an initial permute such that the final permute is equal to the target *) -Theorem permute_swap_lemma ` - ∀prog st perm. +Theorem permute_swap_lemma: + ∀prog st perm. let (res,rst) = evaluate(prog,st) in res ≠ SOME Error (*Note: actually provable without this assum, but this is simpler*) ⇒ ∃perm'. evaluate(prog,st with permute := perm') = - (res,rst with permute:=perm)` - (ho_match_mp_tac (evaluate_ind |> Q.SPEC`UNCURRY P` |> SIMP_RULE (srw_ss())[] |> Q.GEN`P`) >> srw_tac[][]>>full_simp_tac(srw_ss())[evaluate_def] + (res,rst with permute:=perm) +Proof + ho_match_mp_tac (evaluate_ind |> Q.SPEC`UNCURRY P` |> SIMP_RULE (srw_ss())[] |> Q.GEN`P`) >> srw_tac[][]>>full_simp_tac(srw_ss())[evaluate_def] >- metis_tac[ignore_perm] >- @@ -2003,132 +2154,158 @@ Theorem permute_swap_lemma ` perm_assum_tac>> Cases_on`handler`>>TRY(PairCases_on`x''`)>> full_simp_tac(srw_ss())[push_env_def,env_to_list_def,LET_THM,dec_clock_def]>> - qpat_x_assum`A=res` (SUBST1_TAC o SYM)>>full_simp_tac(srw_ss())[])); + qpat_x_assum`A=res` (SUBST1_TAC o SYM)>>full_simp_tac(srw_ss())[]) +QED (*Monotonicity*) -Theorem every_var_inst_mono ` - ∀P inst Q. +Theorem every_var_inst_mono: + ∀P inst Q. (∀x. P x ⇒ Q x) ∧ every_var_inst P inst ⇒ - every_var_inst Q inst` - (ho_match_mp_tac every_var_inst_ind>>srw_tac[][every_var_inst_def]>> - Cases_on`ri`>>full_simp_tac(srw_ss())[every_var_imm_def]); - -Theorem every_var_exp_mono ` - ∀P exp Q. + every_var_inst Q inst +Proof + ho_match_mp_tac every_var_inst_ind>>srw_tac[][every_var_inst_def]>> + Cases_on`ri`>>full_simp_tac(srw_ss())[every_var_imm_def] +QED + +Theorem every_var_exp_mono: + ∀P exp Q. (∀x. P x ⇒ Q x) ∧ every_var_exp P exp ⇒ - every_var_exp Q exp` - (ho_match_mp_tac every_var_exp_ind>>srw_tac[][every_var_exp_def]>> - full_simp_tac(srw_ss())[EVERY_MEM]); - -Theorem every_name_mono ` - ∀P names Q. + every_var_exp Q exp +Proof + ho_match_mp_tac every_var_exp_ind>>srw_tac[][every_var_exp_def]>> + full_simp_tac(srw_ss())[EVERY_MEM] +QED + +Theorem every_name_mono: + ∀P names Q. (∀x. P x ⇒ Q x) ∧ - every_name P names ⇒ every_name Q names` - (srw_tac[][every_name_def]>> - metis_tac[EVERY_MONOTONIC]); - -Theorem every_var_mono ` - ∀P prog Q. + every_name P names ⇒ every_name Q names +Proof + srw_tac[][every_name_def]>> + metis_tac[EVERY_MONOTONIC] +QED + +Theorem every_var_mono: + ∀P prog Q. (∀x. P x ⇒ Q x) ∧ every_var P prog ⇒ - every_var Q prog` - (ho_match_mp_tac every_var_ind>>srw_tac[][every_var_def]>> + every_var Q prog +Proof + ho_match_mp_tac every_var_ind>>srw_tac[][every_var_def]>> TRY(Cases_on`ret`>>full_simp_tac(srw_ss())[]>>PairCases_on`x`>>Cases_on`h`>>full_simp_tac(srw_ss())[]>>TRY(Cases_on`x`)>>full_simp_tac(srw_ss())[])>> TRY(Cases_on`r`>>full_simp_tac(srw_ss())[])>> TRY(Cases_on`ri`>>full_simp_tac(srw_ss())[every_var_imm_def])>> - metis_tac[EVERY_MONOTONIC,every_var_inst_mono,every_var_exp_mono,every_name_mono]); + metis_tac[EVERY_MONOTONIC,every_var_inst_mono,every_var_exp_mono,every_name_mono] +QED (*Conjunct*) -Theorem every_var_inst_conj ` - ∀P inst Q. +Theorem every_var_inst_conj: + ∀P inst Q. every_var_inst P inst ∧ every_var_inst Q inst ⇔ - every_var_inst (λx. P x ∧ Q x) inst` - (ho_match_mp_tac every_var_inst_ind>>srw_tac[][every_var_inst_def]>> + every_var_inst (λx. P x ∧ Q x) inst +Proof + ho_match_mp_tac every_var_inst_ind>>srw_tac[][every_var_inst_def]>> TRY(Cases_on`ri`>>full_simp_tac(srw_ss())[every_var_imm_def])>> - metis_tac[]); + metis_tac[] +QED -Theorem every_var_exp_conj ` - ∀P exp Q. +Theorem every_var_exp_conj: + ∀P exp Q. every_var_exp P exp ∧ every_var_exp Q exp ⇔ - every_var_exp (λx. P x ∧ Q x) exp` - (ho_match_mp_tac every_var_exp_ind>>srw_tac[][every_var_exp_def]>> + every_var_exp (λx. P x ∧ Q x) exp +Proof + ho_match_mp_tac every_var_exp_ind>>srw_tac[][every_var_exp_def]>> full_simp_tac(srw_ss())[EVERY_MEM]>> - metis_tac[]); + metis_tac[] +QED -Theorem every_name_conj ` - ∀P names Q. +Theorem every_name_conj: + ∀P names Q. every_name P names ∧ every_name Q names ⇔ - every_name (λx. P x ∧ Q x) names` - (srw_tac[][every_name_def]>> - metis_tac[EVERY_CONJ]); - -Theorem every_var_conj ` - ∀P prog Q. + every_name (λx. P x ∧ Q x) names +Proof + srw_tac[][every_name_def]>> + metis_tac[EVERY_CONJ] +QED + +Theorem every_var_conj: + ∀P prog Q. every_var P prog ∧ every_var Q prog ⇔ - every_var (λx. P x ∧ Q x) prog` - (ho_match_mp_tac every_var_ind>>srw_tac[][every_var_def]>> + every_var (λx. P x ∧ Q x) prog +Proof + ho_match_mp_tac every_var_ind>>srw_tac[][every_var_def]>> TRY(Cases_on`ret`>>full_simp_tac(srw_ss())[])>> TRY(PairCases_on`x`>>Cases_on`h`>>full_simp_tac(srw_ss())[])>> TRY(Cases_on`x`>>full_simp_tac(srw_ss())[])>> TRY(Cases_on`r`>>full_simp_tac(srw_ss())[])>> TRY(Cases_on`ri`>>full_simp_tac(srw_ss())[every_var_imm_def])>> - TRY(metis_tac[EVERY_CONJ,every_var_inst_conj,every_var_exp_conj,every_name_conj])); + TRY(metis_tac[EVERY_CONJ,every_var_inst_conj,every_var_exp_conj,every_name_conj]) +QED (*Similar lemmas about every_stack_var*) -Theorem every_var_imp_every_stack_var ` - ∀P prog. - every_var P prog ⇒ every_stack_var P prog` - (ho_match_mp_tac every_stack_var_ind>> +Theorem every_var_imp_every_stack_var: + ∀P prog. + every_var P prog ⇒ every_stack_var P prog +Proof + ho_match_mp_tac every_stack_var_ind>> srw_tac[][every_stack_var_def,every_var_def]>> Cases_on`ret`>> Cases_on`h`>>full_simp_tac(srw_ss())[]>> PairCases_on`x`>>full_simp_tac(srw_ss())[]>> - Cases_on`x'`>>Cases_on`r`>>full_simp_tac(srw_ss())[]); + Cases_on`x'`>>Cases_on`r`>>full_simp_tac(srw_ss())[] +QED -Theorem every_stack_var_mono ` - ∀P prog Q. +Theorem every_stack_var_mono: + ∀P prog Q. (∀x. P x ⇒ Q x) ∧ every_stack_var P prog ⇒ - every_stack_var Q prog` - (ho_match_mp_tac every_stack_var_ind>>srw_tac[][every_stack_var_def]>> + every_stack_var Q prog +Proof + ho_match_mp_tac every_stack_var_ind>>srw_tac[][every_stack_var_def]>> TRY(Cases_on`ret`>>full_simp_tac(srw_ss())[]>>PairCases_on`x`>>Cases_on`h`>>full_simp_tac(srw_ss())[]>>TRY(Cases_on`x`>>Cases_on`r`>>full_simp_tac(srw_ss())[]))>> - metis_tac[every_name_mono]); + metis_tac[every_name_mono] +QED -Theorem every_stack_var_conj ` - ∀P prog Q. +Theorem every_stack_var_conj: + ∀P prog Q. every_stack_var P prog ∧ every_stack_var Q prog ⇔ - every_stack_var (λx. P x ∧ Q x) prog` - (ho_match_mp_tac every_stack_var_ind>>srw_tac[][every_stack_var_def]>> + every_stack_var (λx. P x ∧ Q x) prog +Proof + ho_match_mp_tac every_stack_var_ind>>srw_tac[][every_stack_var_def]>> TRY(Cases_on`ret`>>full_simp_tac(srw_ss())[])>> TRY(PairCases_on`x`>>Cases_on`h`>>full_simp_tac(srw_ss())[])>> TRY(Cases_on`x`>>Cases_on`r`>>full_simp_tac(srw_ss())[])>> - TRY(metis_tac[EVERY_CONJ,every_name_conj])); + TRY(metis_tac[EVERY_CONJ,every_name_conj]) +QED (* Locals extend lemma *) val locals_rel_def = Define` locals_rel temp (s:'a word_loc num_map) t ⇔ (∀x. x < temp ⇒ lookup x s = lookup x t)` -Theorem the_words_EVERY_IS_SOME - `∀ls x. +Theorem the_words_EVERY_IS_SOME: + ∀ls x. the_words ls = SOME x ⇒ - EVERY IS_SOME ls` - (Induct>>fs[]>>Cases>>fs[the_words_def]>> + EVERY IS_SOME ls +Proof + Induct>>fs[]>>Cases>>fs[the_words_def]>> TOP_CASE_TAC>>fs[]>> - TOP_CASE_TAC>>fs[]); + TOP_CASE_TAC>>fs[] +QED -Theorem locals_rel_word_exp ` - ∀s exp w. +Theorem locals_rel_word_exp: + ∀s exp w. every_var_exp (λx. x < temp) exp ∧ word_exp s exp = SOME w ∧ locals_rel temp s.locals loc ⇒ - word_exp (s with locals:=loc) exp = SOME w` - (ho_match_mp_tac word_exp_ind>>srw_tac[][]>> + word_exp (s with locals:=loc) exp = SOME w +Proof + ho_match_mp_tac word_exp_ind>>srw_tac[][]>> full_simp_tac(srw_ss())[word_exp_def,every_var_exp_def,locals_rel_def] >- (every_case_tac>> @@ -2148,44 +2325,53 @@ Theorem locals_rel_word_exp ` fs[IS_SOME_EXISTS])>> fs[]) >> - every_case_tac>>res_tac>>full_simp_tac(srw_ss())[]); + every_case_tac>>res_tac>>full_simp_tac(srw_ss())[] +QED -Theorem locals_rel_get_vars ` - ∀ls vs. +Theorem locals_rel_get_vars: + ∀ls vs. get_vars ls st = SOME vs ∧ EVERY (λx. x < temp) ls ∧ locals_rel temp st.locals loc ⇒ - get_vars ls (st with locals:= loc) = SOME vs` - (Induct>>full_simp_tac(srw_ss())[get_vars_def]>>srw_tac[][]>> + get_vars ls (st with locals:= loc) = SOME vs +Proof + Induct>>full_simp_tac(srw_ss())[get_vars_def]>>srw_tac[][]>> qpat_x_assum`A=SOME vs` mp_tac>>ntac 2 full_case_tac>>srw_tac[][]>> res_tac>>full_simp_tac(srw_ss())[get_var_def,locals_rel_def]>> res_tac>> - full_simp_tac(srw_ss())[]); + full_simp_tac(srw_ss())[] +QED -Theorem locals_rel_alist_insert ` - ∀ls vs s t. +Theorem locals_rel_alist_insert: + ∀ls vs s t. locals_rel temp s t ∧ EVERY (λx. x < temp) ls ⇒ - locals_rel temp (alist_insert ls vs s) (alist_insert ls vs t)` - (ho_match_mp_tac alist_insert_ind>>full_simp_tac(srw_ss())[alist_insert_def,locals_rel_def]>> + locals_rel temp (alist_insert ls vs s) (alist_insert ls vs t) +Proof + ho_match_mp_tac alist_insert_ind>>full_simp_tac(srw_ss())[alist_insert_def,locals_rel_def]>> srw_tac[][]>> - Cases_on`x'=ls`>>full_simp_tac(srw_ss())[lookup_insert]); + Cases_on`x'=ls`>>full_simp_tac(srw_ss())[lookup_insert] +QED -Theorem locals_rel_get_var ` - r < temp ∧ +Theorem locals_rel_get_var: + r < temp ∧ get_var r st = SOME x ∧ locals_rel temp st.locals loc ⇒ - get_var r (st with locals:=loc) = SOME x` - (full_simp_tac(srw_ss())[get_var_def,locals_rel_def]>> - metis_tac[]); - -Theorem locals_rel_get_var_imm ` - every_var_imm (λx.x> + metis_tac[] +QED + +Theorem locals_rel_get_var_imm: + every_var_imm (λx.x>full_simp_tac(srw_ss())[get_var_imm_def,every_var_imm_def]>> - metis_tac[locals_rel_get_var]); + get_var_imm r (st with locals:=loc) = SOME x +Proof + Cases_on`r`>>full_simp_tac(srw_ss())[get_var_imm_def,every_var_imm_def]>> + metis_tac[locals_rel_get_var] +QED val locals_rel_set_var = Q.prove(` ∀n s t. @@ -2211,8 +2397,8 @@ val locals_rel_cut_env = Q.prove(` val srestac = qpat_x_assum`A=res`sym_sub_tac>>full_simp_tac(srw_ss())[] -Theorem locals_rel_evaluate_thm ` - ∀prog st res rst loc temp. +Theorem locals_rel_evaluate_thm: + ∀prog st res rst loc temp. evaluate (prog,st) = (res,rst) ∧ res ≠ SOME Error ∧ every_var (λx.x < temp) prog ∧ @@ -2221,8 +2407,9 @@ Theorem locals_rel_evaluate_thm ` evaluate (prog,st with locals:=loc) = (res,rst with locals:=loc') ∧ case res of NONE => locals_rel temp rst.locals loc' - | SOME _ => rst.locals = loc'` - (completeInduct_on`prog_size (K 0) prog`>> + | SOME _ => rst.locals = loc' +Proof + completeInduct_on`prog_size (K 0) prog`>> rpt strip_tac>> Cases_on`prog`>> full_simp_tac(srw_ss())[evaluate_def,LET_THM] @@ -2423,7 +2610,8 @@ Theorem locals_rel_evaluate_thm ` full_case_tac>>full_simp_tac(srw_ss())[state_component_equality,locals_rel_def]>> full_case_tac>>full_simp_tac(srw_ss())[state_component_equality,locals_rel_def]>> fs[pairTheory.ELIM_UNCURRY] >> rpt strip_tac >> rveq >> fs[case_eq_thms] >> - rveq >> fs[case_eq_thms,state_component_equality])); + rveq >> fs[case_eq_thms,state_component_equality]) +QED val gc_fun_ok_def = Define ` gc_fun_ok (f:'a gc_fun_type) = @@ -2685,11 +2873,12 @@ val extract_labels_def = Define` (extract_labels e2 ++ extract_labels e3)) ∧ (extract_labels _ = [])` -Theorem env_to_list_lookup_equiv - `env_to_list y f = (q,r) ==> +Theorem env_to_list_lookup_equiv: + env_to_list y f = (q,r) ==> (!n. ALOOKUP q n = lookup n y) /\ - (!x1 x2. MEM (x1,x2) q ==> lookup x1 y = SOME x2)` - (full_simp_tac(srw_ss())[wordSemTheory.env_to_list_def,LET_DEF] \\ srw_tac[][] + (!x1 x2. MEM (x1,x2) q ==> lookup x1 y = SOME x2) +Proof + full_simp_tac(srw_ss())[wordSemTheory.env_to_list_def,LET_DEF] \\ srw_tac[][] \\ `ALL_DISTINCT (MAP FST (toAList y))` by full_simp_tac(srw_ss())[ALL_DISTINCT_MAP_FST_toAList] \\ imp_res_tac (MATCH_MP PERM_ALL_DISTINCT_MAP (QSORT_PERM |> Q.ISPEC `key_val_compare` |> SPEC_ALL)) @@ -2710,7 +2899,8 @@ Theorem env_to_list_lookup_equiv \\ `~MEM n (MAP FST xs)` by rev_full_simp_tac(srw_ss())[MEM_MAP,FORALL_PROD] \\ full_simp_tac(srw_ss())[GSYM ALOOKUP_NONE] \\ UNABBREV_ALL_TAC \\ full_simp_tac(srw_ss())[] \\ rev_full_simp_tac(srw_ss())[MEM_toAList] - \\ Cases_on `lookup n y` \\ full_simp_tac(srw_ss())[]); + \\ Cases_on `lookup n y` \\ full_simp_tac(srw_ss())[] +QED val max_var_exp_IMP = Q.prove(` ∀exp. @@ -2721,11 +2911,12 @@ val max_var_exp_IMP = Q.prove(` match_mp_tac list_max_intro>> full_simp_tac(srw_ss())[EVERY_MAP,EVERY_MEM]); -Theorem max_var_intro ` - ∀prog. +Theorem max_var_intro: + ∀prog. P 0 ∧ every_var P prog ⇒ - P (max_var prog)` - (ho_match_mp_tac max_var_ind>> + P (max_var prog) +Proof + ho_match_mp_tac max_var_ind>> full_simp_tac(srw_ss())[every_var_def,max_var_def,max_var_exp_IMP,MAX_DEF]>>srw_tac[][]>> TRY(metis_tac[max_var_exp_IMP])>> TRY (match_mp_tac list_max_intro>>full_simp_tac(srw_ss())[EVERY_APPEND,every_name_def]) @@ -2738,7 +2929,8 @@ Theorem max_var_intro ` (TOP_CASE_TAC>>unabbrev_all_tac>>full_simp_tac(srw_ss())[list_max_intro]>> EVERY_CASE_TAC>>full_simp_tac(srw_ss())[LET_THM]>>srw_tac[][]>> match_mp_tac list_max_intro>>full_simp_tac(srw_ss())[EVERY_APPEND,every_name_def]) - >> (unabbrev_all_tac>>EVERY_CASE_TAC>>full_simp_tac(srw_ss())[every_var_imm_def])); + >> (unabbrev_all_tac>>EVERY_CASE_TAC>>full_simp_tac(srw_ss())[every_var_imm_def]) +QED val get_code_labels_def = Define` (get_code_labels (Call r d a h) = diff --git a/compiler/backend/semantics/wordSemScript.sml b/compiler/backend/semantics/wordSemScript.sml index 1e185c8237..61361869a4 100644 --- a/compiler/backend/semantics/wordSemScript.sml +++ b/compiler/backend/semantics/wordSemScript.sml @@ -45,9 +45,11 @@ val theWord_def = Define ` val isWord_def = Define ` (isWord (Word w) = T) /\ (isWord _ = F)`; -Theorem isWord_exists - `isWord x ⇔ ∃w. x = Word w` - (Cases_on`x` \\ rw[isWord_def]); +Theorem isWord_exists: + isWord x ⇔ ∃w. x = Word w +Proof + Cases_on`x` \\ rw[isWord_def] +QED val mem_load_byte_aux_def = Define ` mem_load_byte_aux m dm be w = @@ -827,16 +829,19 @@ val evaluate_ind = theorem"evaluate_ind"; (* We prove that the clock never increases and that termdep is constant. *) -Theorem gc_clock - `!s1 s2. (gc s1 = SOME s2) ==> s2.clock <= s1.clock /\ s2.termdep = s1.termdep` - (full_simp_tac(srw_ss())[gc_def,LET_DEF] \\ SRW_TAC [] [] +Theorem gc_clock: + !s1 s2. (gc s1 = SOME s2) ==> s2.clock <= s1.clock /\ s2.termdep = s1.termdep +Proof + full_simp_tac(srw_ss())[gc_def,LET_DEF] \\ SRW_TAC [] [] \\ every_case_tac >> full_simp_tac(srw_ss())[] - \\ SRW_TAC [] [] \\ full_simp_tac(srw_ss())[]); - -Theorem alloc_clock - `!xs s1 vs s2. (alloc x names s1 = (vs,s2)) ==> - s2.clock <= s1.clock /\ s2.termdep = s1.termdep` - (SIMP_TAC std_ss [alloc_def] \\ rpt gen_tac + \\ SRW_TAC [] [] \\ full_simp_tac(srw_ss())[] +QED + +Theorem alloc_clock: + !xs s1 vs s2. (alloc x names s1 = (vs,s2)) ==> + s2.clock <= s1.clock /\ s2.termdep = s1.termdep +Proof + SIMP_TAC std_ss [alloc_def] \\ rpt gen_tac \\ rpt (BasicProvers.TOP_CASE_TAC \\ full_simp_tac(srw_ss())[]) \\ imp_res_tac gc_clock \\ rpt (disch_then strip_assume_tac) @@ -844,7 +849,8 @@ Theorem alloc_clock \\ full_simp_tac(srw_ss())[push_env_def,set_store_def,call_env_def,LET_THM,pop_env_def] \\ rpt (pairarg_tac \\ full_simp_tac(srw_ss())[]) \\ every_case_tac \\ full_simp_tac(srw_ss())[] - \\ rpt var_eq_tac \\ full_simp_tac(srw_ss())[]); + \\ rpt var_eq_tac \\ full_simp_tac(srw_ss())[] +QED val inst_clock = Q.prove( `inst i s = SOME s2 ==> s2.clock <= s.clock /\ s2.termdep = s.termdep`, @@ -854,10 +860,11 @@ val inst_clock = Q.prove( \\ full_simp_tac(srw_ss())[mem_store_def] \\ SRW_TAC [] [] \\ EVAL_TAC \\ fs[]); -Theorem evaluate_clock - `!xs s1 vs s2. (evaluate (xs,s1) = (vs,s2)) ==> - s2.clock <= s1.clock /\ s2.termdep = s1.termdep` - (recInduct evaluate_ind \\ REPEAT STRIP_TAC +Theorem evaluate_clock: + !xs s1 vs s2. (evaluate (xs,s1) = (vs,s2)) ==> + s2.clock <= s1.clock /\ s2.termdep = s1.termdep +Proof + recInduct evaluate_ind \\ REPEAT STRIP_TAC \\ POP_ASSUM MP_TAC \\ ONCE_REWRITE_TAC [evaluate_def] \\ rpt (disch_then strip_assume_tac) \\ full_simp_tac(srw_ss())[] \\ rpt var_eq_tac \\ full_simp_tac(srw_ss())[] @@ -881,7 +888,8 @@ Theorem evaluate_clock \\ TRY (PairCases_on `x''`) \\ full_simp_tac(srw_ss())[push_env_def,LET_THM] \\ rpt (pairarg_tac \\ full_simp_tac(srw_ss())[]) - \\ decide_tac); + \\ decide_tac +QED val fix_clock_evaluate = Q.prove( `fix_clock s (evaluate (c1,s)) = evaluate (c1,s)`, diff --git a/compiler/backend/source_to_flatScript.sml b/compiler/backend/source_to_flatScript.sml index 6858fad3df..ca9e20512b 100644 --- a/compiler/backend/source_to_flatScript.sml +++ b/compiler/backend/source_to_flatScript.sml @@ -180,46 +180,54 @@ val compile_exp_def = tDefine"compile_exp"` (* * EXPLORER: Again, the `t` is for position information. *) -Theorem compile_exps_append - `!env es es'. +Theorem compile_exps_append: + !env es es'. compile_exps t env (es ++ es') = - compile_exps t env es ++ compile_exps t env es'` - (Induct_on `es` >> - fs [compile_exp_def]); + compile_exps t env es ++ compile_exps t env es' +Proof + Induct_on `es` >> + fs [compile_exp_def] +QED (* * EXPLORER: Again, the `t` is for position information. *) -Theorem compile_exps_reverse - `!env es. - compile_exps t env (REVERSE es) = REVERSE (compile_exps t env es)` - (Induct_on `es` >> - rw [compile_exp_def, compile_exps_append]); +Theorem compile_exps_reverse: + !env es. + compile_exps t env (REVERSE es) = REVERSE (compile_exps t env es) +Proof + Induct_on `es` >> + rw [compile_exp_def, compile_exps_append] +QED (* * EXPLORER: Again, the `t` is for position information. *) -Theorem compile_funs_map - `!env funs. +Theorem compile_funs_map: + !env funs. compile_funs t env funs = - MAP (\(f,x,e). (f,x,compile_exp t (env with v := nsBind x (Var_local t x) env.v) e)) funs` - (induct_on `funs` >> + MAP (\(f,x,e). (f,x,compile_exp t (env with v := nsBind x (Var_local t x) env.v) e)) funs +Proof + induct_on `funs` >> rw [compile_exp_def] >> PairCases_on `h` >> - rw [compile_exp_def]); + rw [compile_exp_def] +QED (* * EXPLORER: Again, the `t` is for position information. *) -Theorem compile_funs_dom - `!funs. +Theorem compile_funs_dom: + !funs. (MAP (λ(x,y,z). x) funs) = - (MAP (λ(x,y,z). x) (compile_funs t env funs))` - (induct_on `funs` >> + (MAP (λ(x,y,z). x) (compile_funs t env funs)) +Proof + induct_on `funs` >> rw [compile_exp_def] >> PairCases_on `h` >> - rw [compile_exp_def]); + rw [compile_exp_def] +QED (* We use om_tra as a basis trace for all orphan traces created here. *) val om_tra_def = Define` @@ -230,15 +238,19 @@ val alloc_defs_def = Define ` (alloc_defs n next (x::xs) = (x, App (Cons om_tra n) (GlobalVarLookup next) []) :: alloc_defs (n + 1) (next + 1) xs)`; -Theorem fst_alloc_defs - `!n next l. MAP FST (alloc_defs n next l) = l` - (induct_on `l` >> - rw [alloc_defs_def]); - -Theorem alloc_defs_append - `!m n l1 l2. alloc_defs m n (l1++l2) = alloc_defs m n l1 ++ alloc_defs (m + LENGTH l1) (n + LENGTH l1) l2` - (induct_on `l1` >> - srw_tac [ARITH_ss] [alloc_defs_def, arithmeticTheory.ADD1]); +Theorem fst_alloc_defs: + !n next l. MAP FST (alloc_defs n next l) = l +Proof + induct_on `l` >> + rw [alloc_defs_def] +QED + +Theorem alloc_defs_append: + !m n l1 l2. alloc_defs m n (l1++l2) = alloc_defs m n l1 ++ alloc_defs (m + LENGTH l1) (n + LENGTH l1) l2 +Proof + induct_on `l1` >> + srw_tac [ARITH_ss] [alloc_defs_def, arithmeticTheory.ADD1] +QED val make_varls_def = Define` (make_varls n t idx [] = Con t NONE []) ∧ diff --git a/compiler/backend/stack_removeScript.sml b/compiler/backend/stack_removeScript.sml index cc73fdbf77..51bba6c582 100644 --- a/compiler/backend/stack_removeScript.sml +++ b/compiler/backend/stack_removeScript.sml @@ -272,10 +272,12 @@ val init_stubs_def = Define ` (1n,halt_inst 0w); (2n,halt_inst 2w)]` -Theorem check_init_stubs_length - `LENGTH (init_stubs gen_gc max_heap k start) + 1 (* gc *) = - stack_num_stubs` - (EVAL_TAC); +Theorem check_init_stubs_length: + LENGTH (init_stubs gen_gc max_heap k start) + 1 (* gc *) = + stack_num_stubs +Proof + EVAL_TAC +QED (* -- full compiler -- *) diff --git a/compiler/backend/wordLangScript.sml b/compiler/backend/wordLangScript.sml index df514b6df7..d5924362f7 100644 --- a/compiler/backend/wordLangScript.sml +++ b/compiler/backend/wordLangScript.sml @@ -17,11 +17,13 @@ val _ = Datatype ` | Op binop (exp list) | Shift shift exp num` -Theorem MEM_IMP_exp_size - `!xs a. MEM a xs ==> (exp_size l a < exp1_size l xs)` - (Induct \\ FULL_SIMP_TAC (srw_ss()) [] +Theorem MEM_IMP_exp_size: + !xs a. MEM a xs ==> (exp_size l a < exp1_size l xs) +Proof + Induct \\ FULL_SIMP_TAC (srw_ss()) [] \\ REPEAT STRIP_TAC \\ SRW_TAC [] [definition"exp_size_def"] - \\ RES_TAC \\ DECIDE_TAC); + \\ RES_TAC \\ DECIDE_TAC +QED val _ = Datatype ` prog = Skip diff --git a/compiler/backend/word_allocScript.sml b/compiler/backend/word_allocScript.sml index 2a09807dbd..3283212ba8 100644 --- a/compiler/backend/word_allocScript.sml +++ b/compiler/backend/word_allocScript.sml @@ -735,7 +735,8 @@ val get_writes_def = Define` (get_writes (Install r1 _ _ _ _) = insert r1 () LN) ∧ (get_writes prog = LN)` -Theorem get_writes_pmatch `!inst. +Theorem get_writes_pmatch: + !inst. get_writes inst = case inst of | Move pri ls => numset_list_insert (MAP FST ls) LN @@ -744,10 +745,12 @@ Theorem get_writes_pmatch `!inst. | Get num store => insert num () LN | LocValue r l1 => insert r () LN | Install r1 _ _ _ _ => insert r1 () LN - | prog => LN` - (rpt strip_tac + | prog => LN +Proof + rpt strip_tac >> CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) - >> every_case_tac >> fs[get_writes_def]) + >> every_case_tac >> fs[get_writes_def] +QED (* Old representation *) val get_clash_sets_def = Define` @@ -894,7 +897,8 @@ val get_prefs_def = Define` | SOME (v,prog,l1,l2) => get_prefs prog (get_prefs ret_handler acc)) ∧ (get_prefs prog acc = acc)` -Theorem get_prefs_pmatch `!s acc. +Theorem get_prefs_pmatch: + !s acc. get_prefs s acc = case s of | (Move pri ls) => (MAP (λx,y. (pri,x,y)) ls) ++ acc @@ -908,8 +912,9 @@ Theorem get_prefs_pmatch `!s acc. get_prefs ret_handler acc | (Call (SOME (v,cutset,ret_handler,l1,l2)) dest args (SOME (_,prog,_,_))) => get_prefs prog (get_prefs ret_handler acc) - | prog => acc` - (rpt strip_tac + | prog => acc +Proof + rpt strip_tac >> CONV_TAC(patternMatchesLib.PMATCH_LIFT_BOOL_CONV true) >> rpt strip_tac >> every_case_tac @@ -918,7 +923,8 @@ Theorem get_prefs_pmatch `!s acc. >> Q.SPEC_TAC (`acc`,`acc`) >> Q.SPEC_TAC (`s`,`s`) >> ho_match_mp_tac (theorem "get_prefs_ind") >> rpt strip_tac >> fs[Once get_prefs_def] - >> every_case_tac >> metis_tac[pair_CASES])); + >> every_case_tac >> metis_tac[pair_CASES]) +QED (* For each var, we collect 5 tuples indicating the number of @@ -1152,7 +1158,8 @@ val get_forced_def = Define` | SOME (v,prog,l1,l2) => get_forced c prog (get_forced c ret_handler acc)) ∧ (get_forced c prog acc = acc)` -Theorem get_forced_pmatch `!c prog acc. +Theorem get_forced_pmatch: + !c prog acc. (get_forced (c:'a asm_config) prog acc = case prog of Inst(Arith (AddCarry r1 r2 r3 r4)) => @@ -1194,8 +1201,9 @@ Theorem get_forced_pmatch `!c prog acc. get_forced c ret_handler acc | Call (SOME (v,cutset,ret_handler,l1,l2)) dest args (SOME (_,prog,_,_)) => get_forced c prog (get_forced c ret_handler acc) - | _ => acc)` - (rpt strip_tac + | _ => acc) +Proof + rpt strip_tac >> CONV_TAC(patternMatchesLib.PMATCH_LIFT_BOOL_CONV true) >> rpt strip_tac >> every_case_tac @@ -1208,7 +1216,8 @@ Theorem get_forced_pmatch `!c prog acc. >> fs[get_forced_def] >> every_case_tac >> fs[] - >> metis_tac[pair_CASES]); + >> metis_tac[pair_CASES] +QED (*col is injective over every cut set*) val check_colouring_ok_alt_def = Define` diff --git a/compiler/backend/word_instScript.sml b/compiler/backend/word_instScript.sml index 1e5091b1bf..ca30f8715d 100644 --- a/compiler/backend/word_instScript.sml +++ b/compiler/backend/word_instScript.sml @@ -39,30 +39,36 @@ val convert_sub_def = Define` (convert_sub [x;Const w] = Op Add [x;Const (-w)]) ∧ (convert_sub ls = Op Sub ls)` -Theorem convert_sub_pmatch `!l. +Theorem convert_sub_pmatch: + !l. convert_sub l = case l of [Const w1;Const w2] => Const (w1 -w2) | [x;Const w] => Op Add [x;Const (-w)] - | ls => Op Sub ls` - (rpt strip_tac + | ls => Op Sub ls +Proof + rpt strip_tac >> CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac - >> fs[convert_sub_def]) + >> fs[convert_sub_def] +QED val op_consts_def = Define` (op_consts And = Const (~0w)) ∧ (op_consts _ = Const 0w)` -Theorem op_consts_pmatch `!op. +Theorem op_consts_pmatch: + !op. op_consts op = case op of And => Const (~0w) - | _ => Const 0w` - (rpt strip_tac + | _ => Const 0w +Proof + rpt strip_tac >> CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac - >> fs[op_consts_def]); + >> fs[op_consts_def] +QED val optimize_consts_def = Define` optimize_consts op ls = @@ -96,7 +102,8 @@ val pull_exp_def = tDefine "pull_exp"` \\ fs[exp_size_def,asmTheory.binop_size_def,astTheory.shift_size_def,store_name_size_def] \\ TRY (DECIDE_TAC)) -Theorem pull_exp_pmatch `!(exp:'a exp). +Theorem pull_exp_pmatch: + !(exp:'a exp). pull_exp exp = case exp of Op Sub ls => ( @@ -110,11 +117,13 @@ Theorem pull_exp_pmatch `!(exp:'a exp). optimize_consts op pull_ls) | Load exp => Load (pull_exp exp) | Shift sh exp nexp => Shift sh (pull_exp exp) nexp - | exp => exp` - (rpt strip_tac + | exp => exp +Proof + rpt strip_tac >> CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac - >> fs[pull_exp_def,ETA_THM]) + >> fs[pull_exp_def,ETA_THM] +QED (*Flatten list expressions to trees -- of the form: + @@ -141,7 +150,8 @@ val flatten_exp_def = tDefine "flatten_exp" ` (* -Theorem flatten_exp_pmatch `!exp. +Theorem flatten_exp_pmatch: + !exp. flatten_exp exp = case exp of (Op Sub exps) => Op Sub (MAP flatten_exp exps) @@ -150,11 +160,13 @@ Theorem flatten_exp_pmatch `!exp. | (Op op (x::xs)) => Op op [flatten_exp (Op op xs);flatten_exp x] | (Load exp) => Load (flatten_exp exp) | (Shift shift exp nexp) => Shift shift (flatten_exp exp) nexp - | exp => exp` - (rpt strip_tac + | exp => exp +Proof + rpt strip_tac >> CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac - >> fs[flatten_exp_def, ETA_THM])*) + >> fs[flatten_exp_def, ETA_THM] +QED*) (* val test = EVAL ``flatten_exp (pull_exp (Op Add [Const 1w;Const 2w; Const 3w; Op Add [Const 4w; Const 5w; Op Add[Const 6w; Const 7w];Op Xor[Const 1w;Var y;Var x]] ; Const (8w:8 word)]))`` @@ -229,7 +241,8 @@ val inst_select_exp_def = tDefine "inst_select_exp" ` \\ fs[exp_size_def] \\ TRY (DECIDE_TAC)) ; -Theorem inst_select_exp_pmatch `!c tar temp exp. +Theorem inst_select_exp_pmatch: + !c tar temp exp. inst_select_exp (c:'a asm_config) tar temp exp = case exp of Load(Op Add [exp';Const w]) => @@ -274,11 +287,13 @@ Theorem inst_select_exp_pmatch `!c tar temp exp. else Inst (Const tar 0w)) (*Make it total*) - | _ => Skip` - (rpt strip_tac + | _ => Skip +Proof + rpt strip_tac >> rpt(CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac >> PURE_ONCE_REWRITE_TAC[LET_DEF] >> BETA_TAC) - >> fs[inst_select_exp_def] >> metis_tac[DIMINDEX_GT_0, NOT_ZERO_LT_ZERO]); + >> fs[inst_select_exp_def] >> metis_tac[DIMINDEX_GT_0, NOT_ZERO_LT_ZERO] +QED (* @@ -340,7 +355,8 @@ val inst_select_def = Define` Call retsel dest args handlersel) ∧ (inst_select c temp prog = prog)` -Theorem inst_select_pmatch `!c temp prog. +Theorem inst_select_pmatch: + !c temp prog. inst_select c temp prog = case prog of | Assign v exp => @@ -387,12 +403,14 @@ Theorem inst_select_pmatch `!c temp prog. NONE => NONE | SOME (n,h,l1,l2) => SOME (n,inst_select c temp h,l1,l2) in Call retsel dest args handlersel) - | prog => prog` - (rpt( + | prog => prog +Proof + rpt( rpt strip_tac >> rpt(CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac >> PURE_ONCE_REWRITE_TAC[LET_DEF] >> BETA_TAC) - >> fs[inst_select_def])); + >> fs[inst_select_def]) +QED (* Convert all 3 register instructions to 2 register instructions @@ -427,7 +445,8 @@ val three_to_two_reg_def = Define` Call retsel dest args handlersel) ∧ (three_to_two_reg prog = prog)` -Theorem three_to_two_reg_pmatch `!prog. +Theorem three_to_two_reg_pmatch: + !prog. three_to_two_reg prog = case prog of | (Inst (Arith (Binop bop r1 r2 ri))) => @@ -457,11 +476,13 @@ Theorem three_to_two_reg_pmatch `!prog. NONE => NONE | SOME (n,h,l1,l2) => SOME (n,three_to_two_reg h,l1,l2) in Call retsel dest args handlersel) - | prog => prog` - (rpt( + | prog => prog +Proof + rpt( rpt strip_tac >> rpt(CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac >> PURE_ONCE_REWRITE_TAC[LET_DEF] >> BETA_TAC) - >> fs[three_to_two_reg_def])); + >> fs[three_to_two_reg_def]) +QED val _ = export_theory(); diff --git a/compiler/backend/word_removeScript.sml b/compiler/backend/word_removeScript.sml index 3db628a05a..ad0b60fac5 100644 --- a/compiler/backend/word_removeScript.sml +++ b/compiler/backend/word_removeScript.sml @@ -25,7 +25,8 @@ val remove_must_terminate_def = Define` Call ret dest args h) ∧ (remove_must_terminate prog = prog)` -Theorem remove_must_terminate_pmatch `!prog. +Theorem remove_must_terminate_pmatch: + !prog. remove_must_terminate prog = case prog of | (Seq p0 p1) => Seq (remove_must_terminate p0) (remove_must_terminate p1) @@ -39,10 +40,12 @@ Theorem remove_must_terminate_pmatch `!prog. let h = case h of NONE => NONE | SOME (v,prog,l1,l2) => SOME (v,remove_must_terminate prog,l1,l2) in Call ret dest args h) - | prog => prog` - (rpt( + | prog => prog +Proof + rpt( rpt strip_tac >> rpt(CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac >> PURE_ONCE_REWRITE_TAC[LET_DEF] >> BETA_TAC) - >> fs[remove_must_terminate_def])); + >> fs[remove_must_terminate_def]) +QED val _ = export_theory(); diff --git a/compiler/backend/word_simpScript.sml b/compiler/backend/word_simpScript.sml index d14cbf2ceb..cd0e2497a3 100644 --- a/compiler/backend/word_simpScript.sml +++ b/compiler/backend/word_simpScript.sml @@ -32,7 +32,8 @@ val Seq_assoc_def = Define ` | SOME (y1,q2,y2,y3) => SOME (y1,Seq_assoc Skip q2,y2,y3)))) /\ (Seq_assoc p1 other = SmartSeq p1 other)`; -Theorem Seq_assoc_pmatch `!p1 prog. +Theorem Seq_assoc_pmatch: + !p1 prog. Seq_assoc p1 prog = case prog of | Skip => p1 @@ -49,10 +50,12 @@ Theorem Seq_assoc_pmatch `!p1 prog. (dtcase handler of | NONE => NONE | SOME (y1,q2,y2,y3) => SOME (y1,Seq_assoc Skip q2,y2,y3))) - | other => SmartSeq p1 other` - (rpt strip_tac + | other => SmartSeq p1 other +Proof + rpt strip_tac >> CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac - >> fs[Seq_assoc_def]); + >> fs[Seq_assoc_def] +QED val Seq_assoc_ind = fetch "-" "Seq_assoc_ind"; @@ -73,29 +76,35 @@ val dest_Seq_def = Define ` (dest_Seq (Seq p1 p2) = (p1,p2:'a wordLang$prog)) /\ (dest_Seq p = (Skip,p))` -Theorem dest_Seq_pmatch `!p. +Theorem dest_Seq_pmatch: + !p. dest_Seq p = case p of Seq p1 p2 => (p1,p2:'a wordLang$prog) - | p => (Skip,p)` - (rpt strip_tac + | p => (Skip,p) +Proof + rpt strip_tac >> CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac - >> fs[dest_Seq_def]); + >> fs[dest_Seq_def] +QED val dest_If_def = Define ` (dest_If (If x1 x2 x3 p1 p2) = SOME (x1,x2,x3,p1,p2:'a wordLang$prog)) /\ (dest_If _ = NONE)` -Theorem dest_If_pmatch `!p. +Theorem dest_If_pmatch: + !p. dest_If p = case p of If x1 x2 x3 p1 p2 => SOME (x1,x2,x3,p1,p2:'a wordLang$prog) - | _ => NONE` - (rpt strip_tac + | _ => NONE +Proof + rpt strip_tac >> CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac - >> fs[dest_If_def]); + >> fs[dest_If_def] +QED val dest_If_Eq_Imm_def = Define ` dest_If_Eq_Imm p = @@ -103,15 +112,18 @@ val dest_If_Eq_Imm_def = Define ` | SOME (Equal,n,Imm w,p1,p2) => SOME (n,w,p1,p2) | _ => NONE` -Theorem dest_If_Eq_Imm_pmatch `!p. +Theorem dest_If_Eq_Imm_pmatch: + !p. dest_If_Eq_Imm p = case dest_If p of | SOME (Equal,n,Imm w,p1,p2) => SOME (n,w,p1,p2) - | _ => NONE` - (rpt strip_tac + | _ => NONE +Proof + rpt strip_tac >> CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac - >> fs[dest_If_Eq_Imm_def]); + >> fs[dest_If_Eq_Imm_def] +QED val dest_Seq_Assign_Const_def = Define ` dest_Seq_Assign_Const n p = @@ -120,19 +132,22 @@ val dest_Seq_Assign_Const_def = Define ` | Assign m (Const w) => if m = n then SOME (p1,w) else NONE | _ => NONE` -Theorem dest_Seq_Assign_Const_pmatch `!n p. +Theorem dest_Seq_Assign_Const_pmatch: + !n p. dest_Seq_Assign_Const n p = let (p1,p2) = dest_Seq p in case p2 of | Assign m (Const w) => if m = n then SOME (p1,w) else NONE - | _ => NONE` - (rpt strip_tac + | _ => NONE +Proof + rpt strip_tac >> Cases_on `dest_Seq p` >> PURE_REWRITE_TAC [LET_THM,pairTheory.UNCURRY_DEF] >> BETA_TAC >> CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac - >> fs[dest_Seq_Assign_Const_def]); + >> fs[dest_Seq_Assign_Const_def] +QED val apply_if_opt_def = Define ` apply_if_opt x1 x2 = @@ -176,7 +191,8 @@ val simp_if_def = tDefine "simp_if" ` (simp_if x = x)` (WF_REL_TAC `measure (wordLang$prog_size (K 0))` \\ rw []) -Theorem simp_if_pmatch `!prog. +Theorem simp_if_pmatch: + !prog. simp_if prog = case prog of | (Seq x1 x2) => @@ -195,12 +211,14 @@ Theorem simp_if_pmatch `!prog. (dtcase handler of | NONE => NONE | SOME (y1,q2,y2,y3) => SOME (y1,simp_if q2,y2,y3)) - | x => x` - (rpt( + | x => x +Proof + rpt( rpt strip_tac >> rpt(CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac >> PURE_ONCE_REWRITE_TAC[LET_DEF] >> BETA_TAC) - >> fs[simp_if_def])); + >> fs[simp_if_def]) +QED val simp_if_ind = fetch "-" "simp_if_ind" @@ -334,7 +352,8 @@ val const_fp_loop_def = Define ` (const_fp_loop (Install r1 r2 r3 r4 names) cs = (Install r1 r2 r3 r4 names, delete r1 (filter_v is_gc_const (inter cs names)))) /\ (const_fp_loop p cs = (p, cs))`; -Theorem const_fp_loop_pmatch `!p cs. +Theorem const_fp_loop_pmatch: + !p cs. const_fp_loop p cs = case p of | (Move pri moves) => (Move pri moves, const_fp_move_cs moves cs cs) @@ -372,8 +391,9 @@ Theorem const_fp_loop_pmatch `!p cs. | (LocValue v x3) => (LocValue v x3, delete v cs) | (Alloc n names) => (Alloc n names, filter_v is_gc_const (inter cs names)) | (Install r1 r2 r3 r4 names) => (Install r1 r2 r3 r4 names, delete r1 (filter_v is_gc_const (inter cs names))) - | p => (p, cs)` - (rpt strip_tac + | p => (p, cs) +Proof + rpt strip_tac >> CONV_TAC(patternMatchesLib.PMATCH_LIFT_BOOL_CONV true) >> rpt strip_tac >- fs[const_fp_loop_def,pairTheory.ELIM_UNCURRY] @@ -390,7 +410,8 @@ Theorem const_fp_loop_pmatch `!p cs. >- fs[const_fp_loop_def,pairTheory.ELIM_UNCURRY] >- fs[const_fp_loop_def,pairTheory.ELIM_UNCURRY] >- fs[const_fp_loop_def,pairTheory.ELIM_UNCURRY] - >> Cases_on `p` >> fs[const_fp_loop_def] >> every_case_tac >> fs[pairTheory.ELIM_UNCURRY]); + >> Cases_on `p` >> fs[const_fp_loop_def] >> every_case_tac >> fs[pairTheory.ELIM_UNCURRY] +QED val const_fp_loop_ind = fetch "-" "const_fp_loop_ind"; diff --git a/compiler/backend/word_to_wordScript.sml b/compiler/backend/word_to_wordScript.sml index 069355c635..f240ceb6cc 100644 --- a/compiler/backend/word_to_wordScript.sml +++ b/compiler/backend/word_to_wordScript.sml @@ -47,8 +47,8 @@ val compile_def = Define ` let progs = ZIP (progs,n_oracles) in (col,MAP (full_compile_single two_reg_arith reg_count word_conf.reg_alg asm_conf) progs)` -Theorem compile_alt ` - compile word_conf (asm_conf:'a asm_config) progs = +Theorem compile_alt: + compile word_conf (asm_conf:'a asm_config) progs = let (two_reg_arith,reg_count) = (asm_conf.two_reg_arith, asm_conf.reg_count - (5+LENGTH asm_conf.avoid_regs)) in let (n_oracles,col) = next_n_oracle (LENGTH progs) word_conf.col_oracle in let alg = word_conf.reg_alg in @@ -69,10 +69,12 @@ Theorem compile_alt ` let _ = empty_ffi (strlit "finished: word_alloc") in let rmt_ps = MAP remove_must_terminate reg_ps in let _ = empty_ffi (strlit "finished: word_remove") in - (col,ZIP(names,ZIP(args,rmt_ps)))` - (fs[compile_def,next_n_oracle_def,LIST_EQ_REWRITE]>> + (col,ZIP(names,ZIP(args,rmt_ps))) +Proof + fs[compile_def,next_n_oracle_def,LIST_EQ_REWRITE]>> rw[]>>fs[EL_MAP,full_compile_single_def,EL_ZIP,EL_MAP2]>> Cases_on`EL x progs`>>simp[]>> - Cases_on`r`>>simp[compile_single_def]); + Cases_on`r`>>simp[compile_single_def] +QED val _ = export_theory(); diff --git a/compiler/backend/x64/proofs/x64_configProofScript.sml b/compiler/backend/x64/proofs/x64_configProofScript.sml index 7eea8770a5..4fd436d6ac 100644 --- a/compiler/backend/x64/proofs/x64_configProofScript.sml +++ b/compiler/backend/x64/proofs/x64_configProofScript.sml @@ -22,9 +22,10 @@ val names_tac = \\ REWRITE_TAC[SUBSET_DEF] \\ EVAL_TAC \\ rpt strip_tac \\ rveq \\ EVAL_TAC -Theorem x64_backend_config_ok ` - backend_config_ok x64_backend_config` - (simp[backend_config_ok_def]>>rw[]>>TRY(EVAL_TAC>>NO_TAC) +Theorem x64_backend_config_ok: + backend_config_ok x64_backend_config +Proof + simp[backend_config_ok_def]>>rw[]>>TRY(EVAL_TAC>>NO_TAC) >- fs[x64_backend_config_def] >- (EVAL_TAC>> blastLib.FULL_BBLAST_TAC) >- names_tac @@ -38,11 +39,13 @@ Theorem x64_backend_config_ok ` \\ fs[stack_removeTheory.max_stack_alloc_def] \\ EVAL_TAC>>fs[] \\ match_mp_tac bitTheory.NOT_BIT_GT_TWOEXP - \\ fs[]) + \\ fs[] +QED -Theorem x64_machine_config_ok - `is_x64_machine_config mc ⇒ mc_conf_ok mc` - (rw[lab_to_targetProofTheory.mc_conf_ok_def,is_x64_machine_config_def] +Theorem x64_machine_config_ok: + is_x64_machine_config mc ⇒ mc_conf_ok mc +Proof + rw[lab_to_targetProofTheory.mc_conf_ok_def,is_x64_machine_config_def] >- EVAL_TAC >- simp[x64_targetProofTheory.x64_encoder_correct] >- EVAL_TAC @@ -50,14 +53,17 @@ Theorem x64_machine_config_ok >- EVAL_TAC >- EVAL_TAC >- EVAL_TAC - >- metis_tac[asmPropsTheory.encoder_correct_def,asmPropsTheory.target_ok_def,x64_encoder_correct]); + >- metis_tac[asmPropsTheory.encoder_correct_def,asmPropsTheory.target_ok_def,x64_encoder_correct] +QED -Theorem x64_init_ok - `is_x64_machine_config mc ⇒ - mc_init_ok x64_backend_config mc` - (rw[mc_init_ok_def] \\ +Theorem x64_init_ok: + is_x64_machine_config mc ⇒ + mc_init_ok x64_backend_config mc +Proof + rw[mc_init_ok_def] \\ fs[is_x64_machine_config_def] \\ - EVAL_TAC); + EVAL_TAC +QED val is_x64_machine_config_mc = x64_init_ok |> concl |> dest_imp |> #1 diff --git a/compiler/bootstrap/compilation/ag32/32/proofs/ag32BootstrapProofScript.sml b/compiler/bootstrap/compilation/ag32/32/proofs/ag32BootstrapProofScript.sml index 08bc2db3fd..a4f1afe38d 100644 --- a/compiler/bootstrap/compilation/ag32/32/proofs/ag32BootstrapProofScript.sml +++ b/compiler/bootstrap/compilation/ag32/32/proofs/ag32BootstrapProofScript.sml @@ -42,15 +42,16 @@ val LENGTH_data = val _ = overload_on("cake_machine_config", ``ag32_machine_config (THE config.ffi_names) (LENGTH code) (LENGTH data)``); -Theorem target_state_rel_cake_start_asm_state - `SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ +Theorem target_state_rel_cake_start_asm_state: + SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ LENGTH inp ≤ stdin_size ∧ is_ag32_init_state (init_memory code data (THE config.ffi_names) (cl,inp)) ms ⇒ ∃n. target_state_rel ag32_target (init_asm_state code data (THE config.ffi_names) (cl,inp)) (FUNPOW Next n ms) ∧ ((FUNPOW Next n ms).io_events = ms.io_events) ∧ (∀x. x ∉ (ag32_startup_addresses) ⇒ - ((FUNPOW Next n ms).MEM x = ms.MEM x))` - (strip_tac + ((FUNPOW Next n ms).MEM x = ms.MEM x)) +Proof + strip_tac \\ drule (GEN_ALL init_asm_state_RTC_asm_step) \\ disch_then drule \\ simp_tac std_ss [] @@ -62,7 +63,8 @@ Theorem target_state_rel_cake_start_asm_state \\ qmatch_goalsub_abbrev_tac`_ ∉ md` \\ disch_then(qspec_then`md`assume_tac) \\ drule (GEN_ALL RTC_asm_step_ag32_target_state_rel_io_events) - \\ simp[EVAL``(ag32_init_asm_state m md).mem_domain``]); + \\ simp[EVAL``(ag32_init_asm_state m md).mem_domain``] +QED val cake_startup_clock_def = new_specification("cake_startup_clock_def",["cake_startup_clock"], @@ -83,14 +85,15 @@ val compile_correct_applied = |> Q.GEN`cbspace` |> Q.SPEC`0` |> Q.GEN`data_sp` |> Q.SPEC`0` -Theorem cake_installed - `SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ +Theorem cake_installed: + SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ LENGTH inp ≤ stdin_size ∧ is_ag32_init_state (init_memory code data (THE config.ffi_names) (cl,inp)) ms0 ⇒ installed code 0 data 0 config.ffi_names (basis_ffi cl fs) (heap_regs ag32_backend_config.stack_conf.reg_names) - (cake_machine_config) (FUNPOW Next (cake_startup_clock ms0 inp cl) ms0)` - (rewrite_tac[ffi_names, THE_DEF] + (cake_machine_config) (FUNPOW Next (cake_startup_clock ms0 inp cl) ms0) +Proof + rewrite_tac[ffi_names, THE_DEF] \\ strip_tac \\ irule ag32_installed \\ drule cake_startup_clock_def @@ -102,7 +105,8 @@ Theorem cake_installed \\ conj_tac >- (simp[LENGTH_code] \\ EVAL_TAC) \\ conj_tac >- (simp[LENGTH_code, LENGTH_data] \\ EVAL_TAC) \\ conj_tac >- EVAL_TAC - \\ asm_exists_tac \\ simp[]); + \\ asm_exists_tac \\ simp[] +QED val cake_machine_sem = compile_correct_applied @@ -112,47 +116,58 @@ val cake_machine_sem = (* TODO: move *) -Theorem get_stdin_stdin_fs[simp] - `get_stdin (stdin_fs inp) = inp` - (EVAL_TAC +Theorem get_stdin_stdin_fs[simp]: + get_stdin (stdin_fs inp) = inp +Proof + EVAL_TAC \\ SELECT_ELIM_TAC - \\ simp[EXISTS_PROD, FORALL_PROD]); + \\ simp[EXISTS_PROD, FORALL_PROD] +QED -Theorem inFS_fname_fastForwardFD[simp] - `inFS_fname (fastForwardFD fs fd) fnm ⇔ inFS_fname fs fnm` - (rw[fsFFIPropsTheory.inFS_fname_def]); +Theorem inFS_fname_fastForwardFD[simp]: + inFS_fname (fastForwardFD fs fd) fnm ⇔ inFS_fname fs fnm +Proof + rw[fsFFIPropsTheory.inFS_fname_def] +QED -Theorem not_inFS_fname_stdin_fs[simp] - `∀nm. ¬ inFS_fname (stdin_fs inp) nm` - (rw[stdin_fs_def,fsFFIPropsTheory.inFS_fname_def]); +Theorem not_inFS_fname_stdin_fs[simp]: + ∀nm. ¬ inFS_fname (stdin_fs inp) nm +Proof + rw[stdin_fs_def,fsFFIPropsTheory.inFS_fname_def] +QED Theorem ALOOKUP_stdin_fs_File_NONE[simp]: ALOOKUP (stdin_fs inp).inode_tbl (File ino) = NONE Proof rw[stdin_fs_def] QED -Theorem ALOOKUP_fastForwardFD_infds_neq - `fd ≠ fd' ⇒ (ALOOKUP (fastForwardFD fs fd).infds fd' = ALOOKUP fs.infds fd')` - (rw[fsFFIPropsTheory.fastForwardFD_def] +Theorem ALOOKUP_fastForwardFD_infds_neq: + fd ≠ fd' ⇒ (ALOOKUP (fastForwardFD fs fd).infds fd' = ALOOKUP fs.infds fd') +Proof + rw[fsFFIPropsTheory.fastForwardFD_def] \\ Cases_on`ALOOKUP fs.infds fd` \\ simp[libTheory.the_def] \\ pairarg_tac \\ simp[] \\ Cases_on`ALOOKUP fs.inode_tbl ino` \\ simp[libTheory.the_def] \\ simp[AFUPDKEY_ALOOKUP] - \\ CASE_TAC); + \\ CASE_TAC +QED -Theorem FST_ALOOKUP_fastForwardFD_infds - `OPTION_MAP FST (ALOOKUP (fastForwardFD fs fd).infds fd') = OPTION_MAP FST (ALOOKUP fs.infds fd')` - (rw[fsFFIPropsTheory.fastForwardFD_def] +Theorem FST_ALOOKUP_fastForwardFD_infds: + OPTION_MAP FST (ALOOKUP (fastForwardFD fs fd).infds fd') = OPTION_MAP FST (ALOOKUP fs.infds fd') +Proof + rw[fsFFIPropsTheory.fastForwardFD_def] \\ Cases_on`ALOOKUP fs.infds fd` \\ simp[libTheory.the_def] \\ pairarg_tac \\ simp[] \\ Cases_on`ALOOKUP fs.inode_tbl ino` \\ simp[libTheory.the_def] \\ simp[AFUPDKEY_ALOOKUP] \\ CASE_TAC \\ simp[] - \\ CASE_TAC \\ simp[]); + \\ CASE_TAC \\ simp[] +QED -Theorem FST_ALOOKUP_add_stdo_infds - `OPTION_MAP FST (ALOOKUP (add_stdo fd nm fs out).infds fd') = OPTION_MAP FST (ALOOKUP fs.infds fd')` - (mp_tac TextIOProofTheory.add_stdo_MAP_FST_infds +Theorem FST_ALOOKUP_add_stdo_infds: + OPTION_MAP FST (ALOOKUP (add_stdo fd nm fs out).infds fd') = OPTION_MAP FST (ALOOKUP fs.infds fd') +Proof + mp_tac TextIOProofTheory.add_stdo_MAP_FST_infds \\ strip_tac \\ drule (GEN_ALL data_to_word_bignumProofTheory.MAP_FST_EQ_IMP_IS_SOME_ALOOKUP) \\ disch_then(qspec_then`fd'`mp_tac) @@ -162,15 +177,17 @@ Theorem FST_ALOOKUP_add_stdo_infds \\ pop_assum mp_tac \\ TOP_CASE_TAC \\ fs[] \\ TOP_CASE_TAC \\ fs[] \\ simp[AFUPDKEY_ALOOKUP] - \\ rw[] \\ Cases_on`x` \\ rw[]); + \\ rw[] \\ Cases_on`x` \\ rw[] +QED -Theorem ALOOKUP_add_stdout_inode_tbl - `STD_streams fs ⇒ ( +Theorem ALOOKUP_add_stdout_inode_tbl: + STD_streams fs ⇒ ( ALOOKUP (add_stdout fs out).inode_tbl fnm = if fnm = UStream(strlit"stdout") then SOME (THE (ALOOKUP fs.inode_tbl fnm) ++ explode out) - else ALOOKUP fs.inode_tbl fnm)` - (strip_tac + else ALOOKUP fs.inode_tbl fnm) +Proof + strip_tac \\ imp_res_tac TextIOProofTheory.STD_streams_stdout \\ simp[TextIOProofTheory.add_stdo_def] \\ SELECT_ELIM_TAC @@ -183,15 +200,17 @@ Theorem ALOOKUP_add_stdout_inode_tbl \\ simp[AFUPDKEY_ALOOKUP] \\ TOP_CASE_TAC \\ TOP_CASE_TAC - \\ fs[]); + \\ fs[] +QED -Theorem ALOOKUP_add_stderr_inode_tbl - `STD_streams fs ⇒ ( +Theorem ALOOKUP_add_stderr_inode_tbl: + STD_streams fs ⇒ ( ALOOKUP (add_stderr fs err).inode_tbl fnm = if fnm = UStream(strlit"stderr") then SOME (THE (ALOOKUP fs.inode_tbl fnm) ++ explode err) - else ALOOKUP fs.inode_tbl fnm)` - (strip_tac + else ALOOKUP fs.inode_tbl fnm) +Proof + strip_tac \\ imp_res_tac TextIOProofTheory.STD_streams_stderr \\ simp[TextIOProofTheory.add_stdo_def] \\ SELECT_ELIM_TAC @@ -204,15 +223,17 @@ Theorem ALOOKUP_add_stderr_inode_tbl \\ simp[AFUPDKEY_ALOOKUP] \\ TOP_CASE_TAC \\ TOP_CASE_TAC - \\ fs[]); + \\ fs[] +QED -Theorem ALOOKUP_add_stdout_infds - `STD_streams fs ⇒ ( +Theorem ALOOKUP_add_stdout_infds: + STD_streams fs ⇒ ( ALOOKUP (add_stdout fs out).infds fd = if fd = 1 then SOME ((I ## I ## ((+) (strlen out))) (THE (ALOOKUP fs.infds fd))) - else ALOOKUP fs.infds fd)` - (strip_tac + else ALOOKUP fs.infds fd) +Proof + strip_tac \\ imp_res_tac TextIOProofTheory.STD_streams_stdout \\ simp[TextIOProofTheory.add_stdo_def] \\ SELECT_ELIM_TAC @@ -226,15 +247,17 @@ Theorem ALOOKUP_add_stdout_infds \\ TOP_CASE_TAC \\ rw[] >- ( strip_tac \\ fs[] ) \\ PairCases_on`x` - \\ fs[]); + \\ fs[] +QED -Theorem ALOOKUP_add_stderr_infds - `STD_streams fs ⇒ ( +Theorem ALOOKUP_add_stderr_infds: + STD_streams fs ⇒ ( ALOOKUP (add_stderr fs err).infds fd = if fd = 2 then SOME ((I ## I ## ((+) (strlen err))) (THE (ALOOKUP fs.infds fd))) - else ALOOKUP fs.infds fd)` - (strip_tac + else ALOOKUP fs.infds fd) +Proof + strip_tac \\ imp_res_tac TextIOProofTheory.STD_streams_stderr \\ simp[TextIOProofTheory.add_stdo_def] \\ SELECT_ELIM_TAC @@ -248,12 +271,13 @@ Theorem ALOOKUP_add_stderr_infds \\ TOP_CASE_TAC \\ rw[] >- ( strip_tac \\ fs[] ) \\ PairCases_on`x` - \\ fs[]); + \\ fs[] +QED (* -- *) -Theorem cake_extract_writes - `wfcl cl ⇒ +Theorem cake_extract_writes: + wfcl cl ⇒ let events = MAP get_output_io_event (cake_io_events cl (stdin_fs inp)) in let out = extract_writes 1 events in let err = extract_writes 2 events in @@ -262,8 +286,9 @@ Theorem cake_extract_writes else let (cout, cerr) = compile_32 (TL cl) inp in (out = explode (concat (append cout))) ∧ - (err = explode cerr)` - (strip_tac + (err = explode cerr) +Proof + strip_tac \\ drule(GEN_ALL(DISCH_ALL cake_output)) \\ disch_then(qspec_then`stdin_fs inp`mp_tac) \\ simp[wfFS_stdin_fs, STD_streams_stdin_fs] @@ -416,10 +441,11 @@ Theorem cake_extract_writes \\ simp[STD_streams_stdin_fs] \\ DEP_REWRITE_TAC[ALOOKUP_add_stdout_infds] \\ simp[STD_streams_stdin_fs] - \\ simp[stdin_fs_def]) + \\ simp[stdin_fs_def] +QED -Theorem cake_ag32_next - `SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ wfcl cl ∧ +Theorem cake_ag32_next: + SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ wfcl cl ∧ LENGTH inp ≤ stdin_size ∧ is_ag32_init_state (init_memory code data (THE config.ffi_names) (cl,inp)) ms0 ⇒ @@ -430,8 +456,9 @@ Theorem cake_ag32_next (get_mem_word ms.MEM ms.PC = Encode (Jump (fAdd,0w,Imm 0w))) ∧ outs ≼ MAP get_output_io_event (cake_io_events cl (stdin_fs inp)) ∧ ((ms.R (n2w (cake_machine_config).ptr_reg) = 0w) ⇒ - (outs = MAP get_output_io_event (cake_io_events cl (stdin_fs inp))))` - (strip_tac + (outs = MAP get_output_io_event (cake_io_events cl (stdin_fs inp)))) +Proof + strip_tac \\ drule (GEN_ALL cake_machine_sem) \\ disch_then drule \\ disch_then drule @@ -453,6 +480,7 @@ Theorem cake_ag32_next \\ strip_tac \\ goal_assum(first_assum o mp_then Any mp_tac) \\ goal_assum(first_assum o mp_then Any mp_tac) - \\ metis_tac[]); + \\ metis_tac[] +QED val _ = export_theory(); diff --git a/compiler/bootstrap/translation/compiler32ProgScript.sml b/compiler/bootstrap/translation/compiler32ProgScript.sml index 83de0653b6..7b3104051d 100644 --- a/compiler/bootstrap/translation/compiler32ProgScript.sml +++ b/compiler/bootstrap/translation/compiler32ProgScript.sml @@ -29,9 +29,11 @@ val max_heap_limit_32_def = Define` val res = translate max_heap_limit_32_def -Theorem max_heap_limit_32_thm - `max_heap_limit (:32) = max_heap_limit_32` - (rw[FUN_EQ_THM] \\ EVAL_TAC); +Theorem max_heap_limit_32_thm: + max_heap_limit (:32) = max_heap_limit_32 +Proof + rw[FUN_EQ_THM] \\ EVAL_TAC +QED (* @@ -233,14 +235,15 @@ val res = append_prog main; val st = get_ml_prog_state() -Theorem main_spec - `app (p:'ffi ffi_proj) ^(fetch_v "main" st) +Theorem main_spec: + app (p:'ffi ffi_proj) ^(fetch_v "main" st) [Conv NONE []] (STDIO fs * COMMANDLINE cl) (POSTv uv. &UNIT_TYPE () uv * STDIO (full_compile_32 (TL cl) (get_stdin fs) fs) - * COMMANDLINE cl)` - (xcf "main" st + * COMMANDLINE cl) +Proof + xcf "main" st \\ xlet_auto >- (xcon \\ xsimpl) \\ xlet_auto >- ( @@ -296,12 +299,14 @@ Theorem main_spec \\ asm_exists_tac \\ xsimpl \\ qexists_tac `fs'` \\ xsimpl) \\ xapp - \\ asm_exists_tac \\ simp [] \\ xsimpl); - -Theorem main_whole_prog_spec - `whole_prog_spec ^(fetch_v "main" st) cl fs NONE - ((=) (full_compile_32 (TL cl) (get_stdin fs) fs))` - (simp[whole_prog_spec_def,UNCURRY] + \\ asm_exists_tac \\ simp [] \\ xsimpl +QED + +Theorem main_whole_prog_spec: + whole_prog_spec ^(fetch_v "main" st) cl fs NONE + ((=) (full_compile_32 (TL cl) (get_stdin fs) fs)) +Proof + simp[whole_prog_spec_def,UNCURRY] \\ qmatch_goalsub_abbrev_tac`fs1 = _ with numchars := _` \\ qexists_tac`fs1` \\ reverse conj_tac >- @@ -310,7 +315,8 @@ Theorem main_whole_prog_spec GSYM add_stdo_with_numchars, with_same_numchars] \\ simp [SEP_CLAUSES] \\ match_mp_tac(MP_CANON(MATCH_MP app_wgframe main_spec)) - \\ xsimpl); + \\ xsimpl +QED val (semantics_thm,prog_tm) = whole_prog_thm st "main" main_whole_prog_spec; diff --git a/compiler/bootstrap/translation/compiler64ProgScript.sml b/compiler/bootstrap/translation/compiler64ProgScript.sml index ec76ac0f05..4c0022beda 100644 --- a/compiler/bootstrap/translation/compiler64ProgScript.sml +++ b/compiler/bootstrap/translation/compiler64ProgScript.sml @@ -31,9 +31,11 @@ val max_heap_limit_64_def = Define` val res = translate max_heap_limit_64_def -Theorem max_heap_limit_64_thm - `max_heap_limit (:64) = max_heap_limit_64` - (rw[FUN_EQ_THM] \\ EVAL_TAC); +Theorem max_heap_limit_64_thm: + max_heap_limit (:64) = max_heap_limit_64 +Proof + rw[FUN_EQ_THM] \\ EVAL_TAC +QED (* @@ -253,14 +255,15 @@ val res = append_prog main; val st = get_ml_prog_state() -Theorem main_spec - `app (p:'ffi ffi_proj) ^(fetch_v "main" st) +Theorem main_spec: + app (p:'ffi ffi_proj) ^(fetch_v "main" st) [Conv NONE []] (STDIO fs * COMMANDLINE cl) (POSTv uv. &UNIT_TYPE () uv * STDIO (full_compile_64 (TL cl) (get_stdin fs) fs) - * COMMANDLINE cl)` - (xcf "main" st + * COMMANDLINE cl) +Proof + xcf "main" st \\ xlet_auto >- (xcon \\ xsimpl) \\ xlet_auto >- ( @@ -316,12 +319,14 @@ Theorem main_spec \\ asm_exists_tac \\ xsimpl \\ qexists_tac `fs'` \\ xsimpl) \\ xapp - \\ asm_exists_tac \\ simp [] \\ xsimpl); - -Theorem main_whole_prog_spec - `whole_prog_spec ^(fetch_v "main" st) cl fs NONE - ((=) (full_compile_64 (TL cl) (get_stdin fs) fs))` - (simp[whole_prog_spec_def,UNCURRY] + \\ asm_exists_tac \\ simp [] \\ xsimpl +QED + +Theorem main_whole_prog_spec: + whole_prog_spec ^(fetch_v "main" st) cl fs NONE + ((=) (full_compile_64 (TL cl) (get_stdin fs) fs)) +Proof + simp[whole_prog_spec_def,UNCURRY] \\ qmatch_goalsub_abbrev_tac`fs1 = _ with numchars := _` \\ qexists_tac`fs1` \\ reverse conj_tac >- @@ -330,7 +335,8 @@ Theorem main_whole_prog_spec GSYM add_stdo_with_numchars, with_same_numchars] \\ simp [SEP_CLAUSES] \\ match_mp_tac(MP_CANON(MATCH_MP app_wgframe main_spec)) - \\ xsimpl); + \\ xsimpl +QED val (semantics_thm,prog_tm) = whole_prog_thm st "main" main_whole_prog_spec; diff --git a/compiler/bootstrap/translation/inferProgScript.sml b/compiler/bootstrap/translation/inferProgScript.sml index d2caedac74..9a10916885 100644 --- a/compiler/bootstrap/translation/inferProgScript.sml +++ b/compiler/bootstrap/translation/inferProgScript.sml @@ -31,9 +31,11 @@ val _ = register_type ``:lexer_fun$symbol``; val _ = add_preferred_thy "-"; val _ = add_preferred_thy "termination"; -Theorem NOT_NIL_AND_LEMMA - `(b <> [] /\ x) = if b = [] then F else x` - (Cases_on `b` THEN FULL_SIMP_TAC std_ss []); +Theorem NOT_NIL_AND_LEMMA: + (b <> [] /\ x) = if b = [] then F else x +Proof + Cases_on `b` THEN FULL_SIMP_TAC std_ss [] +QED val extra_preprocessing = ref [MEMBER_INTRO,MAP]; @@ -64,26 +66,28 @@ val PRECONDITION_INTRO = Q.prove( `(b ==> (x = y)) ==> (x = if PRECONDITION b then y else x)`, Cases_on `b` THEN SIMP_TAC std_ss [PRECONDITION_def]); -Theorem t_vwalk_ind - `!P. +Theorem t_vwalk_ind: + !P. (!s v. (!v1 u. FLOOKUP s v = SOME v1 /\ v1 = Infer_Tuvar u ==> P s u) ==> P s v) ==> - (!s v. t_wfs s ==> P s v)` - (NTAC 3 STRIP_TAC + (!s v. t_wfs s ==> P s v) +Proof + NTAC 3 STRIP_TAC THEN Cases_on `t_wfs s` THEN FULL_SIMP_TAC std_ss [] THEN HO_MATCH_MP_TAC (unifyTheory.t_vwalk_ind |> Q.SPEC `P (s:num |-> infer_t)` |> DISCH_ALL |> RW [AND_IMP_INTRO]) - THEN FULL_SIMP_TAC std_ss []); + THEN FULL_SIMP_TAC std_ss [] +QED val _ = translate (unifyTheory.t_vwalk_eqn |> SIMP_RULE std_ss [PULL_FORALL] |> SPEC_ALL |> MATCH_MP PRECONDITION_INTRO); -Theorem t_vwalk_side_def - `!s v. t_vwalk_side s v <=> t_wfs s` - (STRIP_TAC THEN reverse (Cases_on `t_wfs s`) THEN FULL_SIMP_TAC std_ss [] +Theorem t_vwalk_side_def = Q.prove(` + !s v. t_vwalk_side s v <=> t_wfs s`, + STRIP_TAC THEN reverse (Cases_on `t_wfs s`) THEN FULL_SIMP_TAC std_ss [] THEN1 (ONCE_REWRITE_TAC [fetch "-" "t_vwalk_side_def"] THEN FULL_SIMP_TAC std_ss []) THEN STRIP_TAC THEN POP_ASSUM (fn th => MP_TAC th THEN MP_TAC th) @@ -96,13 +100,15 @@ Theorem t_vwalk_side_def val _ = translate unifyTheory.t_walk_eqn; -Theorem t_walkstar_ind - `!P. +Theorem t_walkstar_ind: + !P. (!s t. (!ts tc0 a. t_walk s t = Infer_Tapp ts tc0 /\ MEM a ts ==> P s a) ==> P s t) ==> - !s t. t_wfs s ==> P s t` - (METIS_TAC [unifyTheory.t_walkstar_ind]); + !s t. t_wfs s ==> P s t +Proof + METIS_TAC [unifyTheory.t_walkstar_ind] +QED val expand_lemma = Q.prove( `t_walkstar s = \x. t_walkstar s x`, @@ -113,9 +119,9 @@ val _ = translate |> RW1 [expand_lemma] |> SIMP_RULE std_ss [PULL_FORALL] |> SPEC_ALL |> MATCH_MP PRECONDITION_INTRO) -Theorem t_walkstar_side_def - `!s v. t_walkstar_side s v <=> t_wfs s` - (STRIP_TAC THEN reverse (Cases_on `t_wfs s`) THEN FULL_SIMP_TAC std_ss [] +Theorem t_walkstar_side_def = Q.prove(` + !s v. t_walkstar_side s v <=> t_wfs s`, + STRIP_TAC THEN reverse (Cases_on `t_wfs s`) THEN FULL_SIMP_TAC std_ss [] THEN1 (ONCE_REWRITE_TAC [fetch "-" "t_walkstar_side_def"] THEN FULL_SIMP_TAC std_ss []) THEN STRIP_TAC THEN POP_ASSUM (fn th => MP_TAC th THEN MP_TAC th) @@ -126,15 +132,17 @@ Theorem t_walkstar_side_def THEN METIS_TAC []) |> update_precondition; -Theorem t_oc_ind - `!P. +Theorem t_oc_ind: + !P. (!s t v. (!ts tt a. t_walk s t = Infer_Tapp ts tt /\ MEM a ts ==> P s a v) ==> P s t v) ==> - (!s t v. t_wfs s ==> P (s:num |-> infer_t) (t:infer_t) (v:num))` - (REPEAT STRIP_TAC THEN Q.SPEC_TAC (`t`,`t`) + (!s t v. t_wfs s ==> P (s:num |-> infer_t) (t:infer_t) (v:num)) +Proof + REPEAT STRIP_TAC THEN Q.SPEC_TAC (`t`,`t`) THEN IMP_RES_TAC unifyTheory.t_walkstar_ind - THEN POP_ASSUM HO_MATCH_MP_TAC THEN METIS_TAC []); + THEN POP_ASSUM HO_MATCH_MP_TAC THEN METIS_TAC [] +QED val EXISTS_LEMMA = Q.prove( `!xs P. EXISTS P xs = EXISTS I (MAP P xs)`, @@ -154,9 +162,9 @@ val t_oc_side_lemma = Q.prove( THEN REPEAT STRIP_TAC THEN FULL_SIMP_TAC (srw_ss()) []) |> SIMP_RULE std_ss []; -Theorem t_oc_side_def - `!s t v. t_oc_side s t v <=> t_wfs s` - (STRIP_TAC THEN Cases_on `t_wfs s` +Theorem t_oc_side_def = Q.prove(` + !s t v. t_oc_side s t v <=> t_wfs s`, + STRIP_TAC THEN Cases_on `t_wfs s` THEN FULL_SIMP_TAC std_ss [t_oc_side_lemma] THEN ONCE_REWRITE_TAC [fetch "-" "t_oc_side_def"] THEN FULL_SIMP_TAC std_ss []) @@ -213,17 +221,17 @@ val t_unify_side_lemma = Q.prove( THEN REPEAT STRIP_TAC THEN FULL_SIMP_TAC (srw_ss()) [] THEN METIS_TAC [unifyTheory.t_unify_unifier]) |> SIMP_RULE std_ss []; -Theorem t_unify_side_def - `!s t v. t_unify_side s t v <=> t_wfs s` - (STRIP_TAC THEN Cases_on `t_wfs s` +Theorem t_unify_side_def = Q.prove(` + !s t v. t_unify_side s t v <=> t_wfs s`, + STRIP_TAC THEN Cases_on `t_wfs s` THEN FULL_SIMP_TAC std_ss [t_unify_side_lemma] THEN ONCE_REWRITE_TAC [t_unify_side_rw] THEN FULL_SIMP_TAC std_ss []) |> update_precondition; -Theorem ts_unify_side_def - `!s t v. ts_unify_side s t v <=> t_wfs s` - (STRIP_TAC THEN Cases_on `t_wfs s` +Theorem ts_unify_side_def = Q.prove(` + !s t v. ts_unify_side s t v <=> t_wfs s`, + STRIP_TAC THEN Cases_on `t_wfs s` THEN FULL_SIMP_TAC std_ss [t_unify_side_lemma] THEN ONCE_REWRITE_TAC [t_unify_side_rw] THEN FULL_SIMP_TAC std_ss []) @@ -517,20 +525,24 @@ val add_constraint_side_def = definition"add_constraint_side_def" val _ = translate (infer_def ``add_constraints``); -Theorem add_constraint_side_thm - `∀l x y z. t_wfs z.subst ⇒ add_constraint_side l x y z` - (rw[add_constraint_side_def]); +Theorem add_constraint_side_thm: + ∀l x y z. t_wfs z.subst ⇒ add_constraint_side l x y z +Proof + rw[add_constraint_side_def] +QED -Theorem add_constraints_side_thm - `∀l x y z. t_wfs z.subst ⇒ add_constraints_side l x y z` - (recInduct add_constraints_ind +Theorem add_constraints_side_thm: + ∀l x y z. t_wfs z.subst ⇒ add_constraints_side l x y z +Proof + recInduct add_constraints_ind \\ rw[Once(theorem"add_constraints_side_def")] \\ rw[Once(theorem"add_constraints_side_def")] \\ rw[add_constraint_side_def] \\ first_x_assum match_mp_tac \\ fs[add_constraint_def] \\ every_case_tac \\ fs[] \\ rw[] - \\ metis_tac[unifyTheory.t_unify_wfs]); + \\ metis_tac[unifyTheory.t_unify_wfs] +QED val def = infer_def ``constrain_op`` (* @@ -598,10 +610,11 @@ val res = translate inter_p_lemma1; val infer_p_side_def = theorem"infer_p_side_def"; -Theorem infer_p_side_thm - `(!l cenv p st. t_wfs st.subst ⇒ infer_p_side l cenv p st) ∧ - (!l cenv ps st. t_wfs st.subst ⇒ infer_ps_side l cenv ps st)` - (ho_match_mp_tac infer_p_ind >> +Theorem infer_p_side_thm: + (!l cenv p st. t_wfs st.subst ⇒ infer_p_side l cenv p st) ∧ + (!l cenv ps st. t_wfs st.subst ⇒ infer_ps_side l cenv ps st) +Proof + ho_match_mp_tac infer_p_ind >> rw [] >> rw [Once infer_p_side_def] >> fs [success_eqns, rich_listTheory.LENGTH_COUNT_LIST] >> @@ -609,7 +622,8 @@ Theorem infer_p_side_thm TRY(qmatch_goalsub_rename_tac`FST pp` >> PairCases_on`pp`) >> fs[] >> TRY(match_mp_tac add_constraints_side_thm >> fs[]) >> every_case_tac >> fs[] >> rw[] >> - metis_tac[infer_p_wfs,PAIR]); + metis_tac[infer_p_wfs,PAIR] +QED val infer_e_lemma = infer_def ``infer_e``; @@ -646,12 +660,13 @@ val constrain_op_side_def = definition"constrain_op_side_def"; val infer_e_side_def = theorem"infer_e_side_def" |> SIMP_RULE std_ss [PULL_FORALL] |> SPEC_ALL -Theorem infer_e_side_thm - `(!l menv e st. t_wfs st.subst ⇒ infer_e_side l menv e st) /\ +Theorem infer_e_side_thm: + (!l menv e st. t_wfs st.subst ⇒ infer_e_side l menv e st) /\ (!l menv es st. t_wfs st.subst ⇒ infer_es_side l menv es st) /\ (!l menv pes t1 t2 st. t_wfs st.subst ⇒ infer_pes_side l menv pes t1 t2 st) /\ - (!l menv funs st. t_wfs st.subst ⇒ infer_funs_side l menv funs st)` - (ho_match_mp_tac infer_e_ind >> + (!l menv funs st. t_wfs st.subst ⇒ infer_funs_side l menv funs st) +Proof + ho_match_mp_tac infer_e_ind >> rw [] >> rw [Once infer_e_side_def] >> TRY (irule add_constraint_side_thm) >> @@ -692,7 +707,8 @@ Theorem infer_e_side_thm PairCases_on `x26` >> fs [] >> imp_res_tac infer_p_wfs >> imp_res_tac infer_e_wfs >> - imp_res_tac unifyTheory.t_unify_wfs >> fs [])); + imp_res_tac unifyTheory.t_unify_wfs >> fs []) +QED val _ = translate (infer_def ``infer_d``) val _ = print "Translated infer_d\n"; @@ -721,10 +737,11 @@ val infer_p_wfs_dest = infer_p_wfs |> BODY_CONJUNCTS val unify_t_wfs_dest = unifyTheory.t_unify_wfs |> CONV_RULE (ONCE_DEPTH_CONV (REWR_CONV CONJ_COMM)) -Theorem infer_d_side_thm - `(!d ienv s. t_wfs s.subst ==> infer_d_side ienv d s) /\ - (!ds ienv s. t_wfs s.subst ==> infer_ds_side ienv ds s)` - (ho_match_mp_tac (fetch "-" "gen_d_ind_ind") +Theorem infer_d_side_thm: + (!d ienv s. t_wfs s.subst ==> infer_d_side ienv d s) /\ + (!ds ienv s. t_wfs s.subst ==> infer_ds_side ienv ds s) +Proof + ho_match_mp_tac (fetch "-" "gen_d_ind_ind") \\ rpt conj_tac \\ rpt gen_tac \\ strip_tac >> once_rewrite_tac [infer_d_side_def] >> rw [FORALL_PROD] >> fs [init_state_def, success_eqns] >> @@ -735,7 +752,8 @@ Theorem infer_d_side_thm EVERY (map (TRY o drule) (infer_p_wfs_dest @ BODY_CONJUNCTS infer_e_wfs @ BODY_CONJUNCTS infer_d_wfs @ [unify_t_wfs_dest, pure_add_constraints_wfs])) >> - fs []); + fs [] +QED val MEM_anub = prove(`` ∀e1M ls k v1. @@ -798,9 +816,9 @@ val nsSub_thm = prove(`` val res = translate infertype_prog_def; -Theorem infertype_prog_side_thm - `infertype_prog_side x y` - (fs [fetch "-" "infertype_prog_side_def"] +Theorem infertype_prog_side_thm = Q.prove(` + infertype_prog_side x y`, + fs [fetch "-" "infertype_prog_side_def"] \\ match_mp_tac (CONJUNCT2 infer_d_side_thm) \\ fs []) |> update_precondition; diff --git a/compiler/bootstrap/translation/lexerProgScript.sml b/compiler/bootstrap/translation/lexerProgScript.sml index be648a62f8..8e03efd150 100644 --- a/compiler/bootstrap/translation/lexerProgScript.sml +++ b/compiler/bootstrap/translation/lexerProgScript.sml @@ -26,9 +26,11 @@ fun list_mk_fun_type [ty] = ty val _ = add_preferred_thy "-"; val _ = add_preferred_thy "termination"; -Theorem NOT_NIL_AND_LEMMA - `(b <> [] /\ x) = if b = [] then F else x` - (Cases_on `b` THEN FULL_SIMP_TAC std_ss []); +Theorem NOT_NIL_AND_LEMMA: + (b <> [] /\ x) = if b = [] then F else x +Proof + Cases_on `b` THEN FULL_SIMP_TAC std_ss [] +QED val extra_preprocessing = ref [MEMBER_INTRO,MAP]; diff --git a/compiler/bootstrap/translation/parserProgScript.sml b/compiler/bootstrap/translation/parserProgScript.sml index bda446d248..7df6a715bc 100644 --- a/compiler/bootstrap/translation/parserProgScript.sml +++ b/compiler/bootstrap/translation/parserProgScript.sml @@ -29,9 +29,11 @@ fun list_mk_fun_type [ty] = ty val _ = add_preferred_thy "-"; val _ = add_preferred_thy "termination"; -Theorem NOT_NIL_AND_LEMMA - `(b <> [] /\ x) = if b = [] then F else x` - (Cases_on `b` THEN FULL_SIMP_TAC std_ss []); +Theorem NOT_NIL_AND_LEMMA: + (b <> [] /\ x) = if b = [] then F else x +Proof + Cases_on `b` THEN FULL_SIMP_TAC std_ss [] +QED val extra_preprocessing = ref [MEMBER_INTRO,MAP]; @@ -65,14 +67,16 @@ val EqType_PT_rule = EqualityType_rule [] ``:(token,MMLnonT,locs) parsetree``; val _ = translate (def_of_const ``cmlPEG``); -Theorem INTRO_FLOOKUP - `(if n IN FDOM G.rules +Theorem INTRO_FLOOKUP: + (if n IN FDOM G.rules then EV (G.rules ' n) i r y fk else Result xx) = (case FLOOKUP G.rules n of NONE => Result xx - | SOME x => EV x i r y fk)` - (SRW_TAC [] [finite_mapTheory.FLOOKUP_DEF]); + | SOME x => EV x i r y fk) +Proof + SRW_TAC [] [finite_mapTheory.FLOOKUP_DEF] +QED val _ = translate (def_of_const ``coreloop`` |> RW [INTRO_FLOOKUP] |> SPEC_ALL |> RW1 [FUN_EQ_THM]); @@ -89,9 +93,11 @@ val _ = translate grammarTheory.ptree_head_def (* parsing: ptree converstion *) -Theorem OPTION_BIND_THM - `!x y. OPTION_BIND x y = case x of NONE => NONE | SOME i => y i` - (Cases THEN SRW_TAC [] []); +Theorem OPTION_BIND_THM: + !x y. OPTION_BIND x y = case x of NONE => NONE | SOME i => y i +Proof + Cases THEN SRW_TAC [] [] +QED val _ = (extra_preprocessing := [MEMBER_INTRO,MAP,OPTION_BIND_THM,monad_unitbind_assert]); @@ -106,9 +112,9 @@ val _ = translate (def_of_const ``ptree_TopLevelDecs``); val _ = translate (RW [monad_unitbind_assert] parse_prog_def); -Theorem parse_prog_side_lemma - `!x. parse_prog_side x = T` - (SIMP_TAC std_ss [fetch "-" "parse_prog_side_def", +Theorem parse_prog_side_lemma = Q.prove(` + !x. parse_prog_side x = T`, + SIMP_TAC std_ss [fetch "-" "parse_prog_side_def", fetch "-" "peg_exec_side_def", fetch "-" "coreloop_side_def"] THEN REPEAT STRIP_TAC THEN STRIP_ASSUME_TAC (Q.SPEC `x` owhile_TopLevelDecs_total) diff --git a/compiler/bootstrap/translation/reg_allocProgScript.sml b/compiler/bootstrap/translation/reg_allocProgScript.sml index f8d3afa04a..f961ac06e4 100644 --- a/compiler/bootstrap/translation/reg_allocProgScript.sml +++ b/compiler/bootstrap/translation/reg_allocProgScript.sml @@ -320,10 +320,12 @@ val map_colors_sub_def = Define ` (\fx. st_ex_bind (map_colors_sub xs) (\fxs. st_ex_return (fx::fxs))))` -Theorem map_colors_sub_eq - `map_colors_sub = st_ex_MAP colors_sub` - (once_rewrite_tac [FUN_EQ_THM] - \\ Induct \\ fs [map_colors_sub_def,st_ex_MAP_def]); +Theorem map_colors_sub_eq: + map_colors_sub = st_ex_MAP colors_sub +Proof + once_rewrite_tac [FUN_EQ_THM] + \\ Induct \\ fs [map_colors_sub_def,st_ex_MAP_def] +QED val res = m_translate spill_register_def; val res = m_translate MAP_colors_def; @@ -414,9 +416,11 @@ val res = append_prog main; val st = get_ml_prog_state (); -Theorem main_whole_prog_spec - `F ==> whole_prog_spec ^(fetch_v "main" st) cl fs NONE (\x. T)` - (simp []); +Theorem main_whole_prog_spec: + F ==> whole_prog_spec ^(fetch_v "main" st) cl fs NONE (\x. T) +Proof + simp [] +QED val (_,prog_tm) = whole_prog_thm st "main" (UNDISCH main_whole_prog_spec); diff --git a/compiler/bootstrap/translation/sexp_parserProgScript.sml b/compiler/bootstrap/translation/sexp_parserProgScript.sml index beed853a2d..f7c9e9e8c1 100644 --- a/compiler/bootstrap/translation/sexp_parserProgScript.sml +++ b/compiler/bootstrap/translation/sexp_parserProgScript.sml @@ -14,9 +14,11 @@ val _ = ml_translatorLib.ml_prog_update (ml_progLib.open_module "sexp_parserProg val monad_unitbind_assert = Q.prove( `!b x. monad_unitbind (assert b) x = if b then x else NONE`, Cases THEN EVAL_TAC THEN SIMP_TAC std_ss []); -Theorem OPTION_BIND_THM - `!x y. OPTION_BIND x y = case x of NONE => NONE | SOME i => y i` - (Cases THEN SRW_TAC [] []); +Theorem OPTION_BIND_THM: + !x y. OPTION_BIND x y = case x of NONE => NONE | SOME i => y i +Proof + Cases THEN SRW_TAC [] [] +QED (* -- *) val r = translate simpleSexpPEGTheory.pnt_def @@ -81,12 +83,13 @@ val r = translate simpleSexpTheory.dstrip_sexp_def (* TODO: move (used?) *) -Theorem isHexDigit_cases - `isHexDigit c ⇔ +Theorem isHexDigit_cases: + isHexDigit c ⇔ isDigit c ∨ c ∈ {#"a";#"b";#"c";#"d";#"e";#"f"} ∨ - c ∈ {#"A";#"B";#"C";#"D";#"E";#"F"}` - (rw[isHexDigit_def,isDigit_def] + c ∈ {#"A";#"B";#"C";#"D";#"E";#"F"} +Proof + rw[isHexDigit_def,isDigit_def] \\ EQ_TAC \\ strip_tac \\ simp[] >- ( `ORD c = 97 ∨ @@ -103,37 +106,44 @@ Theorem isHexDigit_cases ORD c = 68 ∨ ORD c = 69 ∨ ORD c = 70` by decide_tac \\ - pop_assum(assume_tac o Q.AP_TERM`CHR`) \\ fs[CHR_ORD] )); + pop_assum(assume_tac o Q.AP_TERM`CHR`) \\ fs[CHR_ORD] ) +QED -Theorem isHexDigit_UNHEX_LESS - `isHexDigit c ⇒ UNHEX c < 16` - (rw[isHexDigit_cases] \\ EVAL_TAC \\ +Theorem isHexDigit_UNHEX_LESS: + isHexDigit c ⇒ UNHEX c < 16 +Proof + rw[isHexDigit_cases] \\ EVAL_TAC \\ rw[GSYM simpleSexpParseTheory.isDigit_UNHEX_alt] \\ - fs[isDigit_def]); + fs[isDigit_def] +QED -Theorem num_from_hex_string_alt_length_2 - `num_from_hex_string_alt [d1;d2] < 256` - (rw[lexer_implTheory.num_from_hex_string_alt_def, +Theorem num_from_hex_string_alt_length_2: + num_from_hex_string_alt [d1;d2] < 256 +Proof + rw[lexer_implTheory.num_from_hex_string_alt_def, ASCIInumbersTheory.s2n_def, numposrepTheory.l2n_def] \\ qspecl_then[`unhex_alt d1`,`16`]mp_tac MOD_LESS \\ impl_tac >- rw[] \\ qspecl_then[`unhex_alt d2`,`16`]mp_tac MOD_LESS \\ impl_tac >- rw[] - \\ decide_tac); + \\ decide_tac +QED (* -- *) -Theorem num_from_hex_string_alt_intro - `EVERY isHexDigit ls ⇒ +Theorem num_from_hex_string_alt_intro: + EVERY isHexDigit ls ⇒ num_from_hex_string ls = - num_from_hex_string_alt ls` - (rw[ASCIInumbersTheory.num_from_hex_string_def, + num_from_hex_string_alt ls +Proof + rw[ASCIInumbersTheory.num_from_hex_string_def, lexer_implTheory.num_from_hex_string_alt_def, ASCIInumbersTheory.s2n_def, numposrepTheory.l2n_def] \\ AP_TERM_TAC \\ simp[MAP_EQ_f] \\ - fs[EVERY_MEM,lexer_implTheory.unhex_alt_def]); + fs[EVERY_MEM,lexer_implTheory.unhex_alt_def] +QED val lemma = Q.prove(` isHexDigit x ∧ isHexDigit y ∧ A ∧ B ∧ ¬isPrint (CHR (num_from_hex_string[x;y])) ⇔ diff --git a/compiler/bootstrap/translation/to_bviProgScript.sml b/compiler/bootstrap/translation/to_bviProgScript.sml index 0dc687ae3e..28060a79aa 100644 --- a/compiler/bootstrap/translation/to_bviProgScript.sml +++ b/compiler/bootstrap/translation/to_bviProgScript.sml @@ -94,17 +94,17 @@ val r = translate bvi_tailrecTheory.arg_ty_PMATCH; val r = translate bvi_tailrecTheory.op_ty_PMATCH; val r = translate bvi_tailrecTheory.scan_expr_def; -Theorem bvi_tailrec_scan_expr_side - `!a0 a1 a2. bvi_tailrec_scan_expr_side a0 a1 a2` - (recInduct bvi_tailrecTheory.scan_expr_ind \\ rw [] +Theorem bvi_tailrec_scan_expr_side = Q.prove(` + !a0 a1 a2. bvi_tailrec_scan_expr_side a0 a1 a2`, + recInduct bvi_tailrecTheory.scan_expr_ind \\ rw [] \\ once_rewrite_tac [fetch "-" "bvi_tailrec_scan_expr_side_def"] \\ fs [] \\ FULL_CASE_TAC \\ fs []) |> update_precondition; val r = translate bvi_tailrecTheory.rewrite_PMATCH; -Theorem bvi_tailrec_rewrite_side - `!v58 v59 v60 v56 v61 v57. bvi_tailrec_rewrite_side v58 v59 v60 v56 v61 v57` - (recInduct bvi_tailrecTheory.rewrite_ind \\ rw [] +Theorem bvi_tailrec_rewrite_side = Q.prove(` + !v58 v59 v60 v56 v61 v57. bvi_tailrec_rewrite_side v58 v59 v60 v56 v61 v57`, + recInduct bvi_tailrecTheory.rewrite_ind \\ rw [] \\ once_rewrite_tac [fetch "-" "bvi_tailrec_rewrite_side_def"] \\ fs [] \\ FULL_CASE_TAC \\ fs []) |> update_precondition; diff --git a/compiler/bootstrap/translation/to_bvlProgScript.sml b/compiler/bootstrap/translation/to_bvlProgScript.sml index 102e0933c2..fbe6a9c3cf 100644 --- a/compiler/bootstrap/translation/to_bvlProgScript.sml +++ b/compiler/bootstrap/translation/to_bvlProgScript.sml @@ -230,10 +230,12 @@ val bvl_inline_tick_inline_all_side = Q.prove ( val r = translate bvl_inlineTheory.let_op_def; -Theorem let_op_SING_NOT_NIL[simp] - `let_op [x] <> []` - (Cases_on `x` \\ fs [bvl_inlineTheory.let_op_def] - \\ CASE_TAC \\ fs []); +Theorem let_op_SING_NOT_NIL[simp]: + let_op [x] <> [] +Proof + Cases_on `x` \\ fs [bvl_inlineTheory.let_op_def] + \\ CASE_TAC \\ fs [] +QED val bvl_inline_let_op_side = Q.prove(` ∀a. bvl_inline_let_op_side a ⇔ T`, @@ -243,9 +245,9 @@ val bvl_inline_let_op_side = Q.prove(` val r = translate bvl_inlineTheory.remove_ticks_def; -Theorem bvl_inline_remove_ticks_side - `!a. bvl_inline_remove_ticks_side a` - (ho_match_mp_tac bvl_inlineTheory.remove_ticks_ind +Theorem bvl_inline_remove_ticks_side = Q.prove(` + !a. bvl_inline_remove_ticks_side a`, + ho_match_mp_tac bvl_inlineTheory.remove_ticks_ind \\ sg `!x. remove_ticks [x] <> []` >- (CCONTR_TAC \\ fs [] @@ -256,9 +258,9 @@ Theorem bvl_inline_remove_ticks_side val r = translate bvl_inlineTheory.compile_prog_def; -Theorem bvl_inline_compile_prog_side - `!a b c d. bvl_inline_compile_prog_side a b c d` - (rw [Once (fetch "-" "bvl_inline_compile_prog_side_def"), +Theorem bvl_inline_compile_prog_side = Q.prove(` + !a b c d. bvl_inline_compile_prog_side a b c d`, + rw [Once (fetch "-" "bvl_inline_compile_prog_side_def"), Once (fetch "-" "bvl_inline_compile_inc_side_def"), Once (fetch "-" "bvl_inline_optimise_side_def")] \\ strip_tac diff --git a/compiler/bootstrap/translation/to_closProgScript.sml b/compiler/bootstrap/translation/to_closProgScript.sml index e96cfa3507..ff50446d87 100644 --- a/compiler/bootstrap/translation/to_closProgScript.sml +++ b/compiler/bootstrap/translation/to_closProgScript.sml @@ -120,9 +120,9 @@ val clos_known_known_op_side = Q.prove(` val r = translate clos_knownTheory.free_def; -Theorem clos_known_free_side - `!x. clos_known_free_side x` - (ho_match_mp_tac clos_knownTheory.free_ind \\ rw [] +Theorem clos_known_free_side = Q.prove(` + !x. clos_known_free_side x`, + ho_match_mp_tac clos_knownTheory.free_ind \\ rw [] \\ `!xs ys l. free xs = (ys, l) ==> LENGTH xs = LENGTH ys` by (ho_match_mp_tac clos_knownTheory.free_ind \\ rw [] \\ fs [clos_knownTheory.free_def] diff --git a/compiler/bootstrap/translation/to_target32ProgScript.sml b/compiler/bootstrap/translation/to_target32ProgScript.sml index 397eb7fe34..5836400e42 100644 --- a/compiler/bootstrap/translation/to_target32ProgScript.sml +++ b/compiler/bootstrap/translation/to_target32ProgScript.sml @@ -264,9 +264,9 @@ val monadic_enc32_enc_sec_hash_32_ls_side_def = Q.prove(` simp[Once (fetch "-" "monadic_enc32_enc_sec_hash_32_ls_side_def")]>> metis_tac[monadic_enc32_enc_line_hash_32_ls_side_def]); -Theorem monadic_enc32_enc_secs_32_side_def - `monadic_enc32_enc_secs_32_side a b c ⇔ T` - (EVAL_TAC>> +Theorem monadic_enc32_enc_secs_32_side_def = Q.prove(` + monadic_enc32_enc_secs_32_side a b c ⇔ T`, + EVAL_TAC>> rw[]>> metis_tac[monadic_enc32_enc_sec_hash_32_ls_side_def,DECIDE``1n ≠ 0``]) |> update_precondition; diff --git a/compiler/bootstrap/translation/to_target64ProgScript.sml b/compiler/bootstrap/translation/to_target64ProgScript.sml index 6bc0c40080..dd17622092 100644 --- a/compiler/bootstrap/translation/to_target64ProgScript.sml +++ b/compiler/bootstrap/translation/to_target64ProgScript.sml @@ -264,9 +264,9 @@ val monadic_enc64_enc_sec_hash_64_ls_side_def = Q.prove(` simp[Once (fetch "-" "monadic_enc64_enc_sec_hash_64_ls_side_def")]>> metis_tac[monadic_enc64_enc_line_hash_64_ls_side_def]); -Theorem monadic_enc64_enc_secs_64_side_def - `monadic_enc64_enc_secs_64_side a b c ⇔ T` - (EVAL_TAC>> +Theorem monadic_enc64_enc_secs_64_side_def = Q.prove(` + monadic_enc64_enc_secs_64_side a b c ⇔ T`, + EVAL_TAC>> rw[]>> metis_tac[monadic_enc64_enc_sec_hash_64_ls_side_def,DECIDE``1n ≠ 0``]) |> update_precondition; diff --git a/compiler/encoders/ag32/proofs/ag32_targetProofScript.sml b/compiler/encoders/ag32/proofs/ag32_targetProofScript.sml index 99781e6623..01fe8f6afb 100644 --- a/compiler/encoders/ag32/proofs/ag32_targetProofScript.sml +++ b/compiler/encoders/ag32/proofs/ag32_targetProofScript.sml @@ -183,9 +183,11 @@ val aligned_pc = Q.prove( \\ blastLib.BBLAST_TAC ) -Theorem concat_bytes - `!w: word32. (31 >< 24) w @@ (23 >< 16) w @@ (15 >< 8) w @@ (7 >< 0) w = w` - (blastLib.BBLAST_TAC); +Theorem concat_bytes: + !w: word32. (31 >< 24) w @@ (23 >< 16) w @@ (15 >< 8) w @@ (7 >< 0) w = w +Proof + blastLib.BBLAST_TAC +QED val funcT_thm = Q.prove( `!func. @@ -207,9 +209,10 @@ val shiftT_thm = Q.prove( fun tac q l = qmatch_goalsub_rename_tac q \\ MAP_EVERY Cases_on l (* The encoder and decoder are well-behaved *) -Theorem Decode_Encode - `!i. Decode (Encode i) = i` - (Cases +Theorem Decode_Encode: + !i. Decode (Encode i) = i +Proof + Cases \\ TRY (pairLib.PairCases_on `p`) >| [ tac `Accelerator (w, a)` [`a`], @@ -235,7 +238,7 @@ Theorem Decode_Encode \\ CONV_TAC blastLib.BBLAST_CONV \\ simp [funcT_thm, shiftT_thm] \\ CONV_TAC blastLib.BBLAST_CONV - ) +QED val ag32_run = Q.prove( `!i ms. @@ -353,9 +356,10 @@ end val print_tac = asmLib.print_tac "correct" -Theorem ag32_encoder_correct - `encoder_correct ag32_target` - (simp [asmPropsTheory.encoder_correct_def, ag32_target_ok] +Theorem ag32_encoder_correct: + encoder_correct ag32_target +Proof + simp [asmPropsTheory.encoder_correct_def, ag32_target_ok] \\ qabbrev_tac `state_rel = target_state_rel ag32_target` \\ rw [ag32_target_def, ag32_config, asmSemTheory.asm_step_def] \\ qunabbrev_tac `state_rel` @@ -507,6 +511,6 @@ Theorem ag32_encoder_correct print_tac "Loc" \\ next_tac ) - ) +QED val () = export_theory () diff --git a/compiler/encoders/arm6/proofs/arm6_targetProofScript.sml b/compiler/encoders/arm6/proofs/arm6_targetProofScript.sml index 07c47f5fea..d1f5d2abf4 100644 --- a/compiler/encoders/arm6/proofs/arm6_targetProofScript.sml +++ b/compiler/encoders/arm6/proofs/arm6_targetProofScript.sml @@ -981,9 +981,10 @@ val arm6_target_ok = Q.prove ( val print_tac = asmLib.print_tac "correct" -Theorem arm6_encoder_correct - `encoder_correct arm6_target` - (simp [asmPropsTheory.encoder_correct_def, arm6_target_ok] +Theorem arm6_encoder_correct: + encoder_correct arm6_target +Proof + simp [asmPropsTheory.encoder_correct_def, arm6_target_ok] \\ qabbrev_tac `state_rel = target_state_rel arm6_target` \\ rw [arm6_target_def, arm6_config, asmSemTheory.asm_step_def] \\ qunabbrev_tac `state_rel` @@ -1215,6 +1216,6 @@ Theorem arm6_encoder_correct updateTheory.APPLY_UPDATE_ID, arm_stepTheory.R_mode_11, lem1] \\ blastLib.FULL_BBLAST_TAC ) - ) +QED val () = export_theory () diff --git a/compiler/encoders/arm8/proofs/arm8_targetProofScript.sml b/compiler/encoders/arm8/proofs/arm8_targetProofScript.sml index 4e305679d6..91c5528e22 100644 --- a/compiler/encoders/arm8/proofs/arm8_targetProofScript.sml +++ b/compiler/encoders/arm8/proofs/arm8_targetProofScript.sml @@ -19,19 +19,20 @@ fun cases_on_DecodeBitMasks (g as (asl, _)) = (Cases_on `^tm` \\ fs [] \\ Cases_on `x` \\ fs []) g end -Theorem Decode_EncodeBitMask - `(!w: word32 n s r. +Theorem Decode_EncodeBitMask: + (!w: word32 n s r. (EncodeBitMask w = SOME (n, s, r)) ==> (?v. DecodeBitMasks (n, s, r, T) = SOME (w, v))) /\ (!w: word64 n s r. (EncodeBitMask w = SOME (n, s, r)) ==> - (?v. DecodeBitMasks (n, s, r, T) = SOME (w, v)))` - (lrw [arm8Theory.EncodeBitMask_def, arm8Theory.EncodeBitMaskAux_def] + (?v. DecodeBitMasks (n, s, r, T) = SOME (w, v))) +Proof + lrw [arm8Theory.EncodeBitMask_def, arm8Theory.EncodeBitMaskAux_def] \\ BasicProvers.FULL_CASE_TAC \\ fs [] \\ cases_on_DecodeBitMasks \\ metis_tac [] - ) +QED val word_log2_7 = Q.prove( `!s: word6. word_log2 (((1w: word1) @@ s) : word7) = 6w`, @@ -843,9 +844,10 @@ val arm8_target_ok = Q.prove ( val ext12 = ``(11 >< 0) : word64 -> word12`` val print_tac = asmLib.print_tac "correct" -Theorem arm8_encoder_correct - `encoder_correct arm8_target` - (simp [asmPropsTheory.encoder_correct_def, arm8_target_ok] +Theorem arm8_encoder_correct: + encoder_correct arm8_target +Proof + simp [asmPropsTheory.encoder_correct_def, arm8_target_ok] \\ qabbrev_tac `state_rel = target_state_rel arm8_target` \\ rw [arm8_target_def, asmSemTheory.asm_step_def, arm8_config] \\ qunabbrev_tac `state_rel` @@ -1205,6 +1207,6 @@ Theorem arm8_encoder_correct \\ next_state_tacN (`20w`, 1) filter_reg_31 \\ state_tac [alignmentTheory.aligned_extract] \\ blastLib.FULL_BBLAST_TAC) - ) +QED val () = export_theory () diff --git a/compiler/encoders/asm/asmPropsScript.sml b/compiler/encoders/asm/asmPropsScript.sml index 35bdb9ebed..95e7e42b51 100644 --- a/compiler/encoders/asm/asmPropsScript.sml +++ b/compiler/encoders/asm/asmPropsScript.sml @@ -7,9 +7,11 @@ val () = new_theory "asmProps" (* -- semantics is deterministic -- *) -Theorem asm_deterministic - `!c i s1 s2 s3. asm_step c s1 i s2 /\ asm_step c s1 i s3 ==> (s2 = s3)` - (rw [asm_step_def]) +Theorem asm_deterministic: + !c i s1 s2 s3. asm_step c s1 i s2 /\ asm_step c s1 i s3 ==> (s2 = s3) +Proof + rw [asm_step_def] +QED (* -- well-formedness of encoding -- *) @@ -72,9 +74,10 @@ val all_pcs_def = Define` (all_pcs 0n a k = {}) ∧ (all_pcs n a k = a INSERT all_pcs (n-(2 ** k)) (a + n2w (2 ** k)) k)` -Theorem all_pcs_thm - `all_pcs n a k = { a + n2w (i * (2 ** k)) | i | i * (2 ** k) < n }` - (qid_spec_tac`a` +Theorem all_pcs_thm: + all_pcs n a k = { a + n2w (i * (2 ** k)) | i | i * (2 ** k) < n } +Proof + qid_spec_tac`a` \\ qid_spec_tac`k` \\ completeInduct_on`n` \\ Cases_on`n` \\ rw[all_pcs_def] @@ -85,7 +88,8 @@ Theorem all_pcs_thm \\ rw[EQ_IMP_THM] >- ( qexists_tac`SUC i` \\ simp[ADD1,LEFT_ADD_DISTRIB,RIGHT_ADD_DISTRIB] ) \\ qexists_tac`i-1` - \\ Cases_on`i` \\ fs[ADD1,LEFT_ADD_DISTRIB,RIGHT_ADD_DISTRIB]); + \\ Cases_on`i` \\ fs[ADD1,LEFT_ADD_DISTRIB,RIGHT_ADD_DISTRIB] +QED val asserts_def = zDefine ` (asserts 0 next ms _ Q <=> Q (next 0 ms)) /\ @@ -116,9 +120,10 @@ val encoder_correct_def = Define ` (* lemma for proofs *) -Theorem bytes_in_memory_all_pcs - `!xs pc. bytes_in_memory pc xs m d ==> all_pcs (LENGTH xs) pc k SUBSET d` - (gen_tac +Theorem bytes_in_memory_all_pcs: + !xs pc. bytes_in_memory pc xs m d ==> all_pcs (LENGTH xs) pc k SUBSET d +Proof + gen_tac \\ completeInduct_on`LENGTH xs` \\ rw[] \\ fs[all_pcs_thm] @@ -141,15 +146,17 @@ Theorem bytes_in_memory_all_pcs \\ simp[SUB_LEFT_ADD, SUB_RIGHT_ADD] \\ IF_CASES_TAC \\ fs[] \\ `i = 1` by fs[] \\ fs[] ) - \\ Cases_on`i` \\ fs[ADD1, RIGHT_ADD_DISTRIB]); + \\ Cases_on`i` \\ fs[ADD1, RIGHT_ADD_DISTRIB] +QED -Theorem read_bytearray_IMP_bytes_in_memory - `∀p n m ba m' md. +Theorem read_bytearray_IMP_bytes_in_memory: + ∀p n m ba m' md. (n = LENGTH ba) ∧ (∀k. k ∈ all_words p n ⇒ k ∈ md ∧ (m k = SOME (m' k))) ∧ (read_bytearray (p:'a word) n m = SOME ba) ⇒ - bytes_in_memory p ba m' md` - (Induct_on`ba` \\ rw[] >- EVAL_TAC + bytes_in_memory p ba m' md +Proof + Induct_on`ba` \\ rw[] >- EVAL_TAC \\ simp[bytes_in_memory_def] \\ fs[read_bytearray_def, CaseEq"option"] \\ first_assum(qspec_then`p`mp_tac) @@ -157,18 +164,20 @@ Theorem read_bytearray_IMP_bytes_in_memory \\ rw[] \\ first_x_assum irule \\ fs [all_words_def] - \\ metis_tac []); + \\ metis_tac [] +QED -Theorem sym_target_state_rel - `!t s ms. +Theorem sym_target_state_rel: + !t s ms. target_state_rel t s ms <=> t.state_ok ms /\ (s.pc = t.get_pc ms) /\ (!a. a IN s.mem_domain ==> (s.mem a = t.get_byte ms a)) /\ (!i. i < t.config.reg_count /\ ~MEM i t.config.avoid_regs ==> (s.regs i = t.get_reg ms i)) /\ - (!i. i < t.config.fp_reg_count ==> (s.fp_regs i = t.get_fp_reg ms i))` - (metis_tac [target_state_rel_def] - ) + (!i. i < t.config.fp_reg_count ==> (s.fp_regs i = t.get_fp_reg ms i)) +Proof + metis_tac [target_state_rel_def] +QED val all_pcs = Theory.save_thm ("all_pcs", numLib.SUC_RULE all_pcs_def) @@ -182,35 +191,40 @@ val asserts_eval = save_thm("asserts_eval",let |> ONCE_REWRITE_CONV [asserts_def] |> SIMP_RULE std_ss [] in LIST_CONJ (genlist gen_rw 20) end) -Theorem asserts_IMP_FOLDR_COUNT_LIST - `∀n next ms P Q. asserts n next ms P Q ⇒ - Q (FOLDR next (next n ms) (COUNT_LIST n))` - (Induct +Theorem asserts_IMP_FOLDR_COUNT_LIST: + ∀n next ms P Q. asserts n next ms P Q ⇒ + Q (FOLDR next (next n ms) (COUNT_LIST n)) +Proof + Induct >- rw[COUNT_LIST_def, asserts_def] \\ rw[asserts_def] \\ rw[COUNT_LIST_SNOC, FOLDR_SNOC] - \\ first_x_assum drule \\ rw[]); - -Theorem asserts_IMP_FOLDR_COUNT_LIST_LESS - `∀k n next ms P Q. asserts n next ms P Q ∧ k < n ⇒ - P (FOLDR next ms (REVERSE (GENLIST ((-) n) (SUC k))))` - (simp[GSYM MAP_COUNT_LIST] + \\ first_x_assum drule \\ rw[] +QED + +Theorem asserts_IMP_FOLDR_COUNT_LIST_LESS: + ∀k n next ms P Q. asserts n next ms P Q ∧ k < n ⇒ + P (FOLDR next ms (REVERSE (GENLIST ((-) n) (SUC k)))) +Proof + simp[GSYM MAP_COUNT_LIST] \\ Induct_on`k` \\ rw[] \\ Cases_on`n` \\ fs[asserts_def] >- (EVAL_TAC \\ fs[]) \\ first_x_assum drule \\ simp[] - \\ simp[COUNT_LIST_GENLIST,MAP_GENLIST,REVERSE_GENLIST,GENLIST_CONS,PRE_SUB1,FOLDR_APPEND]); + \\ simp[COUNT_LIST_GENLIST,MAP_GENLIST,REVERSE_GENLIST,GENLIST_CONS,PRE_SUB1,FOLDR_APPEND] +QED -Theorem asserts_WEAKEN - `!n next s P Q. +Theorem asserts_WEAKEN: + !n next s P Q. (!k. k <= n ==> (next k = next' k) ∧ (P (FOLDR next s (REVERSE (GENLIST ((-) n) (SUC k)))) ⇒ P' (FOLDR next s (REVERSE (GENLIST ((-) n) (SUC k)))))) ==> asserts n next s P Q ==> - asserts n next' s P' Q` - (Induct \\ fs[asserts_def] + asserts n next' s P' Q +Proof + Induct \\ fs[asserts_def] \\ rpt gen_tac \\ strip_tac \\ strip_tac \\ conj_tac >- ( @@ -234,7 +248,8 @@ Theorem asserts_WEAKEN \\ strip_tac \\ first_assum(qspec_then`SUC n`mp_tac) \\ impl_tac >- fs[] - \\ strip_tac \\ fs[] )); + \\ strip_tac \\ fs[] ) +QED val asserts2_eval = save_thm("asserts2_eval",let fun gen_rw n = @@ -242,36 +257,42 @@ val asserts2_eval = save_thm("asserts2_eval",let |> ONCE_REWRITE_CONV [asserts2_def] |> SIMP_RULE std_ss [] in LIST_CONJ (List.tabulate(21,gen_rw)) end) -Theorem asserts2_change_interfer - `asserts2 n fi fc ms P ∧ +Theorem asserts2_change_interfer: + asserts2 n fi fc ms P ∧ (∀k. k ≤ n ⇒ fi k = fi2 k) ⇒ - asserts2 n fi2 fc ms P` - (qid_spec_tac`ms` + asserts2 n fi2 fc ms P +Proof + qid_spec_tac`ms` \\ Induct_on`n` \\ rw[Once asserts2_def] \\ rw[Once asserts2_def] \\ first_x_assum match_mp_tac \\ rw[] - \\ METIS_TAC[LESS_OR_EQ]); + \\ METIS_TAC[LESS_OR_EQ] +QED -Theorem asserts2_first - `1 ≤ n ∧ asserts2 n fi fc ms P ⇒ P ms (fc ms)` - (rw[Once asserts2_def] \\ fs[]); +Theorem asserts2_first: + 1 ≤ n ∧ asserts2 n fi fc ms P ⇒ P ms (fc ms) +Proof + rw[Once asserts2_def] \\ fs[] +QED -Theorem asserts2_every - `∀n ms j. +Theorem asserts2_every: + ∀n ms j. asserts2 n (λk. f) g ms P ∧ j < n ⇒ - P (FUNPOW (f o g) j ms) (g (FUNPOW (f o g) j ms))` - (Induct + P (FUNPOW (f o g) j ms) (g (FUNPOW (f o g) j ms)) +Proof + Induct \\ rw[Once asserts2_def] \\ Cases_on`j` \\ fs[] \\ first_x_assum drule \\ disch_then drule - \\ simp[FUNPOW]); + \\ simp[FUNPOW] +QED -Theorem upd_pc_simps[simp] - `((asmSem$upd_pc x s).align = s.align) ∧ +Theorem upd_pc_simps[simp]: + ((asmSem$upd_pc x s).align = s.align) ∧ ((asmSem$upd_pc x s).mem_domain = s.mem_domain) ∧ ((asmSem$upd_pc x s).failed = s.failed) ∧ ((asmSem$upd_pc x s).be = s.be) ∧ @@ -279,18 +300,24 @@ Theorem upd_pc_simps[simp] ((asmSem$upd_pc x s).regs = s.regs) ∧ ((asmSem$upd_pc x s).fp_regs = s.fp_regs) ∧ ((asmSem$upd_pc x s).lr = s.lr) ∧ - ((asmSem$upd_pc x s).pc = x)` - (EVAL_TAC); - -Theorem asm_failed_ignore_new_pc - `!i v w s. (asm i w s).failed <=> (asm i v s).failed` - (Cases \\ full_simp_tac(srw_ss())[asm_def,upd_pc_def,jump_to_offset_def,upd_reg_def] - \\ srw_tac[][] \\ full_simp_tac(srw_ss())[]); - -Theorem asm_mem_ignore_new_pc - `!i v w s. (asm i w s).mem = (asm i v s).mem` - (Cases \\ full_simp_tac(srw_ss())[asm_def,upd_pc_def,jump_to_offset_def,upd_reg_def] - \\ srw_tac[][] \\ full_simp_tac(srw_ss())[]); + ((asmSem$upd_pc x s).pc = x) +Proof + EVAL_TAC +QED + +Theorem asm_failed_ignore_new_pc: + !i v w s. (asm i w s).failed <=> (asm i v s).failed +Proof + Cases \\ full_simp_tac(srw_ss())[asm_def,upd_pc_def,jump_to_offset_def,upd_reg_def] + \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] +QED + +Theorem asm_mem_ignore_new_pc: + !i v w s. (asm i w s).mem = (asm i v s).mem +Proof + Cases \\ full_simp_tac(srw_ss())[asm_def,upd_pc_def,jump_to_offset_def,upd_reg_def] + \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] +QED val SND_read_mem_word_consts = Q.prove( `!n a s. ((SND (read_mem_word a n s)).be = s.be) /\ @@ -308,38 +335,45 @@ val write_mem_word_consts = Q.prove( ((write_mem_word a n w s).mem_domain = s.mem_domain)`, Induct \\ full_simp_tac(srw_ss())[write_mem_word_def,LET_DEF,assert_def,upd_mem_def]) -Theorem binop_upd_consts[simp] - `((binop_upd a b c d x).mem_domain = x.mem_domain) ∧ +Theorem binop_upd_consts[simp]: + ((binop_upd a b c d x).mem_domain = x.mem_domain) ∧ ((binop_upd a b c d x).align = x.align) ∧ ((binop_upd a b c d x).failed = x.failed) ∧ ((binop_upd a b c d x).mem = x.mem) ∧ ((binop_upd a b c d x).lr = x.lr) ∧ - ((binop_upd a b c d x).be = x.be)` - (Cases_on`b`>>EVAL_TAC); + ((binop_upd a b c d x).be = x.be) +Proof + Cases_on`b`>>EVAL_TAC +QED -Theorem arith_upd_consts[simp] - `((arith_upd a x).mem_domain = x.mem_domain) ∧ +Theorem arith_upd_consts[simp]: + ((arith_upd a x).mem_domain = x.mem_domain) ∧ ((arith_upd a x).align = x.align) ∧ ((arith_upd a x).mem = x.mem) ∧ ((arith_upd a x).lr = x.lr) ∧ - ((arith_upd a x).be = x.be)` - (Cases_on`a` >> EVAL_TAC >> srw_tac[][]); + ((arith_upd a x).be = x.be) +Proof + Cases_on`a` >> EVAL_TAC >> srw_tac[][] +QED -Theorem fp_upd_consts[simp] - `((fp_upd a x).mem_domain = x.mem_domain) ∧ +Theorem fp_upd_consts[simp]: + ((fp_upd a x).mem_domain = x.mem_domain) ∧ ((fp_upd a x).align = x.align) ∧ ((fp_upd a x).mem = x.mem) ∧ ((fp_upd a x).lr = x.lr) ∧ - ((fp_upd a x).be = x.be)` - (Cases_on`a` - \\ rpt (EVAL_TAC \\ srw_tac[][] \\ CASE_TAC \\ rw [])); - -Theorem asm_consts[simp] - `!i w s. ((asm i w s).be = s.be) /\ + ((fp_upd a x).be = x.be) +Proof + Cases_on`a` + \\ rpt (EVAL_TAC \\ srw_tac[][] \\ CASE_TAC \\ rw []) +QED + +Theorem asm_consts[simp]: + !i w s. ((asm i w s).be = s.be) /\ ((asm i w s).lr = s.lr) /\ ((asm i w s).align = s.align) /\ - ((asm i w s).mem_domain = s.mem_domain)` - (Cases + ((asm i w s).mem_domain = s.mem_domain) +Proof + Cases \\ full_simp_tac(srw_ss())[asm_def,upd_pc_def,jump_to_offset_def,upd_reg_def] \\ TRY (Cases_on `i'`) \\ full_simp_tac(srw_ss())[inst_def] \\ full_simp_tac(srw_ss())[asm_def,upd_pc_def,jump_to_offset_def,upd_reg_def] @@ -349,83 +383,102 @@ Theorem asm_consts[simp] \\ TRY (Cases_on `r`) \\ EVAL_TAC \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] \\ CONV_TAC (DEPTH_CONV PairRules.PBETA_CONV) - \\ full_simp_tac(srw_ss())[SND_read_mem_word_consts,write_mem_word_consts]) + \\ full_simp_tac(srw_ss())[SND_read_mem_word_consts,write_mem_word_consts] +QED -Theorem RTC_asm_step_consts - `RTC (λs1 s2. ∃i. asm_step c s1 i s2) s1 s2 +Theorem RTC_asm_step_consts: + RTC (λs1 s2. ∃i. asm_step c s1 i s2) s1 s2 ⇒ (s2.mem_domain = s1.mem_domain) ∧ (s2.lr = s1.lr) ∧ (s2.align = s1.align) ∧ - (s2.be = s1.be)` - (rw[] + (s2.be = s1.be) +Proof + rw[] \\ first_assum(mp_then (Pat`RTC`) mp_tac (GEN_ALL RTC_lifts_invariants)) \\ disch_then ho_match_mp_tac \\ rw[] \\ fs[asmSemTheory.asm_step_def] - \\ rw[]); + \\ rw[] +QED -Theorem read_mem_word_IMP_mem_eq - `!a k s w s'. (read_mem_word a k s = (w,s')) ==> (s'.mem = s.mem)` - (Induct_on `k` \\ fs [asmSemTheory.read_mem_word_def] +Theorem read_mem_word_IMP_mem_eq: + !a k s w s'. (read_mem_word a k s = (w,s')) ==> (s'.mem = s.mem) +Proof + Induct_on `k` \\ fs [asmSemTheory.read_mem_word_def] \\ rw [] \\ pairarg_tac \\ fs [] \\ res_tac \\ fs [asmSemTheory.assert_def] - \\ rveq \\ fs []); + \\ rveq \\ fs [] +QED -Theorem write_mem_word_mem_domain - `!k b a s. (write_mem_word b k a s).mem_domain = s.mem_domain` - (Induct \\ fs [asmSemTheory.write_mem_word_def, - asmSemTheory.assert_def,asmSemTheory.upd_mem_def]); +Theorem write_mem_word_mem_domain: + !k b a s. (write_mem_word b k a s).mem_domain = s.mem_domain +Proof + Induct \\ fs [asmSemTheory.write_mem_word_def, + asmSemTheory.assert_def,asmSemTheory.upd_mem_def] +QED -Theorem write_mem_word_mem_eq - `!k b a s x. +Theorem write_mem_word_mem_eq: + !k b a s x. ~(write_mem_word b k a s).failed /\ x ∉ s.mem_domain ==> - ((write_mem_word b k a s).mem x = s.mem x)` - (Induct \\ fs [asmSemTheory.write_mem_word_def,APPLY_UPDATE_THM, + ((write_mem_word b k a s).mem x = s.mem x) +Proof + Induct \\ fs [asmSemTheory.write_mem_word_def,APPLY_UPDATE_THM, asmSemTheory.assert_def,asmSemTheory.upd_mem_def] \\ fs [write_mem_word_mem_domain] - \\ rw [] \\ res_tac \\ fs []); - -Theorem mem_op_outside_mem_domain - `∀m n a s x. x ∉ s.mem_domain ∧ ¬(mem_op m n a s).failed ⇒ - ((asmSem$mem_op m n a s).mem x = s.mem x)` - (Cases \\ rw[asmSemTheory.mem_op_def] + \\ rw [] \\ res_tac \\ fs [] +QED + +Theorem mem_op_outside_mem_domain: + ∀m n a s x. x ∉ s.mem_domain ∧ ¬(mem_op m n a s).failed ⇒ + ((asmSem$mem_op m n a s).mem x = s.mem x) +Proof + Cases \\ rw[asmSemTheory.mem_op_def] \\ fs[asmSemTheory.mem_load_def, asmSemTheory.mem_store_def, asmSemTheory.upd_reg_def, asmSemTheory.assert_def] \\ TRY pairarg_tac \\ fs[] \\ imp_res_tac read_mem_word_IMP_mem_eq \\ fs [] - \\ match_mp_tac write_mem_word_mem_eq \\ fs []); + \\ match_mp_tac write_mem_word_mem_eq \\ fs [] +QED -Theorem inst_outside_mem_domain - `∀i. x ∉ s.mem_domain ∧ ¬(inst i s).failed ⇒ ((inst i s).mem x = s.mem x)` - (Cases \\ rw[asmSemTheory.inst_def] +Theorem inst_outside_mem_domain: + ∀i. x ∉ s.mem_domain ∧ ¬(inst i s).failed ⇒ ((inst i s).mem x = s.mem x) +Proof + Cases \\ rw[asmSemTheory.inst_def] >- EVAL_TAC - \\ rw[mem_op_outside_mem_domain]); + \\ rw[mem_op_outside_mem_domain] +QED -Theorem asm_outside_mem_domain - `∀i p s x. x ∉ s.mem_domain ∧ ¬(asm i p s).failed ⇒ ((asm i p s).mem x = s.mem x)` - (ho_match_mp_tac asmTheory.asm_induction +Theorem asm_outside_mem_domain: + ∀i p s x. x ∉ s.mem_domain ∧ ¬(asm i p s).failed ⇒ ((asm i p s).mem x = s.mem x) +Proof + ho_match_mp_tac asmTheory.asm_induction \\ rw[asmSemTheory.asm_def] >- rw[inst_outside_mem_domain] >- rw[asmSemTheory.jump_to_offset_def] >- rw[asmSemTheory.jump_to_offset_def] >- (rw[asmSemTheory.jump_to_offset_def] >- EVAL_TAC) >- EVAL_TAC - >- EVAL_TAC); - -Theorem asm_step_outside_mem_domain - `asm_step c s1 i s2 ⇒ - (∀x. x ∉ s1.mem_domain ⇒ (s2.mem x = s1.mem x))` - (rw[asmSemTheory.asm_step_def] - \\ rw[asm_outside_mem_domain]); - -Theorem RTC_asm_step_outside_mem_domain - `∀s1 s2. RTC (λs1 s2. ∃i. asm_step c s1 i s2) s1 s2 - ⇒ (∀a. a ∉ s1.mem_domain ⇒ (s2.mem a = s1.mem a))` - (ho_match_mp_tac RTC_INDUCT + >- EVAL_TAC +QED + +Theorem asm_step_outside_mem_domain: + asm_step c s1 i s2 ⇒ + (∀x. x ∉ s1.mem_domain ⇒ (s2.mem x = s1.mem x)) +Proof + rw[asmSemTheory.asm_step_def] + \\ rw[asm_outside_mem_domain] +QED + +Theorem RTC_asm_step_outside_mem_domain: + ∀s1 s2. RTC (λs1 s2. ∃i. asm_step c s1 i s2) s1 s2 + ⇒ (∀a. a ∉ s1.mem_domain ⇒ (s2.mem a = s1.mem a)) +Proof + ho_match_mp_tac RTC_INDUCT \\ rw[] \\ drule asm_step_outside_mem_domain \\ disch_then drule \\ rw[] \\ fs[asmSemTheory.asm_step_def] - \\ metis_tac[asm_consts]); + \\ metis_tac[asm_consts] +QED val () = export_theory () diff --git a/compiler/encoders/mips/proofs/mips_targetProofScript.sml b/compiler/encoders/mips/proofs/mips_targetProofScript.sml index 12cab506eb..9bd3b626f3 100644 --- a/compiler/encoders/mips/proofs/mips_targetProofScript.sml +++ b/compiler/encoders/mips/proofs/mips_targetProofScript.sml @@ -477,9 +477,10 @@ val mips_target_ok = Q.prove ( val print_tac = asmLib.print_tac "correct" -Theorem mips_encoder_correct - `encoder_correct mips_target` - (simp [asmPropsTheory.encoder_correct_def, mips_target_ok] +Theorem mips_encoder_correct: + encoder_correct mips_target +Proof + simp [asmPropsTheory.encoder_correct_def, mips_target_ok] \\ qabbrev_tac `state_rel = target_state_rel mips_target` \\ rw [mips_target_def, mips_config, asmSemTheory.asm_step_def] \\ qunabbrev_tac `state_rel` @@ -696,6 +697,6 @@ Theorem mips_encoder_correct ] \\ next_tac ) - ) +QED val () = export_theory () diff --git a/compiler/encoders/monadic_enc/monadic_enc32Script.sml b/compiler/encoders/monadic_enc/monadic_enc32Script.sml index 652d8b51f6..48f0d23719 100644 --- a/compiler/encoders/monadic_enc/monadic_enc32Script.sml +++ b/compiler/encoders/monadic_enc/monadic_enc32Script.sml @@ -118,47 +118,55 @@ val enc_secs_32_def = Define` val msimps = [st_ex_bind_def,st_ex_return_def]; -Theorem Msub_eqn[simp] ` - ∀e n ls v. +Theorem Msub_eqn[simp]: + ∀e n ls v. Msub e n ls = if n < LENGTH ls then Success (EL n ls) - else Failure e` - (ho_match_mp_tac Msub_ind>>rw[]>> + else Failure e +Proof + ho_match_mp_tac Msub_ind>>rw[]>> simp[Once Msub_def]>> Cases_on`ls`>>fs[]>> IF_CASES_TAC>>fs[]>> - Cases_on`n`>>fs[]); + Cases_on`n`>>fs[] +QED -Theorem hash_tab_32_sub_eqn[simp] ` - hash_tab_32_sub n s = +Theorem hash_tab_32_sub_eqn[simp]: + hash_tab_32_sub n s = if n < LENGTH s.hash_tab_32 then (Success (EL n s.hash_tab_32),s) else - (Failure (Subscript),s)` - (rw[fetch "-" "hash_tab_32_sub_def"]>> - fs[Marray_sub_def]); - -Theorem Mupdate_eqn[simp] ` - ∀e x n ls. + (Failure (Subscript),s) +Proof + rw[fetch "-" "hash_tab_32_sub_def"]>> + fs[Marray_sub_def] +QED + +Theorem Mupdate_eqn[simp]: + ∀e x n ls. Mupdate e x n ls = if n < LENGTH ls then Success (LUPDATE x n ls) else - Failure e` - (ho_match_mp_tac Mupdate_ind>>rw[]>> + Failure e +Proof + ho_match_mp_tac Mupdate_ind>>rw[]>> simp[Once Mupdate_def]>> Cases_on`ls`>>fs[]>> IF_CASES_TAC>>fs[LUPDATE_def]>> - Cases_on`n`>>fs[LUPDATE_def]); + Cases_on`n`>>fs[LUPDATE_def] +QED -Theorem update_hash_tab_32_eqn[simp] ` - update_hash_tab_32 n t s = +Theorem update_hash_tab_32_eqn[simp]: + update_hash_tab_32 n t s = if n < LENGTH s.hash_tab_32 then (Success (),s with hash_tab_32 := LUPDATE t n s.hash_tab_32) else - (Failure (Subscript),s)` - (rw[fetch "-" "update_hash_tab_32_def"]>> - fs[Marray_update_def]); + (Failure (Subscript),s) +Proof + rw[fetch "-" "update_hash_tab_32_def"]>> + fs[Marray_update_def] +QED val good_table_32_def = Define` good_table_32 enc n s ⇔ diff --git a/compiler/encoders/monadic_enc/monadic_enc64Script.sml b/compiler/encoders/monadic_enc/monadic_enc64Script.sml index ba3981d018..215528939e 100644 --- a/compiler/encoders/monadic_enc/monadic_enc64Script.sml +++ b/compiler/encoders/monadic_enc/monadic_enc64Script.sml @@ -118,47 +118,55 @@ val enc_secs_64_def = Define` val msimps = [st_ex_bind_def,st_ex_return_def]; -Theorem Msub_eqn[simp] ` - ∀e n ls v. +Theorem Msub_eqn[simp]: + ∀e n ls v. Msub e n ls = if n < LENGTH ls then Success (EL n ls) - else Failure e` - (ho_match_mp_tac Msub_ind>>rw[]>> + else Failure e +Proof + ho_match_mp_tac Msub_ind>>rw[]>> simp[Once Msub_def]>> Cases_on`ls`>>fs[]>> IF_CASES_TAC>>fs[]>> - Cases_on`n`>>fs[]); + Cases_on`n`>>fs[] +QED -Theorem hash_tab_64_sub_eqn[simp] ` - hash_tab_64_sub n s = +Theorem hash_tab_64_sub_eqn[simp]: + hash_tab_64_sub n s = if n < LENGTH s.hash_tab_64 then (Success (EL n s.hash_tab_64),s) else - (Failure (Subscript),s)` - (rw[fetch "-" "hash_tab_64_sub_def"]>> - fs[Marray_sub_def]); - -Theorem Mupdate_eqn[simp] ` - ∀e x n ls. + (Failure (Subscript),s) +Proof + rw[fetch "-" "hash_tab_64_sub_def"]>> + fs[Marray_sub_def] +QED + +Theorem Mupdate_eqn[simp]: + ∀e x n ls. Mupdate e x n ls = if n < LENGTH ls then Success (LUPDATE x n ls) else - Failure e` - (ho_match_mp_tac Mupdate_ind>>rw[]>> + Failure e +Proof + ho_match_mp_tac Mupdate_ind>>rw[]>> simp[Once Mupdate_def]>> Cases_on`ls`>>fs[]>> IF_CASES_TAC>>fs[LUPDATE_def]>> - Cases_on`n`>>fs[LUPDATE_def]); + Cases_on`n`>>fs[LUPDATE_def] +QED -Theorem update_hash_tab_64_eqn[simp] ` - update_hash_tab_64 n t s = +Theorem update_hash_tab_64_eqn[simp]: + update_hash_tab_64 n t s = if n < LENGTH s.hash_tab_64 then (Success (),s with hash_tab_64 := LUPDATE t n s.hash_tab_64) else - (Failure (Subscript),s)` - (rw[fetch "-" "update_hash_tab_64_def"]>> - fs[Marray_update_def]); + (Failure (Subscript),s) +Proof + rw[fetch "-" "update_hash_tab_64_def"]>> + fs[Marray_update_def] +QED val good_table_64_def = Define` good_table_64 enc n s ⇔ diff --git a/compiler/encoders/riscv/proofs/riscv_targetProofScript.sml b/compiler/encoders/riscv/proofs/riscv_targetProofScript.sml index 6e2ced8915..9719cd3436 100644 --- a/compiler/encoders/riscv/proofs/riscv_targetProofScript.sml +++ b/compiler/encoders/riscv/proofs/riscv_targetProofScript.sml @@ -149,9 +149,11 @@ val ror = Q.prove( (* appears to not be relevant -Theorem DecodeAny_encode[simp] - `!encode x. DecodeAny (Word (encode x)) = Decode (encode x)` - (rw [riscv_stepTheory.Decode_IMP_DecodeAny]); +Theorem DecodeAny_encode[simp]: + !encode x. DecodeAny (Word (encode x)) = Decode (encode x) +Proof + rw [riscv_stepTheory.Decode_IMP_DecodeAny] +QED *) @@ -478,9 +480,10 @@ val riscv_target_ok = Q.prove ( val print_tac = asmLib.print_tac "correct" -Theorem riscv_encoder_correct - `encoder_correct riscv_target` - (simp [asmPropsTheory.encoder_correct_def, riscv_target_ok] +Theorem riscv_encoder_correct: + encoder_correct riscv_target +Proof + simp [asmPropsTheory.encoder_correct_def, riscv_target_ok] \\ qabbrev_tac `state_rel = target_state_rel riscv_target` \\ rw [riscv_target_def, riscv_config, asmSemTheory.asm_step_def] \\ qunabbrev_tac `state_rel` @@ -657,6 +660,6 @@ Theorem riscv_encoder_correct print_tac "Loc" \\ next_tac ) - ) +QED val () = export_theory () diff --git a/compiler/encoders/x64/proofs/x64_targetProofScript.sml b/compiler/encoders/x64/proofs/x64_targetProofScript.sml index ba4a03d7d9..c10b0f4769 100644 --- a/compiler/encoders/x64/proofs/x64_targetProofScript.sml +++ b/compiler/encoders/x64/proofs/x64_targetProofScript.sml @@ -880,9 +880,10 @@ val x64_target_ok = Q.prove ( val print_tac = asmLib.print_tac ""; -Theorem x64_encoder_correct - `encoder_correct x64_target` - (simp [asmPropsTheory.encoder_correct_def, x64_target_ok] +Theorem x64_encoder_correct: + encoder_correct x64_target +Proof + simp [asmPropsTheory.encoder_correct_def, x64_target_ok] \\ qabbrev_tac `state_rel = target_state_rel x64_target` \\ rw [x64_target_def, x64_config, asmSemTheory.asm_step_def] \\ qunabbrev_tac `state_rel` @@ -1243,6 +1244,6 @@ Theorem x64_encoder_correct print_tac "Loc" \\ next_tac [] ) - ) +QED val () = export_theory () diff --git a/compiler/inference/inferScript.sml b/compiler/inference/inferScript.sml index 04a8c0a5b8..cb42436cd9 100644 --- a/compiler/inference/inferScript.sml +++ b/compiler/inference/inferScript.sml @@ -620,13 +620,14 @@ Theorem constrain_op_pmatch >> rpt(CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac) >> fs[constrain_op_def]); -Theorem constrain_op_error_msg_sanity -`!l op args s l' s' msg. +Theorem constrain_op_error_msg_sanity: + !l op args s l' s' msg. LENGTH args = SND (op_to_string op) ∧ constrain_op l op args s = (Failure (l',msg), s') ⇒ - IS_PREFIX (explode msg) "Type mismatch"` - (rpt strip_tac >> + IS_PREFIX (explode msg) "Type mismatch" +Proof + rpt strip_tac >> qmatch_abbrev_tac `IS_PREFIX _ m` >> cases_on `op` >> fs [op_to_string_def, constrain_op_def] >> @@ -635,7 +636,8 @@ Theorem constrain_op_error_msg_sanity every_case_tac >> fs [] >> rw [] >> - fs [mlstringTheory.concat_thm, Abbr `m`]); + fs [mlstringTheory.concat_thm, Abbr `m`] +QED val infer_e_def = tDefine "infer_e" ` (infer_e l ienv (Raise e) = diff --git a/compiler/inference/infer_tScript.sml b/compiler/inference/infer_tScript.sml index 68f1a9b196..103df856f5 100644 --- a/compiler/inference/infer_tScript.sml +++ b/compiler/inference/infer_tScript.sml @@ -146,8 +146,8 @@ val t = mk_sum t t *) (* -Theorem inf_type_to_string_pmatch - `(∀t. inf_type_to_string t = +Theorem inf_type_to_string_pmatch: + (∀t. inf_type_to_string t = case t of Infer_Tuvar n => concat [implode ""] @@ -167,10 +167,12 @@ Theorem inf_type_to_string_pmatch case ts of [] => implode "" | [t] => inf_type_to_string t - | t::ts => concat [inf_type_to_string t; implode ", "; inf_types_to_string ts])` - (rpt strip_tac + | t::ts => concat [inf_type_to_string t; implode ", "; inf_types_to_string ts]) +Proof + rpt strip_tac >> rpt(CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac) - >> fs[inf_type_to_string_def]); + >> fs[inf_type_to_string_def] +QED *) val _ = export_theory (); diff --git a/compiler/inference/proofs/envRelScript.sml b/compiler/inference/proofs/envRelScript.sml index 46f0c7082c..92524384e0 100644 --- a/compiler/inference/proofs/envRelScript.sml +++ b/compiler/inference/proofs/envRelScript.sml @@ -29,39 +29,47 @@ convert_decls idecls = defined_types := set idecls.inf_defined_types; defined_exns := set idecls.inf_defined_exns|>`; -Theorem convert_append_decls -`!decls1 decls2. convert_decls (append_decls decls1 decls2) = union_decls (convert_decls decls1) (convert_decls decls2)` - (rw [convert_decls_def, append_decls_def, union_decls_def]); +Theorem convert_append_decls: + !decls1 decls2. convert_decls (append_decls decls1 decls2) = union_decls (convert_decls decls1) (convert_decls decls2) +Proof + rw [convert_decls_def, append_decls_def, union_decls_def] +QED *) -Theorem check_convert_freevars -`(!tvs uvs t. check_t tvs uvs t ⇒ (uvs = {}) ⇒ check_freevars tvs [] (convert_t t))` -(ho_match_mp_tac check_t_ind >> +Theorem check_convert_freevars: + (!tvs uvs t. check_t tvs uvs t ⇒ (uvs = {}) ⇒ check_freevars tvs [] (convert_t t)) +Proof +ho_match_mp_tac check_t_ind >> rw [check_freevars_def, check_t_def, convert_t_def] >> fs [EVERY_MEM, MEM_MAP] >> -metis_tac []); +metis_tac [] +QED -Theorem check_t_to_check_freevars -`!tvs (n:num set) t. check_t tvs {} t ⇒ check_freevars tvs [] (convert_t t)` -(ho_match_mp_tac check_t_ind >> +Theorem check_t_to_check_freevars: + !tvs (n:num set) t. check_t tvs {} t ⇒ check_freevars tvs [] (convert_t t) +Proof +ho_match_mp_tac check_t_ind >> rw [check_t_def, check_freevars_def, convert_t_def, EVERY_MAP] >> -fs [EVERY_MEM]); +fs [EVERY_MEM] +QED -Theorem convert_inc -`!t tvs tvs'. +Theorem convert_inc: + !t tvs tvs'. check_t tvs' {} t ⇒ - (convert_t (infer_deBruijn_inc tvs t) = deBruijn_inc 0 tvs (convert_t t))` -(ho_match_mp_tac (fetch "-" "convert_t_ind") >> + (convert_t (infer_deBruijn_inc tvs t) = deBruijn_inc 0 tvs (convert_t t)) +Proof +ho_match_mp_tac (fetch "-" "convert_t_ind") >> rw [check_t_def, convert_t_def, infer_deBruijn_inc_def, deBruijn_inc_def] >> induct_on `ts` >> fs [] >> -metis_tac []); +metis_tac [] +QED val infer_t_induction = infer_tTheory.infer_t_induction; -Theorem db_subst_infer_subst_swap -`(!t s tvs uvar n. +Theorem db_subst_infer_subst_swap: + (!t s tvs uvar n. t_wfs s ∧ count (uvar + tvs) ⊆ FDOM s ∧ (!uv. uv ∈ FDOM s ⇒ check_t n {} (t_walkstar s (Infer_Tuvar uv))) ∧ @@ -88,8 +96,9 @@ Theorem db_subst_infer_subst_swap MAP (deBruijn_subst 0 (MAP (convert_t o t_walkstar s) (MAP (λn. Infer_Tuvar (uvar + n)) (COUNT_LIST tvs))) o convert_t o t_walkstar (infer_deBruijn_inc tvs o_f s)) - ts))` -(ho_match_mp_tac infer_t_induction >> + ts)) +Proof +ho_match_mp_tac infer_t_induction >> rw [convert_t_def, deBruijn_subst_def, EL_MAP, t_walkstar_eqn1, infer_deBruijn_subst_def, MAP_MAP_o, combinTheory.o_DEF, check_t_def, LENGTH_COUNT_LIST] >| @@ -108,17 +117,20 @@ rw [convert_t_def, deBruijn_subst_def, EL_MAP, t_walkstar_eqn1, deBruijn_inc0, LENGTH_COUNT_LIST, LENGTH_MAP], metis_tac [], - metis_tac []]); - -Theorem inc_convert_t -`(!t tvs' tvs. check_t tvs' {} t ⇒ (deBruijn_inc tvs' tvs (convert_t t) = convert_t t)) ∧ - (!ts tvs' tvs. EVERY (check_t tvs' {}) ts ⇒ (MAP (deBruijn_inc tvs' tvs o convert_t) ts = MAP convert_t ts))` -(ho_match_mp_tac infer_t_induction >> + metis_tac []] +QED + +Theorem inc_convert_t: + (!t tvs' tvs. check_t tvs' {} t ⇒ (deBruijn_inc tvs' tvs (convert_t t) = convert_t t)) ∧ + (!ts tvs' tvs. EVERY (check_t tvs' {}) ts ⇒ (MAP (deBruijn_inc tvs' tvs o convert_t) ts = MAP convert_t ts)) +Proof +ho_match_mp_tac infer_t_induction >> rw [check_t_def, convert_t_def, deBruijn_inc_def] >> -metis_tac [MAP_MAP_o]); +metis_tac [MAP_MAP_o] +QED -Theorem convert_t_subst -`(!t tvs ts'. +Theorem convert_t_subst: + (!t tvs ts'. (LENGTH tvs = LENGTH ts') ∧ check_freevars 0 tvs t ⇒ convert_t (infer_type_subst (ZIP (tvs,ts')) t) = @@ -127,8 +139,9 @@ Theorem convert_t_subst (LENGTH tvs = LENGTH ts') ∧ EVERY (check_freevars 0 tvs) ts ⇒ MAP convert_t (MAP (infer_type_subst (ZIP (tvs,ts'))) ts) = - MAP (type_subst (alist_to_fmap (ZIP (tvs, MAP convert_t ts')))) ts)` -(ho_match_mp_tac t_induction >> + MAP (type_subst (alist_to_fmap (ZIP (tvs, MAP convert_t ts')))) ts) +Proof +ho_match_mp_tac t_induction >> rw [check_freevars_def, convert_t_def, type_subst_def, infer_type_subst_def] >| [full_case_tac >> full_case_tac >> @@ -143,10 +156,11 @@ rw [check_freevars_def, convert_t_def, type_subst_def, infer_type_subst_def] >| cases_on `tvs` >> fs [] >> metis_tac [optionTheory.SOME_11], - metis_tac []]); + metis_tac []] +QED -Theorem deBruijn_subst_convert ` - (∀t. +Theorem deBruijn_subst_convert: + (∀t. check_t n {} t ⇒ deBruijn_subst 0 (MAP convert_t subst) (convert_t t) = convert_t (infer_deBruijn_subst subst t) ) ∧ @@ -154,42 +168,52 @@ Theorem deBruijn_subst_convert ` EVERY (check_t n {}) ts ⇒ MAP ((deBruijn_subst 0 (MAP convert_t subst)) o convert_t) ts = - MAP (convert_t o (infer_deBruijn_subst subst)) ts)` - (ho_match_mp_tac infer_tTheory.infer_t_induction>> + MAP (convert_t o (infer_deBruijn_subst subst)) ts) +Proof + ho_match_mp_tac infer_tTheory.infer_t_induction>> rw[check_t_def]>> fs[convert_t_def,deBruijn_subst_def,infer_deBruijn_subst_def] >- (IF_CASES_TAC>>fs[EL_MAP,convert_t_def]) >> - fs[MAP_MAP_o,EVERY_MEM,MAP_EQ_f]); + fs[MAP_MAP_o,EVERY_MEM,MAP_EQ_f] +QED -Theorem check_freevars_empty_convert_unconvert_id -`!t. check_freevars n [] t ⇒ convert_t (unconvert_t t) = t` - (ho_match_mp_tac unconvert_t_ind>> +Theorem check_freevars_empty_convert_unconvert_id: + !t. check_freevars n [] t ⇒ convert_t (unconvert_t t) = t +Proof + ho_match_mp_tac unconvert_t_ind>> rw[]>>fs[unconvert_t_def,convert_t_def,check_freevars_def]>> - fs[MAP_MAP_o,MAP_EQ_ID,EVERY_MEM]) - -Theorem check_t_empty_unconvert_convert_id -`!t n. check_t n {} t ⇒ - unconvert_t (convert_t t) = t` - (ho_match_mp_tac (fetch "-" "convert_t_ind") >> + fs[MAP_MAP_o,MAP_EQ_ID,EVERY_MEM] +QED + +Theorem check_t_empty_unconvert_convert_id: + !t n. check_t n {} t ⇒ + unconvert_t (convert_t t) = t +Proof + ho_match_mp_tac (fetch "-" "convert_t_ind") >> rw[]>> fs[unconvert_t_def,convert_t_def,check_t_def]>> fs[MAP_MAP_o,MAP_EQ_ID,EVERY_MEM] >> - metis_tac []); + metis_tac [] +QED -Theorem check_freevars_to_check_t -`!t z. check_freevars n [] t ⇒ check_t n {} (unconvert_t t)` - (ho_match_mp_tac unconvert_t_ind>>rw[]>> +Theorem check_freevars_to_check_t: + !t z. check_freevars n [] t ⇒ check_t n {} (unconvert_t t) +Proof + ho_match_mp_tac unconvert_t_ind>>rw[]>> fs[unconvert_t_def,check_freevars_def,check_t_def]>> - fs[EVERY_MAP,EVERY_MEM]) - -Theorem infer_type_subst_nil - `(∀t. check_freevars n [] t ⇒ infer_type_subst [] t = unconvert_t t) ∧ - (∀ts. EVERY (check_freevars n []) ts ⇒ MAP (infer_type_subst []) ts = MAP unconvert_t ts)` - (ho_match_mp_tac(TypeBase.induction_of(``:t``)) >> + fs[EVERY_MAP,EVERY_MEM] +QED + +Theorem infer_type_subst_nil: + (∀t. check_freevars n [] t ⇒ infer_type_subst [] t = unconvert_t t) ∧ + (∀ts. EVERY (check_freevars n []) ts ⇒ MAP (infer_type_subst []) ts = MAP unconvert_t ts) +Proof + ho_match_mp_tac(TypeBase.induction_of(``:t``)) >> rw[infer_type_subst_def,convert_t_def,unconvert_t_def,check_freevars_def] >> - fsrw_tac[boolSimps.ETA_ss][]); + fsrw_tac[boolSimps.ETA_ss][] +QED (* ---------- relating inference and type system environments ---------- *) @@ -241,8 +265,8 @@ val tscheme_approx_def = Define ` t_walkstar s (infer_deBruijn_subst subst t) = t_walkstar s (infer_deBruijn_subst (MAP (infer_deBruijn_subst subst) subst') t')`; -Theorem tscheme_approx_thm - `∀t' max_tvs s tvs tvs' t. +Theorem tscheme_approx_thm: + ∀t' max_tvs s tvs tvs' t. t_wfs s ⇒ (tscheme_approx max_tvs s (tvs,t) (tvs',t') ⇒ ∀subst. @@ -252,34 +276,39 @@ Theorem tscheme_approx_thm ∃subst'. LENGTH subst' = tvs' ∧ EVERY (check_t max_tvs (FDOM s)) subst' ∧ - t_walkstar s (infer_deBruijn_subst subst t) = t_walkstar s (infer_deBruijn_subst subst' t'))` - (rw [tscheme_approx_def] + t_walkstar s (infer_deBruijn_subst subst t) = t_walkstar s (infer_deBruijn_subst subst' t')) +Proof + rw [tscheme_approx_def] >> qexists_tac `MAP (infer_deBruijn_subst subst) subst'` >> fs [EVERY_MAP, EVERY_MEM] >> rw [] >> first_x_assum drule >> rw [] >> irule check_t_infer_deBruijn_subst - >> metis_tac [EVERY_MEM, check_t_more5, SUBSET_DEF, NOT_IN_EMPTY]); + >> metis_tac [EVERY_MEM, check_t_more5, SUBSET_DEF, NOT_IN_EMPTY] +QED -Theorem tscheme_approx_refl - `!max_tvs s tvs t. tscheme_approx max_tvs s (tvs,t) (tvs,t)` - (rw [tscheme_approx_def] >> +Theorem tscheme_approx_refl: + !max_tvs s tvs t. tscheme_approx max_tvs s (tvs,t) (tvs,t) +Proof + rw [tscheme_approx_def] >> qexists_tac `MAP Infer_Tvar_db (COUNT_LIST tvs)` >> rw [LENGTH_COUNT_LIST, EVERY_MAP, every_count_list, check_t_def, MAP_MAP_o, combinTheory.o_DEF, infer_deBruijn_subst_def] >> irule (METIS_PROVE [] ``y = y' ⇒ f x y = f x y'``) >> irule (METIS_PROVE [] ``y = y' ⇒ f y x = f y' x``) >> irule LIST_EQ >> - rw [LENGTH_COUNT_LIST, EL_MAP, EL_COUNT_LIST]); + rw [LENGTH_COUNT_LIST, EL_MAP, EL_COUNT_LIST] +QED (* TODO: should be able to use max_tvs in place of 0 *) -Theorem tscheme_approx_trans - `tscheme_approx max_tvs s (tvs1,t1) (tvs2,t2) ∧ +Theorem tscheme_approx_trans: + tscheme_approx max_tvs s (tvs1,t1) (tvs2,t2) ∧ tscheme_approx 0 s (tvs2,t2) (tvs3,t3) ⇒ - tscheme_approx max_tvs s (tvs1,t1) (tvs3,t3)` - (rw [tscheme_approx_def] >> + tscheme_approx max_tvs s (tvs1,t1) (tvs3,t3) +Proof + rw [tscheme_approx_def] >> qexists_tac `MAP (infer_deBruijn_subst subst') subst''` >> simp [] >> conj_asm1_tac @@ -296,25 +325,29 @@ Theorem tscheme_approx_trans AP_TERM_TAC >> irule (GSYM (CONJUNCT2 infer_deBruijn_subst_twice)) >> qexists_tac `FDOM s` >> - metis_tac [check_t_more2, ADD_COMM, ADD_ASSOC]); + metis_tac [check_t_more2, ADD_COMM, ADD_ASSOC] +QED -Theorem unconvert_db_subst - `!t subst fvs l. +Theorem unconvert_db_subst: + !t subst fvs l. check_freevars l [] t ⇒ unconvert_t (deBruijn_subst 0 subst t) = - infer_deBruijn_subst (MAP unconvert_t subst) (unconvert_t t)` - (ho_match_mp_tac t_ind >> + infer_deBruijn_subst (MAP unconvert_t subst) (unconvert_t t) +Proof + ho_match_mp_tac t_ind >> rw [deBruijn_subst_def, unconvert_t_def, infer_deBruijn_subst_def, check_freevars_def, EL_MAP] >> irule LIST_EQ >> rw [EL_MAP] >> fs [EVERY_MEM, MEM_EL] >> - metis_tac []); - -Theorem tscheme_inst_to_approx - `tscheme_inst (tvs,t) (tvs',t') ⇒ - tscheme_approx 0 FEMPTY (tvs,unconvert_t t) (tvs',unconvert_t t')` - (rw [tscheme_inst_def, tscheme_approx_def, t_walkstar_FEMPTY] >> + metis_tac [] +QED + +Theorem tscheme_inst_to_approx: + tscheme_inst (tvs,t) (tvs',t') ⇒ + tscheme_approx 0 FEMPTY (tvs,unconvert_t t) (tvs',unconvert_t t') +Proof + rw [tscheme_inst_def, tscheme_approx_def, t_walkstar_FEMPTY] >> qexists_tac `MAP unconvert_t subst` >> rw [EVERY_MAP] >- ( @@ -328,7 +361,8 @@ Theorem tscheme_inst_to_approx `check_t (LENGTH (MAP unconvert_t subst)) {} (unconvert_t t')` by rw [] >> `check_t (LENGTH (MAP unconvert_t subst)) uvs (unconvert_t t')` by metis_tac [check_t_more] >> drule (GEN_ALL (CONJUNCT1 infer_deBruijn_subst_twice)) >> - rw [MAP_MAP_o, combinTheory.o_DEF]); + rw [MAP_MAP_o, combinTheory.o_DEF] +QED val env_rel_sound_def = Define ` env_rel_sound s ienv tenv tenvE ⇔ @@ -342,13 +376,14 @@ val env_rel_sound_def = Define ` lookup_var x tenvE tenv = SOME (tvs', t') ∧ tscheme_approx (num_tvs tenvE) s ts (tvs', unconvert_t t')`; -Theorem env_rel_sound_lookup_none - `!ienv tenv s tenvE id. +Theorem env_rel_sound_lookup_none: + !ienv tenv s tenvE id. env_rel_sound s ienv tenv tenvE ∧ lookup_var id tenvE tenv = NONE ⇒ - nsLookup ienv.inf_v id = NONE` - (rw [env_rel_sound_def, lookup_var_def] >> + nsLookup ienv.inf_v id = NONE +Proof + rw [env_rel_sound_def, lookup_var_def] >> every_case_tac >> fs [] >> CCONTR_TAC >> @@ -357,27 +392,31 @@ Theorem env_rel_sound_lookup_none first_x_assum drule >> strip_tac >> every_case_tac >> - fs []); + fs [] +QED -Theorem env_rel_sound_lookup_some - `!id ts s ienv tenv tenvE. +Theorem env_rel_sound_lookup_some: + !id ts s ienv tenv tenvE. nsLookup ienv.inf_v id = SOME ts ∧ env_rel_sound s ienv tenv tenvE ⇒ ?tvs' t'. check_freevars (tvs' + num_tvs tenvE) [] t' ∧ lookup_var id tenvE tenv = SOME (tvs',t') ∧ - tscheme_approx (num_tvs tenvE) s ts (tvs', unconvert_t t')` - (rw [env_rel_sound_def]); + tscheme_approx (num_tvs tenvE) s ts (tvs', unconvert_t t') +Proof + rw [env_rel_sound_def] +QED -Theorem db_subst_infer_subst_swap3 - `!t tvs s subst. +Theorem db_subst_infer_subst_swap3: + !t tvs s subst. t_wfs s ∧ check_freevars tvs [] t ⇒ convert_t (t_walkstar s (infer_deBruijn_subst subst (unconvert_t t))) = - deBruijn_subst 0 (MAP (convert_t o t_walkstar s) subst) t` - (ho_match_mp_tac unconvert_t_ind + deBruijn_subst 0 (MAP (convert_t o t_walkstar s) subst) t +Proof + ho_match_mp_tac unconvert_t_ind >> rw [unconvert_t_def, infer_deBruijn_subst_def, deBruijn_subst_def, check_freevars_def, convert_t_def, t_walkstar_eqn1] >- rw [EL_MAP] @@ -385,17 +424,19 @@ Theorem db_subst_infer_subst_swap3 >> rw [MAP_EQ_f] >> first_x_assum drule >> fs [EVERY_MEM] - >> metis_tac []); + >> metis_tac [] +QED -Theorem tscheme_approx_weakening - `!tvs tvs' s1 s2 ts1 ts2. +Theorem tscheme_approx_weakening: + !tvs tvs' s1 s2 ts1 ts2. tscheme_approx tvs s1 ts1 ts2 ∧ t_wfs s2 ∧ s1 SUBMAP s2 ∧ tvs ≤ tvs' ⇒ - tscheme_approx tvs' s2 ts1 ts2` - (rw [] + tscheme_approx tvs' s2 ts1 ts2 +Proof + rw [] >> Cases_on `ts1` >> Cases_on `ts2` >> fs [tscheme_approx_def] @@ -406,15 +447,17 @@ Theorem tscheme_approx_weakening >- prove_tac [SUBMAP_DEF, check_t_more5, SUBSET_DEF, check_t_more2, ADD_COMM, ADD_ASSOC] >> first_x_assum (qspec_then `subst` mp_tac) >> rw [] - >> metis_tac [t_walkstar_idempotent, t_walkstar_SUBMAP]); + >> metis_tac [t_walkstar_idempotent, t_walkstar_SUBMAP] +QED -Theorem env_rel_sound_extend_tvs - `!s ienv tenv bindings tvs. +Theorem env_rel_sound_extend_tvs: + !s ienv tenv bindings tvs. t_wfs s ∧ env_rel_sound s ienv tenv Empty ⇒ - env_rel_sound s ienv tenv (bind_tvar tvs Empty)` - (rw [env_rel_sound_def] + env_rel_sound s ienv tenv (bind_tvar tvs Empty) +Proof + rw [env_rel_sound_def] >> first_x_assum drule >> simp [bind_tvar_def, lookup_var_def, lookup_varE_def, tveLookup_def] >> rw [] @@ -424,22 +467,26 @@ Theorem env_rel_sound_extend_tvs >- metis_tac [check_freevars_add,DECIDE ``x+y>=x:num``, ADD_COMM, ADD_ASSOC] >- metis_tac [SUBMAP_REFL, tscheme_approx_weakening, DECIDE ``0n ≤ x``] >- metis_tac [check_freevars_add,DECIDE ``x+y>=x:num``, ADD_COMM, ADD_ASSOC] - >- metis_tac [SUBMAP_REFL, tscheme_approx_weakening, DECIDE ``0n ≤ x``]); + >- metis_tac [SUBMAP_REFL, tscheme_approx_weakening, DECIDE ``0n ≤ x``] +QED -Theorem tscheme_approx0 - `!tvs s t. t_wfs s ⇒ tscheme_approx tvs s (0, t) (0, t_walkstar s t)` - (rw [tscheme_approx_def, LENGTH_NIL, infer_deBruijn_subst_id, t_walkstar_idempotent]); +Theorem tscheme_approx0: + !tvs s t. t_wfs s ⇒ tscheme_approx tvs s (0, t) (0, t_walkstar s t) +Proof + rw [tscheme_approx_def, LENGTH_NIL, infer_deBruijn_subst_id, t_walkstar_idempotent] +QED -Theorem env_rel_sound_extend0 - `!s x t ienv tenv tenvE. +Theorem env_rel_sound_extend0: + !s x t ienv tenv tenvE. env_rel_sound s ienv tenv tenvE ∧ t_wfs s ∧ check_t (num_tvs tenvE) (FDOM s) t ∧ (∀uv. uv ∈ FDOM s ⇒ check_t (num_tvs tenvE) ∅ (t_walkstar s (Infer_Tuvar uv))) ⇒ env_rel_sound s (ienv with inf_v := nsBind x (0,t) ienv.inf_v) - tenv (Bind_name x 0 (convert_t (t_walkstar s t)) tenvE)` - (rw [env_rel_sound_def] + tenv (Bind_name x 0 (convert_t (t_walkstar s t)) tenvE) +Proof + rw [env_rel_sound_def] >> Cases_on `Short x = x'` >> rw [] >> simp [lookup_var_def, lookup_varE_def, tveLookup_def, deBruijn_inc0] @@ -458,10 +505,11 @@ Theorem env_rel_sound_extend0 >> first_x_assum drule >> rw [] >> every_case_tac - >> fs [lookup_var_def, lookup_varE_def])); + >> fs [lookup_var_def, lookup_varE_def]) +QED -Theorem env_rel_sound_merge0 - `!s ienv bindings tenv tenvE. +Theorem env_rel_sound_merge0: + !s ienv bindings tenv tenvE. t_wfs s ∧ (∀uv. uv ∈ FDOM s ⇒ check_t (num_tvs tenvE) ∅ (t_walkstar s (Infer_Tuvar uv))) ∧ EVERY (λ(x,t). check_t 0 (FDOM s) t) bindings ∧ @@ -470,8 +518,9 @@ Theorem env_rel_sound_merge0 env_rel_sound s (ienv with inf_v := nsAppend (alist_to_ns (MAP (λ(n,t). (n,0,t)) bindings)) ienv.inf_v) tenv - (bind_var_list 0 (convert_env s bindings) tenvE)` - (rw [env_rel_sound_def] + (bind_var_list 0 (convert_env s bindings) tenvE) +Proof + rw [env_rel_sound_def] >> fs [nsLookup_nsAppend_some, nsLookup_alist_to_ns_some, nsLookup_alist_to_ns_none] >- ( rw [lookup_var_def, lookup_varE_def, tveLookup_bvl, convert_env_def, deBruijn_inc0] @@ -508,10 +557,11 @@ Theorem env_rel_sound_merge0 >> fs [tveLookup_bvl] >> every_case_tac >> fs [deBruijn_inc0, ALOOKUP_MAP, convert_env_def] - >> fs [])); + >> fs []) +QED -Theorem env_rel_e_sound_letrec_merge0 -`!funs ienv tenv tenvE s uvs. +Theorem env_rel_e_sound_letrec_merge0: + !funs ienv tenv tenvE s uvs. t_wfs s ∧ (∀uv. uv ∈ FDOM s ⇒ check_t (num_tvs tenvE) ∅ (t_walkstar s (Infer_Tuvar uv))) ∧ count (uvs + LENGTH funs) ⊆ FDOM s ∧ @@ -529,8 +579,9 @@ Theorem env_rel_e_sound_letrec_merge0 (bind_var_list 0 (MAP2 (λ(f,x,e) t. (f,t)) funs (MAP (λn. convert_t (t_walkstar s (Infer_Tuvar (uvs + n)))) - (COUNT_LIST (LENGTH funs)))) tenvE)` - (induct_on `funs` >> + (COUNT_LIST (LENGTH funs)))) tenvE) +Proof + induct_on `funs` >> srw_tac[] [COUNT_LIST_def, bind_var_list_def] >> PairCases_on `h` >> srw_tac[] [bind_var_list_def] >> @@ -548,7 +599,8 @@ Theorem env_rel_e_sound_letrec_merge0 simp_tac (srw_ss()++ARITH_ss) [ADD1] >> rw [] >> ONCE_REWRITE_TAC [DECIDE ``n + (x + 1) = x + (n + 1n)``] - >> metis_tac []); + >> metis_tac [] +QED val env_rel_complete_def = Define ` env_rel_complete s ienv tenv tenvE ⇔ @@ -565,25 +617,28 @@ val env_rel_complete_def = Define ` check_t (tvs' + num_tvs tenvE) {} t' ∧*) tscheme_approx (num_tvs tenvE) s (tvs, unconvert_t t) (tvs', t')`; -Theorem env_rel_complete_lookup_none - `!ienv tenv s tenvE x. +Theorem env_rel_complete_lookup_none: + !ienv tenv s tenvE x. env_rel_complete s ienv tenv tenvE ∧ nsLookup ienv.inf_v x = NONE ⇒ - nsLookup tenv.v x = NONE` - (rw [env_rel_complete_def, lookup_var_def] >> + nsLookup tenv.v x = NONE +Proof + rw [env_rel_complete_def, lookup_var_def] >> first_x_assum (qspec_then `x` mp_tac) >> simp [lookup_varE_def] >> every_case_tac >> rw [] >> - metis_tac [option_nchotomy, pair_CASES]); + metis_tac [option_nchotomy, pair_CASES] +QED -Theorem env_rel_e_sound_empty_to -`!s ienv tenv tenvE. +Theorem env_rel_e_sound_empty_to: + !s ienv tenv tenvE. t_wfs s ∧ ienv_ok {} ienv ∧ env_rel_sound FEMPTY ienv tenv tenvE ⇒ - env_rel_sound s ienv tenv tenvE` - (rw [env_rel_sound_def] + env_rel_sound s ienv tenv tenvE +Proof + rw [env_rel_sound_def] >> first_x_assum drule >> rw [] >> rename1 `lookup_var _ _ _ = SOME (tvs', t')` @@ -594,7 +649,8 @@ Theorem env_rel_e_sound_empty_to >> simp [] >> qexists_tac `FEMPTY` >> simp [SUBMAP_FEMPTY] - >> HINT_EXISTS_TAC>>fs[]); + >> HINT_EXISTS_TAC>>fs[] +QED (* Environment relation at infer_d and above *) val env_rel_def = Define` @@ -606,18 +662,21 @@ val env_rel_def = Define` env_rel_sound FEMPTY ienv tenv Empty ∧ env_rel_complete FEMPTY ienv tenv Empty`; -Theorem lookup_varE_empty[simp] - `!x. lookup_varE x Empty = NONE` - (rw [lookup_varE_def, tveLookup_def] >> - every_case_tac); +Theorem lookup_varE_empty[simp]: + !x. lookup_varE x Empty = NONE +Proof + rw [lookup_varE_def, tveLookup_def] >> + every_case_tac +QED -Theorem env_rel_extend - `!tenv1 ienv1 tenv2 ienv2. +Theorem env_rel_extend: + !tenv1 ienv1 tenv2 ienv2. env_rel tenv1 ienv1 ∧ env_rel tenv2 ienv2 ⇒ - env_rel (extend_dec_tenv tenv1 tenv2) (extend_dec_ienv ienv1 ienv2)` - (rpt gen_tac >> + env_rel (extend_dec_tenv tenv1 tenv2) (extend_dec_ienv ienv1 ienv2) +Proof + rpt gen_tac >> simp [env_rel_def] >> strip_tac >> conj_tac @@ -685,19 +744,23 @@ Theorem env_rel_extend rw [] >> qexists_tac `tvs''` >> qexists_tac `t''` >> - simp []))); - -Theorem env_rel_empty[simp] - `env_rel <| v := nsEmpty; c := nsEmpty; t := nsEmpty |> - <| inf_v := nsEmpty; inf_c := nsEmpty; inf_t := nsEmpty |>` - (rw [env_rel_def, ienv_ok_def, ienv_val_ok_def, env_rel_sound_def, + simp [])) +QED + +Theorem env_rel_empty[simp]: + env_rel <| v := nsEmpty; c := nsEmpty; t := nsEmpty |> + <| inf_v := nsEmpty; inf_c := nsEmpty; inf_t := nsEmpty |> +Proof + rw [env_rel_def, ienv_ok_def, ienv_val_ok_def, env_rel_sound_def, lookup_var_def, env_rel_complete_def] >> Cases_on `x` >> - rw [namespaceTheory.nsLookupMod_def]); + rw [namespaceTheory.nsLookupMod_def] +QED -Theorem env_rel_lift - `!tenv ienv mn. env_rel tenv ienv ⇒ env_rel (tenvLift mn tenv) (lift_ienv mn ienv)` - (rw [env_rel_def] +Theorem env_rel_lift: + !tenv ienv mn. env_rel tenv ienv ⇒ env_rel (tenvLift mn tenv) (lift_ienv mn ienv) +Proof + rw [env_rel_def] >- metis_tac [ienv_ok_lift] >- fs [typeSoundInvariantsTheory.tenv_ok_def, tenvLift_def, typeSoundInvariantsTheory.tenv_abbrev_ok_def, @@ -725,7 +788,8 @@ Theorem env_rel_lift fs [] >> rw [] >> first_x_assum drule >> - rw [])); + rw []) +QED val ienv_to_tenv_def = Define ` ienv_to_tenv ienv = @@ -733,19 +797,24 @@ val ienv_to_tenv_def = Define ` c := ienv.inf_c; t := ienv.inf_t |>`; -Theorem ienv_to_tenv_extend - `!ienv1 ienv2. +Theorem ienv_to_tenv_extend: + !ienv1 ienv2. ienv_to_tenv (extend_dec_ienv ienv2 ienv1) = - extend_dec_tenv (ienv_to_tenv ienv2) (ienv_to_tenv ienv1)` - (rw [ienv_to_tenv_def, extend_dec_tenv_def, extend_dec_ienv_def, nsMap_nsAppend]); - -Theorem ienv_to_tenv_lift - `!mn ienv. ienv_to_tenv (lift_ienv mn ienv) = tenvLift mn (ienv_to_tenv ienv)` - (rw [ienv_to_tenv_def, lift_ienv_def, tenvLift_def, nsLift_nsMap]); - -Theorem env_rel_ienv_to_tenv - `!ienv. ienv_ok {} ienv ⇒ env_rel (ienv_to_tenv ienv) ienv` - (rw [env_rel_def, ienv_to_tenv_def] + extend_dec_tenv (ienv_to_tenv ienv2) (ienv_to_tenv ienv1) +Proof + rw [ienv_to_tenv_def, extend_dec_tenv_def, extend_dec_ienv_def, nsMap_nsAppend] +QED + +Theorem ienv_to_tenv_lift: + !mn ienv. ienv_to_tenv (lift_ienv mn ienv) = tenvLift mn (ienv_to_tenv ienv) +Proof + rw [ienv_to_tenv_def, lift_ienv_def, tenvLift_def, nsLift_nsMap] +QED + +Theorem env_rel_ienv_to_tenv: + !ienv. ienv_ok {} ienv ⇒ env_rel (ienv_to_tenv ienv) ienv +Proof + rw [env_rel_def, ienv_to_tenv_def] >- ( fs [ienv_ok_def, typeSoundInvariantsTheory.tenv_ok_def, typeSoundInvariantsTheory.tenv_val_ok_def] >> @@ -794,7 +863,8 @@ Theorem env_rel_ienv_to_tenv rw [] >- metis_tac [check_t_to_check_freevars] >> drule check_t_empty_unconvert_convert_id >> - rw [tscheme_approx_refl])); + rw [tscheme_approx_refl]) +QED val tenv_to_ienv_def = Define ` tenv_to_ienv tenv = @@ -802,15 +872,18 @@ val tenv_to_ienv_def = Define ` inf_c := tenv.c; inf_t := tenv.t |>`; -Theorem tenv_to_ienv_extend - `!tenv1 tenv2. +Theorem tenv_to_ienv_extend: + !tenv1 tenv2. tenv_to_ienv (extend_dec_tenv tenv2 tenv1) = - extend_dec_ienv (tenv_to_ienv tenv2) (tenv_to_ienv tenv1)` - (rw [tenv_to_ienv_def, extend_dec_tenv_def, extend_dec_ienv_def, nsMap_nsAppend]); - -Theorem env_rel_tenv_to_ienv - `!tenv. tenv_ok tenv ⇒ env_rel tenv (tenv_to_ienv tenv)` - (rw [env_rel_def, tenv_to_ienv_def] + extend_dec_ienv (tenv_to_ienv tenv2) (tenv_to_ienv tenv1) +Proof + rw [tenv_to_ienv_def, extend_dec_tenv_def, extend_dec_ienv_def, nsMap_nsAppend] +QED + +Theorem env_rel_tenv_to_ienv: + !tenv. tenv_ok tenv ⇒ env_rel tenv (tenv_to_ienv tenv) +Proof + rw [env_rel_def, tenv_to_ienv_def] >- ( fs [ienv_ok_def, typeSoundInvariantsTheory.tenv_ok_def, typeSoundInvariantsTheory.tenv_val_ok_def] >> @@ -854,10 +927,13 @@ Theorem env_rel_tenv_to_ienv drule nsLookup_nsAll >> disch_then drule >> simp [] >> - metis_tac [])); - -Theorem tenv_to_ienv_lift - `!mn tenv. tenv_to_ienv (tenvLift mn tenv) = lift_ienv mn (tenv_to_ienv tenv)` - (rw [tenv_to_ienv_def, lift_ienv_def, tenvLift_def, namespacePropsTheory.nsLift_nsMap]); + metis_tac []) +QED + +Theorem tenv_to_ienv_lift: + !mn tenv. tenv_to_ienv (tenvLift mn tenv) = lift_ienv mn (tenv_to_ienv tenv) +Proof + rw [tenv_to_ienv_def, lift_ienv_def, tenvLift_def, namespacePropsTheory.nsLift_nsMap] +QED val _ = export_theory (); diff --git a/compiler/inference/proofs/inferCompleteScript.sml b/compiler/inference/proofs/inferCompleteScript.sml index 483179dde2..d4db8a3e11 100644 --- a/compiler/inference/proofs/inferCompleteScript.sml +++ b/compiler/inference/proofs/inferCompleteScript.sml @@ -96,8 +96,8 @@ Proof fs [EVERY_EL]) QED -Theorem env_rel_binding_lemma2 - `!t fvs fvs' subst. +Theorem env_rel_binding_lemma2: + !t fvs fvs' subst. check_freevars 0 fvs' t ∧ set fvs' ⊆ set fvs ∧ ALL_DISTINCT fvs' @@ -110,8 +110,9 @@ Theorem env_rel_binding_lemma2 (case find_index (EL n fvs') fvs 0 of NONE => Infer_Tapp [] TC_int | SOME t => Infer_Tvar_db t)) (LENGTH fvs')) - (infer_type_subst (ZIP (fvs',MAP Infer_Tvar_db (COUNT_LIST (LENGTH fvs')))) t)` - (ho_match_mp_tac t_ind >> + (infer_type_subst (ZIP (fvs',MAP Infer_Tvar_db (COUNT_LIST (LENGTH fvs')))) t) +Proof + ho_match_mp_tac t_ind >> rw [infer_type_subst_def, infer_deBruijn_subst_def, check_freevars_def] >- ( qmatch_assum_abbrev_tac `MEM name _` >> @@ -145,18 +146,20 @@ Theorem env_rel_binding_lemma2 >- ( irule LIST_EQ >> rw [EL_MAP] >> - fs [EVERY_EL])); + fs [EVERY_EL]) +QED -Theorem unconvert_type_subst - `(!t subst fvs. +Theorem unconvert_type_subst: + (!t subst fvs. check_freevars 0 fvs t ∧ set fvs ⊆ set (MAP FST subst) ⇒ unconvert_t (type_subst (alist_to_fmap subst) t) = infer_type_subst (MAP (\(x,y). (x, unconvert_t y)) subst) t) ∧ (!ts subst fvs. EVERY (check_freevars 0 fvs) ts ∧ set fvs ⊆ set (MAP FST subst) ⇒ MAP (unconvert_t o type_subst (alist_to_fmap subst)) ts = - MAP (infer_type_subst (MAP (\(x,y). (x, unconvert_t y)) subst)) ts)` - (Induct >> + MAP (infer_type_subst (MAP (\(x,y). (x, unconvert_t y)) subst)) ts) +Proof + Induct >> rw [unconvert_t_def, type_subst_def, infer_type_subst_def, MAP_MAP_o, check_freevars_def] >> fs [combinTheory.o_DEF] @@ -166,10 +169,11 @@ Theorem unconvert_type_subst fs [] >> fs [ALOOKUP_NONE, SUBSET_DEF] >> metis_tac []) >> - metis_tac []); + metis_tac [] +QED -Theorem env_rel_binding - `!fvs t fvs' name. +Theorem env_rel_binding: + !fvs t fvs' name. check_freevars 0 fvs' t ∧ set fvs' ⊆ set fvs ⇒ @@ -189,8 +193,9 @@ Theorem env_rel_binding (ZIP (nub fvs', MAP Infer_Tvar_db (COUNT_LIST (LENGTH (nub fvs'))))) t); inf_c := nsEmpty; - inf_t := nsEmpty|>` - (rw [env_rel_def] + inf_t := nsEmpty|> +Proof + rw [env_rel_def] >- ( rw [ienv_ok_def, ienv_val_ok_def] >> Cases_on `nub fvs' = []` >> @@ -288,7 +293,8 @@ Theorem env_rel_binding rw [MAP_GENLIST, combinTheory.o_DEF] >> irule env_rel_binding_lemma2 >> rw [all_distinct_nub] >> - metis_tac [check_freevars_more, nub_set, SUBSET_DEF])); + metis_tac [check_freevars_more, nub_set, SUBSET_DEF]) +QED val env_rel_complete_bind = Q.prove(` env_rel_complete FEMPTY ienv tenv Empty ⇒ @@ -297,8 +303,8 @@ val env_rel_complete_bind = Q.prove(` res_tac>>fs[]>> TRY(metis_tac[])>> match_mp_tac tscheme_approx_weakening>>asm_exists_tac>>fs[t_wfs_def]); -Theorem type_pe_determ_canon_infer_e -`!loc ienv p e st st' t t' new_bindings s. +Theorem type_pe_determ_canon_infer_e: + !loc ienv p e st st' t t' new_bindings s. ALL_DISTINCT (MAP FST new_bindings) ∧ env_rel_sound FEMPTY ienv tenv Empty ∧ ienv_ok {} ienv ∧ @@ -309,8 +315,9 @@ Theorem type_pe_determ_canon_infer_e t_unify st'.subst t t' = SOME s ∧ type_pe_determ_canon ss.next_id tenv Empty p e ⇒ - EVERY (\(n, t). check_t 0 {} (t_walkstar s t)) new_bindings` - (rw [type_pe_determ_canon_def] >> + EVERY (\(n, t). check_t 0 {} (t_walkstar s t)) new_bindings +Proof + rw [type_pe_determ_canon_def] >> `t_wfs (init_infer_state ss).subst` by rw [t_wfs_def, init_infer_state_def] >> `t_wfs st.subst` by metis_tac [infer_e_wfs] >> `t_wfs st'.subst` by metis_tac [infer_p_wfs] >> @@ -550,7 +557,8 @@ Theorem type_pe_determ_canon_infer_e count st'.next_uvar ∩ COMPL (FDOM s2) = {}` by (fs[EXTENSION,SUBSET_DEF]>>metis_tac[])>> fs[]>>rfs[]>> - metis_tac[check_t_empty_unconvert_convert_id]); + metis_tac[check_t_empty_unconvert_convert_id] +QED @@ -560,12 +568,13 @@ fun str_assums strs = ConseqConv.DISCH_ASM_CONSEQ_CONV_TAC val ap_lemma = Q.prove (`!f. x = y ==> f x = f y`, fs []); -Theorem inf_set_tids_extend_dec_ienv - `inf_set_tids_ienv (count n) ienv2 +Theorem inf_set_tids_extend_dec_ienv: + inf_set_tids_ienv (count n) ienv2 /\ inf_set_tids_ienv (count m) ienv /\ m <= n - ==> inf_set_tids_ienv (count n) (extend_dec_ienv ienv2 ienv)` - (fs [inf_set_tids_ienv_def] + ==> inf_set_tids_ienv (count n) (extend_dec_ienv ienv2 ienv) +Proof + fs [inf_set_tids_ienv_def] \\ rpt disch_tac \\ fs[extend_dec_ienv_def] \\ conj_tac @@ -588,7 +597,8 @@ Theorem inf_set_tids_extend_dec_ienv \\ irule nsAll_mono \\ goal_assum(first_assum o mp_then Any mp_tac) \\ rw[SUBSET_DEF, UNCURRY, inf_set_tids_subset_def] - \\ rw[] \\ res_tac \\ fs[]); + \\ rw[] \\ res_tac \\ fs[] +QED Theorem infer_d_complete_canon: (!d n tenv ids tenv' ienv st1. @@ -1427,8 +1437,8 @@ Theorem infer_ds_complete \\ drule (GEN_ALL BIJ_extend_bij) \\ fs[]*)); (* -Theorem check_specs_complete - `!mn tenvT specs decls tenv. +Theorem check_specs_complete: + !mn tenvT specs decls tenv. type_specs mn tenvT specs decls tenv ⇒ ∀st1 extra_idecls extra_ienv. tenv_abbrev_ok tenvT ⇒ @@ -1436,8 +1446,9 @@ Theorem check_specs_complete decls = convert_decls idecls ∧ env_rel tenv new_ienv ∧ check_specs mn tenvT extra_idecls extra_ienv specs st1 = - (Success (append_decls idecls extra_idecls,extend_dec_ienv new_ienv extra_ienv), st2)` - (ho_match_mp_tac type_specs_ind >> + (Success (append_decls idecls extra_idecls,extend_dec_ienv new_ienv extra_ienv), st2) +Proof + ho_match_mp_tac type_specs_ind >> rw [check_specs_def, success_eqns] >- ( fs [extend_dec_ienv_def, empty_decls_def, convert_decls_def, append_decls_def, @@ -1617,7 +1628,8 @@ Theorem check_specs_complete >- simp [append_decls_def] >- ( simp [extend_dec_ienv_def] >> - simp_tac std_ss [nsAppend_nsSing, GSYM nsAppend_assoc]))); + simp_tac std_ss [nsAppend_nsSing, GSYM nsAppend_assoc])) +QED val n_fresh_uvar_rw = Q.prove(` ∀n st.n_fresh_uvar n st = (Success (GENLIST (λi.Infer_Tuvar(i+st.next_uvar)) n), st with next_uvar := st.next_uvar + n)`, @@ -1670,13 +1682,14 @@ val infer_deBruijn_subst_check_t = Q.prove(` fs[EVERY_MEM,MEM_EL]>> metis_tac[]); -Theorem check_tscheme_inst_complete - `!tvs_spec t_spec tvs_impl t_impl id. +Theorem check_tscheme_inst_complete: + !tvs_spec t_spec tvs_impl t_impl id. check_t tvs_impl {} t_impl ∧ check_t tvs_spec {} t_spec ∧ tscheme_approx 0 FEMPTY (tvs_spec,t_spec) (tvs_impl,t_impl) ⇒ - check_tscheme_inst id (tvs_spec,t_spec) (tvs_impl,t_impl)` - (rw [tscheme_approx_def, check_tscheme_inst_def] >> + check_tscheme_inst id (tvs_spec,t_spec) (tvs_impl,t_impl) +Proof + rw [tscheme_approx_def, check_tscheme_inst_def] >> fs [t_walkstar_FEMPTY] >> simp [st_ex_bind_def, init_state_def, init_infer_state_def, st_ex_return_def, add_constraint_def] >> @@ -1716,16 +1729,18 @@ Theorem check_tscheme_inst_complete fs[markerTheory.Abbrev_def]>> rpt var_eq_tac>> fs[t_walkstar_FEMPTY,ETA_AX,t_wfs_def])>> - fs[]); + fs[] +QED -Theorem check_weak_ienv_complete - `!tenv_impl tenv_spec ienv_impl ienv_spec. +Theorem check_weak_ienv_complete: + !tenv_impl tenv_spec ienv_impl ienv_spec. weak_tenv tenv_impl tenv_spec ∧ env_rel tenv_impl ienv_impl ∧ env_rel tenv_spec ienv_spec ⇒ - check_weak_ienv ienv_impl ienv_spec` - (rw [weak_tenv_def, check_weak_ienv_def, GSYM nsSub_compute_thm] + check_weak_ienv ienv_impl ienv_spec +Proof + rw [weak_tenv_def, check_weak_ienv_def, GSYM nsSub_compute_thm] >- ( fs [namespaceTheory.nsSub_def, env_rel_def, env_rel_sound_def, lookup_var_def, env_rel_complete_def] >> @@ -1744,16 +1759,19 @@ Theorem check_weak_ienv_complete imp_res_tac nsLookup_nsAll>> rfs[]>> metis_tac [tscheme_approx_trans, tscheme_inst_to_approx]) >> - fs [env_rel_def, env_rel_sound_def]); + fs [env_rel_def, env_rel_sound_def] +QED -Theorem check_weak_decls_complete - `!idecls1 idecls2. +Theorem check_weak_decls_complete: + !idecls1 idecls2. weak_decls (convert_decls idecls1) (convert_decls idecls2) ⇒ - check_weak_decls idecls1 idecls2` - (rw [weak_decls_def, check_weak_decls_def, convert_decls_def, SUBSET_DEF, + check_weak_decls idecls1 idecls2 +Proof + rw [weak_decls_def, check_weak_decls_def, convert_decls_def, SUBSET_DEF, list_subset_def, list_set_eq_def] >> - fs [EVERY_MEM]); + fs [EVERY_MEM] +QED *) val _ = export_theory (); diff --git a/compiler/inference/proofs/inferPropsScript.sml b/compiler/inference/proofs/inferPropsScript.sml index 5ef23d4b73..564b5fe386 100644 --- a/compiler/inference/proofs/inferPropsScript.sml +++ b/compiler/inference/proofs/inferPropsScript.sml @@ -8,53 +8,66 @@ open astPropsTheory typeSysPropsTheory; val _ = new_theory "inferProps"; -Theorem ienv_unchanged[simp] - `(ienv with inf_v := ienv.inf_v) = ienv ∧ +Theorem ienv_unchanged[simp]: + (ienv with inf_v := ienv.inf_v) = ienv ∧ (ienv with inf_c := ienv.inf_c) = ienv ∧ - (ienv with inf_t := ienv.inf_t) = ienv` - (rw [inf_env_component_equality]); + (ienv with inf_t := ienv.inf_t) = ienv +Proof + rw [inf_env_component_equality] +QED -Theorem extend_dec_ienv_empty - `!ienv. +Theorem extend_dec_ienv_empty: + !ienv. extend_dec_ienv ienv <| inf_v := nsEmpty; inf_c := nsEmpty; inf_t := nsEmpty |> = ienv ∧ - extend_dec_ienv <| inf_v := nsEmpty; inf_c := nsEmpty; inf_t := nsEmpty |> ienv = ienv` - (rw [extend_dec_ienv_def, inf_env_component_equality]); + extend_dec_ienv <| inf_v := nsEmpty; inf_c := nsEmpty; inf_t := nsEmpty |> ienv = ienv +Proof + rw [extend_dec_ienv_def, inf_env_component_equality] +QED (* ---------- Facts about deBruijn increment ---------- *) -Theorem infer_deBruijn_inc0 -`!(n:num) t. infer_deBruijn_inc 0 t = t` -(ho_match_mp_tac infer_deBruijn_inc_ind >> +Theorem infer_deBruijn_inc0: + !(n:num) t. infer_deBruijn_inc 0 t = t +Proof +ho_match_mp_tac infer_deBruijn_inc_ind >> rw [infer_deBruijn_inc_def] >> induct_on `ts` >> -rw []); - -Theorem infer_deBruijn_inc0_id -`infer_deBruijn_inc 0 = (\x.x)` -(metis_tac [infer_deBruijn_inc0]); - -Theorem t_vars_inc -`!tvs t. t_vars (infer_deBruijn_inc tvs t) = t_vars t` -(ho_match_mp_tac infer_deBruijn_inc_ind >> +rw [] +QED + +Theorem infer_deBruijn_inc0_id: + infer_deBruijn_inc 0 = (\x.x) +Proof +metis_tac [infer_deBruijn_inc0] +QED + +Theorem t_vars_inc: + !tvs t. t_vars (infer_deBruijn_inc tvs t) = t_vars t +Proof +ho_match_mp_tac infer_deBruijn_inc_ind >> rw [t_vars_def, encode_infer_t_def, infer_deBruijn_inc_def] >> induct_on `ts` >> -rw [encode_infer_t_def]); +rw [encode_infer_t_def] +QED -Theorem inc_wfs -`!tvs s. t_wfs s ⇒ t_wfs (infer_deBruijn_inc tvs o_f s)` -(rw [t_wfs_eqn] >> +Theorem inc_wfs: + !tvs s. t_wfs s ⇒ t_wfs (infer_deBruijn_inc tvs o_f s) +Proof +rw [t_wfs_eqn] >> `t_vR s = t_vR (infer_deBruijn_inc tvs o_f s)` by (rw [FLOOKUP_o_f, FUN_EQ_THM, t_vR_eqn] >> full_case_tac >> rw [t_vars_inc]) >> -metis_tac []); +metis_tac [] +QED -Theorem vwalk_inc -`!s tvs n. +Theorem vwalk_inc: + !s tvs n. t_wfs s ⇒ - t_vwalk (infer_deBruijn_inc tvs o_f s) n = infer_deBruijn_inc tvs (t_vwalk s n)` -(rw [] >> + t_vwalk (infer_deBruijn_inc tvs o_f s) n = infer_deBruijn_inc tvs (t_vwalk s n) +Proof +rw [] >> imp_res_tac (DISCH_ALL t_vwalk_ind) >> `t_wfs (infer_deBruijn_inc tvs o_f s)` by metis_tac [inc_wfs] >> rw [] >> @@ -68,23 +81,27 @@ pop_assum (fn _ => all_tac) >> cases_on `FLOOKUP s n` >> rw [FLOOKUP_o_f, infer_deBruijn_inc_def] >> cases_on `x` >> -rw [infer_deBruijn_inc_def]); +rw [infer_deBruijn_inc_def] +QED -Theorem walk_inc -`!s tvs t. +Theorem walk_inc: + !s tvs t. t_wfs s ⇒ - t_walk (infer_deBruijn_inc tvs o_f s) (infer_deBruijn_inc tvs t) = infer_deBruijn_inc tvs (t_walk s t)` -(rw [] >> + t_walk (infer_deBruijn_inc tvs o_f s) (infer_deBruijn_inc tvs t) = infer_deBruijn_inc tvs (t_walk s t) +Proof +rw [] >> cases_on `t` >> -rw [t_walk_eqn, infer_deBruijn_inc_def, vwalk_inc]); +rw [t_walk_eqn, infer_deBruijn_inc_def, vwalk_inc] +QED -Theorem walkstar_inc -`!tvs s t. +Theorem walkstar_inc: + !tvs s t. t_wfs s ⇒ (t_walkstar (infer_deBruijn_inc tvs o_f s) (infer_deBruijn_inc tvs t) = - infer_deBruijn_inc tvs (t_walkstar s t))` -(rw [] >> + infer_deBruijn_inc tvs (t_walkstar s t)) +Proof +rw [] >> imp_res_tac t_walkstar_ind >> Q.SPEC_TAC (`t`, `t`) >> pop_assum ho_match_mp_tac >> @@ -99,19 +116,22 @@ pop_assum mp_tac >> pop_assum (fn _ => all_tac) >> induct_on `l` >> rw [] >> -fs []); +fs [] +QED -Theorem walkstar_inc2 -`!tvs s n. +Theorem walkstar_inc2: + !tvs s n. t_wfs s ⇒ (t_walkstar (infer_deBruijn_inc tvs o_f s) (Infer_Tuvar n) = - infer_deBruijn_inc tvs (t_walkstar s (Infer_Tuvar n)))` -(rw [GSYM walkstar_inc, infer_deBruijn_inc_def]); + infer_deBruijn_inc tvs (t_walkstar s (Infer_Tuvar n))) +Proof +rw [GSYM walkstar_inc, infer_deBruijn_inc_def] +QED (* ---------- Type substitution ---------- *) -Theorem subst_infer_subst_swap -`(!t tvs s uvar. +Theorem subst_infer_subst_swap: + (!t tvs s uvar. t_wfs s ⇒ (t_walkstar s (infer_type_subst (ZIP (tvs, MAP (λn. Infer_Tuvar (uvar + n)) (COUNT_LIST (LENGTH tvs)))) t) = @@ -120,8 +140,9 @@ Theorem subst_infer_subst_swap t_wfs s ⇒ (MAP (t_walkstar s) (MAP (infer_type_subst (ZIP (tvs, MAP (λn. Infer_Tuvar (uvar + n)) (COUNT_LIST (LENGTH tvs))))) ts) = - MAP (infer_type_subst (ZIP (tvs, MAP (λn. t_walkstar s (Infer_Tuvar (uvar + n))) (COUNT_LIST (LENGTH tvs))))) ts))` - (ho_match_mp_tac t_induction >> + MAP (infer_type_subst (ZIP (tvs, MAP (λn. t_walkstar s (Infer_Tuvar (uvar + n))) (COUNT_LIST (LENGTH tvs))))) ts)) +Proof + ho_match_mp_tac t_induction >> rw [type_subst_def, infer_type_subst_def, t_walkstar_eqn1] >- (every_case_tac >> rw [t_walkstar_eqn1] >> @@ -130,19 +151,22 @@ Theorem subst_infer_subst_swap imp_res_tac ALOOKUP_MEM >> fs [MEM_ZIP, LENGTH_COUNT_LIST] >> metis_tac []) - >- metis_tac []); + >- metis_tac [] +QED val infer_t_induction = infer_tTheory.infer_t_induction; -Theorem infer_subst_FEMPTY -`(!t. infer_subst FEMPTY t = t) ∧ - (!ts. MAP (infer_subst FEMPTY) ts = ts)` -(ho_match_mp_tac infer_t_induction >> +Theorem infer_subst_FEMPTY: + (!t. infer_subst FEMPTY t = t) ∧ + (!ts. MAP (infer_subst FEMPTY) ts = ts) +Proof +ho_match_mp_tac infer_t_induction >> rw [SUBSET_DEF, infer_subst_def] >> -metis_tac []); +metis_tac [] +QED -Theorem infer_subst_submap -`(!t s1 s2 m. +Theorem infer_subst_submap: + (!t s1 s2 m. s1 SUBMAP s2 ∧ {uv | uv ∈ t_vars t ∧ m ≤ uv} ⊆ FDOM s1 ∧ (!uv. uv ∈ FDOM s2 DIFF FDOM s1 ⇒ m ≤ uv) @@ -153,8 +177,9 @@ Theorem infer_subst_submap {uv | ?s. uv ∈ s ∧ MEM s (MAP t_vars ts) ∧ m ≤ uv} ⊆ FDOM s1 ∧ (!uv. uv ∈ FDOM s2 DIFF FDOM s1 ⇒ m ≤ uv) ⇒ - (MAP (infer_subst s1) ts = MAP (infer_subst s2) ts))` - (ho_match_mp_tac infer_t_induction >> + (MAP (infer_subst s1) ts = MAP (infer_subst s2) ts)) +Proof + ho_match_mp_tac infer_t_induction >> rw [SUBSET_DEF, infer_subst_def, t_vars_eqn] >- metis_tac [] @@ -167,18 +192,21 @@ Theorem infer_subst_submap >- metis_tac [] >> - metis_tac []); + metis_tac [] +QED -Theorem generalise_list_length ` - ∀a b c d e f g. - generalise_list a b c d = (e,f,g) ⇒ LENGTH g = LENGTH d` - (Induct_on`d`>>fs[generalise_def]>>rw[]>> +Theorem generalise_list_length: + ∀a b c d e f g. + generalise_list a b c d = (e,f,g) ⇒ LENGTH g = LENGTH d +Proof + Induct_on`d`>>fs[generalise_def]>>rw[]>> pairarg_tac>>fs[]>> pairarg_tac>>fs[]>> - res_tac>>fs[]>>rveq>>fs[]); + res_tac>>fs[]>>rveq>>fs[] +QED -Theorem generalise_subst -`(!t m n s tvs s' t'. +Theorem generalise_subst: + (!t m n s tvs s' t'. (generalise m n s t = (tvs, s', t')) ⇒ (s SUBMAP s') ∧ @@ -193,8 +221,9 @@ Theorem generalise_subst (FDOM s' = FDOM s ∪ { uv | uv ∈ BIGUNION (set (MAP t_vars ts)) ∧ m ≤ uv }) ∧ (!uv. uv ∈ FDOM s' DIFF FDOM s ⇒ ∃tv. (FAPPLY s' uv = tv) ∧ n ≤ tv ∧ tv < tvs + n) ∧ (!uv. uv ∈ BIGUNION (set (MAP t_vars ts')) ⇒ uv < m) ∧ - (MAP (infer_subst s') ts = MAP (infer_subst s) ts'))` - (Induct >> + (MAP (infer_subst s') ts = MAP (infer_subst s) ts')) +Proof + Induct >> SIMP_TAC (srw_ss()) [t_vars_eqn, generalise_def, infer_subst_def] >- ( REPEAT GEN_TAC >> @@ -281,17 +310,19 @@ Theorem generalise_subst (rw [SUBSET_DEF] >> `¬(x < m)` by decide_tac >> metis_tac []) >> - metis_tac [infer_subst_submap]); + metis_tac [infer_subst_submap] +QED -Theorem generalise_subst_empty -`!n ts tvs s ts'. +Theorem generalise_subst_empty: + !n ts tvs s ts'. (generalise_list 0 n FEMPTY ts = (tvs, s, ts')) ⇒ (FDOM s = { uv | uv ∈ BIGUNION (set (MAP t_vars ts)) }) ∧ (!uv. uv ∈ FDOM s ⇒ ∃tv. (FAPPLY s uv = tv) ∧ tv < tvs + n) ∧ (BIGUNION (set (MAP t_vars ts')) = {}) ∧ - (ts' = MAP (infer_subst s) ts)` - (rw [] >> + (ts' = MAP (infer_subst s) ts) +Proof + rw [] >> imp_res_tac generalise_subst >> fs [] >> rw [] @@ -310,21 +341,24 @@ Theorem generalise_subst_empty fs [t_vars_eqn] >> metis_tac []) >> - metis_tac [infer_subst_FEMPTY]); + metis_tac [infer_subst_FEMPTY] +QED (* ---------- Dealing with the monad ---------- *) (* TODO: update *) -Theorem infer_st_rewrs -`(!st. (st with next_uvar := st.next_uvar) = st) ∧ +Theorem infer_st_rewrs: + (!st. (st with next_uvar := st.next_uvar) = st) ∧ (!st. (st with subst := st.subst) = st) ∧ (!st s. (st with subst := s).subst = s) ∧ (!st s. (st with subst := s).next_uvar = st.next_uvar) ∧ (!st uv. (st with next_uvar := uv).next_uvar = uv) ∧ - (!st uv. (st with next_uvar := uv).subst = st.subst)` - (rw [] >> + (!st uv. (st with next_uvar := uv).subst = st.subst) +Proof + rw [] >> cases_on `st` >> - rw [infer_st_component_equality]); + rw [infer_st_component_equality] +QED val st_ex_return_success = Q.prove ( `!v st v' st'. @@ -376,14 +410,16 @@ rw [st_ex_return_def, st_ex_bind_def, LET_THM, apply_subst_def, read_def] >> eq_tac >> rw []); -Theorem add_constraint_success -`!l t1 t2 st st' x. +Theorem add_constraint_success: + !l t1 t2 st st' x. (add_constraint l t1 t2 st = (Success x, st')) = - ((x = ()) ∧ (?s. (t_unify st.subst t1 t2 = SOME s) ∧ (st' = st with subst := s)))` -(rw [add_constraint_def] >> + ((x = ()) ∧ (?s. (t_unify st.subst t1 t2 = SOME s) ∧ (st' = st with subst := s))) +Proof +rw [add_constraint_def] >> full_case_tac >> -metis_tac []); +metis_tac [] +QED val add_constraints_success = Q.prove ( `!l ts1 ts2 st st' x. @@ -467,17 +503,19 @@ val guard_success = Q.prove ( rw [guard_def, st_ex_return_def, failwith_def] >> metis_tac []); -Theorem check_dups_success - `!l f ls s r s'. +Theorem check_dups_success: + !l f ls s r s'. check_dups l f ls s = (Success r, s') ⇔ - s' = s ∧ ALL_DISTINCT ls` - (Induct_on `ls` >> + s' = s ∧ ALL_DISTINCT ls +Proof + Induct_on `ls` >> rw [check_dups_def, st_ex_return_def, failwith_def] >> - metis_tac []); + metis_tac [] +QED -Theorem type_name_check_subst_success - `(!t l f tenvT tvs r (s:'a) s'. +Theorem type_name_check_subst_success: + (!t l f tenvT tvs r (s:'a) s'. type_name_check_subst l f tenvT tvs t s = (Success r, s') ⇔ s = s' ∧ r = type_name_subst tenvT t ∧ @@ -486,8 +524,9 @@ Theorem type_name_check_subst_success type_name_check_subst_list l f tenvT tvs ts s = (Success r, s') ⇔ s = s' ∧ r = MAP (type_name_subst tenvT) ts ∧ - EVERY (check_freevars_ast tvs) ts ∧ EVERY (check_type_names tenvT) ts)` - (Induct >> + EVERY (check_freevars_ast tvs) ts ∧ EVERY (check_type_names tenvT) ts) +Proof + Induct >> rw [type_name_check_subst_def, st_ex_bind_def, guard_def, st_ex_return_def, check_freevars_ast_def, check_type_names_def, failwith_def, type_name_subst_def] >> @@ -498,15 +537,17 @@ Theorem type_name_check_subst_success fs [] >> every_case_tac >> fs [lookup_st_ex_success, lookup_st_ex_def] >> - metis_tac [exc_distinct, PAIR_EQ, NOT_EVERY]); + metis_tac [exc_distinct, PAIR_EQ, NOT_EVERY] +QED -Theorem check_ctor_types_success - `!l tenvT tvs ts s s'. +Theorem check_ctor_types_success: + !l tenvT tvs ts s s'. check_ctor_types l tenvT tvs ts s = (Success (),s') ⇔ s = s' ∧ EVERY (λ(cn,ts). EVERY (check_freevars_ast tvs) ts ∧ - EVERY (check_type_names tenvT) ts) ts` - (Induct_on `ts` >> + EVERY (check_type_names tenvT) ts) ts +Proof + Induct_on `ts` >> rw [check_ctor_types_def, st_ex_return_def] >> PairCases_on `h` >> rw [check_ctor_types_def, st_ex_bind_def] >> @@ -514,14 +555,16 @@ Theorem check_ctor_types_success fs [type_name_check_subst_success] >> CCONTR_TAC >> fs [combinTheory.o_DEF] >> - metis_tac [exc_distinct, PAIR_EQ, type_name_check_subst_success]); + metis_tac [exc_distinct, PAIR_EQ, type_name_check_subst_success] +QED -Theorem check_ctors_success - `!l tenvT tds s s'. +Theorem check_ctors_success: + !l tenvT tds s s'. ALL_DISTINCT (MAP (FST o SND) tds) ⇒ (check_ctors l tenvT tds s = (Success (),s') ⇔ - s' = s ∧ check_ctor_tenv tenvT tds)` - (Induct_on `tds` >> + s' = s ∧ check_ctor_tenv tenvT tds) +Proof + Induct_on `tds` >> rw [] >> TRY (PairCases_on `h`) >> fs [check_ctor_tenv_def, check_type_definition_def, st_ex_bind_def, @@ -553,14 +596,16 @@ Theorem check_ctors_success metis_tac [NOT_EVERY, exc_distinct, PAIR_EQ, type_name_check_subst_success]) >- metis_tac [exc_distinct, PAIR_EQ, check_dups_success] >- metis_tac [exc_distinct, PAIR_EQ, check_dups_success] - >- metis_tac [exc_distinct, PAIR_EQ, check_dups_success]); + >- metis_tac [exc_distinct, PAIR_EQ, check_dups_success] +QED -Theorem check_type_definition_success - `!l tenvT tds s r s'. +Theorem check_type_definition_success: + !l tenvT tds s r s'. check_type_definition l tenvT tds s = (Success r, s') ⇔ - s' = s ∧ check_ctor_tenv tenvT tds` - (rw [check_type_definition_def, st_ex_bind_def] >> + s' = s ∧ check_ctor_tenv tenvT tds +Proof + rw [check_type_definition_def, st_ex_bind_def] >> every_case_tac >> fs [check_dups_success] >- metis_tac [check_ctors_success] >> @@ -572,7 +617,8 @@ Theorem check_type_definition_success rw [] >> PairCases_on `h` >> rw [check_ctor_tenv_def] >> - fs [LAMBDA_PROD, combinTheory.o_DEF]); + fs [LAMBDA_PROD, combinTheory.o_DEF] +QED val option_case_eq = Q.prove ( `!opt f g v st st'. @@ -595,31 +641,36 @@ val success_eqns = val _ = save_thm ("success_eqns", success_eqns); -Theorem remove_pair_lem -`(!f v. (\(x,y). f x y) v = f (FST v) (SND v)) ∧ - (!f v. (\(x,y,z). f x y z) v = f (FST v) (FST (SND v)) (SND (SND v)))` -(rw [] >> +Theorem remove_pair_lem: + (!f v. (\(x,y). f x y) v = f (FST v) (SND v)) ∧ + (!f v. (\(x,y,z). f x y z) v = f (FST v) (FST (SND v)) (SND (SND v))) +Proof +rw [] >> PairCases_on `v` >> -rw []); +rw [] +QED (* ---------- Simple structural properties ---------- *) -Theorem infer_funs_length -`!l ienv funs ts st1 st2. +Theorem infer_funs_length: + !l ienv funs ts st1 st2. (infer_funs l ienv funs st1 = (Success ts, st2)) ⇒ - (LENGTH funs = LENGTH ts)` -(induct_on `funs` >> + (LENGTH funs = LENGTH ts) +Proof +induct_on `funs` >> rw [infer_e_def, success_eqns] >> rw [] >> PairCases_on `h` >> fs [infer_e_def, success_eqns] >> rw [] >> -metis_tac []); - -Theorem type_name_check_subst_state - `(!t l err tenvT fvs (st:'a) r st'. type_name_check_subst l err tenvT fvs t st = (r,st') ⇒ st = st') ∧ - (!ts l err tenvT fvs (st:'a) r st'. type_name_check_subst_list l err tenvT fvs ts st = (r,st') ⇒ st = st')` - (Induct >> +metis_tac [] +QED + +Theorem type_name_check_subst_state: + (!t l err tenvT fvs (st:'a) r st'. type_name_check_subst l err tenvT fvs t st = (r,st') ⇒ st = st') ∧ + (!ts l err tenvT fvs (st:'a) r st'. type_name_check_subst_list l err tenvT fvs ts st = (r,st') ⇒ st = st') +Proof + Induct >> rw [type_name_check_subst_def, st_ex_bind_def, guard_def, st_ex_return_def, failwith_def, lookup_st_ex_def] >> every_case_tac >> @@ -629,18 +680,20 @@ Theorem type_name_check_subst_state fs [] >> every_case_tac >> fs [] >> - metis_tac []); + metis_tac [] +QED -Theorem infer_p_bindings -`(!l cenv p st t env st' x. +Theorem infer_p_bindings: + (!l cenv p st t env st' x. (infer_p l cenv p st = (Success (t,env), st')) ⇒ (pat_bindings p x = MAP FST env ++ x)) ∧ (!l cenv ps st ts env st' x. (infer_ps l cenv ps st = (Success (ts,env), st')) ⇒ - (pats_bindings ps x = MAP FST env ++ x))` -(ho_match_mp_tac infer_p_ind >> + (pats_bindings ps x = MAP FST env ++ x)) +Proof +ho_match_mp_tac infer_p_ind >> rw [pat_bindings_def, infer_p_def, success_eqns, remove_pair_lem] >> rw [] >- (PairCases_on `v'` >> @@ -656,7 +709,8 @@ rw [] >- (PairCases_on `v'` >> PairCases_on `v''` >> rw [] >> - metis_tac [APPEND_ASSOC])); + metis_tac [APPEND_ASSOC]) +QED (* ---------- Dealing with the constraint set ---------- *) @@ -674,45 +728,51 @@ PairCases_on `h` >> fs [pure_add_constraints_def] >> metis_tac [t_unify_wfs, t_unify_apply2]); -Theorem pure_add_constraints_apply -`!s1 ts s2. +Theorem pure_add_constraints_apply: + !s1 ts s2. t_wfs s1 ∧ pure_add_constraints s1 ts s2 ⇒ - MAP (t_walkstar s2 o FST) ts = MAP (t_walkstar s2 o SND) ts` -(induct_on `ts` >> + MAP (t_walkstar s2 o FST) ts = MAP (t_walkstar s2 o SND) ts +Proof +induct_on `ts` >> rw [pure_add_constraints_def] >> PairCases_on `h` >> fs [pure_add_constraints_def] >> -metis_tac [t_unify_apply, pure_add_constraints_append2, t_unify_wfs]); +metis_tac [t_unify_apply, pure_add_constraints_append2, t_unify_wfs] +QED -Theorem pure_add_constraints_append -`!s1 ts1 s3 ts2. +Theorem pure_add_constraints_append: + !s1 ts1 s3 ts2. pure_add_constraints s1 (ts1 ++ ts2) s3 = - (?s2. pure_add_constraints s1 ts1 s2 ∧ pure_add_constraints s2 ts2 s3)` -(ho_match_mp_tac pure_add_constraints_ind >> + (?s2. pure_add_constraints s1 ts1 s2 ∧ pure_add_constraints s2 ts2 s3) +Proof +ho_match_mp_tac pure_add_constraints_ind >> rw [pure_add_constraints_def] >> -metis_tac []); +metis_tac [] +QED -Theorem infer_p_constraints -`(!l cenv p st t env st'. +Theorem infer_p_constraints: + (!l cenv p st t env st'. (infer_p l cenv p st = (Success (t,env), st')) ⇒ (?ts. pure_add_constraints st.subst ts st'.subst)) ∧ (!l cenv ps st ts env st'. (infer_ps l cenv ps st = (Success (ts,env), st')) ⇒ - (?ts'. pure_add_constraints st.subst ts' st'.subst))` -(ho_match_mp_tac infer_p_ind >> + (?ts'. pure_add_constraints st.subst ts' st'.subst)) +Proof +ho_match_mp_tac infer_p_ind >> rw [infer_p_def, success_eqns, remove_pair_lem, GSYM FORALL_PROD] >> rw [] >> res_tac >> fs [] >> -prove_tac [pure_add_constraints_append, pure_add_constraints_def, type_name_check_subst_state]); +prove_tac [pure_add_constraints_append, pure_add_constraints_def, type_name_check_subst_state] +QED -Theorem infer_e_constraints -`(!l ienv e st st' t. +Theorem infer_e_constraints: + (!l ienv e st st' t. (infer_e l ienv e st = (Success t, st')) ⇒ (?ts. pure_add_constraints st.subst ts st'.subst)) ∧ @@ -727,8 +787,9 @@ Theorem infer_e_constraints (!l ienv funs st st' ts'. (infer_funs l ienv funs st = (Success ts', st')) ⇒ - (?ts. pure_add_constraints st.subst ts st'.subst))` -(ho_match_mp_tac infer_e_ind >> + (?ts. pure_add_constraints st.subst ts st'.subst)) +Proof +ho_match_mp_tac infer_e_ind >> rw [infer_e_def, constrain_op_success, success_eqns, remove_pair_lem, GSYM FORALL_PROD] >> rw [] >> res_tac >> @@ -739,43 +800,48 @@ fs [success_eqns] >> rw [] >> fs [infer_st_rewrs] >> prove_tac [pure_add_constraints_append, pure_add_constraints_def, - infer_p_constraints, type_name_check_subst_state]); + infer_p_constraints, type_name_check_subst_state] +QED -Theorem pure_add_constraints_wfs -`!s1 ts s2. +Theorem pure_add_constraints_wfs: + !s1 ts s2. pure_add_constraints s1 ts s2 ∧ t_wfs s1 ⇒ - t_wfs s2` -(induct_on `ts` >> + t_wfs s2 +Proof +induct_on `ts` >> rw [pure_add_constraints_def] >- metis_tac [] >> PairCases_on `h` >> fs [pure_add_constraints_def] >> -metis_tac [t_unify_wfs]); +metis_tac [t_unify_wfs] +QED (* ---------- The next unification variable is monotone non-decreasing ---------- *) -Theorem infer_p_next_uvar_mono -`(!l cenv p st t env st'. +Theorem infer_p_next_uvar_mono: + (!l cenv p st t env st'. (infer_p l cenv p st = (Success (t,env), st')) ⇒ st.next_uvar ≤ st'.next_uvar) ∧ (!l cenv ps st ts env st'. (infer_ps l cenv ps st = (Success (ts,env), st')) ⇒ - st.next_uvar ≤ st'.next_uvar)` -(ho_match_mp_tac infer_p_ind >> + st.next_uvar ≤ st'.next_uvar) +Proof +ho_match_mp_tac infer_p_ind >> rw [infer_p_def, success_eqns, remove_pair_lem, GSYM FORALL_PROD] >> rw [] >> res_tac >> fs [] >> `st''' = st''` by metis_tac [type_name_check_subst_state] >> metis_tac [DECIDE ``!(x:num) y z. x ≤ y ⇒ x ≤ y + z``, - arithmeticTheory.LESS_EQ_TRANS]); + arithmeticTheory.LESS_EQ_TRANS] +QED -Theorem infer_e_next_uvar_mono -`(!l ienv e st st' t. +Theorem infer_e_next_uvar_mono: + (!l ienv e st st' t. (infer_e l ienv e st = (Success t, st')) ⇒ st.next_uvar ≤ st'.next_uvar) ∧ @@ -790,8 +856,9 @@ Theorem infer_e_next_uvar_mono (!l ienv funs st st' ts. (infer_funs l ienv funs st = (Success ts, st')) ⇒ - st.next_uvar ≤ st'.next_uvar)` -(ho_match_mp_tac infer_e_ind >> + st.next_uvar ≤ st'.next_uvar) +Proof +ho_match_mp_tac infer_e_ind >> rw [infer_e_def, constrain_op_success, success_eqns, remove_pair_lem, GSYM FORALL_PROD] >> rw [] >> res_tac >> @@ -802,12 +869,13 @@ metis_tac [infer_p_next_uvar_mono, arithmeticTheory.LESS_EQ_TRANS, pair_CASES,type_name_check_subst_state, DECIDE ``!(x:num) y. x ≤ x + y``, DECIDE ``!(x:num) y. x + 1 ≤ y ⇒ x ≤ y``, - DECIDE ``!(x:num) y z. x ≤ y ⇒ x ≤ y + z``]); + DECIDE ``!(x:num) y z. x ≤ y ⇒ x ≤ y + z``] +QED (* ---------- The inferencer builds well-formed substitutions ---------- *) -Theorem infer_p_wfs -`(!l cenv p st t env st'. +Theorem infer_p_wfs: + (!l cenv p st t env st'. t_wfs st.subst ∧ (infer_p l cenv p st = (Success (t,env), st')) ⇒ @@ -816,17 +884,19 @@ Theorem infer_p_wfs t_wfs st.subst ∧ (infer_ps l cenv ps st = (Success (ts,env), st')) ⇒ - t_wfs st'.subst)` -(ho_match_mp_tac infer_p_ind >> + t_wfs st'.subst) +Proof +ho_match_mp_tac infer_p_ind >> rw [infer_p_def, success_eqns, remove_pair_lem, GSYM FORALL_PROD] >> rw [] >> res_tac >> fs [] >- prove_tac [pure_add_constraints_wfs] ->- metis_tac [t_unify_wfs, type_name_check_subst_state]) +>- metis_tac [t_unify_wfs, type_name_check_subst_state] +QED -Theorem infer_e_wfs -`(!l ienv e st st' t. +Theorem infer_e_wfs: + (!l ienv e st st' t. infer_e l ienv e st = (Success t, st') ∧ t_wfs st.subst ⇒ @@ -845,8 +915,9 @@ Theorem infer_e_wfs infer_funs l ienv funs st = (Success ts', st') ∧ t_wfs st.subst ⇒ - t_wfs st'.subst)` -(ho_match_mp_tac infer_e_ind >> + t_wfs st'.subst) +Proof +ho_match_mp_tac infer_e_ind >> rw [infer_e_def, constrain_op_success, success_eqns, remove_pair_lem, GSYM FORALL_PROD] >> fs [] >> res_tac >> @@ -864,121 +935,149 @@ fs [infer_st_rewrs] >> res_tac >> fs [] >> imp_res_tac t_unify_wfs >> -metis_tac [type_name_check_subst_state]); +metis_tac [type_name_check_subst_state] +QED (* ---------- The invariants of the inferencer ---------- *) -Theorem check_t_more -`(!t tvs. check_t tvs {} t ⇒ !uvs. check_t tvs uvs t) ∧ - (!ts tvs. EVERY (check_t tvs {}) ts ⇒ !uvs. EVERY (check_t tvs uvs) ts)` -(ho_match_mp_tac infer_t_induction >> +Theorem check_t_more: + (!t tvs. check_t tvs {} t ⇒ !uvs. check_t tvs uvs t) ∧ + (!ts tvs. EVERY (check_t tvs {}) ts ⇒ !uvs. EVERY (check_t tvs uvs) ts) +Proof +ho_match_mp_tac infer_t_induction >> rw [check_t_def] >> -metis_tac []); +metis_tac [] +QED -Theorem check_t_more2 -`(!t tvs uvs. check_t tvs uvs t ⇒ !tvs'. check_t (tvs' + tvs) uvs t) ∧ - (!ts tvs uvs. EVERY (check_t tvs uvs) ts ⇒ !tvs'. EVERY (check_t (tvs' + tvs) uvs) ts)` -(ho_match_mp_tac infer_t_induction >> +Theorem check_t_more2: + (!t tvs uvs. check_t tvs uvs t ⇒ !tvs'. check_t (tvs' + tvs) uvs t) ∧ + (!ts tvs uvs. EVERY (check_t tvs uvs) ts ⇒ !tvs'. EVERY (check_t (tvs' + tvs) uvs) ts) +Proof +ho_match_mp_tac infer_t_induction >> rw [check_t_def] >> -metis_tac []); +metis_tac [] +QED -Theorem check_t_more3 -`(!t uvs tvs. check_t tvs (count uvs) t ⇒ !uvs'. check_t tvs (count (uvs + uvs')) t) ∧ - (!ts uvs tvs. EVERY (check_t tvs (count uvs)) ts ⇒ !uvs'. EVERY (check_t tvs (count (uvs + uvs'))) ts)` -(ho_match_mp_tac infer_t_induction >> +Theorem check_t_more3: + (!t uvs tvs. check_t tvs (count uvs) t ⇒ !uvs'. check_t tvs (count (uvs + uvs')) t) ∧ + (!ts uvs tvs. EVERY (check_t tvs (count uvs)) ts ⇒ !uvs'. EVERY (check_t tvs (count (uvs + uvs'))) ts) +Proof +ho_match_mp_tac infer_t_induction >> rw [check_t_def] >- metis_tac [] >> -decide_tac); +decide_tac +QED -Theorem check_t_more4 -`(!t uvs tvs. check_t tvs (count uvs) t ⇒ !uvs'. uvs ≤ uvs' ⇒ check_t tvs (count uvs') t) ∧ - (!ts uvs tvs. EVERY (check_t tvs (count uvs)) ts ⇒ !uvs'. uvs ≤ uvs' ⇒ EVERY (check_t tvs (count uvs')) ts)` -(ho_match_mp_tac infer_t_induction >> +Theorem check_t_more4: + (!t uvs tvs. check_t tvs (count uvs) t ⇒ !uvs'. uvs ≤ uvs' ⇒ check_t tvs (count uvs') t) ∧ + (!ts uvs tvs. EVERY (check_t tvs (count uvs)) ts ⇒ !uvs'. uvs ≤ uvs' ⇒ EVERY (check_t tvs (count uvs')) ts) +Proof +ho_match_mp_tac infer_t_induction >> srw_tac [ARITH_ss] [check_t_def] >> -metis_tac []); +metis_tac [] +QED -Theorem check_t_more5 -`(!t uvs tvs. check_t tvs uvs t ⇒ !uvs'. uvs ⊆ uvs' ⇒ check_t tvs uvs' t) ∧ - (!ts uvs tvs. EVERY (check_t tvs uvs) ts ⇒ !uvs'. uvs ⊆ uvs' ⇒ EVERY (check_t tvs uvs') ts)` -(ho_match_mp_tac infer_t_induction >> +Theorem check_t_more5: + (!t uvs tvs. check_t tvs uvs t ⇒ !uvs'. uvs ⊆ uvs' ⇒ check_t tvs uvs' t) ∧ + (!ts uvs tvs. EVERY (check_t tvs uvs) ts ⇒ !uvs'. uvs ⊆ uvs' ⇒ EVERY (check_t tvs uvs') ts) +Proof +ho_match_mp_tac infer_t_induction >> rw [check_t_def, SUBSET_DEF] >> -metis_tac []); - -Theorem check_t_t_vars -`!tvs uvs t. - check_t tvs uvs t ⇒ t_vars t ⊆ uvs` -(ho_match_mp_tac check_t_ind >> +metis_tac [] +QED + +Theorem check_t_t_vars: + !tvs uvs t. + check_t tvs uvs t ⇒ t_vars t ⊆ uvs +Proof +ho_match_mp_tac check_t_ind >> rw [t_vars_eqn, check_t_def, EVERY_MEM, SUBSET_DEF, MEM_MAP] >> -metis_tac []); +metis_tac [] +QED val check_s_more = Q.prove ( `!s tvs uvs. check_s tvs (count uvs) s ⇒ check_s tvs (count (uvs + 1)) s`, rw [check_s_def] >> metis_tac [check_t_more3]); -Theorem check_s_more2 -`!s uvs. check_s tvs (count uvs) s ⇒ !uvs'. uvs ≤ uvs' ⇒ check_s tvs (count uvs') s` -(rw [check_s_def] >> -metis_tac [check_t_more4]); - -Theorem check_s_more3 -`!s uvs. check_s tvs uvs s ⇒ !uvs'. uvs ⊆ uvs' ⇒ check_s tvs uvs' s` -(rw [check_s_def] >> -metis_tac [check_t_more5]); - -Theorem check_s_more5 -`!s uvs tvs uvs'. check_s tvs uvs s ∧ uvs ⊆ uvs' ⇒ check_s tvs uvs' s` - (rw [check_s_def] >> - metis_tac [check_t_more5]); +Theorem check_s_more2: + !s uvs. check_s tvs (count uvs) s ⇒ !uvs'. uvs ≤ uvs' ⇒ check_s tvs (count uvs') s +Proof +rw [check_s_def] >> +metis_tac [check_t_more4] +QED -Theorem check_t_deBruijn_inc2 -`!inc t s. check_t tvs s t ⇒ check_t (inc + tvs) s (infer_deBruijn_inc inc t)` -(ho_match_mp_tac infer_deBruijn_inc_ind >> +Theorem check_s_more3: + !s uvs. check_s tvs uvs s ⇒ !uvs'. uvs ⊆ uvs' ⇒ check_s tvs uvs' s +Proof +rw [check_s_def] >> +metis_tac [check_t_more5] +QED + +Theorem check_s_more5: + !s uvs tvs uvs'. check_s tvs uvs s ∧ uvs ⊆ uvs' ⇒ check_s tvs uvs' s +Proof + rw [check_s_def] >> + metis_tac [check_t_more5] +QED + +Theorem check_t_deBruijn_inc2: + !inc t s. check_t tvs s t ⇒ check_t (inc + tvs) s (infer_deBruijn_inc inc t) +Proof +ho_match_mp_tac infer_deBruijn_inc_ind >> rw [check_t_def, infer_deBruijn_inc_def] >> -fs [EVERY_MAP, EVERY_MEM]); +fs [EVERY_MAP, EVERY_MEM] +QED -Theorem check_t_deBruijn_inc -`!inc t. check_t 0 UNIV t ⇒ (infer_deBruijn_inc inc t = t)` -(ho_match_mp_tac infer_deBruijn_inc_ind >> +Theorem check_t_deBruijn_inc: + !inc t. check_t 0 UNIV t ⇒ (infer_deBruijn_inc inc t = t) +Proof +ho_match_mp_tac infer_deBruijn_inc_ind >> rw [check_t_def, infer_deBruijn_inc_def] >> induct_on `ts` >> -rw []); +rw [] +QED -Theorem infer_deBruijn_subst_twice - `(∀t. +Theorem infer_deBruijn_subst_twice: + (∀t. check_t (LENGTH subst2) uvs t ⇒ (infer_deBruijn_subst subst1 (infer_deBruijn_subst subst2 t) = infer_deBruijn_subst (MAP (infer_deBruijn_subst subst1) subst2) t)) ∧ (∀ts. EVERY (check_t (LENGTH subst2) uvs) ts ⇒ MAP ((infer_deBruijn_subst subst1) o (infer_deBruijn_subst subst2)) ts = - MAP (infer_deBruijn_subst(MAP(infer_deBruijn_subst subst1) subst2)) ts)` - (ho_match_mp_tac infer_tTheory.infer_t_induction>> + MAP (infer_deBruijn_subst(MAP(infer_deBruijn_subst subst1) subst2)) ts) +Proof + ho_match_mp_tac infer_tTheory.infer_t_induction>> rw[check_t_def,infer_deBruijn_subst_def]>> simp[EL_MAP]>> - fs[MAP_MAP_o,EVERY_MEM,MAP_EQ_f]); + fs[MAP_MAP_o,EVERY_MEM,MAP_EQ_f] +QED -Theorem check_t_subst -`!tvs (tvs':num set) t s. +Theorem check_t_subst: + !tvs (tvs':num set) t s. t_wfs s ∧ check_t tvs {} t ⇒ - (t = (t_walkstar (infer_deBruijn_inc tvs o_f s) t))` -(ho_match_mp_tac check_t_ind >> + (t = (t_walkstar (infer_deBruijn_inc tvs o_f s) t)) +Proof +ho_match_mp_tac check_t_ind >> srw_tac [ARITH_ss] [check_t_def, apply_subst_t_eqn] >> `t_wfs (infer_deBruijn_inc tvs o_f s)` by metis_tac [inc_wfs] >> fs [t_walkstar_eqn1] >> induct_on `ts` >> -rw []); +rw [] +QED -Theorem t_vwalk_check -`!s. t_wfs s ⇒ +Theorem t_vwalk_check: + !s. t_wfs s ⇒ !n tvs uvs t. n ∈ uvs ∧ check_s tvs uvs s ⇒ - check_t tvs uvs (t_vwalk s n)` -(NTAC 2 STRIP_TAC >> + check_t tvs uvs (t_vwalk s n) +Proof +NTAC 2 STRIP_TAC >> imp_res_tac (DISCH_ALL t_vwalk_ind) >> pop_assum ho_match_mp_tac >> rw [] >> @@ -988,7 +1087,8 @@ rw [check_t_def] >> cases_on `x` >> rw [check_t_def] >> fs [check_s_def, FLOOKUP_DEF] >> -metis_tac [check_t_def, IN_UNION]); +metis_tac [check_t_def, IN_UNION] +QED val t_walkstar_check' = Q.prove ( `!s. t_wfs s ⇒ @@ -1027,14 +1127,16 @@ val t_walkstar_check' = Q.prove ( fs [EVERY_MEM] >> metis_tac [t_vwalk_to_var]); -Theorem t_walkstar_check -`!s t tvs uvs. +Theorem t_walkstar_check: + !s t tvs uvs. t_wfs s ∧ check_s tvs (uvs ∪ FDOM s) s ∧ check_t tvs (uvs ∪ FDOM s) t ⇒ - check_t tvs uvs (t_walkstar s t)` -(metis_tac [t_walkstar_check']); + check_t tvs uvs (t_walkstar s t) +Proof +metis_tac [t_walkstar_check'] +QED val t_walkstar_uncheck_lem = Q.prove ( `!s. t_wfs s ⇒ @@ -1057,12 +1159,14 @@ val t_walkstar_uncheck_lem = Q.prove ( >> simp [check_t_def] >> fs [check_s_def, FLOOKUP_DEF]); -Theorem t_walkstar_uncheck - `!s t max_tvs uvs. +Theorem t_walkstar_uncheck: + !s t max_tvs uvs. check_t max_tvs uvs (t_walkstar s t) ∧ t_wfs s ⇒ - check_t max_tvs (uvs ∪ FDOM s) t` - (metis_tac [t_walkstar_uncheck_lem]); + check_t max_tvs (uvs ∪ FDOM s) t +Proof + metis_tac [t_walkstar_uncheck_lem] +QED val t_unify_check_s_help = Q.prove ( `(!s t1 t2. t_wfs s ⇒ @@ -1114,8 +1218,8 @@ val t_unify_check_s_help = Q.prove ( cases_on `t_unify s h h'` >> fs []); -Theorem check_t_walkstar -`(!t tvs s. +Theorem check_t_walkstar: + (!t tvs s. t_wfs s ∧ check_t tvs (FDOM s) t ∧ (∀uv. uv ∈ FDOM s ⇒ check_t tvs ∅ (t_walkstar s (Infer_Tuvar uv))) @@ -1126,10 +1230,12 @@ Theorem check_t_walkstar EVERY (check_t tvs (FDOM s)) ts ∧ (∀uv. uv ∈ FDOM s ⇒ check_t tvs ∅ (t_walkstar s (Infer_Tuvar uv))) ⇒ - EVERY (check_t tvs {} o t_walkstar s) ts)` - (ho_match_mp_tac infer_t_induction >> + EVERY (check_t tvs {} o t_walkstar s) ts) +Proof + ho_match_mp_tac infer_t_induction >> rw [check_t_def, t_walkstar_eqn1, EVERY_MAP] >> - metis_tac []); + metis_tac [] +QED val t_walkstar_no_vars = Q.prove ( `!tvs uvs t s. @@ -1145,43 +1251,49 @@ val t_walkstar_no_vars = Q.prove ( rw [] >> metis_tac []); -Theorem t_walkstar_no_vars -`!tvs t s. +Theorem t_walkstar_no_vars: + !tvs t s. t_wfs s ∧ check_t tvs {} t ⇒ - t_walkstar s t = t` - (metis_tac [t_walkstar_no_vars]); + t_walkstar s t = t +Proof + metis_tac [t_walkstar_no_vars] +QED -Theorem t_unify_check_s -`!s1 tvs uvs t1 t2 s2. +Theorem t_unify_check_s: + !s1 tvs uvs t1 t2 s2. t_unify s1 t1 t2 = SOME s2 ∧ t_wfs s1 ∧ check_s tvs uvs s1 ∧ check_t tvs uvs t1 ∧ check_t tvs uvs t2 ⇒ - check_s tvs uvs s2` - (metis_tac [t_unify_check_s_help]); + check_s tvs uvs s2 +Proof + metis_tac [t_unify_check_s_help] +QED -Theorem pure_add_constraints_check_s -`!s1 tvs uvs ts s2. +Theorem pure_add_constraints_check_s: + !s1 tvs uvs ts s2. pure_add_constraints s1 ts s2 ∧ t_wfs s1 ∧ EVERY (\(t1,t2). check_t tvs (count uvs) t1 ∧ check_t tvs (count uvs) t2) ts ∧ check_s tvs (count uvs) s1 ⇒ - check_s tvs (count uvs) s2` - (induct_on `ts` >- + check_s tvs (count uvs) s2 +Proof + induct_on `ts` >- (rw [check_s_def, pure_add_constraints_def] >- metis_tac []) >> rw [pure_add_constraints_def] >> PairCases_on `h` >> fs [pure_add_constraints_def] >> - metis_tac [t_unify_wfs, t_unify_check_s]); + metis_tac [t_unify_wfs, t_unify_check_s] +QED -Theorem infer_p_check_t -`(!l cenv p st t env st'. +Theorem infer_p_check_t: + (!l cenv p st t env st'. (infer_p l cenv p st = (Success (t,env), st')) ⇒ EVERY (\(x,t). check_t 0 (count st'.next_uvar) t) env ∧ @@ -1190,8 +1302,9 @@ Theorem infer_p_check_t (infer_ps l cenv ps st = (Success (ts,env), st')) ⇒ EVERY (\(x,t). check_t 0 (count st'.next_uvar) t) env ∧ - EVERY (check_t 0 (count st'.next_uvar)) ts)` -(ho_match_mp_tac infer_p_ind >> + EVERY (check_t 0 (count st'.next_uvar)) ts) +Proof +ho_match_mp_tac infer_p_ind >> rw [infer_p_def, success_eqns, remove_pair_lem] >> rw [check_t_def] >- (PairCases_on `v'` >> @@ -1249,7 +1362,8 @@ rw [check_t_def] by (imp_res_tac infer_p_next_uvar_mono >> qexists_tac `st'.next_uvar - st''.next_uvar` >> srw_tac [ARITH_ss] []) >> - metis_tac [infer_p_wfs, check_t_more3])); + metis_tac [infer_p_wfs, check_t_more3]) +QED val check_infer_type_subst = Q.prove ( `(!t tvs uvs. @@ -1276,36 +1390,40 @@ val check_infer_type_subst = Q.prove ( >> metis_tac [EVERY_MAP]); (* moved this one around a bit *) -Theorem infer_type_subst_empty_check ` -(∀t. +Theorem infer_type_subst_empty_check: + (∀t. check_freevars 0 [] t ⇒ check_t 0 {} (infer_type_subst [] t)) ∧ ∀ts. EVERY (check_freevars 0 []) ts ⇒ -EVERY (check_t 0 {}) (MAP (infer_type_subst []) ts)` - (Induct>>fs[check_freevars_def,infer_type_subst_def,check_t_def]>> - metis_tac[]); - -Theorem type_name_check_subst_thm - `(!t l err tenvT fvs (st:'a) r st'. +EVERY (check_t 0 {}) (MAP (infer_type_subst []) ts) +Proof + Induct>>fs[check_freevars_def,infer_type_subst_def,check_t_def]>> + metis_tac[] +QED + +Theorem type_name_check_subst_thm: + (!t l err tenvT fvs (st:'a) r st'. type_name_check_subst l err tenvT fvs t st = (Success r,st') ⇒ check_freevars_ast fvs t ∧ check_type_names tenvT t ∧ r = type_name_subst tenvT t) ∧ (!ts l err tenvT fvs (st:'a) rs st'. type_name_check_subst_list l err tenvT fvs ts st = (Success rs,st') ⇒ EVERY (check_freevars_ast fvs) ts ∧ EVERY (check_type_names tenvT) ts ∧ - rs = MAP (type_name_subst tenvT) ts)` - (Induct >> + rs = MAP (type_name_subst tenvT) ts) +Proof + Induct >> rw [check_type_names_def, type_name_check_subst_def, check_freevars_def, type_name_subst_def, success_eqns] >> rw [check_freevars_ast_def] >> TRY pairarg_tac >> fs [success_eqns] >> rw [] >> - metis_tac []); + metis_tac [] +QED -Theorem type_name_check_subst_comp_thm - `(!t l err tenvT fvs (st:'a) r. +Theorem type_name_check_subst_comp_thm: + (!t l err tenvT fvs (st:'a) r. check_freevars_ast fvs t ∧ check_type_names tenvT t ⇒ type_name_check_subst l err tenvT fvs t st = @@ -1314,16 +1432,18 @@ Theorem type_name_check_subst_comp_thm EVERY (check_freevars_ast fvs) ts ∧ EVERY (check_type_names tenvT) ts ⇒ type_name_check_subst_list l err tenvT fvs ts st = - (Success (MAP (type_name_subst tenvT) ts),st))` - (Induct >> + (Success (MAP (type_name_subst tenvT) ts),st)) +Proof + Induct >> rw [check_type_names_def, type_name_check_subst_def, check_freevars_def, type_name_subst_def, success_eqns] >> fs [check_freevars_ast_def] >> TRY pairarg_tac >> - fs [success_eqns]); + fs [success_eqns] +QED -Theorem infer_p_check_s - `(!l ienv p st t env st' tvs. +Theorem infer_p_check_s: + (!l ienv p st t env st' tvs. infer_p l ienv p st = (Success (t,env), st') ∧ t_wfs st.subst ∧ tenv_ctor_ok ienv.inf_c ∧ @@ -1338,8 +1458,9 @@ Theorem infer_p_check_s tenv_abbrev_ok ienv.inf_t ∧ check_s tvs (count st.next_uvar) st.subst ⇒ - check_s tvs (count st'.next_uvar) st'.subst)` - (ho_match_mp_tac infer_p_ind >> + check_s tvs (count st'.next_uvar) st'.subst) +Proof + ho_match_mp_tac infer_p_ind >> rw [infer_p_def, success_eqns, remove_pair_lem] >> rw [] >- metis_tac [check_s_more] @@ -1387,28 +1508,32 @@ Theorem infer_p_check_s check_t_more, type_name_check_subst_thm]) >- (PairCases_on `v'` >> PairCases_on `v''` >> - metis_tac [infer_p_wfs, check_s_more2, infer_p_next_uvar_mono])); + metis_tac [infer_p_wfs, check_s_more2, infer_p_next_uvar_mono]) +QED -Theorem check_env_more -`!uvs e. +Theorem check_env_more: + !uvs e. nsAll (λx (tvs,t). check_t tvs (count uvs) t) e ⇒ - !uvs'. uvs ≤ uvs' ⇒ nsAll (λx (tvs,t). check_t tvs (count uvs') t) e` - (rw [] + !uvs'. uvs ≤ uvs' ⇒ nsAll (λx (tvs,t). check_t tvs (count uvs') t) e +Proof + rw [] >> irule nsAll_mono >> qexists_tac `(λx (tvs,t). check_t tvs (count uvs) t)` >> rw [] >> pairarg_tac >> fs [] - >> metis_tac [check_t_more4]); + >> metis_tac [check_t_more4] +QED -Theorem check_env_letrec_lem -`∀uvs funs uvs'. +Theorem check_env_letrec_lem: + ∀uvs funs uvs'. ((funs = []) ∨ (uvs' + LENGTH funs ≤ uvs)) ⇒ nsAll (λx (tvs,t). check_t tvs (count uvs) t) - (alist_to_ns (MAP2 (λ(f,x,e) uvar. (f,0,uvar)) funs (MAP (λn. Infer_Tuvar (n+uvs')) (COUNT_LIST (LENGTH funs)))))` - (rw [COUNT_LIST_def] + (alist_to_ns (MAP2 (λ(f,x,e) uvar. (f,0,uvar)) funs (MAP (λn. Infer_Tuvar (n+uvs')) (COUNT_LIST (LENGTH funs))))) +Proof + rw [COUNT_LIST_def] >> rw [COUNT_LIST_def] >> irule nsAll_alist_to_ns >> Induct_on `funs` @@ -1424,7 +1549,8 @@ Theorem check_env_letrec_lem >> fs [] >> rpt (pairarg_tac >> fs []) >> rw [] - >> fs [EL_MAP, LENGTH_COUNT_LIST, check_t_def, EL_COUNT_LIST]); + >> fs [EL_MAP, LENGTH_COUNT_LIST, check_t_def, EL_COUNT_LIST] +QED val check_t_infer_db_subst = Q.prove ( `(!t uvs tvs. @@ -1440,22 +1566,24 @@ rw [check_t_def, infer_deBruijn_subst_def, LENGTH_COUNT_LIST, EL_MAP, EL_COUNT_LIST, EVERY_MAP] >> metis_tac []); -Theorem check_t_infer_db_subst2 -`(!t tvs1 tvs2. +Theorem check_t_infer_db_subst2: + (!t tvs1 tvs2. check_t tvs1 (count tvs2) (infer_deBruijn_subst (MAP (\n. Infer_Tuvar n) (COUNT_LIST tvs2)) t) = check_t (tvs1 + tvs2) (count tvs2) t) ∧ (!ts tvs1 tvs2. EVERY (check_t tvs1 (count tvs2) o infer_deBruijn_subst (MAP (\n. Infer_Tuvar n) (COUNT_LIST tvs2))) ts = - EVERY (check_t (tvs1 + tvs2) (count tvs2)) ts)` -(ho_match_mp_tac infer_t_induction >> + EVERY (check_t (tvs1 + tvs2) (count tvs2)) ts) +Proof +ho_match_mp_tac infer_t_induction >> rw [check_t_def, infer_deBruijn_subst_def, LENGTH_COUNT_LIST, EL_MAP, EL_COUNT_LIST, EVERY_MAP] >- -metis_tac []); +metis_tac [] +QED -Theorem infer_e_check_t - `(!l ienv e st st' t. +Theorem infer_e_check_t: + (!l ienv e st st' t. infer_e l ienv e st = (Success t, st') ∧ ienv_val_ok (count st.next_uvar) ienv.inf_v ⇒ @@ -1474,8 +1602,9 @@ Theorem infer_e_check_t infer_funs l ienv funs st = (Success ts', st') ∧ ienv_val_ok (count st.next_uvar) ienv.inf_v ⇒ - EVERY (check_t 0 (count st'.next_uvar)) ts')` - (ho_match_mp_tac infer_e_ind >> + EVERY (check_t 0 (count st'.next_uvar)) ts') +Proof + ho_match_mp_tac infer_e_ind >> srw_tac[] [infer_e_def, constrain_op_success, success_eqns, remove_pair_lem, LET_THM] >> fsrw_tac[] [check_t_def] >> imp_res_tac infer_e_next_uvar_mono >> @@ -1564,7 +1693,8 @@ Theorem infer_e_check_t >> first_x_assum irule >> irule nsAll_nsBind >> simp [check_t_def] - >> metis_tac [check_env_more, DECIDE ``x ≤ x + 1:num``])); + >> metis_tac [check_env_more, DECIDE ``x ≤ x + 1:num``]) +QED val check_t_more_0 = check_t_more2 |> CONJUNCT1 |> Q.SPECL[`t`,`0`] |> SIMP_RULE(srw_ss())[] @@ -1572,41 +1702,46 @@ val check_t_more_0 = val check_t_more_1 = check_t_more3 |> CONJUNCT1 |> SPEC_ALL |> SIMP_RULE(srw_ss())[PULL_FORALL] |> Q.SPEC`1` -Theorem constrain_op_wfs - `!l tvs op ts t st st'. +Theorem constrain_op_wfs: + !l tvs op ts t st st'. constrain_op l op ts st = (Success t, st') ∧ t_wfs st.subst ⇒ - t_wfs st'.subst` - (rw [constrain_op_def] >> + t_wfs st'.subst +Proof + rw [constrain_op_def] >> fs [] >> every_case_tac >> fs [op_to_string_def, success_eqns] >> rw [] >> fs [infer_st_rewrs] >> - metis_tac [t_unify_wfs]); + metis_tac [t_unify_wfs] +QED -Theorem constrain_op_check_t - `!l tvs op ts t st st'. +Theorem constrain_op_check_t: + !l tvs op ts t st st'. constrain_op l op ts st = (Success t, st') ∧ EVERY (check_t 0 (count st.next_uvar)) ts ⇒ - check_t 0 (count st'.next_uvar) t` - (rw [constrain_op_def] >> + check_t 0 (count st'.next_uvar) t +Proof + rw [constrain_op_def] >> every_case_tac >> fs [op_to_string_def, success_eqns] >> rw [] >> - fs [infer_st_rewrs, check_t_def]); + fs [infer_st_rewrs, check_t_def] +QED -Theorem constrain_op_check_s - `!l tvs op ts t st st'. +Theorem constrain_op_check_s: + !l tvs op ts t st st'. constrain_op l op ts st = (Success t, st') ∧ t_wfs st.subst ∧ EVERY (check_t 0 (count st.next_uvar)) ts ∧ check_s tvs (count st.next_uvar) st.subst ⇒ - check_s tvs (count st'.next_uvar) st'.subst` - (rw [] >> + check_s tvs (count st'.next_uvar) st'.subst +Proof + rw [] >> `!uvs tvs. check_t tvs uvs (Infer_Tapp [] TC_int)` by rw [check_t_def] >> `!uvs tvs. check_t tvs uvs (Infer_Tapp [] TC_word8)` by rw [check_t_def] >> `!uvs tvs. check_t tvs uvs (Infer_Tapp [] TC_word8array)` by rw [check_t_def] >> @@ -1625,7 +1760,8 @@ Theorem constrain_op_check_s \\ TRY (match_mp_tac check_s_more \\ rw[]) \\ TRY (CHANGED_TAC(rw[check_t_def])) \\ TRY (match_mp_tac check_t_more_1 \\ rw[]) - \\ match_mp_tac check_t_more_0 \\ simp[] \\ NO_TAC); + \\ match_mp_tac check_t_more_0 \\ simp[] \\ NO_TAC +QED val ienv_ok_def = Define ` ienv_ok uvars ienv ⇔ @@ -1633,13 +1769,15 @@ val ienv_ok_def = Define ` tenv_ctor_ok ienv.inf_c ∧ tenv_abbrev_ok ienv.inf_t`; -Theorem ienv_ok_more - `!uv uv' ienv. ienv_ok (count uv) ienv ∧ uv ≤ uv' ⇒ ienv_ok (count uv') ienv` - (rw [ienv_ok_def, ienv_val_ok_def] - >> metis_tac [check_env_more]); +Theorem ienv_ok_more: + !uv uv' ienv. ienv_ok (count uv) ienv ∧ uv ≤ uv' ⇒ ienv_ok (count uv') ienv +Proof + rw [ienv_ok_def, ienv_val_ok_def] + >> metis_tac [check_env_more] +QED -Theorem infer_e_check_s -`(!l ienv e st st' t tvs. +Theorem infer_e_check_s: + (!l ienv e st st' t tvs. infer_e l ienv e st = (Success t, st') ∧ t_wfs st.subst ∧ ienv_ok (count st.next_uvar) ienv ∧ @@ -1668,8 +1806,9 @@ Theorem infer_e_check_s ienv_ok (count st.next_uvar) ienv ∧ check_s tvs (count st.next_uvar) st.subst ⇒ - check_s tvs (count st'.next_uvar) st'.subst)` - (ho_match_mp_tac infer_e_ind + check_s tvs (count st'.next_uvar) st'.subst) +Proof + ho_match_mp_tac infer_e_ind >> rw [infer_e_def, success_eqns] >> rw [] >- ( @@ -2023,7 +2162,8 @@ Theorem infer_e_check_s >> rw [] >> metis_tac [ienv_ok_more, DECIDE ``x ≤ x+1n``]) >> first_x_assum irule - >> simp [check_s_more])); + >> simp [check_s_more]) +QED val generalise_complete_lemma = Q.prove ( `!tvs ts. @@ -2164,11 +2304,13 @@ val ts_tid_rename_def = tDefine"ts_tid_rename"` val ts_tid_rename_ind = theorem"ts_tid_rename_ind"; -Theorem ts_tid_rename_I[simp] - `ts_tid_rename I = I` - (simp[FUN_EQ_THM] +Theorem ts_tid_rename_I[simp]: + ts_tid_rename I = I +Proof + simp[FUN_EQ_THM] \\ ho_match_mp_tac t_ind - \\ rw[ts_tid_rename_def, MAP_EQ_ID, EVERY_MEM]); + \\ rw[ts_tid_rename_def, MAP_EQ_ID, EVERY_MEM] +QED (* All type ids in a type belonging to a set *) val set_tids_def = tDefine "set_tids"` @@ -2183,22 +2325,25 @@ val set_tids_def = tDefine "set_tids"` val set_tids_ind = theorem"set_tids_ind"; -Theorem set_tids_ts_tid_rename - `∀f t. set_tids (ts_tid_rename f t) = IMAGE f (set_tids t)` - (recInduct ts_tid_rename_ind +Theorem set_tids_ts_tid_rename: + ∀f t. set_tids (ts_tid_rename f t) = IMAGE f (set_tids t) +Proof + recInduct ts_tid_rename_ind \\ rw[ts_tid_rename_def, set_tids_def] \\ rw[Once EXTENSION, MEM_MAP, PULL_EXISTS] - \\ metis_tac[IN_IMAGE]); + \\ metis_tac[IN_IMAGE] +QED val set_tids_subset_def = Define` set_tids_subset tids t <=> set_tids t ⊆ tids` -Theorem set_tids_subset_type_subst ` - ∀s t tids. +Theorem set_tids_subset_type_subst: + ∀s t tids. FEVERY (set_tids_subset tids o SND) s ∧ set_tids_subset tids t ⇒ - set_tids_subset tids (type_subst s t)` - (ho_match_mp_tac type_subst_ind>> + set_tids_subset tids (type_subst s t) +Proof + ho_match_mp_tac type_subst_ind>> rw[type_subst_def,set_tids_def] >- ( TOP_CASE_TAC>> @@ -2211,7 +2356,8 @@ Theorem set_tids_subset_type_subst ` last_x_assum drule>> disch_then drule>> disch_then match_mp_tac>> - metis_tac[])); + metis_tac[]) +QED val unconvert_t_def = tDefine "unconvert_t" ` (unconvert_t (Tvar_db n) = Infer_Tvar_db n) ∧ @@ -2240,32 +2386,38 @@ val inf_set_tids_def = tDefine "inf_set_tids"` val inf_set_tids_subset_def = Define` inf_set_tids_subset tids t <=> inf_set_tids t ⊆ tids` -Theorem inf_set_tids_infer_type_subst_SUBSET - `∀subst t. +Theorem inf_set_tids_infer_type_subst_SUBSET: + ∀subst t. inf_set_tids (infer_type_subst subst t) ⊆ - set_tids t ∪ BIGUNION (IMAGE inf_set_tids (set (MAP SND subst)))` - (recInduct infer_type_subst_ind + set_tids t ∪ BIGUNION (IMAGE inf_set_tids (set (MAP SND subst))) +Proof + recInduct infer_type_subst_ind \\ rw[infer_type_subst_def, set_tids_def, inf_set_tids_def, SUBSET_DEF, PULL_EXISTS, MEM_MAP] \\ TRY FULL_CASE_TAC \\ fs[inf_set_tids_def] \\ imp_res_tac ALOOKUP_MEM - \\ metis_tac[SND]); + \\ metis_tac[SND] +QED -Theorem inf_set_tids_infer_deBruijn_subst_SUBSET - `∀subst t. +Theorem inf_set_tids_infer_deBruijn_subst_SUBSET: + ∀subst t. inf_set_tids (infer_deBruijn_subst subst t) ⊆ - inf_set_tids t ∪ BIGUNION (IMAGE inf_set_tids (set subst))` - (recInduct infer_deBruijn_subst_ind + inf_set_tids t ∪ BIGUNION (IMAGE inf_set_tids (set subst)) +Proof + recInduct infer_deBruijn_subst_ind \\ rw[infer_deBruijn_subst_def, inf_set_tids_def, SUBSET_DEF, PULL_EXISTS, MEM_MAP] - \\ metis_tac[MEM_EL]); + \\ metis_tac[MEM_EL] +QED -Theorem inf_set_tids_unconvert - `∀t. inf_set_tids (unconvert_t t) = set_tids t` - (recInduct set_tids_ind +Theorem inf_set_tids_unconvert: + ∀t. inf_set_tids (unconvert_t t) = set_tids t +Proof + recInduct set_tids_ind \\ rw[unconvert_t_def, inf_set_tids_def, set_tids_def] \\ rw[Once EXTENSION,MEM_MAP,PULL_EXISTS,EQ_IMP_THM] - \\ metis_tac[EXTENSION]); + \\ metis_tac[EXTENSION] +QED (* all the tids used in a tenv *) val inf_set_tids_ienv_def = Define` @@ -2282,12 +2434,13 @@ val prim_tids_def = Define` prim_tids contain tids ⇔ EVERY (\x. x ∈ tids ⇔ contain) (Tlist_num::Tbool_num::prim_type_nums)` -Theorem set_tids_subset_type_name_subst ` - ∀tenvt t tids. +Theorem set_tids_subset_type_name_subst: + ∀tenvt t tids. prim_tids T tids ∧ nsAll (λi (ls,t). set_tids_subset tids t) tenvt ==> - set_tids_subset tids (type_name_subst tenvt t)` - (ho_match_mp_tac type_name_subst_ind>> + set_tids_subset tids (type_name_subst tenvt t) +Proof + ho_match_mp_tac type_name_subst_ind>> rw[set_tids_def,type_name_subst_def,set_tids_subset_def] >- fs[prim_tids_def,prim_type_nums_def] >- ( @@ -2312,10 +2465,11 @@ Theorem set_tids_subset_type_name_subst ` metis_tac[MEM_EL]) >> drule nsLookup_nsAll >> disch_then drule>> - simp[]); + simp[] +QED -Theorem generalise_complete -`!n s l tvs s' ts next_uvar. +Theorem generalise_complete: + !n s l tvs s' ts next_uvar. generalise_list 0 n FEMPTY (MAP (t_walkstar s) l) = (tvs,s',ts) ∧ t_wfs s ∧ check_s 0 (count next_uvar) s ∧ @@ -2326,8 +2480,9 @@ Theorem generalise_complete t_wfs last_sub ∧ sub_completion (tvs + n) next_uvar s ec1 last_sub ∧ (TC_unit ∈ tids ∧ inf_set_tids_subst tids s ⇒ inf_set_tids_subst tids last_sub) - (* ∧ EVERY (check_t tvs (count ???)) (MAP FST ec1 ++ MAP SND ec1)*)` - (rw [] >> + (* ∧ EVERY (check_t tvs (count ???)) (MAP FST ec1 ++ MAP SND ec1)*) +Proof + rw [] >> imp_res_tac generalise_subst_empty >> rw [sub_completion_def] >> Q.ABBREV_TAC `unconstrained = count next_uvar DIFF (FDOM s ∪ FDOM s')` >> @@ -2517,29 +2672,39 @@ Theorem generalise_complete \\ rw[] \\ qhdtm_x_assum`inf_set_tids_subst`mp_tac \\ simp[inf_set_tids_subst_def,IN_FRANGE_FLOOKUP,PULL_EXISTS] - \\ metis_tac[])); + \\ metis_tac[]) +QED val init_infer_state_wfs = Q.prove ( `t_wfs (init_infer_state st).subst ∧ check_s 0 ∅ (init_infer_state st).subst`, rw [check_s_def, init_infer_state_def, t_wfs_def]); -Theorem init_infer_state_next_uvar[simp] - `(init_infer_state st).next_uvar = 0` - (rw [init_infer_state_def]); - -Theorem init_infer_state_subst[simp] - `(init_infer_state st).subst = FEMPTY` - (EVAL_TAC); - -Theorem t_wfs_FEMPTY[simp] - `t_wfs FEMPTY` - (rw[t_wfs_eqn] +Theorem init_infer_state_next_uvar[simp]: + (init_infer_state st).next_uvar = 0 +Proof + rw [init_infer_state_def] +QED + +Theorem init_infer_state_subst[simp]: + (init_infer_state st).subst = FEMPTY +Proof + EVAL_TAC +QED + +Theorem t_wfs_FEMPTY[simp]: + t_wfs FEMPTY +Proof + rw[t_wfs_eqn] \\ EVAL_TAC - \\ rw[relationTheory.WF_DEF, substTheory.vR_def]); + \\ rw[relationTheory.WF_DEF, substTheory.vR_def] +QED -Theorem t_wfs_init_infer_state[simp] - `t_wfs (init_infer_state s).subst` (rw[]); +Theorem t_wfs_init_infer_state[simp]: + t_wfs (init_infer_state s).subst +Proof +rw[] +QED val let_tac = drule (CONJUNCT1 infer_e_check_t) @@ -2594,14 +2759,16 @@ val check_env_letrec_lem2 = Q.prove ( >> Q.SPECL_THEN [`LENGTH funs`, `funs`, `0n`] mp_tac check_env_letrec_lem >> simp []); -Theorem ienv_ok_extend_dec_ienv - `!e1 e2 n. ienv_ok n e1 ∧ ienv_ok n e2 ⇒ ienv_ok n (extend_dec_ienv e1 e2)` - (rw [ienv_ok_def, ienv_val_ok_def, typeSoundInvariantsTheory.tenv_ctor_ok_def, +Theorem ienv_ok_extend_dec_ienv: + !e1 e2 n. ienv_ok n e1 ∧ ienv_ok n e2 ⇒ ienv_ok n (extend_dec_ienv e1 e2) +Proof + rw [ienv_ok_def, ienv_val_ok_def, typeSoundInvariantsTheory.tenv_ctor_ok_def, typeSoundInvariantsTheory.tenv_abbrev_ok_def, extend_dec_ienv_def] - >> metis_tac [nsAll_nsAppend]); + >> metis_tac [nsAll_nsAppend] +QED -Theorem infer_d_check -`(!d ienv st1 st2 ienv'. +Theorem infer_d_check: + (!d ienv st1 st2 ienv'. infer_d ienv d st1 = (Success ienv', st2) ∧ ienv_ok {} ienv ⇒ @@ -2610,8 +2777,9 @@ Theorem infer_d_check infer_ds ienv ds st1 = (Success ienv', st2) ∧ ienv_ok {} ienv ⇒ - ienv_ok {} ienv')` - (Induct>>rw[]>> + ienv_ok {} ienv') +Proof + Induct>>rw[]>> fs [infer_d_def, success_eqns]>> rpt (pairarg_tac >> fs [success_eqns])>> fs [init_state_def]>> rw[]>> @@ -2722,27 +2890,30 @@ Theorem infer_d_check >> match_mp_tac ienv_ok_extend_dec_ienv>> rpt (first_x_assum drule)>> rw[]>> - metis_tac[ienv_ok_extend_dec_ienv]); + metis_tac[ienv_ok_extend_dec_ienv] +QED -Theorem infer_p_next_id_const -`(!l cenv p st t env st'. +Theorem infer_p_next_id_const: + (!l cenv p st t env st'. (infer_p l cenv p st = (Success (t,env), st')) ⇒ st.next_id = st'.next_id) ∧ (!l cenv ps st ts env st'. (infer_ps l cenv ps st = (Success (ts,env), st')) ⇒ - st.next_id = st'.next_id)` -(ho_match_mp_tac infer_p_ind >> + st.next_id = st'.next_id) +Proof +ho_match_mp_tac infer_p_ind >> rw [infer_p_def, success_eqns, remove_pair_lem, GSYM FORALL_PROD] >> fs[]>> imp_res_tac type_name_check_subst_state >> fs [] >> res_tac >> -fs []); +fs [] +QED -Theorem infer_e_next_id_const -`(!l ienv e st st' t. +Theorem infer_e_next_id_const: + (!l ienv e st st' t. (infer_e l ienv e st = (Success t, st')) ⇒ st.next_id = st'.next_id) ∧ @@ -2757,8 +2928,9 @@ Theorem infer_e_next_id_const (!l ienv funs st st' ts. (infer_funs l ienv funs st = (Success ts, st')) ⇒ - st.next_id = st'.next_id)` -(ho_match_mp_tac infer_e_ind >> + st.next_id = st'.next_id) +Proof +ho_match_mp_tac infer_e_ind >> rw [infer_e_def, constrain_op_success, success_eqns, remove_pair_lem, GSYM FORALL_PROD] >> rw [] >> imp_res_tac type_name_check_subst_state >> @@ -2767,16 +2939,18 @@ res_tac >> fs [] >> every_case_tac >> fs [success_eqns] >> -metis_tac [infer_p_next_id_const,pair_CASES]); +metis_tac [infer_p_next_id_const,pair_CASES] +QED -Theorem infer_d_next_id_mono -`(!d ienv st t st'. +Theorem infer_d_next_id_mono: + (!d ienv st t st'. infer_d ienv d st = (Success t, st') ⇒ st.next_id ≤ st'.next_id) ∧ (!ds ienv st ts st'. (infer_ds ienv ds st = (Success ts, st') ⇒ - st.next_id ≤ st'.next_id))` - (Induct>>rw[]>> + st.next_id ≤ st'.next_id)) +Proof + Induct>>rw[]>> fs [infer_d_def, success_eqns]>> rpt (pairarg_tac >> fs [success_eqns])>> fs[init_state_def,init_infer_state_def]>> @@ -2786,7 +2960,8 @@ Theorem infer_d_next_id_mono imp_res_tac infer_e_next_id_const>> imp_res_tac infer_p_next_id_const>>fs[] >- (fs[n_fresh_id_def]>>rw[])>> - metis_tac[LESS_EQ_TRANS]); + metis_tac[LESS_EQ_TRANS] +QED val count_list_one = Q.prove ( `COUNT_LIST 1 = [0]`, @@ -2806,46 +2981,53 @@ rw [check_freevars_def] >> metis_tac []); (* -Theorem t_to_freevars_check -`(!t st fvs st'. +Theorem t_to_freevars_check: + (!t st fvs st'. (t_to_freevars t (st:'a) = (Success fvs, st')) ⇒ check_freevars 0 fvs t) ∧ (!ts st fvs st'. (ts_to_freevars ts (st:'a) = (Success fvs, st')) ⇒ - EVERY (check_freevars 0 fvs) ts)` -(Induct >> + EVERY (check_freevars 0 fvs) ts) +Proof +Induct >> rw [t_to_freevars_def, success_eqns, check_freevars_def] >> rw [] >> -metis_tac [check_freevars_more_append]); +metis_tac [check_freevars_more_append] +QED *) -Theorem check_freevars_more - `∀a b c. check_freevars a b c ⇒ ∀b'. set b ⊆ set b' ⇒ check_freevars a b' c` - (ho_match_mp_tac check_freevars_ind >> +Theorem check_freevars_more: + ∀a b c. check_freevars a b c ⇒ ∀b'. set b ⊆ set b' ⇒ check_freevars a b' c +Proof + ho_match_mp_tac check_freevars_ind >> rw[check_freevars_def] >- fs[SUBSET_DEF] >> - fs[EVERY_MEM]) + fs[EVERY_MEM] +QED (* -Theorem check_freevars_t_to_freevars - `(∀t fvs (st:'a). check_freevars 0 fvs t ⇒ +Theorem check_freevars_t_to_freevars: + (∀t fvs (st:'a). check_freevars 0 fvs t ⇒ ∃fvs' st'. t_to_freevars t st = (Success fvs', st') ∧ set fvs' ⊆ set fvs) ∧ (∀ts fvs (st:'a). EVERY (check_freevars 0 fvs) ts ⇒ - ∃fvs' st'. ts_to_freevars ts st = (Success fvs', st') ∧ set fvs' ⊆ set fvs)` - (Induct >> simp[check_freevars_def,t_to_freevars_def,PULL_EXISTS,success_eqns] >> - simp_tac(srw_ss()++boolSimps.ETA_ss)[] >> simp[] >> metis_tac[]) + ∃fvs' st'. ts_to_freevars ts st = (Success fvs', st') ∧ set fvs' ⊆ set fvs) +Proof + Induct >> simp[check_freevars_def,t_to_freevars_def,PULL_EXISTS,success_eqns] >> + simp_tac(srw_ss()++boolSimps.ETA_ss)[] >> simp[] >> metis_tac[] +QED *) -Theorem check_t_infer_type_subst_dbs - `∀m w t n u ls. +Theorem check_t_infer_type_subst_dbs: + ∀m w t n u ls. check_freevars m w t ∧ m + LENGTH ls ≤ n ∧ (ls = [] ⇒ 0 < m) ⇒ - check_t n u (infer_type_subst (ZIP(ls,MAP Infer_Tvar_db (COUNT_LIST (LENGTH ls)))) t)` - (ho_match_mp_tac check_freevars_ind >> + check_t n u (infer_type_subst (ZIP(ls,MAP Infer_Tvar_db (COUNT_LIST (LENGTH ls)))) t) +Proof + ho_match_mp_tac check_freevars_ind >> conj_tac >- ( simp[check_freevars_def] >> simp[infer_type_subst_def] >> @@ -2867,22 +3049,26 @@ Theorem check_t_infer_type_subst_dbs rw[check_freevars_def,infer_type_subst_def,check_t_def] >> simp[EVERY_MAP] >> fs[EVERY_MEM] ) >> rw[check_freevars_def,check_t_def,infer_type_subst_def] >> - DECIDE_TAC); + DECIDE_TAC +QED -Theorem nub_eq_nil - `∀ls. nub ls = [] ⇔ ls = []` - (Induct >> simp[nub_def] >> rw[] >> - Cases_on`ls`>>fs[]); +Theorem nub_eq_nil: + ∀ls. nub ls = [] ⇔ ls = [] +Proof + Induct >> simp[nub_def] >> rw[] >> + Cases_on`ls`>>fs[] +QED (* -Theorem check_specs_check -`!mn orig_tenvT idecls ienv specs st decls' ienv' st'. +Theorem check_specs_check: + !mn orig_tenvT idecls ienv specs st decls' ienv' st'. check_specs mn orig_tenvT idecls ienv specs st = (Success (decls',ienv'), st') ∧ tenv_abbrev_ok orig_tenvT ∧ ienv_ok {} ienv ⇒ - ienv_ok {} ienv'` - (ho_match_mp_tac check_specs_ind >> + ienv_ok {} ienv' +Proof + ho_match_mp_tac check_specs_ind >> STRIP_TAC >> REPEAT GEN_TAC >- (rw [check_specs_def, success_eqns] >> @@ -2977,23 +3163,27 @@ Theorem check_specs_check >> fs [ienv_ok_def, typeSoundInvariantsTheory.tenv_abbrev_ok_def] >> rw [Abbr `new_tenvT`] >> irule nsAll_nsBind - >> rw [check_freevars_def, EVERY_MAP, EVERY_MEM])); + >> rw [check_freevars_def, EVERY_MAP, EVERY_MEM]) +QED *) -Theorem ienv_ok_lift - `!mn ienv n. ienv_ok n ienv ⇒ ienv_ok n (lift_ienv mn ienv)` - (rw [lift_ienv_def, ienv_ok_def, ienv_val_ok_def, typeSoundInvariantsTheory.tenv_ctor_ok_def, - typeSoundInvariantsTheory.tenv_abbrev_ok_def]); +Theorem ienv_ok_lift: + !mn ienv n. ienv_ok n ienv ⇒ ienv_ok n (lift_ienv mn ienv) +Proof + rw [lift_ienv_def, ienv_ok_def, ienv_val_ok_def, typeSoundInvariantsTheory.tenv_ctor_ok_def, + typeSoundInvariantsTheory.tenv_abbrev_ok_def] +QED (* -Theorem infer_top_invariant -`!decls1 ienv top st1 decls' ienv' st2. +Theorem infer_top_invariant: + !decls1 ienv top st1 decls' ienv' st2. infer_top decls1 ienv top st1 = (Success (decls', ienv'), st2) ∧ ienv_ok {} ienv ⇒ - ienv_ok {} ienv'` - (rw [] + ienv_ok {} ienv' +Proof + rw [] >> Cases_on `top` >> fs [infer_top_def, success_eqns] >> rpt (pairarg_tac >> fs []) @@ -3017,16 +3207,18 @@ Theorem infer_top_invariant >> drule check_specs_check >> disch_then irule >> fs [ienv_ok_def, ienv_val_ok_def]) - >> metis_tac [infer_d_check]); + >> metis_tac [infer_d_check] +QED *) -Theorem sub_completion_wfs -`!n uvars s1 ts s2. +Theorem sub_completion_wfs: + !n uvars s1 ts s2. t_wfs s1 ∧ sub_completion n uvars s1 ts s2 ⇒ - t_wfs s2` - (rw [sub_completion_def] >> + t_wfs s2 +Proof + rw [sub_completion_def] >> pop_assum (fn _ => all_tac) >> pop_assum (fn _ => all_tac) >> pop_assum mp_tac >> @@ -3037,88 +3229,103 @@ Theorem sub_completion_wfs metis_tac [] >> PairCases_on `h` >> fs [pure_add_constraints_def] >> - metis_tac [t_unify_wfs]); - -Theorem infer_deBruijn_subst_id -`(!t. infer_deBruijn_subst [] t = t) ∧ - (!ts. MAP (infer_deBruijn_subst []) ts = ts)` - (Induct>>rw[]>>fs[infer_deBruijn_subst_def,MAP_EQ_ID]); - -Theorem deBruijn_subst_nothing - `(∀t. + metis_tac [t_unify_wfs] +QED + +Theorem infer_deBruijn_subst_id: + (!t. infer_deBruijn_subst [] t = t) ∧ + (!ts. MAP (infer_deBruijn_subst []) ts = ts) +Proof + Induct>>rw[]>>fs[infer_deBruijn_subst_def,MAP_EQ_ID] +QED + +Theorem deBruijn_subst_nothing: + (∀t. deBruijn_subst 0 [] t = t )∧ ∀ts. - MAP (deBruijn_subst 0 []) ts = ts` - (ho_match_mp_tac t_induction>> + MAP (deBruijn_subst 0 []) ts = ts +Proof + ho_match_mp_tac t_induction>> fs[deBruijn_subst_def]>>rw[]>> fs[LIST_EQ_REWRITE]>>rw[]>> - fs[MEM_EL,EL_MAP]); + fs[MEM_EL,EL_MAP] +QED -Theorem infer_deBruijn_subst_id2 - `(∀t. +Theorem infer_deBruijn_subst_id2: + (∀t. check_t tvs {} t ⇒ infer_deBruijn_subst (GENLIST (Infer_Tvar_db) tvs) t = t) ∧ (∀ts. EVERY (check_t tvs {}) ts ⇒ - MAP (infer_deBruijn_subst (GENLIST (Infer_Tvar_db) tvs)) ts = ts)` - (ho_match_mp_tac infer_tTheory.infer_t_induction>> + MAP (infer_deBruijn_subst (GENLIST (Infer_Tvar_db) tvs)) ts = ts) +Proof + ho_match_mp_tac infer_tTheory.infer_t_induction>> rw[]>>fs[check_t_def] >- fs[infer_deBruijn_subst_def] >> fs[infer_deBruijn_subst_def,EVERY_MEM]>> - metis_tac[]); + metis_tac[] +QED -Theorem check_t_infer_deBruijn_subst - `!subst t tvs uvs. +Theorem check_t_infer_deBruijn_subst: + !subst t tvs uvs. check_t (tvs + LENGTH subst) uvs t ∧ EVERY (check_t tvs uvs) subst ⇒ - check_t tvs uvs (infer_deBruijn_subst subst t)` - (ho_match_mp_tac infer_deBruijn_subst_ind + check_t tvs uvs (infer_deBruijn_subst subst t) +Proof + ho_match_mp_tac infer_deBruijn_subst_ind >> rw [infer_deBruijn_subst_def, check_t_def, EVERY_MEM, MEM_EL] >- metis_tac [] >> simp [EL_MAP] - >> metis_tac []); + >> metis_tac [] +QED -Theorem infer_deBruijn_subst_uncheck - `!s t max_tvs uvs. +Theorem infer_deBruijn_subst_uncheck: + !s t max_tvs uvs. check_t max_tvs uvs (infer_deBruijn_subst s t) ⇒ - check_t (max_tvs + LENGTH s) uvs t` - (ho_match_mp_tac infer_deBruijn_subst_ind + check_t (max_tvs + LENGTH s) uvs t +Proof + ho_match_mp_tac infer_deBruijn_subst_ind >> rw [check_t_def, infer_deBruijn_subst_def] >> fs [EVERY_MAP, EVERY_EL] >> rw [] >> first_x_assum drule - >> fs [MEM_EL, PULL_EXISTS]); -Theorem db_subst_inc_id - `!inst t. - infer_deBruijn_subst inst (infer_deBruijn_inc (LENGTH inst) t) = t` - (ho_match_mp_tac infer_deBruijn_subst_ind + >> fs [MEM_EL, PULL_EXISTS] +QED +Theorem db_subst_inc_id: + !inst t. + infer_deBruijn_subst inst (infer_deBruijn_inc (LENGTH inst) t) = t +Proof + ho_match_mp_tac infer_deBruijn_subst_ind >> rw [infer_deBruijn_inc_def, infer_deBruijn_subst_def, MAP_MAP_o, combinTheory.o_DEF] >> Induct_on `ts` - >> rw []); + >> rw [] +QED -Theorem t_walkstar_db_subst - `!inst t s. +Theorem t_walkstar_db_subst: + !inst t s. t_wfs s ⇒ t_walkstar s (infer_deBruijn_subst inst t) = infer_deBruijn_subst (MAP (t_walkstar s) inst) - (t_walkstar (infer_deBruijn_inc (LENGTH inst) o_f s) t)` - (ho_match_mp_tac infer_deBruijn_subst_ind + (t_walkstar (infer_deBruijn_inc (LENGTH inst) o_f s) t) +Proof + ho_match_mp_tac infer_deBruijn_subst_ind >> rw [infer_deBruijn_subst_def] >> drule inc_wfs >> disch_then (qspec_then `LENGTH inst` mp_tac) >> rw [t_walkstar_eqn1, infer_deBruijn_subst_def, EL_MAP, MAP_MAP_o, combinTheory.o_DEF, MAP_EQ_f] >> simp [walkstar_inc2] - >> metis_tac [db_subst_inc_id, LENGTH_MAP]); + >> metis_tac [db_subst_inc_id, LENGTH_MAP] +QED -Theorem generalise_subst_exist ` - (t_wfs s ∧ +Theorem generalise_subst_exist: + (t_wfs s ∧ (∀uv. uv ∈ FDOM s ⇒ check_t tvs {} (t_walkstar s (Infer_Tuvar uv)))) ⇒ (∀t subst n smap a b t'. @@ -3144,8 +3351,9 @@ Theorem generalise_subst_exist ` ∃subst'. LENGTH subst' = a ∧ (∀x. MEM x subst' ⇒ check_t tvs {} x) ∧ - (∀x. x ∈ FDOM b ⇒ EL (b ' x) (subst++subst') = t_walkstar s (Infer_Tuvar x)))` - (strip_tac>> + (∀x. x ∈ FDOM b ⇒ EL (b ' x) (subst++subst') = t_walkstar s (Infer_Tuvar x))) +Proof + strip_tac>> ho_match_mp_tac infer_tTheory.infer_t_induction>> srw_tac[][]>> fsrw_tac[][check_t_def] @@ -3199,10 +3407,11 @@ Theorem generalise_subst_exist ` DECIDE_TAC)>> rw[]>> qexists_tac`subst'++subst''`>>fs[]>> - metis_tac[]); + metis_tac[] +QED -Theorem infer_deBruijn_subst_infer_subst_walkstar ` - ∀b subst n m. +Theorem infer_deBruijn_subst_infer_subst_walkstar: + ∀b subst n m. FRANGE b ⊆ count (LENGTH subst) ∧ t_wfs s ⇒ @@ -3219,8 +3428,9 @@ Theorem infer_deBruijn_subst_infer_subst_walkstar ` EVERY (λt.t_vars t ⊆ FDOM b) ts ⇒ MAP ((infer_deBruijn_subst subst) o (infer_subst b)) ts = - MAP (t_walkstar s) ts))` - (ntac 5 strip_tac>> + MAP (t_walkstar s) ts)) +Proof + ntac 5 strip_tac>> ho_match_mp_tac infer_tTheory.infer_t_induction>>rw[]>> fs[infer_subst_def,t_walkstar_eqn1,check_t_def,infer_deBruijn_subst_def] >- @@ -3235,7 +3445,8 @@ Theorem infer_deBruijn_subst_infer_subst_walkstar ` fs[infer_deBruijn_subst_def]>> reverse IF_CASES_TAC >- (fs[SUBSET_DEF,IN_FRANGE,PULL_EXISTS]>>metis_tac[]) - >> REFL_TAC)); + >> REFL_TAC) +QED val remap_tenv_def = Define` remap_tenv f tenv = @@ -3245,47 +3456,54 @@ val remap_tenv_def = Define` v := nsMap (λ(n,t). (n,ts_tid_rename f t)) tenv.v |>` -Theorem remap_tenv_I[simp] - `remap_tenv I = I` - (rw[FUN_EQ_THM, remap_tenv_def, type_env_component_equality] +Theorem remap_tenv_I[simp]: + remap_tenv I = I +Proof + rw[FUN_EQ_THM, remap_tenv_def, type_env_component_equality] \\ qmatch_goalsub_abbrev_tac`nsMap I'` \\ `I' = I` by simp[Abbr`I'`, UNCURRY, FUN_EQ_THM] - \\ rw[]); + \\ rw[] +QED -Theorem t_vwalk_set_tids - `∀s. t_wfs s ⇒ +Theorem t_vwalk_set_tids: + ∀s. t_wfs s ⇒ ∀v. inf_set_tids_subst tids s ⇒ - inf_set_tids (t_vwalk s v) ⊆ tids` - (ntac 2 strip_tac + inf_set_tids (t_vwalk s v) ⊆ tids +Proof + ntac 2 strip_tac \\ recInduct(t_vwalk_ind) \\ rw[] \\ fs[] \\ rw[Once t_vwalk_eqn] \\ CASE_TAC \\ fs[inf_set_tids_def] \\ CASE_TAC \\ fs[inf_set_tids_def] \\ fs[inf_set_tids_subst_def, FRANGE_FLOOKUP, PULL_EXISTS, inf_set_tids_subset_def] - \\ res_tac \\ fs[inf_set_tids_def]); + \\ res_tac \\ fs[inf_set_tids_def] +QED -Theorem t_walk_set_tids - `∀s t t'. +Theorem t_walk_set_tids: + ∀s t t'. t_wfs s ∧ inf_set_tids_subst tids s ∧ inf_set_tids_subset tids t ∧ t_walk s t = t' ⇒ - inf_set_tids_subset tids t'` - (Cases_on`t` + inf_set_tids_subset tids t' +Proof + Cases_on`t` \\ rw[t_walk_eqn] \\ fs[inf_set_tids_subset_def] - \\ metis_tac[t_vwalk_set_tids]); + \\ metis_tac[t_vwalk_set_tids] +QED -Theorem t_walkstar_set_tids - `∀s t t'. +Theorem t_walkstar_set_tids: + ∀s t t'. t_wfs s ∧ inf_set_tids_subst tids s ∧ inf_set_tids_subset tids t ∧ t_walkstar s t = t' ⇒ - inf_set_tids_subset tids t'` - (gen_tac + inf_set_tids_subset tids t' +Proof + gen_tac \\ simp[GSYM AND_IMP_INTRO, GSYM PULL_FORALL] \\ strip_tac \\ simp[AND_IMP_INTRO, PULL_FORALL] @@ -3298,10 +3516,11 @@ Theorem t_walkstar_set_tids \\ disch_then drule \\ fs[inf_set_tids_def] \\ fs[SUBSET_DEF, PULL_EXISTS, MEM_MAP] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem t_unify_set_tids ` - (∀s t1 t2. t_wfs s ==> +Theorem t_unify_set_tids: + (∀s t1 t2. t_wfs s ==> ∀s'. inf_set_tids_subst tids s ∧ inf_set_tids_subset tids t1 ∧ @@ -3314,8 +3533,9 @@ Theorem t_unify_set_tids ` EVERY (inf_set_tids_subset tids) ts1 ∧ EVERY (inf_set_tids_subset tids) ts2 ∧ ts_unify s ts1 ts2 = SOME s' ⇒ - inf_set_tids_subst tids s')` - (ho_match_mp_tac t_unify_strongind>> + inf_set_tids_subst tids s') +Proof + ho_match_mp_tac t_unify_strongind>> rw[t_unify_eqn]>> every_case_tac>>fs[t_ext_s_check_eqn]>>rw[]>> TRY ( @@ -3324,24 +3544,27 @@ Theorem t_unify_set_tids ` rfs[inf_set_tids_subst_def, FRANGE_FLOOKUP, PULL_EXISTS, FLOOKUP_UPDATE] \\ rw[] \\ res_tac \\ fs[inf_set_tids_subset_def, inf_set_tids_def, SUBSET_DEF, PULL_EXISTS, MEM_MAP, EVERY_MEM] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem pure_add_constraints_set_tids - `∀s1 ls s2. +Theorem pure_add_constraints_set_tids: + ∀s1 ls s2. t_wfs s1 ∧ EVERY (inf_set_tids_subset tids) (MAP FST ls) ∧ EVERY (inf_set_tids_subset tids) (MAP SND ls) ∧ inf_set_tids_subst tids s1 ∧ pure_add_constraints s1 ls s2 ⇒ - inf_set_tids_subst tids s2` - (recInduct pure_add_constraints_ind + inf_set_tids_subst tids s2 +Proof + recInduct pure_add_constraints_ind \\ rw[pure_add_constraints_def] \\ rw[] - \\ metis_tac[t_unify_set_tids, t_unify_wfs]); + \\ metis_tac[t_unify_set_tids, t_unify_wfs] +QED val hide_def = Define`hide x = x`; -Theorem infer_p_inf_set_tids ` - (!l cenv p st t env st'. +Theorem infer_p_inf_set_tids: + (!l cenv p st t env st'. (infer_p l cenv p st = (Success (t,env), st')) ⇒ prim_tids T tids ∧ inf_set_tids_ienv tids cenv ∧ inf_set_tids_subst tids st.subst @@ -3358,8 +3581,9 @@ Theorem infer_p_inf_set_tids ` ⇒ EVERY (inf_set_tids_subset tids) ts ∧ EVERY (inf_set_tids_subset tids o SND) env ∧ - inf_set_tids_subst tids st'.subst)` - (Q.ISPEC_THEN`_ ∧ _ ∧ inf_set_tids_subst _ _ `(fn th => once_rewrite_tac[th])(GSYM hide_def) >> + inf_set_tids_subst tids st'.subst) +Proof + Q.ISPEC_THEN`_ ∧ _ ∧ inf_set_tids_subst _ _ `(fn th => once_rewrite_tac[th])(GSYM hide_def) >> ho_match_mp_tac infer_p_ind >> rw [pat_bindings_def, infer_p_def, success_eqns, remove_pair_lem] >> simp[inf_set_tids_subset_def,inf_set_tids_def]>> @@ -3446,16 +3670,18 @@ Theorem infer_p_inf_set_tids ` fs[hide_def])>> fs[hide_def,SUBSET_DEF,MEM_MAP,PULL_EXISTS,EVERY_MEM,inf_set_tids_subset_def]>> rw[]>> - metis_tac[])); + metis_tac[]) +QED -Theorem constrain_op_set_tids - `constrain_op l op ts st = (Success t, st') ∧ +Theorem constrain_op_set_tids: + constrain_op l op ts st = (Success t, st') ∧ EVERY (inf_set_tids_subset tids) ts ∧ inf_set_tids_subst tids st.subst ∧ t_wfs st.subst ∧ prim_tids T tids ⇒ - inf_set_tids_subset tids t ∧ inf_set_tids_subst tids st'.subst` - (simp[constrain_op_success,success_eqns] + inf_set_tids_subset tids t ∧ inf_set_tids_subst tids st'.subst +Proof + simp[constrain_op_success,success_eqns] \\ strip_tac \\ rveq >> TRY pairarg_tac \\ fs[success_eqns, inf_set_tids_subset_def, inf_set_tids_def, LET_THM] @@ -3468,10 +3694,11 @@ Theorem constrain_op_set_tids \\ rpt ( (impl_tac >-(TRY(rename1`word_tc wz`\\Cases_on`wz`\\simp[word_tc_def]) \\fs[prim_tids_def,prim_type_nums_def])) - \\ strip_tac \\ fs[])); + \\ strip_tac \\ fs[]) +QED -Theorem infer_e_inf_set_tids ` - (!l cenv p st t st'. +Theorem infer_e_inf_set_tids: + (!l cenv p st t st'. (infer_e l cenv p st = (Success t, st')) ⇒ prim_tids T tids ∧ inf_set_tids_ienv tids cenv ∧ inf_set_tids_subst tids st.subst @@ -3503,8 +3730,9 @@ Theorem infer_e_inf_set_tids ` ∧ t_wfs st.subst ⇒ EVERY (inf_set_tids_subset tids) ts ∧ - inf_set_tids_subst tids st'.subst)` - (Q.ISPEC_THEN`EVERY _ _ ∧ _ `(fn th => once_rewrite_tac[th])(GSYM hide_def) + inf_set_tids_subst tids st'.subst) +Proof + Q.ISPEC_THEN`EVERY _ _ ∧ _ `(fn th => once_rewrite_tac[th])(GSYM hide_def) \\ Q.ISPEC_THEN`inf_set_tids_subset _ _ ∧ _ `(fn th => once_rewrite_tac[th])(GSYM hide_def) \\ ho_match_mp_tac infer_e_ind >> rw [pat_bindings_def, infer_e_def, success_eqns, remove_pair_lem] >> @@ -3661,14 +3889,16 @@ Theorem infer_e_inf_set_tids ` \\ first_x_assum match_mp_tac \\ fs[inf_set_tids_ienv_def] \\ match_mp_tac nsAll_nsBind - \\ fs[inf_set_tids_subset_def, inf_set_tids_def] )); + \\ fs[inf_set_tids_subset_def, inf_set_tids_def] ) +QED -Theorem generalise_inf_set_tids - `(∀d a b c e f g. generalise a b c d = (e,f,g) ⇒ +Theorem generalise_inf_set_tids: + (∀d a b c e f g. generalise a b c d = (e,f,g) ⇒ inf_set_tids g = inf_set_tids d) ∧ (∀d a b c e f g. generalise_list a b c d = (e,f,g) ⇒ - EVERY2 (inv_image $= inf_set_tids) d g)` - (Induct + EVERY2 (inv_image $= inf_set_tids) d g) +Proof + Induct \\ rw[generalise_def, inf_set_tids_def] \\ rw[inf_set_tids_def] \\ every_case_tac \\ rw[] \\ fs[inf_set_tids_def] @@ -3677,56 +3907,69 @@ Theorem generalise_inf_set_tids \\ res_tac \\ fs[] \\ AP_TERM_TAC \\ fs[LIST_REL_EL_EQN, EXTENSION,MEM_MAP,PULL_EXISTS,MEM_EL] - \\ metis_tac[]); - -Theorem start_type_id_prim_tids_count - `start_type_id ≤ n ⇒ prim_tids T (count n)` - (rw[prim_tids_def,prim_type_nums_def,start_type_id_def] - \\ EVAL_TAC \\ fs[]); - -Theorem inf_set_tids_subst_FEMPTY[simp] - `inf_set_tids_subst tids FEMPTY` - (EVAL_TAC \\ rw[]); - -Theorem build_ctor_tenv_FOLDR - `∀tenvT tds ids. + \\ metis_tac[] +QED + +Theorem start_type_id_prim_tids_count: + start_type_id ≤ n ⇒ prim_tids T (count n) +Proof + rw[prim_tids_def,prim_type_nums_def,start_type_id_def] + \\ EVAL_TAC \\ fs[] +QED + +Theorem inf_set_tids_subst_FEMPTY[simp]: + inf_set_tids_subst tids FEMPTY +Proof + EVAL_TAC \\ rw[] +QED + +Theorem build_ctor_tenv_FOLDR: + ∀tenvT tds ids. LENGTH tds = LENGTH ids ⇒ build_ctor_tenv tenvT tds ids = FOLDR (combin$C nsAppend) (alist_to_ns []) (MAP (alist_to_ns o REVERSE) (MAP2 (λ(tvs,tn,ctors) id. (MAP (λ(cn,ts). (cn,tvs,MAP (type_name_subst tenvT) ts,id)) ctors)) - tds ids))` - (recInduct build_ctor_tenv_ind - \\ rw[build_ctor_tenv_def]); - -Theorem build_ctor_tenv_FOLDL - `∀tenvT tds ids. + tds ids)) +Proof + recInduct build_ctor_tenv_ind + \\ rw[build_ctor_tenv_def] +QED + +Theorem build_ctor_tenv_FOLDL: + ∀tenvT tds ids. LENGTH tds = LENGTH ids ⇒ build_ctor_tenv tenvT tds ids = FOLDL nsAppend (alist_to_ns []) (REVERSE (MAP (alist_to_ns o REVERSE) (MAP2 (λ(tvs,tn,ctors) id. (MAP (λ(cn,ts). (cn,tvs,MAP (type_name_subst tenvT) ts,id)) ctors)) - tds ids)))` - (simp[FOLDL_FOLDR_REVERSE] + tds ids))) +Proof + simp[FOLDL_FOLDR_REVERSE] \\ recInduct build_ctor_tenv_ind - \\ rw[build_ctor_tenv_def]); - -Theorem nsMap_FOLDL_nsAppend - `∀ls ns. nsMap f (FOLDL nsAppend ns ls) = - FOLDL nsAppend (nsMap f ns) (MAP (nsMap f) ls)` - (Induct \\ rw[] \\ rw[nsMap_nsAppend]); - -Theorem nsAll_FOLDL_nsAppend - `∀ls ns. + \\ rw[build_ctor_tenv_def] +QED + +Theorem nsMap_FOLDL_nsAppend: + ∀ls ns. nsMap f (FOLDL nsAppend ns ls) = + FOLDL nsAppend (nsMap f ns) (MAP (nsMap f) ls) +Proof + Induct \\ rw[] \\ rw[nsMap_nsAppend] +QED + +Theorem nsAll_FOLDL_nsAppend: + ∀ls ns. nsAll P ns ∧ EVERY (nsAll P) ls - ⇒ nsAll P (FOLDL nsAppend ns ls)` - (Induct \\ rw[] + ⇒ nsAll P (FOLDL nsAppend ns ls) +Proof + Induct \\ rw[] \\ first_x_assum match_mp_tac \\ fs[] - \\ match_mp_tac nsAll_nsAppend \\ fs[]); + \\ match_mp_tac nsAll_nsAppend \\ fs[] +QED -Theorem infer_d_inf_set_tids - `(∀d ienv st ienv' st'. +Theorem infer_d_inf_set_tids: + (∀d ienv st ienv' st'. infer_d ienv d st = (Success ienv', st') ∧ start_type_id ≤ st.next_id ∧ inf_set_tids_ienv (count st.next_id) ienv @@ -3737,8 +3980,9 @@ Theorem infer_d_inf_set_tids start_type_id ≤ st.next_id ∧ inf_set_tids_ienv (count st.next_id) ienv ⇒ - inf_set_tids_ienv (count st'.next_id) ienv')` - (Induct + inf_set_tids_ienv (count st'.next_id) ienv') +Proof + Induct \\ rw[infer_d_def, success_eqns] \\ rpt(pairarg_tac \\ fs[success_eqns]) \\ rw[] \\ rpt(first_x_assum drule \\ rw[]) @@ -3899,10 +4143,10 @@ Theorem infer_d_inf_set_tids rw[]>> first_x_assum drule>>fs[]>> disch_then drule>>fs[]) - ); +QED -Theorem infer_d_wfs - `(∀d ienv st ienv' st'. +Theorem infer_d_wfs: + (∀d ienv st ienv' st'. infer_d ienv d st = (Success ienv', st') ∧ t_wfs st.subst ⇒ @@ -3911,8 +4155,9 @@ Theorem infer_d_wfs infer_ds ienv ds st = (Success ienv', st') ∧ t_wfs st.subst ⇒ - t_wfs st'.subst)` - (Induct + t_wfs st'.subst) +Proof + Induct \\ rw[infer_d_def, success_eqns, init_state_def] \\ rpt(pairarg_tac \\ fs[success_eqns]) \\ rw[] >> @@ -3924,6 +4169,7 @@ Theorem infer_d_wfs \\ imp_res_tac t_unify_wfs \\ fs[] \\ imp_res_tac pure_add_constraints_wfs \\ fs[n_fresh_id_def] \\ rw[] - \\ metis_tac[]); + \\ metis_tac[] +QED val _ = export_theory (); diff --git a/compiler/inference/proofs/inferSoundScript.sml b/compiler/inference/proofs/inferSoundScript.sml index 384b0ffbe0..ae68272334 100644 --- a/compiler/inference/proofs/inferSoundScript.sml +++ b/compiler/inference/proofs/inferSoundScript.sml @@ -71,16 +71,18 @@ val lookup_var_empty = Q.prove(` EVERY_CASE_TAC>>fs[tveLookup_def]); (* TODO: This should be generalized eventually *) -Theorem env_rel_complete_bind ` - env_rel_complete FEMPTY ienv tenv Empty ⇒ - env_rel_complete FEMPTY ienv tenv (bind_tvar tvs Empty)` - (rw[env_rel_complete_def,lookup_var_empty]>>res_tac>>fs[] +Theorem env_rel_complete_bind: + env_rel_complete FEMPTY ienv tenv Empty ⇒ + env_rel_complete FEMPTY ienv tenv (bind_tvar tvs Empty) +Proof + rw[env_rel_complete_def,lookup_var_empty]>>res_tac>>fs[] >- metis_tac[] >> match_mp_tac tscheme_approx_weakening>>qexists_tac`0`>> HINT_EXISTS_TAC>> - fs[t_wfs_def]); + fs[t_wfs_def] +QED (* TODO: The generated set of type identifiers (tids) must be related to st2.next_id in some way @@ -97,24 +99,30 @@ val set_ids_eq = Q.prove(` rw[EQ_IMP_THM]>> qexists_tac`x-n1`>>fs[]); -Theorem set_ids_same[simp] - `set_ids x x = {}` - (rw[set_ids_eq]); +Theorem set_ids_same[simp]: + set_ids x x = {} +Proof + rw[set_ids_eq] +QED -Theorem set_ids_eq_union - `x <= y /\ y <= z ==> set_ids x z = set_ids x y UNION set_ids y z` - (fs [set_ids_def, EXTENSION]); +Theorem set_ids_eq_union: + x <= y /\ y <= z ==> set_ids x z = set_ids x y UNION set_ids y z +Proof + fs [set_ids_def, EXTENSION] +QED -Theorem set_ids_eq_union_eq - `x <= y /\ y <= z /\ s = set_ids y z - ==> set_ids x z = set_ids x y UNION s` - (fs [set_ids_eq_union]); +Theorem set_ids_eq_union_eq: + x <= y /\ y <= z /\ s = set_ids y z + ==> set_ids x z = set_ids x y UNION s +Proof + fs [set_ids_eq_union] +QED fun str_tac strs = ConseqConv.CONSEQ_CONV_TAC (ConseqConv.CONSEQ_REWRITE_CONV ([], strs, [])); -Theorem infer_d_sound - `(!d tenv ienv st1 st2 ienv'. +Theorem infer_d_sound: + (!d tenv ienv st1 st2 ienv'. infer_d ienv d st1 = (Success ienv', st2) ∧ env_rel tenv ienv ∧ start_type_id ≤ st1.next_id @@ -125,8 +133,9 @@ Theorem infer_d_sound env_rel tenv ienv ∧ start_type_id ≤ st1.next_id ⇒ - type_ds T tenv ds (set_ids st1.next_id st2.next_id) (ienv_to_tenv ienv'))` - (Induct + type_ds T tenv ds (set_ids st1.next_id st2.next_id) (ienv_to_tenv ienv')) +Proof + Induct >- ( (* Dlet *) rw[infer_d_def,success_eqns]>> @@ -693,10 +702,11 @@ Theorem infer_d_sound fs[env_rel_def]>> metis_tac[infer_d_check]) >> - fs[set_ids_def,EXTENSION,DISJOINT_DEF])); + fs[set_ids_def,EXTENSION,DISJOINT_DEF]) +QED -Theorem db_subst_infer_subst_swap2 -`(!t s tvs uvar n. +Theorem db_subst_infer_subst_swap2: + (!t s tvs uvar n. t_wfs s ∧ check_t tvs {} t ⇒ @@ -718,21 +728,24 @@ Theorem db_subst_infer_subst_swap2 ts = MAP (deBruijn_subst 0 (MAP (convert_t o t_walkstar s) (MAP (λn. Infer_Tuvar n) (COUNT_LIST tvs))) o convert_t) - ts))` -(ho_match_mp_tac infer_t_induction >> + ts)) +Proof +ho_match_mp_tac infer_t_induction >> rw [convert_t_def, deBruijn_subst_def, EL_MAP, t_walkstar_eqn1, infer_deBruijn_subst_def, MAP_MAP_o, combinTheory.o_DEF, check_t_def, - LENGTH_COUNT_LIST]); + LENGTH_COUNT_LIST] +QED (* -Theorem check_tscheme_inst_sound - `!tvs_impl t_impl tvs_spec t_spec. +Theorem check_tscheme_inst_sound: + !tvs_impl t_impl tvs_spec t_spec. check_t tvs_impl {} t_impl ∧ check_t tvs_spec {} t_spec ∧ check_tscheme_inst x (tvs_spec,t_spec) (tvs_impl,t_impl) ⇒ - tscheme_inst (tvs_spec, convert_t t_spec) (tvs_impl, convert_t t_impl)` - (rw [check_tscheme_inst_def, tscheme_inst_def] >> + tscheme_inst (tvs_spec, convert_t t_spec) (tvs_impl, convert_t t_impl) +Proof + rw [check_tscheme_inst_def, tscheme_inst_def] >> every_case_tac >> fs [success_eqns] >> rw [] >> @@ -823,13 +836,15 @@ Theorem check_tscheme_inst_sound >- ( imp_res_tac check_t_t_vars >> fs [EXTENSION, SUBSET_DEF, COUNT_LIST_GENLIST, MAP_GENLIST] >> - metis_tac []))); + metis_tac [])) +QED -Theorem weak_tenv_ienv_to_tenv - `!ienv1 ienv2. +Theorem weak_tenv_ienv_to_tenv: + !ienv1 ienv2. ienv_ok {} ienv1 ∧ ienv_ok {} ienv2 ∧ - check_weak_ienv ienv1 ienv2 ⇒ weak_tenv (ienv_to_tenv ienv1) (ienv_to_tenv ienv2)` - (rw [check_weak_ienv_def, weak_tenv_def, ienv_to_tenv_def, GSYM nsSub_compute_thm] >> + check_weak_ienv ienv1 ienv2 ⇒ weak_tenv (ienv_to_tenv ienv1) (ienv_to_tenv ienv2) +Proof + rw [check_weak_ienv_def, weak_tenv_def, ienv_to_tenv_def, GSYM nsSub_compute_thm] >> simp [nsSub_nsMap] >> fs [tscheme_inst2_def] >> irule nsSub_mono2 >> @@ -849,14 +864,17 @@ Theorem weak_tenv_ienv_to_tenv drule nsLookup_nsAll >> disch_then drule >> rw [] >> - metis_tac [check_tscheme_inst_sound]); + metis_tac [check_tscheme_inst_sound] +QED -Theorem weak_decls_ienv_to_tenv - `!idecls1 idecls2. - check_weak_decls idecls1 idecls2 ⇒ weak_decls (convert_decls idecls1) (convert_decls idecls2)` - (rw [check_weak_decls_def, weak_decls_def, convert_decls_def, SUBSET_DEF, +Theorem weak_decls_ienv_to_tenv: + !idecls1 idecls2. + check_weak_decls idecls1 idecls2 ⇒ weak_decls (convert_decls idecls1) (convert_decls idecls2) +Proof + rw [check_weak_decls_def, weak_decls_def, convert_decls_def, SUBSET_DEF, EVERY_MEM, list_subset_def, list_set_eq_def, EXTENSION] >> - metis_tac []); + metis_tac [] +QED val check_freevars_nub = Q.prove ( `(!t x fvs. @@ -994,13 +1012,14 @@ val check_specs_sound = Q.prove ( union_decls_def, convert_decls_def] >> metis_tac [GSYM nsAppend_assoc, nsAppend_nsSing, INSERT_SING_UNION, UNION_ASSOC])); -Theorem infer_top_sound - `!idecls ienv top st1 idecls' ienv' st2 tenv. +Theorem infer_top_sound: + !idecls ienv top st1 idecls' ienv' st2 tenv. infer_top idecls ienv top st1 = (Success (idecls',ienv'), st2) ∧ env_rel tenv ienv ⇒ - type_top T (convert_decls idecls) tenv top (convert_decls idecls') (ienv_to_tenv ienv')` - (rw [] >> + type_top T (convert_decls idecls) tenv top (convert_decls idecls') (ienv_to_tenv ienv') +Proof + rw [] >> Cases_on `top` >> fs [infer_top_def, success_eqns, type_top_cases] >> pairarg_tac >> @@ -1060,15 +1079,17 @@ Theorem infer_top_sound irule infer_d_sound >> rw [] >> fs [success_eqns] >> - metis_tac [])); + metis_tac []) +QED -Theorem infer_prog_sound - `!idecls ienv prog st1 idecls' ienv' st2 tenv. +Theorem infer_prog_sound: + !idecls ienv prog st1 idecls' ienv' st2 tenv. infer_prog idecls ienv prog st1 = (Success (idecls',ienv'), st2) ∧ env_rel tenv ienv ⇒ - type_prog T (convert_decls idecls) tenv prog (convert_decls idecls') (ienv_to_tenv ienv')` - (induct_on `prog` >> + type_prog T (convert_decls idecls) tenv prog (convert_decls idecls') (ienv_to_tenv ienv') +Proof + induct_on `prog` >> rw [infer_prog_def, success_eqns] >- rw [empty_decls_def,convert_decls_def, empty_inf_decls_def] >- rw [ienv_to_tenv_def] >> @@ -1092,7 +1113,8 @@ Theorem infer_prog_sound qexists_tac `extend_dec_ienv ienv2 ienv1` >> simp [] >> metis_tac [env_rel_extend, env_rel_ienv_to_tenv, env_rel_def, - infer_top_invariant]); + infer_top_invariant] +QED *) val _ = export_theory (); diff --git a/compiler/inference/proofs/infer_eCompleteScript.sml b/compiler/inference/proofs/infer_eCompleteScript.sml index 27a29d2d81..e3fdd18988 100644 --- a/compiler/inference/proofs/infer_eCompleteScript.sml +++ b/compiler/inference/proofs/infer_eCompleteScript.sml @@ -11,43 +11,47 @@ open namespaceTheory namespacePropsTheory envRelTheory; val _ = new_theory "infer_eComplete"; (*Useful lemmas about pure add constraints, some of these imply the others*) -Theorem pure_add_constraints_success -` -!s constraints s'. +Theorem pure_add_constraints_success: + !s constraints s'. t_wfs s ∧ pure_add_constraints s constraints s' ⇒ s SUBMAP s' ∧ FDOM s ⊆ FDOM s' ∧ t_compat s s' ∧ -t_wfs s'` - (ho_match_mp_tac pure_add_constraints_ind>> +t_wfs s' +Proof + ho_match_mp_tac pure_add_constraints_ind>> fs[pure_add_constraints_def,t_compat_refl]>> ntac 7 strip_tac>> imp_res_tac t_unify_unifier>> res_tac>>fs[]>>CONJ_ASM1_TAC>> - metis_tac[SUBMAP_DEF,SUBSET_DEF,SUBMAP_t_compat,SUBMAP_TRANS]); + metis_tac[SUBMAP_DEF,SUBSET_DEF,SUBMAP_t_compat,SUBMAP_TRANS] +QED (*t_compat is preserved over certain types of pure_add_constraints*) -Theorem t_compat_pure_add_constraints_1 -`!ls s sx. +Theorem t_compat_pure_add_constraints_1: + !ls s sx. t_compat s sx ∧ EVERY (\x,y. t_walkstar sx x = t_walkstar sx y) ls ⇒ - ?si. pure_add_constraints s ls si ∧ t_compat si sx` - (Induct>>fs[pure_add_constraints_def]>>rw[]>> + ?si. pure_add_constraints s ls si ∧ t_compat si sx +Proof + Induct>>fs[pure_add_constraints_def]>>rw[]>> Cases_on`h`>>fs[]>> simp[pure_add_constraints_def]>> imp_res_tac t_compat_eqs_t_unify>> - fs[]); + fs[] +QED (*If pure add constraints succeeds then the constraints all unify*) -Theorem t_compat_pure_add_constraints_2 -`!ls s sx. +Theorem t_compat_pure_add_constraints_2: + !ls s sx. t_wfs s ∧ pure_add_constraints s ls sx ⇒ - EVERY (\x,y. t_walkstar sx x = t_walkstar sx y) ls` - (Induct>>rw[]>> + EVERY (\x,y. t_walkstar sx x = t_walkstar sx y) ls +Proof + Induct>>rw[]>> Cases_on`h`>>fs[pure_add_constraints_def] >- (imp_res_tac t_unify_unifier>> @@ -58,22 +62,25 @@ Theorem t_compat_pure_add_constraints_2 metis_tac[t_walkstar_SUBMAP]>> fs[]) >> - metis_tac[t_unify_wfs]); + metis_tac[t_unify_wfs] +QED (*behaves like a function if the first 2 arguments are equal*) -Theorem pure_add_constraints_functional -` !constraints s s' s''. +Theorem pure_add_constraints_functional: + !constraints s s' s''. t_wfs s ∧ pure_add_constraints s constraints s' ∧ - pure_add_constraints s constraints s'' ⇒ s' = s''` - (Induct>> + pure_add_constraints s constraints s'' ⇒ s' = s'' +Proof + Induct>> rw[]>> fs[pure_add_constraints_def]>> Cases_on`h`>> fs[pure_add_constraints_def]>> fs[t_unify_eqn]>> imp_res_tac t_unify_wfs>> - metis_tac[]); + metis_tac[] +QED (*1 direction is sufficient to imply the other*) val pure_add_constraints_swap_lemma = Q.prove( @@ -96,19 +103,21 @@ val pure_add_constraints_swap_lemma = Q.prove( rfs[]>> HINT_EXISTS_TAC>>fs[]); -Theorem pure_add_constraints_swap -`t_wfs s ∧ +Theorem pure_add_constraints_swap: + t_wfs s ∧ pure_add_constraints s (a++b) sx ⇒ ?si. pure_add_constraints s (b++a) si ∧ t_compat si sx ∧ - t_compat sx si` - (rw[]>> + t_compat sx si +Proof + rw[]>> assume_tac pure_add_constraints_swap_lemma>>rfs[]>> HINT_EXISTS_TAC>>fs[]>> imp_res_tac pure_add_constraints_swap_lemma>> imp_res_tac pure_add_constraints_functional>> - fs[t_compat_trans]); + fs[t_compat_trans] +QED val pure_add_constraints_swap = GEN_ALL pure_add_constraints_swap; @@ -149,8 +158,8 @@ val FDOM_extend = Q.prove ( Cases_on`x=next_uvar`>>fs[]>> `x>fs[]); -Theorem pure_add_constraints_exists -`!s ts next_uvar lim. +Theorem pure_add_constraints_exists: + !s ts next_uvar lim. t_wfs s ∧ FDOM s = count next_uvar ∧ EVERY (check_freevars lim []) ts @@ -159,8 +168,9 @@ Theorem pure_add_constraints_exists let targs = MAP unconvert_t ts in let constraints = ZIP ((MAP Infer_Tuvar tys),targs) in let extension = ZIP (tys,targs) in - pure_add_constraints s constraints (s|++extension)` - (induct_on`ts`>> + pure_add_constraints s constraints (s|++extension) +Proof + induct_on`ts`>> srw_tac[][] >>unabbrev_all_tac>> srw_tac[] [COUNT_LIST_def, pure_add_constraints_def]>-rw[FUPDATE_LIST]>> fsrw_tac[][LET_THM,MAP_MAP_o, combinTheory.o_DEF, DECIDE ``x + SUC y = (SUC x) + y``] >> @@ -189,7 +199,8 @@ Theorem pure_add_constraints_exists res_tac>> fs[FUPDATE_LIST_THM]) >- - fs[check_t_def]); + fs[check_t_def] +QED (*Can't find a version of this in the right direction*) val check_t_t_walkstar = prove @@ -401,15 +412,17 @@ val t_unify_ignore = Q.prove( Cases_on`ts`>>Cases_on`ts'`>> fs[ts_unify_def]); -Theorem pure_add_constraints_ignore -`!s ls. t_wfs s ∧ EVERY (λx,y. t_walkstar s x = t_walkstar s y) ls - ⇒ pure_add_constraints s ls s` - (strip_tac>>Induct>> +Theorem pure_add_constraints_ignore: + !s ls. t_wfs s ∧ EVERY (λx,y. t_walkstar s x = t_walkstar s y) ls + ⇒ pure_add_constraints s ls s +Proof + strip_tac>>Induct>> fs[pure_add_constraints_def]>> rw[]>> Cases_on`h` >>rw[pure_add_constraints_def]>> fs[]>>imp_res_tac t_unify_ignore>> - metis_tac[]); + metis_tac[] +QED (*t_compat preserves all grounded (no unification variable after walk) terms*) val t_compat_ground = Q.prove( @@ -444,9 +457,8 @@ val t_walkstar_tuvar_props2 = Q.prove( fs[]); (*Remove every uvar in the FDOM if we walkstar using a completed map*) -Theorem check_t_less -` - (!t. +Theorem check_t_less: + (!t. t_wfs s ∧ (!uv. uv ∈ FDOM s ⇒ check_t n {} (t_walkstar s (Infer_Tuvar uv))) ∧ check_t 0 uvars t @@ -457,8 +469,9 @@ Theorem check_t_less (!uv. uv ∈ FDOM s ⇒ check_t n {} (t_walkstar s (Infer_Tuvar uv))) ∧ EVERY (check_t 0 uvars) ts ⇒ - EVERY (check_t n (uvars ∩ (COMPL (FDOM s)))) (MAP (t_walkstar s) ts))` - (ho_match_mp_tac infer_tTheory.infer_t_induction>> + EVERY (check_t n (uvars ∩ (COMPL (FDOM s)))) (MAP (t_walkstar s) ts)) +Proof + ho_match_mp_tac infer_tTheory.infer_t_induction>> rw[] >- fs[t_walkstar_eqn,t_walk_eqn,check_t_def] >- @@ -469,19 +482,21 @@ Theorem check_t_less (res_tac>>fs[check_t_more]) >> imp_res_tac t_walkstar_tuvar_props>> - fs[check_t_def]); + fs[check_t_def] +QED (*Double sided t_compat thm*) -Theorem t_compat_bi_ground -`(!uv. uv ∈ FDOM a ⇒ check_t n {} (t_walkstar a (Infer_Tuvar uv))) ∧ +Theorem t_compat_bi_ground: + (!uv. uv ∈ FDOM a ⇒ check_t n {} (t_walkstar a (Infer_Tuvar uv))) ∧ t_compat a b ∧ t_compat b a ⇒ (!uv. uv ∈ FDOM b ⇒ check_t n {} (t_walkstar b (Infer_Tuvar uv))) ∧ FDOM a = FDOM b ∧ ((!t. t_walkstar a t= t_walkstar b t) ∧ - (!ts. MAP (t_walkstar a) ts = MAP (t_walkstar b) ts))` - (strip_tac>> + (!ts. MAP (t_walkstar a) ts = MAP (t_walkstar b) ts)) +Proof + strip_tac>> CONJ_ASM1_TAC >- (fs[t_compat_def]>> @@ -515,7 +530,8 @@ Theorem t_compat_bi_ground >- metis_tac[t_walkstar_no_vars] >> - metis_tac[t_walkstar_tuvar_props]); + metis_tac[t_walkstar_tuvar_props] +QED (*Free properties when extending the completed map with uvar->ground var*) val extend_one_props = Q.prove( @@ -604,8 +620,8 @@ val submap_t_walkstar_replace = Q.prove( imp_res_tac t_walkstar_SUBMAP>> metis_tac[t_walkstar_no_vars]); -Theorem extend_multi_props -`!st constraints s ts n. +Theorem extend_multi_props: + !st constraints s ts n. t_wfs st.subst ∧ t_wfs s ∧ pure_add_constraints st.subst constraints s ∧ @@ -625,8 +641,9 @@ Theorem extend_multi_props FDOM s' = count (st.next_uvar +LENGTH ts) ∧ (∀n. n> + ∀uv. uv ∈ FDOM s' ⇒ check_t n {} (t_walkstar s' (Infer_Tuvar uv)) +Proof + rpt strip_tac>> fsrw_tac[][LET_THM]>>CONJ_ASM1_TAC>- (imp_res_tac pure_add_constraints_exists>> fs[LET_THM])>> @@ -684,7 +701,8 @@ Theorem extend_multi_props fs[EVERY_EL,EL_MAP]>> first_x_assum(qspec_then `uv-st.next_uvar` mp_tac)>> impl_tac>- DECIDE_TAC>> - metis_tac[check_freevars_to_check_t]); + metis_tac[check_freevars_to_check_t] +QED (*Useful tactics, mainly for constrain_op*) @@ -992,15 +1010,17 @@ val simp_tenv_invC_append = Q.prove( every_case_tac>>res_tac>>fs[]>>metis_tac[]); (*convert on both sides of eqn*) -Theorem convert_bi_remove -`convert_t A = convert_t B ∧ +Theorem convert_bi_remove: + convert_t A = convert_t B ∧ check_t n {} A ∧ check_t m {} B ⇒ - A = B` - (rw[]>> + A = B +Proof + rw[]>> last_x_assum (assume_tac o (Q.AP_TERM `unconvert_t`))>> - metis_tac[check_t_empty_unconvert_convert_id]); + metis_tac[check_t_empty_unconvert_convert_id] +QED (*Substituting every tvs away with something that has no tvs leaves none left*) val infer_type_subst_check_t_less = Q.prove( @@ -1032,9 +1052,8 @@ val infer_type_subst_check_t_less = Q.prove( fs[EVERY_MAP]>>metis_tac[]); -Theorem infer_p_complete -` - (!tvs tenv p t tenvE. +Theorem infer_p_complete: + (!tvs tenv p t tenvE. type_p tvs tenv p t tenvE ⇒ !l s ienv st constraints. @@ -1075,8 +1094,9 @@ Theorem infer_p_complete FDOM s' = count st'.next_uvar ∧ t_compat s s' ∧ simp_tenv_invC s' tvs new_bindings tenvE ∧ - ts = MAP (convert_t o t_walkstar s') ts')` - (ho_match_mp_tac type_p_strongind>> + ts = MAP (convert_t o t_walkstar s') ts') +Proof + ho_match_mp_tac type_p_strongind>> rw[UNCURRY,success_eqns,infer_p_def] >- (Q.SPECL_THEN [`t`,`st`,`s`,`tvs`,`constraints`] @@ -1304,21 +1324,24 @@ Theorem infer_p_complete metis_tac[t_compat_def]>> rw[]>>AP_TERM_TAC>> fs[t_compat_def]>> - metis_tac[t_walkstar_no_vars])); + metis_tac[t_walkstar_no_vars]) +QED (*Specialize check_t_less a bit since we use this form a lot*) -Theorem sub_completion_completes -`t_wfs s ∧ +Theorem sub_completion_completes: + t_wfs s ∧ check_t 0 (count n) t ∧ FDOM s = count n ∧ (!uv. uv < n ⇒ check_t tvs {} (t_walkstar s (Infer_Tuvar uv))) ⇒ - check_t tvs {} (t_walkstar s t)` - (assume_tac (GEN_ALL (CONJUNCT1 check_t_less))>> + check_t tvs {} (t_walkstar s t) +Proof + assume_tac (GEN_ALL (CONJUNCT1 check_t_less))>> rw[]>> first_x_assum(qspecl_then[`count n`,`s`,`tvs`,`t`] mp_tac)>> - impl_tac>>fs[]); + impl_tac>>fs[] +QED val lookup_var_bind_var_list = Q.prove( `!bindings. @@ -1593,9 +1616,8 @@ val ienv_val_ok_more = Q.prove(` res_tac>>fs[]>> metis_tac[check_t_more4,check_t_more5]); -Theorem infer_e_complete -` - (!tenv tenvE e t. +Theorem infer_e_complete: + (!tenv tenvE e t. type_e tenv tenvE e t ⇒ !loc s ienv st constraints. @@ -1657,8 +1679,9 @@ Theorem infer_e_complete FDOM st'.subst ⊆ count st'.next_uvar ∧ FDOM s' = count st'.next_uvar ∧ t_compat s s' ∧ - MAP SND env = MAP (convert_t o t_walkstar s') env')` - (ho_match_mp_tac type_e_strongind >> + MAP SND env = MAP (convert_t o t_walkstar s') env') +Proof + ho_match_mp_tac type_e_strongind >> rw [add_constraint_success,success_eqns,infer_e_def] (*Easy cases*) >- (qexists_tac `s` >> @@ -2641,6 +2664,7 @@ Theorem infer_e_complete imp_res_tac infer_e_check_t>> rfs[]>> imp_res_tac sub_completion_completes>> - AP_TERM_TAC>>metis_tac[t_walkstar_no_vars])) ; + AP_TERM_TAC>>metis_tac[t_walkstar_no_vars]) +QED ; val _ = export_theory (); diff --git a/compiler/inference/proofs/infer_eSoundScript.sml b/compiler/inference/proofs/infer_eSoundScript.sml index f92bdb7b72..fcf9cf62f3 100644 --- a/compiler/inference/proofs/infer_eSoundScript.sml +++ b/compiler/inference/proofs/infer_eSoundScript.sml @@ -25,13 +25,15 @@ val sub_completion_unify = Q.prove ( rw [sub_completion_def, pure_add_constraints_def] >> full_simp_tac (srw_ss()++ARITH_ss) [SUBSET_DEF, count_add1]); -Theorem sub_completion_unify2 -`!t1 t2 s1 ts s2 n s3 next_uvar. +Theorem sub_completion_unify2: + !t1 t2 s1 ts s2 n s3 next_uvar. (t_unify s1 t1 t2 = SOME s2) ∧ sub_completion n next_uvar s2 ts s3 ⇒ - sub_completion n next_uvar s1 ((t1,t2)::ts) s3` -(rw [sub_completion_def, pure_add_constraints_def]); + sub_completion n next_uvar s1 ((t1,t2)::ts) s3 +Proof +rw [sub_completion_def, pure_add_constraints_def] +QED val sub_completion_infer = Q.prove ( `!l ienv e st1 t st2 n ts2 s. @@ -48,13 +50,14 @@ rw [] >| rw [], full_simp_tac (srw_ss()++ARITH_ss) [SUBSET_DEF]]); -Theorem sub_completion_add_constraints -`!s1 ts1 s2 n next_uvar s3 ts2. +Theorem sub_completion_add_constraints: + !s1 ts1 s2 n next_uvar s3 ts2. pure_add_constraints s1 ts1 s2 ∧ sub_completion n next_uvar s2 ts2 s3 ⇒ - sub_completion n next_uvar s1 (ts1++ts2) s3` -(induct_on `ts1` >> + sub_completion n next_uvar s1 (ts1++ts2) s3 +Proof +induct_on `ts1` >> rw [pure_add_constraints_def] >> Cases_on `h` >> fs [pure_add_constraints_def] >> @@ -62,7 +65,8 @@ res_tac >> fs [sub_completion_def] >> rw [] >> fs [pure_add_constraints_def, pure_add_constraints_append] >> -metis_tac []); +metis_tac [] +QED val sub_completion_more_vars = Q.prove ( `!m n1 n2 s1 ts s2. @@ -84,8 +88,8 @@ res_tac >> imp_res_tac sub_completion_infer >> metis_tac [APPEND_ASSOC]); -Theorem sub_completion_infer_p -`(!l cenv p st t env st' tvs extra_constraints s. +Theorem sub_completion_infer_p: + (!l cenv p st t env st' tvs extra_constraints s. infer_p l cenv p st = (Success (t,env), st') ∧ sub_completion tvs st'.next_uvar st'.subst extra_constraints s ⇒ @@ -94,8 +98,9 @@ Theorem sub_completion_infer_p infer_ps l cenv ps st = (Success (ts,env), st') ∧ sub_completion tvs st'.next_uvar st'.subst extra_constraints s ⇒ - ?ts. sub_completion tvs st.next_uvar st.subst (ts++extra_constraints) s)` -(ho_match_mp_tac infer_p_ind >> + ?ts. sub_completion tvs st.next_uvar st.subst (ts++extra_constraints) s) +Proof +ho_match_mp_tac infer_p_ind >> rw [infer_p_def, success_eqns, remove_pair_lem] >> fs [] >- metis_tac [APPEND, sub_completion_more_vars] @@ -124,7 +129,8 @@ fs [] >- (PairCases_on `v'` >> PairCases_on `v''` >> fs [] >> - metis_tac [APPEND_ASSOC])); + metis_tac [APPEND_ASSOC]) +QED val sub_completion_infer_pes = Q.prove ( `!l ienv pes t1 t2 st1 t st2 n ts2 s. @@ -166,14 +172,15 @@ imp_res_tac sub_completion_infer >> fs [] >> metis_tac [sub_completion_more_vars, APPEND_ASSOC]); -Theorem sub_completion_apply -`!n uvars s1 ts s2 t1 t2. +Theorem sub_completion_apply: + !n uvars s1 ts s2 t1 t2. t_wfs s1 ∧ (t_walkstar s1 t1 = t_walkstar s1 t2) ∧ sub_completion n uvars s1 ts s2 ⇒ - (t_walkstar s2 t1 = t_walkstar s2 t2)` -(rw [sub_completion_def] >> + (t_walkstar s2 t1 = t_walkstar s2 t2) +Proof +rw [sub_completion_def] >> pop_assum (fn _ => all_tac) >> pop_assum (fn _ => all_tac) >> pop_assum mp_tac >> @@ -186,7 +193,8 @@ metis_tac [] >> cases_on `h` >> fs [pure_add_constraints_def] >> fs [] >> -metis_tac [t_unify_apply2, t_unify_wfs]); +metis_tac [t_unify_apply2, t_unify_wfs] +QED val sub_completion_apply_list = Q.prove ( `!n uvars s1 ts s2 ts1 ts2. @@ -222,8 +230,8 @@ fs [sub_completion_def] >| (* ---------- Soundness ---------- *) -Theorem infer_p_sound -`(!l ienv p st t tenv env st' tvs extra_constraints s. +Theorem infer_p_sound: + (!l ienv p st t tenv env st' tvs extra_constraints s. infer_p l ienv p st = (Success (t,env), st') ∧ t_wfs st.subst ∧ tenv_ctor_ok tenv.c ∧ @@ -242,8 +250,9 @@ Theorem infer_p_sound tenv_abbrev_ok tenv.t ∧ sub_completion tvs st'.next_uvar st'.subst extra_constraints s ⇒ - type_ps tvs tenv ps (MAP (convert_t o t_walkstar s) ts) (convert_env s env))` -(ho_match_mp_tac infer_p_ind >> + type_ps tvs tenv ps (MAP (convert_t o t_walkstar s) ts) (convert_env s env)) +Proof +ho_match_mp_tac infer_p_ind >> rw [infer_p_def, success_eqns, remove_pair_lem] >> rw [Once type_p_cases, convert_env_def] >> imp_res_tac sub_completion_wfs >> @@ -356,7 +365,8 @@ fs [] `t_wfs st''.subst` by metis_tac [infer_p_wfs] >> `?ts. sub_completion tvs st''.next_uvar st''.subst ts s` by metis_tac [sub_completion_infer_p] >> fs [convert_env_def] >> - metis_tac [])); + metis_tac []) +QED val letrec_lemma = Q.prove ( `!funs funs_ts s st. @@ -390,10 +400,12 @@ fs [] >> PairCases_on `h` >> rw []); -Theorem word_tc_cases ` - (word_tc wz = Tword8_num ⇔ wz = W8) ∧ - (word_tc wz = Tword64_num ⇔ wz = W64)` - (Cases_on`wz`>>rw[word_tc_def,Tword8_num_def,Tword64_num_def]); +Theorem word_tc_cases: + (word_tc wz = Tword8_num ⇔ wz = W8) ∧ + (word_tc wz = Tword64_num ⇔ wz = W64) +Proof + Cases_on`wz`>>rw[word_tc_def,Tword8_num_def,Tword64_num_def] +QED val binop_tac = imp_res_tac infer_e_wfs >> @@ -440,23 +452,25 @@ val constrain_op_sound = Q.prove ( fs [success_eqns] >> binop_tac); -Theorem infer_deBruijn_subst_walkstar - `!ts t s. +Theorem infer_deBruijn_subst_walkstar: + !ts t s. t_wfs s ⇒ t_walkstar s (infer_deBruijn_subst (MAP (t_walkstar s) ts) t) = - t_walkstar s (infer_deBruijn_subst ts t)` - (ho_match_mp_tac infer_deBruijn_subst_ind + t_walkstar s (infer_deBruijn_subst ts t) +Proof + ho_match_mp_tac infer_deBruijn_subst_ind >> rw [infer_deBruijn_subst_def, EL_MAP] >- metis_tac [SUBMAP_REFL, t_walkstar_idempotent] >> rw [t_walkstar_eqn1, MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> `MEM (EL n ts') ts'` by (rw [MEM_EL] >> metis_tac []) >> first_x_assum drule >> disch_then drule - >> simp [EL_MAP]); + >> simp [EL_MAP] +QED -Theorem infer_e_sound -`(!l ienv e st st' tenv tenvE t extra_constraints s. +Theorem infer_e_sound: + (!l ienv e st st' tenv tenvE t extra_constraints s. infer_e l ienv e st = (Success t, st') ∧ ienv_ok (count st.next_uvar) ienv ∧ env_rel_sound s ienv tenv tenvE ∧ @@ -488,8 +502,9 @@ Theorem infer_e_sound sub_completion (num_tvs tenvE) st'.next_uvar st'.subst extra_constraints s ∧ ALL_DISTINCT (MAP FST funs) ⇒ - type_funs tenv tenvE funs (MAP2 (\(x,y,z) t. (x, (convert_t o t_walkstar s) t)) funs ts))` - (ho_match_mp_tac infer_e_ind >> + type_funs tenv tenvE funs (MAP2 (\(x,y,z) t. (x, (convert_t o t_walkstar s) t)) funs ts)) +Proof + ho_match_mp_tac infer_e_ind >> rw [infer_e_def, success_eqns, remove_pair_lem] >> rw [check_t_def] >> fs [check_t_def] >> @@ -1179,6 +1194,7 @@ Theorem infer_e_sound rw [ALOOKUP_FAILS, MAP2_MAP, MEM_MAP, MEM_ZIP] >> PairCases_on `y` >> fs [MEM_MAP, MEM_EL] >> - metis_tac [FST]])); + metis_tac [FST]]) +QED val _ = export_theory (); diff --git a/compiler/inference/proofs/type_dCanonScript.sml b/compiler/inference/proofs/type_dCanonScript.sml index 1a2db76bba..d46df88ef4 100644 --- a/compiler/inference/proofs/type_dCanonScript.sml +++ b/compiler/inference/proofs/type_dCanonScript.sml @@ -16,45 +16,56 @@ val tenv_equiv_def = Define nsAll2 (λi v1 v2. v1 = v2) tenv1.c tenv2.c ∧ nsAll2 (λi v1 v2. v1 = v2) tenv1.v tenv2.v`; -Theorem tenv_equiv_refl[simp] - `tenv_equiv tenv tenv` - (rw[tenv_equiv_def, nsAll2_def] +Theorem tenv_equiv_refl[simp]: + tenv_equiv tenv tenv +Proof + rw[tenv_equiv_def, nsAll2_def] \\ irule nsSub_refl \\ rw[nsAll_def] - \\ qexists_tac`K (K T)`\\ rw[]); - -Theorem tenv_equiv_sym - `tenv_equiv t1 t2 ⇒ tenv_equiv t2 t1` - (rw[tenv_equiv_def, nsAll2_def, nsSub_def]); - -Theorem tenv_equiv_tenvLift - `tenv_equiv t1 t2 ⇒ tenv_equiv (tenvLift m t1) (tenvLift m t2)` - (rw[tenv_equiv_def, tenvLift_def]); - -Theorem check_type_names_tenv_equiv - `∀t1 t t2. + \\ qexists_tac`K (K T)`\\ rw[] +QED + +Theorem tenv_equiv_sym: + tenv_equiv t1 t2 ⇒ tenv_equiv t2 t1 +Proof + rw[tenv_equiv_def, nsAll2_def, nsSub_def] +QED + +Theorem tenv_equiv_tenvLift: + tenv_equiv t1 t2 ⇒ tenv_equiv (tenvLift m t1) (tenvLift m t2) +Proof + rw[tenv_equiv_def, tenvLift_def] +QED + +Theorem check_type_names_tenv_equiv: + ∀t1 t t2. nsAll2 (λi v1 v2. v1 = v2) t1 t2 ∧ check_type_names t1 t ⇒ - check_type_names t2 t` - (recInduct check_type_names_ind + check_type_names t2 t +Proof + recInduct check_type_names_ind \\ rw[check_type_names_def] \\ fs[EVERY_MEM, option_case_NONE_F] - \\ imp_res_tac nsAll2_nsLookup1 \\ fs[]); + \\ imp_res_tac nsAll2_nsLookup1 \\ fs[] +QED -Theorem lookup_var_tenv_equiv - `tenv_equiv tenv1 tenv2 ⇒ lookup_var n bvs tenv1 = lookup_var n bvs tenv2` - (rw[tenv_equiv_def, lookup_var_def, lookup_varE_def] +Theorem lookup_var_tenv_equiv: + tenv_equiv tenv1 tenv2 ⇒ lookup_var n bvs tenv1 = lookup_var n bvs tenv2 +Proof + rw[tenv_equiv_def, lookup_var_def, lookup_varE_def] \\ every_case_tac \\ fs[] \\ (fn g as (asl,w) => Cases_on[ANTIQUOTE(lhs w)] g) \\ imp_res_tac nsAll2_nsLookup_none \\ imp_res_tac nsAll2_nsLookup1 - \\ fs[]); + \\ fs[] +QED -Theorem type_name_subst_tenv_equiv - `∀t1 t t2. +Theorem type_name_subst_tenv_equiv: + ∀t1 t t2. nsAll2 (λi v1 v2. v1 = v2) t1 t2 ⇒ - type_name_subst t1 t = type_name_subst t2 t` - (recInduct type_name_subst_ind + type_name_subst t1 t = type_name_subst t2 t +Proof + recInduct type_name_subst_ind \\ rw[type_name_subst_def, MAP_EQ_f] \\ CASE_TAC \\ imp_res_tac nsAll2_nsLookup_none \\ fs[MAP_EQ_f] @@ -62,18 +73,20 @@ Theorem type_name_subst_tenv_equiv \\ CASE_TAC \\ AP_THM_TAC \\ ntac 4 AP_TERM_TAC - \\ rw[MAP_EQ_f]); + \\ rw[MAP_EQ_f] +QED -Theorem type_p_tenv_equiv - `(∀tvs tenv1 p t bindings. +Theorem type_p_tenv_equiv: + (∀tvs tenv1 p t bindings. type_p tvs tenv1 p t bindings ⇒ ∀tenv2. tenv_equiv tenv1 tenv2 ⇒ type_p tvs tenv2 p t bindings) ∧ (∀tvs tenv1 ps ts bindings. type_ps tvs tenv1 ps ts bindings ⇒ ∀tenv2. tenv_equiv tenv1 tenv2 ⇒ - type_ps tvs tenv2 ps ts bindings)` - (ho_match_mp_tac type_p_ind + type_ps tvs tenv2 ps ts bindings) +Proof + ho_match_mp_tac type_p_ind \\ rw[] \\ rw[Once type_p_cases] \\ first_x_assum drule \\ rw[] @@ -83,10 +96,11 @@ Theorem type_p_tenv_equiv \\ imp_res_tac type_name_subst_tenv_equiv \\ imp_res_tac check_type_names_tenv_equiv \\ fs[] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem type_e_tenv_equiv - `(∀tenv1 bvs e t. +Theorem type_e_tenv_equiv: + (∀tenv1 bvs e t. type_e tenv1 bvs e t ⇒ ∀tenv2. tenv_equiv tenv1 tenv2 ⇒ type_e tenv2 bvs e t) ∧ @@ -97,8 +111,9 @@ Theorem type_e_tenv_equiv (∀tenv1 bvs funs ts. type_funs tenv1 bvs funs ts ⇒ ∀tenv2. tenv_equiv tenv1 tenv2 ⇒ - type_funs tenv2 bvs funs ts)` - (ho_match_mp_tac type_e_ind + type_funs tenv2 bvs funs ts) +Proof + ho_match_mp_tac type_e_ind \\ rw[] \\ rw[Once type_e_cases] \\ TRY(first_x_assum drule \\ rw[]) @@ -109,17 +124,20 @@ Theorem type_e_tenv_equiv \\ fs[tenv_equiv_def] \\ imp_res_tac nsAll2_nsLookup1 \\ fs[] \\ rw[] \\ metis_tac[type_p_tenv_equiv, tenv_equiv_def, - type_name_subst_tenv_equiv, check_type_names_tenv_equiv]); + type_name_subst_tenv_equiv, check_type_names_tenv_equiv] +QED -Theorem type_pe_determ_tenv_equiv - `type_pe_determ t1 x y z ∧ +Theorem type_pe_determ_tenv_equiv: + type_pe_determ t1 x y z ∧ tenv_equiv t1 t2 ⇒ - type_pe_determ t2 x y z` - (rw[type_pe_determ_def] + type_pe_determ t2 x y z +Proof + rw[type_pe_determ_def] \\ imp_res_tac tenv_equiv_sym \\ imp_res_tac type_p_tenv_equiv \\ imp_res_tac type_e_tenv_equiv - \\ res_tac); + \\ res_tac +QED (* -- *) @@ -139,15 +157,17 @@ val type_pe_determ_canon_def = Define` EVERY (λ(k,t). set_tids_subset (count n) t) tenv2 ⇒ tenv1 = tenv2`; -Theorem type_pe_determ_canon_tenv_equiv - `type_pe_determ_canon n t1 x y z ∧ +Theorem type_pe_determ_canon_tenv_equiv: + type_pe_determ_canon n t1 x y z ∧ tenv_equiv t1 t2 ⇒ - type_pe_determ_canon n t2 x y z` - (rw[type_pe_determ_canon_def] + type_pe_determ_canon n t2 x y z +Proof + rw[type_pe_determ_canon_def] \\ imp_res_tac tenv_equiv_sym \\ imp_res_tac type_p_tenv_equiv \\ imp_res_tac type_e_tenv_equiv - \\ res_tac); + \\ res_tac +QED (* A "canonical" version of type_d that produces the type identifiers in ascending order. @@ -309,16 +329,20 @@ val extend_bij_def = Define` v` *) -Theorem extend_bij_id[simp] ` - (extend_bij f f s 0 = f) ∧ - (extend_bij f g {} n = f)` - (rw[extend_bij_def,FUN_EQ_THM]); - -Theorem extend_bij_compose - `extend_bij (extend_bij f g ids n) h jds (n + m) = - extend_bij f (extend_bij g h jds m) (ids ∪ jds) n` - (rw[extend_bij_def,FUN_EQ_THM] - \\ rw[] \\ fs[]); +Theorem extend_bij_id[simp]: + (extend_bij f f s 0 = f) ∧ + (extend_bij f g {} n = f) +Proof + rw[extend_bij_def,FUN_EQ_THM] +QED + +Theorem extend_bij_compose: + extend_bij (extend_bij f g ids n) h jds (n + m) = + extend_bij f (extend_bij g h jds m) (ids ∪ jds) n +Proof + rw[extend_bij_def,FUN_EQ_THM] + \\ rw[] \\ fs[] +QED (* needs monotonicity of set_tids_tenv *) val set_tids_tenv_extend_dec_tenv = Q.prove(` @@ -328,15 +352,17 @@ val set_tids_tenv_extend_dec_tenv = Q.prove(` set_tids_tenv (s' ∪ s) (extend_dec_tenv t' t)`, rw[extend_dec_tenv_def,set_tids_tenv_def,nsAll_nsAppend]); -Theorem set_tids_tenv_remap - `set_tids_tenv tids tenv ⇒ - set_tids_tenv (IMAGE f tids) (remap_tenv f tenv)` - (rw[set_tids_tenv_def, remap_tenv_def, nsAll_nsMap, set_tids_subset_def, +Theorem set_tids_tenv_remap: + set_tids_tenv tids tenv ⇒ + set_tids_tenv (IMAGE f tids) (remap_tenv f tenv) +Proof + rw[set_tids_tenv_def, remap_tenv_def, nsAll_nsMap, set_tids_subset_def, UNCURRY, set_tids_ts_tid_rename, EVERY_MAP] \\ fs[LAMBDA_PROD] \\ first_assum(mp_then Any match_mp_tac nsAll_mono) \\ simp[FORALL_PROD, EVERY_MEM] - \\ metis_tac[]); + \\ metis_tac[] +QED val good_remap_extend_bij = Q.prove(` good_remap f ∧ prim_tids F ids ⇒ @@ -360,26 +386,29 @@ val remap_tenv_extend_dec_tenv = Q.prove(` extend_dec_tenv (remap_tenv f t) (remap_tenv f t')`, fs[remap_tenv_def,extend_dec_tenv_def,nsMap_nsAppend]); -Theorem BIJ_extend_bij ` - DISJOINT tids ids ∧ +Theorem BIJ_extend_bij: + DISJOINT tids ids ∧ BIJ f tids (count n) ∧ BIJ g ids (count (CARD ids)) ⇒ - BIJ (extend_bij f g ids n) (tids ∪ ids) (count (n + CARD ids))` - (rewrite_tac[INJ_DEF,SURJ_DEF,BIJ_DEF,extend_bij_def,IN_DISJOINT] + BIJ (extend_bij f g ids n) (tids ∪ ids) (count (n + CARD ids)) +Proof + rewrite_tac[INJ_DEF,SURJ_DEF,BIJ_DEF,extend_bij_def,IN_DISJOINT] \\ strip_tac \\ rewrite_tac[IN_UNION, count_add, IN_IMAGE] \\ reverse conj_tac >- metis_tac[] \\ conj_tac >- metis_tac[] \\ rw[] - \\ rpt (first_x_assum drule)>>fs[]); + \\ rpt (first_x_assum drule)>>fs[] +QED (* -Theorem INJ_extend_bij ` - DISJOINT tids ids ∧ +Theorem INJ_extend_bij: + DISJOINT tids ids ∧ INJ f tids (count n) ∧ INJ g ids (count (CARD ids)) ⇒ - INJ (extend_bij f g ids n) (tids ∪ ids) (count (n + CARD ids))` - (rewrite_tac[INJ_DEF,extend_bij_def,IN_DISJOINT,IN_COUNT,IN_UNION] + INJ (extend_bij f g ids n) (tids ∪ ids) (count (n + CARD ids)) +Proof + rewrite_tac[INJ_DEF,extend_bij_def,IN_DISJOINT,IN_COUNT,IN_UNION] \\ rpt strip_tac \\ res_tac \\ rpt (pop_assum mp_tac) @@ -387,27 +416,32 @@ Theorem INJ_extend_bij ` \\ rpt IF_CASES_TAC \\ rpt strip_tac \\ full_simp_tac bool_ss [] - \\ fs[]); + \\ fs[] +QED -Theorem BIJ_extend_bij ` - DISJOINT tids ids ∧ +Theorem BIJ_extend_bij: + DISJOINT tids ids ∧ BIJ f tids (count n) ∧ BIJ g ids (count (CARD ids)) ⇒ - BIJ (extend_bij f g tids ids n) (tids ∪ ids) (count (n + CARD ids))` - (rewrite_tac[INJ_DEF,SURJ_DEF,BIJ_DEF,extend_bij_def,IN_DISJOINT] + BIJ (extend_bij f g tids ids n) (tids ∪ ids) (count (n + CARD ids)) +Proof + rewrite_tac[INJ_DEF,SURJ_DEF,BIJ_DEF,extend_bij_def,IN_DISJOINT] \\ strip_tac \\ rewrite_tac[IN_UNION, count_add, IN_IMAGE] \\ reverse conj_tac >- metis_tac[] \\ conj_tac >- metis_tac[] \\ rw[] - \\ rpt (first_x_assum drule)>>fs[]); + \\ rpt (first_x_assum drule)>>fs[] +QED *) -Theorem set_tids_subset_mono - `∀tids t tids'. +Theorem set_tids_subset_mono: + ∀tids t tids'. set_tids_subset tids t ∧ tids ⊆ tids' ⇒ - set_tids_subset tids' t` - (rw[set_tids_subset_def, SUBSET_DEF]); + set_tids_subset tids' t +Proof + rw[set_tids_subset_def, SUBSET_DEF] +QED val set_tids_tenv_mono = Q.prove(` set_tids_tenv tids tenv ∧ tids ⊆ tids' ⇒ @@ -472,28 +506,33 @@ val sing_renum_NOT_tscheme_inst = Q.prove(` \\ fs[check_freevars_def,EVERY_MEM,MEM_MAP,PULL_EXISTS,MAP_MAP_o,MAP_EQ_ID] \\ metis_tac[])); -Theorem sing_renum_NOTIN_ID - `∀t. +Theorem sing_renum_NOTIN_ID: + ∀t. m ∉ set_tids t ⇒ - ts_tid_rename (sing_renum m n) t = t` - (ho_match_mp_tac t_ind>>rw[]>> + ts_tid_rename (sing_renum m n) t = t +Proof + ho_match_mp_tac t_ind>>rw[]>> fs[ts_tid_rename_def,sing_renum_def,set_tids_def]>> fs[EVERY_MEM,MAP_EQ_ID,MEM_MAP]>> - metis_tac[]); + metis_tac[] +QED -Theorem sing_renum_IN_NOT_ID - `∀t. m ∈ set_tids t ∧ m ≠ n ⇒ ts_tid_rename (sing_renum m n) t ≠ t` - (ho_match_mp_tac t_ind>>rw[]>> +Theorem sing_renum_IN_NOT_ID: + ∀t. m ∈ set_tids t ∧ m ≠ n ⇒ ts_tid_rename (sing_renum m n) t ≠ t +Proof + ho_match_mp_tac t_ind>>rw[]>> fs[ts_tid_rename_def,sing_renum_def,set_tids_def]>> fs[EVERY_MEM,MAP_EQ_ID,MEM_MAP]>> - metis_tac[]); + metis_tac[] +QED (* TODO: this is only true up to equivalence on tenvs *) -Theorem sing_renum_NOTIN_tenv_ID - `set_tids_tenv tids tenv ∧ +Theorem sing_renum_NOTIN_tenv_ID: + set_tids_tenv tids tenv ∧ m ∉ tids ⇒ - tenv_equiv (remap_tenv (sing_renum m n) tenv) (tenv)` - (rw[remap_tenv_def,type_env_component_equality]>> + tenv_equiv (remap_tenv (sing_renum m n) tenv) (tenv) +Proof + rw[remap_tenv_def,type_env_component_equality]>> fs[set_tids_tenv_def,set_tids_subset_def,tenv_equiv_def]>> rw[nsAll2_def, nsSub_def, nsLookup_nsMap, nsLookupMod_nsMap] \\ imp_res_tac nsLookup_nsAll \\ fs[] @@ -503,10 +542,11 @@ Theorem sing_renum_NOTIN_tenv_ID match_mp_tac sing_renum_NOTIN_ID ORELSE match_mp_tac (GSYM sing_renum_NOTIN_ID) \\ CCONTR_TAC \\ fs[SUBSET_DEF] \\ metis_tac[]) - \\ rw[sing_renum_def] \\ fs[]); + \\ rw[sing_renum_def] \\ fs[] +QED -Theorem type_p_ts_tid_rename ` - good_remap f ⇒ +Theorem type_p_ts_tid_rename: + good_remap f ⇒ (∀tvs tenv p t bindings. type_p tvs tenv p t bindings ⇒ type_p tvs (remap_tenv f tenv) p (ts_tid_rename f t) @@ -514,8 +554,9 @@ Theorem type_p_ts_tid_rename ` (∀tvs tenv ps ts bindings. type_ps tvs tenv ps ts bindings ⇒ type_ps tvs (remap_tenv f tenv) ps (MAP (ts_tid_rename f) ts) - (MAP (λn,t. (n,ts_tid_rename f t)) bindings))` - (strip_tac>> + (MAP (λn,t. (n,ts_tid_rename f t)) bindings)) +Proof + strip_tac>> ho_match_mp_tac type_p_strongind>> rw[]>> simp[Once type_p_cases,check_freevars_ts_tid_rename,ts_tid_rename_def]>> @@ -533,16 +574,19 @@ Theorem type_p_ts_tid_rename ` fs[ts_tid_rename_type_name_subst,remap_tenv_def,GSYM check_type_names_ts_tid_rename]>> metis_tac[ts_tid_rename_type_name_subst]) >> - metis_tac[]); + metis_tac[] +QED -Theorem type_op_ts_tid_rename ` - good_remap f ⇒ +Theorem type_op_ts_tid_rename: + good_remap f ⇒ ∀op ts t. type_op op ts t ⇒ - type_op op (MAP (ts_tid_rename f) ts) (ts_tid_rename f t)` - (rw[]>> + type_op op (MAP (ts_tid_rename f) ts) (ts_tid_rename f t) +Proof + rw[]>> fs[typeSysPropsTheory.type_op_cases,ts_tid_rename_def]>> - fs[good_remap_def,prim_type_nums_def]); + fs[good_remap_def,prim_type_nums_def] +QED val remap_tenvE_def = Define` (remap_tenvE f Empty = Empty) ∧ @@ -561,9 +605,11 @@ val remap_tenvE_bind_var_list = Q.prove(` fs[bind_var_list_def,remap_tenvE_def]>> rw[]); -Theorem remap_tenvE_bind_tvar - `remap_tenvE f (bind_tvar tvs e) = bind_tvar tvs (remap_tenvE f e)` - (rw[bind_tvar_def, remap_tenvE_def]); +Theorem remap_tenvE_bind_tvar: + remap_tenvE f (bind_tvar tvs e) = bind_tvar tvs (remap_tenvE f e) +Proof + rw[bind_tvar_def, remap_tenvE_def] +QED val deBruijn_inc_ts_tid_rename = Q.prove(` ∀skip n t. @@ -592,8 +638,8 @@ val ts_tid_rename_deBruijn_subst = Q.prove(` fs[EL_MAP,MAP_MAP_o]>> fs[MAP_EQ_f]); -Theorem type_e_ts_tid_rename ` - good_remap f ⇒ +Theorem type_e_ts_tid_rename: + good_remap f ⇒ (∀tenv tenvE e t. type_e tenv tenvE e t ⇒ type_e (remap_tenv f tenv) (remap_tenvE f tenvE) e (ts_tid_rename f t)) ∧ @@ -602,8 +648,9 @@ Theorem type_e_ts_tid_rename ` type_es (remap_tenv f tenv) (remap_tenvE f tenvE) es (MAP (ts_tid_rename f) ts)) ∧ (∀tenv tenvE funs env. type_funs tenv tenvE funs env ⇒ - type_funs (remap_tenv f tenv) (remap_tenvE f tenvE) funs (MAP (λ(n,t). (n, ts_tid_rename f t)) env))` - (strip_tac>> + type_funs (remap_tenv f tenv) (remap_tenvE f tenvE) funs (MAP (λ(n,t). (n, ts_tid_rename f t)) env)) +Proof + strip_tac>> ho_match_mp_tac type_e_strongind>> rw[]>> simp[Once type_e_cases,ts_tid_rename_def]>> @@ -664,42 +711,50 @@ Theorem type_e_ts_tid_rename ` metis_tac[ts_tid_rename_type_name_subst]) >> fs[check_freevars_def,check_freevars_ts_tid_rename,remap_tenvE_def,ALOOKUP_MAP]>> - fs[good_remap_def,prim_type_nums_def]); + fs[good_remap_def,prim_type_nums_def] +QED -Theorem good_remap_LINV - `good_remap f ∧ prim_tids T s ∧ INJ f s t ⇒ good_remap (LINV f s o f)` - (rw[good_remap_def, prim_tids_def, MAP_EQ_ID, EVERY_MEM] +Theorem good_remap_LINV: + good_remap f ∧ prim_tids T s ∧ INJ f s t ⇒ good_remap (LINV f s o f) +Proof + rw[good_remap_def, prim_tids_def, MAP_EQ_ID, EVERY_MEM] \\ res_tac - \\ imp_res_tac LINV_DEF); + \\ imp_res_tac LINV_DEF +QED -Theorem ts_tid_rename_LINV - `∀f x. INJ f s t ∧ set_tids_subset s x ⇒ ts_tid_rename (LINV f s) (ts_tid_rename f x) = x` - (recInduct ts_tid_rename_ind +Theorem ts_tid_rename_LINV: + ∀f x. INJ f s t ∧ set_tids_subset s x ⇒ ts_tid_rename (LINV f s) (ts_tid_rename f x) = x +Proof + recInduct ts_tid_rename_ind \\ rw[ts_tid_rename_def, MAP_MAP_o, set_tids_subset_def, SUBSET_DEF, MAP_EQ_ID] \\ fs[set_tids_def, PULL_EXISTS, MEM_MAP] >- (fs[EVERY_MEM] \\ metis_tac[]) \\ imp_res_tac LINV_DEF - \\ metis_tac[]); - -Theorem remap_tenv_LINV - `INJ f s t ∧ set_tids_tenv s tenv ⇒ - tenv_equiv (remap_tenv (LINV f s) (remap_tenv f tenv)) tenv` - (rw[remap_tenv_def, tenv_equiv_def, nsMap_compose, nsAll2_def, + \\ metis_tac[] +QED + +Theorem remap_tenv_LINV: + INJ f s t ∧ set_tids_tenv s tenv ⇒ + tenv_equiv (remap_tenv (LINV f s) (remap_tenv f tenv)) tenv +Proof + rw[remap_tenv_def, tenv_equiv_def, nsMap_compose, nsAll2_def, nsSub_def, nsLookup_nsMap, nsLookupMod_nsMap] \\ fs[UNCURRY, set_tids_tenv_def] \\ imp_res_tac nsLookup_nsAll \\ fs[UNCURRY] \\ fs[MAP_MAP_o, o_DEF] \\ imp_res_tac ts_tid_rename_LINV \\ fs[] \\ imp_res_tac LINV_DEF \\ fs[EVERY_MEM] - \\ simp[PAIR_FST_SND_EQ, MAP_EQ_ID]); + \\ simp[PAIR_FST_SND_EQ, MAP_EQ_ID] +QED val LINVI_def = Define` LINVI f s y = case LINV_OPT f s y of SOME x => x | NONE => f y`; -Theorem remap_tenv_LINV - `BIJ f s t ∧ set_tids_tenv s tenv ⇒ - tenv_equiv (remap_tenv (LINV f s) (remap_tenv f tenv)) tenv` - (rw[remap_tenv_def, tenv_equiv_def, nsMap_compose, nsAll2_def, +Theorem remap_tenv_LINV: + BIJ f s t ∧ set_tids_tenv s tenv ⇒ + tenv_equiv (remap_tenv (LINV f s) (remap_tenv f tenv)) tenv +Proof + rw[remap_tenv_def, tenv_equiv_def, nsMap_compose, nsAll2_def, nsSub_def, nsLookup_nsMap, nsLookupMod_nsMap] \\ fs[UNCURRY, set_tids_tenv_def] \\ imp_res_tac nsLookup_nsAll \\ fs[UNCURRY] @@ -708,109 +763,133 @@ Theorem remap_tenv_LINV \\ imp_res_tac ts_tid_rename_LINV \\ fs[] \\ imp_res_tac BIJ_LINV_INV \\ fs[EVERY_MEM] \\ imp_res_tac LINV_DEF \\ fs[] - \\ simp[PAIR_FST_SND_EQ, MAP_EQ_ID]); + \\ simp[PAIR_FST_SND_EQ, MAP_EQ_ID] +QED -Theorem good_remap_BIJ - `good_remap f ∧ prim_tids T s ∧ BIJ f s t ⇒ good_remap (LINV f s)` - (rw[good_remap_def, prim_tids_def, MAP_EQ_ID, EVERY_MEM] +Theorem good_remap_BIJ: + good_remap f ∧ prim_tids T s ∧ BIJ f s t ⇒ good_remap (LINV f s) +Proof + rw[good_remap_def, prim_tids_def, MAP_EQ_ID, EVERY_MEM] \\ imp_res_tac BIJ_LINV_BIJ \\ imp_res_tac BIJ_DEF - \\ metis_tac[BIJ_LINV_INV, INJ_DEF]); + \\ metis_tac[BIJ_LINV_INV, INJ_DEF] +QED -Theorem good_remap_LINVI - `good_remap f ∧ prim_tids T s ∧ INJ f s t ⇒ good_remap (LINVI f s)` - (rw[good_remap_def, prim_tids_def, LINVI_def, MAP_EQ_ID] +Theorem good_remap_LINVI: + good_remap f ∧ prim_tids T s ∧ INJ f s t ⇒ good_remap (LINVI f s) +Proof + rw[good_remap_def, prim_tids_def, LINVI_def, MAP_EQ_ID] \\ drule INJ_LINV_OPT \\ CASE_TAC \\ rw[] \\ fs[EVERY_MEM] - \\ metis_tac[INJ_DEF]); + \\ metis_tac[INJ_DEF] +QED -Theorem INJ_LINVI - `INJ f s t ∧ x ∈ s ⇒ LINVI f s (f x) = x` - (rw[LINVI_def] +Theorem INJ_LINVI: + INJ f s t ∧ x ∈ s ⇒ LINVI f s (f x) = x +Proof + rw[LINVI_def] \\ CASE_TAC \\ imp_res_tac INJ_LINV_OPT \\ rw[] - \\ metis_tac[INJ_DEF, NOT_NONE_SOME]); - -Theorem LINVI_RINV - `INJ f s t ∧ (∃x. x ∈ s ∧ f x = y) ⇒ - f (LINVI f s y) = y` - (rw[LINVI_def] + \\ metis_tac[INJ_DEF, NOT_NONE_SOME] +QED + +Theorem LINVI_RINV: + INJ f s t ∧ (∃x. x ∈ s ∧ f x = y) ⇒ + f (LINVI f s y) = y +Proof + rw[LINVI_def] \\ drule INJ_LINV_OPT \\ disch_then(qspec_then`f x`mp_tac o CONV_RULE SWAP_FORALL_CONV) \\ CASE_TAC \\ rw[] - \\ metis_tac[INJ_DEF]); + \\ metis_tac[INJ_DEF] +QED (* -Theorem BIJ_LINVI_RINV - `BIJ f s t ∧ LINVI f s y ∈ s ⇒ - f (LINVI f s y) = y` - (rw[LINVI_def, LINV_OPT_def] \\ fs[] +Theorem BIJ_LINVI_RINV: + BIJ f s t ∧ LINVI f s y ∈ s ⇒ + f (LINVI f s y) = y +Proof + rw[LINVI_def, LINV_OPT_def] \\ fs[] ff"bij""inv" f"LINV_OPT" \\ imp_res_tac \\ drule INJ_LINV_OPT \\ disch_then(qspec_then`f x`mp_tac o CONV_RULE SWAP_FORALL_CONV) \\ CASE_TAC \\ rw[] - \\ metis_tac[INJ_DEF]); + \\ metis_tac[INJ_DEF] +QED *) -Theorem ts_tid_rename_LINVI - `∀f x. INJ f s t ∧ set_tids_subset s x ⇒ ts_tid_rename (LINVI f s) (ts_tid_rename f x) = x` - (recInduct ts_tid_rename_ind +Theorem ts_tid_rename_LINVI: + ∀f x. INJ f s t ∧ set_tids_subset s x ⇒ ts_tid_rename (LINVI f s) (ts_tid_rename f x) = x +Proof + recInduct ts_tid_rename_ind \\ rw[ts_tid_rename_def, MAP_MAP_o, set_tids_def, set_tids_subset_def, MAP_EQ_ID] \\ fs[SUBSET_DEF, PULL_EXISTS, MEM_MAP] >- metis_tac[] \\ rw[LINVI_def] \\ imp_res_tac INJ_LINV_OPT \\ CASE_TAC \\ fs[] - \\ metis_tac[INJ_DEF]); - -Theorem remap_tenv_LINVI - `INJ f s t ∧ set_tids_tenv s tenv ⇒ - tenv_equiv (remap_tenv (LINVI f s) (remap_tenv f tenv)) tenv` - (rw[remap_tenv_def, tenv_equiv_def, nsMap_compose, nsAll2_def, + \\ metis_tac[INJ_DEF] +QED + +Theorem remap_tenv_LINVI: + INJ f s t ∧ set_tids_tenv s tenv ⇒ + tenv_equiv (remap_tenv (LINVI f s) (remap_tenv f tenv)) tenv +Proof + rw[remap_tenv_def, tenv_equiv_def, nsMap_compose, nsAll2_def, nsSub_def, nsLookup_nsMap, nsLookupMod_nsMap] \\ fs[UNCURRY, set_tids_tenv_def] \\ imp_res_tac nsLookup_nsAll \\ fs[UNCURRY] \\ fs[MAP_MAP_o, o_DEF] \\ imp_res_tac ts_tid_rename_LINVI \\ fs[] \\ imp_res_tac INJ_LINVI \\ fs[EVERY_MEM] - \\ simp[PAIR_FST_SND_EQ, MAP_EQ_ID]); - -Theorem ts_tid_rename_compose - `∀g t f. ts_tid_rename f (ts_tid_rename g t) = ts_tid_rename (f o g) t` - (recInduct ts_tid_rename_ind - \\ rw[ts_tid_rename_def, MAP_MAP_o, o_DEF, MAP_EQ_f]); - -Theorem remap_tenv_compose - `remap_tenv f (remap_tenv g tenv) = remap_tenv (f o g) tenv` - (srw_tac[ETA_ss] + \\ simp[PAIR_FST_SND_EQ, MAP_EQ_ID] +QED + +Theorem ts_tid_rename_compose: + ∀g t f. ts_tid_rename f (ts_tid_rename g t) = ts_tid_rename (f o g) t +Proof + recInduct ts_tid_rename_ind + \\ rw[ts_tid_rename_def, MAP_MAP_o, o_DEF, MAP_EQ_f] +QED + +Theorem remap_tenv_compose: + remap_tenv f (remap_tenv g tenv) = remap_tenv (f o g) tenv +Proof + srw_tac[ETA_ss] [remap_tenv_def, nsMap_compose, ts_tid_rename_compose, - o_DEF, UNCURRY, LAMBDA_PROD, MAP_MAP_o]); + o_DEF, UNCURRY, LAMBDA_PROD, MAP_MAP_o] +QED -Theorem ts_tid_rename_eq_id - `∀f t. (ts_tid_rename f t = t ⇔ ∀x. x ∈ set_tids t ⇒ f x = x)` - (recInduct ts_tid_rename_ind +Theorem ts_tid_rename_eq_id: + ∀f t. (ts_tid_rename f t = t ⇔ ∀x. x ∈ set_tids t ⇒ f x = x) +Proof + recInduct ts_tid_rename_ind \\ rw[ts_tid_rename_def, set_tids_def, MAP_EQ_ID, MEM_MAP] \\ rw[EQ_IMP_THM] \\ rw[] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem ts_tid_rename_eq_f - `∀f t g. (ts_tid_rename f t = ts_tid_rename g t ⇔ ∀x. x ∈ set_tids t ⇒ f x = g x)` - (recInduct ts_tid_rename_ind +Theorem ts_tid_rename_eq_f: + ∀f t g. (ts_tid_rename f t = ts_tid_rename g t ⇔ ∀x. x ∈ set_tids t ⇒ f x = g x) +Proof + recInduct ts_tid_rename_ind \\ rw[ts_tid_rename_def, set_tids_def, MAP_EQ_f, MEM_MAP] \\ rw[EQ_IMP_THM] \\ rw[] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem inj_ts_tid_rename_eq - `∀f t1 t2. +Theorem inj_ts_tid_rename_eq: + ∀f t1 t2. (∀x y. x ∈ set_tids t1 ∧ y ∈ set_tids t2 ∧ f x = f y ⇒ x = y) ∧ (ts_tid_rename f t1 = ts_tid_rename f t2 ) - ⇒ t1 = t2` - (recInduct ts_tid_rename_ind + ⇒ t1 = t2 +Proof + recInduct ts_tid_rename_ind \\ rewrite_tac[ts_tid_rename_def, set_tids_def, NOT_IN_EMPTY, IN_INSERT] \\ rpt strip_tac \\ Cases_on`t2` \\ pop_assum mp_tac \\ rewrite_tac[ts_tid_rename_def] @@ -822,7 +901,8 @@ Theorem inj_ts_tid_rename_eq \\ ntac 2 strip_tac \\ reverse conj_tac >- metis_tac[] \\ first_x_assum(mp_then Any match_mp_tac INJ_MAP_EQ_2) - \\ metis_tac[]); + \\ metis_tac[] +QED (* probably not be true because of shadows... Theorem remap_tenv_LINVI @@ -874,14 +954,15 @@ val type_e_ts_tid_rename_sing_renum = Q.prove(` simp[]>>rw[]>> metis_tac[type_e_tenv_equiv]); -Theorem type_funs_ts_tid_rename_sing_renum ` - m ∉ tids ∧ prim_tids T tids ∧ +Theorem type_funs_ts_tid_rename_sing_renum: + m ∉ tids ∧ prim_tids T tids ∧ type_funs tenv tenvE funs res ∧ set_tids_tenv tids tenv ⇒ type_funs tenv (remap_tenvE (sing_renum m n) tenvE) funs - (MAP (λ(z,t). (z, ts_tid_rename (sing_renum m n) t)) res)` - (rw[]>> + (MAP (λ(z,t). (z, ts_tid_rename (sing_renum m n) t)) res) +Proof + rw[]>> `good_remap (sing_renum m n)` by (fs[good_remap_def,sing_renum_def]>> fs[prim_tids_def]>> @@ -893,7 +974,8 @@ Theorem type_funs_ts_tid_rename_sing_renum ` strip_tac>> first_x_assum drule>> drule sing_renum_NOTIN_tenv_ID>> simp[]>>rw[]>> - metis_tac[type_e_tenv_equiv]); + metis_tac[type_e_tenv_equiv] +QED val type_pe_bindings_tids = Q.prove(` prim_tids T tids ∧ @@ -928,16 +1010,17 @@ val type_pe_bindings_tids = Q.prove(` `x ≠ x+1` by fs[]>> metis_tac[sing_renum_NOT_tscheme_inst]); -Theorem type_funs_bindings_tids - `type_funs tenv (bind_var_list 0 bindings (bind_tvar tvs Empty)) funs bindings ∧ +Theorem type_funs_bindings_tids: + type_funs tenv (bind_var_list 0 bindings (bind_tvar tvs Empty)) funs bindings ∧ set_tids_tenv tids tenv ∧ prim_tids T tids ∧ (∀tvs' bindings'. type_funs tenv (bind_var_list 0 bindings' (bind_tvar tvs' Empty)) funs bindings' ⇒ LIST_REL tscheme_inst (MAP (λx. (tvs', SND x)) bindings') (MAP (λx. (tvs, SND x)) bindings)) ⇒ - EVERY (set_tids_subset tids o SND) bindings` - (CCONTR_TAC>>fs[set_tids_subset_def,SUBSET_DEF,EXISTS_MEM]>> + EVERY (set_tids_subset tids o SND) bindings +Proof + CCONTR_TAC>>fs[set_tids_subset_def,SUBSET_DEF,EXISTS_MEM]>> drule (GEN_ALL type_funs_ts_tid_rename_sing_renum)>> rpt (disch_then drule)>> disch_then(qspec_then`x+1` mp_tac)>> @@ -949,16 +1032,18 @@ Theorem type_funs_bindings_tids asm_exists_tac>> fs[EL_MAP,UNCURRY]>> `x ≠ x+1` by fs[]>> - metis_tac[sing_renum_NOT_tscheme_inst]); + metis_tac[sing_renum_NOT_tscheme_inst] +QED -Theorem type_pe_bindings_tids_0 ` - prim_tids T tids ∧ +Theorem type_pe_bindings_tids_0: + prim_tids T tids ∧ set_tids_tenv tids tenv ∧ type_p 0 tenv p t bindings ∧ type_e tenv Empty e t ∧ type_pe_determ tenv Empty p e ⇒ - ∀p_1 p_2. MEM (p_1,p_2) bindings ⇒ set_tids_subset tids p_2` - (CCONTR_TAC>>fs[set_tids_subset_def,SUBSET_DEF]>> + ∀p_1 p_2. MEM (p_1,p_2) bindings ⇒ set_tids_subset tids p_2 +Proof + CCONTR_TAC>>fs[set_tids_subset_def,SUBSET_DEF]>> drule (GEN_ALL type_p_ts_tid_rename_sing_renum)>> rpt (disch_then drule)>> disch_then(qspec_then`x+1` mp_tac)>> @@ -973,17 +1058,19 @@ Theorem type_pe_bindings_tids_0 ` res_tac >> pairarg_tac \\ fs[] \\ rw[] \\ `x ≠ x+1` by fs[]>> - metis_tac[sing_renum_IN_NOT_ID]); + metis_tac[sing_renum_IN_NOT_ID] +QED -Theorem type_pe_determ_remap - `type_pe_determ tenv Empty p e ∧ +Theorem type_pe_determ_remap: + type_pe_determ tenv Empty p e ∧ good_remap f ∧ prim_tids T tids ∧ BIJ f tids (count n) ∧ set_tids_tenv tids tenv ⇒ - type_pe_determ_canon n (remap_tenv f tenv) Empty p e` - (fs[type_pe_determ_canon_def,type_pe_determ_def] \\ rw[] + type_pe_determ_canon n (remap_tenv f tenv) Empty p e +Proof + fs[type_pe_determ_canon_def,type_pe_determ_def] \\ rw[] \\ imp_res_tac good_remap_BIJ >> drule (GEN_ALL type_p_ts_tid_rename) >> disch_then(mp_tac o CONV_RULE(RESORT_FORALL_CONV(sort_vars["t"])) o CONJUNCT1) @@ -1016,18 +1103,20 @@ Theorem type_pe_determ_remap \\ first_x_assum(mp_then Any match_mp_tac inj_ts_tid_rename_eq) \\ rw[] \\ fs[EVERY_MEM,FORALL_PROD,set_tids_subset_def] - \\ metis_tac[BIJ_LINV_INV, SUBSET_DEF]); + \\ metis_tac[BIJ_LINV_INV, SUBSET_DEF] +QED -Theorem build_ctor_tenv_type_identities ` - ∀tenvt xs type_identities tids. +Theorem build_ctor_tenv_type_identities: + ∀tenvt xs type_identities tids. prim_tids T tids ∧ nsAll (λi (ls,t). set_tids_subset (tids ∪ set type_identities) t) tenvt ∧ LENGTH xs = LENGTH type_identities ⇒ nsAll ((λi (ls,ts,tid). EVERY (λt. set_tids_subset (tids ∪ set type_identities) t) ts ∧ (tid ∈ tids ∨ MEM tid type_identities))) - (build_ctor_tenv tenvt xs type_identities)` - (ho_match_mp_tac build_ctor_tenv_ind>>rw[build_ctor_tenv_def]>> + (build_ctor_tenv tenvt xs type_identities) +Proof + ho_match_mp_tac build_ctor_tenv_ind>>rw[build_ctor_tenv_def]>> match_mp_tac nsAll_nsAppend>>fs[]>> CONJ_TAC>- ( first_x_assum(qspec_then`id INSERT tids` mp_tac)>> @@ -1041,7 +1130,8 @@ Theorem build_ctor_tenv_type_identities ` fs[EVERY_REVERSE,EVERY_MAP,EVERY_MEM,LAMBDA_PROD,FORALL_PROD,MEM_MAP,PULL_EXISTS,PULL_FORALL]>> rw[]>> match_mp_tac set_tids_subset_type_name_subst>> - fs[prim_tids_def,prim_type_nums_def]); + fs[prim_tids_def,prim_type_nums_def] +QED (* Theorem type_d_canon_tenv_equiv @@ -1055,10 +1145,12 @@ Theorem type_d_canon_tenv_equiv type_d_canon_rules *) -Theorem DISJOINT_CARD_UNION - `FINITE s /\ FINITE t /\ DISJOINT s t - ==> CARD (s UNION t) = CARD s + CARD t` - (metis_tac [CARD_UNION, DISJOINT_DEF, CARD_DEF, ADD, ADD_SYM]); +Theorem DISJOINT_CARD_UNION: + FINITE s /\ FINITE t /\ DISJOINT s t + ==> CARD (s UNION t) = CARD s + CARD t +Proof + metis_tac [CARD_UNION, DISJOINT_DEF, CARD_DEF, ADD, ADD_SYM] +QED (* For any type_d, prove that the canonical type identifier strategy succeeds. @@ -1066,8 +1158,8 @@ Theorem DISJOINT_CARD_UNION used by type_d_canon TODO: do we actually need the bijection?? *) -Theorem type_d_type_d_canon ` - (∀extra_checks tenv d ids tenv'. +Theorem type_d_type_d_canon: + (∀extra_checks tenv d ids tenv'. type_d extra_checks tenv d ids tenv' ==> ∀tids f n mapped_tenv. (* These restrict the kinds of type_d that we are thinking about *) @@ -1101,8 +1193,9 @@ Theorem type_d_type_d_canon ` set_tids_tenv (tids ∪ ids) tenv' ∧ prim_tids F ids ∧ FINITE ids ∧ BIJ g ids (count (CARD ids)) ∧ type_ds_canon n mapped_tenv ds (CARD ids) mapped_tenv' ∧ - tenv_equiv (remap_tenv (extend_bij f g ids n) tenv') mapped_tenv')` - (ho_match_mp_tac type_d_strongind>> + tenv_equiv (remap_tenv (extend_bij f g ids n) tenv') mapped_tenv') +Proof + ho_match_mp_tac type_d_strongind>> rw[]>>fs[] >- ( (* Dlet poly *) @@ -1715,11 +1808,12 @@ Theorem type_d_type_d_canon ` \\ rw[] \\ res_tac \\ rw[] \\ fs[ts_tid_rename_eq_f, extend_bij_def, SUBSET_DEF, IN_DISJOINT, MAP_EQ_f, EVERY_MEM] - \\ metis_tac[]); + \\ metis_tac[] +QED (* n.b. proof almost entirely copied from type_d_tenv_ok_helper *) -Theorem type_d_canon_tenv_ok - `(∀check tenv d tdecs tenv'. +Theorem type_d_canon_tenv_ok: + (∀check tenv d tdecs tenv'. type_d_canon check tenv d tdecs tenv' ⇒ tenv_ok tenv ⇒ @@ -1728,8 +1822,9 @@ Theorem type_d_canon_tenv_ok type_ds_canon check tenv d tdecs tenv' ⇒ tenv_ok tenv ⇒ - tenv_ok tenv')` - (ho_match_mp_tac type_d_canon_ind >> + tenv_ok tenv') +Proof + ho_match_mp_tac type_d_canon_ind >> rw [tenv_ctor_ok_def, tenvLift_def] >- ( fs [tenv_ok_def] >> @@ -1804,6 +1899,7 @@ Theorem type_d_canon_tenv_ok >> simp [tenv_abbrev_ok_def]) >- fs [tenv_ok_def, tenv_val_ok_def, tenv_ctor_ok_def, tenv_abbrev_ok_def] >- metis_tac [extend_dec_tenv_ok] - >- metis_tac [extend_dec_tenv_ok]); + >- metis_tac [extend_dec_tenv_ok] +QED val _ = export_theory(); diff --git a/compiler/inference/proofs/type_eDetermScript.sml b/compiler/inference/proofs/type_eDetermScript.sml index 6ca6ab4f74..1686d2b8ed 100644 --- a/compiler/inference/proofs/type_eDetermScript.sml +++ b/compiler/inference/proofs/type_eDetermScript.sml @@ -18,17 +18,19 @@ val sub_completion_empty = Q.prove ( rw [sub_completion_def, pure_add_constraints_def] >> metis_tac []); -Theorem type_p_pat_bindings -`(∀tvs tenv p t new_bindings. +Theorem type_p_pat_bindings: + (∀tvs tenv p t new_bindings. type_p tvs tenv p t new_bindings ⇒ MAP FST new_bindings = pat_bindings p []) ∧ (∀tvs tenv ps ts new_bindings. - type_ps tvs tenv ps ts new_bindings ⇒ MAP FST new_bindings = pats_bindings ps [])` - (ho_match_mp_tac type_p_ind >> + type_ps tvs tenv ps ts new_bindings ⇒ MAP FST new_bindings = pats_bindings ps []) +Proof + ho_match_mp_tac type_p_ind >> rw [pat_bindings_def] >> - metis_tac [semanticPrimitivesPropsTheory.pat_bindings_accum]); + metis_tac [semanticPrimitivesPropsTheory.pat_bindings_accum] +QED -Theorem infer_pe_complete - `ienv_ok {} ienv ∧ +Theorem infer_pe_complete: + ienv_ok {} ienv ∧ env_rel_complete FEMPTY ienv tenv (bind_tvar tvs Empty) ∧ ALL_DISTINCT (pat_bindings p []) ∧ type_p tvs tenv p t1 tenv1 ∧ @@ -45,8 +47,9 @@ Theorem infer_pe_complete t_wfs s ∧ (* This might be implied by something above *) EVERY (λ(n,t). check_t tvs {} (t_walkstar s' t)) new_bindings ∧ - convert_env s' new_bindings = tenv1` - (rw [] + convert_env s' new_bindings = tenv1 +Proof + rw [] >> drule (CONJUNCT1 infer_e_complete) >> drule (CONJUNCT1 infer_p_complete) >> rw [] >> @@ -143,7 +146,8 @@ Theorem infer_pe_complete fs[]>>metis_tac[MEM_EL])>> first_x_assum(qspecl_then[`q`,`r`] mp_tac)>> rw[]>> - metis_tac[check_freevars_empty_convert_unconvert_id]); + metis_tac[check_freevars_empty_convert_unconvert_id] +QED val unconvert_11 = Q.prove ( `!t1 t2. check_freevars 0 [] t1 ∧ check_freevars 0 [] t2 ⇒ @@ -163,8 +167,8 @@ val unconvert_11 = Q.prove ( rfs [EL_MAP] >> metis_tac [EL_MEM]); -Theorem infer_e_type_pe_determ -`!loc ienv p e st st' t t' tenv' s. +Theorem infer_e_type_pe_determ: + !loc ienv p e st st' t t' tenv' s. ALL_DISTINCT (MAP FST tenv') ∧ ienv_ok {} ienv ∧ env_rel_complete FEMPTY ienv tenv Empty ∧ @@ -173,8 +177,9 @@ Theorem infer_e_type_pe_determ t_unify st'.subst t t' = SOME s ∧ EVERY (\(n, t). check_t 0 {} (t_walkstar s t)) tenv' ⇒ - type_pe_determ tenv Empty p e` - (rw [type_pe_determ_def] >> + type_pe_determ tenv Empty p e +Proof + rw [type_pe_determ_def] >> mp_tac (Q.INST [`tvs`|->`0`] infer_pe_complete) >> simp[]>>impl_keep_tac>- (imp_res_tac infer_p_bindings>>fs[])>> @@ -186,10 +191,11 @@ Theorem infer_e_type_pe_determ fs [sub_completion_def] >> imp_res_tac pure_add_constraints_success >> fs [t_compat_def] >> - metis_tac [t_walkstar_no_vars]); + metis_tac [t_walkstar_no_vars] +QED -Theorem t_vars_check_t ` - (∀t. +Theorem t_vars_check_t: + (∀t. ¬check_t 0 {} t ∧ check_t 0 s t ⇒ ∃n'. n' ∈ s ∧ n' ∈ t_vars t) ∧ @@ -197,30 +203,34 @@ Theorem t_vars_check_t ` ∀x.MEM x ts ⇒ ¬check_t 0 {} x ∧ check_t 0 s x ⇒ - ∃n'. n' ∈ s ∧ n' ∈ t_vars x)` - (ho_match_mp_tac infer_tTheory.infer_t_induction>> + ∃n'. n' ∈ s ∧ n' ∈ t_vars x) +Proof + ho_match_mp_tac infer_tTheory.infer_t_induction>> rw[check_t_def,t_vars_eqn]>> fs[EXISTS_MEM,EVERY_MEM]>>res_tac>> qexists_tac `n'`>> fs[MEM_MAP]>> - metis_tac[]); + metis_tac[] +QED -Theorem t_walkstar_diff ` - t_wfs s1 ∧ t_wfs s2 ∧ +Theorem t_walkstar_diff: + t_wfs s1 ∧ t_wfs s2 ∧ (t_walkstar s1 (Infer_Tuvar n) ≠ t_walkstar s2 (Infer_Tuvar n)) ⇒ (∀t.(n ∈ t_vars t) ⇒ t_walkstar s1 t ≠ t_walkstar s2 t) ∧ (∀ts. ∀x. MEM x ts ⇒ - n ∈ t_vars x ⇒ t_walkstar s1 x ≠ t_walkstar s2 x)` - (strip_tac>> + n ∈ t_vars x ⇒ t_walkstar s1 x ≠ t_walkstar s2 x) +Proof + strip_tac>> ho_match_mp_tac infer_tTheory.infer_t_induction>> rw[t_vars_eqn]>>fs[]>> fs[t_walkstar_eqn,t_walk_eqn,MEM_MAP]>> res_tac>>rfs[]>> SPOSE_NOT_THEN assume_tac>> imp_res_tac MAP_EQ_f>> - metis_tac[]); + metis_tac[] +QED val env_rel_sound_weaken = Q.prove( `env_rel_sound FEMPTY ienv tenv tenvE ∧ t_wfs s ⇒ @@ -231,8 +241,8 @@ val env_rel_sound_weaken = Q.prove( qexists_tac`num_tvs tenvE`>>qexists_tac`FEMPTY`>>fs[SUBMAP_FEMPTY])|>GEN_ALL |> curry save_thm "env_rel_sound_weaken"; -Theorem type_pe_determ_infer_e -`!loc ienv p e st st' t t' new_bindings s. +Theorem type_pe_determ_infer_e: + !loc ienv p e st st' t t' new_bindings s. ALL_DISTINCT (MAP FST new_bindings) ∧ (* check_menv ienv.inf_m ∧ @@ -251,8 +261,9 @@ Theorem type_pe_determ_infer_e t_unify st'.subst t t' = SOME s ∧ type_pe_determ tenv Empty p e ⇒ - EVERY (\(n, t). check_t 0 {} (t_walkstar s t)) new_bindings` - (rw [type_pe_determ_def] >> + EVERY (\(n, t). check_t 0 {} (t_walkstar s t)) new_bindings +Proof + rw [type_pe_determ_def] >> `t_wfs (init_infer_state ss).subst` by rw [t_wfs_def, init_infer_state_def] >> `t_wfs st.subst` by metis_tac [infer_e_wfs] >> `t_wfs st'.subst` by metis_tac [infer_p_wfs] >> @@ -428,7 +439,8 @@ Theorem type_pe_determ_infer_e count st'.next_uvar ∩ COMPL (FDOM s2) = {}` by (fs[EXTENSION,SUBSET_DEF]>>metis_tac[])>> fs[]>>rfs[]>> - metis_tac[check_t_empty_unconvert_convert_id]); + metis_tac[check_t_empty_unconvert_convert_id] +QED (*From ¬check_t 0 {} (t_walkstar s tt) it should follow that t_walkstar s tt must contain some unification variables. @@ -440,9 +452,8 @@ Theorem type_pe_determ_infer_e unification variables are exactly bound in s1 and s2 to Infer_Tbool and Infer_Tint, hence the walkstars must differ *) -Theorem infer_funs_complete - ` - ienv_ok {} ienv ∧ +Theorem infer_funs_complete: + ienv_ok {} ienv ∧ tenv_ok tenv ∧ env_rel_complete FEMPTY ienv tenv Empty ∧ type_funs tenv (bind_var_list 0 bindings (bind_tvar tvs Empty)) funs bindings @@ -460,8 +471,9 @@ Theorem infer_funs_complete check_s 0 (count st'.next_uvar) st'.subst ∧ sub_completion tvs st'.next_uvar st'.subst constr s ∧ FDOM s = count st'.next_uvar ∧ - MAP SND bindings = MAP (convert_t o t_walkstar s) funs_ts` - (rw[]>> + MAP SND bindings = MAP (convert_t o t_walkstar s) funs_ts +Proof + rw[]>> imp_res_tac type_funs_distinct >> fs[FST_triple] >> imp_res_tac type_funs_MAP_FST >> imp_res_tac type_funs_Tfn>> @@ -623,6 +635,7 @@ Theorem infer_funs_complete metis_tac[MEM_EL]) >> match_mp_tac (el 4 (CONJUNCTS infer_e_check_s))>> - asm_exists_tac>>fs[ienv_ok_def,init_infer_state_def,check_s_def]) + asm_exists_tac>>fs[ienv_ok_def,init_infer_state_def,check_s_def] +QED val _ = export_theory (); diff --git a/compiler/inference/unifyScript.sml b/compiler/inference/unifyScript.sml index 3db0874350..928192d450 100644 --- a/compiler/inference/unifyScript.sml +++ b/compiler/inference/unifyScript.sml @@ -70,8 +70,8 @@ val decode_infer_t_def = Define ` (decode_infer_t _ = Infer_Tuvar 5) ∧ (decode_infer_ts _ = [])`; -Theorem decode_infer_t_pmatch ` - (!t. decode_infer_t t = +Theorem decode_infer_t_pmatch: + (!t. decode_infer_t t = case t of Var n => Infer_Tuvar n | Const (DB_tag n) => Infer_Tvar_db n @@ -82,10 +82,12 @@ Theorem decode_infer_t_pmatch ` case ts of | Const Null_tag => [] | Pair s1 s2 => decode_infer_t s1 :: decode_infer_ts s2 - | _ => [])` - (rpt strip_tac + | _ => []) +Proof + rpt strip_tac >> rpt(CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac) - >> TRY (Cases_on `a`) >> fs[decode_infer_t_def]); + >> TRY (Cases_on `a`) >> fs[decode_infer_t_def] +QED val decode_left_inverse = Q.prove ( `(!t. decode_infer_t (encode_infer_t t) = t) ∧ @@ -128,8 +130,8 @@ rw [FLOOKUP_o_f, encode_infer_t_def]); val t_vwalk_ind = save_thm("t_vwalk_ind", (UNDISCH o Q.SPEC `s`) t_vwalk_ind') -Theorem t_vwalk_eqn -`!s. +Theorem t_vwalk_eqn: + !s. t_wfs s ⇒ (!v. t_vwalk s v = @@ -137,8 +139,9 @@ Theorem t_vwalk_eqn | NONE => Infer_Tuvar v | SOME (Infer_Tuvar u) => t_vwalk s u | SOME (Infer_Tapp ts tc') => Infer_Tapp ts tc' - | SOME (Infer_Tvar_db n) => Infer_Tvar_db n)` -(rw [t_vwalk_def] >> + | SOME (Infer_Tvar_db n) => Infer_Tvar_db n) +Proof +rw [t_vwalk_def] >> full_case_tac >> rw [] >> fs [t_wfs_def] >| @@ -150,17 +153,20 @@ fs [t_wfs_def] >| fs [], rw [Once vwalk_def, FLOOKUP_o_f] >> cases_on `x` >> - rw [encode_infer_t_def, decode_infer_t_def, decode_left_inverse]]); + rw [encode_infer_t_def, decode_infer_t_def, decode_left_inverse]] +QED val t_walk_def = zDefine ` t_walk s t = decode_infer_t (walk (encode_infer_t o_f s) (encode_infer_t t))`; -Theorem t_walk_eqn -`(!s v. t_walk s (Infer_Tuvar v) = t_vwalk s v) ∧ +Theorem t_walk_eqn: + (!s v. t_walk s (Infer_Tuvar v) = t_vwalk s v) ∧ (!s ts tc. t_walk s (Infer_Tapp ts tc) = Infer_Tapp ts tc) ∧ - (!s n. t_walk s (Infer_Tvar_db n) = Infer_Tvar_db n)` -(rw [t_walk_def, walk_def, t_vwalk_def, encode_infer_t_def, - decode_infer_t_def, decode_left_inverse]); + (!s n. t_walk s (Infer_Tvar_db n) = Infer_Tvar_db n) +Proof +rw [t_walk_def, walk_def, t_vwalk_def, encode_infer_t_def, + decode_infer_t_def, decode_left_inverse] +QED val t_oc_def = zDefine ` t_oc s t v = oc (encode_infer_t o_f s) (encode_infer_t t) v`; @@ -187,14 +193,16 @@ rw [] >| pop_assum ho_match_mp_tac >> rw [encode_vwalk]]); -Theorem t_oc_ind -`∀s oc'. +Theorem t_oc_ind: + ∀s oc'. t_wfs s ∧ (∀t v. v ∈ t_vars t ∧ v ∉ FDOM s ⇒ oc' t v) ∧ (∀t v u t'. u ∈ t_vars t ∧ (t_vwalk s u = t') ∧ oc' t' v ⇒ oc' t v) ⇒ - (∀a0 a1. t_oc s a0 a1 ⇒ oc' a0 a1)` -(rw [t_oc_def] >> -metis_tac [t_oc_ind', FMAP2_FMAP2, FMAP2_id, decode_left_inverse]); + (∀a0 a1. t_oc s a0 a1 ⇒ oc' a0 a1) +Proof +rw [t_oc_def] >> +metis_tac [t_oc_ind', FMAP2_FMAP2, FMAP2_id, decode_left_inverse] +QED *) val encode_vwalk = Q.prove ( @@ -217,21 +225,23 @@ val t_oc_eqn_help = Q.prove ( induct_on `l` >> rw [encode_infer_t_def]); -Theorem t_oc_eqn -`!s. t_wfs s ⇒ +Theorem t_oc_eqn: + !s. t_wfs s ⇒ !t v. t_oc s t v = dtcase t_walk s t of | Infer_Tuvar u => v = u | Infer_Tapp ts tc' => EXISTS (\t. t_oc s t v) ts - | Infer_Tvar_db n => F` -(rw [t_oc_def] >> + | Infer_Tvar_db n => F +Proof +rw [t_oc_def] >> `wfs (encode_infer_t o_f s)` by fs [t_wfs_def] >> rw [Once oc_walking, t_walk_def] >> cases_on `t` >> rw [walk_def, encode_infer_t_def, decode_infer_t_def, decode_left_inverse, encode_vwalk, t_oc_eqn_help] >> cases_on `t_vwalk s n` >> -rw [encode_infer_t_def, t_oc_eqn_help]); +rw [encode_infer_t_def, t_oc_eqn_help] +QED val t_ext_s_check_def = zDefine ` t_ext_s_check s v t = @@ -239,12 +249,14 @@ t_ext_s_check s v t = ((o_f) decode_infer_t) (ext_s_check (encode_infer_t o_f s) v (encode_infer_t t))`; -Theorem t_ext_s_check_eqn -`!s v t. - t_ext_s_check s v t = if t_oc s t v then NONE else SOME (s |+ (v,t))` -(rw [t_ext_s_check_def, t_oc_def, decode_left_inverse_I, +Theorem t_ext_s_check_eqn: + !s v t. + t_ext_s_check s v t = if t_oc s t v then NONE else SOME (s |+ (v,t)) +Proof +rw [t_ext_s_check_def, t_oc_def, decode_left_inverse_I, I_o_f, decode_left_inverse] >> -metis_tac [FUPDATE_PURGE]); +metis_tac [FUPDATE_PURGE] +QED val t_unify_def = zDefine ` t_unify s t1 t2 = @@ -465,8 +477,8 @@ fs [option_map_case] >| metis_tac [wfs_unify]) >> rw [I_o_f, decode_left_inverse_I]]]); -Theorem t_unify_eqn -`(!t1 t2 s. +Theorem t_unify_eqn: + (!t1 t2 s. t_wfs s ⇒ (t_unify s t1 t2 = dtcase (t_walk s t1, t_walk s t2) of @@ -484,8 +496,9 @@ Theorem t_unify_eqn SOME s else NONE - | _ => NONE))` -(rw [t_unify_def] >> + | _ => NONE)) +Proof +rw [t_unify_def] >> `wfs (encode_infer_t o_f s)` by metis_tac [t_wfs_def] >> rw [Once unify_def, t_walk_def] >> cases_on `t1` >> @@ -550,7 +563,8 @@ THEN1 decode_infer_t_def, t_ext_s_check_eqn, option_map_case] >> rw [ts_unify_thm, Once oc_walking, encode_infer_t_def, t_oc_def, option_bind_thm, option_map_case] >> - rw [Once unify_def]); + rw [Once unify_def] +QED val encode_infer_t_inj = Q.prove( `(!t1 t2. (encode_infer_t t1 = encode_infer_t t2) ==> (t1 = t2)) /\ @@ -574,8 +588,8 @@ val encode_infer_t_inj_rwt = Q.prove( (∀t1s t2s. (encode_infer_ts t1s = encode_infer_ts t2s) ⇔ (t1s = t2s))`, metis_tac[encode_infer_t_inj]) -Theorem t_unify_ind - `!P0 P1. +Theorem t_unify_ind: + !P0 P1. (!s t1 t2. (!ts1 ts2 tc2. t_walk s t1 = Infer_Tapp ts1 tc2 /\ @@ -591,8 +605,9 @@ Theorem t_unify_ind ts1 = t1::ts1' /\ ts2 = t2::ts2' ==> P0 s t1 t2) ==> P1 s ts1 ts2) ==> (!s t1 t2. t_wfs s ==> P0 s t1 t2) /\ - (!s ts1 ts2. t_wfs s ==> P1 s ts1 ts2)` - (rpt gen_tac >> strip_tac >> + (!s ts1 ts2. t_wfs s ==> P1 s ts1 ts2) +Proof + rpt gen_tac >> strip_tac >> Q.ISPEC_THEN`λs t1 t2. (∀us u1 u2. wfs s ∧ (s = encode_infer_t o_f us) ∧ (t1 = encode_infer_t u1) ∧ (t2 = encode_infer_t u2) ⇒ P0 us u1 u2) ∧ (∀us tag u1 u2. @@ -666,13 +681,14 @@ Theorem t_unify_ind simp[encode_infer_t_inj_rwt] >> strip_tac >> first_x_assum(qspecl_then[`s`,`Infer_Tvar_db 0`,`Infer_Tvar_db 0`]mp_tac) >> simp[encode_infer_t_def] >> - fs[t_wfs_def]); + fs[t_wfs_def] +QED val apply_subst_t_def = zDefine ` apply_subst_t s t = decode_infer_t (subst_APPLY (encode_infer_t o_f s) (encode_infer_t t))`; -Theorem apply_subst_t_eqn -`(!s n. +Theorem apply_subst_t_eqn: + (!s n. apply_subst_t s (Infer_Tuvar n) = dtcase FLOOKUP s n of | NONE => Infer_Tuvar n @@ -682,13 +698,15 @@ Theorem apply_subst_t_eqn Infer_Tapp (MAP (apply_subst_t s) ts) tc) ∧ (!s n. apply_subst_t s (Infer_Tvar_db n) = - Infer_Tvar_db n)` -(rw [apply_subst_t_def, encode_infer_t_def, FLOOKUP_o_f, + Infer_Tvar_db n) +Proof +rw [apply_subst_t_def, encode_infer_t_def, FLOOKUP_o_f, decode_infer_t_def] >> every_case_tac >> rw [decode_left_inverse, decode_infer_t_def] >> induct_on `ts` >> -rw [apply_subst_t_def, encode_infer_t_def, decode_infer_t_def]); +rw [apply_subst_t_def, encode_infer_t_def, decode_infer_t_def] +QED val t_walkstar_def = zDefine ` t_walkstar s t = @@ -703,31 +721,34 @@ induct_on `l` >> rw [t_wfs_def, encode_infer_t_def, Once walkstar_def, decode_infer_t_def] >> rw [t_walkstar_def]); -Theorem t_walkstar_eqn -`!s. t_wfs s ⇒ +Theorem t_walkstar_eqn: + !s. t_wfs s ⇒ !t. t_walkstar s t = dtcase t_walk s t of | Infer_Tuvar v => Infer_Tuvar v | Infer_Tapp ts tctor => Infer_Tapp (MAP (t_walkstar s) ts) tctor - | Infer_Tvar_db n => Infer_Tvar_db n` -(rw [t_walkstar_def] >> + | Infer_Tvar_db n => Infer_Tvar_db n +Proof +rw [t_walkstar_def] >> `wfs (encode_infer_t o_f s)` by fs [t_wfs_def] >> rw [Once walkstar_def, t_walk_def] >> cases_on `t` >> rw [encode_infer_t_def, decode_infer_t_def, decode_left_inverse, encode_vwalk] >| [rw [ts_walkstar_thm], cases_on `t_vwalk s n` >> - rw [encode_infer_t_def, decode_infer_t_def, ts_walkstar_thm]]); + rw [encode_infer_t_def, decode_infer_t_def, ts_walkstar_thm]] +QED -Theorem t_walkstar_ind -`!s. t_wfs s ==> +Theorem t_walkstar_ind: + !s. t_wfs s ==> !P. (!t. (!ts tt a. (t_walk s t = Infer_Tapp ts tt) /\ MEM a ts ==> P a) ==> P t) ==> - !t. P t` - (rw[] >> + !t. P t +Proof + rw[] >> `wfs (encode_infer_t o_f s)` by fs[t_wfs_def] >> imp_res_tac(GEN_ALL (DISCH_ALL walkstar_ind)) >> qsuff_tac @@ -746,20 +767,24 @@ Theorem t_walkstar_ind Cases_on`us`>>fs[encode_infer_t_def] >> metis_tac[] ) >> Cases_on`us`>>fs[encode_infer_t_def] >> - metis_tac[]) + metis_tac[] +QED val t_collapse_def = zDefine ` t_collapse s = decode_infer_t o_f collapse (encode_infer_t o_f s)`; -Theorem t_collapse_eqn -`!s. t_collapse s = FUN_FMAP (\v. t_walkstar s (Infer_Tuvar v)) (FDOM s)` -(rw [collapse_def, t_collapse_def, t_walkstar_def, encode_infer_t_def, walkstar_def] >> -rw [GSYM fmap_EQ_THM, FUN_FMAP_DEF]); - -Theorem t_unify_unifier - `t_wfs s ∧ (t_unify s t1 t2 = SOME sx) ⇒ t_wfs sx ∧ s ⊑ sx ∧ (t_walkstar sx t1 = t_walkstar sx t2)` - (simp[t_unify_def] >> strip_tac >> +Theorem t_collapse_eqn: + !s. t_collapse s = FUN_FMAP (\v. t_walkstar s (Infer_Tuvar v)) (FDOM s) +Proof +rw [collapse_def, t_collapse_def, t_walkstar_def, encode_infer_t_def, walkstar_def] >> +rw [GSYM fmap_EQ_THM, FUN_FMAP_DEF] +QED + +Theorem t_unify_unifier: + t_wfs s ∧ (t_unify s t1 t2 = SOME sx) ⇒ t_wfs sx ∧ s ⊑ sx ∧ (t_walkstar sx t1 = t_walkstar sx t2) +Proof + simp[t_unify_def] >> strip_tac >> qmatch_assum_abbrev_tac`unify us ut1 ut2 = SOME uz` >> qspecl_then[`us`,`ut1`,`ut2`,`s`,`t1`,`t2`]mp_tac encode_unify >> simp[] >> @@ -770,7 +795,8 @@ Theorem t_unify_unifier rw[decode_left_inverse,decode_left_inverse_I,I_o_f] >> simp[t_wfs_def,t_walkstar_def] >> fs[SUBMAP_DEF] >> - metis_tac[encode_infer_t_inj,o_f_FAPPLY]) + metis_tac[encode_infer_t_inj,o_f_FAPPLY] +QED val t_unify_strongind' = Q.prove( `!P0 P1. @@ -826,69 +852,84 @@ induct_on `l` >> rw [encode_infer_t_def] >> rw [Once walkstar_def]); -Theorem t_walkstar_FEMPTY -`!t.(t_walkstar FEMPTY t = t)` -(rw [t_walkstar_def, decode_left_inverse]); +Theorem t_walkstar_FEMPTY: + !t.(t_walkstar FEMPTY t = t) +Proof +rw [t_walkstar_def, decode_left_inverse] +QED -Theorem t_wfs_SUBMAP -`!s1 s2. t_wfs s2 ∧ s1 ⊑ s2 ⇒ t_wfs s1` -(rw [t_wfs_def] >> +Theorem t_wfs_SUBMAP: + !s1 s2. t_wfs s2 ∧ s1 ⊑ s2 ⇒ t_wfs s1 +Proof +rw [t_wfs_def] >> `encode_infer_t o_f s1 SUBMAP encode_infer_t o_f s2` by (fs [SUBMAP_DEF]) >> -metis_tac [wfs_SUBMAP]); +metis_tac [wfs_SUBMAP] +QED -Theorem t_walkstar_SUBMAP -`!s1 s2 t. s1 SUBMAP s2 ∧ t_wfs s2 ⇒ (t_walkstar s2 t = t_walkstar s2 (t_walkstar s1 t))` -(rw [t_walkstar_def] >> +Theorem t_walkstar_SUBMAP: + !s1 s2 t. s1 SUBMAP s2 ∧ t_wfs s2 ⇒ (t_walkstar s2 t = t_walkstar s2 (t_walkstar s1 t)) +Proof +rw [t_walkstar_def] >> `wfs (encode_infer_t o_f s2)` by fs [t_wfs_def] >> `t_wfs s1` by metis_tac [t_wfs_SUBMAP] >> `encode_infer_t o_f s1 SUBMAP encode_infer_t o_f s2` by fs [SUBMAP_DEF] >> `walkstar (encode_infer_t o_f s2) (encode_infer_t t) = walkstar (encode_infer_t o_f s2) (walkstar (encode_infer_t o_f s1) (encode_infer_t t))` by metis_tac [walkstar_SUBMAP] >> -rw [encode_walkstar, decode_left_inverse]); +rw [encode_walkstar, decode_left_inverse] +QED val t_vR_def = Define ` t_vR s = vR (encode_infer_t o_f s)`; -Theorem t_vR_eqn -`!s x y. t_vR s y x = dtcase FLOOKUP s x of SOME t => y IN t_vars t | _ => F` -(rw [t_vR_def, vR_def] >> +Theorem t_vR_eqn: + !s x y. t_vR s y x = dtcase FLOOKUP s x of SOME t => y IN t_vars t | _ => F +Proof +rw [t_vR_def, vR_def] >> every_case_tac >> -fs [FLOOKUP_o_f, t_vars_def]); +fs [FLOOKUP_o_f, t_vars_def] +QED -Theorem t_wfs_eqn -`!s. t_wfs s = WF (t_vR s)` -(rw [wfs_def, t_wfs_def, t_vR_eqn, WF_DEF, vR_def, FLOOKUP_o_f, t_vars_def] >> +Theorem t_wfs_eqn: + !s. t_wfs s = WF (t_vR s) +Proof +rw [wfs_def, t_wfs_def, t_vR_eqn, WF_DEF, vR_def, FLOOKUP_o_f, t_vars_def] >> eq_tac >> rw [] >> res_tac >> cases_on `FLOOKUP s min` >> fs [] >> qexists_tac `min` >> -rw []); +rw [] +QED val t_rangevars_def = Define ` t_rangevars s = rangevars (encode_infer_t o_f s)`; -Theorem t_rangevars_eqn -`!s. t_rangevars s = BIGUNION (IMAGE t_vars (FRANGE s))` -(rw [t_rangevars_def, rangevars_def, EXTENSION] >> +Theorem t_rangevars_eqn: + !s. t_rangevars s = BIGUNION (IMAGE t_vars (FRANGE s)) +Proof +rw [t_rangevars_def, rangevars_def, EXTENSION] >> EQ_TAC >> rw [t_vars_def, FRANGE_DEF, o_f_FAPPLY] >> -metis_tac [o_f_FAPPLY]); +metis_tac [o_f_FAPPLY] +QED -Theorem t_vars_eqn -`(!x. t_vars (Infer_Tvar_db x) = {}) ∧ +Theorem t_vars_eqn: + (!x. t_vars (Infer_Tvar_db x) = {}) ∧ (!ts tc. t_vars (Infer_Tapp ts tc) = BIGUNION (set (MAP t_vars ts))) ∧ - (!u. t_vars (Infer_Tuvar u) = {u})` -(rw [t_vars_def, encode_infer_t_def] >> + (!u. t_vars (Infer_Tuvar u) = {u}) +Proof +rw [t_vars_def, encode_infer_t_def] >> induct_on `ts` >> -rw [encode_infer_t_def, t_vars_def]); +rw [encode_infer_t_def, t_vars_def] +QED -Theorem t_vwalk_to_var -`t_wfs s ==> !v u. (t_vwalk s v = Infer_Tuvar u) ==> u NOTIN FDOM s` -(rw [t_wfs_def, t_vwalk_def] >> +Theorem t_vwalk_to_var: + t_wfs s ==> !v u. (t_vwalk s v = Infer_Tuvar u) ==> u NOTIN FDOM s +Proof +rw [t_wfs_def, t_vwalk_def] >> imp_res_tac vwalk_to_var >> fs [] >> pop_assum match_mp_tac >> @@ -897,12 +938,14 @@ qexists_tac `v` >> by metis_tac [] >> fs [encode_infer_t_def] >> `t_wfs s` by metis_tac [t_wfs_def] >> -fs [encode_vwalk, decode_left_inverse]); +fs [encode_vwalk, decode_left_inverse] +QED -Theorem t_walkstar_vars_notin -`!s. t_wfs s ⇒ - !t x. x ∈ t_vars (t_walkstar s t) ⇒ x ∉ FDOM s` -(STRIP_TAC >> +Theorem t_walkstar_vars_notin: + !s. t_wfs s ⇒ + !t x. x ∈ t_vars (t_walkstar s t) ⇒ x ∉ FDOM s +Proof +STRIP_TAC >> STRIP_TAC >> imp_res_tac t_walkstar_ind >> pop_assum ho_match_mp_tac >> @@ -918,100 +961,122 @@ rw [] >| rw [GSYM t_walkstar_eqn], cases_on `t` >> fs [t_walk_eqn, t_vars_eqn] >> - metis_tac [t_vwalk_to_var]]); + metis_tac [t_vwalk_to_var]] +QED -Theorem t_walkstar_vars_in -`!s. t_wfs s ⇒ ∀t. t_vars (t_walkstar s t) SUBSET t_vars t UNION BIGUNION (FRANGE (t_vars o_f s))` -(rw [t_walkstar_def, t_vars_def, t_wfs_def] >> +Theorem t_walkstar_vars_in: + !s. t_wfs s ⇒ ∀t. t_vars (t_walkstar s t) SUBSET t_vars t UNION BIGUNION (FRANGE (t_vars o_f s)) +Proof +rw [t_walkstar_def, t_vars_def, t_wfs_def] >> imp_res_tac vars_walkstar >> fs [SUBSET_DEF] >> rw [] >> `t_vars = vars o encode_infer_t` by metis_tac [FUN_EQ_THM, t_vars_def, combinTheory.o_DEF] >> metis_tac [decode_right_inverse, decode_left_inverse, t_wfs_def, - encode_walkstar]); + encode_walkstar] +QED -Theorem t_walkstar_idempotent - `∀s. t_wfs s ⇒ ∀t. t_walkstar s (t_walkstar s t) = t_walkstar s t` - (metis_tac[decode_right_inverse, decode_left_inverse, walkstar_idempotent, t_wfs_def, encode_walkstar]); +Theorem t_walkstar_idempotent: + ∀s. t_wfs s ⇒ ∀t. t_walkstar s (t_walkstar s t) = t_walkstar s t +Proof + metis_tac[decode_right_inverse, decode_left_inverse, walkstar_idempotent, t_wfs_def, encode_walkstar] +QED (* ---------- Lemmas about unification that don't need to go into the encoding ----------*) -Theorem t_unify_apply -`!s1 s2 t1 t2. +Theorem t_unify_apply: + !s1 s2 t1 t2. t_wfs s1 ∧ (t_unify s1 t1 t2 = SOME s2) ⇒ - (t_walkstar s2 t1 = t_walkstar s2 t2)` -(metis_tac [t_unify_unifier]); + (t_walkstar s2 t1 = t_walkstar s2 t2) +Proof +metis_tac [t_unify_unifier] +QED -Theorem t_unify_apply2 -`!s1 s2 t1' t2' t1 t2. +Theorem t_unify_apply2: + !s1 s2 t1' t2' t1 t2. t_wfs s1 ∧ (t_unify s1 t1' t2' = SOME s2) ∧ (t_walkstar s1 t1 = t_walkstar s1 t2) ⇒ - (t_walkstar s2 t1 = t_walkstar s2 t2)` -(rw [] >> + (t_walkstar s2 t1 = t_walkstar s2 t2) +Proof +rw [] >> `t_wfs s2 ∧ s1 SUBMAP s2` by metis_tac [t_unify_unifier] >> -metis_tac [t_walkstar_SUBMAP]); +metis_tac [t_walkstar_SUBMAP] +QED -Theorem t_unify_wfs -`!s1 t1 t2 s2. +Theorem t_unify_wfs: + !s1 t1 t2 s2. t_wfs s1 ∧ (t_unify s1 t1 t2 = SOME s2) ⇒ - t_wfs s2` -(metis_tac [t_unify_unifier]); - -Theorem finite_t_rangevars -`!t. FINITE (t_rangevars t)` -(rw [t_rangevars_eqn, t_vars_def] >> -rw [termTheory.FINITE_vars]); - -Theorem t_walkstar_eqn1 -`!s idx ts tc. + t_wfs s2 +Proof +metis_tac [t_unify_unifier] +QED + +Theorem finite_t_rangevars: + !t. FINITE (t_rangevars t) +Proof +rw [t_rangevars_eqn, t_vars_def] >> +rw [termTheory.FINITE_vars] +QED + +Theorem t_walkstar_eqn1: + !s idx ts tc. t_wfs s ⇒ (t_walkstar s (Infer_Tvar_db idx) = Infer_Tvar_db idx) ∧ - (t_walkstar s (Infer_Tapp ts tc) = Infer_Tapp (MAP (t_walkstar s) ts) tc)` -(rw [t_walkstar_eqn, t_walk_eqn]); - -Theorem oc_tvar_db -`!s uv tvs. t_wfs s ⇒ ~t_oc s (Infer_Tvar_db tvs) uv` -(rw [] >> + (t_walkstar s (Infer_Tapp ts tc) = Infer_Tapp (MAP (t_walkstar s) ts) tc) +Proof +rw [t_walkstar_eqn, t_walk_eqn] +QED + +Theorem oc_tvar_db: + !s uv tvs. t_wfs s ⇒ ~t_oc s (Infer_Tvar_db tvs) uv +Proof +rw [] >> imp_res_tac t_oc_eqn >> pop_assum (fn _ => all_tac) >> pop_assum (fn _ => all_tac) >> pop_assum (ASSUME_TAC o Q.SPECL [`uv`, `Infer_Tvar_db tvs`]) >> -rw [t_walk_eqn]); +rw [t_walk_eqn] +QED -Theorem oc_unit -`!s uv tc. t_wfs s ⇒ ~t_oc s (Infer_Tapp [] tc) uv` -(rw [] >> +Theorem oc_unit: + !s uv tc. t_wfs s ⇒ ~t_oc s (Infer_Tapp [] tc) uv +Proof +rw [] >> imp_res_tac t_oc_eqn >> pop_assum (fn _ => all_tac) >> pop_assum (fn _ => all_tac) >> pop_assum (ASSUME_TAC o Q.SPECL [`uv`, `Infer_Tapp [] tc'`]) >> -rw [t_walk_eqn]); +rw [t_walk_eqn] +QED -Theorem no_vars_lem -`!e l f. +Theorem no_vars_lem: + !e l f. MEM e l ∧ set (MAP f l) = {{}} ⇒ - (f e = {})` -(induct_on `l` >> + (f e = {}) +Proof +induct_on `l` >> rw [] >> fs [MEM_MAP, EXTENSION] >> -metis_tac []); +metis_tac [] +QED -Theorem no_vars_extend_subst_vwalk -`!s. t_wfs s ⇒ +Theorem no_vars_extend_subst_vwalk: + !s. t_wfs s ⇒ !n s'. t_wfs (s |++ s') ∧ DISJOINT (FDOM s) (FDOM (FEMPTY |++ s')) ∧ (!n'. t_vwalk s n ≠ Infer_Tuvar n') ⇒ - t_vwalk (s |++ s') n = t_vwalk s n` - (strip_tac >> + t_vwalk (s |++ s') n = t_vwalk s n +Proof + strip_tac >> strip_tac >> imp_res_tac (DISCH_ALL t_vwalk_ind) >> pop_assum ho_match_mp_tac >> @@ -1033,16 +1098,18 @@ Theorem no_vars_extend_subst_vwalk fs []) >> imp_res_tac alistTheory.ALOOKUP_MEM >> fs [FLOOKUP_DEF, DISJOINT_DEF, EXTENSION, FDOM_FUPDATE_LIST, MEM_MAP] >> - metis_tac [FST, pair_CASES])); + metis_tac [FST, pair_CASES]) +QED -Theorem no_vars_extend_subst -`!s. t_wfs s ⇒ +Theorem no_vars_extend_subst: + !s. t_wfs s ⇒ !t s'. t_wfs (s |++ s') ∧ DISJOINT (FDOM s) (FDOM (FEMPTY |++ s')) ∧ (t_vars (t_walkstar s t) = {}) ⇒ - t_walkstar (s |++ s') t = t_walkstar s t` -(strip_tac >> + t_walkstar (s |++ s') t = t_walkstar s t +Proof +strip_tac >> strip_tac >> imp_res_tac t_walkstar_ind >> pop_assum ho_match_mp_tac >> @@ -1061,14 +1128,16 @@ rw [MAP_EQ_f] >> fs [t_vars_eqn] >> rw [] >> fs [] >> -metis_tac [no_vars_lem, MAP_MAP_o, combinTheory.o_DEF]); +metis_tac [no_vars_lem, MAP_MAP_o, combinTheory.o_DEF] +QED (*Theorems about unification for completeness proof*) -Theorem t_walk_vwalk_id -`t_wfs s ⇒ - !n. t_walk s (t_vwalk s n) = t_vwalk s n` - (strip_tac>> +Theorem t_walk_vwalk_id: + t_wfs s ⇒ + !n. t_walk s (t_vwalk s n) = t_vwalk s n +Proof + strip_tac>> ho_match_mp_tac (Q.INST[`s`|->`s`]t_vwalk_ind)>> rw[]>> Cases_on`FLOOKUP s n`>>fs[t_walk_eqn,Once t_vwalk_eqn]>> @@ -1080,38 +1149,44 @@ Theorem t_walk_vwalk_id >- fs[t_walk_eqn,Once t_vwalk_eqn] >> - fs[]) - -Theorem t_walk_walk_id -`t_wfs s ⇒ - t_walk s (t_walk s h) = t_walk s h` - (Cases_on`h`>> - fs[t_walk_eqn,t_walk_vwalk_id]) - -Theorem eqs_t_unify -`t_wfs s ∧ t_wfs s2 ∧ + fs[] +QED + +Theorem t_walk_walk_id: + t_wfs s ⇒ + t_walk s (t_walk s h) = t_walk s h +Proof + Cases_on`h`>> + fs[t_walk_eqn,t_walk_vwalk_id] +QED + +Theorem eqs_t_unify: + t_wfs s ∧ t_wfs s2 ∧ t_walkstar s2 (t_walkstar s t1) = t_walkstar s2 (t_walkstar s t2) ⇒ - ?sx. t_unify s t1 t2 = SOME sx` - (rw[t_unify_def] >> + ?sx. t_unify s t1 t2 = SOME sx +Proof + rw[t_unify_def] >> match_mp_tac (GEN_ALL eqs_unify) >> qexists_tac`encode_infer_t o_f s2` >> conj_asm1_tac >- fs[t_wfs_def] >> conj_asm1_tac >- fs[t_wfs_def] >> - simp[encode_walkstar]); + simp[encode_walkstar] +QED val encode_walkstar_reverse = encode_walkstar |> REWRITE_RULE [t_walkstar_def] |> SPEC_ALL|>UNDISCH|>SYM |> DISCH_ALL |> GEN_ALL; -Theorem t_unify_mgu -`!s t1 t2 sx s2. +Theorem t_unify_mgu: + !s t1 t2 sx s2. t_wfs s ∧ (t_unify s t1 t2 = SOME sx) ∧ t_wfs s2 ∧ (t_walkstar s2 (t_walkstar s t1)) = t_walkstar s2 (t_walkstar s t2) ⇒ - ∀t. t_walkstar s2 (t_walkstar sx t) = t_walkstar s2 (t_walkstar s t)` - (rw[]>> + ∀t. t_walkstar s2 (t_walkstar sx t) = t_walkstar s2 (t_walkstar s t) +Proof + rw[]>> `t_wfs sx` by metis_tac[t_unify_wfs]>> rfs[t_walkstar_def,encode_walkstar_reverse]>> AP_TERM_TAC>> @@ -1126,20 +1201,23 @@ Theorem t_unify_mgu impl_tac>>fs[])>> conj_asm1_tac>- fs[t_wfs_def]>> qpat_x_assum `decode_infer_t A = B` mp_tac>> - fs[encode_walkstar,decode_left_inverse]) + fs[encode_walkstar,decode_left_inverse] +QED -Theorem t_walkstar_tuvar_props -`t_wfs s +Theorem t_walkstar_tuvar_props: + t_wfs s ⇒ - (uv ∉ FDOM s ⇔ t_walkstar s (Infer_Tuvar uv) = Infer_Tuvar uv)` - (rw[EQ_IMP_THM] + (uv ∉ FDOM s ⇔ t_walkstar s (Infer_Tuvar uv) = Infer_Tuvar uv) +Proof + rw[EQ_IMP_THM] >- (fs[t_walkstar_eqn,t_walk_eqn,Once t_vwalk_eqn]>> imp_res_tac flookup_thm>>fs[]) >> imp_res_tac t_walkstar_vars_notin>> pop_assum (Q.SPECL_THEN [`uv`,`Infer_Tuvar uv`] mp_tac)>> - fs[t_vars_eqn]) + fs[t_vars_eqn] +QED (*t_compat theorems*) val t_compat_def = Define` @@ -1147,34 +1225,42 @@ val t_compat_def = Define` t_wfs s ∧ t_wfs s' ∧ !t. t_walkstar s' (t_walkstar s t) = t_walkstar s' t` -Theorem t_compat_refl -`t_wfs s ⇒ t_compat s s` - (rw[t_compat_def]>>fs[t_walkstar_SUBMAP]) - -Theorem t_compat_trans -`t_compat a b ∧ t_compat b c ⇒ t_compat a c` - (rw[t_compat_def]>>metis_tac[]) - -Theorem SUBMAP_t_compat -`t_wfs s' ∧ s SUBMAP s' ⇒ t_compat s s'` - (rw[t_compat_def] +Theorem t_compat_refl: + t_wfs s ⇒ t_compat s s +Proof + rw[t_compat_def]>>fs[t_walkstar_SUBMAP] +QED + +Theorem t_compat_trans: + t_compat a b ∧ t_compat b c ⇒ t_compat a c +Proof + rw[t_compat_def]>>metis_tac[] +QED + +Theorem SUBMAP_t_compat: + t_wfs s' ∧ s SUBMAP s' ⇒ t_compat s s' +Proof + rw[t_compat_def] >- metis_tac[t_wfs_SUBMAP]>> - fs[t_walkstar_SUBMAP]) + fs[t_walkstar_SUBMAP] +QED (*t_compat is preserved under certain types of unification Proof basically from HOL*) -Theorem t_compat_eqs_t_unify -`!s t1 t2 sx. +Theorem t_compat_eqs_t_unify: + !s t1 t2 sx. t_compat s sx ∧ (t_walkstar sx t1 = t_walkstar sx t2) ⇒ - ?si. (t_unify s t1 t2 = SOME si) ∧ t_compat si sx` - (rw[t_compat_def]>> + ?si. (t_unify s t1 t2 = SOME si) ∧ t_compat si sx +Proof + rw[t_compat_def]>> Q.ISPECL_THEN [`t2`,`t1`,`sx`,`s`] assume_tac (GEN_ALL eqs_t_unify)>> rfs[]>> CONJ_ASM1_TAC>-metis_tac[t_unify_wfs]>> rw[]>> Q.ISPECL_THEN [`s`,`t1`,`t2`,`sx'`,`sx`] assume_tac t_unify_mgu>> - rfs[]); + rfs[] +QED val _ = export_theory (); diff --git a/compiler/parsing/cmlPEGScript.sml b/compiler/parsing/cmlPEGScript.sml index ddd9dbff71..42b7405898 100644 --- a/compiler/parsing/cmlPEGScript.sml +++ b/compiler/parsing/cmlPEGScript.sml @@ -743,15 +743,17 @@ val PEG_exprs = save_thm( pred_setTheory.INSERT_UNION_EQ ]) -Theorem PEG_wellformed - `wfG cmlPEG` - (simp[wfG_def, Gexprs_def, subexprs_def, +Theorem PEG_wellformed: + wfG cmlPEG +Proof + simp[wfG_def, Gexprs_def, subexprs_def, subexprs_pnt, peg_start, peg_range, DISJ_IMP_THM, FORALL_AND_THM, choicel_def, seql_def, pegf_def, tokeq_def, try_def, peg_linfix_def, peg_UQConstructorName_def, peg_TypeDec_def, peg_V_def, peg_EbaseParen_def, peg_longV_def, peg_StructName_def] >> - simp(cml_wfpeg_thm :: wfpeg_rwts @ peg0_rwts @ npeg0_rwts)); + simp(cml_wfpeg_thm :: wfpeg_rwts @ peg0_rwts @ npeg0_rwts) +QED val _ = export_rewrites ["PEG_wellformed"] val parse_TopLevelDecs_total = save_thm( diff --git a/compiler/parsing/fromSexpScript.sml b/compiler/parsing/fromSexpScript.sml index 6ce383cf5c..33cef6eac7 100644 --- a/compiler/parsing/fromSexpScript.sml +++ b/compiler/parsing/fromSexpScript.sml @@ -22,62 +22,78 @@ val _ = temp_overload_on ("lift", ``OPTION_MAP``) (* TODO: move*) -Theorem OPTION_APPLY_MAP3 - `OPTION_APPLY (OPTION_APPLY (OPTION_MAP f x) y) z = SOME r ⇔ - ∃a b c. x = SOME a ∧ y = SOME b ∧ z = SOME c ∧ f a b c = r` - (Cases_on`x`\\simp[] \\ rw[EQ_IMP_THM] \\ rw[] - \\ Cases_on`y`\\fs[]); - -Theorem OPTION_APPLY_MAP4 - `OPTION_APPLY (OPTION_APPLY (OPTION_APPLY (OPTION_MAP f x) y) z ) t= SOME r ⇔ - ∃a b c d. x = SOME a ∧ y = SOME b ∧ z = SOME c ∧ t = SOME d /\ f a b c d= r` - (Cases_on`x`\\simp[] \\ rw[EQ_IMP_THM] \\ rw[] - \\ Cases_on`y`\\fs[] \\ Cases_on`z`\\fs[]); - -Theorem FOLDR_SX_CONS_INJ - `∀l1 l2. FOLDR SX_CONS nil l1 = FOLDR SX_CONS nil l2 ⇔ l1 = l2` - (Induct \\ simp[] +Theorem OPTION_APPLY_MAP3: + OPTION_APPLY (OPTION_APPLY (OPTION_MAP f x) y) z = SOME r ⇔ + ∃a b c. x = SOME a ∧ y = SOME b ∧ z = SOME c ∧ f a b c = r +Proof + Cases_on`x`\\simp[] \\ rw[EQ_IMP_THM] \\ rw[] + \\ Cases_on`y`\\fs[] +QED + +Theorem OPTION_APPLY_MAP4: + OPTION_APPLY (OPTION_APPLY (OPTION_APPLY (OPTION_MAP f x) y) z ) t= SOME r ⇔ + ∃a b c d. x = SOME a ∧ y = SOME b ∧ z = SOME c ∧ t = SOME d /\ f a b c d= r +Proof + Cases_on`x`\\simp[] \\ rw[EQ_IMP_THM] \\ rw[] + \\ Cases_on`y`\\fs[] \\ Cases_on`z`\\fs[] +QED + +Theorem FOLDR_SX_CONS_INJ: + ∀l1 l2. FOLDR SX_CONS nil l1 = FOLDR SX_CONS nil l2 ⇔ l1 = l2 +Proof + Induct \\ simp[] >- ( Induct \\ simp[] ) - \\ gen_tac \\ Induct \\ simp[]); + \\ gen_tac \\ Induct \\ simp[] +QED -Theorem strip_sxcons_11 - `∀s1 s2 x. strip_sxcons s1 = SOME x ∧ strip_sxcons s2 = SOME x ⇒ s1 = s2` - (ho_match_mp_tac simpleSexpTheory.strip_sxcons_ind +Theorem strip_sxcons_11: + ∀s1 s2 x. strip_sxcons s1 = SOME x ∧ strip_sxcons s2 = SOME x ⇒ s1 = s2 +Proof + ho_match_mp_tac simpleSexpTheory.strip_sxcons_ind \\ ntac 4 strip_tac \\ simp[Once simpleSexpTheory.strip_sxcons_def] \\ CASE_TAC \\ fs[] \\ strip_tac \\ rveq \\ fs[] \\ pop_assum mp_tac \\ simp[Once simpleSexpTheory.strip_sxcons_def] - \\ CASE_TAC \\ fs[] \\ strip_tac \\ rveq \\ fs[]); + \\ CASE_TAC \\ fs[] \\ strip_tac \\ rveq \\ fs[] +QED -Theorem dstrip_sexp_size - `∀s sym args. dstrip_sexp s = SOME (sym, args) ⇒ - ∀e. MEM e args ⇒ sexp_size e < sexp_size s` - (Induct >> simp[dstrip_sexp_def, sexp_size_def] >> +Theorem dstrip_sexp_size: + ∀s sym args. dstrip_sexp s = SOME (sym, args) ⇒ + ∀e. MEM e args ⇒ sexp_size e < sexp_size s +Proof + Induct >> simp[dstrip_sexp_def, sexp_size_def] >> rename1 `sexp_CASE sxp` >> Cases_on `sxp` >> simp[] >> rpt strip_tac >> rename1 `MEM sxp0 sxpargs` >> rename1 `strip_sxcons sxp'` >> `sxMEM sxp0 sxp'` by metis_tac[sxMEM_def] >> imp_res_tac sxMEM_sizelt >> - simp[]); + simp[] +QED -Theorem dstrip_sexp_SOME - `dstrip_sexp s = SOME x ⇔ +Theorem dstrip_sexp_SOME: + dstrip_sexp s = SOME x ⇔ ∃sym sa args. s = SX_CONS (SX_SYM sym) sa ∧ strip_sxcons sa = SOME args ∧ - (x = (sym,args))` - (Cases_on`s`>>simp[dstrip_sexp_def]>> - every_case_tac>>simp[]) - -Theorem strip_sxcons_SOME_NIL[simp] - `strip_sxcons s = SOME [] ⇔ s = nil` - (rw[Once strip_sxcons_def] >> - every_case_tac >> simp[]) - -Theorem strip_sxcons_EQ_CONS[simp] - `strip_sxcons s = SOME (h::t) ⇔ - ∃s0. s = SX_CONS h s0 ∧ strip_sxcons s0 = SOME t` - (simp[Once strip_sxcons_def] >> every_case_tac >> simp[] >> - metis_tac[]); + (x = (sym,args)) +Proof + Cases_on`s`>>simp[dstrip_sexp_def]>> + every_case_tac>>simp[] +QED + +Theorem strip_sxcons_SOME_NIL[simp]: + strip_sxcons s = SOME [] ⇔ s = nil +Proof + rw[Once strip_sxcons_def] >> + every_case_tac >> simp[] +QED + +Theorem strip_sxcons_EQ_CONS[simp]: + strip_sxcons s = SOME (h::t) ⇔ + ∃s0. s = SX_CONS h s0 ∧ strip_sxcons s0 = SOME t +Proof + simp[Once strip_sxcons_def] >> every_case_tac >> simp[] >> + metis_tac[] +QED val type_ind = (TypeBase.induction_of``:ast_t``) @@ -133,15 +149,18 @@ val decode_control_def = Define` | _ => NONE else OPTION_IGNORE_BIND (OPTION_GUARD (isPrint c)) (OPTION_MAP (CONS c) (decode_control cs)))`; -Theorem EVERY_isPrint_encode_control - `∀ls. EVERY isPrint (encode_control ls)` - (Induct \\ rw[encode_control_def] +Theorem EVERY_isPrint_encode_control: + ∀ls. EVERY isPrint (encode_control ls) +Proof + Induct \\ rw[encode_control_def] \\ TRY (qmatch_rename_tac`isPrint _` \\ EVAL_TAC) - \\ metis_tac[EVERY_isHexDigit_num_to_hex_string,MONO_EVERY,isHexDigit_isPrint,EVERY_CONJ]); + \\ metis_tac[EVERY_isHexDigit_num_to_hex_string,MONO_EVERY,isHexDigit_isPrint,EVERY_CONJ] +QED -Theorem decode_encode_control[simp] - `∀ls. decode_control (encode_control ls) = SOME ls` - (Induct \\ rw[encode_control_def,decode_control_def] +Theorem decode_encode_control[simp]: + ∀ls. decode_control (encode_control ls) = SOME ls +Proof + Induct \\ rw[encode_control_def,decode_control_def] \\ BasicProvers.TOP_CASE_TAC \\ rw[decode_control_def,encode_control_def] \\ fs[] \\ rw[decode_control_def] @@ -163,7 +182,8 @@ Theorem decode_encode_control[simp] else th) \\ fs[] \\ NO_TAC) \\ simp[num_from_hex_string_leading_0] \\ first_x_assum(CHANGED_TAC o SUBST1_TAC o SYM) - \\ simp[stringTheory.CHR_ORD]) + \\ simp[stringTheory.CHR_ORD] +QED val isHexDigit_alt = Q.prove( `isHexDigit c ⇔ c ∈ set "0123456789abcdefABCDEF"`, @@ -173,18 +193,23 @@ val UNHEX_lt16 = Q.prove( `isHexDigit c ⇒ UNHEX c < 16`, dsimp[isHexDigit_alt, ASCIInumbersTheory.UNHEX_def]); -Theorem isAlpha_isUpper_isLower - `isAlpha c ⇒ (isUpper c ⇎ isLower c)` - (simp[isAlpha_def, isUpper_def, isLower_def]); +Theorem isAlpha_isUpper_isLower: + isAlpha c ⇒ (isUpper c ⇎ isLower c) +Proof + simp[isAlpha_def, isUpper_def, isLower_def] +QED -Theorem isLower_isAlpha - `isLower c ⇒ isAlpha c` - (simp[isLower_def, isAlpha_def]); +Theorem isLower_isAlpha: + isLower c ⇒ isAlpha c +Proof + simp[isLower_def, isAlpha_def] +QED open ASCIInumbersTheory numposrepTheory -Theorem encode_decode_control - `∀ls r. decode_control ls = SOME r ⇒ ls = encode_control r` - (ho_match_mp_tac (theorem"decode_control_ind") +Theorem encode_decode_control: + ∀ls r. decode_control ls = SOME r ⇒ ls = encode_control r +Proof + ho_match_mp_tac (theorem"decode_control_ind") \\ rw[] >- ( fs[decode_control_def] \\ rw[encode_control_def] ) \\ pop_assum mp_tac @@ -234,34 +259,43 @@ Theorem encode_decode_control by metis_tac[num_from_hex_string_length_2, num_from_hex_string_def] >> `LOG 16 N = 1` by simp[logrootTheory.LOG_UNIQUE] >> simp[Abbr`s`, Abbr`N`, LASTN_def, HEX_UNHEX, toUpper_def] >> - metis_tac[isLower_isAlpha, isAlpha_isUpper_isLower]) + metis_tac[isLower_isAlpha, isAlpha_isUpper_isLower] +QED val SEXSTR_def = Define` SEXSTR s = SX_STR (encode_control s)`; -Theorem SEXSTR_11[simp] - `SEXSTR s1 = SEXSTR s2 ⇔ s1 = s2` - (rw[SEXSTR_def] - \\ metis_tac[decode_encode_control,SOME_11]); +Theorem SEXSTR_11[simp]: + SEXSTR s1 = SEXSTR s2 ⇔ s1 = s2 +Proof + rw[SEXSTR_def] + \\ metis_tac[decode_encode_control,SOME_11] +QED -Theorem SEXSTR_distinct[simp] - `(SEXSTR s ≠ SX_SYM sym) ∧ +Theorem SEXSTR_distinct[simp]: + (SEXSTR s ≠ SX_SYM sym) ∧ (SEXSTR s ≠ SX_NUM num) ∧ (SEXSTR s ≠ SX_CONS a d) ∧ - ((SEXSTR s = SX_STR s') ⇔ s' = encode_control s)` - (rw[SEXSTR_def,EQ_IMP_THM]); + ((SEXSTR s = SX_STR s') ⇔ s' = encode_control s) +Proof + rw[SEXSTR_def,EQ_IMP_THM] +QED val odestSEXSTR_def = Define` (odestSEXSTR (SX_STR s) = decode_control s) ∧ (odestSEXSTR _ = NONE)`; -Theorem encode_control_remove - `∀s. EVERY isPrint s ∧ #"\\" ∉ set s ⇒ encode_control s = s` - (Induct \\ simp[encode_control_def]); +Theorem encode_control_remove: + ∀s. EVERY isPrint s ∧ #"\\" ∉ set s ⇒ encode_control s = s +Proof + Induct \\ simp[encode_control_def] +QED -Theorem SEXSTR_remove - `EVERY isPrint s ∧ #"\\" ∉ set s ⇒ SEXSTR s = SX_STR s` - (rw[SEXSTR_def,encode_control_remove]); +Theorem SEXSTR_remove: + EVERY isPrint s ∧ #"\\" ∉ set s ⇒ SEXSTR s = SX_STR s +Proof + rw[SEXSTR_def,encode_control_remove] +QED val odestSXSTR_def = Define` (odestSXSTR (SX_STR s) = SOME s) ∧ @@ -312,44 +346,54 @@ val sexppair_def = Define` | _ => fail `; -Theorem sexppair_CONG[defncong] - `∀s1 s2 p1 p1' p2 p2'. +Theorem sexppair_CONG[defncong]: + ∀s1 s2 p1 p1' p2 p2'. s1 = s2 ∧ (∀s. (∃s'. s2 = SX_CONS s s') ⇒ p1 s = p1' s) ∧ (∀s. (∃s'. s2 = SX_CONS s' s) ⇒ p2 s = p2' s) ⇒ - sexppair p1 p2 s1 = sexppair p1' p2' s2` - (simp[] >> Cases >> simp[sexppair_def]) - - -Theorem strip_sxcons_FAIL_sexplist_FAIL - `∀s. (strip_sxcons s = NONE) ⇒ (sexplist p s = NONE)` - (Induct >> simp[Once strip_sxcons_def, Once sexplist_def] >> - metis_tac[TypeBase.nchotomy_of ``:α option``]); - -Theorem monad_bind_FAIL - `monad_bind m1 (λx. fail) = fail` - (Cases_on `m1` >> simp[]); - -Theorem monad_unitbind_CONG[defncong] - `∀m11 m21 m12 m22. + sexppair p1 p2 s1 = sexppair p1' p2' s2 +Proof + simp[] >> Cases >> simp[sexppair_def] +QED + + +Theorem strip_sxcons_FAIL_sexplist_FAIL: + ∀s. (strip_sxcons s = NONE) ⇒ (sexplist p s = NONE) +Proof + Induct >> simp[Once strip_sxcons_def, Once sexplist_def] >> + metis_tac[TypeBase.nchotomy_of ``:α option``] +QED + +Theorem monad_bind_FAIL: + monad_bind m1 (λx. fail) = fail +Proof + Cases_on `m1` >> simp[] +QED + +Theorem monad_unitbind_CONG[defncong]: + ∀m11 m21 m12 m22. m11 = m12 ∧ (m12 = SOME () ⇒ m21 = m22) ⇒ - monad_unitbind m11 m21 = monad_unitbind m12 m22` - (simp[] >> rpt gen_tac >> rename1 `m12 = SOME ()` >> - Cases_on `m12` >> simp[]); - -Theorem sexplist_CONG[defncong] - `∀s1 s2 p1 p2. + monad_unitbind m11 m21 = monad_unitbind m12 m22 +Proof + simp[] >> rpt gen_tac >> rename1 `m12 = SOME ()` >> + Cases_on `m12` >> simp[] +QED + +Theorem sexplist_CONG[defncong]: + ∀s1 s2 p1 p2. (s1 = s2) ∧ (∀e. sxMEM e s2 ⇒ p1 e = p2 e) ⇒ - (sexplist p1 s1 = sexplist p2 s2)` - (simp[sxMEM_def] >> Induct >> dsimp[Once strip_sxcons_def] + (sexplist p1 s1 = sexplist p2 s2) +Proof + simp[sxMEM_def] >> Induct >> dsimp[Once strip_sxcons_def] >- (ONCE_REWRITE_TAC [sexplist_def] >> simp[] >> rename1 `strip_sxcons t` >> Cases_on `strip_sxcons t` >> simp[] >- (simp[strip_sxcons_FAIL_sexplist_FAIL, monad_bind_FAIL]) >> map_every qx_gen_tac [`p1`, `p2`] >> strip_tac >> Cases_on `p2 s2` >> simp[] >> fs[] >> metis_tac[]) >> - simp[sexplist_def]); + simp[sexplist_def] +QED val _ = temp_overload_on ("guard", ``λb m. monad_unitbind (assert b) m``); @@ -420,9 +464,10 @@ val sexptype_alt_def = tDefine"sexptype_alt"` val sexptype_alt_ind = theorem"sexptype_alt_ind"; -Theorem sexptype_alt_intro - `(∀s. sexptype s = sexptype_alt s) ∧ (∀s. sexptype_list s = sexplist sexptype s)` - (ho_match_mp_tac sexptype_alt_ind \\ rw[] +Theorem sexptype_alt_intro: + (∀s. sexptype s = sexptype_alt s) ∧ (∀s. sexptype_list s = sexplist sexptype s) +Proof + ho_match_mp_tac sexptype_alt_ind \\ rw[] >- ( rw[Once sexptype_alt_def,Once sexptype_def] \\ TOP_CASE_TAC \\ fs[] \\ @@ -433,11 +478,14 @@ Theorem sexptype_alt_intro rw[Once sexplist_def,Once (CONJUNCT2 sexptype_alt_def)] \\ TOP_CASE_TAC \\ fs[] \\ TOP_CASE_TAC \\ fs[] \\ - TOP_CASE_TAC \\ fs[] )); + TOP_CASE_TAC \\ fs[] ) +QED -Theorem sexptype_alt_intro1 - `sexptype = sexptype_alt ∧ sexplist sexptype = sexptype_list` - (rw[FUN_EQ_THM,sexptype_alt_intro]); +Theorem sexptype_alt_intro1: + sexptype = sexptype_alt ∧ sexplist sexptype = sexptype_list +Proof + rw[FUN_EQ_THM,sexptype_alt_intro] +QED val sexplit_def = Define` sexplit s = @@ -532,9 +580,10 @@ val sexppat_alt_def = tDefine"sexppat_alt"` val sexppat_alt_ind = theorem"sexppat_alt_ind"; -Theorem sexppat_alt_intro - `(∀s. sexppat s = sexppat_alt s) ∧ (∀s. sexppat_list s = sexplist sexppat s)` - (ho_match_mp_tac sexppat_alt_ind \\ rw[] +Theorem sexppat_alt_intro: + (∀s. sexppat s = sexppat_alt s) ∧ (∀s. sexppat_list s = sexplist sexppat s) +Proof + ho_match_mp_tac sexppat_alt_ind \\ rw[] >- ( rw[Once sexppat_alt_def,Once sexppat_def] \\ TOP_CASE_TAC \\ fs[] \\ @@ -545,11 +594,14 @@ Theorem sexppat_alt_intro rw[Once sexplist_def,Once (CONJUNCT2 sexppat_alt_def)] \\ TOP_CASE_TAC \\ fs[] \\ TOP_CASE_TAC \\ fs[] \\ - TOP_CASE_TAC \\ fs[] )); + TOP_CASE_TAC \\ fs[] ) +QED -Theorem sexppat_alt_intro1 - `sexppat = sexppat_alt ∧ sexplist sexppat = sexppat_list` - (rw[FUN_EQ_THM,sexppat_alt_intro]); +Theorem sexppat_alt_intro1: + sexppat = sexppat_alt ∧ sexplist sexppat = sexppat_list +Proof + rw[FUN_EQ_THM,sexppat_alt_intro] +QED val sexpop_def = Define` (sexpop (SX_SYM s) = @@ -848,14 +900,15 @@ val sexpexp_alt_def = tDefine"sexpexp_alt"` val sexpexp_alt_ind = theorem"sexpexp_alt_ind"; -Theorem sexpexp_alt_intro - `(∀s. sexpexp s = sexpexp_alt s) ∧ +Theorem sexpexp_alt_intro: + (∀s. sexpexp s = sexpexp_alt s) ∧ (∀s. sexplist sexpexp s = sexpexp_list s) ∧ (∀s. sexplist (sexppair sexppat sexpexp) s = sexppes s) ∧ (∀s. sexplist (sexppair odestSEXSTR (sexppair odestSEXSTR sexpexp)) s = sexpfuns s) ∧ (∀s. sexppair sexppat sexpexp s = sexppatexp s) ∧ - (∀s. sexppair odestSEXSTR (sexppair odestSEXSTR sexpexp) s = sexpfun s)` - (ho_match_mp_tac sexpexp_alt_ind \\ rw[] + (∀s. sexppair odestSEXSTR (sexppair odestSEXSTR sexpexp) s = sexpfun s) +Proof + ho_match_mp_tac sexpexp_alt_ind \\ rw[] >- ( rw[Once sexpexp_alt_def,Once sexpexp_def] \\ TOP_CASE_TAC \\ fs[] \\ @@ -897,12 +950,15 @@ Theorem sexpexp_alt_intro TOP_CASE_TAC \\ fs[sexppat_alt_intro1] \\ TOP_CASE_TAC \\ fs[] \\ TOP_CASE_TAC \\ fs[] \\ - TOP_CASE_TAC \\ fs[])); + TOP_CASE_TAC \\ fs[]) +QED -Theorem sexpexp_alt_intro1 - `sexpexp = sexpexp_alt ∧ - sexplist (sexppair odestSEXSTR (sexppair odestSEXSTR sexpexp)) = sexpfuns` - (rw[FUN_EQ_THM,sexpexp_alt_intro]); +Theorem sexpexp_alt_intro1: + sexpexp = sexpexp_alt ∧ + sexplist (sexppair odestSEXSTR (sexppair odestSEXSTR sexpexp)) = sexpfuns +Proof + rw[FUN_EQ_THM,sexpexp_alt_intro] +QED val sexptype_def_def = Define` sexptype_def = @@ -995,10 +1051,11 @@ val sexpdec_alt_def = tDefine"sexpdec_alt"` val sexpdec_alt_ind = theorem"sexpdec_alt_ind"; -Theorem sexpdec_alt_intro - `(∀s. sexpdec s = sexpdec_alt s) ∧ - (∀s. sexplist sexpdec s = sexpdec_list s)` - (ho_match_mp_tac sexpdec_alt_ind \\ rw[] +Theorem sexpdec_alt_intro: + (∀s. sexpdec s = sexpdec_alt s) ∧ + (∀s. sexplist sexpdec s = sexpdec_list s) +Proof + ho_match_mp_tac sexpdec_alt_ind \\ rw[] >- ( rw[Once sexpdec_def,Once sexpdec_alt_def,sexppat_alt_intro1,sexpexp_alt_intro1,sexptype_alt_intro1] \\ TOP_CASE_TAC \\ fs[] @@ -1008,37 +1065,46 @@ Theorem sexpdec_alt_intro rw[Once sexplist_def,Once (CONJUNCT2 sexpdec_alt_def)] \\ TOP_CASE_TAC \\ fs[] \\ TOP_CASE_TAC \\ fs[] \\ - TOP_CASE_TAC \\ fs[] )); + TOP_CASE_TAC \\ fs[] ) +QED -Theorem sexpdec_alt_intro1 - `sexpdec = sexpdec_alt ∧ - sexplist sexpdec = sexpdec_list` - (rw[FUN_EQ_THM,sexpdec_alt_intro]); +Theorem sexpdec_alt_intro1: + sexpdec = sexpdec_alt ∧ + sexplist sexpdec = sexpdec_list +Proof + rw[FUN_EQ_THM,sexpdec_alt_intro] +QED (* now the reverse: toSexp *) val listsexp_def = Define` listsexp = FOLDR SX_CONS nil`; -Theorem listsexp_11[simp] - `∀ l1 l2. listsexp l1 = listsexp l2 ⇔ l1 = l2` - (Induct >> gen_tac >> cases_on `l2` >> fs[listsexp_def]); +Theorem listsexp_11[simp]: + ∀ l1 l2. listsexp l1 = listsexp l2 ⇔ l1 = l2 +Proof + Induct >> gen_tac >> cases_on `l2` >> fs[listsexp_def] +QED val optsexp_def = Define` (optsexp NONE = SX_SYM "NONE") ∧ (optsexp (SOME x) = listsexp [SX_SYM "SOME"; x])`; -Theorem optsexp_11[simp] - `optsexp o1 = optsexp o2 ⇔ o1 = o2` - (cases_on `o1` >> cases_on `o2` >> fs[optsexp_def, listsexp_def]); +Theorem optsexp_11[simp]: + optsexp o1 = optsexp o2 ⇔ o1 = o2 +Proof + cases_on `o1` >> cases_on `o2` >> fs[optsexp_def, listsexp_def] +QED val idsexp_def = Define` (idsexp (Short n) = listsexp [SX_SYM"Short"; SEXSTR n]) ∧ (idsexp (Long ns n) = listsexp [SX_SYM"Long"; SEXSTR ns; idsexp n])`; -Theorem idsexp_11[simp] - `∀ i1 i2. idsexp i1 = idsexp i2 ⇔ i1 = i2` - (Induct >> gen_tac >> cases_on `i2` >> fs[idsexp_def]); +Theorem idsexp_11[simp]: + ∀ i1 i2. idsexp i1 = idsexp i2 ⇔ i1 = i2 +Proof + Induct >> gen_tac >> cases_on `i2` >> fs[idsexp_def] +QED val typesexp_def = tDefine"typesexp"` (typesexp (Atvar s) = listsexp [SX_SYM "Atvar"; SEXSTR s]) ∧ @@ -1049,15 +1115,17 @@ val typesexp_def = tDefine"typesexp"` Induct_on`ts` >> simp[ast_t_size_def] >> rw[] >> res_tac >> simp[]); -Theorem typesexp_11[simp] - `∀t1 t2. typesexp t1 = typesexp t2 ⇔ t1 = t2` - (ho_match_mp_tac (theorem"typesexp_ind") +Theorem typesexp_11[simp]: + ∀t1 t2. typesexp t1 = typesexp t2 ⇔ t1 = t2 +Proof + ho_match_mp_tac (theorem"typesexp_ind") \\ simp[typesexp_def] \\ rpt conj_tac \\ simp[PULL_FORALL] \\ CONV_TAC(RESORT_FORALL_CONV List.rev) \\ Cases \\ simp[typesexp_def] \\ srw_tac[ETA_ss][EQ_IMP_THM] - \\ metis_tac[MAP_EQ_MAP_IMP]); + \\ metis_tac[MAP_EQ_MAP_IMP] +QED val litsexp_def = Define` (litsexp (IntLit i) = @@ -1068,10 +1136,12 @@ val litsexp_def = Define` (litsexp (Word8 w) = listsexp [SX_SYM "word8"; SX_NUM (w2n w)]) ∧ (litsexp (Word64 w) = listsexp [SX_SYM "word64"; SX_NUM (w2n w)])`; -Theorem litsexp_11[simp] - `∀l1 l2. litsexp l1 = litsexp l2 ⇔ l1 = l2` - (Cases \\ Cases \\ rw[litsexp_def,EQ_IMP_THM,listsexp_def] - \\ intLib.COOPER_TAC); +Theorem litsexp_11[simp]: + ∀l1 l2. litsexp l1 = litsexp l2 ⇔ l1 = l2 +Proof + Cases \\ Cases \\ rw[litsexp_def,EQ_IMP_THM,listsexp_def] + \\ intLib.COOPER_TAC +QED val patsexp_def = tDefine"patsexp"` (patsexp Pany = listsexp [SX_SYM "Pany"]) ∧ @@ -1087,9 +1157,10 @@ val patsexp_def = tDefine"patsexp"` first_x_assum(qspec_then`cn`strip_assume_tac)>> decide_tac ); -Theorem patsexp_11[simp] - `∀p1 p2. patsexp p1 = patsexp p2 ⇔ p1 = p2` - (ho_match_mp_tac (theorem"patsexp_ind") +Theorem patsexp_11[simp]: + ∀p1 p2. patsexp p1 = patsexp p2 ⇔ p1 = p2 +Proof + ho_match_mp_tac (theorem"patsexp_ind") \\ rpt conj_tac \\ simp[PULL_FORALL] \\ CONV_TAC(RESORT_FORALL_CONV List.rev) \\ Cases \\ rw[patsexp_def,listsexp_def] @@ -1098,15 +1169,18 @@ Theorem patsexp_11[simp] \\ imp_res_tac FOLDR_SX_CONS_INJ \\ imp_res_tac (REWRITE_RULE[AND_IMP_INTRO] MAP_EQ_MAP_IMP) \\ first_x_assum match_mp_tac - \\ simp[] \\ metis_tac[]); + \\ simp[] \\ metis_tac[] +QED val lopsexp_def = Define` (lopsexp And = SX_SYM "And") ∧ (lopsexp Or = SX_SYM "Or")`; -Theorem lopsexp_11[simp] - `∀l1 l2. lopsexp l1 = lopsexp l2 ⇔ l1 = l2` - (Cases \\ Cases \\ simp[lopsexp_def]); +Theorem lopsexp_11[simp]: + ∀l1 l2. lopsexp l1 = lopsexp l2 ⇔ l1 = l2 +Proof + Cases \\ Cases \\ simp[lopsexp_def] +QED val opsexp_def = Define` (opsexp (Opn Plus) = SX_SYM "OpnPlus") ∧ @@ -1187,9 +1261,10 @@ val opsexp_def = Define` (opsexp ConfigGC = SX_SYM "ConfigGC") ∧ (opsexp (FFI s) = SX_CONS (SX_SYM "FFI") (SEXSTR s))`; -Theorem sexpop_opsexp[simp] - `sexpop (opsexp op) = SOME op` - (Cases_on`op`>>rw[sexpop_def,opsexp_def]>> +Theorem sexpop_opsexp[simp]: + sexpop (opsexp op) = SOME op +Proof + Cases_on`op`>>rw[sexpop_def,opsexp_def]>> TRY(MAP_FIRST rename1 [ ‘Opn c1’, ‘Opb c1’, ‘Opw c2 c1’, ‘Chopb c1’, ‘Shift c1 c2 _’, ‘FP_cmp c1’, ‘FP_uop c1’, ‘FP_bop c1’, ‘WordFromInt c1’, @@ -1197,26 +1272,33 @@ Theorem sexpop_opsexp[simp] ] >> Cases_on`c1` >> rw[sexpop_def,opsexp_def] >> Cases_on`c2` >> rw[sexpop_def,opsexp_def]) >> - rw[sexpop_def,opsexp_def,SEXSTR_def]) + rw[sexpop_def,opsexp_def,SEXSTR_def] +QED -Theorem opsexp_11[simp] - `∀o1 o2. opsexp o1 = opsexp o2 ⇔ o1 = o2` - (rw[EQ_IMP_THM] >> pop_assum (mp_tac o AP_TERM “sexpop”) >> simp[]); +Theorem opsexp_11[simp]: + ∀o1 o2. opsexp o1 = opsexp o2 ⇔ o1 = o2 +Proof + rw[EQ_IMP_THM] >> pop_assum (mp_tac o AP_TERM “sexpop”) >> simp[] +QED val locnsexp_def = Define` locnsexp (Locs (locn n1 n2 n3) (locn n4 n5 n6)) = listsexp (MAP SX_NUM [n1;n2;n3;n4;n5;n6])`; -Theorem locnsexp_thm[compute] - `locnsexp (Locs l1 l2) = +Theorem locnsexp_thm[compute]: + locnsexp (Locs l1 l2) = listsexp [&(l1.row); &(l1.col); &(l1.offset); - &(l2.row); &(l2.col); &(l2.offset)]` - (Cases_on`l1` \\ Cases_on`l2` \\ rw[locnsexp_def]); - -Theorem locnsexp_11[simp] - `∀l1 l2. locnsexp l1 = locnsexp l2 ⇔ l1 = l2` - (Cases \\ Cases \\ rename [`locnsexp (Locs l1 l2) = locnsexp (Locs l3 l4)`] >> - map_every Cases_on [`l1`, `l2`, `l3`, `l4`] >> rw[locnsexp_def]); + &(l2.row); &(l2.col); &(l2.offset)] +Proof + Cases_on`l1` \\ Cases_on`l2` \\ rw[locnsexp_def] +QED + +Theorem locnsexp_11[simp]: + ∀l1 l2. locnsexp l1 = locnsexp l2 ⇔ l1 = l2 +Proof + Cases \\ Cases \\ rename [`locnsexp (Locs l1 l2) = locnsexp (Locs l3 l4)`] >> + map_every Cases_on [`l1`, `l2`, `l3`, `l4`] >> rw[locnsexp_def] +QED val expsexp_def = tDefine"expsexp"` (expsexp (Raise e) = listsexp [SX_SYM "Raise"; expsexp e]) ∧ @@ -1244,16 +1326,18 @@ val expsexp_def = tDefine"expsexp"` first_x_assum(strip_assume_tac o SPEC_ALL) >> decide_tac); -Theorem expsexp_11[simp] - `∀e1 e2. expsexp e1 = expsexp e2 ⇒ e1 = e2` - (ho_match_mp_tac (theorem"expsexp_ind") +Theorem expsexp_11[simp]: + ∀e1 e2. expsexp e1 = expsexp e2 ⇒ e1 = e2 +Proof + ho_match_mp_tac (theorem"expsexp_ind") \\ rpt conj_tac \\ simp[PULL_FORALL] \\ CONV_TAC(RESORT_FORALL_CONV List.rev) \\ Cases \\ rw[expsexp_def] \\ imp_res_tac (REWRITE_RULE[AND_IMP_INTRO] MAP_EQ_MAP_IMP) \\ TRY(first_x_assum match_mp_tac \\ rw[FORALL_PROD]) \\ rpt(pairarg_tac \\ fs[]) - \\ metis_tac[OPTION_MAP_INJ,idsexp_11,simpleSexpTheory.sexp_11,SEXSTR_11]); + \\ metis_tac[OPTION_MAP_INJ,idsexp_11,simpleSexpTheory.sexp_11,SEXSTR_11] +QED val type_defsexp_def = Define` type_defsexp = listsexp o @@ -1262,9 +1346,10 @@ val type_defsexp_def = Define` (SX_CONS (SEXSTR x) (listsexp (MAP (λ(y,ts). SX_CONS (SEXSTR y) (listsexp (MAP typesexp ts))) ls))))`; -Theorem type_defsexp_11[simp] - `∀t1 t2. type_defsexp t1 = type_defsexp t2 ⇔ t1 = t2` - (rw[type_defsexp_def,EQ_IMP_THM] +Theorem type_defsexp_11[simp]: + ∀t1 t2. type_defsexp t1 = type_defsexp t2 ⇔ t1 = t2 +Proof + rw[type_defsexp_def,EQ_IMP_THM] \\ imp_res_tac (REWRITE_RULE[AND_IMP_INTRO] MAP_EQ_MAP_IMP) \\ first_x_assum match_mp_tac \\ rw[FORALL_PROD] @@ -1278,15 +1363,20 @@ Theorem type_defsexp_11[simp] \\ rw[FORALL_PROD] \\ rpt (pairarg_tac \\ fs[]) \\ rveq \\ Q.ISPEC_THEN`typesexp`match_mp_tac INJ_MAP_EQ - \\ simp[INJ_DEF]); + \\ simp[INJ_DEF] +QED -Theorem dec1_size_eq - `dec1_size xs = list_size dec_size xs` - (Induct_on `xs` \\ fs [dec_size_def, list_size_def]); +Theorem dec1_size_eq: + dec1_size xs = list_size dec_size xs +Proof + Induct_on `xs` \\ fs [dec_size_def, list_size_def] +QED -Theorem mem_size_lemma - `list_size sz xs < N ==> (MEM x xs ⇒ sz x < N)` - (Induct_on `xs` \\ rw [list_size_def] \\ fs []); +Theorem mem_size_lemma: + list_size sz xs < N ==> (MEM x xs ⇒ sz x < N) +Proof + Induct_on `xs` \\ rw [list_size_def] \\ fs [] +QED val decsexp_def = tDefine "decsexp"` (decsexp (Dlet locs p e) = listsexp [SX_SYM "Dlet"; locnsexp locs; patsexp p; expsexp e]) ∧ @@ -1304,112 +1394,155 @@ val decsexp_def = tDefine "decsexp"` \\ rpt (conj_tac ORELSE gen_tac ORELSE match_mp_tac mem_size_lemma) \\ fs []); -Theorem decsexp_11[simp] - `∀d1 d2. decsexp d1 = decsexp d2 ⇔ d1 = d2` - (ho_match_mp_tac(theorem"decsexp_ind") +Theorem decsexp_11[simp]: + ∀d1 d2. decsexp d1 = decsexp d2 ⇔ d1 = d2 +Proof + ho_match_mp_tac(theorem"decsexp_ind") \\ rw[decsexp_def,EQ_IMP_THM] \\ fs[decsexp_def] \\ Cases_on`d2` \\ fs[decsexp_def] \\ rw[] \\ imp_res_tac (REWRITE_RULE[AND_IMP_INTRO] MAP_EQ_MAP_IMP) \\ TRY (first_x_assum match_mp_tac \\ rw[]) - \\ rpt(pairarg_tac \\ fs[])); + \\ rpt(pairarg_tac \\ fs[]) +QED (* round trip *) -Theorem odestSXSTR_SOME[simp] - `odestSXSTR s = SOME y ⇔ (s = SX_STR y)` - (Cases_on`s`>>simp[odestSXSTR_def]) - -Theorem odestSEXSTR_SOME[simp] - `odestSEXSTR s = SOME y ⇔ (s = SEXSTR y)` - (Cases_on`s`\\simp[odestSEXSTR_def,SEXSTR_def] - \\ metis_tac[decode_encode_control,encode_decode_control]); - -Theorem odestSXSTR_SX_STR[simp] - `odestSXSTR (SX_STR s) = SOME s` - (rw[odestSXSTR_def]) - -Theorem odestSEXSTR_SEXSTR[simp] - `odestSEXSTR (SEXSTR s) = SOME s` - (rw[odestSEXSTR_def]); - -Theorem odestSXNUM_SX_NUM[simp] - `odestSXNUM (SX_NUM n) = SOME n` - (EVAL_TAC) - -Theorem odestSXSYM_SX_SYM[simp] - `odestSXSYM (SX_SYM s) = SOME s` - (EVAL_TAC) - -Theorem odestSXNUM_SX_STR[simp] - `odestSXNUM (SX_STR s) = NONE` - (EVAL_TAC) - -Theorem odestSXNUM_SEXSTR[simp] - `odestSXNUM (SEXSTR s) = NONE` - (EVAL_TAC) - -Theorem odestSXSTR_listsexp[simp] - `odestSXSTR (listsexp l) = NONE` - (Cases_on`l`>>EVAL_TAC) - -Theorem odestSEXSTR_listsexp[simp] - `odestSEXSTR (listsexp l) = NONE` - (Cases_on`l`>>EVAL_TAC) - -Theorem odestSXNUM_listsexp[simp] - `odestSXNUM (listsexp l) = NONE` - (Cases_on`l`>>EVAL_TAC) - -Theorem dstrip_sexp_SX_STR[simp] - `dstrip_sexp (SX_STR s) = NONE` - (EVAL_TAC) - -Theorem dstrip_sexp_SEXSTR[simp] - `dstrip_sexp (SEXSTR s) = NONE` - (EVAL_TAC) - -Theorem strip_sxcons_listsexp[simp] - `strip_sxcons (listsexp ls) = SOME ls` - (Induct_on`ls`>>rw[listsexp_def] >> simp[GSYM listsexp_def]); - -Theorem dstrip_sexp_listsexp[simp] - `(dstrip_sexp (listsexp ls) = - case ls of (SX_SYM x::xs) => SOME (x,xs) | _ => NONE)` - (BasicProvers.CASE_TAC >> rw[dstrip_sexp_def,listsexp_def] >> - BasicProvers.CASE_TAC >> rw[GSYM listsexp_def]); - -Theorem sexplist_listsexp_matchable - `∀g gl. (∀x. MEM x l ⇒ f (g x) = SOME x) ∧ (gl = MAP g l) ⇒ - sexplist f (listsexp gl) = SOME l` - (Induct_on`l` >> simp[listsexp_def,Once sexplist_def] >> - simp[GSYM listsexp_def] >> metis_tac[]); - -Theorem sexplist_listsexp_rwt[simp] - `(∀x. MEM x l ⇒ f (g x) = SOME x) ⇒ - (sexplist f (listsexp (MAP g l)) = SOME l)` - (metis_tac[sexplist_listsexp_matchable]); - -Theorem sexplist_listsexp_imp - `sexplist f (listsexp l1) = SOME l2 ⇒ - ∀n. n < LENGTH l1 ⇒ f (EL n l1) = SOME (EL n l2)` - (qid_spec_tac`l2`>> +Theorem odestSXSTR_SOME[simp]: + odestSXSTR s = SOME y ⇔ (s = SX_STR y) +Proof + Cases_on`s`>>simp[odestSXSTR_def] +QED + +Theorem odestSEXSTR_SOME[simp]: + odestSEXSTR s = SOME y ⇔ (s = SEXSTR y) +Proof + Cases_on`s`\\simp[odestSEXSTR_def,SEXSTR_def] + \\ metis_tac[decode_encode_control,encode_decode_control] +QED + +Theorem odestSXSTR_SX_STR[simp]: + odestSXSTR (SX_STR s) = SOME s +Proof + rw[odestSXSTR_def] +QED + +Theorem odestSEXSTR_SEXSTR[simp]: + odestSEXSTR (SEXSTR s) = SOME s +Proof + rw[odestSEXSTR_def] +QED + +Theorem odestSXNUM_SX_NUM[simp]: + odestSXNUM (SX_NUM n) = SOME n +Proof + EVAL_TAC +QED + +Theorem odestSXSYM_SX_SYM[simp]: + odestSXSYM (SX_SYM s) = SOME s +Proof + EVAL_TAC +QED + +Theorem odestSXNUM_SX_STR[simp]: + odestSXNUM (SX_STR s) = NONE +Proof + EVAL_TAC +QED + +Theorem odestSXNUM_SEXSTR[simp]: + odestSXNUM (SEXSTR s) = NONE +Proof + EVAL_TAC +QED + +Theorem odestSXSTR_listsexp[simp]: + odestSXSTR (listsexp l) = NONE +Proof + Cases_on`l`>>EVAL_TAC +QED + +Theorem odestSEXSTR_listsexp[simp]: + odestSEXSTR (listsexp l) = NONE +Proof + Cases_on`l`>>EVAL_TAC +QED + +Theorem odestSXNUM_listsexp[simp]: + odestSXNUM (listsexp l) = NONE +Proof + Cases_on`l`>>EVAL_TAC +QED + +Theorem dstrip_sexp_SX_STR[simp]: + dstrip_sexp (SX_STR s) = NONE +Proof + EVAL_TAC +QED + +Theorem dstrip_sexp_SEXSTR[simp]: + dstrip_sexp (SEXSTR s) = NONE +Proof + EVAL_TAC +QED + +Theorem strip_sxcons_listsexp[simp]: + strip_sxcons (listsexp ls) = SOME ls +Proof + Induct_on`ls`>>rw[listsexp_def] >> simp[GSYM listsexp_def] +QED + +Theorem dstrip_sexp_listsexp[simp]: + (dstrip_sexp (listsexp ls) = + case ls of (SX_SYM x::xs) => SOME (x,xs) | _ => NONE) +Proof + BasicProvers.CASE_TAC >> rw[dstrip_sexp_def,listsexp_def] >> + BasicProvers.CASE_TAC >> rw[GSYM listsexp_def] +QED + +Theorem sexplist_listsexp_matchable: + ∀g gl. (∀x. MEM x l ⇒ f (g x) = SOME x) ∧ (gl = MAP g l) ⇒ + sexplist f (listsexp gl) = SOME l +Proof + Induct_on`l` >> simp[listsexp_def,Once sexplist_def] >> + simp[GSYM listsexp_def] >> metis_tac[] +QED + +Theorem sexplist_listsexp_rwt[simp]: + (∀x. MEM x l ⇒ f (g x) = SOME x) ⇒ + (sexplist f (listsexp (MAP g l)) = SOME l) +Proof + metis_tac[sexplist_listsexp_matchable] +QED + +Theorem sexplist_listsexp_imp: + sexplist f (listsexp l1) = SOME l2 ⇒ + ∀n. n < LENGTH l1 ⇒ f (EL n l1) = SOME (EL n l2) +Proof + qid_spec_tac`l2`>> Induct_on`l1`>>simp[listsexp_def]>>simp[GSYM listsexp_def] >> simp[Once sexplist_def,PULL_EXISTS] >> rw[] >> - Cases_on`n`>>simp[]); - -Theorem sexpopt_optsexp[simp] - `(∀y. (x = SOME y) ⇒ (f (g y) = x)) ⇒ - (sexpopt f (optsexp (OPTION_MAP g x)) = SOME x)` - (Cases_on`x`>>EVAL_TAC >> simp[]); - -Theorem sexpid_odestSEXSTR_idsexp[simp] - `sexpid odestSEXSTR (idsexp i) = SOME i` - (Induct_on `i` >> simp[idsexp_def] >> - rw [Once sexpid_def]); - -Theorem sexptype_typesexp[simp] - `sexptype (typesexp t) = SOME t` - (qid_spec_tac`t` >> + Cases_on`n`>>simp[] +QED + +Theorem sexpopt_optsexp[simp]: + (∀y. (x = SOME y) ⇒ (f (g y) = x)) ⇒ + (sexpopt f (optsexp (OPTION_MAP g x)) = SOME x) +Proof + Cases_on`x`>>EVAL_TAC >> simp[] +QED + +Theorem sexpid_odestSEXSTR_idsexp[simp]: + sexpid odestSEXSTR (idsexp i) = SOME i +Proof + Induct_on `i` >> simp[idsexp_def] >> + rw [Once sexpid_def] +QED + +Theorem sexptype_typesexp[simp]: + sexptype (typesexp t) = SOME t +Proof + qid_spec_tac`t` >> ho_match_mp_tac type_ind >> conj_tac >- rw[Once sexptype_def,typesexp_def] >> conj_tac >- (rw[] \\ rw[Once sexptype_def,typesexp_def]) >> @@ -1421,7 +1554,8 @@ Theorem sexptype_typesexp[simp] match_mp_tac sexplist_listsexp_matchable >> fs[typesexp_def] >> rw[] >> rw[] >> fs[listTheory.EVERY_MEM] >> - metis_tac[])); + metis_tac[]) +QED val exists_g_tac = (fn (g as (asl,w)) => @@ -1430,9 +1564,10 @@ val exists_g_tac = val tm = find_term (fn y => type_of x = type_of y andalso not (is_var y)) b in EXISTS_TAC tm end g) -Theorem sexptype_def_type_defsexp[simp] - `sexptype_def (type_defsexp l) = SOME l` - (Induct_on`l` >> rw[type_defsexp_def] >> rw[sexptype_def_def] >> +Theorem sexptype_def_type_defsexp[simp]: + sexptype_def (type_defsexp l) = SOME l +Proof + Induct_on`l` >> rw[type_defsexp_def] >> rw[sexptype_def_def] >> match_mp_tac sexplist_listsexp_matchable >> simp[] >> exists_g_tac >> simp[] >> @@ -1450,21 +1585,25 @@ Theorem sexptype_def_type_defsexp[simp] fs[listTheory.MEM_EL] >> first_x_assum(fn th => first_assum(mp_tac o MATCH_MP th)) >> pop_assum(assume_tac o SYM) >> - simp[rich_listTheory.EL_MAP]); + simp[rich_listTheory.EL_MAP] +QED -Theorem sexplit_litsexp[simp] - `sexplit (litsexp l) = SOME l` - (Cases_on`l`>>simp[sexplit_def,litsexp_def] +Theorem sexplit_litsexp[simp]: + sexplit (litsexp l) = SOME l +Proof + Cases_on`l`>>simp[sexplit_def,litsexp_def] >- ( rw[] >> intLib.ARITH_TAC ) >> ONCE_REWRITE_TAC[GSYM wordsTheory.dimword_8] >> ONCE_REWRITE_TAC[GSYM wordsTheory.dimword_64] >> ONCE_REWRITE_TAC[wordsTheory.w2n_lt] >> - rw[]); + rw[] +QED -Theorem sexppat_patsexp[simp] - `sexppat (patsexp p) = SOME p` - (qid_spec_tac`p` >> +Theorem sexppat_patsexp[simp]: + sexppat (patsexp p) = SOME p +Proof + qid_spec_tac`p` >> ho_match_mp_tac pat_ind >> conj_tac >- simp[patsexp_def,Once sexppat_def] >> conj_tac >- simp[patsexp_def,Once sexppat_def] >> @@ -1477,20 +1616,26 @@ Theorem sexppat_patsexp[simp] srw_tac[boolSimps.ETA_ss][] >> qexists_tac`patsexp`>>simp[] >> fs[listTheory.EVERY_MEM] >> metis_tac[]) >> - rw[] >> simp[patsexp_def,Once sexppat_def]); - -Theorem sexplop_lopsexp[simp] - `sexplop (lopsexp l) = SOME l` - (Cases_on`l`>>EVAL_TAC) - -Theorem sexplocn_locnsexp[simp] - `sexplocn (locnsexp l) = SOME l` - (Cases_on `l` >> rename [`Locs l1 l2`] >> - Cases_on`l1` \\ Cases_on`l2` \\ rw[locnsexp_def,sexplocn_def]); - -Theorem sexpexp_expsexp[simp] - `sexpexp (expsexp e) = SOME e` - (qid_spec_tac`e` >> + rw[] >> simp[patsexp_def,Once sexppat_def] +QED + +Theorem sexplop_lopsexp[simp]: + sexplop (lopsexp l) = SOME l +Proof + Cases_on`l`>>EVAL_TAC +QED + +Theorem sexplocn_locnsexp[simp]: + sexplocn (locnsexp l) = SOME l +Proof + Cases_on `l` >> rename [`Locs l1 l2`] >> + Cases_on`l1` \\ Cases_on`l2` \\ rw[locnsexp_def,sexplocn_def] +QED + +Theorem sexpexp_expsexp[simp]: + sexpexp (expsexp e) = SOME e +Proof + qid_spec_tac`e` >> ho_match_mp_tac exp_ind >> rw[] >> rw[expsexp_def] >> rw[Once sexpexp_def] >> match_mp_tac sexplist_listsexp_matchable >> @@ -1498,37 +1643,45 @@ Theorem sexpexp_expsexp[simp] fs[listTheory.EVERY_MEM] >> qx_gen_tac`p`>>PairCases_on`p` >> simp[] >> simp[sexppair_def] >> - rw[] >> res_tac >> fs[]); + rw[] >> res_tac >> fs[] +QED -Theorem sexpdec_decsexp[simp] - `∀d. sexpdec (decsexp d) = SOME d` - (ho_match_mp_tac dec_ind +Theorem sexpdec_decsexp[simp]: + ∀d. sexpdec (decsexp d) = SOME d +Proof + ho_match_mp_tac dec_ind \\ rw[decsexp_def] \\ rw[Once sexpdec_def] \\ match_mp_tac sexplist_listsexp_matchable \\ exists_g_tac >> simp[] \\ fs[EVERY_MEM] \\ qx_gen_tac`p`>>PairCases_on`p`>>rw[] - \\ simp[sexppair_def]) + \\ simp[sexppair_def] +QED -Theorem sexpopt_SOME - `sexpopt f s = SOME opt ⇒ +Theorem sexpopt_SOME: + sexpopt f s = SOME opt ⇒ ∃x. s = optsexp x ∧ - (case x of NONE => opt = NONE | SOME s => IS_SOME opt ∧ opt = f s)` - (rw[sexpopt_def] + (case x of NONE => opt = NONE | SOME s => IS_SOME opt ∧ opt = f s) +Proof + rw[sexpopt_def] \\ Cases_on`odestSXSYM s` \\ fs[dstrip_sexp_SOME] \\ rw[] \\ fs[odestSXSYM_def] \\ simp[EXISTS_OPTION, optsexp_def, listsexp_def] \\ fs[quantHeuristicsTheory.LIST_LENGTH_3] \\ rw[] \\ fs[] \\ rw[] \\ rename[`odestSXSYM s = SOME _`] >> Cases_on `s` >> - fs[odestSXSYM_def, dstrip_sexp_def]); - -Theorem listsexp_MAP_EQ_f - `(∀x. MEM x ls ⇒ f1 x = f2 x) ⇒ - listsexp (MAP f1 ls) = listsexp (MAP f2 ls)` - (Induct_on`ls` >> simp[] >> fs[listsexp_def]) - -Theorem sexplist_SOME - `sexplist f s = SOME ls ⇒ ∃l. s = listsexp l ∧ MAP f l = MAP SOME ls` - (map_every qid_spec_tac[`s`,`ls`] >> + fs[odestSXSYM_def, dstrip_sexp_def] +QED + +Theorem listsexp_MAP_EQ_f: + (∀x. MEM x ls ⇒ f1 x = f2 x) ⇒ + listsexp (MAP f1 ls) = listsexp (MAP f2 ls) +Proof + Induct_on`ls` >> simp[] >> fs[listsexp_def] +QED + +Theorem sexplist_SOME: + sexplist f s = SOME ls ⇒ ∃l. s = listsexp l ∧ MAP f l = MAP SOME ls +Proof + map_every qid_spec_tac[`s`,`ls`] >> Induct >> rw[] >- ( fs[Once sexplist_def] >> every_case_tac >> fs[listsexp_def] ) >> @@ -1540,27 +1693,35 @@ Theorem sexplist_SOME rw[listsexp_def,SimpRHS] >> simp[GSYM listsexp_def] >> qmatch_assum_rename_tac`f a = return h` >> - qexists_tac`a::l` >> simp[listsexp_def] ) - -Theorem sexppair_SOME - `sexppair f1 f2 s = SOME p ⇒ ∃x y. f1 x = SOME (FST p) ∧ f2 y = SOME (SND p) ∧ s = SX_CONS x y` - (rw[sexppair_def] - \\ every_case_tac \\ fs[]); - -Theorem OPTION_CHOICE_EQ_SOME - `OPTION_CHOICE m1 m2 = SOME x ⇔ - m1 = SOME x ∨ m1 = NONE ∧ m2 = SOME x` - (Cases_on `m1` >> simp[]); - -Theorem dstrip_sexp_EQ_SOME - `dstrip_sexp s = SOME (nm, args) ⇔ - ∃t. s = SX_CONS (SX_SYM nm) t ∧ strip_sxcons t = SOME args` - (Cases_on`s` >> simp[dstrip_sexp_def] >> every_case_tac >> - simp[] >> metis_tac[]); - -Theorem litsexp_sexplit - `∀s l. sexplit s = SOME l ⇒ litsexp l = s` - (rw[sexplit_def] + qexists_tac`a::l` >> simp[listsexp_def] +QED + +Theorem sexppair_SOME: + sexppair f1 f2 s = SOME p ⇒ ∃x y. f1 x = SOME (FST p) ∧ f2 y = SOME (SND p) ∧ s = SX_CONS x y +Proof + rw[sexppair_def] + \\ every_case_tac \\ fs[] +QED + +Theorem OPTION_CHOICE_EQ_SOME: + OPTION_CHOICE m1 m2 = SOME x ⇔ + m1 = SOME x ∨ m1 = NONE ∧ m2 = SOME x +Proof + Cases_on `m1` >> simp[] +QED + +Theorem dstrip_sexp_EQ_SOME: + dstrip_sexp s = SOME (nm, args) ⇔ + ∃t. s = SX_CONS (SX_SYM nm) t ∧ strip_sxcons t = SOME args +Proof + Cases_on`s` >> simp[dstrip_sexp_def] >> every_case_tac >> + simp[] >> metis_tac[] +QED + +Theorem litsexp_sexplit: + ∀s l. sexplit s = SOME l ⇒ litsexp l = s +Proof + rw[sexplit_def] \\ reverse(Cases_on`odestSXNUM s`) \\ fs[] >- ( rw[litsexp_def] @@ -1571,11 +1732,13 @@ Theorem litsexp_sexplit \\ fs[quantHeuristicsTheory.LIST_LENGTH_3] \\ rw[] \\ fs[OPTION_CHOICE_EQ_SOME, dstrip_sexp_EQ_SOME] >> rw[litsexp_def, listsexp_def] - \\ Cases_on`e1` \\ fs[odestSXNUM_def]); + \\ Cases_on`e1` \\ fs[odestSXNUM_def] +QED -Theorem idsexp_sexpid_odestSEXSTR - `∀y x. sexpid odestSEXSTR x = SOME y ⇒ x = idsexp y` - (Induct +Theorem idsexp_sexpid_odestSEXSTR: + ∀y x. sexpid odestSEXSTR x = SOME y ⇒ x = idsexp y +Proof + Induct \\ rw[Once sexpid_def] \\ fs[dstrip_sexp_SOME] \\ rw[] \\ fs[] @@ -1584,19 +1747,25 @@ Theorem idsexp_sexpid_odestSEXSTR \\ fs[quantHeuristicsTheory.LIST_LENGTH_3] \\ rw[] \\ fs[] \\ fs[Once strip_sxcons_def] - \\ every_case_tac \\ fs[]); - -Theorem strip_sxcons_NIL[simp] - `strip_sxcons ⟪ ⟫ = SOME []` - (simp[Once strip_sxcons_def]); - -Theorem strip_sxcons_SXCONS[simp] - `strip_sxcons (SX_CONS s1 s2) = lift (CONS s1) (strip_sxcons s2)` - (simp[Once strip_sxcons_def]); - -Theorem typesexp_sexptype - `∀s t. sexptype s = SOME t ⇒ typesexp t = s` - (ho_match_mp_tac(theorem"sexptype_ind") + \\ every_case_tac \\ fs[] +QED + +Theorem strip_sxcons_NIL[simp]: + strip_sxcons ⟪ ⟫ = SOME [] +Proof + simp[Once strip_sxcons_def] +QED + +Theorem strip_sxcons_SXCONS[simp]: + strip_sxcons (SX_CONS s1 s2) = lift (CONS s1) (strip_sxcons s2) +Proof + simp[Once strip_sxcons_def] +QED + +Theorem typesexp_sexptype: + ∀s t. sexptype s = SOME t ⇒ typesexp t = s +Proof + ho_match_mp_tac(theorem"sexptype_ind") \\ rw[] \\ pop_assum mp_tac \\ rw[Once sexptype_def] @@ -1617,11 +1786,13 @@ Theorem typesexp_sexptype \\ rpt strip_tac \\ res_tac \\ first_x_assum(MATCH_MP_TAC o MP_CANON) \\ simp[sxMEM_def] - \\ metis_tac[MEM_EL]); + \\ metis_tac[MEM_EL] +QED -Theorem patsexp_sexppat - `∀s p. sexppat s = SOME p ⇒ patsexp p = s` - (ho_match_mp_tac (theorem"sexppat_ind") +Theorem patsexp_sexppat: + ∀s p. sexppat s = SOME p ⇒ patsexp p = s +Proof + ho_match_mp_tac (theorem"sexppat_ind") \\ rw[] \\ pop_assum mp_tac \\ rw[Once sexppat_def] @@ -1648,24 +1819,30 @@ Theorem patsexp_sexppat \\ first_x_assum(match_mp_tac o MP_CANON) \\ simp[] \\ simp[sxMEM_def] - \\ metis_tac[MEM_EL]); + \\ metis_tac[MEM_EL] +QED -Theorem opsexp_sexpop - `sexpop s = SOME p ⇒ opsexp p = s` - (Cases_on`s` \\ rw[sexpop_def] \\ rw[opsexp_def] +Theorem opsexp_sexpop: + sexpop s = SOME p ⇒ opsexp p = s +Proof + Cases_on`s` \\ rw[sexpop_def] \\ rw[opsexp_def] \\ match1_tac(mg.aub`s_:sexp`,(fn(a,t)=>if is_var(t"s") then Cases_on`^(t"s")`\\fs[sexpop_def] else NO_TAC)) \\ match1_tac(mg.aub`s_:sexp`,(fn(a,t)=>if is_var(t"s") then Cases_on`^(t"s")`\\fs[sexpop_def] else NO_TAC)) \\ pop_assum mp_tac \\ rpt IF_CASES_TAC \\ rw[] - \\ rw[opsexp_def, GSYM encode_decode_control]); - -Theorem lopsexp_sexplop - `sexplop s = SOME z ⇒ lopsexp z = s` - (Cases_on`s` \\ rw[sexplop_def] \\ rw[lopsexp_def]); - -Theorem locnsexp_sexplocn - `sexplocn s = SOME z ⇒ locnsexp z = s` - (Cases_on`z` \\ rename [`Locs l1 l2`] >> + \\ rw[opsexp_def, GSYM encode_decode_control] +QED + +Theorem lopsexp_sexplop: + sexplop s = SOME z ⇒ lopsexp z = s +Proof + Cases_on`s` \\ rw[sexplop_def] \\ rw[lopsexp_def] +QED + +Theorem locnsexp_sexplocn: + sexplocn s = SOME z ⇒ locnsexp z = s +Proof + Cases_on`z` \\ rename [`Locs l1 l2`] >> Cases_on`l1` \\ Cases_on `l2` \\ rw[sexplocn_def,locnsexp_def] \\ fs[LENGTH_EQ_NUM_compute] \\ rw[] @@ -1673,11 +1850,13 @@ Theorem locnsexp_sexplocn \\ simp[listsexp_def] \\ rename [`⟪h1; h2; h3; h4; h5; h6⟫`] \\ map_every (fn q => Cases_on q >> fs[odestSXNUM_def]) - [`h1`, `h2`, `h3`, `h4`, `h5`, `h6`]); + [`h1`, `h2`, `h3`, `h4`, `h5`, `h6`] +QED -Theorem expsexp_sexpexp - `∀s e. sexpexp s = SOME e ⇒ expsexp e = s` - (ho_match_mp_tac (theorem"sexpexp_ind") >> +Theorem expsexp_sexpexp: + ∀s e. sexpexp s = SOME e ⇒ expsexp e = s +Proof + ho_match_mp_tac (theorem"sexpexp_ind") >> simp[OPTION_GUARD_EQ_THM, quantHeuristicsTheory.LIST_LENGTH_3, PULL_EXISTS, dstrip_sexp_SOME] \\ rpt gen_tac \\ strip_tac \\ gen_tac @@ -1743,11 +1922,13 @@ Theorem expsexp_sexpexp \\ res_tac \\ imp_res_tac sexppair_SOME \\ fs[] \\ rfs[] \\ rw[] \\ imp_res_tac sexppair_SOME \\ fs[] \\ rfs[] \\ rw[] - \\ fs[sxMEM_def] \\ metis_tac[MEM_EL])); + \\ fs[sxMEM_def] \\ metis_tac[MEM_EL]) +QED -Theorem type_defsexp_sexptype_def - `sexptype_def s = SOME x ⇒ type_defsexp x = s` - (rw[sexptype_def_def,type_defsexp_def] +Theorem type_defsexp_sexptype_def: + sexptype_def s = SOME x ⇒ type_defsexp x = s +Proof + rw[sexptype_def_def,type_defsexp_def] \\ imp_res_tac sexplist_SOME \\ rw[] \\ fs[LIST_EQ_REWRITE,EL_MAP] \\ rw[] \\ rfs[EL_MAP] @@ -1766,11 +1947,13 @@ Theorem type_defsexp_sexptype_def \\ imp_res_tac sexplist_SOME \\ rw[] \\ fs[LIST_EQ_REWRITE,EL_MAP] \\ rw[] \\ rfs[EL_MAP] - \\ metis_tac[typesexp_sexptype]); + \\ metis_tac[typesexp_sexptype] +QED -Theorem decsexp_sexpdec - `∀s d. sexpdec s = SOME d ⇒ decsexp d = s` - (ho_match_mp_tac(theorem"sexpdec_ind") +Theorem decsexp_sexpdec: + ∀s d. sexpdec s = SOME d ⇒ decsexp d = s +Proof + ho_match_mp_tac(theorem"sexpdec_ind") \\ ntac 3 strip_tac \\ rw[Once sexpdec_def] \\ pairarg_tac \\ fs[] @@ -1801,63 +1984,79 @@ Theorem decsexp_sexpdec \\ fs[] \\ rveq \\ fs[] \\ imp_res_tac expsexp_sexpexp) \\ fs [sxMEM_def,listsexp_def] - \\ metis_tac[MEM_EL]); + \\ metis_tac[MEM_EL] +QED (* valid sexps *) -Theorem SEXSTR_valid[simp] - `valid_sexp (SEXSTR s)` - (rw[SEXSTR_def,EVERY_isPrint_encode_control]); - -Theorem listsexp_valid - `∀ls. EVERY valid_sexp ls ⇒ valid_sexp (listsexp ls)` - (Induct \\ simp[listsexp_def] \\ simp[GSYM listsexp_def] - \\ EVAL_TAC); - -Theorem idsexp_valid[simp] - `∀i. valid_sexp (idsexp i)` - (Induct \\ simp[idsexp_def] >> +Theorem SEXSTR_valid[simp]: + valid_sexp (SEXSTR s) +Proof + rw[SEXSTR_def,EVERY_isPrint_encode_control] +QED + +Theorem listsexp_valid: + ∀ls. EVERY valid_sexp ls ⇒ valid_sexp (listsexp ls) +Proof + Induct \\ simp[listsexp_def] \\ simp[GSYM listsexp_def] + \\ EVAL_TAC +QED + +Theorem idsexp_valid[simp]: + ∀i. valid_sexp (idsexp i) +Proof + Induct \\ simp[idsexp_def] >> rw [] \\ match_mp_tac listsexp_valid \\ simp[] - \\ EVAL_TAC); + \\ EVAL_TAC +QED -Theorem typesexp_valid[simp] - `∀t. valid_sexp (typesexp t)` - (ho_match_mp_tac(theorem"typesexp_ind") +Theorem typesexp_valid[simp]: + ∀t. valid_sexp (typesexp t) +Proof + ho_match_mp_tac(theorem"typesexp_ind") \\ rw[typesexp_def] \\ match_mp_tac listsexp_valid \\ simp[] \\ rpt conj_tac \\ TRY (match_mp_tac listsexp_valid) \\ simp[EVERY_MAP,EVERY_MEM] - \\ EVAL_TAC); + \\ EVAL_TAC +QED -Theorem litsexp_valid[simp] - `∀l. valid_sexp (litsexp l)` - (Cases \\ rw[litsexp_def] +Theorem litsexp_valid[simp]: + ∀l. valid_sexp (litsexp l) +Proof + Cases \\ rw[litsexp_def] \\ match_mp_tac listsexp_valid - \\ rw[] \\ EVAL_TAC); + \\ rw[] \\ EVAL_TAC +QED -Theorem optsexp_valid - `∀x. (∀y. x = SOME y ⇒ valid_sexp y) ⇒ valid_sexp (optsexp x)` - (Cases \\ rw[optsexp_def] +Theorem optsexp_valid: + ∀x. (∀y. x = SOME y ⇒ valid_sexp y) ⇒ valid_sexp (optsexp x) +Proof + Cases \\ rw[optsexp_def] \\ TRY(match_mp_tac listsexp_valid) \\ rw[] - \\ EVAL_TAC); + \\ EVAL_TAC +QED -Theorem patsexp_valid[simp] - `∀p. valid_sexp (patsexp p)` - (ho_match_mp_tac(theorem"patsexp_ind") +Theorem patsexp_valid[simp]: + ∀p. valid_sexp (patsexp p) +Proof + ho_match_mp_tac(theorem"patsexp_ind") \\ rw[patsexp_def] \\ match_mp_tac listsexp_valid \\ rw[] \\ TRY (match_mp_tac optsexp_valid \\ rw[] \\ rw[]) \\ TRY (match_mp_tac listsexp_valid \\ simp[EVERY_MAP,EVERY_MEM]) - \\ EVAL_TAC); + \\ EVAL_TAC +QED -Theorem type_defsexp_valid[simp] - `∀t. valid_sexp (type_defsexp t)` - (rw[type_defsexp_def] +Theorem type_defsexp_valid[simp]: + ∀t. valid_sexp (type_defsexp t) +Proof + rw[type_defsexp_def] \\ match_mp_tac listsexp_valid \\ rw[EVERY_MEM,EVERY_MAP] \\ pairarg_tac \\ rw[] @@ -1865,30 +2064,38 @@ Theorem type_defsexp_valid[simp] \\ rw[EVERY_MEM,EVERY_MAP] \\ pairarg_tac \\ rw[] \\ match_mp_tac listsexp_valid - \\ rw[EVERY_MEM,EVERY_MAP]); + \\ rw[EVERY_MEM,EVERY_MAP] +QED -Theorem opsexp_valid[simp] - `∀op. valid_sexp (opsexp op)` - (Cases \\ simp[opsexp_def] +Theorem opsexp_valid[simp]: + ∀op. valid_sexp (opsexp op) +Proof + Cases \\ simp[opsexp_def] \\ TRY (EVAL_TAC \\ NO_TAC) \\ TRY(Cases_on`o'`) \\ simp[opsexp_def] \\ TRY(Cases_on`w`) \\ simp[opsexp_def] \\ TRY(Cases_on`s`) \\ simp[opsexp_def] \\ TRY(Cases_on`f`) \\ simp[opsexp_def] - \\ EVAL_TAC); - -Theorem lopsexp_valid[simp] - `∀l. valid_sexp (lopsexp l)` - (Cases \\ simp[lopsexp_def] - \\ EVAL_TAC); - -Theorem locnsexp_valid[simp] - `∀l. valid_sexp (locnsexp l)` - (Cases \\ rename [`Locs l1 l2`] >> Cases_on `l1` \\ Cases_on `l2` \\ EVAL_TAC); - -Theorem expsexp_valid[simp] - `∀e. valid_sexp (expsexp e)` - (ho_match_mp_tac(theorem"expsexp_ind") + \\ EVAL_TAC +QED + +Theorem lopsexp_valid[simp]: + ∀l. valid_sexp (lopsexp l) +Proof + Cases \\ simp[lopsexp_def] + \\ EVAL_TAC +QED + +Theorem locnsexp_valid[simp]: + ∀l. valid_sexp (locnsexp l) +Proof + Cases \\ rename [`Locs l1 l2`] >> Cases_on `l1` \\ Cases_on `l2` \\ EVAL_TAC +QED + +Theorem expsexp_valid[simp]: + ∀e. valid_sexp (expsexp e) +Proof + ho_match_mp_tac(theorem"expsexp_ind") \\ rw[expsexp_def] \\ TRY(match_mp_tac listsexp_valid) \\ rw[] @@ -1896,16 +2103,19 @@ Theorem expsexp_valid[simp] \\ TRY(match_mp_tac optsexp_valid \\ rw[] \\ rw[]) \\ TRY(match_mp_tac listsexp_valid \\ simp[EVERY_MAP,EVERY_MEM]) \\ simp[FORALL_PROD] - \\ first_x_assum MATCH_ACCEPT_TAC); + \\ first_x_assum MATCH_ACCEPT_TAC +QED -Theorem decsexp_valid[simp] - `∀d. valid_sexp (decsexp d)` - (ho_match_mp_tac dec_ind \\ rw[decsexp_def] +Theorem decsexp_valid[simp]: + ∀d. valid_sexp (decsexp d) +Proof + ho_match_mp_tac dec_ind \\ rw[decsexp_def] \\ match_mp_tac listsexp_valid \\ rw[] \\ TRY (EVAL_TAC \\ NO_TAC) \\ match_mp_tac listsexp_valid \\ simp[EVERY_MAP,EVERY_MEM] - \\ simp[FORALL_PROD]); + \\ simp[FORALL_PROD] +QED val _ = export_theory(); diff --git a/compiler/parsing/lexer_implScript.sml b/compiler/parsing/lexer_implScript.sml index 8ba592f889..f745b3e00b 100644 --- a/compiler/parsing/lexer_implScript.sml +++ b/compiler/parsing/lexer_implScript.sml @@ -17,8 +17,8 @@ val tac = rw [get_token_def, processIdent_def, isAlphaNum_def, isAlpha_def, isDigit_def, isLower_def, isUpper_def]; -Theorem get_token_eqn -`!s. +Theorem get_token_eqn: + !s. get_token s = case s of [] => LexErrorT @@ -136,8 +136,9 @@ Theorem get_token_eqn if s = "withtype" then WithtypeT else AlphaT s else - SymbolT s` - (strip_tac >> + SymbolT s +Proof + strip_tac >> Cases_on `s` >> simp_tac (srw_ss()) [] >- srw_tac [] [processIdent_def, get_token_def] >> @@ -155,7 +156,8 @@ Theorem get_token_eqn isLower_def, isUpper_def] >> full_simp_tac (srw_ss()++ARITH_ss) [char_le_def, char_lt_def] >> Cases_on `t` >> - rw []); + rw [] +QED val _ = computeLib.add_persistent_funs(["get_token_eqn"]); @@ -312,9 +314,10 @@ val read_while_P = Q.prove(` rw[]>>ho_match_mp_tac read_while_P_lem>> MAP_EVERY qexists_tac [`ls`,`""`,`y`]>>fs[]) -Theorem next_sym_eq - `∀x l. next_sym x l = next_sym_alt x l` - (ho_match_mp_tac next_sym_ind>>fs[next_sym_def,next_sym_alt_def]>>rw[]>> +Theorem next_sym_eq: + ∀x l. next_sym x l = next_sym_alt x l +Proof + ho_match_mp_tac next_sym_ind>>fs[next_sym_def,next_sym_alt_def]>>rw[]>> TRY(BasicProvers.TOP_CASE_TAC>>fs[]>>NO_TAC)>> TRY(rpt(pop_assum mp_tac)>> EVAL_TAC>> simp[]>>NO_TAC)>> TRY(pairarg_tac) >>fs[]>> @@ -324,7 +327,8 @@ Theorem next_sym_eq TRY(fs[]>> ho_match_mp_tac read_while_P>> metis_tac[]) >> - every_case_tac >> metis_tac[]); + every_case_tac >> metis_tac[] +QED (* lex_until_toplevel_semicolon *) @@ -372,12 +376,14 @@ val lex_aux_LESS = Q.prove( THEN IMP_RES_TAC (DECIDE ``n < m ==> n <= m:num``) THEN DECIDE_TAC); -Theorem lex_until_toplevel_semicolon_LESS - `(lex_until_toplevel_semicolon input l = SOME (ts, l', rest)) ==> - LENGTH rest < LENGTH input` - (SIMP_TAC std_ss [lex_until_toplevel_semicolon_def] +Theorem lex_until_toplevel_semicolon_LESS: + (lex_until_toplevel_semicolon input l = SOME (ts, l', rest)) ==> + LENGTH rest < LENGTH input +Proof + SIMP_TAC std_ss [lex_until_toplevel_semicolon_def] THEN REPEAT STRIP_TAC THEN IMP_RES_TAC lex_aux_LESS - THEN FULL_SIMP_TAC std_ss []); + THEN FULL_SIMP_TAC std_ss [] +QED (* lex_until_toplevel_semicolon_alt *) @@ -424,12 +430,14 @@ val lex_aux_alt_LESS = Q.prove( THEN IMP_RES_TAC (DECIDE ``n < m ==> n <= m:num``) THEN DECIDE_TAC); -Theorem lex_until_top_semicolon_alt_LESS - `(lex_until_top_semicolon_alt input l = SOME (ts, l', rest)) ==> - LENGTH rest < LENGTH input` - (SIMP_TAC std_ss [lex_until_top_semicolon_alt_def] +Theorem lex_until_top_semicolon_alt_LESS: + (lex_until_top_semicolon_alt input l = SOME (ts, l', rest)) ==> + LENGTH rest < LENGTH input +Proof + SIMP_TAC std_ss [lex_until_top_semicolon_alt_def] THEN REPEAT STRIP_TAC THEN IMP_RES_TAC lex_aux_alt_LESS - THEN FULL_SIMP_TAC std_ss []); + THEN FULL_SIMP_TAC std_ss [] +QED val token_of_sym_EQ_LEMMA = Q.prove( `((token_of_sym q = LetT) = (q = OtherS "let")) /\ @@ -466,13 +474,15 @@ val lex_aux_alt_thm = Q.prove( THEN FULL_SIMP_TAC (srw_ss()) [token_of_sym_loc_def,token_of_sym_def,get_token_def]) |> Q.SPECL [`[]`,`0`] |> SIMP_RULE std_ss [MAP] ; -Theorem lex_until_top_semicolon_alt_thm - `case lex_until_top_semicolon_alt input l of +Theorem lex_until_top_semicolon_alt_thm: + case lex_until_top_semicolon_alt input l of | NONE => (lex_until_toplevel_semicolon input l = NONE) | SOME (ts,rest) => - (lex_until_toplevel_semicolon input l = SOME (MAP token_of_sym_loc ts,rest))` - (SIMP_TAC std_ss [lex_until_top_semicolon_alt_def, - lex_until_toplevel_semicolon_def,lex_aux_alt_thm]); + (lex_until_toplevel_semicolon input l = SOME (MAP token_of_sym_loc ts,rest)) +Proof + SIMP_TAC std_ss [lex_until_top_semicolon_alt_def, + lex_until_toplevel_semicolon_def,lex_aux_alt_thm] +QED (* lex_impl_all *) @@ -605,8 +615,10 @@ val split_top_level_semi_thm = Q.prove( >> STRIP_TAC >> RES_TAC >> POP_ASSUM MP_TAC >> FULL_SIMP_TAC std_ss [TAKE_LENGTH_APPEND,DROP_LENGTH_APPEND]); -Theorem lexer_correct - `!input. split_top_level_semi (lexer_fun_aux input l) = lex_impl_all input l` - (SIMP_TAC std_ss [lex_impl_all_tokens_thm,split_top_level_semi_thm]); +Theorem lexer_correct: + !input. split_top_level_semi (lexer_fun_aux input l) = lex_impl_all input l +Proof + SIMP_TAC std_ss [lex_impl_all_tokens_thm,split_top_level_semi_thm] +QED val _ = export_theory(); diff --git a/compiler/parsing/proofs/pegCompleteScript.sml b/compiler/parsing/proofs/pegCompleteScript.sml index 702c06a6a9..7e70d42388 100644 --- a/compiler/parsing/proofs/pegCompleteScript.sml +++ b/compiler/parsing/proofs/pegCompleteScript.sml @@ -115,367 +115,473 @@ val ptree_head_eq_tok = save_thm( val _ = export_rewrites ["ptree_head_eq_tok"] open NTpropertiesTheory -Theorem firstSet_nUQTyOp[simp] - `firstSet cmlG (NN nUQTyOp::rest) = - {AlphaT s | T} ∪ {SymbolT s | T}` - (simp[Once firstSet_NT, cmlG_applied, cmlG_FDOM] >> - dsimp[Once EXTENSION, EQ_IMP_THM]); - -Theorem firstSet_nTyOp[simp] - `firstSet cmlG (NN nTyOp :: rest) = - {AlphaT s | T} ∪ {SymbolT s | T} ∪ {LongidT s1 s2 | T}` - (simp[Once firstSet_NT, cmlG_applied, cmlG_FDOM] >> - dsimp[Once EXTENSION, EQ_IMP_THM]); - -Theorem firstSet_nPTbase[simp] - `firstSet cmlG (NN nPTbase :: rest) = - firstSet cmlG [NN nTyOp] ∪ {LparT} ∪ {TyvarT s | T}` - (simp[Once firstSet_NT, cmlG_applied, cmlG_FDOM, SimpLHS] >> - simp[nullable_PTbase] >> dsimp[Once EXTENSION] >> metis_tac[]); - -Theorem firstSet_nTbaseList[simp] - `firstSet cmlG (NN nTbaseList :: rest) = - firstSet cmlG [NN nPTbase] ∪ firstSet cmlG rest` - (simp[Once firstSet_NT, SimpLHS, cmlG_FDOM, cmlG_applied, - nullable_TbaseList] >> simp[]); - -Theorem firstSet_nTyVarList[simp] - `firstSet cmlG [NT (mkNT nTyVarList)] = { TyvarT s | T }` - (simp[firstSetML_eqn] >> simp[firstSetML_def] >> +Theorem firstSet_nUQTyOp[simp]: + firstSet cmlG (NN nUQTyOp::rest) = + {AlphaT s | T} ∪ {SymbolT s | T} +Proof + simp[Once firstSet_NT, cmlG_applied, cmlG_FDOM] >> + dsimp[Once EXTENSION, EQ_IMP_THM] +QED + +Theorem firstSet_nTyOp[simp]: + firstSet cmlG (NN nTyOp :: rest) = + {AlphaT s | T} ∪ {SymbolT s | T} ∪ {LongidT s1 s2 | T} +Proof + simp[Once firstSet_NT, cmlG_applied, cmlG_FDOM] >> + dsimp[Once EXTENSION, EQ_IMP_THM] +QED + +Theorem firstSet_nPTbase[simp]: + firstSet cmlG (NN nPTbase :: rest) = + firstSet cmlG [NN nTyOp] ∪ {LparT} ∪ {TyvarT s | T} +Proof + simp[Once firstSet_NT, cmlG_applied, cmlG_FDOM, SimpLHS] >> + simp[nullable_PTbase] >> dsimp[Once EXTENSION] >> metis_tac[] +QED + +Theorem firstSet_nTbaseList[simp]: + firstSet cmlG (NN nTbaseList :: rest) = + firstSet cmlG [NN nPTbase] ∪ firstSet cmlG rest +Proof + simp[Once firstSet_NT, SimpLHS, cmlG_FDOM, cmlG_applied, + nullable_TbaseList] >> simp[] +QED + +Theorem firstSet_nTyVarList[simp]: + firstSet cmlG [NT (mkNT nTyVarList)] = { TyvarT s | T } +Proof + simp[firstSetML_eqn] >> simp[firstSetML_def] >> simp[cmlG_applied, cmlG_FDOM] >> simp[firstSetML_def] >> simp[cmlG_applied, cmlG_FDOM] >> dsimp[Once EXTENSION, EQ_IMP_THM] >> - simp[firstSetML_def]); + simp[firstSetML_def] +QED val _ = firstSetML_def |> CONJUNCTS |> (fn l => List.take(l,2)) |> rewrites |> (fn ss => augment_srw_ss [ss]) -Theorem firstSet_nLetDec[simp] - `firstSet cmlG [NT (mkNT nLetDec)] = {ValT; FunT}` - (simp[firstSetML_eqn, Once firstSetML_def, cmlG_FDOM, - cmlG_applied, INSERT_UNION_EQ]); - -Theorem firstSet_nLetDecs[simp] - `firstSet cmlG [NT (mkNT nLetDecs)] = {ValT; FunT; SemicolonT}` - (simp[firstSetML_eqn, Once firstSetML_def, cmlG_FDOM, +Theorem firstSet_nLetDec[simp]: + firstSet cmlG [NT (mkNT nLetDec)] = {ValT; FunT} +Proof + simp[firstSetML_eqn, Once firstSetML_def, cmlG_FDOM, + cmlG_applied, INSERT_UNION_EQ] +QED + +Theorem firstSet_nLetDecs[simp]: + firstSet cmlG [NT (mkNT nLetDecs)] = {ValT; FunT; SemicolonT} +Proof + simp[firstSetML_eqn, Once firstSetML_def, cmlG_FDOM, cmlG_applied] >> - simp[Once firstSetML_def, cmlG_FDOM, cmlG_applied, INSERT_UNION_EQ]); - -Theorem firstSet_nTypeDec[simp] - `firstSet cmlG [NT (mkNT nTypeDec)] = {DatatypeT}` - (simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied]); - -Theorem firstSet_nTypeAbbrevDec[simp] - `firstSet cmlG [NT (mkNT nTypeAbbrevDec)] = {TypeT}` - (simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied]) - -Theorem firstSet_nDecl[simp] - `firstSet cmlG [NT (mkNT nDecl)] = - {ValT; FunT; DatatypeT;ExceptionT;TypeT;LocalT}` - (simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied, - INSERT_UNION_EQ]); - -Theorem firstSet_nDecls[simp] - `firstSet cmlG [NN nDecls] = - {ValT; DatatypeT; FunT; SemicolonT; ExceptionT; TypeT; LocalT}` - (simp[firstSetML_eqn, Once firstSetML_def, cmlG_applied, cmlG_FDOM] >> + simp[Once firstSetML_def, cmlG_FDOM, cmlG_applied, INSERT_UNION_EQ] +QED + +Theorem firstSet_nTypeDec[simp]: + firstSet cmlG [NT (mkNT nTypeDec)] = {DatatypeT} +Proof + simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied] +QED + +Theorem firstSet_nTypeAbbrevDec[simp]: + firstSet cmlG [NT (mkNT nTypeAbbrevDec)] = {TypeT} +Proof + simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied] +QED + +Theorem firstSet_nDecl[simp]: + firstSet cmlG [NT (mkNT nDecl)] = + {ValT; FunT; DatatypeT;ExceptionT;TypeT;LocalT} +Proof + simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied, + INSERT_UNION_EQ] +QED + +Theorem firstSet_nDecls[simp]: + firstSet cmlG [NN nDecls] = + {ValT; DatatypeT; FunT; SemicolonT; ExceptionT; TypeT; LocalT} +Proof + simp[firstSetML_eqn, Once firstSetML_def, cmlG_applied, cmlG_FDOM] >> simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM] >> ONCE_REWRITE_TAC [firstSetML_def] >> - simp[cmlG_applied, cmlG_FDOM, INSERT_UNION_EQ, INSERT_COMM]); - -Theorem firstSet_nMultOps[simp] - `firstSet cmlG (NT (mkNT nMultOps)::rest) = - {AlphaT "div"; AlphaT"mod"; StarT; SymbolT "/"}` - (simp[firstSetML_eqn, Once firstSetML_def, cmlG_FDOM, cmlG_applied, - INSERT_UNION_EQ]); - -Theorem firstSet_nRelOps[simp] - `firstSet cmlG (NT (mkNT nRelOps)::rest) = + simp[cmlG_applied, cmlG_FDOM, INSERT_UNION_EQ, INSERT_COMM] +QED + +Theorem firstSet_nMultOps[simp]: + firstSet cmlG (NT (mkNT nMultOps)::rest) = + {AlphaT "div"; AlphaT"mod"; StarT; SymbolT "/"} +Proof + simp[firstSetML_eqn, Once firstSetML_def, cmlG_FDOM, cmlG_applied, + INSERT_UNION_EQ] +QED + +Theorem firstSet_nRelOps[simp]: + firstSet cmlG (NT (mkNT nRelOps)::rest) = {SymbolT "<"; SymbolT ">"; SymbolT "<="; SymbolT ">="; SymbolT "<>"; - EqualsT}` - (simp[firstSetML_eqn, Once firstSetML_def, cmlG_applied, cmlG_FDOM] >> - dsimp[Once EXTENSION, EQ_IMP_THM]); - -Theorem firstSet_nAddOps[simp] - `firstSet cmlG (NT (mkNT nAddOps)::rest) = - {SymbolT "+"; SymbolT "-"; SymbolT "\094"}` - (simp[firstSetML_eqn, Once firstSetML_def, cmlG_applied, cmlG_FDOM, - INSERT_UNION_EQ]); - -Theorem firstSet_nCompOps[simp] - `firstSet cmlG (NT (mkNT nCompOps)::rest) = {AlphaT "o"; SymbolT ":="}` - (simp[firstSetML_eqn, Once firstSetML_def, cmlG_FDOM, cmlG_applied, - INSERT_UNION_EQ]) - -Theorem firstSet_nListOps[simp] - `firstSet cmlG (NT (mkNT nListOps)::rest) = {SymbolT "::"; SymbolT "@"}` - (simp[firstSetML_eqn, Once firstSetML_def, cmlG_FDOM, cmlG_applied, - INSERT_UNION_EQ, INSERT_COMM]) - -Theorem firstSet_nStructure[simp] - `firstSet cmlG [NT (mkNT nStructure)] = {StructureT}` - (simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied]); - - -Theorem firstSet_nTopLevelDec[simp] - `firstSet cmlG [NT (mkNT nTopLevelDec)] = - {ValT; FunT; DatatypeT; StructureT; ExceptionT; TypeT; LocalT}` - (simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied, INSERT_UNION_EQ, INSERT_COMM]); - -Theorem firstSet_nSpecLine[simp] - `firstSet cmlG [NT (mkNT nSpecLine)] = - {ValT; DatatypeT; TypeT; ExceptionT}` - (simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied, INSERT_UNION_EQ, INSERT_COMM]); - -Theorem firstSet_nSpecLineList[simp] - `firstSet cmlG [NT (mkNT nSpecLineList)] = - {ValT; DatatypeT; TypeT; SemicolonT; ExceptionT}` - (simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied] >> + EqualsT} +Proof + simp[firstSetML_eqn, Once firstSetML_def, cmlG_applied, cmlG_FDOM] >> + dsimp[Once EXTENSION, EQ_IMP_THM] +QED + +Theorem firstSet_nAddOps[simp]: + firstSet cmlG (NT (mkNT nAddOps)::rest) = + {SymbolT "+"; SymbolT "-"; SymbolT "\094"} +Proof + simp[firstSetML_eqn, Once firstSetML_def, cmlG_applied, cmlG_FDOM, + INSERT_UNION_EQ] +QED + +Theorem firstSet_nCompOps[simp]: + firstSet cmlG (NT (mkNT nCompOps)::rest) = {AlphaT "o"; SymbolT ":="} +Proof + simp[firstSetML_eqn, Once firstSetML_def, cmlG_FDOM, cmlG_applied, + INSERT_UNION_EQ] +QED + +Theorem firstSet_nListOps[simp]: + firstSet cmlG (NT (mkNT nListOps)::rest) = {SymbolT "::"; SymbolT "@"} +Proof + simp[firstSetML_eqn, Once firstSetML_def, cmlG_FDOM, cmlG_applied, + INSERT_UNION_EQ, INSERT_COMM] +QED + +Theorem firstSet_nStructure[simp]: + firstSet cmlG [NT (mkNT nStructure)] = {StructureT} +Proof + simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied] +QED + + +Theorem firstSet_nTopLevelDec[simp]: + firstSet cmlG [NT (mkNT nTopLevelDec)] = + {ValT; FunT; DatatypeT; StructureT; ExceptionT; TypeT; LocalT} +Proof + simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied, INSERT_UNION_EQ, INSERT_COMM] +QED + +Theorem firstSet_nSpecLine[simp]: + firstSet cmlG [NT (mkNT nSpecLine)] = + {ValT; DatatypeT; TypeT; ExceptionT} +Proof + simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied, INSERT_UNION_EQ, INSERT_COMM] +QED + +Theorem firstSet_nSpecLineList[simp]: + firstSet cmlG [NT (mkNT nSpecLineList)] = + {ValT; DatatypeT; TypeT; SemicolonT; ExceptionT} +Proof + simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied] >> simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied, - INSERT_UNION_EQ, INSERT_COMM]); + INSERT_UNION_EQ, INSERT_COMM] +QED -Theorem firstSet_nV - `firstSet cmlG (NN nV:: rest) = +Theorem firstSet_nV: + firstSet cmlG (NN nV:: rest) = { AlphaT s | s ≠ "" ∧ ¬isUpper (HD s) ∧ s ≠ "before" ∧ s ≠ "div" ∧ s ≠ "mod" ∧ s ≠ "o"} ∪ { SymbolT s | s ≠ "+" ∧ s ≠ "*" ∧ s ≠ "-" ∧ s ≠ "/" ∧ s ≠ "<" ∧ s ≠ ">" ∧ s ≠ "<=" ∧ s ≠ ">=" ∧ s ≠ "<>" ∧ s ≠ ":=" ∧ s ≠ "::" ∧ - s ≠ "@" ∧ s ≠ "\094"}` - (simp[Once firstSet_NT, cmlG_applied, cmlG_FDOM] >> - dsimp[Once EXTENSION, EQ_IMP_THM]); - -Theorem firstSet_nFQV - `firstSet cmlG [NT (mkNT nFQV)] = + s ≠ "@" ∧ s ≠ "\094"} +Proof + simp[Once firstSet_NT, cmlG_applied, cmlG_FDOM] >> + dsimp[Once EXTENSION, EQ_IMP_THM] +QED + +Theorem firstSet_nFQV: + firstSet cmlG [NT (mkNT nFQV)] = firstSet cmlG [NT (mkNT nV)] ∪ - { LongidT m i | (m,i) | i ≠ "" ∧ (isAlpha (HD i) ⇒ ¬isUpper (HD i))}` - (simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied] >> - dsimp[Once EXTENSION]); - -Theorem firstSet_nUQConstructorName - `firstSet cmlG (NN nUQConstructorName :: rest) = - { AlphaT s | s ≠ "" ∧ isUpper (HD s) } ` - (simp[Once firstSet_NT, cmlG_applied, cmlG_FDOM] >> - dsimp[Once EXTENSION, EQ_IMP_THM]); - -Theorem firstSet_nConstructorName - `firstSet cmlG (NN nConstructorName :: rest) = + { LongidT m i | (m,i) | i ≠ "" ∧ (isAlpha (HD i) ⇒ ¬isUpper (HD i))} +Proof + simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied] >> + dsimp[Once EXTENSION] +QED + +Theorem firstSet_nUQConstructorName: + firstSet cmlG (NN nUQConstructorName :: rest) = + { AlphaT s | s ≠ "" ∧ isUpper (HD s) } +Proof + simp[Once firstSet_NT, cmlG_applied, cmlG_FDOM] >> + dsimp[Once EXTENSION, EQ_IMP_THM] +QED + +Theorem firstSet_nConstructorName: + firstSet cmlG (NN nConstructorName :: rest) = { LongidT str s | (str,s) | s ≠ "" ∧ isAlpha (HD s) ∧ isUpper (HD s)} ∪ - { AlphaT s | s ≠ "" ∧ isUpper (HD s) }` - (ntac 2 (simp [Once firstSet_NT, cmlG_applied, cmlG_FDOM]) >> - dsimp[Once EXTENSION, EQ_IMP_THM]); - -Theorem firstSetML_nConstructorName[simp] - `mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ⇒ + { AlphaT s | s ≠ "" ∧ isUpper (HD s) } +Proof + ntac 2 (simp [Once firstSet_NT, cmlG_applied, cmlG_FDOM]) >> + dsimp[Once EXTENSION, EQ_IMP_THM] +QED + +Theorem firstSetML_nConstructorName[simp]: + mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ⇒ (firstSetML cmlG sn (NN nConstructorName::rest) = - firstSet cmlG [NN nConstructorName])` - (simp[firstSetML_eqn] >> + firstSet cmlG [NN nConstructorName]) +Proof + simp[firstSetML_eqn] >> ntac 2 (simp[firstSetML_def] >> simp[cmlG_applied, cmlG_FDOM]) >> - strip_tac >> simp[Once EXTENSION, EQ_IMP_THM] >> dsimp[firstSetML_def]); - -Theorem firstSetML_nV[simp] - `mkNT nV ∉ sn ⇒ - (firstSetML cmlG sn (NN nV::rest) = firstSet cmlG [NN nV])` - (simp[firstSetML_eqn] >> simp[firstSetML_def] >> + strip_tac >> simp[Once EXTENSION, EQ_IMP_THM] >> dsimp[firstSetML_def] +QED + +Theorem firstSetML_nV[simp]: + mkNT nV ∉ sn ⇒ + (firstSetML cmlG sn (NN nV::rest) = firstSet cmlG [NN nV]) +Proof + simp[firstSetML_eqn] >> simp[firstSetML_def] >> simp[cmlG_FDOM, cmlG_applied] >> strip_tac >> - simp[Once EXTENSION, EQ_IMP_THM] >> dsimp[]); - -Theorem firstSetML_nFQV[simp] - `mkNT nFQV ∉ sn ∧ mkNT nV ∉ sn ⇒ - (firstSetML cmlG sn (NN nFQV::rest) = firstSet cmlG [NN nFQV])` - (simp[firstSetML_eqn] >> + simp[Once EXTENSION, EQ_IMP_THM] >> dsimp[] +QED + +Theorem firstSetML_nFQV[simp]: + mkNT nFQV ∉ sn ∧ mkNT nV ∉ sn ⇒ + (firstSetML cmlG sn (NN nFQV::rest) = firstSet cmlG [NN nFQV]) +Proof + simp[firstSetML_eqn] >> ntac 2 (simp[firstSetML_def] >> simp[cmlG_FDOM, cmlG_applied]) >> - strip_tac >> simp[Once EXTENSION, EQ_IMP_THM] >> dsimp[]); + strip_tac >> simp[Once EXTENSION, EQ_IMP_THM] >> dsimp[] +QED -Theorem firstSet_nEtuple[simp] - `firstSet cmlG [NT (mkNT nEtuple)] = {LparT}` - (simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied]); +Theorem firstSet_nEtuple[simp]: + firstSet cmlG [NT (mkNT nEtuple)] = {LparT} +Proof + simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied] +QED -Theorem firstSet_nEliteral[simp] - `firstSet cmlG [NT (mkNT nEliteral)] = +Theorem firstSet_nEliteral[simp]: + firstSet cmlG [NT (mkNT nEliteral)] = {IntT i | T} ∪ {StringT s | T} ∪ {CharT c | T} ∪ {WordT w | T} ∪ - {FFIT s | T}` - (simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied] >> - dsimp[Once EXTENSION] >> gen_tac >> eq_tac >> rw[]); + {FFIT s | T} +Proof + simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied] >> + dsimp[Once EXTENSION] >> gen_tac >> eq_tac >> rw[] +QED -Theorem firstSetML_nEliteral[simp] - `mkNT nEliteral ∉ sn ⇒ +Theorem firstSetML_nEliteral[simp]: + mkNT nEliteral ∉ sn ⇒ firstSetML cmlG sn (NT (mkNT nEliteral)::rest) = - firstSet cmlG [NT (mkNT nEliteral)]` - (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM] >> - dsimp[Once EXTENSION] >> metis_tac[]); + firstSet cmlG [NT (mkNT nEliteral)] +Proof + simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM] >> + dsimp[Once EXTENSION] >> metis_tac[] +QED -Theorem firstSet_nEbase[simp] - `firstSet cmlG [NT (mkNT nEbase)] = +Theorem firstSet_nEbase[simp]: + firstSet cmlG [NT (mkNT nEbase)] = {LetT; LparT; LbrackT; OpT} ∪ firstSet cmlG [NT (mkNT nFQV)] ∪ firstSet cmlG [NT (mkNT nEliteral)] ∪ - firstSet cmlG [NT (mkNT nConstructorName)]` - (simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied] >> - dsimp[Once EXTENSION] >> gen_tac >> eq_tac >> rw[] >> simp[]); + firstSet cmlG [NT (mkNT nConstructorName)] +Proof + simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied] >> + dsimp[Once EXTENSION] >> gen_tac >> eq_tac >> rw[] >> simp[] +QED -Theorem firstSetML_nEbase[simp] - `mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ +Theorem firstSetML_nEbase[simp]: + mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ mkNT nEbase ∉ sn ∧ mkNT nFQV ∉ sn ∧ mkNT nV ∉ sn ∧ mkNT nEliteral ∉ sn ⇒ firstSetML cmlG sn (NT (mkNT nEbase)::rest) = - firstSet cmlG [NT (mkNT nEbase)]` - (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM] >> strip_tac >> + firstSet cmlG [NT (mkNT nEbase)] +Proof + simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM] >> strip_tac >> Cases_on `mkNT nEtuple ∈ sn` >> simp[Once firstSetML_def, cmlG_FDOM, cmlG_applied] >> - simp[Once EXTENSION, EQ_IMP_THM] >> dsimp[]); + simp[Once EXTENSION, EQ_IMP_THM] >> dsimp[] +QED -Theorem firstSet_nEapp[simp] - `firstSet cmlG [NT (mkNT nEapp)] = firstSet cmlG [NT (mkNT nEbase)]` - (simp[Once firstSetML_eqn, SimpLHS] >> +Theorem firstSet_nEapp[simp]: + firstSet cmlG [NT (mkNT nEapp)] = firstSet cmlG [NT (mkNT nEbase)] +Proof + simp[Once firstSetML_eqn, SimpLHS] >> ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) >> - simp[Once EXTENSION, EQ_IMP_THM] >> dsimp[]); + simp[Once EXTENSION, EQ_IMP_THM] >> dsimp[] +QED -Theorem firstSetML_nEapp[simp] - `mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ +Theorem firstSetML_nEapp[simp]: + mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ mkNT nEbase ∉ sn ∧ mkNT nFQV ∉ sn ∧ mkNT nV ∉ sn ∧ mkNT nEapp ∉ sn ∧ mkNT nEliteral ∉ sn ⇒ firstSetML cmlG sn (NT (mkNT nEapp) :: rest) = - firstSet cmlG [NT(mkNT nEbase)]` - (ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) >> - simp[Once EXTENSION, EQ_IMP_THM] >> dsimp[]); - -Theorem firstSet_nEmult[simp] - `firstSet cmlG [NT (mkNT nEmult)] = firstSet cmlG [NT (mkNT nEbase)]` - (simp[SimpLHS, firstSetML_eqn] >> - ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM])); - -Theorem firstSetML_nEmult[simp] - `mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ + firstSet cmlG [NT(mkNT nEbase)] +Proof + ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) >> + simp[Once EXTENSION, EQ_IMP_THM] >> dsimp[] +QED + +Theorem firstSet_nEmult[simp]: + firstSet cmlG [NT (mkNT nEmult)] = firstSet cmlG [NT (mkNT nEbase)] +Proof + simp[SimpLHS, firstSetML_eqn] >> + ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) +QED + +Theorem firstSetML_nEmult[simp]: + mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ mkNT nEbase ∉ sn ∧ mkNT nFQV ∉ sn ∧ mkNT nV ∉ sn ∧ mkNT nEapp ∉ sn ∧ mkNT nEmult ∉ sn ∧ mkNT nEliteral ∉ sn ⇒ firstSetML cmlG sn (NT (mkNT nEmult) :: rest) = - firstSet cmlG [NT (mkNT nEbase)]` - (ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM])); - -Theorem firstSet_nEadd[simp] - `firstSet cmlG [NT (mkNT nEadd)] = firstSet cmlG [NT (mkNT nEbase)]` - (simp[SimpLHS, firstSetML_eqn] >> - ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM])); - -Theorem firstSetML_nEadd[simp] - `mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ + firstSet cmlG [NT (mkNT nEbase)] +Proof + ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) +QED + +Theorem firstSet_nEadd[simp]: + firstSet cmlG [NT (mkNT nEadd)] = firstSet cmlG [NT (mkNT nEbase)] +Proof + simp[SimpLHS, firstSetML_eqn] >> + ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) +QED + +Theorem firstSetML_nEadd[simp]: + mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ mkNT nEbase ∉ sn ∧ mkNT nFQV ∉ sn ∧ mkNT nV ∉ sn ∧ mkNT nEapp ∉ sn ∧ mkNT nEmult ∉ sn ∧ mkNT nEadd ∉ sn ∧ mkNT nEliteral ∉ sn⇒ firstSetML cmlG sn (NT (mkNT nEadd) :: rest) = - firstSet cmlG [NT(mkNT nEbase)]` - (ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM])); - -Theorem firstSet_nElistop[simp] - `firstSet cmlG (NT (mkNT nElistop)::rest) = - firstSet cmlG [NT (mkNT nEbase)]` - (simp[SimpLHS, firstSetML_eqn] >> - ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM])); - -Theorem firstSetML_nElistop[simp] - `mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ + firstSet cmlG [NT(mkNT nEbase)] +Proof + ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) +QED + +Theorem firstSet_nElistop[simp]: + firstSet cmlG (NT (mkNT nElistop)::rest) = + firstSet cmlG [NT (mkNT nEbase)] +Proof + simp[SimpLHS, firstSetML_eqn] >> + ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) +QED + +Theorem firstSetML_nElistop[simp]: + mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ mkNT nEbase ∉ sn ∧ mkNT nFQV ∉ sn ∧ mkNT nV ∉ sn ∧ mkNT nEapp ∉ sn ∧ mkNT nEmult ∉ sn ∧ mkNT nEadd ∉ sn ∧ mkNT nElistop ∉ sn ∧ mkNT nEliteral ∉ sn ⇒ firstSetML cmlG sn (NT (mkNT nElistop) :: rest) = - firstSet cmlG [NT(mkNT nEbase)]` - (ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM])); - -Theorem firstSet_nErel[simp] - `firstSet cmlG (NT(mkNT nErel)::rest) = firstSet cmlG [NT (mkNT nEbase)]` - (simp[SimpLHS, firstSetML_eqn] >> - ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM])); - -Theorem firstSetML_nErel[simp] - `mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ + firstSet cmlG [NT(mkNT nEbase)] +Proof + ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) +QED + +Theorem firstSet_nErel[simp]: + firstSet cmlG (NT(mkNT nErel)::rest) = firstSet cmlG [NT (mkNT nEbase)] +Proof + simp[SimpLHS, firstSetML_eqn] >> + ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) +QED + +Theorem firstSetML_nErel[simp]: + mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ mkNT nEbase ∉ sn ∧ mkNT nFQV ∉ sn ∧ mkNT nV ∉ sn ∧ mkNT nEapp ∉ sn ∧ mkNT nEmult ∉ sn ∧ mkNT nEadd ∉ sn ∧ mkNT nErel ∉ sn ∧ mkNT nElistop ∉ sn ∧ mkNT nEliteral ∉ sn ⇒ - firstSetML cmlG sn (NT (mkNT nErel) :: rest) = firstSet cmlG [NN nEbase]` - (ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM])); - -Theorem firstSet_nEcomp[simp] - `firstSet cmlG (NT(mkNT nEcomp)::rest) = firstSet cmlG [NT (mkNT nEbase)]` - (simp[SimpLHS, firstSetML_eqn] >> - ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM])); - -Theorem firstSetML_nEcomp[simp] - `mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ + firstSetML cmlG sn (NT (mkNT nErel) :: rest) = firstSet cmlG [NN nEbase] +Proof + ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) +QED + +Theorem firstSet_nEcomp[simp]: + firstSet cmlG (NT(mkNT nEcomp)::rest) = firstSet cmlG [NT (mkNT nEbase)] +Proof + simp[SimpLHS, firstSetML_eqn] >> + ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) +QED + +Theorem firstSetML_nEcomp[simp]: + mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ mkNT nEbase ∉ sn ∧ mkNT nFQV ∉ sn ∧ mkNT nV ∉ sn ∧ mkNT nEapp ∉ sn ∧ mkNT nEmult ∉ sn ∧ mkNT nEadd ∉ sn ∧ mkNT nErel ∉ sn ∧ mkNT nEcomp ∉ sn ∧ mkNT nElistop ∉ sn ∧ mkNT nEliteral ∉ sn ⇒ - firstSetML cmlG sn (NT (mkNT nEcomp) :: rest) = firstSet cmlG [NN nEbase]` - (ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM])); - -Theorem firstSet_nEbefore[simp] - `firstSet cmlG (NT(mkNT nEbefore)::rest) = - firstSet cmlG [NT (mkNT nEbase)]` - (simp[SimpLHS, firstSetML_eqn] >> - ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM])); - -Theorem firstSetML_nEbefore[simp] - `mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ + firstSetML cmlG sn (NT (mkNT nEcomp) :: rest) = firstSet cmlG [NN nEbase] +Proof + ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) +QED + +Theorem firstSet_nEbefore[simp]: + firstSet cmlG (NT(mkNT nEbefore)::rest) = + firstSet cmlG [NT (mkNT nEbase)] +Proof + simp[SimpLHS, firstSetML_eqn] >> + ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) +QED + +Theorem firstSetML_nEbefore[simp]: + mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ mkNT nEbase ∉ sn ∧ mkNT nFQV ∉ sn ∧ mkNT nV ∉ sn ∧ mkNT nEapp ∉ sn ∧ mkNT nEmult ∉ sn ∧ mkNT nEadd ∉ sn ∧ mkNT nErel ∉ sn ∧ mkNT nEcomp ∉ sn ∧ mkNT nEbefore ∉ sn ∧ mkNT nElistop ∉ sn ∧ mkNT nEliteral ∉ sn ⇒ - firstSetML cmlG sn (NT (mkNT nEbefore)::rest) = firstSet cmlG [NN nEbase]` - (ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM])); - -Theorem firstSet_nEtyped[simp] - `firstSet cmlG (NT(mkNT nEtyped)::rest) = firstSet cmlG [NT (mkNT nEbase)]` - (simp[SimpLHS, firstSetML_eqn] >> - ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM])); - -Theorem firstSetML_nEtyped[simp] - `mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ + firstSetML cmlG sn (NT (mkNT nEbefore)::rest) = firstSet cmlG [NN nEbase] +Proof + ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) +QED + +Theorem firstSet_nEtyped[simp]: + firstSet cmlG (NT(mkNT nEtyped)::rest) = firstSet cmlG [NT (mkNT nEbase)] +Proof + simp[SimpLHS, firstSetML_eqn] >> + ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) +QED + +Theorem firstSetML_nEtyped[simp]: + mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ mkNT nEbase ∉ sn ∧ mkNT nFQV ∉ sn ∧ mkNT nV ∉ sn ∧ mkNT nEapp ∉ sn ∧ mkNT nEmult ∉ sn ∧ mkNT nEadd ∉ sn ∧ mkNT nErel ∉ sn ∧ mkNT nEcomp ∉ sn ∧ mkNT nEbefore ∉ sn ∧ mkNT nEtyped ∉ sn ∧ mkNT nElistop ∉ sn ∧ mkNT nEliteral ∉ sn ⇒ - firstSetML cmlG sn (NT (mkNT nEtyped)::rest) = firstSet cmlG [NN nEbase]` - (ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM])); - -Theorem firstSet_nElogicAND[simp] - `firstSet cmlG (NT(mkNT nElogicAND)::rest) = firstSet cmlG [NT (mkNT nEbase)]` - (simp[SimpLHS, firstSetML_eqn] >> - ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM])); - -Theorem firstSetML_nElogicAND[simp] - `mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ + firstSetML cmlG sn (NT (mkNT nEtyped)::rest) = firstSet cmlG [NN nEbase] +Proof + ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) +QED + +Theorem firstSet_nElogicAND[simp]: + firstSet cmlG (NT(mkNT nElogicAND)::rest) = firstSet cmlG [NT (mkNT nEbase)] +Proof + simp[SimpLHS, firstSetML_eqn] >> + ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) +QED + +Theorem firstSetML_nElogicAND[simp]: + mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ mkNT nEbase ∉ sn ∧ mkNT nFQV ∉ sn ∧ mkNT nV ∉ sn ∧ mkNT nEapp ∉ sn ∧ mkNT nEmult ∉ sn ∧ mkNT nEadd ∉ sn ∧ mkNT nErel ∉ sn ∧ mkNT nEcomp ∉ sn ∧ mkNT nEbefore ∉ sn ∧ mkNT nEtyped ∉ sn ∧ mkNT nElogicAND ∉ sn ∧ mkNT nElistop ∉ sn ∧ mkNT nEliteral ∉ sn ⇒ firstSetML cmlG sn (NT (mkNT nElogicAND)::rest) = - firstSet cmlG [NN nEbase]` - (ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM])); - -Theorem firstSet_nElogicOR[simp] - `firstSet cmlG (NT(mkNT nElogicOR)::rest) = firstSet cmlG [NT (mkNT nEbase)]` - (simp[SimpLHS, firstSetML_eqn] >> - ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM])); - -Theorem firstSetML_nElogicOR[simp] - `mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ + firstSet cmlG [NN nEbase] +Proof + ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) +QED + +Theorem firstSet_nElogicOR[simp]: + firstSet cmlG (NT(mkNT nElogicOR)::rest) = firstSet cmlG [NT (mkNT nEbase)] +Proof + simp[SimpLHS, firstSetML_eqn] >> + ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) +QED + +Theorem firstSetML_nElogicOR[simp]: + mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ mkNT nEbase ∉ sn ∧ mkNT nFQV ∉ sn ∧ mkNT nV ∉ sn ∧ mkNT nEapp ∉ sn ∧ mkNT nEmult ∉ sn ∧ mkNT nEadd ∉ sn ∧ mkNT nErel ∉ sn ∧ mkNT nEcomp ∉ sn ∧ mkNT nEbefore ∉ sn ∧ mkNT nEtyped ∉ sn ∧ mkNT nElogicAND ∉ sn ∧ mkNT nElogicOR ∉ sn ∧ mkNT nElistop ∉ sn ∧ mkNT nEliteral ∉ sn ⇒ firstSetML cmlG sn (NT (mkNT nElogicOR)::rest) = - firstSet cmlG [NN nEbase]` - (ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM])); - -Theorem firstSet_nEhandle[simp] - `firstSet cmlG (NT(mkNT nEhandle)::rest) = firstSet cmlG [NT (mkNT nEbase)]` - (simp[SimpLHS, firstSetML_eqn] >> - ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM])); - -Theorem firstSetML_nEhandle[simp] - `mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ + firstSet cmlG [NN nEbase] +Proof + ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) +QED + +Theorem firstSet_nEhandle[simp]: + firstSet cmlG (NT(mkNT nEhandle)::rest) = firstSet cmlG [NT (mkNT nEbase)] +Proof + simp[SimpLHS, firstSetML_eqn] >> + ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) +QED + +Theorem firstSetML_nEhandle[simp]: + mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ mkNT nEbase ∉ sn ∧ mkNT nFQV ∉ sn ∧ mkNT nV ∉ sn ∧ mkNT nEapp ∉ sn ∧ mkNT nEmult ∉ sn ∧ mkNT nEadd ∉ sn ∧ mkNT nErel ∉ sn ∧ mkNT nEcomp ∉ sn ∧ mkNT nEbefore ∉ sn ∧ mkNT nEtyped ∉ sn ∧ mkNT nElogicAND ∉ sn ∧ @@ -483,41 +589,51 @@ Theorem firstSetML_nEhandle[simp] mkNT nEliteral ∉ sn ⇒ firstSetML cmlG sn (NT (mkNT nEhandle)::rest) = - firstSet cmlG [NN nEbase]` - (ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM])); - -Theorem firstSet_nE - `firstSet cmlG (NT(mkNT nE)::rest) = - firstSet cmlG [NT (mkNT nEbase)] ∪ {IfT; CaseT; FnT; RaiseT}` - (simp[SimpLHS, firstSetML_eqn] >> + firstSet cmlG [NN nEbase] +Proof + ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) +QED + +Theorem firstSet_nE: + firstSet cmlG (NT(mkNT nE)::rest) = + firstSet cmlG [NT (mkNT nEbase)] ∪ {IfT; CaseT; FnT; RaiseT} +Proof + simp[SimpLHS, firstSetML_eqn] >> ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) >> - simp[Once EXTENSION, EQ_IMP_THM] >> dsimp[]); + simp[Once EXTENSION, EQ_IMP_THM] >> dsimp[] +QED -Theorem firstSet_nTopLevelDecs[simp] - `firstSet cmlG [NN nTopLevelDecs] = +Theorem firstSet_nTopLevelDecs[simp]: + firstSet cmlG [NN nTopLevelDecs] = {ValT; FunT; SemicolonT; DatatypeT; StructureT; ExceptionT; TypeT; LocalT} ∪ - firstSet cmlG [NT (mkNT nE)]` - (simp[Once firstSet_NT, cmlG_applied, cmlG_FDOM] >> + firstSet cmlG [NT (mkNT nE)] +Proof + simp[Once firstSet_NT, cmlG_applied, cmlG_FDOM] >> ONCE_REWRITE_TAC [firstSet_NT] >> simp[cmlG_applied, cmlG_FDOM] >> simp[INSERT_UNION_EQ, INSERT_COMM] >> - simp[EXTENSION, EQ_IMP_THM] >> rpt strip_tac >> rveq >> simp[]); + simp[EXTENSION, EQ_IMP_THM] >> rpt strip_tac >> rveq >> simp[] +QED -Theorem firstSet_nNonETopLevelDecs[simp] - `firstSet cmlG [NN nNonETopLevelDecs] = +Theorem firstSet_nNonETopLevelDecs[simp]: + firstSet cmlG [NN nNonETopLevelDecs] = {ValT; FunT; SemicolonT; DatatypeT; StructureT; ExceptionT; TypeT; - LocalT}` - (simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied] >> + LocalT} +Proof simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied] >> - simp[INSERT_COMM, INSERT_UNION_EQ]); - -Theorem firstSet_nEseq[simp] - `firstSet cmlG (NN nEseq :: rest) = firstSet cmlG [NN nE]` - (simp[SimpLHS, Once firstSet_NT, cmlG_FDOM, cmlG_applied] >> - simp[firstSet_nE]); - -Theorem NOTIN_firstSet_nE[simp] - `ValT ∉ firstSet cmlG (NT (mkNT nE) :: rest) ∧ + simp[Once firstSet_NT, cmlG_FDOM, cmlG_applied] >> + simp[INSERT_COMM, INSERT_UNION_EQ] +QED + +Theorem firstSet_nEseq[simp]: + firstSet cmlG (NN nEseq :: rest) = firstSet cmlG [NN nE] +Proof + simp[SimpLHS, Once firstSet_NT, cmlG_FDOM, cmlG_applied] >> + simp[firstSet_nE] +QED + +Theorem NOTIN_firstSet_nE[simp]: + ValT ∉ firstSet cmlG (NT (mkNT nE) :: rest) ∧ StructureT ∉ firstSet cmlG (NT (mkNT nE) :: rest) ∧ FunT ∉ firstSet cmlG (NT (mkNT nE) :: rest) ∧ DatatypeT ∉ firstSet cmlG (NT (mkNT nE) :: rest) ∧ @@ -525,131 +641,169 @@ Theorem NOTIN_firstSet_nE[simp] SemicolonT ∉ firstSet cmlG (NT (mkNT nE) :: rest) ∧ RparT ∉ firstSet cmlG (NN nE :: rest) ∧ RbrackT ∉ firstSet cmlG (NN nE :: rest) ∧ - TypeT ∉ firstSet cmlG (NN nE :: rest)` - (simp[firstSet_nE, firstSet_nFQV] >> - rpt (dsimp[Once firstSet_NT, cmlG_FDOM, cmlG_applied, disjImpI])) - -Theorem firstSetML_nE[simp] - `mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ + TypeT ∉ firstSet cmlG (NN nE :: rest) +Proof + simp[firstSet_nE, firstSet_nFQV] >> + rpt (dsimp[Once firstSet_NT, cmlG_FDOM, cmlG_applied, disjImpI]) +QED + +Theorem firstSetML_nE[simp]: + mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ mkNT nEbase ∉ sn ∧ mkNT nFQV ∉ sn ∧ mkNT nV ∉ sn ∧ mkNT nEapp ∉ sn ∧ mkNT nEmult ∉ sn ∧ mkNT nEadd ∉ sn ∧ mkNT nErel ∉ sn ∧ mkNT nEcomp ∉ sn ∧ mkNT nEbefore ∉ sn ∧ mkNT nEtyped ∉ sn ∧ mkNT nElogicAND ∉ sn ∧ mkNT nElogicOR ∉ sn ∧ mkNT nEhandle ∉ sn ∧ mkNT nE ∉ sn ∧ mkNT nElistop ∉ sn ∧ mkNT nEliteral ∉ sn ⇒ - firstSetML cmlG sn (NT (mkNT nE)::rest) = firstSet cmlG [NN nE]` - (ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM, firstSet_nE]) >> - simp[Once EXTENSION, EQ_IMP_THM] >> dsimp[]); - -Theorem firstSet_nE' - `firstSet cmlG (NT(mkNT nE')::rest) = - firstSet cmlG [NT (mkNT nEbase)] ∪ {IfT; RaiseT}` - (simp[SimpLHS, firstSetML_eqn] >> + firstSetML cmlG sn (NT (mkNT nE)::rest) = firstSet cmlG [NN nE] +Proof + ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM, firstSet_nE]) >> + simp[Once EXTENSION, EQ_IMP_THM] >> dsimp[] +QED + +Theorem firstSet_nE': + firstSet cmlG (NT(mkNT nE')::rest) = + firstSet cmlG [NT (mkNT nEbase)] ∪ {IfT; RaiseT} +Proof + simp[SimpLHS, firstSetML_eqn] >> ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) >> - simp[Once EXTENSION, EQ_IMP_THM] >> dsimp[]); + simp[Once EXTENSION, EQ_IMP_THM] >> dsimp[] +QED -Theorem firstSetML_nE'[simp] - `mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ +Theorem firstSetML_nE'[simp]: + mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ mkNT nEbase ∉ sn ∧ mkNT nFQV ∉ sn ∧ mkNT nV ∉ sn ∧ mkNT nEapp ∉ sn ∧ mkNT nEmult ∉ sn ∧ mkNT nEadd ∉ sn ∧ mkNT nErel ∉ sn ∧ mkNT nEcomp ∉ sn ∧ mkNT nEbefore ∉ sn ∧ mkNT nEtyped ∉ sn ∧ mkNT nElogicAND ∉ sn ∧ mkNT nElogicOR ∉ sn ∧ mkNT nE' ∉ sn ∧ mkNT nElistop ∉ sn ∧ mkNT nEliteral ∉ sn ⇒ - firstSetML cmlG sn (NT (mkNT nE')::rest) = firstSet cmlG [NN nE']` - (ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM, firstSet_nE']) >> - simp[Once EXTENSION, EQ_IMP_THM] >> dsimp[]); - -Theorem firstSet_nElist1[simp] - `firstSet cmlG (NT (mkNT nElist1)::rest) = firstSet cmlG [NT (mkNT nE)]` - (simp[SimpLHS, firstSetML_eqn] >> - simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]); - -Theorem firstSet_nElist2[simp] - `firstSet cmlG (NT (mkNT nElist2)::rest) = firstSet cmlG [NT (mkNT nE)]` - (simp[SimpLHS, firstSetML_eqn] >> - simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]); - -Theorem firstSetML_nPtuple[simp] - `mkNT nPtuple ∉ sn ⇒ (firstSetML cmlG sn (NN nPtuple :: rest) = {LparT})` - (simp[Once firstSetML_def, cmlG_FDOM, cmlG_applied]); - -Theorem firstSet_nPtuple[simp] - `firstSet cmlG (NN nPtuple :: rest) = {LparT}` - (simp[firstSetML_eqn, firstSetML_nPtuple]); - -Theorem firstSet_nPbase[simp] - `firstSet cmlG (NN nPbase :: rest) = + firstSetML cmlG sn (NT (mkNT nE')::rest) = firstSet cmlG [NN nE'] +Proof + ntac 2 (simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM, firstSet_nE']) >> + simp[Once EXTENSION, EQ_IMP_THM] >> dsimp[] +QED + +Theorem firstSet_nElist1[simp]: + firstSet cmlG (NT (mkNT nElist1)::rest) = firstSet cmlG [NT (mkNT nE)] +Proof + simp[SimpLHS, firstSetML_eqn] >> + simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM] +QED + +Theorem firstSet_nElist2[simp]: + firstSet cmlG (NT (mkNT nElist2)::rest) = firstSet cmlG [NT (mkNT nE)] +Proof + simp[SimpLHS, firstSetML_eqn] >> + simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM] +QED + +Theorem firstSetML_nPtuple[simp]: + mkNT nPtuple ∉ sn ⇒ (firstSetML cmlG sn (NN nPtuple :: rest) = {LparT}) +Proof + simp[Once firstSetML_def, cmlG_FDOM, cmlG_applied] +QED + +Theorem firstSet_nPtuple[simp]: + firstSet cmlG (NN nPtuple :: rest) = {LparT} +Proof + simp[firstSetML_eqn, firstSetML_nPtuple] +QED + +Theorem firstSet_nPbase[simp]: + firstSet cmlG (NN nPbase :: rest) = {LparT; UnderbarT; LbrackT; OpT} ∪ {IntT i | T } ∪ {StringT s | T } ∪ {CharT c | T } ∪ - firstSet cmlG [NN nConstructorName] ∪ firstSet cmlG [NN nV]` - (simp[SimpLHS, firstSetML_eqn] >> + firstSet cmlG [NN nConstructorName] ∪ firstSet cmlG [NN nV] +Proof + simp[SimpLHS, firstSetML_eqn] >> simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM] >> - dsimp[Once EXTENSION, EQ_IMP_THM]); + dsimp[Once EXTENSION, EQ_IMP_THM] +QED -Theorem firstSetML_nPbase[simp] - `mkNT nPbase ∉ sn ∧ mkNT nV ∉ sn ∧ mkNT nConstructorName ∉ sn ∧ +Theorem firstSetML_nPbase[simp]: + mkNT nPbase ∉ sn ∧ mkNT nV ∉ sn ∧ mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ mkNT nPtuple ∉ sn ⇒ - firstSetML cmlG sn (NN nPbase :: rest) = firstSet cmlG [NN nPbase]` - (simp[Once firstSetML_def, cmlG_FDOM, cmlG_applied] >> - dsimp[Once EXTENSION, EQ_IMP_THM]); - -Theorem firstSet_nPConApp[simp] - `firstSet cmlG (NN nPConApp :: rest) = - firstSet cmlG [NN nConstructorName]` - (simp[SimpLHS, firstSetML_eqn] >> + firstSetML cmlG sn (NN nPbase :: rest) = firstSet cmlG [NN nPbase] +Proof + simp[Once firstSetML_def, cmlG_FDOM, cmlG_applied] >> + dsimp[Once EXTENSION, EQ_IMP_THM] +QED + +Theorem firstSet_nPConApp[simp]: + firstSet cmlG (NN nPConApp :: rest) = + firstSet cmlG [NN nConstructorName] +Proof + simp[SimpLHS, firstSetML_eqn] >> simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM] >> - simp[Once firstSetML_def]); + simp[Once firstSetML_def] +QED -Theorem firstSetML_nPConApp[simp] - `mkNT nConstructorName ∉ sn ∧ mkNT nPConApp ∉ sn ∧ +Theorem firstSetML_nPConApp[simp]: + mkNT nConstructorName ∉ sn ∧ mkNT nPConApp ∉ sn ∧ mkNT nUQConstructorName ∉ sn ⇒ firstSetML cmlG sn (NN nPConApp :: rest) = - firstSet cmlG [NN nConstructorName]` - (simp[Once firstSetML_def, cmlG_FDOM, cmlG_applied] >> - simp[Once firstSetML_def]); + firstSet cmlG [NN nConstructorName] +Proof + simp[Once firstSetML_def, cmlG_FDOM, cmlG_applied] >> + simp[Once firstSetML_def] +QED -Theorem firstSet_nPapp[simp] - `firstSet cmlG (NN nPapp :: rest) = firstSet cmlG [NN nPbase]` - (simp[SimpLHS, firstSetML_eqn] >> +Theorem firstSet_nPapp[simp]: + firstSet cmlG (NN nPapp :: rest) = firstSet cmlG [NN nPbase] +Proof + simp[SimpLHS, firstSetML_eqn] >> simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM] >> - dsimp[Once EXTENSION, EQ_IMP_THM]); + dsimp[Once EXTENSION, EQ_IMP_THM] +QED -Theorem firstSetML_nPapp[simp] - `mkNT nPbase ∉ sn ∧ mkNT nV ∉ sn ∧ mkNT nConstructorName ∉ sn ∧ +Theorem firstSetML_nPapp[simp]: + mkNT nPbase ∉ sn ∧ mkNT nV ∉ sn ∧ mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ mkNT nPtuple ∉ sn ∧ mkNT nPapp ∉ sn ∧ mkNT nPConApp ∉ sn ⇒ - firstSetML cmlG sn (NN nPapp :: rest) = firstSet cmlG [NN nPbase]` - (simp[Once firstSetML_def, cmlG_FDOM, cmlG_applied] >> - dsimp[Once EXTENSION, EQ_IMP_THM]); - -Theorem firstSet_nPcons[simp] - `firstSet cmlG (NN nPcons :: rest) = firstSet cmlG [NN nPbase]` - (simp[SimpLHS, firstSetML_eqn] >> - simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM]) - -Theorem firstSetML_nPcons[simp] - `mkNT nPbase ∉ sn ∧ mkNT nV ∉ sn ∧ mkNT nConstructorName ∉ sn ∧ + firstSetML cmlG sn (NN nPapp :: rest) = firstSet cmlG [NN nPbase] +Proof + simp[Once firstSetML_def, cmlG_FDOM, cmlG_applied] >> + dsimp[Once EXTENSION, EQ_IMP_THM] +QED + +Theorem firstSet_nPcons[simp]: + firstSet cmlG (NN nPcons :: rest) = firstSet cmlG [NN nPbase] +Proof + simp[SimpLHS, firstSetML_eqn] >> + simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM] +QED + +Theorem firstSetML_nPcons[simp]: + mkNT nPbase ∉ sn ∧ mkNT nV ∉ sn ∧ mkNT nConstructorName ∉ sn ∧ mkNT nUQConstructorName ∉ sn ∧ mkNT nPtuple ∉ sn ∧ mkNT nPapp ∉ sn ∧ mkNT nPcons ∉ sn ∧ mkNT nPConApp ∉ sn ⇒ - firstSetML cmlG sn (NN nPcons :: rest) = firstSet cmlG [NN nPbase]` - (simp[Once firstSetML_def, cmlG_FDOM, cmlG_applied]); - -Theorem firstSet_nPattern[simp] - `firstSet cmlG (NN nPattern :: rest) = firstSet cmlG [NN nPbase]` - (simp[SimpLHS, firstSetML_eqn] >> + firstSetML cmlG sn (NN nPcons :: rest) = firstSet cmlG [NN nPbase] +Proof + simp[Once firstSetML_def, cmlG_FDOM, cmlG_applied] +QED + +Theorem firstSet_nPattern[simp]: + firstSet cmlG (NN nPattern :: rest) = firstSet cmlG [NN nPbase] +Proof + simp[SimpLHS, firstSetML_eqn] >> simp[Once firstSetML_def, cmlG_applied, cmlG_FDOM] >> - dsimp[Once EXTENSION, EQ_IMP_THM]); - -Theorem firstSet_nPatternList[simp] - `firstSet cmlG (NN nPatternList :: rest) = firstSet cmlG [NN nPattern]` - (simp[SimpLHS, Once firstSet_NT, cmlG_FDOM, cmlG_applied] >> simp[]); - -Theorem firstSet_nPbaseList1[simp] - `firstSet cmlG (NN nPbaseList1 :: rest) = firstSet cmlG [NN nPbase]` - (simp[SimpLHS, Once firstSet_NT, cmlG_FDOM, cmlG_applied] >> simp[]); - -Theorem NOTIN_firstSet_nV[simp] - `CommaT ∉ firstSet cmlG [NN nV] ∧ LparT ∉ firstSet cmlG [NN nV] ∧ + dsimp[Once EXTENSION, EQ_IMP_THM] +QED + +Theorem firstSet_nPatternList[simp]: + firstSet cmlG (NN nPatternList :: rest) = firstSet cmlG [NN nPattern] +Proof + simp[SimpLHS, Once firstSet_NT, cmlG_FDOM, cmlG_applied] >> simp[] +QED + +Theorem firstSet_nPbaseList1[simp]: + firstSet cmlG (NN nPbaseList1 :: rest) = firstSet cmlG [NN nPbase] +Proof + simp[SimpLHS, Once firstSet_NT, cmlG_FDOM, cmlG_applied] >> simp[] +QED + +Theorem NOTIN_firstSet_nV[simp]: + CommaT ∉ firstSet cmlG [NN nV] ∧ LparT ∉ firstSet cmlG [NN nV] ∧ RparT ∉ firstSet cmlG [NN nV] ∧ UnderbarT ∉ firstSet cmlG [NN nV] ∧ BarT ∉ firstSet cmlG [NN nV] ∧ OpT ∉ firstSet cmlG [NN nV] ∧ FnT ∉ firstSet cmlG [NN nV] ∧ IfT ∉ firstSet cmlG [NN nV] ∧ @@ -677,11 +831,13 @@ Theorem NOTIN_firstSet_nV[simp] TypeT ∉ firstSet cmlG [NN nV] ∧ SemicolonT ∉ firstSet cmlG [NN nV] ∧ ColonT ∉ firstSet cmlG [NN nV] ∧ StructureT ∉ firstSet cmlG [NN nV] ∧ WordT w ∉ firstSet cmlG [NN nV] ∧ - SymbolT "::" ∉ firstSet cmlG [NN nV]` - (simp[firstSet_nV]); + SymbolT "::" ∉ firstSet cmlG [NN nV] +Proof + simp[firstSet_nV] +QED -Theorem NOTIN_firstSet_nFQV[simp] - `AndT ∉ firstSet cmlG [NN nFQV] ∧ +Theorem NOTIN_firstSet_nFQV[simp]: + AndT ∉ firstSet cmlG [NN nFQV] ∧ BarT ∉ firstSet cmlG [NN nFQV] ∧ CaseT ∉ firstSet cmlG [NN nFQV] ∧ CharT c ∉ firstSet cmlG [NN nFQV] ∧ @@ -715,11 +871,13 @@ Theorem NOTIN_firstSet_nFQV[simp] TypeT ∉ firstSet cmlG [NN nFQV] ∧ UnderbarT ∉ firstSet cmlG [NN nFQV] ∧ ValT ∉ firstSet cmlG [NN nFQV] ∧ - WordT w ∉ firstSet cmlG [NN nFQV]` - (simp[firstSet_nFQV]); + WordT w ∉ firstSet cmlG [NN nFQV] +Proof + simp[firstSet_nFQV] +QED -Theorem NOTIN_firstSet_nConstructorName[simp] - `AndT ∉ firstSet cmlG [NN nConstructorName] ∧ +Theorem NOTIN_firstSet_nConstructorName[simp]: + AndT ∉ firstSet cmlG [NN nConstructorName] ∧ BarT ∉ firstSet cmlG [NN nConstructorName] ∧ ColonT ∉ firstSet cmlG [NN nConstructorName] ∧ CaseT ∉ firstSet cmlG [NN nConstructorName] ∧ @@ -755,8 +913,10 @@ Theorem NOTIN_firstSet_nConstructorName[simp] TypeT ∉ firstSet cmlG [NN nConstructorName] ∧ UnderbarT ∉ firstSet cmlG [NN nConstructorName] ∧ ValT ∉ firstSet cmlG [NN nConstructorName] ∧ - WordT w ∉ firstSet cmlG [NN nConstructorName]` - (simp[firstSet_nConstructorName]); + WordT w ∉ firstSet cmlG [NN nConstructorName] +Proof + simp[firstSet_nConstructorName] +QED val cmlPEG_total = peg_eval_total |> Q.GEN `G` |> Q.ISPEC `cmlPEG` @@ -781,20 +941,23 @@ val FLAT_EQ_CONS = Q.prove( rename [`EVERY ((=) []) pfx`] >> Cases_on `pfx` >- fs[] >> full_simp_tac bool_ss [EVERY_DEF] >> rw[] >> fs[]) -Theorem rfirstSet_nonempty_fringe - `∀pt t l rest. +Theorem rfirstSet_nonempty_fringe: + ∀pt t l rest. real_fringe pt = (TOK t, l) :: rest ∧ valid_lptree G pt ⇒ - t ∈ firstSet G [ptree_head pt]` - (rw[] >> + t ∈ firstSet G [ptree_head pt] +Proof + rw[] >> ‘∃r'. ptree_fringe pt = TOK t :: r'’ by simp[ptree_fringe_real_fringe] >> - metis_tac[firstSet_nonempty_fringe, valid_lptree_def]); + metis_tac[firstSet_nonempty_fringe, valid_lptree_def] +QED -Theorem peg_respects_firstSets - `∀N i0 t l. +Theorem peg_respects_firstSets: + ∀N i0 t l. t ∉ firstSet cmlG [NT N] ∧ ¬peg0 cmlPEG (nt N I) ∧ nt N I ∈ Gexprs cmlPEG ⇒ - peg_eval cmlPEG ((t,l)::i0, nt N I) NONE` - (rpt gen_tac >> CONV_TAC CONTRAPOS_CONV >> simp[] >> + peg_eval cmlPEG ((t,l)::i0, nt N I) NONE +Proof + rpt gen_tac >> CONV_TAC CONTRAPOS_CONV >> simp[] >> Cases_on `nt N I ∈ Gexprs cmlPEG` >> simp[] >> IMP_RES_THEN (qspec_then `(t,l)::i0` (qxchl [`r`] assume_tac)) cmlPEG_total >> pop_assum (assume_tac o MATCH_MP (CONJUNCT1 peg_deterministic)) >> @@ -814,21 +977,24 @@ Theorem peg_respects_firstSets fs[MAP_EQ_APPEND]) >- (fs[] >> pop_assum kall_tac >> first_x_assum (mp_tac o Q.AP_TERM `LENGTH`) >> simp[]) >> - fs[] >> rveq >> metis_tac [rfirstSet_nonempty_fringe]) + fs[] >> rveq >> metis_tac [rfirstSet_nonempty_fringe] +QED val sym2peg_def = Define` sym2peg (TOK tk) = tokeq tk ∧ sym2peg (NT N) = nt N I `; -Theorem not_peg0_peg_eval_NIL_NONE - `¬peg0 G sym ∧ sym ∈ Gexprs G ∧ wfG G ⇒ - peg_eval G ([], sym) NONE` - (strip_tac >> +Theorem not_peg0_peg_eval_NIL_NONE: + ¬peg0 G sym ∧ sym ∈ Gexprs G ∧ wfG G ⇒ + peg_eval G ([], sym) NONE +Proof + strip_tac >> `∃r. peg_eval G ([], sym) r` by metis_tac [peg_eval_total] >> Cases_on `r` >> simp[] >> Cases_on `x` >> - erule mp_tac not_peg0_LENGTH_decreases >> simp[]); + erule mp_tac not_peg0_LENGTH_decreases >> simp[] +QED val list_case_lemma = Q.prove( `([x] = case a of [] => [] | h::t => f h t) ⇔ @@ -848,49 +1014,63 @@ val left_insert1_ind = theorem "left_insert1_ind" open grammarTheory -Theorem left_insert1_FOLDL - `left_insert1 pt (FOLDL (λa b. mkNd (mkNT P) [a; b]) acc arg) = - FOLDL (λa b. mkNd (mkNT P) [a; b]) (left_insert1 pt acc) arg` - (qid_spec_tac `acc` >> Induct_on `arg` >> - fs[left_insert1_def,mkNd_def,ptree_list_loc_def]); +Theorem left_insert1_FOLDL: + left_insert1 pt (FOLDL (λa b. mkNd (mkNT P) [a; b]) acc arg) = + FOLDL (λa b. mkNd (mkNT P) [a; b]) (left_insert1 pt acc) arg +Proof + qid_spec_tac `acc` >> Induct_on `arg` >> + fs[left_insert1_def,mkNd_def,ptree_list_loc_def] +QED val _ = export_rewrites ["grammar.ptree_loc_def"] -Theorem ptree_loc_mkNd[simp] - `ptree_loc (mkNd n subs) = ptree_list_loc subs` - (simp[mkNd_def]); +Theorem ptree_loc_mkNd[simp]: + ptree_loc (mkNd n subs) = ptree_list_loc subs +Proof + simp[mkNd_def] +QED -Theorem merge_list_locs_HDLAST - `∀h. merge_list_locs (h::t) = merge_locs h (LAST (h::t))` - (Induct_on ‘t’ >> simp[] >> Cases_on ‘t’ >> simp[]); +Theorem merge_list_locs_HDLAST: + ∀h. merge_list_locs (h::t) = merge_locs h (LAST (h::t)) +Proof + Induct_on ‘t’ >> simp[] >> Cases_on ‘t’ >> simp[] +QED -Theorem ptree_loc_left_insert1 - `∀subpt pt. +Theorem ptree_loc_left_insert1: + ∀subpt pt. valid_locs pt ⇒ ptree_loc (left_insert1 subpt pt) = - merge_locs (ptree_loc subpt) (ptree_loc pt)` - (ho_match_mp_tac left_insert1_ind >> simp[left_insert1_def, ptree_loc_def] >> + merge_locs (ptree_loc subpt) (ptree_loc pt) +Proof + ho_match_mp_tac left_insert1_ind >> simp[left_insert1_def, ptree_loc_def] >> rw[] >> Cases_on `subs` >> simp[] >> fs[] >> rename [`list_CASE t`] >> Cases_on `t` >> fs[mkNd_def, ptree_list_loc_def, locationTheory.merge_list_locs_def, merge_list_locs_HDLAST] >> - rename [`MAP ptree_loc t2`] >> Cases_on ‘t2’ >> simp[]); + rename [`MAP ptree_loc t2`] >> Cases_on ‘t2’ >> simp[] +QED val leftLoc_def = Define`leftLoc (Locs l1 _) = l1`; val rightLoc_def = Define`rightLoc (Locs _ l2) = l2`; val _ = export_rewrites ["leftLoc_def", "rightLoc_def"] -Theorem merge_locs_LR - `merge_locs l1 l2 = Locs (leftLoc l1) (rightLoc l2)` - (map_every Cases_on [‘l1’, ‘l2’] >> simp[locationTheory.merge_locs_def]); +Theorem merge_locs_LR: + merge_locs l1 l2 = Locs (leftLoc l1) (rightLoc l2) +Proof + map_every Cases_on [‘l1’, ‘l2’] >> simp[locationTheory.merge_locs_def] +QED -Theorem leftLoc_merge_locs[simp] - `leftLoc (merge_locs l1 l2) = leftLoc l1` - (simp[merge_locs_LR]); +Theorem leftLoc_merge_locs[simp]: + leftLoc (merge_locs l1 l2) = leftLoc l1 +Proof + simp[merge_locs_LR] +QED -Theorem rightLoc_merge_locs[simp] - `rightLoc (merge_locs l1 l2) = rightLoc l2` - (simp[merge_locs_LR]); +Theorem rightLoc_merge_locs[simp]: + rightLoc (merge_locs l1 l2) = rightLoc l2 +Proof + simp[merge_locs_LR] +QED (* two valid parse-trees with the same head, and the same fringes, which are all tokens, must be identical. *) @@ -916,8 +1096,8 @@ Theorem rightLoc_merge_locs[simp] former into the latter gives us back what we started with. *) -Theorem eapp_reassociated - `∀pt bpt pf bf. +Theorem eapp_reassociated: + ∀pt bpt pf bf. valid_lptree cmlG pt ∧ ptree_head pt = NN nEapp ∧ real_fringe pt = MAP (TK ## I) pf ∧ valid_lptree cmlG bpt ∧ ptree_head bpt = NN nEbase ∧ @@ -928,8 +1108,9 @@ Theorem eapp_reassociated rightLoc (ptree_loc pt') = rightLoc (ptree_loc bpt) ∧ ptree_head pt' = NN nEapp ∧ ptree_head bpt' = NN nEbase ∧ real_fringe bpt' ++ real_fringe pt' = MAP (TK ## I) (pf ++ bf) ∧ - mkNd (mkNT nEapp) [pt; bpt] = left_insert1 bpt' pt'` - (simp[valid_lptree_def] >> + mkNd (mkNT nEapp) [pt; bpt] = left_insert1 bpt' pt' +Proof + simp[valid_lptree_def] >> ho_match_mp_tac grammarTheory.ptree_ind >> simp[MAP_EQ_CONS, cmlG_applied, cmlG_FDOM, FORALL_PROD, EXISTS_PROD] >> qx_gen_tac `subs` >> rpt strip_tac >> rveq >> @@ -949,7 +1130,8 @@ Theorem eapp_reassociated map_every qexists_tac [`mkNd (mkNT nEapp) [bpt]`, `bpt0`] >> dsimp[cmlG_applied, cmlG_FDOM, left_insert1_def, mkNd_def, ptree_list_loc_def, ptree_loc_def, - locationTheory.merge_list_locs_def]); + locationTheory.merge_list_locs_def] +QED val leftmost_def = Define` leftmost (Lf s) = Lf s ∧ @@ -973,12 +1155,13 @@ val left_insert2_def = Define` val left_insert2_ind = theorem "left_insert2_ind" val _ = export_rewrites ["left_insert2_def"] -Theorem ptree_loc_left_insert2 - `∀bpt dpt. +Theorem ptree_loc_left_insert2: + ∀bpt dpt. valid_locs dpt ⇒ ptree_loc (left_insert2 bpt dpt) = - merge_locs (ptree_loc bpt) (ptree_loc dpt)` - (ho_match_mp_tac left_insert2_ind >> rw[] >> + merge_locs (ptree_loc bpt) (ptree_loc dpt) +Proof + ho_match_mp_tac left_insert2_ind >> rw[] >> rename [`MAP ptree_loc subs`] >> Cases_on `subs` >> fs[] >> rename [`list_CASE t`] >> reverse (Cases_on `t`) >> fs[] >- (simp[ptree_list_loc_def, merge_list_locs_HDLAST] >> @@ -986,12 +1169,15 @@ Theorem ptree_loc_left_insert2 rename [`parsetree_CASE pt`] >> Cases_on `pt` >> fs[ptree_list_loc_def] >> rename [`list_CASE ptl`] >> Cases_on `ptl` >> fs[ptree_list_loc_def] >> rename [`list_CASE ptl'`] >> Cases_on `ptl'` >> fs[ptree_list_loc_def] >> - rename [`Nd nl _`] >> Cases_on `nl` >> fs[]); + rename [`Nd nl _`] >> Cases_on `nl` >> fs[] +QED -Theorem left_insert2_FOLDL - `left_insert2 pt (FOLDL (λa b. mkNd (mkNT P) [a; b]) acc arg) = - FOLDL (λa b. mkNd (mkNT P) [a; b]) (left_insert2 pt acc) arg` - (qid_spec_tac `acc` >> Induct_on `arg` >> simp[] >> simp[mkNd_def]); +Theorem left_insert2_FOLDL: + left_insert2 pt (FOLDL (λa b. mkNd (mkNT P) [a; b]) acc arg) = + FOLDL (λa b. mkNd (mkNT P) [a; b]) (left_insert2 pt acc) arg +Proof + qid_spec_tac `acc` >> Induct_on `arg` >> simp[] >> simp[mkNd_def] +QED (* the situation with DType is similar to that with Eapp and Ebase. @@ -1022,8 +1208,8 @@ Theorem left_insert2_FOLDL `- TyOp -- "option" *) -Theorem dtype_reassociated - `∀pt bpt pf bf. +Theorem dtype_reassociated: + ∀pt bpt pf bf. valid_lptree cmlG pt ∧ ptree_head pt = NN nDType ∧ real_fringe pt = MAP (TK ## I) pf ∧ valid_lptree cmlG bpt ∧ ptree_head bpt = NN nTyOp ∧ @@ -1036,8 +1222,9 @@ Theorem dtype_reassociated real_fringe bpt' ++ real_fringe pt' = MAP (TK ## I) (pf ++ bf) ∧ leftLoc (ptree_loc bpt') = leftLoc (ptree_loc pt) ∧ rightLoc (ptree_loc pt') = rightLoc (ptree_loc bpt) ∧ - mkNd (mkNT nDType) [pt; bpt] = left_insert2 bpt' pt'` - (ho_match_mp_tac grammarTheory.ptree_ind >> conj_tac + mkNd (mkNT nDType) [pt; bpt] = left_insert2 bpt' pt' +Proof + ho_match_mp_tac grammarTheory.ptree_ind >> conj_tac >- dsimp[FORALL_PROD] >> simp[Once FORALL_PROD, MAP_EQ_CONS, cmlG_applied, cmlG_FDOM, valid_lptree_def] >> @@ -1062,7 +1249,8 @@ Theorem dtype_reassociated map_every qexists_tac [`mkNd (mkNT nDType) [mkNd (mkNT nTbase) [bpt]]`, `bpt0`] >> dsimp[cmlG_applied, cmlG_FDOM, left_insert2_def, leftmost_def, mkNd_def, - ptree_list_loc_def]); + ptree_list_loc_def] +QED (* The next reassociation scenario is the general story of a left-associative @@ -1088,11 +1276,13 @@ val left_insert_def = Define` `; -Theorem left_insert_mkNd[simp] - `(left_insert (mkNd n [c0]) n sep c = mkNd n [mkNd n [c]; sep; c0]) ∧ +Theorem left_insert_mkNd[simp]: + (left_insert (mkNd n [c0]) n sep c = mkNd n [mkNd n [c]; sep; c0]) ∧ (left_insert (mkNd n [p'; s'; c']) n sep c = - mkNd n [left_insert p' n sep c; s'; c'])` - (simp[left_insert_def, mkNd_def, ptree_list_loc_def]) + mkNd n [left_insert p' n sep c; s'; c']) +Proof + simp[left_insert_def, mkNd_def, ptree_list_loc_def] +QED val list_case_eq = Q.prove( ‘(list_CASE l n c = v) ⇔ @@ -1100,18 +1290,20 @@ val list_case_eq = Q.prove( Cases_on `l` >> simp[] >> metis_tac[]); -Theorem ptree_loc_left_insert - `∀bpt n sep c. +Theorem ptree_loc_left_insert: + ∀bpt n sep c. valid_locs bpt ⇒ ptree_loc (left_insert bpt n sep c) = - merge_locs (ptree_loc c) (ptree_loc bpt)` - (ho_match_mp_tac (theorem "left_insert_ind") >> simp[left_insert_def] >> + merge_locs (ptree_loc c) (ptree_loc bpt) +Proof + ho_match_mp_tac (theorem "left_insert_ind") >> simp[left_insert_def] >> simp[FORALL_PROD] >> rw[] >> rpt (rename [`list_CASE subtl`] >> - Cases_on `subtl` >> simp[ptree_list_loc_def])) + Cases_on `subtl` >> simp[ptree_list_loc_def]) +QED -Theorem lassoc_reassociated - `∀G P SEP C ppt spt cpt pf sf cf. +Theorem lassoc_reassociated: + ∀G P SEP C ppt spt cpt pf sf cf. G.rules ' P = {[NT P; SEP; C]; [C]} ⇒ valid_lptree G ppt ∧ ptree_head ppt = NT P ∧ real_fringe ppt = MAP (TOK ## I) pf ∧ @@ -1127,8 +1319,9 @@ Theorem lassoc_reassociated MAP (TOK ## I) (pf ++ sf ++ cf) ∧ leftLoc (ptree_loc cpt') = leftLoc (ptree_loc ppt) ∧ rightLoc (ptree_loc ppt') = rightLoc (ptree_loc cpt) ∧ - mkNd P [ppt; spt; cpt] = left_insert ppt' P spt' cpt'` - (rpt gen_tac >> strip_tac >> + mkNd P [ppt; spt; cpt] = left_insert ppt' P spt' cpt' +Proof + rpt gen_tac >> strip_tac >> map_every qid_spec_tac [`cf`, `sf`, `pf`, `cpt`, `spt`, `ppt`] >> ho_match_mp_tac grammarTheory.ptree_ind >> simp[MAP_EQ_SING, valid_lptree_def] >> @@ -1158,78 +1351,92 @@ Theorem lassoc_reassociated simp[DISJ_IMP_THM, FORALL_AND_THM, left_insert_def] >> simp[ptree_list_loc_def] >> fs[mkNd_def, ptree_list_loc_def, ptree_loc_left_insert] >> - simp[merge_locs_LR]) - -Theorem left_insert_mk_linfix - `left_insert (mk_linfix N acc arg) N s c = - mk_linfix N (left_insert acc N s c) arg` - (qid_spec_tac `acc` >> completeInduct_on `LENGTH arg` >> rw[] >> + simp[merge_locs_LR] +QED + +Theorem left_insert_mk_linfix: + left_insert (mk_linfix N acc arg) N s c = + mk_linfix N (left_insert acc N s c) arg +Proof + qid_spec_tac `acc` >> completeInduct_on `LENGTH arg` >> rw[] >> full_simp_tac (srw_ss() ++ DNF_ss)[] >> `arg = [] ∨ ∃h1 t. arg = h1::t` by (Cases_on `arg` >> simp[]) >- simp[mk_linfix_def] >> `t = [] ∨ ∃h2 t2. t = h2::t2` by (Cases_on `t` >> simp[]) >- simp[mk_linfix_def] >> - rw[] >> simp[mk_linfix_def, left_insert_def]); + rw[] >> simp[mk_linfix_def, left_insert_def] +QED -Theorem firstSets_nV_nConstructorName - `¬(t ∈ firstSet cmlG [NN nConstructorName] ∧ t ∈ firstSet cmlG [NN nV])` - (Cases_on `t ∈ firstSet cmlG [NN nV]` >> simp[] >> - fs[firstSet_nV, firstSet_nConstructorName]); +Theorem firstSets_nV_nConstructorName: + ¬(t ∈ firstSet cmlG [NN nConstructorName] ∧ t ∈ firstSet cmlG [NN nV]) +Proof + Cases_on `t ∈ firstSet cmlG [NN nV]` >> simp[] >> + fs[firstSet_nV, firstSet_nConstructorName] +QED val elim_disjineq = Q.prove( `p \/ x ≠ y ⇔ (x = y ⇒ p)`, DECIDE_TAC) val elim_det = Q.prove(`(!x. P x ⇔ (x = y)) ==> P y`, METIS_TAC[]) val peg_det = CONJUNCT1 peg_deterministic -Theorem peg_seql_NONE_det - `peg_eval G (i0, seql syms f) NONE ⇒ - ∀f' r. peg_eval G (i0, seql syms f') r ⇔ r = NONE` - (Induct_on `syms` >> simp[] >> rpt strip_tac >> - rpt (first_x_assum (assume_tac o MATCH_MP peg_det)) >> simp[]); +Theorem peg_seql_NONE_det: + peg_eval G (i0, seql syms f) NONE ⇒ + ∀f' r. peg_eval G (i0, seql syms f') r ⇔ r = NONE +Proof + Induct_on `syms` >> simp[] >> rpt strip_tac >> + rpt (first_x_assum (assume_tac o MATCH_MP peg_det)) >> simp[] +QED -Theorem peg_seql_NONE_append - `∀i0 f. peg_eval G (i0, seql (l1 ++ l2) f) NONE ⇔ +Theorem peg_seql_NONE_append: + ∀i0 f. peg_eval G (i0, seql (l1 ++ l2) f) NONE ⇔ peg_eval G (i0, seql l1 I) NONE ∨ ∃i' r. peg_eval G (i0, seql l1 I) (SOME(i',r)) ∧ - peg_eval G (i', seql l2 I) NONE` - (Induct_on `l1` >> simp[] >- metis_tac [peg_seql_NONE_det] >> + peg_eval G (i', seql l2 I) NONE +Proof + Induct_on `l1` >> simp[] >- metis_tac [peg_seql_NONE_det] >> map_every qx_gen_tac [`h`, `i0`] >> Cases_on `peg_eval G (i0,h) NONE` >> simp[] >> - dsimp[] >> metis_tac[]); + dsimp[] >> metis_tac[] +QED -Theorem peg_seql_SOME_append - `∀i0 l2 f i r. +Theorem peg_seql_SOME_append: + ∀i0 l2 f i r. peg_eval G (i0, seql (l1 ++ l2) f) (SOME(i,r)) ⇔ ∃i' r1 r2. peg_eval G (i0, seql l1 I) (SOME(i',r1)) ∧ peg_eval G (i', seql l2 I) (SOME(i,r2)) ∧ - (r = f (r1 ++ r2))` - (Induct_on `l1` >> simp[] + (r = f (r1 ++ r2)) +Proof + Induct_on `l1` >> simp[] >- (Induct_on `l2` >- simp[] >> ONCE_REWRITE_TAC [peg_eval_seql_CONS] >> simp_tac (srw_ss() ++ DNF_ss) []) >> - dsimp[] >> metis_tac[]); + dsimp[] >> metis_tac[] +QED fun has_const c = assert (Lib.can (find_term (same_const c)) o concl) -Theorem eOR_wrongtok - `¬peg_eval cmlPEG ((RaiseT,loc)::i0, nt (mkNT nElogicOR) I) (SOME(i,r)) ∧ +Theorem eOR_wrongtok: + ¬peg_eval cmlPEG ((RaiseT,loc)::i0, nt (mkNT nElogicOR) I) (SOME(i,r)) ∧ ¬peg_eval cmlPEG ((FnT,loc)::i0, nt (mkNT nElogicOR) I) (SOME(i,r)) ∧ ¬peg_eval cmlPEG ((CaseT,loc)::i0, nt (mkNT nElogicOR) I) (SOME(i,r)) ∧ - ¬peg_eval cmlPEG ((IfT,loc)::i0, nt (mkNT nElogicOR) I) (SOME(i,r))` - (rpt conj_tac >> + ¬peg_eval cmlPEG ((IfT,loc)::i0, nt (mkNT nElogicOR) I) (SOME(i,r)) +Proof + rpt conj_tac >> qmatch_abbrev_tac `¬peg_eval cmlPEG (ttk::i0, nt (mkNT nElogicOR) I) (SOME(i,r))` >> strip_tac >> `peg_eval cmlPEG (ttk::i0, nt (mkNT nElogicOR) I) NONE` suffices_by (first_assum (assume_tac o MATCH_MP peg_det) >> simp[]) >> - simp[Abbr`ttk`, peg_respects_firstSets]); + simp[Abbr`ttk`, peg_respects_firstSets] +QED -Theorem nE'_nE - `∀i0 i r. +Theorem nE'_nE: + ∀i0 i r. peg_eval cmlPEG (i0, nt (mkNT nE') I) (SOME(i,r)) ∧ (i ≠ [] ⇒ FST (HD i) ≠ HandleT) ⇒ - ∃r'. peg_eval cmlPEG (i0, nt (mkNT nE) I) (SOME(i,r'))` - (gen_tac >> completeInduct_on `LENGTH i0` >> gen_tac >> strip_tac >> + ∃r'. peg_eval cmlPEG (i0, nt (mkNT nE) I) (SOME(i,r')) +Proof + gen_tac >> completeInduct_on `LENGTH i0` >> gen_tac >> strip_tac >> full_simp_tac (srw_ss() ++ DNF_ss) [AND_IMP_INTRO] >> simp[peg_eval_NT_SOME] >> simp[cmlpeg_rules_applied] >> rpt strip_tac >> rveq >> simp[peg_eval_tok_NONE] >> fs[] @@ -1251,15 +1458,17 @@ Theorem nE'_nE >- (rename [`FST tkl = RaiseT`] >> Cases_on `tkl` >> fs[] >> rveq >> fs[eOR_wrongtok]) >- (rename [`FST tkl = RaiseT`] >> Cases_on `tkl` >> fs[] >> rveq >> - fs[eOR_wrongtok])) + fs[eOR_wrongtok]) +QED -Theorem nE'_bar_nE - `∀i0 i i' r r'. +Theorem nE'_bar_nE: + ∀i0 i i' r r'. peg_eval cmlPEG (i0, nt (mkNT nE) I) (SOME(i,r)) ∧ (i ≠ [] ⇒ FST (HD i) ≠ BarT ∧ FST (HD i) ≠ HandleT) ∧ i' ≠ [] ∧ peg_eval cmlPEG (i0, nt (mkNT nE') I) (SOME(i',r')) ⇒ - FST (HD i') ≠ BarT` - (gen_tac >> completeInduct_on `LENGTH i0` >> rpt strip_tac >> + FST (HD i') ≠ BarT +Proof + gen_tac >> completeInduct_on `LENGTH i0` >> rpt strip_tac >> full_simp_tac (srw_ss() ++ DNF_ss) [AND_IMP_INTRO] >> rw[] >> rpt (qpat_x_assum `peg_eval X Y Z` mp_tac) >> simp[peg_eval_NT_SOME] >> @@ -1327,7 +1536,8 @@ Theorem nE'_bar_nE peg_eval_seql_NIL, peg_eval_tok_SOME, tokeq_def] >> rpt strip_tac >> rveq >> fs[] >> simp[eOR_wrongtok] >> fs[] >> rename [`FST tkl = CaseT`] >> Cases_on `tkl` >> fs[] >> - simp[eOR_wrongtok]); + simp[eOR_wrongtok] +QED val nestoppers_def = Define` nestoppers = @@ -1496,13 +1706,15 @@ end g val normlist = REWRITE_TAC [GSYM APPEND_ASSOC, listTheory.APPEND] -Theorem left_insert1_mkNd - `left_insert1 pt1 (mkNd (mkNT nEapp) [pt2]) = - mkNd (mkNT nEapp) [mkNd (mkNT nEapp) [pt1]; pt2]` - (simp[mkNd_def, left_insert1_def]); +Theorem left_insert1_mkNd: + left_insert1 pt1 (mkNd (mkNT nEapp) [pt2]) = + mkNd (mkNT nEapp) [mkNd (mkNT nEapp) [pt1]; pt2] +Proof + simp[mkNd_def, left_insert1_def] +QED -Theorem eapp_complete - `(∀pt' pfx' sfx' N. +Theorem eapp_complete: + (∀pt' pfx' sfx' N. LENGTH pfx' < LENGTH master ∧ valid_lptree cmlG pt' ∧ mkNT N ∈ FDOM cmlPEG.rules ∧ ptree_head pt' = NN N ∧ real_fringe pt' = MAP (TK ## I) pfx' ∧ @@ -1519,8 +1731,9 @@ Theorem eapp_complete IS_SUFFIX master pfx ∧ valid_lptree cmlG apt ∧ ptree_head apt = NN nEapp ∧ real_fringe apt = MAP (TK ## I) pfx ∧ (sfx ≠ [] ⇒ FST (HD sfx) ∈ stoppers nEapp) ⇒ - peg_eval cmlPEG (pfx ++ sfx, nt (mkNT nEapp) I) (SOME(sfx, [apt]))` - (strip_tac >> + peg_eval cmlPEG (pfx ++ sfx, nt (mkNT nEapp) I) (SOME(sfx, [apt])) +Proof + strip_tac >> simp[Once peg_eval_NT_SOME, cmlpeg_rules_applied, (*list_case_lemma, *) peg_eval_rpt, GSYM LEFT_EXISTS_AND_THM, GSYM RIGHT_EXISTS_AND_THM, valid_lptree_thm] >> @@ -1577,85 +1790,103 @@ Theorem eapp_complete `pfx = master` by metis_tac[rich_listTheory.IS_PREFIX_LENGTH_ANTI, REVERSE_11, listTheory.LENGTH_REVERSE] >> - rveq >> simp[]); + rveq >> simp[] +QED -Theorem peg_respects_firstSets' - `peg_eval cmlPEG ((t,l) :: rest, nt N I) (SOME(sfx, res)) ∧ +Theorem peg_respects_firstSets': + peg_eval cmlPEG ((t,l) :: rest, nt N I) (SOME(sfx, res)) ∧ nt N I ∈ Gexprs cmlPEG ∧ ¬peg0 cmlPEG (nt N I) ⇒ - t ∈ firstSet cmlG [NT N]` - (strip_tac >> + t ∈ firstSet cmlG [NT N] +Proof + strip_tac >> mp_tac (CONV_RULE (STRIP_QUANT_CONV CONTRAPOS_CONV) peg_respects_firstSets) >> disch_then (qspecl_then [`N`, `rest`, `t`, `l`] mp_tac) >> simp[] >> disch_then irule >> strip_tac >> - metis_tac[peg_deterministic, NOT_NONE_SOME]) + metis_tac[peg_deterministic, NOT_NONE_SOME] +QED -Theorem nUQConstructorName_input_monotone - `peg_eval cmlPEG (i0, nt (mkNT nUQConstructorName) I) (SOME (i,r)) ⇒ +Theorem nUQConstructorName_input_monotone: + peg_eval cmlPEG (i0, nt (mkNT nUQConstructorName) I) (SOME (i,r)) ⇒ peg_eval cmlPEG (i0 ++ sfx, nt (mkNT nUQConstructorName) I) - (SOME (i ++ sfx,r))` - (simp[peg_eval_NT_SOME] >> - simp[cmlpeg_rules_applied, peg_UQConstructorName_def]); + (SOME (i ++ sfx,r)) +Proof + simp[peg_eval_NT_SOME] >> + simp[cmlpeg_rules_applied, peg_UQConstructorName_def] +QED -Theorem nConstructorName_input_monotone - `peg_eval cmlPEG (i0, nt (mkNT nConstructorName) I) (SOME (i,r)) ⇒ +Theorem nConstructorName_input_monotone: + peg_eval cmlPEG (i0, nt (mkNT nConstructorName) I) (SOME (i,r)) ⇒ peg_eval cmlPEG (i0 ++ sfx, nt (mkNT nConstructorName) I) - (SOME (i ++ sfx,r))` - (simp[peg_eval_NT_SOME] >> simp[cmlpeg_rules_applied] >> strip_tac >> rveq >> + (SOME (i ++ sfx,r)) +Proof + simp[peg_eval_NT_SOME] >> simp[cmlpeg_rules_applied] >> strip_tac >> rveq >> simp[] >- dsimp[EXISTS_PROD, nUQConstructorName_input_monotone] >> fs[peg_eval_seq_NONE] >> rename [‘FST tkl = LongidT str s’] >> Cases_on `tkl` >> fs[] >> rveq >> - simp[peg_respects_firstSets, firstSet_nUQConstructorName]); + simp[peg_respects_firstSets, firstSet_nUQConstructorName] +QED val peg_eval_NT_NONE = save_thm( "peg_eval_NT_NONE", ``peg_eval cmlPEG (i0, nt (mkNT n) I) NONE`` |> SIMP_CONV (srw_ss()) [Once peg_eval_cases]) -Theorem nConstructorName_NONE_input_monotone - `peg_eval cmlPEG ((tk,l) :: i, nt (mkNT nConstructorName) I) NONE ⇒ - peg_eval cmlPEG ((tk,l) :: (i ++ sfx), nt (mkNT nConstructorName) I) NONE` - (simp[peg_eval_NT_NONE] >> +Theorem nConstructorName_NONE_input_monotone: + peg_eval cmlPEG ((tk,l) :: i, nt (mkNT nConstructorName) I) NONE ⇒ + peg_eval cmlPEG ((tk,l) :: (i ++ sfx), nt (mkNT nConstructorName) I) NONE +Proof + simp[peg_eval_NT_NONE] >> simp[cmlpeg_rules_applied, FDOM_cmlPEG, EXISTS_PROD, peg_eval_seq_NONE, peg_eval_tok_NONE] >> simp[peg_eval_NT_NONE] >> simp[cmlpeg_rules_applied, FDOM_cmlPEG, EXISTS_PROD, peg_eval_seq_NONE, - peg_eval_tok_NONE, peg_UQConstructorName_def]) - -Theorem nV_input_monotone - `peg_eval cmlPEG (i0, nt (mkNT nV) I) (SOME (i,r)) ⇒ - peg_eval cmlPEG (i0 ++ sfx, nt (mkNT nV) I) (SOME (i ++ sfx,r))` - (simp[peg_eval_NT_SOME] >> simp[cmlpeg_rules_applied, peg_V_def] >> - strip_tac >> rveq >> simp[peg_eval_tok_NONE]); - -Theorem nOpID_input_monotone - `peg_eval cmlPEG (i0, nt (mkNT nOpID) I) (SOME (i,r)) ⇒ - peg_eval cmlPEG (i0 ++ sfx, nt (mkNT nOpID) I) (SOME (i ++ sfx,r))` - (simp[peg_eval_NT_SOME] >> simp[cmlpeg_rules_applied, peg_eval_seq_NONE] >> - strip_tac >> rveq >> simp[peg_eval_tok_NONE]); - -Theorem nUQTyOp_input_monotone - `peg_eval cmlPEG (i0, nt (mkNT nUQTyOp) I) (SOME(i,r)) ⇒ - peg_eval cmlPEG (i0 ++ sfx, nt (mkNT nUQTyOp) I) (SOME(i++sfx,r))` - (simp[peg_eval_NT_SOME] >> simp[cmlpeg_rules_applied, peg_eval_seq_NONE] >> - strip_tac >> rveq >> simp[peg_eval_tok_NONE]); - -Theorem nTyOp_input_monotone - `peg_eval cmlPEG (i0, nt (mkNT nTyOp) I) (SOME(i,r)) ⇒ - peg_eval cmlPEG (i0 ++ sfx, nt (mkNT nTyOp) I) (SOME(i++sfx,r))` - (simp[peg_eval_NT_SOME] >> simp[cmlpeg_rules_applied, peg_eval_seq_NONE] >> + peg_eval_tok_NONE, peg_UQConstructorName_def] +QED + +Theorem nV_input_monotone: + peg_eval cmlPEG (i0, nt (mkNT nV) I) (SOME (i,r)) ⇒ + peg_eval cmlPEG (i0 ++ sfx, nt (mkNT nV) I) (SOME (i ++ sfx,r)) +Proof + simp[peg_eval_NT_SOME] >> simp[cmlpeg_rules_applied, peg_V_def] >> + strip_tac >> rveq >> simp[peg_eval_tok_NONE] +QED + +Theorem nOpID_input_monotone: + peg_eval cmlPEG (i0, nt (mkNT nOpID) I) (SOME (i,r)) ⇒ + peg_eval cmlPEG (i0 ++ sfx, nt (mkNT nOpID) I) (SOME (i ++ sfx,r)) +Proof + simp[peg_eval_NT_SOME] >> simp[cmlpeg_rules_applied, peg_eval_seq_NONE] >> + strip_tac >> rveq >> simp[peg_eval_tok_NONE] +QED + +Theorem nUQTyOp_input_monotone: + peg_eval cmlPEG (i0, nt (mkNT nUQTyOp) I) (SOME(i,r)) ⇒ + peg_eval cmlPEG (i0 ++ sfx, nt (mkNT nUQTyOp) I) (SOME(i++sfx,r)) +Proof + simp[peg_eval_NT_SOME] >> simp[cmlpeg_rules_applied, peg_eval_seq_NONE] >> + strip_tac >> rveq >> simp[peg_eval_tok_NONE] +QED + +Theorem nTyOp_input_monotone: + peg_eval cmlPEG (i0, nt (mkNT nTyOp) I) (SOME(i,r)) ⇒ + peg_eval cmlPEG (i0 ++ sfx, nt (mkNT nTyOp) I) (SOME(i++sfx,r)) +Proof + simp[peg_eval_NT_SOME] >> simp[cmlpeg_rules_applied, peg_eval_seq_NONE] >> strip_tac >> rveq >> simp[peg_eval_tok_NONE, nUQTyOp_input_monotone] >> rename [‘isLongidT (FST tkl)’] >> Cases_on `tkl` >> fs[] >> simp[peg_eval_NT_NONE] >> simp[cmlpeg_rules_applied, peg_eval_tok_NONE, peg_eval_seq_NONE] >> - rename [‘isLongidT tk’] >> Cases_on `tk` >> fs[]); + rename [‘isLongidT tk’] >> Cases_on `tk` >> fs[] +QED -Theorem nTyOplist_input_monotone - `∀result i0 i sfx. +Theorem nTyOplist_input_monotone: + ∀result i0 i sfx. peg_eval_list cmlPEG (i0, nt (mkNT nTyOp) I) (i, result) ∧ (i = [] ∧ sfx ≠ [] ⇒ FST (HD sfx) ∈ stoppers nDType) ⇒ - peg_eval_list cmlPEG (i0 ++ sfx, nt (mkNT nTyOp) I) (i ++ sfx, result)` - (Induct + peg_eval_list cmlPEG (i0 ++ sfx, nt (mkNT nTyOp) I) (i ++ sfx, result) +Proof + Induct >- (ONCE_REWRITE_TAC [peg_eval_list] >> simp[] >> rpt strip_tac >> Cases_on `i0` >> simp[] >- (Cases_on `sfx` >- simp[not_peg0_peg_eval_NIL_NONE] >> fs[] >> @@ -1669,7 +1900,8 @@ Theorem nTyOplist_input_monotone ONCE_REWRITE_TAC [peg_eval_list] >> rpt strip_tac >> rveq >> fs[] >> rveq >> rename [‘peg_eval cmlPEG (i0, nt (mkNT nTyOp) I) (SOME(i1, r1))’] >> ‘peg_eval cmlPEG (i0 ++ sfx, nt (mkNT nTyOp) I) (SOME(i1 ++ sfx, r1))’ - by simp[nTyOp_input_monotone] >> qexists_tac `i1 ++ sfx` >> simp[]) + by simp[nTyOp_input_monotone] >> qexists_tac `i1 ++ sfx` >> simp[] +QED val peg_eval_TyOp_LparT = Q.prove( ‘peg_eval cmlPEG ((LparT, loc)::i0, nt (mkNT nTyOp) I) (SOME (i,r)) ⇔ F’, @@ -1677,14 +1909,15 @@ val peg_eval_TyOp_LparT = Q.prove( pop_assum (mp_then (Pos hd) mp_tac peg_respects_firstSets') >> simp[]); val _ = augment_srw_ss [rewrites [peg_eval_TyOp_LparT]] -Theorem Type_input_monotone - `∀N i0 i r sfx. +Theorem Type_input_monotone: + ∀N i0 i r sfx. N ∈ {nTypeList2; nTypeList1; nType; nPType; nDType; nTbase} ∧ (i ≠ [] ⇒ FST (HD i) ∈ stoppers N) ∧ (i = [] ∧ sfx ≠ [] ⇒ FST (HD sfx) ∈ stoppers N) ∧ peg_eval cmlPEG (i0, nt (mkNT N) I) (SOME (i, r)) ⇒ - peg_eval cmlPEG (i0 ++ sfx, nt (mkNT N) I) (SOME (i ++ sfx, r))` - (ntac 2 gen_tac >> `?iN. iN = (i0,N)` by simp[] >> pop_assum mp_tac >> + peg_eval cmlPEG (i0 ++ sfx, nt (mkNT N) I) (SOME (i ++ sfx, r)) +Proof + ntac 2 gen_tac >> `?iN. iN = (i0,N)` by simp[] >> pop_assum mp_tac >> map_every qid_spec_tac [`i0`, `N`, `iN`] >> qispl_then [`measure (LENGTH:(token # locs) list->num) LEX measure (NT_rank o mkNT)`] @@ -1864,7 +2097,8 @@ Theorem Type_input_monotone (assume_tac o MATCH_MP (CONJUNCT1 peg_deterministic)) >> qpat_x_assum ‘peg_eval _ (_, nt (mkNT nTypeList2) I) _’ mp_tac >> simp[SimpL “$==>”, peg_eval_NT_SOME] >> - simp[cmlpeg_rules_applied, peg_eval_tok_NONE]))); + simp[cmlpeg_rules_applied, peg_eval_tok_NONE])) +QED val Pattern_input_monotone0 = Q.prove( ‘∀N i0 rlist b i r sfx. @@ -2117,14 +2351,15 @@ val Pattern_input_monotone = save_thm( "Pattern_input_monotone", SIMP_RULE bool_ss [FORALL_AND_THM] Pattern_input_monotone0) -Theorem extend_Pbase_list - `∀results pfx sfx sfx' result. +Theorem extend_Pbase_list: + ∀results pfx sfx sfx' result. peg_eval_list cmlPEG (pfx, nt (mkNT nPbase) I) ([], results) ∧ peg_eval cmlPEG (sfx, nt (mkNT nPbase) I) (SOME(sfx', result)) ∧ (sfx' ≠ [] ⇒ FST (HD sfx') ∉ firstSet cmlG [NN nPbase]) ⇒ peg_eval_list cmlPEG (pfx ++ sfx, nt (mkNT nPbase) I) - (sfx', results ++ [result])` - (Induct >> dsimp[Once peg_eval_list] + (sfx', results ++ [result]) +Proof + Induct >> dsimp[Once peg_eval_list] >- (simp[Once peg_eval_list] >> simp[Once peg_eval_list] >> rpt strip_tac >> Cases_on `sfx'` >> simp[not_peg0_peg_eval_NIL_NONE, peg0_nPbase] >> fs[] >> @@ -2136,10 +2371,11 @@ Theorem extend_Pbase_list (qspec_then ‘sfx’ mp_tac) (CONJUNCT1 Pattern_input_monotone)) >> simp[] >> - disch_then (assume_tac o MATCH_MP (CONJUNCT1 peg_deterministic)) >> simp[]); + disch_then (assume_tac o MATCH_MP (CONJUNCT1 peg_deterministic)) >> simp[] +QED -Theorem papp_complete - `(∀pt' pfx' N sfx'. +Theorem papp_complete: + (∀pt' pfx' N sfx'. LENGTH pfx' < LENGTH master ∧ valid_lptree cmlG pt' ∧ mkNT N ∈ FDOM cmlPEG.rules ∧ ptree_head pt' = NN N ∧ real_fringe pt' = MAP (TK ## I) pfx' ∧ @@ -2162,8 +2398,9 @@ Theorem papp_complete peg_eval_list cmlPEG (i, nt (mkNT nPbase) I) (sfx, bpts) ∧ accpt = FOLDL (λpcpt bpt. bindNT0 nPConApp [pcpt; bpt]) - (mkNd (mkNT nPConApp) [cpt]) (FLAT bpts))` - (strip_tac >> gen_tac >> completeInduct_on ‘LENGTH pfx’ >> rpt strip_tac >> + (mkNd (mkNT nPConApp) [cpt]) (FLAT bpts)) +Proof + strip_tac >> gen_tac >> completeInduct_on ‘LENGTH pfx’ >> rpt strip_tac >> rveq >> `∃subs. accpt = mkNd (mkNT nPConApp) subs` by metis_tac[ptree_head_NT_mkNd] >> @@ -2207,28 +2444,37 @@ Theorem papp_complete first_assum (mp_then (Pos (el 2)) mp_tac extend_Pbase_list) >> disch_then (first_assum o mp_then (Pos hd) mp_tac) >> simp[] >> disch_then (assume_tac o MATCH_MP (CONJUNCT2 peg_deterministic)) >> - simp[FOLDL_APPEND]); - -Theorem leftmost_mkNd_DType[simp] - `leftmost (mkNd (mkNT nDType) (c::cs)) = leftmost c` - (simp[leftmost_def, mkNd_def]); - -Theorem leftmost_mkNd_Tbase[simp] - `leftmost (mkNd (mkNT nTbase) (x::xs)) = x` - (simp[leftmost_def, mkNd_def]); - -Theorem leftmost_FOLDL - `leftmost (FOLDL (λa b. mkNd (mkNT nDType) [a;b]) acc args) = - leftmost acc` - (qid_spec_tac `acc` >> Induct_on `args` >> simp[]); - -Theorem left_insert2_mkNd[simp] - `left_insert2 bpt (mkNd (mkNT nDType) [mkNd n [sub]]) = - mkNd (mkNT nDType) [mkNd (mkNT nDType) [bpt]; sub]` - (simp[left_insert2_def, mkNd_def, ptree_list_loc_def]); - -Theorem dtype_complete - `(∀pt' pfx' sfx' N. + simp[FOLDL_APPEND] +QED + +Theorem leftmost_mkNd_DType[simp]: + leftmost (mkNd (mkNT nDType) (c::cs)) = leftmost c +Proof + simp[leftmost_def, mkNd_def] +QED + +Theorem leftmost_mkNd_Tbase[simp]: + leftmost (mkNd (mkNT nTbase) (x::xs)) = x +Proof + simp[leftmost_def, mkNd_def] +QED + +Theorem leftmost_FOLDL: + leftmost (FOLDL (λa b. mkNd (mkNT nDType) [a;b]) acc args) = + leftmost acc +Proof + qid_spec_tac `acc` >> Induct_on `args` >> simp[] +QED + +Theorem left_insert2_mkNd[simp]: + left_insert2 bpt (mkNd (mkNT nDType) [mkNd n [sub]]) = + mkNd (mkNT nDType) [mkNd (mkNT nDType) [bpt]; sub] +Proof + simp[left_insert2_def, mkNd_def, ptree_list_loc_def] +QED + +Theorem dtype_complete: + (∀pt' pfx' sfx' N. LENGTH pfx' < LENGTH master ∧ valid_lptree cmlG pt' ∧ mkNT N ∈ FDOM cmlPEG.rules ∧ ptree_head pt' = NN N ∧ real_fringe pt' = MAP (TK ## I) pfx' ∧ @@ -2244,8 +2490,9 @@ Theorem dtype_complete IS_SUFFIX master pfx ∧ valid_lptree cmlG apt ∧ ptree_head apt = NN nDType ∧ real_fringe apt = MAP (TK ## I) pfx ∧ (sfx ≠ [] ⇒ FST (HD sfx) ∈ stoppers nDType) ⇒ - peg_eval cmlPEG (pfx ++ sfx, nt (mkNT nDType) I) (SOME(sfx, [apt]))` - (strip_tac >> + peg_eval cmlPEG (pfx ++ sfx, nt (mkNT nDType) I) (SOME(sfx, [apt])) +Proof + strip_tac >> simp[Once peg_eval_NT_SOME, cmlpeg_rules_applied, (*list_case_lemma, *) peg_eval_rpt, GSYM LEFT_EXISTS_AND_THM, GSYM RIGHT_EXISTS_AND_THM] >> gen_tac >> @@ -2328,7 +2575,8 @@ Theorem dtype_complete `pfx = master` by metis_tac[rich_listTheory.IS_PREFIX_LENGTH_ANTI, REVERSE_11, listTheory.LENGTH_REVERSE] >> - rveq >> simp[]); + rveq >> simp[] +QED (* could generalise this slightly: allowing for nullable seps, but this would require a more complicated condition on the sfx, something like @@ -2336,8 +2584,8 @@ Theorem dtype_complete (sfx ≠ [] ∧ nullable cmlG [SEP] ⇒ HD sfx ∉ firstSet cmlG [C]) and I can't be bothered with that right now. *) -Theorem peg_linfix_complete - `(∀n. SEP = NT n ⇒ +Theorem peg_linfix_complete: + (∀n. SEP = NT n ⇒ ∃nn. n = mkNT nn ∧ nt (mkNT nn) I ∈ Gexprs cmlPEG ∧ stoppers nn = UNIV) ∧ (∀n. C = NT n ⇒ ∃nn. n = mkNT nn) ∧ @@ -2370,8 +2618,9 @@ Theorem peg_linfix_complete ⇒ peg_eval cmlPEG (pfx ++ sfx, peg_linfix (mkNT P) (sym2peg C) (sym2peg SEP)) - (SOME(sfx,[pt]))` - (strip_tac >> + (SOME(sfx,[pt])) +Proof + strip_tac >> simp[peg_linfix_def, list_case_lemma, peg_eval_rpt] >> dsimp[] >> gen_tac >> completeInduct_on `LENGTH pfx` >> rpt strip_tac >> @@ -2466,7 +2715,8 @@ Theorem peg_linfix_complete simp[mk_linfix_def, left_insert_mk_linfix, left_insert_def]) >> simp[left_insert_mk_linfix] >> fs[sym2peg_def] >> first_x_assum (mp_tac o MATCH_MP peg_sound) >> rw[] >> - simp[mk_linfix_def, left_insert_def]); + simp[mk_linfix_def, left_insert_def] +QED val stdstart = simp[Once peg_eval_NT_SOME, cmlpeg_rules_applied, MAP_EQ_CONS] >> rw[] >> @@ -2489,23 +2739,26 @@ val pmap_cases = ORELSE (rename [`(_ ## _) pair = (_,_)`] >> Cases_on `pair` >> fs[] >> rveq)) -Theorem ptPapply0_FOLDL - `∀l a pt. +Theorem ptPapply0_FOLDL: + ∀l a pt. ptPapply0 a (l ++ [pt]) = [bindNT0 nPapp [FOLDL (λpcpt bpt. bindNT0 nPConApp [pcpt; bpt]) a l; - pt]]` - (Induct >> simp[ptPapply0_def] >> Cases_on `l` >> simp[ptPapply0_def] >> - fs[]); - -Theorem completeness - `∀pt N pfx sfx. + pt]] +Proof + Induct >> simp[ptPapply0_def] >> Cases_on `l` >> simp[ptPapply0_def] >> + fs[] +QED + +Theorem completeness: + ∀pt N pfx sfx. valid_lptree cmlG pt ∧ ptree_head pt = NT (mkNT N) ∧ mkNT N ∈ FDOM cmlPEG.rules ∧ (sfx ≠ [] ⇒ FST (HD sfx) ∈ stoppers N) ∧ real_fringe pt = MAP (TOK ## I) pfx ⇒ - peg_eval cmlPEG (pfx ++ sfx, nt (mkNT N) I) (SOME(sfx, [pt]))` - (ho_match_mp_tac parsing_ind >> qx_gen_tac `pt` >> + peg_eval cmlPEG (pfx ++ sfx, nt (mkNT N) I) (SOME(sfx, [pt])) +Proof + ho_match_mp_tac parsing_ind >> qx_gen_tac `pt` >> disch_then (strip_assume_tac o SIMP_RULE (srw_ss() ++ DNF_ss) []) >> RULE_ASSUM_TAC (SIMP_RULE (srw_ss() ++ CONJ_ss) [AND_IMP_INTRO]) >> map_every qx_gen_tac [`N`, `pfx`, `sfx`] >> strip_tac >> fs[] >> @@ -3864,16 +4117,18 @@ Theorem completeness print_tac "nAddOps" >> simp[MAP_EQ_CONS, Once peg_eval_NT_SOME, cmlpeg_rules_applied] >> rw[] >> fs[MAP_EQ_CONS, MAP_EQ_APPEND, DISJ_IMP_THM, FORALL_AND_THM, - peg_eval_tok_NONE, mkNd_def] >> pmap_cases); + peg_eval_tok_NONE, mkNd_def] >> pmap_cases +QED -Theorem cmlG_unambiguous - `valid_lptree cmlG pt1 ∧ ptree_head pt1 = NT (mkNT N) ∧ +Theorem cmlG_unambiguous: + valid_lptree cmlG pt1 ∧ ptree_head pt1 = NT (mkNT N) ∧ valid_lptree cmlG pt2 ∧ ptree_head pt2 = NT (mkNT N) ∧ mkNT N ∈ FDOM cmlPEG.rules ∧ (* e.g., nTopLevelDecs *) real_fringe pt2 = real_fringe pt1 ∧ (∀s. s ∈ set (ptree_fringe pt1) ⇒ ∃t. s = TOK t) ⇒ - pt1 = pt2` - (rpt strip_tac >> + pt1 = pt2 +Proof + rpt strip_tac >> `∃pfx. real_fringe pt1 = MAP (TK ## I) pfx` by (Q.UNDISCH_THEN `real_fringe pt2 = real_fringe pt1` kall_tac >> fs[ptree_fringe_real_fringe, MEM_MAP, GSYM LEFT_FORALL_IMP_THM] >> @@ -3886,6 +4141,7 @@ Theorem cmlG_unambiguous completeness >> pop_assum (fn th => MP_TAC (Q.SPEC `pt1` th) THEN MP_TAC (Q.SPEC `pt2` th)) >> simp[] >> - metis_tac[PAIR_EQ, peg_deterministic, SOME_11, CONS_11]); + metis_tac[PAIR_EQ, peg_deterministic, SOME_11, CONS_11] +QED val _ = export_theory(); diff --git a/compiler/parsing/proofs/pegSoundScript.sml b/compiler/parsing/proofs/pegSoundScript.sml index d52260deff..5e8f05aa81 100644 --- a/compiler/parsing/proofs/pegSoundScript.sml +++ b/compiler/parsing/proofs/pegSoundScript.sml @@ -18,42 +18,52 @@ val i = TypeBase.one_one_of ``:(α,β,γ)pegsym`` infix >* fun t1 >* t2 = (t1 >> conj_tac) >- t2 -Theorem peg_eval_choicel_NIL[simp] - `peg_eval G (i0, choicel []) x = (x = NONE)` - (simp[choicel_def, Once peg_eval_cases]); +Theorem peg_eval_choicel_NIL[simp]: + peg_eval G (i0, choicel []) x = (x = NONE) +Proof + simp[choicel_def, Once peg_eval_cases] +QED -Theorem peg_eval_choicel_CONS - `∀x. peg_eval G (i0, choicel (h::t)) x ⇔ +Theorem peg_eval_choicel_CONS: + ∀x. peg_eval G (i0, choicel (h::t)) x ⇔ peg_eval G (i0, h) x ∧ x <> NONE ∨ - peg_eval G (i0,h) NONE ∧ peg_eval G (i0, choicel t) x` - (simp[choicel_def, SimpLHS, Once peg_eval_cases] >> - simp[sumID_def, pairTheory.FORALL_PROD, optionTheory.FORALL_OPTION]); + peg_eval G (i0,h) NONE ∧ peg_eval G (i0, choicel t) x +Proof + simp[choicel_def, SimpLHS, Once peg_eval_cases] >> + simp[sumID_def, pairTheory.FORALL_PROD, optionTheory.FORALL_OPTION] +QED -Theorem peg_eval_seql_NIL[simp] - `peg_eval G (i0, seql [] f) x ⇔ (x = SOME(i0,f []))` - (simp[seql_def, pegf_def] >> simp[Once peg_eval_cases]); +Theorem peg_eval_seql_NIL[simp]: + peg_eval G (i0, seql [] f) x ⇔ (x = SOME(i0,f [])) +Proof + simp[seql_def, pegf_def] >> simp[Once peg_eval_cases] +QED -Theorem peg_eval_try - `∀x. peg_eval G (i0, try s) x ⇔ +Theorem peg_eval_try: + ∀x. peg_eval G (i0, try s) x ⇔ peg_eval G (i0, s) NONE ∧ x = SOME(i0,[]) ∨ - ∃i r. peg_eval G (i0, s) (SOME(i,r)) ∧ x = SOME(i,r)` - (simp[Once peg_eval_cases, try_def, SimpLHS, choicel_def, - peg_eval_choice] >> simp[sumID_def] >> metis_tac[]); + ∃i r. peg_eval G (i0, s) (SOME(i,r)) ∧ x = SOME(i,r) +Proof + simp[Once peg_eval_cases, try_def, SimpLHS, choicel_def, + peg_eval_choice] >> simp[sumID_def] >> metis_tac[] +QED -Theorem peg_eval_seql_CONS - `∀x. peg_eval G (i0, seql (h::t) f) x ⇔ +Theorem peg_eval_seql_CONS: + ∀x. peg_eval G (i0, seql (h::t) f) x ⇔ peg_eval G (i0, h) NONE ∧ x = NONE ∨ (∃rh i1. peg_eval G (i0,h) (SOME(i1,rh)) ∧ peg_eval G (i1, seql t I) NONE ∧ x = NONE) ∨ (∃rh i1 i rt. peg_eval G (i0, h) (SOME(i1,rh)) ∧ peg_eval G (i1, seql t I) (SOME(i,rt)) ∧ - x = SOME(i,f(rh ++ rt)))` - (simp[seql_def, pegf_def] >> + x = SOME(i,f(rh ++ rt))) +Proof + simp[seql_def, pegf_def] >> simp[SimpLHS, Once peg_eval_cases] >> simp[optionTheory.FORALL_OPTION, pairTheory.FORALL_PROD] >> conj_tac >- (simp[peg_eval_seq_NONE] >> metis_tac[]) >> - simp[peg_eval_seq_SOME] >> dsimp[] >> metis_tac[]); + simp[peg_eval_seq_SOME] >> dsimp[] >> metis_tac[] +QED val peg_eval_choicel_SING = save_thm( "peg_eval_choicel_SING", @@ -63,9 +73,11 @@ val peg_eval_choicel_SING = save_thm( (``peg_eval G (i0, choicel [sym]) NONE`` |> SIMP_CONV (srw_ss()) [peg_eval_choicel_CONS, peg_eval_choicel_NIL])); -Theorem not_peg0_LENGTH_decreases - `¬peg0 G s ⇒ peg_eval G (i0, s) (SOME(i,r)) ⇒ LENGTH i < LENGTH i0` - (metis_tac[peg_eval_suffix', lemma4_1a]) +Theorem not_peg0_LENGTH_decreases: + ¬peg0 G s ⇒ peg_eval G (i0, s) (SOME(i,r)) ⇒ LENGTH i < LENGTH i0 +Proof + metis_tac[peg_eval_suffix', lemma4_1a] +QED val _ = augment_srw_ss [rewrites [ @@ -73,54 +85,70 @@ val _ = augment_srw_ss [rewrites [ peg_eval_choicel_CONS, pegf_def, peg_eval_seq_SOME, pnt_def, peg_eval_try, try_def]] -Theorem peg_eval_TypeDec_wrongtok - `FST tk ≠ DatatypeT ⇒ ¬peg_eval cmlPEG (tk::i, nt (mkNT nTypeDec) f) (SOME x)` - (simp[Once peg_eval_cases, cmlpeg_rules_applied, FDOM_cmlPEG, - peg_TypeDec_def, peg_eval_seq_SOME, tokeq_def, peg_eval_tok_SOME]); +Theorem peg_eval_TypeDec_wrongtok: + FST tk ≠ DatatypeT ⇒ ¬peg_eval cmlPEG (tk::i, nt (mkNT nTypeDec) f) (SOME x) +Proof + simp[Once peg_eval_cases, cmlpeg_rules_applied, FDOM_cmlPEG, + peg_TypeDec_def, peg_eval_seq_SOME, tokeq_def, peg_eval_tok_SOME] +QED -Theorem peg_eval_TypeAbbrevDec_wrongtok - `FST tk ≠ TypeT ⇒ ¬peg_eval cmlPEG (tk::i, nt (mkNT nTypeAbbrevDec) f) (SOME x)` - (simp[Once peg_eval_cases, cmlpeg_rules_applied, FDOM_cmlPEG, - peg_eval_seq_SOME, tokeq_def, peg_eval_tok_SOME]); +Theorem peg_eval_TypeAbbrevDec_wrongtok: + FST tk ≠ TypeT ⇒ ¬peg_eval cmlPEG (tk::i, nt (mkNT nTypeAbbrevDec) f) (SOME x) +Proof + simp[Once peg_eval_cases, cmlpeg_rules_applied, FDOM_cmlPEG, + peg_eval_seq_SOME, tokeq_def, peg_eval_tok_SOME] +QED -Theorem peg_eval_LetDec_wrongtok - `FST tk = SemicolonT ⇒ ¬peg_eval cmlPEG (tk::i, nt (mkNT nLetDec) f) (SOME x)` - (simp[Once peg_eval_cases, cmlpeg_rules_applied, FDOM_cmlPEG, +Theorem peg_eval_LetDec_wrongtok: + FST tk = SemicolonT ⇒ ¬peg_eval cmlPEG (tk::i, nt (mkNT nLetDec) f) (SOME x) +Proof + simp[Once peg_eval_cases, cmlpeg_rules_applied, FDOM_cmlPEG, peg_TypeDec_def, peg_eval_seq_SOME, tokeq_def, peg_eval_tok_SOME, - peg_eval_choicel_CONS, peg_eval_seql_CONS]); + peg_eval_choicel_CONS, peg_eval_seql_CONS] +QED -Theorem peg_eval_nUQConstructor_wrongtok - `(∀s. FST t ≠ AlphaT s) ⇒ - ¬peg_eval cmlPEG (t::i, nt (mkNT nUQConstructorName) f) (SOME x)` - (simp[Once peg_eval_cases, cmlpeg_rules_applied, +Theorem peg_eval_nUQConstructor_wrongtok: + (∀s. FST t ≠ AlphaT s) ⇒ + ¬peg_eval cmlPEG (t::i, nt (mkNT nUQConstructorName) f) (SOME x) +Proof + simp[Once peg_eval_cases, cmlpeg_rules_applied, peg_eval_tok_SOME, - peg_UQConstructorName_def] >> Cases_on `t` >> simp[]); + peg_UQConstructorName_def] >> Cases_on `t` >> simp[] +QED -Theorem peg_eval_nConstructor_wrongtok - `(∀s. FST t ≠ AlphaT s) ∧ (∀s1 s2. FST t ≠ LongidT s1 s2) ⇒ - ¬peg_eval cmlPEG (t::i, nt (mkNT nConstructorName) f) (SOME x)` - (simp[Once peg_eval_cases, cmlpeg_rules_applied, peg_eval_tok_SOME, +Theorem peg_eval_nConstructor_wrongtok: + (∀s. FST t ≠ AlphaT s) ∧ (∀s1 s2. FST t ≠ LongidT s1 s2) ⇒ + ¬peg_eval cmlPEG (t::i, nt (mkNT nConstructorName) f) (SOME x) +Proof + simp[Once peg_eval_cases, cmlpeg_rules_applied, peg_eval_tok_SOME, peg_eval_choicel_CONS, peg_eval_seq_NONE, pegf_def, pnt_def, peg_eval_nUQConstructor_wrongtok, peg_eval_seq_SOME] >> - Cases_on `t` >> simp[]); + Cases_on `t` >> simp[] +QED -Theorem peg_eval_nV_wrongtok - `(∀s. FST t ≠ AlphaT s) ∧ (∀s. FST t ≠ SymbolT s) ⇒ - ¬peg_eval cmlPEG (t::i, nt (mkNT nV) f) (SOME x)` - (simp[Once peg_eval_cases, cmlpeg_rules_applied, peg_V_def, +Theorem peg_eval_nV_wrongtok: + (∀s. FST t ≠ AlphaT s) ∧ (∀s. FST t ≠ SymbolT s) ⇒ + ¬peg_eval cmlPEG (t::i, nt (mkNT nV) f) (SOME x) +Proof + simp[Once peg_eval_cases, cmlpeg_rules_applied, peg_V_def, peg_eval_seq_NONE, peg_eval_choice] >> - Cases_on `t` >> simp[]); + Cases_on `t` >> simp[] +QED -Theorem peg_eval_nFQV_wrongtok - `(∀s. FST t ≠ AlphaT s) ∧ (∀s. FST t ≠ SymbolT s) ∧ (∀s1 s2. FST t ≠ LongidT s1 s2) ⇒ - ¬peg_eval cmlPEG (t::i, nt (mkNT nFQV) f) (SOME x)` - (simp[Once peg_eval_cases, cmlpeg_rules_applied, +Theorem peg_eval_nFQV_wrongtok: + (∀s. FST t ≠ AlphaT s) ∧ (∀s. FST t ≠ SymbolT s) ∧ (∀s1 s2. FST t ≠ LongidT s1 s2) ⇒ + ¬peg_eval cmlPEG (t::i, nt (mkNT nFQV) f) (SOME x) +Proof + simp[Once peg_eval_cases, cmlpeg_rules_applied, peg_eval_seq_NONE, peg_eval_choice, peg_eval_nV_wrongtok] >> - Cases_on `t` >> simp[peg_longV_def]); + Cases_on `t` >> simp[peg_longV_def] +QED -Theorem peg_eval_rpt_never_NONE - `¬peg_eval G (i, rpt sym f) NONE` - (simp[Once peg_eval_cases]); +Theorem peg_eval_rpt_never_NONE: + ¬peg_eval G (i, rpt sym f) NONE +Proof + simp[Once peg_eval_cases] +QED val _ = export_rewrites ["peg_eval_rpt_never_NONE"] val pegsym_to_sym_def = Define` @@ -129,63 +157,83 @@ val pegsym_to_sym_def = Define` pegsym_to_sym _ = {} ` -Theorem valid_ptree_mkNd[simp] - `valid_ptree G (mkNd N subs) ⇔ +Theorem valid_ptree_mkNd[simp]: + valid_ptree G (mkNd N subs) ⇔ N ∈ FDOM G.rules ∧ MAP ptree_head subs ∈ G.rules ' N ∧ - ∀pt. MEM pt subs ⇒ valid_ptree G pt` - (simp[mkNd_def]); + ∀pt. MEM pt subs ⇒ valid_ptree G pt +Proof + simp[mkNd_def] +QED -Theorem ptree_head_mkNd[simp] - `ptree_head (mkNd N subs) = NT N` - (simp[mkNd_def]); +Theorem ptree_head_mkNd[simp]: + ptree_head (mkNd N subs) = NT N +Proof + simp[mkNd_def] +QED val ptree_list_loc_def = grammarTheory.ptree_list_loc_def -Theorem ptree_list_loc_SING[simp] - `ptree_list_loc [pt] = ptree_loc pt` - (simp[ptree_list_loc_def]); +Theorem ptree_list_loc_SING[simp]: + ptree_list_loc [pt] = ptree_loc pt +Proof + simp[ptree_list_loc_def] +QED -Theorem ptree_fringe_mkNd[simp] - `ptree_fringe (mkNd N subs) = FLAT (MAP ptree_fringe subs)` - (simp[mkNd_def]); +Theorem ptree_fringe_mkNd[simp]: + ptree_fringe (mkNd N subs) = FLAT (MAP ptree_fringe subs) +Proof + simp[mkNd_def] +QED -Theorem valid_locs_mkNd[simp] - `valid_locs (mkNd N subs) ⇔ ∀pt. MEM pt subs ⇒ valid_locs pt` - (simp[mkNd_def, ptree_list_loc_def]); +Theorem valid_locs_mkNd[simp]: + valid_locs (mkNd N subs) ⇔ ∀pt. MEM pt subs ⇒ valid_locs pt +Proof + simp[mkNd_def, ptree_list_loc_def] +QED -Theorem rfringe_length_not_nullable - `∀G s. ¬nullable G [s] ⇒ +Theorem rfringe_length_not_nullable: + ∀G s. ¬nullable G [s] ⇒ ∀pt. ptree_head pt = s ⇒ valid_lptree G pt ⇒ - 0 < LENGTH (real_fringe pt)` - (metis_tac[fringe_length_not_nullable, LENGTH_real_fringe, valid_lptree_def]); + 0 < LENGTH (real_fringe pt) +Proof + metis_tac[fringe_length_not_nullable, LENGTH_real_fringe, valid_lptree_def] +QED -Theorem valid_lptree_mkNd[simp] - `valid_lptree G (mkNd n children) ⇔ +Theorem valid_lptree_mkNd[simp]: + valid_lptree G (mkNd n children) ⇔ n ∈ FDOM G.rules ∧ MAP ptree_head children ∈ G.rules ' n ∧ - ∀pt. MEM pt children ⇒ valid_lptree G pt` - (simp[mkNd_def, ptree_list_loc_def]); + ∀pt. MEM pt children ⇒ valid_lptree G pt +Proof + simp[mkNd_def, ptree_list_loc_def] +QED -Theorem real_fringe_mkNd[simp] - `real_fringe (mkNd n subs) = FLAT (MAP real_fringe subs)` - (simp[mkNd_def] >> rpt (AP_TERM_TAC ORELSE AP_THM_TAC) >> - simp[FUN_EQ_THM]); +Theorem real_fringe_mkNd[simp]: + real_fringe (mkNd n subs) = FLAT (MAP real_fringe subs) +Proof + simp[mkNd_def] >> rpt (AP_TERM_TAC ORELSE AP_THM_TAC) >> + simp[FUN_EQ_THM] +QED -Theorem ptree_head_NT_mkNd - `ptree_head pt = NN n ∧ valid_lptree cmlG pt ∧ +Theorem ptree_head_NT_mkNd: + ptree_head pt = NN n ∧ valid_lptree cmlG pt ∧ real_fringe pt = MAP (TK ## I) pf ⇒ - ∃subs. pt = mkNd (mkNT n) subs` - (Cases_on `pt` + ∃subs. pt = mkNd (mkNT n) subs +Proof + Cases_on `pt` >- (rename [`ptree_head (Lf pair)`] >> Cases_on `pair` >> simp[] >> rw[valid_lptree_def] >> rename [`(NN _, _) = (TK ## I) pair`] >> Cases_on `pair` >> fs[]) >> rename [`ptree_head (Nd pair _)`] >> Cases_on `pair` >> - simp[MAP_EQ_CONS, mkNd_def, ptree_list_loc_def]); + simp[MAP_EQ_CONS, mkNd_def, ptree_list_loc_def] +QED -Theorem mkNd_11[simp] - `mkNd n1 sub1 = mkNd n2 sub2 ⇔ n1 = n2 ∧ sub1 = sub2` - (csimp[mkNd_def]); +Theorem mkNd_11[simp]: + mkNd n1 sub1 = mkNd n2 sub2 ⇔ n1 = n2 ∧ sub1 = sub2 +Proof + csimp[mkNd_def] +QED -Theorem peg_linfix_correct_lemma - `∀UpperN sym sepsym i0 i pts. +Theorem peg_linfix_correct_lemma: + ∀UpperN sym sepsym i0 i pts. peg_eval cmlPEG (i0, peg_linfix UpperN sym sepsym) (SOME(i,pts)) ⇒ (∀i0' i pts s. s ∈ {sym;sepsym} ⇒ @@ -207,8 +255,9 @@ Theorem peg_linfix_correct_lemma gsep ∈ pegsym_to_sym sepsym ∧ gsym ∈ pegsym_to_sym sym } ⊆ cmlG.rules ' UpperN ⇒ ∃pt. pts = [pt] ∧ ptree_head pt = NT UpperN ∧ valid_lptree cmlG pt ∧ - MAP (TK ## I) i0 = real_fringe pt ++ MAP (TK ## I) i` - (rpt strip_tac >> qpat_x_assum `peg_eval X Y Z` mp_tac >> + MAP (TK ## I) i0 = real_fringe pt ++ MAP (TK ## I) i +Proof + rpt strip_tac >> qpat_x_assum `peg_eval X Y Z` mp_tac >> simp[peg_linfix_def, peg_eval_rpt, peg_eval_seq_SOME] >> rpt strip_tac >> rveq >> asm_match `peg_eval cmlPEG (i0, sym) (SOME(i1,r1))` >> @@ -251,26 +300,33 @@ Theorem peg_linfix_correct_lemma simp[DISJ_IMP_THM, FORALL_AND_THM] >> `[NT UpperN; ptree_head sep_pt; ptree_head sym_pt] ∈ cmlG.rules ' UpperN` by fs[SUBSET_DEF] >> - simp[]); + simp[] +QED -Theorem length_no_greater - `peg_eval G (i0, sym) (SOME(i,r)) ⇒ LENGTH i ≤ LENGTH i0` - (metis_tac[peg_eval_suffix', - DECIDE ``x ≤ y:num ⇔ x < y ∨ x = y``]); +Theorem length_no_greater: + peg_eval G (i0, sym) (SOME(i,r)) ⇒ LENGTH i ≤ LENGTH i0 +Proof + metis_tac[peg_eval_suffix', + DECIDE ``x ≤ y:num ⇔ x < y ∨ x = y``] +QED -Theorem MAP_TK_11[simp] - `MAP TK x = MAP TK y ⇔ x = y` - (eq_tac >> simp[] >> strip_tac >> +Theorem MAP_TK_11[simp]: + MAP TK x = MAP TK y ⇔ x = y +Proof + eq_tac >> simp[] >> strip_tac >> match_mp_tac (INST_TYPE [beta |-> ``:(token,MMLnonT) grammar$symbol``] listTheory.INJ_MAP_EQ) >> qexists_tac `TK` >> - simp[INJ_DEF]); + simp[INJ_DEF] +QED -Theorem peg_eval_nTyOp_wrongtok - `FST tk = LparT ⇒ ¬peg_eval cmlPEG (tk::i, nt (mkNT nTyOp) f) (SOME x)` - (simp[Once peg_eval_cases, cmlpeg_rules_applied, FDOM_cmlPEG] >> - simp[Once peg_eval_cases, cmlpeg_rules_applied, FDOM_cmlPEG]); +Theorem peg_eval_nTyOp_wrongtok: + FST tk = LparT ⇒ ¬peg_eval cmlPEG (tk::i, nt (mkNT nTyOp) f) (SOME x) +Proof + simp[Once peg_eval_cases, cmlpeg_rules_applied, FDOM_cmlPEG] >> + simp[Once peg_eval_cases, cmlpeg_rules_applied, FDOM_cmlPEG] +QED datatype disposition = X | KEEP fun rlresolve d P k = let @@ -288,8 +344,8 @@ in assert P o concl)) end -Theorem peg_EbaseParen_sound - `∀i0 i pts. +Theorem peg_EbaseParen_sound: + ∀i0 i pts. peg_eval cmlPEG (i0, peg_EbaseParen) (SOME(i,pts)) ⇒ (∀i0' N i pts. LENGTH i0' < LENGTH i0 ∧ @@ -301,8 +357,9 @@ Theorem peg_EbaseParen_sound ∃pt. pts = [pt] ∧ ptree_head pt = NT (mkNT nEbase) ∧ valid_lptree cmlG pt ∧ - MAP (TOK ## I) i0 = real_fringe pt ++ MAP (TOK ## I) i` - (rw[peg_EbaseParen_def] + MAP (TOK ## I) i0 = real_fringe pt ++ MAP (TOK ## I) i +Proof + rw[peg_EbaseParen_def] >- (rlresolve X (K true) mp_tac >> simp[] >> strip_tac >> rveq >> simp[peg_EbaseParenFn_def, cmlG_FDOM, cmlG_applied, DISJ_IMP_THM, pairTheory.PAIR_MAP]) @@ -323,7 +380,8 @@ Theorem peg_EbaseParen_sound simp[] >> rpt strip_tac >>rveq >> rpt (qpat_x_assum`_ = FST _`(assume_tac o SYM)) >> simp[peg_EbaseParenFn_def, cmlG_applied, cmlG_FDOM, - DISJ_IMP_THM, FORALL_AND_THM, pairTheory.PAIR_MAP] >> fs[]) + DISJ_IMP_THM, FORALL_AND_THM, pairTheory.PAIR_MAP] >> fs[] +QED val PAIR_MAP_I = Q.prove( ‘(f ## I) x = (f (FST x), SND x) ⇔ T’, @@ -336,8 +394,8 @@ val _ = augment_srw_ss [rewrites [bindNT0_lemma]] (* left recursive rules in the grammar turn into calls to rpt in the PEG, and this in turn requires inductions *) -Theorem ptPapply_lemma - `∀limit. +Theorem ptPapply_lemma: + ∀limit. (∀i0 i pts. LENGTH i0 < limit ⇒ peg_eval cmlPEG (i0, nt (mkNT nPbase) I) (SOME (i, pts)) ⇒ @@ -351,8 +409,9 @@ Theorem ptPapply_lemma ∃pt. ptPapply0 acc (pt0 :: FLAT ptlist) = [pt] ∧ ptree_head pt = NN nPapp ∧ valid_lptree cmlG pt ∧ real_fringe acc ++ real_fringe pt0 ++ MAP (TK ## I) i0 = - real_fringe pt ++ MAP (TK ## I) i` - (gen_tac >> strip_tac >> Induct + real_fringe pt ++ MAP (TK ## I) i +Proof + gen_tac >> strip_tac >> Induct >- (simp[Once peg_eval_list] >> simp[ptPapply0_def] >> dsimp[cmlG_FDOM, cmlG_applied]) >> dsimp[Once peg_eval_list] >> rpt strip_tac >> @@ -362,15 +421,17 @@ Theorem ptPapply_lemma ‘peg_eval_list _ (i1, _) (i, ptlist)’] >> first_x_assum (qspecl_then [‘pt1’, ‘mkNd (mkNT nPConApp) [acc; pt0]’, ‘i1’] mp_tac) >> simp[] >> - disch_then irule >> dsimp[cmlG_applied, cmlG_FDOM]); + disch_then irule >> dsimp[cmlG_applied, cmlG_FDOM] +QED -Theorem peg_sound - `∀N i0 i pts. +Theorem peg_sound: + ∀N i0 i pts. peg_eval cmlPEG (i0,nt N I) (SOME(i,pts)) ⇒ ∃pt. pts = [pt] ∧ ptree_head pt = NT N ∧ valid_lptree cmlG pt ∧ - MAP (TOK ## I) i0 = real_fringe pt ++ MAP (TOK ## I) i` - (ntac 2 gen_tac >> `?iN. iN = (i0,N)` by simp[] >> pop_assum mp_tac >> + MAP (TOK ## I) i0 = real_fringe pt ++ MAP (TOK ## I) i +Proof + ntac 2 gen_tac >> `?iN. iN = (i0,N)` by simp[] >> pop_assum mp_tac >> map_every qid_spec_tac [`i0`, `N`, `iN`] >> qispl_then [`measure (LENGTH:(token # locs) list->num) LEX measure NT_rank`] (ho_match_mp_tac o @@ -1278,6 +1339,7 @@ Theorem peg_sound asm_match `isTyvarT h` >> Cases_on `h` >> fs[]) >> print_tac "nV" >> simp[peg_V_def, peg_eval_choice] >> - strip_tac >> rveq >> dsimp[cmlG_FDOM, cmlG_applied, PAIR_MAP]); + strip_tac >> rveq >> dsimp[cmlG_FDOM, cmlG_applied, PAIR_MAP] +QED val _ = export_theory() diff --git a/compiler/proofs/compilerProofScript.sml b/compiler/proofs/compilerProofScript.sml index 0ba73b1638..889dcc50cf 100644 --- a/compiler/proofs/compilerProofScript.sml +++ b/compiler/proofs/compilerProofScript.sml @@ -43,9 +43,10 @@ val initial_condition_def = Define` backend_config_ok cc.backend_config ∧ mc_conf_ok mc ∧ mc_init_ok cc.backend_config mc`; -Theorem parse_prog_correct - `parse_prog = parse` - (simp[FUN_EQ_THM] \\ gen_tac +Theorem parse_prog_correct: + parse_prog = parse +Proof + simp[FUN_EQ_THM] \\ gen_tac \\ simp[parse_def,cmlParseTheory.parse_prog_def] \\ DEEP_INTRO_TAC some_intro \\ simp[] @@ -91,16 +92,18 @@ Theorem parse_prog_correct \\ strip_tac \\ rveq \\ simp[] \\ Cases_on`ptree_TopLevelDecs pt`\\simp[] \\ strip_tac \\ fs[MAP_MAP_o] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem infertype_prog_correct - `env_rel st.tenv ienv ∧ +Theorem infertype_prog_correct: + env_rel st.tenv ienv ∧ st.type_ids = count start_type_id ∧ inf_set_tids_ienv (count start_type_id) ienv ∧ set_tids_tenv (count start_type_id) st.tenv ⇒ - ∃c' x. infertype_prog ienv p = if can_type_prog st p then Success c' else Failure x` - (strip_tac + ∃c' x. infertype_prog ienv p = if can_type_prog st p then Success c' else Failure x +Proof + strip_tac \\ simp[inferTheory.infertype_prog_def, ml_monadBaseTheory.run_def,ml_monadBaseTheory.st_ex_bind_def] \\ qmatch_goalsub_abbrev_tac`infer_ds ienv p st0` @@ -122,15 +125,18 @@ Theorem infertype_prog_correct \\ qmatch_asmsub_abbrev_tac`infer_ds _ _ st1` \\ disch_then(qspec_then`st1`mp_tac) \\ fs[Abbr`st1`, inferTheory.init_infer_state_def] - \\ rfs[DISJOINT_SYM]); + \\ rfs[DISJOINT_SYM] +QED -Theorem compile_tap_compile - `∀conf p res td. backend$compile_tap conf p = (res,td) ⇒ - backend$compile conf p = res` - (simp[backendTheory.compile_def]); +Theorem compile_tap_compile: + ∀conf p res td. backend$compile_tap conf p = (res,td) ⇒ + backend$compile conf p = res +Proof + simp[backendTheory.compile_def] +QED -Theorem compile_correct_gen - `∀(st:'ffi semantics$state) (cc:α compiler$config) prelude input mc data_sp cbspace. +Theorem compile_correct_gen: + ∀(st:'ffi semantics$state) (cc:α compiler$config) prelude input mc data_sp cbspace. initial_condition st cc mc ⇒ case FST (compiler$compile cc prelude input) of | Failure ParseError => semantics st prelude input = CannotParse @@ -146,8 +152,9 @@ Theorem compile_correct_gen ⇒ machine_sem mc st.sem_st.ffi ms ⊆ extend_with_resource_limit behaviours - (* see theorem about to_data to avoid extend_with_resource_limit *)` - (rpt strip_tac + (* see theorem about to_data to avoid extend_with_resource_limit *) +Proof + rpt strip_tac \\ simp[compilerTheory.compile_def] \\ simp[parse_prog_correct] \\ qpat_abbrev_tac `tt = if _ then _ else _` @@ -191,10 +198,11 @@ Theorem compile_correct_gen \\ reverse conj_tac >- metis_tac[] \\ fs[IN_DISJOINT] \\ CCONTR_TAC \\ fs[SUBSET_DEF] \\ rfs[] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem compile_correct - `∀(ffi:'ffi ffi_state) prelude input (cc:α compiler$config) mc data_sp cbspace. +Theorem compile_correct = Q.prove(` + ∀(ffi:'ffi ffi_state) prelude input (cc:α compiler$config) mc data_sp cbspace. config_ok cc mc ⇒ case FST (compiler$compile cc prelude input) of | Failure ParseError => semantics_init ffi prelude input = CannotParse @@ -208,8 +216,8 @@ Theorem compile_correct installed code cbspace data data_sp c.ffi_names ffi (heap_regs cc.backend_config.stack_conf.reg_names) mc ms ⇒ machine_sem mc ffi ms ⊆ extend_with_resource_limit behaviours - (* see theorem about to_data to avoid extend_with_resource_limit *)` - (rw[semantics_init_def] + (* see theorem about to_data to avoid extend_with_resource_limit *)`, + rw[semantics_init_def] \\ qmatch_goalsub_abbrev_tac`semantics$semantics st` \\ `(FST(THE(prim_sem_env ffi))).ffi = ffi` by simp[primSemEnvTheory.prim_sem_env_eq] \\ Q.ISPEC_THEN`st`mp_tac compile_correct_gen @@ -242,10 +250,11 @@ Theorem compile_correct \\ simp[]) |> check_thm; -Theorem type_config_ok - `env_rel prim_tenv infer$init_config ∧ - inf_set_tids_ienv prim_type_ids infer$init_config` - (rw [env_rel_def, inf_set_tids_ienv_def, ienv_ok_def, ienv_val_ok_def, +Theorem type_config_ok: + env_rel prim_tenv infer$init_config ∧ + inf_set_tids_ienv prim_type_ids infer$init_config +Proof + rw [env_rel_def, inf_set_tids_ienv_def, ienv_ok_def, ienv_val_ok_def, tenv_ok_def, tenv_ctor_ok_def, tenv_abbrev_ok_def, env_rel_sound_def, env_rel_complete_def, init_config_def, primTypesTheory.prim_tenv_def, typeSystemTheory.lookup_var_def] >> @@ -255,6 +264,7 @@ Theorem type_config_ok rpt ( irule namespacePropsTheory.nsAll_nsBind >> rw [unconvert_t_def, inf_set_tids_def,terminationTheory.check_freevars_def]) >> - rw [typeSystemTheory.prim_type_nums_def]); + rw [typeSystemTheory.prim_type_nums_def] +QED val _ = export_theory(); diff --git a/examples/array_searchProgScript.sml b/examples/array_searchProgScript.sml index 497942c437..4a4b135f9b 100644 --- a/examples/array_searchProgScript.sml +++ b/examples/array_searchProgScript.sml @@ -30,13 +30,14 @@ fun linear_search array value = `; val _ = append_prog linear_search; -Theorem EL_HD_DROP - `∀ n l . n < LENGTH l ⇒ EL n l = HD (DROP n l)` - (Induct >> rw[] >> Cases_on `l` >> fs[] -); +Theorem EL_HD_DROP: + ∀ n l . n < LENGTH l ⇒ EL n l = HD (DROP n l) +Proof + Induct >> rw[] >> Cases_on `l` >> fs[] +QED -Theorem linear_search_spec - `∀ a ffi_p value value_v elems elem_vs arr_v . +Theorem linear_search_spec: + ∀ a ffi_p value value_v elems elem_vs arr_v . EqualityType a ∧ (a) value value_v ∧ LIST_REL (a) elems elem_vs @@ -53,8 +54,9 @@ Theorem linear_search_spec (* if value present, it is found *) (¬MEM value elems ⇒ ret = NONE) (* if value not present, NONE *) ) - )` - (xcf "linear_search" (basis_st()) >> + ) +Proof + xcf "linear_search" (basis_st()) >> reverse (xfun_spec `search_aux` `∀ sublist sublist_vs offset offset_v . sublist = DROP offset elems ∧ @@ -172,7 +174,7 @@ Theorem linear_search_spec `sublist = DROP (offset + 1) elems` by metis_tac[DROP_EQ_CONS_IMP_DROP_SUC, ADD1] >> fs[] >> rveq >> rw[] >> fs[] -); +QED (**********) @@ -197,26 +199,29 @@ fun binary_search cmp array value = val _ = append_prog binary_search; -Theorem drop_take_partition - `∀ l n m . n ≤ m ∧ m ≤ LENGTH l ⇒ - TAKE n l ++ DROP n (TAKE m l) ++ DROP m l = l` - (Induct_on `l` >> rw[] >> fs[TAKE_def] >> Cases_on `n = 0` >> fs[] >> +Theorem drop_take_partition: + ∀ l n m . n ≤ m ∧ m ≤ LENGTH l ⇒ + TAKE n l ++ DROP n (TAKE m l) ++ DROP m l = l +Proof + Induct_on `l` >> rw[] >> fs[TAKE_def] >> Cases_on `n = 0` >> fs[] >> fs[DROP_def] >> Cases_on `m = 0` >> fs[] -); +QED -Theorem drop_take - `∀ l n m . n ≤ m ∧ m ≤ LENGTH l ⇒ - DROP n (TAKE m l) = TAKE (m - n) (DROP n l)` - (Induct_on `l` >> rw[] >> fs[TAKE_def] >> +Theorem drop_take: + ∀ l n m . n ≤ m ∧ m ≤ LENGTH l ⇒ + DROP n (TAKE m l) = TAKE (m - n) (DROP n l) +Proof + Induct_on `l` >> rw[] >> fs[TAKE_def] >> Cases_on `m = 0` >> fs[] >> fs[DROP_def] >> Cases_on `n = 0` >> fs[] -); +QED -Theorem strict_weak_order_NOT_MEM - `∀ h t cmp e . strict_weak_order cmp ∧ +Theorem strict_weak_order_NOT_MEM: + ∀ h t cmp e . strict_weak_order cmp ∧ SORTED (λ x y . cmp x y) (h::t) ∧ cmp e h - ⇒ ¬ MEM e (h::t)` - (Induct_on `t` >> rw[] + ⇒ ¬ MEM e (h::t) +Proof + Induct_on `t` >> rw[] >- (fs[strict_weak_order_def] >> metis_tac[]) >- (fs[strict_weak_order_def] >> metis_tac[]) >- (fs[SORTED_DEF] >> @@ -228,87 +233,94 @@ Theorem strict_weak_order_NOT_MEM rw[] >- imp_res_tac SORTED_TL >> fs[SORTED_DEF] >> fs[strict_weak_order_def] >> metis_tac[transitive_def]) -); +QED -Theorem strict_weak_order_cmp_TAKE - `∀ cmp e l mid . +Theorem strict_weak_order_cmp_TAKE: + ∀ cmp e l mid . strict_weak_order cmp ∧ MEM e l ∧ cmp e (EL mid l) ∧ SORTED (λ x y . cmp x y) l - ⇒ MEM e (TAKE mid l)` - (Induct_on `l` >> rw[] >> fs[TAKE_def] >> + ⇒ MEM e (TAKE mid l) +Proof + Induct_on `l` >> rw[] >> fs[TAKE_def] >> Cases_on `mid = 0` >> fs[] >- (fs[strict_weak_order_def] >> metis_tac[]) >- (drule strict_weak_order_NOT_MEM >> rpt(disch_then drule) >> fs[]) >- (Cases_on `e = h` >> fs[] >> first_x_assum match_mp_tac >> qexists_tac `cmp` >> fs[] >> Cases_on `mid` >> fs[] >> metis_tac[SORTED_TL]) -); +QED -Theorem strict_weak_order_cmp_EL - `∀ l e n cmp . +Theorem strict_weak_order_cmp_EL: + ∀ l e n cmp . n < LENGTH (e::l) ∧ strict_weak_order cmp ∧ ¬cmp e (EL n (e::l)) ∧ SORTED (λ x y . cmp x y) (e::l) - ⇒ n = 0` - (Induct_on `l` >> rw[] >> `cmp e h` by fs[SORTED_DEF] >> + ⇒ n = 0 +Proof + Induct_on `l` >> rw[] >> `cmp e h` by fs[SORTED_DEF] >> Cases_on `n` >> fs[] >> first_x_assum (qspecl_then [`e`, `n'`, `cmp`] mp_tac) >> fs[] >> Cases_on `n' = 0` >> fs[] >> Cases_on `n'` >> fs[] >> Cases_on `l` >> fs[SORTED_DEF] >> fs[strict_weak_order_def] >> metis_tac[transitive_def] -); +QED -Theorem strict_weak_order_cmp_DROP - `∀ cmp e l mid . +Theorem strict_weak_order_cmp_DROP: + ∀ cmp e l mid . strict_weak_order cmp ∧ mid < LENGTH l ∧ MEM e l ∧ ¬cmp e (EL mid l) ∧ EL mid l ≠ e ∧ SORTED (λ x y . cmp x y) l - ⇒ MEM e (DROP (mid + 1) l)` - (Induct_on `l` >> rw[] >> fs[DROP_def] >> + ⇒ MEM e (DROP (mid + 1) l) +Proof + Induct_on `l` >> rw[] >> fs[DROP_def] >> Cases_on `mid = 0` >> fs[] >- (imp_res_tac strict_weak_order_cmp_EL >> fs[]) >- (Cases_on `mid` >> fs[ADD1] >> first_x_assum match_mp_tac >> qexists_tac `cmp` >> fs[] >> metis_tac[SORTED_TL]) -); +QED -Theorem sorted_drop - `∀ l n f . SORTED f l ⇒ SORTED f (DROP n l)` - (Induct >> rw[] >> fs[DROP_def] >> Cases_on `n = 0` >> fs[] >> +Theorem sorted_drop: + ∀ l n f . SORTED f l ⇒ SORTED f (DROP n l) +Proof + Induct >> rw[] >> fs[DROP_def] >> Cases_on `n = 0` >> fs[] >> first_x_assum match_mp_tac >> metis_tac[SORTED_TL] -); +QED -Theorem sorted_take - `∀ l n f . SORTED f l ⇒ SORTED f (TAKE n l)` - (Induct >> rw[] >> fs[TAKE_def] >> Cases_on `n` >> fs[] >> +Theorem sorted_take: + ∀ l n f . SORTED f l ⇒ SORTED f (TAKE n l) +Proof + Induct >> rw[] >> fs[TAKE_def] >> Cases_on `n` >> fs[] >> Cases_on `l` >> fs[TAKE, SORTED_DEF] >> Cases_on `n'` >> fs[] >> fs[SORTED_DEF] >> first_x_assum (qspecl_then [`n + 1`, `f`] mp_tac) >> rw[] -); +QED -Theorem mem_take_impl - `∀ l n m v . n ≤ m ⇒ - MEM v (TAKE n l) ⇒ MEM v (TAKE m l)` - (Induct >> rw[] >> fs[TAKE_def] >> +Theorem mem_take_impl: + ∀ l n m v . n ≤ m ⇒ + MEM v (TAKE n l) ⇒ MEM v (TAKE m l) +Proof + Induct >> rw[] >> fs[TAKE_def] >> Cases_on `m = 0` >> fs[] >> rfs[] >> Cases_on `n = 0` >> fs[] >> Cases_on `v = h` >> fs[] >> first_x_assum (qspecl_then [`n - 1`, `m - 1`, `v`] mp_tac) >> fs[] -); +QED -Theorem mem_drop_impl - `∀ l n m v . n ≤ m - ⇒ MEM v (DROP m l) ⇒ MEM v (DROP n l)` - (Induct >> rw[] >> fs[DROP_def] >> +Theorem mem_drop_impl: + ∀ l n m v . n ≤ m + ⇒ MEM v (DROP m l) ⇒ MEM v (DROP n l) +Proof + Induct >> rw[] >> fs[DROP_def] >> Cases_on `m = 0` >> fs[] >> Cases_on `n = 0` >> fs[] >- ( Cases_on `v = h` >> fs[] >> first_x_assum (qspecl_then [`0`, `m - 1`, `v`] mp_tac) >> fs[]) >- (first_x_assum (qspecl_then [`n - 1`, `m - 1`, `v`] mp_tac) >> fs[]) -); +QED -Theorem binary_search_spec - `∀ a ffi_p cmp cmp_v value value_v elems elem_vs arr_v . +Theorem binary_search_spec: + ∀ a ffi_p cmp cmp_v value value_v elems elem_vs arr_v . strict_weak_order cmp ∧ EqualityType a ∧ (a --> a --> BOOL) cmp cmp_v ∧ @@ -327,8 +339,9 @@ Theorem binary_search_spec (* if value present, it is found *) (¬MEM value elems ⇒ u = NONE) (* if value not present, NONE *) ) - )` - (xcf "binary_search" (basis_st()) >> + ) +Proof + xcf "binary_search" (basis_st()) >> reverse (xfun_spec `search_aux` `∀ sublist sublist_vs start finish start_v finish_v . sublist = DROP start (TAKE finish elems) ∧ @@ -641,6 +654,6 @@ Theorem binary_search_spec fs[] >> fs[X_LE_DIV]) ) ) -); +QED val _ = export_theory (); diff --git a/examples/catProgScript.sml b/examples/catProgScript.sml index d6b1dfdad6..110c3948e1 100644 --- a/examples/catProgScript.sml +++ b/examples/catProgScript.sml @@ -28,17 +28,21 @@ val _ = process_topdecs ` ` |> append_prog (* TODO: move *) -Theorem SEP_EXISTS_UNWIND1 - `(SEP_EXISTS x. &(a = x) * P x) = P a` - (rw[Once FUN_EQ_THM,SEP_EXISTS_THM,STAR_def,Once EQ_IMP_THM,cond_def,SPLIT_def]); +Theorem SEP_EXISTS_UNWIND1: + (SEP_EXISTS x. &(a = x) * P x) = P a +Proof + rw[Once FUN_EQ_THM,SEP_EXISTS_THM,STAR_def,Once EQ_IMP_THM,cond_def,SPLIT_def] +QED -Theorem SEP_EXISTS_UNWIND2 - `(SEP_EXISTS x. &(x = a) * P x) = P a` - (rw[Once FUN_EQ_THM,SEP_EXISTS_THM,STAR_def,Once EQ_IMP_THM,cond_def,SPLIT_def]); +Theorem SEP_EXISTS_UNWIND2: + (SEP_EXISTS x. &(x = a) * P x) = P a +Proof + rw[Once FUN_EQ_THM,SEP_EXISTS_THM,STAR_def,Once EQ_IMP_THM,cond_def,SPLIT_def] +QED (* -- *) -Theorem do_onefile_spec - `∀fnm fnv fs. +Theorem do_onefile_spec: + ∀fnm fnv fs. FILENAME fnm fnv ∧ hasFreeFD fs ⇒ app (p:'ffi ffi_proj) ^(fetch_v "do_onefile" (get_ml_prog_state())) [fnv] @@ -51,8 +55,9 @@ Theorem do_onefile_spec STDIO (add_stdout fs (implode content))) (\e. &BadFileName_exn e * &(~inFS_fname fs fnm) * - STDIO fs))` - (rpt strip_tac >> xcf "do_onefile" (get_ml_prog_state()) >> + STDIO fs)) +Proof + rpt strip_tac >> xcf "do_onefile" (get_ml_prog_state()) >> reverse(Cases_on`STD_streams fs`) >- (fs[STDIO_def] \\ xpull) \\ reverse(Cases_on`consistentFS fs`) >-(fs[STDIO_def,IOFS_def,wfFS_def] \\ xpull \\ fs[consistentFS_def] \\ res_tac) @@ -145,20 +150,23 @@ Theorem do_onefile_spec simp[Abbr`fs0`,UNIT_TYPE_def,add_stdout_fastForwardFD,STD_streams_openFileFS] \\ simp[GSYM add_stdo_ADELKEY,Abbr`fd`,openFileFS_ADELKEY_nextFD] \\ xsimpl \\ - simp[validFileFD_def]); + simp[validFileFD_def] +QED val file_contents_def = Define ` file_contents fnm fs = implode (THE (ALOOKUP fs.inode_tbl (File (THE (ALOOKUP fs.files fnm)))))` -Theorem file_contents_add_stdout - `STD_streams fs ⇒ - file_contents fnm (add_stdout fs out) = file_contents fnm fs` - (rw[file_contents_def,add_stdo_def,up_stdo_def,fsFFITheory.fsupdate_def] +Theorem file_contents_add_stdout: + STD_streams fs ⇒ + file_contents fnm (add_stdout fs out) = file_contents fnm fs +Proof + rw[file_contents_def,add_stdo_def,up_stdo_def,fsFFITheory.fsupdate_def] \\ CASE_TAC \\ CASE_TAC \\ simp[AFUPDKEY_ALOOKUP] \\ TOP_CASE_TAC \\ rw[] - \\ metis_tac[STD_streams_def,SOME_11,PAIR,FST,fsFFITheory.inode_distinct]); + \\ metis_tac[STD_streams_def,SOME_11,PAIR,FST,fsFFITheory.inode_distinct] +QED val catfiles_string_def = Define` catfiles_string fs fns = @@ -217,15 +225,16 @@ val catfile_string_def = Define ` if inFS_fname fs fnm then file_contents fnm fs else (strlit"")` -Theorem cat1_spec - `!fnm fnmv. +Theorem cat1_spec: + !fnm fnmv. FILENAME fnm fnmv /\ hasFreeFD fs ==> app (p:'ffi ffi_proj) ^(fetch_v "cat1" (get_ml_prog_state())) [fnmv] (STDIO fs) (POSTv u. &UNIT_TYPE () u * - STDIO (add_stdout fs (catfile_string fs fnm)))` - (xcf "cat1" (get_ml_prog_state()) >> + STDIO (add_stdout fs (catfile_string fs fnm))) +Proof + xcf "cat1" (get_ml_prog_state()) >> xhandle `POSTve (\u. SEP_EXISTS content ino. &UNIT_TYPE () u * &(ALOOKUP fs.files fnm = SOME ino) * @@ -244,7 +253,7 @@ Theorem cat1_spec imp_res_tac STD_streams_stdout >> imp_res_tac add_stdo_nil >> xsimpl -); +QED val cat_main = process_topdecs` fun cat_main _ = cat (CommandLine.arguments())`; @@ -252,14 +261,15 @@ val _ = append_prog cat_main; val st = get_ml_prog_state(); -Theorem cat_main_spec - `EVERY (inFS_fname fs) (TL cl) ∧ hasFreeFD fs +Theorem cat_main_spec: + EVERY (inFS_fname fs) (TL cl) ∧ hasFreeFD fs ⇒ app (p:'ffi ffi_proj) ^(fetch_v"cat_main"st) [Conv NONE []] (STDIO fs * COMMANDLINE cl) (POSTv uv. &UNIT_TYPE () uv * (STDIO (add_stdout fs (catfiles_string fs (TL cl))) - * (COMMANDLINE cl)))` - (strip_tac + * (COMMANDLINE cl))) +Proof + strip_tac \\ xcf "cat_main" st \\ xmatch \\ xlet_auto >- (xcon \\ xsimpl) @@ -275,19 +285,22 @@ Theorem cat_main_spec \\ instantiate \\ Cases_on`cl` \\ fs[] \\ simp[MEM_MAP,FILENAME_def,PULL_EXISTS] - \\ fs[validArg_def,EVERY_MEM]); + \\ fs[validArg_def,EVERY_MEM] +QED -Theorem cat_whole_prog_spec - `EVERY (inFS_fname fs) (TL cl) ∧ hasFreeFD fs ⇒ +Theorem cat_whole_prog_spec: + EVERY (inFS_fname fs) (TL cl) ∧ hasFreeFD fs ⇒ whole_prog_spec ^(fetch_v"cat_main"st) cl fs NONE - ((=) (add_stdout fs (catfiles_string fs (TL cl))))` - (disch_then assume_tac + ((=) (add_stdout fs (catfiles_string fs (TL cl)))) +Proof + disch_then assume_tac \\ simp[whole_prog_spec_def] \\ qmatch_goalsub_abbrev_tac`fs1 = _ with numchars := _` \\ qexists_tac`fs1` \\ simp[Abbr`fs1`,GSYM add_stdo_with_numchars,with_same_numchars] \\ match_mp_tac (MP_CANON (MATCH_MP app_wgframe (UNDISCH cat_main_spec))) - \\ xsimpl); + \\ xsimpl +QED val name = "cat_main" val (semantics_thm,prog_tm) = whole_prog_thm st name (UNDISCH cat_whole_prog_spec) diff --git a/examples/compilation/ag32/proofs/helloProofScript.sml b/examples/compilation/ag32/proofs/helloProofScript.sml index 67fdd64172..cef27f5347 100644 --- a/examples/compilation/ag32/proofs/helloProofScript.sml +++ b/examples/compilation/ag32/proofs/helloProofScript.sml @@ -35,15 +35,16 @@ val LENGTH_data = val _ = overload_on("hello_machine_config", ``ag32_machine_config (THE config.ffi_names) (LENGTH code) (LENGTH data)``); -Theorem target_state_rel_hello_start_asm_state - `SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ +Theorem target_state_rel_hello_start_asm_state: + SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ LENGTH inp ≤ stdin_size ∧ is_ag32_init_state (init_memory code data (THE config.ffi_names) (cl,inp)) ms ⇒ ∃n. target_state_rel ag32_target (init_asm_state code data (THE config.ffi_names) (cl,inp)) (FUNPOW Next n ms) ∧ ((FUNPOW Next n ms).io_events = ms.io_events) ∧ (∀x. x ∉ (ag32_startup_addresses) ⇒ - ((FUNPOW Next n ms).MEM x = ms.MEM x))` - (strip_tac + ((FUNPOW Next n ms).MEM x = ms.MEM x)) +Proof + strip_tac \\ drule (GEN_ALL init_asm_state_RTC_asm_step) \\ disch_then drule \\ simp_tac std_ss [] @@ -55,7 +56,8 @@ Theorem target_state_rel_hello_start_asm_state \\ qmatch_goalsub_abbrev_tac`_ ∉ md` \\ disch_then(qspec_then`md`assume_tac) \\ drule (GEN_ALL RTC_asm_step_ag32_target_state_rel_io_events) - \\ simp[EVAL``(ag32_init_asm_state m md).mem_domain``]); + \\ simp[EVAL``(ag32_init_asm_state m md).mem_domain``] +QED val hello_startup_clock_def = new_specification("hello_startup_clock_def",["hello_startup_clock"], @@ -75,14 +77,15 @@ val compile_correct_applied = |> Q.GEN`cbspace` |> Q.SPEC`0` |> Q.GEN`data_sp` |> Q.SPEC`0` -Theorem hello_installed - `SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ +Theorem hello_installed: + SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ LENGTH inp ≤ stdin_size ∧ is_ag32_init_state (init_memory code data (THE config.ffi_names) (cl,inp)) ms0 ⇒ installed code 0 data 0 config.ffi_names (basis_ffi cl fs) (heap_regs ag32_backend_config.stack_conf.reg_names) - (hello_machine_config) (FUNPOW Next (hello_startup_clock ms0 inp cl) ms0)` - (rewrite_tac[ffi_names, THE_DEF] + (hello_machine_config) (FUNPOW Next (hello_startup_clock ms0 inp cl) ms0) +Proof + rewrite_tac[ffi_names, THE_DEF] \\ strip_tac \\ irule ag32_installed \\ drule hello_startup_clock_def @@ -96,7 +99,8 @@ Theorem hello_installed \\ conj_tac >- (EVAL_TAC) \\ asm_exists_tac \\ simp[] - \\ fs[ffi_names]); + \\ fs[ffi_names] +QED val hello_machine_sem = compile_correct_applied @@ -104,11 +108,12 @@ val hello_machine_sem = |> DISCH_ALL |> curry save_thm "hello_machine_sem"; -Theorem hello_extract_writes_stdout - `wfcl cl ⇒ +Theorem hello_extract_writes_stdout: + wfcl cl ⇒ (extract_writes 1 (MAP get_output_io_event (hello_io_events cl (stdin_fs inp))) = - "Hello World!\n")` - (strip_tac + "Hello World!\n") +Proof + strip_tac \\ drule(GEN_ALL(DISCH_ALL hello_output)) \\ disch_then(qspec_then`stdin_fs inp`mp_tac) \\ simp[wfFS_stdin_fs, STD_streams_stdin_fs] @@ -138,10 +143,11 @@ Theorem hello_extract_writes_stdout pop_assum mp_tac \\ rw[] \\ fs[] \\ rw[] \\ pop_assum mp_tac \\ rw[]) - >- rw[]); + >- rw[] +QED -Theorem hello_ag32_next - `SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ wfcl cl ∧ +Theorem hello_ag32_next: + SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ wfcl cl ∧ LENGTH inp ≤ stdin_size ∧ is_ag32_init_state (init_memory code data (THE config.ffi_names) (cl,inp)) ms0 ⇒ @@ -152,8 +158,9 @@ Theorem hello_ag32_next (get_mem_word ms.MEM ms.PC = Encode (Jump (fAdd,0w,Imm 0w))) ∧ outs ≼ MAP get_output_io_event (hello_io_events cl (stdin_fs inp)) ∧ ((ms.R (n2w (hello_machine_config).ptr_reg) = 0w) ⇒ - (outs = MAP get_output_io_event (hello_io_events cl (stdin_fs inp))))` - (strip_tac + (outs = MAP get_output_io_event (hello_io_events cl (stdin_fs inp)))) +Proof + strip_tac \\ drule (GEN_ALL hello_machine_sem) \\ disch_then drule \\ disch_then drule @@ -175,6 +182,7 @@ Theorem hello_ag32_next \\ strip_tac \\ goal_assum(first_assum o mp_then Any mp_tac) \\ goal_assum(first_assum o mp_then Any mp_tac) - \\ metis_tac[]); + \\ metis_tac[] +QED val _ = export_theory(); diff --git a/examples/compilation/ag32/proofs/sortProofScript.sml b/examples/compilation/ag32/proofs/sortProofScript.sml index 8d9367d8b4..02cb92d853 100644 --- a/examples/compilation/ag32/proofs/sortProofScript.sml +++ b/examples/compilation/ag32/proofs/sortProofScript.sml @@ -52,15 +52,16 @@ val LENGTH_data = val _ = overload_on("sort_machine_config", ``ag32_machine_config (THE config.ffi_names) (LENGTH code) (LENGTH data)``); -Theorem target_state_rel_sort_start_asm_state - `SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ +Theorem target_state_rel_sort_start_asm_state: + SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ LENGTH inp ≤ stdin_size ∧ is_ag32_init_state (init_memory code data (THE config.ffi_names) (cl,inp)) ms ⇒ ∃n. target_state_rel ag32_target (init_asm_state code data (THE config.ffi_names) (cl,inp)) (FUNPOW Next n ms) ∧ ((FUNPOW Next n ms).io_events = ms.io_events) ∧ (∀x. x ∉ (ag32_startup_addresses) ⇒ - ((FUNPOW Next n ms).MEM x = ms.MEM x))` - (strip_tac + ((FUNPOW Next n ms).MEM x = ms.MEM x)) +Proof + strip_tac \\ drule (GEN_ALL init_asm_state_RTC_asm_step) \\ disch_then drule \\ simp_tac std_ss [] @@ -72,7 +73,8 @@ Theorem target_state_rel_sort_start_asm_state \\ qmatch_goalsub_abbrev_tac`_ ∉ md` \\ disch_then(qspec_then`md`assume_tac) \\ drule (GEN_ALL RTC_asm_step_ag32_target_state_rel_io_events) - \\ simp[EVAL``(ag32_init_asm_state m md).mem_domain``]); + \\ simp[EVAL``(ag32_init_asm_state m md).mem_domain``] +QED val sort_startup_clock_def = new_specification("sort_startup_clock_def",["sort_startup_clock"], @@ -92,14 +94,15 @@ val compile_correct_applied = |> Q.GEN`cbspace` |> Q.SPEC`0` |> Q.GEN`data_sp` |> Q.SPEC`0` -Theorem sort_installed - `SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ +Theorem sort_installed: + SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ LENGTH inp ≤ stdin_size ∧ is_ag32_init_state (init_memory code data (THE config.ffi_names) (cl,inp)) ms0 ⇒ installed code 0 data 0 config.ffi_names (basis_ffi cl fs) (heap_regs ag32_backend_config.stack_conf.reg_names) - (sort_machine_config) (FUNPOW Next (sort_startup_clock ms0 inp cl) ms0)` - (rewrite_tac[ffi_names, THE_DEF] + (sort_machine_config) (FUNPOW Next (sort_startup_clock ms0 inp cl) ms0) +Proof + rewrite_tac[ffi_names, THE_DEF] \\ strip_tac \\ irule ag32_installed \\ drule sort_startup_clock_def @@ -113,7 +116,8 @@ Theorem sort_installed \\ conj_tac >- (EVAL_TAC) \\ asm_exists_tac \\ simp[] - \\ fs[ffi_names]); + \\ fs[ffi_names] +QED val sort_machine_sem = compile_correct_applied @@ -127,11 +131,12 @@ val sort_machine_sem = |> curry save_thm "sort_machine_sem"; (* TODO: theorems currently in ag32Bootstrap can make this shorter *) -Theorem sort_extract_writes_stdout - `∃output. PERM output (lines_of (implode input)) ∧ SORTED mlstring_le output ∧ +Theorem sort_extract_writes_stdout: + ∃output. PERM output (lines_of (implode input)) ∧ SORTED mlstring_le output ∧ (extract_writes 1 (MAP get_output_io_event (sort_io_events input)) = - explode (concat output))` - (qspec_then`input`strip_assume_tac(GEN_ALL(DISCH_ALL sort_output)) + explode (concat output)) +Proof + qspec_then`input`strip_assume_tac(GEN_ALL(DISCH_ALL sort_output)) \\ asm_exists_tac \\ pop_assum mp_tac \\ DEP_REWRITE_TAC[TextIOProofTheory.add_stdout_fastForwardFD] @@ -164,10 +169,11 @@ Theorem sort_extract_writes_stdout pop_assum mp_tac \\ rw[] \\ fs[] \\ rw[] \\ pop_assum mp_tac \\ rw[]) - >- rw[OPTREL_def]); + >- rw[OPTREL_def] +QED -Theorem sort_ag32_next - `LENGTH inp ≤ stdin_size ∧ +Theorem sort_ag32_next: + LENGTH inp ≤ stdin_size ∧ is_ag32_init_state (init_memory code data (THE config.ffi_names) ([strlit"sort"],inp)) ms0 ⇒ ∃k1. ∀k. k1 ≤ k ⇒ @@ -177,8 +183,9 @@ Theorem sort_ag32_next (get_mem_word ms.MEM ms.PC = Encode (Jump (fAdd,0w,Imm 0w))) ∧ outs ≼ MAP get_output_io_event (sort_io_events inp) ∧ ((ms.R (n2w (sort_machine_config).ptr_reg) = 0w) ⇒ - (outs = MAP get_output_io_event (sort_io_events inp)))` - (strip_tac + (outs = MAP get_output_io_event (sort_io_events inp))) +Proof + strip_tac \\ drule (GEN_ALL sort_machine_sem) \\ disch_then drule \\ strip_tac @@ -198,6 +205,7 @@ Theorem sort_ag32_next \\ qmatch_goalsub_abbrev_tac`FUNPOW Next clk` \\ qexists_tac`clk` \\ simp[] \\ EVAL_TAC - \\ metis_tac[]); + \\ metis_tac[] +QED val _ = export_theory(); diff --git a/examples/compilation/ag32/proofs/wordcountProofScript.sml b/examples/compilation/ag32/proofs/wordcountProofScript.sml index bd3083db72..9db436fc1c 100644 --- a/examples/compilation/ag32/proofs/wordcountProofScript.sml +++ b/examples/compilation/ag32/proofs/wordcountProofScript.sml @@ -14,9 +14,11 @@ val _ = new_theory"wordcountProof"; val is_ag32_init_state_def = ag32_targetTheory.is_ag32_init_state_def; (* TODO: move *) -Theorem int_toString_num - `mlint$toString ((&(n:num)):int) = toString n` - (rw[mlintTheory.num_to_str_def]); +Theorem int_toString_num: + mlint$toString ((&(n:num)):int) = toString n +Proof + rw[mlintTheory.num_to_str_def] +QED (* -- *) val wordcount_stdin_semantics = Q.prove( @@ -60,15 +62,16 @@ val LENGTH_data = val _ = overload_on("wordcount_machine_config", ``ag32_machine_config (THE config.ffi_names) (LENGTH code) (LENGTH data)``); -Theorem target_state_rel_wordcount_start_asm_state - `SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ +Theorem target_state_rel_wordcount_start_asm_state: + SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ LENGTH inp ≤ stdin_size ∧ is_ag32_init_state (init_memory code data (THE config.ffi_names) (cl,inp)) ms ⇒ ∃n. target_state_rel ag32_target (init_asm_state code data (THE config.ffi_names) (cl,inp)) (FUNPOW Next n ms) ∧ ((FUNPOW Next n ms).io_events = ms.io_events) ∧ (∀x. x ∉ (ag32_startup_addresses) ⇒ - ((FUNPOW Next n ms).MEM x = ms.MEM x))` - (strip_tac + ((FUNPOW Next n ms).MEM x = ms.MEM x)) +Proof + strip_tac \\ drule (GEN_ALL init_asm_state_RTC_asm_step) \\ disch_then drule \\ simp_tac std_ss [] @@ -80,7 +83,8 @@ Theorem target_state_rel_wordcount_start_asm_state \\ qmatch_goalsub_abbrev_tac`_ ∉ md` \\ disch_then(qspec_then`md`assume_tac) \\ drule (GEN_ALL RTC_asm_step_ag32_target_state_rel_io_events) - \\ simp[EVAL``(ag32_init_asm_state m md).mem_domain``]); + \\ simp[EVAL``(ag32_init_asm_state m md).mem_domain``] +QED val wordcount_startup_clock_def = new_specification("wordcount_startup_clock_def",["wordcount_startup_clock"], @@ -101,14 +105,15 @@ val wordcount_compile_correct_applied = |> Q.GEN`data_sp` |> Q.SPEC`0` |> curry save_thm "wordcount_compile_correct_applied"; -Theorem wordcount_installed - `SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ +Theorem wordcount_installed: + SUM (MAP strlen cl) + LENGTH cl ≤ cline_size ∧ LENGTH inp ≤ stdin_size ∧ is_ag32_init_state (init_memory code data (THE config.ffi_names) (cl,inp)) ms0 ⇒ installed code 0 data 0 config.ffi_names (basis_ffi cl fs) (heap_regs ag32_backend_config.stack_conf.reg_names) - (wordcount_machine_config) (FUNPOW Next (wordcount_startup_clock ms0 inp cl) ms0)` - (rewrite_tac[ffi_names, THE_DEF] + (wordcount_machine_config) (FUNPOW Next (wordcount_startup_clock ms0 inp cl) ms0) +Proof + rewrite_tac[ffi_names, THE_DEF] \\ strip_tac \\ irule ag32_installed \\ drule wordcount_startup_clock_def @@ -122,7 +127,8 @@ Theorem wordcount_installed \\ conj_tac >- (EVAL_TAC) \\ asm_exists_tac \\ simp[] - \\ fs[ffi_names]); + \\ fs[ffi_names] +QED val wordcount_machine_sem = wordcount_compile_correct_applied @@ -135,12 +141,13 @@ val wordcount_machine_sem = |> DISCH_ALL |> curry save_thm "wordcount_machine_sem"; -Theorem wordcount_extract_writes_stdout - `(extract_writes 1 (MAP get_output_io_event (wordcount_io_events input)) = +Theorem wordcount_extract_writes_stdout: + (extract_writes 1 (MAP get_output_io_event (wordcount_io_events input)) = explode ( concat [toString (LENGTH (TOKENS isSpace input)); strlit" "; - toString (LENGTH (splitlines input)); strlit "\n"]))` - (qspec_then`input`mp_tac(GEN_ALL(DISCH_ALL wordcount_output)) + toString (LENGTH (splitlines input)); strlit "\n"])) +Proof + qspec_then`input`mp_tac(GEN_ALL(DISCH_ALL wordcount_output)) \\ DEP_REWRITE_TAC[TextIOProofTheory.add_stdout_fastForwardFD] \\ simp[STD_streams_stdin_fs] \\ simp[TextIOProofTheory.add_stdo_def] @@ -171,10 +178,11 @@ Theorem wordcount_extract_writes_stdout pop_assum mp_tac \\ rw[] \\ fs[] \\ rw[] \\ pop_assum mp_tac \\ rw[]) - >- rw[OPTREL_def]); + >- rw[OPTREL_def] +QED -Theorem wordcount_ag32_next - `LENGTH inp ≤ stdin_size ∧ +Theorem wordcount_ag32_next: + LENGTH inp ≤ stdin_size ∧ is_ag32_init_state (init_memory code data (THE config.ffi_names) ([strlit"wordcount"],inp)) ms0 ⇒ ∃k1. ∀k. k1 ≤ k ⇒ @@ -184,8 +192,9 @@ Theorem wordcount_ag32_next (get_mem_word ms.MEM ms.PC = Encode (Jump (fAdd,0w,Imm 0w))) ∧ outs ≼ MAP get_output_io_event (wordcount_io_events inp) ∧ ((ms.R (n2w (wordcount_machine_config).ptr_reg) = 0w) ⇒ - (outs = MAP get_output_io_event (wordcount_io_events inp)))` - (strip_tac + (outs = MAP get_output_io_event (wordcount_io_events inp))) +Proof + strip_tac \\ drule (GEN_ALL wordcount_machine_sem) \\ disch_then drule \\ strip_tac @@ -205,6 +214,7 @@ Theorem wordcount_ag32_next \\ qmatch_goalsub_abbrev_tac`FUNPOW Next clk` \\ qexists_tac`clk` \\ simp[] \\ EVAL_TAC - \\ metis_tac[]); + \\ metis_tac[] +QED val _ = export_theory(); diff --git a/examples/diffProgScript.sml b/examples/diffProgScript.sml index 501c8c6d5f..e738390934 100644 --- a/examples/diffProgScript.sml +++ b/examples/diffProgScript.sml @@ -87,8 +87,8 @@ val _ = (append_prog o process_topdecs) ` None => TextIO.output TextIO.stdErr (notfound_string fname2) | Some lines2 => TextIO.print_list (diff_alg2 lines1 lines2)` -Theorem diff'_spec - `FILENAME f1 fv1 ∧ FILENAME f2 fv2 /\ +Theorem diff'_spec: + FILENAME f1 fv1 ∧ FILENAME f2 fv2 /\ hasFreeFD fs ⇒ app (p:'ffi ffi_proj) ^(fetch_v"diff'"(get_ml_prog_state())) @@ -103,8 +103,9 @@ Theorem diff'_spec concat ((diff_alg2 (all_lines fs f1) (all_lines fs f2)))) else add_stderr fs (notfound_string f2) - else add_stderr fs (notfound_string f1)))` - (xcf"diff'"(get_ml_prog_state()) + else add_stderr fs (notfound_string f1))) +Proof + xcf"diff'"(get_ml_prog_state()) \\ xlet_auto_spec(SOME inputLinesFrom_spec) >- xsimpl \\ xmatch \\ reverse(Cases_on `inFS_fname fs f1`) @@ -128,7 +129,8 @@ Theorem diff'_spec \\ PURE_REWRITE_TAC [GSYM CONJ_ASSOC] \\ reverse strip_tac >- (EVAL_TAC \\ rw[]) \\ xlet_auto >- xsimpl - \\ xapp \\ rw[]); + \\ xapp \\ rw[] +QED val _ = (append_prog o process_topdecs) ` fun diff u = @@ -150,15 +152,16 @@ val diff_sem_def = Define` else add_stderr fs (notfound_string (EL 1 cl)) else add_stderr fs usage_string`; -Theorem diff_spec - `hasFreeFD fs +Theorem diff_spec: + hasFreeFD fs ⇒ app (p:'ffi ffi_proj) ^(fetch_v"diff"(get_ml_prog_state())) [Conv NONE []] (STDIO fs * COMMANDLINE cl) (POSTv uv. &UNIT_TYPE () uv * - STDIO (diff_sem cl fs) * (COMMANDLINE cl))` - (once_rewrite_tac[diff_sem_def] + STDIO (diff_sem cl fs) * (COMMANDLINE cl)) +Proof + once_rewrite_tac[diff_sem_def] \\ strip_tac \\ xcf "diff" (get_ml_prog_state()) \\ xlet_auto >- (xcon \\ xsimpl) \\ reverse(Cases_on`wfcl cl`) >- (fs[COMMANDLINE_def] \\ xpull) @@ -182,20 +185,23 @@ Theorem diff_spec \\ CONV_TAC SWAP_EXISTS_CONV \\ qexists_tac `h''` \\ CONV_TAC SWAP_EXISTS_CONV \\ qexists_tac `h'` \\ xsimpl \\ fs[FILENAME_def] - \\ fs[validArg_def,EVERY_MEM]); + \\ fs[validArg_def,EVERY_MEM] +QED val st = get_ml_prog_state(); -Theorem diff_whole_prog_spec - `hasFreeFD fs ⇒ - whole_prog_spec ^(fetch_v"diff"st) cl fs NONE ((=) (diff_sem cl fs))` - (rw[whole_prog_spec_def] +Theorem diff_whole_prog_spec: + hasFreeFD fs ⇒ + whole_prog_spec ^(fetch_v"diff"st) cl fs NONE ((=) (diff_sem cl fs)) +Proof + rw[whole_prog_spec_def] \\ qexists_tac`diff_sem cl fs` \\ reverse conj_tac >- ( rw[diff_sem_def,GSYM add_stdo_with_numchars,with_same_numchars] ) \\ simp [SEP_CLAUSES] \\ match_mp_tac (MP_CANON (DISCH_ALL (MATCH_MP app_wgframe (UNDISCH diff_spec)))) - \\ xsimpl); + \\ xsimpl +QED val name = "diff" val (sem_thm,prog_tm) = whole_prog_thm st name (UNDISCH diff_whole_prog_spec) diff --git a/examples/diffScript.sml b/examples/diffScript.sml index 37f9542559..58b665ab47 100644 --- a/examples/diffScript.sml +++ b/examples/diffScript.sml @@ -80,8 +80,8 @@ val diff_alg2_def = Define ` in diff_with_lcs (dynamic_lcs l l') l prefix_length l' prefix_length` -Theorem diff_alg2_thm ` - diff_alg2 l l' = +Theorem diff_alg2_thm: + diff_alg2 l l' = let prefix_length = LENGTH(longest_common_prefix l l'); l = DROP prefix_length l; l' = DROP prefix_length l'; @@ -91,27 +91,35 @@ Theorem diff_alg2_thm ` l = TAKE (llength - suffix_length) l; l' = TAKE (l'length - suffix_length) l' in - diff_with_lcs (dynamic_lcs l l') l prefix_length l' prefix_length` - (PURE_ONCE_REWRITE_TAC [diff_alg2_def] + diff_with_lcs (dynamic_lcs l l') l prefix_length l' prefix_length +Proof + PURE_ONCE_REWRITE_TAC [diff_alg2_def] >> ntac 5 (PURE_ONCE_REWRITE_TAC [LET_THM]) >> ntac 5 (Ho_Rewrite.PURE_ONCE_REWRITE_TAC [BETA_THM]) >> PURE_ONCE_REWRITE_TAC [longest_common_suffix_length_if] - >> REFL_TAC); + >> REFL_TAC +QED (* Diff algorithm properties *) -Theorem diff_with_lcs_refl - `!n n'. diff_with_lcs l l n l n' = []` - (Induct_on `l` >> rw[diff_with_lcs_def,SPLITP]); - -Theorem diff_alg_refl - `diff_alg l l = []` - (rw[diff_alg_def,lcs_refl',diff_with_lcs_refl,optimised_lcs_refl]); - -Theorem diff_alg2_refl - `diff_alg2 l l = []` - (rw[diff_alg2_thm,lcs_refl',diff_with_lcs_refl,dynamic_lcs_refl, - longest_common_prefix_refl]); +Theorem diff_with_lcs_refl: + !n n'. diff_with_lcs l l n l n' = [] +Proof + Induct_on `l` >> rw[diff_with_lcs_def,SPLITP] +QED + +Theorem diff_alg_refl: + diff_alg l l = [] +Proof + rw[diff_alg_def,lcs_refl',diff_with_lcs_refl,optimised_lcs_refl] +QED + +Theorem diff_alg2_refl: + diff_alg2 l l = [] +Proof + rw[diff_alg2_thm,lcs_refl',diff_with_lcs_refl,dynamic_lcs_refl, + longest_common_prefix_refl] +QED (* Patch algorithm definition *) @@ -231,20 +239,27 @@ val patch_alg_offs_def = Define ` (* Patch cancels diff *) -Theorem string_concat_empty -`!s. s ^ strlit "" = s /\ strlit "" ^ s = s` (fs[strcat_thm,implode_explode]); - -Theorem tokens_append_strlit - `∀P s1 x s2. - P x ⇒ tokens P (s1 ^ strlit [x] ^ s2) = tokens P s1 ++ tokens P s2` - (rpt strip_tac >> drule0 tokens_append >> fs[str_def,implode_def]); - -Theorem tokens_append_right_strlit - `∀P s x. - P x ⇒ tokens P (s ^ strlit [x]) = tokens P s` - (rpt strip_tac >> drule0 tokens_append_strlit +Theorem string_concat_empty: + !s. s ^ strlit "" = s /\ strlit "" ^ s = s +Proof +fs[strcat_thm,implode_explode] +QED + +Theorem tokens_append_strlit: + ∀P s1 x s2. + P x ⇒ tokens P (s1 ^ strlit [x] ^ s2) = tokens P s1 ++ tokens P s2 +Proof + rpt strip_tac >> drule0 tokens_append >> fs[str_def,implode_def] +QED + +Theorem tokens_append_right_strlit: + ∀P s x. + P x ⇒ tokens P (s ^ strlit [x]) = tokens P s +Proof + rpt strip_tac >> drule0 tokens_append_strlit >> disch_then (qspecl_then [`s`,`strlit ""`] assume_tac) - >> fs[string_concat_empty,tokens_def,tokens_aux_def]); + >> fs[string_concat_empty,tokens_def,tokens_aux_def] +QED val zero_pad_acc = Q.prove( `!n acc. STRCAT (zero_pad n "") acc = (zero_pad n acc)`, @@ -274,9 +289,10 @@ val toChars_acc = Q.prove( (assume_tac o GSYM)) >> fs[maxSmall_DEC_def]); -Theorem one_to_ten - `!P. P 0 /\ P 1 /\ P 2 /\ P 3 /\ P 4 /\ P 5 /\ P 6 /\ P 7 /\ P 8 /\ P 9 /\ (!n. (n:num) >= 10 ==> P n) ==> !n. P n` - (rpt strip_tac >> Cases_on `n` >> fs[] +Theorem one_to_ten: + !P. P 0 /\ P 1 /\ P 2 /\ P 3 /\ P 4 /\ P 5 /\ P 6 /\ P 7 /\ P 8 /\ P 9 /\ (!n. (n:num) >= 10 ==> P n) ==> !n. P n +Proof + rpt strip_tac >> Cases_on `n` >> fs[] >> qmatch_goalsub_rename_tac `SUC n` >> Cases_on `n` >> fs[] >> qmatch_goalsub_rename_tac `SUC(SUC n)` @@ -294,7 +310,8 @@ Theorem one_to_ten >> qmatch_goalsub_rename_tac `SUC(SUC(SUC(SUC(SUC(SUC(SUC(SUC n)))))))` >> Cases_on `n` >> fs[] >> qmatch_goalsub_rename_tac `SUC(SUC(SUC(SUC(SUC(SUC(SUC(SUC(SUC n))))))))` - >> Cases_on `n` >> fs[]); + >> Cases_on `n` >> fs[] +QED val SPLITP_HEX = Q.prove( `!n. n < 10 ==> SPLITP (λx. x = #"a" ∨ x = #"d" ∨ x = #"c" ∨ x = #"\n") @@ -373,9 +390,11 @@ val strsub_strcat = Induct >> simp[strcat_thm,implode_def,strsub_def,EL_APPEND_EQN] \\ gen_tac \\ Cases \\ simp[]); -Theorem strsub_str - `strsub (str c) 0 = c` - (rw[str_def,implode_def,strsub_def]); +Theorem strsub_str: + strsub (str c) 0 = c +Proof + rw[str_def,implode_def,strsub_def] +QED val acd_simps = Q.prove(`l ≠ [] ==> (acd [] l = #"a" /\ acd l [] = #"d")`, @@ -389,21 +408,25 @@ val HEX_isDigit = Q.prove(`!n. n < 10 ==> isDigit(HEX n)`, recInduct one_to_ten >> fs[isDigit_def]); (* TODO: move at least these (and probably others in this file) *) -Theorem toString_isDigit - `!n. EVERY isDigit (toString(n:num))` - (recInduct COMPLETE_INDUCTION +Theorem toString_isDigit: + !n. EVERY isDigit (toString(n:num)) +Proof + recInduct COMPLETE_INDUCTION >> rpt strip_tac >> fs[ASCIInumbersTheory.num_to_dec_string_def] >> fs[ASCIInumbersTheory.n2s_def] >> PURE_ONCE_REWRITE_TAC[numposrepTheory.n2l_def] - >> rw[] >> fs[HEX_isDigit]); + >> rw[] >> fs[HEX_isDigit] +QED (* -- *) (*`!n. explode (toString n) = toString n`*) -Theorem int_abs_toString_num -`!n. toString (&n) = toString n` - (recInduct COMPLETE_INDUCTION >> strip_tac - >> fs[integer_wordTheory.toString_def]); +Theorem int_abs_toString_num: + !n. toString (&n) = toString n +Proof + recInduct COMPLETE_INDUCTION >> strip_tac + >> fs[integer_wordTheory.toString_def] +QED val substring_adhoc_simps = Q.prove(`!h. (substring (strlit "> " ^ h) 0 2 = strlit "> ") @@ -419,9 +442,11 @@ val depatch_lines_strcat_cancel = Q.prove( `!r. depatch_lines (MAP (strcat (strlit "> ")) r) = SOME r`, Induct >> fs[depatch_lines_def,depatch_line_def,strlen_strcat,substring_adhoc_simps]) -Theorem depatch_lines_diff_add_prefix_cancel - `depatch_lines (diff_add_prefix l (strlit "> ")) = SOME l` - (fs[diff_add_prefix_def,depatch_lines_strcat_cancel]); +Theorem depatch_lines_diff_add_prefix_cancel: + depatch_lines (diff_add_prefix l (strlit "> ")) = SOME l +Proof + fs[diff_add_prefix_def,depatch_lines_strcat_cancel] +QED val patch_aux_nil = Q.prove(`patch_aux [] file remfl n = SOME file`,fs[patch_aux_def]); @@ -433,12 +458,14 @@ val line_numbers_not_empty = Q.prove( >> PURE_ONCE_REWRITE_TAC[simple_toChars_def] >> rw[Once zero_pad_def,padLen_DEC_def] >> fs[Once(GSYM simple_toChars_acc),Once(GSYM zero_pad_acc),Once(GSYM toChars_acc)]); -Theorem tokens_eq_sing - `!s f. EVERY ($~ o f) (explode s) /\ s <> strlit "" ==> tokens f s = [s]` - (Cases +Theorem tokens_eq_sing: + !s f. EVERY ($~ o f) (explode s) /\ s <> strlit "" ==> tokens f s = [s] +Proof + Cases \\ fs[TOKENS_eq_tokens_sym,toString_thm,explode_implode,implode_def] \\ Cases_on `s'` \\ fs [TOKENS_def] \\ rw [] - \\ fs [o_DEF,SPLITP_EVERY,TOKENS_def]) + \\ fs [o_DEF,SPLITP_EVERY,TOKENS_def] +QED val tokens_toString_comma = Q.prove(`tokens ($= #",") (toString (n:num)) = [toString n]`, @@ -466,20 +493,22 @@ val tokens_comma_lemma = Q.prove( \\ rw [line_numbers_def,num_to_str_thm,implode_def] \\ fs [strcat_def,concat_def]); -Theorem parse_header_cancel -`l <> [] \/ l' <> [] ==> +Theorem parse_header_cancel: + l <> [] \/ l' <> [] ==> (parse_patch_header(diff_single_header l n l' n') = SOME(n,if LENGTH l <= 1 then NONE else SOME(n+LENGTH l), if l = [] then #"a" else if l' = [] then #"d" else #"c", - n',if LENGTH l' <= 1 then NONE else SOME(n'+LENGTH l')))` - (rw[diff_single_header_def,parse_patch_header_def, + n',if LENGTH l' <= 1 then NONE else SOME(n'+LENGTH l'))) +Proof + rw[diff_single_header_def,parse_patch_header_def, option_case_eq,list_case_eq,PULL_EXISTS, strsub_strcat,tokens_append_right_strlit,GSYM str_def, tokens_append,acd_simps,acd_more_simps,tokens_comma_lemma, tokens_comma_lemma] \\ rw[line_numbers_def,tokens_toString_comma, fromNatString_toString, - GSYM str_def,tokens_append,strsub_str]); + GSYM str_def,tokens_append,strsub_str] +QED val patch_aux_cancel_base_case = Q.prove( `patch_aux (diff_with_lcs [] r n r' m) r (LENGTH r) n = SOME r'`, @@ -495,26 +524,36 @@ val patch_aux_cancel_base_case = Q.prove( >> `LENGTH r = 1` by (Cases_on `LENGTH r` >> fs[]) >> fs[depatch_lines_strcat_cancel]); -Theorem SPLITP_NIL_FST - `∀ls P r. SPLITP P ls = ([],r) ⇔ (r = ls ∧ ((ls <> []) ==> P(HD ls)))` - (Cases >> rpt strip_tac >> fs[SPLITP,EQ_IMP_THM] >> IF_CASES_TAC - >> strip_tac >> fs[]); - -Theorem diff_add_prefix_length -`!l s. LENGTH (diff_add_prefix l s) = LENGTH l` -(fs[diff_add_prefix_def]); - -Theorem diff_add_prefix_TAKE - `!l n s. TAKE n (diff_add_prefix l s) = diff_add_prefix (TAKE n l) s` - (fs[diff_add_prefix_def,MAP_TAKE]); - -Theorem diff_add_prefix_DROP - `!l n s. DROP n (diff_add_prefix l s) = diff_add_prefix (DROP n l) s` - (fs[diff_add_prefix_def,MAP_DROP]); - -Theorem diff_add_prefix_nil - `!s. (diff_add_prefix [] s) = []` - (fs[diff_add_prefix_def]); +Theorem SPLITP_NIL_FST: + ∀ls P r. SPLITP P ls = ([],r) ⇔ (r = ls ∧ ((ls <> []) ==> P(HD ls))) +Proof + Cases >> rpt strip_tac >> fs[SPLITP,EQ_IMP_THM] >> IF_CASES_TAC + >> strip_tac >> fs[] +QED + +Theorem diff_add_prefix_length: + !l s. LENGTH (diff_add_prefix l s) = LENGTH l +Proof +fs[diff_add_prefix_def] +QED + +Theorem diff_add_prefix_TAKE: + !l n s. TAKE n (diff_add_prefix l s) = diff_add_prefix (TAKE n l) s +Proof + fs[diff_add_prefix_def,MAP_TAKE] +QED + +Theorem diff_add_prefix_DROP: + !l n s. DROP n (diff_add_prefix l s) = diff_add_prefix (DROP n l) s +Proof + fs[diff_add_prefix_def,MAP_DROP] +QED + +Theorem diff_add_prefix_nil: + !s. (diff_add_prefix [] s) = [] +Proof + fs[diff_add_prefix_def] +QED val ONE_MINUS_SUCC = Q.prove(`1 - SUC x = 0`,intLib.COOPER_TAC); @@ -579,11 +618,12 @@ val minus_add_too_large = Q.prove(`a - ((a:num) + n) = 0`,intLib.COOPER_TAC); val minus_add_too_large' = Q.prove(`(a + 1) - ((a:num) + 2) = 0`,intLib.COOPER_TAC); -Theorem patch_aux_diff_cancel -`!l r n r' m. +Theorem patch_aux_diff_cancel: + !l r n r' m. common_subsequence l r r' ==> -(patch_aux (diff_with_lcs l r n r' m) r (LENGTH r) n = SOME r')` -(Induct +(patch_aux (diff_with_lcs l r n r' m) r (LENGTH r) n = SOME r') +Proof +Induct >> rpt strip_tac >-fs[patch_aux_cancel_base_case] >> fs[diff_with_lcs_def,diff_single_def, @@ -647,14 +687,17 @@ common_subsequence l r r' ==> minus_add_too_large,TAKE_APPEND,minus_add_too_large',ONE_MINUS_SUCC] >> drule0 patch_aux_keep_init_cons >> disch_then(qspecl_then [`n + LENGTH ll`,`h`,`m + LENGTH l'l`] mp_tac) - >> fs[ADD1,list_length_1_lemma])); + >> fs[ADD1,list_length_1_lemma]) +QED -Theorem patch_diff_cancel - `patch_alg (diff_alg l r) l = SOME r` - (fs[patch_alg_def,diff_alg_def] +Theorem patch_diff_cancel: + patch_alg (diff_alg l r) l = SOME r +Proof + fs[patch_alg_def,diff_alg_def] >> mp_tac (GEN_ALL (INST_TYPE [alpha|->``:mlstring``] optimised_lcs_correct)) >> disch_then (qspecl_then [`r`,`l`] assume_tac) - >> fs[patch_aux_diff_cancel,lcs_def]); + >> fs[patch_aux_diff_cancel,lcs_def] +QED val headers_within_def = Define ` headers_within n m l = @@ -664,48 +707,66 @@ val headers_within_def = Define ` (IS_SOME m' ==> (n <= THE m' /\ THE m' <= m))))) (MAP parse_patch_header l)` -Theorem headers_within_IMP - `headers_within n m (h::t) /\ parse_patch_header h = SOME(q,NONE,c,tup) - ==> n <= q /\ q <= m /\ ((c= #"d" \/ c = #"c") ==> q+1 <= m)` - (rpt strip_tac >> fs[headers_within_def] >> rfs[pairTheory.ELIM_UNCURRY]) - -Theorem headers_within_IMP_SOME - `headers_within n m (h::t) /\ parse_patch_header h = SOME(q,SOME q',c,tup) - ==> n <= q /\ q <= m /\ n <= q' /\ q' <= m` - (rpt strip_tac >> fs[headers_within_def] >> rfs[pairTheory.ELIM_UNCURRY]) - -Theorem headers_within_grow - `headers_within n' m' l /\ n <= n' /\ m' <= m ==> headers_within n m l` - (Induct_on `l` >> rpt strip_tac >> fs[headers_within_def] +Theorem headers_within_IMP: + headers_within n m (h::t) /\ parse_patch_header h = SOME(q,NONE,c,tup) + ==> n <= q /\ q <= m /\ ((c= #"d" \/ c = #"c") ==> q+1 <= m) +Proof + rpt strip_tac >> fs[headers_within_def] >> rfs[pairTheory.ELIM_UNCURRY] +QED + +Theorem headers_within_IMP_SOME: + headers_within n m (h::t) /\ parse_patch_header h = SOME(q,SOME q',c,tup) + ==> n <= q /\ q <= m /\ n <= q' /\ q' <= m +Proof + rpt strip_tac >> fs[headers_within_def] >> rfs[pairTheory.ELIM_UNCURRY] +QED + +Theorem headers_within_grow: + headers_within n' m' l /\ n <= n' /\ m' <= m ==> headers_within n m l +Proof + Induct_on `l` >> rpt strip_tac >> fs[headers_within_def] >> Cases_on `parse_patch_header h` >> fs[pairTheory.ELIM_UNCURRY] - >> rw[] >> fs[]); + >> rw[] >> fs[] +QED -Theorem headers_within_append - `headers_within n m (l++l') = (headers_within n m l /\ headers_within n m l')` - (simp[headers_within_def]); +Theorem headers_within_append: + headers_within n m (l++l') = (headers_within n m l /\ headers_within n m l') +Proof + simp[headers_within_def] +QED -Theorem headers_within_dest_cons - `headers_within n m (e::l') ==> headers_within n m l'` - (simp[headers_within_def]); +Theorem headers_within_dest_cons: + headers_within n m (e::l') ==> headers_within n m l' +Proof + simp[headers_within_def] +QED (* todo: move to richlist? *) -Theorem EVERY_DROP_T - `!P l m. EVERY P l ==> EVERY P (DROP m l)` - (Induct_on `l` >> rw[DROP_def]); - -Theorem headers_within_drop - `headers_within n m (l) ==> headers_within n m (DROP x l)` - (simp[headers_within_def,MAP_DROP,EVERY_DROP_T]); - -Theorem fromString_gt - `fromString (implode (STRING #">" x)) = NONE /\ - fromString (implode (STRING #"<" x)) = NONE` - (rw [] \\ match_mp_tac fromString_EQ_NONE \\ EVAL_TAC); - -Theorem fromNatString_gt - `fromNatString (implode (STRING #">" x)) = NONE /\ - fromNatString (implode (STRING #"<" x)) = NONE` - (rw [fromNatString_def,fromString_gt]); +Theorem EVERY_DROP_T: + !P l m. EVERY P l ==> EVERY P (DROP m l) +Proof + Induct_on `l` >> rw[DROP_def] +QED + +Theorem headers_within_drop: + headers_within n m (l) ==> headers_within n m (DROP x l) +Proof + simp[headers_within_def,MAP_DROP,EVERY_DROP_T] +QED + +Theorem fromString_gt: + fromString (implode (STRING #">" x)) = NONE /\ + fromString (implode (STRING #"<" x)) = NONE +Proof + rw [] \\ match_mp_tac fromString_EQ_NONE \\ EVAL_TAC +QED + +Theorem fromNatString_gt: + fromNatString (implode (STRING #">" x)) = NONE /\ + fromNatString (implode (STRING #"<" x)) = NONE +Proof + rw [fromNatString_def,fromString_gt] +QED val parse_nonheader_lemma = Q.prove( `!f r. EVERY (OPTION_ALL f) (MAP parse_patch_header (diff_add_prefix r (strlit "> ")))`, @@ -743,10 +804,11 @@ val parse_nonheader_lemma3 = Q.prove( >> fs[tokens_append_strlit,TOKENS_eq_tokens_sym] >> fs[TOKENS_def,pairTheory.ELIM_UNCURRY,SPLITP] >> rveq); -Theorem diff_with_lcs_headers_within - `!l r n r' m. common_subsequence l r r' ==> - headers_within n (n + LENGTH r) (diff_with_lcs l r n r' m)` - (Induct +Theorem diff_with_lcs_headers_within: + !l r n r' m. common_subsequence l r r' ==> + headers_within n (n + LENGTH r) (diff_with_lcs l r n r' m) +Proof + Induct >> rpt strip_tac >- (fs[diff_with_lcs_def,headers_within_def,diff_single_def] >> rw[] >> fs[parse_header_cancel] @@ -786,7 +848,8 @@ Theorem diff_with_lcs_headers_within >> drule0(GEN_ALL headers_within_grow) >> disch_then match_mp_tac >> Q.ISPECL_THEN [`($= h)`,`r`] assume_tac (GEN_ALL (GSYM SPLITP_LENGTH)) - >> fs[]); + >> fs[] +QED val highly_specific_implication = Q.prove( `¬(q < n + 1) /\ ¬(m < q − n) ==> n + (SUC m) - (q + 1) = (n + m - q)`, @@ -796,16 +859,18 @@ val highly_specific_implication2 = Q.prove( `¬(SUC m < (q+1) − n) ==> n + (SUC m) - (q + 1) = (n + m - q)`, fs[]); -Theorem headers_within_cons -`headers_within (n+1) m p1 /\ m >= n+1 ==> - patch_alg_offs n p1 (e::l) = OPTION_MAP (CONS e) (patch_alg_offs (n+1) p1 l)` - (Cases_on `p1` >> rpt strip_tac +Theorem headers_within_cons: + headers_within (n+1) m p1 /\ m >= n+1 ==> + patch_alg_offs n p1 (e::l) = OPTION_MAP (CONS e) (patch_alg_offs (n+1) p1 l) +Proof + Cases_on `p1` >> rpt strip_tac >> fs[patch_alg_offs_def,patch_aux_def] >> every_case_tac >> fs[headers_within_def] >> rfs[] >> TRY(drule0(GEN_ALL highly_specific_implication) >> disch_then drule0 >> disch_then (fn x => fs[x])) >> TRY(drule0(GEN_ALL highly_specific_implication2) >> disch_then (fn x => fs[x])) - >> fs[GSYM ADD1]); + >> fs[GSYM ADD1] +QED val IS_SUFFIX_induct_aux = Q.prove(`!P l. P [] /\ (!h l. (!sl. IS_SUFFIX l sl ==> P sl) ==> P (h::l)) ==> (!sl. IS_SUFFIX l sl ==> P sl)`, @@ -820,19 +885,24 @@ val IS_SUFFIX_induct_aux = >> FULL_SIMP_TAC std_ss [GSYM SNOC_APPEND, IS_PREFIX_SNOC] >> fs[]) -Theorem IS_SUFFIX_induct - `!P. P [] /\ (!h l. (!sl. IS_SUFFIX l sl ==> P sl) ==> P (h::l)) ==> !l. P l` - (metis_tac[IS_SUFFIX_induct_aux,IS_SUFFIX_REFL]) - -Theorem IS_SUFFIX_DROP - `!l n. IS_SUFFIX l (DROP n l)` - (Induct >> rpt strip_tac >> rw[DROP_def] - >> metis_tac[IS_SUFFIX_CONS]); - -Theorem headers_within_snoc -`!p1 n l m e. headers_within m (n + LENGTH l) p1 /\ m <= (n + LENGTH l) ==> - patch_alg_offs n p1 (SNOC e l) = OPTION_MAP (SNOC e) (patch_alg_offs n p1 l)` - (ho_match_mp_tac IS_SUFFIX_induct +Theorem IS_SUFFIX_induct: + !P. P [] /\ (!h l. (!sl. IS_SUFFIX l sl ==> P sl) ==> P (h::l)) ==> !l. P l +Proof + metis_tac[IS_SUFFIX_induct_aux,IS_SUFFIX_REFL] +QED + +Theorem IS_SUFFIX_DROP: + !l n. IS_SUFFIX l (DROP n l) +Proof + Induct >> rpt strip_tac >> rw[DROP_def] + >> metis_tac[IS_SUFFIX_CONS] +QED + +Theorem headers_within_snoc: + !p1 n l m e. headers_within m (n + LENGTH l) p1 /\ m <= (n + LENGTH l) ==> + patch_alg_offs n p1 (SNOC e l) = OPTION_MAP (SNOC e) (patch_alg_offs n p1 l) +Proof + ho_match_mp_tac IS_SUFFIX_induct >> rpt strip_tac >> fs[patch_alg_offs_def,patch_aux_def] >> every_case_tac >> fs[] >> rfs[] @@ -953,12 +1023,14 @@ Theorem headers_within_snoc >> `q - n <= LENGTH l` by intLib.COOPER_TAC >> simp[TAKE_APPEND,SNOC_APPEND,DROP_APPEND] >> simp[DROP_def] - >> fs[SNOC_APPEND,DROP_APPEND,DROP_def] >> NO_TAC)); - -Theorem headers_within_append1 -`!l' l. headers_within (n+LENGTH l') m p1 /\ m >= n+LENGTH l' ==> - patch_alg_offs n p1 (l' ++ l) = OPTION_MAP (APPEND l') (patch_alg_offs (n+LENGTH l') p1 l)` - (ho_match_mp_tac SNOC_INDUCT + >> fs[SNOC_APPEND,DROP_APPEND,DROP_def] >> NO_TAC) +QED + +Theorem headers_within_append1: + !l' l. headers_within (n+LENGTH l') m p1 /\ m >= n+LENGTH l' ==> + patch_alg_offs n p1 (l' ++ l) = OPTION_MAP (APPEND l') (patch_alg_offs (n+LENGTH l') p1 l) +Proof + ho_match_mp_tac SNOC_INDUCT >> rpt strip_tac >- (fs[] >> qmatch_goalsub_abbrev_tac `OPTION_MAP _ a1` >> Cases_on `a1` >> fs[]) >> rpt strip_tac @@ -972,20 +1044,24 @@ Theorem headers_within_append1 >> FULL_SIMP_TAC std_ss [ADD_ASSOC] >> pop_assum kall_tac >> drule0(GEN_ALL headers_within_cons) - >> fs[]); + >> fs[] +QED -Theorem headers_within_append1' -`!l' l. headers_within (LENGTH l) m p1 /\ m >= LENGTH l+LENGTH l' ==> - patch_alg p1 (l ++ l') = OPTION_MAP (APPEND l) (patch_alg_offs (LENGTH l) p1 l')` - (rpt strip_tac +Theorem headers_within_append1': + !l' l. headers_within (LENGTH l) m p1 /\ m >= LENGTH l+LENGTH l' ==> + patch_alg p1 (l ++ l') = OPTION_MAP (APPEND l) (patch_alg_offs (LENGTH l) p1 l') +Proof + rpt strip_tac >> assume_tac (GEN_ALL headers_within_append1) >> pop_assum (qspecl_then [`p1`,`0`,`m`,`l`,`l'`] assume_tac) - >> fs[patch_alg_def,patch_alg_offs_def]); - -Theorem headers_within_append2 -`!l' l. headers_within m (n + LENGTH l) p1 /\ m <= n+LENGTH l ==> - patch_alg_offs n p1 (l ++ l') = OPTION_MAP (combin$C APPEND l') (patch_alg_offs n p1 l)` - (Induct + >> fs[patch_alg_def,patch_alg_offs_def] +QED + +Theorem headers_within_append2: + !l' l. headers_within m (n + LENGTH l) p1 /\ m <= n+LENGTH l ==> + patch_alg_offs n p1 (l ++ l') = OPTION_MAP (combin$C APPEND l') (patch_alg_offs n p1 l) +Proof + Induct >> rpt strip_tac >- (fs[] >> qmatch_goalsub_abbrev_tac `OPTION_MAP _ a1` >> Cases_on `a1` >> fs[]) >> SIMP_TAC bool_ss [Once CONS_APPEND,APPEND_ASSOC] @@ -1001,14 +1077,16 @@ Theorem headers_within_append2 >> FULL_SIMP_TAC std_ss [ADD_ASSOC] >> fs[GSYM SNOC_APPEND] >> drule0(GEN_ALL headers_within_snoc) - >> fs[]); + >> fs[] +QED -Theorem longest_common_sandwich - `!l r. l = longest_common_prefix l r ++ +Theorem longest_common_sandwich: + !l r. l = longest_common_prefix l r ++ let l' = DROP (LENGTH(longest_common_prefix l r)) l; r' = DROP (LENGTH(longest_common_prefix l r)) r in - TAKE (LENGTH l' - LENGTH(longest_common_suffix l' r')) l' ++ longest_common_suffix l' r'` - (rpt strip_tac >> fs[] + TAKE (LENGTH l' - LENGTH(longest_common_suffix l' r')) l' ++ longest_common_suffix l' r' +Proof + rpt strip_tac >> fs[] >> qspecl_then [`l`,`r`] assume_tac longest_prefix_is_prefix >> fs[] >> imp_res_tac IS_PREFIX_APPEND @@ -1018,24 +1096,28 @@ Theorem longest_common_sandwich >> fs[] >> imp_res_tac IS_SUFFIX_APPEND >> qpat_abbrev_tac `a2 = longest_common_suffix _ _ ` - >> fs[TAKE_APPEND]); + >> fs[TAKE_APPEND] +QED -Theorem LENGTH_suffix_prefix - `!l r. LENGTH l >= LENGTH (longest_common_prefix l r) +Theorem LENGTH_suffix_prefix: + !l r. LENGTH l >= LENGTH (longest_common_prefix l r) + LENGTH (longest_common_suffix (DROP (LENGTH (longest_common_prefix l r)) l) - (DROP (LENGTH (longest_common_prefix l r)) r))` - (rpt strip_tac + (DROP (LENGTH (longest_common_prefix l r)) r)) +Proof + rpt strip_tac >> PURE_ONCE_REWRITE_TAC [Once longest_common_sandwich] - >> rw[SUB_RIGHT_ADD,SUB_LEFT_ADD]); + >> rw[SUB_RIGHT_ADD,SUB_LEFT_ADD] +QED -Theorem longest_common_sandwich' - `!l r. r = longest_common_prefix l r ++ +Theorem longest_common_sandwich': + !l r. r = longest_common_prefix l r ++ let l' = DROP (LENGTH(longest_common_prefix l r)) l; r' = DROP (LENGTH(longest_common_prefix l r)) r in - TAKE (LENGTH r' - LENGTH(longest_common_suffix l' r')) r' ++ longest_common_suffix l' r'` - (rpt strip_tac >> fs[] + TAKE (LENGTH r' - LENGTH(longest_common_suffix l' r')) r' ++ longest_common_suffix l' r' +Proof + rpt strip_tac >> fs[] >> qspecl_then [`l`,`r`] assume_tac longest_prefix_is_prefix >> fs[] >> imp_res_tac IS_PREFIX_APPEND @@ -1045,21 +1127,25 @@ Theorem longest_common_sandwich' >> fs[] >> imp_res_tac IS_SUFFIX_APPEND >> qpat_abbrev_tac `a2 = longest_common_suffix _ _ ` - >> fs[TAKE_APPEND]); + >> fs[TAKE_APPEND] +QED -Theorem LENGTH_suffix_prefix' - `!l r. LENGTH r >= LENGTH (longest_common_prefix l r) +Theorem LENGTH_suffix_prefix': + !l r. LENGTH r >= LENGTH (longest_common_prefix l r) + LENGTH (longest_common_suffix (DROP (LENGTH (longest_common_prefix l r)) l) - (DROP (LENGTH (longest_common_prefix l r)) r))` - (rpt strip_tac + (DROP (LENGTH (longest_common_prefix l r)) r)) +Proof + rpt strip_tac >> PURE_ONCE_REWRITE_TAC [Once longest_common_sandwich'] - >> rw[SUB_RIGHT_ADD,SUB_LEFT_ADD]); + >> rw[SUB_RIGHT_ADD,SUB_LEFT_ADD] +QED -Theorem patch_diff2_cancel - `patch_alg (diff_alg2 l r) l = SOME r` - (fs[diff_alg2_thm] +Theorem patch_diff2_cancel: + patch_alg (diff_alg2 l r) l = SOME r +Proof + fs[diff_alg2_thm] >> fs[patch_aux_def] >> qmatch_goalsub_abbrev_tac `TAKE (LENGTH _ - (a1 + a2)) _` >> qpat_abbrev_tac `a3 = DROP a1 l` @@ -1102,7 +1188,8 @@ Theorem patch_diff2_cancel >> unabbrev_all_tac >> Q.ISPECL_THEN [`l`,`r`] mp_tac (longest_common_sandwich' |> SIMP_RULE std_ss [LET_THM]) >> rpt(pop_assum kall_tac) - >> fs[]); + >> fs[] +QED (* The diff is optimal, in the sense that the number of line changes it reports is precisely the number of deviations from the lcs of the @@ -1163,27 +1250,32 @@ val diff_with_lcs_optimal = Q.prove( >> rw[] >> rpt (qpat_x_assum `lcs (_::_) _ _` kall_tac) >> drule0 lcs_max_length >> fs[]); -Theorem diff_optimal - `!l r r'. lcs l r r' ==> - LENGTH(FILTER is_patch_line (diff_alg r r')) = LENGTH r + LENGTH r' - (2*LENGTH l)` - (rpt strip_tac >> fs[diff_alg_def] +Theorem diff_optimal: + !l r r'. lcs l r r' ==> + LENGTH(FILTER is_patch_line (diff_alg r r')) = LENGTH r + LENGTH r' - (2*LENGTH l) +Proof + rpt strip_tac >> fs[diff_alg_def] >> `lcs (optimised_lcs r r') r r'` by(metis_tac[optimised_lcs_correct]) >> `LENGTH l = LENGTH (optimised_lcs r r')` by(fs[lcs_def,common_subsequence_def,is_subsequence_def] >> metis_tac[is_subsequence_length,LESS_EQUAL_ANTISYM]) - >> fs[diff_with_lcs_optimal]); + >> fs[diff_with_lcs_optimal] +QED -Theorem REVERSE_DROP_REVERSE_TAKE - `!l n. n <= LENGTH l ==> - REVERSE((DROP n (REVERSE l))) = TAKE (LENGTH l - n) l` - (Induct >> rpt strip_tac >> fs[DROP_def,DROP_APPEND] >> rw[] +Theorem REVERSE_DROP_REVERSE_TAKE: + !l n. n <= LENGTH l ==> + REVERSE((DROP n (REVERSE l))) = TAKE (LENGTH l - n) l +Proof + Induct >> rpt strip_tac >> fs[DROP_def,DROP_APPEND] >> rw[] >> fs[ADD1,NOT_LEQ] >> imp_res_tac EQ_LESS_EQ >> fs[] - >> fs[DROP_LENGTH_TOO_LONG]) - -Theorem diff2_optimal - `!l r r'. lcs l r r' ==> - LENGTH(FILTER is_patch_line (diff_alg2 r r')) = LENGTH r + LENGTH r' - (2*LENGTH l)` - (rpt strip_tac >> fs[diff_alg2_thm] + >> fs[DROP_LENGTH_TOO_LONG] +QED + +Theorem diff2_optimal: + !l r r'. lcs l r r' ==> + LENGTH(FILTER is_patch_line (diff_alg2 r r')) = LENGTH r + LENGTH r' - (2*LENGTH l) +Proof + rpt strip_tac >> fs[diff_alg2_thm] >> qmatch_goalsub_abbrev_tac `longest_common_suffix a1 a2` >> qmatch_goalsub_abbrev_tac `dynamic_lcs a3 a4` >> `lcs (dynamic_lcs a3 a4) a3 a4` by(MATCH_ACCEPT_TAC dynamic_lcs_correct) @@ -1224,6 +1316,7 @@ Theorem diff2_optimal >> fs[]) >> pop_assum (fn x => PURE_ONCE_REWRITE_TAC[x]) >> pop_assum (fn x => PURE_ONCE_REWRITE_TAC[x]) - >> fs[]); + >> fs[] +QED val _ = export_theory (); diff --git a/examples/doubleProgScript.sml b/examples/doubleProgScript.sml index 75f1f0ac99..25be219890 100644 --- a/examples/doubleProgScript.sml +++ b/examples/doubleProgScript.sml @@ -19,11 +19,12 @@ val double = process_topdecs ` val _ = append_prog double; -Theorem double_spec - `∀x x_v. NUM x x_v +Theorem double_spec: + ∀x x_v. NUM x x_v ⇒ app (p:'ffi ffi_proj) ^(fetch_v "double" (basis_st())) [x_v] - emp (POSTv v. &(NUM (2 * x) v))` - (Induct_on `x` >> + emp (POSTv v. &(NUM (2 * x) v)) +Proof + Induct_on `x` >> xcf "double" (basis_st()) >- (xlet_auto >- xsimpl @@ -43,7 +44,7 @@ Theorem double_spec fs[NUM_def, INT_def] >> fs[integerTheory.INT_ADD_CALCULATE] ) -); +QED (**********) @@ -57,11 +58,12 @@ val double_tail_rec = process_topdecs ` val _ = append_prog double_tail_rec; -Theorem double_tail_rec_spec - `∀x x_v. NUM x x_v +Theorem double_tail_rec_spec: + ∀x x_v. NUM x x_v ⇒ app (p:'ffi ffi_proj) ^(fetch_v "double_tail_rec" (basis_st())) [x_v] - emp (POSTv v. &(NUM (2 * x) v))` - (xcf "double_tail_rec" (basis_st()) >> + emp (POSTv v. &(NUM (2 * x) v)) +Proof + xcf "double_tail_rec" (basis_st()) >> xlet_auto >- xsimpl >> xif >> fs[BOOL_def] @@ -98,7 +100,7 @@ Theorem double_tail_rec_spec qexists_tac `carry + 2` >> fs[] >> fs[ADD1] >> fs[NUM_def, INT_def, INT_OF_NUM_SUBS] -); +QED (**********) @@ -115,8 +117,8 @@ val double_ref = process_topdecs ` val _ = append_prog double_ref; -Theorem double_ref_spec - `∀ inp inp_v inp_ref ffi_p . +Theorem double_ref_spec: + ∀ inp inp_v inp_ref ffi_p . NUM inp inp_v ⇒ app (ffi_p:'ffi ffi_proj) ^(fetch_v "double_ref" (basis_st())) [inp_ref] (inp_ref ~~> inp_v) @@ -125,8 +127,9 @@ Theorem double_ref_spec (inp_ref ~~> inp0_v) * &(NUM 0 inp0_v)) * (SEP_EXISTS ret_v . (ret_ref ~~> ret_v) * &(NUM (2 * inp) ret_v)) - )` - (Induct_on `inp` >> + ) +Proof + Induct_on `inp` >> xcf "double_ref" (basis_st()) >- (xlet_auto >- xsimpl @@ -168,7 +171,7 @@ Theorem double_ref_spec >- xsimpl >> xvar >> xsimpl >> fs[NUM_def, INT_def] -); +QED (**********) @@ -180,8 +183,8 @@ val double_ref_same = process_topdecs ` val _ = append_prog double_ref_same; -Theorem double_ref_same_spec - `∀ inp inp_v inp_ref ffi_p . +Theorem double_ref_same_spec: + ∀ inp inp_v inp_ref ffi_p . NUM inp inp_v ⇒ app (ffi_p:'ffi ffi_proj) ^(fetch_v "double_ref_same" (basis_st())) [inp_ref] @@ -192,8 +195,9 @@ Theorem double_ref_same_spec &(NUM (2 * inp) ret_v ∧ ret_ref = inp_ref) ) - )` - (Induct_on `inp` >> + ) +Proof + Induct_on `inp` >> xcf "double_ref_same" (basis_st()) >- ( xlet_auto @@ -237,6 +241,6 @@ Theorem double_ref_same_spec >- xsimpl >> xvar >> xsimpl >> fs[NUM_def, INT_def] -); +QED val _ = export_theory(); diff --git a/examples/echoProgScript.sml b/examples/echoProgScript.sml index 6b43d2ae1d..15824461ff 100644 --- a/examples/echoProgScript.sml +++ b/examples/echoProgScript.sml @@ -19,13 +19,14 @@ val () = append_prog echo; val st = get_ml_prog_state() -Theorem echo_spec - `app (p:'ffi ffi_proj) ^(fetch_v "echo" st) [Conv NONE []] +Theorem echo_spec: + app (p:'ffi ffi_proj) ^(fetch_v "echo" st) [Conv NONE []] (STDIO fs * COMMANDLINE cl) (POSTv uv. &UNIT_TYPE () uv * (STDIO (add_stdout fs (concatWith (strlit" ") (TL cl) ^ (strlit"\n")))) * - COMMANDLINE cl)` - (xcf "echo" st \\ + COMMANDLINE cl) +Proof + xcf "echo" st \\ cases_on`¬ STD_streams fs` >-(fs[STDIO_def] >> xpull) >> xlet_auto >- (xcon \\ xsimpl) \\ reverse(Cases_on`wfcl cl`) >- (fs[COMMANDLINE_def] \\ xpull) \\ @@ -45,17 +46,20 @@ Theorem echo_spec xsimpl >> fs[] >> imp_res_tac STD_streams_stdout >> simp[str_def,implode_def] >> - imp_res_tac add_stdo_o >> xsimpl); + imp_res_tac add_stdo_o >> xsimpl +QED -Theorem echo_whole_prog_spec - `whole_prog_spec ^(fetch_v "echo" st) cl fs NONE - ((=) (add_stdout fs (concatWith (strlit" ") (TL cl) ^ (strlit"\n"))))` - (rw[whole_prog_spec_def] +Theorem echo_whole_prog_spec: + whole_prog_spec ^(fetch_v "echo" st) cl fs NONE + ((=) (add_stdout fs (concatWith (strlit" ") (TL cl) ^ (strlit"\n")))) +Proof + rw[whole_prog_spec_def] \\ qmatch_goalsub_abbrev_tac`fs1 = _ with numchars := _` \\ qexists_tac`fs1` \\ simp[Abbr`fs1`,GSYM add_stdo_with_numchars,with_same_numchars] \\ match_mp_tac (MP_CANON (MATCH_MP app_wgframe echo_spec)) - \\ xsimpl); + \\ xsimpl +QED val (call_thm_echo, echo_prog_tm) = whole_prog_thm st "echo" echo_whole_prog_spec; val echo_prog_def = Define`echo_prog = ^echo_prog_tm`; diff --git a/examples/grepProgScript.sml b/examples/grepProgScript.sml index 27893f607c..dcfc148433 100644 --- a/examples/grepProgScript.sml +++ b/examples/grepProgScript.sml @@ -154,31 +154,37 @@ val compile_regexp_with_limit_def = delta_vecs, accepts_vec))`; -Theorem Brz_sound_wrt_Brzozo - `Brz seen worklist acc d = SOME result ==> Brzozo seen worklist acc = result` - (rpt strip_tac +Theorem Brz_sound_wrt_Brzozo: + Brz seen worklist acc d = SOME result ==> Brzozo seen worklist acc = result +Proof + rpt strip_tac >> `IS_SOME (Brz seen worklist acc d)` by rw[optionTheory.IS_SOME_DEF] >> `IS_SOME (Brz seen worklist acc (rdepth seen worklist acc))` by (rw[optionTheory.IS_SOME_DEF] >> metis_tac [rdepth_thm]) >> `Brz seen worklist acc d = Brz seen worklist acc (rdepth seen worklist acc)` by metis_tac [Brz_determ] - >> fs[Brzozo_def]); + >> fs[Brzozo_def] +QED -Theorem Brz_sound_wrt_Brzozowski - `Brz seen worklist acc d = SOME result ==> Brzozowski seen worklist acc = result` - (rpt strip_tac +Theorem Brz_sound_wrt_Brzozowski: + Brz seen worklist acc d = SOME result ==> Brzozowski seen worklist acc = result +Proof + rpt strip_tac >> `IS_SOME (Brz seen worklist acc d)` by rw[optionTheory.IS_SOME_DEF] >> rw[Brzozowski_def,dom_Brz_def] - >> metis_tac[Brz_sound_wrt_Brzozo]); + >> metis_tac[Brz_sound_wrt_Brzozo] +QED -Theorem compile_regexp_with_limit_sound - `compile_regexp_with_limit r = SOME result ==> compile_regexp r = result` - (fs[compile_regexp_with_limit_def,compile_regexp_def] +Theorem compile_regexp_with_limit_sound: + compile_regexp_with_limit r = SOME result ==> compile_regexp r = result +Proof + fs[compile_regexp_with_limit_def,compile_regexp_def] >> every_case_tac >> IMP_RES_TAC Brz_sound_wrt_Brzozowski - >> rw[pairTheory.ELIM_UNCURRY]); + >> rw[pairTheory.ELIM_UNCURRY] +QED val r = translate compile_regexp_with_limit_def; @@ -195,12 +201,14 @@ val regexp_matcher_with_limit_def = in SOME(exec_dfa acceptsV deltaV start_state s))`; -Theorem regexp_matcher_with_limit_sound - `regexp_matcher_with_limit r s = SOME result ==> regexp_matcher r s = result` - (fs[regexp_matcher_with_limit_def,regexp_matcher_def] +Theorem regexp_matcher_with_limit_sound: + regexp_matcher_with_limit r s = SOME result ==> regexp_matcher r s = result +Proof + fs[regexp_matcher_with_limit_def,regexp_matcher_def] >> every_case_tac >> IMP_RES_TAC compile_regexp_with_limit_sound - >> rw[pairTheory.ELIM_UNCURRY]); + >> rw[pairTheory.ELIM_UNCURRY] +QED val r = translate (regexp_matcher_with_limit_def); @@ -266,9 +274,11 @@ val compile_regexp_with_limit_lookup = Q.prove( compile_regexp_with_limit_sound]) >> fs[eq_cmp_bmapTheory.fdom_def]); -Theorem tolist_fromlist_map_cancel - `MAP mlvector$toList (MAP fromList ll) = ll` - (Induct_on `ll` >> fs[]); +Theorem tolist_fromlist_map_cancel: + MAP mlvector$toList (MAP fromList ll) = ll +Proof + Induct_on `ll` >> fs[] +QED val regexp_matcher_with_limit_side_def = Q.prove( `!r s. regexp_matcher_with_limit_side r s ⇔ T`, @@ -292,15 +302,17 @@ val regexp_matcher_with_limit_side_def = Q.prove( (* TODO: should this be in regexp_compilerTheory *) -Theorem regexp_matcher_correct - `dom_Brz_alt empty [normalize r] ⇒ - (regexp_matcher r s ⇔ s ∈ regexp_lang r)` - (rw[regexp_matcher_def] +Theorem regexp_matcher_correct: + dom_Brz_alt empty [normalize r] ⇒ + (regexp_matcher r s ⇔ s ∈ regexp_lang r) +Proof + rw[regexp_matcher_def] \\ pairarg_tac \\ fs[] \\ imp_res_tac compile_regexp_good_vec \\ rfs[dom_Brz_alt_equal,eq_cmp_bmapTheory.fdom_def] \\ imp_res_tac Brzozowski_partial_eval_256 - \\ simp[IN_DEF]); + \\ simp[IN_DEF] +QED (* -- *) @@ -308,14 +320,16 @@ Theorem regexp_matcher_correct n.b. INTRO_FLOOKUP is copied from parserProgScript.sml *) -Theorem INTRO_FLOOKUP - `(if n IN FDOM G.rules +Theorem INTRO_FLOOKUP: + (if n IN FDOM G.rules then EV (G.rules ' n) i r y fk else Result xx) = (case FLOOKUP G.rules n of NONE => Result xx - | SOME x => EV x i r y fk)` - (SRW_TAC [] [finite_mapTheory.FLOOKUP_DEF]); + | SOME x => EV x i r y fk) +Proof + SRW_TAC [] [finite_mapTheory.FLOOKUP_DEF] +QED val coreloop_def' = ( pegexecTheory.coreloop_def @@ -396,8 +410,8 @@ val print_matching_lines = process_topdecs` print_matching_lines match prefix fd)`; val _ = append_prog print_matching_lines; -Theorem print_matching_lines_spec - `(STRING_TYPE --> BOOL) m mv ∧ STRING_TYPE pfx pfxv ∧ +Theorem print_matching_lines_spec: + (STRING_TYPE --> BOOL) m mv ∧ STRING_TYPE pfx pfxv ∧ INSTREAM fd fdv ∧ fd ≠ 1 ∧ fd ≠ 2 ∧ IS_SOME (get_file_content fs fd) ∧ get_mode fs fd = SOME ReadMode ⇒ app (p:'ffi ffi_proj) @@ -408,8 +422,9 @@ Theorem print_matching_lines_spec STDIO (add_stdout (fastForwardFD fs fd) (concat (MAP (strcat pfx) - (FILTER m (MAP implode (linesFD fs fd)))))))` - (Induct_on`linesFD fs fd` \\ rw[] + (FILTER m (MAP implode (linesFD fs fd))))))) +Proof + Induct_on`linesFD fs fd` \\ rw[] >- ( qpat_x_assum`[] = _`(assume_tac o SYM) \\ fs[] \\ xcf"print_matching_lines"(get_ml_prog_state()) @@ -480,7 +495,8 @@ Theorem print_matching_lines_spec \\ simp[STD_streams_add_stdout] \\ DEP_REWRITE_TAC[GEN_ALL add_stdo_o] \\ conj_tac >- metis_tac[STD_streams_stdout] - \\ rw[concat_cons]); + \\ rw[concat_cons] +QED val notfound_string_def = Define` notfound_string f = concat[strlit"cake_grep: ";f;strlit": No such file or directory\n"]`; @@ -496,8 +512,8 @@ val print_matching_lines_in_file = process_topdecs` TextIO.output TextIO.stdErr (notfound_string file)`; val _ = append_prog print_matching_lines_in_file; -Theorem print_matching_lines_in_file_spec - `FILENAME f fv ∧ hasFreeFD fs ∧ +Theorem print_matching_lines_in_file_spec: + FILENAME f fv ∧ hasFreeFD fs ∧ (STRING_TYPE --> BOOL) m mv ⇒ app (p:'ffi ffi_proj) ^(fetch_v"print_matching_lines_in_file"(get_ml_prog_state())) @@ -509,8 +525,9 @@ Theorem print_matching_lines_in_file_spec (concat (MAP (strcat f o strcat (strlit":")) (FILTER m (all_lines fs f)))) - else add_stderr fs (notfound_string f)))` - (xcf"print_matching_lines_in_file"(get_ml_prog_state()) + else add_stderr fs (notfound_string f))) +Proof + xcf"print_matching_lines_in_file"(get_ml_prog_state()) \\ reverse(Cases_on`STD_streams fs`) >- (fs[STDIO_def] \\ xpull) \\ reverse(Cases_on`consistentFS fs`) >-(fs[STDIO_def,IOFS_def] >> xpull >> fs[wfFS_def,consistentFS_def] >> res_tac) @@ -567,7 +584,8 @@ Theorem print_matching_lines_in_file_spec \\ simp[MAP_MAP_o,o_DEF] \\ rewrite_tac[GSYM APPEND_ASSOC,GSYM CONS_APPEND] \\ simp[GSYM add_stdo_ADELKEY,openFileFS_ADELKEY_nextFD] - \\ xsimpl); + \\ xsimpl +QED val usage_string_def = Define` usage_string = strlit"Usage: grep ...\n"`; @@ -610,15 +628,17 @@ val build_matcher_side = Q.prove( val build_matcher_v_thm = theorem"build_matcher_v_thm" -Theorem build_matcher_partial_spec - `REGEXP_REGEXP_TYPE r rv ⇒ +Theorem build_matcher_partial_spec: + REGEXP_REGEXP_TYPE r rv ⇒ app (p:'ffi ffi_proj) ^(fetch_v"build_matcher"(get_ml_prog_state())) [rv] emp - (POSTv v. &(STRING_TYPE --> BOOL) (build_matcher r) v)` - (strip_tac + (POSTv v. &(STRING_TYPE --> BOOL) (build_matcher r) v) +Proof + strip_tac \\ rw[app_def] \\ irule Arrow_IMP_app_basic \\ instantiate - \\ simp[build_matcher_v_thm]); + \\ simp[build_matcher_v_thm] +QED val grep = process_topdecs` fun grep u = @@ -680,37 +700,46 @@ val grep_sem_ind = theorem"grep_sem_ind"; |> SIMP_RULE(srw_ss())[] *) -Theorem grep_sem_file_MAP_FST_infds[simp] - `consistentFS fs ⇒ MAP FST (grep_sem_file L nm fs).infds = MAP FST fs.infds` - (rw[grep_sem_file_def] \\ CASE_TAC \\ simp[] \\ CASE_TAC \\ simp[] - \\ fs[consistentFS_def] \\ res_tac \\ fs[ALOOKUP_NONE]); - -Theorem grep_sem_file_maxFD[simp] - `consistentFS fs ⇒ (grep_sem_file L nm fs).maxFD = fs.maxFD` - (rw[grep_sem_file_def,consistentFS_def] \\ CASE_TAC \\ simp[] \\ res_tac \\ - CASE_TAC \\ fs[ALOOKUP_NONE]); - -Theorem STD_streams_grep_sem_file - `consistentFS fs /\ STD_streams fs ⇒ STD_streams (grep_sem_file L fn fs)` - (rw[grep_sem_file_def,consistentFS_def] +Theorem grep_sem_file_MAP_FST_infds[simp]: + consistentFS fs ⇒ MAP FST (grep_sem_file L nm fs).infds = MAP FST fs.infds +Proof + rw[grep_sem_file_def] \\ CASE_TAC \\ simp[] \\ CASE_TAC \\ simp[] + \\ fs[consistentFS_def] \\ res_tac \\ fs[ALOOKUP_NONE] +QED + +Theorem grep_sem_file_maxFD[simp]: + consistentFS fs ⇒ (grep_sem_file L nm fs).maxFD = fs.maxFD +Proof + rw[grep_sem_file_def,consistentFS_def] \\ CASE_TAC \\ simp[] \\ res_tac \\ + CASE_TAC \\ fs[ALOOKUP_NONE] +QED + +Theorem STD_streams_grep_sem_file: + consistentFS fs /\ STD_streams fs ⇒ STD_streams (grep_sem_file L fn fs) +Proof + rw[grep_sem_file_def,consistentFS_def] \\ rpt CASE_TAC \\ simp[STD_streams_add_stderr,STD_streams_add_stdout] - \\ res_tac >> fs[ALOOKUP_NONE]); - -Theorem consistentFS_grep_sem_file[simp] - `consistentFS fs ⇒ - consistentFS (grep_sem_file L fn fs)` - (rw[grep_sem_file_def,consistentFS_def] + \\ res_tac >> fs[ALOOKUP_NONE] +QED + +Theorem consistentFS_grep_sem_file[simp]: + consistentFS fs ⇒ + consistentFS (grep_sem_file L fn fs) +Proof + rw[grep_sem_file_def,consistentFS_def] \\ rpt CASE_TAC \\ fs[up_stdo_files,add_stdo_def] \\ - res_tac >> fs[ALOOKUP_NONE]); + res_tac >> fs[ALOOKUP_NONE] +QED -Theorem grep_sem_file_lemma - `consistentFS fs /\ STD_streams fs ⇒ +Theorem grep_sem_file_lemma: + consistentFS fs /\ STD_streams fs ⇒ let fs' = FOLDL (λa f. grep_sem_file L f o a) I ls fs in STD_streams fs'∧ consistentFS fs' ∧ (hasFreeFD fs ⇒ hasFreeFD fs') ∧ FILTER (isFile o FST) fs'.inode_tbl = FILTER (isFile o FST) fs.inode_tbl ∧ - fs'.files = fs.files` - (simp[] + fs'.files = fs.files +Proof + simp[] \\ qid_spec_tac`fs` \\ qid_spec_tac`ls` \\ ho_match_mp_tac SNOC_INDUCT @@ -722,29 +751,34 @@ Theorem grep_sem_file_lemma >-(rpt (CASE_TAC \\ simp[FILTER_File_add_stderr,FILTER_File_add_stdout,add_stdo_def,up_stdo_def,fsupdate_def]) \\ res_tac \\ fs[consistentFS_def] \\ res_tac \\ fs[ALOOKUP_NONE]) - ); +QED -Theorem grep_sem_file_lemma' - `consistentFS fs ⇒ - consistentFS (FOLDL (λa f. grep_sem_file L f o a) I ls fs)` - (simp[] +Theorem grep_sem_file_lemma': + consistentFS fs ⇒ + consistentFS (FOLDL (λa f. grep_sem_file L f o a) I ls fs) +Proof + simp[] \\ qid_spec_tac`fs` \\ qid_spec_tac`ls` \\ ho_match_mp_tac SNOC_INDUCT - \\ rw[FOLDL_SNOC,consistentFS_grep_sem_file,FOLDL_APPEND]); + \\ rw[FOLDL_SNOC,consistentFS_grep_sem_file,FOLDL_APPEND] +QED -Theorem grep_sem_file_with_numchars - `consistentFS fs ⇒ +Theorem grep_sem_file_with_numchars: + consistentFS fs ⇒ grep_sem_file L filename (fs with numchars := ns) = - grep_sem_file L filename fs with numchars := ns` - (rw[grep_sem_file_def,consistentFS_def] \\ CASE_TAC \\ rw[add_stdo_with_numchars] - \\ CASE_TAC \\ res_tac \\ fs[ALOOKUP_NONE]); - -Theorem grep_sem_with_numchars - `∀cl fs. consistentFS fs ⇒ + grep_sem_file L filename fs with numchars := ns +Proof + rw[grep_sem_file_def,consistentFS_def] \\ CASE_TAC \\ rw[add_stdo_with_numchars] + \\ CASE_TAC \\ res_tac \\ fs[ALOOKUP_NONE] +QED + +Theorem grep_sem_with_numchars: + ∀cl fs. consistentFS fs ⇒ grep_sem cl (fs with numchars := ns) = - grep_sem cl fs with numchars := ns` - (recInduct grep_sem_ind + grep_sem cl fs with numchars := ns +Proof + recInduct grep_sem_ind \\ rw[grep_sem_def,add_stdo_with_numchars] \\ CASE_TAC \\ rw[add_stdo_with_numchars] \\ pop_assum kall_tac @@ -754,7 +788,8 @@ Theorem grep_sem_with_numchars \\ qid_spec_tac`filenames` \\ ho_match_mp_tac SNOC_INDUCT \\ rw[FOLDL_SNOC,FOLDL_APPEND] - \\ rw[grep_sem_file_with_numchars,grep_sem_file_lemma']); + \\ rw[grep_sem_file_with_numchars,grep_sem_file_lemma'] +QED val grep_termination_assum_def = Define` (grep_termination_assum (_::regexp::filenames) ⇔ @@ -764,15 +799,16 @@ val grep_termination_assum_def = Define` | SOME r => IS_SOME (Brz empty [normalize r] (1,singleton (normalize r) 0,[]) MAXNUM_32)) ∧ (grep_termination_assum _ ⇔ T)`; -Theorem grep_spec - `hasFreeFD fs ∧ +Theorem grep_spec: + hasFreeFD fs ∧ grep_termination_assum cl ⇒ app (p:'ffi ffi_proj) ^(fetch_v"grep"(get_ml_prog_state())) [Conv NONE []] (STDIO fs * COMMANDLINE cl) - (POSTv v. &UNIT_TYPE () v * STDIO (grep_sem cl fs) * COMMANDLINE cl)` - (strip_tac + (POSTv v. &UNIT_TYPE () v * STDIO (grep_sem cl fs) * COMMANDLINE cl) +Proof + strip_tac \\ xcf"grep"(get_ml_prog_state()) \\ xlet_auto >- (xcon \\ xsimpl) \\ reverse(Cases_on`wfcl cl`)>-(fs[COMMANDLINE_def] \\ xpull) @@ -909,20 +945,23 @@ Theorem grep_spec \\ simp[FOLDL_APPEND,Abbr`ff`] \\ disch_then match_mp_tac \\ imp_res_tac grep_sem_file_lemma - \\ fs[]); + \\ fs[] +QED val st = get_ml_prog_state() -Theorem grep_whole_prog_spec - `consistentFS fs ⇒ +Theorem grep_whole_prog_spec: + consistentFS fs ⇒ whole_prog_spec ^(fetch_v "grep" st) cl fs NONE - ((=) (grep_sem cl fs))` - (disch_then assume_tac + ((=) (grep_sem cl fs)) +Proof + disch_then assume_tac \\ simp[whole_prog_spec_def] \\ qexists_tac`grep_sem cl fs` \\ simp[GSYM grep_sem_with_numchars,with_same_numchars] \\ match_mp_tac (MP_CANON (MATCH_MP app_wgframe (UNDISCH grep_spec))) - \\ xsimpl); + \\ xsimpl +QED val name = "grep" val spec = grep_whole_prog_spec |> UNDISCH diff --git a/examples/helloErrProgScript.sml b/examples/helloErrProgScript.sml index 01f923b5bd..20fa8d23f5 100644 --- a/examples/helloErrProgScript.sml +++ b/examples/helloErrProgScript.sml @@ -16,30 +16,34 @@ val () = append_prog helloErr; val st = get_ml_prog_state () -Theorem helloErr_spec - `app (p:'ffi ffi_proj) ^(fetch_v "helloErr" st) +Theorem helloErr_spec: + app (p:'ffi ffi_proj) ^(fetch_v "helloErr" st) [Conv NONE []] (RUNTIME * STDIO fs) (POSTf n. λ c b. RUNTIME * &(n = "exit" /\ c = [] /\ b = [1w]) * - STDIO (add_stderr fs (strlit "Well oH lord!\n")))` - (xcf "helloErr" st + STDIO (add_stderr fs (strlit "Well oH lord!\n"))) +Proof + xcf "helloErr" st \\ xlet `(POSTv uv. &(UNIT_TYPE () uv) * RUNTIME * STDIO (add_stderr fs (strlit "Well oH lord!\n")))` >- (xapp_spec output_stderr_spec \\ xsimpl \\ MAP_EVERY qexists_tac [`RUNTIME`,`fs`] \\ xsimpl) \\ xlet_auto >- (xcon \\ xsimpl) - \\ xapp \\ xsimpl); - -Theorem helloErr_whole_prog_spec - `whole_prog_ffidiv_spec ^(fetch_v "helloErr" st) cl fs - (λn c b fs'. n = "exit" /\ c = [] /\ b = [1w] /\ add_stderr fs (strlit "Well oH lord!\n") = fs')` - (rw[basis_ffiTheory.whole_prog_ffidiv_spec_def] + \\ xapp \\ xsimpl +QED + +Theorem helloErr_whole_prog_spec: + whole_prog_ffidiv_spec ^(fetch_v "helloErr" st) cl fs + (λn c b fs'. n = "exit" /\ c = [] /\ b = [1w] /\ add_stderr fs (strlit "Well oH lord!\n") = fs') +Proof + rw[basis_ffiTheory.whole_prog_ffidiv_spec_def] \\ qmatch_goalsub_abbrev_tac`fs1 = _ with numchars := _` \\ qexists_tac `fs1` \\ simp[Abbr`fs1`,GSYM add_stdo_with_numchars,with_same_numchars] \\ match_mp_tac (MP_CANON (MATCH_MP app_wgframe helloErr_spec)) - \\ xsimpl); + \\ xsimpl +QED val (helloErr_sem_thm, helloErr_prog_tm) = whole_prog_thm st "helloErr" helloErr_whole_prog_spec; val helloErr_prog_def = Define`helloErr_prog = ^helloErr_prog_tm`; diff --git a/examples/helloProgScript.sml b/examples/helloProgScript.sml index 11945cf656..430e80e4ba 100644 --- a/examples/helloProgScript.sml +++ b/examples/helloProgScript.sml @@ -14,22 +14,26 @@ val () = append_prog hello val st = get_ml_prog_state () -Theorem hello_spec - ` app (p:'ffi ffi_proj) ^(fetch_v "hello" st) +Theorem hello_spec: + app (p:'ffi ffi_proj) ^(fetch_v "hello" st) [Conv NONE []] (STDIO fs) - (POSTv uv. &UNIT_TYPE () uv * STDIO (add_stdout fs (strlit "Hello World!\n")))` - (xcf "hello" st \\ xapp \\ xsimpl); - -Theorem hello_whole_prog_spec - `whole_prog_spec ^(fetch_v "hello" st) cl fs NONE - ((=) (add_stdout fs (strlit "Hello World!\n")))` - (rw[whole_prog_spec_def] + (POSTv uv. &UNIT_TYPE () uv * STDIO (add_stdout fs (strlit "Hello World!\n"))) +Proof + xcf "hello" st \\ xapp \\ xsimpl +QED + +Theorem hello_whole_prog_spec: + whole_prog_spec ^(fetch_v "hello" st) cl fs NONE + ((=) (add_stdout fs (strlit "Hello World!\n"))) +Proof + rw[whole_prog_spec_def] \\ qmatch_goalsub_abbrev_tac`fs1 = _ with numchars := _` \\ qexists_tac`fs1` \\ simp[Abbr`fs1`,GSYM add_stdo_with_numchars,with_same_numchars] \\ match_mp_tac (MP_CANON (MATCH_MP app_wgframe hello_spec)) - \\ xsimpl); + \\ xsimpl +QED val spec = hello_whole_prog_spec val name = "hello"; diff --git a/examples/insertSortProgScript.sml b/examples/insertSortProgScript.sml index 403b193b14..6e13411629 100644 --- a/examples/insertSortProgScript.sml +++ b/examples/insertSortProgScript.sml @@ -51,39 +51,45 @@ val list_rel_perm_help = Q.prove ( ho_match_mp_tac PERM_IND >> rw []); -Theorem list_rel_perm - `!r l1 l2 l3 l4. +Theorem list_rel_perm: + !r l1 l2 l3 l4. LENGTH l3 = LENGTH l4 ∧ LIST_REL r l1 l2 ∧ PERM (ZIP (l1,l2)) (ZIP (l3,l4)) ⇒ - LIST_REL r l3 l4` - (rw [] >> + LIST_REL r l3 l4 +Proof + rw [] >> drule list_rel_perm_help >> imp_res_tac LIST_REL_LENGTH >> - rw [MAP_ZIP]); + rw [MAP_ZIP] +QED -Theorem list_rel_front - `!r l1 l2. +Theorem list_rel_front: + !r l1 l2. l1 ≠ [] ∧ l2 ≠ [] ⇒ (LIST_REL r l1 l2 ⇔ - LIST_REL r (FRONT l1) (FRONT l2) ∧ r (LAST l1) (LAST l2))` - (Induct_on `l1` >> + LIST_REL r (FRONT l1) (FRONT l2) ∧ r (LAST l1) (LAST l2)) +Proof + Induct_on `l1` >> rw [] >> Cases_on `l2` >> fs [FRONT_DEF, LAST_DEF] >> rw [] >> - metis_tac []); + metis_tac [] +QED -Theorem zip_append_sing - `!l1 l2 x y. +Theorem zip_append_sing: + !l1 l2 x y. LENGTH l1 = LENGTH l2 ⇒ - ZIP (l1,l2) ++ [(x, y)] = ZIP (l1++[x], l2++[y])` - (rw [] >> + ZIP (l1,l2) ++ [(x, y)] = ZIP (l1++[x], l2++[y]) +Proof + rw [] >> `[(x,y)] = ZIP ([x], [y])` by rw [] >> - metis_tac [ZIP_APPEND, LENGTH]); + metis_tac [ZIP_APPEND, LENGTH] +QED val arith = Q.prove ( `!x:num. x ≠ 0 ⇒ &(x-1) = &x - 1:int`, @@ -94,8 +100,8 @@ val eq_num_v_thm = (DISCH_ALL mlbasicsProgTheory.eq_v_thm) (ml_translatorTheory.EqualityType_NUM_BOOL |> CONJUNCT1) -Theorem insertsort_spec - `!ffi_p cmp cmp_v arr_v elem_vs elems. +Theorem insertsort_spec: + !ffi_p cmp cmp_v arr_v elem_vs elems. LIST_REL a elems elem_vs ∧ (a --> a --> BOOL) cmp cmp_v ∧ (!x y. cmp x y ⇒ ~cmp y x) @@ -108,8 +114,9 @@ Theorem insertsort_spec ARRAY arr_v elem_vs' * &(?elems'. PERM (ZIP (elems', elem_vs')) (ZIP (elems, elem_vs)) ∧ - SORTED (\x y. ¬(cmp y x)) elems'))` - (xcf "insertsort" insertsort_st >> + SORTED (\x y. ¬(cmp y x)) elems')) +Proof + xcf "insertsort" insertsort_st >> xfun_spec `outer_loop` `!elem_vs2 elems1 elems2 elem_vs1 prefix_v. elem_vs1 ≠ [] ∧ @@ -473,6 +480,7 @@ Theorem insertsort_spec fs [] >> rw [] >> qexists_tac `elems'` >> - simp [])); + simp []) +QED val _ = export_theory (); diff --git a/examples/iocatProgScript.sml b/examples/iocatProgScript.sml index 91287bb302..ed2946976f 100644 --- a/examples/iocatProgScript.sml +++ b/examples/iocatProgScript.sml @@ -140,15 +140,16 @@ val cat_main = process_topdecs` fun cat_main _ = cat (CommandLine.arguments())`; val _ = append_prog cat_main; -Theorem cat_main_spec - `EVERY (inFS_fname fs) (TL cl) ∧ hasFreeFD fs +Theorem cat_main_spec: + EVERY (inFS_fname fs) (TL cl) ∧ hasFreeFD fs ⇒ app (p:'ffi ffi_proj) ^(fetch_v"cat_main" (st())) [Conv NONE []] (STDIO fs * COMMANDLINE cl ) (POSTv uv. &UNIT_TYPE () uv * (STDIO (add_stdout fs (catfiles_string fs (TL cl)))) - * COMMANDLINE cl)` - (strip_tac + * COMMANDLINE cl) +Proof + strip_tac \\ xcf "cat_main" (st()) \\ xmatch \\ xlet_auto >-(xcon >> xsimpl) @@ -162,21 +163,24 @@ Theorem cat_main_spec \\ instantiate \\ simp[FILENAME_def] \\ fs[EVERY_MEM,validArg_def] - \\ Cases_on`cl` \\ fs[]); + \\ Cases_on`cl` \\ fs[] +QED val st = st(); -Theorem cat_whole_prog_spec - `EVERY (inFS_fname fs) (TL cl) ∧ hasFreeFD fs ⇒ +Theorem cat_whole_prog_spec: + EVERY (inFS_fname fs) (TL cl) ∧ hasFreeFD fs ⇒ whole_prog_spec ^(fetch_v"cat_main"st) cl fs NONE - ((=) (add_stdout fs (catfiles_string fs (TL cl))))` - (disch_then assume_tac + ((=) (add_stdout fs (catfiles_string fs (TL cl)))) +Proof + disch_then assume_tac \\ simp[whole_prog_spec_def] \\ qmatch_goalsub_abbrev_tac`fs1 = _ with numchars := _` \\ qexists_tac`fs1` \\ simp[Abbr`fs1`,GSYM add_stdo_with_numchars,with_same_numchars] \\ match_mp_tac (MP_CANON (MATCH_MP app_wgframe (UNDISCH cat_main_spec))) - \\ xsimpl); + \\ xsimpl +QED val name = "cat_main" val (semantics_thm,prog_tm) = whole_prog_thm st name (UNDISCH cat_whole_prog_spec) diff --git a/examples/lcsScript.sml b/examples/lcsScript.sml index 48b2bc0494..7f1aaf735b 100644 --- a/examples/lcsScript.sml +++ b/examples/lcsScript.sml @@ -69,131 +69,164 @@ Define `lcs s t u = (* Properties of lcs and its auxiliary functions *) -Theorem is_subsequence_nil ` - (is_subsequence l [] = (l = [])) /\ (is_subsequence [] l = T)` - (Induct_on `l` >> fs[is_subsequence_def]); - -Theorem is_subsequence_cons ` - is_subsequence (f::r) (h::r') = - (((f = h) /\ is_subsequence r r') \/ is_subsequence (f::r) r')` - (fs[Once is_subsequence_def]); - -Theorem is_subsequence_single - `is_subsequence s [h] = ((s = [h]) \/ (s = []))` - (Cases_on `s` - >> fs[is_subsequence_nil,is_subsequence_cons]); - -Theorem is_subsequence_refl ` - is_subsequence l l = T` - (Induct_on `l` >> fs[is_subsequence_nil,is_subsequence_cons]); - -Theorem prefix_is_subsequence ` - ! s l s'. - (is_subsequence (s ++ s') l ==> is_subsequence s l)` - (ho_match_mp_tac (theorem "is_subsequence_ind") +Theorem is_subsequence_nil: + (is_subsequence l [] = (l = [])) /\ (is_subsequence [] l = T) +Proof + Induct_on `l` >> fs[is_subsequence_def] +QED + +Theorem is_subsequence_cons: + is_subsequence (f::r) (h::r') = + (((f = h) /\ is_subsequence r r') \/ is_subsequence (f::r) r') +Proof + fs[Once is_subsequence_def] +QED + +Theorem is_subsequence_single: + is_subsequence s [h] = ((s = [h]) \/ (s = [])) +Proof + Cases_on `s` + >> fs[is_subsequence_nil,is_subsequence_cons] +QED + +Theorem is_subsequence_refl: + is_subsequence l l = T +Proof + Induct_on `l` >> fs[is_subsequence_nil,is_subsequence_cons] +QED + +Theorem prefix_is_subsequence: + ! s l s'. + (is_subsequence (s ++ s') l ==> is_subsequence s l) +Proof + ho_match_mp_tac (theorem "is_subsequence_ind") >> rpt strip_tac >- fs[is_subsequence_nil,is_subsequence_cons] >> Cases_on `l` >- fs[is_subsequence_nil] >> fs[is_subsequence_cons] >> rw[] - >> metis_tac[]); + >> metis_tac[] +QED -Theorem suffix_is_subsequence - `! s l s'. - (is_subsequence (f::s) l ==> is_subsequence s l)` - (ho_match_mp_tac (theorem "is_subsequence_ind") +Theorem suffix_is_subsequence: + ! s l s'. + (is_subsequence (f::s) l ==> is_subsequence s l) +Proof + ho_match_mp_tac (theorem "is_subsequence_ind") >> rpt strip_tac >- fs[is_subsequence_nil,is_subsequence_cons] >> Cases_on `l` >- fs[is_subsequence_nil] - >> fs[is_subsequence_cons]); - -Theorem suffix_is_subsequence' - `!s l. is_subsequence (s' ++ s) l ==> is_subsequence s l` - (Induct_on `s'` - >> fs[] >> metis_tac[suffix_is_subsequence]); - -Theorem cons_is_subsequence - `is_subsequence s l ==> is_subsequence s (f::l)` - (Induct_on `s` - >> rw[is_subsequence_cons,is_subsequence_nil]); - -Theorem is_subsequence_snoc ` - !s l f. is_subsequence (s ++ [f]) (l ++ [f]) = is_subsequence s l` - (ho_match_mp_tac (theorem "is_subsequence_ind") + >> fs[is_subsequence_cons] +QED + +Theorem suffix_is_subsequence': + !s l. is_subsequence (s' ++ s) l ==> is_subsequence s l +Proof + Induct_on `s'` + >> fs[] >> metis_tac[suffix_is_subsequence] +QED + +Theorem cons_is_subsequence: + is_subsequence s l ==> is_subsequence s (f::l) +Proof + Induct_on `s` + >> rw[is_subsequence_cons,is_subsequence_nil] +QED + +Theorem is_subsequence_snoc: + !s l f. is_subsequence (s ++ [f]) (l ++ [f]) = is_subsequence s l +Proof + ho_match_mp_tac (theorem "is_subsequence_ind") >> rpt strip_tac >- (Induct_on `l` >> fs[is_subsequence_nil,is_subsequence_cons]) >> fs[is_subsequence_nil,is_subsequence_cons] >> Cases_on `l` - >> rfs[is_subsequence_nil,is_subsequence_cons] >> metis_tac[]); + >> rfs[is_subsequence_nil,is_subsequence_cons] >> metis_tac[] +QED -Theorem is_subsequence_snoc' - `!r r'. is_subsequence (r ++ [f]) (r' ++ [h]) = - (((f = h) /\ is_subsequence r r') \/ is_subsequence (r ++ [f]) r')` - (ho_match_mp_tac (theorem "is_subsequence_ind") +Theorem is_subsequence_snoc': + !r r'. is_subsequence (r ++ [f]) (r' ++ [h]) = + (((f = h) /\ is_subsequence r r') \/ is_subsequence (r ++ [f]) r') +Proof + ho_match_mp_tac (theorem "is_subsequence_ind") >> rpt strip_tac >> fs[is_subsequence_cons,is_subsequence_nil] >> Induct_on `r'` >> rpt strip_tac >> fs[is_subsequence_nil,is_subsequence_cons] - >> metis_tac[]); - -Theorem snoc_is_subsequence ` - !s l f. is_subsequence s l ==> is_subsequence s (l++[f])` - (ho_match_mp_tac SNOC_INDUCT - >> rw[is_subsequence_snoc',is_subsequence_nil,SNOC_APPEND]); - -Theorem is_subsequence_appendr ` - !l' s l. is_subsequence s l ==> is_subsequence s (l++l')` - (Induct + >> metis_tac[] +QED + +Theorem snoc_is_subsequence: + !s l f. is_subsequence s l ==> is_subsequence s (l++[f]) +Proof + ho_match_mp_tac SNOC_INDUCT + >> rw[is_subsequence_snoc',is_subsequence_nil,SNOC_APPEND] +QED + +Theorem is_subsequence_appendr: + !l' s l. is_subsequence s l ==> is_subsequence s (l++l') +Proof + Induct >> rpt strip_tac >> fs[] >> drule snoc_is_subsequence >> disch_then(qspec_then `h` assume_tac) >> first_x_assum drule - >> FULL_SIMP_TAC bool_ss [GSYM APPEND_ASSOC,GSYM CONS_APPEND]) + >> FULL_SIMP_TAC bool_ss [GSYM APPEND_ASSOC,GSYM CONS_APPEND] +QED -Theorem is_subsequence_appendl ` - !l' s l. is_subsequence s l ==> is_subsequence s (l'++l)` - (Induct +Theorem is_subsequence_appendl: + !l' s l. is_subsequence s l ==> is_subsequence s (l'++l) +Proof + Induct >> rpt strip_tac >> fs[] - >> match_mp_tac cons_is_subsequence >> metis_tac[]); + >> match_mp_tac cons_is_subsequence >> metis_tac[] +QED -Theorem is_subsequence_append - `!l l' r r'. is_subsequence l l' /\ is_subsequence r r' ==> is_subsequence(l++r) (l'++r')` - (ho_match_mp_tac (fetch "lcs" "is_subsequence_ind") +Theorem is_subsequence_append: + !l l' r r'. is_subsequence l l' /\ is_subsequence r r' ==> is_subsequence(l++r) (l'++r') +Proof + ho_match_mp_tac (fetch "lcs" "is_subsequence_ind") >> rpt strip_tac >- (fs[is_subsequence_def] >> metis_tac[is_subsequence_appendl]) >> Cases_on `l'` >- fs[is_subsequence_def] - >> fs[is_subsequence_cons]); + >> fs[is_subsequence_cons] +QED -Theorem is_subsequence_length ` - !l l'. is_subsequence l l' ==> LENGTH l <= LENGTH l'` - (ho_match_mp_tac (theorem "is_subsequence_ind") +Theorem is_subsequence_length: + !l l'. is_subsequence l l' ==> LENGTH l <= LENGTH l' +Proof + ho_match_mp_tac (theorem "is_subsequence_ind") >> rpt strip_tac >- fs[is_subsequence_nil] >> Cases_on `l'` >- fs[is_subsequence_nil] >> fs[is_subsequence_cons] - >> metis_tac [suffix_is_subsequence]); + >> metis_tac [suffix_is_subsequence] +QED -Theorem is_subsequence_cons' ` - !s l f. is_subsequence s (f::l) +Theorem is_subsequence_cons': + !s l f. is_subsequence s (f::l) ==> ((((s = []) \/ f ≠ HD s) /\ is_subsequence s l) - \/ (((s ≠ []) /\ (f = HD s)) /\ is_subsequence (TL s) l))` - (ho_match_mp_tac (theorem "is_subsequence_ind") + \/ (((s ≠ []) /\ (f = HD s)) /\ is_subsequence (TL s) l)) +Proof + ho_match_mp_tac (theorem "is_subsequence_ind") >> rpt strip_tac >- fs[is_subsequence_nil] >> Cases_on `l` >- fs[is_subsequence_nil, Once is_subsequence_def] >- (Cases_on `f' = f` >> fs[is_subsequence_cons] >> rfs[] - >> metis_tac [cons_is_subsequence])); + >> metis_tac [cons_is_subsequence]) +QED -Theorem is_subsequence_snoc'' ` - !s l f. is_subsequence s (l ++ [f]) +Theorem is_subsequence_snoc'': + !s l f. is_subsequence s (l ++ [f]) ==> ((((s = []) \/ f ≠ LAST s) /\ is_subsequence s l) - \/ (((s ≠ []) /\ (f = LAST s)) /\ is_subsequence (FRONT s) l))` - (ho_match_mp_tac (theorem "is_subsequence_ind") + \/ (((s ≠ []) /\ (f = LAST s)) /\ is_subsequence (FRONT s) l)) +Proof + ho_match_mp_tac (theorem "is_subsequence_ind") >> rpt strip_tac >- fs[is_subsequence_nil] >> Cases_on `l` @@ -201,23 +234,32 @@ Theorem is_subsequence_snoc'' ` >- (Cases_on `f' = f` >> fs[is_subsequence_snoc'] >> fs[is_subsequence_cons] >> rpt(first_x_assum(ASSUME_TAC o Q.SPEC `f'`)) - >> rfs[is_subsequence_nil] >> Cases_on `s` >> fs[is_subsequence_nil,is_subsequence_cons])); - -Theorem common_subsequence_append - `common_subsequence a b c /\ common_subsequence a' b' c' ==> common_subsequence(a++a') (b++b') (c++c')` - (fs[common_subsequence_def,is_subsequence_append]) - -Theorem common_subsequence_sym - `common_subsequence u u u` - (fs[common_subsequence_def,is_subsequence_refl]) - -Theorem common_subsequence_sym - `common_subsequence s u t = common_subsequence s t u` - (fs[common_subsequence_def,EQ_IMP_THM]) - -Theorem lcs_refl - `lcs l l l` - (fs[lcs_def,common_subsequence_def,is_subsequence_refl,is_subsequence_length]); + >> rfs[is_subsequence_nil] >> Cases_on `s` >> fs[is_subsequence_nil,is_subsequence_cons]) +QED + +Theorem common_subsequence_append: + common_subsequence a b c /\ common_subsequence a' b' c' ==> common_subsequence(a++a') (b++b') (c++c') +Proof + fs[common_subsequence_def,is_subsequence_append] +QED + +Theorem common_subsequence_sym: + common_subsequence u u u +Proof + fs[common_subsequence_def,is_subsequence_refl] +QED + +Theorem common_subsequence_sym: + common_subsequence s u t = common_subsequence s t u +Proof + fs[common_subsequence_def,EQ_IMP_THM] +QED + +Theorem lcs_refl: + lcs l l l +Proof + fs[lcs_def,common_subsequence_def,is_subsequence_refl,is_subsequence_length] +QED val is_subsequence_greater = Q.prove( `!l' l. is_subsequence l' l /\ LENGTH l ≤ LENGTH l' @@ -229,31 +271,40 @@ val is_subsequence_greater = Q.prove( >> fs[is_subsequence_cons,is_subsequence_nil] >> rfs[]); -Theorem lcs_refl' - `lcs l' l l = (l = l')` - (fs[lcs_def,common_subsequence_def,EQ_IMP_THM,is_subsequence_refl,is_subsequence_length] +Theorem lcs_refl': + lcs l' l l = (l = l') +Proof + fs[lcs_def,common_subsequence_def,EQ_IMP_THM,is_subsequence_refl,is_subsequence_length] >> rpt strip_tac >> first_x_assum(assume_tac o Q.SPEC `l`) - >> fs[is_subsequence_refl,is_subsequence_greater]); + >> fs[is_subsequence_refl,is_subsequence_greater] +QED -Theorem lcs_sym - `lcs l l' l'' = lcs l l'' l'` - (metis_tac[lcs_def,common_subsequence_sym]); +Theorem lcs_sym: + lcs l l' l'' = lcs l l'' l' +Proof + metis_tac[lcs_def,common_subsequence_sym] +QED val lcs_empty = Q.prove(`lcs [] l [] /\ lcs [] [] l`, fs[lcs_def,common_subsequence_def,is_subsequence_nil]); -Theorem lcs_empty' - `(lcs l l' [] = (l = [])) /\ (lcs l [] l' = (l = []))` - (fs[lcs_def,common_subsequence_def,is_subsequence_nil,EQ_IMP_THM]); - -Theorem common_subsequence_empty' - `(common_subsequence l l' [] = (l = [])) /\ (common_subsequence l [] l' = (l = []))` - (fs[common_subsequence_def,is_subsequence_nil,EQ_IMP_THM]); - -Theorem cons_lcs_optimal_substructure - `lcs (f::l) (f::l') (f::l'') = lcs l l' l''` - (fs[lcs_def,common_subsequence_def, Once is_subsequence_def, EQ_IMP_THM] +Theorem lcs_empty': + (lcs l l' [] = (l = [])) /\ (lcs l [] l' = (l = [])) +Proof + fs[lcs_def,common_subsequence_def,is_subsequence_nil,EQ_IMP_THM] +QED + +Theorem common_subsequence_empty': + (common_subsequence l l' [] = (l = [])) /\ (common_subsequence l [] l' = (l = [])) +Proof + fs[common_subsequence_def,is_subsequence_nil,EQ_IMP_THM] +QED + +Theorem cons_lcs_optimal_substructure: + lcs (f::l) (f::l') (f::l'') = lcs l l' l'' +Proof + fs[lcs_def,common_subsequence_def, Once is_subsequence_def, EQ_IMP_THM] >> rpt strip_tac >> first_assum(ASSUME_TAC o Q.SPEC `f::s'`) >> fs[is_subsequence_cons] @@ -265,32 +316,38 @@ Theorem cons_lcs_optimal_substructure >- metis_tac[cons_is_subsequence, LESS_EQ_SUC_REFL, LESS_EQ_TRANS] >- (`LENGTH(TL s') ≤ LENGTH l` by metis_tac[cons_is_subsequence, LESS_EQ_SUC_REFL, LESS_EQ_TRANS] >> Cases_on `s'` - >> fs[])); + >> fs[]) +QED -Theorem cons_common_subsequence - `common_subsequence (f::l) (f::l') (f::l'') = common_subsequence l l' l''` - (fs[common_subsequence_def, Once is_subsequence_def, EQ_IMP_THM] +Theorem cons_common_subsequence: + common_subsequence (f::l) (f::l') (f::l'') = common_subsequence l l' l'' +Proof + fs[common_subsequence_def, Once is_subsequence_def, EQ_IMP_THM] >> rpt strip_tac >> fs[is_subsequence_cons] - >> metis_tac[suffix_is_subsequence]); + >> metis_tac[suffix_is_subsequence] +QED -Theorem snoc_lcs_optimal_substructure - `lcs (l ++ [f]) (l' ++ [f]) (l'' ++ [f]) = lcs l l' l''` - (fs[lcs_def,common_subsequence_def, Once is_subsequence_def, EQ_IMP_THM] +Theorem snoc_lcs_optimal_substructure: + lcs (l ++ [f]) (l' ++ [f]) (l'' ++ [f]) = lcs l l' l'' +Proof + fs[lcs_def,common_subsequence_def, Once is_subsequence_def, EQ_IMP_THM] >> rpt strip_tac >> first_assum(ASSUME_TAC o Q.SPEC `s' ++ [f]`) >> rpt(first_x_assum(assume_tac o MATCH_MP is_subsequence_snoc'')) >> fs[is_subsequence_snoc,FRONT_APPEND] >> TRY(metis_tac[prefix_is_subsequence]) >- (`LENGTH s' ≤ LENGTH l` by fs[] >> fs[]) - >- (`LENGTH(FRONT s') ≤ LENGTH l` by fs[] >> Cases_on `s'` >> fs[])); + >- (`LENGTH(FRONT s') ≤ LENGTH l` by fs[] >> Cases_on `s'` >> fs[]) +QED -Theorem cons_lcs_optimal_substructure_left - `f ≠ f' /\ lcs l (f::l') l'' +Theorem cons_lcs_optimal_substructure_left: + f ≠ f' /\ lcs l (f::l') l'' /\ lcs l''' l' (f'::l'') /\ LENGTH l >= LENGTH l''' - ==> lcs l (f::l') (f'::l'')` - (fs[lcs_def,common_subsequence_def, Once is_subsequence_def, EQ_IMP_THM] + ==> lcs l (f::l') (f'::l'') +Proof + fs[lcs_def,common_subsequence_def, Once is_subsequence_def, EQ_IMP_THM] >> rpt strip_tac >- metis_tac[cons_is_subsequence] >> PAT_ASSUM ``is_subsequence s' (f'::l'')`` (assume_tac o MATCH_MP is_subsequence_cons') @@ -299,14 +356,16 @@ Theorem cons_lcs_optimal_substructure_left >> Cases_on `s'` >> fs[is_subsequence_cons] >> `LENGTH(h::t) ≤ LENGTH l'''` by(first_assum match_mp_tac >> fs[is_subsequence_cons]) - >> fs[]); + >> fs[] +QED -Theorem snoc_lcs_optimal_substructure_left - `f ≠ f' /\ lcs l (l' ++ [f]) l'' +Theorem snoc_lcs_optimal_substructure_left: + f ≠ f' /\ lcs l (l' ++ [f]) l'' /\ lcs l''' l' (l''++[f']) /\ LENGTH l >= LENGTH l''' - ==> lcs l (l'++[f]) (l''++[f'])` - (fs[lcs_def,common_subsequence_def, is_subsequence_snoc', EQ_IMP_THM] + ==> lcs l (l'++[f]) (l''++[f']) +Proof + fs[lcs_def,common_subsequence_def, is_subsequence_snoc', EQ_IMP_THM] >> rpt strip_tac >- metis_tac[snoc_is_subsequence] >> PAT_ASSUM ``is_subsequence s' (l''++[f'])`` (assume_tac o MATCH_MP is_subsequence_snoc'') @@ -315,154 +374,203 @@ Theorem snoc_lcs_optimal_substructure_left >> FULL_STRUCT_CASES_TAC (Q.SPEC `s'` SNOC_CASES) >> fs[is_subsequence_snoc',SNOC_APPEND] >> `LENGTH(l''''++[x]) ≤ LENGTH l'''` by(first_assum match_mp_tac >> fs[is_subsequence_snoc']) - >> fs[]); + >> fs[] +QED -Theorem cons_lcs_optimal_substructure_right ` - f ≠ f' /\ lcs l (f::l') l'' +Theorem cons_lcs_optimal_substructure_right: + f ≠ f' /\ lcs l (f::l') l'' /\ lcs l''' l' (f'::l'') /\ LENGTH l''' >= LENGTH l - ==> lcs l''' (f::l') (f'::l'')` - (metis_tac[cons_lcs_optimal_substructure_left,lcs_sym]); + ==> lcs l''' (f::l') (f'::l'') +Proof + metis_tac[cons_lcs_optimal_substructure_left,lcs_sym] +QED -Theorem snoc_lcs_optimal_substructure_right ` - f ≠ f' /\ lcs l (l'++[f]) l'' +Theorem snoc_lcs_optimal_substructure_right: + f ≠ f' /\ lcs l (l'++[f]) l'' /\ lcs l''' l' (l''++[f']) /\ LENGTH l''' >= LENGTH l - ==> lcs l''' (l'++[f]) (l''++[f'])` - (metis_tac[snoc_lcs_optimal_substructure_left,lcs_sym]); - -Theorem lcs_length_left ` - (lcs xl yl zl /\ lcs xl' (yl ++ [y]) zl) - ==> SUC(LENGTH xl) >= LENGTH xl'` - (fs[lcs_def,common_subsequence_def] >> rpt strip_tac + ==> lcs l''' (l'++[f]) (l''++[f']) +Proof + metis_tac[snoc_lcs_optimal_substructure_left,lcs_sym] +QED + +Theorem lcs_length_left: + (lcs xl yl zl /\ lcs xl' (yl ++ [y]) zl) + ==> SUC(LENGTH xl) >= LENGTH xl' +Proof + fs[lcs_def,common_subsequence_def] >> rpt strip_tac >> first_assum(assume_tac o MATCH_MP is_subsequence_snoc'') >> fs[] >- (`LENGTH xl' <= LENGTH xl` by metis_tac[] >> fs[]) >> FULL_STRUCT_CASES_TAC (Q.SPEC `xl'` SNOC_CASES) >> fs[SNOC_APPEND] >> rpt(first_x_assum(assume_tac o MATCH_MP prefix_is_subsequence)) - >> `LENGTH l <= LENGTH xl` by metis_tac[] >> fs[]) - -Theorem lcs_length_right ` - (lcs xl yl zl /\ lcs xl' (yl) (zl ++ [z])) - ==> SUC(LENGTH xl) >= LENGTH xl'` - (metis_tac[lcs_sym,lcs_length_left]); - -Theorem lcs_length - `!l l' r r'. lcs l r r' /\ lcs l' r r' ==> LENGTH l = LENGTH l'` - (rpt strip_tac >> fs[lcs_def] - >> metis_tac[EQ_LESS_EQ]); - -Theorem is_subsequence_rev ` - !l r. is_subsequence (REVERSE l) (REVERSE r) = is_subsequence l r` - (ho_match_mp_tac (theorem "is_subsequence_ind") + >> `LENGTH l <= LENGTH xl` by metis_tac[] >> fs[] +QED + +Theorem lcs_length_right: + (lcs xl yl zl /\ lcs xl' (yl) (zl ++ [z])) + ==> SUC(LENGTH xl) >= LENGTH xl' +Proof + metis_tac[lcs_sym,lcs_length_left] +QED + +Theorem lcs_length: + !l l' r r'. lcs l r r' /\ lcs l' r r' ==> LENGTH l = LENGTH l' +Proof + rpt strip_tac >> fs[lcs_def] + >> metis_tac[EQ_LESS_EQ] +QED + +Theorem is_subsequence_rev: + !l r. is_subsequence (REVERSE l) (REVERSE r) = is_subsequence l r +Proof + ho_match_mp_tac (theorem "is_subsequence_ind") >> rpt strip_tac >> fs[is_subsequence_nil] >> Cases_on `r` - >> fs[is_subsequence_nil,is_subsequence_snoc',is_subsequence_cons]); + >> fs[is_subsequence_nil,is_subsequence_snoc',is_subsequence_cons] +QED -Theorem is_subsequence_rev' ` - !l r. is_subsequence l (REVERSE r) = is_subsequence (REVERSE l) r` - (ho_match_mp_tac SNOC_INDUCT +Theorem is_subsequence_rev': + !l r. is_subsequence l (REVERSE r) = is_subsequence (REVERSE l) r +Proof + ho_match_mp_tac SNOC_INDUCT >> strip_tac >- fs[is_subsequence_nil] >> rpt strip_tac >> Induct_on `r` - >> fs[is_subsequence_nil,is_subsequence_cons,is_subsequence_snoc',SNOC_APPEND,REVERSE_APPEND]); - -Theorem common_subsequence_rev - `!l r s. common_subsequence (REVERSE l) (REVERSE r) (REVERSE s) = common_subsequence l r s` - (rw[common_subsequence_def,is_subsequence_rev]); - -Theorem common_subsequence_rev' - `!l r s. common_subsequence l (REVERSE r) (REVERSE s) = common_subsequence (REVERSE l) r s` - (rw[common_subsequence_def,is_subsequence_rev']); - -Theorem lcs_rev - `!l r s. lcs (REVERSE l) (REVERSE r) (REVERSE s) = lcs l r s` - (rw[common_subsequence_rev',lcs_def,EQ_IMP_THM] - >> metis_tac[LENGTH_REVERSE,REVERSE_REVERSE]); - -Theorem lcs_rev' - `!l r s. lcs l (REVERSE r) (REVERSE s) = lcs (REVERSE l) r s` - (rw[common_subsequence_rev',lcs_def,EQ_IMP_THM] - >> metis_tac[LENGTH_REVERSE,REVERSE_REVERSE]); - -Theorem lcs_drop_ineq -`(lcs (f::r) (h::l) l' /\ f ≠ h) ==> lcs (f::r) l l'` - (rpt strip_tac + >> fs[is_subsequence_nil,is_subsequence_cons,is_subsequence_snoc',SNOC_APPEND,REVERSE_APPEND] +QED + +Theorem common_subsequence_rev: + !l r s. common_subsequence (REVERSE l) (REVERSE r) (REVERSE s) = common_subsequence l r s +Proof + rw[common_subsequence_def,is_subsequence_rev] +QED + +Theorem common_subsequence_rev': + !l r s. common_subsequence l (REVERSE r) (REVERSE s) = common_subsequence (REVERSE l) r s +Proof + rw[common_subsequence_def,is_subsequence_rev'] +QED + +Theorem lcs_rev: + !l r s. lcs (REVERSE l) (REVERSE r) (REVERSE s) = lcs l r s +Proof + rw[common_subsequence_rev',lcs_def,EQ_IMP_THM] + >> metis_tac[LENGTH_REVERSE,REVERSE_REVERSE] +QED + +Theorem lcs_rev': + !l r s. lcs l (REVERSE r) (REVERSE s) = lcs (REVERSE l) r s +Proof + rw[common_subsequence_rev',lcs_def,EQ_IMP_THM] + >> metis_tac[LENGTH_REVERSE,REVERSE_REVERSE] +QED + +Theorem lcs_drop_ineq: + (lcs (f::r) (h::l) l' /\ f ≠ h) ==> lcs (f::r) l l' +Proof + rpt strip_tac >> fs[lcs_def,common_subsequence_def,Once is_subsequence_cons] - >> metis_tac[cons_is_subsequence]); + >> metis_tac[cons_is_subsequence] +QED -Theorem common_subsequence_drop_ineq -`(common_subsequence (f::r) (h::l) l' /\ f ≠ h) ==> common_subsequence (f::r) l l'` - (rpt strip_tac +Theorem common_subsequence_drop_ineq: + (common_subsequence (f::r) (h::l) l' /\ f ≠ h) ==> common_subsequence (f::r) l l' +Proof + rpt strip_tac >> fs[common_subsequence_def,Once is_subsequence_cons] - >> metis_tac[cons_is_subsequence]); + >> metis_tac[cons_is_subsequence] +QED -Theorem lcs_split - `lcs (f::r) l l' ==> ?ll lr. SPLITP ($= f) l = (ll,f::lr)` - (Induct_on `l` +Theorem lcs_split: + lcs (f::r) l l' ==> ?ll lr. SPLITP ($= f) l = (ll,f::lr) +Proof + Induct_on `l` >> rw[lcs_empty',SPLITP] >> fs[SPLITP] - >> metis_tac[lcs_drop_ineq,SND]); + >> metis_tac[lcs_drop_ineq,SND] +QED -Theorem common_subsequence_split - `common_subsequence (f::r) l l' ==> ?ll lr. SPLITP ($= f) l = (ll,f::lr)` - (Induct_on `l` +Theorem common_subsequence_split: + common_subsequence (f::r) l l' ==> ?ll lr. SPLITP ($= f) l = (ll,f::lr) +Proof + Induct_on `l` >> rw[common_subsequence_empty',SPLITP] >> fs[SPLITP] - >> metis_tac[common_subsequence_drop_ineq,SND]); - -Theorem lcs_split2 - `lcs (f::r) l l' ==> ?ll lr. SPLITP ($= f) l' = (ll,f::lr)` - (metis_tac[lcs_split,lcs_sym]); - -Theorem common_subsequence_split2 - `common_subsequence (f::r) l l' ==> ?ll lr. SPLITP ($= f) l' = (ll,f::lr)` - (metis_tac[common_subsequence_split,common_subsequence_sym]); - -Theorem lcs_split_lcs - `lcs (f::r) l l' ==> lcs (f::r) (SND(SPLITP ($= f) l)) l'` - (Induct_on `l` + >> metis_tac[common_subsequence_drop_ineq,SND] +QED + +Theorem lcs_split2: + lcs (f::r) l l' ==> ?ll lr. SPLITP ($= f) l' = (ll,f::lr) +Proof + metis_tac[lcs_split,lcs_sym] +QED + +Theorem common_subsequence_split2: + common_subsequence (f::r) l l' ==> ?ll lr. SPLITP ($= f) l' = (ll,f::lr) +Proof + metis_tac[common_subsequence_split,common_subsequence_sym] +QED + +Theorem lcs_split_lcs: + lcs (f::r) l l' ==> lcs (f::r) (SND(SPLITP ($= f) l)) l' +Proof + Induct_on `l` >> rw[lcs_empty',SPLITP] - >> metis_tac[lcs_drop_ineq,SND]); + >> metis_tac[lcs_drop_ineq,SND] +QED -Theorem common_subsequence_split_css - `common_subsequence (f::r) l l' ==> common_subsequence (f::r) (SND(SPLITP ($= f) l)) l'` - (Induct_on `l` +Theorem common_subsequence_split_css: + common_subsequence (f::r) l l' ==> common_subsequence (f::r) (SND(SPLITP ($= f) l)) l' +Proof + Induct_on `l` >> rw[common_subsequence_empty',SPLITP] - >> metis_tac[common_subsequence_drop_ineq,SND]); - -Theorem lcs_split_lcs2 - `lcs (f::r) l l' ==> lcs (f::r) l (SND(SPLITP ($= f) l'))` - (metis_tac[lcs_split_lcs,lcs_sym]); - -Theorem common_subsequence_split_css2 - `common_subsequence (f::r) l l' ==> common_subsequence (f::r) l (SND(SPLITP ($= f) l'))` - (metis_tac[common_subsequence_split_css,common_subsequence_sym]); - -Theorem split_lcs_optimal_substructure - `lcs (f::r) l l' ==> lcs r (TL(SND(SPLITP ($= f) l))) (TL(SND(SPLITP ($= f) l')))` - (rpt strip_tac >> + >> metis_tac[common_subsequence_drop_ineq,SND] +QED + +Theorem lcs_split_lcs2: + lcs (f::r) l l' ==> lcs (f::r) l (SND(SPLITP ($= f) l')) +Proof + metis_tac[lcs_split_lcs,lcs_sym] +QED + +Theorem common_subsequence_split_css2: + common_subsequence (f::r) l l' ==> common_subsequence (f::r) l (SND(SPLITP ($= f) l')) +Proof + metis_tac[common_subsequence_split_css,common_subsequence_sym] +QED + +Theorem split_lcs_optimal_substructure: + lcs (f::r) l l' ==> lcs r (TL(SND(SPLITP ($= f) l))) (TL(SND(SPLITP ($= f) l'))) +Proof + rpt strip_tac >> drule lcs_split >> drule lcs_split2 >> pop_assum (assume_tac o MATCH_MP lcs_split_lcs2 o MATCH_MP lcs_split_lcs) >> rpt strip_tac - >> fs[cons_lcs_optimal_substructure]); + >> fs[cons_lcs_optimal_substructure] +QED -Theorem split_common_subsequence - `common_subsequence (f::r) l l' ==> common_subsequence r (TL(SND(SPLITP ($= f) l))) (TL(SND(SPLITP ($= f) l')))` - (rpt strip_tac >> +Theorem split_common_subsequence: + common_subsequence (f::r) l l' ==> common_subsequence r (TL(SND(SPLITP ($= f) l))) (TL(SND(SPLITP ($= f) l'))) +Proof + rpt strip_tac >> drule common_subsequence_split >> drule common_subsequence_split2 >> pop_assum (assume_tac o MATCH_MP common_subsequence_split_css2 o MATCH_MP common_subsequence_split_css) >> rpt strip_tac - >> fs[cons_common_subsequence]); + >> fs[cons_common_subsequence] +QED -Theorem lcs_max_length - `!l t t'. lcs l t t' ==> 2 * LENGTH l <= LENGTH t + LENGTH t'` - (rpt strip_tac >> fs[lcs_def,common_subsequence_def] +Theorem lcs_max_length: + !l t t'. lcs l t t' ==> 2 * LENGTH l <= LENGTH t + LENGTH t' +Proof + rpt strip_tac >> fs[lcs_def,common_subsequence_def] >> drule is_subsequence_length >> qpat_x_assum `is_subsequence _ _` kall_tac - >> drule is_subsequence_length >> fs[]); + >> drule is_subsequence_length >> fs[] +QED (* A naive, exponential-time LCS algorithm that's easy to verify *) @@ -481,27 +589,34 @@ Define (* Properties of the naive lcs algorithm *) -Theorem longest_tail - `longest (l ++ [e]) (l' ++ [e]) = longest l l' ++ [e]` - (rw[longest_def,GSYM ADD1] >> fs[]) +Theorem longest_tail: + longest (l ++ [e]) (l' ++ [e]) = longest l l' ++ [e] +Proof + rw[longest_def,GSYM ADD1] >> fs[] +QED -Theorem longest_cons - `longest (e::l) (e::l') = e::longest l l'` - (rw[longest_def,GSYM ADD1] >> fs[]) +Theorem longest_cons: + longest (e::l) (e::l') = e::longest l l' +Proof + rw[longest_def,GSYM ADD1] >> fs[] +QED -Theorem naive_lcs_clauses ` -(naive_lcs l [] = []) ∧ +Theorem naive_lcs_clauses: + (naive_lcs l [] = []) ∧ (naive_lcs [] l = []) ∧ (naive_lcs (f::r) (f'::r') = if f = f' then f::naive_lcs r r' else - longest(naive_lcs (f::r) r') (naive_lcs r (f'::r')))` - (Cases_on `l` >> fs[naive_lcs_def]); - -Theorem naive_lcs_tail ` - !prevh fullr h. naive_lcs (prevh ++ [h]) (fullr ++ [h]) = naive_lcs prevh fullr ++ [h]` - (ho_match_mp_tac (theorem "naive_lcs_ind") + longest(naive_lcs (f::r) r') (naive_lcs r (f'::r'))) +Proof + Cases_on `l` >> fs[naive_lcs_def] +QED + +Theorem naive_lcs_tail: + !prevh fullr h. naive_lcs (prevh ++ [h]) (fullr ++ [h]) = naive_lcs prevh fullr ++ [h] +Proof + ho_match_mp_tac (theorem "naive_lcs_ind") >> rpt strip_tac >- (fs[naive_lcs_clauses] >> Induct_on `prevh` @@ -510,12 +625,15 @@ Theorem naive_lcs_tail ` >> Induct_on `v3` (*TODO: generated name *) >> rw[naive_lcs_clauses,longest_def]) >> rw[naive_lcs_clauses] - >> fs[longest_tail]); + >> fs[longest_tail] +QED -Theorem naive_lcs_length_bound ` - !l l'. LENGTH (naive_lcs l l') <= MIN (LENGTH l) (LENGTH l')` - (ho_match_mp_tac (theorem "naive_lcs_ind") - >> rw[naive_lcs_clauses, MIN_DEF, longest_def]); +Theorem naive_lcs_length_bound: + !l l'. LENGTH (naive_lcs l l') <= MIN (LENGTH l) (LENGTH l') +Proof + ho_match_mp_tac (theorem "naive_lcs_ind") + >> rw[naive_lcs_clauses, MIN_DEF, longest_def] +QED val naive_lcs_length = Q.prove( `!l l' h. LENGTH(naive_lcs l l') + 1 >= LENGTH(naive_lcs l (l' ++ [h]))`, @@ -542,9 +660,10 @@ val naive_lcs_length' = Q.prove( (* Main correctness theorem for the naive lcs algorithm *) -Theorem naive_lcs_correct - `∀l l'. lcs (naive_lcs l l') l l'` - (ho_match_mp_tac (theorem "naive_lcs_ind") +Theorem naive_lcs_correct: + ∀l l'. lcs (naive_lcs l l') l l' +Proof + ho_match_mp_tac (theorem "naive_lcs_ind") >> rpt strip_tac (* Base cases *) >- fs[naive_lcs_def,lcs_def,common_subsequence_def,is_subsequence_nil] @@ -555,7 +674,8 @@ Theorem naive_lcs_correct >> rw[naive_lcs_def, longest_def] >- metis_tac[cons_lcs_optimal_substructure_left] >> `LENGTH (naive_lcs l (f'::l')) ≥ (LENGTH (naive_lcs (f::l) l'))` by fs[] - >> metis_tac[cons_lcs_optimal_substructure_right]); + >> metis_tac[cons_lcs_optimal_substructure_right] +QED (* A quadratic-time LCS algorithm in dynamic programming style *) @@ -608,12 +728,13 @@ val dynamic_lcs_rows_invariant_def = Define ` (!n. 0 <= n /\ n < LENGTH previous_row ==> (lcs (REVERSE(FST(EL n previous_row))) (TAKE (LENGTH fullh - LENGTH h) fullh) (TAKE (SUC n) r))) ∧ (!n. 0 <= n /\ n < LENGTH previous_row ==> (SND(EL n previous_row) = LENGTH(FST(EL n previous_row)))))`; -Theorem dynamic_lcs_row_invariant_pres1 ` - dynamic_lcs_row_invariant h (h::r) previous_col previous_row (diagonal,dl) prevh fullr +Theorem dynamic_lcs_row_invariant_pres1: + dynamic_lcs_row_invariant h (h::r) previous_col previous_row (diagonal,dl) prevh fullr ==> dynamic_lcs_row_invariant h r (longest' (h::diagonal,dl+1) (longest' (HD previous_row) previous_col)) - (TL previous_row) (HD previous_row) prevh fullr` - (Cases_on `previous_col` + (TL previous_row) (HD previous_row) prevh fullr +Proof + Cases_on `previous_col` >> rename1 `(previous_col,pcl)` >> fs[dynamic_lcs_row_invariant_def] >> rpt strip_tac @@ -650,13 +771,15 @@ Theorem dynamic_lcs_row_invariant_pres1 ` >> PAT_ASSUM ``IS_SUFFIX fullr (h::r)`` (assume_tac o MATCH_MP is_suffix_drop) >> rfs[] >> fs[] >> metis_tac[ADD1,lcs_length_right,LENGTH_REVERSE]) (* longest is from previous column *) - >- metis_tac[ADD1,lcs_length_left,LENGTH_REVERSE])); + >- metis_tac[ADD1,lcs_length_left,LENGTH_REVERSE]) +QED -Theorem dynamic_lcs_row_invariant_pres2 ` - h ≠ f ∧ dynamic_lcs_row_invariant h (f::r) previous_col previous_row diagonal fullh fullr +Theorem dynamic_lcs_row_invariant_pres2: + h ≠ f ∧ dynamic_lcs_row_invariant h (f::r) previous_col previous_row diagonal fullh fullr ==> dynamic_lcs_row_invariant h r (longest' (HD previous_row) previous_col) (TL previous_row) - (HD previous_row) fullh fullr` - (fs[dynamic_lcs_row_invariant_def] + (HD previous_row) fullh fullr +Proof + fs[dynamic_lcs_row_invariant_def] >> rpt strip_tac >- (Cases_on `previous_row` >> fs[]) >- metis_tac[IS_SUFFIX_CONS2_E] @@ -697,20 +820,24 @@ Theorem dynamic_lcs_row_invariant_pres2 ` >> first_x_assum (assume_tac o Q.SPEC `0`) >> rfs[] >> fs[Q.SPEC `1` ADD_SYM] >> fs[TAKE_SUM] >> PAT_ASSUM ``IS_SUFFIX fullr (f::r)`` (assume_tac o MATCH_MP is_suffix_drop) - >> rfs[] >> fs[]))); - -Theorem dynamic_lcs_length ` - !h r previous_col previous_row diagonal. - LENGTH(dynamic_lcs_row h r previous_col previous_row diagonal) = LENGTH r` - (Induct_on `r` >> Cases_on `diagonal` >> rw[dynamic_lcs_row_def]); - -Theorem dynamic_lcs_row_invariant_pres ` - !h r previous_col previous_row diagonal prevh fullr l n. + >> rfs[] >> fs[])) +QED + +Theorem dynamic_lcs_length: + !h r previous_col previous_row diagonal. + LENGTH(dynamic_lcs_row h r previous_col previous_row diagonal) = LENGTH r +Proof + Induct_on `r` >> Cases_on `diagonal` >> rw[dynamic_lcs_row_def] +QED + +Theorem dynamic_lcs_row_invariant_pres: + !h r previous_col previous_row diagonal prevh fullr l n. (dynamic_lcs_row_invariant h r previous_col previous_row diagonal prevh fullr /\ (dynamic_lcs_row h r previous_col previous_row diagonal = l) /\ (0 <= n) /\ (n < LENGTH l)) - ==> (lcs (REVERSE (FST(EL n l))) (prevh ++ [h]) (TAKE (SUC n + (LENGTH fullr - (LENGTH l))) fullr))` - (Induct_on `r` + ==> (lcs (REVERSE (FST(EL n l))) (prevh ++ [h]) (TAKE (SUC n + (LENGTH fullr - (LENGTH l))) fullr)) +Proof + Induct_on `r` >> rpt strip_tac >> Cases_on `diagonal` >> rename1 `(diagonal,dl)` @@ -767,15 +894,17 @@ Theorem dynamic_lcs_row_invariant_pres ` `longest' (HD previous_row) previous_col`, `TL previous_row`, `HD previous_row`, `prevh`, `fullr`,`n'`]) - >> rfs[] >> metis_tac[sub_le_suc])); + >> rfs[] >> metis_tac[sub_le_suc]) +QED -Theorem dynamic_lcs_row_invariant_pres2 ` - !h r previous_col previous_row diagonal prevh fullr l n. +Theorem dynamic_lcs_row_invariant_pres2: + !h r previous_col previous_row diagonal prevh fullr l n. (dynamic_lcs_row_invariant h r previous_col previous_row diagonal prevh fullr /\ (dynamic_lcs_row h r previous_col previous_row diagonal = l) /\ (0 <= n) /\ (n < LENGTH l)) - ==> (SND (EL n l) = LENGTH (FST (EL n l)))` - (Induct_on `r` + ==> (SND (EL n l) = LENGTH (FST (EL n l))) +Proof + Induct_on `r` >> rpt strip_tac >> Cases_on `diagonal` >> rename1 `(diagonal,dl)` @@ -822,12 +951,14 @@ Theorem dynamic_lcs_row_invariant_pres2 ` `longest' (HD previous_row) previous_col`, `TL previous_row`, `HD previous_row`, `prevh`, `fullr`,`n'`]) - >> rfs[])); + >> rfs[]) +QED -Theorem dynamic_lcs_rows_invariant_pres ` - dynamic_lcs_rows_invariant (h::l) r previous_row fullh - ==> dynamic_lcs_rows_invariant l r (dynamic_lcs_row h r ([],0) previous_row ([],0)) fullh` - (fs[dynamic_lcs_rows_invariant_def] +Theorem dynamic_lcs_rows_invariant_pres: + dynamic_lcs_rows_invariant (h::l) r previous_row fullh + ==> dynamic_lcs_rows_invariant l r (dynamic_lcs_row h r ([],0) previous_row ([],0)) fullh +Proof + fs[dynamic_lcs_rows_invariant_def] >> rpt strip_tac >- fs[dynamic_lcs_length] >- metis_tac[IS_SUFFIX_CONS2_E] @@ -852,13 +983,15 @@ Theorem dynamic_lcs_rows_invariant_pres ` >> Q.EXISTS_TAC `([],0)` >> Q.EXISTS_TAC `(TAKE (LENGTH fullh − SUC (LENGTH l)) fullh)` >> Q.EXISTS_TAC `r` >> fs[] >> fs[dynamic_lcs_row_invariant_def,lcs_empty] - >> fs[dynamic_lcs_length])); + >> fs[dynamic_lcs_length]) +QED -Theorem dynamic_lcs_rows_correct ` - !l r previous_row fullh. +Theorem dynamic_lcs_rows_correct: + !l r previous_row fullh. dynamic_lcs_rows_invariant l r previous_row fullh - ==> lcs (REVERSE (dynamic_lcs_rows l r previous_row)) fullh r` - (Induct + ==> lcs (REVERSE (dynamic_lcs_rows l r previous_row)) fullh r +Proof + Induct >> rpt strip_tac (* nil *) >- (fs[dynamic_lcs_rows_invariant_def] @@ -873,25 +1006,32 @@ Theorem dynamic_lcs_rows_correct ` >> first_x_assum(assume_tac o Q.SPECL [`r`, `dynamic_lcs_row h r ([],0) previous_row ([],0)`, `fullh`]) - >> fs[dynamic_lcs_rows_def]); + >> fs[dynamic_lcs_rows_def] +QED (* Main correctness theorem for dynamic LCS algorithm *) -Theorem dynamic_lcs_correct - `lcs (dynamic_lcs l r) l r` - (`dynamic_lcs_rows_invariant l r (REPLICATE (LENGTH r) ([],0)) l` +Theorem dynamic_lcs_correct: + lcs (dynamic_lcs l r) l r +Proof + `dynamic_lcs_rows_invariant l r (REPLICATE (LENGTH r) ([],0)) l` by fs[dynamic_lcs_rows_invariant_def,LENGTH_REPLICATE,EL_REPLICATE,lcs_empty] - >> fs[dynamic_lcs_def, dynamic_lcs_rows_correct]); + >> fs[dynamic_lcs_def, dynamic_lcs_rows_correct] +QED -Theorem dynamic_lcs_no_rev_correct - `lcs (REVERSE(dynamic_lcs_no_rev l r)) l r` - (`dynamic_lcs_rows_invariant l r (REPLICATE (LENGTH r) ([],0)) l` +Theorem dynamic_lcs_no_rev_correct: + lcs (REVERSE(dynamic_lcs_no_rev l r)) l r +Proof + `dynamic_lcs_rows_invariant l r (REPLICATE (LENGTH r) ([],0)) l` by fs[dynamic_lcs_rows_invariant_def,LENGTH_REPLICATE,EL_REPLICATE,lcs_empty] - >> fs[dynamic_lcs_no_rev_def, dynamic_lcs_rows_correct]); + >> fs[dynamic_lcs_no_rev_def, dynamic_lcs_rows_correct] +QED -Theorem dynamic_lcs_refl - `dynamic_lcs l l = l` - (metis_tac[dynamic_lcs_correct,lcs_refl']); +Theorem dynamic_lcs_refl: + dynamic_lcs l l = l +Proof + metis_tac[dynamic_lcs_correct,lcs_refl'] +QED (* Further optimisation of the dynamic LCS algorithm: prune common prefixes and suffixes as a preprocessing step *) @@ -902,12 +1042,14 @@ val longest_common_prefix_def = Define ` (longest_common_prefix (f::r) (f'::r') = if f = f' then f::longest_common_prefix r r' else [])` -Theorem longest_common_prefix_clauses ` - (longest_common_prefix [] l = []) /\ +Theorem longest_common_prefix_clauses: + (longest_common_prefix [] l = []) /\ (longest_common_prefix l [] = []) /\ (longest_common_prefix (f::r) (f'::r') = - if f = f' then f::longest_common_prefix r r' else [])` - (Cases_on `l` >> fs[longest_common_prefix_def]); + if f = f' then f::longest_common_prefix r r' else []) +Proof + Cases_on `l` >> fs[longest_common_prefix_def] +QED val optimised_lcs_def = Define ` optimised_lcs l r = @@ -936,34 +1078,41 @@ val longest_common_suffix_def = Define ` f::l else l)` -Theorem longest_common_suffix_clauses `!r r' f f'. +Theorem longest_common_suffix_clauses: + !r r' f f'. (longest_common_suffix [] l = []) /\ (longest_common_suffix l [] = []) /\ (longest_common_suffix (r ++ [f]) (r' ++ [f']) = - if f = f' then SNOC f (longest_common_suffix r r') else [])` - (fs[longest_common_suffix_def, + if f = f' then SNOC f (longest_common_suffix r r') else []) +Proof + fs[longest_common_suffix_def, Q.prove(`longest_common_suffix l [] = []`, Cases_on `l` >> fs[longest_common_suffix_def])] >> ho_match_mp_tac (theorem "longest_common_suffix_ind") >> rpt strip_tac >> fs[longest_common_suffix_def] >- (Induct_on `r'` >> fs[longest_common_suffix_def,APPEND] >> Induct_on `v3` >> fs[longest_common_suffix_def]) >- (Induct_on `v3` >> fs[longest_common_suffix_def] >> rw[] >> fs[] >> rfs[]) - >> rw[] >> fs[] >> rfs[]); + >> rw[] >> fs[] >> rfs[] +QED -Theorem longest_common_prefix_LENGTH ` - !l r. LENGTH(longest_common_prefix l r) <= LENGTH l /\ LENGTH(longest_common_prefix l r) <= LENGTH r` - (ho_match_mp_tac (fetch "lcs" "longest_common_prefix_ind") +Theorem longest_common_prefix_LENGTH: + !l r. LENGTH(longest_common_prefix l r) <= LENGTH l /\ LENGTH(longest_common_prefix l r) <= LENGTH r +Proof + ho_match_mp_tac (fetch "lcs" "longest_common_prefix_ind") >> rpt strip_tac >> fs[longest_common_prefix_clauses] - >> rw[]); + >> rw[] +QED -Theorem longest_common_suffix_LENGTH ` - !l r. LENGTH(longest_common_suffix l r) <= LENGTH l /\ LENGTH(longest_common_suffix l r) <= LENGTH r` - (ho_match_mp_tac (fetch "lcs" "longest_common_suffix_ind") +Theorem longest_common_suffix_LENGTH: + !l r. LENGTH(longest_common_suffix l r) <= LENGTH l /\ LENGTH(longest_common_suffix l r) <= LENGTH r +Proof + ho_match_mp_tac (fetch "lcs" "longest_common_suffix_ind") >> rpt strip_tac >> fs[longest_common_suffix_clauses] >> rw[] - >> rw[longest_common_suffix_def]); + >> rw[longest_common_suffix_def] +QED val longest_common_suffix_length_def = Define ` (longest_common_suffix_length [] [] n = n) /\ @@ -973,52 +1122,60 @@ val longest_common_suffix_length_def = Define ` else longest_common_suffix_length r r' 0)` -Theorem longest_common_suffix_length_le_length - `!l r. LENGTH(longest_common_suffix l r) <= LENGTH r` - (ho_match_mp_tac(fetch "-" "longest_common_suffix_ind") +Theorem longest_common_suffix_length_le_length: + !l r. LENGTH(longest_common_suffix l r) <= LENGTH r +Proof + ho_match_mp_tac(fetch "-" "longest_common_suffix_ind") >> rpt strip_tac >> rw[longest_common_suffix_def] - >> fs[]); + >> fs[] +QED -Theorem longest_common_suffix_length_thm - `!l r n. +Theorem longest_common_suffix_length_thm: + !l r n. LENGTH l = LENGTH r ==> longest_common_suffix_length l r n = if LENGTH(longest_common_suffix l r) = LENGTH r then n + LENGTH(longest_common_suffix l r) else - LENGTH(longest_common_suffix l r)` - (ho_match_mp_tac (fetch "-" "longest_common_suffix_ind") + LENGTH(longest_common_suffix l r) +Proof + ho_match_mp_tac (fetch "-" "longest_common_suffix_ind") >> rpt strip_tac >> fs[longest_common_suffix_length_def,longest_common_suffix_def] >> rw[] >> qspecl_then [`l`,`r`] assume_tac longest_common_suffix_length_le_length - >> fs[]) + >> fs[] +QED -Theorem longest_common_suffix_dropr - `!l r. LENGTH r > LENGTH l ==> - longest_common_suffix l (DROP (LENGTH r − LENGTH l) r) = longest_common_suffix l r` - (ho_match_mp_tac (fetch "-" "longest_common_suffix_ind") +Theorem longest_common_suffix_dropr: + !l r. LENGTH r > LENGTH l ==> + longest_common_suffix l (DROP (LENGTH r − LENGTH l) r) = longest_common_suffix l r +Proof + ho_match_mp_tac (fetch "-" "longest_common_suffix_ind") >> rw[longest_common_suffix_def] >> fs[] >> fs[ADD1] >> Cases_on `LENGTH r > LENGTH l + 1` >> fs[] >> `LENGTH l +1 = LENGTH r` by fs[] - >> fs[]); + >> fs[] +QED -Theorem longest_common_suffix_dropl - `!l r. LENGTH l > LENGTH r ==> - longest_common_suffix (DROP (LENGTH l − LENGTH r) l) r = longest_common_suffix l r` - (ho_match_mp_tac (fetch "-" "longest_common_suffix_ind") +Theorem longest_common_suffix_dropl: + !l r. LENGTH l > LENGTH r ==> + longest_common_suffix (DROP (LENGTH l − LENGTH r) l) r = longest_common_suffix l r +Proof + ho_match_mp_tac (fetch "-" "longest_common_suffix_ind") >> rw[longest_common_suffix_def,ADD1,DROP_LENGTH_NIL] >> fs[] >> fs[ADD1,DROP_LENGTH_NIL] >> Cases_on `LENGTH l > LENGTH r + 1` >> fs[] >> `LENGTH r +1 = LENGTH l` by fs[] - >> fs[]); + >> fs[] +QED -Theorem longest_common_suffix_length_if - `!l r. +Theorem longest_common_suffix_length_if: + !l r. (if LENGTH l = LENGTH r then longest_common_suffix_length l r 0 else if LENGTH l < LENGTH r then @@ -1026,40 +1183,51 @@ Theorem longest_common_suffix_length_if else longest_common_suffix_length (DROP (LENGTH l - LENGTH r) l) r 0) = - LENGTH(longest_common_suffix l r)` - (rw[] - >> fs[longest_common_suffix_length_thm,longest_common_suffix_dropl,longest_common_suffix_dropr]); - -Theorem longest_prefix_is_prefix - `!l r. IS_PREFIX l (longest_common_prefix l r) /\ IS_PREFIX r (longest_common_prefix l r)` - (ho_match_mp_tac (theorem "longest_common_prefix_ind") - >> rw[longest_common_prefix_def]); - -Theorem longest_prefix_correct -`!l r s. lcs (longest_common_prefix l r ++ s) l r = lcs s (DROP (LENGTH (longest_common_prefix l r)) l) (DROP (LENGTH (longest_common_prefix l r)) r)` - (ho_match_mp_tac (theorem "longest_common_prefix_ind") + LENGTH(longest_common_suffix l r) +Proof + rw[] + >> fs[longest_common_suffix_length_thm,longest_common_suffix_dropl,longest_common_suffix_dropr] +QED + +Theorem longest_prefix_is_prefix: + !l r. IS_PREFIX l (longest_common_prefix l r) /\ IS_PREFIX r (longest_common_prefix l r) +Proof + ho_match_mp_tac (theorem "longest_common_prefix_ind") + >> rw[longest_common_prefix_def] +QED + +Theorem longest_prefix_correct: + !l r s. lcs (longest_common_prefix l r ++ s) l r = lcs s (DROP (LENGTH (longest_common_prefix l r)) l) (DROP (LENGTH (longest_common_prefix l r)) r) +Proof + ho_match_mp_tac (theorem "longest_common_prefix_ind") >> rpt strip_tac - >> rw[longest_common_prefix_clauses,cons_lcs_optimal_substructure]); + >> rw[longest_common_prefix_clauses,cons_lcs_optimal_substructure] +QED -Theorem longest_common_prefix_reverse ` - !l r. longest_common_prefix (REVERSE l) (REVERSE r) = REVERSE(longest_common_suffix l r)` - (ho_match_mp_tac (SNOC_INDUCT) +Theorem longest_common_prefix_reverse: + !l r. longest_common_prefix (REVERSE l) (REVERSE r) = REVERSE(longest_common_suffix l r) +Proof + ho_match_mp_tac (SNOC_INDUCT) >> strip_tac >- fs[longest_common_prefix_clauses,longest_common_suffix_clauses] >> ntac 3 strip_tac >> ho_match_mp_tac (SNOC_INDUCT) >> rpt strip_tac >> fs[longest_common_prefix_clauses,longest_common_suffix_clauses] - >> rw[]); - -Theorem longest_suffix_is_suffix - `!l r. IS_SUFFIX l (longest_common_suffix l r) /\ IS_SUFFIX r (longest_common_suffix l r)` - (rpt strip_tac >> fs[IS_SUFFIX_compute,GSYM longest_common_prefix_reverse] - >> metis_tac[longest_prefix_is_prefix]); - -Theorem longest_suffix_correct -`!l r s. lcs (s ++ longest_common_suffix l r) l r = lcs s (REVERSE (DROP (LENGTH (longest_common_suffix l r)) (REVERSE l))) (REVERSE (DROP (LENGTH (longest_common_suffix l r)) (REVERSE r)))` - (ho_match_mp_tac SNOC_INDUCT + >> rw[] +QED + +Theorem longest_suffix_is_suffix: + !l r. IS_SUFFIX l (longest_common_suffix l r) /\ IS_SUFFIX r (longest_common_suffix l r) +Proof + rpt strip_tac >> fs[IS_SUFFIX_compute,GSYM longest_common_prefix_reverse] + >> metis_tac[longest_prefix_is_prefix] +QED + +Theorem longest_suffix_correct: + !l r s. lcs (s ++ longest_common_suffix l r) l r = lcs s (REVERSE (DROP (LENGTH (longest_common_suffix l r)) (REVERSE l))) (REVERSE (DROP (LENGTH (longest_common_suffix l r)) (REVERSE r))) +Proof + ho_match_mp_tac SNOC_INDUCT >> strip_tac >- fs[longest_common_suffix_clauses] >> ntac 3 strip_tac @@ -1070,25 +1238,32 @@ Theorem longest_suffix_correct >> fs[longest_common_suffix_clauses] >> rw[] >> fs[SNOC_APPEND,snoc_lcs_optimal_substructure,REVERSE_APPEND, - Q.prove(`l - r - l = (0:num)`,intLib.COOPER_TAC),take_suc_length]); + Q.prove(`l - r - l = (0:num)`,intLib.COOPER_TAC),take_suc_length] +QED -Theorem longest_common_prefix_refl ` - !l r. longest_common_prefix l l = l` - (Induct >> fs[longest_common_prefix_clauses]); +Theorem longest_common_prefix_refl: + !l r. longest_common_prefix l l = l +Proof + Induct >> fs[longest_common_prefix_clauses] +QED (* Main correctness theorem for optimised LCS algorithm *) -Theorem optimised_lcs_correct - `lcs (optimised_lcs l r) l r` - (fs[optimised_lcs_def,longest_prefix_correct] +Theorem optimised_lcs_correct: + lcs (optimised_lcs l r) l r +Proof + fs[optimised_lcs_def,longest_prefix_correct] >> PURE_ONCE_REWRITE_TAC[GSYM APPEND_ASSOC] >> fs[longest_prefix_correct,longest_common_prefix_reverse, - longest_suffix_correct,lcs_rev',dynamic_lcs_no_rev_correct]); + longest_suffix_correct,lcs_rev',dynamic_lcs_no_rev_correct] +QED (* More properties of optimised LCS algorithm *) -Theorem optimised_lcs_refl - `optimised_lcs l l = l` - (metis_tac[optimised_lcs_correct,lcs_refl']); +Theorem optimised_lcs_refl: + optimised_lcs l l = l +Proof + metis_tac[optimised_lcs_correct,lcs_refl'] +QED val _ = export_theory (); diff --git a/examples/patchProgScript.sml b/examples/patchProgScript.sml index acb9b0a246..f98bafac10 100644 --- a/examples/patchProgScript.sml +++ b/examples/patchProgScript.sml @@ -59,8 +59,11 @@ val tokens_two_less = Q.prove(`!s f s1 s2. tokens f s = [s1;s2] ==> strlen s1 < >> qspecl_then [`s`,`f`] assume_tac tokens_not_nil >> Induct >> Cases >> Induct >> Cases >> rpt strip_tac >> fs[]); -Theorem hexDigit_IMP_digit `!c. isDigit c ==> isHexDigit c` - (rw[isHexDigit_def,isDigit_def]); +Theorem hexDigit_IMP_digit: + !c. isDigit c ==> isHexDigit c +Proof + rw[isHexDigit_def,isDigit_def] +QED val parse_patch_header_side = Q.prove(`!s. parse_patch_header_side s = T`, rw[fetch "-" "parse_patch_header_side_def"] @@ -109,8 +112,8 @@ val _ = (append_prog o process_topdecs) ` None => TextIO.output TextIO.stdErr (rejected_patch_string) | Some s => TextIO.print_list s` -Theorem patch'_spec - `FILENAME f1 fv1 ∧ FILENAME f2 fv2 /\ hasFreeFD fs +Theorem patch'_spec: + FILENAME f1 fv1 ∧ FILENAME f2 fv2 /\ hasFreeFD fs ⇒ app (p:'ffi ffi_proj) ^(fetch_v"patch'"(get_ml_prog_state())) [fv1; fv2] @@ -123,8 +126,9 @@ Theorem patch'_spec | NONE => add_stderr fs rejected_patch_string | SOME s => add_stdout fs (concat s) else add_stderr fs (notfound_string f2) - else add_stderr fs (notfound_string f1)))` - (xcf"patch'"(get_ml_prog_state()) + else add_stderr fs (notfound_string f1))) +Proof + xcf"patch'"(get_ml_prog_state()) \\ xlet_auto >- xsimpl \\ xmatch \\ reverse(Cases_on `inFS_fname fs f1`) \\ fs[OPTION_TYPE_def] @@ -148,7 +152,8 @@ Theorem patch'_spec \\ Cases_on `a1` \\ fs[OPTION_TYPE_def] \\ xmatch >- (xapp_spec output_stderr_spec \\ simp[theorem "rejected_patch_string_v_thm"]) - \\ xapp \\ rw[]); + \\ xapp \\ rw[] +QED val _ = (append_prog o process_topdecs) ` fun patch u = @@ -169,15 +174,16 @@ val patch_sem_def = Define` else add_stderr fs (notfound_string (EL 1 cl)) else add_stderr fs usage_string`; -Theorem patch_spec - `hasFreeFD fs +Theorem patch_spec: + hasFreeFD fs ⇒ app (p:'ffi ffi_proj) ^(fetch_v"patch"(get_ml_prog_state())) [Conv NONE []] (STDIO fs * COMMANDLINE cl) (POSTv uv. &UNIT_TYPE () uv * - STDIO (patch_sem cl fs) * COMMANDLINE cl)` - (once_rewrite_tac[patch_sem_def] + STDIO (patch_sem cl fs) * COMMANDLINE cl) +Proof + once_rewrite_tac[patch_sem_def] \\ strip_tac \\ xcf "patch" (get_ml_prog_state()) \\ xlet_auto >- (xcon \\ xsimpl) \\ reverse(Cases_on`wfcl cl`) >- (fs[COMMANDLINE_def] \\ xpull) @@ -203,21 +209,24 @@ Theorem patch_spec \\ CONV_TAC SWAP_EXISTS_CONV \\ qexists_tac `h''` \\ CONV_TAC SWAP_EXISTS_CONV \\ qexists_tac `h'` \\ xsimpl \\ fs[FILENAME_def] - \\ fs[validArg_def,EVERY_MEM]); + \\ fs[validArg_def,EVERY_MEM] +QED val st = get_ml_prog_state(); -Theorem patch_whole_prog_spec - `hasFreeFD fs ⇒ - whole_prog_spec ^(fetch_v"patch"st) cl fs NONE ((=) (patch_sem cl fs))` - (rw[whole_prog_spec_def] +Theorem patch_whole_prog_spec: + hasFreeFD fs ⇒ + whole_prog_spec ^(fetch_v"patch"st) cl fs NONE ((=) (patch_sem cl fs)) +Proof + rw[whole_prog_spec_def] \\ qexists_tac`patch_sem cl fs` \\ reverse conj_tac >- ( rw[patch_sem_def,GSYM add_stdo_with_numchars,with_same_numchars] \\ CASE_TAC \\ rw[GSYM add_stdo_with_numchars,with_same_numchars]) \\ simp [SEP_CLAUSES] \\ match_mp_tac (MP_CANON (DISCH_ALL (MATCH_MP app_wgframe (UNDISCH patch_spec)))) - \\ xsimpl); + \\ xsimpl +QED val name = "patch" val (sem_thm,prog_tm) = whole_prog_thm st name (UNDISCH patch_whole_prog_spec) diff --git a/examples/queueProgScript.sml b/examples/queueProgScript.sml index 94f7c26905..eba816b9c2 100644 --- a/examples/queueProgScript.sml +++ b/examples/queueProgScript.sml @@ -53,16 +53,19 @@ val lqueue_def = Define‘ r ≤ f ∧ (∃p s mj. qels = s ++ mj ++ p ∧ els = p ++ s ∧ r = LENGTH s ∧ f = r + LENGTH mj))’; -Theorem lqueue_empty - `i < LENGTH xs ⇒ lqueue xs i i []` - (simp[lqueue_def] >> strip_tac >> - map_every qexists_tac [‘TAKE i xs’, ‘DROP i xs’] >> simp[]) - -Theorem lqueue_enqueue - `∀x f r vs aels n. +Theorem lqueue_empty: + i < LENGTH xs ⇒ lqueue xs i i [] +Proof + simp[lqueue_def] >> strip_tac >> + map_every qexists_tac [‘TAKE i xs’, ‘DROP i xs’] >> simp[] +QED + +Theorem lqueue_enqueue: + ∀x f r vs aels n. LENGTH vs < LENGTH aels ∧ lqueue aels f r vs ∧ (n = LENGTH aels) ⇒ - lqueue (LUPDATE x r aels) f ((r + 1) MOD n) (vs ++ [x])` - (rw[lqueue_def] >> fs[] + lqueue (LUPDATE x r aels) f ((r + 1) MOD n) (vs ++ [x]) +Proof + rw[lqueue_def] >> fs[] >- (Cases_on ‘r + 1 = LENGTH pj + (LENGTH rj + LENGTH vs)’ >> simp[] >- ((* wrap around happened *) disj2_tac >> qexists_tac `pj` >> simp[] >> @@ -75,16 +78,19 @@ Theorem lqueue_enqueue `r = LENGTH pj + LENGTH vs` by simp[] >> simp[LUPDATE_def]) >> (* already wrapped around *) disj2_tac >> map_every qexists_tac [‘p’, ‘s ++ [x]’, ‘TL mj’] >> Cases_on ‘mj’ >> fs[] >> - simp[LUPDATE_APPEND2, LUPDATE_APPEND1]) + simp[LUPDATE_APPEND2, LUPDATE_APPEND1] +QED -Theorem lqueue_dequeue - `lqueue aels f r (v::vs) ⇒ lqueue aels ((f + 1) MOD LENGTH aels) r vs` - (rw[lqueue_def] >> fs[] +Theorem lqueue_dequeue: + lqueue aels f r (v::vs) ⇒ lqueue aels ((f + 1) MOD LENGTH aels) r vs +Proof + rw[lqueue_def] >> fs[] >- (disj1_tac >> map_every qexists_tac [‘pj ++ [v]’, ‘rj’] >> simp[]) >> Cases_on ‘LENGTH p = 1’ >> simp[] >- ((* f wraps around *) disj1_tac >> Cases_on ‘p’ >> fs[]) >> map_every qexists_tac [‘TL p’, ‘s’, ‘mj ++ [v]’] >> simp[] >> - Cases_on ‘p’ >> fs[]) + Cases_on ‘p’ >> fs[] +QED (* Heap predicate for queues: @@ -123,14 +129,16 @@ val xs_auto_tac = rpt (FIRST [xcon, (CHANGED_TAC xsimpl), xif, xmatch, xapp, xle val st = get_ml_prog_state (); -Theorem empty_queue_spec - `NUM n nv ∧ 0 < n ∧ A a errv ⇒ +Theorem empty_queue_spec: + NUM n nv ∧ 0 < n ∧ A a errv ⇒ app (p:'ffi ffi_proj) ^(fetch_v "empty_queue" st) [nv; errv] - emp (POSTv qv. QUEUE A n [] qv)` - (xcf "empty_queue" st \\ + emp (POSTv qv. QUEUE A n [] qv) +Proof + xcf "empty_queue" st \\ xs_auto_tac >> simp[QUEUE_def] >> xsimpl >> qexists_tac `REPLICATE n a` >> - simp[lqueue_def, LIST_REL_REPLICATE_same]) + simp[lqueue_def, LIST_REL_REPLICATE_same] +QED val EqualityType_INT = prove(``EqualityType INT``, simp[EqualityType_NUM_BOOL]) @@ -139,23 +147,26 @@ val eq_int_thm = mlbasicsProgTheory.eq_v_thm |> Q.INST [‘a’ |-> ‘INT’] |> PROVE_HYP EqualityType_INT -Theorem full_spec - `app (p:'ffi ffi_proj) ^(fetch_v "full" st) [qv] +Theorem full_spec: + app (p:'ffi ffi_proj) ^(fetch_v "full" st) [qv] (QUEUE A mx vs qv) - (POSTv bv. &(BOOL (LENGTH vs = mx) bv) * QUEUE A mx vs qv)` - (xcf "full" st >> simp[QUEUE_def] >> xpull >> xs_auto_tac >> + (POSTv bv. &(BOOL (LENGTH vs = mx) bv) * QUEUE A mx vs qv) +Proof + xcf "full" st >> simp[QUEUE_def] >> xpull >> xs_auto_tac >> reverse (rw[]) >- EVAL_TAC (* validate_pat *) >> xlet_auto >- xsimpl >> xapp_spec (cf_spec “:'ffi” Translator_spec eq_int_thm) >> xsimpl >> fs[ml_translatorTheory.BOOL_def, ml_translatorTheory.NUM_def] >> rpt (goal_assum (first_assum o mp_then (Pos hd) mp_tac)) >> - imp_res_tac LIST_REL_LENGTH >> simp[] >> metis_tac[]); + imp_res_tac LIST_REL_LENGTH >> simp[] >> metis_tac[] +QED -Theorem enqueue_spec - `!qv xv vs x. app (p:'ffi ffi_proj) ^(fetch_v "enqueue" st) [qv; xv] +Theorem enqueue_spec: + !qv xv vs x. app (p:'ffi ffi_proj) ^(fetch_v "enqueue" st) [qv; xv] (QUEUE A mx vs qv * & (A x xv ∧ LENGTH vs < mx)) - (POSTv uv. QUEUE A mx (vs ++ [x]) qv)` - (xcf "enqueue" st >> + (POSTv uv. QUEUE A mx (vs ++ [x]) qv) +Proof + xcf "enqueue" st >> xpull >> xs_auto_tac >> xlet ‘POSTv bv. QUEUE A mx vs qv * &(BOOL (LENGTH vs = mx) bv)’ >- (xapp >> xsimpl >> qexists_tac `emp` >> xsimpl >> @@ -173,18 +184,21 @@ Theorem enqueue_spec ‘qelvs ≠ []’ by (strip_tac >> fs[]) >> simp[integerTheory.INT_MOD] >> strip_tac >> rpt (goal_assum (first_assum o mp_then (Pos hd) mp_tac)) >> - simp[lqueue_enqueue]); + simp[lqueue_enqueue] +QED -Theorem LIST_REL_REL_lqueue_HD - `LIST_REL A qels qelvs ∧ lqueue qels f r (h::t) ⇒ A h (EL f qelvs)` - (simp[lqueue_def] >> rw[] +Theorem LIST_REL_REL_lqueue_HD: + LIST_REL A qels qelvs ∧ lqueue qels f r (h::t) ⇒ A h (EL f qelvs) +Proof + simp[lqueue_def] >> rw[] >- (fs[LIST_REL_SPLIT1] >> rw[] >> imp_res_tac LIST_REL_LENGTH >> simp[EL_APPEND1, EL_APPEND2]) >> Cases_on `p` >> fs[] >> rw[] >> fs[LIST_REL_SPLIT1] >> rw[] >> imp_res_tac LIST_REL_LENGTH >> fs[] >> - simp[EL_APPEND1, EL_APPEND2]); + simp[EL_APPEND1, EL_APPEND2] +QED val dequeue_spec_noexn = Q.prove( `!qv xv vs x. app (p:'ffi ffi_proj) ^(fetch_v "dequeue" st) [qv] @@ -204,13 +218,14 @@ val dequeue_spec_noexn = Q.prove( Cases_on `vs` >> fs[integerTheory.INT_SUB] >> metis_tac[lqueue_dequeue, LIST_REL_REL_lqueue_HD]); -Theorem dequeue_spec - `∀p qv xv vs x A mx. +Theorem dequeue_spec: + ∀p qv xv vs x A mx. app (p:'ffi ffi_proj) ^(fetch_v "dequeue" st) [qv] (QUEUE A mx vs qv) (POSTve (λv. &(vs ≠ [] ∧ A (HD vs) v) * QUEUE A mx (TL vs) qv) - (λe. &(vs = [] ∧ EmptyQueue_exn e) * QUEUE A mx vs qv))’ - (xcf "dequeue" st >> simp[QUEUE_def] >> xpull >> xs_auto_tac >> + (λe. &(vs = [] ∧ EmptyQueue_exn e) * QUEUE A mx vs qv)) +Proof + xcf "dequeue" st >> simp[QUEUE_def] >> xpull >> xs_auto_tac >> reverse(rw[]) >- EVAL_TAC >> xlet_auto >- xsimpl >> xif >- ((* throws exception *) xs_auto_tac >> rw[] >> xraise >> xsimpl >> dsimp[] >> fs[] >> @@ -226,6 +241,7 @@ Theorem dequeue_spec strip_tac >> rpt (goal_assum (first_assum o mp_then Any mp_tac)) >> Cases_on `vs` >> fs[integerTheory.INT_SUB] >> - metis_tac[lqueue_dequeue, LIST_REL_REL_lqueue_HD]); + metis_tac[lqueue_dequeue, LIST_REL_REL_lqueue_HD] +QED val _ = export_theory () diff --git a/examples/quicksortProgScript.sml b/examples/quicksortProgScript.sml index ec865f1552..1a809cc2c9 100644 --- a/examples/quicksortProgScript.sml +++ b/examples/quicksortProgScript.sml @@ -22,17 +22,19 @@ val list_rel_perm_help = Q.prove ( ho_match_mp_tac PERM_IND >> rw []); -Theorem list_rel_perm - `!r l1 l2 l3 l4. +Theorem list_rel_perm: + !r l1 l2 l3 l4. LENGTH l3 = LENGTH l4 ∧ LIST_REL r l1 l2 ∧ PERM (ZIP (l1,l2)) (ZIP (l3,l4)) ⇒ - LIST_REL r l3 l4` - (rw [] >> + LIST_REL r l3 l4 +Proof + rw [] >> drule list_rel_perm_help >> imp_res_tac LIST_REL_LENGTH >> - rw [MAP_ZIP]); + rw [MAP_ZIP] +QED val split_list = Q.prove ( `!l x. x < LENGTH l ⇒ ?l1 l2. x = LENGTH l1 ∧ l = l1++[EL x l]++l2`, @@ -81,26 +83,30 @@ val perm_swap_help = Q.prove ( fs [] >> rw [FILTER_APPEND]); -Theorem perm_swap - `!l x y. +Theorem perm_swap: + !l x y. x < LENGTH l ∧ y < LENGTH l ⇒ - PERM l (LUPDATE (EL x l) y (LUPDATE (EL y l) x l))` - (rw [] >> + PERM l (LUPDATE (EL x l) y (LUPDATE (EL y l) x l)) +Proof + rw [] >> `x < y ∨ y < x ∨ x = y` by decide_tac >> rw [] >> - metis_tac [perm_swap_help, LUPDATE_commutes , PERM_REFL, LUPDATE_SAME]); + metis_tac [perm_swap_help, LUPDATE_commutes , PERM_REFL, LUPDATE_SAME] +QED -Theorem lupdate_zip - `!l1 l2 x y n. +Theorem lupdate_zip: + !l1 l2 x y n. LENGTH l1 = LENGTH l2 ∧ n < LENGTH l1 ⇒ LUPDATE (x,y) n (ZIP (l1,l2)) = - ZIP (LUPDATE x n l1, LUPDATE y n l2)` - (induct_on `n` >> + ZIP (LUPDATE x n l1, LUPDATE y n l2) +Proof + induct_on `n` >> rw [] >> Cases_on `l1` >> Cases_on `l2` >> - fs [LUPDATE_def]); + fs [LUPDATE_def] +QED val el_append_length1 = Q.prove ( `!n l1 l2. EL (n + LENGTH l1) (l1 ++ l2) = EL n l2`, @@ -109,11 +115,12 @@ val el_append_length1 = Q.prove ( `PRE (n + SUC (LENGTH l1)) = n + LENGTH l1` by decide_tac >> metis_tac []); -Theorem front_zip - `!l1 l2. +Theorem front_zip: + !l1 l2. l1 ≠ [] ∧ LENGTH l1 = LENGTH l2 ⇒ - FRONT (ZIP (l1,l2)) = ZIP (FRONT l1, FRONT l2)` - (Induct_on `l1` >> + FRONT (ZIP (l1,l2)) = ZIP (FRONT l1, FRONT l2) +Proof + Induct_on `l1` >> rw [] >> Cases_on `l2` >> fs [] >> @@ -121,7 +128,8 @@ Theorem front_zip Cases_on `t` >> fs [] >> first_x_assum (qspec_then `h'''::t''` mp_tac) >> - rw []); + rw [] +QED val strict_weak_order_def = Define ` strict_weak_order r ⇔ @@ -129,24 +137,30 @@ val strict_weak_order_def = Define ` (!x y. r x y ⇒ ~r y x) ∧ transitive (\x y. ~r x y ∧ ¬r y x)`; -Theorem strict_weak_order_alt - `strict_weak_order r ⇔ +Theorem strict_weak_order_alt: + strict_weak_order r ⇔ (!x y. r x y ⇒ ~r y x) ∧ - transitive (\x y. ~r y x)` - (rw [strict_weak_order_def, transitive_def] >> - metis_tac []); + transitive (\x y. ~r y x) +Proof + rw [strict_weak_order_def, transitive_def] >> + metis_tac [] +QED -Theorem sing_length1 - `!l. LENGTH l = 1 ⇔ ?x. l = [x]` - (Cases >> - rw [LENGTH_NIL]); +Theorem sing_length1: + !l. LENGTH l = 1 ⇔ ?x. l = [x] +Proof + Cases >> + rw [LENGTH_NIL] +QED -Theorem length_gt1 - `!l. LENGTH l > 1 ⇒ ?x y z. l = x::y::z` - (Cases >> +Theorem length_gt1: + !l. LENGTH l > 1 ⇒ ?x y z. l = x::y::z +Proof + Cases >> rw [] >> Cases_on `t` >> - fs []); + fs [] +QED (* -- *) @@ -219,8 +233,8 @@ val perm_helper = Q.prove( `!a b c. PERM b c ∧ PERM a b ⇒ PERM a c`, metis_tac [PERM_SYM, PERM_TRANS]); -Theorem partition_spec - `!a ffi_p cmp cmp_v arr_v pivot pivot_v lower_v upper_v elem_vs1 elem_vs2 elem_vs3 elems2. +Theorem partition_spec: + !a ffi_p cmp cmp_v arr_v pivot pivot_v lower_v upper_v elem_vs1 elem_vs2 elem_vs3 elems2. strict_weak_order cmp ∧ (a --> a --> BOOL) cmp cmp_v ∧ (* We split the array into 3 parts. The second must have elements of type @@ -245,8 +259,9 @@ Theorem partition_spec (POSTv p_v. SEP_EXISTS part1 part2. (* The array is still in the heap, with the middle part partitioned. *) ARRAY arr_v (elem_vs1 ++ part1 ++ part2 ++ elem_vs3) * - &(partition_pred cmp (LENGTH elem_vs1) p_v pivot elems2 elem_vs2 part1 part2))` - (xcf "partition" (basis_st()) >> + &(partition_pred cmp (LENGTH elem_vs1) p_v pivot elems2 elem_vs2 part1 part2)) +Proof + xcf "partition" (basis_st()) >> qmatch_assum_abbrev_tac `INT (&lower) lower_v` >> qmatch_assum_abbrev_tac `INT (&upper) upper_v` >> `a pivot pivot_v` @@ -964,7 +979,8 @@ Theorem partition_spec rw [] >> metis_tac [strict_weak_order_def]) >- fs [INT_def, NUM_def] - >- metis_tac []); + >- metis_tac [] +QED val quicksort = process_topdecs ` fun quicksort cmp a = @@ -992,8 +1008,8 @@ val eq_int_v_thm = (DISCH_ALL mlbasicsProgTheory.eq_v_thm) (ml_translatorTheory.EqualityType_NUM_BOOL |> CONJUNCT2 |> CONJUNCT1) -Theorem quicksort_spec - `!ffi_p cmp cmp_v arr_v elem_vs elems. +Theorem quicksort_spec: + !ffi_p cmp cmp_v arr_v elem_vs elems. strict_weak_order cmp ∧ (a --> a --> BOOL) cmp cmp_v ∧ (* The elements of the array are all of "semantic type" a *) @@ -1015,8 +1031,9 @@ Theorem quicksort_spec LIST_REL a elems' elem_vs' ∧ PERM (ZIP (elems',elem_vs')) (ZIP (elems,elem_vs)) ∧ (* We use "not greater than" as equivalent to "less or equal" *) - SORTED (\x y. ¬(cmp y x)) elems'))` - (xcf "quicksort" (basis_st()) >> + SORTED (\x y. ¬(cmp y x)) elems')) +Proof + xcf "quicksort" (basis_st()) >> (* The loop invariant for the main loop. Note that we have to quantify over * what's in the array because it changes on the recursive calls. *) xfun_spec `quicksort_help` @@ -1186,6 +1203,7 @@ Theorem quicksort_spec rw [] >> irule list_rel_perm >> rw [] >> - metis_tac [PERM_SYM]); + metis_tac [PERM_SYM] +QED val _ = export_theory (); diff --git a/examples/sortProgScript.sml b/examples/sortProgScript.sml index fbef9b428d..631c636271 100644 --- a/examples/sortProgScript.sml +++ b/examples/sortProgScript.sml @@ -9,76 +9,98 @@ val _ = new_theory "sortProg"; val _ = translation_extends"quicksortProg"; (* TODO: move *) -Theorem perm_zip - `!l1 l2 l3 l4. +Theorem perm_zip: + !l1 l2 l3 l4. LENGTH l1 = LENGTH l2 ∧ LENGTH l3 = LENGTH l4 ∧ PERM (ZIP (l1,l2)) (ZIP (l3,l4)) ⇒ - PERM l1 l3 ∧ PERM l2 l4` - (rw [] >> - metis_tac [MAP_ZIP, PERM_MAP]); + PERM l1 l3 ∧ PERM l2 l4 +Proof + rw [] >> + metis_tac [MAP_ZIP, PERM_MAP] +QED -Theorem list_type_v_to_list - `!A l v. +Theorem list_type_v_to_list: + !A l v. LIST_TYPE A l v ⇒ - ?l'. v_to_list v = SOME l' ∧ LIST_REL A l l'` - (Induct_on `l` >> + ?l'. v_to_list v = SOME l' ∧ LIST_REL A l l' +Proof + Induct_on `l` >> rw [LIST_TYPE_def, terminationTheory.v_to_list_def] >- EVAL_TAC >> rw [terminationTheory.v_to_list_def] >> first_x_assum drule >> rw [] >> every_case_tac >> - rw [] >> EVAL_TAC); - -Theorem string_list_uniq - `!l1 l2. - LIST_REL STRING_TYPE l1 l2 ⇒ l2 = MAP (λs. Litv (StrLit (explode s))) l1` - (Induct_on `l1` >> + rw [] >> EVAL_TAC +QED + +Theorem string_list_uniq: + !l1 l2. + LIST_REL STRING_TYPE l1 l2 ⇒ l2 = MAP (λs. Litv (StrLit (explode s))) l1 +Proof + Induct_on `l1` >> rw [] >> `?s'. h = strlit s'` by metis_tac [mlstringTheory.mlstring_nchotomy] >> - fs [STRING_TYPE_def]); - -Theorem string_not_lt - `¬(x < y) ⇔ (y:string) ≤ x` - (rw[string_le_def] - \\ metis_tac[string_lt_total,string_lt_antisym]); - -Theorem strict_weak_order_string_cmp - `strict_weak_order (λs1 s2. explode s1 < explode s2)` - (rw [strict_weak_order_alt, transitive_def] >> - metis_tac [string_lt_antisym, string_lt_trans, string_lt_total]); - -Theorem string_le_transitive - `transitive string_le` - (rw[transitive_def,string_le_def] - \\ metis_tac[string_lt_trans]); - -Theorem string_le_antisymmetric - `antisymmetric string_le` - (rw[antisymmetric_def,string_le_def] - \\ metis_tac[string_lt_antisym]); - -Theorem SORTED_string_lt_le - `SORTED string_lt ls ⇒ SORTED string_le ls` - (strip_tac \\ match_mp_tac SORTED_weaken - \\ asm_exists_tac \\ rw[string_le_def]); - -Theorem validArg_filename - `validArg x ∧ STRING_TYPE x v ⇒ FILENAME x v` - (rw [validArg_def, FILENAME_def, EVERY_MEM, LENGTH_explode]); - -Theorem validArg_filename_list - `!x v. EVERY validArg x ∧ LIST_TYPE STRING_TYPE x v ⇒ LIST_TYPE FILENAME x v` - (Induct_on `x` >> - rw [LIST_TYPE_def, validArg_filename]); + fs [STRING_TYPE_def] +QED + +Theorem string_not_lt: + ¬(x < y) ⇔ (y:string) ≤ x +Proof + rw[string_le_def] + \\ metis_tac[string_lt_total,string_lt_antisym] +QED + +Theorem strict_weak_order_string_cmp: + strict_weak_order (λs1 s2. explode s1 < explode s2) +Proof + rw [strict_weak_order_alt, transitive_def] >> + metis_tac [string_lt_antisym, string_lt_trans, string_lt_total] +QED + +Theorem string_le_transitive: + transitive string_le +Proof + rw[transitive_def,string_le_def] + \\ metis_tac[string_lt_trans] +QED + +Theorem string_le_antisymmetric: + antisymmetric string_le +Proof + rw[antisymmetric_def,string_le_def] + \\ metis_tac[string_lt_antisym] +QED + +Theorem SORTED_string_lt_le: + SORTED string_lt ls ⇒ SORTED string_le ls +Proof + strip_tac \\ match_mp_tac SORTED_weaken + \\ asm_exists_tac \\ rw[string_le_def] +QED + +Theorem validArg_filename: + validArg x ∧ STRING_TYPE x v ⇒ FILENAME x v +Proof + rw [validArg_def, FILENAME_def, EVERY_MEM, LENGTH_explode] +QED + +Theorem validArg_filename_list: + !x v. EVERY validArg x ∧ LIST_TYPE STRING_TYPE x v ⇒ LIST_TYPE FILENAME x v +Proof + Induct_on `x` >> + rw [LIST_TYPE_def, validArg_filename] +QED val v_to_string_def = Define ` v_to_string (Litv (StrLit s)) = s`; -Theorem LIST_REL_STRING_TYPE - `LIST_REL STRING_TYPE ls vs ⇒ ls = MAP (implode o v_to_string) vs` - (rw[LIST_REL_EL_EQN,LIST_EQ_REWRITE,EL_MAP] \\ rfs[] \\ res_tac \\ - Cases_on`EL x ls` \\ fs[STRING_TYPE_def,v_to_string_def,implode_def]); +Theorem LIST_REL_STRING_TYPE: + LIST_REL STRING_TYPE ls vs ⇒ ls = MAP (implode o v_to_string) vs +Proof + rw[LIST_REL_EL_EQN,LIST_EQ_REWRITE,EL_MAP] \\ rfs[] \\ res_tac \\ + Cases_on`EL x ls` \\ fs[STRING_TYPE_def,v_to_string_def,implode_def] +QED (* -- *) val usage_string_def = Define` @@ -109,8 +131,8 @@ val get_file_contents = process_topdecs ` val _ = append_prog get_file_contents; (* TODO: these functions are generic, and should probably be moved *) -Theorem get_file_contents_spec - `!fs fd fd_v acc_v acc. +Theorem get_file_contents_spec: + !fs fd fd_v acc_v acc. INSTREAM fd fd_v ∧ IS_SOME (get_file_content fs fd) ∧ get_mode fs fd = SOME ReadMode ∧ LIST_TYPE STRING_TYPE (MAP implode acc) acc_v @@ -123,8 +145,9 @@ Theorem get_file_contents_spec STDIO (fastForwardFD fs fd) * &(LIST_TYPE STRING_TYPE (MAP implode (REVERSE (linesFD fs fd) ++ acc)) - strings_v))` - (ntac 2 strip_tac >> + strings_v)) +Proof + ntac 2 strip_tac >> completeInduct_on `LENGTH (linesFD fs fd)` >> rw [] >> xcf "get_file_contents" (get_ml_prog_state ()) >> @@ -157,10 +180,11 @@ Theorem get_file_contents_spec fs [linesFD_nil_lineFD_NONE]) >> drule linesFD_cons_imp >> rw [LIST_TYPE_def] >> xsimpl >> - metis_tac [APPEND, APPEND_ASSOC])); + metis_tac [APPEND, APPEND_ASSOC]) +QED -Theorem get_files_contents_spec - `!fnames_v fnames acc_v acc fs. +Theorem get_files_contents_spec: + !fnames_v fnames acc_v acc fs. hasFreeFD fs ∧ LIST_TYPE FILENAME fnames fnames_v ∧ LIST_TYPE STRING_TYPE (MAP implode acc) acc_v @@ -180,8 +204,9 @@ Theorem get_files_contents_spec (\e. STDIO fs * &(BadFileName_exn e ∧ - ¬EVERY (inFS_fname fs) fnames)))` - (Induct_on `fnames` >> + ¬EVERY (inFS_fname fs) fnames))) +Proof + Induct_on `fnames` >> rw [] >> xcf "get_files_contents" (get_ml_prog_state ()) >> (reverse(Cases_on`consistentFS fs`) @@ -221,7 +246,8 @@ Theorem get_files_contents_spec simp[Abbr`fs'`,Abbr`fd`,openFileFS_ADELKEY_nextFD] >> full_simp_tac std_ss [GSYM MAP_APPEND] >> instantiate >> xsimpl >> - simp[REVERSE_APPEND,MAP_REVERSE,linesFD_openFileFS_nextFD,MAP_MAP_o,o_DEF]); + simp[REVERSE_APPEND,MAP_REVERSE,linesFD_openFileFS_nextFD,MAP_MAP_o,o_DEF] +QED (* -- *) val _ = (append_prog o process_topdecs) ` @@ -253,43 +279,53 @@ val valid_sort_result_def = Define` result_fs = add_stdout fs (concat output) else result_fs = add_stderr init_fs (strlit "Cannot open file")`; -Theorem valid_sort_result_unique - `valid_sort_result cl fs fs1 ∧ +Theorem valid_sort_result_unique: + valid_sort_result cl fs fs1 ∧ valid_sort_result cl fs fs2 ⇒ - fs1 = fs2` - (rw[valid_sort_result_def] + fs1 = fs2 +Proof + rw[valid_sort_result_def] \\ AP_TERM_TAC \\ AP_TERM_TAC \\ match_mp_tac (MP_CANON SORTED_PERM_EQ) \\ instantiate \\ simp[transitive_mlstring_le,antisymmetric_mlstring_le] - \\ metis_tac[PERM_SYM,PERM_TRANS]); + \\ metis_tac[PERM_SYM,PERM_TRANS] +QED -Theorem valid_sort_result_exists - `∃r. valid_sort_result cl fs r` - (rw[valid_sort_result_def] +Theorem valid_sort_result_exists: + ∃r. valid_sort_result cl fs r +Proof + rw[valid_sort_result_def] \\ TRY CASE_TAC \\ PROVE_TAC[QSORT_SORTED, QSORT_PERM, PERM_SYM, total_def, - total_mlstring_le, transitive_mlstring_le ]); + total_mlstring_le, transitive_mlstring_le ] +QED -Theorem valid_sort_result_numchars - `valid_sort_result cl fs1 fs2 ⇒ fs2.numchars = fs1.numchars` - (rw[valid_sort_result_def] \\ rw[]); +Theorem valid_sort_result_numchars: + valid_sort_result cl fs1 fs2 ⇒ fs2.numchars = fs1.numchars +Proof + rw[valid_sort_result_def] \\ rw[] +QED val sort_sem_def = new_specification("sort_sem_def",["sort_sem"], valid_sort_result_exists |> Q.GENL[`cl`,`fs`] |> SIMP_RULE bool_ss [SKOLEM_THM]); -Theorem sort_sem_intro - `(∀out. valid_sort_result cl fs out ⇒ P out) - ⇒ P (sort_sem cl fs)` - (metis_tac[sort_sem_def,valid_sort_result_unique]); +Theorem sort_sem_intro: + (∀out. valid_sort_result cl fs out ⇒ P out) + ⇒ P (sort_sem cl fs) +Proof + metis_tac[sort_sem_def,valid_sort_result_unique] +QED -Theorem sort_sem_numchars[simp] - `(sort_sem cl fs).numchars = fs.numchars` - (DEEP_INTRO_TAC sort_sem_intro - \\ metis_tac[valid_sort_result_numchars]); +Theorem sort_sem_numchars[simp]: + (sort_sem cl fs).numchars = fs.numchars +Proof + DEEP_INTRO_TAC sort_sem_intro + \\ metis_tac[valid_sort_result_numchars] +QED val SORTED_mlstring_le = prove( ``!output. SORTED mlstring_le output = SORTED $<= (MAP explode output)``, @@ -298,16 +334,17 @@ val SORTED_mlstring_le = prove( \\ Cases \\ Cases_on `h` \\ fs [explode_def,strlit_le_strlit]); -Theorem sort_spec - `(if LENGTH cl ≤ 1 then (∃input. get_file_content fs 0 = SOME (input,0)) else hasFreeFD fs) +Theorem sort_spec: + (if LENGTH cl ≤ 1 then (∃input. get_file_content fs 0 = SOME (input,0)) else hasFreeFD fs) ⇒ app (p : 'ffi ffi_proj) ^(fetch_v "sort" (get_ml_prog_state ())) [Conv NONE []] (STDIO fs * COMMANDLINE cl) (POSTv uv. &UNIT_TYPE () uv * - STDIO (sort_sem cl fs) * COMMANDLINE cl)` - (xcf "sort" (get_ml_prog_state ()) >> + STDIO (sort_sem cl fs) * COMMANDLINE cl) +Proof + xcf "sort" (get_ml_prog_state ()) >> xmatch >> qabbrev_tac `fnames = TL cl` >> qabbrev_tac `lines = if LENGTH cl ≤ 1 then @@ -507,18 +544,21 @@ Theorem sort_spec drule (Q.ISPEC `explode `PERM_MAP) \\ fs [MAP_MAP_o,o_DEF] \\ CONV_TAC (DEPTH_CONV ETA_CONV) \\ - fs [])); - -Theorem sort_whole_prog_spec - `(if LENGTH cl ≤ 1 then (∃input. get_file_content fs 0 = SOME (input,0)) else hasFreeFD fs) - ⇒ whole_prog_spec ^(fetch_v "sort" (get_ml_prog_state())) cl fs NONE (valid_sort_result cl fs)` - (disch_then assume_tac + fs []) +QED + +Theorem sort_whole_prog_spec: + (if LENGTH cl ≤ 1 then (∃input. get_file_content fs 0 = SOME (input,0)) else hasFreeFD fs) + ⇒ whole_prog_spec ^(fetch_v "sort" (get_ml_prog_state())) cl fs NONE (valid_sort_result cl fs) +Proof + disch_then assume_tac \\ simp[whole_prog_spec_def] \\ qexists_tac`sort_sem cl fs` \\ reverse conj_tac >- metis_tac[with_same_numchars,sort_sem_numchars,sort_sem_def] \\ match_mp_tac (MP_CANON (MATCH_MP app_wgframe (UNDISCH sort_spec))) - \\ xsimpl); + \\ xsimpl +QED val (sem_thm,prog_tm) = whole_prog_thm (get_ml_prog_state ()) "sort" (UNDISCH sort_whole_prog_spec) val sort_prog_def = Define `sort_prog = ^prog_tm`; diff --git a/examples/stackProgScript.sml b/examples/stackProgScript.sml index 492c0d7ca3..a47d35d3e1 100644 --- a/examples/stackProgScript.sml +++ b/examples/stackProgScript.sml @@ -57,28 +57,32 @@ val xs_auto_tac = rpt (FIRST [xcon, (CHANGED_TAC xsimpl), xif, xmatch, xapp, xle val st = get_ml_prog_state (); -Theorem empty_stack_spec - `!uv. app (p:'ffi ffi_proj) ^(fetch_v "empty_stack" st) [uv] - emp (POSTv qv. STACK A [] qv)` - (xcf "empty_stack" st \\ +Theorem empty_stack_spec: + !uv. app (p:'ffi ffi_proj) ^(fetch_v "empty_stack" st) [uv] + emp (POSTv qv. STACK A [] qv) +Proof + xcf "empty_stack" st \\ xlet `POSTv v. &UNIT_TYPE () v` THEN1(xcon \\ xsimpl) \\ xlet `POSTv av. ARRAY av []` THEN1(xapp \\ fs[]) \\ xlet `POSTv pv. SEP_EXISTS av iv. &(pv = Conv NONE [av; iv]) * ARRAY av [] * &NUM 0 iv` THEN1(xcon \\ xsimpl) \\ - xref >> simp[STACK_def] >> xsimpl); - -Theorem empty_stack_spec - `!uv. app (p:'ffi ffi_proj) ^(fetch_v "empty_stack" st) [uv] - emp (POSTv qv. STACK A [] qv)` - (xcf "empty_stack" st >> simp[STACK_def] >> xs_auto_tac -); - -Theorem push_spec - `!qv xv vs x. app (p:'ffi ffi_proj) ^(fetch_v "push" st) [qv; xv] + xref >> simp[STACK_def] >> xsimpl +QED + +Theorem empty_stack_spec: + !uv. app (p:'ffi ffi_proj) ^(fetch_v "empty_stack" st) [uv] + emp (POSTv qv. STACK A [] qv) +Proof + xcf "empty_stack" st >> simp[STACK_def] >> xs_auto_tac +QED + +Theorem push_spec: + !qv xv vs x. app (p:'ffi ffi_proj) ^(fetch_v "push" st) [qv; xv] (STACK A vs qv * & A x xv) - (POSTv uv. STACK A (vs ++ [x]) qv)` - (xcf "push" st >> + (POSTv uv. STACK A (vs ++ [x]) qv) +Proof + xcf "push" st >> simp[STACK_def] >> xpull >> xlet_auto >-(xsimpl)>> @@ -122,13 +126,14 @@ Theorem push_spec Cases_on `junk:v list` >-(fs[LENGTH_NIL]) >> `vvs++[h]++t = vvs++h::t` by rw[] >> POP_ASSUM (fn x => fs[x, LUPDATE_LENGTH]) -); +QED -Theorem push_spec - `!qv xv vs x. app (p:'ffi ffi_proj) ^(fetch_v "push" st) [qv; xv] +Theorem push_spec: + !qv xv vs x. app (p:'ffi ffi_proj) ^(fetch_v "push" st) [qv; xv] (STACK A vs qv * & A x xv) - (POSTv uv. STACK A (vs ++ [x]) qv)` - (xcf "push" st >> + (POSTv uv. STACK A (vs ++ [x]) qv) +Proof + xcf "push" st >> simp[STACK_def] >> xpull >> xs_auto_tac >> @@ -155,21 +160,22 @@ Theorem push_spec Cases_on `junk:v list` >-(fs[LENGTH_NIL]) >> `vvs++[h]++t = vvs++h::t` by rw[] >> POP_ASSUM (fn x => fs[x, LUPDATE_LENGTH]) -); +QED val eq_num_v_thm = mlbasicsProgTheory.eq_v_thm |> DISCH_ALL |> C MATCH_MP (EqualityType_NUM_BOOL |> CONJUNCT1); -Theorem pop_spec - `!qv. +Theorem pop_spec: + !qv. EqualityType A ==> app (p:'ffi ffi_proj) ^(fetch_v "pop" st) [qv] (STACK A vs qv) (POSTve (\v. &(not(NULL vs) /\ A (LAST vs) v) * STACK A (FRONT vs) qv) - (\e. &(NULL vs /\ EmptyStack_exn e) * STACK A vs qv))` - (xcf "pop" st >> + (\e. &(NULL vs /\ EmptyStack_exn e) * STACK A vs qv)) +Proof + xcf "pop" st >> simp[STACK_def] >> xpull >> xlet_auto >-(xsimpl)>> @@ -219,6 +225,6 @@ Theorem pop_spec xsimpl >> rw[] >> fs[NULL_EQ] -); +QED val _ = export_theory () diff --git a/misc/byteScript.sml b/misc/byteScript.sml index fa394fbf80..b5c8c1d511 100644 --- a/misc/byteScript.sml +++ b/misc/byteScript.sml @@ -90,13 +90,14 @@ val words_of_bytes_def = tDefine "words_of_bytes" ` val words_of_bytes_ind = theorem"words_of_bytes_ind"; -Theorem LENGTH_words_of_bytes - `8 ≤ dimindex(:'a) ⇒ +Theorem LENGTH_words_of_bytes: + 8 ≤ dimindex(:'a) ⇒ ∀be ls. (LENGTH (words_of_bytes be ls : 'a word list) = LENGTH ls DIV (w2n (bytes_in_word : 'a word)) + - MIN 1 (LENGTH ls MOD (w2n (bytes_in_word : 'a word))))` - (strip_tac + MIN 1 (LENGTH ls MOD (w2n (bytes_in_word : 'a word)))) +Proof + strip_tac \\ recInduct words_of_bytes_ind \\ `1 ≤ w2n bytes_in_word` by ( @@ -132,15 +133,17 @@ Theorem LENGTH_words_of_bytes \\ fs[] \\ `m DIV n - 1 + 1 = m DIV n` suffices_by fs[] \\ DEP_REWRITE_TAC[SUB_ADD] - \\ fs[X_LE_DIV]); + \\ fs[X_LE_DIV] +QED -Theorem words_of_bytes_append - `0 < w2n(bytes_in_word:'a word) ⇒ +Theorem words_of_bytes_append: + 0 < w2n(bytes_in_word:'a word) ⇒ ∀l1 l2. (LENGTH l1 MOD w2n (bytes_in_word:'a word) = 0) ⇒ (words_of_bytes be (l1 ++ l2) : 'a word list = - words_of_bytes be l1 ++ words_of_bytes be l2)` - (strip_tac + words_of_bytes be l1 ++ words_of_bytes be l2) +Proof + strip_tac \\ gen_tac \\ completeInduct_on`LENGTH l1` \\ rw[] @@ -172,7 +175,8 @@ Theorem words_of_bytes_append \\ IF_CASES_TAC \\ fs[NOT_LESS] >- metis_tac[] \\ Cases_on`w2n bytes_in_word` \\ fs[] \\ rw[] - \\ Cases_on`n''` \\ fs[]); + \\ Cases_on`n''` \\ fs[] +QED Theorem words_of_bytes_append_word: 0 < LENGTH l1 ∧ (LENGTH l1 = w2n (bytes_in_word:'a word)) ⇒ @@ -193,11 +197,12 @@ val bytes_to_word_def = Define ` val bytes_to_word_ind = theorem "bytes_to_word_ind"; -Theorem word_of_bytes_bytes_to_word - `∀be a bs k. +Theorem word_of_bytes_bytes_to_word: + ∀be a bs k. LENGTH bs ≤ k ⇒ - (word_of_bytes be a bs = bytes_to_word k a bs 0w be)` - (Induct_on`bs` + (word_of_bytes be a bs = bytes_to_word k a bs 0w be) +Proof + Induct_on`bs` >- ( EVAL_TAC \\ Cases_on`k` @@ -209,7 +214,8 @@ Theorem word_of_bytes_bytes_to_word \\ AP_THM_TAC \\ AP_TERM_TAC \\ first_x_assum match_mp_tac - \\ fs[]); + \\ fs[] +QED Theorem bytes_to_word_same: ∀bw k b1 w be b2. diff --git a/misc/miscScript.sml b/misc/miscScript.sml index fc3bd4145e..a2a965701b 100644 --- a/misc/miscScript.sml +++ b/misc/miscScript.sml @@ -43,47 +43,59 @@ val _ = numLib.prefer_num(); val IMP_IMP = save_thm("IMP_IMP",METIS_PROVE[]``(P /\ (Q ==> R)) ==> ((P ==> Q) ==> R)``); (* never used *) -Theorem SUBSET_IMP - `s SUBSET t ==> (x IN s ==> x IN t)` - (fs[pred_setTheory.SUBSET_DEF]); - -Theorem revdroprev - `∀l n. - n ≤ LENGTH l ⇒ (REVERSE (DROP n (REVERSE l)) = TAKE (LENGTH l - n) l)` - (ho_match_mp_tac listTheory.SNOC_INDUCT >> simp[] >> rpt strip_tac >> +Theorem SUBSET_IMP: + s SUBSET t ==> (x IN s ==> x IN t) +Proof + fs[pred_setTheory.SUBSET_DEF] +QED + +Theorem revdroprev: + ∀l n. + n ≤ LENGTH l ⇒ (REVERSE (DROP n (REVERSE l)) = TAKE (LENGTH l - n) l) +Proof + ho_match_mp_tac listTheory.SNOC_INDUCT >> simp[] >> rpt strip_tac >> rename1 `n ≤ SUC (LENGTH l)` >> `n = 0 ∨ ∃m. n = SUC m` by (Cases_on `n` >> simp[]) >> simp[] >- simp[TAKE_APPEND2] >> simp[TAKE_APPEND1] >> `LENGTH l + 1 - SUC m = LENGTH l - m` suffices_by (disch_then SUBST_ALL_TAC >> simp[]) >> - simp[]); + simp[] +QED -Theorem revtakerev - `∀n l. n ≤ LENGTH l ⇒ REVERSE (TAKE n (REVERSE l)) = DROP (LENGTH l - n) l` - (Induct >> simp[DROP_LENGTH_NIL] >> +Theorem revtakerev: + ∀n l. n ≤ LENGTH l ⇒ REVERSE (TAKE n (REVERSE l)) = DROP (LENGTH l - n) l +Proof + Induct >> simp[DROP_LENGTH_NIL] >> qx_gen_tac `l` >> `l = [] ∨ ∃f e. l = SNOC e f` by metis_tac[SNOC_CASES] >> simp[] >> - simp[DROP_APPEND1]); + simp[DROP_APPEND1] +QED -Theorem times_add_o - `(λn:num. k * n + x) = ($+ x) o ($* k)` - (rw[FUN_EQ_THM]); +Theorem times_add_o: + (λn:num. k * n + x) = ($+ x) o ($* k) +Proof + rw[FUN_EQ_THM] +QED -Theorem SORTED_inv_image_LESS_PLUS - `SORTED (inv_image $< (arithmetic$+ k)) = SORTED $<` - (simp[FUN_EQ_THM] +Theorem SORTED_inv_image_LESS_PLUS: + SORTED (inv_image $< (arithmetic$+ k)) = SORTED $< +Proof + simp[FUN_EQ_THM] \\ Induct \\ Q.ISPEC_THEN`$+ k`(fn th => simp[MATCH_MP SORTED_EQ th]) (MATCH_MP transitive_inv_image transitive_LESS) - \\ simp[MATCH_MP SORTED_EQ transitive_LESS]); + \\ simp[MATCH_MP SORTED_EQ transitive_LESS] +QED -Theorem SORTED_GENLIST_TIMES - `0 < k ⇒ ∀n. SORTED prim_rec$< (GENLIST ($* k) n)` - (strip_tac +Theorem SORTED_GENLIST_TIMES: + 0 < k ⇒ ∀n. SORTED prim_rec$< (GENLIST ($* k) n) +Proof + strip_tac \\ Induct \\ simp[GENLIST,SNOC_APPEND] \\ match_mp_tac SORTED_APPEND - \\ simp[MEM_GENLIST,PULL_EXISTS]); + \\ simp[MEM_GENLIST,PULL_EXISTS] +QED (* this is read_bytearray a c gb = OPT_MMAP gb (GENLIST (λi. a + n2w i) c) @@ -98,50 +110,62 @@ val read_bytearray_def = Define ` | SOME bs => SOME (b::bs))` (* HOL to have OPT_MMAP f l1 = SOME l2 ==> (LENGTH l2 = LENGTH l1) *) -Theorem read_bytearray_LENGTH - `!n a f x. - (read_bytearray a n f = SOME x) ==> (LENGTH x = n)` - (Induct \\ fs [read_bytearray_def] \\ REPEAT STRIP_TAC - \\ BasicProvers.EVERY_CASE_TAC \\ fs [] \\ rw [] \\ res_tac); +Theorem read_bytearray_LENGTH: + !n a f x. + (read_bytearray a n f = SOME x) ==> (LENGTH x = n) +Proof + Induct \\ fs [read_bytearray_def] \\ REPEAT STRIP_TAC + \\ BasicProvers.EVERY_CASE_TAC \\ fs [] \\ rw [] \\ res_tac +QED val shift_seq_def = Define ` shift_seq k s = \i. s (i + k:num)`; (* TODO: Used once in all of CakeML: could probably be pushed back to use-site*) -Theorem SUM_SET_IN_LT - `!s x y. FINITE s /\ x IN s /\ y < x ==> y < SUM_SET s` - (metis_tac[SUM_SET_IN_LE,LESS_LESS_EQ_TRANS]); +Theorem SUM_SET_IN_LT: + !s x y. FINITE s /\ x IN s /\ y < x ==> y < SUM_SET s +Proof + metis_tac[SUM_SET_IN_LE,LESS_LESS_EQ_TRANS] +QED (* only used in proof of tlookup_bij_iff *) -Theorem CARD_IMAGE_ID_BIJ - `∀s. FINITE s ⇒ (∀x. x ∈ s ⇒ f x ∈ s) ∧ CARD (IMAGE f s) = CARD s ⇒ BIJ f s s` - (rw[] +Theorem CARD_IMAGE_ID_BIJ: + ∀s. FINITE s ⇒ (∀x. x ∈ s ⇒ f x ∈ s) ∧ CARD (IMAGE f s) = CARD s ⇒ BIJ f s s +Proof + rw[] \\ `SURJ f s s` suffices_by metis_tac[FINITE_SURJ_BIJ] \\ rw[IMAGE_SURJ] \\ `IMAGE f s ⊆ s` by metis_tac[SUBSET_DEF,IN_IMAGE] - \\ metis_tac[SUBSET_EQ_CARD,IMAGE_FINITE]); + \\ metis_tac[SUBSET_EQ_CARD,IMAGE_FINITE] +QED (* never used *) -Theorem CARD_IMAGE_EQ_BIJ - `∀s. FINITE s ⇒ CARD (IMAGE f s) = CARD s ⇒ BIJ f s (IMAGE f s)` - (rw[] +Theorem CARD_IMAGE_EQ_BIJ: + ∀s. FINITE s ⇒ CARD (IMAGE f s) = CARD s ⇒ BIJ f s (IMAGE f s) +Proof + rw[] \\ `SURJ f s (IMAGE f s)` suffices_by metis_tac[FINITE_SURJ_BIJ] - \\ rw[IMAGE_SURJ]); + \\ rw[IMAGE_SURJ] +QED (* used only in clos_callProof - HOL has DISJOINT_IMAGE: |- (!x y. f x = f y <=> x = y) ==> (DISJOINT (IMAGE f x) (IMAGE f y) <=> DISJOINT x y *) -Theorem DISJOINT_IMAGE_SUC - `DISJOINT (IMAGE SUC x) (IMAGE SUC y) <=> DISJOINT x y` - (fs [IN_DISJOINT] \\ metis_tac [DECIDE ``(SUC n = SUC m) <=> (m = n)``]); +Theorem DISJOINT_IMAGE_SUC: + DISJOINT (IMAGE SUC x) (IMAGE SUC y) <=> DISJOINT x y +Proof + fs [IN_DISJOINT] \\ metis_tac [DECIDE ``(SUC n = SUC m) <=> (m = n)``] +QED (* disgusting and used only in clos_callProof *) -Theorem IMAGE_SUC_SUBSET_UNION - `IMAGE SUC x SUBSET IMAGE SUC y UNION IMAGE SUC z <=> - x SUBSET y UNION z` - (fs [SUBSET_DEF] \\ metis_tac [DECIDE ``(SUC n = SUC m) <=> (m = n)``]); +Theorem IMAGE_SUC_SUBSET_UNION: + IMAGE SUC x SUBSET IMAGE SUC y UNION IMAGE SUC z <=> + x SUBSET y UNION z +Proof + fs [SUBSET_DEF] \\ metis_tac [DECIDE ``(SUC n = SUC m) <=> (m = n)``] +QED val _ = overload_on ("LLOOKUP", “λl n. oEL n l”) val LLOOKUP_def = save_thm("LLOOKUP_def", listTheory.oEL_def); @@ -163,16 +187,20 @@ val append_aux_def = Define ` val append_def = Define ` append l = append_aux l []`; -Theorem append_aux_thm - `!l xs. append_aux l xs = append_aux l [] ++ xs` - (Induct \\ metis_tac [APPEND,APPEND_ASSOC,append_aux_def]); +Theorem append_aux_thm: + !l xs. append_aux l xs = append_aux l [] ++ xs +Proof + Induct \\ metis_tac [APPEND,APPEND_ASSOC,append_aux_def] +QED -Theorem append_thm[simp] - `append (Append l1 l2) = append l1 ++ append l2 /\ +Theorem append_thm[simp]: + append (Append l1 l2) = append l1 ++ append l2 /\ append (List xs) = xs /\ - append Nil = []` - (fs [append_def,append_aux_def] - \\ once_rewrite_tac [append_aux_thm] \\ fs []); + append Nil = [] +Proof + fs [append_def,append_aux_def] + \\ once_rewrite_tac [append_aux_thm] \\ fs [] +QED val SmartAppend_def = Define` (SmartAppend Nil l2 = l2) ∧ @@ -180,28 +208,36 @@ val SmartAppend_def = Define` (SmartAppend l1 l2 = Append l1 l2)`; val _ = export_rewrites["SmartAppend_def"]; -Theorem SmartAppend_thm - `∀l1 l2. +Theorem SmartAppend_thm: + ∀l1 l2. SmartAppend l1 l2 = if l1 = Nil then l2 else - if l2 = Nil then l1 else Append l1 l2` - (Cases \\ Cases \\ rw[]); + if l2 = Nil then l1 else Append l1 l2 +Proof + Cases \\ Cases \\ rw[] +QED -Theorem append_SmartAppend[simp] - `append (SmartAppend l1 l2) = append l1 ++ append l2` - (rw[append_def,SmartAppend_thm,append_aux_def] - \\ rw[Once append_aux_thm]); +Theorem append_SmartAppend[simp]: + append (SmartAppend l1 l2) = append l1 ++ append l2 +Proof + rw[append_def,SmartAppend_thm,append_aux_def] + \\ rw[Once append_aux_thm] +QED (* instant derivation from LIST_EQ_REWRITE *) -Theorem GENLIST_eq_MAP - `GENLIST f n = MAP g ls ⇔ - LENGTH ls = n ∧ ∀m. m < n ⇒ f m = g (EL m ls)` - (srw_tac[][LIST_EQ_REWRITE,EQ_IMP_THM,EL_MAP]) +Theorem GENLIST_eq_MAP: + GENLIST f n = MAP g ls ⇔ + LENGTH ls = n ∧ ∀m. m < n ⇒ f m = g (EL m ls) +Proof + srw_tac[][LIST_EQ_REWRITE,EQ_IMP_THM,EL_MAP] +QED (* TODO - already in HOL as ZIP_GENLIST *) -Theorem ZIP_GENLIST1 - `∀l f n. LENGTH l = n ⇒ ZIP (GENLIST f n,l) = GENLIST (λx. (f x, EL x l)) n` - (Induct \\ rw[] \\ rw[GENLIST_CONS,o_DEF]); +Theorem ZIP_GENLIST1: + ∀l f n. LENGTH l = n ⇒ ZIP (GENLIST f n,l) = GENLIST (λx. (f x, EL x l)) n +Proof + Induct \\ rw[] \\ rw[GENLIST_CONS,o_DEF] +QED (* MAP3 never used *) val MAP3_def = Define` @@ -211,62 +247,80 @@ val _ = export_rewrites["MAP3_def"]; val MAP3_ind = theorem"MAP3_ind"; -Theorem LENGTH_MAP3[simp] - `∀f l1 l2 l3. LENGTH l1 = LENGTH l3 /\ LENGTH l2 = LENGTH l3 ⇒ LENGTH (MAP3 f l1 l2 l3) = LENGTH l3` - (ho_match_mp_tac MAP3_ind \\ rw[]); +Theorem LENGTH_MAP3[simp]: + ∀f l1 l2 l3. LENGTH l1 = LENGTH l3 /\ LENGTH l2 = LENGTH l3 ⇒ LENGTH (MAP3 f l1 l2 l3) = LENGTH l3 +Proof + ho_match_mp_tac MAP3_ind \\ rw[] +QED -Theorem EL_MAP3 - `∀f l1 l2 l3 n. n < LENGTH l1 ∧ n < LENGTH l2 ∧ n < LENGTH l3 ⇒ - EL n (MAP3 f l1 l2 l3) = f (EL n l1) (EL n l2) (EL n l3)` - (ho_match_mp_tac MAP3_ind \\ rw[] - \\ Cases_on`n` \\ fs[]); +Theorem EL_MAP3: + ∀f l1 l2 l3 n. n < LENGTH l1 ∧ n < LENGTH l2 ∧ n < LENGTH l3 ⇒ + EL n (MAP3 f l1 l2 l3) = f (EL n l1) (EL n l2) (EL n l3) +Proof + ho_match_mp_tac MAP3_ind \\ rw[] + \\ Cases_on`n` \\ fs[] +QED (* used once *) -Theorem MAP_REVERSE_STEP - `∀x f. x ≠ [] ⇒ MAP f (REVERSE x) = f (LAST x) :: MAP f (REVERSE (FRONT x))` - (recInduct SNOC_INDUCT - \\ rw [FRONT_APPEND]); +Theorem MAP_REVERSE_STEP: + ∀x f. x ≠ [] ⇒ MAP f (REVERSE x) = f (LAST x) :: MAP f (REVERSE (FRONT x)) +Proof + recInduct SNOC_INDUCT + \\ rw [FRONT_APPEND] +QED (* used three times, once with MIN_DEF alongside, which turns it into LENGTH_TAKE_EQ *) -Theorem LENGTH_TAKE_EQ_MIN - `!n xs. LENGTH (TAKE n xs) = MIN n (LENGTH xs)` - (simp[LENGTH_TAKE_EQ] \\ full_simp_tac(srw_ss())[MIN_DEF] \\ decide_tac); +Theorem LENGTH_TAKE_EQ_MIN: + !n xs. LENGTH (TAKE n xs) = MIN n (LENGTH xs) +Proof + simp[LENGTH_TAKE_EQ] \\ full_simp_tac(srw_ss())[MIN_DEF] \\ decide_tac +QED (* should be switched in orientation; looks like an attempt to get congruence rule *) -Theorem LIST_REL_MEM - `!xs ys P. LIST_REL P xs ys <=> - LIST_REL (\x y. MEM x xs /\ MEM y ys ==> P x y) xs ys` - (full_simp_tac(srw_ss())[LIST_REL_EL_EQN] \\ METIS_TAC [MEM_EL]); +Theorem LIST_REL_MEM: + !xs ys P. LIST_REL P xs ys <=> + LIST_REL (\x y. MEM x xs /\ MEM y ys ==> P x y) xs ys +Proof + full_simp_tac(srw_ss())[LIST_REL_EL_EQN] \\ METIS_TAC [MEM_EL] +QED (* only used in theorem immediately below *) -Theorem LIST_REL_GENLIST_I - `!xs. LIST_REL P (GENLIST I (LENGTH xs)) xs = - !n. n < LENGTH xs ==> P n (EL n xs)` - (simp[LIST_REL_EL_EQN]); +Theorem LIST_REL_GENLIST_I: + !xs. LIST_REL P (GENLIST I (LENGTH xs)) xs = + !n. n < LENGTH xs ==> P n (EL n xs) +Proof + simp[LIST_REL_EL_EQN] +QED (* only used in bvi_to_dataProof *) -Theorem LIST_REL_lookup_fromList - `LIST_REL (\v x. lookup v (fromList args) = SOME x) - (GENLIST I (LENGTH args)) args` - (SIMP_TAC std_ss [lookup_fromList,LIST_REL_GENLIST_I]); +Theorem LIST_REL_lookup_fromList: + LIST_REL (\v x. lookup v (fromList args) = SOME x) + (GENLIST I (LENGTH args)) args +Proof + SIMP_TAC std_ss [lookup_fromList,LIST_REL_GENLIST_I] +QED -Theorem LIST_REL_lookup_fromList_MAP - `LIST_REL (λv x. ∃z. lookup v (fromList args) = SOME z ∧ x = f z) - (GENLIST I (LENGTH args)) (MAP f args)` - (fs [LIST_REL_MAP2,LIST_REL_GENLIST_I,lookup_fromList]) +Theorem LIST_REL_lookup_fromList_MAP: + LIST_REL (λv x. ∃z. lookup v (fromList args) = SOME z ∧ x = f z) + (GENLIST I (LENGTH args)) (MAP f args) +Proof + fs [LIST_REL_MAP2,LIST_REL_GENLIST_I,lookup_fromList] +QED (* only used in examples/stackProg; oriented badly *) -Theorem LIST_REL_FRONT_LAST - `l1 <> [] /\ l2 <> [] ==> +Theorem LIST_REL_FRONT_LAST: + l1 <> [] /\ l2 <> [] ==> (LIST_REL A l1 l2 <=> - LIST_REL A (FRONT l1) (FRONT l2) /\ A (LAST l1) (LAST l2))` - (map_every + LIST_REL A (FRONT l1) (FRONT l2) /\ A (LAST l1) (LAST l2)) +Proof + map_every (fn q => Q.ISPEC_THEN q FULL_STRUCT_CASES_TAC SNOC_CASES >> fs[LIST_REL_SNOC]) - [`l1`,`l2`]); + [`l1`,`l2`] +QED val lemmas = Q.prove( `(2 + 2 * n - 1 = 2 * n + 1:num) /\ @@ -297,106 +351,127 @@ val EVEN_fromList2_lemma = Q.prove( \\ REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[EVEN_EXISTS] \\ Q.EXISTS_TAC `SUC m` \\ DECIDE_TAC); -Theorem EVEN_fromList2 - `!l n. n IN domain (fromList2 l) ==> EVEN n` - (ASSUME_TAC (EVEN_fromList2_lemma +Theorem EVEN_fromList2: + !l n. n IN domain (fromList2 l) ==> EVEN n +Proof + ASSUME_TAC (EVEN_fromList2_lemma |> Q.SPECL [`l`,`0`,`LN`] |> SIMP_RULE (srw_ss()) [GSYM fromList2_def] - |> GEN_ALL) \\ full_simp_tac(srw_ss())[]); + |> GEN_ALL) \\ full_simp_tac(srw_ss())[] +QED -Theorem SUBMAP_mono_FUPDATE_LIST - `∀ls f g. +Theorem SUBMAP_mono_FUPDATE_LIST: + ∀ls f g. DRESTRICT f (COMPL (set (MAP FST ls))) ⊑ DRESTRICT g (COMPL (set (MAP FST ls))) - ⇒ f |++ ls ⊑ g |++ ls` - (Induct \\ rw[FUPDATE_LIST_THM, DRESTRICT_UNIV] + ⇒ f |++ ls ⊑ g |++ ls +Proof + Induct \\ rw[FUPDATE_LIST_THM, DRESTRICT_UNIV] \\ first_x_assum MATCH_MP_TAC \\ Cases_on`h` \\ fs[SUBMAP_FLOOKUP_EQN] \\ rw[] \\ fs[FLOOKUP_DRESTRICT, FLOOKUP_UPDATE] \\ rw[] \\ fs[] - \\ METIS_TAC[]); + \\ METIS_TAC[] +QED -Theorem INJ_FAPPLY_FUPDATE - `INJ ($' f) (FDOM f) (FRANGE f) ∧ +Theorem INJ_FAPPLY_FUPDATE: + INJ ($' f) (FDOM f) (FRANGE f) ∧ s = k INSERT FDOM f ∧ v ∉ FRANGE f ∧ t = v INSERT FRANGE f ⇒ - INJ ($' (f |+ (k,v))) s t` - (srw_tac[][INJ_DEF,FAPPLY_FUPDATE_THM] >> srw_tac[][] >> + INJ ($' (f |+ (k,v))) s t +Proof + srw_tac[][INJ_DEF,FAPPLY_FUPDATE_THM] >> srw_tac[][] >> pop_assum mp_tac >> srw_tac[][] >> full_simp_tac(srw_ss())[IN_FRANGE] >> - METIS_TAC[]) + METIS_TAC[] +QED (* used in only one place: stack_to_labProof *) -Theorem BIJ_FLOOKUP_MAP_KEYS - `BIJ bij UNIV UNIV ==> - FLOOKUP (MAP_KEYS (LINV bij UNIV) f) n = FLOOKUP f (bij n)` - (fs [FLOOKUP_DEF,MAP_KEYS_def,BIJ_DEF] \\ strip_tac +Theorem BIJ_FLOOKUP_MAP_KEYS: + BIJ bij UNIV UNIV ==> + FLOOKUP (MAP_KEYS (LINV bij UNIV) f) n = FLOOKUP f (bij n) +Proof + fs [FLOOKUP_DEF,MAP_KEYS_def,BIJ_DEF] \\ strip_tac \\ match_mp_tac (METIS_PROVE [] ``x=x'/\(x /\ x' ==> y=y') ==> (if x then y else z) = (if x' then y' else z)``) \\ fs [] \\ rw [] THEN1 (eq_tac \\ rw [] \\ metis_tac [BIJ_LINV_INV,BIJ_DEF,IN_UNIV,LINV_DEF]) \\ `BIJ (LINV bij UNIV) UNIV UNIV` by metis_tac [BIJ_LINV_BIJ,BIJ_DEF] \\ `INJ (LINV bij UNIV) (FDOM f) UNIV` by fs [INJ_DEF,IN_UNIV,BIJ_DEF] - \\ fs [MAP_KEYS_def] \\ metis_tac [BIJ_LINV_INV,BIJ_DEF,IN_UNIV,LINV_DEF]); + \\ fs [MAP_KEYS_def] \\ metis_tac [BIJ_LINV_INV,BIJ_DEF,IN_UNIV,LINV_DEF] +QED -Theorem SPLIT_LIST - `!xs. +Theorem SPLIT_LIST: + !xs. ?ys zs. (xs = ys ++ zs) /\ - (LENGTH xs DIV 2 = LENGTH ys)` - (REPEAT STRIP_TAC + (LENGTH xs DIV 2 = LENGTH ys) +Proof + REPEAT STRIP_TAC \\ Q.LIST_EXISTS_TAC [`TAKE (LENGTH xs DIV 2) xs`,`DROP (LENGTH xs DIV 2) xs`] \\ REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[TAKE_DROP] \\ MATCH_MP_TAC (GSYM LENGTH_TAKE) - \\ full_simp_tac(srw_ss())[DIV_LE_X] \\ DECIDE_TAC); + \\ full_simp_tac(srw_ss())[DIV_LE_X] \\ DECIDE_TAC +QED -Theorem EXISTS_ZIP - `!l f. EXISTS (\(x,y). f x) l = EXISTS f (MAP FST l)` - (Induct_on `l` >> +Theorem EXISTS_ZIP: + !l f. EXISTS (\(x,y). f x) l = EXISTS f (MAP FST l) +Proof + Induct_on `l` >> srw_tac[][] >> Cases_on `h` >> full_simp_tac(srw_ss())[] >> - metis_tac []); + metis_tac [] +QED -Theorem EVERY_ZIP - `!l f. EVERY (\(x,y). f x) l = EVERY f (MAP FST l)` - (Induct_on `l` >> +Theorem EVERY_ZIP: + !l f. EVERY (\(x,y). f x) l = EVERY f (MAP FST l) +Proof + Induct_on `l` >> srw_tac[][] >> Cases_on `h` >> full_simp_tac(srw_ss())[] >> - metis_tac []); + metis_tac [] +QED -Theorem every_zip_split - `!l1 l2 P Q. +Theorem every_zip_split: + !l1 l2 P Q. LENGTH l1 = LENGTH l2 ⇒ - (EVERY (\(x,y). P x ∧ Q y) (ZIP (l1, l2)) ⇔ EVERY P l1 ∧ EVERY Q l2)` - (Induct_on `l1` + (EVERY (\(x,y). P x ∧ Q y) (ZIP (l1, l2)) ⇔ EVERY P l1 ∧ EVERY Q l2) +Proof + Induct_on `l1` >> simp [] >> Cases_on `l2` >> rw [] - >> metis_tac []); + >> metis_tac [] +QED -Theorem every_shim -`!l P. EVERY (\(x,y). P y) l = EVERY P (MAP SND l)` -(Induct_on `l` >> +Theorem every_shim: + !l P. EVERY (\(x,y). P y) l = EVERY P (MAP SND l) +Proof +Induct_on `l` >> rw [] >> PairCases_on `h` >> -rw []); +rw [] +QED -Theorem every_shim2 -`!l P Q. EVERY (\(x,y). P x ∧ Q y) l = (EVERY (\x. P (FST x)) l ∧ EVERY (\x. Q (SND x)) l)` -(Induct_on `l` >> +Theorem every_shim2: + !l P Q. EVERY (\(x,y). P x ∧ Q y) l = (EVERY (\x. P (FST x)) l ∧ EVERY (\x. Q (SND x)) l) +Proof +Induct_on `l` >> rw [] >> PairCases_on `h` >> rw [] >> -metis_tac []); +metis_tac [] +QED -Theorem MEM_ZIP2 ` - ∀l1 l2 x. +Theorem MEM_ZIP2: + ∀l1 l2 x. MEM x (ZIP (l1,l2)) ⇒ - ∃n. n < LENGTH l1 ∧ n < LENGTH l2 ∧ x = (EL n l1,EL n l2)` - (Induct>>fs[ZIP_def]>> + ∃n. n < LENGTH l1 ∧ n < LENGTH l2 ∧ x = (EL n l1,EL n l2) +Proof + Induct>>fs[ZIP_def]>> Cases_on`l2`>>fs[ZIP_def]>> rw[] >- @@ -404,20 +479,27 @@ Theorem MEM_ZIP2 ` >> first_x_assum drule>> rw[]>> - qexists_tac`SUC n`>>fs[]); + qexists_tac`SUC n`>>fs[] +QED -Theorem ZIP_MAP_FST_SND_EQ - `∀ls. ZIP (MAP FST ls,MAP SND ls) = ls` - (Induct>>full_simp_tac(srw_ss())[]) +Theorem ZIP_MAP_FST_SND_EQ: + ∀ls. ZIP (MAP FST ls,MAP SND ls) = ls +Proof + Induct>>full_simp_tac(srw_ss())[] +QED -Theorem MAP_FST_I_PAIR_MAP[simp] - `!xs. MAP FST (MAP (I ## f) xs) = MAP FST xs` - (Induct \\ fs [FORALL_PROD]); +Theorem MAP_FST_I_PAIR_MAP[simp]: + !xs. MAP FST (MAP (I ## f) xs) = MAP FST xs +Proof + Induct \\ fs [FORALL_PROD] +QED -Theorem EVERY_FST_SND - `EVERY (λ(a,b). P a ∧ Q b) ls ⇔ EVERY P (MAP FST ls) ∧ EVERY Q (MAP SND ls)` - (rw[EVERY_MEM,MEM_MAP,UNCURRY,EXISTS_PROD,FORALL_PROD,PULL_EXISTS] - \\ metis_tac[]); +Theorem EVERY_FST_SND: + EVERY (λ(a,b). P a ∧ Q b) ls ⇔ EVERY P (MAP FST ls) ∧ EVERY Q (MAP SND ls) +Proof + rw[EVERY_MEM,MEM_MAP,UNCURRY,EXISTS_PROD,FORALL_PROD,PULL_EXISTS] + \\ metis_tac[] +QED val zlookup_def = Define ` zlookup m k = case lookup k m of NONE => 0n | SOME k => k`; @@ -425,16 +507,19 @@ val zlookup_def = Define ` val tlookup_def = Define ` tlookup m k = case lookup k m of NONE => k | SOME k => k`; -Theorem tlookup_id - `x ∉ domain names - ⇒ tlookup names x = x` - (rw[tlookup_def] - \\ fs[domain_lookup] \\ CASE_TAC \\ fs[]); +Theorem tlookup_id: + x ∉ domain names + ⇒ tlookup names x = x +Proof + rw[tlookup_def] + \\ fs[domain_lookup] \\ CASE_TAC \\ fs[] +QED -Theorem tlookup_bij_suff - `set (toList names) = domain names ⇒ - BIJ (tlookup names) UNIV UNIV` - (strip_tac +Theorem tlookup_bij_suff: + set (toList names) = domain names ⇒ + BIJ (tlookup names) UNIV UNIV +Proof + strip_tac \\ match_mp_tac BIJ_support \\ qexists_tac`domain names` \\ reverse conj_tac @@ -451,12 +536,14 @@ Theorem tlookup_bij_suff \\ metis_tac[] ) \\ match_mp_tac (MP_CANON CARD_IMAGE_ID_BIJ) \\ fs[] \\ rw[] \\ fs[EXTENSION] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem tlookup_bij_iff - `BIJ (tlookup names) UNIV UNIV ⇔ - set (toList names) = domain names` - (rw[EQ_IMP_THM,tlookup_bij_suff] +Theorem tlookup_bij_iff: + BIJ (tlookup names) UNIV UNIV ⇔ + set (toList names) = domain names +Proof + rw[EQ_IMP_THM,tlookup_bij_suff] \\ fs[BIJ_IFF_INV] \\ rw[EXTENSION,domain_lookup,MEM_toList] \\ rw[EQ_IMP_THM] @@ -480,7 +567,8 @@ Theorem tlookup_bij_iff \\ CASE_TAC \\ fs[] \\ CCONTR_TAC \\ fs[] \\ metis_tac[]) - \\ metis_tac[] ) + \\ metis_tac[] +QED (* should be composition of oEL and as-yet-undefined "THEdflt" *) val any_el_def = Define ` @@ -493,20 +581,26 @@ val list_max_def = Define ` let m = list_max xs in if m < x then x else m)` -Theorem list_max_max - `∀ls. EVERY (λx. x ≤ list_max ls) ls` - (Induct>>full_simp_tac(srw_ss())[list_max_def,LET_THM]>>srw_tac[][]>>full_simp_tac(srw_ss())[EVERY_MEM]>>srw_tac[][]>> - res_tac >> decide_tac); +Theorem list_max_max: + ∀ls. EVERY (λx. x ≤ list_max ls) ls +Proof + Induct>>full_simp_tac(srw_ss())[list_max_def,LET_THM]>>srw_tac[][]>>full_simp_tac(srw_ss())[EVERY_MEM]>>srw_tac[][]>> + res_tac >> decide_tac +QED -Theorem list_max_intro ` - ∀ls. - P 0 ∧ EVERY P ls ⇒ P (list_max ls)` - (Induct>>full_simp_tac(srw_ss())[list_max_def]>>srw_tac[][]>> - IF_CASES_TAC>>full_simp_tac(srw_ss())[]); +Theorem list_max_intro: + ∀ls. + P 0 ∧ EVERY P ls ⇒ P (list_max ls) +Proof + Induct>>full_simp_tac(srw_ss())[list_max_def]>>srw_tac[][]>> + IF_CASES_TAC>>full_simp_tac(srw_ss())[] +QED -Theorem FOLDR_MAX_0_list_max - `∀ls. FOLDR MAX 0 ls = list_max ls` - (Induct \\ rw[list_max_def] \\ rw[MAX_DEF]); +Theorem FOLDR_MAX_0_list_max: + ∀ls. FOLDR MAX 0 ls = list_max ls +Proof + Induct \\ rw[list_max_def] \\ rw[MAX_DEF] +QED (* never used *) val list_inter_def = Define ` @@ -517,33 +611,41 @@ val max3_def = Define` else (if z > y then z else y)` val _ = export_rewrites["max3_def"]; -Theorem ALOOKUP_SNOC - `∀ls p k. ALOOKUP (SNOC p ls) k = +Theorem ALOOKUP_SNOC: + ∀ls p k. ALOOKUP (SNOC p ls) k = case ALOOKUP ls k of SOME v => SOME v | - NONE => if k = FST p then SOME (SND p) else NONE` - (Induct >> simp[] >> - Cases >> simp[] >> srw_tac[][]) + NONE => if k = FST p then SOME (SND p) else NONE +Proof + Induct >> simp[] >> + Cases >> simp[] >> srw_tac[][] +QED -Theorem ALOOKUP_GENLIST - `∀f n k. ALOOKUP (GENLIST (λi. (i,f i)) n) k = if k < n then SOME (f k) else NONE` - (gen_tac >> Induct >> simp[GENLIST] >> srw_tac[][] >> full_simp_tac(srw_ss())[ALOOKUP_SNOC] >> - srw_tac[][] >> fsrw_tac[ARITH_ss][]) +Theorem ALOOKUP_GENLIST: + ∀f n k. ALOOKUP (GENLIST (λi. (i,f i)) n) k = if k < n then SOME (f k) else NONE +Proof + gen_tac >> Induct >> simp[GENLIST] >> srw_tac[][] >> full_simp_tac(srw_ss())[ALOOKUP_SNOC] >> + srw_tac[][] >> fsrw_tac[ARITH_ss][] +QED -Theorem ALOOKUP_ZIP_FAIL - `∀A B x. +Theorem ALOOKUP_ZIP_FAIL: + ∀A B x. LENGTH A = LENGTH B ⇒ - (ALOOKUP (ZIP (A,B)) x = NONE ⇔ ¬MEM x A)` - (srw_tac[][]>>Q.ISPECL_THEN [`ZIP(A,B)`,`x`] assume_tac ALOOKUP_NONE >> - full_simp_tac(srw_ss())[MAP_ZIP]) + (ALOOKUP (ZIP (A,B)) x = NONE ⇔ ¬MEM x A) +Proof + srw_tac[][]>>Q.ISPECL_THEN [`ZIP(A,B)`,`x`] assume_tac ALOOKUP_NONE >> + full_simp_tac(srw_ss())[MAP_ZIP] +QED -Theorem MEM_ALOOKUP - `!xs x v. +Theorem MEM_ALOOKUP: + !xs x v. ALL_DISTINCT (MAP FST xs) ==> - (MEM (x,v) xs <=> ALOOKUP xs x = SOME v)` - (Induct \\ fs [FORALL_PROD] \\ rw [] + (MEM (x,v) xs <=> ALOOKUP xs x = SOME v) +Proof + Induct \\ fs [FORALL_PROD] \\ rw [] \\ res_tac \\ eq_tac \\ rw [] \\ rfs [] \\ imp_res_tac ALOOKUP_MEM - \\ fs [MEM_MAP,FORALL_PROD] \\ rfs []); + \\ fs [MEM_MAP,FORALL_PROD] \\ rfs [] +QED (* TODO - candidate for move to HOL, but in simpler form without accumulator *) (* only used in inferProg *) @@ -555,39 +657,46 @@ val anub_def = Define` val anub_ind = theorem"anub_ind" -Theorem EVERY_anub_imp - `∀ls acc x y. +Theorem EVERY_anub_imp: + ∀ls acc x y. EVERY P (anub ((x,y)::ls) acc) ∧ x ∉ set acc ⇒ - P (x,y) ∧ EVERY P (anub ls (x::acc))` - (ho_match_mp_tac anub_ind >> srw_tac[][anub_def] >> - full_simp_tac(srw_ss())[MEM_MAP,PULL_EXISTS,FORALL_PROD,EXISTS_PROD]) + P (x,y) ∧ EVERY P (anub ls (x::acc)) +Proof + ho_match_mp_tac anub_ind >> srw_tac[][anub_def] >> + full_simp_tac(srw_ss())[MEM_MAP,PULL_EXISTS,FORALL_PROD,EXISTS_PROD] +QED (* terrible rewrite *) -Theorem ALOOKUP_anub - `ALOOKUP (anub ls acc) k = +Theorem ALOOKUP_anub: + ALOOKUP (anub ls acc) k = if MEM k acc then ALOOKUP (anub ls acc) k - else ALOOKUP ls k` - (qid_spec_tac`acc` >> + else ALOOKUP ls k +Proof + qid_spec_tac`acc` >> Induct_on`ls` >> srw_tac[][anub_def] >> Cases_on`h`>>srw_tac[][anub_def]>>full_simp_tac(srw_ss())[] >- ( first_x_assum(qspec_then`acc`mp_tac) >> srw_tac[][] ) >> first_x_assum(qspec_then`q::acc`mp_tac) >> - srw_tac[][]) + srw_tac[][] +QED -Theorem anub_eq_nil - `anub x y = [] ⇔ EVERY (combin$C MEM y) (MAP FST x)` - (qid_spec_tac`y` >> +Theorem anub_eq_nil: + anub x y = [] ⇔ EVERY (combin$C MEM y) (MAP FST x) +Proof + qid_spec_tac`y` >> Induct_on`x`>>srw_tac[][anub_def]>> - Cases_on`h`>>srw_tac[][anub_def]) + Cases_on`h`>>srw_tac[][anub_def] +QED -Theorem EVERY_anub_suff - `∀ls acc. +Theorem EVERY_anub_suff: + ∀ls acc. (∀x. ¬MEM x acc ⇒ case ALOOKUP ls x of SOME v => P (x,v) | NONE => T) - ⇒ EVERY P (anub ls acc)` - (Induct >> simp[anub_def] >> + ⇒ EVERY P (anub ls acc) +Proof + Induct >> simp[anub_def] >> Cases >> simp[anub_def] >> srw_tac[][] >- ( first_x_assum(match_mp_tac) >> srw_tac[][] >> @@ -597,66 +706,84 @@ Theorem EVERY_anub_suff res_tac >> full_simp_tac(srw_ss())[] ) >> first_x_assum match_mp_tac >> srw_tac[][] >> res_tac >> full_simp_tac(srw_ss())[] >> - `q ≠ x` by full_simp_tac(srw_ss())[] >> full_simp_tac(srw_ss())[]) + `q ≠ x` by full_simp_tac(srw_ss())[] >> full_simp_tac(srw_ss())[] +QED -Theorem anub_notin_acc - `∀ls acc. MEM x acc ⇒ ¬MEM x (MAP FST (anub ls acc))` - (Induct >> simp[anub_def] >> +Theorem anub_notin_acc: + ∀ls acc. MEM x acc ⇒ ¬MEM x (MAP FST (anub ls acc)) +Proof + Induct >> simp[anub_def] >> Cases >> simp[anub_def] >> srw_tac[][] >> - metis_tac[]) + metis_tac[] +QED -Theorem anub_tl_anub - `∀x y h t. anub x y = h::t ⇒ ∃a b. t = anub a b ∧ set a ⊆ set x ∧ set b ⊆ set ((FST h)::y)` - (Induct >> srw_tac[][anub_def] >> +Theorem anub_tl_anub: + ∀x y h t. anub x y = h::t ⇒ ∃a b. t = anub a b ∧ set a ⊆ set x ∧ set b ⊆ set ((FST h)::y) +Proof + Induct >> srw_tac[][anub_def] >> Cases_on`h`>>full_simp_tac(srw_ss())[anub_def] >> pop_assum mp_tac >> srw_tac[][] >> res_tac >> srw_tac[][] >> full_simp_tac(srw_ss())[SUBSET_DEF] >> - metis_tac[MEM] ) + metis_tac[MEM] +QED -Theorem anub_all_distinct_keys - `∀ls acc. +Theorem anub_all_distinct_keys: + ∀ls acc. ALL_DISTINCT acc ⇒ - ALL_DISTINCT ((MAP FST (anub ls acc)) ++ acc)` - (Induct>>srw_tac[][anub_def]>>PairCases_on`h`>>full_simp_tac(srw_ss())[anub_def]>> + ALL_DISTINCT ((MAP FST (anub ls acc)) ++ acc) +Proof + Induct>>srw_tac[][anub_def]>>PairCases_on`h`>>full_simp_tac(srw_ss())[anub_def]>> srw_tac[][]>> `ALL_DISTINCT (h0::acc)` by full_simp_tac(srw_ss())[ALL_DISTINCT]>>res_tac>> full_simp_tac(srw_ss())[ALL_DISTINCT_APPEND]>> - metis_tac[]) + metis_tac[] +QED -Theorem MEM_anub_ALOOKUP - `MEM (k,v) (anub ls []) ⇒ - ALOOKUP ls k = SOME v` - (srw_tac[][]>> +Theorem MEM_anub_ALOOKUP: + MEM (k,v) (anub ls []) ⇒ + ALOOKUP ls k = SOME v +Proof + srw_tac[][]>> Q.ISPECL_THEN[`ls`,`[]`] assume_tac anub_all_distinct_keys>> Q.ISPECL_THEN [`ls`,`k`,`[]`] assume_tac (GEN_ALL ALOOKUP_anub)>> full_simp_tac(srw_ss())[]>> - metis_tac[ALOOKUP_ALL_DISTINCT_MEM]) + metis_tac[ALOOKUP_ALL_DISTINCT_MEM] +QED -Theorem IS_SOME_EXISTS - `∀opt. IS_SOME opt ⇔ ∃x. opt = SOME x` - (Cases >> simp[]) +Theorem IS_SOME_EXISTS: + ∀opt. IS_SOME opt ⇔ ∃x. opt = SOME x +Proof + Cases >> simp[] +QED val _ = type_abbrev("num_set",``:unit spt``); val _ = type_abbrev("num_map",``:'a spt``); -Theorem toAList_domain ` - ∀x. MEM x (MAP FST (toAList t)) ⇔ x ∈ domain t` - (full_simp_tac(srw_ss())[EXISTS_PROD,MEM_MAP,MEM_toAList,domain_lookup]) +Theorem toAList_domain: + ∀x. MEM x (MAP FST (toAList t)) ⇔ x ∈ domain t +Proof + full_simp_tac(srw_ss())[EXISTS_PROD,MEM_MAP,MEM_toAList,domain_lookup] +QED -Theorem domain_nat_set_from_list - `∀ls ns. domain (FOLDL (λs n. insert n () s) ns ls) = domain ns ∪ set ls` - (Induct >> simp[sptreeTheory.domain_insert] >> - srw_tac[][EXTENSION] >> metis_tac[]) +Theorem domain_nat_set_from_list: + ∀ls ns. domain (FOLDL (λs n. insert n () s) ns ls) = domain ns ∪ set ls +Proof + Induct >> simp[sptreeTheory.domain_insert] >> + srw_tac[][EXTENSION] >> metis_tac[] +QED val _ = export_rewrites["domain_nat_set_from_list"] -Theorem wf_nat_set_from_list - `∀ls ns. wf ns ⇒ wf (FOLDL (λs n. insert n z s) ns ls)` - (Induct >> simp[] >> srw_tac[][sptreeTheory.wf_insert]) +Theorem wf_nat_set_from_list: + ∀ls ns. wf ns ⇒ wf (FOLDL (λs n. insert n z s) ns ls) +Proof + Induct >> simp[] >> srw_tac[][sptreeTheory.wf_insert] +QED -Theorem BIT_11 - `∀n m. (BIT n = BIT m) ⇔ (n = m)` - (simp[EQ_IMP_THM] >> +Theorem BIT_11: + ∀n m. (BIT n = BIT m) ⇔ (n = m) +Proof + simp[EQ_IMP_THM] >> Induct >> simp[BIT0_ODD,FUN_EQ_THM] >- ( Cases >> simp[] >> qexists_tac`1` >> simp[GSYM BIT_DIV2,BIT_ZERO] ) >> @@ -670,11 +797,13 @@ Theorem BIT_11 simp[FUN_EQ_THM] >> gen_tac >> first_x_assum(qspec_then`x*2`mp_tac) >> - simp[arithmeticTheory.MULT_DIV]) + simp[arithmeticTheory.MULT_DIV] +QED -Theorem BIT_11_2 - `∀n m. (∀z. (z < 2 ** (MAX n m)) ⇒ (BIT n z ⇔ BIT m z)) ⇔ (n = m)` - (simp[Once EQ_IMP_THM] >> +Theorem BIT_11_2: + ∀n m. (∀z. (z < 2 ** (MAX n m)) ⇒ (BIT n z ⇔ BIT m z)) ⇔ (n = m) +Proof + simp[Once EQ_IMP_THM] >> Induct >- ( simp[] >> Cases >> simp[] >> @@ -691,19 +820,23 @@ Theorem BIT_11_2 srw_tac[][] >> first_x_assum MATCH_MP_TAC >> full_simp_tac(srw_ss())[arithmeticTheory.MAX_DEF] >> srw_tac[][] >> full_simp_tac(srw_ss())[] >> - simp[arithmeticTheory.EXP]) + simp[arithmeticTheory.EXP] +QED (* only used below in proof of theorem that is in turn used just twice *) -Theorem LOG2_TIMES2 - `0 < n ⇒ (LOG2 (2 * n) = SUC (LOG2 n))` - (srw_tac[][LOG2_def] >> +Theorem LOG2_TIMES2: + 0 < n ⇒ (LOG2 (2 * n) = SUC (LOG2 n)) +Proof + srw_tac[][LOG2_def] >> qspecl_then[`1`,`2`,`n`]mp_tac logrootTheory.LOG_EXP >> - simp[arithmeticTheory.ADD1]) + simp[arithmeticTheory.ADD1] +QED (* only used below in proof of theorem that is in turn used just twice *) -Theorem LOG2_TIMES2_1 - `∀n. 0 < n ⇒ (LOG2 (2 * n + 1) = LOG2 (2 * n))` - (srw_tac[][LOG2_def] >> +Theorem LOG2_TIMES2_1: + ∀n. 0 < n ⇒ (LOG2 (2 * n + 1) = LOG2 (2 * n)) +Proof + srw_tac[][LOG2_def] >> MATCH_MP_TAC logrootTheory.LOG_UNIQUE >> simp[GSYM LOG2_def,LOG2_TIMES2] >> simp[arithmeticTheory.EXP] >> @@ -740,12 +873,14 @@ Theorem LOG2_TIMES2_1 qexists_tac`2 * 2 ** LOG2 n` >> simp[] ) >> simp[Abbr`Y`,arithmeticTheory.ODD_EXISTS] >> - metis_tac[]) + metis_tac[] +QED (* used only twice, both times in candle/set-theory *) -Theorem C_BIT_11 - `∀n m. (∀z. (z ≤ LOG2 (MAX n m)) ⇒ (BIT z n ⇔ BIT z m)) ⇔ (n = m)` - (simp_tac std_ss [Once EQ_IMP_THM] >> +Theorem C_BIT_11: + ∀n m. (∀z. (z ≤ LOG2 (MAX n m)) ⇒ (BIT z n ⇔ BIT z m)) ⇔ (n = m) +Proof + simp_tac std_ss [Once EQ_IMP_THM] >> ho_match_mp_tac binary_induct >> simp_tac std_ss [] >> conj_tac >- ( @@ -794,32 +929,40 @@ Theorem C_BIT_11 impl_tac >- ( full_simp_tac std_ss [arithmeticTheory.MAX_DEF] >> srw_tac[][] >> full_simp_tac arith_ss [LOG2_TIMES2_1,LOG2_TIMES2] ) >> - full_simp_tac arith_ss [BIT_TIMES2_1,BIT_TIMES2]) + full_simp_tac arith_ss [BIT_TIMES2_1,BIT_TIMES2] +QED -Theorem BIT_num_from_bin_list_leading - `∀l x. EVERY ($> 2) l ∧ LENGTH l ≤ x ⇒ ¬BIT x (num_from_bin_list l)` - (simp[numposrepTheory.num_from_bin_list_def] >> +Theorem BIT_num_from_bin_list_leading: + ∀l x. EVERY ($> 2) l ∧ LENGTH l ≤ x ⇒ ¬BIT x (num_from_bin_list l) +Proof + simp[numposrepTheory.num_from_bin_list_def] >> srw_tac[][] >> MATCH_MP_TAC NOT_BIT_GT_TWOEXP >> MATCH_MP_TAC arithmeticTheory.LESS_LESS_EQ_TRANS >> qexists_tac`2 ** LENGTH l` >> - simp[numposrepTheory.l2n_lt] ) + simp[numposrepTheory.l2n_lt] +QED -Theorem word_bit_test - `word_bit n w <=> ((w && n2w (2 ** n)) <> 0w:'a word)` - (srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] - [wordsTheory.word_index, DECIDE ``0n < d ==> (n <= d - 1) = (n < d)``]) +Theorem word_bit_test: + word_bit n w <=> ((w && n2w (2 ** n)) <> 0w:'a word) +Proof + srw_tac [wordsLib.WORD_BIT_EQ_ss, boolSimps.CONJ_ss] + [wordsTheory.word_index, DECIDE ``0n < d ==> (n <= d - 1) = (n < d)``] +QED val least_from_def = Define` least_from P n = if (∃x. P x ∧ n ≤ x) then $LEAST (λx. P x ∧ n ≤ x) else $LEAST P` -Theorem LEAST_thm - `$LEAST P = least_from P 0` - (srw_tac[][least_from_def,ETA_AX]) +Theorem LEAST_thm: + $LEAST P = least_from P 0 +Proof + srw_tac[][least_from_def,ETA_AX] +QED -Theorem least_from_thm - `least_from P n = if P n then n else least_from P (n+1)` - (srw_tac[][least_from_def] >> +Theorem least_from_thm: + least_from P n = if P n then n else least_from P (n+1) +Proof + srw_tac[][least_from_def] >> numLib.LEAST_ELIM_TAC >> srw_tac[][] >> full_simp_tac(srw_ss())[] >> res_tac >> TRY(metis_tac[arithmeticTheory.LESS_OR_EQ]) >- ( numLib.LEAST_ELIM_TAC >> srw_tac[][] >> full_simp_tac(srw_ss())[] >- metis_tac[] >> @@ -838,76 +981,99 @@ Theorem least_from_thm >- ( `¬(n ≤ x)` by metis_tac[] >> `x = n` by DECIDE_TAC >> - full_simp_tac(srw_ss())[] )) + full_simp_tac(srw_ss())[] ) +QED -Theorem FUNPOW_mono - `(∀x y. R1 x y ⇒ R2 x y) ∧ +Theorem FUNPOW_mono: + (∀x y. R1 x y ⇒ R2 x y) ∧ (∀R1 R2. (∀x y. R1 x y ⇒ R2 x y) ⇒ ∀x y. f R1 x y ⇒ f R2 x y) ⇒ - ∀n x y. FUNPOW f n R1 x y ⇒ FUNPOW f n R2 x y` - (strip_tac >> Induct >> simp[] >> + ∀n x y. FUNPOW f n R1 x y ⇒ FUNPOW f n R2 x y +Proof + strip_tac >> Induct >> simp[] >> simp[arithmeticTheory.FUNPOW_SUC] >> - first_x_assum match_mp_tac >> srw_tac[][]) + first_x_assum match_mp_tac >> srw_tac[][] +QED -Theorem FUNPOW_SUC_PLUS - `∀n a. FUNPOW SUC n = (+) n` (Induct \\ simp[FUNPOW,FUN_EQ_THM]); +Theorem FUNPOW_SUC_PLUS: + ∀n a. FUNPOW SUC n = (+) n +Proof +Induct \\ simp[FUNPOW,FUN_EQ_THM] +QED (* used just once; better as transitive R ==> transitive (OPTREL R) or that with transitive expanded out *) -Theorem OPTREL_trans - `∀R x y z. (∀a b c. (x = SOME a) ∧ (y = SOME b) ∧ (z = SOME c) ∧ R a b ∧ R b c ⇒ R a c) - ∧ OPTREL R x y ∧ OPTREL R y z ⇒ OPTREL R x z` - (srw_tac[][optionTheory.OPTREL_def]) +Theorem OPTREL_trans: + ∀R x y z. (∀a b c. (x = SOME a) ∧ (y = SOME b) ∧ (z = SOME c) ∧ R a b ∧ R b c ⇒ R a c) + ∧ OPTREL R x y ∧ OPTREL R y z ⇒ OPTREL R x z +Proof + srw_tac[][optionTheory.OPTREL_def] +QED val UPDATE_LIST_def = Define` UPDATE_LIST = FOLDL (combin$C (UNCURRY UPDATE))` val _ = Parse.add_infix("=++",500,Parse.LEFT) val _ = Parse.overload_on("=++",``UPDATE_LIST``) -Theorem UPDATE_LIST_THM - `∀f. (f =++ [] = f) ∧ ∀h t. (f =++ (h::t) = (FST h =+ SND h) f =++ t)` - (srw_tac[][UPDATE_LIST_def,pairTheory.UNCURRY]) +Theorem UPDATE_LIST_THM: + ∀f. (f =++ [] = f) ∧ ∀h t. (f =++ (h::t) = (FST h =+ SND h) f =++ t) +Proof + srw_tac[][UPDATE_LIST_def,pairTheory.UNCURRY] +QED -Theorem APPLY_UPDATE_LIST_ALOOKUP - `∀ls f x. (f =++ ls) x = case ALOOKUP (REVERSE ls) x of NONE => f x | SOME y => y` - (Induct >> simp[UPDATE_LIST_THM,ALOOKUP_APPEND] >> +Theorem APPLY_UPDATE_LIST_ALOOKUP: + ∀ls f x. (f =++ ls) x = case ALOOKUP (REVERSE ls) x of NONE => f x | SOME y => y +Proof + Induct >> simp[UPDATE_LIST_THM,ALOOKUP_APPEND] >> Cases >> simp[combinTheory.APPLY_UPDATE_THM] >> - srw_tac[][] >> BasicProvers.CASE_TAC) + srw_tac[][] >> BasicProvers.CASE_TAC +QED (* should be using indexedLists$findi, or INDEX_OF *) val find_index_def = Define` (find_index _ [] _ = NONE) ∧ (find_index y (x::xs) n = if x = y then SOME n else find_index y xs (n+1))` -Theorem INDEX_FIND_CONS_EQ_SOME - `(INDEX_FIND n f (x::xs) = SOME y) <=> +Theorem INDEX_FIND_CONS_EQ_SOME: + (INDEX_FIND n f (x::xs) = SOME y) <=> (f x /\ (y = (n,x))) \/ - (~f x /\ (INDEX_FIND (n+1) f xs = SOME y))` - (fs [INDEX_FIND_def] \\ rw [] \\ Cases_on `y` \\ fs [ADD1] \\ metis_tac []); + (~f x /\ (INDEX_FIND (n+1) f xs = SOME y)) +Proof + fs [INDEX_FIND_def] \\ rw [] \\ Cases_on `y` \\ fs [ADD1] \\ metis_tac [] +QED -Theorem find_index_INDEX_FIND - `∀y xs n. find_index y xs n = OPTION_MAP FST (INDEX_FIND n ($= y) xs)` - (Induct_on`xs` \\ rw[find_index_def] - \\ rw[Once INDEX_FIND_def,ADD1]); +Theorem find_index_INDEX_FIND: + ∀y xs n. find_index y xs n = OPTION_MAP FST (INDEX_FIND n ($= y) xs) +Proof + Induct_on`xs` \\ rw[find_index_def] + \\ rw[Once INDEX_FIND_def,ADD1] +QED -Theorem find_index_INDEX_OF - `find_index y xs 0 = INDEX_OF y xs` - (rw[INDEX_OF_def,find_index_INDEX_FIND]) +Theorem find_index_INDEX_OF: + find_index y xs 0 = INDEX_OF y xs +Proof + rw[INDEX_OF_def,find_index_INDEX_FIND] +QED -Theorem find_index_NOT_MEM - `∀ls x n. ¬MEM x ls = (find_index x ls n = NONE)` - (Induct >> srw_tac[][find_index_def]) +Theorem find_index_NOT_MEM: + ∀ls x n. ¬MEM x ls = (find_index x ls n = NONE) +Proof + Induct >> srw_tac[][find_index_def] +QED -Theorem find_index_MEM - `!ls x n. MEM x ls ==> ?i. (find_index x ls n = SOME (n+i)) /\ i < LENGTH ls /\ (EL i ls = x)` - (Induct >> srw_tac[][find_index_def] >- ( +Theorem find_index_MEM: + !ls x n. MEM x ls ==> ?i. (find_index x ls n = SOME (n+i)) /\ i < LENGTH ls /\ (EL i ls = x) +Proof + Induct >> srw_tac[][find_index_def] >- ( qexists_tac`0`>>srw_tac[][] ) >> first_x_assum(qspecl_then[`x`,`n+1`]mp_tac) >> - srw_tac[][]>>qexists_tac`SUC i`>>srw_tac[ARITH_ss][ADD1]) + srw_tac[][]>>qexists_tac`SUC i`>>srw_tac[ARITH_ss][ADD1] +QED -Theorem find_index_LEAST_EL - `∀ls x n. find_index x ls n = if MEM x ls then SOME (n + (LEAST n. x = EL n ls)) else NONE` - (Induct >- srw_tac[][find_index_def] >> +Theorem find_index_LEAST_EL: + ∀ls x n. find_index x ls n = if MEM x ls then SOME (n + (LEAST n. x = EL n ls)) else NONE +Proof + Induct >- srw_tac[][find_index_def] >> simp[find_index_def] >> rpt gen_tac >> Cases_on`h=x`>>full_simp_tac(srw_ss())[] >- ( @@ -928,17 +1094,22 @@ Theorem find_index_LEAST_EL Cases_on`n < m` >- ( `n + 1 < m + 1` by DECIDE_TAC >> res_tac >> full_simp_tac(srw_ss())[GSYM ADD1] ) >> - DECIDE_TAC ) + DECIDE_TAC +QED -Theorem find_index_LESS_LENGTH -`∀ls n m i. (find_index n ls m = SOME i) ⇒ (m <= i) ∧ (i < m + LENGTH ls)` -(Induct >> srw_tac[][find_index_def] >> +Theorem find_index_LESS_LENGTH: + ∀ls n m i. (find_index n ls m = SOME i) ⇒ (m <= i) ∧ (i < m + LENGTH ls) +Proof +Induct >> srw_tac[][find_index_def] >> res_tac >> -srw_tac[ARITH_ss][arithmeticTheory.ADD1]) +srw_tac[ARITH_ss][arithmeticTheory.ADD1] +QED -Theorem ALOOKUP_find_index_NONE - `(ALOOKUP env k = NONE) ⇒ (find_index k (MAP FST env) m = NONE)` - (srw_tac[][ALOOKUP_FAILS] >> srw_tac[][GSYM find_index_NOT_MEM,MEM_MAP,EXISTS_PROD]) +Theorem ALOOKUP_find_index_NONE: + (ALOOKUP env k = NONE) ⇒ (find_index k (MAP FST env) m = NONE) +Proof + srw_tac[][ALOOKUP_FAILS] >> srw_tac[][GSYM find_index_NOT_MEM,MEM_MAP,EXISTS_PROD] +QED val ALOOKUP_find_index_SOME = Q.prove( `∀env. (ALOOKUP env k = SOME v) ⇒ @@ -949,83 +1120,104 @@ val ALOOKUP_find_index_SOME = Q.prove( first_x_assum(qspec_then`m+1`mp_tac)>>srw_tac[][]>>srw_tac[][]>> qexists_tac`SUC i`>>simp[]) |> SPEC_ALL |> UNDISCH_ALL |> Q.SPEC`0` |> DISCH_ALL |> SIMP_RULE (srw_ss())[] -Theorem ALOOKUP_find_index_SOME - `(ALOOKUP env k = SOME v) ⇒ +Theorem ALOOKUP_find_index_SOME: + (ALOOKUP env k = SOME v) ⇒ ∃i. (find_index k (MAP FST env) 0 = SOME i) ∧ - i < LENGTH env ∧ (v = SND (EL i env))` - (srw_tac[][] >> imp_res_tac ALOOKUP_find_index_SOME >> - imp_res_tac find_index_LESS_LENGTH >> full_simp_tac(srw_ss())[EL_MAP]) + i < LENGTH env ∧ (v = SND (EL i env)) +Proof + srw_tac[][] >> imp_res_tac ALOOKUP_find_index_SOME >> + imp_res_tac find_index_LESS_LENGTH >> full_simp_tac(srw_ss())[EL_MAP] +QED -Theorem find_index_ALL_DISTINCT_EL -`∀ls n m. ALL_DISTINCT ls ∧ n < LENGTH ls ⇒ (find_index (EL n ls) ls m = SOME (m + n))` -(Induct >- srw_tac[][] >> +Theorem find_index_ALL_DISTINCT_EL: + ∀ls n m. ALL_DISTINCT ls ∧ n < LENGTH ls ⇒ (find_index (EL n ls) ls m = SOME (m + n)) +Proof +Induct >- srw_tac[][] >> gen_tac >> Cases >> srw_tac[ARITH_ss][find_index_def] >> -metis_tac[MEM_EL]) +metis_tac[MEM_EL] +QED val _ = export_rewrites["find_index_ALL_DISTINCT_EL"] -Theorem find_index_ALL_DISTINCT_EL_eq - `∀ls. ALL_DISTINCT ls ⇒ ∀x m i. (find_index x ls m = SOME i) = - ∃j. (i = m + j) ∧ j < LENGTH ls ∧ (x = EL j ls)` - (srw_tac[][EQ_IMP_THM] >- ( +Theorem find_index_ALL_DISTINCT_EL_eq: + ∀ls. ALL_DISTINCT ls ⇒ ∀x m i. (find_index x ls m = SOME i) = + ∃j. (i = m + j) ∧ j < LENGTH ls ∧ (x = EL j ls) +Proof + srw_tac[][EQ_IMP_THM] >- ( imp_res_tac find_index_LESS_LENGTH >> full_simp_tac(srw_ss())[find_index_LEAST_EL] >> srw_tac[ARITH_ss][] >> numLib.LEAST_ELIM_TAC >> conj_tac >- PROVE_TAC[MEM_EL] >> full_simp_tac(srw_ss())[EL_ALL_DISTINCT_EL_EQ] ) >> - PROVE_TAC[find_index_ALL_DISTINCT_EL]) + PROVE_TAC[find_index_ALL_DISTINCT_EL] +QED -Theorem find_index_APPEND_same - `!l1 n m i l2. (find_index n l1 m = SOME i) ==> (find_index n (l1 ++ l2) m = SOME i)` - (Induct >> srw_tac[][find_index_def]) +Theorem find_index_APPEND_same: + !l1 n m i l2. (find_index n l1 m = SOME i) ==> (find_index n (l1 ++ l2) m = SOME i) +Proof + Induct >> srw_tac[][find_index_def] +QED -Theorem find_index_ALL_DISTINCT_REVERSE - `∀ls x m j. ALL_DISTINCT ls ∧ (find_index x ls m = SOME j) ⇒ (find_index x (REVERSE ls) m = SOME (m + LENGTH ls + m - j - 1))` - (srw_tac[][] >> imp_res_tac find_index_ALL_DISTINCT_EL_eq >> +Theorem find_index_ALL_DISTINCT_REVERSE: + ∀ls x m j. ALL_DISTINCT ls ∧ (find_index x ls m = SOME j) ⇒ (find_index x (REVERSE ls) m = SOME (m + LENGTH ls + m - j - 1)) +Proof + srw_tac[][] >> imp_res_tac find_index_ALL_DISTINCT_EL_eq >> `ALL_DISTINCT (REVERSE ls)` by srw_tac[][ALL_DISTINCT_REVERSE] >> simp[find_index_ALL_DISTINCT_EL_eq] >> srw_tac[][] >> fsrw_tac[ARITH_ss][] >> srw_tac[][] >> qmatch_assum_rename_tac`z < LENGTH ls` >> qexists_tac`LENGTH ls - z - 1` >> - lrw[EL_REVERSE,PRE_SUB1]) + lrw[EL_REVERSE,PRE_SUB1] +QED -Theorem THE_find_index_suff - `∀P x ls n. (∀m. m < LENGTH ls ⇒ P (m + n)) ∧ MEM x ls ⇒ - P (THE (find_index x ls n))` - (srw_tac[][] >> +Theorem THE_find_index_suff: + ∀P x ls n. (∀m. m < LENGTH ls ⇒ P (m + n)) ∧ MEM x ls ⇒ + P (THE (find_index x ls n)) +Proof + srw_tac[][] >> imp_res_tac find_index_MEM >> pop_assum(qspec_then`n`mp_tac) >> - srw_tac[DNF_ss,ARITH_ss][]) + srw_tac[DNF_ss,ARITH_ss][] +QED -Theorem find_index_APPEND1 - `∀l1 n l2 m i. (find_index n (l1 ++ l2) m = SOME i) ∧ (i < m+LENGTH l1) ⇒ (find_index n l1 m = SOME i)` - (Induct >> simp[find_index_def] >- ( +Theorem find_index_APPEND1: + ∀l1 n l2 m i. (find_index n (l1 ++ l2) m = SOME i) ∧ (i < m+LENGTH l1) ⇒ (find_index n l1 m = SOME i) +Proof + Induct >> simp[find_index_def] >- ( spose_not_then strip_assume_tac >> imp_res_tac find_index_LESS_LENGTH >> DECIDE_TAC ) >> srw_tac[][] >> res_tac >> first_x_assum match_mp_tac >> - simp[]) + simp[] +QED -Theorem find_index_APPEND2 - `∀l1 n l2 m i. (find_index n (l1 ++ l2) m = SOME i) ∧ (m + LENGTH l1 ≤ i) ⇒ (find_index n l2 (m+LENGTH l1) = SOME i)` - (Induct >> simp[find_index_def] >> +Theorem find_index_APPEND2: + ∀l1 n l2 m i. (find_index n (l1 ++ l2) m = SOME i) ∧ (m + LENGTH l1 ≤ i) ⇒ (find_index n l2 (m+LENGTH l1) = SOME i) +Proof + Induct >> simp[find_index_def] >> srw_tac[][] >> fsrw_tac[ARITH_ss][] >> - res_tac >> fsrw_tac[ARITH_ss][ADD1]) + res_tac >> fsrw_tac[ARITH_ss][ADD1] +QED -Theorem find_index_is_MEM - `∀x ls n j. (find_index x ls n = SOME j) ⇒ MEM x ls` - (metis_tac[find_index_NOT_MEM,optionTheory.NOT_SOME_NONE]) +Theorem find_index_is_MEM: + ∀x ls n j. (find_index x ls n = SOME j) ⇒ MEM x ls +Proof + metis_tac[find_index_NOT_MEM,optionTheory.NOT_SOME_NONE] +QED -Theorem find_index_MAP_inj - `∀ls x n f. (∀y. MEM y ls ⇒ (f x = f y) ⇒ x = y) ⇒ (find_index (f x) (MAP f ls) n = find_index x ls n)` - (Induct >- simp[find_index_def] >> +Theorem find_index_MAP_inj: + ∀ls x n f. (∀y. MEM y ls ⇒ (f x = f y) ⇒ x = y) ⇒ (find_index (f x) (MAP f ls) n = find_index x ls n) +Proof + Induct >- simp[find_index_def] >> srw_tac[][] >> srw_tac[][find_index_def] >> - metis_tac[]) + metis_tac[] +QED -Theorem find_index_shift_0 - `∀ls x k. find_index x ls k = OPTION_MAP (λx. x + k) (find_index x ls 0)` - (Induct >> simp_tac(srw_ss())[find_index_def] >> +Theorem find_index_shift_0: + ∀ls x k. find_index x ls k = OPTION_MAP (λx. x + k) (find_index x ls 0) +Proof + Induct >> simp_tac(srw_ss())[find_index_def] >> rpt gen_tac >> Cases_on`h=x` >- ( BasicProvers.VAR_EQ_TAC >> @@ -1037,23 +1229,28 @@ Theorem find_index_shift_0 first_x_assum(qspecl_then[`x`,`1`]mp_tac) >> srw_tac[][] >> Cases_on`find_index x ls 0`>>srw_tac[][] >> - simp[]) + simp[] +QED -Theorem find_index_shift - `∀ls x k j. (find_index x ls k = SOME j) ⇒ j ≥ k ∧ ∀n. find_index x ls n = SOME (j-k+n)` - (Induct >> simp[find_index_def] >> srw_tac[][] >> res_tac >> fsrw_tac[ARITH_ss][]) +Theorem find_index_shift: + ∀ls x k j. (find_index x ls k = SOME j) ⇒ j ≥ k ∧ ∀n. find_index x ls n = SOME (j-k+n) +Proof + Induct >> simp[find_index_def] >> srw_tac[][] >> res_tac >> fsrw_tac[ARITH_ss][] +QED -Theorem find_index_APPEND - `∀l1 l2 x n. find_index x (l1 ++ l2) n = +Theorem find_index_APPEND: + ∀l1 l2 x n. find_index x (l1 ++ l2) n = case find_index x l1 n of | NONE => find_index x l2 (n + LENGTH l1) - | SOME x => SOME x` - (Induct >> simp[find_index_def] >> srw_tac[][] >> + | SOME x => SOME x +Proof + Induct >> simp[find_index_def] >> srw_tac[][] >> BasicProvers.CASE_TAC >> - simp[arithmeticTheory.ADD1]) + simp[arithmeticTheory.ADD1] +QED -Theorem find_index_in_FILTER_ZIP_EQ - `∀P l1 l2 x n1 n2 v1 j1 j2. +Theorem find_index_in_FILTER_ZIP_EQ: + ∀P l1 l2 x n1 n2 v1 j1 j2. (LENGTH l1 = LENGTH v1) ∧ (FILTER (P o FST) (ZIP(l1,v1)) = l2) ∧ (find_index x l1 n1 = SOME (n1+j1)) ∧ @@ -1061,8 +1258,9 @@ Theorem find_index_in_FILTER_ZIP_EQ P x ⇒ j1 < LENGTH l1 ∧ j2 < LENGTH l2 ∧ - (EL j1 (ZIP(l1,v1)) = EL j2 l2)` - (gen_tac >> Induct >> simp[find_index_def] >> + (EL j1 (ZIP(l1,v1)) = EL j2 l2) +Proof + gen_tac >> Induct >> simp[find_index_def] >> rpt gen_tac >> BasicProvers.CASE_TAC >- ( strip_tac >> full_simp_tac(srw_ss())[] >> @@ -1090,12 +1288,14 @@ Theorem find_index_in_FILTER_ZIP_EQ fsrw_tac[ARITH_ss][] >> Cases_on`j1=0`>>fsrw_tac[ARITH_ss][]>> disch_then(qspec_then`PRE j1`mp_tac) >> - simp[rich_listTheory.EL_CONS] ) + simp[rich_listTheory.EL_CONS] +QED -Theorem ALL_DISTINCT_PERM_ALOOKUP_ZIP - `∀l1 l2 l3. ALL_DISTINCT (MAP FST l1) ∧ PERM (MAP FST l1) l2 - ⇒ (set l1 = set (ZIP (l2, MAP (THE o ALOOKUP (l1 ++ l3)) l2)))` - (srw_tac[][EXTENSION,FORALL_PROD,EQ_IMP_THM] >- ( +Theorem ALL_DISTINCT_PERM_ALOOKUP_ZIP: + ∀l1 l2 l3. ALL_DISTINCT (MAP FST l1) ∧ PERM (MAP FST l1) l2 + ⇒ (set l1 = set (ZIP (l2, MAP (THE o ALOOKUP (l1 ++ l3)) l2))) +Proof + srw_tac[][EXTENSION,FORALL_PROD,EQ_IMP_THM] >- ( qmatch_assum_rename_tac`MEM (x,y) l1` >> imp_res_tac PERM_LENGTH >> full_simp_tac(srw_ss())[] >> simp[MEM_ZIP] >> @@ -1122,13 +1322,15 @@ Theorem ALL_DISTINCT_PERM_ALOOKUP_ZIP BasicProvers.CASE_TAC >- ( imp_res_tac ALOOKUP_FAILS >> metis_tac[MEM_EL] ) >> - metis_tac[MEM_EL,ALOOKUP_ALL_DISTINCT_MEM,optionTheory.THE_DEF]) + metis_tac[MEM_EL,ALOOKUP_ALL_DISTINCT_MEM,optionTheory.THE_DEF] +QED (* surely better with UNZIP rather than ZIP: i.e., UNZIP l1 = (a,b)... *) -Theorem PERM_ZIP - `∀l1 l2. PERM l1 l2 ⇒ ∀a b c d. (l1 = ZIP(a,b)) ∧ (l2 = ZIP(c,d)) ∧ (LENGTH a = LENGTH b) ∧ (LENGTH c = LENGTH d) ⇒ - PERM a c ∧ PERM b d` - (ho_match_mp_tac PERM_IND >> +Theorem PERM_ZIP: + ∀l1 l2. PERM l1 l2 ⇒ ∀a b c d. (l1 = ZIP(a,b)) ∧ (l2 = ZIP(c,d)) ∧ (LENGTH a = LENGTH b) ∧ (LENGTH c = LENGTH d) ⇒ + PERM a c ∧ PERM b d +Proof + ho_match_mp_tac PERM_IND >> conj_tac >- ( Cases >> simp[LENGTH_NIL_SYM] >> Cases >> simp[LENGTH_NIL_SYM] >> @@ -1164,30 +1366,36 @@ Theorem PERM_ZIP simp[] >> strip_tac >> last_x_assum(qspecl_then[`MAP FST ll`,`MAP SND ll`,`c`,`d`]mp_tac) >> simp[] >> strip_tac >> - metis_tac[PERM_TRANS]) + metis_tac[PERM_TRANS] +QED (* never used *) -Theorem RTC_invariant - `!R P. (!x y. P x /\ R x y ==> P y) ==> !x y. RTC R x y ==> P x ==> RTC (R RINTER (\x y. P x /\ P y)) x y` - (rpt gen_tac >> strip_tac >> +Theorem RTC_invariant: + !R P. (!x y. P x /\ R x y ==> P y) ==> !x y. RTC R x y ==> P x ==> RTC (R RINTER (\x y. P x /\ P y)) x y +Proof + rpt gen_tac >> strip_tac >> ho_match_mp_tac RTC_INDUCT >> srw_tac[][] >> res_tac >> full_simp_tac(srw_ss())[] >> simp[Once RTC_CASES1] >> disj2_tac >> HINT_EXISTS_TAC >> - simp[RINTER]) + simp[RINTER] +QED (* never used *) -Theorem RTC_RSUBSET - `!R1 R2. R1 RSUBSET R2 ==> (RTC R1) RSUBSET (RTC R2)` - (simp[RSUBSET] >> rpt gen_tac >> strip_tac >> +Theorem RTC_RSUBSET: + !R1 R2. R1 RSUBSET R2 ==> (RTC R1) RSUBSET (RTC R2) +Proof + simp[RSUBSET] >> rpt gen_tac >> strip_tac >> ho_match_mp_tac RTC_INDUCT >> simp[] >> - metis_tac[RTC_CASES1]) + metis_tac[RTC_CASES1] +QED -Theorem PERM_PART - `∀P L l1 l2 p q. ((p,q) = PART P L l1 l2) ⇒ PERM (L ++ (l1 ++ l2)) (p++q)` - (GEN_TAC THEN Induct >> +Theorem PERM_PART: + ∀P L l1 l2 p q. ((p,q) = PART P L l1 l2) ⇒ PERM (L ++ (l1 ++ l2)) (p++q) +Proof + GEN_TAC THEN Induct >> simp[PART_DEF] >> srw_tac[][] >- ( first_x_assum(qspecl_then[`h::l1`,`l2`,`p`,`q`]mp_tac) >> simp[] >> @@ -1202,59 +1410,75 @@ Theorem PERM_PART strip_tac >> REWRITE_TAC[Once CONS_APPEND] >> full_simp_tac std_ss [APPEND_ASSOC] >> - metis_tac[PERM_REWR,PERM_APPEND,APPEND_ASSOC] ) + metis_tac[PERM_REWR,PERM_APPEND,APPEND_ASSOC] +QED -Theorem PERM_PARTITION - `∀P L A B. ((A,B) = PARTITION P L) ==> PERM L (A ++ B)` - (METIS_TAC[PERM_PART,PARTITION_DEF,APPEND_NIL]) +Theorem PERM_PARTITION: + ∀P L A B. ((A,B) = PARTITION P L) ==> PERM L (A ++ B) +Proof + METIS_TAC[PERM_PART,PARTITION_DEF,APPEND_NIL] +QED -Theorem option_case_NONE_F - `(case X of NONE => F | SOME x => P x) = (∃x. (X = SOME x) ∧ P x)` - (Cases_on`X`>>srw_tac[][]) +Theorem option_case_NONE_F: + (case X of NONE => F | SOME x => P x) = (∃x. (X = SOME x) ∧ P x) +Proof + Cases_on`X`>>srw_tac[][] +QED -Theorem IS_PREFIX_THM - `!l2 l1. IS_PREFIX l1 l2 <=> (LENGTH l2 <= LENGTH l1) /\ !n. n < LENGTH l2 ==> (EL n l2 = EL n l1)` - (Induct THEN SRW_TAC[][IS_PREFIX] THEN +Theorem IS_PREFIX_THM: + !l2 l1. IS_PREFIX l1 l2 <=> (LENGTH l2 <= LENGTH l1) /\ !n. n < LENGTH l2 ==> (EL n l2 = EL n l1) +Proof + Induct THEN SRW_TAC[][IS_PREFIX] THEN Cases_on`l1`THEN SRW_TAC[][EQ_IMP_THM] THEN1 ( Cases_on`n`THEN SRW_TAC[][EL_CONS] THEN FULL_SIMP_TAC(srw_ss()++ARITH_ss)[] ) THEN1 ( POP_ASSUM(Q.SPEC_THEN`0`MP_TAC)THEN SRW_TAC[][] ) THEN1 ( - FIRST_X_ASSUM(Q.SPEC_THEN`SUC n`MP_TAC)THEN SRW_TAC[][] )) + FIRST_X_ASSUM(Q.SPEC_THEN`SUC n`MP_TAC)THEN SRW_TAC[][] ) +QED -Theorem EVERY2_RC_same - `EVERY2 (RC R) l l` - (srw_tac[DNF_ss][EVERY2_EVERY,EVERY_MEM,MEM_ZIP,relationTheory.RC_DEF]) +Theorem EVERY2_RC_same: + EVERY2 (RC R) l l +Proof + srw_tac[DNF_ss][EVERY2_EVERY,EVERY_MEM,MEM_ZIP,relationTheory.RC_DEF] +QED val _ = export_rewrites["EVERY2_RC_same"] (* used twice, and only in source_to_flatProof *) -Theorem FOLDL_invariant - `!P f ls a. (P a) /\ (!x y . MEM y ls /\ P x ==> P (f x y)) ==> P (FOLDL f a ls)` - (NTAC 2 GEN_TAC THEN - Induct THEN SRW_TAC[][]) +Theorem FOLDL_invariant: + !P f ls a. (P a) /\ (!x y . MEM y ls /\ P x ==> P (f x y)) ==> P (FOLDL f a ls) +Proof + NTAC 2 GEN_TAC THEN + Induct THEN SRW_TAC[][] +QED (* never used *) -Theorem FOLDL_invariant_rest - `∀P f ls a. P ls a ∧ (∀x n. n < LENGTH ls ∧ P (DROP n ls) x ⇒ P (DROP (SUC n) ls) (f x (EL n ls))) ⇒ P [] (FOLDL f a ls)` - (ntac 2 gen_tac >> +Theorem FOLDL_invariant_rest: + ∀P f ls a. P ls a ∧ (∀x n. n < LENGTH ls ∧ P (DROP n ls) x ⇒ P (DROP (SUC n) ls) (f x (EL n ls))) ⇒ P [] (FOLDL f a ls) +Proof + ntac 2 gen_tac >> Induct >> srw_tac[][] >> first_x_assum match_mp_tac >> conj_tac >- ( first_x_assum (qspecl_then[`a`,`0`] mp_tac) >> srw_tac[][] ) >> - srw_tac[][] >> first_x_assum (qspecl_then[`x`,`SUC n`] mp_tac) >> srw_tac[][]) + srw_tac[][] >> first_x_assum (qspecl_then[`x`,`SUC n`] mp_tac) >> srw_tac[][] +QED val between_def = Define` between x y z ⇔ x:num ≤ z ∧ z < y` -Theorem IN_between - `x ∈ between y z ⇔ y ≤ x ∧ x < z` - (rw[IN_DEF] \\ EVAL_TAC); +Theorem IN_between: + x ∈ between y z ⇔ y ≤ x ∧ x < z +Proof + rw[IN_DEF] \\ EVAL_TAC +QED (* never used *) -Theorem SUC_LEAST - `!x. P x ==> (SUC ($LEAST P) = LEAST x. 0 < x /\ P (PRE x))` - (GEN_TAC THEN STRIP_TAC THEN +Theorem SUC_LEAST: + !x. P x ==> (SUC ($LEAST P) = LEAST x. 0 < x /\ P (PRE x)) +Proof + GEN_TAC THEN STRIP_TAC THEN numLib.LEAST_ELIM_TAC THEN STRIP_TAC THEN1 PROVE_TAC[] THEN numLib.LEAST_ELIM_TAC THEN @@ -1272,82 +1496,102 @@ Theorem SUC_LEAST SPOSE_NOT_THEN STRIP_ASSUME_TAC THEN RES_TAC THEN FULL_SIMP_TAC(srw_ss())[] ) THEN - DECIDE_TAC) + DECIDE_TAC +QED (* never used *) val fmap_linv_def = Define` fmap_linv f1 f2 ⇔ (FDOM f2 = FRANGE f1) /\ (!x. x IN FDOM f1 ==> (FLOOKUP f2 (FAPPLY f1 x) = SOME x))` (* never used *) -Theorem fmap_linv_unique - `!f f1 f2. fmap_linv f f1 /\ fmap_linv f f2 ==> (f1 = f2)` - (SRW_TAC[][fmap_linv_def,GSYM fmap_EQ_THM] THEN +Theorem fmap_linv_unique: + !f f1 f2. fmap_linv f f1 /\ fmap_linv f f2 ==> (f1 = f2) +Proof + SRW_TAC[][fmap_linv_def,GSYM fmap_EQ_THM] THEN FULL_SIMP_TAC(srw_ss())[FRANGE_DEF,FLOOKUP_DEF] THEN - PROVE_TAC[]) + PROVE_TAC[] +QED (* never used *) -Theorem INJ_has_fmap_linv - `INJ (FAPPLY f) (FDOM f) (FRANGE f) ==> ?g. fmap_linv f g` - (STRIP_TAC THEN +Theorem INJ_has_fmap_linv: + INJ (FAPPLY f) (FDOM f) (FRANGE f) ==> ?g. fmap_linv f g +Proof + STRIP_TAC THEN Q.EXISTS_TAC `FUN_FMAP (\x. @y. FLOOKUP f y = SOME x) (FRANGE f)` THEN SRW_TAC[][fmap_linv_def,FLOOKUP_FUN_FMAP,FRANGE_DEF] THEN1 PROVE_TAC[] THEN SELECT_ELIM_TAC THEN - FULL_SIMP_TAC (srw_ss()) [INJ_DEF,FRANGE_DEF,FLOOKUP_DEF]) + FULL_SIMP_TAC (srw_ss()) [INJ_DEF,FRANGE_DEF,FLOOKUP_DEF] +QED (* never used *) -Theorem has_fmap_linv_inj - `(?g. fmap_linv f g) = (INJ (FAPPLY f) (FDOM f) (FRANGE f))` - (Tactical.REVERSE EQ_TAC THEN1 PROVE_TAC[INJ_has_fmap_linv] THEN +Theorem has_fmap_linv_inj: + (?g. fmap_linv f g) = (INJ (FAPPLY f) (FDOM f) (FRANGE f)) +Proof + Tactical.REVERSE EQ_TAC THEN1 PROVE_TAC[INJ_has_fmap_linv] THEN SRW_TAC[][fmap_linv_def,INJ_DEF,EQ_IMP_THM] THEN1 ( SRW_TAC[][FRANGE_DEF] THEN PROVE_TAC[] ) - THEN1 ( FULL_SIMP_TAC(srw_ss())[FLOOKUP_DEF] THEN PROVE_TAC[] )) + THEN1 ( FULL_SIMP_TAC(srw_ss())[FLOOKUP_DEF] THEN PROVE_TAC[] ) +QED (* never used *) -Theorem fmap_linv_FAPPLY - `fmap_linv f g /\ x IN FDOM f ==> (g ' (f ' x) = x)` - (SRW_TAC[][fmap_linv_def,FLOOKUP_DEF]) +Theorem fmap_linv_FAPPLY: + fmap_linv f g /\ x IN FDOM f ==> (g ' (f ' x) = x) +Proof + SRW_TAC[][fmap_linv_def,FLOOKUP_DEF] +QED (* TODO - candidate for move to HOL *) -Theorem plus_compose - `!n:num m. $+ n o $+ m = $+ (n + m)` - (SRW_TAC[ARITH_ss][FUN_EQ_THM]) +Theorem plus_compose: + !n:num m. $+ n o $+ m = $+ (n + m) +Proof + SRW_TAC[ARITH_ss][FUN_EQ_THM] +QED (* TODO: move elsewhere? export as rewrite? *) (* never used *) -Theorem IN_option_rwt -`(x ∈ case opt of NONE => {} | SOME y => Q y) ⇔ - (∃y. (opt = SOME y) ∧ x ∈ Q y)` -(Cases_on `opt` >> srw_tac[][EQ_IMP_THM]) +Theorem IN_option_rwt: + (x ∈ case opt of NONE => {} | SOME y => Q y) ⇔ + (∃y. (opt = SOME y) ∧ x ∈ Q y) +Proof +Cases_on `opt` >> srw_tac[][EQ_IMP_THM] +QED (* never used *) -Theorem IN_option_rwt2 -`x ∈ option_CASE opt {} s ⇔ ∃y. (opt = SOME y) ∧ x ∈ s y` -(Cases_on `opt` >> srw_tac[][]) +Theorem IN_option_rwt2: + x ∈ option_CASE opt {} s ⇔ ∃y. (opt = SOME y) ∧ x ∈ s y +Proof +Cases_on `opt` >> srw_tac[][] +QED (* Re-expressing folds *) (* only used in flat_elimProof *) -Theorem FOLDR_CONS_triple -`!f ls a. FOLDR (\(x,y,z) w. f x y z :: w) a ls = (MAP (\(x,y,z). f x y z) ls)++a` -(GEN_TAC THEN +Theorem FOLDR_CONS_triple: + !f ls a. FOLDR (\(x,y,z) w. f x y z :: w) a ls = (MAP (\(x,y,z). f x y z) ls)++a +Proof +GEN_TAC THEN Induct THEN1 SRW_TAC[][] THEN Q.X_GEN_TAC `p` THEN PairCases_on `p` THEN -SRW_TAC[][]) +SRW_TAC[][] +QED (* never used *) -Theorem FOLDR_CONS_5tup -`!f ls a. FOLDR (\(c,d,x,y,z) w. f c d x y z :: w) a ls = (MAP (\(c,d,x,y,z). f c d x y z) ls)++a` -(GEN_TAC THEN +Theorem FOLDR_CONS_5tup: + !f ls a. FOLDR (\(c,d,x,y,z) w. f c d x y z :: w) a ls = (MAP (\(c,d,x,y,z). f c d x y z) ls)++a +Proof +GEN_TAC THEN Induct THEN1 SRW_TAC[][] THEN Q.X_GEN_TAC `p` THEN PairCases_on `p` THEN -SRW_TAC[][]) +SRW_TAC[][] +QED (* never used *) -Theorem FOLDR_transitive_property -`!P ls f a. P [] a /\ (!n a. n < LENGTH ls /\ P (DROP (SUC n) ls) a ==> P (DROP n ls) (f (EL n ls) a)) ==> P ls (FOLDR f a ls)` -(GEN_TAC THEN Induct THEN SRW_TAC[][] THEN +Theorem FOLDR_transitive_property: + !P ls f a. P [] a /\ (!n a. n < LENGTH ls /\ P (DROP (SUC n) ls) a ==> P (DROP n ls) (f (EL n ls) a)) ==> P ls (FOLDR f a ls) +Proof +GEN_TAC THEN Induct THEN SRW_TAC[][] THEN `P ls (FOLDR f a ls)` by ( FIRST_X_ASSUM MATCH_MP_TAC THEN SRW_TAC[][] THEN @@ -1355,42 +1599,56 @@ Theorem FOLDR_transitive_property FIRST_X_ASSUM (Q.SPECL_THEN [`SUC n`,`b`] MP_TAC) THEN SRW_TAC[][] ) THEN FIRST_X_ASSUM (Q.SPEC_THEN `0` MP_TAC) THEN -SRW_TAC[][]) +SRW_TAC[][] +QED (* Re-expressing curried lambdas *) -Theorem FST_triple -`(λ(n,ns,b). n) = FST` -(srw_tac[][FUN_EQ_THM,pairTheory.UNCURRY]) +Theorem FST_triple: + (λ(n,ns,b). n) = FST +Proof +srw_tac[][FUN_EQ_THM,pairTheory.UNCURRY] +QED (* never used *) -Theorem FST_5tup -`(λ(n,ns,b,x,y). n) = FST` -(srw_tac[][FUN_EQ_THM,pairTheory.UNCURRY]) +Theorem FST_5tup: + (λ(n,ns,b,x,y). n) = FST +Proof +srw_tac[][FUN_EQ_THM,pairTheory.UNCURRY] +QED (* never used *) -Theorem SND_triple -`(λ(n,ns,b). f ns b) = UNCURRY f o SND` -(srw_tac[][FUN_EQ_THM,pairTheory.UNCURRY]) +Theorem SND_triple: + (λ(n,ns,b). f ns b) = UNCURRY f o SND +Proof +srw_tac[][FUN_EQ_THM,pairTheory.UNCURRY] +QED -Theorem FST_pair -`(λ(n,v). n) = FST` -(srw_tac[][FUN_EQ_THM,pairTheory.UNCURRY]) +Theorem FST_pair: + (λ(n,v). n) = FST +Proof +srw_tac[][FUN_EQ_THM,pairTheory.UNCURRY] +QED (* never used *) -Theorem SND_pair -`(λ(n,v). v) = SND` -(srw_tac[][FUN_EQ_THM,pairTheory.UNCURRY]) +Theorem SND_pair: + (λ(n,v). v) = SND +Proof +srw_tac[][FUN_EQ_THM,pairTheory.UNCURRY] +QED (* never used *) -Theorem SND_FST_pair -`(λ((n,m),c).m) = SND o FST` -(srw_tac[][FUN_EQ_THM,pairTheory.UNCURRY]) +Theorem SND_FST_pair: + (λ((n,m),c).m) = SND o FST +Proof +srw_tac[][FUN_EQ_THM,pairTheory.UNCURRY] +QED (* never used *) -Theorem MAP_ZIP_SND_triple -`(LENGTH l1 = LENGTH l2) ⇒ (MAP (λ(x,y,z). f y z) (ZIP(l1,l2)) = MAP (UNCURRY f) l2)` -(strip_tac >> ( +Theorem MAP_ZIP_SND_triple: + (LENGTH l1 = LENGTH l2) ⇒ (MAP (λ(x,y,z). f y z) (ZIP(l1,l2)) = MAP (UNCURRY f) l2) +Proof +strip_tac >> ( MAP_ZIP |> Q.GEN`g` |> Q.ISPEC `UNCURRY (f:'b->'c->'d)` @@ -1398,138 +1656,172 @@ MAP_ZIP |> UNDISCH_ALL |> CONJUNCTS |> Lib.el 4 -|> MATCH_ACCEPT_TAC)) +|> MATCH_ACCEPT_TAC) +QED (* Specialisations to identity function *) -Theorem I_PERMUTES[simp] - `I PERMUTES s` (rw[BIJ_DEF, INJ_DEF, SURJ_DEF]); +Theorem I_PERMUTES[simp]: + I PERMUTES s +Proof +rw[BIJ_DEF, INJ_DEF, SURJ_DEF] +QED (* never used *) -Theorem INJ_I -`∀s t. INJ I s t ⇔ s ⊆ t` -(SRW_TAC[][INJ_DEF,SUBSET_DEF]) +Theorem INJ_I: + ∀s t. INJ I s t ⇔ s ⊆ t +Proof +SRW_TAC[][INJ_DEF,SUBSET_DEF] +QED -Theorem MAP_EQ_ID -`!f ls. (MAP f ls = ls) = (!x. MEM x ls ==> (f x = x))` -(PROVE_TAC[MAP_EQ_f,MAP_ID,combinTheory.I_THM]) +Theorem MAP_EQ_ID: + !f ls. (MAP f ls = ls) = (!x. MEM x ls ==> (f x = x)) +Proof +PROVE_TAC[MAP_EQ_f,MAP_ID,combinTheory.I_THM] +QED (* Specialisations to FEMPTY *) -Theorem FUN_FMAP_FAPPLY_FEMPTY_FAPPLY -`FINITE s ==> (FUN_FMAP ($FAPPLY FEMPTY) s ' x = FEMPTY ' x)` -(Cases_on `x IN s` >> -srw_tac[][FUN_FMAP_DEF,NOT_FDOM_FAPPLY_FEMPTY]) +Theorem FUN_FMAP_FAPPLY_FEMPTY_FAPPLY: + FINITE s ==> (FUN_FMAP ($FAPPLY FEMPTY) s ' x = FEMPTY ' x) +Proof +Cases_on `x IN s` >> +srw_tac[][FUN_FMAP_DEF,NOT_FDOM_FAPPLY_FEMPTY] +QED val _ = export_rewrites["FUN_FMAP_FAPPLY_FEMPTY_FAPPLY"] (* FUPDATE_LIST stuff *) (* Misc. *) -Theorem LESS_1 -`x < 1 ⇔ (x = 0:num)` -(DECIDE_TAC) +Theorem LESS_1: + x < 1 ⇔ (x = 0:num) +Proof +DECIDE_TAC +QED val _ = export_rewrites["LESS_1"] (* --------- SO additions --------- *) -Theorem map_fst -`!l f. MAP FST (MAP (\(x,y). (x, f y)) l) = MAP FST l` -(Induct_on `l` >> +Theorem map_fst: + !l f. MAP FST (MAP (\(x,y). (x, f y)) l) = MAP FST l +Proof +Induct_on `l` >> srw_tac[][] >> PairCases_on `h` >> -full_simp_tac(srw_ss())[]); +full_simp_tac(srw_ss())[] +QED (* use INJ_MAP_EQ_IFF and INJ_DEF *) -Theorem map_some_eq -`!l1 l2. (MAP SOME l1 = MAP SOME l2) ⇔ (l1 = l2)` - (Induct_on `l1` >> +Theorem map_some_eq: + !l1 l2. (MAP SOME l1 = MAP SOME l2) ⇔ (l1 = l2) +Proof + Induct_on `l1` >> srw_tac[][] >> Cases_on `l2` >> - srw_tac[][]); + srw_tac[][] +QED (* never used *) -Theorem map_some_eq_append -`!l1 l2 l3. (MAP SOME l1 ++ MAP SOME l2 = MAP SOME l3) ⇔ (l1 ++ l2 = l3)` -(metis_tac [map_some_eq, MAP_APPEND]); +Theorem map_some_eq_append: + !l1 l2 l3. (MAP SOME l1 ++ MAP SOME l2 = MAP SOME l3) ⇔ (l1 ++ l2 = l3) +Proof +metis_tac [map_some_eq, MAP_APPEND] +QED val _ = augment_srw_ss [rewrites [map_some_eq,map_some_eq_append]]; (* list misc *) -Theorem LASTN_LEMMA - `(LASTN (LENGTH xs + 1 + 1) (x::y::xs) = x::y::xs) /\ - (LASTN (LENGTH xs + 1) (x::xs) = x::xs)` - (MP_TAC (Q.SPEC `x::y::xs` LASTN_LENGTH_ID) - \\ MP_TAC (Q.SPEC `x::xs` LASTN_LENGTH_ID) \\ full_simp_tac(srw_ss())[ADD1]); +Theorem LASTN_LEMMA: + (LASTN (LENGTH xs + 1 + 1) (x::y::xs) = x::y::xs) /\ + (LASTN (LENGTH xs + 1) (x::xs) = x::xs) +Proof + MP_TAC (Q.SPEC `x::y::xs` LASTN_LENGTH_ID) + \\ MP_TAC (Q.SPEC `x::xs` LASTN_LENGTH_ID) \\ full_simp_tac(srw_ss())[ADD1] +QED val LASTN_TL = save_thm("LASTN_TL", LASTN_CONS |> Q.SPECL[`n+1`,`xs`] |> C MP (DECIDE``n < LENGTH xs ⇒ n + 1 ≤ LENGTH xs`` |> UNDISCH) |> SPEC_ALL |> DISCH_ALL); -Theorem LASTN_LENGTH_LESS_EQ - `!xs n. LENGTH xs <= n ==> LASTN n xs = xs` - (full_simp_tac(srw_ss())[LASTN_def] \\ ONCE_REWRITE_TAC [GSYM LENGTH_REVERSE] - \\ SIMP_TAC std_ss [listTheory.TAKE_LENGTH_TOO_LONG] \\ full_simp_tac(srw_ss())[]); +Theorem LASTN_LENGTH_LESS_EQ: + !xs n. LENGTH xs <= n ==> LASTN n xs = xs +Proof + full_simp_tac(srw_ss())[LASTN_def] \\ ONCE_REWRITE_TAC [GSYM LENGTH_REVERSE] + \\ SIMP_TAC std_ss [listTheory.TAKE_LENGTH_TOO_LONG] \\ full_simp_tac(srw_ss())[] +QED -Theorem LASTN_ALT - `(LASTN n [] = []) /\ - (LASTN n (x::xs) = if LENGTH (x::xs) <= n then x::xs else LASTN n xs)` - (srw_tac[][] THEN1 (full_simp_tac(srw_ss())[LASTN_def]) +Theorem LASTN_ALT: + (LASTN n [] = []) /\ + (LASTN n (x::xs) = if LENGTH (x::xs) <= n then x::xs else LASTN n xs) +Proof + srw_tac[][] THEN1 (full_simp_tac(srw_ss())[LASTN_def]) THEN1 (match_mp_tac LASTN_LENGTH_LESS_EQ \\ full_simp_tac(srw_ss())[]) \\ full_simp_tac(srw_ss())[LASTN_def] \\ REPEAT STRIP_TAC \\ `n <= LENGTH (REVERSE xs)` by (full_simp_tac(srw_ss())[] \\ DECIDE_TAC) - \\ imp_res_tac TAKE_APPEND1 \\ full_simp_tac(srw_ss())[]); + \\ imp_res_tac TAKE_APPEND1 \\ full_simp_tac(srw_ss())[] +QED -Theorem LENGTH_LASTN_LESS - `!xs n. LENGTH (LASTN n xs) <= LENGTH xs` - (Induct \\ full_simp_tac(srw_ss())[LASTN_ALT] \\ srw_tac[][] +Theorem LENGTH_LASTN_LESS: + !xs n. LENGTH (LASTN n xs) <= LENGTH xs +Proof + Induct \\ full_simp_tac(srw_ss())[LASTN_ALT] \\ srw_tac[][] \\ first_x_assum (qspec_then `n` assume_tac) - \\ decide_tac); + \\ decide_tac +QED -Theorem MAP_EQ_MAP_IMP - `!xs ys f. +Theorem MAP_EQ_MAP_IMP: + !xs ys f. (!x y. MEM x xs /\ MEM y ys /\ (f x = f y) ==> (x = y)) ==> - (MAP f xs = MAP f ys) ==> (xs = ys)` - (Induct \\ Cases_on `ys` \\ FULL_SIMP_TAC (srw_ss()) [MAP] \\ METIS_TAC []); + (MAP f xs = MAP f ys) ==> (xs = ys) +Proof + Induct \\ Cases_on `ys` \\ FULL_SIMP_TAC (srw_ss()) [MAP] \\ METIS_TAC [] +QED (* NB: this is weaker: val MAP_EQ_MAP_IMP = save_thm("MAP_EQ_MAP_IMP", INJ_MAP_EQ |> SIMP_RULE (srw_ss()) [INJ_DEF]); *) -Theorem INJ_MAP_EQ_2 - `∀f l1 l2. +Theorem INJ_MAP_EQ_2: + ∀f l1 l2. (∀x y. x ∈ set l1 ∧ y ∈ set l2 ∧ f x = f y ⇒ x = y) ∧ MAP f l1 = MAP f l2 ⇒ - l1 = l2` - (gen_tac \\ Induct \\ rw[] - \\ Cases_on`l2` \\ pop_assum mp_tac \\ rw[]); - -Theorem LENGTH_EQ_FILTER_FILTER - `!xs. EVERY (\x. (P x \/ Q x) /\ ~(P x /\ Q x)) xs ==> - (LENGTH xs = LENGTH (FILTER P xs) + LENGTH (FILTER Q xs))` - (Induct \\ SIMP_TAC std_ss [LENGTH,FILTER,EVERY_DEF] \\ STRIP_TAC - \\ Cases_on `P h` \\ FULL_SIMP_TAC std_ss [LENGTH,ADD_CLAUSES]); - -Theorem LIST_REL_MAP_FILTER_NEQ - `∀P f1 f2 z1 z2 l1 l2. + l1 = l2 +Proof + gen_tac \\ Induct \\ rw[] + \\ Cases_on`l2` \\ pop_assum mp_tac \\ rw[] +QED + +Theorem LENGTH_EQ_FILTER_FILTER: + !xs. EVERY (\x. (P x \/ Q x) /\ ~(P x /\ Q x)) xs ==> + (LENGTH xs = LENGTH (FILTER P xs) + LENGTH (FILTER Q xs)) +Proof + Induct \\ SIMP_TAC std_ss [LENGTH,FILTER,EVERY_DEF] \\ STRIP_TAC + \\ Cases_on `P h` \\ FULL_SIMP_TAC std_ss [LENGTH,ADD_CLAUSES] +QED + +Theorem LIST_REL_MAP_FILTER_NEQ: + ∀P f1 f2 z1 z2 l1 l2. LIST_REL P (MAP f1 l1) (MAP f2 l2) ∧ (∀y1 y2. MEM (y1,y2) (ZIP(l1,l2)) ⇒ (SND y1 ≠ z1 ⇔ SND y2 ≠ z2) ∧ (P (f1 y1) (f2 y2))) ⇒ - LIST_REL P (MAP f1 (FILTER (λ(x,y). y ≠ z1) l1)) (MAP f2 (FILTER (λ(x,y). y ≠ z2) l2))` - (ntac 5 gen_tac >> + LIST_REL P (MAP f1 (FILTER (λ(x,y). y ≠ z1) l1)) (MAP f2 (FILTER (λ(x,y). y ≠ z2) l2)) +Proof + ntac 5 gen_tac >> Induct >> simp[] >> Cases >> simp[] >> Cases >> simp[] >> strip_tac >> Cases_on`h`>>fs[] >> rw[] >> - METIS_TAC[SND]) + METIS_TAC[SND] +QED (* move into HOL? *) @@ -1551,57 +1843,70 @@ val lookup_vars_def = Define ` | NONE => NONE else NONE)` -Theorem EVERY_lookup_vars - `∀vs env env'. EVERY P env ∧ lookup_vars vs env = SOME env' ⇒ EVERY P env'` - (Induct >> simp[lookup_vars_def, CaseEq"option", CaseEq"bool", PULL_EXISTS] >> - metis_tac[MEM_EL, EVERY_MEM]); +Theorem EVERY_lookup_vars: + ∀vs env env'. EVERY P env ∧ lookup_vars vs env = SOME env' ⇒ EVERY P env' +Proof + Induct >> simp[lookup_vars_def, CaseEq"option", CaseEq"bool", PULL_EXISTS] >> + metis_tac[MEM_EL, EVERY_MEM] +QED -Theorem EVERY_LAST - `!P l. l ≠ [] /\ EVERY P l ==> P (LAST l)` - (rw [LAST_EL, EVERY_EL, NOT_NIL_EQ_LENGTH_NOT_0]); +Theorem EVERY_LAST: + !P l. l ≠ [] /\ EVERY P l ==> P (LAST l) +Proof + rw [LAST_EL, EVERY_EL, NOT_NIL_EQ_LENGTH_NOT_0] +QED (* TODO - candidate for move to HOL *) -Theorem num_to_hex_string_length_1 - `∀x. x < 16 ⇒ (LENGTH (num_to_hex_string x) = 1)` - (REWRITE_TAC[GSYM rich_listTheory.MEM_COUNT_LIST] +Theorem num_to_hex_string_length_1: + ∀x. x < 16 ⇒ (LENGTH (num_to_hex_string x) = 1) +Proof + REWRITE_TAC[GSYM rich_listTheory.MEM_COUNT_LIST] \\ gen_tac \\ CONV_TAC(LAND_CONV EVAL) \\ strip_tac \\ var_eq_tac - \\ EVAL_TAC); + \\ EVAL_TAC +QED (* TODO - candidate for move to HOL *) -Theorem num_to_hex_string_length_2 - `∀x. 16 ≤ x ∧ x < 256 ⇒ (LENGTH (num_to_hex_string x) = 2)` - (REWRITE_TAC[GSYM rich_listTheory.MEM_COUNT_LIST] +Theorem num_to_hex_string_length_2: + ∀x. 16 ≤ x ∧ x < 256 ⇒ (LENGTH (num_to_hex_string x) = 2) +Proof + REWRITE_TAC[GSYM rich_listTheory.MEM_COUNT_LIST] \\ gen_tac \\ CONV_TAC(LAND_CONV (RAND_CONV EVAL)) \\ strip_tac \\ var_eq_tac \\ pop_assum mp_tac - \\ EVAL_TAC); + \\ EVAL_TAC +QED -Theorem num_from_hex_string_length_2 - `num_from_hex_string [d1;d2] < 256` - (rw[ASCIInumbersTheory.num_from_hex_string_def, +Theorem num_from_hex_string_length_2: + num_from_hex_string [d1;d2] < 256 +Proof + rw[ASCIInumbersTheory.num_from_hex_string_def, ASCIInumbersTheory.s2n_def, numposrepTheory.l2n_def] \\ qspecl_then[`UNHEX d1`,`16`]mp_tac MOD_LESS \\ impl_tac >- rw[] \\ qspecl_then[`UNHEX d2`,`16`]mp_tac MOD_LESS \\ impl_tac >- rw[] - \\ decide_tac); + \\ decide_tac +QED -Theorem num_from_hex_string_leading_0 - `∀ls. ls ≠ [] ⇒ (num_from_hex_string (#"0" :: ls) = num_from_hex_string ls)` - (simp[ASCIInumbersTheory.num_from_hex_string_def,ASCIInumbersTheory.s2n_def] +Theorem num_from_hex_string_leading_0: + ∀ls. ls ≠ [] ⇒ (num_from_hex_string (#"0" :: ls) = num_from_hex_string ls) +Proof + simp[ASCIInumbersTheory.num_from_hex_string_def,ASCIInumbersTheory.s2n_def] \\ ho_match_mp_tac SNOC_INDUCT \\ simp[] \\ simp[REVERSE_SNOC] \\ simp[numposrepTheory.l2n_def] \\ rw[] \\ Cases_on`ls` \\ fs[numposrepTheory.l2n_def] - \\ EVAL_TAC); + \\ EVAL_TAC +QED -Theorem num_from_hex_string_length_2_less_16 - `∀h1 h2. isHexDigit h1 ⇒ num_from_hex_string [h1;h2] < 16 ⇒ h1 = #"0"` - (rw[ASCIInumbersTheory.num_from_hex_string_def,ASCIInumbersTheory.s2n_def, +Theorem num_from_hex_string_length_2_less_16: + ∀h1 h2. isHexDigit h1 ⇒ num_from_hex_string [h1;h2] < 16 ⇒ h1 = #"0" +Proof + rw[ASCIInumbersTheory.num_from_hex_string_def,ASCIInumbersTheory.s2n_def, numposrepTheory.l2n_def] \\ Cases_on`UNHEX h1 MOD 16` \\ fs[] \\ fs[MOD_EQ_0_DIVISOR] @@ -1630,17 +1935,22 @@ Theorem num_from_hex_string_length_2_less_16 \\ rfs[SUB_RIGHT_EQ] \\ fs[ASCIInumbersTheory.UNHEX_def] \\ `n = 65` by decide_tac - \\ fs[ASCIInumbersTheory.UNHEX_def] ) + \\ fs[ASCIInumbersTheory.UNHEX_def] +QED -Theorem num_from_hex_string_num_to_hex_string[simp] - `num_from_hex_string (num_to_hex_string n) = n` - (ASCIInumbersTheory.num_hex_string +Theorem num_from_hex_string_num_to_hex_string[simp]: + num_from_hex_string (num_to_hex_string n) = n +Proof + ASCIInumbersTheory.num_hex_string |> SIMP_RULE std_ss [combinTheory.o_DEF,FUN_EQ_THM] - |> MATCH_ACCEPT_TAC) + |> MATCH_ACCEPT_TAC +QED -Theorem MAPi_ID[simp] - `MAPi (\x y. y) = I` - (fs [FUN_EQ_THM] \\ Induct \\ fs [o_DEF]); +Theorem MAPi_ID[simp]: + MAPi (\x y. y) = I +Proof + fs [FUN_EQ_THM] \\ Induct \\ fs [o_DEF] +QED (* TODO - candidate for move to HOL - though enumerate i0 l = MAPi (λx i. (i + i0, x)) l @@ -1650,48 +1960,63 @@ val enumerate_def = Define` (enumerate n (x::xs) = (n,x)::enumerate (n+1n) xs)` (* TODO - candidate for move to HOL *) -Theorem LENGTH_enumerate ` - ∀xs k. LENGTH (enumerate k xs) = LENGTH xs` - (Induct>>fs[enumerate_def]) +Theorem LENGTH_enumerate: + ∀xs k. LENGTH (enumerate k xs) = LENGTH xs +Proof + Induct>>fs[enumerate_def] +QED -Theorem EL_enumerate ` - ∀xs n k. +Theorem EL_enumerate: + ∀xs n k. n < LENGTH xs ⇒ - EL n (enumerate k xs) = (n+k,EL n xs)` - (Induct>>fs[enumerate_def]>>rw[]>> - Cases_on`n`>>fs[]) - -Theorem MAP_enumerate_MAPi ` - ∀f xs. - MAP f (enumerate 0 xs) = MAPi (λn e. f (n,e)) xs` - (rw[]>>match_mp_tac LIST_EQ>>fs[LENGTH_MAP,EL_MAP,EL_MAPi,LENGTH_enumerate,EL_enumerate]) - -Theorem MAPi_enumerate_MAP ` - ∀f xs. - MAPi f xs = MAP (λi,e. f i e) (enumerate 0 xs)` - (rw[]>>match_mp_tac LIST_EQ>>fs[LENGTH_MAP,EL_MAP,EL_MAPi,LENGTH_enumerate,EL_enumerate]) - -Theorem MEM_enumerate ` - ∀xs i e. + EL n (enumerate k xs) = (n+k,EL n xs) +Proof + Induct>>fs[enumerate_def]>>rw[]>> + Cases_on`n`>>fs[] +QED + +Theorem MAP_enumerate_MAPi: + ∀f xs. + MAP f (enumerate 0 xs) = MAPi (λn e. f (n,e)) xs +Proof + rw[]>>match_mp_tac LIST_EQ>>fs[LENGTH_MAP,EL_MAP,EL_MAPi,LENGTH_enumerate,EL_enumerate] +QED + +Theorem MAPi_enumerate_MAP: + ∀f xs. + MAPi f xs = MAP (λi,e. f i e) (enumerate 0 xs) +Proof + rw[]>>match_mp_tac LIST_EQ>>fs[LENGTH_MAP,EL_MAP,EL_MAPi,LENGTH_enumerate,EL_enumerate] +QED + +Theorem MEM_enumerate: + ∀xs i e. i < LENGTH xs ⇒ - (MEM (i,e) (enumerate 0 xs) ⇔ EL i xs = e)` - (fs[MEM_EL]>>rw[]>>eq_tac>>rw[LENGTH_enumerate]>> + (MEM (i,e) (enumerate 0 xs) ⇔ EL i xs = e) +Proof + fs[MEM_EL]>>rw[]>>eq_tac>>rw[LENGTH_enumerate]>> imp_res_tac EL_enumerate>>fs[]>> - qexists_tac`i`>>fs[]) + qexists_tac`i`>>fs[] +QED -Theorem MEM_enumerate_IMP ` - ∀xs i e. - MEM (i,e) (enumerate 0 xs) ⇒ MEM e xs` - (fs[MEM_EL,LENGTH_enumerate]>>rw[]>>imp_res_tac EL_enumerate>> - qexists_tac`n`>>fs[]) +Theorem MEM_enumerate_IMP: + ∀xs i e. + MEM (i,e) (enumerate 0 xs) ⇒ MEM e xs +Proof + fs[MEM_EL,LENGTH_enumerate]>>rw[]>>imp_res_tac EL_enumerate>> + qexists_tac`n`>>fs[] +QED -Theorem SUM_MAP_LENGTH_REPLICATE - `∀n ls. SUM (MAP LENGTH (REPLICATE n ls)) = n * LENGTH ls` - (Induct >> simp[REPLICATE,MULT]); +Theorem SUM_MAP_LENGTH_REPLICATE: + ∀n ls. SUM (MAP LENGTH (REPLICATE n ls)) = n * LENGTH ls +Proof + Induct >> simp[REPLICATE,MULT] +QED -Theorem SUM_MAP_COUNT_LIST - `!n k. SUM (MAP ($+ k) (COUNT_LIST n)) = (n * (2 * k + n - 1)) DIV 2` - (Induct \\ rw [COUNT_LIST_def] +Theorem SUM_MAP_COUNT_LIST: + !n k. SUM (MAP ($+ k) (COUNT_LIST n)) = (n * (2 * k + n - 1)) DIV 2 +Proof + Induct \\ rw [COUNT_LIST_def] \\ `!xs. MAP SUC xs = MAP ($+ 1) xs` by (Induct \\ rw []) \\ pop_assum (qspec_then `COUNT_LIST n` SUBST1_TAC) \\ pop_assum (qspec_then `k + 1` mp_tac) @@ -1699,92 +2024,120 @@ Theorem SUM_MAP_COUNT_LIST \\ `$+ (k + 1) = \x. k + (x + 1)` by fs [FUN_EQ_THM] \\ pop_assum SUBST1_TAC \\ rw [ADD1] \\ fs [LEFT_ADD_DISTRIB, RIGHT_ADD_DISTRIB] - \\ metis_tac [ADD_DIV_ADD_DIV, MULT_COMM, DECIDE ``0n < 2``]); + \\ metis_tac [ADD_DIV_ADD_DIV, MULT_COMM, DECIDE ``0n < 2``] +QED -Theorem SUM_REPLICATE - `∀n m. SUM (REPLICATE n m) = n * m` - (Induct \\ simp[REPLICATE,ADD1]); +Theorem SUM_REPLICATE: + ∀n m. SUM (REPLICATE n m) = n * m +Proof + Induct \\ simp[REPLICATE,ADD1] +QED -Theorem SUM_MAP_BOUND ` - (∀x. f x ≤ c) ⇒ (SUM (MAP f ls) ≤ LENGTH ls * c)` - (rw[]>> Induct_on`ls` >>rw[MULT_SUC]>> +Theorem SUM_MAP_BOUND: + (∀x. f x ≤ c) ⇒ (SUM (MAP f ls) ≤ LENGTH ls * c) +Proof + rw[]>> Induct_on`ls` >>rw[MULT_SUC]>> first_x_assum(qspec_then`h` assume_tac)>> - DECIDE_TAC); + DECIDE_TAC +QED -Theorem SUM_MOD ` - k > 0 ⇒ - (SUM ls MOD k = (SUM (MAP (λn. n MOD k) ls)) MOD k)` - (Induct_on`ls`>>rw[]>> - DEP_ONCE_REWRITE_TAC[GSYM MOD_PLUS]>>fs[]); +Theorem SUM_MOD: + k > 0 ⇒ + (SUM ls MOD k = (SUM (MAP (λn. n MOD k) ls)) MOD k) +Proof + Induct_on`ls`>>rw[]>> + DEP_ONCE_REWRITE_TAC[GSYM MOD_PLUS]>>fs[] +QED -Theorem MOD_SUB_LEMMA - `n MOD k = 0 /\ m MOD k = 0 /\ 0 < k ==> (n - m) MOD k = 0` - (Cases_on `m <= n` \\ fs [] +Theorem MOD_SUB_LEMMA: + n MOD k = 0 /\ m MOD k = 0 /\ 0 < k ==> (n - m) MOD k = 0 +Proof + Cases_on `m <= n` \\ fs [] \\ imp_res_tac LESS_EQ_EXISTS \\ rw [] \\ qpat_x_assum `(m + _) MOD k = 0` mp_tac \\ drule MOD_PLUS - \\ disch_then (fn th => once_rewrite_tac [GSYM th]) \\ fs []); + \\ disch_then (fn th => once_rewrite_tac [GSYM th]) \\ fs [] +QED -Theorem FLAT_REPLICATE_NIL - `!n. FLAT (REPLICATE n []) = []` - (Induct \\ fs [REPLICATE]); +Theorem FLAT_REPLICATE_NIL: + !n. FLAT (REPLICATE n []) = [] +Proof + Induct \\ fs [REPLICATE] +QED -Theorem MEM_REPLICATE_EQ - `!n x y. MEM x (REPLICATE n y) <=> x = y /\ n <> 0` - (Induct \\ fs [REPLICATE] \\ rw [] \\ eq_tac \\ rw []); +Theorem MEM_REPLICATE_EQ: + !n x y. MEM x (REPLICATE n y) <=> x = y /\ n <> 0 +Proof + Induct \\ fs [REPLICATE] \\ rw [] \\ eq_tac \\ rw [] +QED (* n.b. used in hol-reflection *) -Theorem FDOM_FLOOKUP - `x ∈ FDOM f ⇔ ∃v. FLOOKUP f x = SOME v` - (rw[FLOOKUP_DEF]) +Theorem FDOM_FLOOKUP: + x ∈ FDOM f ⇔ ∃v. FLOOKUP f x = SOME v +Proof + rw[FLOOKUP_DEF] +QED -Theorem FLAT_MAP_SING - `∀ls. FLAT (MAP (λx. [f x]) ls) = MAP f ls` - (Induct \\ simp[]); +Theorem FLAT_MAP_SING: + ∀ls. FLAT (MAP (λx. [f x]) ls) = MAP f ls +Proof + Induct \\ simp[] +QED -Theorem FLAT_MAP_NIL - `FLAT (MAP (λx. []) ls) = []` - (rw[FLAT_EQ_NIL,EVERY_MAP]); +Theorem FLAT_MAP_NIL: + FLAT (MAP (λx. []) ls) = [] +Proof + rw[FLAT_EQ_NIL,EVERY_MAP] +QED -Theorem UPDATE_LIST_NOT_MEM - `∀ls f x. ¬MEM x(MAP FST ls) ⇒ (f =++ ls) x = f x` - (Induct >> simp[UPDATE_LIST_THM,combinTheory.APPLY_UPDATE_THM]) +Theorem UPDATE_LIST_NOT_MEM: + ∀ls f x. ¬MEM x(MAP FST ls) ⇒ (f =++ ls) x = f x +Proof + Induct >> simp[UPDATE_LIST_THM,combinTheory.APPLY_UPDATE_THM] +QED -Theorem MAP_ZIP_UPDATE_LIST_ALL_DISTINCT_same - `∀ks vs f. LENGTH ks = LENGTH vs ∧ ALL_DISTINCT ks ⇒ (MAP (f =++ ZIP (ks,vs)) ks = vs)` - (Induct >> simp[LENGTH_NIL_SYM] >> +Theorem MAP_ZIP_UPDATE_LIST_ALL_DISTINCT_same: + ∀ks vs f. LENGTH ks = LENGTH vs ∧ ALL_DISTINCT ks ⇒ (MAP (f =++ ZIP (ks,vs)) ks = vs) +Proof + Induct >> simp[LENGTH_NIL_SYM] >> gen_tac >> Cases >> simp[UPDATE_LIST_THM] >> - simp[UPDATE_LIST_NOT_MEM,MAP_ZIP,combinTheory.APPLY_UPDATE_THM]) + simp[UPDATE_LIST_NOT_MEM,MAP_ZIP,combinTheory.APPLY_UPDATE_THM] +QED -Theorem flookup_update_list_none -`!x m l. +Theorem flookup_update_list_none: + !x m l. (FLOOKUP (m |++ l) x = NONE) = - ((FLOOKUP m x = NONE) ∧ (ALOOKUP l x = NONE))` - (rw [flookup_fupdate_list] >> + ((FLOOKUP m x = NONE) ∧ (ALOOKUP l x = NONE)) +Proof + rw [flookup_fupdate_list] >> every_case_tac >> fs [flookup_thm, ALOOKUP_FAILS] >> imp_res_tac ALOOKUP_MEM >> fs [] >> - metis_tac []); + metis_tac [] +QED -Theorem flookup_update_list_some -`!x m l y. +Theorem flookup_update_list_some: + !x m l y. (FLOOKUP (m |++ l) x = SOME y) = ((ALOOKUP (REVERSE l) x = SOME y) ∨ - ((ALOOKUP l x = NONE) ∧ (FLOOKUP m x = SOME y)))` - (rw [flookup_fupdate_list] >> + ((ALOOKUP l x = NONE) ∧ (FLOOKUP m x = SOME y))) +Proof + rw [flookup_fupdate_list] >> every_case_tac >> fs [flookup_thm, ALOOKUP_FAILS] >> imp_res_tac ALOOKUP_MEM >> fs [] >> - metis_tac []); + metis_tac [] +QED -Theorem MULT_LE_EXP - `∀a:num b. a ≠ 1 ⇒ a * b ≤ a ** b` - (Induct_on`b` >> simp[arithmeticTheory.MULT,arithmeticTheory.EXP] >> +Theorem MULT_LE_EXP: + ∀a:num b. a ≠ 1 ⇒ a * b ≤ a ** b +Proof + Induct_on`b` >> simp[arithmeticTheory.MULT,arithmeticTheory.EXP] >> Cases >> simp[] >> strip_tac >> first_x_assum(qspec_then`SUC n`mp_tac) >> simp[arithmeticTheory.MULT] >> @@ -1793,44 +2146,56 @@ Theorem MULT_LE_EXP `SUC b ≤ b + b * n` suffices_by simp[] >> simp[arithmeticTheory.ADD1] >> Cases_on`b * n` >> simp[] >> - fs[arithmeticTheory.MULT_EQ_0] >> fs[]) + fs[arithmeticTheory.MULT_EQ_0] >> fs[] +QED -Theorem domain_rrestrict_subset - `domain (rrestrict r s) ⊆ domain r ∩ s` - (rw[set_relationTheory.domain_def, +Theorem domain_rrestrict_subset: + domain (rrestrict r s) ⊆ domain r ∩ s +Proof + rw[set_relationTheory.domain_def, set_relationTheory.rrestrict_def, - SUBSET_DEF] >> metis_tac[]) + SUBSET_DEF] >> metis_tac[] +QED -Theorem range_rrestrict_subset - `range (rrestrict r s) ⊆ range r ∩ s` - (rw[set_relationTheory.range_def, +Theorem range_rrestrict_subset: + range (rrestrict r s) ⊆ range r ∩ s +Proof + rw[set_relationTheory.range_def, set_relationTheory.rrestrict_def, - SUBSET_DEF] >> metis_tac[]) + SUBSET_DEF] >> metis_tac[] +QED -Theorem PERM_MAP_BIJ - `∀f l1 l2. +Theorem PERM_MAP_BIJ: + ∀f l1 l2. BIJ f UNIV UNIV ⇒ - (PERM l1 l2 ⇔ PERM (MAP f l1) (MAP f l2))` - (rw[BIJ_IFF_INV] >> + (PERM l1 l2 ⇔ PERM (MAP f l1) (MAP f l2)) +Proof + rw[BIJ_IFF_INV] >> EQ_TAC >- rw[sortingTheory.PERM_MAP] >> `∀l. MEM l [l1;l2] ⇒ l = MAP g (MAP f l)` by ( rw[MAP_MAP_o,combinTheory.o_DEF] ) >> fs[] >> - metis_tac[sortingTheory.PERM_MAP]) + metis_tac[sortingTheory.PERM_MAP] +QED -Theorem bool_case_eq - `COND b t f = v ⇔ b /\ v = t ∨ ¬b ∧ v = f` - (srw_tac[][] >> metis_tac[]); +Theorem bool_case_eq: + COND b t f = v ⇔ b /\ v = t ∨ ¬b ∧ v = f +Proof + srw_tac[][] >> metis_tac[] +QED -Theorem pair_case_eq -`pair_CASE x f = v ⇔ ?x1 x2. x = (x1,x2) ∧ f x1 x2 = v` - (Cases_on `x` >> - srw_tac[][]); +Theorem pair_case_eq: + pair_CASE x f = v ⇔ ?x1 x2. x = (x1,x2) ∧ f x1 x2 = v +Proof + Cases_on `x` >> + srw_tac[][] +QED -Theorem lookup_fromList2 - `!l n. lookup n (fromList2 l) = - if EVEN n then lookup (n DIV 2) (fromList l) else NONE` - (recInduct SNOC_INDUCT \\ srw_tac[][] +Theorem lookup_fromList2: + !l n. lookup n (fromList2 l) = + if EVEN n then lookup (n DIV 2) (fromList l) else NONE +Proof + recInduct SNOC_INDUCT \\ srw_tac[][] THEN1 (EVAL_TAC \\ full_simp_tac(srw_ss())[lookup_def]) THEN1 (EVAL_TAC \\ full_simp_tac(srw_ss())[lookup_def]) \\ full_simp_tac(srw_ss())[fromList2_def,FOLDL_SNOC] @@ -1847,98 +2212,131 @@ Theorem lookup_fromList2 \\ TRY decide_tac \\ full_simp_tac(srw_ss())[DIV_LT_X] \\ `n = LENGTH l * 2 + 1` by decide_tac - \\ full_simp_tac(srw_ss())[MOD_TIMES]); + \\ full_simp_tac(srw_ss())[MOD_TIMES] +QED -Theorem domain_fromList2 - `∀q. domain(fromList2 q) = set(GENLIST (λx. 2n*x) (LENGTH q))` - (rw[EXTENSION,domain_lookup,lookup_fromList2,MEM_GENLIST, +Theorem domain_fromList2: + ∀q. domain(fromList2 q) = set(GENLIST (λx. 2n*x) (LENGTH q)) +Proof + rw[EXTENSION,domain_lookup,lookup_fromList2,MEM_GENLIST, lookup_fromList,EVEN_EXISTS] \\ rw[EQ_IMP_THM] \\ rename1`2 * m` - \\ qspecl_then[`2`,`m`]mp_tac MULT_DIV \\ simp[]); + \\ qspecl_then[`2`,`m`]mp_tac MULT_DIV \\ simp[] +QED -Theorem UNCURRY_eq_pair - `UNCURRY f v = z ⇔ ∃a b. v = (a,b) ∧ f a b = z` - (Cases_on`v`\\ rw[UNCURRY]); +Theorem UNCURRY_eq_pair: + UNCURRY f v = z ⇔ ∃a b. v = (a,b) ∧ f a b = z +Proof + Cases_on`v`\\ rw[UNCURRY] +QED -Theorem OLEAST_SOME_IMP - `$OLEAST P = SOME i ⇒ P i ∧ (∀n. n < i ⇒ ¬P n)` - (simp[whileTheory.OLEAST_def] - \\ metis_tac[whileTheory.LEAST_EXISTS_IMP]); +Theorem OLEAST_SOME_IMP: + $OLEAST P = SOME i ⇒ P i ∧ (∀n. n < i ⇒ ¬P n) +Proof + simp[whileTheory.OLEAST_def] + \\ metis_tac[whileTheory.LEAST_EXISTS_IMP] +QED -Theorem EXP2_EVEN - `∀n. EVEN (2 ** n) ⇔ n ≠ 0` - (Induct >> simp[EXP,EVEN_DOUBLE]); +Theorem EXP2_EVEN: + ∀n. EVEN (2 ** n) ⇔ n ≠ 0 +Proof + Induct >> simp[EXP,EVEN_DOUBLE] +QED -Theorem FST_UNZIP_MAPi - `∀l f. FST (UNZIP (MAPi f l)) = MAPi ((o) ((o) FST) f) l` - (Induct >> simp[]); +Theorem FST_UNZIP_MAPi: + ∀l f. FST (UNZIP (MAPi f l)) = MAPi ((o) ((o) FST) f) l +Proof + Induct >> simp[] +QED -Theorem SND_UNZIP_MAPi - `∀l f. SND (UNZIP (MAPi f l)) = MAPi ((o) ((o) SND) f) l` - (Induct >> simp[]); +Theorem SND_UNZIP_MAPi: + ∀l f. SND (UNZIP (MAPi f l)) = MAPi ((o) ((o) SND) f) l +Proof + Induct >> simp[] +QED -Theorem ALL_DISTINCT_FLAT - `∀l. ALL_DISTINCT (FLAT l) ⇔ +Theorem ALL_DISTINCT_FLAT: + ∀l. ALL_DISTINCT (FLAT l) ⇔ (∀l0. MEM l0 l ⇒ ALL_DISTINCT l0) ∧ (∀i j. i < j ∧ j < LENGTH l ⇒ - ∀e. MEM e (EL i l) ⇒ ¬MEM e (EL j l))` - (Induct >> dsimp[ALL_DISTINCT_APPEND, LT_SUC, MEM_FLAT] >> - metis_tac[MEM_EL]); + ∀e. MEM e (EL i l) ⇒ ¬MEM e (EL j l)) +Proof + Induct >> dsimp[ALL_DISTINCT_APPEND, LT_SUC, MEM_FLAT] >> + metis_tac[MEM_EL] +QED -Theorem ALL_DISTINCT_FLAT_EVERY - `∀ls. ALL_DISTINCT (FLAT ls) ⇒ EVERY ALL_DISTINCT ls` - (Induct \\ simp[ALL_DISTINCT_APPEND]); +Theorem ALL_DISTINCT_FLAT_EVERY: + ∀ls. ALL_DISTINCT (FLAT ls) ⇒ EVERY ALL_DISTINCT ls +Proof + Induct \\ simp[ALL_DISTINCT_APPEND] +QED -Theorem ALL_DISTINCT_APPEND_APPEND_IMP - `ALL_DISTINCT (xs ++ ys ++ zs) ==> - ALL_DISTINCT (xs ++ ys) /\ ALL_DISTINCT (xs ++ zs) /\ ALL_DISTINCT (ys ++ zs)` - (fs [ALL_DISTINCT_APPEND]); +Theorem ALL_DISTINCT_APPEND_APPEND_IMP: + ALL_DISTINCT (xs ++ ys ++ zs) ==> + ALL_DISTINCT (xs ++ ys) /\ ALL_DISTINCT (xs ++ zs) /\ ALL_DISTINCT (ys ++ zs) +Proof + fs [ALL_DISTINCT_APPEND] +QED -Theorem GSPEC_o - `GSPEC f o g = { x | ∃y. (g x, T) = f y }` - (simp[FUN_EQ_THM, GSPECIFICATION]); +Theorem GSPEC_o: + GSPEC f o g = { x | ∃y. (g x, T) = f y } +Proof + simp[FUN_EQ_THM, GSPECIFICATION] +QED (* TODO - candidate for move to HOL *) -Theorem o_PAIR_MAP - `FST o (f ## g) = f o FST ∧ - SND o (f ## g) = g o SND` - (simp[FUN_EQ_THM]); - -Theorem any_el_ALT - `∀l n d. any_el n l d = if n < LENGTH l then EL n l else d` - (Induct_on `l` >> simp[any_el_def] >> Cases_on `n` >> simp[] >> rw[] >> - fs[] \\ rfs[]); - -Theorem MOD_MINUS - `0 < p /\ 0 < k ==> (p * k - n MOD (p * k)) MOD k = (k - n MOD k) MOD k` - (strip_tac +Theorem o_PAIR_MAP: + FST o (f ## g) = f o FST ∧ + SND o (f ## g) = g o SND +Proof + simp[FUN_EQ_THM] +QED + +Theorem any_el_ALT: + ∀l n d. any_el n l d = if n < LENGTH l then EL n l else d +Proof + Induct_on `l` >> simp[any_el_def] >> Cases_on `n` >> simp[] >> rw[] >> + fs[] \\ rfs[] +QED + +Theorem MOD_MINUS: + 0 < p /\ 0 < k ==> (p * k - n MOD (p * k)) MOD k = (k - n MOD k) MOD k +Proof + strip_tac \\ mp_tac (wordsTheory.MOD_COMPLEMENT |> Q.SPECL [`k`,`p`,`n MOD (p * k)`]) \\ impl_tac THEN1 (fs [MOD_LESS,ZERO_LESS_MULT]) - \\ fs [MOD_MULT_MOD]); + \\ fs [MOD_MULT_MOD] +QED val option_fold_def = Define ` (option_fold f x NONE = x) ∧ (option_fold f x (SOME y) = f y x)`; -Theorem SPLITP_CONS_IMP - `∀ls l' r. (SPLITP P ls = (l', r)) /\ (r <> []) ==> (EXISTS P ls)` - (rw[] \\ imp_res_tac SPLITP_IMP \\ imp_res_tac SPLITP_JOIN - \\ Cases_on `r` \\ rfs[NULL_EQ, EXISTS_DEF, HD]); +Theorem SPLITP_CONS_IMP: + ∀ls l' r. (SPLITP P ls = (l', r)) /\ (r <> []) ==> (EXISTS P ls) +Proof + rw[] \\ imp_res_tac SPLITP_IMP \\ imp_res_tac SPLITP_JOIN + \\ Cases_on `r` \\ rfs[NULL_EQ, EXISTS_DEF, HD] +QED -Theorem LAST_CONS_alt - `P x ==> ((ls <> [] ==> P (LAST ls)) <=> (P (LAST (CONS x ls))))` - (Cases_on`ls` \\ rw[]); +Theorem LAST_CONS_alt: + P x ==> ((ls <> [] ==> P (LAST ls)) <=> (P (LAST (CONS x ls)))) +Proof + Cases_on`ls` \\ rw[] +QED -Theorem EVERY_TOKENS - `∀P ls. EVERY (EVERY ($~ o P)) (TOKENS P ls)` - (recInduct TOKENS_ind +Theorem EVERY_TOKENS: + ∀P ls. EVERY (EVERY ($~ o P)) (TOKENS P ls) +Proof + recInduct TOKENS_ind \\ rw[TOKENS_def] \\ pairarg_tac \\ fs[NULL_EQ] \\ IF_CASES_TAC \\ fs[] - \\ imp_res_tac SPLITP_IMP); + \\ imp_res_tac SPLITP_IMP +QED Theorem TOKENS_START: !l a. TOKENS (\x. x = a) (a::l) = TOKENS (\x. x = a) l @@ -1953,34 +2351,39 @@ Proof >-(pairarg_tac \\ fs[NULL_EQ] \\ rw[] \\ fs[SPLITP]) QED -Theorem TOKENS_END - `!l a. - TOKENS (\x. x = a) (l ++ [a]) = TOKENS (\x. x = a) l` - (rw[] +Theorem TOKENS_END: + !l a. + TOKENS (\x. x = a) (l ++ [a]) = TOKENS (\x. x = a) l +Proof + rw[] \\ `TOKENS (\x. x = a) (l ++ [a]) = TOKENS (\x. x = a) l ++ TOKENS (\x. x = a) ""` by fs[TOKENS_APPEND] \\ fs[TOKENS_def] \\ rw[] -); +QED -Theorem TOKENS_LENGTH_END - `!l a. - LENGTH (TOKENS (\x. x = a) (l ++ [a])) = LENGTH (TOKENS (\x. x = a) l)` - (rw[] \\ AP_TERM_TAC \\ rw[TOKENS_END] -); +Theorem TOKENS_LENGTH_END: + !l a. + LENGTH (TOKENS (\x. x = a) (l ++ [a])) = LENGTH (TOKENS (\x. x = a) l) +Proof + rw[] \\ AP_TERM_TAC \\ rw[TOKENS_END] +QED -Theorem TOKENS_LENGTH_START - `!l a. - LENGTH (TOKENS (\x. x = a) (a::l)) = LENGTH (TOKENS (\x. x= a) l)` - (rw[] \\ AP_TERM_TAC \\ rw[TOKENS_START] -); +Theorem TOKENS_LENGTH_START: + !l a. + LENGTH (TOKENS (\x. x = a) (a::l)) = LENGTH (TOKENS (\x. x= a) l) +Proof + rw[] \\ AP_TERM_TAC \\ rw[TOKENS_START] +QED -Theorem DROP_EMPTY - `!ls n. (DROP n ls = []) ==> (n >= LENGTH ls)` - (Induct \\ rw[DROP] +Theorem DROP_EMPTY: + !ls n. (DROP n ls = []) ==> (n >= LENGTH ls) +Proof + Induct \\ rw[DROP] \\ Cases_on `n > LENGTH ls` \\ fs[] \\ `n < LENGTH (h::ls)` by fs[] - \\ fs[DROP_EL_CONS]); + \\ fs[DROP_EL_CONS] +QED val FRONT_APPEND' = Q.prove( `!l h a b t. l = h ++ [a; b] ++ t ==> @@ -2022,144 +2425,188 @@ val CONCAT_WITH_AUX_ind = theorem"CONCAT_WITH_aux_ind"; val CONCAT_WITH_def = Define` CONCAT_WITH s l = CONCAT_WITH_aux s l [] ` -Theorem OPT_MMAP_MAP_o - `!ls. OPT_MMAP f (MAP g ls) = OPT_MMAP (f o g) ls` - (Induct \\ rw[OPT_MMAP_def]); +Theorem OPT_MMAP_MAP_o: + !ls. OPT_MMAP f (MAP g ls) = OPT_MMAP (f o g) ls +Proof + Induct \\ rw[OPT_MMAP_def] +QED -Theorem OPT_MMAP_SOME[simp] - `OPT_MMAP SOME ls = SOME ls` - (Induct_on`ls` \\ rw[OPT_MMAP_def]); +Theorem OPT_MMAP_SOME[simp]: + OPT_MMAP SOME ls = SOME ls +Proof + Induct_on`ls` \\ rw[OPT_MMAP_def] +QED -Theorem OPT_MMAP_CONG[defncong] - `!l1 l2 f f'. +Theorem OPT_MMAP_CONG[defncong]: + !l1 l2 f f'. (l1 = l2) /\ (!x. MEM x l2 ==> (f x = f' x)) - ==> (OPT_MMAP f l1 = OPT_MMAP f' l2)` - (Induct \\ rw[OPT_MMAP_def] \\ rw[OPT_MMAP_def] \\ - Cases_on`f' h` \\ rw[] \\ fs[] \\ metis_tac[]); - -Theorem IMP_OPT_MMAP_EQ - `!l1 l2. (MAP f1 l1 = MAP f2 l2) ==> (OPT_MMAP f1 l1 = OPT_MMAP f2 l2)` - (Induct \\ rw[OPT_MMAP_def] \\ Cases_on`l2` \\ fs[OPT_MMAP_def] \\ - Cases_on`f2 h'` \\ fs[] \\ metis_tac[]); - -Theorem DISJOINT_set_simp - `DISJOINT (set []) s /\ - (DISJOINT (set (x::xs)) s <=> ~(x IN s) /\ DISJOINT (set xs) s)` - (fs [DISJOINT_DEF,EXTENSION] \\ metis_tac []); - -Theorem DISJOINT_INTER - `DISJOINT b c ⇒ DISJOINT (a ∩ b) (a ∩ c)` - (rw[IN_DISJOINT] \\ metis_tac[]); - -Theorem ALOOKUP_EXISTS_IFF - `(∃v. ALOOKUP alist k = SOME v) ⇔ (∃v. MEM (k,v) alist)` - (Induct_on `alist` >> simp[FORALL_PROD] >> rw[] >> metis_tac[]); - -Theorem LUPDATE_commutes - `∀m n e1 e2 l. + ==> (OPT_MMAP f l1 = OPT_MMAP f' l2) +Proof + Induct \\ rw[OPT_MMAP_def] \\ rw[OPT_MMAP_def] \\ + Cases_on`f' h` \\ rw[] \\ fs[] \\ metis_tac[] +QED + +Theorem IMP_OPT_MMAP_EQ: + !l1 l2. (MAP f1 l1 = MAP f2 l2) ==> (OPT_MMAP f1 l1 = OPT_MMAP f2 l2) +Proof + Induct \\ rw[OPT_MMAP_def] \\ Cases_on`l2` \\ fs[OPT_MMAP_def] \\ + Cases_on`f2 h'` \\ fs[] \\ metis_tac[] +QED + +Theorem DISJOINT_set_simp: + DISJOINT (set []) s /\ + (DISJOINT (set (x::xs)) s <=> ~(x IN s) /\ DISJOINT (set xs) s) +Proof + fs [DISJOINT_DEF,EXTENSION] \\ metis_tac [] +QED + +Theorem DISJOINT_INTER: + DISJOINT b c ⇒ DISJOINT (a ∩ b) (a ∩ c) +Proof + rw[IN_DISJOINT] \\ metis_tac[] +QED + +Theorem ALOOKUP_EXISTS_IFF: + (∃v. ALOOKUP alist k = SOME v) ⇔ (∃v. MEM (k,v) alist) +Proof + Induct_on `alist` >> simp[FORALL_PROD] >> rw[] >> metis_tac[] +QED + +Theorem LUPDATE_commutes: + ∀m n e1 e2 l. m ≠ n ⇒ - LUPDATE e1 m (LUPDATE e2 n l) = LUPDATE e2 n (LUPDATE e1 m l)` - (Induct_on `l` >> simp[LUPDATE_def] >> + LUPDATE e1 m (LUPDATE e2 n l) = LUPDATE e2 n (LUPDATE e1 m l) +Proof + Induct_on `l` >> simp[LUPDATE_def] >> Cases_on `m` >> simp[LUPDATE_def] >> rpt strip_tac >> rename[`LUPDATE _ nn (_ :: _)`] >> - Cases_on `nn` >> fs[LUPDATE_def]); + Cases_on `nn` >> fs[LUPDATE_def] +QED -Theorem LUPDATE_APPEND - `!xs n ys x. +Theorem LUPDATE_APPEND: + !xs n ys x. LUPDATE x n (xs ++ ys) = if n < LENGTH xs then LUPDATE x n xs ++ ys - else xs ++ LUPDATE x (n - LENGTH xs) ys` - (Induct \\ fs [] \\ Cases_on `n` \\ fs [LUPDATE_def] \\ rw [] \\ fs []); + else xs ++ LUPDATE x (n - LENGTH xs) ys +Proof + Induct \\ fs [] \\ Cases_on `n` \\ fs [LUPDATE_def] \\ rw [] \\ fs [] +QED -Theorem FILTER_EL_EQ - `∀l1 l2. LENGTH l1 = LENGTH l2 ∧ +Theorem FILTER_EL_EQ: + ∀l1 l2. LENGTH l1 = LENGTH l2 ∧ (∀n. n < LENGTH l1 ∧ (P (EL n l1) ∨ P (EL n l2)) ⇒ (EL n l1 = EL n l2)) ⇒ - FILTER P l1 = FILTER P l2` - (Induct \\ rw[] \\ Cases_on`l2` \\ fs[] + FILTER P l1 = FILTER P l2 +Proof + Induct \\ rw[] \\ Cases_on`l2` \\ fs[] \\ first_assum(qspec_then`0`mp_tac) \\ simp_tac (srw_ss())[] \\ simp[] \\ rw[] \\ fs[] \\ first_x_assum match_mp_tac \\ rw[] - \\ first_x_assum(qspec_then`SUC n`mp_tac) \\ rw[]); + \\ first_x_assum(qspec_then`SUC n`mp_tac) \\ rw[] +QED -Theorem FST_EL_AFUPDKEY - `∀n. n < LENGTH ls ⇒ FST (EL n (AFUPDKEY k f ls)) = FST (EL n ls)` - (Induct_on`ls` \\ simp[] +Theorem FST_EL_AFUPDKEY: + ∀n. n < LENGTH ls ⇒ FST (EL n (AFUPDKEY k f ls)) = FST (EL n ls) +Proof + Induct_on`ls` \\ simp[] \\ Cases \\ rw[AFUPDKEY_def] - \\ Cases_on`n` \\ fs[]); + \\ Cases_on`n` \\ fs[] +QED -Theorem EL_AFUPDKEY_unchanged - `∀n. n < LENGTH ls ∧ FST (EL n ls) ≠ k ⇒ EL n (AFUPDKEY k f ls) = EL n ls` - (Induct_on`ls` \\ simp[] +Theorem EL_AFUPDKEY_unchanged: + ∀n. n < LENGTH ls ∧ FST (EL n ls) ≠ k ⇒ EL n (AFUPDKEY k f ls) = EL n ls +Proof + Induct_on`ls` \\ simp[] \\ Cases \\ simp[AFUPDKEY_def] \\ Cases \\ simp[] - \\ IF_CASES_TAC \\ rveq \\ rw[]); + \\ IF_CASES_TAC \\ rveq \\ rw[] +QED -Theorem findi_APPEND - `∀l1 l2 x. +Theorem findi_APPEND: + ∀l1 l2 x. findi x (l1 ++ l2) = let n0 = findi x l1 in if n0 = LENGTH l1 then n0 + findi x l2 - else n0` - (Induct >> simp[findi_def] >> rw[] >> fs[]); + else n0 +Proof + Induct >> simp[findi_def] >> rw[] >> fs[] +QED -Theorem NOT_MEM_findi_IFF - `¬MEM e l ⇔ findi e l = LENGTH l` - (Induct_on `l` >> simp[findi_def, bool_case_eq, ADD1] >> metis_tac[]); +Theorem NOT_MEM_findi_IFF: + ¬MEM e l ⇔ findi e l = LENGTH l +Proof + Induct_on `l` >> simp[findi_def, bool_case_eq, ADD1] >> metis_tac[] +QED val NOT_MEM_findi = save_thm( (* more useful as conditional rewrite *) "NOT_MEM_findi", NOT_MEM_findi_IFF |> EQ_IMP_RULE |> #1); -Theorem ORD_eq_0 - `(ORD c = 0 ⇔ c = CHR 0) ∧ (0 = ORD c ⇔ c = CHR 0)` - (metis_tac[char_BIJ, ORD_CHR, EVAL ``0n < 256``]); +Theorem ORD_eq_0: + (ORD c = 0 ⇔ c = CHR 0) ∧ (0 = ORD c ⇔ c = CHR 0) +Proof + metis_tac[char_BIJ, ORD_CHR, EVAL ``0n < 256``] +QED -Theorem HD_LUPDATE - `0 < LENGTH l ⇒ HD (LUPDATE x p l) = if p = 0 then x else HD l` - (Cases_on `l` >> rw[LUPDATE_def] >> Cases_on `p` >> fs[LUPDATE_def]); +Theorem HD_LUPDATE: + 0 < LENGTH l ⇒ HD (LUPDATE x p l) = if p = 0 then x else HD l +Proof + Cases_on `l` >> rw[LUPDATE_def] >> Cases_on `p` >> fs[LUPDATE_def] +QED -Theorem DROP_LUPDATE - `!n x m l. n ≤ m ⇒ DROP n (LUPDATE x m l) = LUPDATE x (m - n) (DROP n l)` - (rw [LIST_EQ_REWRITE, EL_DROP, EL_LUPDATE] >> +Theorem DROP_LUPDATE: + !n x m l. n ≤ m ⇒ DROP n (LUPDATE x m l) = LUPDATE x (m - n) (DROP n l) +Proof + rw [LIST_EQ_REWRITE, EL_DROP, EL_LUPDATE] >> rw [] >> - fs []); + fs [] +QED val w2n_lt_256 = w2n_lt |> INST_TYPE [``:'a``|->``:8``] |> SIMP_RULE std_ss [EVAL ``dimword (:8)``] |> curry save_thm "w2n_lt_256" -Theorem CHR_w2n_n2w_ORD - `(CHR o w2n o (n2w:num->word8) o ORD) = I` - (rw[o_DEF, ORD_BOUND, CHR_ORD, FUN_EQ_THM] -); +Theorem CHR_w2n_n2w_ORD: + (CHR o w2n o (n2w:num->word8) o ORD) = I +Proof + rw[o_DEF, ORD_BOUND, CHR_ORD, FUN_EQ_THM] +QED -Theorem n2w_ORD_CHR_w2n - `((n2w:num->word8) o ORD o CHR o w2n) = I` - (rw[w2n_lt_256, o_DEF, ORD_BOUND, ORD_CHR, FUN_EQ_THM] -); +Theorem n2w_ORD_CHR_w2n: + ((n2w:num->word8) o ORD o CHR o w2n) = I +Proof + rw[w2n_lt_256, o_DEF, ORD_BOUND, ORD_CHR, FUN_EQ_THM] +QED -Theorem CHR_w2n_n2w_ORD_simp[simp] - `!c. CHR(w2n((n2w:num->word8)(ORD c))) = c` - (metis_tac[CHR_w2n_n2w_ORD,o_THM,I_THM]); +Theorem CHR_w2n_n2w_ORD_simp[simp]: + !c. CHR(w2n((n2w:num->word8)(ORD c))) = c +Proof + metis_tac[CHR_w2n_n2w_ORD,o_THM,I_THM] +QED -Theorem n2w_ORD_CHR_w2n_simp[simp] - `!w. n2w(ORD(CHR(w2n w))) = (w:word8)` - (metis_tac[n2w_ORD_CHR_w2n,o_THM,I_THM]); +Theorem n2w_ORD_CHR_w2n_simp[simp]: + !w. n2w(ORD(CHR(w2n w))) = (w:word8) +Proof + metis_tac[n2w_ORD_CHR_w2n,o_THM,I_THM] +QED -Theorem MAP_CHR_w2n_11 - `!ws1 ws2:word8 list. - MAP (CHR ∘ w2n) ws1 = MAP (CHR ∘ w2n) ws2 <=> ws1 = ws2` - (Induct \\ fs [] \\ rw [] \\ eq_tac \\ rw [] \\ fs [] - \\ Cases_on `ws2` \\ fs [] \\ metis_tac [CHR_11,w2n_lt_256,w2n_11]); +Theorem MAP_CHR_w2n_11: + !ws1 ws2:word8 list. + MAP (CHR ∘ w2n) ws1 = MAP (CHR ∘ w2n) ws2 <=> ws1 = ws2 +Proof + Induct \\ fs [] \\ rw [] \\ eq_tac \\ rw [] \\ fs [] + \\ Cases_on `ws2` \\ fs [] \\ metis_tac [CHR_11,w2n_lt_256,w2n_11] +QED -Theorem MAP_K_REPLICATE - `MAP (K x) ls = REPLICATE (LENGTH ls) x` - (Induct_on`ls` \\ rw[REPLICATE]); +Theorem MAP_K_REPLICATE: + MAP (K x) ls = REPLICATE (LENGTH ls) x +Proof + Induct_on`ls` \\ rw[REPLICATE] +QED val shift_left_def = Define` shift_left (a : 'a word) n = @@ -2170,12 +2617,14 @@ val shift_left_def = Define` else if n > 8 then shift_left (a << 8) (n - 8) else shift_left (a << 1) (n - 1)` -Theorem shift_left_rwt - `!a n. a << n = shift_left a n` - (completeInduct_on `n` +Theorem shift_left_rwt: + !a n. a << n = shift_left a n +Proof + completeInduct_on `n` \\ rw [Once shift_left_def] \\ qpat_x_assum `!n. P` (assume_tac o GSYM) - \\ fs []) + \\ fs [] +QED val shift_right_def = Define` shift_right (a : 'a word) n = @@ -2186,12 +2635,14 @@ val shift_right_def = Define` else if n > 8 then shift_right (a >>> 8) (n - 8) else shift_right (a >>> 1) (n - 1)` -Theorem shift_right_rwt - `!a n. a >>> n = shift_right a n` - (completeInduct_on `n` +Theorem shift_right_rwt: + !a n. a >>> n = shift_right a n +Proof + completeInduct_on `n` \\ rw [Once shift_right_def] \\ qpat_x_assum `!n. P` (assume_tac o GSYM) - \\ fs []) + \\ fs [] +QED val arith_shift_right_def = Define` arith_shift_right (a : 'a word) n = @@ -2203,12 +2654,14 @@ val arith_shift_right_def = Define` else if n > 8 then arith_shift_right (a >> 8) (n - 8) else arith_shift_right (a >> 1) (n - 1)` -Theorem arith_shift_right_rwt - `!a n. a >> n = arith_shift_right a n` - (completeInduct_on `n` +Theorem arith_shift_right_rwt: + !a n. a >> n = arith_shift_right a n +Proof + completeInduct_on `n` \\ rw [Once arith_shift_right_def] \\ qpat_x_assum `!n. P` (assume_tac o GSYM) - \\ fs [SIMP_RULE (srw_ss()) [] wordsTheory.ASR_UINT_MAX]) + \\ fs [SIMP_RULE (srw_ss()) [] wordsTheory.ASR_UINT_MAX] +QED val any_word64_ror_def = Define ` any_word64_ror (w:word64) (n:num) = @@ -2220,37 +2673,48 @@ val any_word64_ror_def = Define ` if 2 <= n then any_word64_ror (word_ror w 2) (n - 2) else if 1 <= n then word_ror w 1 else w` -Theorem word_ror_eq_any_word64_ror - `!a n. word_ror a n = any_word64_ror a n` - (completeInduct_on `n` +Theorem word_ror_eq_any_word64_ror: + !a n. word_ror a n = any_word64_ror a n +Proof + completeInduct_on `n` \\ rw [Once any_word64_ror_def] \\ qpat_x_assum `!n. P` (assume_tac o GSYM) \\ fs [SIMP_RULE (srw_ss()) [] wordsTheory.ASR_UINT_MAX] THEN1 fs [fcpTheory.CART_EQ,wordsTheory.word_ror_def,arithmeticTheory.SUB_MOD] - \\ `n = 1 \/ n = 0` by fs [] \\ fs []); + \\ `n = 1 \/ n = 0` by fs [] \\ fs [] +QED -Theorem TL_DROP_SUC - `∀x ls. x < LENGTH ls ⇒ TL (DROP x ls) = DROP (SUC x) ls` - (Induct \\ rw[] \\ Cases_on`ls` \\ fs[]); +Theorem TL_DROP_SUC: + ∀x ls. x < LENGTH ls ⇒ TL (DROP x ls) = DROP (SUC x) ls +Proof + Induct \\ rw[] \\ Cases_on`ls` \\ fs[] +QED -Theorem DROP_IMP_LESS_LENGTH - `!xs n y ys. DROP n xs = y::ys ==> n < LENGTH xs` - (Induct \\ full_simp_tac(srw_ss())[DROP_def] \\ srw_tac[][] - \\ res_tac \\ decide_tac); +Theorem DROP_IMP_LESS_LENGTH: + !xs n y ys. DROP n xs = y::ys ==> n < LENGTH xs +Proof + Induct \\ full_simp_tac(srw_ss())[DROP_def] \\ srw_tac[][] + \\ res_tac \\ decide_tac +QED -Theorem DROP_EQ_CONS_IMP_DROP_SUC - `!xs n y ys. DROP n xs = y::ys ==> DROP (SUC n) xs = ys` - (Induct \\ full_simp_tac(srw_ss())[DROP_def] \\ srw_tac[][] +Theorem DROP_EQ_CONS_IMP_DROP_SUC: + !xs n y ys. DROP n xs = y::ys ==> DROP (SUC n) xs = ys +Proof + Induct \\ full_simp_tac(srw_ss())[DROP_def] \\ srw_tac[][] \\ res_tac \\ full_simp_tac(srw_ss())[ADD1] - \\ `n - 1 + 1 = n` by decide_tac \\ full_simp_tac(srw_ss())[]); + \\ `n - 1 + 1 = n` by decide_tac \\ full_simp_tac(srw_ss())[] +QED -Theorem DROP_IMP_EL - `!xs n h t. DROP n xs = h::t ==> (EL n xs = h)` - (Induct \\ fs [DROP_def] \\ Cases_on `n` \\ fs []); +Theorem DROP_IMP_EL: + !xs n h t. DROP n xs = h::t ==> (EL n xs = h) +Proof + Induct \\ fs [DROP_def] \\ Cases_on `n` \\ fs [] +QED -Theorem LENGTH_FIELDS - `∀ls. LENGTH (FIELDS P ls) = LENGTH (FILTER P ls) + 1` - (gen_tac +Theorem LENGTH_FIELDS: + ∀ls. LENGTH (FIELDS P ls) = LENGTH (FILTER P ls) + 1 +Proof + gen_tac \\ completeInduct_on`LENGTH ls` \\ Cases \\ rw[FIELDS_def] @@ -2268,16 +2732,20 @@ Theorem LENGTH_FIELDS \\ disch_then(qspec_then`t`mp_tac) \\ Cases_on`t` \\ rw[FIELDS_def] \\ fs[SPLITP] \\ rfs[] - \\ rfs[NULL_EQ]); + \\ rfs[NULL_EQ] +QED -Theorem FIELDS_NEQ_NIL[simp] - `FIELDS P ls ≠ []` - (disch_then(assume_tac o Q.AP_TERM`LENGTH`) - \\ fs[LENGTH_FIELDS]); +Theorem FIELDS_NEQ_NIL[simp]: + FIELDS P ls ≠ [] +Proof + disch_then(assume_tac o Q.AP_TERM`LENGTH`) + \\ fs[LENGTH_FIELDS] +QED -Theorem CONCAT_FIELDS - `∀ls. CONCAT (FIELDS P ls) = FILTER ($~ o P) ls` - (gen_tac +Theorem CONCAT_FIELDS: + ∀ls. CONCAT (FIELDS P ls) = FILTER ($~ o P) ls +Proof + gen_tac \\ completeInduct_on`LENGTH ls` \\ Cases \\ simp[FIELDS_def] @@ -2295,15 +2763,17 @@ Theorem CONCAT_FIELDS \\ imp_res_tac SPLITP_JOIN \\ simp[FILTER_APPEND] \\ fs[GSYM FILTER_EQ_ID] - \\ Cases_on`r` \\ fs[] ); + \\ Cases_on`r` \\ fs[] +QED -Theorem FIELDS_next - `∀ls l1 l2. +Theorem FIELDS_next: + ∀ls l1 l2. FIELDS P ls = l1::l2 ⇒ LENGTH l1 < LENGTH ls ⇒ FIELDS P (DROP (SUC (LENGTH l1)) ls) = l2 ∧ - (∃c. l1 ++ [c] ≼ ls ∧ P c)` - (gen_tac + (∃c. l1 ++ [c] ≼ ls ∧ P c) +Proof + gen_tac \\ completeInduct_on`LENGTH ls` \\ ntac 4 strip_tac \\ Cases_on`ls` @@ -2326,13 +2796,15 @@ Theorem FIELDS_next Cases_on`t` \\ fs[] \\ rw[FIELDS_def,NULL_EQ] ) \\ first_x_assum(qspecl_then[`t`,`q`,`FIELDS P (TL r)`]mp_tac) - \\ simp[] ); + \\ simp[] +QED -Theorem FIELDS_full - `∀P ls l1 l2. +Theorem FIELDS_full: + ∀P ls l1 l2. FIELDS P ls = l1::l2 ∧ LENGTH ls ≤ LENGTH l1 ⇒ - l1 = ls ∧ l2 = []` - (ntac 2 gen_tac + l1 = ls ∧ l2 = [] +Proof + ntac 2 gen_tac \\ completeInduct_on`LENGTH ls` \\ ntac 4 strip_tac \\ Cases_on`ls` @@ -2357,14 +2829,16 @@ Theorem FIELDS_full \\ simp[] \\ strip_tac \\ fs[] \\ `LENGTH r = 0` by decide_tac - \\ fs[LENGTH_NIL]); + \\ fs[LENGTH_NIL] +QED -Theorem FLAT_MAP_TOKENS_FIELDS - `∀P' ls P. +Theorem FLAT_MAP_TOKENS_FIELDS: + ∀P' ls P. (∀x. P' x ⇒ P x) ⇒ FLAT (MAP (TOKENS P) (FIELDS P' ls)) = - TOKENS P ls` - (Induct_on`FIELDS P' ls` \\ rw[] \\ + TOKENS P ls +Proof + Induct_on`FIELDS P' ls` \\ rw[] \\ qpat_x_assum`_ = FIELDS _ _`(assume_tac o SYM) \\ imp_res_tac FIELDS_next \\ Cases_on`LENGTH ls ≤ LENGTH h` >- ( @@ -2372,11 +2846,14 @@ Theorem FLAT_MAP_TOKENS_FIELDS fs[] \\ rw[] \\ fs[IS_PREFIX_APPEND,DROP_APPEND,DROP_LENGTH_TOO_LONG,ADD1] \\ `h ++ [c] ++ l = h ++ (c::l)` by simp[] \\ pop_assum SUBST_ALL_TAC \\ - asm_simp_tac std_ss [TOKENS_APPEND]); + asm_simp_tac std_ss [TOKENS_APPEND] +QED -Theorem the_nil_eq_cons - `(the [] x = y::z) ⇔ x = SOME (y ::z)` - (Cases_on`x` \\ EVAL_TAC); +Theorem the_nil_eq_cons: + (the [] x = y::z) ⇔ x = SOME (y ::z) +Proof + Cases_on`x` \\ EVAL_TAC +QED val splitlines_def = Define` splitlines ls = @@ -2384,11 +2861,12 @@ val splitlines_def = Define` (* discard trailing newline *) if NULL (LAST lines) then FRONT lines else lines`; -Theorem splitlines_next - `splitlines ls = ln::lns ⇒ +Theorem splitlines_next: + splitlines ls = ln::lns ⇒ splitlines (DROP (SUC (LENGTH ln)) ls) = lns ∧ - ln ≼ ls ∧ (LENGTH ln < LENGTH ls ⇒ ln ++ "\n" ≼ ls)` - (simp[splitlines_def] + ln ≼ ls ∧ (LENGTH ln < LENGTH ls ⇒ ln ++ "\n" ≼ ls) +Proof + simp[splitlines_def] \\ Cases_on`FIELDS ($= #"\n") ls` \\ fs[] \\ Cases_on`LENGTH h < LENGTH ls` >- ( @@ -2408,36 +2886,42 @@ Theorem splitlines_next \\ imp_res_tac FIELDS_full \\ fs[] \\ IF_CASES_TAC \\ fs[] \\ strip_tac \\ rveq \\ fs[] - \\ simp[DROP_LENGTH_TOO_LONG,FIELDS_def]); + \\ simp[DROP_LENGTH_TOO_LONG,FIELDS_def] +QED val splitlines_nil = save_thm("splitlines_nil[simp]", EVAL``splitlines ""``); -Theorem splitlines_eq_nil[simp] - `splitlines ls = [] ⇔ (ls = [])` - (rw[EQ_IMP_THM] +Theorem splitlines_eq_nil[simp]: + splitlines ls = [] ⇔ (ls = []) +Proof + rw[EQ_IMP_THM] \\ fs[splitlines_def] \\ every_case_tac \\ fs[] \\ Cases_on`FIELDS ($= #"\n") ls` \\ fs[] \\ fs[LAST_DEF] \\ rfs[NULL_EQ] \\ Cases_on`LENGTH "" < LENGTH ls` >- ( imp_res_tac FIELDS_next \\ fs[] ) - \\ fs[LENGTH_NIL]); + \\ fs[LENGTH_NIL] +QED -Theorem splitlines_CONS_FST_SPLITP - `splitlines ls = ln::lns ⇒ FST (SPLITP ($= #"\n") ls) = ln` - (rw[splitlines_def] +Theorem splitlines_CONS_FST_SPLITP: + splitlines ls = ln::lns ⇒ FST (SPLITP ($= #"\n") ls) = ln +Proof + rw[splitlines_def] \\ Cases_on`ls` \\ fs[FIELDS_def] \\ TRY pairarg_tac \\ fs[] \\ rw[] \\ fs[] \\ every_case_tac \\ fs[] \\ rw[] \\ fs[NULL_EQ] \\ qmatch_assum_abbrev_tac`FRONT (x::y) = _` - \\ Cases_on`y` \\ fs[]); + \\ Cases_on`y` \\ fs[] +QED -Theorem n2l_DIV_MOD - `!b n k. 1 < b /\ 0 < k /\ b ** k <= n ==> +Theorem n2l_DIV_MOD: + !b n k. 1 < b /\ 0 < k /\ b ** k <= n ==> (n2l b (n MOD (b ** k)) ++ REPLICATE (k - LENGTH (n2l b (n MOD (b ** k)))) 0 ++ - n2l b (n DIV (b ** k)) = n2l b n)` - (ho_match_mp_tac numposrepTheory.n2l_ind + n2l b (n DIV (b ** k)) = n2l b n) +Proof + ho_match_mp_tac numposrepTheory.n2l_ind \\ rw[] \\ Cases_on`b < 2` \\ fs[] \\ Cases_on`n < b` \\ fs[] @@ -2479,67 +2963,88 @@ Theorem n2l_DIV_MOD \\ rewrite_tac[GSYM REPLICATE,ADD1] \\ `LOG b (n MOD b) = 0` by ( simp[logrootTheory.LOG_EQ_0] ) - \\ simp[]); + \\ simp[] +QED -Theorem irreflexive_inv_image - `!R f. irreflexive R ==> irreflexive (inv_image R f)` - (SIMP_TAC std_ss [irreflexive_def,inv_image_def]) +Theorem irreflexive_inv_image: + !R f. irreflexive R ==> irreflexive (inv_image R f) +Proof + SIMP_TAC std_ss [irreflexive_def,inv_image_def] +QED -Theorem trichotomous_inv_image - `!R f. trichotomous R /\ (INJ f UNIV UNIV) ==> trichotomous (inv_image R f)` - (SIMP_TAC std_ss [trichotomous,inv_image_def,INJ_DEF,IN_UNIV] THEN - METIS_TAC[]) +Theorem trichotomous_inv_image: + !R f. trichotomous R /\ (INJ f UNIV UNIV) ==> trichotomous (inv_image R f) +Proof + SIMP_TAC std_ss [trichotomous,inv_image_def,INJ_DEF,IN_UNIV] THEN + METIS_TAC[] +QED -Theorem MEM_REPLICATE_IMP - `MEM x (REPLICATE n y) ==> x = y` - (Induct_on`n` \\ rw[REPLICATE] \\ fs[]); +Theorem MEM_REPLICATE_IMP: + MEM x (REPLICATE n y) ==> x = y +Proof + Induct_on`n` \\ rw[REPLICATE] \\ fs[] +QED -Theorem plus_0_I[simp] - `$+ 0n = I` (rw[FUN_EQ_THM]); +Theorem plus_0_I[simp]: + $+ 0n = I +Proof +rw[FUN_EQ_THM] +QED (* used once *) val SUM_COUNT_LIST = save_thm("SUM_COUNT_LIST", SUM_MAP_COUNT_LIST |> Q.SPECL [`n`,`0`] |> SIMP_RULE (srw_ss()) []); -Theorem OPTION_MAP_I[simp] - `OPTION_MAP I x = x` - (Cases_on`x` \\ rw[]); +Theorem OPTION_MAP_I[simp]: + OPTION_MAP I x = x +Proof + Cases_on`x` \\ rw[] +QED (* should be made an iff in conclusion *) -Theorem OPTION_MAP_INJ - `(∀x y. f x = f y ⇒ x = y) +Theorem OPTION_MAP_INJ: + (∀x y. f x = f y ⇒ x = y) ⇒ ∀o1 o2. - OPTION_MAP f o1 = OPTION_MAP f o2 ⇒ o1 = o2` - (strip_tac \\ Cases \\ Cases \\ simp[]); + OPTION_MAP f o1 = OPTION_MAP f o2 ⇒ o1 = o2 +Proof + strip_tac \\ Cases \\ Cases \\ simp[] +QED -Theorem the_OPTION_MAP - `!f d opt. +Theorem the_OPTION_MAP: + !f d opt. f d = d ==> - the d (OPTION_MAP f opt) = f (the d opt)` - (rw [] >> Cases_on `opt` >> rw [the_def] -); + the d (OPTION_MAP f opt) = f (the d opt) +Proof + rw [] >> Cases_on `opt` >> rw [the_def] +QED -Theorem TAKE_FLAT_REPLICATE_LEQ - `∀j k ls len. +Theorem TAKE_FLAT_REPLICATE_LEQ: + ∀j k ls len. len = LENGTH ls ∧ k ≤ j ⇒ - TAKE (k * len) (FLAT (REPLICATE j ls)) = FLAT (REPLICATE k ls)` - (Induct \\ simp[REPLICATE] + TAKE (k * len) (FLAT (REPLICATE j ls)) = FLAT (REPLICATE k ls) +Proof + Induct \\ simp[REPLICATE] \\ Cases \\ simp[REPLICATE] \\ simp[TAKE_APPEND2] \\ rw[] \\ fs[] - \\ simp[MULT_SUC]); + \\ simp[MULT_SUC] +QED -Theorem MOD_2EXP_0_EVEN - `∀x y. 0 < x ∧ MOD_2EXP x y = 0 ⇒ EVEN y` - (rw[EVEN_MOD2,bitTheory.MOD_2EXP_def,MOD_EQ_0_DIVISOR] - \\ Cases_on`x` \\ fs[EXP]); +Theorem MOD_2EXP_0_EVEN: + ∀x y. 0 < x ∧ MOD_2EXP x y = 0 ⇒ EVEN y +Proof + rw[EVEN_MOD2,bitTheory.MOD_2EXP_def,MOD_EQ_0_DIVISOR] + \\ Cases_on`x` \\ fs[EXP] +QED -Theorem ADD_MOD_EQ_LEMMA - `k MOD d = 0 /\ n < d ==> (k + n) MOD d = n` - (rw [] \\ `0 < d` by decide_tac +Theorem ADD_MOD_EQ_LEMMA: + k MOD d = 0 /\ n < d ==> (k + n) MOD d = n +Proof + rw [] \\ `0 < d` by decide_tac \\ fs [MOD_EQ_0_DIVISOR] \\ pop_assum kall_tac \\ drule MOD_MULT - \\ fs []); + \\ fs [] +QED (* should be set l1 ⊆ set l2 *) val list_subset_def = Define ` @@ -2548,65 +3053,81 @@ list_subset l1 l2 = EVERY (\x. MEM x l2) l1`; val list_set_eq = Define ` list_set_eq l1 l2 ⇔ list_subset l1 l2 ∧ list_subset l2 l1`; -Theorem list_subset_LENGTH ` - !l1 l2.ALL_DISTINCT l1 ∧ +Theorem list_subset_LENGTH: + !l1 l2.ALL_DISTINCT l1 ∧ list_subset l1 l2 ⇒ - LENGTH l1 ≤ LENGTH l2` - (fs[list_subset_def,EVERY_MEM]>> + LENGTH l1 ≤ LENGTH l2 +Proof + fs[list_subset_def,EVERY_MEM]>> Induct>>rw[]>> first_x_assum(qspec_then`FILTER ($~ o $= h) l2` assume_tac)>> rfs[MEM_FILTER]>> `LENGTH (FILTER ($~ o $= h) l2) < LENGTH l2` by (match_mp_tac LENGTH_FILTER_LESS>> fs[EXISTS_MEM])>> - fs[]); + fs[] +QED -Theorem BIJ_UPDATE - `!f s t x y. BIJ f s t /\ ~(x IN s) /\ ~(y IN t) ==> - BIJ ((x =+ y) f) (x INSERT s) (y INSERT t)` - (simp_tac std_ss [BIJ_DEF,SURJ_DEF,INJ_DEF,IN_INSERT,APPLY_UPDATE_THM] - \\ metis_tac []); +Theorem BIJ_UPDATE: + !f s t x y. BIJ f s t /\ ~(x IN s) /\ ~(y IN t) ==> + BIJ ((x =+ y) f) (x INSERT s) (y INSERT t) +Proof + simp_tac std_ss [BIJ_DEF,SURJ_DEF,INJ_DEF,IN_INSERT,APPLY_UPDATE_THM] + \\ metis_tac [] +QED -Theorem INJ_UPDATE - `INJ f s t /\ ~(x IN s) /\ ~(y IN t) ==> - INJ ((x =+ y) f) (x INSERT s) (y INSERT t)` - (simp_tac std_ss [BIJ_DEF,SURJ_DEF,INJ_DEF,IN_INSERT,APPLY_UPDATE_THM] - \\ metis_tac []); +Theorem INJ_UPDATE: + INJ f s t /\ ~(x IN s) /\ ~(y IN t) ==> + INJ ((x =+ y) f) (x INSERT s) (y INSERT t) +Proof + simp_tac std_ss [BIJ_DEF,SURJ_DEF,INJ_DEF,IN_INSERT,APPLY_UPDATE_THM] + \\ metis_tac [] +QED (* TODO: candidate for move to HOL; subspt_domain exists already but is specialised to unit *) -Theorem subspt_domain_SUBSET - `subspt t1 t2 ==> domain t1 SUBSET domain t2` - (fs [subspt_def,SUBSET_DEF]); +Theorem subspt_domain_SUBSET: + subspt t1 t2 ==> domain t1 SUBSET domain t2 +Proof + fs [subspt_def,SUBSET_DEF] +QED (* Some temporal logic definitions based on lazy lists *) (* move into llistTheory? *) -Theorem SPLITP_TAKE_DROP - `!P i l. EVERY ($~ ∘ P) (TAKE i l) ==> +Theorem SPLITP_TAKE_DROP: + !P i l. EVERY ($~ ∘ P) (TAKE i l) ==> P (EL i l) ==> - SPLITP P l = (TAKE i l, DROP i l)` - (Induct_on`l` >> rw[SPLITP] >> Cases_on`i` >> fs[] >> - res_tac >> fs[FST,SND]); - -Theorem SND_SPLITP_DROP - `!P n l. EVERY ($~ o P) (TAKE n l) ==> - SND (SPLITP P (DROP n l)) = SND (SPLITP P l)` - (Induct_on`n` >> rw[SPLITP] >> Cases_on`l` >> fs[SPLITP]); - -Theorem FST_SPLITP_DROP - `!P n l. EVERY ($~ o P) (TAKE n l) ==> - FST (SPLITP P l) = (TAKE n l) ++ FST (SPLITP P (DROP n l))` - (Induct_on`n` >> rw[SPLITP] >> Cases_on`l` >> + SPLITP P l = (TAKE i l, DROP i l) +Proof + Induct_on`l` >> rw[SPLITP] >> Cases_on`i` >> fs[] >> + res_tac >> fs[FST,SND] +QED + +Theorem SND_SPLITP_DROP: + !P n l. EVERY ($~ o P) (TAKE n l) ==> + SND (SPLITP P (DROP n l)) = SND (SPLITP P l) +Proof + Induct_on`n` >> rw[SPLITP] >> Cases_on`l` >> fs[SPLITP] +QED + +Theorem FST_SPLITP_DROP: + !P n l. EVERY ($~ o P) (TAKE n l) ==> + FST (SPLITP P l) = (TAKE n l) ++ FST (SPLITP P (DROP n l)) +Proof + Induct_on`n` >> rw[SPLITP] >> Cases_on`l` >> PURE_REWRITE_TAC[DROP_def,TAKE_def,APPEND] >> simp[] >> - fs[SPLITP]); + fs[SPLITP] +QED -Theorem TAKE_DROP_SUBLIST - `ll ≼ (DROP n ls) ∧ n < LENGTH ls ∧ (nlll = n + LENGTH ll) ⇒ - (TAKE n ls ++ ll ++ DROP nlll ls = ls)` - (rw[IS_PREFIX_APPEND, LIST_EQ_REWRITE, LENGTH_TAKE_EQ, EL_APPEND_EQN, EL_DROP] +Theorem TAKE_DROP_SUBLIST: + ll ≼ (DROP n ls) ∧ n < LENGTH ls ∧ (nlll = n + LENGTH ll) ⇒ + (TAKE n ls ++ ll ++ DROP nlll ls = ls) +Proof + rw[IS_PREFIX_APPEND, LIST_EQ_REWRITE, LENGTH_TAKE_EQ, EL_APPEND_EQN, EL_DROP] \\ rw[] \\ fs[EL_TAKE] - \\ fs[NOT_LESS, LESS_EQ_EXISTS]); + \\ fs[NOT_LESS, LESS_EQ_EXISTS] +QED (* computes the next position for which P holds *) val Lnext_def = tDefine "Lnext" ` @@ -2632,10 +3153,12 @@ val Lnext_def = tDefine "Lnext" ` val Lnext_pos_def = Define` Lnext_pos (ll :num llist) = Lnext (λll. ∃k. LHD ll = SOME k ∧ k ≠ 0) ll` -Theorem OPTION_CHOICE_EQUALS_OPTION - `!(x:'a option) y z. (OPTION_CHOICE x y = SOME z) <=> - ((x = SOME z) \/ ((x = NONE) /\ (y = SOME z)))` - (rw[] \\ Cases_on `x` \\ Cases_on `y` \\ fs[]); +Theorem OPTION_CHOICE_EQUALS_OPTION: + !(x:'a option) y z. (OPTION_CHOICE x y = SOME z) <=> + ((x = SOME z) \/ ((x = NONE) /\ (y = SOME z))) +Proof + rw[] \\ Cases_on `x` \\ Cases_on `y` \\ fs[] +QED val _ = save_thm("option_eq_some", LIST_CONJ [ @@ -2643,35 +3166,47 @@ val _ = save_thm("option_eq_some", OPTION_BIND_EQUALS_OPTION, OPTION_CHOICE_EQUALS_OPTION]); -Theorem ALL_DISTINCT_alist_to_fmap_REVERSE - `ALL_DISTINCT (MAP FST ls) ⇒ alist_to_fmap (REVERSE ls) = alist_to_fmap ls` - (Induct_on`ls` \\ simp[FORALL_PROD] \\ rw[] \\ rw[FUNION_FUPDATE_2]); +Theorem ALL_DISTINCT_alist_to_fmap_REVERSE: + ALL_DISTINCT (MAP FST ls) ⇒ alist_to_fmap (REVERSE ls) = alist_to_fmap ls +Proof + Induct_on`ls` \\ simp[FORALL_PROD] \\ rw[] \\ rw[FUNION_FUPDATE_2] +QED -Theorem FUPDATE_LIST_alist_to_fmap -`∀ls fm. fm |++ ls = alist_to_fmap (REVERSE ls) ⊌ fm` - (metis_tac [FUNION_alist_to_fmap, REVERSE_REVERSE]); +Theorem FUPDATE_LIST_alist_to_fmap: + ∀ls fm. fm |++ ls = alist_to_fmap (REVERSE ls) ⊌ fm +Proof + metis_tac [FUNION_alist_to_fmap, REVERSE_REVERSE] +QED -Theorem DISTINCT_FUPDATE_LIST_UNION - `ALL_DISTINCT (MAP FST ls) /\ +Theorem DISTINCT_FUPDATE_LIST_UNION: + ALL_DISTINCT (MAP FST ls) /\ DISJOINT (FDOM f) (set(MAP FST ls)) ==> - f |++ ls = FUNION f (alist_to_fmap ls)` - (rw[FUPDATE_LIST_alist_to_fmap,ALL_DISTINCT_alist_to_fmap_REVERSE] - \\ match_mp_tac FUNION_COMM \\ rw[DISJOINT_SYM]); - -Theorem fevery_to_drestrict -`!P m s. - FEVERY P m ⇒ FEVERY P (DRESTRICT m s)` - (rw [FEVERY_ALL_FLOOKUP,FLOOKUP_DRESTRICT]); - -Theorem SUM_MAP_K - `∀f ls c. (∀x. f x = c) ⇒ SUM (MAP f ls) = LENGTH ls * c` - (rw[] \\ Induct_on`ls` \\ rw[MULT_SUC]); - -Theorem LAST_FLAT - `∀ls. ~NULL (FLAT ls) ==> (LAST (FLAT ls) = LAST (LAST (FILTER ($~ o NULL) ls)))` - (ho_match_mp_tac SNOC_INDUCT \\ rw[] + f |++ ls = FUNION f (alist_to_fmap ls) +Proof + rw[FUPDATE_LIST_alist_to_fmap,ALL_DISTINCT_alist_to_fmap_REVERSE] + \\ match_mp_tac FUNION_COMM \\ rw[DISJOINT_SYM] +QED + +Theorem fevery_to_drestrict: + !P m s. + FEVERY P m ⇒ FEVERY P (DRESTRICT m s) +Proof + rw [FEVERY_ALL_FLOOKUP,FLOOKUP_DRESTRICT] +QED + +Theorem SUM_MAP_K: + ∀f ls c. (∀x. f x = c) ⇒ SUM (MAP f ls) = LENGTH ls * c +Proof + rw[] \\ Induct_on`ls` \\ rw[MULT_SUC] +QED + +Theorem LAST_FLAT: + ∀ls. ~NULL (FLAT ls) ==> (LAST (FLAT ls) = LAST (LAST (FILTER ($~ o NULL) ls))) +Proof + ho_match_mp_tac SNOC_INDUCT \\ rw[] \\ fs[FLAT_SNOC,FILTER_SNOC] - \\ Cases_on`x` \\ fs[]); + \\ Cases_on`x` \\ fs[] +QED Theorem TOKENS_unchanged: EVERY ($~ o P) ls ==> TOKENS P ls = if NULL ls then [] else [ls] @@ -2695,16 +3230,18 @@ Proof \\ fs[] \\ rw[] \\ metis_tac[] QED -Theorem TOKENS_FLAT_MAP_SNOC - `EVERY (EVERY ((<>) x)) ls ∧ EVERY ($~ o NULL) ls ==> - TOKENS ((=) x) (FLAT (MAP (SNOC x) ls)) = ls` - (Induct_on`ls` \\ rw[TOKENS_NIL] +Theorem TOKENS_FLAT_MAP_SNOC: + EVERY (EVERY ((<>) x)) ls ∧ EVERY ($~ o NULL) ls ==> + TOKENS ((=) x) (FLAT (MAP (SNOC x) ls)) = ls +Proof + Induct_on`ls` \\ rw[TOKENS_NIL] \\ Q.ISPEC_THEN`x`(mp_tac o GSYM) CONS_APPEND \\ rewrite_tac[GSYM APPEND_ASSOC] \\ disch_then(rewrite_tac o mlibUseful.sing) \\ DEP_REWRITE_TAC[TOKENS_APPEND] \\ rw[] \\ DEP_REWRITE_TAC[TOKENS_unchanged] - \\ fs[EVERY_MEM]); + \\ fs[EVERY_MEM] +QED (* insert a string (l1) at specified index (n) in a list (l2) *) val insert_atI_def = Define` @@ -2712,79 +3249,100 @@ val insert_atI_def = Define` TAKE n l2 ++ l1 ++ DROP (n + LENGTH l1) l2 `; -Theorem insert_atI_NIL - `∀n l.insert_atI [] n l = l` - (simp[insert_atI_def]); +Theorem insert_atI_NIL: + ∀n l.insert_atI [] n l = l +Proof + simp[insert_atI_def] +QED -Theorem insert_atI_CONS - `∀n l h t. +Theorem insert_atI_CONS: + ∀n l h t. n + LENGTH t < LENGTH l ==> - insert_atI (h::t) n l = LUPDATE h n (insert_atI t (n + 1) l)` - (simp[insert_atI_def] >> Induct_on `n` + insert_atI (h::t) n l = LUPDATE h n (insert_atI t (n + 1) l) +Proof + simp[insert_atI_def] >> Induct_on `n` >- (Cases_on `l` >> simp[ADD1, LUPDATE_def]) >> Cases_on `l` >> simp[ADD1] >> fs[ADD1] >> - simp[GSYM ADD1, LUPDATE_def]); + simp[GSYM ADD1, LUPDATE_def] +QED -Theorem LENGTH_insert_atI - `p + LENGTH l1 <= LENGTH l2 ⇒ LENGTH (insert_atI l1 p l2) = LENGTH l2` - (simp[insert_atI_def]); +Theorem LENGTH_insert_atI: + p + LENGTH l1 <= LENGTH l2 ⇒ LENGTH (insert_atI l1 p l2) = LENGTH l2 +Proof + simp[insert_atI_def] +QED -Theorem insert_atI_app - `∀n l c1 c2. n + LENGTH c1 + LENGTH c2 <= LENGTH l ==> +Theorem insert_atI_app: + ∀n l c1 c2. n + LENGTH c1 + LENGTH c2 <= LENGTH l ==> insert_atI (c1 ++ c2) n l = - insert_atI c1 n (insert_atI c2 (n + LENGTH c1) l)` - (Induct_on`c1` >> fs[insert_atI_NIL,insert_atI_CONS,LENGTH_insert_atI,ADD1]); + insert_atI c1 n (insert_atI c2 (n + LENGTH c1) l) +Proof + Induct_on`c1` >> fs[insert_atI_NIL,insert_atI_CONS,LENGTH_insert_atI,ADD1] +QED -Theorem insert_atI_end - `insert_atI l1 (LENGTH l2) l2 = l2 ++ l1` - (simp[insert_atI_def,DROP_LENGTH_TOO_LONG]); +Theorem insert_atI_end: + insert_atI l1 (LENGTH l2) l2 = l2 ++ l1 +Proof + simp[insert_atI_def,DROP_LENGTH_TOO_LONG] +QED -Theorem insert_atI_insert_atI - `pos2 = pos1 + LENGTH c1 ==> - insert_atI c2 pos2 (insert_atI c1 pos1 l) = insert_atI (c1 ++ c2) pos1 l` - (rw[insert_atI_def,TAKE_SUM,TAKE_APPEND,LENGTH_TAKE_EQ,LENGTH_DROP, +Theorem insert_atI_insert_atI: + pos2 = pos1 + LENGTH c1 ==> + insert_atI c2 pos2 (insert_atI c1 pos1 l) = insert_atI (c1 ++ c2) pos1 l +Proof + rw[insert_atI_def,TAKE_SUM,TAKE_APPEND,LENGTH_TAKE_EQ,LENGTH_DROP, GSYM DROP_DROP_T,DROP_LENGTH_TOO_LONG,DROP_LENGTH_NIL_rwt] >> fs[DROP_LENGTH_NIL_rwt,LENGTH_TAKE,DROP_APPEND1,TAKE_APPEND,TAKE_TAKE, - DROP_DROP_T,DROP_APPEND2,TAKE_LENGTH_TOO_LONG,TAKE_SUM,LENGTH_DROP]); + DROP_DROP_T,DROP_APPEND2,TAKE_LENGTH_TOO_LONG,TAKE_SUM,LENGTH_DROP] +QED -Theorem LUPDATE_insert_commute - `∀ws pos1 pos2 a w. +Theorem LUPDATE_insert_commute: + ∀ws pos1 pos2 a w. pos2 < pos1 ∧ pos1 + LENGTH ws <= LENGTH a ⇒ insert_atI ws pos1 (LUPDATE w pos2 a) = - LUPDATE w pos2 (insert_atI ws pos1 a)` - (Induct >> simp[insert_atI_NIL,insert_atI_CONS, LUPDATE_commutes]); + LUPDATE w pos2 (insert_atI ws pos1 a) +Proof + Induct >> simp[insert_atI_NIL,insert_atI_CONS, LUPDATE_commutes] +QED -Theorem LESS_EQ_LENGTH - `!xs k. k <= LENGTH xs ==> ?ys1 ys2. (xs = ys1 ++ ys2) /\ (LENGTH ys1 = k)` - (Induct \\ Cases_on `k` \\ full_simp_tac std_ss [LENGTH,ADD1,LENGTH_NIL,APPEND] +Theorem LESS_EQ_LENGTH: + !xs k. k <= LENGTH xs ==> ?ys1 ys2. (xs = ys1 ++ ys2) /\ (LENGTH ys1 = k) +Proof + Induct \\ Cases_on `k` \\ full_simp_tac std_ss [LENGTH,ADD1,LENGTH_NIL,APPEND] \\ rpt strip_tac \\ res_tac \\ full_simp_tac std_ss [] \\ qexists_tac `h::ys1` \\ full_simp_tac std_ss [LENGTH,APPEND] - \\ srw_tac [] [ADD1]); + \\ srw_tac [] [ADD1] +QED -Theorem LESS_LENGTH - `!xs k. k < LENGTH xs ==> - ?ys1 y ys2. (xs = ys1 ++ y::ys2) /\ (LENGTH ys1 = k)` - (Induct \\ Cases_on `k` \\ full_simp_tac std_ss [LENGTH,ADD1,LENGTH_NIL,APPEND] +Theorem LESS_LENGTH: + !xs k. k < LENGTH xs ==> + ?ys1 y ys2. (xs = ys1 ++ y::ys2) /\ (LENGTH ys1 = k) +Proof + Induct \\ Cases_on `k` \\ full_simp_tac std_ss [LENGTH,ADD1,LENGTH_NIL,APPEND] \\ rpt strip_tac \\ res_tac \\ full_simp_tac std_ss [CONS_11] \\ qexists_tac `h::ys1` \\ full_simp_tac std_ss [LENGTH,APPEND] - \\ srw_tac [] [ADD1]); + \\ srw_tac [] [ADD1] +QED val IN_EVEN = save_thm("IN_EVEN", SIMP_CONV std_ss [IN_DEF] ``x ∈ EVEN``); -Theorem FOLDL_OPTION_CHOICE_EQ_SOME_IMP_MEM - `FOLDL OPTION_CHOICE x ls = SOME y ⇒ MEM (SOME y) (x::ls)` - (qid_spec_tac`x` \\ Induct_on`ls` \\ rw[] \\ - res_tac \\ fs[] \\ Cases_on`x` \\ fs[]); +Theorem FOLDL_OPTION_CHOICE_EQ_SOME_IMP_MEM: + FOLDL OPTION_CHOICE x ls = SOME y ⇒ MEM (SOME y) (x::ls) +Proof + qid_spec_tac`x` \\ Induct_on`ls` \\ rw[] \\ + res_tac \\ fs[] \\ Cases_on`x` \\ fs[] +QED -Theorem BAG_ALL_DISTINCT_FOLDR_BAG_UNION - `∀ls b0. +Theorem BAG_ALL_DISTINCT_FOLDR_BAG_UNION: + ∀ls b0. BAG_ALL_DISTINCT (FOLDR BAG_UNION b0 ls) ⇔ BAG_ALL_DISTINCT b0 ∧ (∀n. n < LENGTH ls ⇒ BAG_DISJOINT (EL n ls) b0 ∧ BAG_ALL_DISTINCT (EL n ls) ∧ - (∀m. m < n ⇒ BAG_DISJOINT (EL n ls) (EL m ls)))` - (Induct \\ rw[] + (∀m. m < n ⇒ BAG_DISJOINT (EL n ls) (EL m ls))) +Proof + Induct \\ rw[] \\ rw[BAG_ALL_DISTINCT_BAG_UNION] \\ simp[Once FORALL_NUM, SimpRHS] \\ Cases_on`BAG_ALL_DISTINCT h` \\ simp[] @@ -2793,7 +3351,8 @@ Theorem BAG_ALL_DISTINCT_FOLDR_BAG_UNION \\ CONV_TAC(PATH_CONV"rrrarrr"(HO_REWR_CONV FORALL_NUM)) \\ simp[] \\ rw[EQ_IMP_THM] \\ fs[] - \\ metis_tac[BAG_DISJOINT_SYM]); + \\ metis_tac[BAG_DISJOINT_SYM] +QED (* TODO - candidate for move to HOL *) (* N.B.: there is a different is_subsequence defined in lcsTheory; these should be merged *) @@ -2808,138 +3367,182 @@ val is_subseq_def = Define` val is_subseq_ind = theorem"is_subseq_ind"; (* TODO - candidate for move to HOL *) -Theorem is_subseq_refl[simp] - `∀ls. is_subseq ls ls` (Induct \\ rw[is_subseq_def]); +Theorem is_subseq_refl[simp]: + ∀ls. is_subseq ls ls +Proof +Induct \\ rw[is_subseq_def] +QED (* TODO - candidate for move to HOL *) -Theorem is_subseq_nil[simp] - `is_subseq [] ls ⇔ ls = []` - (Cases_on`ls` \\ rw[is_subseq_def]); +Theorem is_subseq_nil[simp]: + is_subseq [] ls ⇔ ls = [] +Proof + Cases_on`ls` \\ rw[is_subseq_def] +QED (* TODO - candidate for move to HOL *) -Theorem is_subseq_cons - `∀l1 l2 x. is_subseq l1 l2 ⇒ is_subseq (x::l1) l2` - (recInduct is_subseq_ind - \\ rw[is_subseq_def]); +Theorem is_subseq_cons: + ∀l1 l2 x. is_subseq l1 l2 ⇒ is_subseq (x::l1) l2 +Proof + recInduct is_subseq_ind + \\ rw[is_subseq_def] +QED (* TODO - candidate for move to HOL *) -Theorem is_subseq_snoc - `∀l1 l2 x. is_subseq l1 l2 ⇒ is_subseq (SNOC x l1) l2` - (recInduct is_subseq_ind - \\ rw[is_subseq_def] \\ fs[]); +Theorem is_subseq_snoc: + ∀l1 l2 x. is_subseq l1 l2 ⇒ is_subseq (SNOC x l1) l2 +Proof + recInduct is_subseq_ind + \\ rw[is_subseq_def] \\ fs[] +QED (* TODO - candidate for move to HOL *) -Theorem is_subseq_append1 - `∀l3 l1 l2. is_subseq l1 l2 ⇒ is_subseq (l3 ++ l1) l2` - (Induct +Theorem is_subseq_append1: + ∀l3 l1 l2. is_subseq l1 l2 ⇒ is_subseq (l3 ++ l1) l2 +Proof + Induct \\ rw[is_subseq_def] \\ fs[] - \\ metis_tac[is_subseq_cons]); + \\ metis_tac[is_subseq_cons] +QED (* TODO - candidate for move to HOL *) -Theorem is_subseq_append2 - `∀l4 l1 l2. is_subseq l1 l2 ⇒ is_subseq (l1 ++ l4) l2` - (ho_match_mp_tac SNOC_INDUCT +Theorem is_subseq_append2: + ∀l4 l1 l2. is_subseq l1 l2 ⇒ is_subseq (l1 ++ l4) l2 +Proof + ho_match_mp_tac SNOC_INDUCT \\ rw[is_subseq_def] \\ fs[] - \\ metis_tac[is_subseq_snoc, SNOC_APPEND, APPEND_ASSOC]); + \\ metis_tac[is_subseq_snoc, SNOC_APPEND, APPEND_ASSOC] +QED (* TODO - candidate for move to HOL *) -Theorem is_subseq_IS_SUBLIST - `is_subseq l1 l2 ∧ IS_SUBLIST l3 l1 ⇒ is_subseq l3 l2` - (rw[IS_SUBLIST_APPEND] - \\ metis_tac[is_subseq_append1, is_subseq_append2]); +Theorem is_subseq_IS_SUBLIST: + is_subseq l1 l2 ∧ IS_SUBLIST l3 l1 ⇒ is_subseq l3 l2 +Proof + rw[IS_SUBLIST_APPEND] + \\ metis_tac[is_subseq_append1, is_subseq_append2] +QED (* TODO - candidate for move to HOL *) -Theorem is_subseq_MEM - `∀l1 l2 x. is_subseq l1 l2 ∧ MEM x l2 ⇒ MEM x l1` - (recInduct is_subseq_ind +Theorem is_subseq_MEM: + ∀l1 l2 x. is_subseq l1 l2 ∧ MEM x l2 ⇒ MEM x l1 +Proof + recInduct is_subseq_ind \\ rw[is_subseq_def] - \\ metis_tac[]); + \\ metis_tac[] +QED (* TODO - candidate for move to HOL *) -Theorem IS_PREFIX_is_subseq - `∀l1 l2. IS_PREFIX l1 l2 ⇒ is_subseq l1 l2` - (recInduct is_subseq_ind +Theorem IS_PREFIX_is_subseq: + ∀l1 l2. IS_PREFIX l1 l2 ⇒ is_subseq l1 l2 +Proof + recInduct is_subseq_ind \\ rw[is_subseq_def] - \\ fs[IS_PREFIX_NIL]); + \\ fs[IS_PREFIX_NIL] +QED (* TODO - candidate for move to HOL *) -Theorem IS_SUBLIST_is_subseq - `∀l1 l2. IS_SUBLIST l1 l2 ⇒ is_subseq l1 l2` - (recInduct is_subseq_ind +Theorem IS_SUBLIST_is_subseq: + ∀l1 l2. IS_SUBLIST l1 l2 ⇒ is_subseq l1 l2 +Proof + recInduct is_subseq_ind \\ rw[is_subseq_def, IS_SUBLIST] - \\ simp[IS_PREFIX_is_subseq]); + \\ simp[IS_PREFIX_is_subseq] +QED (* TODO - candidate for move to HOL *) -Theorem is_subseq_ALL_DISTINCT - `∀l1 l2. ALL_DISTINCT l1 ∧ is_subseq l1 l2 ⇒ ALL_DISTINCT l2` - (recInduct is_subseq_ind +Theorem is_subseq_ALL_DISTINCT: + ∀l1 l2. ALL_DISTINCT l1 ∧ is_subseq l1 l2 ⇒ ALL_DISTINCT l2 +Proof + recInduct is_subseq_ind \\ rw[is_subseq_def] \\ fs[] \\ rfs[] - \\ metis_tac[is_subseq_MEM]); + \\ metis_tac[is_subseq_MEM] +QED (* TODO - candidate for move to HOL *) -Theorem is_subseq_append_suff - `∀l1 l3 l2 l4. +Theorem is_subseq_append_suff: + ∀l1 l3 l2 l4. is_subseq l1 l3 ∧ is_subseq l2 l4 ⇒ - is_subseq (l1 ++ l2) (l3 ++ l4)` - (recInduct is_subseq_ind + is_subseq (l1 ++ l2) (l3 ++ l4) +Proof + recInduct is_subseq_ind \\ rw[is_subseq_def] - \\ metis_tac[is_subseq_append1]); + \\ metis_tac[is_subseq_append1] +QED (* TODO - candidate for move to HOL *) -Theorem is_subseq_FLAT_suff - `∀ls1 ls2. LIST_REL is_subseq ls1 ls2 ⇒ is_subseq (FLAT ls1) (FLAT ls2)` - (ho_match_mp_tac LIST_REL_ind - \\ rw[is_subseq_append_suff]); - -Theorem LIST_REL_IMP_LAST - `!P xs ys. - LIST_REL P xs ys /\ (xs <> [] \/ ys <> []) ==> P (LAST xs) (LAST ys)` - (rpt gen_tac +Theorem is_subseq_FLAT_suff: + ∀ls1 ls2. LIST_REL is_subseq ls1 ls2 ⇒ is_subseq (FLAT ls1) (FLAT ls2) +Proof + ho_match_mp_tac LIST_REL_ind + \\ rw[is_subseq_append_suff] +QED + +Theorem LIST_REL_IMP_LAST: + !P xs ys. + LIST_REL P xs ys /\ (xs <> [] \/ ys <> []) ==> P (LAST xs) (LAST ys) +Proof + rpt gen_tac \\ Cases_on `xs = []` \\ fs [] \\ Cases_on `ys = []` \\ fs [] \\ `?x1 x2. xs = SNOC x1 x2` by metis_tac [SNOC_CASES] \\ `?y1 y2. ys = SNOC y1 y2` by metis_tac [SNOC_CASES] - \\ asm_rewrite_tac [LAST_SNOC] \\ fs [LIST_REL_SNOC]); + \\ asm_rewrite_tac [LAST_SNOC] \\ fs [LIST_REL_SNOC] +QED val make_even_def = Define` make_even n = if EVEN n then n else n+1`; -Theorem EVEN_make_even[simp] - `EVEN (make_even x)` - (rw[make_even_def, EVEN_ADD]); +Theorem EVEN_make_even[simp]: + EVEN (make_even x) +Proof + rw[make_even_def, EVEN_ADD] +QED -Theorem ALOOKUP_MAP_FST_INJ_SOME - `∀ls x y. +Theorem ALOOKUP_MAP_FST_INJ_SOME: + ∀ls x y. ALOOKUP ls x = SOME y ∧ (∀x'. IS_SOME (ALOOKUP ls x') ∧ f x' = f x ⇒ x = x') ⇒ - ALOOKUP (MAP (f ## g) ls) (f x) = SOME (g y)` - (Induct \\ simp[] + ALOOKUP (MAP (f ## g) ls) (f x) = SOME (g y) +Proof + Induct \\ simp[] \\ Cases \\ rw[] >- metis_tac[IS_SOME_EXISTS] \\ first_x_assum irule \\ rw[] \\ first_x_assum irule - \\ rw[]); + \\ rw[] +QED -Theorem v2w_32_F[simp] - `(v2w [F] : word32) = 0w` (EVAL_TAC); +Theorem v2w_32_F[simp]: + (v2w [F] : word32) = 0w +Proof +EVAL_TAC +QED -Theorem v2w_32_T[simp] - `(v2w [T] : word32) = 1w` (EVAL_TAC); +Theorem v2w_32_T[simp]: + (v2w [T] : word32) = 1w +Proof +EVAL_TAC +QED -Theorem v2w_sing - `v2w [b] = if b then 1w else 0w` - (Cases_on `b` \\ EVAL_TAC); +Theorem v2w_sing: + v2w [b] = if b then 1w else 0w +Proof + Cases_on `b` \\ EVAL_TAC +QED -Theorem FOLDR_FUNPOW - `FOLDR (λx. f) x ls = FUNPOW f (LENGTH ls) x` - (qid_spec_tac`x` +Theorem FOLDR_FUNPOW: + FOLDR (λx. f) x ls = FUNPOW f (LENGTH ls) x +Proof + qid_spec_tac`x` \\ Induct_on`ls` - \\ rw[FUNPOW_SUC]); + \\ rw[FUNPOW_SUC] +QED -Theorem FUNPOW_refl_trans_chain - `transitive P ∧ reflexive P ⇒ +Theorem FUNPOW_refl_trans_chain: + transitive P ∧ reflexive P ⇒ ∀n x. (∀j. j < n ⇒ P (FUNPOW f j x) (f (FUNPOW f j x))) ⇒ - P x (FUNPOW f n x)` - (strip_tac + P x (FUNPOW f n x) +Proof + strip_tac \\ Induct \\ rw[] >- fs[reflexive_def] @@ -2948,40 +3551,51 @@ Theorem FUNPOW_refl_trans_chain \\ last_x_assum irule \\ simp[FUNPOW_SUC] \\ qexists_tac`FUNPOW f n x` - \\ simp[]); + \\ simp[] +QED -Theorem byte_align_extract - `byte_align (x:word32) = (((31 >< 2) x):word30) @@ (0w:word2)` - (rw[alignmentTheory.byte_align_def] +Theorem byte_align_extract: + byte_align (x:word32) = (((31 >< 2) x):word30) @@ (0w:word2) +Proof + rw[alignmentTheory.byte_align_def] \\ rw[alignmentTheory.align_def] - \\ blastLib.BBLAST_TAC); + \\ blastLib.BBLAST_TAC +QED (* TODO - candidate for move to HOL *) -Theorem byte_align_aligned - `byte_aligned x ⇔ (byte_align x = x)` (EVAL_TAC); +Theorem byte_align_aligned: + byte_aligned x ⇔ (byte_align x = x) +Proof +EVAL_TAC +QED (* TODO - candidate for move to HOL *) -Theorem byte_aligned_add - `byte_aligned x ∧ byte_aligned y ⇒ byte_aligned (x+y)` - (rw[alignmentTheory.byte_aligned_def] - \\ metis_tac[alignmentTheory.aligned_add_sub_cor]); +Theorem byte_aligned_add: + byte_aligned x ∧ byte_aligned y ⇒ byte_aligned (x+y) +Proof + rw[alignmentTheory.byte_aligned_def] + \\ metis_tac[alignmentTheory.aligned_add_sub_cor] +QED (* TODO - candidate for move to HOL *) -Theorem align_ls - `align p n <=+ n` - (simp[WORD_LS] +Theorem align_ls: + align p n <=+ n +Proof + simp[WORD_LS] \\ Cases_on`n` \\ fs[alignmentTheory.align_w2n] \\ qmatch_asmsub_rename_tac`n < _` \\ DEP_REWRITE_TAC[LESS_MOD] \\ conj_asm2_tac >- fs[] \\ DEP_REWRITE_TAC[GSYM X_LE_DIV] - \\ simp[]); + \\ simp[] +QED (* TODO - candidate for move to HOL *) -Theorem align_lo - `¬aligned p n ⇒ align p n <+ n` - (simp[WORD_LO] +Theorem align_lo: + ¬aligned p n ⇒ align p n <+ n +Proof + simp[WORD_LO] \\ Cases_on`n` \\ fs[alignmentTheory.align_w2n, alignmentTheory.aligned_def] \\ strip_tac @@ -2992,11 +3606,13 @@ Theorem align_lo \\ DEP_REWRITE_TAC[LESS_MOD] \\ conj_asm2_tac >- fs[] \\ DEP_REWRITE_TAC[GSYM X_LE_DIV] - \\ simp[]); + \\ simp[] +QED -Theorem aligned_between - `¬aligned p n ∧ aligned p m ∧ align p n <+ m ⇒ n <+ m` - (rw[WORD_LO] +Theorem aligned_between: + ¬aligned p n ∧ aligned p m ∧ align p n <+ m ⇒ n <+ m +Proof + rw[WORD_LO] \\ fs[alignmentTheory.align_w2n, alignmentTheory.aligned_def] \\ Cases_on`n` \\ Cases_on`m` \\ fs[] \\ CCONTR_TAC \\ fs[NOT_LESS] @@ -3015,14 +3631,16 @@ Theorem aligned_between \\ conj_tac >- simp[Abbr`d`] \\ simp[NOT_LESS_EQUAL] \\ `d * (m DIV d) < d * (n DIV d)` suffices_by fs[] - \\ metis_tac[]) + \\ metis_tac[] +QED -Theorem byte_align_IN_IMP_IN_range - `byte_align a ∈ dm ∧ +Theorem byte_align_IN_IMP_IN_range: + byte_align a ∈ dm ∧ (dm = { w | low <=+ w ∧ w <+ hi }) ∧ byte_aligned low ∧ byte_aligned hi ⇒ - a ∈ dm` - (rw[] \\ fs[] + a ∈ dm +Proof + rw[] \\ fs[] >- ( `byte_align a <=+ a` suffices_by metis_tac[WORD_LOWER_EQ_TRANS] \\ simp[alignmentTheory.byte_align_def] @@ -3034,7 +3652,8 @@ Theorem byte_align_IN_IMP_IN_range \\ match_mp_tac (GEN_ALL aligned_between) \\ fs[alignmentTheory.byte_aligned_def] \\ asm_exists_tac - \\ fs[alignmentTheory.byte_align_def]); + \\ fs[alignmentTheory.byte_align_def] +QED local open alignmentTheory @@ -3051,9 +3670,10 @@ in CONJ aligned_add_mult_lemma aligned_add_mult_any) end -Theorem align_add_aligned_gen - `∀a. aligned p a ⇒ (align p (a + b) = a + align p b)` - (completeInduct_on`w2n b` +Theorem align_add_aligned_gen: + ∀a. aligned p a ⇒ (align p (a + b) = a + align p b) +Proof + completeInduct_on`w2n b` \\ rw[] \\ Cases_on`w2n b < 2 ** p` >- ( @@ -3083,34 +3703,43 @@ Theorem align_add_aligned_gen \\ strip_tac \\ first_x_assum(qspec_then`n2w (2**p)`mp_tac) \\ impl_tac >- fs[aligned_w2n] - \\ simp[]); + \\ simp[] +QED -Theorem MULT_DIV_MULT_LEMMA - `!m l k. 0 < m /\ 0 < l ==> (m * k) DIV (l * m) = k DIV l` - (rw [] \\ qsuff_tac `k * m DIV (m * l) = k DIV l` THEN1 fs [] - \\ simp [GSYM DIV_DIV_DIV_MULT] \\ simp [MULT_DIV]); +Theorem MULT_DIV_MULT_LEMMA: + !m l k. 0 < m /\ 0 < l ==> (m * k) DIV (l * m) = k DIV l +Proof + rw [] \\ qsuff_tac `k * m DIV (m * l) = k DIV l` THEN1 fs [] + \\ simp [GSYM DIV_DIV_DIV_MULT] \\ simp [MULT_DIV] +QED -Theorem IMP_MULT_DIV_LESS - `m <> 0 /\ d < k ==> m * (d DIV m) < k` - (strip_tac \\ `0 < m` by decide_tac +Theorem IMP_MULT_DIV_LESS: + m <> 0 /\ d < k ==> m * (d DIV m) < k +Proof + strip_tac \\ `0 < m` by decide_tac \\ drule DIVISION \\ disch_then (qspec_then `d` assume_tac) - \\ decide_tac); + \\ decide_tac +QED -Theorem DIV_LESS_DIV - `n MOD k = 0 /\ m MOD k = 0 /\ n < m /\ 0 < k ==> n DIV k < m DIV k` - (strip_tac +Theorem DIV_LESS_DIV: + n MOD k = 0 /\ m MOD k = 0 /\ n < m /\ 0 < k ==> n DIV k < m DIV k +Proof + strip_tac \\ drule DIVISION \\ disch_then (qspec_then `n` (strip_assume_tac o GSYM)) \\ drule DIVISION \\ disch_then (qspec_then `m` (strip_assume_tac o GSYM)) - \\ rfs [] \\ metis_tac [LT_MULT_LCANCEL]); + \\ rfs [] \\ metis_tac [LT_MULT_LCANCEL] +QED open pathTheory -Theorem toPath_fromList - `(toPath (x, fromList []) = stopped_at x) ∧ - (toPath (x, fromList ((y,z)::t)) = pcons x y (toPath (z, fromList t)))` - (conj_tac >- EVAL_TAC - \\ rw[pathTheory.pcons_def, pathTheory.first_def, pathTheory.path_rep_bijections_thm]); +Theorem toPath_fromList: + (toPath (x, fromList []) = stopped_at x) ∧ + (toPath (x, fromList ((y,z)::t)) = pcons x y (toPath (z, fromList t))) +Proof + conj_tac >- EVAL_TAC + \\ rw[pathTheory.pcons_def, pathTheory.first_def, pathTheory.path_rep_bijections_thm] +QED val steps_def = Define` (steps f x [] = []) ∧ @@ -3127,34 +3756,41 @@ val steps_rel_def = Define` val steps_rel_ind = theorem"steps_rel_ind"; -Theorem steps_rel_okpath - `∀R x tr. - steps_rel R x tr ⇔ okpath R (toPath (x,fromList tr))` - (recInduct steps_rel_ind +Theorem steps_rel_okpath: + ∀R x tr. + steps_rel R x tr ⇔ okpath R (toPath (x,fromList tr)) +Proof + recInduct steps_rel_ind \\ rewrite_tac[toPath_fromList] - \\ rw[steps_rel_def, pathTheory.first_def, pathTheory.path_rep_bijections_thm]); + \\ rw[steps_rel_def, pathTheory.first_def, pathTheory.path_rep_bijections_thm] +QED -Theorem steps_rel_LRC - `∀R x tr. +Theorem steps_rel_LRC: + ∀R x tr. steps_rel R x tr ⇒ LRC (λx y. ∃i. R x i y) - (FRONT(x::(MAP SND tr))) x (LAST (x::(MAP SND tr)))` - (recInduct steps_rel_ind + (FRONT(x::(MAP SND tr))) x (LAST (x::(MAP SND tr))) +Proof + recInduct steps_rel_ind \\ rw[steps_rel_def] \\ rw[LRC_def, PULL_EXISTS] - \\ asm_exists_tac \\ rw[]); + \\ asm_exists_tac \\ rw[] +QED -Theorem LAST_MAP_SND_steps_FOLDL - `∀f x ls. LAST (x::(MAP SND (steps f x ls))) = FOLDL f x ls` - (Induct_on`ls` \\ rw[steps_def]); +Theorem LAST_MAP_SND_steps_FOLDL: + ∀f x ls. LAST (x::(MAP SND (steps f x ls))) = FOLDL f x ls +Proof + Induct_on`ls` \\ rw[steps_def] +QED val all_words_def = Define ` (all_words base 0 = ∅) /\ (all_words base (SUC n) = base INSERT (all_words (base + 1w) n))`; -Theorem IN_all_words - `x ∈ all_words base n ⇔ (∃i. i < n ∧ x = base + n2w i)` - (qid_spec_tac`base` +Theorem IN_all_words: + x ∈ all_words base n ⇔ (∃i. i < n ∧ x = base + n2w i) +Proof + qid_spec_tac`base` \\ Induct_on`n` \\ rw[all_words_def, ADD1] \\ rw[EQ_IMP_THM] @@ -3163,49 +3799,57 @@ Theorem IN_all_words \\ Cases_on`i` \\ fs[ADD1] \\ disj2_tac \\ simp[GSYM word_add_n2w] - \\ asm_exists_tac \\ simp[]); + \\ asm_exists_tac \\ simp[] +QED -Theorem read_bytearray_IMP_mem_SOME - `∀p n m ba. +Theorem read_bytearray_IMP_mem_SOME: + ∀p n m ba. (read_bytearray p n m = SOME ba) ⇒ - ∀k. k ∈ all_words p n ⇒ IS_SOME (m k)` - (Induct_on `n` + ∀k. k ∈ all_words p n ⇒ IS_SOME (m k) +Proof + Induct_on `n` \\ rw[read_bytearray_def,all_words_def] \\ fs[CaseEq"option"] \\ first_x_assum drule \\ disch_then drule - \\ simp []); + \\ simp [] +QED -Theorem read_bytearray_no_wrap - `∀ptr len. +Theorem read_bytearray_no_wrap: + ∀ptr len. IS_SOME (read_bytearray ptr len (m:'a word -> 'b option)) ∧ (∀x. IS_SOME (m x) ⇒ w2n x < dimword(:'a) - 1) ∧ w2n ptr < dimword (:'a) ⇒ - w2n ptr + len < dimword(:'a)` - (Induct_on`len` + w2n ptr + len < dimword(:'a) +Proof + Induct_on`len` \\ rw[read_bytearray_def] \\ fs[CaseEq"option", IS_SOME_EXISTS, PULL_EXISTS] \\ Cases_on`ptr` \\ fs[word_add_n2w, ADD1] - \\ res_tac \\ fs[] \\ rfs[]) + \\ res_tac \\ fs[] \\ rfs[] +QED val asm_write_bytearray_def = Define ` (asm_write_bytearray a [] (m:'a word -> word8) = m) /\ (asm_write_bytearray a (x::xs) m = (a =+ x) (asm_write_bytearray (a+1w) xs m))` -Theorem mem_eq_imp_asm_write_bytearray_eq - `∀a bs. +Theorem mem_eq_imp_asm_write_bytearray_eq: + ∀a bs. (m1 k = m2 k) ⇒ - (asm_write_bytearray a bs m1 k = asm_write_bytearray a bs m2 k)` - (Induct_on`bs` + (asm_write_bytearray a bs m1 k = asm_write_bytearray a bs m2 k) +Proof + Induct_on`bs` \\ rw[asm_write_bytearray_def] - \\ rw[APPLY_UPDATE_THM]); + \\ rw[APPLY_UPDATE_THM] +QED -Theorem asm_write_bytearray_unchanged - `∀a bs m z. (x <+ a ∨ a + n2w (LENGTH bs) <=+ x) ∧ +Theorem asm_write_bytearray_unchanged: + ∀a bs m z. (x <+ a ∨ a + n2w (LENGTH bs) <=+ x) ∧ (w2n a + LENGTH bs < dimword(:'a)) ∧ (z = m x) - ⇒ (asm_write_bytearray (a:'a word) bs m x = z)` - (Induct_on`bs` + ⇒ (asm_write_bytearray (a:'a word) bs m x = z) +Proof + Induct_on`bs` \\ rw[asm_write_bytearray_def,APPLY_UPDATE_THM] \\ TRY ( Cases_on`a` \\ fs[word_ls_n2w,word_lo_n2w,word_add_n2w] @@ -3213,45 +3857,53 @@ Theorem asm_write_bytearray_unchanged \\ first_x_assum match_mp_tac \\ Cases_on`a` \\ Cases_on`x` - \\ fs[word_ls_n2w,word_lo_n2w,word_add_n2w]); + \\ fs[word_ls_n2w,word_lo_n2w,word_add_n2w] +QED -Theorem asm_write_bytearray_id - `∀a bs m. +Theorem asm_write_bytearray_id: + ∀a bs m. (∀j. j < LENGTH bs ⇒ (m (a + n2w j) = EL j bs)) - ⇒ (asm_write_bytearray (a:'a word) bs m x = m x)` - (Induct_on`bs` + ⇒ (asm_write_bytearray (a:'a word) bs m x = m x) +Proof + Induct_on`bs` \\ rw[asm_write_bytearray_def,APPLY_UPDATE_THM] >- ( first_x_assum(qspec_then`0`mp_tac) \\ rw[] ) \\ first_x_assum match_mp_tac \\ rw[] \\ first_x_assum(qspec_then`SUC j`mp_tac) \\ rw[] - \\ fs[ADD1, GSYM word_add_n2w]); + \\ fs[ADD1, GSYM word_add_n2w] +QED -Theorem asm_write_bytearray_unchanged_alt - `∀a bs m z. +Theorem asm_write_bytearray_unchanged_alt: + ∀a bs m z. (z = m x) /\ ~(x IN { a + n2w k | k < LENGTH bs }) ==> - (asm_write_bytearray a bs m x = z)` - (Induct_on`bs` + (asm_write_bytearray a bs m x = z) +Proof + Induct_on`bs` \\ rw[asm_write_bytearray_def,APPLY_UPDATE_THM] THEN1 (first_x_assum (qspec_then `0` mp_tac) \\ fs []) \\ first_x_assum match_mp_tac \\ fs [] \\ rw [] \\ first_x_assum (qspec_then `k + 1` mp_tac) - \\ fs [GSYM word_add_n2w,ADD1]); + \\ fs [GSYM word_add_n2w,ADD1] +QED -Theorem asm_write_bytearray_unchanged_all_words - `∀a bs m z x. +Theorem asm_write_bytearray_unchanged_all_words: + ∀a bs m z x. ~(x ∈ all_words a (LENGTH bs)) ∧ (z = m x) ⇒ - (asm_write_bytearray (a:'a word) bs m x = z)` - (Induct_on`bs` - \\ rw[all_words_def,asm_write_bytearray_def,APPLY_UPDATE_THM]); + (asm_write_bytearray (a:'a word) bs m x = z) +Proof + Induct_on`bs` + \\ rw[all_words_def,asm_write_bytearray_def,APPLY_UPDATE_THM] +QED -Theorem asm_write_bytearray_append - `∀a l1 l2 m. +Theorem asm_write_bytearray_append: + ∀a l1 l2 m. w2n a + LENGTH l1 + LENGTH l2 < dimword (:'a) ⇒ (asm_write_bytearray (a:'a word) (l1 ++ l2) m = - asm_write_bytearray (a + n2w (LENGTH l1)) l2 (asm_write_bytearray a l1 m))` - (Induct_on`l1` \\ rw[asm_write_bytearray_def] + asm_write_bytearray (a + n2w (LENGTH l1)) l2 (asm_write_bytearray a l1 m)) +Proof + Induct_on`l1` \\ rw[asm_write_bytearray_def] \\ rw[FUN_EQ_THM, APPLY_UPDATE_THM] \\ rw[] >- ( @@ -3266,56 +3918,69 @@ Theorem asm_write_bytearray_append \\ disch_then drule \\ rw[] \\ irule mem_eq_imp_asm_write_bytearray_eq - \\ simp[APPLY_UPDATE_THM]); + \\ simp[APPLY_UPDATE_THM] +QED -Theorem asm_write_bytearray_EL - `∀a bs m x. x < LENGTH bs ∧ LENGTH bs < dimword(:'a) ⇒ - (asm_write_bytearray (a:'a word) bs m (a + n2w x) = EL x bs)` - (Induct_on`bs` +Theorem asm_write_bytearray_EL: + ∀a bs m x. x < LENGTH bs ∧ LENGTH bs < dimword(:'a) ⇒ + (asm_write_bytearray (a:'a word) bs m (a + n2w x) = EL x bs) +Proof + Induct_on`bs` \\ rw[asm_write_bytearray_def,APPLY_UPDATE_THM] \\ Cases_on`x` \\ fs[] >- ( fs[addressTheory.WORD_EQ_ADD_CANCEL] ) \\ first_x_assum drule \\ simp[ADD1,GSYM word_add_n2w] - \\ metis_tac[WORD_ADD_ASSOC,WORD_ADD_COMM]); + \\ metis_tac[WORD_ADD_ASSOC,WORD_ADD_COMM] +QED (* TODO - candidate for move to HOL *) -Theorem word_bit_thm - `!n w:'a word. word_bit n w <=> n < dimindex (:'a) /\ w ' n` - (fs [word_bit_def,LESS_EQ] \\ rw [] +Theorem word_bit_thm: + !n w:'a word. word_bit n w <=> n < dimindex (:'a) /\ w ' n +Proof + fs [word_bit_def,LESS_EQ] \\ rw [] \\ assume_tac DIMINDEX_GT_0 - \\ Cases_on `dimindex (:α)` \\ fs [LESS_EQ]); + \\ Cases_on `dimindex (:α)` \\ fs [LESS_EQ] +QED (* TODO - candidate for move to HOL *) -Theorem word_bit_and - `word_bit n (w1 && w2) <=> word_bit n w1 /\ word_bit n w2` - (fs [word_bit_def,word_and_def] \\ eq_tac \\ rw [] +Theorem word_bit_and: + word_bit n (w1 && w2) <=> word_bit n w1 /\ word_bit n w2 +Proof + fs [word_bit_def,word_and_def] \\ eq_tac \\ rw [] \\ assume_tac DIMINDEX_GT_0 \\ `n < dimindex (:'a)` by decide_tac - \\ fs [fcpTheory.FCP_BETA]); + \\ fs [fcpTheory.FCP_BETA] +QED (* TODO - candidate for move to HOL *) -Theorem word_bit_or - `word_bit n (w1 || w2) <=> word_bit n w1 \/ word_bit n w2` - (fs [word_bit_def,word_or_def] \\ eq_tac \\ rw [] +Theorem word_bit_or: + word_bit n (w1 || w2) <=> word_bit n w1 \/ word_bit n w2 +Proof + fs [word_bit_def,word_or_def] \\ eq_tac \\ rw [] \\ assume_tac DIMINDEX_GT_0 \\ `n < dimindex (:'a)` by decide_tac - \\ fs [fcpTheory.FCP_BETA]); + \\ fs [fcpTheory.FCP_BETA] +QED (* TODO - candidate for move to HOL *) -Theorem word_bit_lsl - `word_bit n (w << i) <=> - word_bit (n - i) (w:'a word) /\ n < dimindex (:'a) /\ i <= n` - (fs [word_bit_thm,word_lsl_def] \\ eq_tac \\ fs [] - \\ rw [] \\ rfs [fcpTheory.FCP_BETA]); +Theorem word_bit_lsl: + word_bit n (w << i) <=> + word_bit (n - i) (w:'a word) /\ n < dimindex (:'a) /\ i <= n +Proof + fs [word_bit_thm,word_lsl_def] \\ eq_tac \\ fs [] + \\ rw [] \\ rfs [fcpTheory.FCP_BETA] +QED (* TODO - candidate for move to HOL *) -Theorem word_msb_align - `p < dimindex(:'a) ⇒ (word_msb (align p w) = word_msb (w:'a word))` - (rw[alignmentTheory.align_bitwise_and,word_msb] +Theorem word_msb_align: + p < dimindex(:'a) ⇒ (word_msb (align p w) = word_msb (w:'a word)) +Proof + rw[alignmentTheory.align_bitwise_and,word_msb] \\ rw[word_bit_and] \\ rw[word_bit_lsl] - \\ rw[word_bit_test, MOD_EQ_0_DIVISOR, dimword_def]); + \\ rw[word_bit_test, MOD_EQ_0_DIVISOR, dimword_def] +QED (* TODO: move to sptTheory *) @@ -3326,11 +3991,12 @@ val eq_shape_def = Define ` eq_shape (BS t1 _ t2) (BS u1 _ u2) = (eq_shape t1 u1 /\ eq_shape t2 u2) /\ eq_shape _ _ = F`; -Theorem spt_eq - `!t1 t2. +Theorem spt_eq: + !t1 t2. t1 = t2 <=> - (eq_shape t1 t2 /\ (!k v. lookup k t1 = SOME v ==> lookup k t2 = SOME v))` - (Induct \\ Cases_on `t2` \\ fs [eq_shape_def,lookup_def] + (eq_shape t1 t2 /\ (!k v. lookup k t1 = SOME v ==> lookup k t2 = SOME v)) +Proof + Induct \\ Cases_on `t2` \\ fs [eq_shape_def,lookup_def] THEN1 metis_tac [] \\ rw [] \\ eq_tac \\ rw [] \\ rw [] \\ fs [] \\ first_assum (qspec_then `0` mp_tac) @@ -3338,16 +4004,21 @@ Theorem spt_eq \\ first_x_assum (qspec_then `k * 2 + 1 + 1` mp_tac) \\ fs [ONCE_REWRITE_RULE [MULT_COMM] MULT_DIV] \\ fs [ONCE_REWRITE_RULE [MULT_COMM] DIV_MULT,EVEN_ADD] - \\ fs [GSYM ADD1,EVEN,EVEN_DOUBLE]); + \\ fs [GSYM ADD1,EVEN,EVEN_DOUBLE] +QED -Theorem eq_shape_map - `!t1 t2 f. eq_shape (map f t1) t2 <=> eq_shape t1 t2` - (Induct \\ Cases_on `t2` \\ fs [eq_shape_def,map_def]); +Theorem eq_shape_map: + !t1 t2 f. eq_shape (map f t1) t2 <=> eq_shape t1 t2 +Proof + Induct \\ Cases_on `t2` \\ fs [eq_shape_def,map_def] +QED -Theorem eq_shape_IMP_domain - `!t1 t2. eq_shape t1 t2 ==> domain t1 = domain t2` - (ho_match_mp_tac (fetch "-" "eq_shape_ind") - \\ rw [] \\ fs [eq_shape_def]); +Theorem eq_shape_IMP_domain: + !t1 t2. eq_shape t1 t2 ==> domain t1 = domain t2 +Proof + ho_match_mp_tac (fetch "-" "eq_shape_ind") + \\ rw [] \\ fs [eq_shape_def] +QED val copy_shape_def = Define ` copy_shape LN LN = LN /\ @@ -3379,16 +4050,18 @@ val num_lemma = prove( (!n m. 2 * n + 2 <> 2 * m + 1n)``, rw [] \\ fs [] \\ Cases_on `m = n` \\ fs []); -Theorem shape_eq_copy_shape - `!t1 t2. domain t1 = domain t2 ==> eq_shape (copy_shape t1 t2) t2` - (Induct \\ Cases_on `t2` \\ fs [eq_shape_def,copy_shape_def] +Theorem shape_eq_copy_shape: + !t1 t2. domain t1 = domain t2 ==> eq_shape (copy_shape t1 t2) t2 +Proof + Induct \\ Cases_on `t2` \\ fs [eq_shape_def,copy_shape_def] \\ rpt strip_tac \\ TRY (first_x_assum match_mp_tac) \\ TRY (match_mp_tac eq_shape_copy_shape) \\ fs [] \\ rw [] \\ fs [eq_shape_def] \\ fs [EXTENSION] \\ TRY (first_assum (qspec_then `0` mp_tac) \\ simp_tac std_ss []) \\ rw [] \\ first_assum (qspec_then `2 * x + 2` mp_tac) \\ first_x_assum (qspec_then `2 * x + 1` mp_tac) - \\ fs [num_lemma]); + \\ fs [num_lemma] +QED val lookup_copy_shape_LN = prove( ``!s n. lookup n (copy_shape LN s) = NONE``, @@ -3400,50 +4073,57 @@ val domain_EMPTY_lookup = prove( \\ pop_assum (qspec_then `x` mp_tac) \\ Cases_on `lookup x t` \\ fs []); -Theorem lookup_copy_shape - `!t1 t2 n. lookup n (copy_shape t1 t2) = lookup n t1` - (Induct \\ Cases_on `t2` \\ fs [copy_shape_def,lookup_def] \\ rw [] - \\ fs [lookup_def,lookup_copy_shape_LN,domain_EMPTY_lookup]); +Theorem lookup_copy_shape: + !t1 t2 n. lookup n (copy_shape t1 t2) = lookup n t1 +Proof + Induct \\ Cases_on `t2` \\ fs [copy_shape_def,lookup_def] \\ rw [] + \\ fs [lookup_def,lookup_copy_shape_LN,domain_EMPTY_lookup] +QED (* / TODO *) (* BEGIN TODO: move to sptreeTheory *) -Theorem lookup_zero - `∀ n t x. (lookup n t = SOME x) ==> (size t <> 0)` - (recInduct lookup_ind +Theorem lookup_zero: + ∀ n t x. (lookup n t = SOME x) ==> (size t <> 0) +Proof + recInduct lookup_ind \\ rw[lookup_def] -); +QED -Theorem empty_sub - `isEmpty(difference a b) ∧ (subspt b a) ==> (domain a = domain b)` - (fs[subspt_def] >> +Theorem empty_sub: + isEmpty(difference a b) ∧ (subspt b a) ==> (domain a = domain b) +Proof + fs[subspt_def] >> rw[] >> imp_res_tac difference_sub >> metis_tac[GSYM SUBSET_DEF, SUBSET_ANTISYM] -); +QED -Theorem subspt_delete - `∀ a b x . subspt a b ⇒ subspt (delete x a) b` - (rw[subspt_def, lookup_delete] -); +Theorem subspt_delete: + ∀ a b x . subspt a b ⇒ subspt (delete x a) b +Proof + rw[subspt_def, lookup_delete] +QED -Theorem inter_union_empty - `∀ a b c . isEmpty (inter (union a b) c) - ⇔ isEmpty (inter a c) ∧ isEmpty (inter b c)` - (rw[] >> EQ_TAC >> rw[] >> +Theorem inter_union_empty: + ∀ a b c . isEmpty (inter (union a b) c) + ⇔ isEmpty (inter a c) ∧ isEmpty (inter b c) +Proof + rw[] >> EQ_TAC >> rw[] >> `wf (inter (union a b) c) ∧ wf (inter a c)` by metis_tac[wf_inter] >> fs[domain_empty] >> fs[EXTENSION] >> rw[] >> pop_assum (qspec_then `x` mp_tac) >> fs[domain_lookup] >> rw[] >> fs[lookup_inter, lookup_union] >> TRY(first_x_assum (qspec_then `x` mp_tac)) >> rw[] >> fs[lookup_inter, lookup_union] >> BasicProvers.EVERY_CASE_TAC >> fs[] -); +QED -Theorem inter_insert_empty - `∀ n t1 t2 . isEmpty (inter (insert n () t1) t2) - ⇒ n ∉ domain t2 ∧ isEmpty(inter t1 t2)` - (rw[] >> +Theorem inter_insert_empty: + ∀ n t1 t2 . isEmpty (inter (insert n () t1) t2) + ⇒ n ∉ domain t2 ∧ isEmpty(inter t1 t2) +Proof + rw[] >> `∀ k . lookup k (inter (insert n () t1) t2) = NONE` by fs[lookup_def] >- (fs[domain_lookup] >> rw[] >> fs[lookup_inter] >> pop_assum (qspec_then `n` mp_tac) >> @@ -3455,22 +4135,24 @@ Theorem inter_insert_empty fs[domain_lookup, lookup_inter, lookup_insert] >> Cases_on `x = n` >> fs[] >> Cases_on `lookup n t2` >> fs[] >> CASE_TAC) -); +QED -Theorem fromList2_value - `∀ e l t n . MEM e l ⇔ ∃ n . lookup n (fromList2 l) = SOME e` - (rw[lookup_fromList2] >> rw[lookup_fromList] >> fs[MEM_EL] >> +Theorem fromList2_value: + ∀ e l t n . MEM e l ⇔ ∃ n . lookup n (fromList2 l) = SOME e +Proof + rw[lookup_fromList2] >> rw[lookup_fromList] >> fs[MEM_EL] >> EQ_TAC >> rw[] >- (qexists_tac `n * 2` >> fs[] >> once_rewrite_tac [MULT_COMM] >> rw[EVEN_DOUBLE, MULT_DIV]) >- (qexists_tac `n DIV 2` >> fs[]) -); +QED -Theorem wf_spt_fold_tree - `∀ tree : num_set num_map y : num_set. +Theorem wf_spt_fold_tree: + ∀ tree : num_set num_map y : num_set. wf tree ∧ (∀ n x . (lookup n tree = SOME x) ⇒ wf x) ∧ wf y - ⇒ wf(spt_fold union y tree)` - (Induct >> rw[] >> fs[spt_fold_def] + ⇒ wf(spt_fold union y tree) +Proof + Induct >> rw[] >> fs[spt_fold_def] >- (fs[wf_def] >> metis_tac[lookup_def, wf_union]) >> `wf(spt_fold union y tree)` by ( last_x_assum match_mp_tac >> @@ -3488,14 +4170,15 @@ Theorem wf_spt_fold_tree >> `wf a` by (last_x_assum match_mp_tac >> qexists_tac `0` >> fs[lookup_def]) >> fs[wf_union]) -); +QED -Theorem lookup_spt_fold_union - `∀ tree : num_set num_map y : num_set n : num . +Theorem lookup_spt_fold_union: + ∀ tree : num_set num_map y : num_set n : num . lookup n (spt_fold union y tree) = SOME () ⇒ lookup n y = SOME () ∨ - ∃ n1 s . lookup n1 tree = SOME s ∧ lookup n s = SOME ()` - (Induct >> rw[] + ∃ n1 s . lookup n1 tree = SOME s ∧ lookup n s = SOME () +Proof + Induct >> rw[] >- fs[spt_fold_def] >- (fs[spt_fold_def, lookup_union] >> BasicProvers.EVERY_CASE_TAC >> fs[] >> @@ -3573,14 +4256,15 @@ Theorem lookup_spt_fold_union fs[MULT_DIV] ) ) -); +QED -Theorem lookup_spt_fold_union_STRONG - `∀ tree : num_set num_map y : num_set n : num . +Theorem lookup_spt_fold_union_STRONG: + ∀ tree : num_set num_map y : num_set n : num . lookup n (spt_fold union y tree) = SOME () <=> lookup n y = SOME () ∨ - ∃ n1 s . lookup n1 tree = SOME s ∧ lookup n s = SOME ()` - (Induct >> rw[] >> EQ_TAC >> fs[lookup_spt_fold_union] >> rw[] >> + ∃ n1 s . lookup n1 tree = SOME s ∧ lookup n s = SOME () +Proof + Induct >> rw[] >> EQ_TAC >> fs[lookup_spt_fold_union] >> rw[] >> fs[spt_fold_def, lookup_def, lookup_union] >- (BasicProvers.EVERY_CASE_TAC >> fs[]) >- (BasicProvers.EVERY_CASE_TAC >> fs[] @@ -3597,13 +4281,14 @@ Theorem lookup_spt_fold_union_STRONG >- (DISJ2_TAC >> qexists_tac `(n1 - 1) DIV 2` >> qexists_tac `s` >> fs[]) ) -); +QED -Theorem subspt_domain_spt_fold_union - `∀ t1 : num_set num_map t2 y : num_set . +Theorem subspt_domain_spt_fold_union: + ∀ t1 : num_set num_map t2 y : num_set . subspt t1 t2 - ⇒ domain (spt_fold union y t1) ⊆ domain (spt_fold union y t2)` - (rw[SUBSET_DEF] >> fs[domain_lookup] >> + ⇒ domain (spt_fold union y t1) ⊆ domain (spt_fold union y t2) +Proof + rw[SUBSET_DEF] >> fs[domain_lookup] >> qspecl_then [`t1`, `y`] mp_tac lookup_spt_fold_union_STRONG >> qspecl_then [`t2`, `y`] mp_tac lookup_spt_fold_union_STRONG >> ntac 2 strip_tac >> res_tac @@ -3611,60 +4296,69 @@ Theorem subspt_domain_spt_fold_union >> ntac 2 (first_x_assum kall_tac) >> `lookup n1 t2 = SOME s` by fs[subspt_def, domain_lookup] >> metis_tac[] -); +QED -Theorem domain_spt_fold_union - `∀ tree : num_set num_map y : num_set . +Theorem domain_spt_fold_union: + ∀ tree : num_set num_map y : num_set . (∀ k v . lookup k tree = SOME v ⇒ domain v ⊆ domain tree) - ⇒ domain (spt_fold union y tree) ⊆ domain y ∪ domain tree` - (rw[] >> qspec_then `tree` mp_tac lookup_spt_fold_union >> + ⇒ domain (spt_fold union y tree) ⊆ domain y ∪ domain tree +Proof + rw[] >> qspec_then `tree` mp_tac lookup_spt_fold_union >> rw[] >> fs[SUBSET_DEF, domain_lookup] >> rw[] >> res_tac >> fs[] >> metis_tac[] -); +QED -Theorem domain_spt_fold_union_LN - `∀ tree : num_set num_map . +Theorem domain_spt_fold_union_LN: + ∀ tree : num_set num_map . (∀ k v . lookup k tree = SOME v ⇒ domain v ⊆ domain tree) - ⇔ domain (spt_fold union LN tree) ⊆ domain tree` - (rw[] >> EQ_TAC >> rw[] + ⇔ domain (spt_fold union LN tree) ⊆ domain tree +Proof + rw[] >> EQ_TAC >> rw[] >- (drule domain_spt_fold_union >> strip_tac >> first_x_assum (qspec_then `LN` mp_tac) >> fs[]) >- (qspec_then `tree` mp_tac lookup_spt_fold_union_STRONG >> rw[] >> fs[SUBSET_DEF, domain_lookup, lookup_def] >> rw[] >> metis_tac[]) -); +QED (* END TODO *) -Theorem TWOxDIV2 - `2 * x DIV 2 = x` - (ONCE_REWRITE_TAC[MULT_COMM] - \\ simp[MULT_DIV]); +Theorem TWOxDIV2: + 2 * x DIV 2 = x +Proof + ONCE_REWRITE_TAC[MULT_COMM] + \\ simp[MULT_DIV] +QED -Theorem alist_insert_pull_insert - `∀xs ys z. ¬MEM x xs ⇒ +Theorem alist_insert_pull_insert: + ∀xs ys z. ¬MEM x xs ⇒ alist_insert xs ys (insert x y z) = - insert x y (alist_insert xs ys z)` - (ho_match_mp_tac alist_insert_ind + insert x y (alist_insert xs ys z) +Proof + ho_match_mp_tac alist_insert_ind \\ simp[alist_insert_def] \\ rw[] \\ fs[] - \\ metis_tac[insert_swap]); + \\ metis_tac[insert_swap] +QED -Theorem alist_insert_REVERSE - `∀xs ys s. +Theorem alist_insert_REVERSE: + ∀xs ys s. ALL_DISTINCT xs ∧ LENGTH xs = LENGTH ys ⇒ - alist_insert (REVERSE xs) (REVERSE ys) s = alist_insert xs ys s` - (Induct \\ simp[alist_insert_def] + alist_insert (REVERSE xs) (REVERSE ys) s = alist_insert xs ys s +Proof + Induct \\ simp[alist_insert_def] \\ gen_tac \\ Cases \\ simp[alist_insert_def] \\ simp[alist_insert_append,alist_insert_def] - \\ rw[] \\ simp[alist_insert_pull_insert]); + \\ rw[] \\ simp[alist_insert_pull_insert] +QED -Theorem alist_insert_ALL_DISTINCT ` - ∀xs ys t ls. +Theorem alist_insert_ALL_DISTINCT: + ∀xs ys t ls. ALL_DISTINCT xs ∧ LENGTH xs = LENGTH ys ∧ PERM (ZIP (xs,ys)) ls ⇒ - alist_insert xs ys t = alist_insert (MAP FST ls) (MAP SND ls) t` - (ho_match_mp_tac alist_insert_ind>>rw[]>> + alist_insert xs ys t = alist_insert (MAP FST ls) (MAP SND ls) t +Proof + ho_match_mp_tac alist_insert_ind>>rw[]>> fs[LENGTH_NIL_SYM]>>rveq>>fs[ZIP]>> simp[alist_insert_def]>> fs[PERM_CONS_EQ_APPEND]>> @@ -3678,37 +4372,45 @@ Theorem alist_insert_ALL_DISTINCT ` fs[EL_MEM])>> simp[alist_insert_pull_insert]>> simp[GSYM alist_insert_append]>> - metis_tac[MAP_APPEND]) + metis_tac[MAP_APPEND] +QED -Theorem n2w_lt - `(0w:'a word) < n2w a ∧ (0w:'a word) < n2w b ∧ +Theorem n2w_lt: + (0w:'a word) < n2w a ∧ (0w:'a word) < n2w b ∧ a < dimword (:'a) ∧ b < dimword (:'a) ⇒ - ((n2w a:'a word) < (n2w b:'a word) ⇔ a < b)` - (simp[word_lt_n2w]); + ((n2w a:'a word) < (n2w b:'a word) ⇔ a < b) +Proof + simp[word_lt_n2w] +QED -Theorem n2w_le - `(0w:'a word) < n2w a ∧ (0w:'a word) < n2w b ∧ +Theorem n2w_le: + (0w:'a word) < n2w a ∧ (0w:'a word) < n2w b ∧ a < dimword (:'a) ∧ b < dimword (:'a) ⇒ - ((n2w a:'a word) ≤ (n2w b:'a word) ⇔ a ≤ b)` - (srw_tac[][WORD_LESS_OR_EQ,LESS_OR_EQ] - \\ metis_tac[n2w_lt]); + ((n2w a:'a word) ≤ (n2w b:'a word) ⇔ a ≤ b) +Proof + srw_tac[][WORD_LESS_OR_EQ,LESS_OR_EQ] + \\ metis_tac[n2w_lt] +QED -Theorem word_lt_0w - `2 * n < dimword (:'a) ⇒ ((0w:'a word) < n2w n ⇔ 0 < n)` - (simp[WORD_LT] +Theorem word_lt_0w: + 2 * n < dimword (:'a) ⇒ ((0w:'a word) < n2w n ⇔ 0 < n) +Proof + simp[WORD_LT] \\ Cases_on`0 < n` \\ simp[] \\ simp[word_msb_n2w_numeric] \\ simp[NOT_LESS_EQUAL] \\ simp[INT_MIN_def] \\ simp[dimword_def] \\ Cases_on`dimindex(:'a)`\\simp[] - \\ simp[EXP]); + \\ simp[EXP] +QED -Theorem word_sub_lt - `0w < n ∧ 0w < m ∧ n ≤ m ⇒ m - n < m` - (rpt strip_tac +Theorem word_sub_lt: + 0w < n ∧ 0w < m ∧ n ≤ m ⇒ m - n < m +Proof + rpt strip_tac \\ Cases_on`m`>>Cases_on`n` \\ qpat_x_assum`_ ≤ _`mp_tac \\ asm_simp_tac std_ss [n2w_le] @@ -3723,7 +4425,8 @@ Theorem word_sub_lt >- ( dep_rewrite.DEP_ONCE_REWRITE_TAC[n2w_lt] \\ simp[]) - \\ full_simp_tac(srw_ss())[word_lt_n2w,LET_THM]); + \\ full_simp_tac(srw_ss())[word_lt_n2w,LET_THM] +QED (* see #521 *) @@ -3732,63 +4435,72 @@ val bytes_in_memory_def = Define ` (bytes_in_memory a ((x:word8)::xs) m dm <=> (m a = x) /\ a IN dm /\ bytes_in_memory (a + 1w) xs m dm)` -Theorem bytes_in_memory_APPEND - `!l1 l2 pc mem mem_domain. +Theorem bytes_in_memory_APPEND: + !l1 l2 pc mem mem_domain. bytes_in_memory pc (l1 ++ l2) mem mem_domain <=> bytes_in_memory pc l1 mem mem_domain /\ - bytes_in_memory (pc + n2w (LENGTH l1)) l2 mem mem_domain` - (Induct + bytes_in_memory (pc + n2w (LENGTH l1)) l2 mem mem_domain +Proof + Induct THEN ASM_SIMP_TAC list_ss [bytes_in_memory_def, wordsTheory.WORD_ADD_0, wordsTheory.word_add_n2w, GSYM wordsTheory.WORD_ADD_ASSOC, arithmeticTheory.ADD1] THEN DECIDE_TAC - ) +QED -Theorem bytes_in_memory_change_domain - `∀a bs m md1 md2. +Theorem bytes_in_memory_change_domain: + ∀a bs m md1 md2. bytes_in_memory a bs m md1 ∧ (∀n. n < LENGTH bs ∧ a + n2w n ∈ md1 ⇒ a + n2w n ∈ md2) - ⇒ bytes_in_memory a bs m md2` - (Induct_on`bs` + ⇒ bytes_in_memory a bs m md2 +Proof + Induct_on`bs` \\ rw[bytes_in_memory_def] >- ( first_x_assum(qspec_then`0`mp_tac) \\ rw[] ) \\ first_x_assum irule \\ goal_assum(first_assum o mp_then Any mp_tac) \\ strip_tac \\ first_x_assum(qspec_then`SUC n`mp_tac) - \\ simp[ADD1,GSYM word_add_n2w]); + \\ simp[ADD1,GSYM word_add_n2w] +QED -Theorem bytes_in_memory_change_mem - `∀a bs m1 m2 md. +Theorem bytes_in_memory_change_mem: + ∀a bs m1 m2 md. bytes_in_memory a bs m1 md ∧ (∀n. n < LENGTH bs ⇒ (m1 (a + n2w n) = m2 (a + n2w n))) - ⇒ bytes_in_memory a bs m2 md` - (Induct_on`bs` + ⇒ bytes_in_memory a bs m2 md +Proof + Induct_on`bs` \\ rw[bytes_in_memory_def] >- ( first_x_assum(qspec_then`0`mp_tac) \\ rw[] ) \\ first_x_assum irule \\ goal_assum(first_assum o mp_then Any mp_tac) \\ strip_tac \\ first_x_assum(qspec_then`SUC n`mp_tac) - \\ simp[ADD1,GSYM word_add_n2w]); + \\ simp[ADD1,GSYM word_add_n2w] +QED -Theorem bytes_in_memory_EL - `∀a bs m md k. bytes_in_memory a bs m md ∧ k < LENGTH bs ⇒ (m (a + n2w k) = EL k bs)` - (Induct_on`bs` +Theorem bytes_in_memory_EL: + ∀a bs m md k. bytes_in_memory a bs m md ∧ k < LENGTH bs ⇒ (m (a + n2w k) = EL k bs) +Proof + Induct_on`bs` \\ rw[bytes_in_memory_def] \\ Cases_on`k` \\ fs[] \\ first_x_assum drule \\ disch_then drule - \\ simp[ADD1, GSYM word_add_n2w]); + \\ simp[ADD1, GSYM word_add_n2w] +QED -Theorem bytes_in_memory_in_domain - `∀a bs m md k. bytes_in_memory a bs m md ∧ k < LENGTH bs ⇒ ((a + n2w k) ∈ md)` - (Induct_on`bs` +Theorem bytes_in_memory_in_domain: + ∀a bs m md k. bytes_in_memory a bs m md ∧ k < LENGTH bs ⇒ ((a + n2w k) ∈ md) +Proof + Induct_on`bs` \\ rw[bytes_in_memory_def] \\ Cases_on`k` \\ fs[] \\ first_x_assum drule \\ disch_then drule - \\ simp[ADD1, GSYM word_add_n2w]); + \\ simp[ADD1, GSYM word_add_n2w] +QED val bytes_in_mem_def = Define ` (bytes_in_mem a [] m md k <=> T) /\ @@ -3796,29 +4508,33 @@ val bytes_in_mem_def = Define ` a IN md /\ ~(a IN k) /\ (m a = b) /\ bytes_in_mem (a+1w) bs m md k)` -Theorem bytes_in_mem_IMP - `!xs p. bytes_in_mem p xs m dm dm1 ==> bytes_in_memory p xs m dm` - (Induct \\ full_simp_tac(srw_ss())[bytes_in_mem_def,bytes_in_memory_def]); +Theorem bytes_in_mem_IMP: + !xs p. bytes_in_mem p xs m dm dm1 ==> bytes_in_memory p xs m dm +Proof + Induct \\ full_simp_tac(srw_ss())[bytes_in_mem_def,bytes_in_memory_def] +QED -Theorem fun2set_disjoint_union - ` - DISJOINT d1 d2 ∧ +Theorem fun2set_disjoint_union: + DISJOINT d1 d2 ∧ p (fun2set (m,d1)) ∧ q (fun2set (m,d2)) - ⇒ (p * q) (fun2set (m,d1 ∪ d2))` - (rw[set_sepTheory.fun2set_def,set_sepTheory.STAR_def,set_sepTheory.SPLIT_def] + ⇒ (p * q) (fun2set (m,d1 ∪ d2)) +Proof + rw[set_sepTheory.fun2set_def,set_sepTheory.STAR_def,set_sepTheory.SPLIT_def] \\ first_assum(part_match_exists_tac (last o strip_conj) o concl) \\ simp[] \\ first_assum(part_match_exists_tac (last o strip_conj) o concl) \\ simp[] \\ simp[EXTENSION] \\ conj_tac >- metis_tac[] - \\ fs[IN_DISJOINT,FORALL_PROD]); + \\ fs[IN_DISJOINT,FORALL_PROD] +QED -Theorem WORD_LS_IMP - `a <=+ b ==> +Theorem WORD_LS_IMP: + a <=+ b ==> ?k. Abbrev (b = a + n2w k) /\ w2n (b - a) = k /\ - (!w. a <=+ w /\ w <+ b <=> ?i. w = a + n2w i /\ i < k)` - (Cases_on `a` \\ Cases_on `b` \\ fs [WORD_LS] + (!w. a <=+ w /\ w <+ b <=> ?i. w = a + n2w i /\ i < k) +Proof + Cases_on `a` \\ Cases_on `b` \\ fs [WORD_LS] \\ fs [markerTheory.Abbrev_def] \\ full_simp_tac std_ss [GSYM word_sub_def,addressTheory.word_arith_lemma2] \\ fs [] \\ rw [] THEN1 @@ -3827,6 +4543,7 @@ Theorem WORD_LS_IMP \\ rewrite_tac [WORD_ADD_SUB]) \\ Cases_on `w` \\ fs [WORD_LO,word_add_n2w] \\ eq_tac \\ rw [] \\ fs [] - \\ rename1 `k < m:num` \\ qexists_tac `k - n` \\ fs []) + \\ rename1 `k < m:num` \\ qexists_tac `k - n` \\ fs [] +QED val _ = export_theory() diff --git a/semantics/alt_semantics/proofs/bigClockScript.sml b/semantics/alt_semantics/proofs/bigClockScript.sml index 7a5ca20d0a..7435f81c6e 100644 --- a/semantics/alt_semantics/proofs/bigClockScript.sml +++ b/semantics/alt_semantics/proofs/bigClockScript.sml @@ -84,20 +84,22 @@ val with_clock_with_clock = Q.prove ( `(s with clock := a) with clock := b = (s with clock := b)`, rw [state_component_equality]); -Theorem big_unclocked -`!s env e s' r count1 count2. +Theorem big_unclocked: + !s env e s' r count1 count2. (evaluate F env ^s e (s', r) ⇒ r ≠ Rerr (Rabort Rtimeout_error) ∧ s.clock = s'.clock) ∧ (evaluate F env (^s with clock := count1) e (s' with clock := count1, r) ⇒ - evaluate F env (^s with clock := count2) e (s' with clock := count2, r))` - (rw [] >> - metis_tac [big_unclocked_ignore, big_unclocked_unchanged, FST, SND, with_clock_with_clock]); + evaluate F env (^s with clock := count2) e (s' with clock := count2, r)) +Proof + rw [] >> + metis_tac [big_unclocked_ignore, big_unclocked_unchanged, FST, SND, with_clock_with_clock] +QED -Theorem add_to_counter - `(∀ck env ^s e r1. +Theorem add_to_counter: + (∀ck env ^s e r1. evaluate ck env s e r1 ⇒ !s' r' extra. (r1 = (s',r')) ∧ @@ -117,8 +119,9 @@ Theorem add_to_counter (r1 = (s',r')) ∧ (r' ≠ Rerr (Rabort Rtimeout_error)) ∧ (ck = T) ⇒ - evaluate_match T env (s with clock := s.clock+extra) v pes err_v ((s' with clock := s'.clock+extra),r'))` - (ho_match_mp_tac evaluate_ind >> + evaluate_match T env (s with clock := s.clock+extra) v pes err_v ((s' with clock := s'.clock+extra),r')) +Proof + ho_match_mp_tac evaluate_ind >> rw [] >> rw [Once evaluate_cases] >> fs[] >> rfs[] >> TRY (metis_tac[]) >> @@ -128,7 +131,8 @@ Theorem add_to_counter simp[] >> fsrw_tac[ARITH_ss][] >> `extra + s2.clock - 1 = s2.clock -1 + extra` by DECIDE_TAC >> - metis_tac []); + metis_tac [] +QED val with_clock_clock = Q.prove( `(s with clock := a).clock = a`,rw[]); @@ -197,14 +201,16 @@ val clock_monotone = Q.prove ( val with_same_clock = Q.prove( `(s with clock := s.clock) = s`,rw[state_component_equality]) -Theorem big_clocked_unclocked_equiv - `!s env e s' r1. +Theorem big_clocked_unclocked_equiv: + !s env e s' r1. evaluate F env s e (s', r1) = ?c. evaluate T env (s with clock := c) e (s' with clock := 0,r1) ∧ (r1 ≠ Rerr (Rabort Rtimeout_error)) ∧ - (s.clock = s'.clock)` - (metis_tac [with_clock_clock, with_same_clock, add_clock, - big_unclocked_ignore, big_unclocked]); + (s.clock = s'.clock) +Proof + metis_tac [with_clock_clock, with_same_clock, add_clock, + big_unclocked_ignore, big_unclocked] +QED val wf_lem = Q.prove ( `WF (($< :(num->num->bool)) LEX measure exp_size)`, @@ -448,13 +454,15 @@ val big_clocked_total_lem = Q.prove ( >- ((* Lannot *) rw [exp_size_def])); -Theorem big_clocked_total - `!s env e. - ∃s' r. evaluate T env s e (s', r)` - (metis_tac [big_clocked_total_lem, FST, SND, with_same_clock]); +Theorem big_clocked_total: + !s env e. + ∃s' r. evaluate T env s e (s', r) +Proof + metis_tac [big_clocked_total_lem, FST, SND, with_same_clock] +QED -Theorem big_clocked_timeout_0 - `(∀ck env ^s e r1. +Theorem big_clocked_timeout_0: + (∀ck env ^s e r1. evaluate ck env s e r1 ⇒ !s'. (r1 = (s',Rerr (Rabort Rtimeout_error))) ∧ @@ -474,29 +482,33 @@ Theorem big_clocked_timeout_0 (r1 = (s',Rerr (Rabort Rtimeout_error))) ∧ (ck = T) ⇒ - (s'.clock = 0))` - (ho_match_mp_tac evaluate_ind >> + (s'.clock = 0)) +Proof + ho_match_mp_tac evaluate_ind >> rw [] >> fs[do_app_cases] >> rw [] >> fs [] >> - every_case_tac >> fs[] >> rveq >> fs[]); + every_case_tac >> fs[] >> rveq >> fs[] +QED -Theorem big_clocked_unclocked_equiv_timeout - `!s env e. +Theorem big_clocked_unclocked_equiv_timeout: + !s env e. (!r. ¬evaluate F env s e r) = - (∀c. ?s'. evaluate T env (s with clock := c) e (s',Rerr (Rabort Rtimeout_error)) ∧ s'.clock = 0)` - (rw [] >> + (∀c. ?s'. evaluate T env (s with clock := c) e (s',Rerr (Rabort Rtimeout_error)) ∧ s'.clock = 0) +Proof + rw [] >> eq_tac >> rw [] >| [`?s1 r1. evaluate T env (s with clock := c) e (s1,r1)` by metis_tac [big_clocked_total] >> metis_tac [big_unclocked_ignore, big_unclocked,big_clocked_timeout_0, with_clock_clock, with_same_clock, result_distinct,result_11, error_result_distinct,result_nchotomy, error_result_nchotomy], - metis_tac [big_exp_determ, pair_CASES, PAIR_EQ, big_unclocked, add_clock]]); + metis_tac [big_exp_determ, pair_CASES, PAIR_EQ, big_unclocked, add_clock]] +QED -Theorem sub_from_counter -`(∀ck env ^s e r1. +Theorem sub_from_counter: + (∀ck env ^s e r1. evaluate ck env s e r1 ⇒ !count count' s' r'. (s.clock = count+extra) ∧ @@ -519,8 +531,9 @@ Theorem sub_from_counter (r1 = (s',r')) ∧ s'.clock = count' + extra ∧ (ck = T) ⇒ - evaluate_match T env (s with clock := count) v pes err_v (s' with clock := count',r'))` - (ho_match_mp_tac evaluate_strongind >> + evaluate_match T env (s with clock := count) v pes err_v (s' with clock := count',r')) +Proof + ho_match_mp_tac evaluate_strongind >> rw [] >> rw [Once evaluate_cases] >> full_simp_tac (srw_ss()++ARITH_ss) [state_component_equality] @@ -546,44 +559,52 @@ Theorem sub_from_counter qexists_tac `vs` >> qexists_tac `s2 with clock := count''` >> rw []) >> - metis_tac [pair_CASES, FST, clock_monotone, DECIDE ``y + z ≤ x ⇒ (x = (x - z) + z:num)``]); + metis_tac [pair_CASES, FST, clock_monotone, DECIDE ``y + z ≤ x ⇒ (x = (x - z) + z:num)``] +QED -Theorem clocked_min_counter -`!s env e s' r'. +Theorem clocked_min_counter: + !s env e s' r'. evaluate T env s e (s',r') ⇒ -evaluate T env (s with clock := s.clock - s'.clock) e (s' with clock := 0, r')` - (rw [] >> +evaluate T env (s with clock := s.clock - s'.clock) e (s' with clock := 0, r') +Proof + rw [] >> `s'.clock ≤ s.clock` by metis_tac [clock_monotone, PAIR_EQ, FST, SND, pair_CASES] >> `s'.clock = 0 + s'.clock ∧ s.clock = (s.clock - s'.clock) + s'.clock:num` by decide_tac >> - metis_tac [sub_from_counter]); + metis_tac [sub_from_counter] +QED (* -Theorem dec_evaluate_not_timeout -`!mn s env d s' r. - evaluate_dec F mn env s d (s', r) ⇒ r ≠ Rerr (Rabort Rtimeout_error)` -(rw [evaluate_dec_cases] >> -metis_tac [big_unclocked]); - -Theorem dec_unclocked -`!mn count s env d count' s' r. +Theorem dec_evaluate_not_timeout: + !mn s env d s' r. + evaluate_dec F mn env s d (s', r) ⇒ r ≠ Rerr (Rabort Rtimeout_error) +Proof +rw [evaluate_dec_cases] >> +metis_tac [big_unclocked] +QED + +Theorem dec_unclocked: + !mn count s env d count' s' r. (evaluate_dec F mn env s d (s', r) ⇒ (r ≠ Rerr (Rabort Rtimeout_error)) ∧ s.clock = s'.clock) ∧ (evaluate_dec F mn env (s with clock := count) d (s' with clock := count, r) = - evaluate_dec F mn env (s with clock := count') d (s' with clock := count', r))` - (rw [evaluate_dec_cases] >> + evaluate_dec F mn env (s with clock := count') d (s' with clock := count', r)) +Proof + rw [evaluate_dec_cases] >> rw [] >> fs [state_component_equality] >> - metis_tac [big_unclocked]); + metis_tac [big_unclocked] +QED -Theorem not_evaluate_dec_timeout -`∀mn env s d. +Theorem not_evaluate_dec_timeout: + ∀mn env s d. (∀r. ¬evaluate_dec F mn env s d r) ⇒ - ∃r. evaluate_dec T mn env s d r ∧ (SND r = Rerr (Rabort Rtimeout_error))` - (rpt gen_tac >> + ∃r. evaluate_dec T mn env s d r ∧ (SND r = Rerr (Rabort Rtimeout_error)) +Proof + rpt gen_tac >> reverse(Cases_on`d`)>> simp[Once evaluate_dec_cases] >- metis_tac[] >- metis_tac[] @@ -597,91 +618,109 @@ Theorem not_evaluate_dec_timeout Cases_on`r1`>>fs[METIS_PROVE[]``P ∨ Q ⇔ ¬P ⇒ Q``] >> res_tac >> metis_tac[match_result_nchotomy] ) >> fs [big_clocked_unclocked_equiv_timeout] >> - metis_tac[with_same_clock]); + metis_tac[with_same_clock] +QED -Theorem dec_clocked_total -`∀mn env s d. ∃res. evaluate_dec T mn env s d res` - (rpt gen_tac >> +Theorem dec_clocked_total: + ∀mn env s d. ∃res. evaluate_dec T mn env s d res +Proof + rpt gen_tac >> reverse(Cases_on`d`)>>simp[Once evaluate_dec_cases] >> srw_tac[DNF_ss][] >- metis_tac[] >> qspecl_then[`s`,`env`,`e`]strip_assume_tac big_clocked_total >> - Cases_on`r`>>metis_tac[match_result_nchotomy, pair_CASES]); - -Theorem dec_clocked_min_counter -`∀ck mn env ^s d res. evaluate_dec ck mn env s d res ⇒ - ck ⇒ evaluate_dec ck mn env (s with clock := s.clock - (FST res).clock) d ((FST res) with clock := 0, SND res)` - (ho_match_mp_tac evaluate_dec_ind >> rw[] >> + Cases_on`r`>>metis_tac[match_result_nchotomy, pair_CASES] +QED + +Theorem dec_clocked_min_counter: + ∀ck mn env ^s d res. evaluate_dec ck mn env s d res ⇒ + ck ⇒ evaluate_dec ck mn env (s with clock := s.clock - (FST res).clock) d ((FST res) with clock := 0, SND res) +Proof + ho_match_mp_tac evaluate_dec_ind >> rw[] >> rw[Once evaluate_dec_cases] >> imp_res_tac clocked_min_counter >> rw[] >> srw_tac[DNF_ss][] >> TRY disj1_tac >> - metis_tac []); + metis_tac [] +QED -Theorem dec_clocked_unclocked_equiv -`∀mn env s1 s2 d r. +Theorem dec_clocked_unclocked_equiv: + ∀mn env s1 s2 d r. evaluate_dec F mn env s1 d (s2,r) ⇔ ∃c. evaluate_dec T mn env (s1 with clock := c) d (s2 with clock := 0,r) ∧ - r ≠ Rerr (Rabort Rtimeout_error) ∧ s1.clock = s2.clock` - (Cases_on`d`>>simp[evaluate_dec_cases]>>rw[]>> + r ≠ Rerr (Rabort Rtimeout_error) ∧ s1.clock = s2.clock +Proof + Cases_on`d`>>simp[evaluate_dec_cases]>>rw[]>> fs[big_clocked_unclocked_equiv]>> srw_tac[DNF_ss][EQ_IMP_THM]>> simp [state_component_equality] >> fs [state_component_equality] >> - metis_tac[]); + metis_tac[] +QED -Theorem dec_sub_from_counter - `∀ck mn env ^s d res. evaluate_dec ck mn env s d res ⇒ +Theorem dec_sub_from_counter: + ∀ck mn env ^s d res. evaluate_dec ck mn env s d res ⇒ ∀extra count count' s' r. s.clock = count + extra ∧ s'.clock = count' + extra ∧ res = (s',r) ∧ ck ⇒ - evaluate_dec ck mn env (s with clock := count) d (s' with clock := count',r)` - (ho_match_mp_tac evaluate_dec_ind >> rw[] >> + evaluate_dec ck mn env (s with clock := count) d (s' with clock := count',r) +Proof + ho_match_mp_tac evaluate_dec_ind >> rw[] >> rw[evaluate_dec_cases] >> imp_res_tac sub_from_counter >> fs[] >> - metis_tac[]); - -Theorem dec_clock_monotone -`∀ck mn env ^s d res. evaluate_dec ck mn env s d res ⇒ ck ⇒ (FST res).clock ≤ s.clock` - (ho_match_mp_tac evaluate_dec_ind >> rw[] >> - imp_res_tac clock_monotone >> fs[]); - -Theorem dec_add_clock - `∀ck mn env ^s d res. evaluate_dec ck mn env s d res ⇒ + metis_tac[] +QED + +Theorem dec_clock_monotone: + ∀ck mn env ^s d res. evaluate_dec ck mn env s d res ⇒ ck ⇒ (FST res).clock ≤ s.clock +Proof + ho_match_mp_tac evaluate_dec_ind >> rw[] >> + imp_res_tac clock_monotone >> fs[] +QED + +Theorem dec_add_clock: + ∀ck mn env ^s d res. evaluate_dec ck mn env s d res ⇒ ∀s' r. res = (s',r) ∧ ¬ck ⇒ - ∃c. evaluate_dec T mn env (s with clock := c) d (s' with clock := 0, r)` - (ho_match_mp_tac evaluate_dec_ind >> rw[] >> + ∃c. evaluate_dec T mn env (s with clock := c) d (s' with clock := 0, r) +Proof + ho_match_mp_tac evaluate_dec_ind >> rw[] >> rw[Once evaluate_dec_cases] >> imp_res_tac add_clock >> fs[] >> - metis_tac[]); + metis_tac[] +QED -Theorem dec_add_to_counter - `∀ck mn env ^s d res. evaluate_dec ck mn env s d res ⇒ +Theorem dec_add_to_counter: + ∀ck mn env ^s d res. evaluate_dec ck mn env s d res ⇒ ∀r2 r3 extra. res = (r2,r3) ∧ ck ∧ r3 ≠ Rerr (Rabort Rtimeout_error) ⇒ - evaluate_dec T mn env (s with clock := s.clock + extra) d (r2 with clock := r2.clock + extra,r3)` - (ho_match_mp_tac evaluate_dec_ind >> rw[] >> + evaluate_dec T mn env (s with clock := s.clock + extra) d (r2 with clock := r2.clock + extra,r3) +Proof + ho_match_mp_tac evaluate_dec_ind >> rw[] >> rw[Once evaluate_dec_cases] >> imp_res_tac add_to_counter >> fs[] >> - metis_tac[]); + metis_tac[] +QED -Theorem dec_unclocked_ignore - `∀ck mn env ^s d res. evaluate_dec ck mn env s d res ⇒ +Theorem dec_unclocked_ignore: + ∀ck mn env ^s d res. evaluate_dec ck mn env s d res ⇒ ∀r2 r3 count. res = (r2,r3) ∧ r3 ≠ Rerr (Rabort Rtimeout_error) ⇒ - evaluate_dec F mn env (s with clock := count) d (r2 with clock := count,r3)` - (ho_match_mp_tac evaluate_dec_ind >> rw[] >> + evaluate_dec F mn env (s with clock := count) d (r2 with clock := count,r3) +Proof + ho_match_mp_tac evaluate_dec_ind >> rw[] >> rw[Once evaluate_dec_cases] >> imp_res_tac big_unclocked_ignore >> fs[] >> - metis_tac[]); + metis_tac[] +QED -Theorem decs_add_clock - `∀ck mn env ^s d res. evaluate_decs ck mn env s d res ⇒ +Theorem decs_add_clock: + ∀ck mn env ^s d res. evaluate_decs ck mn env s d res ⇒ ∀r2 r3. res = (r2,r3) ∧ ¬ck ⇒ - ∃c. evaluate_decs T mn env (s with clock := c) d (r2 with clock := 0,r3)` - (ho_match_mp_tac evaluate_decs_ind >> rw[] >> + ∃c. evaluate_decs T mn env (s with clock := c) d (r2 with clock := 0,r3) +Proof + ho_match_mp_tac evaluate_decs_ind >> rw[] >> rw[Once evaluate_decs_cases] >> imp_res_tac dec_add_clock >> fs[] >- metis_tac[] >> @@ -690,13 +729,15 @@ Theorem decs_add_clock CONV_TAC(STRIP_BINDER_CONV(SOME existential)(move_conj_left(same_const``evaluate_decs`` o fst o strip_comb))) >> first_assum(match_exists_tac o concl) >> simp[] >> imp_res_tac dec_add_to_counter >> fs[] >> - metis_tac[]); + metis_tac[] +QED -Theorem decs_evaluate_not_timeout - `!ck mn env ^s ds r. +Theorem decs_evaluate_not_timeout: + !ck mn env ^s ds r. evaluate_decs ck mn env s ds r ⇒ - !s' r'. ck = F ∧ r = (s', r') ⇒ r' ≠ Rerr (Rabort Rtimeout_error)` - (ho_match_mp_tac evaluate_decs_ind >> + !s' r'. ck = F ∧ r = (s', r') ⇒ r' ≠ Rerr (Rabort Rtimeout_error) +Proof + ho_match_mp_tac evaluate_decs_ind >> rw [] >> rw [] >- (CCONTR_TAC >> @@ -704,18 +745,20 @@ Theorem decs_evaluate_not_timeout imp_res_tac dec_evaluate_not_timeout >> fs []) >> cases_on `r` >> - rw [combine_dec_result_def]); + rw [combine_dec_result_def] +QED -Theorem decs_unclocked - `!mn c s env ds c' s' r. +Theorem decs_unclocked: + !mn c s env ds c' s' r. (evaluate_decs F mn env s ds (s',r) ⇒ (r ≠ Rerr (Rabort Rtimeout_error)) ∧ (s.clock = s'.clock)) ∧ (evaluate_decs F mn env (s with clock := c) ds (s' with clock := c,r) = - evaluate_decs F mn env (s with clock := c') ds (s' with clock := c',r))` - (induct_on `ds` >> + evaluate_decs F mn env (s with clock := c') ds (s' with clock := c',r)) +Proof + induct_on `ds` >> rpt gen_tac >> ONCE_REWRITE_TAC [evaluate_decs_cases] >> rw[] @@ -728,13 +771,15 @@ Theorem decs_unclocked >- metis_tac [pair_CASES, dec_unclocked] >- (eq_tac >> rw [] >> - metis_tac[dec_unclocked,with_clock_with_clock,with_clock_clock,with_same_clock])); + metis_tac[dec_unclocked,with_clock_with_clock,with_clock_clock,with_same_clock]) +QED -Theorem not_evaluate_decs_timeout - `∀mn env s ds. +Theorem not_evaluate_decs_timeout: + ∀mn env s ds. (∀r. ¬evaluate_decs F mn env s ds r) ⇒ - ∃r. evaluate_decs T mn env s ds r ∧ (SND r = Rerr (Rabort Rtimeout_error))` - (Induct_on`ds` >- ( simp[Once evaluate_decs_cases] ) >> + ∃r. evaluate_decs T mn env s ds r ∧ (SND r = Rerr (Rabort Rtimeout_error)) +Proof + Induct_on`ds` >- ( simp[Once evaluate_decs_cases] ) >> rpt gen_tac >> simp[Once evaluate_decs_cases] >> srw_tac[DNF_ss][] >> @@ -765,11 +810,13 @@ Theorem not_evaluate_decs_timeout last_x_assum(fn th => first_x_assum(strip_assume_tac o MATCH_MP th)) >> PairCases_on`r`>>fs[] >> first_assum(match_exists_tac o concl) >> simp[] >> - simp[combine_dec_result_def]); + simp[combine_dec_result_def] +QED -Theorem decs_clocked_total - `∀mn env s ds. ∃res. evaluate_decs T mn env s ds res` - (Induct_on`ds`>>simp[Once evaluate_decs_cases] >> +Theorem decs_clocked_total: + ∀mn env s ds. ∃res. evaluate_decs T mn env s ds res +Proof + Induct_on`ds`>>simp[Once evaluate_decs_cases] >> qx_gen_tac`d` >> srw_tac[DNF_ss][] >> qspecl_then[`mn`,`env`,`s`,`d`]strip_assume_tac dec_clocked_total >> @@ -778,55 +825,65 @@ Theorem decs_clocked_total fs[]>> disj2_tac >> first_assum(match_exists_tac o concl) >> simp[] >> - fs[EXISTS_PROD]); - -Theorem decs_clock_monotone - `∀ck mn env ^s d res. evaluate_decs ck mn env s d res ⇒ - ck ⇒ (FST res).clock ≤ s.clock` - (ho_match_mp_tac evaluate_decs_ind >> rw[] >> - imp_res_tac dec_clock_monotone >> fsrw_tac[ARITH_ss][]); - -Theorem decs_sub_from_counter - `∀ck mn env ^s d res. evaluate_decs ck mn env s d res ⇒ + fs[EXISTS_PROD] +QED + +Theorem decs_clock_monotone: + ∀ck mn env ^s d res. evaluate_decs ck mn env s d res ⇒ + ck ⇒ (FST res).clock ≤ s.clock +Proof + ho_match_mp_tac evaluate_decs_ind >> rw[] >> + imp_res_tac dec_clock_monotone >> fsrw_tac[ARITH_ss][] +QED + +Theorem decs_sub_from_counter: + ∀ck mn env ^s d res. evaluate_decs ck mn env s d res ⇒ ∀extra count count' s0 r0. s.clock = count + extra ∧ s0.clock = count' + extra ∧ res = (s0,r0) ∧ ck ⇒ - evaluate_decs ck mn env (s with clock := count) d (s0 with clock := count',r0)` - (ho_match_mp_tac evaluate_decs_strongind >> rw[] >> + evaluate_decs ck mn env (s with clock := count) d (s0 with clock := count',r0) +Proof + ho_match_mp_tac evaluate_decs_strongind >> rw[] >> rw[Once evaluate_decs_cases] >> imp_res_tac dec_sub_from_counter >> fs[] >> imp_res_tac dec_clock_monotone >> imp_res_tac decs_clock_monotone >> fs[] >> rw[] >> - metis_tac [DECIDE ``y + z ≤ x ⇒ (x = (x - z) + z:num)``]) + metis_tac [DECIDE ``y + z ≤ x ⇒ (x = (x - z) + z:num)``] +QED -Theorem decs_clocked_min_counter - `∀ck mn env ^s ds res. evaluate_decs ck mn env s ds res ⇒ +Theorem decs_clocked_min_counter: + ∀ck mn env ^s ds res. evaluate_decs ck mn env s ds res ⇒ ck ⇒ evaluate_decs ck mn env (s with clock := s.clock - (FST res).clock) ds - ((FST res) with clock := 0, SND res)` - (rw[] >> + ((FST res) with clock := 0, SND res) +Proof + rw[] >> imp_res_tac decs_clock_monotone >> PairCases_on`res`>>fs[]>> `res0.clock = 0 + res0.clock ∧ s.clock = (s.clock - res0.clock) + res0.clock` by decide_tac >> - metis_tac[decs_sub_from_counter]); + metis_tac[decs_sub_from_counter] +QED -Theorem decs_unclocked_ignore - `∀ck mn env ^s d res. evaluate_decs ck mn env s d res ⇒ +Theorem decs_unclocked_ignore: + ∀ck mn env ^s d res. evaluate_decs ck mn env s d res ⇒ ∀r2 r3 count. res = (r2,r3) ∧ r3 ≠ Rerr (Rabort Rtimeout_error) ⇒ - evaluate_decs F mn env (s with clock := count) d (r2 with clock := count,r3)` - (ho_match_mp_tac evaluate_decs_ind >> rw[] >> + evaluate_decs F mn env (s with clock := count) d (r2 with clock := count,r3) +Proof + ho_match_mp_tac evaluate_decs_ind >> rw[] >> rw[Once evaluate_decs_cases] >> imp_res_tac dec_unclocked_ignore >> fs[] >> Cases_on`r=Rerr (Rabort Rtimeout_error)`>-fs[combine_dec_result_def]>>fs[]>> - metis_tac[]); + metis_tac[] +QED -Theorem decs_add_to_counter - `∀ck mn env ^s d res. evaluate_decs ck mn env s d res ⇒ +Theorem decs_add_to_counter: + ∀ck mn env ^s d res. evaluate_decs ck mn env s d res ⇒ ∀r2 r3 extra. res = (r2,r3) ∧ ck ∧ r3 ≠ Rerr (Rabort Rtimeout_error) ⇒ - evaluate_decs T mn env (s with clock := s.clock + extra) d (r2 with clock := r2.clock + extra,r3)` - (ho_match_mp_tac evaluate_decs_ind >> rw[] >> + evaluate_decs T mn env (s with clock := s.clock + extra) d (r2 with clock := r2.clock + extra,r3) +Proof + ho_match_mp_tac evaluate_decs_ind >> rw[] >> rw [Once evaluate_decs_cases] >> imp_res_tac dec_add_to_counter >> fs [] >> @@ -836,70 +893,82 @@ Theorem decs_add_to_counter by (Cases_on `r` >> fs [combine_dec_result_def]) >> fs [] >> - metis_tac []); - -Theorem top_evaluate_not_timeout -`!env s top s' r. - evaluate_top F env s top (s', r) ⇒ r ≠ Rerr (Rabort Rtimeout_error)` -(rw [evaluate_top_cases] >> -metis_tac [dec_evaluate_not_timeout, decs_evaluate_not_timeout]); - -Theorem top_unclocked - `!s env top s' r count count'. + metis_tac [] +QED + +Theorem top_evaluate_not_timeout: + !env s top s' r. + evaluate_top F env s top (s', r) ⇒ r ≠ Rerr (Rabort Rtimeout_error) +Proof +rw [evaluate_top_cases] >> +metis_tac [dec_evaluate_not_timeout, decs_evaluate_not_timeout] +QED + +Theorem top_unclocked: + !s env top s' r count count'. (evaluate_top F env s top (s',r) ⇒ (r ≠ Rerr (Rabort Rtimeout_error)) ∧ (s.clock = s'.clock)) ∧ (evaluate_top F env (s with clock := count) top (s' with clock := count,r) = - evaluate_top F env (s with clock := count') top (s' with clock := count',r))` - (reverse (rw [evaluate_top_cases]) >> + evaluate_top F env (s with clock := count') top (s' with clock := count',r)) +Proof + reverse (rw [evaluate_top_cases]) >> simp [state_component_equality] >> simp_tac((srw_ss())++QUANT_INST_ss[record_default_qp])[] >> simp[EXISTS_PROD,FORALL_PROD] >> - metis_tac [dec_unclocked, decs_unclocked]); - -Theorem not_evaluate_top_timeout - `∀env stm top. (∀res. ¬evaluate_top F env stm top res) ⇒ - ∃r. evaluate_top T env stm top r ∧ SND r = Rerr (Rabort Rtimeout_error)` - (Cases_on`top`>>simp[Once evaluate_top_cases]>> srw_tac[DNF_ss][] >> + metis_tac [dec_unclocked, decs_unclocked] +QED + +Theorem not_evaluate_top_timeout: + ∀env stm top. (∀res. ¬evaluate_top F env stm top res) ⇒ + ∃r. evaluate_top T env stm top r ∧ SND r = Rerr (Rabort Rtimeout_error) +Proof + Cases_on`top`>>simp[Once evaluate_top_cases]>> srw_tac[DNF_ss][] >> simp[Once evaluate_top_cases] >> srw_tac[DNF_ss][] >> fs[] >- ( Cases_on`no_dup_types l`>>fs[] >> metis_tac[not_evaluate_decs_timeout,SND,result_nchotomy,pair_CASES]) >> - metis_tac[not_evaluate_dec_timeout,SND,result_nchotomy,pair_CASES]); + metis_tac[not_evaluate_dec_timeout,SND,result_nchotomy,pair_CASES] +QED -Theorem top_clocked_total - `∀env s t. ∃res. evaluate_top T env s t res` - (rpt gen_tac >> +Theorem top_clocked_total: + ∀env s t. ∃res. evaluate_top T env s t res +Proof + rpt gen_tac >> reverse(Cases_on`t`)>>simp[Once evaluate_top_cases] >> srw_tac[DNF_ss][] >- ( qspecl_then[`[]`,`env`,`s`,`d`]strip_assume_tac dec_clocked_total >> PairCases_on`res`>>Cases_on`res1`>>metis_tac[pair_CASES] ) >> qspecl_then[`[s']`,`env`,`s`,`l`]strip_assume_tac decs_clocked_total >> PairCases_on`res`>>fs[]>> - Cases_on`res1`>>metis_tac[]); + Cases_on`res1`>>metis_tac[] +QED -Theorem top_clocked_min_counter - `∀ck env ^s top res. evaluate_top ck env s top res ⇒ +Theorem top_clocked_min_counter: + ∀ck env ^s top res. evaluate_top ck env s top res ⇒ ck ⇒ evaluate_top ck env (s with clock := s.clock - (FST res).clock) top - (FST res with clock := 0,SND res)` - (ho_match_mp_tac evaluate_top_ind >> rw[] >> + (FST res with clock := 0,SND res) +Proof + ho_match_mp_tac evaluate_top_ind >> rw[] >> rw[Once evaluate_top_cases] >> imp_res_tac dec_clocked_min_counter >> fs[] >> imp_res_tac decs_clocked_min_counter >> fs[FMEQ_SINGLE_SIMPLE_DISJ_ELIM] >> fs [state_component_equality] >> qexists_tac `s2 with clock := 0` >> rw [] - >> metis_tac []); + >> metis_tac [] +QED -Theorem top_add_clock -`∀ck env s top s' r. +Theorem top_add_clock: + ∀ck env s top s' r. evaluate_top ck env s top (s',r) ∧ ¬ck ⇒ - ∃c. evaluate_top T env (s with clock := c) top (s' with clock := 0,r)` - (rw[evaluate_top_cases] >> + ∃c. evaluate_top T env (s with clock := c) top (s' with clock := 0,r) +Proof + rw[evaluate_top_cases] >> imp_res_tac dec_add_clock >> imp_res_tac decs_add_clock >> fs [] @@ -914,85 +983,99 @@ Theorem top_add_clock rw [] >> qexists_tac `s2 with clock := 0` >> rw []) >> - metis_tac []); + metis_tac [] +QED -Theorem top_unclocked_ignore -`∀ck env s top s' r c. +Theorem top_unclocked_ignore: + ∀ck env s top s' r c. evaluate_top ck env s top (s',r) ∧ r ≠ Rerr (Rabort Rtimeout_error) ⇒ - evaluate_top F env (s with clock := c) top (s' with clock := c, r)` - (rw[evaluate_top_cases] >> + evaluate_top F env (s with clock := c) top (s' with clock := c, r) +Proof + rw[evaluate_top_cases] >> imp_res_tac dec_unclocked_ignore >> imp_res_tac decs_unclocked_ignore >> fs[FMEQ_SINGLE_SIMPLE_DISJ_ELIM] >> qexists_tac `s2 with clock := c` >> rw [] - >> metis_tac []); + >> metis_tac [] +QED -Theorem top_clocked_unclocked_equiv -`∀env s1 s2 t r. +Theorem top_clocked_unclocked_equiv: + ∀env s1 s2 t r. evaluate_top F env s1 t (s2,r) ⇔ ∃c. evaluate_top T env (s1 with clock := c) t (s2 with clock := 0,r) ∧ r ≠ Rerr (Rabort Rtimeout_error) ∧ - s1.clock = s2.clock` - (simp[FORALL_PROD] >> rw[EQ_IMP_THM] >> + s1.clock = s2.clock +Proof + simp[FORALL_PROD] >> rw[EQ_IMP_THM] >> imp_res_tac top_unclocked >> imp_res_tac top_clocked_min_counter >> imp_res_tac top_add_clock >> imp_res_tac top_unclocked_ignore >> fs[] >> rfs [] >> - metis_tac[with_same_clock]); + metis_tac[with_same_clock] +QED -Theorem top_clock_monotone -`∀ck env s d s' r. evaluate_top ck env s d (s',r) ∧ ck ⇒ s'.clock ≤ s.clock` - (rw [evaluate_top_cases] >> +Theorem top_clock_monotone: + ∀ck env s d s' r. evaluate_top ck env s d (s',r) ∧ ck ⇒ s'.clock ≤ s.clock +Proof + rw [evaluate_top_cases] >> imp_res_tac dec_clock_monotone >> fs[] >> - imp_res_tac decs_clock_monotone >> fs[]); + imp_res_tac decs_clock_monotone >> fs[] +QED -Theorem top_sub_from_counter -`∀ck env s d s' r extra c c'. +Theorem top_sub_from_counter: + ∀ck env s d s' r extra c c'. evaluate_top ck env s d (s',r) ∧ ck ∧ s.clock = c + extra ∧ s'.clock = c' + extra ⇒ - evaluate_top ck env (s with clock := c) d (s' with clock := c',r)` - (rw[evaluate_top_cases] >> + evaluate_top ck env (s with clock := c) d (s' with clock := c',r) +Proof + rw[evaluate_top_cases] >> imp_res_tac dec_sub_from_counter >> fs[] >> imp_res_tac decs_sub_from_counter >> fs[] >> qexists_tac `s2 with clock := c'` >> rw [] - >> metis_tac []); + >> metis_tac [] +QED -Theorem top_add_to_counter -`∀env s d s' r extra. +Theorem top_add_to_counter: + ∀env s d s' r extra. evaluate_top T env s d (s',r) ∧ r ≠ Rerr (Rabort Rtimeout_error) ⇒ - evaluate_top T env (s with clock := s.clock + extra) d (s' with clock := s'.clock + extra, r)` - (rw[evaluate_top_cases] >> + evaluate_top T env (s with clock := s.clock + extra) d (s' with clock := s'.clock + extra, r) +Proof + rw[evaluate_top_cases] >> imp_res_tac dec_add_to_counter >> fs[] >> imp_res_tac decs_add_to_counter >> fs[] >> qexists_tac `s2 with clock := s2.clock + extra` >> rw [] >> - metis_tac []); - -Theorem prog_clock_monotone - `∀ck env ^s d res. evaluate_prog ck env s d res ⇒ - ck ⇒ (FST res).clock ≤ s.clock` - (ho_match_mp_tac evaluate_prog_ind >> rw[] >> - imp_res_tac top_clock_monotone >> fsrw_tac[ARITH_ss][]); - -Theorem prog_unclocked - `!count s env ds count' s' r. + metis_tac [] +QED + +Theorem prog_clock_monotone: + ∀ck env ^s d res. evaluate_prog ck env s d res ⇒ + ck ⇒ (FST res).clock ≤ s.clock +Proof + ho_match_mp_tac evaluate_prog_ind >> rw[] >> + imp_res_tac top_clock_monotone >> fsrw_tac[ARITH_ss][] +QED + +Theorem prog_unclocked: + !count s env ds count' s' r. (evaluate_prog F env s ds (s',r) ⇒ r ≠ Rerr (Rabort Rtimeout_error) ∧ s.clock = s'.clock) ∧ (evaluate_prog F env (s with clock := count) ds (s' with clock := count,r) = - evaluate_prog F env (s with clock := count') ds (s' with clock := count',r))` - (induct_on `ds` >> + evaluate_prog F env (s with clock := count') ds (s' with clock := count',r)) +Proof + induct_on `ds` >> rpt gen_tac >> ONCE_REWRITE_TAC [evaluate_prog_cases] >> rw [] @@ -1005,12 +1088,14 @@ Theorem prog_unclocked >- metis_tac[top_unclocked] >- metis_tac[top_unclocked] >> eq_tac >> rw [] >> - metis_tac[top_unclocked,with_clock_with_clock,with_clock_clock,with_same_clock]); - -Theorem not_evaluate_prog_timeout - `∀env s prog. (∀res. ¬evaluate_prog F env s prog res) ⇒ - ∃r. evaluate_prog T env s prog r ∧ SND r = Rerr (Rabort Rtimeout_error)` - (Induct_on`prog` >- simp[Once evaluate_prog_cases] >> + metis_tac[top_unclocked,with_clock_with_clock,with_clock_clock,with_same_clock] +QED + +Theorem not_evaluate_prog_timeout: + ∀env s prog. (∀res. ¬evaluate_prog F env s prog res) ⇒ + ∃r. evaluate_prog T env s prog r ∧ SND r = Rerr (Rabort Rtimeout_error) +Proof + Induct_on`prog` >- simp[Once evaluate_prog_cases] >> rpt gen_tac >> simp[Once evaluate_prog_cases] >> srw_tac[DNF_ss][] >> @@ -1040,64 +1125,76 @@ Theorem not_evaluate_prog_timeout last_x_assum(fn th => first_x_assum(strip_assume_tac o MATCH_MP th)) >> PairCases_on`r`>>fs[] >> first_assum(match_exists_tac o concl) >> simp[] >> - simp[combine_dec_result_def]); + simp[combine_dec_result_def] +QED -Theorem not_evaluate_whole_prog_timeout - `∀env stm prog. +Theorem not_evaluate_whole_prog_timeout: + ∀env stm prog. (∀res. ¬evaluate_whole_prog F env stm prog res) ⇒ ∃r. evaluate_whole_prog T env stm prog r ∧ - SND r = Rerr (Rabort Rtimeout_error)` - (rw[FORALL_PROD,EXISTS_PROD,evaluate_whole_prog_def] >> + SND r = Rerr (Rabort Rtimeout_error) +Proof + rw[FORALL_PROD,EXISTS_PROD,evaluate_whole_prog_def] >> BasicProvers.EVERY_CASE_TAC >> fs[] >> fs[GSYM EXISTS_PROD,GSYM FORALL_PROD] >> - metis_tac[not_evaluate_prog_timeout,SND,pair_CASES]); + metis_tac[not_evaluate_prog_timeout,SND,pair_CASES] +QED -Theorem prog_add_to_counter - `∀ck env st prog res. +Theorem prog_add_to_counter: + ∀ck env st prog res. evaluate_prog ck env st prog res ⇒ ∀r2 r3 extra. res = (r2,r3) ∧ ck ∧ r3 ≠ Rerr (Rabort Rtimeout_error) ⇒ - evaluate_prog T env (st with clock := st.clock + extra) prog (r2 with clock := r2.clock + extra,r3)` - (ho_match_mp_tac evaluate_prog_ind >> rw[] >> + evaluate_prog T env (st with clock := st.clock + extra) prog (r2 with clock := r2.clock + extra,r3) +Proof + ho_match_mp_tac evaluate_prog_ind >> rw[] >> rw[Once evaluate_prog_cases] >> imp_res_tac top_add_to_counter >> fs[] >> rw[] >> fs[] >> `r ≠ Rerr (Rabort Rtimeout_error)` by (Cases_on`r` >> fs[combine_dec_result_def]) >> - fs[] >> metis_tac[]) -Theorem prog_clock_monotone -`∀ck env ^s d res. evaluate_prog ck env s d res ⇒ ck ⇒ (FST res).clock ≤ s.clock` - (ho_match_mp_tac evaluate_prog_ind >> rw[] >> - imp_res_tac top_clock_monotone >> fsrw_tac[ARITH_ss][]); - -Theorem prog_sub_from_counter - `∀ck env ^s d res. evaluate_prog ck env s d res ⇒ + fs[] >> metis_tac[] +QED +Theorem prog_clock_monotone: + ∀ck env ^s d res. evaluate_prog ck env s d res ⇒ ck ⇒ (FST res).clock ≤ s.clock +Proof + ho_match_mp_tac evaluate_prog_ind >> rw[] >> + imp_res_tac top_clock_monotone >> fsrw_tac[ARITH_ss][] +QED + +Theorem prog_sub_from_counter: + ∀ck env ^s d res. evaluate_prog ck env s d res ⇒ ∀extra c c' s' r. s.clock = c + extra ∧ s'.clock = c' + extra ∧ res = (s',r) ∧ ck ⇒ - evaluate_prog ck env (s with clock := c) d (s' with clock := c',r)` - (ho_match_mp_tac evaluate_prog_strongind >> rw[] >> + evaluate_prog ck env (s with clock := c) d (s' with clock := c',r) +Proof + ho_match_mp_tac evaluate_prog_strongind >> rw[] >> rw[Once evaluate_prog_cases] >> fs[] >> metis_tac[top_sub_from_counter,top_clock_monotone,prog_clock_monotone,FST, - DECIDE ``y + z ≤ x ⇒ (x = (x - z) + z:num)``]); + DECIDE ``y + z ≤ x ⇒ (x = (x - z) + z:num)``] +QED -Theorem prog_clocked_min_counter -`∀ck env ^s p res. +Theorem prog_clocked_min_counter: + ∀ck env ^s p res. evaluate_prog T env s p res ⇒ evaluate_prog T env (s with clock := s.clock - (FST res).clock) p - (FST res with clock := 0,SND res)` - (rw[] >> + (FST res with clock := 0,SND res) +Proof + rw[] >> imp_res_tac prog_clock_monotone >> PairCases_on`res`>>fs[]>> `res0.clock = 0 + res0.clock ∧ s.clock = (s.clock - res0.clock) + res0.clock` by decide_tac >> - metis_tac[prog_sub_from_counter]); + metis_tac[prog_sub_from_counter] +QED -Theorem prog_add_clock - `∀ck env ^s d res. evaluate_prog ck env s d res ⇒ +Theorem prog_add_clock: + ∀ck env ^s d res. evaluate_prog ck env s d res ⇒ ¬ck ⇒ - ∃c. evaluate_prog T env (s with clock := c) d (FST res with clock := 0, SND res)` - (ho_match_mp_tac evaluate_prog_ind >> rw[] >> + ∃c. evaluate_prog T env (s with clock := c) d (FST res with clock := 0, SND res) +Proof + ho_match_mp_tac evaluate_prog_ind >> rw[] >> rw[Once evaluate_prog_cases] >> imp_res_tac top_add_clock >> fs[state_component_equality] >- (fs [] >> @@ -1105,32 +1202,37 @@ Theorem prog_add_clock fs [] >> rw [] >> metis_tac []) - >- metis_tac[]); + >- metis_tac[] +QED -Theorem prog_unclocked_ignore -`∀ck env ^s d res. evaluate_prog ck env s d res ⇒ +Theorem prog_unclocked_ignore: + ∀ck env ^s d res. evaluate_prog ck env s d res ⇒ ∀c s' r. res = (s',r) ∧ r ≠ Rerr (Rabort Rtimeout_error) ⇒ - evaluate_prog F env (s with clock := c) d (s' with clock := c,r)` - (ho_match_mp_tac evaluate_prog_ind >> rw[] >> + evaluate_prog F env (s with clock := c) d (s' with clock := c,r) +Proof + ho_match_mp_tac evaluate_prog_ind >> rw[] >> rw[Once evaluate_prog_cases] >> imp_res_tac top_unclocked_ignore >> fs[] >> Cases_on`r=Rerr (Rabort Rtimeout_error)`>-fs[combine_dec_result_def]>>fs[]>> - metis_tac[]); + metis_tac[] +QED -Theorem prog_clocked_unclocked_equiv -`∀env s p s' r. +Theorem prog_clocked_unclocked_equiv: + ∀env s p s' r. evaluate_prog F env s p (s',r) ⇔ ∃c. evaluate_prog T env (s with clock:= c) p (s' with clock := 0, r) ∧ r ≠ Rerr (Rabort Rtimeout_error) ∧ - s.clock = s'.clock` - (simp[FORALL_PROD] >> rw[EQ_IMP_THM] >> + s.clock = s'.clock +Proof + simp[FORALL_PROD] >> rw[EQ_IMP_THM] >> imp_res_tac prog_unclocked >> imp_res_tac prog_clocked_min_counter >> imp_res_tac prog_add_clock >> imp_res_tac prog_unclocked_ignore >> fs[] >> rfs [] >> - metis_tac[with_same_clock]); + metis_tac[with_same_clock] +QED *) val _ = export_theory (); diff --git a/semantics/alt_semantics/proofs/bigSmallEquivScript.sml b/semantics/alt_semantics/proofs/bigSmallEquivScript.sml index 7bd542e914..4ed80b910a 100644 --- a/semantics/alt_semantics/proofs/bigSmallEquivScript.sml +++ b/semantics/alt_semantics/proofs/bigSmallEquivScript.sml @@ -1693,13 +1693,14 @@ val evaluate_change_state = Q.prove( evaluate a b c' d (e',f)`, srw_tac[][] >> srw_tac[][]) |> GEN_ALL; -Theorem small_big_exp_equiv -`!env s e s' r. +Theorem small_big_exp_equiv: + !env s e s' r. (small_eval env (to_small_st s) e [] (to_small_st s',r) ∧ s.clock = s'.clock ∧ s.next_type_stamp = s'.next_type_stamp ∧ s.next_exn_stamp= s'.next_exn_stamp) ⇔ - evaluate F env s e (s',r)` - (srw_tac[][] >> + evaluate F env s e (s',r) +Proof + srw_tac[][] >> eq_tac >- (srw_tac[][] >> cases_on `r` >| @@ -1733,16 +1734,18 @@ Theorem small_big_exp_equiv >- (srw_tac[][] >> imp_res_tac big_exp_to_small_exp >> full_simp_tac(srw_ss())[small_eval_def, to_small_res_def] >> - metis_tac [evaluate_no_new_types_exns, FST, big_unclocked])); + metis_tac [evaluate_no_new_types_exns, FST, big_unclocked]) +QED (* ---------------------- Small step determinacy ------------------------- *) -Theorem small_exp_determ -`!env s e r1 r2. +Theorem small_exp_determ: + !env s e r1 r2. small_eval env s e [] r1 ∧ small_eval env s e [] r2 ⇒ - (r1 = r2)` - (srw_tac[][] >> + (r1 = r2) +Proof + srw_tac[][] >> assume_tac small_big_exp_equiv >> full_simp_tac(srw_ss())[to_small_st_def] >> PairCases_on `r1` >> @@ -1759,6 +1762,7 @@ Theorem small_exp_determ full_simp_tac(srw_ss())[] >> srw_tac[][] >> imp_res_tac big_exp_determ >> - full_simp_tac(srw_ss())[]); + full_simp_tac(srw_ss())[] +QED val _ = export_theory (); diff --git a/semantics/alt_semantics/proofs/bigStepPropsScript.sml b/semantics/alt_semantics/proofs/bigStepPropsScript.sml index fb300fe534..caa3871a4f 100644 --- a/semantics/alt_semantics/proofs/bigStepPropsScript.sml +++ b/semantics/alt_semantics/proofs/bigStepPropsScript.sml @@ -8,13 +8,14 @@ open bigStepTheory; val _ = new_theory "bigStepProps"; (* TODO see if this is actually needed -Theorem evaluate_decs_evaluate_prog_MAP_Tdec - `∀ck env cs tids ds res. +Theorem evaluate_decs_evaluate_prog_MAP_Tdec: + ∀ck env cs tids ds res. evaluate_decs ck NONE env (cs,tids) ds res ⇔ case res of ((s,tids'),envC,r) => - evaluate_prog ck env (cs,tids,{}) (MAP Tdec ds) ((s,tids',{}),([],envC),map_result(λenvE. ([],envE))(I)r)` - (Induct_on`ds`>>simp[Once evaluate_decs_cases,Once evaluate_prog_cases] >- ( + evaluate_prog ck env (cs,tids,{}) (MAP Tdec ds) ((s,tids',{}),([],envC),map_result(λenvE. ([],envE))(I)r) +Proof + Induct_on`ds`>>simp[Once evaluate_decs_cases,Once evaluate_prog_cases] >- ( rpt gen_tac >> BasicProvers.EVERY_CASE_TAC >> simp[] >> Cases_on`r'`>>simp[] ) >> srw_tac[DNF_ss][] >> @@ -52,14 +53,16 @@ Theorem evaluate_decs_evaluate_prog_MAP_Tdec TRY (Cases_on`res4`>>full_simp_tac(srw_ss())[]) >> Cases_on`a`>>Cases_on`e`>>full_simp_tac(srw_ss())[]>>srw_tac[][]) >- ( - Cases_on`a`>>full_simp_tac(srw_ss())[])) + Cases_on`a`>>full_simp_tac(srw_ss())[]) +QED -Theorem evaluate_decs_ctors_in - `∀ck mn env s decs res. evaluate_decs ck mn env s decs res ⇒ +Theorem evaluate_decs_ctors_in: + ∀ck mn env s decs res. evaluate_decs ck mn env s decs res ⇒ ∀cn. IS_SOME (ALOOKUP (FST(SND res)) cn) ⇒ - MEM cn (FLAT (MAP ctors_of_dec decs))` - (HO_MATCH_MP_TAC evaluate_decs_ind >> + MEM cn (FLAT (MAP ctors_of_dec decs)) +Proof + HO_MATCH_MP_TAC evaluate_decs_ind >> simp[] >> srw_tac[][Once evaluate_dec_cases] >> simp[] >> full_simp_tac(srw_ss())[ALOOKUP_APPEND] >> @@ -79,14 +82,15 @@ Theorem evaluate_decs_ctors_in PairCases_on `y` >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> - METIS_TAC[pair_CASES]) + METIS_TAC[pair_CASES] +QED *) val st = ``st:'ffi state`` -Theorem evaluate_no_new_types_exns -`(!ck env ^st e r. evaluate ck env st e r ⇒ +Theorem evaluate_no_new_types_exns: + (!ck env ^st e r. evaluate ck env st e r ⇒ st.next_type_stamp = (FST r).next_type_stamp ∧ st.next_exn_stamp = (FST r).next_exn_stamp) ∧ (!ck env ^st es r. evaluate_list ck env st es r ⇒ @@ -94,12 +98,14 @@ Theorem evaluate_no_new_types_exns st.next_exn_stamp = (FST r).next_exn_stamp) ∧ (!ck env ^st v pes err_v r. evaluate_match ck env st v pes err_v r ⇒ st.next_type_stamp = (FST r).next_type_stamp ∧ - st.next_exn_stamp = (FST r).next_exn_stamp)` - (ho_match_mp_tac bigStepTheory.evaluate_ind >> - srw_tac[][]); + st.next_exn_stamp = (FST r).next_exn_stamp) +Proof + ho_match_mp_tac bigStepTheory.evaluate_ind >> + srw_tac[][] +QED -Theorem evaluate_ignores_types_exns -`(∀ck env ^st e r. +Theorem evaluate_ignores_types_exns: + (∀ck env ^st e r. evaluate ck env st e r ⇒ !x y. evaluate ck env (st with <| next_type_stamp := x; next_exn_stamp := y |>) e ((FST r) with <| next_type_stamp := x; next_exn_stamp := y |>, SND r)) ∧ @@ -110,26 +116,32 @@ Theorem evaluate_ignores_types_exns (∀ck env ^st v pes err_v r. evaluate_match ck env st v pes err_v r ⇒ !x y. evaluate_match ck env (st with <| next_type_stamp := x; next_exn_stamp := y |>) v pes err_v - ((FST r) with <| next_type_stamp := x; next_exn_stamp := y |>, SND r))` - (ho_match_mp_tac bigStepTheory.evaluate_ind >> + ((FST r) with <| next_type_stamp := x; next_exn_stamp := y |>, SND r)) +Proof + ho_match_mp_tac bigStepTheory.evaluate_ind >> srw_tac[][] >> srw_tac[][Once evaluate_cases, state_component_equality] >> - metis_tac [state_accfupds, K_DEF]); + metis_tac [state_accfupds, K_DEF] +QED (* -Theorem eval_d_no_new_mods -`!ck mn env st d r. evaluate_dec ck mn env st d r ⇒ st.defined_mods = (FST r).defined_mods` - (srw_tac[][evaluate_dec_cases] >> +Theorem eval_d_no_new_mods: + !ck mn env st d r. evaluate_dec ck mn env st d r ⇒ st.defined_mods = (FST r).defined_mods +Proof + srw_tac[][evaluate_dec_cases] >> imp_res_tac evaluate_no_new_types_mods >> - full_simp_tac(srw_ss())[]); + full_simp_tac(srw_ss())[] +QED -Theorem eval_ds_no_new_mods -`!ck mn env ^st ds r. evaluate_decs ck mn env st ds r ⇒ st.defined_mods = (FST r).defined_mods` - (ho_match_mp_tac evaluate_decs_ind >> +Theorem eval_ds_no_new_mods: + !ck mn env ^st ds r. evaluate_decs ck mn env st ds r ⇒ st.defined_mods = (FST r).defined_mods +Proof + ho_match_mp_tac evaluate_decs_ind >> srw_tac[][] >> imp_res_tac eval_d_no_new_mods >> - full_simp_tac(srw_ss())[]); + full_simp_tac(srw_ss())[] +QED *) (* REPL bootstrap lemmas *) @@ -180,8 +192,8 @@ val evaluate_decs_last3 = Q.prove( PairCases_on`cenv` >> full_simp_tac(srw_ss())[semanticPrimitivesTheory.merge_alist_mod_env_def, FUNION_ASSOC]) -Theorem evaluate_Tmod_last3 - `evaluate_top ck env0 st (Tmod mn NONE decs) ((cs,u),envC,Rval ([(mn,env)],v)) ⇒ +Theorem evaluate_Tmod_last3 = Q.prove(` + evaluate_top ck env0 st (Tmod mn NONE decs) ((cs,u),envC,Rval ([(mn,env)],v)) ⇒ decs = decs0 ++[Dlet (Pvar x) (App Opref [Con i []]);Dlet (Pvar y) (App Opref [Con j []]);Dlet (Pvar p) (Fun q z)] ⇒ ∃n ls1 ls iv jv. @@ -191,8 +203,8 @@ Theorem evaluate_Tmod_last3 build_conv (merge_alist_mod_env ([],THE (ALOOKUP (FST envC) mn)) (FST(SND env0))) i [] = SOME iv ∧ build_conv (merge_alist_mod_env ([],THE (ALOOKUP (FST envC) mn)) (FST(SND env0))) j [] = SOME jv ∧ (EL n (SND cs) = Refv iv) ∧ - (EL (n+1) (SND cs) = Refv jv)` - (Cases_on`cs`>>srw_tac[][bigStepTheory.evaluate_top_cases]>> + (EL (n+1) (SND cs) = Refv jv)`, + Cases_on`cs`>>srw_tac[][bigStepTheory.evaluate_top_cases]>> imp_res_tac evaluate_decs_last3 >> full_simp_tac(srw_ss())[]) |> GEN_ALL val evaluate_decs_tys = Q.prove( diff --git a/semantics/alt_semantics/proofs/determScript.sml b/semantics/alt_semantics/proofs/determScript.sml index a4ff2ac813..5f332a2f52 100644 --- a/semantics/alt_semantics/proofs/determScript.sml +++ b/semantics/alt_semantics/proofs/determScript.sml @@ -10,8 +10,8 @@ val _ = new_theory "determ"; val s = ``s:'ffi state``; -Theorem big_exp_determ - `(∀ck env ^s e r1. +Theorem big_exp_determ: + (∀ck env ^s e r1. evaluate ck env s e r1 ⇒ ∀r2. evaluate ck env s e r2 ⇒ (r1 = r2)) ∧ @@ -22,8 +22,9 @@ Theorem big_exp_determ (∀ck env ^s v pes err_v r1. evaluate_match ck env s v pes err_v r1 ⇒ ∀r2. evaluate_match ck env s v pes err_v r2 ⇒ - (r1 = r2))` -(HO_MATCH_MP_TAC evaluate_ind >> + (r1 = r2)) +Proof +HO_MATCH_MP_TAC evaluate_ind >> rw [] >> pop_assum (ASSUME_TAC o SIMP_RULE (srw_ss ()) [Once evaluate_cases]) >> fs [] >> @@ -35,10 +36,11 @@ rw [] >> res_tac >> fs [] >> rw [] >> -metis_tac []); +metis_tac [] +QED -Theorem decs_determ -`(!ck env (s:'a state) d r1. +Theorem decs_determ: + (!ck env (s:'a state) d r1. evaluate_dec ck env s d r1 ⇒ !r2. evaluate_dec ck env s d r2 @@ -49,59 +51,67 @@ Theorem decs_determ !r2. evaluate_decs ck env s ds r2 ⇒ - (r1 = r2))` -(HO_MATCH_MP_TAC evaluate_dec_ind >> + (r1 = r2)) +Proof +HO_MATCH_MP_TAC evaluate_dec_ind >> rw [] >> pop_assum mp_tac >> simp [Once evaluate_dec_cases] >> fs [] >> rw [] >> metis_tac [big_exp_determ, result_11, result_distinct,PAIR_EQ,NOT_EXISTS, - NOT_EVERY, match_result_11, match_result_distinct, optionTheory.SOME_11]); + NOT_EVERY, match_result_11, match_result_distinct, optionTheory.SOME_11] +QED (* -Theorem top_determ -`!ck env s top r1. +Theorem top_determ: + !ck env s top r1. evaluate_top ck env s top r1 ⇒ !r2. evaluate_top ck env s top r2 ⇒ - (r1 = r2)` -(rw [evaluate_top_cases] >> + (r1 = r2) +Proof +rw [evaluate_top_cases] >> metis_tac [dec_determ, result_11, result_distinct,PAIR_EQ, match_result_11, match_result_distinct, optionTheory.SOME_11, - decs_determ]); + decs_determ] +QED -Theorem prog_determ -`!ck env s ds r1. +Theorem prog_determ: + !ck env s ds r1. evaluate_prog ck env s ds r1 ⇒ !r2. evaluate_prog ck env s ds r2 ⇒ - (r1 = r2)` -(HO_MATCH_MP_TAC evaluate_prog_ind >> + (r1 = r2) +Proof +HO_MATCH_MP_TAC evaluate_prog_ind >> rw [] >> pop_assum (ASSUME_TAC o SIMP_RULE (srw_ss ()) [Once evaluate_prog_cases]) >> fs [] >> rw [] >> metis_tac [top_determ, result_11, result_distinct,PAIR_EQ, - match_result_11, match_result_distinct, optionTheory.SOME_11]); + match_result_11, match_result_distinct, optionTheory.SOME_11] +QED -Theorem whole_prog_determ -`!ck env s ds r1. +Theorem whole_prog_determ: + !ck env s ds r1. evaluate_whole_prog ck env s ds r1 ⇒ !r2. evaluate_whole_prog ck env s ds r2 ⇒ - (r1 = r2)` - (rw [] >> + (r1 = r2) +Proof + rw [] >> PairCases_on `r1` >> PairCases_on `r2` >> fs [evaluate_whole_prog_def] >> every_case_tac >> fs [] >> imp_res_tac prog_determ >> - rw []); + rw [] +QED *) val _ = export_theory (); diff --git a/semantics/alt_semantics/proofs/funBigStepEquivScript.sml b/semantics/alt_semantics/proofs/funBigStepEquivScript.sml index 46e772633d..2da6f3ec9f 100644 --- a/semantics/alt_semantics/proofs/funBigStepEquivScript.sml +++ b/semantics/alt_semantics/proofs/funBigStepEquivScript.sml @@ -9,12 +9,13 @@ val _ = new_theory"funBigStepEquiv" val s = ``s:'ffi state``; -Theorem evaluate_eq_run_eval_list - `(∀^s env e. evaluate s env e = run_eval_list env e s) ∧ +Theorem evaluate_eq_run_eval_list: + (∀^s env e. evaluate s env e = run_eval_list env e s) ∧ (∀^s env v e errv. evaluate_match s env v e errv = - (I ## list_result) (run_eval_match env v e errv s))` - (ho_match_mp_tac evaluate_ind >> + (I ## list_result) (run_eval_match env v e errv s)) +Proof + ho_match_mp_tac evaluate_ind >> rw[evaluate_def,run_eval_def, result_return_def,result_bind_def] >> every_case_tac >> fs[] >> rw[] >> @@ -37,23 +38,29 @@ Theorem evaluate_eq_run_eval_list every_case_tac >> fs[dec_clock_def,evaluateTheory.dec_clock_def] >> rfs[] >> fs[state_transformerTheory.UNIT_DEF] >> rw[list_result_def] >> fs[set_store_def] >> rw[] >> - fs[FST_triple]); + fs[FST_triple] +QED -Theorem functional_evaluate_list - `evaluate s env es = (s',r) ⇔ evaluate_list T env s es (s',r)` - (rw[evaluate_run_eval_list,evaluate_eq_run_eval_list]) +Theorem functional_evaluate_list: + evaluate s env es = (s',r) ⇔ evaluate_list T env s es (s',r) +Proof + rw[evaluate_run_eval_list,evaluate_eq_run_eval_list] +QED -Theorem functional_evaluate_match - `evaluate_match s env v pes errv = (s',list_result r) ⇔ - evaluate_match T env s v pes errv (s',r)` - (rw[evaluate_run_eval_match,evaluate_eq_run_eval_list] >> +Theorem functional_evaluate_match: + evaluate_match s env v pes errv = (s',list_result r) ⇔ + evaluate_match T env s v pes errv (s',r) +Proof + rw[evaluate_run_eval_match,evaluate_eq_run_eval_list] >> Cases_on`run_eval_match env v pes errv s`>>rw[] >> - Cases_on`r`>>Cases_on`r'`>>rw[list_result_def]); + Cases_on`r`>>Cases_on`r'`>>rw[list_result_def] +QED -Theorem evaluate_decs_eq_run_eval_decs - `∀s env decs r tds s'. - evaluate_decs s env decs = run_eval_decs env s decs` - (recInduct evaluate_decs_ind >> +Theorem evaluate_decs_eq_run_eval_decs: + ∀s env decs r tds s'. + evaluate_decs s env decs = run_eval_decs env s decs +Proof + recInduct evaluate_decs_ind >> rw[evaluate_decs_def,run_eval_dec_def,run_eval_dec_def] >> every_case_tac >> fs[combine_dec_result_def,evaluate_eq_run_eval_list] >> @@ -61,41 +68,52 @@ Theorem evaluate_decs_eq_run_eval_decs fs[run_eval_def,result_bind_def,result_return_def] >> rw[] >> fs[FST_triple] >> rfs[] >> NO_TAC) >> - every_case_tac >> fs[functional_evaluate_list]); + every_case_tac >> fs[functional_evaluate_list] +QED -Theorem functional_evaluate_decs - `evaluate_decs s env decs = (s',r) ⇒ - evaluate_decs T env s decs (s',r)` - (rw[evaluate_decs_eq_run_eval_decs,run_eval_decs_spec]) +Theorem functional_evaluate_decs: + evaluate_decs s env decs = (s',r) ⇒ + evaluate_decs T env s decs (s',r) +Proof + rw[evaluate_decs_eq_run_eval_decs,run_eval_decs_spec] +QED (* -Theorem evaluate_tops_eq_run_eval_prog - `∀s env tops. - evaluate_tops s env tops = run_eval_prog env s tops` - (recInduct evaluate_tops_ind >> +Theorem evaluate_tops_eq_run_eval_prog: + ∀s env tops. + evaluate_tops s env tops = run_eval_prog env s tops +Proof + recInduct evaluate_tops_ind >> rw[evaluate_tops_def,run_eval_prog_def,run_eval_top_def] >> every_case_tac >> fs[combine_dec_result_def,evaluate_decs_eq_run_eval_decs] >> fs[run_eval_decs_def,combine_dec_result_def] >> rw [] >> split_pair_case_tac - >> fs []); + >> fs [] +QED -Theorem functional_evaluate_tops - `evaluate_tops s env tops = (s',r) ⇒ evaluate_prog T env s tops (s',r)` - (rw[evaluate_tops_eq_run_eval_prog,run_eval_prog_spec]) +Theorem functional_evaluate_tops: + evaluate_tops s env tops = (s',r) ⇒ evaluate_prog T env s tops (s',r) +Proof + rw[evaluate_tops_eq_run_eval_prog,run_eval_prog_spec] +QED -Theorem functional_evaluate_prog - `evaluate_prog s env prog = (s',r) ⇒ - evaluate_whole_prog T env s prog (s',r)` - (rw[evaluate_prog_def,bigStepTheory.evaluate_whole_prog_def] >> - imp_res_tac functional_evaluate_tops); +Theorem functional_evaluate_prog: + evaluate_prog s env prog = (s',r) ⇒ + evaluate_whole_prog T env s prog (s',r) +Proof + rw[evaluate_prog_def,bigStepTheory.evaluate_whole_prog_def] >> + imp_res_tac functional_evaluate_tops +QED *) -Theorem functional_evaluate - `evaluate T env s e (s',r) ⇔ evaluate s env [e] = (s',list_result r)` - (functional_evaluate_list |> Q.GENL[`es`,`r`] |> qspec_then`[e]`mp_tac \\ +Theorem functional_evaluate: + evaluate T env s e (s',r) ⇔ evaluate s env [e] = (s',list_result r) +Proof + functional_evaluate_list |> Q.GENL[`es`,`r`] |> qspec_then`[e]`mp_tac \\ ntac 6 (simp[Once (CONJUNCT2 bigStepTheory.evaluate_cases)]) \\ - Cases_on`r` \\ fs[]); + Cases_on`r` \\ fs[] +QED val _ = export_theory() diff --git a/semantics/alt_semantics/proofs/interpScript.sml b/semantics/alt_semantics/proofs/interpScript.sml index 824cb2a3b7..cb18ed7c3f 100644 --- a/semantics/alt_semantics/proofs/interpScript.sml +++ b/semantics/alt_semantics/proofs/interpScript.sml @@ -43,26 +43,32 @@ val run_eval_spec_lem = Q.prove ( val run_eval_spec = new_specification ("run_eval", ["run_eval", "run_eval_list", "run_eval_match"], run_eval_spec_lem); -Theorem evaluate_run_eval -`!env e r st. +Theorem evaluate_run_eval: + !env e r st. evaluate T env st e r = - (run_eval env e st = r)` -(metis_tac [big_exp_determ, run_eval_spec]); + (run_eval env e st = r) +Proof +metis_tac [big_exp_determ, run_eval_spec] +QED -Theorem evaluate_run_eval_list -`!env es r st. +Theorem evaluate_run_eval_list: + !env es r st. evaluate_list T env st es r = - (run_eval_list env es st = r)` -(metis_tac [big_exp_determ, run_eval_spec]); + (run_eval_list env es st = r) +Proof +metis_tac [big_exp_determ, run_eval_spec] +QED -Theorem evaluate_run_eval_match -`!env v pes r err_v st. +Theorem evaluate_run_eval_match: + !env v pes r err_v st. evaluate_match T env st v pes err_v r = - (run_eval_match env v pes err_v st = r)` -(metis_tac [big_exp_determ, run_eval_spec]); + (run_eval_match env v pes err_v st = r) +Proof +metis_tac [big_exp_determ, run_eval_spec] +QED val _ = type_abbrev("M", ``:'ffi state -> 'ffi state # ('a, v) result``); @@ -109,8 +115,8 @@ rw [FUN_EQ_THM] >> PairCases_on `x` >> fs []); -Theorem run_eval_def -`(!^st env l. +Theorem run_eval_def: + (!^st env l. run_eval env (Lit l) = return (Litv l)) ∧ @@ -246,8 +252,9 @@ Theorem run_eval_def | Match env' => run_eval (env with v := nsAppend (alist_to_ns env') env.v) e else raise (Rabort Rtype_error) - od)` - (rw [GSYM evaluate_run_eval, FUN_EQ_THM, result_raise_def, result_return_def, + od) +Proof + rw [GSYM evaluate_run_eval, FUN_EQ_THM, result_raise_def, result_return_def, result_bind_def, get_store_def, set_store_def] >> rw [Once evaluate_cases] >- (every_case_tac >> @@ -314,7 +321,8 @@ Theorem run_eval_def >- (every_case_tac >> rw [] >> fs [GSYM evaluate_run_eval_match, GSYM evaluate_run_eval] >> - rw [Once evaluate_cases])); + rw [Once evaluate_cases]) +QED val run_eval_dec_def = Define ` (run_eval_dec env ^st (Dlet _ p e) = @@ -398,14 +406,15 @@ run_eval_whole_prog env st prog = (st,Rerr (Rabort Rtype_error))`; *) -Theorem run_eval_decs_spec -`(!d (st:'a state) env st' r. +Theorem run_eval_decs_spec: + (!d (st:'a state) env st' r. (run_eval_dec env st d = (st', r)) ⇒ evaluate_dec T env st d (st', r)) ∧ (!ds env (st:'a state) st' r. (run_eval_decs env st ds = (st',r)) ⇒ - evaluate_decs T env st ds (st',r))` - (ho_match_mp_tac astTheory.dec_induction >> + evaluate_decs T env st ds (st',r)) +Proof + ho_match_mp_tac astTheory.dec_induction >> rw [] >> simp [Once evaluate_dec_cases] >> fs [run_eval_dec_def] >> @@ -413,16 +422,17 @@ Theorem run_eval_decs_spec rw [] >> fs [GSYM evaluate_run_eval, fst_lem] >> metis_tac [] -); +QED (* -Theorem run_eval_top_spec -`!st env top st' r. +Theorem run_eval_top_spec: + !st env top st' r. (run_eval_top env st top = (st', r)) ⇒ - evaluate_top T env st top (st', r)` - (cases_on `top` >> + evaluate_top T env st top (st', r) +Proof + cases_on `top` >> rw [evaluate_top_cases, run_eval_top_def] >> every_case_tac >> rw [] >> @@ -430,13 +440,15 @@ Theorem run_eval_top_spec imp_res_tac run_eval_dec_spec >> fs [] >> rw [] >> - metis_tac []); + metis_tac [] +QED -Theorem run_eval_prog_spec -`!env st prog st' r. +Theorem run_eval_prog_spec: + !env st prog st' r. run_eval_prog env st prog = (st', r) ⇒ - evaluate_prog T env st prog (st', r)` - (induct_on `prog` >> + evaluate_prog T env st prog (st', r) +Proof + induct_on `prog` >> rw [run_eval_prog_def, Once evaluate_prog_cases] >> every_case_tac >> rw [] >> @@ -446,14 +458,17 @@ Theorem run_eval_prog_spec fs [] >- (disj1_tac >> MAP_EVERY qexists_tac [`q`, `a`, `r'`] >> - rw [combine_dec_result_def])); + rw [combine_dec_result_def]) +QED -Theorem run_eval_whole_prog_spec -`!env st prog st' r. +Theorem run_eval_whole_prog_spec: + !env st prog st' r. run_eval_whole_prog env st prog = (st',r) ⇒ - evaluate_whole_prog T env st prog (st',r)` - (rw [run_eval_whole_prog_def, evaluate_whole_prog_def] >> - metis_tac [run_eval_prog_spec]); + evaluate_whole_prog T env st prog (st',r) +Proof + rw [run_eval_whole_prog_def, evaluate_whole_prog_def] >> + metis_tac [run_eval_prog_spec] +QED *) val _ = export_theory (); diff --git a/semantics/alt_semantics/proofs/untypedSafetyScript.sml b/semantics/alt_semantics/proofs/untypedSafetyScript.sml index 00462c74dd..6e570864d3 100644 --- a/semantics/alt_semantics/proofs/untypedSafetyScript.sml +++ b/semantics/alt_semantics/proofs/untypedSafetyScript.sml @@ -60,18 +60,21 @@ val small_exp_safety2 = Q.prove ( rw [small_eval_def] >> metis_tac [])); -Theorem untyped_safety_exp -`!s env e. (?r. small_eval env s e [] r) = ¬e_diverges env s e` -(metis_tac [small_exp_safety2, small_exp_safety1]); +Theorem untyped_safety_exp: + !s env e. (?r. small_eval env s e [] r) = ¬e_diverges env s e +Proof +metis_tac [small_exp_safety2, small_exp_safety1] +QED val to_small_st_surj = Q.prove( `∀s. ∃y. s = to_small_st y`, srw_tac[QUANT_INST_ss[record_default_qp,std_qp]][to_small_st_def]); -Theorem untyped_safety_decs - `(!d (s:'a state) env. (∃r. evaluate_dec F env s d r) = ~dec_diverges env s d) ∧ - (!ds (s:'a state) env. (?r. evaluate_decs F env s ds r) = ~decs_diverges env s ds)` - (ho_match_mp_tac dec_induction >> +Theorem untyped_safety_decs: + (!d (s:'a state) env. (∃r. evaluate_dec F env s d r) = ~dec_diverges env s d) ∧ + (!ds (s:'a state) env. (?r. evaluate_decs F env s ds r) = ~decs_diverges env s ds) +Proof + ho_match_mp_tac dec_induction >> rw [] >> rw [Once evaluate_dec_cases, Once dec_diverges_cases] >> rw [GSYM untyped_safety_exp] @@ -121,24 +124,28 @@ Theorem untyped_safety_decs eq_tac >> rw [] >> metis_tac [pair_CASES, result_nchotomy, result_distinct, decs_determ, - PAIR_EQ, result_11])); + PAIR_EQ, result_11]) +QED (* -Theorem untyped_safety_top -`!s env top. (?r. evaluate_top F env s top r) = ~top_diverges env s top` -(rw [evaluate_top_cases, top_diverges_cases] >> +Theorem untyped_safety_top: + !s env top. (?r. evaluate_top F env s top r) = ~top_diverges env s top +Proof +rw [evaluate_top_cases, top_diverges_cases] >> eq_tac >> rw [] >> rw [] >> CCONTR_TAC >> fs [] >> rw [] >> -metis_tac [top_nchotomy, untyped_safety_decs, untyped_safety_dec, pair_CASES, result_nchotomy]); +metis_tac [top_nchotomy, untyped_safety_decs, untyped_safety_dec, pair_CASES, result_nchotomy] +QED -Theorem untyped_safety_prog -`!s env tops. (?r. evaluate_prog F env s tops r) = ~prog_diverges env s tops` - (induct_on `tops` >> +Theorem untyped_safety_prog: + !s env tops. (?r. evaluate_prog F env s tops r) = ~prog_diverges env s tops +Proof + induct_on `tops` >> rw [] >- rw [Once evaluate_prog_cases, Once prog_diverges_cases] >> rw [Once evaluate_prog_cases, Once prog_diverges_cases] >> @@ -158,7 +165,8 @@ Theorem untyped_safety_prog `?s. (?err. r = (s,Rerr err)) ∨ (?env'. r = (s,Rval env'))` by metis_tac [pair_CASES, result_nchotomy] >> rw [] >- metis_tac [] - >- metis_tac [PAIR_EQ, result_11, pair_CASES, top_determ, top_unclocked])); + >- metis_tac [PAIR_EQ, result_11, pair_CASES, top_determ, top_unclocked]) +QED *) val _ = export_theory (); diff --git a/semantics/cmlPtreeConversionScript.sml b/semantics/cmlPtreeConversionScript.sml index 493a14eb46..7553986db7 100644 --- a/semantics/cmlPtreeConversionScript.sml +++ b/semantics/cmlPtreeConversionScript.sml @@ -349,13 +349,16 @@ val detuplify_def = Define` detuplify ty = [ty] ` -Theorem detuplify_pmatch `!ty. +Theorem detuplify_pmatch: + !ty. detuplify ty = case ty of Attup args => args - | ty => [ty]` - (ho_match_mp_tac (theorem "detuplify_ind") - >> fs[detuplify_def]); + | ty => [ty] +Proof + ho_match_mp_tac (theorem "detuplify_ind") + >> fs[detuplify_def] +QED val ptree_PTbase_def = Define‘ ptree_PTbase ast = diff --git a/semantics/lexer_funScript.sml b/semantics/lexer_funScript.sml index efe5e3ec27..cbe7a592ed 100644 --- a/semantics/lexer_funScript.sml +++ b/semantics/lexer_funScript.sml @@ -38,11 +38,13 @@ val read_while_def = Define ` if P c then read_while P cs (c :: s) else (IMPLODE (REVERSE s),STRING c cs))`; -Theorem read_while_thm - `!cs s cs' s'. - (read_while P cs s = (s',cs')) ==> STRLEN cs' <= STRLEN cs` - (Induct THEN SRW_TAC [][read_while_def] THEN SRW_TAC [][] THEN - RES_TAC THEN FULL_SIMP_TAC std_ss [LENGTH,LENGTH_APPEND] THEN DECIDE_TAC); +Theorem read_while_thm: + !cs s cs' s'. + (read_while P cs s = (s',cs')) ==> STRLEN cs' <= STRLEN cs +Proof + Induct THEN SRW_TAC [][read_while_def] THEN SRW_TAC [][] THEN + RES_TAC THEN FULL_SIMP_TAC std_ss [LENGTH,LENGTH_APPEND] THEN DECIDE_TAC +QED val is_single_char_symbol_def = Define ` is_single_char_symbol c = MEM c "()[]{},;"`; @@ -68,10 +70,11 @@ val read_string_def = tDefine "read_string" ` (WF_REL_TAC `measure (LENGTH o FST)` THEN REPEAT STRIP_TAC THEN Cases_on `str` THEN FULL_SIMP_TAC (srw_ss()) [] THEN DECIDE_TAC) -Theorem read_string_thm - `!s t l l' x1 x2. (read_string s t l = (x1, l', x2)) ==> - (LENGTH x2 <= LENGTH s + LENGTH t)` - (ONCE_REWRITE_TAC [EQ_SYM_EQ] +Theorem read_string_thm: + !s t l l' x1 x2. (read_string s t l = (x1, l', x2)) ==> + (LENGTH x2 <= LENGTH s + LENGTH t) +Proof + ONCE_REWRITE_TAC [EQ_SYM_EQ] THEN HO_MATCH_MP_TAC (fetch "-" "read_string_ind") THEN REPEAT STRIP_TAC THEN POP_ASSUM MP_TAC THEN ONCE_REWRITE_TAC [read_string_def] @@ -83,7 +86,8 @@ Theorem read_string_thm THEN SIMP_TAC std_ss [] THEN SRW_TAC [] [] THEN REPEAT STRIP_TAC THEN FULL_SIMP_TAC std_ss [] THEN RES_TAC THEN TRY DECIDE_TAC THEN CCONTR_TAC - THEN FULL_SIMP_TAC std_ss [LENGTH] THEN DECIDE_TAC); + THEN FULL_SIMP_TAC std_ss [LENGTH] THEN DECIDE_TAC +QED val loc_row_def = Define` loc_row n = <| row := n ; col := 1; offset := 0|>` @@ -103,14 +107,16 @@ val skip_comment_def = Define ` skip_comment (y::xs) d (loc_row (loc.row+1)) else skip_comment (y::xs) d (loc with col := loc.col + 1))` -Theorem skip_comment_thm - `!xs d l l' str. (skip_comment xs d l = SOME (str, l')) ==> LENGTH str <= LENGTH xs` - (ONCE_REWRITE_TAC [EQ_SYM_EQ] +Theorem skip_comment_thm: + !xs d l l' str. (skip_comment xs d l = SOME (str, l')) ==> LENGTH str <= LENGTH xs +Proof + ONCE_REWRITE_TAC [EQ_SYM_EQ] THEN HO_MATCH_MP_TAC (fetch "-" "skip_comment_ind") THEN REPEAT STRIP_TAC THEN POP_ASSUM MP_TAC THEN ONCE_REWRITE_TAC [skip_comment_def] THEN SRW_TAC [] [] THEN RES_TAC THEN TRY DECIDE_TAC THEN FULL_SIMP_TAC std_ss [] THEN SRW_TAC [] [] THEN RES_TAC - THEN DECIDE_TAC); + THEN DECIDE_TAC +QED val read_FFIcall_def = Define‘ (read_FFIcall "" acc loc = (ErrorS, loc, "")) ∧ @@ -124,11 +130,13 @@ val read_FFIcall_def = Define‘ read_FFIcall s0 (c::acc) (loc with col updated_by (+) 1)) ’ -Theorem read_FFIcall_reduces_input - `∀s0 a l0 t l s. - read_FFIcall s0 a l0 = (t, l, s) ⇒ LENGTH s < LENGTH s0 + 1` - (Induct >> dsimp[read_FFIcall_def, bool_case_eq] >> rw[] >> - qpat_x_assum `_ = _` (assume_tac o SYM) >> res_tac >> simp[]); +Theorem read_FFIcall_reduces_input: + ∀s0 a l0 t l s. + read_FFIcall s0 a l0 = (t, l, s) ⇒ LENGTH s < LENGTH s0 + 1 +Proof + Induct >> dsimp[read_FFIcall_def, bool_case_eq] >> rw[] >> + qpat_x_assum `_ = _` (assume_tac o SYM) >> res_tac >> simp[] +QED val isAlphaNumPrime_def = Define` isAlphaNumPrime c <=> isAlphaNum c \/ (c = #"'") \/ (c = #"_")` @@ -256,10 +264,11 @@ val listeq = CaseEq "list" val optioneq = CaseEq "option" -Theorem next_sym_LESS - `!input l s l' rest. - (next_sym input l = SOME (s, l', rest)) ==> LENGTH rest < LENGTH input` - (ho_match_mp_tac (fetch "-" "next_sym_ind") >> +Theorem next_sym_LESS: + !input l s l' rest. + (next_sym input l = SOME (s, l', rest)) ==> LENGTH rest < LENGTH input +Proof + ho_match_mp_tac (fetch "-" "next_sym_ind") >> simp[next_sym_def, bool_case_eq, listeq, optioneq] >> rw[] >> fs[] >> rpt (pairarg_tac >> fs[]) >> rveq >> fs[NOT_NIL_EXISTS_CONS] >> rveq >> fs[] >> rveq >> fs[] >> @@ -273,7 +282,8 @@ Theorem next_sym_LESS TRY (rename1 `read_FFIcall` >> imp_res_tac read_FFIcall_reduces_input >> simp[] >> NO_TAC) >> qpat_x_assum ‘SOME _ = next_sym _ _’ (assume_tac o SYM) >> - first_x_assum drule >> simp[]); + first_x_assum drule >> simp[] +QED val _ = Define ` init_loc = <| row := 1; col := 1; offset := 0|>` @@ -374,15 +384,17 @@ val next_token_def = Define ` | SOME (sym, locs, rest_of_input) => SOME (token_of_sym sym, locs, rest_of_input)`; -Theorem next_token_LESS - `!s l l' rest input. (next_token input l = SOME (s, l', rest)) ==> - LENGTH rest < LENGTH input` - (NTAC 5 STRIP_TAC THEN Cases_on `next_sym input l` +Theorem next_token_LESS: + !s l l' rest input. (next_token input l = SOME (s, l', rest)) ==> + LENGTH rest < LENGTH input +Proof + NTAC 5 STRIP_TAC THEN Cases_on `next_sym input l` THEN ASM_SIMP_TAC (srw_ss()) [next_token_def] THEN every_case_tac THEN ASM_SIMP_TAC (srw_ss()) [] THEN IMP_RES_TAC next_sym_LESS THEN REPEAT STRIP_TAC - THEN FULL_SIMP_TAC std_ss []); + THEN FULL_SIMP_TAC std_ss [] +QED (* top-level lexer specification *) diff --git a/semantics/proofs/cmlPtreeConversionPropsScript.sml b/semantics/proofs/cmlPtreeConversionPropsScript.sml index 2d1f8756c4..c0d2a68def 100644 --- a/semantics/proofs/cmlPtreeConversionPropsScript.sml +++ b/semantics/proofs/cmlPtreeConversionPropsScript.sml @@ -31,21 +31,25 @@ val tyname_to_AST_def = Define‘ tyname_to_AST _ = ARB ’; -Theorem tyname_inverted - `∀id. user_expressible_tyname id ⇒ - ptree_Tyop (tyname_to_AST id) = SOME id` - (Cases >> +Theorem tyname_inverted: + ∀id. user_expressible_tyname id ⇒ + ptree_Tyop (tyname_to_AST id) = SOME id +Proof + Cases >> simp[ptree_Tyop_def, tyname_to_AST_def, ptree_UQTyop_def] >> rename [‘Long m j’] >> Cases_on ‘j’ >> - simp[ptree_Tyop_def, tyname_to_AST_def, ptree_UQTyop_def]); + simp[ptree_Tyop_def, tyname_to_AST_def, ptree_UQTyop_def] +QED -Theorem tyname_validptree - `∀id. user_expressible_tyname id ⇒ +Theorem tyname_validptree: + ∀id. user_expressible_tyname id ⇒ valid_ptree cmlG (tyname_to_AST id) ∧ - ptree_head (tyname_to_AST id) = NN nTyOp` - (Cases >> simp[tyname_to_AST_def, cmlG_FDOM, cmlG_applied] >> + ptree_head (tyname_to_AST id) = NN nTyOp +Proof + Cases >> simp[tyname_to_AST_def, cmlG_FDOM, cmlG_applied] >> rename [‘Long m j’] >> Cases_on ‘j’ >> - simp[tyname_to_AST_def, cmlG_applied, cmlG_FDOM]); + simp[tyname_to_AST_def, cmlG_applied, cmlG_FDOM] +QED val user_expressible_type_def = tDefine "user_expressible_type" ‘ @@ -124,16 +128,18 @@ val type_to_AST_def = tDefine "type_to_AST" ‘ | INR (INL tyl) => ast_t1_size tyl | INR (INR tyl) => ast_t1_size tyl)’) -Theorem destTyvarPT_tyname_to_AST - `∀i. user_expressible_tyname i ⇒ destTyvarPT (tyname_to_AST i) = NONE` - (Cases >> simp[tyname_to_AST_def] >> +Theorem destTyvarPT_tyname_to_AST: + ∀i. user_expressible_tyname i ⇒ destTyvarPT (tyname_to_AST i) = NONE +Proof + Cases >> simp[tyname_to_AST_def] >> rename [‘Long _ j’] >> Cases_on ‘j’ >> - simp[tyname_to_AST_def]); + simp[tyname_to_AST_def] +QED val _ = temp_type_abbrev ("PT", “:(token,MMLnonT,α) parsetree”); -Theorem types_inverted - `(∀ty. +Theorem types_inverted: + (∀ty. user_expressible_type ty ⇒ ptree_Type nType (type_to_AST ty : α PT) = SOME ty ∧ valid_ptree cmlG (type_to_AST ty : α PT) ∧ @@ -147,8 +153,9 @@ Theorem types_inverted EVERY user_expressible_type tys ∧ tys ≠ [] ⇒ ptree_PType (typel_to_AST_PType tys : α PT) = SOME tys ∧ valid_ptree cmlG (typel_to_AST_PType tys : α PT) ∧ - ptree_head (typel_to_AST_PType tys : α PT) = NN nPType)` - (ho_match_mp_tac (theorem "type_to_AST_ind") >> + ptree_head (typel_to_AST_PType tys : α PT) = NN nPType) +Proof + ho_match_mp_tac (theorem "type_to_AST_ind") >> rpt conj_tac >> simp[] >- simp[ptree_Type_def, type_to_AST_def, tuplify_def, cmlG_FDOM, cmlG_applied] >- (rpt gen_tac >> ntac 2 strip_tac >> rename [‘Atfun dty rty’] >> @@ -186,24 +193,31 @@ Theorem types_inverted dsimp[ptree_Type_def, tokcheck_def, cmlG_applied, cmlG_FDOM]) >- (simp[type_to_AST_def] >> rpt strip_tac >> dsimp[Ntimes ptree_Type_def 6, tokcheck_def, - cmlG_FDOM, cmlG_applied])); + cmlG_FDOM, cmlG_applied]) +QED -Theorem type_to_AST_injection - `INJ type_to_AST +Theorem type_to_AST_injection: + INJ type_to_AST { t | user_expressible_type t } - { ast | valid_ptree cmlG ast ∧ ptree_head ast = NN nType }` - (simp[INJ_DEF] >> metis_tac[types_inverted, SOME_11]); + { ast | valid_ptree cmlG ast ∧ ptree_head ast = NN nType } +Proof + simp[INJ_DEF] >> metis_tac[types_inverted, SOME_11] +QED -Theorem ptree_Type_surjection - `∀t. user_expressible_type t ⇒ +Theorem ptree_Type_surjection: + ∀t. user_expressible_type t ⇒ ∃pt. valid_ptree cmlG pt ∧ ptree_head pt = NN nType ∧ - ptree_Type nType pt = SOME t` - (metis_tac[types_inverted]); + ptree_Type nType pt = SOME t +Proof + metis_tac[types_inverted] +QED -Theorem ptree_head_TOK - `(ptree_head pt = TOK sym ⇔ ?l. pt = Lf (TOK sym,l)) ∧ - (TOK sym = ptree_head pt ⇔ ?l. pt = Lf (TOK sym,l))` - (Cases_on `pt` >> Cases_on`p` >> simp[] >> metis_tac[]); +Theorem ptree_head_TOK: + (ptree_head pt = TOK sym ⇔ ?l. pt = Lf (TOK sym,l)) ∧ + (TOK sym = ptree_head pt ⇔ ?l. pt = Lf (TOK sym,l)) +Proof + Cases_on `pt` >> Cases_on`p` >> simp[] >> metis_tac[] +QED val _ = export_rewrites ["ptree_head_TOK"] val start = @@ -212,35 +226,42 @@ val start = strip_tac >> rveq >> fs[cmlG_FDOM, cmlG_applied, MAP_EQ_CONS] >> rveq >> fs[MAP_EQ_CONS] >> rveq -Theorem UQTyOp_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NT (mkNT nUQTyOp) ∧ +Theorem UQTyOp_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NT (mkNT nUQTyOp) ∧ MAP TK toks = ptree_fringe pt ⇒ - ∃utyop. ptree_UQTyop pt = SOME utyop` - (start >> simp[ptree_UQTyop_def, tokcheck_def]); + ∃utyop. ptree_UQTyop pt = SOME utyop +Proof + start >> simp[ptree_UQTyop_def, tokcheck_def] +QED -Theorem TyOp_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NT (mkNT nTyOp) ∧ +Theorem TyOp_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NT (mkNT nTyOp) ∧ MAP TK toks = ptree_fringe pt ⇒ - ∃tyop. ptree_Tyop pt = SOME tyop ∧ user_expressible_tyname tyop` - (start >> simp[ptree_Tyop_def] >> + ∃tyop. ptree_Tyop pt = SOME tyop ∧ user_expressible_tyname tyop +Proof + start >> simp[ptree_Tyop_def] >> asm_match `valid_ptree cmlG pt'` >> `destLf pt' = NONE` by (Cases_on `pt'` >> fs[MAP_EQ_CONS] >> rename [`Lf tokloc`] >> Cases_on `tokloc` >> rveq >> fs[] >> rveq >> fs[]) >> - dsimp[] >> metis_tac [UQTyOp_OK]); + dsimp[] >> metis_tac [UQTyOp_OK] +QED -Theorem TyvarN_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NT (mkNT nTyvarN) ∧ +Theorem TyvarN_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NT (mkNT nTyvarN) ∧ MAP TK toks = ptree_fringe pt ⇒ - ∃tyvn. ptree_TyvarN pt = SOME tyvn` - (start >> simp[ptree_TyvarN_def]); + ∃tyvn. ptree_TyvarN pt = SOME tyvn +Proof + start >> simp[ptree_TyvarN_def] +QED -Theorem TyVarList_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NT (mkNT nTyVarList) ∧ +Theorem TyVarList_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NT (mkNT nTyVarList) ∧ MAP TK toks = ptree_fringe pt ⇒ - ∃tyvnms. ptree_linfix nTyVarList CommaT ptree_TyvarN pt = SOME tyvnms` - (map_every qid_spec_tac [`toks`, `pt`] >> + ∃tyvnms. ptree_linfix nTyVarList CommaT ptree_TyvarN pt = SOME tyvnms +Proof + map_every qid_spec_tac [`toks`, `pt`] >> ho_match_mp_tac grammarTheory.ptree_ind >> conj_tac >> simp[MAP_EQ_CONS, cmlG_applied, cmlG_FDOM, Once FORALL_PROD] >> rpt strip_tac >> rveq >> @@ -248,29 +269,34 @@ Theorem TyVarList_OK >- (simp[ptree_linfix_def] >> metis_tac [TyvarN_OK]) >> simp_tac (srw_ss()) [Once ptree_linfix_def] >> fs[MAP_EQ_APPEND, MAP_EQ_CONS, tokcheck_def] >> rveq >> - metis_tac [TyvarN_OK]); + metis_tac [TyvarN_OK] +QED -Theorem TypeName_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NT (mkNT nTypeName) ∧ +Theorem TypeName_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NT (mkNT nTypeName) ∧ MAP TOK toks = ptree_fringe pt ⇒ - ∃tn. ptree_TypeName pt = SOME tn` - (start >> simp[ptree_TypeName_def, tokcheck_def] >| [ + ∃tn. ptree_TypeName pt = SOME tn +Proof + start >> simp[ptree_TypeName_def, tokcheck_def] >| [ metis_tac[UQTyOp_OK], full_simp_tac (srw_ss() ++ DNF_ss) [MAP_EQ_CONS, MAP_EQ_APPEND] >> metis_tac[UQTyOp_OK, TyVarList_OK], metis_tac[UQTyOp_OK] - ]); + ] +QED -Theorem tuplify_OK - `tl <> [] ⇒ +Theorem tuplify_OK: + tl <> [] ⇒ ∃t. tuplify tl = SOME t ∧ - (EVERY user_expressible_type tl ⇒ user_expressible_type t)` - (strip_tac >> + (EVERY user_expressible_type tl ⇒ user_expressible_type t) +Proof + strip_tac >> `∃h tl0. tl = h::tl0` by (Cases_on `tl` >> fs[]) >> - Cases_on `tl0` >> simp[tuplify_def]); + Cases_on `tl0` >> simp[tuplify_def] +QED -Theorem Type_OK0 - `valid_ptree cmlG pt ∧ MAP TK toks = ptree_fringe pt ⇒ +Theorem Type_OK0: + valid_ptree cmlG pt ∧ MAP TK toks = ptree_fringe pt ⇒ (N ∈ {nType; nDType; nTbase} ∧ ptree_head pt = NT (mkNT N) ⇒ @@ -281,8 +307,9 @@ Theorem Type_OK0 (ptree_head pt = NT (mkNT nTypeList1) ⇒ ∃tl. ptree_TypeList1 pt = SOME tl ∧ EVERY user_expressible_type tl) ∧ (ptree_head pt = NT (mkNT nTypeList2) ⇒ - ∃tl. ptree_Typelist2 pt = SOME tl ∧ EVERY user_expressible_type tl)` - (map_every qid_spec_tac [`N`, `toks`, `pt`] >> + ∃tl. ptree_Typelist2 pt = SOME tl ∧ EVERY user_expressible_type tl) +Proof + map_every qid_spec_tac [`N`, `toks`, `pt`] >> ho_match_mp_tac grammarTheory.ptree_ind >> conj_tac >> simp[Once FORALL_PROD] >> dsimp[] >> rpt strip_tac >> @@ -305,7 +332,8 @@ Theorem Type_OK0 >- (dsimp[] >> metis_tac[]) >- (dsimp[] >> metis_tac[]) >- (dsimp[] >> metis_tac[]) - >- (dsimp[] >> metis_tac[])); + >- (dsimp[] >> metis_tac[]) +QED fun okify c q th = th |> UNDISCH |> c |> Q.INST [`N` |-> q] @@ -314,42 +342,52 @@ fun okify c q th = val Type_OK = save_thm("Type_OK", okify CONJUNCT1 `nType` Type_OK0); -Theorem V_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NT (mkNT nV) ∧ +Theorem V_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NT (mkNT nV) ∧ MAP TK toks = ptree_fringe pt ⇒ - ∃i. ptree_V pt = SOME i` - (start >> simp[ptree_V_def]); + ∃i. ptree_V pt = SOME i +Proof + start >> simp[ptree_V_def] +QED -Theorem FQV_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NT (mkNT nFQV) ∧ +Theorem FQV_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NT (mkNT nFQV) ∧ MAP TK toks = ptree_fringe pt ⇒ - ∃i. ptree_FQV pt = SOME i` - (start >> simp[ptree_FQV_def] + ∃i. ptree_FQV pt = SOME i +Proof + start >> simp[ptree_FQV_def] >- metis_tac[V_OK, optionTheory.OPTION_MAP_DEF, optionTheory.OPTION_CHOICE_def] >> - simp[ptree_V_def]); + simp[ptree_V_def] +QED -Theorem UQConstructorName_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NT (mkNT nUQConstructorName) ∧ +Theorem UQConstructorName_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NT (mkNT nUQConstructorName) ∧ MAP TK toks = ptree_fringe pt ⇒ - ∃i. ptree_UQConstructorName pt = SOME i` - (start >> simp[ptree_UQConstructorName_def]); + ∃i. ptree_UQConstructorName pt = SOME i +Proof + start >> simp[ptree_UQConstructorName_def] +QED val n = SIMP_RULE bool_ss [GSYM AND_IMP_INTRO] -Theorem ConstructorName_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NT (mkNT nConstructorName) ∧ +Theorem ConstructorName_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NT (mkNT nConstructorName) ∧ MAP TK toks = ptree_fringe pt ⇒ - ∃i. ptree_ConstructorName pt = SOME i` - (start >> simp[ptree_ConstructorName_def] + ∃i. ptree_ConstructorName pt = SOME i +Proof + start >> simp[ptree_ConstructorName_def] >- (erule strip_assume_tac (n UQConstructorName_OK) >> simp[]) >> - simp[ptree_UQConstructorName_def]); + simp[ptree_UQConstructorName_def] +QED -Theorem Ops_OK0 - `N ∈ {nMultOps; nAddOps; nListOps; nRelOps; nCompOps} ∧ valid_ptree cmlG pt ∧ +Theorem Ops_OK0: + N ∈ {nMultOps; nAddOps; nListOps; nRelOps; nCompOps} ∧ valid_ptree cmlG pt ∧ MAP TK toks = ptree_fringe pt ∧ ptree_head pt = NT (mkNT N) ⇒ - ∃opv. ptree_Op pt = SOME opv` - (start >> simp[ptree_Op_def, tokcheck_def, tokcheckl_def]); + ∃opv. ptree_Op pt = SOME opv +Proof + start >> simp[ptree_Op_def, tokcheck_def, tokcheckl_def] +QED val MAP_TK11 = Q.prove( `∀l1 l2. MAP TK l1 = MAP TK l2 ⇔ l1 = l2`, @@ -357,30 +395,33 @@ val MAP_TK11 = Q.prove( Cases_on `l2` >> simp[]); val _ = augment_srw_ss [rewrites [MAP_TK11]] -Theorem OpID_OK - `ptree_head pt = NN nOpID ∧ MAP TK toks = ptree_fringe pt ∧ +Theorem OpID_OK: + ptree_head pt = NN nOpID ∧ MAP TK toks = ptree_fringe pt ∧ valid_ptree cmlG pt ⇒ ∃astv. ptree_OpID pt = SOME astv ∧ ((∃cnm. astv = Con cnm []) ∨ - (∃v. astv = Var v))` - (map_every qid_spec_tac [`toks`, `pt`] >> + (∃v. astv = Var v)) +Proof + map_every qid_spec_tac [`toks`, `pt`] >> ho_match_mp_tac grammarTheory.ptree_ind >> dsimp[] >> conj_tac >> simp[Once FORALL_PROD] >> rpt strip_tac >> fs[MAP_EQ_CONS, cmlG_FDOM, cmlG_applied, MAP_EQ_APPEND] >> rveq >> fs[MAP_EQ_CONS, MAP_EQ_APPEND] >> simp[ptree_OpID_def, isConstructor_def, isSymbolicConstructor_def, ifM_def] >> - rw[] >> Cases_on `s` >> fs[oHD_def] >> rw[]); + rw[] >> Cases_on `s` >> fs[oHD_def] >> rw[] +QED val std = rpt (first_x_assum (erule strip_assume_tac o n)) >> simp[] -Theorem Pattern_OK0 - `valid_ptree cmlG pt ∧ MAP TK toks = ptree_fringe pt ⇒ +Theorem Pattern_OK0: + valid_ptree cmlG pt ∧ MAP TK toks = ptree_fringe pt ⇒ (N ∈ {nPattern; nPtuple; nPapp; nPbase; nPcons; nPConApp} ∧ ptree_head pt = NT (mkNT N) ⇒ ∃p. ptree_Pattern N pt = SOME p) ∧ (ptree_head pt = NN nPatternList ⇒ - ∃pl. ptree_Plist pt = SOME pl ∧ pl <> [])` - (map_every qid_spec_tac [`N`, `toks`, `pt`] >> + ∃pl. ptree_Plist pt = SOME pl ∧ pl <> []) +Proof + map_every qid_spec_tac [`N`, `toks`, `pt`] >> ho_match_mp_tac grammarTheory.ptree_ind >> conj_tac >> simp[Once FORALL_PROD] >> dsimp[] >> rpt strip_tac >> @@ -415,20 +456,24 @@ Theorem Pattern_OK0 >- simp[ptree_Pattern_def, ptree_ConstructorName_def, ptree_V_def] >- (erule strip_assume_tac (n OpID_OK) >> simp[EtoPat_def] >> rename [`Var v`] >> Cases_on `v` >> simp[EtoPat_def]) - >- (erule strip_assume_tac (n ConstructorName_OK) >> simp[])); + >- (erule strip_assume_tac (n ConstructorName_OK) >> simp[]) +QED val Pattern_OK = save_thm("Pattern_OK", okify CONJUNCT1 `nPattern` Pattern_OK0); -Theorem Eseq_encode_OK - `∀l. l <> [] ⇒ ∃e. Eseq_encode l = SOME e` - (Induct >> simp[] >> - Cases_on `l` >> simp[Eseq_encode_def]); +Theorem Eseq_encode_OK: + ∀l. l <> [] ⇒ ∃e. Eseq_encode l = SOME e +Proof + Induct >> simp[] >> + Cases_on `l` >> simp[Eseq_encode_def] +QED -Theorem PbaseList1_OK - `valid_ptree cmlG pt ∧ MAP TK toks = ptree_fringe pt ∧ +Theorem PbaseList1_OK: + valid_ptree cmlG pt ∧ MAP TK toks = ptree_fringe pt ∧ ptree_head pt = NT (mkNT nPbaseList1) ⇒ - ∃pl. ptree_PbaseList1 pt = SOME pl ∧ 0 < LENGTH pl` - (map_every qid_spec_tac [`toks`, `pt`] >> + ∃pl. ptree_PbaseList1 pt = SOME pl ∧ 0 < LENGTH pl +Proof + map_every qid_spec_tac [`toks`, `pt`] >> ho_match_mp_tac grammarTheory.ptree_ind >> dsimp[] >> conj_tac >> simp[Once FORALL_PROD] >> rpt strip_tac >> fs[MAP_EQ_CONS, cmlG_FDOM, cmlG_applied, MAP_EQ_APPEND] >> rveq >> @@ -442,17 +487,20 @@ Theorem PbaseList1_OK mp_tac (Pattern_OK0 |> Q.INST [`N` |-> `nPbase`, `pt` |-> `pbt`, `toks` |-> `pbtoks`] |> n) >> - simp[] >> fs[])) + simp[] >> fs[]) +QED -Theorem Eliteral_OK - `valid_ptree cmlG pt ∧ MAP TK toks = ptree_fringe pt ∧ +Theorem Eliteral_OK: + valid_ptree cmlG pt ∧ MAP TK toks = ptree_fringe pt ∧ ptree_head pt = NT (mkNT nEliteral) ⇒ - ∃t. ptree_Eliteral pt = SOME t` - (start >> simp[ptree_Eliteral_def]); + ∃t. ptree_Eliteral pt = SOME t +Proof + start >> simp[ptree_Eliteral_def] +QED val _ = print "The E_OK proof takes a while\n" -Theorem E_OK0 - `valid_ptree cmlG pt ∧ MAP TK toks = ptree_fringe pt ⇒ +Theorem E_OK0: + valid_ptree cmlG pt ∧ MAP TK toks = ptree_fringe pt ⇒ (N ∈ {nE; nE'; nEhandle; nElogicOR; nElogicAND; nEtuple; nEmult; nEadd; nElistop; nErel; nEcomp; nEbefore; nEtyped; nEapp; nEbase} ∧ @@ -472,8 +520,9 @@ Theorem E_OK0 (ptree_head pt = NT (mkNT nLetDec) ⇒ ∃ld. ptree_LetDec pt = SOME ld) ∧ (ptree_head pt = NT (mkNT nAndFDecls) ⇒ ∃fds. ptree_AndFDecls pt = SOME fds) ∧ - (ptree_head pt = NT (mkNT nFDecl) ⇒ ∃fd. ptree_FDecl pt = SOME fd)` - (map_every qid_spec_tac [`N`, `toks`, `pt`] >> + (ptree_head pt = NT (mkNT nFDecl) ⇒ ∃fd. ptree_FDecl pt = SOME fd) +Proof + map_every qid_spec_tac [`N`, `toks`, `pt`] >> ho_match_mp_tac grammarTheory.ptree_ind >> conj_tac >> simp[Once FORALL_PROD] >> dsimp[] >> rpt strip_tac >> fs[MAP_EQ_CONS, cmlG_FDOM, cmlG_applied, MAP_EQ_APPEND] >> @@ -523,36 +572,41 @@ Theorem E_OK0 >- (erule strip_assume_tac (n Pattern_OK) >> std) >- (dsimp[] >> map_every (erule strip_assume_tac o n) [V_OK, PbaseList1_OK] >> - asm_match `0 < LENGTH pl` >> Cases_on `pl` >> fs[oHD_def] >> std)); + asm_match `0 < LENGTH pl` >> Cases_on `pl` >> fs[oHD_def] >> std) +QED val E_OK = save_thm("E_OK", okify CONJUNCT1 `nE` E_OK0) val AndFDecls_OK = save_thm( "AndFDecls_OK", okify (last o #1 o front_last o CONJUNCTS) `v` E_OK0); -Theorem PTbase_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NN nPTbase ∧ +Theorem PTbase_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NN nPTbase ∧ MAP TK toks = ptree_fringe pt ⇒ - ∃ty. ptree_PTbase pt = SOME ty` - (start >> fs[MAP_EQ_APPEND, FORALL_AND_THM, DISJ_IMP_THM] >> rveq >> + ∃ty. ptree_PTbase pt = SOME ty +Proof + start >> fs[MAP_EQ_APPEND, FORALL_AND_THM, DISJ_IMP_THM] >> rveq >> simp[ptree_PTbase_def, tokcheck_def] >- (erule strip_assume_tac (n TyOp_OK) >> simp[] >> rename [‘destTyvarPT pt’] >> Cases_on ‘OPTION_MAP Atvar (destTyvarPT pt)’ >> simp[]) >> - metis_tac[Type_OK]); + metis_tac[Type_OK] +QED -Theorem TbaseList_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NN nTbaseList ∧ +Theorem TbaseList_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NN nTbaseList ∧ MAP TK toks = ptree_fringe pt ⇒ - ∃tys. ptree_TbaseList pt = SOME tys` - (map_every qid_spec_tac [`toks`, `pt`] >> + ∃tys. ptree_TbaseList pt = SOME tys +Proof + map_every qid_spec_tac [`toks`, `pt`] >> ho_match_mp_tac grammarTheory.ptree_ind >> conj_tac >> simp[Once FORALL_PROD] >> gen_tac >> strip_tac >> simp[cmlG_applied, cmlG_FDOM] >> rpt strip_tac >> rveq >> fs[MAP_EQ_CONS, FORALL_AND_THM, DISJ_IMP_THM] >> rveq >> simp[Once ptree_TbaseList_def] >> dsimp[] >> fs[FORALL_AND_THM, DISJ_IMP_THM, MAP_EQ_APPEND] >> - metis_tac[PTbase_OK]); + metis_tac[PTbase_OK] +QED Theorem Dconstructor_OK: valid_ptree cmlG pt ∧ ptree_head pt = NN nDconstructor ∧ @@ -566,64 +620,75 @@ Proof simp[] QED -Theorem DtypeCons_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NN nDtypeCons ∧ +Theorem DtypeCons_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NN nDtypeCons ∧ MAP TK toks = ptree_fringe pt ⇒ - ∃dtc. ptree_linfix nDtypeCons BarT ptree_Dconstructor pt = SOME dtc` - (map_every qid_spec_tac [`toks`, `pt`] >> + ∃dtc. ptree_linfix nDtypeCons BarT ptree_Dconstructor pt = SOME dtc +Proof + map_every qid_spec_tac [`toks`, `pt`] >> ho_match_mp_tac grammarTheory.ptree_ind >> conj_tac >> simp[Once FORALL_PROD] >> simp[MAP_EQ_CONS, cmlG_applied, cmlG_FDOM] >> rpt strip_tac >> rveq >> full_simp_tac (srw_ss() ++ DNF_ss) [MAP_EQ_APPEND, MAP_EQ_CONS] >> simp[Once ptree_linfix_def, tokcheck_def] >> - erule strip_assume_tac (n Dconstructor_OK) >> simp[]); + erule strip_assume_tac (n Dconstructor_OK) >> simp[] +QED -Theorem DtypeDecl_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NN nDtypeDecl ∧ +Theorem DtypeDecl_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NN nDtypeDecl ∧ MAP TK toks = ptree_fringe pt ⇒ - ∃dtd. ptree_DtypeDecl pt = SOME dtd` - (start >> fs[MAP_EQ_APPEND, FORALL_AND_THM, DISJ_IMP_THM] >> + ∃dtd. ptree_DtypeDecl pt = SOME dtd +Proof + start >> fs[MAP_EQ_APPEND, FORALL_AND_THM, DISJ_IMP_THM] >> rveq >> simp[ptree_DtypeDecl_def] >> map_every (erule strip_assume_tac o n) [DtypeCons_OK, TypeName_OK] >> - simp[tokcheck_def]); + simp[tokcheck_def] +QED -Theorem DtypeDecls_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NN nDtypeDecls ∧ +Theorem DtypeDecls_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NN nDtypeDecls ∧ MAP TK toks = ptree_fringe pt ⇒ - ∃td. ptree_linfix nDtypeDecls AndT ptree_DtypeDecl pt = SOME td` - (map_every qid_spec_tac [`toks`, `pt`] >> + ∃td. ptree_linfix nDtypeDecls AndT ptree_DtypeDecl pt = SOME td +Proof + map_every qid_spec_tac [`toks`, `pt`] >> ho_match_mp_tac grammarTheory.ptree_ind >> conj_tac >> simp[Once FORALL_PROD] >> simp[MAP_EQ_CONS, cmlG_applied, cmlG_FDOM] >> rpt strip_tac >> rveq >> full_simp_tac (srw_ss() ++ DNF_ss) [MAP_EQ_APPEND, MAP_EQ_CONS] >> simp[Once ptree_linfix_def, tokcheck_def] >> - erule strip_assume_tac (n DtypeDecl_OK) >> simp[]); + erule strip_assume_tac (n DtypeDecl_OK) >> simp[] +QED -Theorem TypeDec_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NN nTypeDec ∧ +Theorem TypeDec_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NN nTypeDec ∧ MAP TK toks = ptree_fringe pt ⇒ - ∃td. ptree_TypeDec pt = SOME td` - (start >> fs[MAP_EQ_APPEND, FORALL_AND_THM, DISJ_IMP_THM] >> + ∃td. ptree_TypeDec pt = SOME td +Proof + start >> fs[MAP_EQ_APPEND, FORALL_AND_THM, DISJ_IMP_THM] >> rveq >> fs[MAP_EQ_CONS] >> simp[ptree_TypeDec_def, tokcheck_def] >> - erule strip_assume_tac (n DtypeDecls_OK) >> simp[]); + erule strip_assume_tac (n DtypeDecls_OK) >> simp[] +QED -Theorem TypeAbbrevDec_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NN nTypeAbbrevDec ∧ +Theorem TypeAbbrevDec_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NN nTypeAbbrevDec ∧ MAP TK toks = ptree_fringe pt ⇒ - ∃td. ptree_TypeAbbrevDec pt = SOME td` - (start >> fs[MAP_EQ_APPEND, FORALL_AND_THM, DISJ_IMP_THM] >> + ∃td. ptree_TypeAbbrevDec pt = SOME td +Proof + start >> fs[MAP_EQ_APPEND, FORALL_AND_THM, DISJ_IMP_THM] >> rveq >> fs[MAP_EQ_CONS] >> rveq >> simp[ptree_TypeAbbrevDec_def, pairTheory.EXISTS_PROD, PULL_EXISTS, tokcheck_def] >> metis_tac[SIMP_RULE (srw_ss()) [pairTheory.EXISTS_PROD] TypeName_OK, - Type_OK]); + Type_OK] +QED -Theorem Decl_OK - ‘valid_ptree cmlG pt ∧ MAP TK toks = ptree_fringe pt ⇒ +Theorem Decl_OK: + valid_ptree cmlG pt ∧ MAP TK toks = ptree_fringe pt ⇒ (ptree_head pt = NN nDecl ⇒ ∃d. ptree_Decl pt = SOME d) ∧ - (ptree_head pt = NN nDecls ⇒ ∃d. ptree_Decls pt = SOME d)’ - (map_every qid_spec_tac [‘toks’, ‘pt’] >> + (ptree_head pt = NN nDecls ⇒ ∃d. ptree_Decls pt = SOME d) +Proof + map_every qid_spec_tac [‘toks’, ‘pt’] >> ho_match_mp_tac grammarTheory.ptree_ind >> rw[] >- (rename [‘Lf p’] >> Cases_on ‘p’ >> fs[]) >- (rename [‘Lf p’] >> Cases_on ‘p’ >> fs[]) @@ -646,30 +711,36 @@ Theorem Decl_OK fs[cmlG_FDOM, cmlG_applied, MAP_EQ_CONS] >> rveq >> fs[MAP_EQ_CONS, MAP_EQ_APPEND] >> rveq >> simp[Once ptree_Decl_def, tokcheckl_def, tokcheck_def] >> dsimp[] >> - rw[] >> metis_tac[])); + rw[] >> metis_tac[]) +QED -Theorem OptTypEqn_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NN nOptTypEqn ∧ +Theorem OptTypEqn_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NN nOptTypEqn ∧ MAP TK toks = ptree_fringe pt ⇒ - ∃typopt. ptree_OptTypEqn pt = SOME typopt` - (start >> fs[DISJ_IMP_THM, FORALL_AND_THM] >> - simp[ptree_OptTypEqn_def, tokcheck_def] >> metis_tac[Type_OK]); + ∃typopt. ptree_OptTypEqn pt = SOME typopt +Proof + start >> fs[DISJ_IMP_THM, FORALL_AND_THM] >> + simp[ptree_OptTypEqn_def, tokcheck_def] >> metis_tac[Type_OK] +QED -Theorem SpecLine_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NN nSpecLine ∧ +Theorem SpecLine_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NN nSpecLine ∧ MAP TK toks = ptree_fringe pt ⇒ - ∃sl. ptree_SpecLine pt = SOME sl` - (start >> fs[MAP_EQ_APPEND, MAP_EQ_CONS, FORALL_AND_THM, DISJ_IMP_THM] >> + ∃sl. ptree_SpecLine pt = SOME sl +Proof + start >> fs[MAP_EQ_APPEND, MAP_EQ_CONS, FORALL_AND_THM, DISJ_IMP_THM] >> rveq >> simp[ptree_SpecLine_def, pairTheory.EXISTS_PROD, PULL_EXISTS, tokcheckl_def, tokcheck_def] >> metis_tac[V_OK, Type_OK, TypeName_OK, TypeDec_OK, Dconstructor_OK, - pairTheory.pair_CASES, OptTypEqn_OK]); + pairTheory.pair_CASES, OptTypEqn_OK] +QED -Theorem SpecLineList_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NN nSpecLineList ∧ +Theorem SpecLineList_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NN nSpecLineList ∧ MAP TK toks = ptree_fringe pt ⇒ - ∃sl. ptree_SpeclineList pt = SOME sl` - (map_every qid_spec_tac [`toks`, `pt`] >> + ∃sl. ptree_SpeclineList pt = SOME sl +Proof + map_every qid_spec_tac [`toks`, `pt`] >> ho_match_mp_tac grammarTheory.ptree_ind >> conj_tac >> simp[Once FORALL_PROD] >> simp[MAP_EQ_CONS, cmlG_applied, cmlG_FDOM] >> rpt strip_tac >> rveq >> @@ -679,28 +750,34 @@ Theorem SpecLineList_OK erule strip_assume_tac (n SpecLine_OK) >> simp[] >> asm_match `ptree_head pt' = NN nSpecLine` (* >> Cases_on `pt'` - >- (rename[`Lf p`] >> Cases_on `p` >> fs[]) >> simp[] *)) + >- (rename[`Lf p`] >> Cases_on `p` >> fs[]) >> simp[] *) +QED -Theorem StructName_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NN nStructName ∧ +Theorem StructName_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NN nStructName ∧ MAP TK toks = ptree_fringe pt ⇒ - ∃sl. ptree_StructName pt = SOME sl` - (start >> fs[MAP_EQ_APPEND, MAP_EQ_CONS, FORALL_AND_THM, DISJ_IMP_THM] >> - rveq >> simp[ptree_StructName_def]); + ∃sl. ptree_StructName pt = SOME sl +Proof + start >> fs[MAP_EQ_APPEND, MAP_EQ_CONS, FORALL_AND_THM, DISJ_IMP_THM] >> + rveq >> simp[ptree_StructName_def] +QED -Theorem SignatureValue_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NN nSignatureValue ∧ +Theorem SignatureValue_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NN nSignatureValue ∧ MAP TK toks = ptree_fringe pt ⇒ - ∃sv. ptree_SignatureValue pt = SOME sv` - (start >> fs[MAP_EQ_APPEND, MAP_EQ_CONS, FORALL_AND_THM, DISJ_IMP_THM] >> + ∃sv. ptree_SignatureValue pt = SOME sv +Proof + start >> fs[MAP_EQ_APPEND, MAP_EQ_CONS, FORALL_AND_THM, DISJ_IMP_THM] >> rveq >> simp[ptree_SignatureValue_def, tokcheckl_def, tokcheck_def] >> - metis_tac[SpecLineList_OK, oneTheory.one]); + metis_tac[SpecLineList_OK, oneTheory.one] +QED -Theorem Structure_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NN nStructure ∧ +Theorem Structure_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NN nStructure ∧ MAP TK toks = ptree_fringe pt ⇒ - ∃s. ptree_Structure pt = SOME s` - (start >> fs[MAP_EQ_APPEND, MAP_EQ_CONS, FORALL_AND_THM, DISJ_IMP_THM] >> + ∃s. ptree_Structure pt = SOME s +Proof + start >> fs[MAP_EQ_APPEND, MAP_EQ_CONS, FORALL_AND_THM, DISJ_IMP_THM] >> rveq >> simp[ptree_Structure_def] >> rpt (Q.PAT_X_ASSUM `X = ptree_head Y` (assume_tac o SYM)) >> map_every (erule strip_assume_tac o n) [Decl_OK, StructName_OK] >> @@ -711,24 +788,28 @@ Theorem Structure_OK rename[`Nd p`] >> Cases_on `p` >> fs[] >> fs[cmlG_FDOM, cmlG_applied, MAP_EQ_CONS] >> rveq >> fs[DISJ_IMP_THM, FORALL_AND_THM, MAP_EQ_CONS] >> - metis_tac[SignatureValue_OK, oneTheory.one]); + metis_tac[SignatureValue_OK, oneTheory.one] +QED -Theorem TopLevelDec_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NN nTopLevelDec ∧ +Theorem TopLevelDec_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NN nTopLevelDec ∧ MAP TK toks = ptree_fringe pt ⇒ - ∃t. ptree_TopLevelDec pt = SOME t` - (start + ∃t. ptree_TopLevelDec pt = SOME t +Proof + start >- (erule strip_assume_tac (n Structure_OK) >> simp[ptree_TopLevelDec_def]) >> erule strip_assume_tac (n Decl_OK) >> simp[ptree_TopLevelDec_def] >> rename1 `ptree_Structure pt` >> - Cases_on `ptree_Structure pt` >> simp[]); + Cases_on `ptree_Structure pt` >> simp[] +QED -Theorem TopLevelDecs_OK - `valid_ptree cmlG pt ∧ MAP TK toks = ptree_fringe pt ⇒ +Theorem TopLevelDecs_OK: + valid_ptree cmlG pt ∧ MAP TK toks = ptree_fringe pt ⇒ (ptree_head pt = NN nTopLevelDecs ⇒ ∃ts. ptree_TopLevelDecs pt = SOME ts) ∧ (ptree_head pt = NN nNonETopLevelDecs ⇒ - ∃ts. ptree_NonETopLevelDecs pt = SOME ts)` - (map_every qid_spec_tac [`toks`, `pt`] >> + ∃ts. ptree_NonETopLevelDecs pt = SOME ts) +Proof + map_every qid_spec_tac [`toks`, `pt`] >> ho_match_mp_tac grammarTheory.ptree_ind >> conj_tac >> simp[Once FORALL_PROD] >> dsimp[] >> rpt strip_tac >> fs[MAP_EQ_CONS, cmlG_applied, cmlG_FDOM] >> @@ -742,19 +823,22 @@ Theorem TopLevelDecs_OK metis_tac[TopLevelDec_OK, grammarTheory.ptree_fringe_def]) >- (rename[`destLf lf`] >> Cases_on `lf` >> fs[] >- (rename[`Lf p`] >> Cases_on `p` >> fs[]) >> - metis_tac[TopLevelDec_OK, grammarTheory.ptree_fringe_def])) + metis_tac[TopLevelDec_OK, grammarTheory.ptree_fringe_def]) +QED (* -Theorem REPLTop_OK - `valid_ptree cmlG pt ∧ ptree_head pt = NN nREPLTop ∧ +Theorem REPLTop_OK: + valid_ptree cmlG pt ∧ ptree_head pt = NN nREPLTop ∧ MAP TK toks = ptree_fringe pt ⇒ - ∃r. ptree_REPLTop pt = SOME r` - (start >> fs[MAP_EQ_APPEND, MAP_EQ_CONS, DISJ_IMP_THM, FORALL_AND_THM] >> + ∃r. ptree_REPLTop pt = SOME r +Proof + start >> fs[MAP_EQ_APPEND, MAP_EQ_CONS, DISJ_IMP_THM, FORALL_AND_THM] >> simp[ptree_REPLTop_def] >- (erule strip_assume_tac (n TopLevelDec_OK) >> simp[]) >> rename1 `ptree_TopLevelDec pt0` >> Cases_on `ptree_TopLevelDec pt0` >> simp[] >> - erule strip_assume_tac (n E_OK) >> simp[]); + erule strip_assume_tac (n E_OK) >> simp[] +QED *) val _ = export_theory(); diff --git a/semantics/proofs/evaluatePropsScript.sml b/semantics/proofs/evaluatePropsScript.sml index b3f167ac07..70bdd7c3e9 100644 --- a/semantics/proofs/evaluatePropsScript.sml +++ b/semantics/proofs/evaluatePropsScript.sml @@ -9,26 +9,32 @@ open terminationTheory val _ = new_theory"evaluateProps"; -Theorem call_FFI_LENGTH - `(call_FFI st index conf x = FFI_return new_st new_bytes) ==> - (LENGTH x = LENGTH new_bytes)` - (fs[ffiTheory.call_FFI_def] \\ every_case_tac \\ rw[] \\ fs[LENGTH_MAP]); +Theorem call_FFI_LENGTH: + (call_FFI st index conf x = FFI_return new_st new_bytes) ==> + (LENGTH x = LENGTH new_bytes) +Proof + fs[ffiTheory.call_FFI_def] \\ every_case_tac \\ rw[] \\ fs[LENGTH_MAP] +QED val call_FFI_rel_def = Define ` call_FFI_rel s1 s2 <=> ?n conf bytes t. call_FFI s1 n conf bytes = FFI_return s2 t`; -Theorem call_FFI_rel_consts - `call_FFI_rel s1 s2 ⇒ (s2.oracle = s1.oracle)` - (rw[call_FFI_rel_def] +Theorem call_FFI_rel_consts: + call_FFI_rel s1 s2 ⇒ (s2.oracle = s1.oracle) +Proof + rw[call_FFI_rel_def] \\ fs[ffiTheory.call_FFI_def] \\ fs[CaseEq"bool",CaseEq"oracle_result"] - \\ rw[]); + \\ rw[] +QED -Theorem RTC_call_FFI_rel_consts - `∀s1 s2. RTC call_FFI_rel s1 s2 ⇒ (s2.oracle = s1.oracle)` - (once_rewrite_tac[EQ_SYM_EQ] +Theorem RTC_call_FFI_rel_consts: + ∀s1 s2. RTC call_FFI_rel s1 s2 ⇒ (s2.oracle = s1.oracle) +Proof + once_rewrite_tac[EQ_SYM_EQ] \\ match_mp_tac RTC_lifts_equalities - \\ rw[call_FFI_rel_consts]); + \\ rw[call_FFI_rel_consts] +QED val dest_IO_event_def = Define` dest_IO_event (IO_event s c b) = (s,c,b)`; @@ -39,47 +45,58 @@ val io_events_mono_def = Define` s1.io_events ≼ s2.io_events ∧ (s2.io_events = s1.io_events ⇒ s2 = s1)`; -Theorem io_events_mono_refl[simp] - `io_events_mono ffi ffi` - (rw[io_events_mono_def]); +Theorem io_events_mono_refl[simp]: + io_events_mono ffi ffi +Proof + rw[io_events_mono_def] +QED -Theorem io_events_mono_trans - `io_events_mono ffi1 ffi2 ∧ io_events_mono ffi2 ffi3 ⇒ - io_events_mono ffi1 ffi3` - (rw[io_events_mono_def] - \\ metis_tac[IS_PREFIX_TRANS, IS_PREFIX_ANTISYM]); +Theorem io_events_mono_trans: + io_events_mono ffi1 ffi2 ∧ io_events_mono ffi2 ffi3 ⇒ + io_events_mono ffi1 ffi3 +Proof + rw[io_events_mono_def] + \\ metis_tac[IS_PREFIX_TRANS, IS_PREFIX_ANTISYM] +QED -Theorem io_events_mono_antisym - `io_events_mono s1 s2 ∧ io_events_mono s2 s1 ⇒ s1 = s2` - (rw[io_events_mono_def] +Theorem io_events_mono_antisym: + io_events_mono s1 s2 ∧ io_events_mono s2 s1 ⇒ s1 = s2 +Proof + rw[io_events_mono_def] \\ imp_res_tac IS_PREFIX_ANTISYM - \\ rfs[]); + \\ rfs[] +QED -Theorem call_FFI_rel_io_events_mono - `∀s1 s2. - RTC call_FFI_rel s1 s2 ⇒ io_events_mono s1 s2` - (REWRITE_TAC[io_events_mono_def] \\ +Theorem call_FFI_rel_io_events_mono: + ∀s1 s2. + RTC call_FFI_rel s1 s2 ⇒ io_events_mono s1 s2 +Proof + REWRITE_TAC[io_events_mono_def] \\ ho_match_mp_tac RTC_INDUCT \\ simp[call_FFI_rel_def,ffiTheory.call_FFI_def] \\ rpt gen_tac \\ strip_tac \\ every_case_tac \\ fs[] \\ rveq \\ fs[] - \\ fs[IS_PREFIX_APPEND]); + \\ fs[IS_PREFIX_APPEND] +QED -Theorem do_app_call_FFI_rel - `do_app (r,ffi) op vs = SOME ((r',ffi'),res) ⇒ - call_FFI_rel^* ffi ffi'` - (srw_tac[][do_app_cases] >> rw[] >> +Theorem do_app_call_FFI_rel: + do_app (r,ffi) op vs = SOME ((r',ffi'),res) ⇒ + call_FFI_rel^* ffi ffi' +Proof + srw_tac[][do_app_cases] >> rw[] >> FULL_CASE_TAC >- (match_mp_tac RTC_SUBSET >> rw[call_FFI_rel_def] >> fs[] >> every_case_tac >> fs[] >> metis_tac[]) - >- fs[]); + >- fs[] +QED -Theorem evaluate_call_FFI_rel - `(∀(s:'ffi state) e exp. +Theorem evaluate_call_FFI_rel: + (∀(s:'ffi state) e exp. RTC call_FFI_rel s.ffi (FST (evaluate s e exp)).ffi) ∧ (∀(s:'ffi state) e v pes errv. - RTC call_FFI_rel s.ffi (FST (evaluate_match s e v pes errv)).ffi)` - (ho_match_mp_tac terminationTheory.evaluate_ind >> + RTC call_FFI_rel s.ffi (FST (evaluate_match s e v pes errv)).ffi) +Proof + ho_match_mp_tac terminationTheory.evaluate_ind >> srw_tac[][terminationTheory.evaluate_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> TRY ( @@ -90,16 +107,19 @@ Theorem evaluate_call_FFI_rel rename1`op = Opapp` >> rev_full_simp_tac(srw_ss())[dec_clock_def] >> metis_tac[RTC_TRANSITIVE,transitive_def] ) >> - metis_tac[RTC_TRANSITIVE,transitive_def,FST]); + metis_tac[RTC_TRANSITIVE,transitive_def,FST] +QED -Theorem evaluate_call_FFI_rel_imp - `(∀s e p s' r. +Theorem evaluate_call_FFI_rel_imp: + (∀s e p s' r. evaluate s e p = (s',r) ⇒ RTC call_FFI_rel s.ffi s'.ffi) ∧ (∀s e v pes errv s' r. evaluate_match s e v pes errv = (s',r) ⇒ - RTC call_FFI_rel s.ffi s'.ffi)` - (metis_tac[PAIR,FST,evaluate_call_FFI_rel]); + RTC call_FFI_rel s.ffi s'.ffi) +Proof + metis_tac[PAIR,FST,evaluate_call_FFI_rel] +QED val evaluate_decs_call_FFI_rel = Q.prove( `∀s e d. @@ -109,11 +129,13 @@ val evaluate_decs_call_FFI_rel = Q.prove( every_case_tac >> full_simp_tac(srw_ss())[] >> metis_tac[RTC_TRANSITIVE,transitive_def,evaluate_call_FFI_rel,FST]); -Theorem evaluate_decs_call_FFI_rel_imp - `∀s e p s' r. +Theorem evaluate_decs_call_FFI_rel_imp: + ∀s e p s' r. evaluate_decs s e p = (s',r) ⇒ - RTC call_FFI_rel s.ffi s'.ffi` - (metis_tac[PAIR,FST,evaluate_decs_call_FFI_rel]); + RTC call_FFI_rel s.ffi s'.ffi +Proof + metis_tac[PAIR,FST,evaluate_decs_call_FFI_rel] +QED (* val evaluate_tops_call_FFI_rel = Q.prove( @@ -124,43 +146,53 @@ val evaluate_tops_call_FFI_rel = Q.prove( every_case_tac >> full_simp_tac(srw_ss())[] >> metis_tac[RTC_TRANSITIVE,transitive_def,evaluate_decs_call_FFI_rel,FST]) -Theorem evaluate_tops_call_FFI_rel_imp - `∀s e p s' r. +Theorem evaluate_tops_call_FFI_rel_imp: + ∀s e p s' r. evaluate_tops s e p = (s',r) ⇒ - RTC call_FFI_rel s.ffi s'.ffi` - (metis_tac[PAIR,FST,evaluate_tops_call_FFI_rel]) + RTC call_FFI_rel s.ffi s'.ffi +Proof + metis_tac[PAIR,FST,evaluate_tops_call_FFI_rel] +QED *) -Theorem do_app_io_events_mono - `do_app (r,ffi) op vs = SOME ((r',ffi'),res) ⇒ io_events_mono ffi ffi'` - (metis_tac[do_app_call_FFI_rel,call_FFI_rel_io_events_mono]) +Theorem do_app_io_events_mono: + do_app (r,ffi) op vs = SOME ((r',ffi'),res) ⇒ io_events_mono ffi ffi' +Proof + metis_tac[do_app_call_FFI_rel,call_FFI_rel_io_events_mono] +QED -Theorem evaluate_io_events_mono - `(∀(s:'ffi state) e exp. +Theorem evaluate_io_events_mono: + (∀(s:'ffi state) e exp. io_events_mono s.ffi (FST (evaluate s e exp)).ffi) ∧ (∀(s:'ffi state) e v pes errv. - io_events_mono s.ffi (FST (evaluate_match s e v pes errv)).ffi)` - (metis_tac[evaluate_call_FFI_rel,call_FFI_rel_io_events_mono]); + io_events_mono s.ffi (FST (evaluate_match s e v pes errv)).ffi) +Proof + metis_tac[evaluate_call_FFI_rel,call_FFI_rel_io_events_mono] +QED -Theorem evaluate_io_events_mono_imp - `(∀s e p s' r. +Theorem evaluate_io_events_mono_imp: + (∀s e p s' r. evaluate s e p = (s',r) ⇒ io_events_mono s.ffi s'.ffi) ∧ (∀s e v pes errv s' r. evaluate_match s e v pes errv = (s',r) ⇒ - io_events_mono s.ffi s'.ffi)` - (metis_tac[PAIR,FST,evaluate_io_events_mono]) + io_events_mono s.ffi s'.ffi) +Proof + metis_tac[PAIR,FST,evaluate_io_events_mono] +QED val evaluate_decs_io_events_mono = Q.prove( `∀s e d. io_events_mono s.ffi (FST (evaluate_decs s e d)).ffi`, metis_tac[evaluate_decs_call_FFI_rel,call_FFI_rel_io_events_mono]); -Theorem evaluate_decs_io_events_mono_imp - `∀s e p s' r. +Theorem evaluate_decs_io_events_mono_imp: + ∀s e p s' r. evaluate_decs s e p = (s',r) ⇒ - io_events_mono s.ffi s'.ffi` - (metis_tac[PAIR,FST,evaluate_decs_io_events_mono]) + io_events_mono s.ffi s'.ffi +Proof + metis_tac[PAIR,FST,evaluate_decs_io_events_mono] +QED (* val evaluate_tops_io_events_mono = Q.prove( @@ -168,11 +200,13 @@ val evaluate_tops_io_events_mono = Q.prove( io_events_mono s.ffi (FST (evaluate_tops s e p)).ffi`, metis_tac[evaluate_tops_call_FFI_rel,call_FFI_rel_io_events_mono]) -Theorem evaluate_tops_io_events_mono_imp - `∀s e p s' r. +Theorem evaluate_tops_io_events_mono_imp: + ∀s e p s' r. evaluate_tops s e p = (s',r) ⇒ - io_events_mono s.ffi s'.ffi` - (metis_tac[PAIR,FST,evaluate_tops_io_events_mono]) + io_events_mono s.ffi s'.ffi +Proof + metis_tac[PAIR,FST,evaluate_tops_io_events_mono] +QED *) val is_clock_io_mono_def = Define @@ -193,25 +227,32 @@ val is_clock_io_mono_def = Define /\ (clk <= s.clock ==> io_events_mono s''.ffi s'.ffi) ))`; -Theorem is_clock_io_mono_return - `is_clock_io_mono (\s. (s,Rval r)) s` - (fs [is_clock_io_mono_def]) +Theorem is_clock_io_mono_return: + is_clock_io_mono (\s. (s,Rval r)) s +Proof + fs [is_clock_io_mono_def] +QED -Theorem is_clock_io_mono_err - `is_clock_io_mono (\s. (s,Rerr r)) s` - (fs [is_clock_io_mono_def]) +Theorem is_clock_io_mono_err: + is_clock_io_mono (\s. (s,Rerr r)) s +Proof + fs [is_clock_io_mono_def] +QED -Theorem pair_CASE_eq_forall - `(case x of (a, b) => P a b) = (!a b. x = (a, b) ==> P a b)` - (Cases_on `x` \\ fs []); +Theorem pair_CASE_eq_forall: + (case x of (a, b) => P a b) = (!a b. x = (a, b) ==> P a b) +Proof + Cases_on `x` \\ fs [] +QED -Theorem is_clock_io_mono_bind - `is_clock_io_mono f s /\ (!s' r. f s = (s', r) +Theorem is_clock_io_mono_bind: + is_clock_io_mono f s /\ (!s' r. f s = (s', r) ==> is_clock_io_mono (g r) s') /\ (!s'. g (Rerr (Rabort Rtimeout_error)) s' = (s', Rerr (Rabort Rtimeout_error))) - ==> is_clock_io_mono (\s. case f s of (s', r) => g r s') s` - (fs [is_clock_io_mono_def] + ==> is_clock_io_mono (\s. case f s of (s', r) => g r s') s +Proof + fs [is_clock_io_mono_def] \\ rpt (FIRST [DISCH_TAC, GEN_TAC, CASE_TAC]) \\ fs [] \\ conj_tac \\ (TRY (irule io_events_mono_trans \\ metis_tac [])) @@ -229,52 +270,61 @@ Theorem is_clock_io_mono_bind \\ FIRST_X_ASSUM drule \\ rpt (FIRST (map CHANGED_TAC [DISCH_TAC, fs [], rfs [], rveq, fs [EQ_IMP_THM]])) - ); +QED -Theorem is_clock_io_mono_check - `(~ (s.clock = 0) ==> is_clock_io_mono f (dec_clock s)) +Theorem is_clock_io_mono_check: + (~ (s.clock = 0) ==> is_clock_io_mono f (dec_clock s)) ==> is_clock_io_mono (\s. if s.clock = 0 - then (s,Rerr (Rabort Rtimeout_error)) else f (dec_clock s)) s` - (fs [is_clock_io_mono_def, dec_clock_def] + then (s,Rerr (Rabort Rtimeout_error)) else f (dec_clock s)) s +Proof + fs [is_clock_io_mono_def, dec_clock_def] \\ rpt (CASE_TAC ORELSE DISCH_TAC ORELSE GEN_TAC ORELSE CHANGED_TAC (fs [])) \\ fs [pair_CASE_eq_forall] \\ FIRST_X_ASSUM drule \\ rpt (CASE_TAC ORELSE DISCH_TAC ORELSE GEN_TAC ORELSE CHANGED_TAC (fs [])) - \\ Cases_on `r' = Rerr (Rabort Rtimeout_error)` \\ fs []); + \\ Cases_on `r' = Rerr (Rabort Rtimeout_error)` \\ fs [] +QED -Theorem is_clock_io_mono_refs_lemma - `is_clock_io_mono (\s'. f (s.refs) s') s - ==> is_clock_io_mono (\s'. f (s'.refs) s') s` - (fs [is_clock_io_mono_def]); +Theorem is_clock_io_mono_refs_lemma: + is_clock_io_mono (\s'. f (s.refs) s') s + ==> is_clock_io_mono (\s'. f (s'.refs) s') s +Proof + fs [is_clock_io_mono_def] +QED -Theorem is_clock_io_mono_do_app - `is_clock_io_mono (\st'. case do_app (st.refs, st'.ffi) op xs of +Theorem is_clock_io_mono_do_app: + is_clock_io_mono (\st'. case do_app (st.refs, st'.ffi) op xs of NONE => (st', Rerr (Rabort Rtype_error)) | SOME ((refs,ffi),r) => (st' with <|refs := refs; ffi := ffi|>, - list_result r)) st` - (fs [is_clock_io_mono_def] + list_result r)) st +Proof + fs [is_clock_io_mono_def] \\ rpt (CASE_TAC ORELSE CHANGED_TAC (fs []) ORELSE strip_tac) - \\ metis_tac [do_app_io_events_mono]); + \\ metis_tac [do_app_io_events_mono] +QED -Theorem is_clock_io_mono_evaluate - `(!(s : 'ffi state) env es. is_clock_io_mono (\s. evaluate s env es) s) /\ +Theorem is_clock_io_mono_evaluate: + (!(s : 'ffi state) env es. is_clock_io_mono (\s. evaluate s env es) s) /\ (!(s : 'ffi state) env v pes err_v. - is_clock_io_mono (\s. evaluate_match s env v pes err_v) s)` - (ho_match_mp_tac evaluate_ind + is_clock_io_mono (\s. evaluate_match s env v pes err_v) s) +Proof + ho_match_mp_tac evaluate_ind \\ rpt strip_tac \\ fs [evaluate_def] \\ rpt (FIRST ([strip_tac] @ map ho_match_mp_tac [is_clock_io_mono_bind, is_clock_io_mono_check] @ [CHANGED_TAC (fs [is_clock_io_mono_return, is_clock_io_mono_err, is_clock_io_mono_do_app]), CASE_TAC, - CHANGED_TAC (ho_match_mp_tac is_clock_io_mono_refs_lemma)]))); + CHANGED_TAC (ho_match_mp_tac is_clock_io_mono_refs_lemma)])) +QED -Theorem is_clock_io_mono_extra - `(!s. is_clock_io_mono f s) +Theorem is_clock_io_mono_extra: + (!s. is_clock_io_mono f s) ==> f s = (s', r) /\ ~ (r = Rerr (Rabort Rtimeout_error)) ==> f (s with clock := s.clock + extra) - = (s' with clock := s'.clock + extra,r)` - (DISCH_TAC + = (s' with clock := s'.clock + extra,r) +Proof + DISCH_TAC \\ FIRST_X_ASSUM (MP_TAC o Q.SPEC `s with clock := s.clock + extra`) \\ fs [is_clock_io_mono_def] \\ CASE_TAC @@ -283,13 +333,15 @@ Theorem is_clock_io_mono_extra \\ FIRST_X_ASSUM (MP_TAC o Q.SPEC `s.clock`) \\ fs [semanticPrimitivesPropsTheory.with_same_clock] \\ rpt DISCH_TAC - \\ rpt (CHANGED_TAC (fs [semanticPrimitivesPropsTheory.with_same_clock]))); + \\ rpt (CHANGED_TAC (fs [semanticPrimitivesPropsTheory.with_same_clock])) +QED -Theorem is_clock_io_mono_extra_mono - `(!s. is_clock_io_mono f s) +Theorem is_clock_io_mono_extra_mono: + (!s. is_clock_io_mono f s) ==> io_events_mono (FST(f s)).ffi - (FST(f (s with clock := s.clock + extra))).ffi` - (DISCH_TAC + (FST(f (s with clock := s.clock + extra))).ffi +Proof + DISCH_TAC \\ FIRST_X_ASSUM (MP_TAC o Q.SPEC `s with clock := s.clock + extra`) \\ fs [is_clock_io_mono_def] \\ CASE_TAC @@ -297,7 +349,8 @@ Theorem is_clock_io_mono_extra_mono \\ fs [] \\ FIRST_X_ASSUM (MP_TAC o Q.SPEC `s.clock`) \\ fs [semanticPrimitivesPropsTheory.with_same_clock] - \\ CASE_TAC); + \\ CASE_TAC +QED fun mk_extra_lemmas mp_rule monad_rule = BODY_CONJUNCTS monad_rule @@ -305,58 +358,76 @@ fun mk_extra_lemmas mp_rule monad_rule fun prove_extra mp_rule monad_rule = simp_tac bool_ss (mk_extra_lemmas mp_rule monad_rule) -Theorem evaluate_add_to_clock - `!(s:'ffi state) env es s' r extra. +Theorem evaluate_add_to_clock: + !(s:'ffi state) env es s' r extra. evaluate s env es = (s',r) ∧ r ≠ Rerr (Rabort Rtimeout_error) ⇒ evaluate (s with clock := s.clock + extra) env es = - (s' with clock := s'.clock + extra,r)` - (prove_extra is_clock_io_mono_extra is_clock_io_mono_evaluate); + (s' with clock := s'.clock + extra,r) +Proof + prove_extra is_clock_io_mono_extra is_clock_io_mono_evaluate +QED -Theorem evaluate_match_add_to_clock - `!(s:'ffi state) env v pes err_v s' r extra. +Theorem evaluate_match_add_to_clock: + !(s:'ffi state) env v pes err_v s' r extra. evaluate_match s env v pes err_v = (s', r) ∧ r ≠ Rerr (Rabort Rtimeout_error) ⇒ evaluate_match (s with clock := s.clock + extra) env v pes err_v = - (s' with clock := s'.clock + extra,r)` - (prove_extra is_clock_io_mono_extra is_clock_io_mono_evaluate); - -Theorem list_result_eq_Rval[simp] - `list_result r = Rval r' ⇔ ∃v. r' = [v] ∧ r = Rval v` - (Cases_on`r`>>srw_tac[][list_result_def,EQ_IMP_THM]) - -Theorem list_result_eq_Rerr[simp] - `list_result r = Rerr e ⇔ r = Rerr e` - (Cases_on`r`>>srw_tac[][list_result_def,EQ_IMP_THM]) - -Theorem result_rel_list_result[simp] - `result_rel (LIST_REL R) Q (list_result r1) (list_result r2) ⇔ - result_rel R Q r1 r2` - (Cases_on`r1`>>srw_tac[][PULL_EXISTS]); - -Theorem list_result_inj - `list_result x = list_result y ⇒ x = y` - (Cases_on`x`>>Cases_on`y`>>EVAL_TAC) - -Theorem evaluate_length - `(∀(s:'ffi state) e p s' r. evaluate s e p = (s',Rval r) ⇒ LENGTH r = LENGTH p) ∧ - (∀(s:'ffi state) e v p er s' r. evaluate_match s e v p er = (s',Rval r) ⇒ LENGTH r = 1)` - (ho_match_mp_tac evaluate_ind >> + (s' with clock := s'.clock + extra,r) +Proof + prove_extra is_clock_io_mono_extra is_clock_io_mono_evaluate +QED + +Theorem list_result_eq_Rval[simp]: + list_result r = Rval r' ⇔ ∃v. r' = [v] ∧ r = Rval v +Proof + Cases_on`r`>>srw_tac[][list_result_def,EQ_IMP_THM] +QED + +Theorem list_result_eq_Rerr[simp]: + list_result r = Rerr e ⇔ r = Rerr e +Proof + Cases_on`r`>>srw_tac[][list_result_def,EQ_IMP_THM] +QED + +Theorem result_rel_list_result[simp]: + result_rel (LIST_REL R) Q (list_result r1) (list_result r2) ⇔ + result_rel R Q r1 r2 +Proof + Cases_on`r1`>>srw_tac[][PULL_EXISTS] +QED + +Theorem list_result_inj: + list_result x = list_result y ⇒ x = y +Proof + Cases_on`x`>>Cases_on`y`>>EVAL_TAC +QED + +Theorem evaluate_length: + (∀(s:'ffi state) e p s' r. evaluate s e p = (s',Rval r) ⇒ LENGTH r = LENGTH p) ∧ + (∀(s:'ffi state) e v p er s' r. evaluate_match s e v p er = (s',Rval r) ⇒ LENGTH r = 1) +Proof + ho_match_mp_tac evaluate_ind >> srw_tac[][evaluate_def,LENGTH_NIL] >> srw_tac[][] >> - every_case_tac >> full_simp_tac(srw_ss())[list_result_eq_Rval] >> srw_tac[][]) + every_case_tac >> full_simp_tac(srw_ss())[list_result_eq_Rval] >> srw_tac[][] +QED -Theorem evaluate_nil[simp] - `∀(s:'ffi state) env. evaluate s env [] = (s,Rval [])` - (rw [evaluate_def]); +Theorem evaluate_nil[simp]: + ∀(s:'ffi state) env. evaluate s env [] = (s,Rval []) +Proof + rw [evaluate_def] +QED -Theorem evaluate_sing - `∀(s:'ffi state) env e s' vs. evaluate s env [e] = (s',Rval vs) ⇒ ∃v. vs = [v]` - (rw [] +Theorem evaluate_sing: + ∀(s:'ffi state) env e s' vs. evaluate s env [e] = (s',Rval vs) ⇒ ∃v. vs = [v] +Proof + rw [] >> imp_res_tac evaluate_length >> Cases_on `vs` >> fs [] >> Cases_on `t` - >> fs []); + >> fs [] +QED Theorem evaluate_cons: ∀(s:'ffi state) env e es. @@ -384,90 +455,105 @@ Proof >> drule evaluate_sing >> rw [] \\ rw[]); -Theorem evaluate_decs_nil[simp] - `∀(s:'ffi state) env. - evaluate_decs s env [] = (s,Rval <| v := nsEmpty; c := nsEmpty |>)` - (rw [evaluate_decs_def]); +Theorem evaluate_decs_nil[simp]: + ∀(s:'ffi state) env. + evaluate_decs s env [] = (s,Rval <| v := nsEmpty; c := nsEmpty |>) +Proof + rw [evaluate_decs_def] +QED -Theorem evaluate_decs_cons - `∀(s:'ffi state) env d ds. +Theorem evaluate_decs_cons: + ∀(s:'ffi state) env d ds. evaluate_decs s env (d::ds) = case evaluate_decs s env [d] of | (s1, Rval env1) => (case evaluate_decs s1 (extend_dec_env env1 env) ds of | (s2, r) => (s2, combine_dec_result env1 r) | err => err) - | err => err` - (Cases_on `ds` + | err => err +Proof + Cases_on `ds` >> rw [evaluate_decs_def] >> split_pair_case_tac >> simp [] >> rename1 `evaluate_decs _ _ _ = (s1,r)` >> Cases_on `r` - >> simp [combine_dec_result_def, sem_env_component_equality]); + >> simp [combine_dec_result_def, sem_env_component_equality] +QED (* -Theorem evaluate_tops_nil[simp] - `∀(s:'ffi state) env. evaluate_tops s env [] = (s,Rval <| v := nsEmpty; c := nsEmpty |>)` - (rw [evaluate_tops_def]); +Theorem evaluate_tops_nil[simp]: + ∀(s:'ffi state) env. evaluate_tops s env [] = (s,Rval <| v := nsEmpty; c := nsEmpty |>) +Proof + rw [evaluate_tops_def] +QED -Theorem evaluate_tops_cons - `∀(s:'ffi state) env top tops. +Theorem evaluate_tops_cons: + ∀(s:'ffi state) env top tops. evaluate_tops s env (top::tops) = case evaluate_tops s env [top] of | (s1, Rval env1) => (case evaluate_tops s1 (extend_dec_env env1 env) tops of | (s2, r) => (s2, combine_dec_result env1 r) | err => err) - | err => err` - (Cases_on `tops` + | err => err +Proof + Cases_on `tops` >> rw [evaluate_tops_def] >> split_pair_case_tac >> simp [] >> rename1 `evaluate_tops _ _ _ = (s1,r)` >> Cases_on `r` - >> simp [combine_dec_result_def, sem_env_component_equality]); + >> simp [combine_dec_result_def, sem_env_component_equality] +QED *) -Theorem evaluate_match_list_result - `evaluate_match s e v p er = (s',r) ⇒ - ∃r'. r = list_result r'` - (Cases_on`r` >> srw_tac[][] >> +Theorem evaluate_match_list_result: + evaluate_match s e v p er = (s',r) ⇒ + ∃r'. r = list_result r' +Proof + Cases_on`r` >> srw_tac[][] >> imp_res_tac evaluate_length >|[ Cases_on`a` >> full_simp_tac(srw_ss())[LENGTH_NIL],all_tac] >> - metis_tac[list_result_def]); + metis_tac[list_result_def] +QED -Theorem is_clock_io_mono_evaluate_decs - `!s e p. is_clock_io_mono (\s. evaluate_decs s e p) s` - (ho_match_mp_tac evaluate_decs_ind +Theorem is_clock_io_mono_evaluate_decs: + !s e p. is_clock_io_mono (\s. evaluate_decs s e p) s +Proof + ho_match_mp_tac evaluate_decs_ind \\ fs [evaluate_decs_def, combine_dec_result_def] \\ rpt (strip_tac ORELSE TOP_CASE_TAC ORELSE (CHANGED_TAC (fs [is_clock_io_mono_return, is_clock_io_mono_err, is_clock_io_mono_evaluate])) ORELSE ho_match_mp_tac is_clock_io_mono_bind ) - \\ fs [is_clock_io_mono_def]); + \\ fs [is_clock_io_mono_def] +QED val evaluate_decs_lemmas = BODY_CONJUNCTS is_clock_io_mono_evaluate_decs |> map (BETA_RULE o MATCH_MP is_clock_io_mono_extra o Q.GEN `s`) -Theorem evaluate_decs_add_to_clock - `!s e p s' r extra. +Theorem evaluate_decs_add_to_clock: + !s e p s' r extra. evaluate_decs s e p = (s',r) ∧ r ≠ Rerr (Rabort Rtimeout_error) ⇒ evaluate_decs (s with clock := s.clock + extra) e p = - (s' with clock := s'.clock + extra,r)` - (simp_tac bool_ss evaluate_decs_lemmas); + (s' with clock := s'.clock + extra,r) +Proof + simp_tac bool_ss evaluate_decs_lemmas +QED (* -Theorem evaluate_tops_add_to_clock - `!s e p s' r extra. +Theorem evaluate_tops_add_to_clock: + !s e p s' r extra. evaluate_tops s e p = (s',r) ∧ r ≠ Rerr (Rabort Rtimeout_error) ⇒ evaluate_tops (s with clock := s.clock + extra) e p = - (s' with clock := s'.clock + extra,r)` - (ho_match_mp_tac evaluate_tops_ind + (s' with clock := s'.clock + extra,r) +Proof + ho_match_mp_tac evaluate_tops_ind >> rw [evaluate_tops_def] >- ( split_pair_case_tac @@ -498,7 +584,8 @@ Theorem evaluate_tops_add_to_clock >> imp_res_tac evaluate_decs_add_to_clock >> rfs [] >> fs [] - >> rw [])); + >> rw []) +QED *) val add_lemma = Q.prove ( @@ -508,8 +595,8 @@ val add_lemma = Q.prove ( val with_clock_ffi = Q.prove( `(s with clock := k).ffi = s.ffi`,EVAL_TAC); -Theorem evaluate_decs_clock_determ -`!s e p s1 r1 s2 r2 k1 k2. +Theorem evaluate_decs_clock_determ: + !s e p s1 r1 s2 r2 k1 k2. evaluate_decs (s with clock := k1) e p = (s1,r1) ∧ evaluate_decs (s with clock := k2) e p = (s2,r2) ⇒ @@ -521,8 +608,9 @@ Theorem evaluate_decs_clock_determ | (_, Rerr (Rabort Rtimeout_error)) => k2 < k1 | _ => - s1.ffi = s2.ffi ∧ r1 = r2` - (rw [] + s1.ffi = s2.ffi ∧ r1 = r2 +Proof + rw [] >> Cases_on `r2 = Rerr (Rabort Rtimeout_error)` >> Cases_on `r1 = Rerr (Rabort Rtimeout_error)` >> fs [] @@ -553,30 +641,36 @@ Theorem evaluate_decs_clock_determ rw [] >> imp_res_tac evaluate_decs_add_to_clock >> fs [] >> - rw [])) + rw []) +QED -Theorem evaluate_add_to_clock_io_events_mono - `(∀(s:'ffi state) e d extra. +Theorem evaluate_add_to_clock_io_events_mono: + (∀(s:'ffi state) e d extra. io_events_mono (FST(evaluate s e d)).ffi (FST(evaluate (s with clock := s.clock + extra) e d)).ffi) ∧ (∀(s:'ffi state) e v d er extra. io_events_mono (FST(evaluate_match s e v d er)).ffi - (FST(evaluate_match (s with clock := s.clock + extra) e v d er)).ffi)` - (prove_extra is_clock_io_mono_extra_mono is_clock_io_mono_evaluate); + (FST(evaluate_match (s with clock := s.clock + extra) e v d er)).ffi) +Proof + prove_extra is_clock_io_mono_extra_mono is_clock_io_mono_evaluate +QED -Theorem evaluate_decs_add_to_clock_io_events_mono - `∀s e d. +Theorem evaluate_decs_add_to_clock_io_events_mono: + ∀s e d. io_events_mono (FST(evaluate_decs s e d)).ffi - (FST(evaluate_decs (s with clock := s.clock + extra) e d)).ffi` - (prove_extra is_clock_io_mono_extra_mono is_clock_io_mono_evaluate_decs); + (FST(evaluate_decs (s with clock := s.clock + extra) e d)).ffi +Proof + prove_extra is_clock_io_mono_extra_mono is_clock_io_mono_evaluate_decs +QED (* -Theorem evaluate_tops_add_to_clock_io_events_mono - `∀s e p extra. +Theorem evaluate_tops_add_to_clock_io_events_mono: + ∀s e p extra. io_events_mono (FST(evaluate_tops s e p)).ffi - (FST(evaluate_tops (s with clock := s.clock + extra) e p)).ffi` - (ho_match_mp_tac evaluate_tops_ind >> + (FST(evaluate_tops (s with clock := s.clock + extra) e p)).ffi +Proof + ho_match_mp_tac evaluate_tops_ind >> srw_tac[][evaluate_tops_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> imp_res_tac evaluate_tops_add_to_clock >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> @@ -584,21 +678,24 @@ Theorem evaluate_tops_add_to_clock_io_events_mono TRY( last_x_assum(qspec_then`extra`mp_tac) >> simp[] >> metis_tac[io_events_mono_trans]) >> - metis_tac[evaluate_decs_add_to_clock_io_events_mono,FST]) + metis_tac[evaluate_decs_add_to_clock_io_events_mono,FST] +QED *) -Theorem evaluate_decs_ffi_mono_clock - `∀k1 k2 s e p. +Theorem evaluate_decs_ffi_mono_clock: + ∀k1 k2 s e p. k1 ≤ k2 ⇒ io_events_mono (FST (evaluate_decs (s with clock := k1) e p)).ffi - (FST (evaluate_decs (s with clock := k2) e p)).ffi` - (metis_tac [is_clock_io_mono_evaluate_decs + (FST (evaluate_decs (s with clock := k2) e p)).ffi +Proof + metis_tac [is_clock_io_mono_evaluate_decs |> Q.SPEC `s with clock := k1` - |> SIMP_RULE (srw_ss ()) [is_clock_io_mono_def, pair_CASE_def]]); + |> SIMP_RULE (srw_ss ()) [is_clock_io_mono_def, pair_CASE_def]] +QED -Theorem evaluate_state_unchanged - `(!(st:'ffi state) env es st' r. +Theorem evaluate_state_unchanged: + (!(st:'ffi state) env es st' r. evaluate st env es = (st', r) ⇒ st'.next_type_stamp = st.next_type_stamp ∧ @@ -607,25 +704,29 @@ Theorem evaluate_state_unchanged evaluate_match st env v pes err_v = (st', r) ⇒ st'.next_type_stamp = st.next_type_stamp ∧ - st'.next_exn_stamp = st.next_exn_stamp)` - (ho_match_mp_tac evaluate_ind + st'.next_exn_stamp = st.next_exn_stamp) +Proof + ho_match_mp_tac evaluate_ind >> rw [evaluate_def] >> every_case_tac >> fs [] - >> rw [dec_clock_def]); + >> rw [dec_clock_def] +QED (* -Theorem evaluate_decs_state_unchanged - `!mn st env ds st' r. +Theorem evaluate_decs_state_unchanged: + !mn st env ds st' r. evaluate_decs mn st env ds = (st',r) ⇒ - st.defined_mods = st'.defined_mods` - (ho_match_mp_tac evaluate_decs_ind + st.defined_mods = st'.defined_mods +Proof + ho_match_mp_tac evaluate_decs_ind >> rw [evaluate_decs_def] >> every_case_tac >> fs [] >> rw [] - >> metis_tac [evaluate_state_unchanged]); + >> metis_tac [evaluate_state_unchanged] +QED *) @@ -658,8 +759,8 @@ val option_CASE_fst_cong = Q.prove( val evaluate_state_const = CONJUNCT1 evaluate_state_unchanged; -Theorem evaluate_ffi_intro ` - (∀(s:'a state) env e s' r. +Theorem evaluate_ffi_intro: + (∀(s:'a state) env e s' r. evaluate s env e = (s',r) ∧ s'.ffi = s.ffi ∧ (∀outcome. r ≠ Rerr(Rabort(Rffi_error outcome))) @@ -676,8 +777,9 @@ Theorem evaluate_ffi_intro ` ∀(t:'b state). t.clock = s.clock ∧ t.refs = s.refs ⇒ - evaluate_match t env v pes errv = (t with <| clock := s'.clock; refs := s'.refs |>, r))` - (ho_match_mp_tac evaluate_ind + evaluate_match t env v pes errv = (t with <| clock := s'.clock; refs := s'.refs |>, r)) +Proof + ho_match_mp_tac evaluate_ind \\ rw[] >- ( rfs[evaluate_def] \\ rw[state_component_equality] ) >- ( @@ -863,56 +965,65 @@ Theorem evaluate_ffi_intro ` \\ reverse TOP_CASE_TAC \\ fs[] >- rw[state_component_equality] \\ TOP_CASE_TAC \\ fs[] - \\ rw[state_component_equality] )); + \\ rw[state_component_equality] ) +QED -Theorem is_clock_io_mono_set_clock - `is_clock_io_mono f s +Theorem is_clock_io_mono_set_clock: + is_clock_io_mono f s ==> f s = (s', r) /\ ~ (r = Rerr (Rabort Rtimeout_error)) - ==> ?ck0. f (s with clock := ck0) = (s' with clock := ck1, r)` - (fs [is_clock_io_mono_def] + ==> ?ck0. f (s with clock := ck0) = (s' with clock := ck1, r) +Proof + fs [is_clock_io_mono_def] \\ rpt (FIRST (map CHANGED_TAC [fs [], strip_tac])) \\ FIRST_X_ASSUM (MP_TAC o Q.SPEC `ck1 + (s.clock − (HD [s';s]).clock)`) \\ CASE_TAC \\ rpt (FIRST (map CHANGED_TAC [fs [], strip_tac])) - \\ metis_tac []); + \\ metis_tac [] +QED val evaluate_set_clock_lemmas = (BODY_CONJUNCTS is_clock_io_mono_evaluate @ BODY_CONJUNCTS is_clock_io_mono_evaluate_decs) |> map (BETA_RULE o MATCH_MP is_clock_io_mono_set_clock); -Theorem evaluate_set_clock - `!(s:'ffi state) env exps s1 res. +Theorem evaluate_set_clock: + !(s:'ffi state) env exps s1 res. evaluate s env exps = (s1,res) /\ res <> Rerr (Rabort Rtimeout_error) ==> !ck. ?ck1. evaluate (s with clock := ck1) env exps = - (s1 with clock := ck,res)` - (metis_tac evaluate_set_clock_lemmas); + (s1 with clock := ck,res) +Proof + metis_tac evaluate_set_clock_lemmas +QED -Theorem evaluate_decs_set_clock - `!s env decs s1 res. +Theorem evaluate_decs_set_clock: + !s env decs s1 res. evaluate_decs s env decs = (s1,res) /\ res <> Rerr (Rabort Rtimeout_error) ==> !ck. ?ck1. evaluate_decs (s with clock := ck1) env decs = - (s1 with clock := ck,res)` - (metis_tac evaluate_set_clock_lemmas); + (s1 with clock := ck,res) +Proof + metis_tac evaluate_set_clock_lemmas +QED -Theorem is_clock_io_mono_minimal - `is_clock_io_mono f s +Theorem is_clock_io_mono_minimal: + is_clock_io_mono f s ==> f s = (s', r) /\ s'.clock = 0 /\ r <> Rerr (Rabort Rtimeout_error) /\ s.clock > k ==> (?s''. f (s with clock := k) = (s'', Rerr (Rabort Rtimeout_error)) /\ - io_events_mono s''.ffi s'.ffi)` - (fs [is_clock_io_mono_def] + io_events_mono s''.ffi s'.ffi) +Proof + fs [is_clock_io_mono_def] \\ rpt (FIRST (map CHANGED_TAC [fs [], strip_tac])) \\ FIRST_X_ASSUM (MP_TAC o Q.SPEC `k`) - \\ CASE_TAC \\ fs []); + \\ CASE_TAC \\ fs [] +QED val evaluate_minimal_lemmas = BODY_CONJUNCTS is_clock_io_mono_evaluate |> map (BETA_RULE o MATCH_MP is_clock_io_mono_minimal); -Theorem evaluate_minimal_clock - `(!(s:'ffi state) env es s' r k. +Theorem evaluate_minimal_clock: + (!(s:'ffi state) env es s' r k. evaluate s env es = (s',r) ∧ s'.clock = 0 ∧ r ≠ Rerr (Rabort Rtimeout_error) ∧ @@ -921,11 +1032,13 @@ Theorem evaluate_minimal_clock ?s''. evaluate (s with clock := k) env es = (s'',Rerr (Rabort Rtimeout_error)) /\ - io_events_mono s''.ffi s'.ffi)` - (metis_tac evaluate_minimal_lemmas); + io_events_mono s''.ffi s'.ffi) +Proof + metis_tac evaluate_minimal_lemmas +QED -Theorem evaluate_match_minimal_clock - `(!(s:'ffi state) env v pes err_v s' r k. +Theorem evaluate_match_minimal_clock: + (!(s:'ffi state) env v pes err_v s' r k. evaluate_match s env v pes err_v = (s',r) ∧ s'.clock = 0 ∧ r ≠ Rerr (Rabort Rtimeout_error) ∧ @@ -934,18 +1047,21 @@ Theorem evaluate_match_minimal_clock ?s''. evaluate_match (s with clock := k) env v pes err_v = (s'',Rerr (Rabort Rtimeout_error)) /\ - io_events_mono s''.ffi s'.ffi)` - (metis_tac evaluate_minimal_lemmas); + io_events_mono s''.ffi s'.ffi) +Proof + metis_tac evaluate_minimal_lemmas +QED -Theorem evaluate_set_init_clock - `evaluate st env xs = (st', res) /\ +Theorem evaluate_set_init_clock: + evaluate st env xs = (st', res) /\ res <> Rerr (Rabort Rtimeout_error) ==> !k. ?ck res1 st1. evaluate (st with clock := k) env xs = (st1, res1) /\ (res1 = res /\ st1 = (st' with clock := ck) \/ res1 = Rerr (Rabort Rtimeout_error) /\ - io_events_mono st1.ffi st'.ffi)` - (rw [] + io_events_mono st1.ffi st'.ffi) +Proof + rw [] \\ drule evaluate_set_clock \\ disch_then (qspec_then `0` mp_tac) \\ fs [] \\ strip_tac \\ Cases_on `ck1 <= k` @@ -956,6 +1072,7 @@ Theorem evaluate_set_init_clock \\ metis_tac []) \\ drule evaluate_minimal_clock \\ fs [] \\ disch_then (qspec_then `k` mp_tac) \\ fs [] - \\ rw [] \\ fs []); + \\ rw [] \\ fs [] +QED val _ = export_theory(); diff --git a/semantics/proofs/gramPropsScript.sml b/semantics/proofs/gramPropsScript.sml index 78d2f64a7c..8e893ede24 100644 --- a/semantics/proofs/gramPropsScript.sml +++ b/semantics/proofs/gramPropsScript.sml @@ -285,10 +285,11 @@ val fringe_lengths_def = Define` ` val RTC_R_I = relationTheory.RTC_RULES |> SPEC_ALL |> CONJUNCT2 |> GEN_ALL -Theorem fringe_length_ptree - `∀G i pt. ptree_fringe pt = MAP TOK i ∧ valid_ptree G pt ⇒ - LENGTH i ∈ fringe_lengths G [ptree_head pt]` - (ntac 2 gen_tac >> +Theorem fringe_length_ptree: + ∀G i pt. ptree_fringe pt = MAP TOK i ∧ valid_ptree G pt ⇒ + LENGTH i ∈ fringe_lengths G [ptree_head pt] +Proof + ntac 2 gen_tac >> HO_MATCH_MP_TAC grammarTheory.ptree_ind >> dsimp[MAP_EQ_SING] >> conj_tac >- ( simp[fringe_lengths_def] >> rpt strip_tac >> @@ -298,32 +299,39 @@ Theorem fringe_length_ptree qabbrev_tac `pt = Nd N subs` >> Cases_on `N` >> `NT q = ptree_head pt` by simp[Abbr`pt`] >> `MAP TOK i = ptree_fringe pt` by simp[Abbr`pt`] >> simp[] >> - match_mp_tac grammarTheory.valid_ptree_derive >> simp[Abbr`pt`]); + match_mp_tac grammarTheory.valid_ptree_derive >> simp[Abbr`pt`] +QED -Theorem fringe_length_not_nullable - `∀G s. ¬nullable G [s] ⇒ +Theorem fringe_length_not_nullable: + ∀G s. ¬nullable G [s] ⇒ ∀pt. ptree_head pt = s ⇒ valid_ptree G pt ⇒ - 0 < LENGTH (ptree_fringe pt)` - (spose_not_then strip_assume_tac >> + 0 < LENGTH (ptree_fringe pt) +Proof + spose_not_then strip_assume_tac >> `LENGTH (ptree_fringe pt) = 0` by decide_tac >> fs[listTheory.LENGTH_NIL] >> erule mp_tac grammarTheory.valid_ptree_derive >> - fs[NTpropertiesTheory.nullable_def]); - -Theorem derives_singleTOK - `derives G [TOK t] l ⇔ (l = [TOK t])` - (simp[Once relationTheory.RTC_CASES1, grammarTheory.derive_def] >> - metis_tac[]); + fs[NTpropertiesTheory.nullable_def] +QED + +Theorem derives_singleTOK: + derives G [TOK t] l ⇔ (l = [TOK t]) +Proof + simp[Once relationTheory.RTC_CASES1, grammarTheory.derive_def] >> + metis_tac[] +QED val _ = export_rewrites ["derives_singleTOK"] -Theorem fringe_lengths_V - `fringe_lengths cmlG [NT (mkNT nV)] = {1}` - (simp[fringe_lengths_def] >> +Theorem fringe_lengths_V: + fringe_lengths cmlG [NT (mkNT nV)] = {1} +Proof + simp[fringe_lengths_def] >> simp[Once relationTheory.RTC_CASES1, MAP_EQ_SING, cmlG_FDOM] >> dsimp[MAP_EQ_SING,cmlG_applied] >> simp[EXTENSION, EQ_IMP_THM] >> qx_gen_tac `t` >> rpt strip_tac >> fs[] >> qexists_tac `[AlphaT "foo"]` >> - simp[stringTheory.isUpper_def]); + simp[stringTheory.isUpper_def] +QED val parsing_ind = save_thm( "parsing_ind", diff --git a/semantics/proofs/namespacePropsScript.sml b/semantics/proofs/namespacePropsScript.sml index 3037f4184d..b0b2b6af6a 100644 --- a/semantics/proofs/namespacePropsScript.sml +++ b/semantics/proofs/namespacePropsScript.sml @@ -8,109 +8,144 @@ open terminationTheory; val _ = new_theory "namespaceProps"; -Theorem mk_id_11[simp] - `!a b c d. mk_id a b = mk_id c d ⇔ (a = c) ∧ (b = d)` - (Induct_on `a` +Theorem mk_id_11[simp]: + !a b c d. mk_id a b = mk_id c d ⇔ (a = c) ∧ (b = d) +Proof + Induct_on `a` >> Cases_on `c` >> rw [mk_id_def] - >> metis_tac []); - -Theorem id_to_mods_mk_id[simp] - `!mn x. id_to_mods (mk_id mn x) = mn` - (Induct_on `mn` - >> rw [id_to_mods_def, mk_id_def]); - -Theorem id_to_namemods_mk_id[simp] - `!mn x. id_to_n (mk_id mn x) = x` - (Induct_on `mn` - >> rw [id_to_n_def, mk_id_def]); - -Theorem mk_id_surj - `!id. ?p n. id = mk_id p n` - (Induct_on `id` + >> metis_tac [] +QED + +Theorem id_to_mods_mk_id[simp]: + !mn x. id_to_mods (mk_id mn x) = mn +Proof + Induct_on `mn` + >> rw [id_to_mods_def, mk_id_def] +QED + +Theorem id_to_namemods_mk_id[simp]: + !mn x. id_to_n (mk_id mn x) = x +Proof + Induct_on `mn` + >> rw [id_to_n_def, mk_id_def] +QED + +Theorem mk_id_surj: + !id. ?p n. id = mk_id p n +Proof + Induct_on `id` >> rw [] - >> metis_tac [mk_id_def]); + >> metis_tac [mk_id_def] +QED -Theorem mk_id_thm - `!id. mk_id (id_to_mods id) (id_to_n id) = id` - (Induct_on `id` - >> rw [id_to_mods_def, id_to_n_def, mk_id_def]); +Theorem mk_id_thm: + !id. mk_id (id_to_mods id) (id_to_n id) = id +Proof + Induct_on `id` + >> rw [id_to_mods_def, id_to_n_def, mk_id_def] +QED (* ----------- Monotonicity for Hol_reln ------------ *) -Theorem nsAll_mono[mono] - `(!id x. P id x ⇒ Q id x) ⇒ nsAll P e ⇒ nsAll Q e` - (rw [nsAll_def]); +Theorem nsAll_mono[mono]: + (!id x. P id x ⇒ Q id x) ⇒ nsAll P e ⇒ nsAll Q e +Proof + rw [nsAll_def] +QED -Theorem nsSub_mono[mono] - `(!x y z. R1 x y z ⇒ R2 x y z) ⇒ (nsSub R1 e1 e2 ⇒ nsSub R2 e1 e2)` - (Cases_on `e1` +Theorem nsSub_mono[mono]: + (!x y z. R1 x y z ⇒ R2 x y z) ⇒ (nsSub R1 e1 e2 ⇒ nsSub R2 e1 e2) +Proof + Cases_on `e1` >> Cases_on `e2` >> simp [nsSub_def, nsLookup_def] >> rw [] - >> metis_tac []); + >> metis_tac [] +QED -Theorem nsSub_mono2 - `(!x y z. nsLookup e1 x = SOME y ∧ nsLookup e2 x = SOME z ∧ R1 x y z ⇒ R2 x y z) ⇒ (nsSub R1 e1 e2 ⇒ nsSub R2 e1 e2)` - (Cases_on `e1` +Theorem nsSub_mono2: + (!x y z. nsLookup e1 x = SOME y ∧ nsLookup e2 x = SOME z ∧ R1 x y z ⇒ R2 x y z) ⇒ (nsSub R1 e1 e2 ⇒ nsSub R2 e1 e2) +Proof + Cases_on `e1` >> Cases_on `e2` >> simp [nsSub_def, nsLookup_def] >> rw [] - >> metis_tac []); + >> metis_tac [] +QED -Theorem nsAll2_mono[mono] - `(!x y z. R1 x y z ⇒ R2 x y z) ⇒ nsAll2 R1 e1 e2 ⇒ nsAll2 R2 e1 e2` - (rw [nsAll2_def] +Theorem nsAll2_mono[mono]: + (!x y z. R1 x y z ⇒ R2 x y z) ⇒ nsAll2 R1 e1 e2 ⇒ nsAll2 R2 e1 e2 +Proof + rw [nsAll2_def] >> irule nsSub_mono >> rw [] >- metis_tac [] >> qexists_tac `\x y z. R1 x z y` - >> rw []); + >> rw [] +QED (* ---------- Automatic simps involving empty envs -------------- *) -Theorem nsLookup_nsEmpty[simp] - `!id. nsLookup nsEmpty id = NONE` - (Cases - >> rw [nsLookup_def, nsEmpty_def]); - -Theorem nsLookupMod_nsEmpty[simp] - `!x y. nsLookupMod nsEmpty (x::y) = NONE` - (rw [nsLookupMod_def, nsEmpty_def]); - -Theorem nsAppend_nsEmpty[simp] - `!env. nsAppend env nsEmpty = env ∧ nsAppend nsEmpty env = env` - (Cases - >> rw [nsAppend_def, nsEmpty_def]); - -Theorem alist_to_ns_nil[simp] - `alist_to_ns [] = nsEmpty` - (rw [alist_to_ns_def, nsEmpty_def]); - -Theorem nsSub_nsEmpty[simp] - `!r env. nsSub r nsEmpty env` - (rw [nsSub_def] +Theorem nsLookup_nsEmpty[simp]: + !id. nsLookup nsEmpty id = NONE +Proof + Cases + >> rw [nsLookup_def, nsEmpty_def] +QED + +Theorem nsLookupMod_nsEmpty[simp]: + !x y. nsLookupMod nsEmpty (x::y) = NONE +Proof + rw [nsLookupMod_def, nsEmpty_def] +QED + +Theorem nsAppend_nsEmpty[simp]: + !env. nsAppend env nsEmpty = env ∧ nsAppend nsEmpty env = env +Proof + Cases + >> rw [nsAppend_def, nsEmpty_def] +QED + +Theorem alist_to_ns_nil[simp]: + alist_to_ns [] = nsEmpty +Proof + rw [alist_to_ns_def, nsEmpty_def] +QED + +Theorem nsSub_nsEmpty[simp]: + !r env. nsSub r nsEmpty env +Proof + rw [nsSub_def] >> Induct_on `path` >> Cases_on `env` - >> fs [nsLookupMod_def, nsEmpty_def]); - -Theorem nsAll_nsEmpty[simp] - `!f. nsAll f nsEmpty` - (rw [nsEmpty_def, nsAll_def]); - -Theorem nsAll2_nsEmpty[simp] - `!f. nsAll2 f nsEmpty nsEmpty` - (rw [nsEmpty_def, nsAll2_def]); - -Theorem nsDom_nsEmpty[simp] - `nsDom nsEmpty = {}` - (rw [nsDom_def, nsEmpty_def, EXTENSION, GSPECIFICATION] + >> fs [nsLookupMod_def, nsEmpty_def] +QED + +Theorem nsAll_nsEmpty[simp]: + !f. nsAll f nsEmpty +Proof + rw [nsEmpty_def, nsAll_def] +QED + +Theorem nsAll2_nsEmpty[simp]: + !f. nsAll2 f nsEmpty nsEmpty +Proof + rw [nsEmpty_def, nsAll2_def] +QED + +Theorem nsDom_nsEmpty[simp]: + nsDom nsEmpty = {} +Proof + rw [nsDom_def, nsEmpty_def, EXTENSION, GSPECIFICATION] >> pairarg_tac - >> rw []); + >> rw [] +QED -Theorem nsDomMod_nsEmpty[simp] - `nsDomMod nsEmpty = {[]}` - (rw [nsDomMod_def, nsEmpty_def, EXTENSION, GSPECIFICATION] >> +Theorem nsDomMod_nsEmpty[simp]: + nsDomMod nsEmpty = {[]} +Proof + rw [nsDomMod_def, nsEmpty_def, EXTENSION, GSPECIFICATION] >> eq_tac >- ( rw [] >> @@ -118,103 +153,135 @@ Theorem nsDomMod_nsEmpty[simp] fs [] >> Cases_on `n` >> fs [nsLookupMod_def]) - >- rw [EXISTS_PROD, nsLookupMod_def]); - -Theorem nsMap_nsEmpty[simp] - `!f. nsMap f nsEmpty = nsEmpty` - (rw [nsMap_def, nsEmpty_def]); - -Theorem nsBind_nsEmpty[simp] - `!x y env. nsBind x y env ≠ nsEmpty` - (rw [] >> + >- rw [EXISTS_PROD, nsLookupMod_def] +QED + +Theorem nsMap_nsEmpty[simp]: + !f. nsMap f nsEmpty = nsEmpty +Proof + rw [nsMap_def, nsEmpty_def] +QED + +Theorem nsBind_nsEmpty[simp]: + !x y env. nsBind x y env ≠ nsEmpty +Proof + rw [] >> Cases_on `env` >> - rw [nsBind_def, nsEmpty_def]); + rw [nsBind_def, nsEmpty_def] +QED -Theorem nsLookup_Bind_v_some - `nsLookup (Bind v []) k = SOME x ⇔ - ∃y. k = Short y ∧ ALOOKUP v y = SOME x` - (Cases_on`k` \\ EVAL_TAC \\ simp[]); +Theorem nsLookup_Bind_v_some: + nsLookup (Bind v []) k = SOME x ⇔ + ∃y. k = Short y ∧ ALOOKUP v y = SOME x +Proof + Cases_on`k` \\ EVAL_TAC \\ simp[] +QED (* ------------- Other simple automatic theorems --------- *) -Theorem alist_to_ns_cons[simp] - `!k v l. alist_to_ns ((k,v)::l) = nsBind k v (alist_to_ns l)` - (rw [alist_to_ns_def, nsBind_def]); +Theorem alist_to_ns_cons[simp]: + !k v l. alist_to_ns ((k,v)::l) = nsBind k v (alist_to_ns l) +Proof + rw [alist_to_ns_def, nsBind_def] +QED -Theorem nsAppend_nsBind[simp] - `!k v e1 e2. nsAppend (nsBind k v e1) e2 = nsBind k v (nsAppend e1 e2)` - (Cases_on `e1` +Theorem nsAppend_nsBind[simp]: + !k v e1 e2. nsAppend (nsBind k v e1) e2 = nsBind k v (nsAppend e1 e2) +Proof + Cases_on `e1` >> Cases_on `e2` - >> rw [nsAppend_def, nsBind_def]); - -Theorem nsAppend_alist_to_ns[simp] - `!al1 al2. nsAppend (alist_to_ns al1) (alist_to_ns al2) = alist_to_ns (al1 ++ al2)` - (rw [alist_to_ns_def, nsAppend_def]); - -Theorem nsAppend_assoc[simp] - `!e1 e2 e3. nsAppend e1 (nsAppend e2 e3) = nsAppend (nsAppend e1 e2) e3` - (rpt Cases - >> rw [nsAppend_def]); - -Theorem nsLookup_nsBind[simp] - `(!n v e. nsLookup (nsBind n v e) (Short n) = SOME v) ∧ - (!n n' v e. n ≠ Short n' ⇒ nsLookup (nsBind n' v e) n = nsLookup e n)` - (rw [] + >> rw [nsAppend_def, nsBind_def] +QED + +Theorem nsAppend_alist_to_ns[simp]: + !al1 al2. nsAppend (alist_to_ns al1) (alist_to_ns al2) = alist_to_ns (al1 ++ al2) +Proof + rw [alist_to_ns_def, nsAppend_def] +QED + +Theorem nsAppend_assoc[simp]: + !e1 e2 e3. nsAppend e1 (nsAppend e2 e3) = nsAppend (nsAppend e1 e2) e3 +Proof + rpt Cases + >> rw [nsAppend_def] +QED + +Theorem nsLookup_nsBind[simp]: + (!n v e. nsLookup (nsBind n v e) (Short n) = SOME v) ∧ + (!n n' v e. n ≠ Short n' ⇒ nsLookup (nsBind n' v e) n = nsLookup e n) +Proof + rw [] >> Cases_on `e` >> TRY (Cases_on `n`) - >> rw [nsLookup_def, nsBind_def]); + >> rw [nsLookup_def, nsBind_def] +QED -Theorem nsAppend_nsSing[simp] - `!n x e. nsAppend (nsSing n x) e = nsBind n x e` - (rw [nsSing_def] +Theorem nsAppend_nsSing[simp]: + !n x e. nsAppend (nsSing n x) e = nsBind n x e +Proof + rw [nsSing_def] >> Cases_on `e` - >> simp [nsBind_def, nsAppend_def]); + >> simp [nsBind_def, nsAppend_def] +QED -Theorem nsLookup_nsSing[simp] - `!n v id. nsLookup (nsSing n v) id = if id = Short n then SOME v else NONE` - (rw [nsSing_def, nsLookup_def] +Theorem nsLookup_nsSing[simp]: + !n v id. nsLookup (nsSing n v) id = if id = Short n then SOME v else NONE +Proof + rw [nsSing_def, nsLookup_def] >> Cases_on` id` - >> fs [nsLookup_def]); + >> fs [nsLookup_def] +QED -Theorem nsAll_nsSing[simp] - `!R n v. nsAll R (nsSing n v) ⇔ R (Short n) v` - (rw [nsAll_def, nsSing_def] +Theorem nsAll_nsSing[simp]: + !R n v. nsAll R (nsSing n v) ⇔ R (Short n) v +Proof + rw [nsAll_def, nsSing_def] >> eq_tac >> rw [nsLookup_def] >> Cases_on `id` - >> fs [nsLookup_def]); + >> fs [nsLookup_def] +QED -Theorem nsAll2_nsSing[simp] - `!R n1 v1 n2 v2. nsAll2 R (nsSing n1 v1) (nsSing n2 v2) ⇔ n1 = n2 ∧ R (Short n1) v1 v2` - (rw [nsAll2_def, nsSub_def] +Theorem nsAll2_nsSing[simp]: + !R n1 v1 n2 v2. nsAll2 R (nsSing n1 v1) (nsSing n2 v2) ⇔ n1 = n2 ∧ R (Short n1) v1 v2 +Proof + rw [nsAll2_def, nsSub_def] >> eq_tac >- metis_tac [] >> rw [] >> rw [] >> Cases_on `path` - >> fs [nsSing_def, nsLookupMod_def]); - -Theorem nsMap_nsSing[simp] - `!f x v. nsMap f (nsSing x v) = nsSing x (f v)` - (rw [nsSing_def, nsMap_def]); - -Theorem nsLookupMod_nsSing[simp] - `!n1 n2 v. nsLookupMod (nsSing n2 v) n1 = if n1 = [] then SOME (nsSing n2 v) else NONE` - (rw [nsSing_def, nsLookupMod_def] >> + >> fs [nsSing_def, nsLookupMod_def] +QED + +Theorem nsMap_nsSing[simp]: + !f x v. nsMap f (nsSing x v) = nsSing x (f v) +Proof + rw [nsSing_def, nsMap_def] +QED + +Theorem nsLookupMod_nsSing[simp]: + !n1 n2 v. nsLookupMod (nsSing n2 v) n1 = if n1 = [] then SOME (nsSing n2 v) else NONE +Proof + rw [nsSing_def, nsLookupMod_def] >> Cases_on `n1` >> - rw [nsLookupMod_def]); + rw [nsLookupMod_def] +QED -Theorem nsBind_11[simp] - `!x y n x' y' n'. nsBind x y n = nsBind x' y' n' ⇔ x = x' ∧ y = y' ∧ n = n'` - (rw [] >> +Theorem nsBind_11[simp]: + !x y n x' y' n'. nsBind x y n = nsBind x' y' n' ⇔ x = x' ∧ y = y' ∧ n = n' +Proof + rw [] >> Cases_on `n` >> Cases_on `n'` >> fs [nsBind_def] >> - metis_tac []); + metis_tac [] +QED -Theorem nsDom_nsBind[simp] - `!x y n. nsDom (nsBind x y n) = Short x INSERT nsDom n` - (rw [] >> +Theorem nsDom_nsBind[simp]: + !x y n. nsDom (nsBind x y n) = Short x INSERT nsDom n +Proof + rw [] >> Cases_on `n` >> rw [nsBind_def, nsDom_def, EXTENSION, GSPECIFICATION, EXISTS_PROD] >> eq_tac >> @@ -222,68 +289,86 @@ Theorem nsDom_nsBind[simp] rw [nsLookup_def] >> Cases_on `x'` >> fs [nsLookup_def] >> - metis_tac []); - -Theorem nsDom_nsSing[simp] - `!x y. nsDom (nsSing x y) = {Short x}` - (rw [nsSing_def, nsDom_def, EXTENSION, GSPECIFICATION, LAMBDA_PROD, EXISTS_PROD]); - -Theorem nsDomMod_nsBind[simp] - `!x y n. nsDomMod (nsBind x y n) = nsDomMod n` - (rw [] >> + metis_tac [] +QED + +Theorem nsDom_nsSing[simp]: + !x y. nsDom (nsSing x y) = {Short x} +Proof + rw [nsSing_def, nsDom_def, EXTENSION, GSPECIFICATION, LAMBDA_PROD, EXISTS_PROD] +QED + +Theorem nsDomMod_nsBind[simp]: + !x y n. nsDomMod (nsBind x y n) = nsDomMod n +Proof + rw [] >> Cases_on `n` >> rw [nsBind_def, nsDomMod_def, EXTENSION, GSPECIFICATION, EXISTS_PROD] >> eq_tac >> rw [nsLookupMod_def] >> Cases_on `x'` >> fs [nsLookupMod_def] >> - metis_tac []); - -Theorem nsDomMod_nsSing[simp] - `!x y. nsDomMod (nsSing x y) = {[]}` - (rw [nsSing_def, nsDomMod_def, EXTENSION, GSPECIFICATION, LAMBDA_PROD, EXISTS_PROD]); - -Theorem nsLookupMod_alist_to_ns[simp] - `!l x y. nsLookupMod (alist_to_ns l) (x::y) = NONE` - (rw [alist_to_ns_def, nsLookupMod_def]); - -Theorem alist_to_ns_11[simp] - `!l1 l2. alist_to_ns l1 = alist_to_ns l2 ⇔ l1 = l2` - (rw [alist_to_ns_def]); + metis_tac [] +QED + +Theorem nsDomMod_nsSing[simp]: + !x y. nsDomMod (nsSing x y) = {[]} +Proof + rw [nsSing_def, nsDomMod_def, EXTENSION, GSPECIFICATION, LAMBDA_PROD, EXISTS_PROD] +QED + +Theorem nsLookupMod_alist_to_ns[simp]: + !l x y. nsLookupMod (alist_to_ns l) (x::y) = NONE +Proof + rw [alist_to_ns_def, nsLookupMod_def] +QED + +Theorem alist_to_ns_11[simp]: + !l1 l2. alist_to_ns l1 = alist_to_ns l2 ⇔ l1 = l2 +Proof + rw [alist_to_ns_def] +QED (* -------------- nsLookup ------------------ *) -Theorem nsLookup_to_nsLookupMod - `!n v t. +Theorem nsLookup_to_nsLookupMod: + !n v t. nsLookup n v = SOME t ⇒ - ?m. nsLookupMod n (id_to_mods v) = SOME m ∧ nsLookup m (Short (id_to_n v)) = SOME t` - (ho_match_mp_tac nsLookup_ind >> + ?m. nsLookupMod n (id_to_mods v) = SOME m ∧ nsLookup m (Short (id_to_n v)) = SOME t +Proof + ho_match_mp_tac nsLookup_ind >> rw [id_to_n_def, nsLookup_def, nsLookupMod_def, id_to_mods_def] >> CASE_TAC >> - fs []); + fs [] +QED (* -------------- alist_to_ns --------------- *) -Theorem nsLookup_alist_to_ns_some - `!l id v. nsLookup (alist_to_ns l) id = SOME v ⇔ ?x'. id = Short x' ∧ ALOOKUP l x' = SOME v` - (Induct_on `l` +Theorem nsLookup_alist_to_ns_some: + !l id v. nsLookup (alist_to_ns l) id = SOME v ⇔ ?x'. id = Short x' ∧ ALOOKUP l x' = SOME v +Proof + Induct_on `l` >> fs [alist_to_ns_def, nsLookup_def] >> rw [] >> Cases_on `id` - >> fs [nsLookup_def]); + >> fs [nsLookup_def] +QED -Theorem nsLookup_alist_to_ns_none - `!l id. nsLookup (alist_to_ns l) id = NONE ⇔ !x'. id = Short x' ⇒ ALOOKUP l x' = NONE` - (Induct_on `l` +Theorem nsLookup_alist_to_ns_none: + !l id. nsLookup (alist_to_ns l) id = NONE ⇔ !x'. id = Short x' ⇒ ALOOKUP l x' = NONE +Proof + Induct_on `l` >> fs [alist_to_ns_def, nsLookup_def] >> rw [] >> Cases_on `id` - >> fs [nsLookup_def]); + >> fs [nsLookup_def] +QED -Theorem nsDom_alist_to_ns[simp] - `!l. nsDom (alist_to_ns l) = set (MAP (Short o FST) l)` - (rw [nsDom_def, GSPECIFICATION, EXTENSION, EXISTS_PROD, MEM_MAP] >> +Theorem nsDom_alist_to_ns[simp]: + !l. nsDom (alist_to_ns l) = set (MAP (Short o FST) l) +Proof + rw [nsDom_def, GSPECIFICATION, EXTENSION, EXISTS_PROD, MEM_MAP] >> eq_tac >> rw [nsLookup_alist_to_ns_some] >- metis_tac [ALOOKUP_MEM] >> @@ -291,12 +376,13 @@ Theorem nsDom_alist_to_ns[simp] rw [] >> rw [] >> PairCases_on `h` >> - rw []); + rw [] +QED (* -------------- nsLift --------------- *) -Theorem nsLookup_nsLift - `!mn e id. +Theorem nsLookup_nsLift: + !mn e id. nsLookup (nsLift mn e) id = case id of | Long mn' id' => @@ -304,13 +390,15 @@ Theorem nsLookup_nsLift nsLookup e id' else NONE - | Short _ => NONE` - (rw [nsLift_def] + | Short _ => NONE +Proof + rw [nsLift_def] >> CASE_TAC - >> rw [nsLookup_def]); + >> rw [nsLookup_def] +QED -Theorem nsLookupMod_nsLift - `!mn e path. +Theorem nsLookupMod_nsLift: + !mn e path. nsLookupMod (nsLift mn e) path = case path of | [] => SOME (nsLift mn e) @@ -318,42 +406,49 @@ Theorem nsLookupMod_nsLift if mn = mn' then nsLookupMod e path' else - NONE` - (rw [nsLift_def] + NONE +Proof + rw [nsLift_def] >> CASE_TAC - >> rw [nsLookupMod_def]); + >> rw [nsLookupMod_def] +QED -Theorem nsLookup_nsLift_append[simp] - `!m ns ns' m' id n. +Theorem nsLookup_nsLift_append[simp]: + !m ns ns' m' id n. nsLookup (nsAppend (nsLift m ns) ns') (Short n) = nsLookup ns' (Short n) ∧ nsLookup (nsAppend (nsLift m ns) ns') (Long m' id) = - if m = m' then nsLookup ns id else nsLookup ns' (Long m' id)` - (rpt strip_tac + if m = m' then nsLookup ns id else nsLookup ns' (Long m' id) +Proof + rpt strip_tac >> Cases_on `ns'` - >> rw [nsAppend_def, nsLift_def, nsLookup_def]); + >> rw [nsAppend_def, nsLift_def, nsLookup_def] +QED (* --------------- nsAppend ------------- *) -Theorem nsLookup_nsAppend_none - `∀e1 id e2. +Theorem nsLookup_nsAppend_none: + ∀e1 id e2. nsLookup e1 id = NONE ∧ nsLookup e2 id = NONE ⇒ - nsLookup (nsAppend e1 e2) id = NONE` - (ho_match_mp_tac nsLookup_ind + nsLookup (nsAppend e1 e2) id = NONE +Proof + ho_match_mp_tac nsLookup_ind >> rw [] >> Cases_on `e2` >> fs [nsAppend_def, nsLookup_def, ALOOKUP_APPEND] >> every_case_tac - >> fs []); + >> fs [] +QED -Theorem nsLookup_nsAppend_none - `∀e1 id e2. +Theorem nsLookup_nsAppend_none: + ∀e1 id e2. nsLookup (nsAppend e1 e2) id = NONE ⇔ (nsLookup e1 id = NONE ∧ (nsLookup e2 id = NONE ∨ - ?p1 p2 e3. p1 ≠ [] ∧ id_to_mods id = p1++p2 ∧ nsLookupMod e1 p1 = SOME e3))` - (ho_match_mp_tac nsLookup_ind + ?p1 p2 e3. p1 ≠ [] ∧ id_to_mods id = p1++p2 ∧ nsLookupMod e1 p1 = SOME e3)) +Proof + ho_match_mp_tac nsLookup_ind >> rw [] >> Cases_on `e2` >> fs [nsAppend_def, nsLookup_def, ALOOKUP_APPEND] @@ -367,16 +462,18 @@ Theorem nsLookup_nsAppend_none >> rfs []) >> rw [METIS_PROVE [] ``x ∨ y ⇔ ~x ⇒ y``] >> qexists_tac `[mn]` - >> simp [nsLookupMod_def]); + >> simp [nsLookupMod_def] +QED -Theorem nsLookup_nsAppend_some - `∀e1 id e2 v. +Theorem nsLookup_nsAppend_some: + ∀e1 id e2 v. nsLookup (nsAppend e1 e2) id = SOME v ⇔ nsLookup e1 id = SOME v ∨ (nsLookup e1 id = NONE ∧ nsLookup e2 id = SOME v ∧ - !p1 p2. p1 ≠ [] ∧ id_to_mods id = p1++p2 ⇒ nsLookupMod e1 p1 = NONE)` - (ho_match_mp_tac nsLookup_ind + !p1 p2. p1 ≠ [] ∧ id_to_mods id = p1++p2 ⇒ nsLookupMod e1 p1 = NONE) +Proof + ho_match_mp_tac nsLookup_ind >> rw [] >> Cases_on `e2` >> fs [nsAppend_def, nsLookup_def, ALOOKUP_APPEND] @@ -389,27 +486,31 @@ Theorem nsLookup_nsAppend_some Cases_on `p1` >> fs [nsLookupMod_def]) >> first_x_assum (qspec_then `[mn]` mp_tac) - >> simp [nsLookupMod_def]); + >> simp [nsLookupMod_def] +QED -Theorem nsAppend_to_nsBindList - `!l. nsAppend (alist_to_ns l) e = nsBindList l e` - (Induct_on `l` +Theorem nsAppend_to_nsBindList: + !l. nsAppend (alist_to_ns l) e = nsBindList l e +Proof + Induct_on `l` >> fs [nsBindList_def, alist_to_ns_def] >> rw [] >> pairarg_tac >> simp [] >> Cases_on `e` >> fs [nsAppend_def] - >> metis_tac [nsAppend_def, nsBind_def]); + >> metis_tac [nsAppend_def, nsBind_def] +QED -Theorem nsLookupMod_nsAppend_none - `!e1 e2 path. +Theorem nsLookupMod_nsAppend_none: + !e1 e2 path. nsLookupMod (nsAppend e1 e2) path = NONE ⇔ (nsLookupMod e1 path = NONE ∧ (nsLookupMod e2 path = NONE ∨ - ?p1 p2 e3. p1 ≠ [] ∧ path = p1++p2 ∧ nsLookupMod e1 p1 = SOME e3))` - (Induct_on `path` + ?p1 p2 e3. p1 ≠ [] ∧ path = p1++p2 ∧ nsLookupMod e1 p1 = SOME e3)) +Proof + Induct_on `path` >> rw [] >> Cases_on `e2` >> Cases_on `e1` @@ -424,17 +525,19 @@ Theorem nsLookupMod_nsAppend_none >> rfs []) >> rw [METIS_PROVE [] ``x ∨ y ⇔ ~x ⇒ y``] >> qexists_tac `[h]` - >> simp [nsLookupMod_def]); + >> simp [nsLookupMod_def] +QED -Theorem nsLookupMod_nsAppend_some - `!e1 e2 path. +Theorem nsLookupMod_nsAppend_some: + !e1 e2 path. (nsLookupMod (nsAppend e1 e2) path = SOME x ⇔ if path = [] then x = nsAppend e1 e2 else nsLookupMod e1 path = SOME x ∨ (nsLookupMod e2 path = SOME x ∧ - !p1 p2. p1 ≠ [] ∧ path = p1++p2 ⇒ nsLookupMod e1 p1 = NONE))` - (Induct_on `path` + !p1 p2. p1 ≠ [] ∧ path = p1++p2 ⇒ nsLookupMod e1 p1 = NONE)) +Proof + Induct_on `path` >> rw [] >> Cases_on `e2` >> Cases_on `e1` @@ -457,11 +560,13 @@ Theorem nsLookupMod_nsAppend_some rw [nsLookupMod_def]) >- ( first_x_assum (qspecl_then [`[h]`, `path`] mp_tac) >> - rw [nsLookupMod_def])); + rw [nsLookupMod_def]) +QED -Theorem nsDom_nsAppend_alist[simp] - `!x y. nsDom (nsAppend (alist_to_ns x) y) = set (MAP (Short o FST) x) ∪ nsDom y` - (rw [nsDom_def, EXTENSION, GSPECIFICATION, LAMBDA_PROD, EXISTS_PROD, MAP_o] >> +Theorem nsDom_nsAppend_alist[simp]: + !x y. nsDom (nsAppend (alist_to_ns x) y) = set (MAP (Short o FST) x) ∪ nsDom y +Proof + rw [nsDom_def, EXTENSION, GSPECIFICATION, LAMBDA_PROD, EXISTS_PROD, MAP_o] >> eq_tac >> rw [nsLookup_nsAppend_some, nsLookup_alist_to_ns_some, nsLookup_alist_to_ns_none] >> fs [MEM_MAP] >> @@ -487,21 +592,27 @@ Theorem nsDom_nsAppend_alist[simp] >- ( rw [id_to_mods_def, alist_to_ns_def] >> Cases_on `p1` >> - fs [nsLookupMod_def]))); + fs [nsLookupMod_def])) +QED (* -------------- nsAll ---------------- *) -Theorem eALL_T[simp] - `!e. nsAll (\n x. T) e` - (rw [nsAll_def]); - -Theorem nsLookup_nsAll - `!env x P v. nsAll P env ∧ nsLookup env x = SOME v ⇒ P x v` - (rw [nsAll_def]); - -Theorem nsAll_nsAppend - `!f e1 e2. nsAll f e1 ∧ nsAll f e2 ⇒ nsAll f (nsAppend e1 e2)` - (simp [nsAll_def, PULL_FORALL] +Theorem eALL_T[simp]: + !e. nsAll (\n x. T) e +Proof + rw [nsAll_def] +QED + +Theorem nsLookup_nsAll: + !env x P v. nsAll P env ∧ nsLookup env x = SOME v ⇒ P x v +Proof + rw [nsAll_def] +QED + +Theorem nsAll_nsAppend: + !f e1 e2. nsAll f e1 ∧ nsAll f e2 ⇒ nsAll f (nsAppend e1 e2) +Proof + simp [nsAll_def, PULL_FORALL] >> rpt gen_tac >> qspec_tac (`v`, `v`) >> qspec_tac (`e2`, `e2`) @@ -517,28 +628,34 @@ Theorem nsAll_nsAppend >- metis_tac [nsLookup_def] >> rw [] >> rpt (first_x_assum (qspec_then `Long mn id` mp_tac)) - >> simp [nsLookup_def]); + >> simp [nsLookup_def] +QED -Theorem nsAll_nsBind - `!P x v e. P (Short x) v ∧ nsAll P e ⇒ nsAll P (nsBind x v e)` - (rw [nsAll_def, nsBind_def] +Theorem nsAll_nsBind: + !P x v e. P (Short x) v ∧ nsAll P e ⇒ nsAll P (nsBind x v e) +Proof + rw [nsAll_def, nsBind_def] >> Cases_on `id = Short x` - >> fs []); + >> fs [] +QED -Theorem nsAll_nsOptBind - `!P x v e. (x = NONE ∨ ?n. x = SOME n ∧ P (Short n) v) ∧ nsAll P e ⇒ nsAll P (nsOptBind x v e)` - (rw [nsAll_def, nsOptBind_def] +Theorem nsAll_nsOptBind: + !P x v e. (x = NONE ∨ ?n. x = SOME n ∧ P (Short n) v) ∧ nsAll P e ⇒ nsAll P (nsOptBind x v e) +Proof + rw [nsAll_def, nsOptBind_def] >> every_case_tac >> fs [] >> Cases_on `id` >> fs [nsLookup_def, nsBind_def] >> rename1 `nsLookup (nsBind n1 _ _) (Short n2)` >> Cases_on `n1 = n2` - >> fs []); + >> fs [] +QED -Theorem nsAll_alist_to_ns - `!R l. EVERY (λ(n,v). R (Short n) v) l ⇒ nsAll R (alist_to_ns l)` - (Induct_on `l` +Theorem nsAll_alist_to_ns: + !R l. EVERY (λ(n,v). R (Short n) v) l ⇒ nsAll R (alist_to_ns l) +Proof + Induct_on `l` >> rw [nsAll_def, alist_to_ns_def] >> pairarg_tac >> fs [] @@ -548,40 +665,50 @@ Theorem nsAll_alist_to_ns >> fs [EVERY_MEM, LAMBDA_PROD, FORALL_PROD] >> rw [] >> drule ALOOKUP_MEM - >> metis_tac []); + >> metis_tac [] +QED -Theorem nsAll_nsLift[simp] - `!R mn e. nsAll R (nsLift mn e) ⇔ nsAll (\id. R (Long mn id)) e` - (rw [nsAll_def, nsLookup_nsLift] +Theorem nsAll_nsLift[simp]: + !R mn e. nsAll R (nsLift mn e) ⇔ nsAll (\id. R (Long mn id)) e +Proof + rw [nsAll_def, nsLookup_nsLift] >> eq_tac >> rw [] >> every_case_tac - >> fs []); + >> fs [] +QED -Theorem nsAll_nsAppend_left - `!P n1 n2. nsAll P (nsAppend n1 n2) ⇒ nsAll P n1` - (rw [nsAll_def] >> - fs [nsLookup_nsAppend_some]); +Theorem nsAll_nsAppend_left: + !P n1 n2. nsAll P (nsAppend n1 n2) ⇒ nsAll P n1 +Proof + rw [nsAll_def] >> + fs [nsLookup_nsAppend_some] +QED (* -------------- nsSub ---------------- *) -Theorem nsSub_conj - `!P Q e1 e2. nsSub (\id x y. P id x y ∧ Q id x y) e1 e2 ⇔ nsSub P e1 e2 ∧ - nsSub Q e1 e2` - (rw [nsSub_def] +Theorem nsSub_conj: + !P Q e1 e2. nsSub (\id x y. P id x y ∧ Q id x y) e1 e2 ⇔ nsSub P e1 e2 ∧ + nsSub Q e1 e2 +Proof + rw [nsSub_def] >> eq_tac >> rw [] - >> metis_tac [SOME_11]); - -Theorem nsSub_refl - `!P R. (!n x. P n x ⇒ R n x x) ⇒ !e. nsAll P e ⇒ nsSub R e e` - (rw [nsSub_def] - >> metis_tac [nsLookup_nsAll]); - -Theorem nsSub_nsBind - `!R x v1 v2 e1 e2. - R (Short x) v1 v2 ∧ nsSub R e1 e2 ⇒ nsSub R (nsBind x v1 e1) (nsBind x v2 e2)` - (rw [nsBind_def, nsSub_def] + >> metis_tac [SOME_11] +QED + +Theorem nsSub_refl: + !P R. (!n x. P n x ⇒ R n x x) ⇒ !e. nsAll P e ⇒ nsSub R e e +Proof + rw [nsSub_def] + >> metis_tac [nsLookup_nsAll] +QED + +Theorem nsSub_nsBind: + !R x v1 v2 e1 e2. + R (Short x) v1 v2 ∧ nsSub R e1 e2 ⇒ nsSub R (nsBind x v1 e1) (nsBind x v2 e2) +Proof + rw [nsBind_def, nsSub_def] >- ( Cases_on `id = Short x` >> fs []) @@ -590,21 +717,25 @@ Theorem nsSub_nsBind >> fs [nsBind_def, nsLookupMod_def] >> Cases_on `e1` >> Cases_on `e2` - >> fs [nsBind_def, nsLookupMod_def]); + >> fs [nsBind_def, nsLookupMod_def] +QED -Theorem nsSub_nsAppend2 - `!R e1 e2 e2'. nsSub R e1 e1 ∧ nsSub R e2 e2' ⇒ nsSub R (nsAppend e1 e2) (nsAppend e1 e2')` - (rw [nsSub_def, nsLookup_nsAppend_some, nsLookupMod_nsAppend_none] +Theorem nsSub_nsAppend2: + !R e1 e2 e2'. nsSub R e1 e1 ∧ nsSub R e2 e2' ⇒ nsSub R (nsAppend e1 e2) (nsAppend e1 e2') +Proof + rw [nsSub_def, nsLookup_nsAppend_some, nsLookupMod_nsAppend_none] >> rw [nsSub_def, nsLookup_nsAppend_some, nsLookupMod_nsAppend_none] - >> metis_tac [NOT_SOME_NONE, SOME_11, option_nchotomy]); + >> metis_tac [NOT_SOME_NONE, SOME_11, option_nchotomy] +QED -Theorem nsSub_nsAppend_lift - `!R mn e1 e1' e2 e2'. +Theorem nsSub_nsAppend_lift: + !R mn e1 e1' e2 e2'. nsSub (\id. R (Long mn id)) e1 e1' ∧ nsSub R e2 e2' ⇒ - nsSub R (nsAppend (nsLift mn e1) e2) (nsAppend (nsLift mn e1') e2')` - (rw [nsSub_def, nsLookup_nsAppend_some, nsLookupMod_nsAppend_none, + nsSub R (nsAppend (nsLift mn e1) e2) (nsAppend (nsLift mn e1') e2') +Proof + rw [nsSub_def, nsLookup_nsAppend_some, nsLookupMod_nsAppend_none, nsLookupMod_nsLift, nsLookup_nsLift] >> rw [nsSub_def, nsLookup_nsAppend_some, nsLookupMod_nsAppend_none, nsLookupMod_nsLift, nsLookup_nsLift] @@ -623,7 +754,8 @@ Theorem nsSub_nsAppend_lift >- ( disj2_tac >> qexists_tac `[h]` - >> simp [nsLookupMod_def])); + >> simp [nsLookupMod_def]) +QED val alist_rel_restr_def = Define ` (alist_rel_restr R l1 l2 [] ⇔ T) ∧ @@ -635,29 +767,33 @@ val alist_rel_restr_def = Define ` | NONE => F | SOME v2 => R k1 v1 v2 ∧ alist_rel_restr R l1 l2 keys)`; -Theorem alist_rel_restr_thm - `!R e1 e2 keys. +Theorem alist_rel_restr_thm: + !R e1 e2 keys. alist_rel_restr R e1 e2 keys ⇔ - !k. MEM k keys ⇒ ?v1 v2. ALOOKUP e1 k = SOME v1 ∧ ALOOKUP e2 k = SOME v2 ∧ R k v1 v2` - (Induct_on `keys` + !k. MEM k keys ⇒ ?v1 v2. ALOOKUP e1 k = SOME v1 ∧ ALOOKUP e2 k = SOME v2 ∧ R k v1 v2 +Proof + Induct_on `keys` >> rw [alist_rel_restr_def] >> every_case_tac >> fs [] - >> metis_tac [NOT_SOME_NONE, SOME_11, option_nchotomy]); + >> metis_tac [NOT_SOME_NONE, SOME_11, option_nchotomy] +QED val alistSub_def = Define ` alistSub R e1 e2 ⇔ alist_rel_restr R e1 e2 (MAP FST e1)`; -Theorem alistSub_cong - `!l1 l2 l1' l2' R R'. +Theorem alistSub_cong: + !l1 l2 l1' l2' R R'. l1 = l1' ∧ l2 = l2' ∧ (!n x y. ALOOKUP l1' n = SOME x ∧ ALOOKUP l2' n = SOME y ⇒ R n x y = R' n x y) ⇒ - (alistSub R l1 l2 ⇔ alistSub R' l1' l2')` - (rw [alistSub_def] + (alistSub R l1 l2 ⇔ alistSub R' l1' l2') +Proof + rw [alistSub_def] >> qspec_tac (`MAP FST l1`, `keys`) >> Induct >> rw [alist_rel_restr_def] >> every_case_tac - >> metis_tac []); + >> metis_tac [] +QED val _ = DefnBase.export_cong "alistSub_cong"; @@ -675,17 +811,20 @@ val nsSub_compute_def = tDefine "nsSub_compute" ` >> fs [] >> rw [namespace_size_def]); -Theorem nsLookup_FOLDR_nsLift - `!e p k. nsLookup (FOLDR nsLift e p) (mk_id p k) = nsLookup e (Short k)` - (Induct_on `p` - >> rw [mk_id_def, nsLookup_def, nsLift_def]); +Theorem nsLookup_FOLDR_nsLift: + !e p k. nsLookup (FOLDR nsLift e p) (mk_id p k) = nsLookup e (Short k) +Proof + Induct_on `p` + >> rw [mk_id_def, nsLookup_def, nsLift_def] +QED -Theorem nsLookup_FOLDR_nsLift_some - `!e p id v. +Theorem nsLookup_FOLDR_nsLift_some: + !e p id v. nsLookup (FOLDR nsLift e p) id = SOME v ⇔ (p = [] ∧ nsLookup e id = SOME v) ∨ - (p ≠ [] ∧ ?p2 n. id = mk_id (p++p2) n ∧ nsLookup e (mk_id p2 n) = SOME v)` - (Induct_on `p` + (p ≠ [] ∧ ?p2 n. id = mk_id (p++p2) n ∧ nsLookup e (mk_id p2 n) = SOME v) +Proof + Induct_on `p` >> rw [nsLift_def] >> Cases_on `id` >> rw [nsLookup_def, mk_id_def] @@ -696,22 +835,26 @@ Theorem nsLookup_FOLDR_nsLift_some >> rw [] >> qexists_tac `id_to_mods i` >> qexists_tac `id_to_n i` - >> rw [mk_id_thm]); + >> rw [mk_id_thm] +QED -Theorem nsLookupMod_FOLDR_nsLift_none - `!e p1 p2. nsLookupMod (FOLDR nsLift e p1) p2 = NONE ⇔ +Theorem nsLookupMod_FOLDR_nsLift_none: + !e p1 p2. nsLookupMod (FOLDR nsLift e p1) p2 = NONE ⇔ (IS_PREFIX p1 p2 ∨ IS_PREFIX p2 p1) ⇒ - ?p3. p2 = p1++p3 ∧ nsLookupMod e p3 = NONE` - (Induct_on `p1` + ?p3. p2 = p1++p3 ∧ nsLookupMod e p3 = NONE +Proof + Induct_on `p1` >> rw [nsLift_def] >> Cases_on `p2` - >> rw [nsLookupMod_def, mk_id_def]); + >> rw [nsLookupMod_def, mk_id_def] +QED -Theorem nsSub_compute_thm_general - `!p R e1 e2. +Theorem nsSub_compute_thm_general: + !p R e1 e2. nsSub R (FOLDR nsLift e1 (REVERSE p)) (FOLDR nsLift e2 (REVERSE p)) ⇔ - nsSub_compute p R e1 e2` - (ho_match_mp_tac (theorem "nsSub_compute_ind") + nsSub_compute p R e1 e2 +Proof + ho_match_mp_tac (theorem "nsSub_compute_ind") >> rw [nsSub_def, nsSub_compute_def, alistSub_def, alist_rel_restr_thm, nsLookup_def] >> eq_tac >> rw [] @@ -845,57 +988,71 @@ Theorem nsSub_compute_thm_general >> fs [] >> pop_assum kall_tac >> first_x_assum (qspec_then `REVERSE p ++ [h] ++ t` mp_tac) - >> rw [])); + >> rw []) +QED -Theorem nsSub_compute_thm - `!R e1 e2. nsSub R e1 e2 ⇔ nsSub_compute [] R e1 e2` - (rw [GSYM nsSub_compute_thm_general]); +Theorem nsSub_compute_thm: + !R e1 e2. nsSub R e1 e2 ⇔ nsSub_compute [] R e1 e2 +Proof + rw [GSYM nsSub_compute_thm_general] +QED (* -------------- nsAll2 ---------------- *) -Theorem nsAll2_conj - `!P Q e1 e2. nsAll2 (\id x y. P id x y ∧ Q id x y) e1 e2 ⇔ nsAll2 P e1 e2 ∧ nsAll2 Q e1 e2` - (rw [nsAll2_def, nsSub_conj] - >> metis_tac []); +Theorem nsAll2_conj: + !P Q e1 e2. nsAll2 (\id x y. P id x y ∧ Q id x y) e1 e2 ⇔ nsAll2 P e1 e2 ∧ nsAll2 Q e1 e2 +Proof + rw [nsAll2_def, nsSub_conj] + >> metis_tac [] +QED -Theorem nsAll2_nsLookup1 - `!R e1 e2 n v1. +Theorem nsAll2_nsLookup1: + !R e1 e2 n v1. nsLookup e1 n = SOME v1 ∧ nsAll2 R e1 e2 ⇒ - ?v2. nsLookup e2 n = SOME v2 ∧ R n v1 v2` - (rw [nsSub_def, nsAll2_def]); + ?v2. nsLookup e2 n = SOME v2 ∧ R n v1 v2 +Proof + rw [nsSub_def, nsAll2_def] +QED -Theorem nsAll2_nsLookup2 - `!R e1 e2 n v2. +Theorem nsAll2_nsLookup2: + !R e1 e2 n v2. nsLookup e2 n = SOME v2 ∧ nsAll2 R e1 e2 ⇒ - ?v1. nsLookup e1 n = SOME v1 ∧ R n v1 v2` - (rw [nsSub_def, nsAll2_def] - >> metis_tac [NOT_SOME_NONE, option_nchotomy, SOME_11]); - -Theorem nsAll2_nsLookup_none - `!R e1 e2 n. + ?v1. nsLookup e1 n = SOME v1 ∧ R n v1 v2 +Proof + rw [nsSub_def, nsAll2_def] + >> metis_tac [NOT_SOME_NONE, option_nchotomy, SOME_11] +QED + +Theorem nsAll2_nsLookup_none: + !R e1 e2 n. nsAll2 R e1 e2 ⇒ - (nsLookup e1 n = NONE ⇔ nsLookup e2 n = NONE)` - (rw [nsSub_def, nsAll2_def] - >> metis_tac [NOT_SOME_NONE, option_nchotomy, SOME_11]); - -Theorem nsAll2_nsBind - `!R x v1 v2 e1 e2. - R (Short x) v1 v2 ∧ nsAll2 R e1 e2 ⇒ nsAll2 R (nsBind x v1 e1) (nsBind x v2 e2)` - (rw [nsAll2_def] + (nsLookup e1 n = NONE ⇔ nsLookup e2 n = NONE) +Proof + rw [nsSub_def, nsAll2_def] + >> metis_tac [NOT_SOME_NONE, option_nchotomy, SOME_11] +QED + +Theorem nsAll2_nsBind: + !R x v1 v2 e1 e2. + R (Short x) v1 v2 ∧ nsAll2 R e1 e2 ⇒ nsAll2 R (nsBind x v1 e1) (nsBind x v2 e2) +Proof + rw [nsAll2_def] >> irule nsSub_nsBind - >> rw []); + >> rw [] +QED -Theorem nsAll2_nsBindList - `!R l1 l2 e1 e2. +Theorem nsAll2_nsBindList: + !R l1 l2 e1 e2. LIST_REL (\(x,y) (x',y'). x = x' ∧ R (Short x) y y') l1 l2 ∧ nsAll2 R e1 e2 ⇒ - nsAll2 R (nsBindList l1 e1) (nsBindList l2 e2)` - (Induct_on `l1` + nsAll2 R (nsBindList l1 e1) (nsBindList l2 e2) +Proof + Induct_on `l1` >> rw [nsBindList_def] >> rw [nsBindList_def] >> pairarg_tac @@ -904,17 +1061,21 @@ Theorem nsAll2_nsBindList >> rw [] >> fs [nsBindList_def] >> irule nsAll2_nsBind - >> rw []); - -Theorem nsAll2_nsAppend - `!R e1 e1' e2 e2'. - nsAll2 R e1 e2 ∧ nsAll2 R e1' e2' ⇒ nsAll2 R (nsAppend e1 e1') (nsAppend e2 e2')` - (rw [nsAll2_def, nsSub_def, nsLookup_nsAppend_some, nsLookupMod_nsAppend_none] - >> metis_tac [NOT_SOME_NONE, SOME_11, option_nchotomy]); - -Theorem nsAll2_alist_to_ns - `!R l1 l2. LIST_REL (\(x,y) (x',y'). x = x' ∧ R (Short x) y y') l1 l2 ⇒ nsAll2 R (alist_to_ns l1) (alist_to_ns l2)` - (Induct_on `l1` + >> rw [] +QED + +Theorem nsAll2_nsAppend: + !R e1 e1' e2 e2'. + nsAll2 R e1 e2 ∧ nsAll2 R e1' e2' ⇒ nsAll2 R (nsAppend e1 e1') (nsAppend e2 e2') +Proof + rw [nsAll2_def, nsSub_def, nsLookup_nsAppend_some, nsLookupMod_nsAppend_none] + >> metis_tac [NOT_SOME_NONE, SOME_11, option_nchotomy] +QED + +Theorem nsAll2_alist_to_ns: + !R l1 l2. LIST_REL (\(x,y) (x',y'). x = x' ∧ R (Short x) y y') l1 l2 ⇒ nsAll2 R (alist_to_ns l1) (alist_to_ns l2) +Proof + Induct_on `l1` >> rw [] >> pairarg_tac >> fs [] @@ -922,11 +1083,13 @@ Theorem nsAll2_alist_to_ns >> fs [] >> rw [] >> irule nsAll2_nsBind - >> simp []); + >> simp [] +QED -Theorem nsAll2_nsLift[simp] - `!R mn e1 e2. nsAll2 R (nsLift mn e1) (nsLift mn e2) ⇔ nsAll2 (\id. R (Long mn id)) e1 e2` - (rw [nsAll2_def, nsSub_def] +Theorem nsAll2_nsLift[simp]: + !R mn e1 e2. nsAll2 R (nsLift mn e1) (nsLift mn e2) ⇔ nsAll2 (\id. R (Long mn id)) e1 e2 +Proof + rw [nsAll2_def, nsSub_def] >> eq_tac >> rw [] >- ( @@ -944,116 +1107,146 @@ Theorem nsAll2_nsLift[simp] >> pop_assum mp_tac >> simp [nsLookup_nsLift, nsLookupMod_nsLift] >> every_case_tac - >> fs []); + >> fs [] +QED (* -------------- nsMap --------------- *) -Theorem nsMap_alist_to_ns[simp] - `!f l. nsMap f (alist_to_ns l) = alist_to_ns (MAP (\(k,v). (k, f v)) l)` - (Induct_on `l` +Theorem nsMap_alist_to_ns[simp]: + !f l. nsMap f (alist_to_ns l) = alist_to_ns (MAP (\(k,v). (k, f v)) l) +Proof + Induct_on `l` >> rw [] - >> rw [alist_to_ns_def, nsMap_def]); + >> rw [alist_to_ns_def, nsMap_def] +QED -Theorem nsMap_compose - `∀g e f. nsMap f (nsMap g e) = nsMap (f o g) e` - (recInduct nsMap_ind +Theorem nsMap_compose: + ∀g e f. nsMap f (nsMap g e) = nsMap (f o g) e +Proof + recInduct nsMap_ind \\ rw[nsMap_def, MAP_MAP_o, o_DEF, FORALL_PROD, EXISTS_PROD, LAMBDA_PROD, MAP_EQ_f] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem nsMap_I[simp] - `∀ns. nsMap I ns = ns` - (`∀ns f. f = I ⇒ nsMap f ns = ns` suffices_by rw[] +Theorem nsMap_I[simp]: + ∀ns. nsMap I ns = ns +Proof + `∀ns f. f = I ⇒ nsMap f ns = ns` suffices_by rw[] \\ CONV_TAC SWAP_FORALL_CONV \\ recInduct nsMap_ind \\ rw[nsMap_def, MAP_EQ_ID, UNCURRY, FORALL_PROD] - \\ res_tac); - -Theorem nsMap_nsAppend - `!n1 n2 f. nsMap f (nsAppend n1 n2) = nsAppend (nsMap f n1) (nsMap f n2)` - (ho_match_mp_tac nsAppend_ind >> - rw [nsAppend_def, nsMap_def]); - -Theorem nsLookupMod_nsMap - `!n x f. nsLookupMod (nsMap f n) x = OPTION_MAP (nsMap f) (nsLookupMod n x)` - (ho_match_mp_tac nsLookupMod_ind >> + \\ res_tac +QED + +Theorem nsMap_nsAppend: + !n1 n2 f. nsMap f (nsAppend n1 n2) = nsAppend (nsMap f n1) (nsMap f n2) +Proof + ho_match_mp_tac nsAppend_ind >> + rw [nsAppend_def, nsMap_def] +QED + +Theorem nsLookupMod_nsMap: + !n x f. nsLookupMod (nsMap f n) x = OPTION_MAP (nsMap f) (nsLookupMod n x) +Proof + ho_match_mp_tac nsLookupMod_ind >> rw [nsLookupMod_def, nsMap_def, ALOOKUP_MAP] >> every_case_tac >> rw [] >> - fs []); + fs [] +QED -Theorem nsLookup_nsMap - `!n x f. nsLookup (nsMap f n) x = OPTION_MAP f (nsLookup n x)` - (ho_match_mp_tac nsLookup_ind >> +Theorem nsLookup_nsMap: + !n x f. nsLookup (nsMap f n) x = OPTION_MAP f (nsLookup n x) +Proof + ho_match_mp_tac nsLookup_ind >> rw [nsLookup_def, nsMap_def, ALOOKUP_MAP] >> every_case_tac >> rw [] >> - fs []); - -Theorem nsAll_nsMap - `!f n P. nsAll P (nsMap f n) ⇔ nsAll (\x y. P x (f y)) n` - (rw [nsMap_def, nsAll_def, nsLookup_nsMap] >> - metis_tac []); - -Theorem nsLift_nsMap - `!f n mn. nsLift mn (nsMap f n) = nsMap f (nsLift mn n)` - (rw [nsLift_def, nsMap_def]); - -Theorem nsSub_nsMap - `!R f n1 n2. - nsSub R (nsMap f n1) (nsMap f n2) ⇔ nsSub (\id x y. R id (f x) (f y)) n1 n2` - (rw [nsSub_def, nsMap_def, nsLookup_nsMap, nsLookupMod_nsMap] >> + fs [] +QED + +Theorem nsAll_nsMap: + !f n P. nsAll P (nsMap f n) ⇔ nsAll (\x y. P x (f y)) n +Proof + rw [nsMap_def, nsAll_def, nsLookup_nsMap] >> + metis_tac [] +QED + +Theorem nsLift_nsMap: + !f n mn. nsLift mn (nsMap f n) = nsMap f (nsLift mn n) +Proof + rw [nsLift_def, nsMap_def] +QED + +Theorem nsSub_nsMap: + !R f n1 n2. + nsSub R (nsMap f n1) (nsMap f n2) ⇔ nsSub (\id x y. R id (f x) (f y)) n1 n2 +Proof + rw [nsSub_def, nsMap_def, nsLookup_nsMap, nsLookupMod_nsMap] >> eq_tac >> rw [] >> - metis_tac []); + metis_tac [] +QED (* --------------- nsDom --------------- *) -Theorem nsLookup_nsDom - `!x n. x ∈ nsDom n ⇔ ?v. nsLookup n x = SOME v` - (rw [nsDom_def, GSPECIFICATION, EXISTS_PROD]); - -Theorem nsDomMod_alist_to_ns[simp] - `!l. nsDomMod (alist_to_ns l) = {[]}` - (rw [nsDomMod_def, alist_to_ns_def, EXTENSION, GSPECIFICATION, EXISTS_PROD, UNCURRY] >> +Theorem nsLookup_nsDom: + !x n. x ∈ nsDom n ⇔ ?v. nsLookup n x = SOME v +Proof + rw [nsDom_def, GSPECIFICATION, EXISTS_PROD] +QED + +Theorem nsDomMod_alist_to_ns[simp]: + !l. nsDomMod (alist_to_ns l) = {[]} +Proof + rw [nsDomMod_def, alist_to_ns_def, EXTENSION, GSPECIFICATION, EXISTS_PROD, UNCURRY] >> Cases_on `x` >> - rw [nsLookupMod_def]); + rw [nsLookupMod_def] +QED val lemma = Q.prove ( `(?x. y = SOME x) ⇔ y ≠ NONE`, Cases_on `y` >> rw []); -Theorem nsDom_nsAppend_equal - `!n1 n2 n3 n4. +Theorem nsDom_nsAppend_equal: + !n1 n2 n3 n4. nsDom n1 = nsDom n3 ∧ nsDom n2 = nsDom n4 ∧ nsDomMod n1 = nsDomMod n3 ∧ nsDomMod n2 = nsDomMod n4 ⇒ nsDom (nsAppend n1 n2) = nsDom (nsAppend n3 n4) ∧ - nsDomMod (nsAppend n1 n2) = nsDomMod (nsAppend n3 n4)` - (rw [namespaceTheory.nsDom_def, namespaceTheory.nsDomMod_def, + nsDomMod (nsAppend n1 n2) = nsDomMod (nsAppend n3 n4) +Proof + rw [namespaceTheory.nsDom_def, namespaceTheory.nsDomMod_def, EXTENSION, GSPECIFICATION, EXISTS_PROD, nsLookup_nsAppend_some] >- metis_tac [NOT_SOME_NONE, option_nchotomy] >> fs [lemma, nsLookupMod_nsAppend_none] - >- metis_tac [NOT_SOME_NONE, option_nchotomy]); + >- metis_tac [NOT_SOME_NONE, option_nchotomy] +QED -Theorem nsDom_nsLift - `!mn n. nsDom (nsLift mn n) = IMAGE (Long mn) (nsDom n)` - (rw [nsDom_def, EXTENSION, GSPECIFICATION, EXISTS_PROD, nsLookup_nsLift] >> +Theorem nsDom_nsLift: + !mn n. nsDom (nsLift mn n) = IMAGE (Long mn) (nsDom n) +Proof + rw [nsDom_def, EXTENSION, GSPECIFICATION, EXISTS_PROD, nsLookup_nsLift] >> Cases_on `x` >> rw [] >> - metis_tac []); + metis_tac [] +QED -Theorem nsDomMod_nsLift - `!mn n. nsDomMod (nsLift mn n) = [] INSERT IMAGE (CONS mn) (nsDomMod n)` - (rw [nsDomMod_def, EXTENSION, GSPECIFICATION, EXISTS_PROD, nsLookupMod_nsLift] >> +Theorem nsDomMod_nsLift: + !mn n. nsDomMod (nsLift mn n) = [] INSERT IMAGE (CONS mn) (nsDomMod n) +Proof + rw [nsDomMod_def, EXTENSION, GSPECIFICATION, EXISTS_PROD, nsLookupMod_nsLift] >> Cases_on `x` >> rw [] >> - metis_tac []); + metis_tac [] +QED -Theorem nsDom_nsAppend_flat - `!n1 n2.nsDomMod n1 = {[]} ⇒ nsDom (nsAppend n1 n2) = nsDom n1 ∪ nsDom n2` - (rw [nsDom_def, nsDomMod_def, EXTENSION, GSPECIFICATION, EXISTS_PROD, +Theorem nsDom_nsAppend_flat: + !n1 n2.nsDomMod n1 = {[]} ⇒ nsDom (nsAppend n1 n2) = nsDom n1 ∪ nsDom n2 +Proof + rw [nsDom_def, nsDomMod_def, EXTENSION, GSPECIFICATION, EXISTS_PROD, nsLookup_nsAppend_some] >> eq_tac >> rw [] @@ -1067,11 +1260,13 @@ Theorem nsDom_nsAppend_flat Cases_on `p1` >> fs [] >> rw [] >> - metis_tac [NOT_NIL_CONS, option_nchotomy]); + metis_tac [NOT_NIL_CONS, option_nchotomy] +QED -Theorem nsDomMod_nsAppend_flat - `!n1 n2.nsDomMod n1 = {[]} ⇒ nsDomMod (nsAppend n1 n2) = nsDomMod n2` - (rw [nsDomMod_def, EXTENSION, GSPECIFICATION, EXISTS_PROD] >> +Theorem nsDomMod_nsAppend_flat: + !n1 n2.nsDomMod n1 = {[]} ⇒ nsDomMod (nsAppend n1 n2) = nsDomMod n2 +Proof + rw [nsDomMod_def, EXTENSION, GSPECIFICATION, EXISTS_PROD] >> eq_tac >> rw [] >- ( @@ -1085,6 +1280,7 @@ Theorem nsDomMod_nsAppend_flat `nsLookupMod (nsAppend n1 n2) x = NONE` by metis_tac [option_nchotomy] >> fs [nsLookupMod_nsAppend_none] >> fs [] >> - metis_tac [option_nchotomy])); + metis_tac [option_nchotomy]) +QED val _ = export_theory (); diff --git a/semantics/proofs/primSemEnvScript.sml b/semantics/proofs/primSemEnvScript.sml index 86c42794b8..963a7defef 100644 --- a/semantics/proofs/primSemEnvScript.sml +++ b/semantics/proofs/primSemEnvScript.sml @@ -28,15 +28,16 @@ val prim_sem_env_eq = save_thm ("prim_sem_env_eq", val th1 = mk_eq(rhs(concl pth),lhs(concl th)) |> EVAL |> EQT_ELIM in TRANS (TRANS pth th1) th end)); -Theorem prim_type_sound_invariants - `!type_ids sem_st prim_env. +Theorem prim_type_sound_invariants: + !type_ids sem_st prim_env. (sem_st,prim_env) = THE (prim_sem_env ffi) ∧ DISJOINT type_ids {Tlist_num; Tbool_num; Texn_num} ⇒ ?ctMap. type_sound_invariant sem_st prim_env ctMap FEMPTY type_ids prim_tenv ∧ - FRANGE ((SND o SND) o_f ctMap) ⊆ prim_type_ids` - (rw[type_sound_invariant_def, prim_sem_env_eq, prim_tenv_def] >> + FRANGE ((SND o SND) o_f ctMap) ⊆ prim_type_ids +Proof + rw[type_sound_invariant_def, prim_sem_env_eq, prim_tenv_def] >> qexists_tac`FEMPTY |++ REVERSE [ (bind_stamp, ([],[],Texn_num)); (div_stamp, ([],[],Texn_num)); @@ -87,6 +88,7 @@ Theorem prim_type_sound_invariants \\ simp[] \\ EVAL_TAC \\ rpt strip_tac \\ rveq - \\ EVAL_TAC)); + \\ EVAL_TAC) +QED val _ = export_theory (); diff --git a/semantics/proofs/semanticPrimitivesPropsScript.sml b/semantics/proofs/semanticPrimitivesPropsScript.sml index 7e8de56b5f..76ed43653c 100644 --- a/semantics/proofs/semanticPrimitivesPropsScript.sml +++ b/semantics/proofs/semanticPrimitivesPropsScript.sml @@ -10,31 +10,43 @@ open boolSimps; val _ = new_theory "semanticPrimitivesProps"; -Theorem with_same_v[simp] - `(env:'v sem_env) with v := env.v = env` - (srw_tac[][sem_env_component_equality]); - -Theorem unchanged_env[simp] - `!(env : 'a sem_env). - <| v := env.v; c := env.c |> = env` - (rw [sem_env_component_equality]); - -Theorem with_same_clock - `(st:'ffi semanticPrimitives$state) with clock := st.clock = st` - (rw[semanticPrimitivesTheory.state_component_equality]) - -Theorem Boolv_11[simp] `Boolv b1 = Boolv b2 ⇔ (b1 = b2)` (srw_tac[][Boolv_def]); - -Theorem extend_dec_env_assoc[simp] - `!env1 env2 env3. +Theorem with_same_v[simp]: + (env:'v sem_env) with v := env.v = env +Proof + srw_tac[][sem_env_component_equality] +QED + +Theorem unchanged_env[simp]: + !(env : 'a sem_env). + <| v := env.v; c := env.c |> = env +Proof + rw [sem_env_component_equality] +QED + +Theorem with_same_clock: + (st:'ffi semanticPrimitives$state) with clock := st.clock = st +Proof + rw[semanticPrimitivesTheory.state_component_equality] +QED + +Theorem Boolv_11[simp]: + Boolv b1 = Boolv b2 ⇔ (b1 = b2) +Proof +srw_tac[][Boolv_def] +QED + +Theorem extend_dec_env_assoc[simp]: + !env1 env2 env3. extend_dec_env env1 (extend_dec_env env2 env3) = - extend_dec_env (extend_dec_env env1 env2) env3` - (rw [extend_dec_env_def]); + extend_dec_env (extend_dec_env env1 env2) env3 +Proof + rw [extend_dec_env_def] +QED (* -Theorem Tword_simp[simp] - `(∀z1 z2. (Tword z1 = Tword z2) ⇔ (z1 = z2)) ∧ +Theorem Tword_simp[simp]: + (∀z1 z2. (Tword z1 = Tword z2) ⇔ (z1 = z2)) ∧ (∀z1 z2. (TC_word z1 = TC_word z2) ⇔ (z1 = z2)) ∧ (∀z. TC_word z ≠ TC_string) ∧ (∀z. TC_word z ≠ TC_tup) ∧ @@ -56,8 +68,10 @@ Theorem Tword_simp[simp] (∀n a. (Tword W64 = Tapp a n) ⇔ (a = [] ∧ n = TC_word64)) ∧ (∀z a n. (Tword z = Tapp a n) ⇔ (a = [] ∧ n = TC_word z)) ∧ (∀n a. (Tword8 = Tapp a n) ⇔ (a = [] ∧ n = TC_word8)) ∧ - (∀n a. (Tword64 = Tapp a n) ⇔ (a = [] ∧ n = TC_word64))` - (rpt conj_tac \\ rpt Cases \\ EVAL_TAC \\ metis_tac[]); + (∀n a. (Tword64 = Tapp a n) ⇔ (a = [] ∧ n = TC_word64)) +Proof + rpt conj_tac \\ rpt Cases \\ EVAL_TAC \\ metis_tac[] +QED *) val opw_lookup_def = Define` @@ -98,19 +112,24 @@ val do_word_from_int_def = Define` (do_word_from_int W64 i = Word64 (i2w i))`; val _ = export_rewrites["do_word_from_int_def"]; -Theorem lit_same_type_refl - `∀l. lit_same_type l l` - (Cases >> simp[semanticPrimitivesTheory.lit_same_type_def]) +Theorem lit_same_type_refl: + ∀l. lit_same_type l l +Proof + Cases >> simp[semanticPrimitivesTheory.lit_same_type_def] +QED val _ = export_rewrites["lit_same_type_refl"] -Theorem lit_same_type_sym - `∀l1 l2. lit_same_type l1 l2 ⇒ lit_same_type l2 l1` - (Cases >> Cases >> simp[semanticPrimitivesTheory.lit_same_type_def]) +Theorem lit_same_type_sym: + ∀l1 l2. lit_same_type l1 l2 ⇒ lit_same_type l2 l1 +Proof + Cases >> Cases >> simp[semanticPrimitivesTheory.lit_same_type_def] +QED -Theorem pat_bindings_accum -`(!p acc. pat_bindings p acc = pat_bindings p [] ++ acc) ∧ - (!ps acc. pats_bindings ps acc = pats_bindings ps [] ++ acc)` - (Induct >> +Theorem pat_bindings_accum: + (!p acc. pat_bindings p acc = pat_bindings p [] ++ acc) ∧ + (!ps acc. pats_bindings ps acc = pats_bindings ps [] ++ acc) +Proof + Induct >> srw_tac[][] >- srw_tac[][pat_bindings_def] >- srw_tac[][pat_bindings_def] @@ -119,41 +138,46 @@ Theorem pat_bindings_accum >- metis_tac [APPEND_ASSOC, pat_bindings_def] >- metis_tac [APPEND_ASSOC, pat_bindings_def] >- srw_tac[][pat_bindings_def] - >- metis_tac [APPEND_ASSOC, pat_bindings_def]); + >- metis_tac [APPEND_ASSOC, pat_bindings_def] +QED -Theorem pmatch_append -`(!(cenv : env_ctor) (st : v store) p v env env' env''. +Theorem pmatch_append: + (!(cenv : env_ctor) (st : v store) p v env env' env''. (pmatch cenv st p v env = Match env') ⇒ (pmatch cenv st p v (env++env'') = Match (env'++env''))) ∧ (!(cenv : env_ctor) (st : v store) ps v env env' env''. (pmatch_list cenv st ps v env = Match env') ⇒ - (pmatch_list cenv st ps v (env++env'') = Match (env'++env'')))` -(ho_match_mp_tac pmatch_ind >> + (pmatch_list cenv st ps v (env++env'') = Match (env'++env''))) +Proof +ho_match_mp_tac pmatch_ind >> srw_tac[][pmatch_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> -metis_tac []); +metis_tac [] +QED -Theorem pmatch_extend -`(!cenv s p v env env' env''. +Theorem pmatch_extend: + (!cenv s p v env env' env''. pmatch cenv s p v env = Match env' ⇒ ?env''. env' = env'' ++ env ∧ MAP FST env'' = pat_bindings p []) ∧ (!cenv s ps vs env env' env''. pmatch_list cenv s ps vs env = Match env' ⇒ - ?env''. env' = env'' ++ env ∧ MAP FST env'' = pats_bindings ps [])` - (ho_match_mp_tac pmatch_ind >> + ?env''. env' = env'' ++ env ∧ MAP FST env'' = pats_bindings ps []) +Proof + ho_match_mp_tac pmatch_ind >> srw_tac[][pat_bindings_def, pmatch_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> res_tac >> rveq >> srw_tac[][] >> - metis_tac [pat_bindings_accum]); + metis_tac [pat_bindings_accum] +QED -Theorem pmatch_acc - `(!envc store p v env env' env2. +Theorem pmatch_acc: + (!envc store p v env env' env2. (pmatch envc store p v env = Match env' ⇔ pmatch envc store p v (env++env2) = Match (env'++env2)) ∧ (pmatch envc store p v env = No_match ⇔ @@ -166,8 +190,9 @@ Theorem pmatch_acc (pmatch_list envc store ps vs env = No_match ⇔ pmatch_list envc store ps vs (env++env2) = No_match) ∧ (pmatch_list envc store ps vs env = Match_type_error ⇔ - pmatch_list envc store ps vs (env++env2) = Match_type_error))` - (ho_match_mp_tac pmatch_ind + pmatch_list envc store ps vs (env++env2) = Match_type_error)) +Proof + ho_match_mp_tac pmatch_ind >> rw [pmatch_def] >- (every_case_tac >> rw []) >- (every_case_tac >> rw []) @@ -179,7 +204,8 @@ Theorem pmatch_acc >> rw [] >> CASE_TAC >> rw [] - >> metis_tac [match_result_distinct, match_result_11]); + >> metis_tac [match_result_distinct, match_result_11] +QED val op_thms = { nchotomy = op_nchotomy, case_def = op_case_def} val list_thms = { nchotomy = list_nchotomy, case_def = list_case_def} @@ -208,8 +234,8 @@ val do_app_cases = save_thm ("do_app_cases", ALL_CONV)); (* -Theorem do_app_cases -`!st op st' vs v. +Theorem do_app_cases: + !st op st' vs v. (do_app st op vs = SOME (st',v)) = ((?op' n1 n2. @@ -331,8 +357,9 @@ Theorem do_app_cases (~(i < 0) ∧ Num (ABS i) < LENGTH vs' ∧ store_assign lnum (Varray (LUPDATE v' (Num (ABS i)) vs')) st = SOME st' ∧ - v = Rval (Conv NONE [])))))` - (SIMP_TAC (srw_ss()) [do_app_def] >> + v = Rval (Conv NONE []))))) +Proof + SIMP_TAC (srw_ss()) [do_app_def] >> cases_on `op` >> srw_tac[][] >> cases_on `vs` >> @@ -347,11 +374,12 @@ Theorem do_app_cases full_simp_tac (srw_ss()++ARITH_ss) [] >> every_case_tac >> srw_tac[][] >> - metis_tac []); + metis_tac [] +QED *) -Theorem do_opapp_cases - `∀env' vs v. +Theorem do_opapp_cases: + ∀env' vs v. (do_opapp vs = SOME (env',v)) = ((∃v2 env'' n e. @@ -361,32 +389,38 @@ Theorem do_opapp_cases (vs = [Recclosure env'' funs n'; v2]) ∧ (find_recfun n' funs = SOME (n'',e)) ∧ (ALL_DISTINCT (MAP (\(f,x,e). f) funs)) ∧ - (env' = env'' with <| v := nsBind n'' v2 (build_rec_env funs env'' env''.v) |> ∧ (v = e))))` - (srw_tac[][do_opapp_def] >> + (env' = env'' with <| v := nsBind n'' v2 (build_rec_env funs env'' env''.v) |> ∧ (v = e)))) +Proof + srw_tac[][do_opapp_def] >> cases_on `vs` >> srw_tac[][] >> - every_case_tac >> metis_tac []); - -Theorem do_app_NONE_ffi - `do_app (refs,ffi) op args = NONE ⇒ - do_app (refs,ffi') op args = NONE` - (rw[do_app_def] + every_case_tac >> metis_tac [] +QED + +Theorem do_app_NONE_ffi: + do_app (refs,ffi) op args = NONE ⇒ + do_app (refs,ffi') op args = NONE +Proof + rw[do_app_def] \\ every_case_tac \\ fs[] \\ TRY pairarg_tac \\ fs[] \\ fs[store_assign_def,store_v_same_type_def] \\ every_case_tac \\ fs[] - \\ rfs[store_assign_def,store_v_same_type_def,store_lookup_def]); + \\ rfs[store_assign_def,store_v_same_type_def,store_lookup_def] +QED -Theorem do_app_SOME_ffi_same - `do_app (refs,ffi) op args = SOME ((refs',ffi),r) +Theorem do_app_SOME_ffi_same: + do_app (refs,ffi) op args = SOME ((refs',ffi),r) ∧ (∀outcome. r ≠ Rerr(Rabort(Rffi_error outcome))) ⇒ - do_app (refs,ffi') op args = SOME ((refs',ffi'),r)` - (rw[] + do_app (refs,ffi') op args = SOME ((refs',ffi'),r) +Proof + rw[] \\ fs[do_app_cases] \\ rw[] \\ fs[] \\ fs[ffiTheory.call_FFI_def] \\ every_case_tac \\ fs[] \\ rveq \\ fs[ffiTheory.ffi_state_component_equality] - \\ rfs[store_assign_def,store_v_same_type_def,store_lookup_def]); + \\ rfs[store_assign_def,store_v_same_type_def,store_lookup_def] +QED val build_rec_env_help_lem = Q.prove ( `∀funs env funs'. @@ -398,82 +432,101 @@ val build_rec_env_help_lem = Q.prove ( srw_tac[][]); (* Alternate definition for build_rec_env *) -Theorem build_rec_env_merge -`∀funs funs' env env'. +Theorem build_rec_env_merge: + ∀funs funs' env env'. build_rec_env funs env env' = - nsAppend (alist_to_ns (MAP (λ(f,n,e). (f, Recclosure env funs f)) funs)) env'` -(srw_tac[][build_rec_env_def, build_rec_env_help_lem]); - -Theorem do_con_check_build_conv -`!tenvC cn vs l. - do_con_check tenvC cn l ⇒ ?v. build_conv tenvC cn vs = SOME v` -(srw_tac[][do_con_check_def, build_conv_def] >> + nsAppend (alist_to_ns (MAP (λ(f,n,e). (f, Recclosure env funs f)) funs)) env' +Proof +srw_tac[][build_rec_env_def, build_rec_env_help_lem] +QED + +Theorem do_con_check_build_conv: + !tenvC cn vs l. + do_con_check tenvC cn l ⇒ ?v. build_conv tenvC cn vs = SOME v +Proof +srw_tac[][do_con_check_def, build_conv_def] >> every_case_tac >> -full_simp_tac(srw_ss())[]); +full_simp_tac(srw_ss())[] +QED (* -Theorem same_ctor_and_same_tid -`!cn1 tn1 cn2 tn2. +Theorem same_ctor_and_same_tid: + !cn1 tn1 cn2 tn2. same_tid tn1 tn2 ∧ same_ctor (cn1,tn1) (cn2,tn2) ⇒ - tn1 = tn2 ∧ cn1 = cn2` - (cases_on `tn1` >> + tn1 = tn2 ∧ cn1 = cn2 +Proof + cases_on `tn1` >> cases_on `tn2` >> - full_simp_tac(srw_ss())[same_tid_def, same_ctor_def]); - -Theorem same_tid_refl[simp] - `same_tid t t` - (Cases_on`t`>>EVAL_TAC); - -Theorem same_tid_sym -`!tn1 tn2. same_tid tn1 tn2 = same_tid tn2 tn1` - (cases_on `tn1` >> + full_simp_tac(srw_ss())[same_tid_def, same_ctor_def] +QED + +Theorem same_tid_refl[simp]: + same_tid t t +Proof + Cases_on`t`>>EVAL_TAC +QED + +Theorem same_tid_sym: + !tn1 tn2. same_tid tn1 tn2 = same_tid tn2 tn1 +Proof + cases_on `tn1` >> cases_on `tn2` >> srw_tac[][same_tid_def] >> - metis_tac []); + metis_tac [] +QED -Theorem same_tid_diff_ctor - `!cn1 cn2 t1 t2. +Theorem same_tid_diff_ctor: + !cn1 cn2 t1 t2. same_tid t1 t2 ∧ ~same_ctor (cn1, t1) (cn2, t2) ⇒ - (cn1 ≠ cn2) ∨ (cn1 = cn2 ∧ ?mn1 mn2. t1 = TypeExn mn1 ∧ t2 = TypeExn mn2 ∧ mn1 ≠ mn2)` - (srw_tac[][] >> + (cn1 ≠ cn2) ∨ (cn1 = cn2 ∧ ?mn1 mn2. t1 = TypeExn mn1 ∧ t2 = TypeExn mn2 ∧ mn1 ≠ mn2) +Proof + srw_tac[][] >> cases_on `t1` >> cases_on `t2` >> - full_simp_tac(srw_ss())[same_tid_def, same_ctor_def]); - -Theorem same_tid_tid - `(same_tid (TypeId x) y ⇔ (y = TypeId x)) ∧ - (same_tid y (TypeId x) ⇔ (y = TypeId x))` - (Cases_on`y`>>EVAL_TAC>>srw_tac[][EQ_IMP_THM]) - -Theorem build_tdefs_cons -`(!tvs tn ctors tds mn. + full_simp_tac(srw_ss())[same_tid_def, same_ctor_def] +QED + +Theorem same_tid_tid: + (same_tid (TypeId x) y ⇔ (y = TypeId x)) ∧ + (same_tid y (TypeId x) ⇔ (y = TypeId x)) +Proof + Cases_on`y`>>EVAL_TAC>>srw_tac[][EQ_IMP_THM] +QED + +Theorem build_tdefs_cons: + (!tvs tn ctors tds mn. build_tdefs mn ((tvs,tn,ctors)::tds) = nsAppend (build_tdefs mn tds) (alist_to_ns (REVERSE (MAP (\(conN,ts). (conN, LENGTH ts, TypeId (mk_id mn tn))) ctors)))) ∧ - (!mn. build_tdefs mn [] = nsEmpty)` - (srw_tac[][build_tdefs_def, REVERSE_APPEND]); + (!mn. build_tdefs mn [] = nsEmpty) +Proof + srw_tac[][build_tdefs_def, REVERSE_APPEND] +QED *) (* -Theorem MAP_FST_build_tdefs - `set (MAP FST (build_tdefs mn ls)) = - set (MAP FST (FLAT (MAP (SND o SND) ls)))` - (Induct_on`ls`>>simp[build_tdefs_cons] >> +Theorem MAP_FST_build_tdefs: + set (MAP FST (build_tdefs mn ls)) = + set (MAP FST (FLAT (MAP (SND o SND) ls))) +Proof + Induct_on`ls`>>simp[build_tdefs_cons] >> qx_gen_tac`p`>>PairCases_on`p`>>simp[build_tdefs_cons,MAP_REVERSE] >> simp[MAP_MAP_o,combinTheory.o_DEF,UNCURRY,ETA_AX] >> - metis_tac[UNION_COMM]) + metis_tac[UNION_COMM] +QED *) (* -Theorem check_dup_ctors_cons -`!tvs ts ctors tds. +Theorem check_dup_ctors_cons: + !tvs ts ctors tds. check_dup_ctors ((tvs,ts,ctors)::tds) ⇒ - check_dup_ctors tds` -(induct_on `tds` >> + check_dup_ctors tds +Proof +induct_on `tds` >> srw_tac[][check_dup_ctors_def, LET_THM, RES_FORALL] >> PairCases_on `h` >> full_simp_tac(srw_ss())[] >> @@ -482,7 +535,8 @@ pop_assum (fn _ => all_tac) >> induct_on `ctors` >> srw_tac[][] >> PairCases_on `h` >> -full_simp_tac(srw_ss())[]); +full_simp_tac(srw_ss())[] +QED *) val map_error_result_def = Define` @@ -490,27 +544,35 @@ val map_error_result_def = Define` (map_error_result f (Rabort a) = Rabort a)` val _ = export_rewrites["map_error_result_def"] -Theorem map_error_result_Rtype_error - `map_error_result f e = (Rabort a) ⇔ e = Rabort a` - (Cases_on`e`>>simp[]) +Theorem map_error_result_Rtype_error: + map_error_result f e = (Rabort a) ⇔ e = Rabort a +Proof + Cases_on`e`>>simp[] +QED val _ = export_rewrites["map_error_result_Rtype_error"] -Theorem map_error_result_I[simp] - `map_error_result I e = e` - (Cases_on`e`>>EVAL_TAC); +Theorem map_error_result_I[simp]: + map_error_result I e = e +Proof + Cases_on`e`>>EVAL_TAC +QED val map_result_def = Define` (map_result f1 f2 (Rval v) = Rval (f1 v)) ∧ (map_result f1 f2 (Rerr e) = Rerr (map_error_result f2 e))` val _ = export_rewrites["map_result_def"] -Theorem map_result_Rval[simp] - `map_result f1 f2 e = Rval x ⇔ ∃y. e = Rval y ∧ x = f1 y` - (Cases_on`e`>>simp[EQ_IMP_THM]) - -Theorem map_result_Rerr - `map_result f1 f2 e = Rerr e' ⇔ ∃a. e = Rerr a ∧ map_error_result f2 a = e'` - (Cases_on`e`>>simp[EQ_IMP_THM]) +Theorem map_result_Rval[simp]: + map_result f1 f2 e = Rval x ⇔ ∃y. e = Rval y ∧ x = f1 y +Proof + Cases_on`e`>>simp[EQ_IMP_THM] +QED + +Theorem map_result_Rerr: + map_result f1 f2 e = Rerr e' ⇔ ∃a. e = Rerr a ∧ map_error_result f2 a = e' +Proof + Cases_on`e`>>simp[EQ_IMP_THM] +QED val _ = export_rewrites["map_result_Rerr"] val exc_rel_def = Define` @@ -519,29 +581,41 @@ val exc_rel_def = Define` (exc_rel _ _ _ = F)` val _ = export_rewrites["exc_rel_def"] -Theorem exc_rel_raise1 - `exc_rel R (Rraise v) e = ∃v'. (e = Rraise v') ∧ R v v'` - (Cases_on`e`>>srw_tac[][]) -Theorem exc_rel_raise2 - `exc_rel R e (Rraise v) = ∃v'. (e = Rraise v') ∧ R v' v` - (Cases_on`e`>>srw_tac[][]) -Theorem exc_rel_type_error1 - `(exc_rel R (Rabort a) e = (e = Rabort a))` - (Cases_on`e`>>srw_tac[][]>>metis_tac []) -Theorem exc_rel_type_error2 - `(exc_rel R e (Rabort a) = (e = Rabort a))` - (Cases_on`e`>>srw_tac[][]>>metis_tac []) +Theorem exc_rel_raise1: + exc_rel R (Rraise v) e = ∃v'. (e = Rraise v') ∧ R v v' +Proof + Cases_on`e`>>srw_tac[][] +QED +Theorem exc_rel_raise2: + exc_rel R e (Rraise v) = ∃v'. (e = Rraise v') ∧ R v' v +Proof + Cases_on`e`>>srw_tac[][] +QED +Theorem exc_rel_type_error1: + (exc_rel R (Rabort a) e = (e = Rabort a)) +Proof + Cases_on`e`>>srw_tac[][]>>metis_tac [] +QED +Theorem exc_rel_type_error2: + (exc_rel R e (Rabort a) = (e = Rabort a)) +Proof + Cases_on`e`>>srw_tac[][]>>metis_tac [] +QED val _ = export_rewrites["exc_rel_raise1","exc_rel_raise2","exc_rel_type_error1","exc_rel_type_error2"] -Theorem exc_rel_refl - `(∀x. R x x) ⇒ ∀x. exc_rel R x x` -(strip_tac >> Cases >> srw_tac[][]) +Theorem exc_rel_refl: + (∀x. R x x) ⇒ ∀x. exc_rel R x x +Proof +strip_tac >> Cases >> srw_tac[][] +QED val _ = export_rewrites["exc_rel_refl"]; -Theorem exc_rel_trans -`(∀x y z. R x y ∧ R y z ⇒ R x z) ⇒ (∀x y z. exc_rel R x y ∧ exc_rel R y z ⇒ exc_rel R x z)` -(srw_tac[][] >> -Cases_on `x` >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> full_simp_tac(srw_ss())[] >> PROVE_TAC[]) +Theorem exc_rel_trans: + (∀x y z. R x y ∧ R y z ⇒ R x z) ⇒ (∀x y z. exc_rel R x y ∧ exc_rel R y z ⇒ exc_rel R x z) +Proof +srw_tac[][] >> +Cases_on `x` >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> full_simp_tac(srw_ss())[] >> PROVE_TAC[] +QED val result_rel_def = Define` (result_rel R1 _ (Rval v1) (Rval v2) = R1 v1 v2) ∧ @@ -549,26 +623,36 @@ val result_rel_def = Define` (result_rel _ _ _ _ = F)` val _ = export_rewrites["result_rel_def"] -Theorem result_rel_Rval -`result_rel R1 R2 (Rval v) r = ∃v'. (r = Rval v') ∧ R1 v v'` -(Cases_on `r` >> srw_tac[][]) -Theorem result_rel_Rerr1 -`result_rel R1 R2 (Rerr e) r = ∃e'. (r = Rerr e') ∧ exc_rel R2 e e'` -(Cases_on `r` >> srw_tac[][EQ_IMP_THM]) -Theorem result_rel_Rerr2 -`result_rel R1 R2 r (Rerr e) = ∃e'. (r = Rerr e') ∧ exc_rel R2 e' e` -(Cases_on `r` >> srw_tac[][EQ_IMP_THM]) +Theorem result_rel_Rval: + result_rel R1 R2 (Rval v) r = ∃v'. (r = Rval v') ∧ R1 v v' +Proof +Cases_on `r` >> srw_tac[][] +QED +Theorem result_rel_Rerr1: + result_rel R1 R2 (Rerr e) r = ∃e'. (r = Rerr e') ∧ exc_rel R2 e e' +Proof +Cases_on `r` >> srw_tac[][EQ_IMP_THM] +QED +Theorem result_rel_Rerr2: + result_rel R1 R2 r (Rerr e) = ∃e'. (r = Rerr e') ∧ exc_rel R2 e' e +Proof +Cases_on `r` >> srw_tac[][EQ_IMP_THM] +QED val _ = export_rewrites["result_rel_Rval","result_rel_Rerr1","result_rel_Rerr2"] -Theorem result_rel_refl -`(∀x. R1 x x) ∧ (∀x. R2 x x) ⇒ ∀x. result_rel R1 R2 x x` -(strip_tac >> Cases >> srw_tac[][]) +Theorem result_rel_refl: + (∀x. R1 x x) ∧ (∀x. R2 x x) ⇒ ∀x. result_rel R1 R2 x x +Proof +strip_tac >> Cases >> srw_tac[][] +QED val _ = export_rewrites["result_rel_refl"] -Theorem result_rel_trans -`(∀x y z. R1 x y ∧ R1 y z ⇒ R1 x z) ∧ (∀x y z. R2 x y ∧ R2 y z ⇒ R2 x z) ⇒ (∀x y z. result_rel R1 R2 x y ∧ result_rel R1 R2 y z ⇒ result_rel R1 R2 x z)` -(srw_tac[][] >> -Cases_on `x` >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> full_simp_tac(srw_ss())[] >> PROVE_TAC[exc_rel_trans]) +Theorem result_rel_trans: + (∀x y z. R1 x y ∧ R1 y z ⇒ R1 x z) ∧ (∀x y z. R2 x y ∧ R2 y z ⇒ R2 x z) ⇒ (∀x y z. result_rel R1 R2 x y ∧ result_rel R1 R2 y z ⇒ result_rel R1 R2 x z) +Proof +srw_tac[][] >> +Cases_on `x` >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> full_simp_tac(srw_ss())[] >> PROVE_TAC[exc_rel_trans] +QED val every_error_result_def = Define` (every_error_result P (Rraise e) = P e) ∧ @@ -606,33 +690,43 @@ val sv_rel_def = Define` sv_rel R _ _ = F` val _ = export_rewrites["sv_rel_def"] -Theorem sv_rel_refl - `∀R x. (∀x. R x x) ⇒ sv_rel R x x` - (gen_tac >> Cases >> srw_tac[][sv_rel_def] >> +Theorem sv_rel_refl: + ∀R x. (∀x. R x x) ⇒ sv_rel R x x +Proof + gen_tac >> Cases >> srw_tac[][sv_rel_def] >> induct_on `l` >> - srw_tac[][]) + srw_tac[][] +QED val _ = export_rewrites["sv_rel_refl"] -Theorem sv_rel_trans - `∀R. (∀x y z. R x y ∧ R y z ⇒ R x z) ⇒ ∀x y z. sv_rel R x y ∧ sv_rel R y z ⇒ sv_rel R x z` - (gen_tac >> strip_tac >> Cases >> Cases >> Cases >> srw_tac[][] >> full_simp_tac(srw_ss())[sv_rel_def] >> metis_tac[LIST_REL_trans]); +Theorem sv_rel_trans: + ∀R. (∀x y z. R x y ∧ R y z ⇒ R x z) ⇒ ∀x y z. sv_rel R x y ∧ sv_rel R y z ⇒ sv_rel R x z +Proof + gen_tac >> strip_tac >> Cases >> Cases >> Cases >> srw_tac[][] >> full_simp_tac(srw_ss())[sv_rel_def] >> metis_tac[LIST_REL_trans] +QED -Theorem sv_rel_cases - `∀x y. +Theorem sv_rel_cases: + ∀x y. sv_rel R x y ⇔ (∃v1 v2. x = Refv v1 ∧ y = Refv v2 ∧ R v1 v2) ∨ (∃w. x = W8array w ∧ y = W8array w) ∨ - (?vs1 vs2. x = Varray vs1 ∧ y = Varray vs2 ∧ LIST_REL R vs1 vs2)` - (Cases >> Cases >> simp[sv_rel_def,EQ_IMP_THM]) - -Theorem sv_rel_O - `∀R1 R2. sv_rel (R1 O R2) = sv_rel R1 O sv_rel R2` - (srw_tac[][FUN_EQ_THM,sv_rel_cases,O_DEF,EQ_IMP_THM, LIST_REL_O] >> - metis_tac[]); - -Theorem sv_rel_mono - `(∀x y. P x y ⇒ Q x y) ⇒ sv_rel P x y ⇒ sv_rel Q x y` - (srw_tac[][sv_rel_cases] >> metis_tac [LIST_REL_mono]) + (?vs1 vs2. x = Varray vs1 ∧ y = Varray vs2 ∧ LIST_REL R vs1 vs2) +Proof + Cases >> Cases >> simp[sv_rel_def,EQ_IMP_THM] +QED + +Theorem sv_rel_O: + ∀R1 R2. sv_rel (R1 O R2) = sv_rel R1 O sv_rel R2 +Proof + srw_tac[][FUN_EQ_THM,sv_rel_cases,O_DEF,EQ_IMP_THM, LIST_REL_O] >> + metis_tac[] +QED + +Theorem sv_rel_mono: + (∀x y. P x y ⇒ Q x y) ⇒ sv_rel P x y ⇒ sv_rel Q x y +Proof + srw_tac[][sv_rel_cases] >> metis_tac [LIST_REL_mono] +QED val store_v_vs_def = Define` store_v_vs (Refv v) = [v] ∧ @@ -643,57 +737,70 @@ val _ = export_rewrites["store_v_vs_def"] val store_vs_def = Define` store_vs s = FLAT (MAP store_v_vs s)` -Theorem EVERY_sv_every_MAP_map_sv - `∀P f ls. EVERY P (MAP f (store_vs ls)) ⇒ EVERY (sv_every P) (MAP (map_sv f) ls)` - (rpt gen_tac >> +Theorem EVERY_sv_every_MAP_map_sv: + ∀P f ls. EVERY P (MAP f (store_vs ls)) ⇒ EVERY (sv_every P) (MAP (map_sv f) ls) +Proof + rpt gen_tac >> simp[EVERY_MAP,EVERY_MEM,store_vs_def,MEM_MAP,PULL_EXISTS,MEM_FILTER,MEM_FLAT] >> - strip_tac >> Cases >> simp[] >> srw_tac[][] >> res_tac >> full_simp_tac(srw_ss())[EVERY_MEM,MEM_MAP,PULL_EXISTS]) + strip_tac >> Cases >> simp[] >> srw_tac[][] >> res_tac >> full_simp_tac(srw_ss())[EVERY_MEM,MEM_MAP,PULL_EXISTS] +QED -Theorem LIST_REL_store_vs_intro - `∀P l1 l2. LIST_REL (sv_rel P) l1 l2 ⇒ LIST_REL P (store_vs l1) (store_vs l2)` - (gen_tac >> +Theorem LIST_REL_store_vs_intro: + ∀P l1 l2. LIST_REL (sv_rel P) l1 l2 ⇒ LIST_REL P (store_vs l1) (store_vs l2) +Proof + gen_tac >> Induct >- simp[store_vs_def] >> Cases >> simp[PULL_EXISTS,sv_rel_cases] >> full_simp_tac(srw_ss())[store_vs_def] >> srw_tac[][] >> - match_mp_tac rich_listTheory.EVERY2_APPEND_suff >> simp[]) + match_mp_tac rich_listTheory.EVERY2_APPEND_suff >> simp[] +QED -Theorem EVERY_sv_every_EVERY_store_vs - `∀P ls. EVERY (sv_every P ) ls ⇔ EVERY P (store_vs ls)` - (srw_tac[][EVERY_MEM,EQ_IMP_THM,store_vs_def,MEM_MAP,PULL_EXISTS,MEM_FILTER,MEM_FLAT] >> +Theorem EVERY_sv_every_EVERY_store_vs: + ∀P ls. EVERY (sv_every P ) ls ⇔ EVERY P (store_vs ls) +Proof + srw_tac[][EVERY_MEM,EQ_IMP_THM,store_vs_def,MEM_MAP,PULL_EXISTS,MEM_FILTER,MEM_FLAT] >> res_tac >> TRY(Cases_on`e`) >> TRY(Cases_on`y`) >> full_simp_tac(srw_ss())[] >> - full_simp_tac(srw_ss())[EVERY_MEM]) + full_simp_tac(srw_ss())[EVERY_MEM] +QED -Theorem EVERY_store_vs_intro - `∀P ls. EVERY (sv_every P) ls ⇒ EVERY P (store_vs ls)` - (srw_tac[][EVERY_MEM,store_vs_def,MEM_MAP,MEM_FILTER,MEM_FLAT] >> +Theorem EVERY_store_vs_intro: + ∀P ls. EVERY (sv_every P) ls ⇒ EVERY P (store_vs ls) +Proof + srw_tac[][EVERY_MEM,store_vs_def,MEM_MAP,MEM_FILTER,MEM_FLAT] >> res_tac >> qmatch_assum_rename_tac`sv_every P x` >> - Cases_on`x`>>full_simp_tac(srw_ss())[EVERY_MEM]); + Cases_on`x`>>full_simp_tac(srw_ss())[EVERY_MEM] +QED -Theorem map_sv_compose - `map_sv f (map_sv g x) = map_sv (f o g) x` - (Cases_on`x`>>simp[MAP_MAP_o]) +Theorem map_sv_compose: + map_sv f (map_sv g x) = map_sv (f o g) x +Proof + Cases_on`x`>>simp[MAP_MAP_o] +QED val map_match_def = Define` (map_match f (Match env) = Match (f env)) ∧ (map_match f x = x)` val _ = export_rewrites["map_match_def"] -Theorem find_recfun_ALOOKUP -`∀funs n. find_recfun n funs = ALOOKUP funs n` -(Induct >- srw_tac[][semanticPrimitivesTheory.find_recfun_def] >> +Theorem find_recfun_ALOOKUP: + ∀funs n. find_recfun n funs = ALOOKUP funs n +Proof +Induct >- srw_tac[][semanticPrimitivesTheory.find_recfun_def] >> qx_gen_tac `d` >> PairCases_on `d` >> -srw_tac[][semanticPrimitivesTheory.find_recfun_def]); +srw_tac[][semanticPrimitivesTheory.find_recfun_def] +QED -Theorem find_recfun_el - `!f funs x e n. +Theorem find_recfun_el: + !f funs x e n. ALL_DISTINCT (MAP (\(f,x,e). f) funs) ∧ n < LENGTH funs ∧ EL n funs = (f,x,e) ⇒ - find_recfun f funs = SOME (x,e)` - (simp[find_recfun_ALOOKUP] >> + find_recfun f funs = SOME (x,e) +Proof + simp[find_recfun_ALOOKUP] >> induct_on `funs` >> srw_tac[][] >> cases_on `n` >> @@ -703,7 +810,8 @@ Theorem find_recfun_el srw_tac[][] >> res_tac >> full_simp_tac(srw_ss())[MEM_MAP, MEM_EL, FORALL_PROD] >> - metis_tac []); + metis_tac [] +QED val ctors_of_tdef_def = Define` ctors_of_tdef (_,_,condefs) = MAP FST condefs` @@ -749,14 +857,18 @@ val _ = export_rewrites["FV_def"] val _ = Parse.overload_on("SFV",``λe. {x | Short x ∈ FV e}``) -Theorem FV_pes_MAP - `FV_pes pes = BIGUNION (IMAGE (λ(p,e). FV e DIFF (IMAGE Short (set (pat_bindings p [])))) (set pes))` - (Induct_on`pes`>>simp[]>> - qx_gen_tac`p`>>PairCases_on`p`>>srw_tac[][]) - -Theorem FV_defs_MAP - `∀ls. FV_defs ls = BIGUNION (IMAGE (λ(f,x,e). FV e DIFF {Short x}) (set ls))` - (Induct_on`ls`>>simp[FORALL_PROD]) +Theorem FV_pes_MAP: + FV_pes pes = BIGUNION (IMAGE (λ(p,e). FV e DIFF (IMAGE Short (set (pat_bindings p [])))) (set pes)) +Proof + Induct_on`pes`>>simp[]>> + qx_gen_tac`p`>>PairCases_on`p`>>srw_tac[][] +QED + +Theorem FV_defs_MAP: + ∀ls. FV_defs ls = BIGUNION (IMAGE (λ(f,x,e). FV e DIFF {Short x}) (set ls)) +Proof + Induct_on`ls`>>simp[FORALL_PROD] +QED val FV_dec_def = Define` (FV_dec (Dlet locs p e) = FV (Mat e [(p,Lit ARB)])) ∧ diff --git a/semantics/proofs/semanticsPropsScript.sml b/semantics/proofs/semanticsPropsScript.sml index 2209a849fc..85e4597f68 100644 --- a/semantics/proofs/semanticsPropsScript.sml +++ b/semantics/proofs/semanticsPropsScript.sml @@ -9,33 +9,38 @@ open preamble val _ = new_theory"semanticsProps" -Theorem evaluate_prog_events_determ - `!st env k p k'. +Theorem evaluate_prog_events_determ: + !st env k p k'. LENGTH((FST(evaluate_prog_with_clock st env k p)).io_events) = LENGTH((FST(evaluate_prog_with_clock st env k' p)).io_events) ==> (FST(evaluate_prog_with_clock st env k p)).io_events - = (FST(evaluate_prog_with_clock st env k' p)).io_events` - (rpt strip_tac + = (FST(evaluate_prog_with_clock st env k' p)).io_events +Proof + rpt strip_tac >> (Cases_on `k <= k'` >| [ALL_TAC,`k' <= k` by simp[]]) >> fs[evaluate_prog_with_clock_def,ELIM_UNCURRY] >> drule evaluate_decs_ffi_mono_clock >> disch_then(qspecl_then [`st`,`env`,`p`] assume_tac) >> fs[io_events_mono_def,evaluate_prog_with_clock_def, ELIM_UNCURRY] - >> metis_tac[IS_PREFIX_LENGTH_ANTI]); + >> metis_tac[IS_PREFIX_LENGTH_ANTI] +QED -Theorem evaluate_prog_io_events_chain - `lprefix_chain (IMAGE (λk. fromList (FST (evaluate_prog_with_clock st env k prog)).io_events) UNIV)` - (qho_match_abbrev_tac`lprefix_chain (IMAGE (λk. fromList (g k)) UNIV)` >> +Theorem evaluate_prog_io_events_chain: + lprefix_chain (IMAGE (λk. fromList (FST (evaluate_prog_with_clock st env k prog)).io_events) UNIV) +Proof + qho_match_abbrev_tac`lprefix_chain (IMAGE (λk. fromList (g k)) UNIV)` >> ONCE_REWRITE_TAC[GSYM o_DEF] >> REWRITE_TAC[IMAGE_COMPOSE] >> match_mp_tac prefix_chain_lprefix_chain >> srw_tac[][prefix_chain_def,Abbr`g`,evaluate_prog_with_clock_def] >> srw_tac[][] >> - metis_tac[LESS_EQ_CASES,evaluate_decs_ffi_mono_clock,io_events_mono_def,FST]); + metis_tac[LESS_EQ_CASES,evaluate_decs_ffi_mono_clock,io_events_mono_def,FST] +QED -Theorem semantics_prog_total - `∀s e p. ∃b. semantics_prog s e p b` - (srw_tac[][] >> +Theorem semantics_prog_total: + ∀s e p. ∃b. semantics_prog s e p b +Proof + srw_tac[][] >> Cases_on`∃k. SND(evaluate_prog_with_clock s e k p) = Rerr (Rabort Rtype_error)` >- metis_tac[semantics_prog_def] >> full_simp_tac(srw_ss())[] >> Cases_on`∃k ffi r. @@ -61,7 +66,8 @@ Theorem semantics_prog_total Cases_on`e'`>>simp[]>> Cases_on`a`>>simp[]) >> match_mp_tac build_lprefix_lub_thm >> - MATCH_ACCEPT_TAC evaluate_prog_io_events_chain); + MATCH_ACCEPT_TAC evaluate_prog_io_events_chain +QED val with_clock_ffi = Q.prove( `(s with clock := x).ffi = s.ffi`,EVAL_TAC) @@ -74,12 +80,13 @@ val tac1 = val tac2 = every_case_tac >> rfs[] >> first_x_assum (qspec_then `k` assume_tac) >> rfs[] -Theorem semantics_prog_deterministic - `∀s e p b b'. +Theorem semantics_prog_deterministic: + ∀s e p b b'. semantics_prog s e p b ∧ semantics_prog s e p b' ⇒ - b = b'` - (rw [] + b = b' +Proof + rw [] >> Cases_on `b` >> Cases_on `b'` >> fs [semantics_prog_def] @@ -129,16 +136,19 @@ Theorem semantics_prog_deterministic >> first_x_assum drule >> simp [] >> every_case_tac - >> fs [semanticPrimitivesTheory.state_component_equality])); + >> fs [semanticPrimitivesTheory.state_component_equality]) +QED -Theorem semantics_prog_Terminate_not_Fail - `semantics_prog s e p (Terminate x y) ⇒ +Theorem semantics_prog_Terminate_not_Fail: + semantics_prog s e p (Terminate x y) ⇒ ¬semantics_prog s e p Fail ∧ - semantics_prog s e p = {Terminate x y}` - (rpt strip_tac + semantics_prog s e p = {Terminate x y} +Proof + rpt strip_tac \\ simp[FUN_EQ_THM] \\ imp_res_tac semantics_prog_deterministic \\ fs[] - \\ metis_tac[semantics_prog_deterministic]); + \\ metis_tac[semantics_prog_deterministic] +QED val state_invariant_def = Define` state_invariant st ⇔ @@ -152,11 +162,12 @@ val clock_lemmas = Q.prove( (x with clock := x.clock = x)`, srw_tac[][semanticPrimitivesTheory.state_component_equality]) -Theorem semantics_deterministic - `state_invariant st ⇒ +Theorem semantics_deterministic: + state_invariant st ⇒ semantics st prelude inp = Execute bs - ⇒ ∃b. bs = {b} ∧ b ≠ Fail` - (rw [state_invariant_def, semantics_def] + ⇒ ∃b. bs = {b} ∧ b ≠ Fail +Proof + rw [state_invariant_def, semantics_def] >> every_case_tac >> fs [can_type_prog_def] >> rw [] @@ -172,7 +183,8 @@ Theorem semantics_deterministic metis_tac []) >> fs [typeSoundInvariantsTheory.type_sound_invariant_def] >> rfs [typeSoundInvariantsTheory.consistent_ctMap_def] >> - metis_tac []); + metis_tac [] +QED val extend_with_resource_limit_def = Define` extend_with_resource_limit behaviours = @@ -182,37 +194,46 @@ val extend_with_resource_limit_def = Define` { Terminate Resource_limit_hit io_list | io_list | ∃ll. Diverge ll ∈ behaviours ∧ LPREFIX (fromList io_list) ll }`; -Theorem extend_with_resource_limit_not_fail - `x ∈ extend_with_resource_limit y ∧ Fail ∉ y ⇒ x ≠ Fail` - (rw[extend_with_resource_limit_def] \\ metis_tac[]) +Theorem extend_with_resource_limit_not_fail: + x ∈ extend_with_resource_limit y ∧ Fail ∉ y ⇒ x ≠ Fail +Proof + rw[extend_with_resource_limit_def] \\ metis_tac[] +QED val implements_def = Define ` implements x y <=> (~(Fail IN y) ==> x SUBSET extend_with_resource_limit y)`; -Theorem implements_intro - `(b /\ x <> Fail ==> y = x) ==> b ==> implements {y} {x}` - (full_simp_tac(srw_ss())[implements_def] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] - \\ full_simp_tac(srw_ss())[extend_with_resource_limit_def]); +Theorem implements_intro: + (b /\ x <> Fail ==> y = x) ==> b ==> implements {y} {x} +Proof + full_simp_tac(srw_ss())[implements_def] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] + \\ full_simp_tac(srw_ss())[extend_with_resource_limit_def] +QED -Theorem implements_trivial_intro - `(y = x) ==> implements {y} {x}` - (full_simp_tac(srw_ss())[implements_def] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] - \\ full_simp_tac(srw_ss())[extend_with_resource_limit_def]); +Theorem implements_trivial_intro: + (y = x) ==> implements {y} {x} +Proof + full_simp_tac(srw_ss())[implements_def] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] + \\ full_simp_tac(srw_ss())[extend_with_resource_limit_def] +QED -Theorem implements_intro_ext - `(b /\ x <> Fail ==> y IN extend_with_resource_limit {x}) ==> - b ==> implements {y} {x}` - (full_simp_tac(srw_ss())[implements_def] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] - \\ full_simp_tac(srw_ss())[extend_with_resource_limit_def]); +Theorem implements_intro_ext: + (b /\ x <> Fail ==> y IN extend_with_resource_limit {x}) ==> + b ==> implements {y} {x} +Proof + full_simp_tac(srw_ss())[implements_def] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] + \\ full_simp_tac(srw_ss())[extend_with_resource_limit_def] +QED val isPREFIX_IMP_LPREFIX = Q.prove( `!xs ys. isPREFIX xs ys ==> LPREFIX (fromList xs) (fromList ys)`, full_simp_tac(srw_ss())[LPREFIX_def,llistTheory.from_toList]); -Theorem implements_trans - `implements y z ==> implements x y ==> implements x z` - (full_simp_tac(srw_ss())[implements_def] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] +Theorem implements_trans: + implements y z ==> implements x y ==> implements x z +Proof + full_simp_tac(srw_ss())[implements_def] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[extend_with_resource_limit_def] \\ Cases_on `Fail IN y` \\ full_simp_tac(srw_ss())[] THEN1 (full_simp_tac(srw_ss())[SUBSET_DEF] \\ res_tac \\ full_simp_tac(srw_ss())[]) @@ -223,6 +244,7 @@ Theorem implements_trans \\ imp_res_tac IS_PREFIX_TRANS \\ imp_res_tac isPREFIX_IMP_LPREFIX \\ imp_res_tac LPREFIX_TRANS - \\ metis_tac []) + \\ metis_tac [] +QED val _ = export_theory() diff --git a/semantics/proofs/typeSoundScript.sml b/semantics/proofs/typeSoundScript.sml index 553c29615f..df6f5b61e0 100644 --- a/semantics/proofs/typeSoundScript.sml +++ b/semantics/proofs/typeSoundScript.sml @@ -29,13 +29,15 @@ val type_num_defs = LIST_CONJ [ Tword8_num_def, Tword8array_num_def]; -Theorem list_rel_flat - `!R l1 l2. LIST_REL (LIST_REL R) l1 l2 ⇒ LIST_REL R (FLAT l1) (FLAT l2)` - (Induct_on `l1` +Theorem list_rel_flat: + !R l1 l2. LIST_REL (LIST_REL R) l1 l2 ⇒ LIST_REL R (FLAT l1) (FLAT l2) +Proof + Induct_on `l1` >> rw [FLAT] >> rw [FLAT] >> irule EVERY2_APPEND_suff - >> rw []); + >> rw [] +QED val fst_triple = Q.prove ( `(\(x,y,z). x) = FST`, @@ -43,10 +45,12 @@ val fst_triple = Q.prove ( >> pairarg_tac >> rw []); -Theorem disjoint_image - `!s1 s2 f. DISJOINT (IMAGE f s1) (IMAGE f s2) ⇒ DISJOINT s1 s2` - (rw [DISJOINT_DEF, EXTENSION] - >> metis_tac []); +Theorem disjoint_image: + !s1 s2 f. DISJOINT (IMAGE f s1) (IMAGE f s2) ⇒ DISJOINT s1 s2 +Proof + rw [DISJOINT_DEF, EXTENSION] + >> metis_tac [] +QED val sing_list = Q.prove ( `!l. LENGTH l = 1 ⇔ ?x. l = [x]`, @@ -60,13 +64,15 @@ val EVERY_LIST_REL = Q.prove ( induct_on `l` >> srw_tac[][REPLICATE]); -Theorem v_unchanged[simp] -`!tenv x. tenv with v := tenv.v = tenv` - (srw_tac[][type_env_component_equality]); +Theorem v_unchanged[simp]: + !tenv x. tenv with v := tenv.v = tenv +Proof + srw_tac[][type_env_component_equality] +QED (* Classifying values of basic types *) -Theorem prim_canonical_values_thm - `(type_v tvs ctMap tenvS v Tint ∧ ctMap_ok ctMap ⇒ (∃n. v = Litv (IntLit n))) ∧ +Theorem prim_canonical_values_thm: + (type_v tvs ctMap tenvS v Tint ∧ ctMap_ok ctMap ⇒ (∃n. v = Litv (IntLit n))) ∧ (type_v tvs ctMap tenvS v Tchar ∧ ctMap_ok ctMap ⇒ (∃c. v = Litv (Char c))) ∧ (type_v tvs ctMap tenvS v Tstring ∧ ctMap_ok ctMap ⇒ (∃s. v = Litv (StrLit s))) ∧ (type_v tvs ctMap tenvS v Tword8 ∧ ctMap_ok ctMap ⇒ (∃n. v = Litv (Word8 n))) ∧ @@ -87,8 +93,9 @@ Theorem prim_canonical_values_thm EVERY (\v. type_v 0 ctMap tenvS v t) vs ∧ FLOOKUP tenvS n = SOME (Varray_t t))) ∧ (type_v tvs ctMap tenvS v (Tvector t) ∧ ctMap_ok ctMap ⇒ - (?vs. v = Vectorv vs ∧ EVERY (\v. type_v tvs ctMap tenvS v t) vs))` - (strip_tac >> + (?vs. v = Vectorv vs ∧ EVERY (\v. type_v tvs ctMap tenvS v t) vs)) +Proof + strip_tac >> rpt (conj_tac) >> simp [Once type_v_cases] >> fs [prim_type_nums_def, ctMap_ok_def, type_num_defs] >> @@ -100,7 +107,8 @@ Theorem prim_canonical_values_thm >- metis_tac [LIST_REL_LENGTH] >> res_tac >> Cases_on `v` >> - fs [type_sv_def]); + fs [type_sv_def] +QED val has_lists_v_to_list = Q.prove ( `!ctMap tvs tenvS t3. @@ -146,8 +154,8 @@ val has_lists_v_to_list = Q.prove ( imp_res_tac (SIMP_RULE (srw_ss()) [] prim_canonical_values_thm) >> rw [v_to_char_list_def, vs_to_string_def]); -Theorem ctor_canonical_values_thm - `(type_v tvs ctMap tenvS v Tbool ∧ ctMap_ok ctMap ∧ ctMap_has_bools ctMap ⇒ +Theorem ctor_canonical_values_thm: + (type_v tvs ctMap tenvS v Tbool ∧ ctMap_ok ctMap ∧ ctMap_has_bools ctMap ⇒ ∃b. v = Boolv b) ∧ (type_v tvs ctMap tenvS v (Tlist t) ∧ ctMap_ok ctMap ∧ ctMap_has_lists ctMap ⇒ ?vs. @@ -159,8 +167,9 @@ Theorem ctor_canonical_values_thm ctMap_ok ctMap ∧ FLOOKUP ctMap stamp = SOME (tvs',ts',ti) ⇒ (?cn n vs. same_type stamp (TypeStamp cn n) ∧ v = Conv (SOME (TypeStamp cn n)) vs) ∨ - (?n vs. same_type stamp (ExnStamp n) ∧ v = Conv (SOME (ExnStamp n)) vs))` - (rw [] + (?n vs. same_type stamp (ExnStamp n) ∧ v = Conv (SOME (ExnStamp n)) vs)) +Proof + rw [] >- ( fs [Once type_v_cases] >> full_simp_tac std_ss [ctMap_has_bools_def, Boolv_def, type_num_defs, ctMap_ok_def] >> @@ -190,7 +199,8 @@ Theorem ctor_canonical_values_thm Cases_on `stamp'` >> fs [same_type_def] >> res_tac >> - fs [])); + fs []) +QED val same_type_refl = Q.prove ( `!t. same_type t t`, @@ -426,8 +436,8 @@ val remove_lambda_prod = Q.prove ( >> pairarg_tac >> rw []); -Theorem opapp_type_sound -`!ctMap tenvS vs ts t. +Theorem opapp_type_sound: + !ctMap tenvS vs ts t. ctMap_ok ctMap ∧ type_op Opapp ts t ∧ LIST_REL (type_v 0 ctMap tenvS) vs ts @@ -438,8 +448,9 @@ Theorem opapp_type_sound num_tvs tenvE = 0 ∧ type_all_env ctMap tenvS env (tenv with v := add_tenvE tenvE tenv.v) ∧ type_e tenv tenvE e t ∧ - do_opapp vs = SOME (env,e)` - (rw [type_op_cases] >> + do_opapp vs = SOME (env,e) +Proof + rw [type_op_cases] >> fs [] >> rw [] >> MAP_EVERY (TRY o drule o SIMP_RULE (srw_ss()) [] o GEN_ALL) @@ -488,31 +499,37 @@ Theorem opapp_type_sound >> metis_tac []) >- ( simp [remove_lambda_prod] - >> metis_tac []))); + >> metis_tac [])) +QED val store_type_extension_def = Define ` store_type_extension tenvS1 tenvS2 = ?tenvS'. (tenvS2 = FUNION tenvS' tenvS1) ∧ (!l. (FLOOKUP tenvS' l = NONE) ∨ (FLOOKUP tenvS1 l = NONE))`; -Theorem store_type_extension_weakS -`!tenvS1 tenvS2. - store_type_extension tenvS1 tenvS2 ⇒ weakS tenvS2 tenvS1` - (srw_tac[][store_type_extension_def, weakS_def, FLOOKUP_FUNION] >> +Theorem store_type_extension_weakS: + !tenvS1 tenvS2. + store_type_extension tenvS1 tenvS2 ⇒ weakS tenvS2 tenvS1 +Proof + srw_tac[][store_type_extension_def, weakS_def, FLOOKUP_FUNION] >> full_simp_tac(srw_ss())[SUBMAP_DEF, FLOOKUP_DEF, FUNION_DEF] >> - metis_tac []); + metis_tac [] +QED -Theorem store_type_extension_refl - `!tenvS. store_type_extension tenvS tenvS` - (rw [store_type_extension_def] >> +Theorem store_type_extension_refl: + !tenvS. store_type_extension tenvS tenvS +Proof + rw [store_type_extension_def] >> qexists_tac `FEMPTY` >> - rw []); + rw [] +QED -Theorem store_type_extension_trans - `!s1 s2 s3. +Theorem store_type_extension_trans: + !s1 s2 s3. store_type_extension s1 s2 ∧ store_type_extension s2 s3 ⇒ - store_type_extension s1 s3` - (rw [store_type_extension_def] + store_type_extension s1 s3 +Proof + rw [store_type_extension_def] >> qexists_tac `FUNION tenvS'' tenvS'` >> rw [FUNION_ASSOC, FLOOKUP_FUNION] >> CASE_TAC @@ -521,18 +538,20 @@ Theorem store_type_extension_trans >> first_x_assum (qspec_then `l` mp_tac) >> rw [] >> every_case_tac - >> fs []); + >> fs [] +QED -Theorem store_assign_type_sound - `!ctMap tenvS store sv st l. +Theorem store_assign_type_sound: + !ctMap tenvS store sv st l. type_s ctMap store tenvS ∧ FLOOKUP tenvS l = SOME st ∧ type_sv ctMap tenvS sv st ⇒ ?store'. store_assign l sv store = SOME store' ∧ - type_s ctMap store' tenvS` - (rw [store_assign_def, type_s_def, store_v_same_type_def] + type_s ctMap store' tenvS +Proof + rw [store_assign_def, type_s_def, store_v_same_type_def] >- ( first_x_assum (qspec_then `l` mp_tac) >> rw [store_lookup_def] @@ -550,10 +569,11 @@ Theorem store_assign_type_sound >- ( fs [store_lookup_def, EL_LUPDATE] >> rw [] - >> fs [])); + >> fs []) +QED -Theorem store_alloc_type_sound - `!ctMap tenvS store sv st. +Theorem store_alloc_type_sound: + !ctMap tenvS store sv st. ctMap_ok ctMap ∧ type_s ctMap store tenvS ∧ type_sv ctMap tenvS sv st @@ -562,8 +582,9 @@ Theorem store_alloc_type_sound store_type_extension tenvS tenvS' ∧ store_alloc sv store = (store', n) ∧ type_s ctMap store' tenvS' ∧ - FLOOKUP tenvS' n = SOME st` - (rw [store_alloc_def] + FLOOKUP tenvS' n = SOME st +Proof + rw [store_alloc_def] >> qexists_tac `tenvS |+ (LENGTH store, st)` >> rw [store_type_extension_def, FLOOKUP_UPDATE] >- ( @@ -590,43 +611,49 @@ Theorem store_alloc_type_sound >> fs [FLOOKUP_DEF] >> fs [] >> res_tac - >> fs [])); + >> fs []) +QED (* -Theorem store_lookup_type_sound - `!ctMap tenvS store n st. +Theorem store_lookup_type_sound: + !ctMap tenvS store n st. type_s ctMap store tenvS ∧ FLOOKUP tenvS n = SOME st ⇒ ?sv. store_lookup n store = SOME sv ∧ - type_sv ctMap tenvS sv st` - (rw [type_s_def] - >> metis_tac []); + type_sv ctMap tenvS sv st +Proof + rw [type_s_def] + >> metis_tac [] +QED *) -Theorem type_v_list_to_v - `!x xs t. +Theorem type_v_list_to_v: + !x xs t. type_v n ctMap tenvS x t /\ v_to_list x = SOME xs ==> - type_v n ctMap tenvS (list_to_v xs) t` - (recInduct v_to_list_ind \\ rw [Once type_v_cases] + type_v n ctMap tenvS (list_to_v xs) t +Proof + recInduct v_to_list_ind \\ rw [Once type_v_cases] \\ fs [v_to_list_def, list_to_v_def] \\ rw [] \\ fs [list_to_v_def] \\ FULL_CASE_TAC \\ fs [] \\ rw [] \\ fs [list_to_v_def] \\ qpat_x_assum `type_v _ _ _ _ _` mp_tac - \\ rw [Once type_v_cases] \\ simp [Once type_v_cases]); + \\ rw [Once type_v_cases] \\ simp [Once type_v_cases] +QED -Theorem type_v_list_to_v_APPEND - `!xs ys t. +Theorem type_v_list_to_v_APPEND: + !xs ys t. ctMap_has_lists ctMap /\ type_v 0 ctMap tenvS (list_to_v xs) (Tapp [t] Tlist_num) /\ type_v 0 ctMap tenvS (list_to_v ys) (Tapp [t] Tlist_num) ==> - type_v 0 ctMap tenvS (list_to_v (xs ++ ys)) (Tapp [t] Tlist_num)` - (Induct \\ rw [list_to_v_def] + type_v 0 ctMap tenvS (list_to_v (xs ++ ys)) (Tapp [t] Tlist_num) +Proof + Induct \\ rw [list_to_v_def] \\ ntac 2 (pop_assum mp_tac) \\ rw [Once type_v_cases] \\ rw [Once type_v_cases] @@ -639,10 +666,11 @@ Theorem type_v_list_to_v_APPEND \\ qpat_x_assum `type_v _ _ _ (_ xs) _` mp_tac \\ EVAL_TAC \\ strip_tac \\ first_x_assum (qspec_then `ys` mp_tac) - \\ EVAL_TAC \\ metis_tac [Tlist_num_def]); + \\ EVAL_TAC \\ metis_tac [Tlist_num_def] +QED -Theorem op_type_sound -`!ctMap tenvS vs op ts t store (ffi : 'ffi ffi_state). +Theorem op_type_sound: + !ctMap tenvS vs op ts t store (ffi : 'ffi ffi_state). good_ctMap ctMap ∧ op ≠ Opapp ∧ type_s ctMap store tenvS ∧ @@ -658,8 +686,9 @@ Theorem op_type_sound | Rval v => type_v 0 ctMap tenvS' v t | Rerr (Rraise v) => type_v 0 ctMap tenvS' v Texn | Rerr (Rabort(Rffi_error _)) => T - | Rerr (Rabort _) => F` - (rw [type_op_cases, good_ctMap_def] >> + | Rerr (Rabort _) => F +Proof + rw [type_op_cases, good_ctMap_def] >> fs [] >> rw [] >> rpt ( @@ -990,10 +1019,11 @@ Theorem op_type_sound rw [] >> qexists_tac `tenvS` >> rw [store_type_extension_refl] >> - metis_tac [type_v_list_to_v_APPEND, type_v_list_to_v])); + metis_tac [type_v_list_to_v_APPEND, type_v_list_to_v]) +QED -Theorem build_conv_type_sound -`!envC cn vs tvs ts ctMap tenvS ts' tn tenvC tvs' tenvE l. +Theorem build_conv_type_sound: + !envC cn vs tvs ts ctMap tenvS ts' tn tenvC tvs' tenvE l. nsAll2 (type_ctor ctMap) envC tenvC ∧ do_con_check envC (SOME cn) l ∧ num_tvs tenvE = 0 ∧ @@ -1005,8 +1035,9 @@ Theorem build_conv_type_sound ⇒ ?v. build_conv envC (SOME cn) (REVERSE vs) = SOME v ∧ - type_v tvs ctMap tenvS v (Tapp ts' tn)` - (rw [] + type_v tvs ctMap tenvS v (Tapp ts' tn) +Proof + rw [] >> drule do_con_check_build_conv >> disch_then (qspec_then `REVERSE vs` mp_tac) >> rw [] @@ -1020,18 +1051,21 @@ Theorem build_conv_type_sound >> rw [] >> simp [Once type_v_cases, GSYM EVERY2_REVERSE1] >> simp [GSYM FUNION_alist_to_fmap] - >> rfs [bind_tvar_def, num_tvs_def]); + >> rfs [bind_tvar_def, num_tvs_def] +QED -Theorem same_ctor_and_same_tid - `!stamp1 stamp2. +Theorem same_ctor_and_same_tid: + !stamp1 stamp2. same_ctor stamp1 stamp2 ∧ same_type stamp1 stamp2 ⇒ - stamp1 = stamp2` - (rw [] >> + stamp1 = stamp2 +Proof + rw [] >> Cases_on `stamp1` >> Cases_on `stamp2` >> - fs [same_ctor_def, same_type_def]); + fs [same_ctor_def, same_type_def] +QED val pat_sound_tac = CCONTR_TAC >> @@ -1049,8 +1083,8 @@ val pat_sound_tac = fs [] >> NO_TAC; -Theorem pat_type_sound - `(∀(cenv : env_ctor) st p v bindings tenv ctMap tbindings t new_tbindings tenvS tvs. +Theorem pat_type_sound: + (∀(cenv : env_ctor) st p v bindings tenv ctMap tbindings t new_tbindings tenvS tvs. ctMap_ok ctMap ∧ nsAll2 (type_ctor ctMap) cenv tenv.c ∧ type_v tvs ctMap tenvS v t ∧ @@ -1073,8 +1107,9 @@ Theorem pat_type_sound pmatch_list cenv st ps vs bindings = No_match ∨ (?bindings'. pmatch_list cenv st ps vs bindings = Match bindings' ∧ - LIST_REL (\(x,v) (x',t). x = x' ∧ type_v tvs ctMap tenvS v t) bindings' (new_tbindings ++ tbindings)))` - (ho_match_mp_tac pmatch_ind + LIST_REL (\(x,v) (x',t). x = x' ∧ type_v tvs ctMap tenvS v t) bindings' (new_tbindings ++ tbindings))) +Proof + ho_match_mp_tac pmatch_ind >> rw [pmatch_def] >> TRY (qpat_x_assum `type_p _ _ _ _ _` mp_tac >> simp [Once type_p_cases]) @@ -1168,10 +1203,11 @@ Theorem pat_type_sound >> simp [] >> metis_tac []) >- pat_sound_tac - >- pat_sound_tac); + >- pat_sound_tac +QED -Theorem lookup_var_sound - `!n tvs tenvE targs t ctMap tenvS env tenv. +Theorem lookup_var_sound: + !n tvs tenvE targs t ctMap tenvS env tenv. lookup_var n (bind_tvar tvs tenvE) tenv = SOME (LENGTH targs, t) ∧ ctMap_ok ctMap ∧ tenv_val_exp_ok tenvE ∧ @@ -1179,8 +1215,9 @@ Theorem lookup_var_sound EVERY (check_freevars tvs []) targs ∧ type_all_env ctMap tenvS env (tenv with v := add_tenvE tenvE tenv.v) ⇒ - ?v. nsLookup env.v n = SOME v ∧ type_v tvs ctMap tenvS v (deBruijn_subst 0 targs t)` - (rw [lookup_var_def, type_all_env_def] + ?v. nsLookup env.v n = SOME v ∧ type_v tvs ctMap tenvS v (deBruijn_subst 0 targs t) +Proof + rw [lookup_var_def, type_all_env_def] >> `nsLookup (add_tenvE tenvE tenv.v) n = SOME (LENGTH targs, t)` suffices_by ( rw [] @@ -1200,10 +1237,11 @@ Theorem lookup_var_sound >- metis_tac [] >> fs [tenv_val_exp_ok_def] >> metis_tac [tveLookup_freevars]) - >- metis_tac [nsLookup_add_tenvE3]); + >- metis_tac [nsLookup_add_tenvE3] +QED -Theorem exp_type_sound - `(!(s:'ffi semanticPrimitives$state) env es r s' tenv tenvE ts tvs tenvS. +Theorem exp_type_sound: + (!(s:'ffi semanticPrimitives$state) env es r s' tenv tenvE ts tvs tenvS. evaluate s env es = (s', r) ∧ tenv_ok tenv ∧ tenv_val_exp_ok tenvE ∧ @@ -1243,8 +1281,9 @@ Theorem exp_type_sound | Rerr (Rraise v) => type_v 0 ctMap tenvS' v Texn | Rerr (Rabort Rtimeout_error) => T | Rerr (Rabort (Rffi_error _)) => T - | Rerr (Rabort Rtype_error) => F)` - (ho_match_mp_tac evaluate_ind + | Rerr (Rabort Rtype_error) => F) +Proof + ho_match_mp_tac evaluate_ind >> simp [evaluate_def, type_es_list_rel, GSYM CONJ_ASSOC, good_ctMap_def] >> rw [] >- metis_tac [store_type_extension_refl] @@ -1750,7 +1789,8 @@ Theorem exp_type_sound CCONTR_TAC >> fs [type_pes_def, RES_FORALL] >> pop_assum (qspec_then `(p,e)` mp_tac) - >> simp [])); + >> simp []) +QED val let_tac = rw [] @@ -1885,16 +1925,18 @@ val check_ctor_tenv_dups = Q.prove ( ho_match_mp_tac check_ctor_tenv_ind >> rw [check_ctor_tenv_def]); -Theorem type_all_env_extend - `type_all_env ctMap tenvS env1 tenv1 +Theorem type_all_env_extend: + type_all_env ctMap tenvS env1 tenv1 /\ type_all_env ctMap tenvS env2 tenv2 ==> type_all_env ctMap tenvS (extend_dec_env env1 env2) - (extend_dec_tenv tenv1 tenv2)` - (fs [type_all_env_def, extend_dec_env_def, extend_dec_tenv_def] - \\ metis_tac [nsAll2_nsAppend]); + (extend_dec_tenv tenv1 tenv2) +Proof + fs [type_all_env_def, extend_dec_env_def, extend_dec_tenv_def] + \\ metis_tac [nsAll2_nsAppend] +QED -Theorem decs_type_sound_no_check - `∀(st:'ffi semanticPrimitives$state) env ds st' r ctMap tenvS tenv tids tenv'. +Theorem decs_type_sound_no_check: + ∀(st:'ffi semanticPrimitives$state) env ds st' r ctMap tenvS tenv tids tenv'. evaluate_decs st env ds = (st',r) ∧ type_ds F tenv ds tids tenv' ∧ type_sound_invariant st env ctMap tenvS tids tenv @@ -1913,8 +1955,9 @@ Theorem decs_type_sound_no_check type_sound_invariant st' env ctMap' tenvS' {} tenv | Rerr (Rabort Rtype_error) => F | Rerr (Rabort Rtimeout_error) => T - | Rerr (Rabort(Rffi_error _)) => T` - (ho_match_mp_tac evaluate_decs_ind + | Rerr (Rabort(Rffi_error _)) => T +Proof + ho_match_mp_tac evaluate_decs_ind >> rw [evaluate_decs_def] >> rw [] >> TRY (qpat_x_assum `type_ds _ _ _ _ _ _ _` mp_tac >> simp [Once type_d_cases]) @@ -2412,10 +2455,10 @@ Theorem decs_type_sound_no_check >> metis_tac [SUBSET_TRANS, SUBSET_UNION] ) ) -); +QED -Theorem decs_type_sound - `∀(st:'ffi semanticPrimitives$state) env ds extra_checks st' r ctMap tenvS tenv tids tenv'. +Theorem decs_type_sound: + ∀(st:'ffi semanticPrimitives$state) env ds extra_checks st' r ctMap tenvS tenv tids tenv'. evaluate_decs st env ds = (st',r) ∧ type_ds extra_checks tenv ds tids tenv' ∧ type_sound_invariant st env ctMap tenvS tids tenv @@ -2434,14 +2477,16 @@ Theorem decs_type_sound type_sound_invariant st' env ctMap' tenvS' {} tenv | Rerr (Rabort Rtype_error) => F | Rerr (Rabort (Rffi_error _)) => T - | Rerr (Rabort Rtimeout_error) => T` - (rw [] >> + | Rerr (Rabort Rtimeout_error) => T +Proof + rw [] >> imp_res_tac type_d_check_uniq >> imp_res_tac decs_type_sound_no_check >> qexists_tac `ctMap'` >> qexists_tac `tenvS'` >> Cases_on `r` >> - fs []); + fs [] +QED (* val type_sound_invariant_def = Define ` @@ -2467,8 +2512,8 @@ val tscheme_inst2_lemma = Q.prove ( >> PairCases_on `x'` >> rw [tscheme_inst2_def]); -Theorem tops_type_sound_no_extra_checks - `∀(st:'ffi semanticPrimitives$state) env tops st' env' r tdecs1 ctMap tenvS tenv tdecs1' tenv'. +Theorem tops_type_sound_no_extra_checks: + ∀(st:'ffi semanticPrimitives$state) env tops st' env' r tdecs1 ctMap tenvS tenv tdecs1' tenv'. evaluate_tops st env tops = (st',r) ∧ type_prog F tdecs1 tenv tops tdecs1' tenv' ∧ type_sound_invariant st env tdecs1 ctMap tenvS tenv ⇒ @@ -2484,8 +2529,9 @@ Theorem tops_type_sound_no_extra_checks type_sound_invariant st' env (union_decls tdecs1' tdecs1) ctMap' tenvS' tenv | Rerr (Rabort Rtype_error) => F | Rerr (Rabort(Rffi_error _)) => T - | Rerr (Rabort Rtimeout_error) => T` - (ho_match_mp_tac evaluate_tops_ind + | Rerr (Rabort Rtimeout_error) => T +Proof + ho_match_mp_tac evaluate_tops_ind >> rw [evaluate_tops_def] >- ( rw [extend_dec_env_def, extend_dec_tenv_def, type_all_env_def] @@ -2773,10 +2819,11 @@ Theorem tops_type_sound_no_extra_checks >- ( fs [type_sound_invariant_def, SUBSET_DEF] >> metis_tac [weak_decls_def]) - >- metis_tac [type_ds_no_dup_types, pair_CASES])); + >- metis_tac [type_ds_no_dup_types, pair_CASES]) +QED -Theorem tops_type_sound - `∀(st:'ffi semanticPrimitives$state) env tops st' r checks tdecs1 ctMap tenvS tenv tdecs1' tenv'. +Theorem tops_type_sound: + ∀(st:'ffi semanticPrimitives$state) env tops st' r checks tdecs1 ctMap tenvS tenv tdecs1' tenv'. evaluate_tops st env tops = (st',r) ∧ type_prog checks tdecs1 tenv tops tdecs1' tenv' ∧ type_sound_invariant st env tdecs1 ctMap tenvS tenv ⇒ @@ -2792,17 +2839,19 @@ Theorem tops_type_sound type_sound_invariant st' env (union_decls tdecs1' tdecs1) ctMap' tenvS' tenv | Rerr (Rabort Rtype_error) => F | Rerr (Rabort(Rffi_error _)) => T - | Rerr (Rabort Rtimeout_error) => T` - (rpt strip_tac + | Rerr (Rabort Rtimeout_error) => T +Proof + rpt strip_tac >> irule tops_type_sound_no_extra_checks >> qexists_tac `st` >> qexists_tac `tops` >> rw [] >> irule type_prog_check_uniq - >> metis_tac []); + >> metis_tac [] +QED -Theorem prog_type_sound - `∀(st:'ffi semanticPrimitives$state) env tops st' r checks tdecs1 ctMap tenvS tenv tdecs1' tenv'. +Theorem prog_type_sound: + ∀(st:'ffi semanticPrimitives$state) env tops st' r checks tdecs1 ctMap tenvS tenv tdecs1' tenv'. evaluate_prog st env tops = (st',r) ∧ type_prog checks tdecs1 tenv tops tdecs1' tenv' ∧ type_sound_invariant st env tdecs1 ctMap tenvS tenv ⇒ @@ -2818,8 +2867,9 @@ Theorem prog_type_sound type_sound_invariant st' env (union_decls tdecs1' tdecs1) ctMap' tenvS' tenv | Rerr (Rabort Rtype_error) => F | Rerr (Rabort(Rffi_error _)) => T - | Rerr (Rabort Rtimeout_error) => T` - (REWRITE_TAC [evaluate_prog_def] + | Rerr (Rabort Rtimeout_error) => T +Proof + REWRITE_TAC [evaluate_prog_def] >> rpt strip_tac >> irule tops_type_sound >> fs [] @@ -2840,17 +2890,19 @@ Theorem prog_type_sound >> rpt (disch_then drule) >> fs [no_dup_top_types_def, DISJOINT_DEF, EXTENSION, SUBSET_DEF] >> rw [] - >> metis_tac [weak_decls_def])); + >> metis_tac [weak_decls_def]) +QED *) -Theorem semantics_type_sound - `∀(st:'ffi semanticPrimitives$state) env tops r checks ctMap tenvS tenv new_tenv tids. +Theorem semantics_type_sound: + ∀(st:'ffi semanticPrimitives$state) env tops r checks ctMap tenvS tenv new_tenv tids. semantics_prog st env tops r ∧ type_ds checks tenv tops tids new_tenv ∧ type_sound_invariant st env ctMap tenvS tids tenv ⇒ - r ≠ Fail` - (rw [] + r ≠ Fail +Proof + rw [] >> CCONTR_TAC >> fs [semantics_prog_def] >> Cases_on `evaluate_prog_with_clock st env k tops` @@ -2865,6 +2917,7 @@ Theorem semantics_type_sound >> simp [] >> fs [type_sound_invariant_def] >> fs [consistent_ctMap_def] - >> metis_tac []); + >> metis_tac [] +QED val _ = export_theory (); diff --git a/semantics/proofs/typeSysPropsScript.sml b/semantics/proofs/typeSysPropsScript.sml index c7b9b791d4..bd8a4f026d 100644 --- a/semantics/proofs/typeSysPropsScript.sml +++ b/semantics/proofs/typeSysPropsScript.sml @@ -36,57 +36,77 @@ val _ = export_rewrites [ (* ----------- Basic stuff ----------- *) -Theorem unchanged_tenv[simp] - `!(tenv : type_env). - <| v := tenv.v; c := tenv.c; t := tenv.t |> = tenv` - (rw [type_env_component_equality]); +Theorem unchanged_tenv[simp]: + !(tenv : type_env). + <| v := tenv.v; c := tenv.c; t := tenv.t |> = tenv +Proof + rw [type_env_component_equality] +QED (* -Theorem union_decls_assoc[simp] -`!decls1 decls2 decls3. +Theorem union_decls_assoc[simp]: + !decls1 decls2 decls3. union_decls decls1 (union_decls decls2 decls3) = - union_decls (union_decls decls1 decls2) decls3` - (srw_tac[][] >> + union_decls (union_decls decls1 decls2) decls3 +Proof + srw_tac[][] >> srw_tac[][union_decls_def] >> - metis_tac [UNION_ASSOC]); - -Theorem union_decls_sym -`!decls1 decls2. union_decls decls1 decls2 = union_decls decls2 decls1` - (rw [union_decls_def] >> - rw [UNION_COMM]); - -Theorem union_decls_mods[simp] - `(union_decls d1 d2).defined_mods = d1.defined_mods ∪ d2.defined_mods` - (rw [union_decls_def]); - -Theorem union_decls_empty[simp] - `!d. union_decls empty_decls d = d ∧ union_decls d empty_decls = d` - (rw [union_decls_def, decls_component_equality, empty_decls_def]); + metis_tac [UNION_ASSOC] +QED + +Theorem union_decls_sym: + !decls1 decls2. union_decls decls1 decls2 = union_decls decls2 decls1 +Proof + rw [union_decls_def] >> + rw [UNION_COMM] +QED + +Theorem union_decls_mods[simp]: + (union_decls d1 d2).defined_mods = d1.defined_mods ∪ d2.defined_mods +Proof + rw [union_decls_def] +QED + +Theorem union_decls_empty[simp]: + !d. union_decls empty_decls d = d ∧ union_decls d empty_decls = d +Proof + rw [union_decls_def, decls_component_equality, empty_decls_def] +QED *) -Theorem extend_dec_tenv_assoc[simp] - `!tenv1 tenv2 tenv3. +Theorem extend_dec_tenv_assoc[simp]: + !tenv1 tenv2 tenv3. extend_dec_tenv tenv1 (extend_dec_tenv tenv2 tenv3) = - extend_dec_tenv (extend_dec_tenv tenv1 tenv2) tenv3` - (rw [extend_dec_tenv_def]); - -Theorem tenv_val_ok_nsEmpty[simp] - `tenv_val_ok nsEmpty` - (rw [tenv_val_ok_def]); - -Theorem tenv_ctor_ok_nsEmpty[simp] - `tenv_ctor_ok nsEmpty` - (rw [tenv_ctor_ok_def]); - -Theorem tenv_abbrev_ok_nsEmpty[simp] - `tenv_abbrev_ok nsEmpty` - (rw [tenv_abbrev_ok_def]); - -Theorem tenv_ok_empty[simp] - `tenv_ok <| v := nsEmpty; c := nsEmpty; t := nsEmpty |>` - (rw [tenv_ok_def, tenv_val_ok_def, tenv_ctor_ok_def, tenv_abbrev_ok_def]); + extend_dec_tenv (extend_dec_tenv tenv1 tenv2) tenv3 +Proof + rw [extend_dec_tenv_def] +QED + +Theorem tenv_val_ok_nsEmpty[simp]: + tenv_val_ok nsEmpty +Proof + rw [tenv_val_ok_def] +QED + +Theorem tenv_ctor_ok_nsEmpty[simp]: + tenv_ctor_ok nsEmpty +Proof + rw [tenv_ctor_ok_def] +QED + +Theorem tenv_abbrev_ok_nsEmpty[simp]: + tenv_abbrev_ok nsEmpty +Proof + rw [tenv_abbrev_ok_def] +QED + +Theorem tenv_ok_empty[simp]: + tenv_ok <| v := nsEmpty; c := nsEmpty; t := nsEmpty |> +Proof + rw [tenv_ok_def, tenv_val_ok_def, tenv_ctor_ok_def, tenv_abbrev_ok_def] +QED val type_pes_def = Define ` type_pes tvs tvs' tenv tenvE pes t1 t2 ⇔ @@ -96,15 +116,16 @@ val type_pes_def = Define ` type_p tvs tenv p t1 bindings ∧ type_e tenv (bind_var_list tvs' bindings tenvE) e t2)`; -Theorem type_pes_cons - `!tvs tvs' tenv tenvE p e pes t1 t2. +Theorem type_pes_cons: + !tvs tvs' tenv tenvE p e pes t1 t2. type_pes tvs tvs' tenv tenvE ((p,e)::pes) t1 t2 ⇔ (ALL_DISTINCT (pat_bindings p []) ∧ (?bindings. type_p tvs tenv p t1 bindings ∧ type_e tenv (bind_var_list tvs' bindings tenvE) e t2) ∧ - type_pes tvs tvs' tenv tenvE pes t1 t2)` - (rw [type_pes_def, RES_FORALL] >> + type_pes tvs tvs' tenv tenvE pes t1 t2) +Proof + rw [type_pes_def, RES_FORALL] >> eq_tac >> rw [] >> rw [] @@ -115,28 +136,32 @@ Theorem type_pes_cons pop_assum (qspec_then `(p,e)` mp_tac) >> rw [] >> metis_tac []) - >> metis_tac []); + >> metis_tac [] +QED (* ---------- check_freevars ---------- *) -Theorem check_freevars_add -`(!tvs tvs' t. check_freevars tvs tvs' t ⇒ - !tvs''. tvs'' ≥ tvs ⇒ check_freevars tvs'' tvs' t)` -(ho_match_mp_tac check_freevars_ind >> +Theorem check_freevars_add: + (!tvs tvs' t. check_freevars tvs tvs' t ⇒ + !tvs''. tvs'' ≥ tvs ⇒ check_freevars tvs'' tvs' t) +Proof +ho_match_mp_tac check_freevars_ind >> srw_tac[][check_freevars_def] >- metis_tac [MEM_EL, EVERY_MEM] >> -decide_tac); +decide_tac +QED (* ---------- type_subst ---------- *) -Theorem check_freevars_subst_single -`!dbmax tvs t tvs' ts. +Theorem check_freevars_subst_single: + !dbmax tvs t tvs' ts. LENGTH tvs = LENGTH ts ∧ check_freevars dbmax tvs t ∧ EVERY (check_freevars dbmax tvs') ts ⇒ - check_freevars dbmax tvs' (type_subst (alist_to_fmap (ZIP (tvs,ts))) t)` - (recInduct check_freevars_ind >> + check_freevars dbmax tvs' (type_subst (alist_to_fmap (ZIP (tvs,ts))) t) +Proof + recInduct check_freevars_ind >> srw_tac[][check_freevars_def, type_subst_def, EVERY_MAP] >- (every_case_tac >> full_simp_tac(srw_ss())[check_freevars_def, ALOOKUP_FAILS] @@ -148,38 +173,45 @@ Theorem check_freevars_subst_single full_simp_tac(srw_ss())[MEM_EL, EVERY_MEM] >> srw_tac[][] >> metis_tac [])) - >- full_simp_tac(srw_ss())[EVERY_MEM]); + >- full_simp_tac(srw_ss())[EVERY_MEM] +QED -Theorem check_freevars_subst_list -`!dbmax tvs tvs' ts ts'. +Theorem check_freevars_subst_list: + !dbmax tvs tvs' ts ts'. (LENGTH tvs = LENGTH ts) ∧ EVERY (check_freevars dbmax tvs) ts' ∧ EVERY (check_freevars dbmax tvs') ts ⇒ - EVERY (check_freevars dbmax tvs') (MAP (type_subst (alist_to_fmap (ZIP (tvs,ts)))) ts')` -(induct_on `ts'` >> + EVERY (check_freevars dbmax tvs') (MAP (type_subst (alist_to_fmap (ZIP (tvs,ts)))) ts') +Proof +induct_on `ts'` >> srw_tac[][] >> -metis_tac [check_freevars_subst_single]); +metis_tac [check_freevars_subst_single] +QED (* ---------- deBruijn_inc ---------- *) -Theorem deBruijn_inc0 -`(!t sk. deBruijn_inc sk 0 t = t) ∧ - (!ts sk. MAP (deBruijn_inc sk 0) ts = ts)` -(ho_match_mp_tac t_induction >> +Theorem deBruijn_inc0: + (!t sk. deBruijn_inc sk 0 t = t) ∧ + (!ts sk. MAP (deBruijn_inc sk 0) ts = ts) +Proof +ho_match_mp_tac t_induction >> srw_tac[][deBruijn_inc_def] >> -metis_tac []); +metis_tac [] +QED -Theorem deBruijn_inc_deBruijn_inc -`!sk i2 t i1. - deBruijn_inc sk i1 (deBruijn_inc sk i2 t) = deBruijn_inc sk (i1 + i2) t` -(ho_match_mp_tac deBruijn_inc_ind >> +Theorem deBruijn_inc_deBruijn_inc: + !sk i2 t i1. + deBruijn_inc sk i1 (deBruijn_inc sk i2 t) = deBruijn_inc sk (i1 + i2) t +Proof +ho_match_mp_tac deBruijn_inc_ind >> srw_tac[][deBruijn_inc_def] >> srw_tac[][] >- decide_tac >- decide_tac >> induct_on `ts` >> -full_simp_tac(srw_ss())[]); +full_simp_tac(srw_ss())[] +QED val deBuijn_inc_lem1 = Q.prove ( `!sk i2 t i1. @@ -216,15 +248,17 @@ val type_subst_deBruijn_inc_single = Q.prove ( full_simp_tac(srw_ss())[EVERY_MEM] >> metis_tac [])); -Theorem type_subst_deBruijn_inc_list -`!ts' ts tvs inc sk. +Theorem type_subst_deBruijn_inc_list: + !ts' ts tvs inc sk. (LENGTH tvs = LENGTH ts) ∧ EVERY (check_freevars 0 tvs) ts' ⇒ (MAP (deBruijn_inc sk inc) (MAP (type_subst (alist_to_fmap (ZIP (tvs,ts)))) ts') = - MAP (type_subst (alist_to_fmap (ZIP (tvs, MAP (\t. deBruijn_inc sk inc t) ts)))) ts')` - (induct_on `ts'` >> + MAP (type_subst (alist_to_fmap (ZIP (tvs, MAP (\t. deBruijn_inc sk inc t) ts)))) ts') +Proof + induct_on `ts'` >> srw_tac[][] >> - metis_tac [type_subst_deBruijn_inc_single]); + metis_tac [type_subst_deBruijn_inc_single] +QED val check_freevars_deBruijn_inc = Q.prove ( `!tvs tvs' t. check_freevars tvs tvs' t ⇒ @@ -235,12 +269,13 @@ full_simp_tac(srw_ss())[EVERY_MAP, EVERY_MEM] >> srw_tac[][check_freevars_def] >> decide_tac); -Theorem nil_deBruijn_inc -`∀skip tvs t. +Theorem nil_deBruijn_inc: + ∀skip tvs t. (check_freevars skip [] t ∨ check_freevars skip [] (deBruijn_inc skip tvs t)) ⇒ - (deBruijn_inc skip tvs t = t)` -(ho_match_mp_tac deBruijn_inc_ind >> + (deBruijn_inc skip tvs t = t) +Proof +ho_match_mp_tac deBruijn_inc_ind >> srw_tac[][deBruijn_inc_def, check_freevars_def] >- decide_tac >- (induct_on `ts` >> @@ -249,46 +284,52 @@ decide_tac >- (induct_on `ts` >> srw_tac[][] >> metis_tac []) >> -metis_tac []); +metis_tac [] +QED (* ---------- deBruijn_subst ---------- *) -Theorem deBruijn_subst_check_freevars -`!tvs tvs' t ts n. +Theorem deBruijn_subst_check_freevars: + !tvs tvs' t ts n. check_freevars tvs tvs' t ∧ EVERY (check_freevars tvs tvs') ts ⇒ - check_freevars tvs tvs' (deBruijn_subst 0 ts t)` -(ho_match_mp_tac check_freevars_ind >> + check_freevars tvs tvs' (deBruijn_subst 0 ts t) +Proof +ho_match_mp_tac check_freevars_ind >> srw_tac[][check_freevars_def, deBruijn_subst_def, EVERY_MAP] >> full_simp_tac(srw_ss())[EVERY_MEM] >> full_simp_tac(srw_ss())[MEM_EL] >- metis_tac [] >> -decide_tac); +decide_tac +QED -Theorem deBruijn_subst_check_freevars2 -`!tvs tvs' t ts n tvs''. +Theorem deBruijn_subst_check_freevars2: + !tvs tvs' t ts n tvs''. check_freevars (LENGTH ts) tvs' t ∧ EVERY (check_freevars tvs tvs') ts ⇒ - check_freevars tvs tvs' (deBruijn_subst 0 ts t)` -(ho_match_mp_tac check_freevars_ind >> + check_freevars tvs tvs' (deBruijn_subst 0 ts t) +Proof +ho_match_mp_tac check_freevars_ind >> srw_tac[][check_freevars_def, deBruijn_subst_def, EVERY_MAP] >> full_simp_tac(srw_ss())[EVERY_MEM] >> full_simp_tac(srw_ss())[MEM_EL] >> srw_tac[][] >> -metis_tac []); +metis_tac [] +QED -Theorem check_freevars_subst_inc -`∀tvs tvs2 t. +Theorem check_freevars_subst_inc: + ∀tvs tvs2 t. check_freevars tvs tvs2 t ⇒ ∀tvs' targs tvs1. tvs = LENGTH targs + tvs' ∧ EVERY (check_freevars (tvs1 + tvs') tvs2) targs ⇒ check_freevars (tvs1 + tvs') tvs2 - (deBruijn_subst 0 targs (deBruijn_inc (LENGTH targs) tvs1 t))` -(ho_match_mp_tac check_freevars_ind >> + (deBruijn_subst 0 targs (deBruijn_inc (LENGTH targs) tvs1 t)) +Proof +ho_match_mp_tac check_freevars_ind >> srw_tac[][check_freevars_def, deBruijn_inc_def, deBruijn_subst_def, EVERY_MAP] >> full_simp_tac(srw_ss())[EVERY_MEM] >> cases_on `n < LENGTH targs` >> @@ -296,17 +337,19 @@ srw_tac[][deBruijn_subst_def, check_freevars_def] >> full_simp_tac(srw_ss())[MEM_EL] >- metis_tac [] >- metis_tac [] >> -decide_tac); +decide_tac +QED -Theorem check_freevars_subst -`∀tvs tvs2 t. +Theorem check_freevars_subst: + ∀tvs tvs2 t. check_freevars tvs tvs2 t ⇒ ∀tvs' targs tvs1. tvs = LENGTH targs + tvs' ∧ EVERY (check_freevars (tvs1 + tvs') tvs2) targs ⇒ - check_freevars (tvs1 + tvs') tvs2 (deBruijn_subst 0 targs t)` -(ho_match_mp_tac check_freevars_ind >> + check_freevars (tvs1 + tvs') tvs2 (deBruijn_subst 0 targs t) +Proof +ho_match_mp_tac check_freevars_ind >> srw_tac[][check_freevars_def, deBruijn_inc_def, deBruijn_subst_def, EVERY_MAP] >> full_simp_tac(srw_ss())[EVERY_MEM] >> cases_on `n < LENGTH targs` >> @@ -314,7 +357,8 @@ srw_tac[][deBruijn_subst_def, check_freevars_def] >> full_simp_tac(srw_ss())[MEM_EL] >- metis_tac [] >- decide_tac >> -decide_tac); +decide_tac +QED val type_subst_deBruijn_subst_single = Q.prove ( `!s t tvs tvs' ts ts' inc. @@ -333,15 +377,17 @@ val type_subst_deBruijn_subst_single = Q.prove ( full_simp_tac(srw_ss())[EVERY_MEM] >> metis_tac [])); -Theorem type_subst_deBruijn_subst_list -`!t tvs tvs' ts ts' ts'' inc. +Theorem type_subst_deBruijn_subst_list: + !t tvs tvs' ts ts' ts'' inc. (LENGTH tvs = LENGTH ts) ∧ EVERY (check_freevars 0 tvs) ts'' ⇒ (MAP (deBruijn_subst inc ts') (MAP (type_subst (alist_to_fmap (ZIP (tvs,ts)))) ts'') = - MAP (type_subst (alist_to_fmap (ZIP (tvs,MAP (\t. deBruijn_subst inc ts' t) ts)))) ts'')` -(induct_on `ts''` >> + MAP (type_subst (alist_to_fmap (ZIP (tvs,MAP (\t. deBruijn_subst inc ts' t) ts)))) ts'') +Proof +induct_on `ts''` >> srw_tac[][] >> -metis_tac [type_subst_deBruijn_subst_single]); +metis_tac [type_subst_deBruijn_subst_single] +QED val check_freevars_lem = Q.prove ( `!l tvs' t. @@ -366,45 +412,51 @@ srw_tac[][deBruijn_inc_def, deBruijn_subst_def, check_freevars_def] >| decide_tac, decide_tac]]); -Theorem nil_deBruijn_subst -`∀skip tvs t. check_freevars skip [] t ⇒ (deBruijn_subst skip tvs t = t)` -(ho_match_mp_tac deBruijn_subst_ind >> +Theorem nil_deBruijn_subst: + ∀skip tvs t. check_freevars skip [] t ⇒ (deBruijn_subst skip tvs t = t) +Proof +ho_match_mp_tac deBruijn_subst_ind >> srw_tac[][deBruijn_subst_def, check_freevars_def] >> induct_on `ts'` >> -srw_tac[][]); +srw_tac[][] +QED -Theorem deBruijn_subst2 -`(!t sk targs targs' tvs'. +Theorem deBruijn_subst2: + (!t sk targs targs' tvs'. check_freevars (LENGTH targs) [] t ⇒ (deBruijn_subst sk (MAP (deBruijn_inc 0 sk) targs') (deBruijn_subst 0 targs t) = deBruijn_subst 0 (MAP (deBruijn_subst sk (MAP (deBruijn_inc 0 sk) targs')) targs) t)) ∧ (!ts sk targs targs' tvs'. EVERY (check_freevars (LENGTH targs) []) ts ⇒ (MAP (deBruijn_subst sk (MAP (deBruijn_inc 0 sk) targs')) (MAP (deBruijn_subst 0 targs) ts) = - (MAP (deBruijn_subst 0 (MAP (deBruijn_subst sk (MAP (deBruijn_inc 0 sk) targs')) targs)) ts)))` -(ho_match_mp_tac t_induction >> + (MAP (deBruijn_subst 0 (MAP (deBruijn_subst sk (MAP (deBruijn_inc 0 sk) targs')) targs)) ts))) +Proof +ho_match_mp_tac t_induction >> srw_tac[][deBruijn_subst_def, deBruijn_inc_def] >> full_simp_tac(srw_ss())[EL_MAP, MAP_MAP_o, combinTheory.o_DEF] >> srw_tac[][] >> full_simp_tac (srw_ss()++ARITH_ss) [deBruijn_subst_def, check_freevars_def] >> -metis_tac []); +metis_tac [] +QED -Theorem type_e_subst_lem3 -`∀tvs tvs2 t. +Theorem type_e_subst_lem3: + ∀tvs tvs2 t. check_freevars tvs tvs2 t ⇒ ∀tvs' targs n. (tvs = n + LENGTH targs) ∧ EVERY (check_freevars tvs' tvs2) targs ⇒ check_freevars (n + tvs') tvs2 - (deBruijn_subst n (MAP (deBruijn_inc 0 n) targs) t)` -(ho_match_mp_tac check_freevars_ind >> + (deBruijn_subst n (MAP (deBruijn_inc 0 n) targs) t) +Proof +ho_match_mp_tac check_freevars_ind >> srw_tac[][check_freevars_def, deBruijn_inc_def, deBruijn_subst_def, EVERY_MAP] >> full_simp_tac(srw_ss())[EVERY_MEM] >> srw_tac[][] >> full_simp_tac (srw_ss()++ARITH_ss) [check_freevars_def, EL_MAP, MEM_EL] >> `n - n' < LENGTH targs` by decide_tac >> -metis_tac [check_freevars_deBruijn_inc]); +metis_tac [check_freevars_deBruijn_inc] +QED val type_e_subst_lem5 = Q.prove ( `(!t n inc n' targs. @@ -423,19 +475,21 @@ srw_tac[][] >> full_simp_tac (srw_ss()++ARITH_ss) [EL_MAP] >> metis_tac [deBuijn_inc_lem1]); -Theorem subst_inc_cancel -`(!t ts inc. +Theorem subst_inc_cancel: + (!t ts inc. deBruijn_subst 0 ts (deBruijn_inc 0 (inc + LENGTH ts) t) = deBruijn_inc 0 inc t) ∧ (!ts' ts inc. MAP (deBruijn_subst 0 ts) (MAP (deBruijn_inc 0 (inc + LENGTH ts)) ts') = - MAP (deBruijn_inc 0 inc) ts')` -(ho_match_mp_tac t_induction >> + MAP (deBruijn_inc 0 inc) ts') +Proof +ho_match_mp_tac t_induction >> srw_tac[][deBruijn_subst_def, deBruijn_inc_def] >> full_simp_tac (srw_ss()++ARITH_ss) [] >> -metis_tac []); +metis_tac [] +QED val type_e_subst_lem7 = Q.prove ( `(!t sk targs targs' tvs' tvs''. @@ -454,47 +508,54 @@ full_simp_tac (srw_ss()++ARITH_ss) [EL_MAP, deBruijn_subst_def, check_freevars_d rw[] >> fs[] >> metis_tac [subst_inc_cancel, LENGTH_MAP]); -Theorem deBruijn_subst_id -`(!t n. check_freevars n [] t ⇒ (deBruijn_subst 0 (MAP Tvar_db (COUNT_LIST n)) t = t)) ∧ - (!ts n. EVERY (check_freevars n []) ts ⇒ (MAP (deBruijn_subst 0 (MAP Tvar_db (COUNT_LIST n))) ts = ts))` -(Induct >> +Theorem deBruijn_subst_id: + (!t n. check_freevars n [] t ⇒ (deBruijn_subst 0 (MAP Tvar_db (COUNT_LIST n)) t = t)) ∧ + (!ts n. EVERY (check_freevars n []) ts ⇒ (MAP (deBruijn_subst 0 (MAP Tvar_db (COUNT_LIST n))) ts = ts)) +Proof +Induct >> srw_tac[][deBruijn_subst_def, LENGTH_COUNT_LIST, EL_MAP, EL_COUNT_LIST, check_freevars_def] >> -metis_tac []); +metis_tac [] +QED -Theorem deBruijn_subst_freevars -`!skip targs t tvs. +Theorem deBruijn_subst_freevars: + !skip targs t tvs. skip = 0 ∧ EVERY (check_freevars tvs []) targs ∧ check_freevars (LENGTH targs) [] t ⇒ - check_freevars tvs [] (deBruijn_subst skip targs t)` -(ho_match_mp_tac deBruijn_subst_ind >> + check_freevars tvs [] (deBruijn_subst skip targs t) +Proof +ho_match_mp_tac deBruijn_subst_ind >> srw_tac[][check_freevars_def, deBruijn_subst_def, EVERY_MAP] >> full_simp_tac(srw_ss())[EVERY_MEM, MEM_EL] >> -metis_tac []); +metis_tac [] +QED (* ---------- tenv_abbrev stuff ---------- *) -Theorem tenv_abbrev_ok_lookup -`!tenvT tn tvs t. +Theorem tenv_abbrev_ok_lookup: + !tenvT tn tvs t. tenv_abbrev_ok tenvT ∧ nsLookup tenvT tn = SOME (tvs,t) ⇒ - check_freevars 0 tvs t` - (rw [tenv_abbrev_ok_def] + check_freevars 0 tvs t +Proof + rw [tenv_abbrev_ok_def] >> drule nsLookup_nsAll >> disch_then drule - >> simp []); + >> simp [] +QED -Theorem check_freevars_type_name_subst -`!tvs t dbmax tenvT. +Theorem check_freevars_type_name_subst: + !tvs t dbmax tenvT. tenv_abbrev_ok tenvT ∧ check_type_names tenvT t ∧ check_freevars_ast tvs t ⇒ - check_freevars dbmax tvs (type_name_subst tenvT t)` - (recInduct check_freevars_ast_ind >> + check_freevars dbmax tvs (type_name_subst tenvT t) +Proof + recInduct check_freevars_ast_ind >> srw_tac[][type_name_subst_def, LET_THM] >> every_case_tac >> fs [check_type_names_def, check_freevars_def, check_freevars_ast_def, EVERY_MAP] >> @@ -503,44 +564,53 @@ Theorem check_freevars_type_name_subst srw_tac[][EVERY_MAP] >> srw_tac[][EVERY_MEM] >> imp_res_tac tenv_abbrev_ok_lookup >> - metis_tac [check_freevars_add, numeralTheory.numeral_distrib]); + metis_tac [check_freevars_add, numeralTheory.numeral_distrib] +QED -Theorem tenv_abbrev_ok_merge -`!tenvT1 tenvT2. +Theorem tenv_abbrev_ok_merge: + !tenvT1 tenvT2. tenv_abbrev_ok tenvT1 ∧ tenv_abbrev_ok tenvT2 ⇒ - tenv_abbrev_ok (nsAppend tenvT1 tenvT2)` - (rw [tenv_abbrev_ok_def] + tenv_abbrev_ok (nsAppend tenvT1 tenvT2) +Proof + rw [tenv_abbrev_ok_def] >> irule nsAll_nsAppend - >> rw []); + >> rw [] +QED (* ---------- tenv_ctor stuff ----------*) -Theorem type_ctor_long - `!ctMap mn id. type_ctor ctMap (Long mn id) = type_ctor ctMap id` - (rw [FUN_EQ_THM] +Theorem type_ctor_long: + !ctMap mn id. type_ctor ctMap (Long mn id) = type_ctor ctMap id +Proof + rw [FUN_EQ_THM] >> PairCases_on `x` >> PairCases_on `x'` - >> simp [type_ctor_def, id_to_n_def]); + >> simp [type_ctor_def, id_to_n_def] +QED -Theorem tenv_ctor_ok_merge[simp] - `!tenvC1 tenvC2. +Theorem tenv_ctor_ok_merge[simp]: + !tenvC1 tenvC2. tenv_ctor_ok tenvC1 ∧ tenv_ctor_ok tenvC2 ⇒ - tenv_ctor_ok (nsAppend tenvC1 tenvC2)` - (rw [tenv_ctor_ok_def] + tenv_ctor_ok (nsAppend tenvC1 tenvC2) +Proof + rw [tenv_ctor_ok_def] >> irule nsAll_nsAppend - >> rw []); + >> rw [] +QED -Theorem tenv_ctor_ok_lookup - `!tenvC cn tvs ts tn. +Theorem tenv_ctor_ok_lookup: + !tenvC cn tvs ts tn. tenv_ctor_ok tenvC ∧ nsLookup tenvC cn = SOME (tvs,ts,tn) ⇒ - EVERY (check_freevars 0 tvs) ts` - (rw [tenv_ctor_ok_def] + EVERY (check_freevars 0 tvs) ts +Proof + rw [tenv_ctor_ok_def] >> drule nsLookup_nsAll >> disch_then drule - >> simp []); + >> simp [] +QED (* ---------- tenv_val_exp stuff ---------- *) @@ -559,8 +629,8 @@ val db_merge_def = Define ` (db_merge (Bind_tvar tvs e1) e2 = Bind_tvar tvs (db_merge e1 e2)) ∧ (db_merge (Bind_name x tvs t e1) e2 = Bind_name x tvs t (db_merge e1 e2))`; -Theorem bind_tvar_rewrites[simp] - `(!tvs e1 e2. db_merge (bind_tvar tvs e1) e2 = bind_tvar tvs (db_merge e1 e2)) ∧ +Theorem bind_tvar_rewrites[simp]: + (!tvs e1 e2. db_merge (bind_tvar tvs e1) e2 = bind_tvar tvs (db_merge e1 e2)) ∧ (!tvs e. num_tvs (bind_tvar tvs e) = tvs + num_tvs e) ∧ (!tvs e. num_tvs (Bind_tvar tvs e) = tvs + num_tvs e) ∧ (!tvs n t e. num_tvs (Bind_name n tvs t e) = num_tvs e) ∧ @@ -569,146 +639,180 @@ Theorem bind_tvar_rewrites[simp] (!tvs e. tenv_val_exp_ok (bind_tvar tvs e) ⇔ tenv_val_exp_ok e) ∧ (!targs tvs e. deBruijn_subst_tenvE targs (bind_tvar tvs e) = - bind_tvar tvs (deBruijn_subst_tenvE targs e))` - (srw_tac[][bind_tvar_def, deBruijn_subst_tenvE_def, db_merge_def, num_tvs_def, - tveLookup_def, tenv_val_exp_ok_def]); - -Theorem bind_tvar0[simp] -`!x. bind_tvar 0 x = x` - (Cases_on `x` - >> rw [bind_tvar_def]); - -Theorem tveLookup_subst_none -`!n inc e. + bind_tvar tvs (deBruijn_subst_tenvE targs e)) +Proof + srw_tac[][bind_tvar_def, deBruijn_subst_tenvE_def, db_merge_def, num_tvs_def, + tveLookup_def, tenv_val_exp_ok_def] +QED + +Theorem bind_tvar0[simp]: + !x. bind_tvar 0 x = x +Proof + Cases_on `x` + >> rw [bind_tvar_def] +QED + +Theorem tveLookup_subst_none: + !n inc e. tveLookup n inc (deBruijn_subst_tenvE targs e) = NONE ⇔ - tveLookup n inc e = NONE` -(induct_on `e` >> -srw_tac[][deBruijn_subst_tenvE_def, tveLookup_def]); - -Theorem tveLookup_db_merge_none -`!n inc e1 e2. + tveLookup n inc e = NONE +Proof +induct_on `e` >> +srw_tac[][deBruijn_subst_tenvE_def, tveLookup_def] +QED + +Theorem tveLookup_db_merge_none: + !n inc e1 e2. tveLookup n inc (db_merge e1 e2) = NONE ⇔ - tveLookup n inc e1 = NONE ∧ tveLookup n (num_tvs e1 + inc) e2 = NONE` - (Induct_on `e1` - >> rw [tveLookup_def, db_merge_def]); - -Theorem tveLookup_inc_none -`!n inc e. + tveLookup n inc e1 = NONE ∧ tveLookup n (num_tvs e1 + inc) e2 = NONE +Proof + Induct_on `e1` + >> rw [tveLookup_def, db_merge_def] +QED + +Theorem tveLookup_inc_none: + !n inc e. tveLookup n inc e = NONE ⇔ - tveLookup n 0 e = NONE` - (Induct_on `e` - >> rw [tveLookup_def]); - -Theorem tveLookup_freevars - `!n tvs tenvE tvs' t. + tveLookup n 0 e = NONE +Proof + Induct_on `e` + >> rw [tveLookup_def] +QED + +Theorem tveLookup_freevars: + !n tvs tenvE tvs' t. tenv_val_exp_ok tenvE ∧ num_tvs tenvE = 0 ∧ tveLookup n tvs tenvE = SOME (tvs',t) ⇒ - check_freevars tvs' [] t` - (Induct_on `tenvE` + check_freevars tvs' [] t +Proof + Induct_on `tenvE` >> rw [tveLookup_def, tenv_val_exp_ok_def] >> fs [] - >> metis_tac [nil_deBruijn_inc]); + >> metis_tac [nil_deBruijn_inc] +QED -Theorem tveLookup_bvl - `!x tvs tvs' bindings tenvE. +Theorem tveLookup_bvl: + !x tvs tvs' bindings tenvE. tveLookup x tvs (bind_var_list tvs' bindings tenvE) = case ALOOKUP bindings x of | SOME t => SOME (tvs',deBruijn_inc tvs' tvs t) - | NONE => tveLookup x tvs tenvE` - (Induct_on `bindings` + | NONE => tveLookup x tvs tenvE +Proof + Induct_on `bindings` >> rw [bind_var_list_def] >> PairCases_on `h` - >> rw [bind_var_list_def, tveLookup_def]); - -Theorem bind_var_list_append -`!n te1 te2 te3. - bind_var_list n (te1++te2) te3 = bind_var_list n te1 (bind_var_list n te2 te3)` -(induct_on `te1` >> + >> rw [bind_var_list_def, tveLookup_def] +QED + +Theorem bind_var_list_append: + !n te1 te2 te3. + bind_var_list n (te1++te2) te3 = bind_var_list n te1 (bind_var_list n te2 te3) +Proof +induct_on `te1` >> srw_tac[][bind_var_list_def] >> PairCases_on `h` >> -srw_tac[][bind_var_list_def]); +srw_tac[][bind_var_list_def] +QED -Theorem num_tvs_bind_var_list[simp] -`!tvs env tenvE. num_tvs (bind_var_list tvs env tenvE) = num_tvs tenvE` -(induct_on `env` >> +Theorem num_tvs_bind_var_list[simp]: + !tvs env tenvE. num_tvs (bind_var_list tvs env tenvE) = num_tvs tenvE +Proof +induct_on `env` >> srw_tac[][num_tvs_def, bind_var_list_def] >> PairCases_on `h` >> -srw_tac[][bind_var_list_def, num_tvs_def]); +srw_tac[][bind_var_list_def, num_tvs_def] +QED -Theorem tenv_val_exp_ok_bvl -`!tenvE env. +Theorem tenv_val_exp_ok_bvl: + !tenvE env. tenv_val_exp_ok tenvE ∧ EVERY (check_freevars (num_tvs tenvE) []) (MAP SND env) ⇒ - tenv_val_exp_ok (bind_var_list 0 env tenvE)` - (Induct_on `env` >> + tenv_val_exp_ok (bind_var_list 0 env tenvE) +Proof + Induct_on `env` >> srw_tac[][tenv_val_exp_ok_def, bind_var_list_def] >> PairCases_on `h` >> srw_tac[][tenv_val_exp_ok_def, bind_var_list_def] - >> fs []); + >> fs [] +QED -Theorem tveLookup_subst_some - `∀n e targs tvs t inc. +Theorem tveLookup_subst_some: + ∀n e targs tvs t inc. tveLookup n inc e = SOME (tvs,t) ⇒ tveLookup n inc (deBruijn_subst_tenvE targs e) = - SOME (tvs, deBruijn_subst (tvs+inc+num_tvs e) (MAP (deBruijn_inc 0 (tvs+inc+num_tvs e)) targs) t)` - (induct_on `e` >> + SOME (tvs, deBruijn_subst (tvs+inc+num_tvs e) (MAP (deBruijn_inc 0 (tvs+inc+num_tvs e)) targs) t) +Proof + induct_on `e` >> srw_tac[][tveLookup_def,deBruijn_subst_tenvE_def, deBruijn_inc_def, num_tvs_def, type_e_subst_lem5] - >> metis_tac [arithmeticTheory.ADD_ASSOC]); + >> metis_tac [arithmeticTheory.ADD_ASSOC] +QED -Theorem num_tvs_db_merge[simp] -`!e1 e2. num_tvs (db_merge e1 e2) = num_tvs e1 + num_tvs e2` -(induct_on `e1` >> +Theorem num_tvs_db_merge[simp]: + !e1 e2. num_tvs (db_merge e1 e2) = num_tvs e1 + num_tvs e2 +Proof +induct_on `e1` >> srw_tac[][num_tvs_def, db_merge_def] >> -decide_tac); - -Theorem num_tvs_deBruijn_subst_tenvE[simp] -`!targs tenvE. num_tvs (deBruijn_subst_tenvE targs tenvE) = num_tvs tenvE` -(induct_on `tenvE` >> -srw_tac[][deBruijn_subst_tenvE_def, num_tvs_def]); - -Theorem tveLookup_inc_some -`!n inc e tvs t inc2. +decide_tac +QED + +Theorem num_tvs_deBruijn_subst_tenvE[simp]: + !targs tenvE. num_tvs (deBruijn_subst_tenvE targs tenvE) = num_tvs tenvE +Proof +induct_on `tenvE` >> +srw_tac[][deBruijn_subst_tenvE_def, num_tvs_def] +QED + +Theorem tveLookup_inc_some: + !n inc e tvs t inc2. tveLookup n inc e = SOME (tvs, t) ⇒ ?t'. (t = deBruijn_inc tvs inc t') ∧ - (tveLookup n inc2 e = SOME (tvs, deBruijn_inc tvs inc2 t'))` -(induct_on `e` >> + (tveLookup n inc2 e = SOME (tvs, deBruijn_inc tvs inc2 t')) +Proof +induct_on `e` >> srw_tac[][deBruijn_inc_def, tveLookup_def] >> srw_tac[][] >> -metis_tac [deBruijn_inc_deBruijn_inc]); +metis_tac [deBruijn_inc_deBruijn_inc] +QED -Theorem tveLookup_add_inc -`!x inc tenv tvs t inc2. +Theorem tveLookup_add_inc: + !x inc tenv tvs t inc2. (tveLookup x inc tenv = SOME (tvs,t)) ⇒ - (tveLookup x (inc2 + inc) tenv = SOME (tvs, deBruijn_inc tvs inc2 t))` -(induct_on `tenv` >> + (tveLookup x (inc2 + inc) tenv = SOME (tvs, deBruijn_inc tvs inc2 t)) +Proof +induct_on `tenv` >> srw_tac[][tveLookup_def] >> srw_tac[][deBruijn_inc_deBruijn_inc] >> -metis_tac [arithmeticTheory.ADD_ASSOC]); +metis_tac [arithmeticTheory.ADD_ASSOC] +QED -Theorem tveLookup_freevars_subst - `!tenvE targs n t inc. +Theorem tveLookup_freevars_subst: + !tenvE targs n t inc. EVERY (check_freevars (inc + num_tvs tenvE) []) targs ∧ tveLookup n inc tenvE = SOME (LENGTH targs,t) ∧ tenv_val_exp_ok tenvE ⇒ - check_freevars (inc + num_tvs tenvE) [] (deBruijn_subst 0 targs t)` - (induct_on `tenvE` >> + check_freevars (inc + num_tvs tenvE) [] (deBruijn_subst 0 targs t) +Proof + induct_on `tenvE` >> rw [check_freevars_def, num_tvs_def, tveLookup_def, tenv_val_exp_ok_def] >> metis_tac [deBruijn_subst_check_freevars, arithmeticTheory.ADD_ASSOC, - check_freevars_subst_inc]); + check_freevars_subst_inc] +QED -Theorem tenv_val_exp_ok_db_merge -`!e1 e2. tenv_val_exp_ok (db_merge e1 e2) ⇒ tenv_val_exp_ok e2` -(induct_on `e1` >> -srw_tac[][tenv_val_exp_ok_def, db_merge_def]); +Theorem tenv_val_exp_ok_db_merge: + !e1 e2. tenv_val_exp_ok (db_merge e1 e2) ⇒ tenv_val_exp_ok e2 +Proof +induct_on `e1` >> +srw_tac[][tenv_val_exp_ok_def, db_merge_def] +QED val tveLookup_freevars = Q.prove ( `!e n inc t tvs. @@ -723,52 +827,60 @@ val tveLookup_freevars = Q.prove ( metis_tac [arithmeticTheory.ADD_ASSOC, arithmeticTheory.ADD_COMM], metis_tac []]); -Theorem tveLookup_no_tvs -`!tvs l tenv n t. +Theorem tveLookup_no_tvs: + !tvs l tenv n t. tenv_val_exp_ok tenv ∧ num_tvs tenv = 0 ⇒ (tveLookup n tvs tenv = SOME (l,t) ⇔ - tveLookup n 0 tenv = SOME (l,t))` -(induct_on `tenv` >> + tveLookup n 0 tenv = SOME (l,t)) +Proof +induct_on `tenv` >> srw_tac[][tveLookup_def, num_tvs_def, tenv_val_exp_ok_def] >> eq_tac >> srw_tac[][] >> full_simp_tac(srw_ss())[] >> -metis_tac [nil_deBruijn_inc, deBruijn_inc0]); +metis_tac [nil_deBruijn_inc, deBruijn_inc0] +QED -Theorem deBruijn_subst_E_bvl -`!tenv1 tenv2 tvs. +Theorem deBruijn_subst_E_bvl: + !tenv1 tenv2 tvs. deBruijn_subst_tenvE targs (bind_var_list tvs tenv1 tenv2) = bind_var_list tvs (MAP (\(x,t). (x, deBruijn_subst (tvs + num_tvs tenv2) (MAP (deBruijn_inc 0 (tvs + num_tvs tenv2)) targs) t)) tenv1) - (deBruijn_subst_tenvE targs tenv2)` -(induct_on `tenv1` >> + (deBruijn_subst_tenvE targs tenv2) +Proof +induct_on `tenv1` >> srw_tac[][bind_var_list_def] >> PairCases_on `h` >> -srw_tac[][bind_var_list_def, deBruijn_subst_tenvE_def]); +srw_tac[][bind_var_list_def, deBruijn_subst_tenvE_def] +QED -Theorem db_merge_bvl -`!tenv1 tenv2 tenv3 tvs. +Theorem db_merge_bvl: + !tenv1 tenv2 tenv3 tvs. db_merge (bind_var_list tvs tenv1 tenv2) tenv3 = - bind_var_list tvs tenv1 (db_merge tenv2 tenv3)` -(induct_on `tenv1` >> + bind_var_list tvs tenv1 (db_merge tenv2 tenv3) +Proof +induct_on `tenv1` >> srw_tac[][bind_var_list_def] >> PairCases_on `h` >> -srw_tac[][bind_var_list_def, db_merge_def]); +srw_tac[][bind_var_list_def, db_merge_def] +QED -Theorem tveLookup_db_merge_some - `!n inc tenvE1 tenvE2 tvs t. +Theorem tveLookup_db_merge_some: + !n inc tenvE1 tenvE2 tvs t. tveLookup n inc (db_merge tenvE1 tenvE2) = SOME (tvs,t) ⇔ tveLookup n inc tenvE1 = SOME (tvs,t) ∨ (tveLookup n inc tenvE1 = NONE ∧ - tveLookup n (num_tvs tenvE1 + inc) tenvE2 = SOME (tvs, t))` - (Induct_on `tenvE1` - >> rw [db_merge_def, tveLookup_def]); + tveLookup n (num_tvs tenvE1 + inc) tenvE2 = SOME (tvs, t)) +Proof + Induct_on `tenvE1` + >> rw [db_merge_def, tveLookup_def] +QED (* ---------- type_op ---------- *) @@ -789,29 +901,33 @@ val type_op_cases = save_thm("type_op_cases", (* ---------- type_p ---------- *) -Theorem type_ps_length -`∀tvs tenvC ps ts tenv. - type_ps tvs tenvC ps ts tenv ⇒ (LENGTH ps = LENGTH ts)` -(induct_on `ps` >> +Theorem type_ps_length: + ∀tvs tenvC ps ts tenv. + type_ps tvs tenvC ps ts tenv ⇒ (LENGTH ps = LENGTH ts) +Proof +induct_on `ps` >> srw_tac[][Once type_p_cases] >> srw_tac[][] >> -metis_tac []); +metis_tac [] +QED -Theorem type_p_freevars -`(!tvs tenvC p t env'. +Theorem type_p_freevars: + (!tvs tenvC p t env'. type_p tvs tenvC p t env' ⇒ check_freevars tvs [] t ∧ EVERY (check_freevars tvs []) (MAP SND env')) ∧ (!tvs tenvC ps ts env'. type_ps tvs tenvC ps ts env' ⇒ EVERY (check_freevars tvs []) ts ∧ - EVERY (check_freevars tvs []) (MAP SND env'))` -(ho_match_mp_tac type_p_ind >> + EVERY (check_freevars tvs []) (MAP SND env')) +Proof +ho_match_mp_tac type_p_ind >> srw_tac[][check_freevars_def, bind_tvar_def, bind_var_list_def] >> -metis_tac []); +metis_tac [] +QED -Theorem type_p_subst -`(!n tenv p t new_bindings. type_p n tenv p t new_bindings ⇒ +Theorem type_p_subst: + (!n tenv p t new_bindings. type_p n tenv p t new_bindings ⇒ !targs' inc tvs targs. tenv_abbrev_ok tenv.t ∧ tenv_ctor_ok tenv.c ∧ @@ -834,8 +950,9 @@ Theorem type_p_subst type_ps (inc + tvs) tenv ps (MAP (deBruijn_subst inc targs') ts) - (MAP (\(x,t). (x, deBruijn_subst inc targs' t)) new_bindings))` - (ho_match_mp_tac type_p_strongind >> + (MAP (\(x,t). (x, deBruijn_subst inc targs' t)) new_bindings)) +Proof + ho_match_mp_tac type_p_strongind >> srw_tac[][] >> ONCE_REWRITE_TAC [type_p_cases] >> simp [deBruijn_subst_def, OPTION_MAP_DEF] @@ -854,83 +971,98 @@ Theorem type_p_subst `! n:num . n ≥ 0` by decide_tac >> rw []) >> metis_tac []) - >- metis_tac []); + >- metis_tac [] +QED -Theorem type_p_bvl - `(!tvs tenvC p t bindings. type_p tvs tenvC p t bindings ⇒ +Theorem type_p_bvl: + (!tvs tenvC p t bindings. type_p tvs tenvC p t bindings ⇒ !tenv'. tenv_val_exp_ok tenv' ⇒ tenv_val_exp_ok (bind_var_list tvs bindings tenv')) ∧ (!tvs tenvC ps ts bindings. type_ps tvs tenvC ps ts bindings ⇒ - !tenv'. tenv_val_exp_ok tenv' ⇒ tenv_val_exp_ok (bind_var_list tvs bindings tenv'))` - (ho_match_mp_tac type_p_ind >> + !tenv'. tenv_val_exp_ok tenv' ⇒ tenv_val_exp_ok (bind_var_list tvs bindings tenv')) +Proof + ho_match_mp_tac type_p_ind >> srw_tac[][bind_var_list_def, tenv_val_exp_ok_def, num_tvs_def, bind_var_list_append] >> `tvs + num_tvs tenv' ≥ tvs` by decide_tac >> - metis_tac [check_freevars_add]); + metis_tac [check_freevars_add] +QED -Theorem type_p_tenvV_indep -`(!p tvs tenv t bindings tenvV. +Theorem type_p_tenvV_indep: + (!p tvs tenv t bindings tenvV. type_p tvs tenv p t bindings = type_p tvs (tenv with v := tenvV) p t bindings) ∧ (!ps tvs tenv t bindings tenvV. - type_ps tvs tenv ps t bindings = type_ps tvs (tenv with v := tenvV) ps t bindings)` - (Induct >> + type_ps tvs tenv ps t bindings = type_ps tvs (tenv with v := tenvV) ps t bindings) +Proof + Induct >> rw [] >> ONCE_REWRITE_TAC [type_p_cases] >> simp [] >> - metis_tac []); + metis_tac [] +QED (* ---------- type_e, type_es, type_funs ---------- *) -Theorem type_es_list_rel -`!es ts tenv tenvE. type_es tenv tenvE es ts = LIST_REL (type_e tenv tenvE) es ts` - (induct_on `es` >> +Theorem type_es_list_rel: + !es ts tenv tenvE. type_es tenv tenvE es ts = LIST_REL (type_e tenv tenvE) es ts +Proof + induct_on `es` >> srw_tac[][] >> - srw_tac[][Once type_e_cases]); - -Theorem type_es_length -`∀tenv tenvE es ts. - type_es tenv tenvE es ts ⇒ (LENGTH es = LENGTH ts)` -(induct_on `es` >> + srw_tac[][Once type_e_cases] +QED + +Theorem type_es_length: + ∀tenv tenvE es ts. + type_es tenv tenvE es ts ⇒ (LENGTH es = LENGTH ts) +Proof +induct_on `es` >> srw_tac[][Once type_e_cases] >> srw_tac[][] >> -metis_tac []); +metis_tac [] +QED -Theorem type_funs_MAP_FST -`!funs tenv tenvE env. +Theorem type_funs_MAP_FST: + !funs tenv tenvE env. type_funs tenv tenvE funs env ⇒ - MAP FST funs = MAP FST env` - (Induct>>srw_tac[][]>> + MAP FST funs = MAP FST env +Proof + Induct>>srw_tac[][]>> pop_assum (ASSUME_TAC o SIMP_RULE (srw_ss()) [Once type_e_cases]) >> - full_simp_tac(srw_ss())[]>>metis_tac[]) + full_simp_tac(srw_ss())[]>>metis_tac[] +QED -Theorem tenv_val_exp_ok_bvl_tvs - `!funs tenv env tvs bindings tenvE. +Theorem tenv_val_exp_ok_bvl_tvs: + !funs tenv env tvs bindings tenvE. type_funs tenv (bind_var_list 0 bindings (bind_tvar tvs tenvE)) funs env ∧ tenv_val_exp_ok tenvE ⇒ - tenv_val_exp_ok (bind_var_list tvs env tenvE)` - (induct_on `funs` + tenv_val_exp_ok (bind_var_list tvs env tenvE) +Proof + induct_on `funs` >> rw [] >> qpat_x_assum `type_funs _ _ _ _` mp_tac >> simp [Once type_e_cases] >> rw [check_freevars_def] >> rw [check_freevars_def, bind_var_list_def, tenv_val_exp_ok_def] - >> metis_tac []); + >> metis_tac [] +QED -Theorem tenv_val_exp_ok_bvl_funs - `!funs env tenv bindings tenv_val tenvE. +Theorem tenv_val_exp_ok_bvl_funs: + !funs env tenv bindings tenv_val tenvE. type_funs tenv (bind_var_list 0 bindings tenvE) funs env ∧ tenv_val_exp_ok tenvE ⇒ - tenv_val_exp_ok (bind_var_list 0 env tenvE)` - (induct_on `funs` + tenv_val_exp_ok (bind_var_list 0 env tenvE) +Proof + induct_on `funs` >> rw [] >> qpat_x_assum `type_funs _ _ _ _` mp_tac >> simp [Once type_e_cases] >> rw [check_freevars_def] >> rw [check_freevars_def, bind_var_list_def, tenv_val_exp_ok_def] - >> metis_tac []); + >> metis_tac [] +QED -Theorem type_e_freevars -`(!tenv tenvE e t. +Theorem type_e_freevars: + (!tenv tenvE e t. type_e tenv tenvE e t ⇒ tenv_val_exp_ok tenvE ∧ tenv_val_ok tenv.v ⇒ check_freevars (num_tvs tenvE) [] t) ∧ @@ -941,8 +1073,9 @@ Theorem type_e_freevars (!tenv tenvE funs env. type_funs tenv tenvE funs env ⇒ tenv_val_exp_ok tenvE ∧ tenv_val_ok tenv.v ⇒ - EVERY (check_freevars (num_tvs tenvE) []) (MAP SND env))` - (ho_match_mp_tac type_e_strongind >> + EVERY (check_freevars (num_tvs tenvE) []) (MAP SND env)) +Proof + ho_match_mp_tac type_e_strongind >> srw_tac[][check_freevars_def, num_tvs_def, type_op_cases, tenv_val_ok_def, bind_tvar_def, bind_var_list_def, opt_bind_name_def] >> full_simp_tac(srw_ss())[check_freevars_def] @@ -975,10 +1108,11 @@ Theorem type_e_freevars >> metis_tac [pair_CASES, type_p_freevars, tenv_val_exp_ok_bvl]) >- (every_case_tac >> fs [num_tvs_def, tenv_val_exp_ok_def]) - >- metis_tac [tenv_val_exp_ok_bvl_funs, num_tvs_bind_var_list]); + >- metis_tac [tenv_val_exp_ok_bvl_funs, num_tvs_bind_var_list] +QED -Theorem type_e_subst -`(!tenv tenvE e t. type_e tenv tenvE e t ⇒ +Theorem type_e_subst: + (!tenv tenvE e t. type_e tenv tenvE e t ⇒ !tenvE1 targs tvs targs'. num_tvs tenvE2 = 0 ∧ tenv_abbrev_ok tenv.t ∧ @@ -1019,8 +1153,9 @@ Theorem type_e_subst ⇒ type_funs tenv (db_merge (deBruijn_subst_tenvE targs tenvE1) (bind_tvar tvs tenvE2)) funs - (MAP (\(x,t). (x, deBruijn_subst (num_tvs tenvE1) targs' t)) env))` - (ho_match_mp_tac type_e_strongind >> + (MAP (\(x,t). (x, deBruijn_subst (num_tvs tenvE1) targs' t)) env)) +Proof + ho_match_mp_tac type_e_strongind >> srw_tac[][] >> ONCE_REWRITE_TAC [type_e_cases] >> srw_tac[][deBruijn_subst_def, deBruijn_subst_tenvE_def, opt_bind_name_def, @@ -1335,16 +1470,18 @@ Theorem type_e_subst full_simp_tac(srw_ss())[] >> srw_tac[][] >> full_simp_tac(srw_ss())[] >> - metis_tac [mem_exists_set])); + metis_tac [mem_exists_set]) +QED (* Recursive functions have function type *) -Theorem type_funs_Tfn - `∀tenv tenvE funs bindings tvs t n. +Theorem type_funs_Tfn: + ∀tenv tenvE funs bindings tvs t n. type_funs tenv tenvE funs bindings ∧ ALOOKUP bindings n = SOME t ⇒ - ∃t1 t2. (t = Tfn t1 t2) ∧ check_freevars (num_tvs tenvE) [] (Tfn t1 t2)` - (induct_on `funs` + ∃t1 t2. (t = Tfn t1 t2) ∧ check_freevars (num_tvs tenvE) [] (Tfn t1 t2) +Proof + induct_on `funs` >> rw [] >> qpat_x_assum `type_funs _ _ _ _` mp_tac >> simp [Once type_e_cases] @@ -1352,47 +1489,53 @@ Theorem type_funs_Tfn >> fs [] >> every_case_tac >> fs [deBruijn_subst_def, check_freevars_def] - >>metis_tac [type_e_freevars, num_tvs_def]); + >>metis_tac [type_e_freevars, num_tvs_def] +QED (* Recursive functions can be looked up in the execution environment. *) -Theorem type_funs_lookup -`∀fn tenvE funs bindings n e tenv. +Theorem type_funs_lookup: + ∀fn tenvE funs bindings n e tenv. MEM (fn,n,e) funs ∧ type_funs tenv tenvE funs bindings ⇒ - (∃t. ALOOKUP bindings fn = SOME t)` -(Induct_on `funs` >> + (∃t. ALOOKUP bindings fn = SOME t) +Proof +Induct_on `funs` >> srw_tac[][] >> pop_assum (ASSUME_TAC o SIMP_RULE (srw_ss()) [Once type_e_cases]) >> full_simp_tac(srw_ss())[] >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> -metis_tac []); +metis_tac [] +QED (* Functions in the type environment can be found *) -Theorem type_funs_find_recfun -`∀fn env funs bindings e tenv tenvE t. +Theorem type_funs_find_recfun: + ∀fn env funs bindings e tenv tenvE t. ALOOKUP bindings fn = SOME t ∧ type_funs tenv tenvE funs bindings ⇒ - (∃n e. find_recfun fn funs = SOME (n,e))` -(Induct_on `funs` >> + (∃n e. find_recfun fn funs = SOME (n,e)) +Proof +Induct_on `funs` >> srw_tac[][] >> pop_assum (ASSUME_TAC o SIMP_RULE (srw_ss()) [Once type_e_cases]) >> full_simp_tac(srw_ss())[] >> full_simp_tac(srw_ss())[] >> srw_tac[][Once find_recfun_def] >> -metis_tac []); +metis_tac [] +QED -Theorem type_recfun_lookup - `∀fn funs n e tenv tenvE bindings tvs t1 t2. +Theorem type_recfun_lookup: + ∀fn funs n e tenv tenvE bindings tvs t1 t2. find_recfun fn funs = SOME (n,e) ∧ type_funs tenv tenvE funs bindings ∧ ALOOKUP bindings fn = SOME (Tfn t1 t2) ⇒ type_e tenv (Bind_name n 0 t1 tenvE) e t2 ∧ - check_freevars (num_tvs tenvE) [] (Tfn t1 t2)` - (induct_on `funs` + check_freevars (num_tvs tenvE) [] (Tfn t1 t2) +Proof + induct_on `funs` >> rw [Once find_recfun_def] >> qpat_x_assum `type_funs _ _ _ _` mp_tac >> simp [Once type_e_cases] @@ -1401,15 +1544,17 @@ Theorem type_recfun_lookup >> every_case_tac >> fs [] >> rw [] - >> metis_tac []); + >> metis_tac [] +QED (* No duplicate function definitions in a single let rec *) -Theorem type_funs_distinct -`∀tenv tenvE funs bindings . +Theorem type_funs_distinct: + ∀tenv tenvE funs bindings . type_funs tenv tenvE funs bindings ⇒ - ALL_DISTINCT (MAP (λ(x,y,z). x) funs)` -(induct_on `funs` >> + ALL_DISTINCT (MAP (λ(x,y,z). x) funs) +Proof +induct_on `funs` >> srw_tac[][] >> pop_assum (ASSUME_TAC o SIMP_RULE (srw_ss()) [Once type_e_cases]) >> full_simp_tac(srw_ss())[] >> @@ -1420,22 +1565,25 @@ srw_tac[][MEM_MAP] >| full_simp_tac(srw_ss())[] >> srw_tac[][] >> metis_tac [type_funs_lookup, optionTheory.NOT_SOME_NONE], - metis_tac []]); + metis_tac []] +QED -Theorem type_funs_tenv_exp_ok - `!funs env tenv tenvE tvs bindings. +Theorem type_funs_tenv_exp_ok: + !funs env tenv tenvE tvs bindings. num_tvs tenvE = 0 ∧ type_funs tenv (bind_var_list 0 bindings (bind_tvar tvs tenvE)) funs env ⇒ - tenv_val_exp_ok (bind_var_list tvs env Empty)` - (induct_on `funs` + tenv_val_exp_ok (bind_var_list tvs env Empty) +Proof + induct_on `funs` >> rw [] >> pop_assum mp_tac >> simp [Once type_e_cases] >> rw [bind_var_list_def, tenv_val_exp_ok_def] >> rw [bind_var_list_def, tenv_val_exp_ok_def] >> first_x_assum irule - >> metis_tac []); + >> metis_tac [] +QED val type_e_subst_lem = Q.prove ( `∀tenv tenvE e t targs tvs targs'. @@ -1459,14 +1607,16 @@ val type_e_subst_lem = Q.prove ( (* (* ---------- tid_exn_to_tc ---------- *) -Theorem tid_exn_to_tc_11 -`!x y. (tid_exn_to_tc x = tid_exn_to_tc y) = same_tid x y` -(cases_on `x` >> +Theorem tid_exn_to_tc_11: + !x y. (tid_exn_to_tc x = tid_exn_to_tc y) = same_tid x y +Proof +cases_on `x` >> cases_on `y` >> -srw_tac[][tid_exn_to_tc_def, same_tid_def]); +srw_tac[][tid_exn_to_tc_def, same_tid_def] +QED -Theorem tid_exn_not -`(!tn. tid_exn_to_tc tn ≠ TC_int) ∧ +Theorem tid_exn_not: + (!tn. tid_exn_to_tc tn ≠ TC_int) ∧ (!tn. tid_exn_to_tc tn ≠ TC_char) ∧ (!tn. tid_exn_to_tc tn ≠ TC_string) ∧ (!tn. tid_exn_to_tc tn ≠ TC_ref) ∧ @@ -1477,12 +1627,14 @@ Theorem tid_exn_not (!tn wz. tid_exn_to_tc tn ≠ TC_word wz) ∧ (!tn. tid_exn_to_tc tn ≠ TC_word8array) ∧ (!tn. tid_exn_to_tc tn ≠ TC_vector) ∧ - (!tn. tid_exn_to_tc tn ≠ TC_array)` - (srw_tac[][] >> + (!tn. tid_exn_to_tc tn ≠ TC_array) +Proof + srw_tac[][] >> cases_on `tn` >> full_simp_tac(srw_ss())[tid_exn_to_tc_def] >> Cases_on`wz` \\ EVAL_TAC >> - metis_tac []); + metis_tac [] +QED *) (* ---------- ctMap stuff ---------- *) @@ -1497,32 +1649,35 @@ val type_def_to_ctMap_def = Define ` (TypeStamp cn next_stamp, (tvs, MAP (type_name_subst tenvT) ts, id))) ctors))`; -Theorem mem_type_def_to_ctMap - `!tenvT next tds ids stamp x. +Theorem mem_type_def_to_ctMap: + !tenvT next tds ids stamp x. MEM (stamp,x) (type_def_to_ctMap tenvT next tds ids) ∧ LENGTH tds = LENGTH ids ⇒ - ?cn i. stamp = TypeStamp cn i ∧ next ≤ i ∧ i < next + LENGTH tds` - (ho_match_mp_tac (theorem "type_def_to_ctMap_ind") >> + ?cn i. stamp = TypeStamp cn i ∧ next ≤ i ∧ i < next + LENGTH tds +Proof + ho_match_mp_tac (theorem "type_def_to_ctMap_ind") >> rw [type_def_to_ctMap_def] >> fs [] >> res_tac >> rw [] >> fs [MEM_MAP] >> pairarg_tac >> - fs []); + fs [] +QED val o_f_FRANGE2 = Q.prove ( `(?x. y = f x ∧ x ∈ FRANGE g) ⇒ y ∈ FRANGE (f o_f g)`, rw [FRANGE_DEF] >> metis_tac [o_f_FAPPLY]); -Theorem ctMap_ok_merge_imp - `!ctMap1 ctMap2. +Theorem ctMap_ok_merge_imp: + !ctMap1 ctMap2. DISJOINT (FRANGE ((SND o SND) o_f ctMap1)) (FRANGE ((SND o SND) o_f ctMap2)) ∧ ctMap_ok ctMap1 ∧ ctMap_ok ctMap2 ⇒ - ctMap_ok (FUNION ctMap1 ctMap2)` - (REWRITE_TAC [ctMap_ok_def] >> + ctMap_ok (FUNION ctMap1 ctMap2) +Proof + REWRITE_TAC [ctMap_ok_def] >> rpt gen_tac >> strip_tac >> rpt conj_tac @@ -1567,24 +1722,28 @@ Theorem ctMap_ok_merge_imp simp []) >> fs [DISJOINT_DEF, EXTENSION] >> metis_tac []) - >- metis_tac [])); + >- metis_tac []) +QED -Theorem ctMap_ok_lookup -`!ctMap cn tvs ts ti tn. +Theorem ctMap_ok_lookup: + !ctMap cn tvs ts ti tn. ctMap_ok ctMap ∧ (FLOOKUP ctMap tn = SOME (tvs,ts,ti)) ⇒ - EVERY (check_freevars 0 tvs) ts` - (srw_tac[][ctMap_ok_def, FEVERY_ALL_FLOOKUP] >> + EVERY (check_freevars 0 tvs) ts +Proof + srw_tac[][ctMap_ok_def, FEVERY_ALL_FLOOKUP] >> res_tac >> - full_simp_tac(srw_ss())[]); + full_simp_tac(srw_ss())[] +QED -Theorem type_def_to_ctMap_mem - `!tenvT next tds tids. +Theorem type_def_to_ctMap_mem: + !tenvT next tds tids. ALOOKUP (type_def_to_ctMap tenvT next tds tids) k = SOME x ∧ LENGTH tds = LENGTH tids ⇒ - MEM (SND (SND x)) tids` - (ho_match_mp_tac (theorem "type_def_to_ctMap_ind") >> + MEM (SND (SND x)) tids +Proof + ho_match_mp_tac (theorem "type_def_to_ctMap_ind") >> rw [type_def_to_ctMap_def] >> fs [ALOOKUP_APPEND] >> every_case_tac >> @@ -1592,15 +1751,16 @@ Theorem type_def_to_ctMap_mem drule ALOOKUP_MEM >> rw [MEM_MAP] >> pairarg_tac >> - fs []); + fs [] +QED val fupdate2_union = Q.prove ( `!m a1 a2. m |++ a1 |++ a2 = FEMPTY |++ a2 ⊌ (m |++ a1)`, rw [FLOOKUP_EXT, FUN_EQ_THM, FLOOKUP_FUNION, flookup_fupdate_list] >> every_case_tac); -Theorem ctMap_ok_type_defs - `!tenvT next tds tids. +Theorem ctMap_ok_type_defs: + !tenvT next tds tids. ALL_DISTINCT tids ∧ DISJOINT (set tids) (set prim_type_nums) ∧ LENGTH tds = LENGTH tids ∧ @@ -1609,8 +1769,9 @@ Theorem ctMap_ok_type_defs ⇒ ctMap_ok (FEMPTY |++ - REVERSE (type_def_to_ctMap tenvT next tds tids))` - (ho_match_mp_tac (theorem "type_def_to_ctMap_ind") >> + REVERSE (type_def_to_ctMap tenvT next tds tids)) +Proof + ho_match_mp_tac (theorem "type_def_to_ctMap_ind") >> rw [type_def_to_ctMap_def, check_ctor_tenv_def] >- rw [ctMap_ok_def, flookup_fupdate_list, FEVERY_FUPDATE_LIST, FEVERY_FEMPTY] >> fs [REVERSE_APPEND, FUPDATE_LIST_APPEND, fupdate2_union] >> @@ -1673,13 +1834,15 @@ Theorem ctMap_ok_type_defs imp_res_tac ALOOKUP_MEM >> fs [MEM_MAP] >> pairarg_tac >> - fs [])); + fs []) +QED (* -Theorem ctMap_ok_type_decs - `!mn tds. tenv_abbrev_ok tenvT ∧ check_ctor_tenv tenvT tds ⇒ ctMap_ok (type_decs_to_ctMap mn tenvT tds)` - (rw [check_ctor_tenv_def, ctMap_ok_def, type_decs_to_ctMap_def, FEVERY_ALL_FLOOKUP, FUPDATE_LIST_alist_to_fmap] +Theorem ctMap_ok_type_decs: + !mn tds. tenv_abbrev_ok tenvT ∧ check_ctor_tenv tenvT tds ⇒ ctMap_ok (type_decs_to_ctMap mn tenvT tds) +Proof + rw [check_ctor_tenv_def, ctMap_ok_def, type_decs_to_ctMap_def, FEVERY_ALL_FLOOKUP, FUPDATE_LIST_alist_to_fmap] >> drule ALOOKUP_MEM >> simp [MEM_FLAT, MEM_MAP] >> pairarg_tac @@ -1702,42 +1865,48 @@ Theorem ctMap_ok_type_decs >> fs [] >> rw [] >> fs [MEM_MAP] - >> metis_tac [check_freevars_type_name_subst]); + >> metis_tac [check_freevars_type_name_subst] +QED -Theorem consistent_ctMap_union - `!tdecs1 tdecs2 ctMap1 ctMap2. +Theorem consistent_ctMap_union: + !tdecs1 tdecs2 ctMap1 ctMap2. consistent_ctMap tdecs1 ctMap1 ∧ consistent_ctMap tdecs2 ctMap2 ⇒ - consistent_ctMap (union_decls tdecs1 tdecs2) (FUNION ctMap1 ctMap2)` - (rw [consistent_ctMap_def, RES_FORALL] + consistent_ctMap (union_decls tdecs1 tdecs2) (FUNION ctMap1 ctMap2) +Proof + rw [consistent_ctMap_def, RES_FORALL] >> pairarg_tac >> fs [] >> CASE_TAC >> fs [union_decls_def] >> first_x_assum drule - >> simp []); + >> simp [] +QED -Theorem consistent_ctMap_union2 - `!tdecs1 tdecs2 ctMap. +Theorem consistent_ctMap_union2: + !tdecs1 tdecs2 ctMap. consistent_ctMap tdecs2 ctMap ⇒ - consistent_ctMap (union_decls tdecs1 tdecs2) ctMap` - (rw [consistent_ctMap_def, RES_FORALL] + consistent_ctMap (union_decls tdecs1 tdecs2) ctMap +Proof + rw [consistent_ctMap_def, RES_FORALL] >> pairarg_tac >> fs [] >> CASE_TAC >> fs [union_decls_def] >> first_x_assum drule - >> simp []); + >> simp [] +QED -Theorem consistent_ctMap_disjoint -`!mn (tds:type_def) (ctMap:ctMap) tdecs tabbrev. +Theorem consistent_ctMap_disjoint: + !mn (tds:type_def) (ctMap:ctMap) tdecs tabbrev. DISJOINT (set (MAP (λ(tvs,tn,ctors). mk_id mn tn) tds)) tdecs.defined_types ∧ consistent_ctMap tdecs ctMap ⇒ - DISJOINT (IMAGE SND (FDOM (type_decs_to_ctMap mn tabbrev tds))) (IMAGE SND (FDOM ctMap))` - (rw [consistent_ctMap_def, + DISJOINT (IMAGE SND (FDOM (type_decs_to_ctMap mn tabbrev tds))) (IMAGE SND (FDOM ctMap)) +Proof + rw [consistent_ctMap_def, type_decs_to_ctMap_def, RES_FORALL, FUPDATE_LIST_alist_to_fmap, DISJOINT_DEF, EXTENSION, MEM_MAP] >> rw [METIS_PROVE [] ``y ∨ x ⇔ ~y ⇒ x``] @@ -1756,7 +1925,8 @@ Theorem consistent_ctMap_disjoint >> rw [] >> fs [METIS_PROVE [] ``y ∨ x ⇔ ~y ⇒ x``, PULL_EXISTS] >> first_x_assum drule - >> simp []); + >> simp [] +QED *) val all_distinct_map_fst_lemma = Q.prove ( @@ -1815,147 +1985,172 @@ val check_ctor_tenv_type_decs_to_ctMap_lemma = Q.prove ( >> pairarg_tac >> fs [])); -Theorem check_ctor_tenv_type_decs_to_ctMap - `!tenvT tds mn tvs tn c cn ts. +Theorem check_ctor_tenv_type_decs_to_ctMap: + !tenvT tds mn tvs tn c cn ts. check_ctor_tenv tenvT tds ∧ MEM (tvs,tn,c) tds ∧ MEM (cn,ts) c ⇒ - FLOOKUP (type_decs_to_ctMap mn tenvT tds) (cn, TypeId (mk_id mn tn)) = SOME (tvs, MAP (type_name_subst tenvT) ts)` - (metis_tac [REVERSE_REVERSE, check_ctor_tenv_type_decs_to_ctMap_lemma]); + FLOOKUP (type_decs_to_ctMap mn tenvT tds) (cn, TypeId (mk_id mn tn)) = SOME (tvs, MAP (type_name_subst tenvT) ts) +Proof + metis_tac [REVERSE_REVERSE, check_ctor_tenv_type_decs_to_ctMap_lemma] +QED *) -Theorem check_ctor_tenv_change_tenvT - `∀tenvT1 env tenvT2. +Theorem check_ctor_tenv_change_tenvT: + ∀tenvT1 env tenvT2. EVERY (λ(cn,ts). EVERY (check_type_names tenvT1) ts ⇒ EVERY (check_type_names tenvT2) ts) (FLAT (MAP (SND o SND) env)) ∧ check_ctor_tenv tenvT1 env ⇒ - check_ctor_tenv tenvT2 env` - (recInduct check_ctor_tenv_ind + check_ctor_tenv tenvT2 env +Proof + recInduct check_ctor_tenv_ind \\ rw[check_ctor_tenv_def] \\ fs[EVERY_MEM, UNCURRY, MEM_FLAT, MEM_MAP, PULL_EXISTS] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem check_ctor_tenv_EVERY - `∀tenvT tds. +Theorem check_ctor_tenv_EVERY: + ∀tenvT tds. check_ctor_tenv tenvT tds ⇔ EVERY check_dup_ctors tds ∧ EVERY (ALL_DISTINCT o FST) tds ∧ EVERY (λ(tvs,tn,ctors). EVERY (λ(cn,ts). EVERY (check_freevars_ast tvs) ts ∧ EVERY (check_type_names tenvT) ts) ctors) tds ∧ - ALL_DISTINCT (MAP (FST o SND) tds)` - (recInduct check_ctor_tenv_ind + ALL_DISTINCT (MAP (FST o SND) tds) +Proof + recInduct check_ctor_tenv_ind \\ rw[check_ctor_tenv_def,LAMBDA_PROD] \\ rw[EQ_IMP_THM] - \\ fs[MEM_MAP,EXISTS_PROD]); + \\ fs[MEM_MAP,EXISTS_PROD] +QED (* ---------- consistent_decls ---------- *) (* -Theorem consistent_decls_union - `!defined_types1 defined_types2 tdecs1 tdecs2. +Theorem consistent_decls_union: + !defined_types1 defined_types2 tdecs1 tdecs2. consistent_decls defined_types1 tdecs1 ∧ consistent_decls defined_types2 tdecs2 ⇒ - consistent_decls (defined_types1 ∪ defined_types2) (union_decls tdecs1 tdecs2)` - (rw [consistent_decls_def, union_decls_def, RES_FORALL] + consistent_decls (defined_types1 ∪ defined_types2) (union_decls tdecs1 tdecs2) +Proof + rw [consistent_decls_def, union_decls_def, RES_FORALL] >> CASE_TAC >> fs [] >> first_x_assum drule >> rw [] - >> metis_tac []); + >> metis_tac [] +QED -Theorem consistent_decls_union2 - `!defined_types tdecs1 tdecs2. +Theorem consistent_decls_union2: + !defined_types tdecs1 tdecs2. consistent_decls defined_types tdecs2 ⇒ - consistent_decls defined_types (union_decls tdecs1 tdecs2)` - (rw [consistent_decls_def, union_decls_def, RES_FORALL] + consistent_decls defined_types (union_decls tdecs1 tdecs2) +Proof + rw [consistent_decls_def, union_decls_def, RES_FORALL] >> CASE_TAC >> fs [] >> first_x_assum drule >> rw [] - >> metis_tac []); + >> metis_tac [] +QED -Theorem consistent_decls_add_mod -`!decls d mn. +Theorem consistent_decls_add_mod: + !decls d mn. consistent_decls decls d ⇒ - consistent_decls decls (d with defined_mods := {mn} ∪ d.defined_mods)` - (srw_tac[][consistent_decls_def, RES_FORALL] >> + consistent_decls decls (d with defined_mods := {mn} ∪ d.defined_mods) +Proof + srw_tac[][consistent_decls_def, RES_FORALL] >> every_case_tac >> full_simp_tac(srw_ss())[] >> res_tac >> - full_simp_tac(srw_ss())[]); + full_simp_tac(srw_ss())[] +QED *) (* ---------- type_v ---------- *) -Theorem nsLookup_add_tenvE1 - `!tenvE tenvV n tvs t tvs2. +Theorem nsLookup_add_tenvE1: + !tenvE tenvV n tvs t tvs2. check_freevars tvs2 [] t ∧ tveLookup n tvs tenvE = SOME (tvs2,t) ⇒ - nsLookup (add_tenvE tenvE tenvV) (Short n) = SOME (tvs2,t)` - (Induct_on `tenvE` + nsLookup (add_tenvE tenvE tenvV) (Short n) = SOME (tvs2,t) +Proof + Induct_on `tenvE` >> rw [tveLookup_def, add_tenvE_def] >> fs [] - >> metis_tac [nil_deBruijn_inc]); + >> metis_tac [nil_deBruijn_inc] +QED -Theorem nsLookup_add_tenvE2 - `!tenvE tenvV n tvs t tvs2. +Theorem nsLookup_add_tenvE2: + !tenvE tenvV n tvs t tvs2. tveLookup n tvs tenvE = NONE ∧ nsLookup tenvV (Short n) = SOME (tvs2,t) ⇒ - nsLookup (add_tenvE tenvE tenvV) (Short n) = SOME (tvs2,t)` - (Induct_on `tenvE` + nsLookup (add_tenvE tenvE tenvV) (Short n) = SOME (tvs2,t) +Proof + Induct_on `tenvE` >> rw [tveLookup_def, add_tenvE_def] >> fs [] - >> metis_tac []); + >> metis_tac [] +QED -Theorem nsLookup_add_tenvE3 - `!tenvE tenvV n t tvs2 mn. +Theorem nsLookup_add_tenvE3: + !tenvE tenvV n t tvs2 mn. nsLookup tenvV (Long mn n) = SOME (tvs2,t) ⇒ - nsLookup (add_tenvE tenvE tenvV) (Long mn n) = SOME (tvs2,t)` - (Induct_on `tenvE` + nsLookup (add_tenvE tenvE tenvV) (Long mn n) = SOME (tvs2,t) +Proof + Induct_on `tenvE` >> rw [tveLookup_def, add_tenvE_def] >> fs [] - >> metis_tac []); + >> metis_tac [] +QED -Theorem tenv_val_ok_add_tenvE - `!tenvE tenvV. +Theorem tenv_val_ok_add_tenvE: + !tenvE tenvV. num_tvs tenvE = 0 ∧ tenv_val_exp_ok tenvE ∧ tenv_val_ok tenvV ⇒ - tenv_val_ok (add_tenvE tenvE tenvV)` - (Induct_on `tenvE` + tenv_val_ok (add_tenvE tenvE tenvV) +Proof + Induct_on `tenvE` >> rw [add_tenvE_def, tenv_val_exp_ok_def] >> fs [tenv_val_ok_def] >> irule nsAll_nsBind >> rw [] - >> rfs []); - -Theorem add_tenvE_nsAppend - `!tenvE tenvV. nsAppend (add_tenvE tenvE nsEmpty) tenvV = add_tenvE tenvE tenvV` - (Induct_on `tenvE` - >> rw [add_tenvE_def]); - -Theorem add_tenvE_bvl - `!n bindings tenvE tenvV. + >> rfs [] +QED + +Theorem add_tenvE_nsAppend: + !tenvE tenvV. nsAppend (add_tenvE tenvE nsEmpty) tenvV = add_tenvE tenvE tenvV +Proof + Induct_on `tenvE` + >> rw [add_tenvE_def] +QED + +Theorem add_tenvE_bvl: + !n bindings tenvE tenvV. add_tenvE (bind_var_list n bindings tenvE) tenvV = - nsBindList (MAP (\(x,t). (x, (n, t))) bindings) (add_tenvE tenvE tenvV)` - (Induct_on `bindings` + nsBindList (MAP (\(x,t). (x, (n, t))) bindings) (add_tenvE tenvE tenvV) +Proof + Induct_on `bindings` >> rw [bind_var_list_def, nsBindList_def] >> pairarg_tac >> rw [] >> pairarg_tac >> fs [] - >> rw [bind_var_list_def, add_tenvE_def, nsBindList_def]); + >> rw [bind_var_list_def, add_tenvE_def, nsBindList_def] +QED -Theorem type_v_freevars -`!tvs tenvC tenvS v t. type_v tvs tenvC tenvS v t ⇒ check_freevars tvs [] t` - (ho_match_mp_tac type_v_strongind >> +Theorem type_v_freevars: + !tvs tenvC tenvS v t. type_v tvs tenvC tenvS v t ⇒ check_freevars tvs [] t +Proof + ho_match_mp_tac type_v_strongind >> srw_tac[][check_freevars_def, tenv_val_ok_def, num_tvs_def, bind_tvar_def, Tchar_def] >- metis_tac [] >> res_tac @@ -1989,7 +2184,8 @@ Theorem type_v_freevars >- metis_tac [check_freevars_add, arithmeticTheory.ZERO_LESS_EQ, arithmeticTheory.GREATER_EQ] >- metis_tac [check_freevars_add, arithmeticTheory.ZERO_LESS_EQ, - arithmeticTheory.GREATER_EQ]); + arithmeticTheory.GREATER_EQ] +QED val remove_lambda_prod = Q.prove ( `(\(x,y). P x y) = (\xy. P (FST xy) (SND xy))`, @@ -2004,16 +2200,17 @@ val type_subst_lem1 = SIMP_RULE (srw_ss()) [GSYM RIGHT_FORALL_IMP_THM]) check_freevars_subst; -Theorem type_subst - `!tvs ctMap tenvS v t. +Theorem type_subst: + !tvs ctMap tenvS v t. type_v tvs ctMap tenvS v t ⇒ tvs = LENGTH targs ∧ ctMap_ok ctMap ∧ EVERY (check_freevars tvs' []) targs ∧ check_freevars (LENGTH targs) [] t ⇒ - type_v tvs' ctMap tenvS v (deBruijn_subst 0 targs t)` - (ho_match_mp_tac type_v_strongind + type_v tvs' ctMap tenvS v (deBruijn_subst 0 targs t) +Proof + ho_match_mp_tac type_v_strongind >> rw [] >> simp [Once type_v_cases, deBruijn_inc_def, deBruijn_subst_def] >> fs [check_freevars_def] @@ -2090,16 +2287,18 @@ Theorem type_subst >- simp [nil_deBruijn_subst, nil_deBruijn_inc] >- ( fs [EVERY_MEM] - >> simp [nil_deBruijn_subst, nil_deBruijn_inc])); + >> simp [nil_deBruijn_subst, nil_deBruijn_inc]) +QED -Theorem check_ctor_tenv_ok -`!tenvT tds tis. +Theorem check_ctor_tenv_ok: + !tenvT tds tis. LENGTH tds = LENGTH tis ∧ check_ctor_tenv tenvT tds ∧ tenv_abbrev_ok tenvT ⇒ - tenv_ctor_ok (build_ctor_tenv tenvT tds tis)` - (ho_match_mp_tac build_ctor_tenv_ind >> + tenv_ctor_ok (build_ctor_tenv tenvT tds tis) +Proof + ho_match_mp_tac build_ctor_tenv_ind >> rw [build_ctor_tenv_def, tenv_ctor_ok_def, check_ctor_tenv_def] >> irule nsAll_nsAppend >> simp [] @@ -2120,17 +2319,19 @@ Theorem check_ctor_tenv_ok rw [] >> fs [MEM_MAP] >> irule check_freevars_type_name_subst - >> simp []); + >> simp [] +QED -Theorem nsMap_build_ctor_tenv - `∀ga g h tenvT tds ids. +Theorem nsMap_build_ctor_tenv: + ∀ga g h tenvT tds ids. LENGTH tds = LENGTH ids ∧ (∀x. MEM x (MAP SND (FLAT (MAP (SND o SND) tds))) ⇒ MAP (type_name_subst tenvT) (ga x) = (g (MAP (type_name_subst tenvT) x))) ⇒ nsMap (λ(tvs,ts,tid). (tvs, g ts, h tid)) (build_ctor_tenv tenvT tds ids) = - build_ctor_tenv tenvT (MAP (I ## I ## MAP (I ## ga)) tds) (MAP h ids)` - (ntac 3 gen_tac + build_ctor_tenv tenvT (MAP (I ## I ## MAP (I ## ga)) tds) (MAP h ids) +Proof + ntac 3 gen_tac \\ recInduct build_ctor_tenv_ind \\ rw[build_ctor_tenv_def] \\ rw[nsMap_nsAppend, MAP_REVERSE, MAP_MAP_o, o_DEF, UNCURRY, LAMBDA_PROD] @@ -2142,51 +2343,58 @@ Theorem nsMap_build_ctor_tenv \\ match_mp_tac EQ_SYM \\ first_x_assum irule \\ rw[MEM_MAP,EXISTS_PROD] - \\ metis_tac[]); + \\ metis_tac[] +QED (* (* --------- decls_ok ------------ *) -Theorem decls_ok_union - `∀d1 d2. +Theorem decls_ok_union: + ∀d1 d2. decls_ok d1 ∧ decls_ok d2 ⇒ - decls_ok (union_decls d1 d2)` - (rw [decls_ok_def, union_decls_def, SUBSET_DEF, decls_to_mods_def, GSPECIFICATION] + decls_ok (union_decls d1 d2) +Proof + rw [decls_ok_def, union_decls_def, SUBSET_DEF, decls_to_mods_def, GSPECIFICATION] >> full_simp_tac (srw_ss()++DNF_ss) [] - >> metis_tac []); + >> metis_tac [] +QED *) (* ---------- type_d ---------- *) -Theorem type_d_check_uniq -`(!check tenv d tdecs new_tenv. +Theorem type_d_check_uniq: + (!check tenv d tdecs new_tenv. type_d check tenv d tdecs new_tenv ⇒ type_d F tenv d tdecs new_tenv) ∧ (!check tenv d tdecs new_tenv. type_ds check tenv d tdecs new_tenv ⇒ - type_ds F tenv d tdecs new_tenv)` - (ho_match_mp_tac type_d_ind >> + type_ds F tenv d tdecs new_tenv) +Proof + ho_match_mp_tac type_d_ind >> rw [] >> simp [Once type_d_cases] >> - metis_tac []); + metis_tac [] +QED -Theorem extend_dec_tenv_ok - `!tenv tenv'. tenv_ok tenv ∧ tenv_ok tenv' ⇒ tenv_ok (extend_dec_tenv tenv tenv')` - (rw [extend_dec_tenv_def, tenv_ok_def] +Theorem extend_dec_tenv_ok: + !tenv tenv'. tenv_ok tenv ∧ tenv_ok tenv' ⇒ tenv_ok (extend_dec_tenv tenv tenv') +Proof + rw [extend_dec_tenv_def, tenv_ok_def] >- ( fs [tenv_val_ok_def] >> irule nsAll_nsAppend >> simp []) >> fs [tenv_abbrev_ok_def] >> irule nsAll_nsAppend - >> simp []); + >> simp [] +QED -Theorem type_d_tenv_ok_helper - `(∀check tenv d tdecs tenv'. +Theorem type_d_tenv_ok_helper: + (∀check tenv d tdecs tenv'. type_d check tenv d tdecs tenv' ⇒ tenv_ok tenv ⇒ @@ -2195,8 +2403,9 @@ Theorem type_d_tenv_ok_helper type_ds check tenv d tdecs tenv' ⇒ tenv_ok tenv ⇒ - tenv_ok tenv')` - (ho_match_mp_tac type_d_ind >> + tenv_ok tenv') +Proof + ho_match_mp_tac type_d_ind >> rw [tenv_ctor_ok_def, tenvLift_def] >- ( fs [tenv_ok_def] >> @@ -2271,24 +2480,28 @@ Theorem type_d_tenv_ok_helper >> simp [tenv_abbrev_ok_def]) >- fs [tenv_ok_def, tenv_val_ok_def, tenv_ctor_ok_def, tenv_abbrev_ok_def] >- metis_tac [extend_dec_tenv_ok] - >- metis_tac [extend_dec_tenv_ok]); + >- metis_tac [extend_dec_tenv_ok] +QED -Theorem type_d_tenv_ok - `∀check tenv d tdecs tenv'. +Theorem type_d_tenv_ok: + ∀check tenv d tdecs tenv'. type_d check tenv d tdecs tenv' ∧ tenv_ok tenv ⇒ - tenv_ok (extend_dec_tenv tenv' tenv)` - (metis_tac [extend_dec_tenv_ok, type_d_tenv_ok_helper]); + tenv_ok (extend_dec_tenv tenv' tenv) +Proof + metis_tac [extend_dec_tenv_ok, type_d_tenv_ok_helper] +QED (* -Theorem type_d_mod -`!uniq mn tdecs tenv d tdecs' new_tenv. +Theorem type_d_mod: + !uniq mn tdecs tenv d tdecs' new_tenv. type_d uniq mn tdecs tenv d tdecs' new_tenv ⇒ tdecs'.defined_mods = {} ∧ - decls_to_mods tdecs' ⊆ { mn }` - (srw_tac[][type_d_cases, decls_to_mods_def, SUBSET_DEF, FDOM_FUPDATE_LIST] >> + decls_to_mods tdecs' ⊆ { mn } +Proof + srw_tac[][type_d_cases, decls_to_mods_def, SUBSET_DEF, FDOM_FUPDATE_LIST] >> full_simp_tac(srw_ss())[build_ctor_tenv_def, MEM_FLAT, MEM_MAP] >> srw_tac[][empty_decls_def] >> every_case_tac >> @@ -2296,34 +2509,40 @@ Theorem type_d_mod every_case_tac >> full_simp_tac(srw_ss())[GSPECIFICATION] >> TRY (PairCases_on `y`) >> - full_simp_tac(srw_ss())[]); + full_simp_tac(srw_ss())[] +QED *) (* ---------- type_ds ---------- *) -Theorem type_ds_empty[simp] - `!check tenv decls r. +Theorem type_ds_empty[simp]: + !check tenv decls r. type_ds check tenv [] decls r ⇔ - decls = {} ∧ r = <| v := nsEmpty; c:= nsEmpty; t := nsEmpty |>` - (rw [Once type_d_cases]); - -Theorem type_ds_sing[simp] - `!check tenv d decls r. - type_ds check tenv [d] decls r ⇔ type_d check tenv d decls r` - (simp [Once type_d_cases] + decls = {} ∧ r = <| v := nsEmpty; c:= nsEmpty; t := nsEmpty |> +Proof + rw [Once type_d_cases] +QED + +Theorem type_ds_sing[simp]: + !check tenv d decls r. + type_ds check tenv [d] decls r ⇔ type_d check tenv d decls r +Proof + simp [Once type_d_cases] >> rw [extend_dec_tenv_def, type_env_component_equality] >> eq_tac >> rw [] - >> metis_tac [type_env_component_equality]); + >> metis_tac [type_env_component_equality] +QED (* -Theorem type_ds_mod -`!uniq mn tdecs tenv ds tdecs' new_tenv. +Theorem type_ds_mod: + !uniq mn tdecs tenv ds tdecs' new_tenv. type_ds uniq mn tdecs tenv ds tdecs' new_tenv ⇒ tdecs'.defined_mods = {} ∧ - decls_to_mods tdecs' ⊆ {mn}` - (induct_on `ds` >> + decls_to_mods tdecs' ⊆ {mn} +Proof + induct_on `ds` >> srw_tac[][Once type_ds_cases] >- srw_tac[][decls_to_mods_def, empty_decls_def, SUBSET_DEF, FDOM_FUPDATE_LIST, MEM_MAP] >- srw_tac[][decls_to_mods_def, empty_decls_def, SUBSET_DEF, FDOM_FUPDATE_LIST, MEM_MAP] >> @@ -2335,7 +2554,8 @@ Theorem type_ds_mod ONCE_REWRITE_TAC [SUBSET_DEF] >> REWRITE_TAC [GSPECIFICATION] >> rw_tac (bool_ss) [] >> - metis_tac []); + metis_tac [] +QED *) (* @@ -2371,12 +2591,13 @@ val type_ds_no_dup_types_helper = Q.prove ( full_simp_tac(srw_ss())[DISJOINT_DEF, EXTENSION] >> metis_tac []); -Theorem type_ds_no_dup_types -`!uniq mn decls tenv ds decls' tenv'. +Theorem type_ds_no_dup_types: + !uniq mn decls tenv ds decls' tenv'. type_ds uniq mn decls tenv ds decls' tenv' ⇒ - no_dup_types ds` - (induct_on `ds` >> + no_dup_types ds +Proof + induct_on `ds` >> srw_tac[][no_dup_types_def, decs_to_types_def] >> pop_assum (assume_tac o SIMP_RULE (srw_ss()) [Once type_ds_cases]) >> full_simp_tac(srw_ss())[EXISTS_PROD,extend_dec_tenv_def] >> @@ -2420,31 +2641,35 @@ Theorem type_ds_no_dup_types full_simp_tac(srw_ss())[] >> metis_tac [])) >- metis_tac [] - >- metis_tac []); + >- metis_tac [] +QED -Theorem type_ds_decls_ok - `!mn tenv decls' tenv' ds tdecs_no_sig. +Theorem type_ds_decls_ok: + !mn tenv decls' tenv' ds tdecs_no_sig. type_ds F mn tdecs_no_sig tenv ds decls' tenv' ∧ mn ≠ [] ⇒ - decls_ok (union_decls <|defined_mods := {mn}; defined_types := ∅; defined_exns := ∅ |> decls')` - (rw [decls_ok_def, union_decls_def] + decls_ok (union_decls <|defined_mods := {mn}; defined_types := ∅; defined_exns := ∅ |> decls') +Proof + rw [decls_ok_def, union_decls_def] >> imp_res_tac type_ds_mod >> full_simp_tac (srw_ss()++DNF_ss) [decls_to_mods_def, SUBSET_DEF, GSPECIFICATION] >> rw [] - >> fs [weak_decls_def, SUBSET_DEF]); + >> fs [weak_decls_def, SUBSET_DEF] +QED *) (* ---------- type_specs ---------- *) (* -Theorem type_specs_tenv_ok - `!mn tenvT specs decls' tenv'. +Theorem type_specs_tenv_ok: + !mn tenvT specs decls' tenv'. type_specs mn tenvT specs decls' tenv' ⇒ tenv_abbrev_ok tenvT ⇒ - tenv_ok tenv'` - (ho_match_mp_tac type_specs_ind + tenv_ok tenv' +Proof + ho_match_mp_tac type_specs_ind >> rw [] >- ( irule extend_dec_tenv_ok @@ -2518,26 +2743,30 @@ Theorem type_specs_tenv_ok >> simp [check_freevars_def, EVERY_MAP, EVERY_MEM] >> fs [tenv_abbrev_ok_def]) >> simp [tenv_ok_def] - >> fs [tenv_abbrev_ok_def])); + >> fs [tenv_abbrev_ok_def]) +QED -Theorem type_specs_no_mod -`!mn tenvT specs decls' new_tenv. +Theorem type_specs_no_mod: + !mn tenvT specs decls' new_tenv. type_specs mn tenvT specs decls' new_tenv ⇒ - decls'.defined_mods = {}` - (ho_match_mp_tac type_specs_strongind >> + decls'.defined_mods = {} +Proof + ho_match_mp_tac type_specs_strongind >> srw_tac[][empty_decls_def] >> imp_res_tac type_d_mod >> - full_simp_tac(srw_ss())[union_decls_def]); + full_simp_tac(srw_ss())[union_decls_def] +QED -Theorem check_signature_tenv_ok - `!mn tenv decls tenv' specs decls' tenv'' ds tdecs1 tenvT''. +Theorem check_signature_tenv_ok: + !mn tenv decls tenv' specs decls' tenv'' ds tdecs1 tenvT''. check_signature [mn] tenvT'' decls tenv' specs decls' tenv'' ∧ type_ds F [mn] tdecs1 tenv ds decls tenv' ∧ tenv_ok tenv ∧ tenvT'' = tenv.t ⇒ - tenv_ok (extend_dec_tenv <| v := nsLift mn tenv''.v; c := nsLift mn tenv''.c; t := nsLift mn tenv''.t |> tenv)` - (rw [check_signature_cases] + tenv_ok (extend_dec_tenv <| v := nsLift mn tenv''.v; c := nsLift mn tenv''.c; t := nsLift mn tenv''.t |> tenv) +Proof + rw [check_signature_cases] >- ( drule type_ds_tenv_ok_helper >> rw [] @@ -2549,49 +2778,59 @@ Theorem check_signature_tenv_ok >> rw [] >> irule extend_dec_tenv_ok >> simp [] - >> fs [tenv_ok_def, tenv_ctor_ok_def, tenv_val_ok_def, tenv_abbrev_ok_def])); + >> fs [tenv_ok_def, tenv_ctor_ok_def, tenv_val_ok_def, tenv_abbrev_ok_def]) +QED *) (* ---------------- type_top, type_prog ---------- *) (* -Theorem type_prog_empty[simp] - `!u mn decls tenv decls' r. - type_prog u decls tenv [] decls' r ⇔ decls' = empty_decls ∧ r = <| v := nsEmpty; c := nsEmpty; t := nsEmpty |>` - (rw [Once type_prog_cases]); - -Theorem type_prog_sing[simp] - `!u mn decls tenv d decls' r. - type_prog u decls tenv [d] decls' r ⇔ type_top u decls tenv d decls' r` - (simp [Once type_prog_cases] >> +Theorem type_prog_empty[simp]: + !u mn decls tenv decls' r. + type_prog u decls tenv [] decls' r ⇔ decls' = empty_decls ∧ r = <| v := nsEmpty; c := nsEmpty; t := nsEmpty |> +Proof + rw [Once type_prog_cases] +QED + +Theorem type_prog_sing[simp]: + !u mn decls tenv d decls' r. + type_prog u decls tenv [d] decls' r ⇔ type_top u decls tenv d decls' r +Proof + simp [Once type_prog_cases] >> rw [] >> eq_tac >> - rw [extend_dec_tenv_def]); + rw [extend_dec_tenv_def] +QED -Theorem type_top_check_uniq -`!uniq tdecs tenv top tdecs' new_tenv. +Theorem type_top_check_uniq: + !uniq tdecs tenv top tdecs' new_tenv. type_top uniq tdecs tenv top tdecs' new_tenv ⇒ - type_top F tdecs tenv top tdecs' new_tenv` - (srw_tac[][type_top_cases] >> - metis_tac [type_d_check_uniq, type_ds_check_uniq]); - -Theorem type_prog_check_uniq -`!uniq tdecs tenv prog tdecs' new_tenv. + type_top F tdecs tenv top tdecs' new_tenv +Proof + srw_tac[][type_top_cases] >> + metis_tac [type_d_check_uniq, type_ds_check_uniq] +QED + +Theorem type_prog_check_uniq: + !uniq tdecs tenv prog tdecs' new_tenv. type_prog uniq tdecs tenv prog tdecs' new_tenv ⇒ - type_prog F tdecs tenv prog tdecs' new_tenv` - (ho_match_mp_tac type_prog_ind >> + type_prog F tdecs tenv prog tdecs' new_tenv +Proof + ho_match_mp_tac type_prog_ind >> srw_tac[][] >> srw_tac[][Once type_prog_cases] >> - metis_tac [type_top_check_uniq]); + metis_tac [type_top_check_uniq] +QED -Theorem type_top_decls_ok -`!uniq tdecs tenv top tdecs' new_tenv. +Theorem type_top_decls_ok: + !uniq tdecs tenv top tdecs' new_tenv. type_top uniq tdecs tenv top tdecs' new_tenv ⇒ - decls_ok tdecs'` - (rw [type_top_cases] + decls_ok tdecs' +Proof + rw [type_top_cases] >> simp [decls_ok_def] >- ( drule type_d_mod @@ -2604,20 +2843,23 @@ Theorem type_top_decls_ok >> TRY (drule type_specs_no_mod) >> simp_tac (srw_ss()++DNF_ss) [SUBSET_DEF, decls_to_mods_def, SUBSET_DEF, GSPECIFICATION] >> rw [] - >> fs [weak_decls_def, SUBSET_DEF])); + >> fs [weak_decls_def, SUBSET_DEF]) +QED -Theorem type_prog_decls_ok -`!uniq tdecs tenv prog tdecs' new_tenv. +Theorem type_prog_decls_ok: + !uniq tdecs tenv prog tdecs' new_tenv. type_prog uniq tdecs tenv prog tdecs' new_tenv ⇒ - decls_ok tdecs'` - (ho_match_mp_tac type_prog_ind >> + decls_ok tdecs' +Proof + ho_match_mp_tac type_prog_ind >> srw_tac[][] >> srw_tac[][Once type_prog_cases] >- simp [decls_ok_def, empty_decls_def, decls_to_mods_def] >> irule decls_ok_union >> simp [] - >> metis_tac [type_top_decls_ok]); + >> metis_tac [type_top_decls_ok] +QED val type_no_dup_top_types_lem = Q.prove ( `!uniq decls1 tenv prog decls1' res. @@ -2676,14 +2918,15 @@ val type_no_dup_top_types_lem2 = Q.prove ( full_simp_tac(srw_ss())[mk_id_def] >> metis_tac []); -Theorem type_no_dup_top_types -`!decls1 tenv prog decls1' tenv' uniq decls2 decls_no_sig. +Theorem type_no_dup_top_types: + !decls1 tenv prog decls1' tenv' uniq decls2 decls_no_sig. type_prog uniq decls1 tenv prog decls1' tenv' ∧ consistent_decls decls2 decls_no_sig ∧ weak_decls_only_mods decls_no_sig decls1 ⇒ - no_dup_top_types prog decls2` - (srw_tac[][] >> + no_dup_top_types prog decls2 +Proof + srw_tac[][] >> `no_dup_top_types prog (IMAGE TypeId decls1.defined_types)` by metis_tac [type_no_dup_top_types_lem2] >> full_simp_tac(srw_ss())[semanticPrimitivesTheory.no_dup_top_types_def] >> @@ -2695,7 +2938,8 @@ Theorem type_no_dup_top_types every_case_tac >> full_simp_tac(srw_ss())[MEM_MAP] >> srw_tac[][] >> - metis_tac []); + metis_tac [] +QED val type_no_dup_mods_lem = Q.prove ( `!uniq decls1 tenv prog decls1' res. @@ -2716,13 +2960,15 @@ val type_no_dup_mods_lem = Q.prove ( >- (full_simp_tac(srw_ss())[union_decls_def, DISJOINT_DEF, EXTENSION] >> metis_tac [])); -Theorem type_no_dup_mods -`!uniq decls1 tenv prog decls1' tenv'. +Theorem type_no_dup_mods: + !uniq decls1 tenv prog decls1' tenv'. type_prog uniq decls1 tenv prog decls1' tenv' ⇒ - no_dup_mods prog decls1.defined_mods` - (srw_tac[][semanticPrimitivesTheory.no_dup_mods_def] >> - metis_tac [type_no_dup_mods_lem, DISJOINT_SYM]); + no_dup_mods prog decls1.defined_mods +Proof + srw_tac[][semanticPrimitivesTheory.no_dup_mods_def] >> + metis_tac [type_no_dup_mods_lem, DISJOINT_SYM] +QED *) (* @@ -2739,20 +2985,26 @@ val tenv_names_def = Define` (tenv_names (Bind_name n _ _ e) = n INSERT tenv_names e)` val _ = export_rewrites["tenv_names_def"] -Theorem lookup_tenv_names - `∀tenv n inc x. lookup_tenv_val n inc tenv = SOME x ⇒ n ∈ tenv_names tenv` - (Induct >> simp[lookup_tenv_val_def] >> metis_tac[]) +Theorem lookup_tenv_names: + ∀tenv n inc x. lookup_tenv_val n inc tenv = SOME x ⇒ n ∈ tenv_names tenv +Proof + Induct >> simp[lookup_tenv_val_def] >> metis_tac[] +QED -Theorem tenv_names_bind_var_list - `∀n l1 l2. tenv_names (bind_var_list n l1 l2) = set (MAP FST l1) ∪ tenv_names l2` - (ho_match_mp_tac bind_var_list_ind >> +Theorem tenv_names_bind_var_list: + ∀n l1 l2. tenv_names (bind_var_list n l1 l2) = set (MAP FST l1) ∪ tenv_names l2 +Proof + ho_match_mp_tac bind_var_list_ind >> simp[bind_var_list_def,EXTENSION] >> - metis_tac[]) + metis_tac[] +QED -Theorem tenv_names_bind_var_list2 - `∀l1 tenv. tenv_names (bind_var_list2 l1 tenv) = set (MAP FST l1) ∪ tenv_names tenv` - (Induct >> TRY(qx_gen_tac`p`>>PairCases_on`p`) >> simp[bind_var_list2_def] >> - simp[EXTENSION] >> metis_tac[]) +Theorem tenv_names_bind_var_list2: + ∀l1 tenv. tenv_names (bind_var_list2 l1 tenv) = set (MAP FST l1) ∪ tenv_names tenv +Proof + Induct >> TRY(qx_gen_tac`p`>>PairCases_on`p`) >> simp[bind_var_list2_def] >> + simp[EXTENSION] >> metis_tac[] +QED val type_p_closed = Q.prove( `(∀tvs tcenv p t tenv. @@ -2954,12 +3206,13 @@ val type_ds_closed = Q.prove( *) (* -Theorem type_top_closed - `∀uniq decls tenv top decls' new_tenv. +Theorem type_top_closed: + ∀uniq decls tenv top decls' new_tenv. type_top uniq decls tenv top decls' new_tenv ⇒ - FV_top top ⊆ (IMAGE Short (tenv_names tenv.v) ∪ tmenv_dom tenv.m)` - (ho_match_mp_tac type_top_ind >> + FV_top top ⊆ (IMAGE Short (tenv_names tenv.v) ∪ tmenv_dom tenv.m) +Proof + ho_match_mp_tac type_top_ind >> strip_tac >- ( simp[] >> rpt gen_tac >> strip_tac >> @@ -2967,7 +3220,8 @@ Theorem type_top_closed simp[] >> rpt gen_tac >> strip_tac >> imp_res_tac type_ds_closed >> - full_simp_tac(srw_ss())[]); + full_simp_tac(srw_ss())[] +QED *) val type_env_dom = Q.prove ( @@ -3042,13 +3296,14 @@ val consistent_mod_env_dom = Q.prove ( *) (* -Theorem type_sound_inv_closed - `∀uniq top rs new_tenvM new_tenvC new_tenv new_decls new_tenvT decls' store. +Theorem type_sound_inv_closed: + ∀uniq top rs new_tenvM new_tenvC new_tenv new_decls new_tenvT decls' store. type_top uniq rs.tdecs rs.tenvT rs.tenvM rs.tenvC rs.tenv top new_decls new_tenvT new_tenvM new_tenvC new_tenv ∧ type_sound_invariants NONE (rs.tdecs,rs.tenvT,rs.tenvM,rs.tenvC,rs.tenv,decls',rs.sem_env,store) ⇒ - FV_top top ⊆ all_env_dom (rs.sem_env.sem_envM,rs.sem_env.sem_envC,rs.sem_env.sem_envE)` - (srw_tac[][] >> + FV_top top ⊆ all_env_dom (rs.sem_env.sem_envM,rs.sem_env.sem_envC,rs.sem_env.sem_envE) +Proof + srw_tac[][] >> imp_res_tac type_top_closed >> `(?err. r = Rerr err) ∨ (?menv env. r = Rval (menv,env))` by (cases_on `r` >> @@ -3062,7 +3317,8 @@ Theorem type_sound_inv_closed imp_res_tac (GSYM consistent_mod_env_dom) >> full_simp_tac(srw_ss())[] >> full_simp_tac(srw_ss())[SUBSET_DEF] >> - metis_tac []); + metis_tac [] +QED *) val _ = export_theory (); diff --git a/semantics/proofs/weakeningScript.sml b/semantics/proofs/weakeningScript.sml index d5757b4644..b32fd3fa4c 100644 --- a/semantics/proofs/weakeningScript.sml +++ b/semantics/proofs/weakeningScript.sml @@ -23,21 +23,26 @@ weak_tenvE tenv tenv' = val weakS_def = Define ` weakS tenvS tenvS' ⇔ tenvS' SUBMAP tenvS`; -Theorem weak_tenvE_refl - `!tenvE. weak_tenvE tenvE tenvE` - (rw [weak_tenvE_def]); +Theorem weak_tenvE_refl: + !tenvE. weak_tenvE tenvE tenvE +Proof + rw [weak_tenvE_def] +QED (* -Theorem weak_tenvT_refl - `∀n x. weak_tenvT n x x` - (rw [] +Theorem weak_tenvT_refl: + ∀n x. weak_tenvT n x x +Proof + rw [] >> PairCases_on `x` - >> rw [weak_tenvT_def]); + >> rw [weak_tenvT_def] +QED *) -Theorem weak_tenv_refl - `!tenv. tenv_val_ok tenv.v ⇒ weak_tenv tenv tenv` - (rw [weak_tenv_def] +Theorem weak_tenv_refl: + !tenv. tenv_val_ok tenv.v ⇒ weak_tenv tenv tenv +Proof + rw [weak_tenv_def] >> irule nsSub_refl >> rw [tscheme_inst2_def] >- ( @@ -52,15 +57,20 @@ Theorem weak_tenv_refl >> fs [tenv_val_ok_def] >> metis_tac [deBruijn_subst_id]) >> qexists_tac `\n t. T` - >> rw [(*weak_tenvT_refl*)]); + >> rw [(*weak_tenvT_refl*)] +QED -Theorem weakS_refl - `!tenvS. weakS tenvS tenvS` - (rw [weakS_def]); +Theorem weakS_refl: + !tenvS. weakS tenvS tenvS +Proof + rw [weakS_def] +QED -Theorem weakS_bind -`!l t tenvS. FLOOKUP tenvS l = NONE ⇒ weakS (tenvS |+ (l,t)) tenvS` - (rw [weakS_def, FLOOKUP_UPDATE, flookup_thm]); +Theorem weakS_bind: + !l t tenvS. FLOOKUP tenvS l = NONE ⇒ weakS (tenvS |+ (l,t)) tenvS +Proof + rw [weakS_def, FLOOKUP_UPDATE, flookup_thm] +QED val weak_tenvE_freevars = Q.prove ( `!tenv tenv' tvs t. @@ -175,17 +185,19 @@ val weak_def = Define ` weak tenv' tenv ⇔ tenv'.t = tenv.t ∧ weak_tenv tenv' tenv`; -Theorem type_p_weakening -`(!tvs tenv p t bindings. type_p tvs tenv p t bindings ⇒ +Theorem type_p_weakening: + (!tvs tenv p t bindings. type_p tvs tenv p t bindings ⇒ !tenv' tvs'. tvs' ≥ tvs ∧ weak tenv' tenv ⇒ type_p tvs' tenv' p t bindings) ∧ (!tvs tenv ps ts bindings. type_ps tvs tenv ps ts bindings ⇒ - !tenv' tvs'. tvs' ≥ tvs ∧ weak tenv' tenv ⇒ type_ps tvs' tenv' ps ts bindings)` - (ho_match_mp_tac type_p_ind >> + !tenv' tvs'. tvs' ≥ tvs ∧ weak tenv' tenv ⇒ type_ps tvs' tenv' ps ts bindings) +Proof + ho_match_mp_tac type_p_ind >> rw [] >> ONCE_REWRITE_TAC [type_p_cases] >> rw [] >> fs [EVERY_MEM] >> - metis_tac [weak_def, check_freevars_add, EVERY_MEM, eLookupC_weak]); + metis_tac [weak_def, check_freevars_add, EVERY_MEM, eLookupC_weak] +QED val type_e_weakening_lem = Q.prove ( `(!tenv tenvE e t. type_e tenv tenvE e t ⇒ @@ -279,14 +291,16 @@ val type_e_weakening_lem = Q.prove ( rw [] >> metis_tac [weak_tenvE_bind, weak_tenvE_bind_tvar, weak_tenvE_freevars])); -Theorem type_e_weakening -`(!tenv tenvE e t tenv' tenvE'. +Theorem type_e_weakening: + (!tenv tenvE e t tenv' tenvE'. type_e tenv tenvE e t ∧ weak tenv' tenv ∧ weak_tenvE tenvE' tenvE ⇒ type_e tenv' tenvE' e t) ∧ (!tenv tenvE es ts tenv' tenvE'. type_es tenv tenvE es ts ∧ weak tenv' tenv ∧ weak_tenvE tenvE' tenvE ⇒ type_es tenv' tenvE' es ts) ∧ (!tenv tenvE funs bindings tenv' tenvE'. - type_funs tenv tenvE funs bindings ∧ weak tenv' tenv ∧ weak_tenvE tenvE' tenvE ⇒ type_funs tenv' tenvE' funs bindings)` -(metis_tac [type_e_weakening_lem]); + type_funs tenv tenvE funs bindings ∧ weak tenv' tenv ∧ weak_tenvE tenvE' tenvE ⇒ type_funs tenv' tenvE' funs bindings) +Proof +metis_tac [type_e_weakening_lem] +QED val gt_0 = Q.prove ( `!x:num.x ≥ 0`, @@ -304,35 +318,44 @@ val weak_ctMap_lookup = Q.prove ( rw [weakCT_def] >> metis_tac [FLOOKUP_SUBMAP]); -Theorem weakCT_refl -`!ctMap. weakCT ctMap ctMap` -(rw [weakCT_def] >> -metis_tac [SUBMAP_REFL]); - -Theorem weakCT_trans -`weakCT C1 C2 ∧ weakCT C2 C3 ⇒ weakCT C1 C3` - (rw [weakCT_def] - >> metis_tac [SUBMAP_TRANS]); - -Theorem disjoint_env_weakCT -`!ctMap ctMap'. +Theorem weakCT_refl: + !ctMap. weakCT ctMap ctMap +Proof +rw [weakCT_def] >> +metis_tac [SUBMAP_REFL] +QED + +Theorem weakCT_trans: + weakCT C1 C2 ∧ weakCT C2 C3 ⇒ weakCT C1 C3 +Proof + rw [weakCT_def] + >> metis_tac [SUBMAP_TRANS] +QED + +Theorem disjoint_env_weakCT: + !ctMap ctMap'. DISJOINT (FDOM ctMap') (FDOM ctMap) ⇒ - weakCT (FUNION ctMap' ctMap) ctMap` -(rw [weakCT_def] >> -metis_tac [SUBMAP_FUNION, DISJOINT_SYM, SUBMAP_REFL]); - -Theorem weakCT2 -`!ctMap ctMap'. weakCT (FUNION ctMap' ctMap) ctMap'` - (rw [weakCT_def] >> - metis_tac [SUBMAP_FUNION, DISJOINT_SYM, SUBMAP_REFL]); - -Theorem type_tenv_ctor_weakening -`!ctMap tenvC envC ctMap'. + weakCT (FUNION ctMap' ctMap) ctMap +Proof +rw [weakCT_def] >> +metis_tac [SUBMAP_FUNION, DISJOINT_SYM, SUBMAP_REFL] +QED + +Theorem weakCT2: + !ctMap ctMap'. weakCT (FUNION ctMap' ctMap) ctMap' +Proof + rw [weakCT_def] >> + metis_tac [SUBMAP_FUNION, DISJOINT_SYM, SUBMAP_REFL] +QED + +Theorem type_tenv_ctor_weakening: + !ctMap tenvC envC ctMap'. weakCT ctMap' ctMap ∧ nsAll2 (type_ctor ctMap) envC tenvC ⇒ - nsAll2 (type_ctor ctMap') envC tenvC` - (rw [weakCT_def, weakS_def] + nsAll2 (type_ctor ctMap') envC tenvC +Proof + rw [weakCT_def, weakS_def] >> irule nsAll2_mono >> qexists_tac `type_ctor ctMap` >> rw [] @@ -340,7 +363,8 @@ Theorem type_tenv_ctor_weakening >> `?n t1 stamp tvs ts t2. x1 = (n,stamp) ∧ x2 = (tvs,ts,t2)` by metis_tac [pair_CASES] >> fs [type_ctor_def] >> rw [] - >> metis_tac [FLOOKUP_SUBMAP]); + >> metis_tac [FLOOKUP_SUBMAP] +QED val type_tenv_val_weakening_lemma = Q.prove ( `!ctMap tenvS tenvV envV ctMap' tenvS'. @@ -373,12 +397,13 @@ val remove_lambda_prod = Q.prove ( >> pairarg_tac >> rw []); -Theorem type_v_weakening -`(!tvs ctMap tenvS v t. type_v tvs ctMap tenvS v t ⇒ +Theorem type_v_weakening: + (!tvs ctMap tenvS v t. type_v tvs ctMap tenvS v t ⇒ !tvs' ctMap' tenvS'. ((tvs = 0) ∨ (tvs = tvs')) ∧ weakCT ctMap' ctMap ∧ weakS tenvS' tenvS ⇒ - type_v tvs' ctMap' tenvS' v t)` - (ho_match_mp_tac type_v_ind >> + type_v tvs' ctMap' tenvS' v t) +Proof + ho_match_mp_tac type_v_ind >> rw [] >> rw [Once type_v_cases] >- ( @@ -463,16 +488,18 @@ Theorem type_v_weakening >- (fs [weakS_def] >> metis_tac [FLOOKUP_SUBMAP]) >- fs [EVERY_MEM] - >- fs [EVERY_MEM]); + >- fs [EVERY_MEM] +QED -Theorem type_all_env_weakening -`!ctMap tenvS tenv env ctMap' tenvS'. +Theorem type_all_env_weakening: + !ctMap tenvS tenv env ctMap' tenvS'. weakCT ctMap' ctMap ∧ weakS tenvS' tenvS ∧ type_all_env ctMap tenvS env tenv ⇒ - type_all_env ctMap' tenvS' env tenv` - (rw [type_all_env_def] + type_all_env ctMap' tenvS' env tenv +Proof + rw [type_all_env_def] >- metis_tac [type_tenv_ctor_weakening] >> irule type_tenv_val_weakening_lemma >> qexists_tac `ctMap` @@ -485,31 +512,36 @@ Theorem type_all_env_weakening >> pairarg_tac >> rw [] >> fs [] - >> metis_tac [type_v_weakening]); + >> metis_tac [type_v_weakening] +QED -Theorem type_sv_weakening -`!ctMap tenvS st sv ctMap' tenvS'. +Theorem type_sv_weakening: + !ctMap tenvS st sv ctMap' tenvS'. type_sv ctMap tenvS sv st ∧ weakCT ctMap' ctMap ∧ weakS tenvS' tenvS ⇒ - type_sv ctMap' tenvS' sv st` - (rpt gen_tac >> + type_sv ctMap' tenvS' sv st +Proof + rpt gen_tac >> Cases_on `sv` >> Cases_on `st` >> rw [type_sv_def] >- metis_tac [type_v_weakening] >> fs [EVERY_MEM] - >> metis_tac [type_v_weakening]); + >> metis_tac [type_v_weakening] +QED -Theorem type_s_weakening -`!ctMap tenvS st ctMap'. +Theorem type_s_weakening: + !ctMap tenvS st ctMap'. type_s ctMap tenvS st ∧ weakCT ctMap' ctMap ⇒ - type_s ctMap' tenvS st` - (rw [type_s_def] >> - metis_tac [type_sv_weakening, weakS_refl]); + type_s ctMap' tenvS st +Proof + rw [type_s_def] >> + metis_tac [type_sv_weakening, weakS_refl] +QED (* val weakCT_only_other_mods_def = Define ` @@ -527,69 +559,83 @@ val weakCT_only_other_mods_merge = Q.prove ( rw [weakCT_only_other_mods_def] >> metis_tac []); -Theorem weak_decls_only_mods_union -`!decls1 decls2 decls3. +Theorem weak_decls_only_mods_union: + !decls1 decls2 decls3. weak_decls_only_mods decls2 decls3 ⇒ - weak_decls_only_mods (union_decls decls1 decls2) (union_decls decls1 decls3)` - (rw [] >> + weak_decls_only_mods (union_decls decls1 decls2) (union_decls decls1 decls3) +Proof + rw [] >> fs [weak_decls_only_mods_def, union_decls_def] >> - metis_tac []); + metis_tac [] +QED -Theorem weak_decls_only_mods_union2 -`!decls1 decls2 decls3 decls1'. +Theorem weak_decls_only_mods_union2: + !decls1 decls2 decls3 decls1'. weak_decls_only_mods decls1 decls1' ∧ weak_decls_only_mods decls2 decls3 ⇒ - weak_decls_only_mods (union_decls decls1 decls2) (union_decls decls1' decls3)` - (rw [] >> + weak_decls_only_mods (union_decls decls1 decls2) (union_decls decls1' decls3) +Proof + rw [] >> fs [weak_decls_only_mods_def, union_decls_def] >> - metis_tac []); + metis_tac [] +QED -Theorem weak_decls_refl -`!decls. weak_decls decls decls` - (rw [weak_decls_def]); +Theorem weak_decls_refl: + !decls. weak_decls decls decls +Proof + rw [weak_decls_def] +QED -Theorem weak_decls_trans -`!decls1 decls2 decls3. +Theorem weak_decls_trans: + !decls1 decls2 decls3. weak_decls decls1 decls2 ∧ weak_decls decls2 decls3 ⇒ - weak_decls decls1 decls3` - (rw [] >> - fs [weak_decls_def, SUBSET_DEF]); + weak_decls decls1 decls3 +Proof + rw [] >> + fs [weak_decls_def, SUBSET_DEF] +QED val weak_decls_other_mods_def = Define ` weak_decls_other_mods mn d' d ⇔ (!tid. tid ∈ d'.defined_types ∧ tid ∉ d.defined_types ⇒ ¬?tn. tid = mk_id mn tn) ∧ (!cid. cid ∈ d'.defined_exns ∧ cid ∉ d.defined_exns ⇒ ¬?cn. cid = mk_id mn cn)`; -Theorem weak_decls_other_mods_refl -`!mn decls. weak_decls_other_mods mn decls decls` - (rw [] >> - rw [weak_decls_other_mods_def]); +Theorem weak_decls_other_mods_refl: + !mn decls. weak_decls_other_mods mn decls decls +Proof + rw [] >> + rw [weak_decls_other_mods_def] +QED *) -Theorem weak_tenv_extend_dec_tenv - `!tenv1 tenv2 tenv3. +Theorem weak_tenv_extend_dec_tenv: + !tenv1 tenv2 tenv3. tenv_val_ok tenv1.v ∧ weak_tenv tenv2 tenv3 ⇒ - weak_tenv (extend_dec_tenv tenv1 tenv2) (extend_dec_tenv tenv1 tenv3)` - (rw [] + weak_tenv (extend_dec_tenv tenv1 tenv2) (extend_dec_tenv tenv1 tenv3) +Proof + rw [] >> drule weak_tenv_refl >> fs [weak_tenv_def, extend_dec_tenv_def] >> rw [] >> irule nsSub_nsAppend2 - >> simp []); + >> simp [] +QED -Theorem weak_extend_dec_tenv - `tenv_ok tenv1 /\ weak tenv2 tenv3 - ==> weak (extend_dec_tenv tenv1 tenv2) (extend_dec_tenv tenv1 tenv3)` - (fs [weak_def, tenv_ok_def, weak_tenv_extend_dec_tenv] - \\ fs [extend_dec_tenv_def]); +Theorem weak_extend_dec_tenv: + tenv_ok tenv1 /\ weak tenv2 tenv3 + ==> weak (extend_dec_tenv tenv1 tenv2) (extend_dec_tenv tenv1 tenv3) +Proof + fs [weak_def, tenv_ok_def, weak_tenv_extend_dec_tenv] + \\ fs [extend_dec_tenv_def] +QED -Theorem type_d_weakening -`(!check tenv d decls tenv'. +Theorem type_d_weakening: + (!check tenv d decls tenv'. type_d check tenv d decls tenv' ⇒ !tenv''. check = F ∧ @@ -604,8 +650,9 @@ Theorem type_d_weakening tenv_ok tenv'' ∧ weak tenv'' tenv ⇒ - type_ds check tenv'' d decls tenv')` - (ho_match_mp_tac type_d_ind >> + type_ds check tenv'' d decls tenv') +Proof + ho_match_mp_tac type_d_ind >> rw [] >> simp [Once type_d_cases] >> rw [] @@ -642,103 +689,121 @@ Theorem type_d_weakening suffices_by (metis_tac [extend_dec_tenv_ok, weak_extend_dec_tenv]) \\ metis_tac [type_d_tenv_ok_helper] ) -); +QED (* -Theorem weak_decls_union -`!decls1 decls2 decls3. +Theorem weak_decls_union: + !decls1 decls2 decls3. weak_decls decls1 decls2 ⇒ - weak_decls (union_decls decls3 decls1) (union_decls decls3 decls2)` - (rw [] >> + weak_decls (union_decls decls3 decls1) (union_decls decls3 decls2) +Proof + rw [] >> fs [weak_decls_def, union_decls_def, SUBSET_DEF] >> - metis_tac []); + metis_tac [] +QED -Theorem weak_decls_union -`!decls1 decls2 decls3. +Theorem weak_decls_union: + !decls1 decls2 decls3. weak_decls decls1 decls2 ⇒ - weak_decls (union_decls decls3 decls1) (union_decls decls3 decls2)` - (rw [] >> + weak_decls (union_decls decls3 decls1) (union_decls decls3 decls2) +Proof + rw [] >> fs [weak_decls_def, union_decls_def, SUBSET_DEF] >> - metis_tac []); + metis_tac [] +QED -Theorem weak_decls_union2 -`!decls1 decls2 decls3. +Theorem weak_decls_union2: + !decls1 decls2 decls3. decls1.defined_mods = {} ⇒ - weak_decls (union_decls decls1 decls2) decls2` - (rw [] >> - fs [weak_decls_def, union_decls_def, SUBSET_DEF]); + weak_decls (union_decls decls1 decls2) decls2 +Proof + rw [] >> + fs [weak_decls_def, union_decls_def, SUBSET_DEF] +QED -Theorem weak_decls_union3 -`!decls1 decls2 decls3. +Theorem weak_decls_union3: + !decls1 decls2 decls3. weak_decls decls1 decls2 ⇒ - weak_decls (union_decls decls1 decls3) (union_decls decls2 decls3)` - (rw [] >> + weak_decls (union_decls decls1 decls3) (union_decls decls2 decls3) +Proof + rw [] >> fs [weak_decls_def, union_decls_def, SUBSET_DEF] >> - metis_tac []); + metis_tac [] +QED -Theorem weak_decls_other_mods_union -`!mn decls1 decls2 decls3. +Theorem weak_decls_other_mods_union: + !mn decls1 decls2 decls3. weak_decls_other_mods mn decls1 decls2 ⇒ - weak_decls_other_mods mn (union_decls decls3 decls1) (union_decls decls3 decls2)` - (rw [] >> + weak_decls_other_mods mn (union_decls decls3 decls1) (union_decls decls3 decls2) +Proof + rw [] >> fs [weak_decls_other_mods_def, union_decls_def] >> - metis_tac []); + metis_tac [] +QED -Theorem weak_decls_other_mods_only_mods_NIL -`weak_decls_only_mods tdecs_no_sig tdecs1 ∧ +Theorem weak_decls_other_mods_only_mods_NIL: + weak_decls_only_mods tdecs_no_sig tdecs1 ∧ weak_decls tdecs_no_sig tdecs1 ⇒ - weak_decls_other_mods [] tdecs_no_sig tdecs1` - (fs [weak_decls_only_mods_def, weak_decls_other_mods_def, weak_decls_def, namespaceTheory.mk_id_def] - >> metis_tac []); - -Theorem weak_decls_other_mods_only_mods_SOME -`decls_ok tdecs_no_sig ∧ + weak_decls_other_mods [] tdecs_no_sig tdecs1 +Proof + fs [weak_decls_only_mods_def, weak_decls_other_mods_def, weak_decls_def, namespaceTheory.mk_id_def] + >> metis_tac [] +QED + +Theorem weak_decls_other_mods_only_mods_SOME: + decls_ok tdecs_no_sig ∧ mn ≠ [] ∧ mn ∉ tdecs1.defined_mods ∧ weak_decls tdecs_no_sig tdecs1 ⇒ - weak_decls_other_mods mn tdecs_no_sig tdecs1` - (fs [weak_decls_only_mods_def, weak_decls_other_mods_def, weak_decls_def, + weak_decls_other_mods mn tdecs_no_sig tdecs1 +Proof + fs [weak_decls_only_mods_def, weak_decls_other_mods_def, weak_decls_def, namespaceTheory.mk_id_def, decls_ok_def, decls_to_mods_def, SUBSET_DEF] >> fsrw_tac[boolSimps.DNF_ss][decls_to_mods_def,GSPECIFICATION] >> rw [] >> rw [METIS_PROVE [] ``¬x ∨ y ⇔ x ⇒ y``] >> res_tac >> fs [id_to_mods_mk_id] - >> metis_tac []); + >> metis_tac [] +QED -Theorem type_ds_weak_decls_only_mods - `!mn tdecs_no_sig tenv ds decls tenv' decls'. +Theorem type_ds_weak_decls_only_mods: + !mn tdecs_no_sig tenv ds decls tenv' decls'. type_ds F mn tdecs_no_sig tenv ds decls tenv' ∧ mn ≠ [] ⇒ - weak_decls_only_mods decls decls'` - (rw [weak_decls_only_mods_def] + weak_decls_only_mods decls decls' +Proof + rw [weak_decls_only_mods_def] >> drule type_ds_mod >> srw_tac [DNF_ss] [decls_to_mods_def, SUBSET_DEF, GSPECIFICATION] >> res_tac - >> fs [namespaceTheory.id_to_mods_def]); + >> fs [namespaceTheory.id_to_mods_def] +QED -Theorem weak_tenv_extend_dec_tenv - `!tenv1 tenv2 tenv3. +Theorem weak_tenv_extend_dec_tenv: + !tenv1 tenv2 tenv3. tenv_val_ok tenv1.v ∧ weak_tenv tenv2 tenv3 ⇒ - weak_tenv (extend_dec_tenv tenv1 tenv2) (extend_dec_tenv tenv1 tenv3)` - (rw [] + weak_tenv (extend_dec_tenv tenv1 tenv2) (extend_dec_tenv tenv1 tenv3) +Proof + rw [] >> drule weak_tenv_refl >> fs [weak_tenv_def, extend_dec_tenv_def] >> rw [] >> irule nsSub_nsAppend2 - >> simp []); + >> simp [] +QED -Theorem type_ds_weakening - `!uniq mn decls tenv ds decls' tenv'. +Theorem type_ds_weakening: + !uniq mn decls tenv ds decls' tenv'. type_ds uniq mn decls tenv ds decls' tenv' ⇒ !decls'' tenv''. uniq = F ∧ @@ -747,8 +812,9 @@ Theorem type_ds_weakening tenv_ok tenv'' ∧ weak tenv'' tenv ⇒ - type_ds F mn decls'' tenv'' ds decls' tenv'` - (ho_match_mp_tac type_ds_ind >> + type_ds F mn decls'' tenv'' ds decls' tenv' +Proof + ho_match_mp_tac type_ds_ind >> rw [] >> rw [Once type_ds_cases] >> imp_res_tac type_d_weakening >> @@ -771,31 +837,35 @@ Theorem type_ds_weakening >> drule type_d_tenv_ok_helper >> rw [tenv_ok_def]) >- metis_tac [weak_decls_union] - >- metis_tac [weak_decls_other_mods_union]); + >- metis_tac [weak_decls_other_mods_union] +QED *) (* -Theorem consistent_decls_weakening -`!decls1 decls2 decls3. +Theorem consistent_decls_weakening: + !decls1 decls2 decls3. consistent_decls decls1 decls3 ∧ weak_decls decls2 decls3 ⇒ - consistent_decls decls1 decls2` - (rw [] >> + consistent_decls decls1 decls2 +Proof + rw [] >> fs [consistent_decls_def, RES_FORALL, weak_decls_def] >> rw [] >> every_case_tac >> fs [SUBSET_DEF] >> res_tac >> - fs []); + fs [] +QED -Theorem consistent_ctMap_weakening -`!ctMap tdecls tdecls'. +Theorem consistent_ctMap_weakening: + !ctMap tdecls tdecls'. consistent_ctMap tdecls ctMap ∧ weak_decls tdecls' tdecls ⇒ - consistent_ctMap tdecls' ctMap` - (rw [] >> + consistent_ctMap tdecls' ctMap +Proof + rw [] >> fs [weak_decls_def, consistent_ctMap_def, RES_FORALL] >> rw [] >> PairCases_on `x` >> @@ -803,7 +873,8 @@ Theorem consistent_ctMap_weakening every_case_tac >> fs [] >> res_tac >> - fs [SUBSET_DEF]); + fs [SUBSET_DEF] +QED *) val _ = export_theory (); diff --git a/semantics/terminationScript.sml b/semantics/terminationScript.sml index af209c8e78..803a9f5199 100644 --- a/semantics/terminationScript.sml +++ b/semantics/terminationScript.sml @@ -38,50 +38,62 @@ val pats_size_thm = size_thm "pats_size_thm" ``pats_size`` ``pat_size``; (* val envE_size_thm = size_thm "envE_size_thm" ``envE_size`` ``v3_size``; *) (* val envM_size_thm = size_thm "envM_size_thm" ``envM_size`` ``v5_size``; *) -Theorem SUM_MAP_exp2_size_thm -`∀defs. SUM (MAP exp2_size defs) = SUM (MAP (list_size char_size) (MAP FST defs)) + +Theorem SUM_MAP_exp2_size_thm: + ∀defs. SUM (MAP exp2_size defs) = SUM (MAP (list_size char_size) (MAP FST defs)) + SUM (MAP exp4_size (MAP SND defs)) + - LENGTH defs` -(Induct >- rw[exp_size_def] >> + LENGTH defs +Proof +Induct >- rw[exp_size_def] >> qx_gen_tac `p` >> PairCases_on `p` >> -srw_tac[ARITH_ss][exp_size_def]) +srw_tac[ARITH_ss][exp_size_def] +QED -Theorem SUM_MAP_exp4_size_thm -`∀ls. SUM (MAP exp4_size ls) = SUM (MAP (list_size char_size) (MAP FST ls)) + +Theorem SUM_MAP_exp4_size_thm: + ∀ls. SUM (MAP exp4_size ls) = SUM (MAP (list_size char_size) (MAP FST ls)) + SUM (MAP exp_size (MAP SND ls)) + - LENGTH ls` -(Induct >- rw[exp_size_def] >> -Cases >> srw_tac[ARITH_ss][exp_size_def]); - -Theorem SUM_MAP_exp5_size_thm -`∀ls. SUM (MAP exp5_size ls) = SUM (MAP pat_size (MAP FST ls)) + + LENGTH ls +Proof +Induct >- rw[exp_size_def] >> +Cases >> srw_tac[ARITH_ss][exp_size_def] +QED + +Theorem SUM_MAP_exp5_size_thm: + ∀ls. SUM (MAP exp5_size ls) = SUM (MAP pat_size (MAP FST ls)) + SUM (MAP exp_size (MAP SND ls)) + - LENGTH ls` -(Induct >- rw[exp_size_def] >> -Cases >> srw_tac[ARITH_ss][exp_size_def]); + LENGTH ls +Proof +Induct >- rw[exp_size_def] >> +Cases >> srw_tac[ARITH_ss][exp_size_def] +QED (* -Theorem SUM_MAP_v2_size_thm -`∀env. SUM (MAP v2_size env) = SUM (MAP (list_size char_size) (MAP FST env)) + +Theorem SUM_MAP_v2_size_thm: + ∀env. SUM (MAP v2_size env) = SUM (MAP (list_size char_size) (MAP FST env)) + SUM (MAP v_size (MAP SND env)) + - LENGTH env` -(Induct >- rw[v_size_def] >> -Cases >> srw_tac[ARITH_ss][v_size_def]) + LENGTH env +Proof +Induct >- rw[v_size_def] >> +Cases >> srw_tac[ARITH_ss][v_size_def] +QED *) (* -Theorem SUM_MAP_v3_size_thm -`∀env f. SUM (MAP (v3_size f) env) = SUM (MAP (v_size f) (MAP FST env)) + +Theorem SUM_MAP_v3_size_thm: + ∀env f. SUM (MAP (v3_size f) env) = SUM (MAP (v_size f) (MAP FST env)) + SUM (MAP (option_size (pair_size (λx. x) f)) (MAP SND env)) + - LENGTH env` -(Induct >- rw[v_size_def] >> -Cases >> srw_tac[ARITH_ss][v_size_def]) + LENGTH env +Proof +Induct >- rw[v_size_def] >> +Cases >> srw_tac[ARITH_ss][v_size_def] +QED *) -Theorem exp_size_positive -`∀e. 0 < exp_size e` -(Induct >> srw_tac[ARITH_ss][exp_size_def]) +Theorem exp_size_positive: + ∀e. 0 < exp_size e +Proof +Induct >> srw_tac[ARITH_ss][exp_size_def] +QED val _ = export_rewrites["exp_size_positive"]; fun register name def ind = @@ -214,9 +226,10 @@ val (vs_to_string_def,vs_to_string_ind) = wf_rel_tac `measure LENGTH` \\ rw[]); val _ = register "vs_to_string" vs_to_string_def vs_to_string_ind; -Theorem check_dup_ctors_thm - `check_dup_ctors (tvs,tn,condefs) = ALL_DISTINCT (MAP FST condefs)` - (rw [check_dup_ctors_def] >> +Theorem check_dup_ctors_thm: + check_dup_ctors (tvs,tn,condefs) = ALL_DISTINCT (MAP FST condefs) +Proof + rw [check_dup_ctors_def] >> induct_on `condefs` >> rw [] >> pairarg_tac >> @@ -226,18 +239,21 @@ Theorem check_dup_ctors_thm induct_on `condefs` >> rw [] >> pairarg_tac >> - fs []); + fs [] +QED (* -Theorem do_log_thm - `do_log l v e = +Theorem do_log_thm: + do_log l v e = if l = And ∧ v = Conv(SOME("true",TypeId(Short"bool")))[] then SOME (Exp e) else if l = Or ∧ v = Conv(SOME("false",TypeId(Short"bool")))[] then SOME (Exp e) else if v = Conv(SOME("true",TypeId(Short"bool")))[] then SOME (Val v) else if v = Conv(SOME("false",TypeId(Short"bool")))[] then SOME (Val v) else - NONE` - (rw[semanticPrimitivesTheory.do_log_def] >> - every_case_tac >> rw[]) + NONE +Proof + rw[semanticPrimitivesTheory.do_log_def] >> + every_case_tac >> rw[] +QED *) val fix_clock_IMP = Q.prove( @@ -256,19 +272,23 @@ val (evaluate_def, evaluate_ind) = imp_res_tac fix_clock_IMP >> simp[SIMP_RULE(srw_ss())[]exps_size_thm,MAP_REVERSE,SUM_REVERSE]); -Theorem evaluate_clock - `(∀(s1:'ffi state) env e r s2. evaluate s1 env e = (s2,r) ⇒ s2.clock ≤ s1.clock) ∧ - (∀(s1:'ffi state) env v p v' r s2. evaluate_match s1 env v p v' = (s2,r) ⇒ s2.clock ≤ s1.clock)` - (ho_match_mp_tac evaluate_ind >> rw[evaluate_def] >> +Theorem evaluate_clock: + (∀(s1:'ffi state) env e r s2. evaluate s1 env e = (s2,r) ⇒ s2.clock ≤ s1.clock) ∧ + (∀(s1:'ffi state) env v p v' r s2. evaluate_match s1 env v p v' = (s2,r) ⇒ s2.clock ≤ s1.clock) +Proof + ho_match_mp_tac evaluate_ind >> rw[evaluate_def] >> every_case_tac >> fs[] >> rw[] >> rfs[] >> fs[dec_clock_def,fix_clock_def] >> simp[] >> - imp_res_tac fix_clock_IMP >> fs[]); + imp_res_tac fix_clock_IMP >> fs[] +QED -Theorem fix_clock_evaluate - `fix_clock s1 (evaluate s1 env e) = evaluate s1 env e` - (Cases_on `evaluate s1 env e` \\ fs [fix_clock_def] +Theorem fix_clock_evaluate: + fix_clock s1 (evaluate s1 env e) = evaluate s1 env e +Proof + Cases_on `evaluate s1 env e` \\ fs [fix_clock_def] \\ imp_res_tac evaluate_clock - \\ fs [MIN_DEF,state_component_equality]); + \\ fs [MIN_DEF,state_component_equality] +QED val evaluate_def = save_thm("evaluate_def", REWRITE_RULE [fix_clock_evaluate] evaluate_def |> INST_TYPE[alpha|->``:'ffi``] (* TODO: this is only broken because Lem sucks *)); @@ -280,9 +300,11 @@ val _ = register "evaluate" evaluate_def evaluate_ind val _ = export_rewrites["evaluate.list_result_def"]; -Theorem dec1_size_eq - `dec1_size xs = list_size dec_size xs` - (Induct_on `xs` \\ fs [dec_size_def, list_size_def]); +Theorem dec1_size_eq: + dec1_size xs = list_size dec_size xs +Proof + Induct_on `xs` \\ fs [dec_size_def, list_size_def] +QED val (evaluate_decs_def,evaluate_decs_ind) = tprove_no_defn ((evaluate_decs_def,evaluate_decs_ind), diff --git a/semantics/tokenUtilsScript.sml b/semantics/tokenUtilsScript.sml index f52a81ad41..32cebc527d 100644 --- a/semantics/tokenUtilsScript.sml +++ b/semantics/tokenUtilsScript.sml @@ -70,9 +70,11 @@ val destLongidT_def = Define` ` val _ = export_rewrites ["destLongidT_def"] -Theorem destLongidT_EQ_SOME[simp] - `destLongidT t = SOME strs ⇔ ∃str s. t = LongidT str s ∧ strs = (str, s)` - (Cases_on `t` >> simp[] >> metis_tac[]); +Theorem destLongidT_EQ_SOME[simp]: + destLongidT t = SOME strs ⇔ ∃str s. t = LongidT str s ∧ strs = (str, s) +Proof + Cases_on `t` >> simp[] >> metis_tac[] +QED val destTyvarPT_def = Define` (destTyvarPT (Lf (TOK (TyvarT s),_)) = SOME s) ∧ @@ -91,9 +93,11 @@ val destAlphaT_def = Define` `; val _ = export_rewrites ["destAlphaT_def"] -Theorem destAlphaT_EQ_SOME[simp] - `destAlphaT t = SOME s ⇔ t = AlphaT s` - (Cases_on `t` >> simp[]); +Theorem destAlphaT_EQ_SOME[simp]: + destAlphaT t = SOME s ⇔ t = AlphaT s +Proof + Cases_on `t` >> simp[] +QED val destSymbolT_def = Define` (destSymbolT (SymbolT s) = SOME s) ∧ @@ -101,9 +105,11 @@ val destSymbolT_def = Define` `; val _ = export_rewrites ["destSymbolT_def"] -Theorem destSymbolT_EQ_SOME[simp] - `destSymbolT t = SOME s ⇔ t = SymbolT s` - (Cases_on `t` >> simp[]); +Theorem destSymbolT_EQ_SOME[simp]: + destSymbolT t = SOME s ⇔ t = SymbolT s +Proof + Cases_on `t` >> simp[] +QED val destIntT_def = Define` (destIntT (IntT i) = SOME i) ∧ diff --git a/translator/ml_optimiseScript.sml b/translator/ml_optimiseScript.sml index bcb5739245..d50caf6db6 100644 --- a/translator/ml_optimiseScript.sml +++ b/translator/ml_optimiseScript.sml @@ -90,9 +90,11 @@ val REVERSE_BOTTOM_UP_OPT_LIST = prove( ``!xs. REVERSE (BOTTOM_UP_OPT_LIST f xs) = BOTTOM_UP_OPT_LIST f (REVERSE xs)``, Induct \\ fs [BOTTOM_UP_OPT_def,BOTTOM_UP_OPT_LIST_APPEND]); -Theorem dec_clock_with_clock[simp] - `(dec_clock st1 with clock := c) = st1 with clock := c` - (fs [state_component_equality,evaluateTheory.dec_clock_def]); +Theorem dec_clock_with_clock[simp]: + (dec_clock st1 with clock := c) = st1 with clock := c +Proof + fs [state_component_equality,evaluateTheory.dec_clock_def] +QED val s = ``s:'ffi semanticPrimitives$state`` @@ -392,13 +394,15 @@ val OPTIMISE_def = Define ` OPTIMISE = BOTTOM_UP_OPT (opt_sub_add o let_id) o BOTTOM_UP_OPT abs2let`; -Theorem Eval_OPTIMISE - `Eval env exp P ==> Eval env (OPTIMISE exp) P` - (simp [Eval_def] \\ rpt strip_tac +Theorem Eval_OPTIMISE: + Eval env exp P ==> Eval env (OPTIMISE exp) P +Proof + simp [Eval_def] \\ rpt strip_tac \\ first_x_assum(qspec_then`refs`strip_assume_tac) \\ qexists_tac `res` \\ fs [OPTIMISE_def] \\ qexists_tac`refs'` \\ match_mp_tac (MP_CANON BOTTOM_UP_OPT_THM) \\ fs [] - \\ metis_tac [BOTTOM_UP_OPT_THM,opt_sub_add_thm,let_id_thm,abs2let_thm]); + \\ metis_tac [BOTTOM_UP_OPT_THM,opt_sub_add_thm,let_id_thm,abs2let_thm] +QED val _ = export_theory(); diff --git a/translator/ml_pmatchScript.sml b/translator/ml_pmatchScript.sml index f91cacac33..3f15be835b 100644 --- a/translator/ml_pmatchScript.sml +++ b/translator/ml_pmatchScript.sml @@ -66,14 +66,16 @@ val EvalPatBind_def = Define` (Pmatch env refs [p] [av] = SOME env2) ∧ (pat vars = x)` -Theorem Pmatch_cons - `∀ps vs. +Theorem Pmatch_cons: + ∀ps vs. Pmatch env refs (p::ps) (v::vs) = case Pmatch env refs [p] [v] of | NONE => NONE - | SOME env' => Pmatch env' refs ps vs` - (Induct >> Cases_on`vs` >> simp[Pmatch_def] >> + | SOME env' => Pmatch env' refs ps vs +Proof + Induct >> Cases_on`vs` >> simp[Pmatch_def] >> BasicProvers.CASE_TAC >> - Cases_on`ps`>>simp[Pmatch_def]) + Cases_on`ps`>>simp[Pmatch_def] +QED val pmatch_imp_Pmatch = Q.prove( `(∀envC s p v env aenv. @@ -125,48 +127,56 @@ val pmatch_imp_Pmatch = Q.prove( |> SIMP_RULE std_ss [] |> curry save_thm "pmatch_imp_Pmatch" -Theorem Pmatch_SOME_const - `∀env refs ps vs env'. +Theorem Pmatch_SOME_const: + ∀env refs ps vs env'. Pmatch env refs ps vs = SOME env' ⇒ - env'.c = env.c` - (ho_match_mp_tac Pmatch_ind >> simp[Pmatch_def] >> + env'.c = env.c +Proof + ho_match_mp_tac Pmatch_ind >> simp[Pmatch_def] >> rw[] >> BasicProvers.EVERY_CASE_TAC >> fs[] >> - fs[write_def]) + fs[write_def] +QED -Theorem pmatch_PMATCH_ROW_COND_No_match - `EvalPatRel env a p pat ∧ +Theorem pmatch_PMATCH_ROW_COND_No_match: + EvalPatRel env a p pat ∧ (∀vars. ¬PMATCH_ROW_COND pat (K T) xv vars) ∧ a xv res ⇒ - pmatch env.c refs p res [] = No_match` - (fs [PMATCH_ROW_COND_def] >> + pmatch env.c refs p res [] = No_match +Proof + fs [PMATCH_ROW_COND_def] >> rw[EvalPatRel_def] >> first_x_assum(fn th => first_x_assum(strip_assume_tac o MATCH_MP th)) >> first_x_assum(qspec_then`refs`mp_tac) >> simp [evaluate_def] >> - every_case_tac >> fs []); + every_case_tac >> fs [] +QED -Theorem pmatch_PMATCH_ROW_COND_Match - `EvalPatRel env a p pat ∧ +Theorem pmatch_PMATCH_ROW_COND_Match: + EvalPatRel env a p pat ∧ PMATCH_ROW_COND pat (K T) xv vars ∧ a xv res - ⇒ ∃env2. pmatch env.c refs p res [] = Match env2` - (rw[EvalPatRel_def,PMATCH_ROW_COND_def] >> + ⇒ ∃env2. pmatch env.c refs p res [] = Match env2 +Proof + rw[EvalPatRel_def,PMATCH_ROW_COND_def] >> first_x_assum(fn th => first_x_assum(strip_assume_tac o MATCH_MP th)) >> first_x_assum(qspec_then`refs`mp_tac) >> simp [evaluate_def] >> every_case_tac >> fs [pmatch_def,build_conv_def,do_con_check_def] >> - metis_tac []); + metis_tac [] +QED -Theorem Eval_PMATCH_NIL - `!b x xv a. +Theorem Eval_PMATCH_NIL: + !b x xv a. Eval env x (a xv) ==> CONTAINER F ==> - Eval env (Mat x []) (b (PMATCH xv []))` - (rw[CONTAINER_def]); + Eval env (Mat x []) (b (PMATCH xv [])) +Proof + rw[CONTAINER_def] +QED -Theorem Eval_PMATCH - `!b a x xv. +Theorem Eval_PMATCH: + !b a x xv. ALL_DISTINCT (pat_bindings p []) ⇒ (∀v1 v2. pat v1 = pat v2 ⇒ v1 = v2) ⇒ Eval env x (a xv) ⇒ @@ -177,8 +187,9 @@ Theorem Eval_PMATCH Eval env2 e (b (res vars))) ⇒ (∀vars. CONTAINER (PMATCH_ROW_COND pat (K T) xv vars) ⇒ p2 vars) ∧ ((∀vars. ¬CONTAINER (PMATCH_ROW_COND pat (K T) xv vars)) ⇒ p1 xv) ⇒ - Eval env (Mat x ((p,e)::ys)) (b (PMATCH xv ((PMATCH_ROW pat (K T) res)::yrs)))` - (rw[Eval_def,CONTAINER_def] + Eval env (Mat x ((p,e)::ys)) (b (PMATCH xv ((PMATCH_ROW pat (K T) res)::yrs))) +Proof + rw[Eval_def,CONTAINER_def] \\ rw[evaluate_def,PULL_EXISTS] \\ fs[] \\ first_x_assum(qspec_then`refs`strip_assume_tac) \\ reverse (Cases_on`∃vars. PMATCH_ROW_COND pat (K T) xv vars` >> fs[]) @@ -233,19 +244,24 @@ Theorem Eval_PMATCH \\ fs [state_component_equality] \\ simp[PMATCH_def,PMATCH_ROW_def,PMATCH_ROW_COND_def] \\ qsuff_tac `(some x. pat x = pat vars) = SOME vars` \\ simp [] - \\ simp[optionTheory.some_def] \\ metis_tac []); + \\ simp[optionTheory.some_def] \\ metis_tac [] +QED -Theorem PMATCH_option_case_rwt - `((case x of NONE => NONE +Theorem PMATCH_option_case_rwt: + ((case x of NONE => NONE | SOME (y1,y2) => P y1 y2) = SOME env2) <=> - ?y1 y2. (x = SOME (y1,y2)) /\ (P y1 y2 = SOME env2)` - (Cases_on `x` \\ fs [] \\ Cases_on `x'` \\ fs []); + ?y1 y2. (x = SOME (y1,y2)) /\ (P y1 y2 = SOME env2) +Proof + Cases_on `x` \\ fs [] \\ Cases_on `x'` \\ fs [] +QED -Theorem PMATCH_SIMP - `((∀vars. ¬CONTAINER (vars = x)) = F) /\ +Theorem PMATCH_SIMP: + ((∀vars. ¬CONTAINER (vars = x)) = F) /\ ((∀vars. ¬CONTAINER (x = vars)) = F) /\ ((∀vars. ¬(vars = x)) = F) /\ - ((∀vars. ¬(x = vars)) = F)` - (fs [CONTAINER_def]); + ((∀vars. ¬(x = vars)) = F) +Proof + fs [CONTAINER_def] +QED val _ = export_theory() diff --git a/translator/ml_progScript.sml b/translator/ml_progScript.sml index 5a2fcfb0a8..6de6120b93 100644 --- a/translator/ml_progScript.sml +++ b/translator/ml_progScript.sml @@ -49,118 +49,146 @@ val nsLookup_Short_def = zDefine ` val nsLookup_Mod1_def = zDefine ` nsLookup_Mod1 ns = (case ns of Bind _ ms => ALOOKUP ms)`; -Theorem nsLookup_eq - `nsLookup ns (Short nm) = nsLookup_Short ns nm /\ +Theorem nsLookup_eq: + nsLookup ns (Short nm) = nsLookup_Short ns nm /\ nsLookup ns (Long mnm id) = (case nsLookup_Mod1 ns mnm of - NONE => NONE | SOME ns2 => nsLookup ns2 id)` - (fs [nsLookup_Short_def] + NONE => NONE | SOME ns2 => nsLookup ns2 id) +Proof + fs [nsLookup_Short_def] \\ Cases_on `ns` - \\ fs[nsLookup_Mod1_def, nsLookup_def]); + \\ fs[nsLookup_Mod1_def, nsLookup_def] +QED (* base facts about the partial functions *) -Theorem option_choice_f_apply - `option_choice_f f g x = OPTION_CHOICE (f x) (g x)` - (fs [option_choice_f_def]); - -Theorem nsLookup_Short_Bind - `nsLookup_Short (Bind ss ms) = ALOOKUP ss` - (fs [nsLookup_Short_def, nsLookup_def, FUN_EQ_THM]); - -Theorem nsLookup_Short_nsAppend - `nsLookup_Short (nsAppend ns1 ns2) - = option_choice_f (nsLookup_Short ns1) (nsLookup_Short ns2)` - (Cases_on `ns1` \\ Cases_on `ns2` +Theorem option_choice_f_apply: + option_choice_f f g x = OPTION_CHOICE (f x) (g x) +Proof + fs [option_choice_f_def] +QED + +Theorem nsLookup_Short_Bind: + nsLookup_Short (Bind ss ms) = ALOOKUP ss +Proof + fs [nsLookup_Short_def, nsLookup_def, FUN_EQ_THM] +QED + +Theorem nsLookup_Short_nsAppend: + nsLookup_Short (nsAppend ns1 ns2) + = option_choice_f (nsLookup_Short ns1) (nsLookup_Short ns2) +Proof + Cases_on `ns1` \\ Cases_on `ns2` \\ fs [nsLookup_Short_Bind, nsAppend_def, - alookup_append_option_choice_f]); - -Theorem nsLookup_Mod1_Bind - `nsLookup_Mod1 (Bind ss ms) nm = ALOOKUP ms nm` - (fs [nsLookup_Mod1_def]); - -Theorem nsLookup_Mod1_nsAppend - `nsLookup_Mod1 (nsAppend ns1 ns2) - = option_choice_f (nsLookup_Mod1 ns1) (nsLookup_Mod1 ns2)` - (Cases_on `ns1` \\ Cases_on `ns2` + alookup_append_option_choice_f] +QED + +Theorem nsLookup_Mod1_Bind: + nsLookup_Mod1 (Bind ss ms) nm = ALOOKUP ms nm +Proof + fs [nsLookup_Mod1_def] +QED + +Theorem nsLookup_Mod1_nsAppend: + nsLookup_Mod1 (nsAppend ns1 ns2) + = option_choice_f (nsLookup_Mod1 ns1) (nsLookup_Mod1 ns2) +Proof + Cases_on `ns1` \\ Cases_on `ns2` \\ fs [nsLookup_Mod1_def, nsAppend_def, - alookup_append_option_choice_f]); - -Theorem nsLookup_Short_nsLift - `nsLookup_Short (nsLift mnm ns) = ALOOKUP []` - (Cases_on `ns` \\ fs [nsLift_def, nsLookup_Short_Bind]); - -Theorem nsLookup_Mod1_nsLift - `nsLookup_Mod1 (nsLift mnm ns) = ALOOKUP [(mnm, ns)]` - (Cases_on `ns` \\ fs [nsLift_def, nsLookup_Mod1_def]); - -Theorem nsLookup_pf_nsBind - `nsLookup_Short (nsBind n v ns) + alookup_append_option_choice_f] +QED + +Theorem nsLookup_Short_nsLift: + nsLookup_Short (nsLift mnm ns) = ALOOKUP [] +Proof + Cases_on `ns` \\ fs [nsLift_def, nsLookup_Short_Bind] +QED + +Theorem nsLookup_Mod1_nsLift: + nsLookup_Mod1 (nsLift mnm ns) = ALOOKUP [(mnm, ns)] +Proof + Cases_on `ns` \\ fs [nsLift_def, nsLookup_Mod1_def] +QED + +Theorem nsLookup_pf_nsBind: + nsLookup_Short (nsBind n v ns) = option_choice_f (ALOOKUP [(n, v)]) (nsLookup_Short ns) /\ - nsLookup_Mod1 (nsBind n v ns) = nsLookup_Mod1 ns` - (Cases_on `ns` + nsLookup_Mod1 (nsBind n v ns) = nsLookup_Mod1 ns +Proof + Cases_on `ns` \\ fs [nsLookup_Short_def,nsLookup_Mod1_def, FUN_EQ_THM, write_def,nsLookup_def,nsBind_def,option_choice_f_def] \\ rpt strip_tac - \\ fs [] \\ CASE_TAC \\ fs []); + \\ fs [] \\ CASE_TAC \\ fs [] +QED (* equalities on these partial functions for the various env operators *) -Theorem nsLookup_write_eqs - `nsLookup_Short ((write n v env).c) = nsLookup_Short env.c /\ +Theorem nsLookup_write_eqs: + nsLookup_Short ((write n v env).c) = nsLookup_Short env.c /\ nsLookup_Mod1 ((write n v env).c) = nsLookup_Mod1 env.c /\ nsLookup_Mod1 ((write n v env).v) = nsLookup_Mod1 env.v /\ nsLookup_Short ((write n v env).v) = option_choice_f (ALOOKUP [(n, v)]) - (nsLookup_Short env.v)` - (fs[write_def, nsLookup_pf_nsBind] -); + (nsLookup_Short env.v) +Proof + fs[write_def, nsLookup_pf_nsBind] +QED -Theorem nsLookup_write_cons_eqs - `nsLookup_Short ((write_cons n v env).v) = nsLookup_Short env.v /\ +Theorem nsLookup_write_cons_eqs: + nsLookup_Short ((write_cons n v env).v) = nsLookup_Short env.v /\ nsLookup_Mod1 ((write_cons n v env).v) = nsLookup_Mod1 env.v /\ nsLookup_Mod1 ((write_cons n v env).c) = nsLookup_Mod1 env.c /\ nsLookup_Short ((write_cons n v env).c) = option_choice_f (ALOOKUP [(n, v)]) - (nsLookup_Short env.c)` - (fs[write_cons_def, nsLookup_pf_nsBind] -); + (nsLookup_Short env.c) +Proof + fs[write_cons_def, nsLookup_pf_nsBind] +QED -Theorem nsLookup_merge_env_eqs - `nsLookup_Short ((merge_env env env2).v) +Theorem nsLookup_merge_env_eqs: + nsLookup_Short ((merge_env env env2).v) = option_choice_f (nsLookup_Short env.v) (nsLookup_Short env2.v) /\ nsLookup_Mod1 ((merge_env env env2).v) = option_choice_f (nsLookup_Mod1 env.v) (nsLookup_Mod1 env2.v) /\ nsLookup_Short ((merge_env env env2).c) = option_choice_f (nsLookup_Short env.c) (nsLookup_Short env2.c) /\ nsLookup_Mod1 ((merge_env env env2).c) - = option_choice_f (nsLookup_Mod1 env.c) (nsLookup_Mod1 env2.c)` - (fs[merge_env_def, nsLookup_Short_nsAppend, nsLookup_Mod1_nsAppend]); + = option_choice_f (nsLookup_Mod1 env.c) (nsLookup_Mod1 env2.c) +Proof + fs[merge_env_def, nsLookup_Short_nsAppend, nsLookup_Mod1_nsAppend] +QED -Theorem nsLookup_write_mod_eqs - `nsLookup_Short ((write_mod mnm env env2).v) = nsLookup_Short env2.v /\ +Theorem nsLookup_write_mod_eqs: + nsLookup_Short ((write_mod mnm env env2).v) = nsLookup_Short env2.v /\ nsLookup_Mod1 ((write_mod mnm env env2).v) = option_choice_f (ALOOKUP [(mnm, env.v)]) (nsLookup_Mod1 env2.v) /\ nsLookup_Short ((write_mod mnm env env2).c) = nsLookup_Short env2.c /\ nsLookup_Mod1 ((write_mod mnm env env2).c) - = option_choice_f (ALOOKUP [(mnm, env.c)]) (nsLookup_Mod1 env2.c)` - (fs[write_mod_def, nsLookup_Short_nsAppend, nsLookup_Mod1_nsAppend, + = option_choice_f (ALOOKUP [(mnm, env.c)]) (nsLookup_Mod1 env2.c) +Proof + fs[write_mod_def, nsLookup_Short_nsAppend, nsLookup_Mod1_nsAppend, nsLookup_Short_nsLift, nsLookup_Mod1_nsLift, - alookup_empty_option_choice_f]); + alookup_empty_option_choice_f] +QED -Theorem nsLookup_empty_eqs - `nsLookup_Short empty_env.v = ALOOKUP [] /\ +Theorem nsLookup_empty_eqs: + nsLookup_Short empty_env.v = ALOOKUP [] /\ nsLookup_Mod1 empty_env.v = ALOOKUP [] /\ nsLookup_Short empty_env.c = ALOOKUP [] /\ - nsLookup_Mod1 empty_env.c = ALOOKUP []` - (fs[empty_env_def, nsEmpty_def, nsLookup_Short_Bind, nsLookup_Mod1_def]); + nsLookup_Mod1 empty_env.c = ALOOKUP [] +Proof + fs[empty_env_def, nsEmpty_def, nsLookup_Short_Bind, nsLookup_Mod1_def] +QED (* nonsense theorem instantiated when env's are defined *) -Theorem nsLookup_eq_format - `!env:v sem_env. +Theorem nsLookup_eq_format: + !env:v sem_env. (nsLookup_Short env.v = nsLookup_Short env.v) /\ (nsLookup_Short env.c = nsLookup_Short env.c) /\ (nsLookup_Mod1 env.v = nsLookup_Mod1 env.v) /\ - (nsLookup_Mod1 env.c = nsLookup_Mod1 env.c)` - (rewrite_tac []); + (nsLookup_Mod1 env.c = nsLookup_Mod1 env.c) +Proof + rewrite_tac [] +QED (* some shorthands that are allowed to EVAL are below *) @@ -168,14 +196,16 @@ val write_rec_def = Define ` write_rec funs env1 env = FOLDR (\f env. write (FST f) (Recclosure env1 funs (FST f)) env) env funs`; -Theorem write_rec_thm - `write_rec funs env1 env = - env with v := build_rec_env funs env1 env.v` - (fs [write_rec_def,build_rec_env_def] +Theorem write_rec_thm: + write_rec funs env1 env = + env with v := build_rec_env funs env1 env.v +Proof + fs [write_rec_def,build_rec_env_def] \\ qspec_tac (`Recclosure env1 funs`,`hh`) \\ qspec_tac (`env`,`env`) \\ Induct_on `funs` \\ fs [FORALL_PROD] - \\ fs [write_def]); + \\ fs [write_def] +QED val write_conses_def = Define ` write_conses ([] :(tvarN, type_ident # stamp) alist) env = env /\ @@ -202,10 +232,12 @@ val write_tdefs_lemma = prove( \\ Q.SPEC_TAC (`REVERSE (build_constrs n p_2)`,`xs`) \\ Induct \\ fs [write_conses_def,FORALL_PROD,write_cons_def]); -Theorem write_tdefs_thm - `write_tdefs n tds empty_env = - <|v := nsEmpty; c := build_tdefs n tds|>` - (fs [write_tdefs_lemma,empty_env_def,merge_env_def]); +Theorem write_tdefs_thm: + write_tdefs n tds empty_env = + <|v := nsEmpty; c := build_tdefs n tds|> +Proof + fs [write_tdefs_lemma,empty_env_def,merge_env_def] +QED val merge_env_write_conses = prove( ``!xs env. merge_env (write_conses xs env1) env2 = @@ -222,31 +254,37 @@ val merge_env_write_tdefs = prove( (* it's not clear if these are still needed, but ml_progComputeLib and cfTacticsLib want them to be present. *) -Theorem nsLookup_nsAppend_Short[compute] ` - (nsLookup (nsAppend e1 e2) (Short id) = +Theorem nsLookup_nsAppend_Short[compute]: + (nsLookup (nsAppend e1 e2) (Short id) = case nsLookup e1 (Short id) of NONE => nsLookup e2 (Short id) - | SOME v => SOME v)` - (every_case_tac>> + | SOME v => SOME v) +Proof + every_case_tac>> Cases_on`nsLookup e2(Short id)`>> fs[namespacePropsTheory.nsLookup_nsAppend_some, - namespacePropsTheory.nsLookup_nsAppend_none,id_to_mods_def]); + namespacePropsTheory.nsLookup_nsAppend_none,id_to_mods_def] +QED -Theorem write_simp[compute] - `(write n v env).c = env.c /\ +Theorem write_simp[compute]: + (write n v env).c = env.c /\ nsLookup (write n v env).v (Short q) = - if n = q then SOME v else nsLookup env.v (Short q)` - (IF_CASES_TAC>>fs[write_def,namespacePropsTheory.nsLookup_nsBind]); + if n = q then SOME v else nsLookup env.v (Short q) +Proof + IF_CASES_TAC>>fs[write_def,namespacePropsTheory.nsLookup_nsBind] +QED -Theorem write_cons_simp[compute] - `(write_cons n v env).v = env.v /\ +Theorem write_cons_simp[compute]: + (write_cons n v env).v = env.v /\ nsLookup (write_cons n v env).c (Short q) = - if n = q then SOME v else nsLookup env.c (Short q)` - (IF_CASES_TAC>>fs[write_cons_def,namespacePropsTheory.nsLookup_nsBind]); + if n = q then SOME v else nsLookup env.c (Short q) +Proof + IF_CASES_TAC>>fs[write_cons_def,namespacePropsTheory.nsLookup_nsBind] +QED -Theorem write_mod_simp[compute] - `(nsLookup (write_mod mn env env2).v (Short q) = +Theorem write_mod_simp[compute]: + (nsLookup (write_mod mn env env2).v (Short q) = nsLookup env2.v (Short q)) ∧ (nsLookup (write_mod mn env env2).c (Short c) = nsLookup env2.c (Short c)) ∧ @@ -255,13 +293,17 @@ Theorem write_mod_simp[compute] else nsLookup env2.v (Long mn' r)) ∧ (nsLookup (write_mod mn env env2).c (Long mn' s) = if mn = mn' then nsLookup env.c s - else nsLookup env2.c (Long mn' s))` - (rw[write_mod_def]); - -Theorem empty_simp[compute] - `nsLookup empty_env.v q = NONE /\ - nsLookup empty_env.c q = NONE` - (fs [empty_env_def] ); + else nsLookup env2.c (Long mn' s)) +Proof + rw[write_mod_def] +QED + +Theorem empty_simp[compute]: + nsLookup empty_env.v q = NONE /\ + nsLookup empty_env.c q = NONE +Proof + fs [empty_env_def] +QED (* the components of nsLookup are 'nicer' partial functions *) @@ -275,33 +317,39 @@ val Decls_def = Define ` ?ck1 ck2. evaluate_decs (s1 with clock := ck1) env ds = (s2 with clock := ck2, Rval env2)`; -Theorem Decls_Dtype - `!env s tds env2 s2 locs. +Theorem Decls_Dtype: + !env s tds env2 s2 locs. Decls env s [Dtype locs tds] env2 s2 <=> EVERY check_dup_ctors tds /\ s2 = s with <| next_type_stamp := (s.next_type_stamp + LENGTH tds) |> /\ - env2 = write_tdefs s.next_type_stamp tds empty_env` - (SIMP_TAC std_ss [Decls_def,evaluate_decs_def] + env2 = write_tdefs s.next_type_stamp tds empty_env +Proof + SIMP_TAC std_ss [Decls_def,evaluate_decs_def] \\ rw [] \\ eq_tac \\ rw [] \\ fs [bool_case_eq] - \\ rveq \\ fs [state_component_equality,write_tdefs_thm]); + \\ rveq \\ fs [state_component_equality,write_tdefs_thm] +QED -Theorem Decls_Dexn - `!env s n l env2 s2 locs. +Theorem Decls_Dexn: + !env s n l env2 s2 locs. Decls env s [Dexn locs n l] env2 s2 <=> s2 = s with <| next_exn_stamp := (s.next_exn_stamp + 1) |> /\ - env2 = write_cons n (LENGTH l, ExnStamp s.next_exn_stamp) empty_env` - (SIMP_TAC std_ss [Decls_def,evaluate_decs_def,write_cons_def] + env2 = write_cons n (LENGTH l, ExnStamp s.next_exn_stamp) empty_env +Proof + SIMP_TAC std_ss [Decls_def,evaluate_decs_def,write_cons_def] \\ rw [] \\ eq_tac \\ rw [] \\ fs [bool_case_eq] \\ rveq \\ fs [state_component_equality,write_tdefs_thm] - \\ fs [nsBind_def,nsEmpty_def,nsSing_def,empty_env_def]); + \\ fs [nsBind_def,nsEmpty_def,nsSing_def,empty_env_def] +QED -Theorem Decls_Dtabbrev - `!env s x y z env2 s2 locs. +Theorem Decls_Dtabbrev: + !env s x y z env2 s2 locs. Decls env s [Dtabbrev locs x y z] env2 s2 <=> - s2 = s ∧ env2 = empty_env` - (fs [Decls_def,evaluate_decs_def] + s2 = s ∧ env2 = empty_env +Proof + fs [Decls_def,evaluate_decs_def] \\ rw [] \\ eq_tac \\ rw [] \\ fs [bool_case_eq] - \\ rveq \\ fs [state_component_equality,empty_env_def]); + \\ rveq \\ fs [state_component_equality,empty_env_def] +QED val eval_rel_def = Define ` eval_rel s1 env e s2 x <=> @@ -310,16 +358,18 @@ val eval_rel_def = Define ` evaluate (s1 with clock := ck1) env [e] = (s2 with clock := ck2,Rval [x])` -Theorem eval_rel_alt - `eval_rel s1 env e s2 x <=> +Theorem eval_rel_alt: + eval_rel s1 env e s2 x <=> s2.clock = s1.clock ∧ - ∃ck. evaluate (s1 with clock := ck) env [e] = (s2,Rval [x])` - (reverse eq_tac \\ rw [] \\ fs [eval_rel_def] + ∃ck. evaluate (s1 with clock := ck) env [e] = (s2,Rval [x]) +Proof + reverse eq_tac \\ rw [] \\ fs [eval_rel_def] THEN1 (qexists_tac `ck` \\ fs [state_component_equality]) \\ drule evaluatePropsTheory.evaluate_set_clock \\ fs [] \\ disch_then (qspec_then `s2.clock` strip_assume_tac) \\ rename [`evaluate (s1 with clock := ck) env [e]`] - \\ qexists_tac `ck` \\ fs [state_component_equality]); + \\ qexists_tac `ck` \\ fs [state_component_equality] +QED val eval_list_rel_def = Define ` eval_list_rel s1 env e s2 x <=> @@ -337,11 +387,12 @@ val eval_match_rel_def = Define ` (s2 with clock := ck2,Rval [x])` (* Delays the write *) -Theorem Decls_Dlet - `!env s1 v e s2 env2 locs. +Theorem Decls_Dlet: + !env s1 v e s2 env2 locs. Decls env s1 [Dlet locs (Pvar v) e] env2 s2 <=> - ?x. eval_rel s1 env e s2 x /\ (env2 = write v x empty_env)` - (simp [Decls_def,evaluate_decs_def,eval_rel_def] + ?x. eval_rel s1 env e s2 x /\ (env2 = write v x empty_env) +Proof + simp [Decls_def,evaluate_decs_def,eval_rel_def] \\ rw [] \\ eq_tac \\ rw [] \\ fs [bool_case_eq] THEN1 (FULL_CASE_TAC @@ -352,7 +403,8 @@ Theorem Decls_Dlet \\ fs [pat_bindings_def,ALL_DISTINCT,MEM, pmatch_def,combine_dec_result_def] \\ qexists_tac `ck1` \\ qexists_tac `ck2` - \\ fs [write_def,empty_env_def]); + \\ fs [write_def,empty_env_def] +QED val FOLDR_LEMMA = Q.prove( `!xs ys. FOLDR (\(x1,x2,x3) x4. (x1, f x1 x2 x3) :: x4) [] xs ++ ys = @@ -360,13 +412,14 @@ val FOLDR_LEMMA = Q.prove( Induct \\ FULL_SIMP_TAC (srw_ss()) [FORALL_PROD]); (* Delays the write in build_rec_env *) -Theorem Decls_Dletrec - `!env s1 funs s2 env2 locs. +Theorem Decls_Dletrec: + !env s1 funs s2 env2 locs. Decls env s1 [Dletrec locs funs] env2 s2 <=> (s2 = s1) /\ ALL_DISTINCT (MAP (\(x,y,z). x) funs) /\ - (env2 = write_rec funs env empty_env)` - (simp [Decls_def,evaluate_decs_def,bool_case_eq,PULL_EXISTS] + (env2 = write_rec funs env empty_env) +Proof + simp [Decls_def,evaluate_decs_def,bool_case_eq,PULL_EXISTS] \\ rw [] \\ eq_tac \\ rw [] \\ fs [] \\ fs [state_component_equality,write_rec_def] \\ fs[write_def,write_rec_thm,empty_env_def,build_rec_env_def] @@ -374,42 +427,50 @@ Theorem Decls_Dletrec \\ qspec_tac (`Recclosure env funs`,`xx`) \\ qspec_tac (`nsEmpty:env_val`,`nn`) \\ Induct_on `funs` \\ fs [FORALL_PROD] - \\ pop_assum (assume_tac o GSYM) \\ fs []); + \\ pop_assum (assume_tac o GSYM) \\ fs [] +QED -Theorem Decls_Dmod - `Decls env1 s1 [Dmod mn ds] env2 s2 <=> +Theorem Decls_Dmod: + Decls env1 s1 [Dmod mn ds] env2 s2 <=> ?s env. Decls env1 s1 ds env s /\ s2 = s /\ - env2 = write_mod mn env empty_env` - (fs [Decls_def,Decls_def,evaluate_decs_def,PULL_EXISTS, + env2 = write_mod mn env empty_env +Proof + fs [Decls_def,Decls_def,evaluate_decs_def,PULL_EXISTS, combine_dec_result_def,write_mod_def,empty_env_def] \\ rw [] \\ eq_tac \\ rw [] \\ fs [pair_case_eq,result_case_eq] - \\ rveq \\ fs [] \\ asm_exists_tac \\ fs []); + \\ rveq \\ fs [] \\ asm_exists_tac \\ fs [] +QED -Theorem Decls_Dlocal - `Decls env st lds env2 st2 +Theorem Decls_Dlocal: + Decls env st lds env2 st2 ==> Decls (merge_env env2 env) st2 ds env3 st3 - ==> Decls env st [Dlocal lds ds] env3 st3` - (fs [Decls_def,evaluate_decs_def,extend_dec_env_def,merge_env_def] + ==> Decls env st [Dlocal lds ds] env3 st3 +Proof + fs [Decls_def,evaluate_decs_def,extend_dec_env_def,merge_env_def] \\ rw [pair_case_eq, result_case_eq] \\ imp_res_tac evaluate_decs_set_clock - \\ fs [] \\ metis_tac []); + \\ fs [] \\ metis_tac [] +QED -Theorem Decls_NIL - `!env s n l env2 s2. +Theorem Decls_NIL: + !env s n l env2 s2. Decls env s [] env2 s2 <=> - s2 = s ∧ env2 = empty_env` - (fs [Decls_def,evaluate_decs_def,state_component_equality,empty_env_def] - \\ rw [] \\ eq_tac \\ rw []); - -Theorem Decls_CONS - `!s1 s3 env1 d ds1 ds2 env3. + s2 = s ∧ env2 = empty_env +Proof + fs [Decls_def,evaluate_decs_def,state_component_equality,empty_env_def] + \\ rw [] \\ eq_tac \\ rw [] +QED + +Theorem Decls_CONS: + !s1 s3 env1 d ds1 ds2 env3. Decls env1 s1 (d::ds2) env3 s3 = ?envA envB s2. Decls env1 s1 [d] envA s2 /\ Decls (merge_env envA env1) s2 ds2 envB s3 /\ - env3 = merge_env envB envA` - (rw[Decls_def,PULL_EXISTS,evaluate_decs_def] + env3 = merge_env envB envA +Proof + rw[Decls_def,PULL_EXISTS,evaluate_decs_def] \\ reverse (rw[EQ_IMP_THM]) \\ fs [] THEN1 (once_rewrite_tac [evaluate_decs_cons] @@ -430,36 +491,45 @@ Theorem Decls_CONS \\ qexists_tac `s1'.clock` \\ fs [state_component_equality] \\ `(s1' with clock := s1'.clock) = s1'` by fs [state_component_equality] \\ fs [extend_dec_env_def] - \\ fs [state_component_equality]); - -Theorem merge_env_empty_env - `merge_env env empty_env = env /\ - merge_env empty_env env = env` - (rw [merge_env_def,empty_env_def]); - -Theorem merge_env_assoc - `merge_env env1 (merge_env env2 env3) = merge_env (merge_env env1 env2) env3` - (fs [merge_env_def]); - -Theorem Decls_APPEND - `!s1 s3 env1 ds1 ds2 env3. + \\ fs [state_component_equality] +QED + +Theorem merge_env_empty_env: + merge_env env empty_env = env /\ + merge_env empty_env env = env +Proof + rw [merge_env_def,empty_env_def] +QED + +Theorem merge_env_assoc: + merge_env env1 (merge_env env2 env3) = merge_env (merge_env env1 env2) env3 +Proof + fs [merge_env_def] +QED + +Theorem Decls_APPEND: + !s1 s3 env1 ds1 ds2 env3. Decls env1 s1 (ds1 ++ ds2) env3 s3 = ?envA envB s2. Decls env1 s1 ds1 envA s2 /\ Decls (merge_env envA env1) s2 ds2 envB s3 /\ - env3 = merge_env envB envA` - (Induct_on `ds1` \\ fs [APPEND,Decls_NIL,merge_env_empty_env] + env3 = merge_env envB envA +Proof + Induct_on `ds1` \\ fs [APPEND,Decls_NIL,merge_env_empty_env] \\ once_rewrite_tac [Decls_CONS] - \\ fs [PULL_EXISTS,merge_env_assoc] \\ metis_tac []); + \\ fs [PULL_EXISTS,merge_env_assoc] \\ metis_tac [] +QED -Theorem Decls_SNOC - `!s1 s3 env1 ds1 d env3. +Theorem Decls_SNOC: + !s1 s3 env1 ds1 d env3. Decls env1 s1 (SNOC d ds1) env3 s3 = ?envA envB s2. Decls env1 s1 ds1 envA s2 /\ Decls (merge_env envA env1) s2 [d] envB s3 /\ - env3 = merge_env envB envA` - (METIS_TAC [SNOC_APPEND, Decls_APPEND]); + env3 = merge_env envB envA +Proof + METIS_TAC [SNOC_APPEND, Decls_APPEND] +QED (* The translator and CF tools use the following definition of ML_code @@ -482,10 +552,12 @@ val ML_code_def = Define `(ML_code env [] res_st <=> T) /\ Decls (ML_code_env env bls) st decls res_env res_st))`; (* retreive the Decls from a toplevel ML_code *) -Theorem ML_code_Decls - `ML_code env1 [(comm, st1, prog, env2)] st2 ==> - Decls env1 st1 prog env2 st2` - (fs [ML_code_def, ML_code_env_def]); +Theorem ML_code_Decls: + ML_code env1 [(comm, st1, prog, env2)] st2 ==> + Decls env1 st1 prog env2 st2 +Proof + fs [ML_code_def, ML_code_env_def] +QED (* an empty program *) local open primSemEnvTheory in @@ -508,9 +580,11 @@ in init_state ffi = ^init_state_tm`; end -Theorem init_state_env_thm - `THE (prim_sem_env ffi) = (init_state ffi,init_env)` - (rewrite_tac[prim_sem_env_eq,THE_DEF,init_state_def,init_env_def]); +Theorem init_state_env_thm: + THE (prim_sem_env ffi) = (init_state ffi,init_env) +Proof + rewrite_tac[prim_sem_env_eq,THE_DEF,init_state_def,init_env_def] +QED val nsLookup_init_env_pfun_eqs = save_thm("nsLookup_init_env_pfun_eqs", [``nsLookup_Short init_env.c``, ``nsLookup_Short init_env.v``, @@ -522,75 +596,89 @@ val nsLookup_init_env_pfun_eqs = save_thm("nsLookup_init_env_pfun_eqs", end -Theorem ML_code_NIL - `ML_code init_env [(("Toplevel", ""), init_state ffi, [], empty_env)] - (init_state ffi)` - (fs [ML_code_def,Decls_NIL]); +Theorem ML_code_NIL: + ML_code init_env [(("Toplevel", ""), init_state ffi, [], empty_env)] + (init_state ffi) +Proof + fs [ML_code_def,Decls_NIL] +QED (* opening and closing of modules *) -Theorem ML_code_new_block - `!comm2. ML_code inp_env ((comm, st, decls, env) :: bls) st2 ==> +Theorem ML_code_new_block: + !comm2. ML_code inp_env ((comm, st, decls, env) :: bls) st2 ==> let env2 = ML_code_env inp_env ((comm, st, decls, env) :: bls) in ML_code inp_env ((comm2, st2, [], empty_env) - :: (comm, st, decls, env) :: bls) st2` - (fs [ML_code_def] \\ rw [Decls_NIL] \\ EVAL_TAC); + :: (comm, st, decls, env) :: bls) st2 +Proof + fs [ML_code_def] \\ rw [Decls_NIL] \\ EVAL_TAC +QED -Theorem ML_code_close_module - `ML_code inp_env ((("Module", mn), m_i_st, m_decls, m_env) +Theorem ML_code_close_module: + ML_code inp_env ((("Module", mn), m_i_st, m_decls, m_env) :: (comm, st, decls, env) :: bls) st2 ==> let env2 = write_mod mn m_env env in ML_code inp_env ((comm, st, SNOC (Dmod mn m_decls) decls, - env2) :: bls) st2` - (rw [ML_code_def, ML_code_env_def] + env2) :: bls) st2 +Proof + rw [ML_code_def, ML_code_env_def] \\ fs [SNOC_APPEND,Decls_APPEND] \\ asm_exists_tac \\ fs [Decls_Dmod,PULL_EXISTS] \\ asm_exists_tac - \\ fs [write_mod_def,merge_env_def,empty_env_def]); + \\ fs [write_mod_def,merge_env_def,empty_env_def] +QED -Theorem ML_code_close_local - `ML_code inp_env ((("Local", ln2), l2_i_st, l2_decls, l2_env) +Theorem ML_code_close_local: + ML_code inp_env ((("Local", ln2), l2_i_st, l2_decls, l2_env) :: (("Local", ln1), l1_i_st, l1_decls, l1_env) :: (comm, st, decls, env) :: bls) st2 ==> let env2 = merge_env l2_env env in ML_code inp_env ((comm, st, SNOC (Dlocal l1_decls l2_decls) decls, - env2) :: bls) st2` - (rw [ML_code_def, ML_code_env_def] - \\ fs [SNOC_APPEND,Decls_APPEND] \\ metis_tac [Decls_Dlocal]); + env2) :: bls) st2 +Proof + rw [ML_code_def, ML_code_env_def] + \\ fs [SNOC_APPEND,Decls_APPEND] \\ metis_tac [Decls_Dlocal] +QED (* appending a Dtype *) -Theorem ML_code_Dtype - `!tds locs. ML_code inp_env ((comm, s1, prog, env2) :: bls) s2 ==> +Theorem ML_code_Dtype: + !tds locs. ML_code inp_env ((comm, s1, prog, env2) :: bls) s2 ==> EVERY check_dup_ctors tds ==> let nts = s2.next_type_stamp in let s3 = (s2 with next_type_stamp := nts + LENGTH tds) in let env3 = write_tdefs nts tds env2 in - ML_code inp_env ((comm, s1, SNOC (Dtype locs tds) prog, env3) :: bls) s3` - (fs [ML_code_def,SNOC_APPEND,Decls_APPEND,Decls_Dtype,merge_env_empty_env] + ML_code inp_env ((comm, s1, SNOC (Dtype locs tds) prog, env3) :: bls) s3 +Proof + fs [ML_code_def,SNOC_APPEND,Decls_APPEND,Decls_Dtype,merge_env_empty_env] \\ rw [] \\ rpt (asm_exists_tac \\ fs []) \\ fs [merge_env_write_tdefs] \\ AP_TERM_TAC - \\ fs [merge_env_def,empty_env_def,sem_env_component_equality]); + \\ fs [merge_env_def,empty_env_def,sem_env_component_equality] +QED (* appending a Dexn *) -Theorem ML_code_Dexn - `!n l locs. ML_code inp_env ((comm, s1, prog, env2) :: bls) s2 ==> +Theorem ML_code_Dexn: + !n l locs. ML_code inp_env ((comm, s1, prog, env2) :: bls) s2 ==> let nes = s2.next_exn_stamp in let s3 = s2 with next_exn_stamp := nes + 1 in let env3 = write_cons n (LENGTH l,ExnStamp nes) env2 in - ML_code inp_env ((comm, s1, SNOC (Dexn locs n l) prog, env3) :: bls) s3` - (fs [ML_code_def,SNOC_APPEND,Decls_APPEND,Decls_Dexn,merge_env_empty_env] + ML_code inp_env ((comm, s1, SNOC (Dexn locs n l) prog, env3) :: bls) s3 +Proof + fs [ML_code_def,SNOC_APPEND,Decls_APPEND,Decls_Dexn,merge_env_empty_env] \\ rw [] \\ rpt (asm_exists_tac \\ fs []) - \\ fs [write_cons_def,merge_env_def,empty_env_def,sem_env_component_equality]); + \\ fs [write_cons_def,merge_env_def,empty_env_def,sem_env_component_equality] +QED (* appending a Dtabbrev *) -Theorem ML_code_Dtabbrev - `!x y z locs. ML_code inp_env ((comm, s1, prog, env2) :: bls) s2 ==> +Theorem ML_code_Dtabbrev: + !x y z locs. ML_code inp_env ((comm, s1, prog, env2) :: bls) s2 ==> ML_code inp_env ((comm, s1, SNOC (Dtabbrev locs x y z) prog, env2) :: bls) - s2` - (fs [ML_code_def,SNOC_APPEND,Decls_APPEND,Decls_Dtabbrev,merge_env_empty_env]); + s2 +Proof + fs [ML_code_def,SNOC_APPEND,Decls_APPEND,Decls_Dtabbrev,merge_env_empty_env] +QED (* appending a Letrec *) @@ -601,39 +689,45 @@ val build_rec_env_APPEND = Q.prove( \\ qspec_tac (`add_to_env`,`xs`) \\ Induct_on `funs` \\ fs [FORALL_PROD]); -Theorem ML_code_Dletrec - `!fns locs. ML_code env0 ((comm, s1, prog, env2) :: bls) s2 ==> +Theorem ML_code_Dletrec: + !fns locs. ML_code env0 ((comm, s1, prog, env2) :: bls) s2 ==> ALL_DISTINCT (MAP (λ(x,y,z). x) fns) ==> let code_env = ML_code_env env0 ((comm, s1, prog, env2) :: bls) in let env3 = write_rec fns code_env env2 in - ML_code env0 ((comm, s1, SNOC (Dletrec locs fns) prog, env3) :: bls) s2` - (fs [ML_code_def,SNOC_APPEND,Decls_APPEND,Decls_Dletrec,ML_code_env_def] + ML_code env0 ((comm, s1, SNOC (Dletrec locs fns) prog, env3) :: bls) s2 +Proof + fs [ML_code_def,SNOC_APPEND,Decls_APPEND,Decls_Dletrec,ML_code_env_def] \\ rw [] \\ asm_exists_tac \\ fs [merge_env_def,write_rec_thm,empty_env_def,sem_env_component_equality] - \\ fs [build_rec_env_APPEND]); + \\ fs [build_rec_env_APPEND] +QED (* appending a Let *) -Theorem ML_code_Dlet_var - `!cenv e s3 x n locs. ML_code env0 ((comm, s1, prog, env1) :: bls) s2 ==> +Theorem ML_code_Dlet_var: + !cenv e s3 x n locs. ML_code env0 ((comm, s1, prog, env1) :: bls) s2 ==> eval_rel s2 cenv e s3 x ==> cenv = ML_code_env env0 ((comm, s1, prog, env1) :: bls) ==> let env2 = write n x env1 in let s3_abbrev = s3 in ML_code env0 ((comm, s1, SNOC (Dlet locs (Pvar n) e) prog, env2) - :: bls) s3_abbrev` - (fs [ML_code_def,ML_code_env_def,SNOC_APPEND,Decls_APPEND,Decls_Dlet] + :: bls) s3_abbrev +Proof + fs [ML_code_def,ML_code_env_def,SNOC_APPEND,Decls_APPEND,Decls_Dlet] \\ rw [] \\ asm_exists_tac \\ fs [PULL_EXISTS] - \\ fs [write_def,merge_env_def,empty_env_def,sem_env_component_equality]); + \\ fs [write_def,merge_env_def,empty_env_def,sem_env_component_equality] +QED -Theorem ML_code_Dlet_Fun - `!n v e locs. ML_code env0 ((comm, s1, prog, env1) :: bls) s2 ==> +Theorem ML_code_Dlet_Fun: + !n v e locs. ML_code env0 ((comm, s1, prog, env1) :: bls) s2 ==> let code_env = ML_code_env env0 ((comm, s1, prog, env1) :: bls) in let v_abbrev = Closure code_env v e in let env2 = write n v_abbrev env1 in ML_code env0 ((comm, s1, SNOC (Dlet locs (Pvar n) (Fun v e)) prog, - env2) :: bls) s2` - (rw [] \\ imp_res_tac ML_code_Dlet_var - \\ fs [evaluate_def,state_component_equality,eval_rel_def]); + env2) :: bls) s2 +Proof + rw [] \\ imp_res_tac ML_code_Dlet_var + \\ fs [evaluate_def,state_component_equality,eval_rel_def] +QED (* lookup function definitions *) @@ -653,13 +747,15 @@ val mod_defined_def = zDefine ` p1 ≠ [] ∧ id_to_mods n = p1 ++ p2 ∧ nsLookupMod env p1 = SOME e3`; -Theorem mod_defined_nsLookup_Mod1[compute] - `mod_defined env id = (case id of Short _ => F - | Long mn _ => (case nsLookup_Mod1 env mn of NONE => F | _ => T))` - (PURE_CASE_TAC \\ fs [id_to_mods_def, mod_defined_def] +Theorem mod_defined_nsLookup_Mod1[compute]: + mod_defined env id = (case id of Short _ => F + | Long mn _ => (case nsLookup_Mod1 env mn of NONE => F | _ => T)) +Proof + PURE_CASE_TAC \\ fs [id_to_mods_def, mod_defined_def] \\ Cases_on `env` \\ fs [Once EXISTS_LIST, nsLookupMod_def, nsLookup_Mod1_def] - \\ PURE_CASE_TAC \\ fs [Once EXISTS_LIST, nsLookupMod_def]); + \\ PURE_CASE_TAC \\ fs [Once EXISTS_LIST, nsLookupMod_def] +QED (* theorems about old lookup functions *) (* FIXME: everything below this line is unlikely to be needed. *) @@ -670,35 +766,41 @@ val nsLookupMod_nsBind = Q.prove(` Cases_on`env`>>fs[nsBind_def]>> Induct_on`p`>> fs[nsLookupMod_def]); -Theorem nsLookup_write - `(nsLookup (write n v env).v (Short name) = +Theorem nsLookup_write: + (nsLookup (write n v env).v (Short name) = if n = name then SOME v else nsLookup env.v (Short name)) /\ (nsLookup (write n v env).v (Long mn lname) = nsLookup env.v (Long mn lname)) /\ (nsLookup (write n v env).c a = nsLookup env.c a) /\ (mod_defined (write n v env).v x = mod_defined env.v x) /\ - (mod_defined (write n v env).c x = mod_defined env.c x)` - (fs [write_def] \\ rw [] - \\ metis_tac[nsLookupMod_nsBind,mod_defined_def]); - -Theorem nsLookup_write_cons - `(nsLookup (write_cons n v env).v a = nsLookup env.v a) /\ + (mod_defined (write n v env).c x = mod_defined env.c x) +Proof + fs [write_def] \\ rw [] + \\ metis_tac[nsLookupMod_nsBind,mod_defined_def] +QED + +Theorem nsLookup_write_cons: + (nsLookup (write_cons n v env).v a = nsLookup env.v a) /\ (nsLookup (write_cons n d env).c (Short name) = if name = n then SOME d else nsLookup env.c (Short name)) /\ (mod_defined (write_cons n d env).v x = mod_defined env.v x) /\ (mod_defined (write_cons n d env).c x = mod_defined env.c x) /\ (nsLookup (write_cons n d env).c (Long mn lname) = - nsLookup env.c (Long mn lname))` - (fs [write_cons_def] \\ rw [] \\ - metis_tac[nsLookupMod_nsBind,mod_defined_def]); - -Theorem nsLookup_empty - `(nsLookup empty_env.v a = NONE) /\ + nsLookup env.c (Long mn lname)) +Proof + fs [write_cons_def] \\ rw [] \\ + metis_tac[nsLookupMod_nsBind,mod_defined_def] +QED + +Theorem nsLookup_empty: + (nsLookup empty_env.v a = NONE) /\ (nsLookup empty_env.c b = NONE) /\ (mod_defined empty_env.v x = F) /\ - (mod_defined empty_env.c x = F)` - (rw[empty_env_def, nsLookup_def, mod_defined_def, - nsLookupMod_def] \\ Cases_on`p1` \\ fs[]); + (mod_defined empty_env.c x = F) +Proof + rw[empty_env_def, nsLookup_def, mod_defined_def, + nsLookupMod_def] \\ Cases_on`p1` \\ fs[] +QED val nsLookupMod_nsAppend = Q.prove(` nsLookupMod (nsAppend env1 env2) p = @@ -717,8 +819,8 @@ val nsLookupMod_nsAppend = Q.prove(` fs[namespacePropsTheory.nsLookupMod_nsAppend_none,namespacePropsTheory.nsLookupMod_nsAppend_some]>> metis_tac[option_CLAUSES]) |> GEN_ALL; -Theorem nsLookup_write_mod - `(nsLookup (write_mod mn env1 env2).v (Short n) = +Theorem nsLookup_write_mod: + (nsLookup (write_mod mn env1 env2).v (Short n) = nsLookup env2.v (Short n)) /\ (nsLookup (write_mod mn env1 env2).c (Short n) = nsLookup env2.c (Short n)) /\ @@ -732,8 +834,9 @@ Theorem nsLookup_write_mod nsLookup env2.v (Long mn1 ln)) /\ (nsLookup (write_mod mn env1 env2).c (Long mn1 ln) = if mn = mn1 then nsLookup env1.c ln else - nsLookup env2.c (Long mn1 ln))` - (fs [write_mod_def,mod_defined_def] \\ + nsLookup env2.c (Long mn1 ln)) +Proof + fs [write_mod_def,mod_defined_def] \\ EVAL_TAC \\ fs[GSYM nsLift_def,id_to_mods_def,nsLookupMod_nsAppend] \\ simp[] >> CONJ_TAC>> @@ -753,10 +856,11 @@ Theorem nsLookup_write_mod asm_exists_tac>>fs[namespacePropsTheory.nsLookupMod_nsLift,nsLookupMod_def]>> Cases_on`p1`>>fs[]>> rw[]>> Cases_on`p1'`>>fs[]>> - metis_tac[])); + metis_tac[]) +QED -Theorem nsLookup_merge_env - `(nsLookup (merge_env e1 e2).v (Short n) = +Theorem nsLookup_merge_env: + (nsLookup (merge_env e1 e2).v (Short n) = case nsLookup e1.v (Short n) of | NONE => nsLookup e2.v (Short n) | SOME x => SOME x) /\ @@ -777,8 +881,9 @@ Theorem nsLookup_merge_env (mod_defined (merge_env e1 e2).v x = (mod_defined e1.v x ∨ mod_defined e2.v x)) /\ (mod_defined (merge_env e1 e2).c x = - (mod_defined e1.c x ∨ mod_defined e2.c x))` - (fs [merge_env_def,mod_defined_def] \\ rw[] \\ every_case_tac + (mod_defined e1.c x ∨ mod_defined e2.c x)) +Proof + fs [merge_env_def,mod_defined_def] \\ rw[] \\ every_case_tac \\ fs[namespacePropsTheory.nsLookup_nsAppend_some] THEN1 (Cases_on `nsLookup e2.v (Short n)` \\ fs [namespacePropsTheory.nsLookup_nsAppend_none, @@ -846,13 +951,15 @@ Theorem nsLookup_merge_env rename[`nsLookupMod _ xx`,`p1 ++ p2`,`xx ++ p3`] >> first_x_assum(qspecl_then[`xx`,`p3++p2`]mp_tac) >> fs[]) - ); +QED -Theorem nsLookup_nsBind_compute[compute] - `(nsLookup (nsBind n v e) (Short n1) = +Theorem nsLookup_nsBind_compute[compute]: + (nsLookup (nsBind n v e) (Short n1) = if n = n1 then SOME v else nsLookup e (Short n1)) /\ - (nsLookup (nsBind n v e) (Long l1 l2) = nsLookup e (Long l1 l2))` - (rw [namespacePropsTheory.nsLookup_nsBind]); + (nsLookup (nsBind n v e) (Long l1 l2) = nsLookup e (Long l1 l2)) +Proof + rw [namespacePropsTheory.nsLookup_nsBind] +QED val nsLookup_nsAppend = save_thm("nsLookup_nsAppend[compute]", nsLookup_merge_env @@ -861,9 +968,11 @@ val nsLookup_nsAppend = save_thm("nsLookup_nsAppend[compute]", |> SIMP_RULE (srw_ss()) []); (* Base case for mod_defined (?) *) -Theorem mod_defined_base[compute] - `mod_defined (Bind _ []) _ = F` - (rw[mod_defined_def]>>Cases_on`p1`>>EVAL_TAC); +Theorem mod_defined_base[compute]: + mod_defined (Bind _ []) _ = F +Proof + rw[mod_defined_def]>>Cases_on`p1`>>EVAL_TAC +QED (* --- the rest of this file might be unused junk --- *) @@ -871,59 +980,69 @@ Theorem mod_defined_base[compute] (* misc theorems about lookup functions *) (* No idea why this is sparated out *) -Theorem lookup_var_write - `(lookup_var v (write w x env) = if v = w then SOME x else lookup_var v env) /\ +Theorem lookup_var_write: + (lookup_var v (write w x env) = if v = w then SOME x else lookup_var v env) /\ (nsLookup (write w x env).v (Short v) = if v = w then SOME x else nsLookup env.v (Short v) ) /\ (nsLookup (write w x env).v (Long mn lname) = nsLookup env.v (Long mn lname)) ∧ - (lookup_cons name (write w x env) = lookup_cons name env)` - (fs [lookup_var_def,write_def,lookup_cons_def] \\ rw []); + (lookup_cons name (write w x env) = lookup_cons name env) +Proof + fs [lookup_var_def,write_def,lookup_cons_def] \\ rw [] +QED -Theorem lookup_var_write_mod - `(lookup_var v (write_mod mn e1 env) = lookup_var v env) /\ +Theorem lookup_var_write_mod: + (lookup_var v (write_mod mn e1 env) = lookup_var v env) /\ (lookup_cons (Long mn1 (Short name)) (write_mod mn2 e1 env) = if mn1 = mn2 then lookup_cons (Short name) e1 else lookup_cons (Long mn1 (Short name)) env) /\ (lookup_cons (Short name) (write_mod mn2 e1 env) = - lookup_cons (Short name) env)` - (fs [lookup_var_def,write_mod_def, lookup_cons_def] \\ rw []); + lookup_cons (Short name) env) +Proof + fs [lookup_var_def,write_mod_def, lookup_cons_def] \\ rw [] +QED -Theorem lookup_var_write_cons - `(lookup_var v (write_cons n d env) = lookup_var v env) /\ +Theorem lookup_var_write_cons: + (lookup_var v (write_cons n d env) = lookup_var v env) /\ (lookup_cons (Short name) (write_cons n d env) = if name = n then SOME d else lookup_cons (Short name) env) /\ (lookup_cons (Long l full_name) (write_cons n d env) = lookup_cons (Long l full_name) env) /\ - (nsLookup (write_cons n d env).v x = nsLookup env.v x)` - (fs [lookup_var_def,write_cons_def,lookup_cons_def] \\ rw []); + (nsLookup (write_cons n d env).v x = nsLookup env.v x) +Proof + fs [lookup_var_def,write_cons_def,lookup_cons_def] \\ rw [] +QED -Theorem lookup_var_empty_env - `(lookup_var v empty_env = NONE) /\ +Theorem lookup_var_empty_env: + (lookup_var v empty_env = NONE) /\ (nsLookup empty_env.v (Short k) = NONE) /\ (nsLookup empty_env.v (Long mn m) = NONE) /\ - (lookup_cons name empty_env = NONE)` - (fs[lookup_var_def,empty_env_def,lookup_cons_def]); + (lookup_cons name empty_env = NONE) +Proof + fs[lookup_var_def,empty_env_def,lookup_cons_def] +QED (* -Theorem lookup_var_merge_env - `(lookup_var v1 (merge_env e1 e2) = +Theorem lookup_var_merge_env: + (lookup_var v1 (merge_env e1 e2) = case lookup_var v1 e1 of | NONE => lookup_var v1 e2 | res => res) /\ (lookup_cons name (merge_env e1 e2) = case lookup_cons name e1 of | NONE => lookup_cons name e2 - | res => res)` - (fs [lookup_var_def,lookup_cons_def,merge_env_def] \\ rw[] \\ every_case_tac \\ + | res => res) +Proof + fs [lookup_var_def,lookup_cons_def,merge_env_def] \\ rw[] \\ every_case_tac \\ fs[namespacePropsTheory.nsLookup_nsAppend_some] >- (Cases_on`nsLookup e2.v (Short v1)`>> fs[namespacePropsTheory.nsLookup_nsAppend_none, namespacePropsTheory.nsLookup_nsAppend_some,namespaceTheory.id_to_mods_def]) - \\ ... (* TODO *))); + \\ ... (* TODO *) +QED); *) val _ = export_theory(); diff --git a/translator/ml_translatorScript.sml b/translator/ml_translatorScript.sml index 451aaa3f73..3e0b66bdd7 100644 --- a/translator/ml_translatorScript.sml +++ b/translator/ml_translatorScript.sml @@ -112,21 +112,24 @@ in val Eval_rw = CONJ evaluate_def Eval_lemma end; -Theorem evaluate_empty_state_IMP - `eval_rel (empty_state with refs := s.refs) env exp (empty_state with refs := s.refs ++ refs') x ⇒ - eval_rel (s:'ffi state) env exp (s with refs := s.refs ++ refs') x` - (rw [eval_rel_def] +Theorem evaluate_empty_state_IMP: + eval_rel (empty_state with refs := s.refs) env exp (empty_state with refs := s.refs ++ refs') x ⇒ + eval_rel (s:'ffi state) env exp (s with refs := s.refs ++ refs') x +Proof + rw [eval_rel_def] \\ drule (INST_TYPE[alpha|->oneSyntax.one_ty,beta|->``:'ffi``] (CONJUNCT1 evaluatePropsTheory.evaluate_ffi_intro)) \\ disch_then (qspec_then `s with clock := ck1` mp_tac) \\ fs [empty_state_def] - \\ strip_tac \\ asm_exists_tac \\ fs []); + \\ strip_tac \\ asm_exists_tac \\ fs [] +QED -Theorem Eval_Arrow - `Eval env x1 ((a --> b) f) ==> +Theorem Eval_Arrow: + Eval env x1 ((a --> b) f) ==> Eval env x2 (a x) ==> - Eval env (App Opapp [x1;x2]) (b (f x))` - (rw[Eval_rw,Arrow_def,AppReturns_def] + Eval env (App Opapp [x1;x2]) (b (f x)) +Proof + rw[Eval_rw,Arrow_def,AppReturns_def] \\ pop_assum (qspec_then `refs` strip_assume_tac) \\ fs [] \\ drule evaluate_add_to_clock \\ first_x_assum (qspec_then `refs ++ refs'` strip_assume_tac) \\ fs [] @@ -140,50 +143,62 @@ Theorem Eval_Arrow \\ fs [evaluateTheory.dec_clock_def,eval_rel_def] \\ ntac 2 (pop_assum kall_tac) \\ drule evaluate_add_to_clock \\ fs [] - \\ fs [empty_state_def,state_component_equality]); + \\ fs [empty_state_def,state_component_equality] +QED -Theorem Eval_Fun - `(!v x. a x v ==> Eval (write name v env) body (b ((f:'a->'b) x))) ==> - Eval env (Fun name body) ((a --> b) f)` - (rw[Eval_rw,Arrow_def,AppReturns_def] +Theorem Eval_Fun: + (!v x. a x v ==> Eval (write name v env) body (b ((f:'a->'b) x))) ==> + Eval env (Fun name body) ((a --> b) f) +Proof + rw[Eval_rw,Arrow_def,AppReturns_def] \\ fs [empty_state_def,state_component_equality] \\ rw [] \\ first_x_assum drule \\ disch_then (qspec_then `refs` strip_assume_tac) \\ fs [do_opapp_def,eval_rel_def,PULL_EXISTS] - \\ metis_tac [write_def]); - -Theorem Eval_Fun_Eq - `(!v. a x v ==> Eval (write name v env) body (b (f x))) ==> - Eval env (Fun name body) ((Eq a x --> b) f)` - (rw[Eval_rw,Arrow_def,AppReturns_def] + \\ metis_tac [write_def] +QED + +Theorem Eval_Fun_Eq: + (!v. a x v ==> Eval (write name v env) body (b (f x))) ==> + Eval env (Fun name body) ((Eq a x --> b) f) +Proof + rw[Eval_rw,Arrow_def,AppReturns_def] \\ fs [empty_state_def,state_component_equality,Eq_def] \\ rw [] \\ first_x_assum drule \\ disch_then (qspec_then `refs` strip_assume_tac) \\ fs [do_opapp_def,eval_rel_def,PULL_EXISTS] - \\ metis_tac [write_def]); - -Theorem And_IMP_Eq - `Eval env exp ((And a P --> b) f) ==> - (P x ==> Eval env exp ((Eq a x --> b) f))` - (fs [Eval_rw,Arrow_def,AppReturns_def,And_def,Eq_def] \\ metis_tac []); - -Theorem Eq_IMP_And - `(!x. P x ==> Eval env (Fun name exp) ((Eq a x --> b) f)) ==> - Eval env (Fun name exp) ((And a P --> b) f)` - (simp[Eval_rw,Arrow_def,AppReturns_def,And_def,Eq_def] - \\ fs[state_component_equality]); - -Theorem Eval_Fun_And - `(!v x. P x ==> a x v ==> Eval (write name v env) body (b (f x))) ==> - Eval env (Fun name body) ((And a P --> b) f)` - (fs [GSYM And_def,AND_IMP_INTRO] - \\ rw [] \\ match_mp_tac Eval_Fun \\ simp []); - -Theorem Eval_Let - `Eval env exp (a res) /\ + \\ metis_tac [write_def] +QED + +Theorem And_IMP_Eq: + Eval env exp ((And a P --> b) f) ==> + (P x ==> Eval env exp ((Eq a x --> b) f)) +Proof + fs [Eval_rw,Arrow_def,AppReturns_def,And_def,Eq_def] \\ metis_tac [] +QED + +Theorem Eq_IMP_And: + (!x. P x ==> Eval env (Fun name exp) ((Eq a x --> b) f)) ==> + Eval env (Fun name exp) ((And a P --> b) f) +Proof + simp[Eval_rw,Arrow_def,AppReturns_def,And_def,Eq_def] + \\ fs[state_component_equality] +QED + +Theorem Eval_Fun_And: + (!v x. P x ==> a x v ==> Eval (write name v env) body (b (f x))) ==> + Eval env (Fun name body) ((And a P --> b) f) +Proof + fs [GSYM And_def,AND_IMP_INTRO] + \\ rw [] \\ match_mp_tac Eval_Fun \\ simp [] +QED + +Theorem Eval_Let: + Eval env exp (a res) /\ (!v. a res v ==> Eval (write name v env) body (b (f res))) ==> - Eval env (Let (SOME name) exp body) (b (LET f res))` - (rw[Eval_rw,write_def] + Eval env (Let (SOME name) exp body) (b (LET f res)) +Proof + rw[Eval_rw,write_def] \\ last_x_assum (qspec_then `refs` strip_assume_tac) \\ drule evaluate_add_to_clock \\ first_x_assum drule @@ -193,84 +208,113 @@ Theorem Eval_Let \\ disch_then (qspec_then `ck1'` strip_assume_tac) \\ fs [] \\ qexists_tac `ck1+ck1'` \\ fs [namespaceTheory.nsOptBind_def] - \\ fs [empty_state_def,state_component_equality]); + \\ fs [empty_state_def,state_component_equality] +QED -Theorem Eval_Var_general - `P v ==> !iden. nsLookup env.v iden = SOME v ==> Eval env (Var iden) P` - (fs [Eval_rw,state_component_equality]); +Theorem Eval_Var_general: + P v ==> !iden. nsLookup env.v iden = SOME v ==> Eval env (Var iden) P +Proof + fs [Eval_rw,state_component_equality] +QED -Theorem Eval_Var_Short - `P v ==> !name env. +Theorem Eval_Var_Short: + P v ==> !name env. (nsLookup env.v (Short name) = SOME v) ==> - Eval env (Var (Short name)) P` - (fs [Eval_Var_general]); + Eval env (Var (Short name)) P +Proof + fs [Eval_Var_general] +QED -Theorem Eval_Var_Long - `P v ==> !m name env. +Theorem Eval_Var_Long: + P v ==> !m name env. (nsLookup env.v (Long m (Short name)) = SOME v) ==> - Eval env (Var (Long m (Short name))) P` - (fs [Eval_Var_general]); + Eval env (Var (Long m (Short name))) P +Proof + fs [Eval_Var_general] +QED -Theorem Eval_Var_SWAP_ENV - `!env1. +Theorem Eval_Var_SWAP_ENV: + !env1. Eval env1 (Var (Short name)) P /\ (lookup_var name env = lookup_var name env1) ==> - Eval env (Var (Short name)) P` - (fs [FORALL_PROD,lookup_var_def,Eval_rw]); + Eval env (Var (Short name)) P +Proof + fs [FORALL_PROD,lookup_var_def,Eval_rw] +QED val LOOKUP_VAR_def = Define ` LOOKUP_VAR name env x = (lookup_var name env = SOME x)`; -Theorem LOOKUP_VAR_THM - `LOOKUP_VAR name env x ==> Eval env (Var (Short name)) ($= x)` - (fs [FORALL_PROD,lookup_var_def,Eval_rw,LOOKUP_VAR_def] - \\ fs [state_component_equality]); - -Theorem LOOKUP_VAR_SIMP - `LOOKUP_VAR name (write x v env) y = - if x = name then (v = y) else LOOKUP_VAR name env y` - (simp [LOOKUP_VAR_def,write_def,lookup_var_def] \\ rw []); - -Theorem Eval_Val_INT - `!n. Eval env (Lit (IntLit n)) (INT n)` - (simp [Eval_rw,state_component_equality,INT_def]); - -Theorem Eval_Val_NUM - `!n. Eval env (Lit (IntLit (&n))) (NUM n)` - (simp [Eval_rw,state_component_equality,INT_def,NUM_def]); - -Theorem Eval_Val_UNIT - `Eval env (Con NONE []) (UNIT_TYPE ())` - (simp [Eval_rw,state_component_equality,UNIT_TYPE_def] +Theorem LOOKUP_VAR_THM: + LOOKUP_VAR name env x ==> Eval env (Var (Short name)) ($= x) +Proof + fs [FORALL_PROD,lookup_var_def,Eval_rw,LOOKUP_VAR_def] + \\ fs [state_component_equality] +QED + +Theorem LOOKUP_VAR_SIMP: + LOOKUP_VAR name (write x v env) y = + if x = name then (v = y) else LOOKUP_VAR name env y +Proof + simp [LOOKUP_VAR_def,write_def,lookup_var_def] \\ rw [] +QED + +Theorem Eval_Val_INT: + !n. Eval env (Lit (IntLit n)) (INT n) +Proof + simp [Eval_rw,state_component_equality,INT_def] +QED + +Theorem Eval_Val_NUM: + !n. Eval env (Lit (IntLit (&n))) (NUM n) +Proof + simp [Eval_rw,state_component_equality,INT_def,NUM_def] +QED + +Theorem Eval_Val_UNIT: + Eval env (Con NONE []) (UNIT_TYPE ()) +Proof + simp [Eval_rw,state_component_equality,UNIT_TYPE_def] \\ fs [EVAL ``do_con_check env.c NONE 0``,state_component_equality, - EVAL ``build_conv env.c NONE []``]); - -Theorem Eval_Val_BOOL_T - `Eval env (App (Opb Leq) [Lit (IntLit 0); Lit (IntLit 0)]) (BOOL T)` - (fs [Eval_rw,do_app_def,empty_state_def,state_component_equality] - \\ EVAL_TAC); - -Theorem Eval_Val_BOOL_F - `Eval env (App (Opb Lt) [Lit (IntLit 0); Lit (IntLit 0)]) (BOOL F)` - (fs [Eval_rw,do_app_def,empty_state_def,state_component_equality] - \\ EVAL_TAC); - -Theorem Eval_Val_CHAR - `!c. Eval env (Lit (Char c)) (CHAR c)` - (fs [Eval_rw,empty_state_def,state_component_equality,CHAR_def]); - -Theorem Eval_Val_STRING - `!s. Eval env (Lit (StrLit s)) (STRING_TYPE (strlit s))` - (fs [Eval_rw,empty_state_def,state_component_equality,STRING_TYPE_def]); - -Theorem Eval_Val_WORD - `!w:'a word. + EVAL ``build_conv env.c NONE []``] +QED + +Theorem Eval_Val_BOOL_T: + Eval env (App (Opb Leq) [Lit (IntLit 0); Lit (IntLit 0)]) (BOOL T) +Proof + fs [Eval_rw,do_app_def,empty_state_def,state_component_equality] + \\ EVAL_TAC +QED + +Theorem Eval_Val_BOOL_F: + Eval env (App (Opb Lt) [Lit (IntLit 0); Lit (IntLit 0)]) (BOOL F) +Proof + fs [Eval_rw,do_app_def,empty_state_def,state_component_equality] + \\ EVAL_TAC +QED + +Theorem Eval_Val_CHAR: + !c. Eval env (Lit (Char c)) (CHAR c) +Proof + fs [Eval_rw,empty_state_def,state_component_equality,CHAR_def] +QED + +Theorem Eval_Val_STRING: + !s. Eval env (Lit (StrLit s)) (STRING_TYPE (strlit s)) +Proof + fs [Eval_rw,empty_state_def,state_component_equality,STRING_TYPE_def] +QED + +Theorem Eval_Val_WORD: + !w:'a word. dimindex(:'a) ≤ 64 ⇒ Eval env (Lit (if dimindex(:'a) ≤ 8 then Word8 (w2w w << (8-dimindex(:'a))) else Word64 (w2w w << (64-dimindex(:'a))))) - (WORD w)` - (simp [WORD_def,Eval_rw,state_component_equality]); + (WORD w) +Proof + simp [WORD_def,Eval_rw,state_component_equality] +QED (* Equality *) @@ -311,12 +355,13 @@ val Eq_lemma = Q.prove( \\ fs [LESS_EQ_EXISTS] \\ rw [] \\ fs [EXP_ADD] \\ simp_tac std_ss [Once MULT_COMM] \\ fs []); -Theorem EqualityType_NUM_BOOL - ` EqualityType NUM /\ EqualityType INT /\ +Theorem EqualityType_NUM_BOOL: + EqualityType NUM /\ EqualityType INT /\ EqualityType BOOL /\ EqualityType WORD /\ EqualityType CHAR /\ EqualityType STRING_TYPE /\ - EqualityType UNIT_TYPE` - (EVAL_TAC \\ fs [no_closures_def, + EqualityType UNIT_TYPE +Proof + EVAL_TAC \\ fs [no_closures_def, types_match_def, lit_same_type_def, stringTheory.ORD_11,mlstringTheory.explode_11] \\ SRW_TAC [] [] \\ EVAL_TAC @@ -325,14 +370,17 @@ Theorem EqualityType_NUM_BOOL \\ Cases_on `x2` \\ fs[STRING_TYPE_def] \\ EVAL_TAC \\ fs [WORD_MUL_LSL,word_mul_n2w] \\ imp_res_tac Eq_lemma \\ fs [] - \\ fs [MULT_EXP_MONO |> Q.SPECL [`p`,`1`] |> SIMP_RULE bool_ss [EVAL ``SUC 1``]]); + \\ fs [MULT_EXP_MONO |> Q.SPECL [`p`,`1`] |> SIMP_RULE bool_ss [EVAL ``SUC 1``]] +QED -Theorem EqualityType_measure - `!m. (!n : num. EqualityType (And TY (\x. m x < n))) ==> EqualityType TY` - (rpt strip_tac +Theorem EqualityType_measure: + !m. (!n : num. EqualityType (And TY (\x. m x < n))) ==> EqualityType TY +Proof + rpt strip_tac \\ RULE_ASSUM_TAC (Q.GENL [`x`, `y`] o Q.SPEC `MAX (SUC (m x)) (SUC (m y))`) \\ fs [EqualityType_def, And_def] - \\ metis_tac [prim_recTheory.LESS_SUC_REFL]); + \\ metis_tac [prim_recTheory.LESS_SUC_REFL] +QED val trivial4_def = Define `trivial4 x y a b = T`; @@ -340,20 +388,23 @@ val Conv_args_def = Define `Conv_args v = (case v of | Conv _ vs => vs | _ => [v])`; -Theorem EqualityType_def_rearranged - `EqualityType abs = (!x y vx vy. trivial4 x y vx vy +Theorem EqualityType_def_rearranged: + EqualityType abs = (!x y vx vy. trivial4 x y vx vy ==> abs x vx /\ abs y vy ==> (x = y ==> vx = vy ==> no_closures vx) - /\ (vx = vy <=> x = y) /\ types_match vx vy)` - (fs [EqualityType_def, trivial4_def] \\ metis_tac []); + /\ (vx = vy <=> x = y) /\ types_match vx vy) +Proof + fs [EqualityType_def, trivial4_def] \\ metis_tac [] +QED -Theorem EqualityType_from_ONTO - `(!a. ?r. (a = num2a r) ∧ r < (N : num)) +Theorem EqualityType_from_ONTO: + (!a. ?r. (a = num2a r) ∧ r < (N : num)) ==> (!TY stamps stn. (GENLIST (\n v. TY (num2a n) v) N = MAP (\st v. v = Conv (SOME (TypeStamp st stn)) []) stamps) ==> ALL_DISTINCT stamps - ==> EqualityType TY)` - (rpt strip_tac + ==> EqualityType TY) +Proof + rpt strip_tac \\ fs [EqualityType_def_rearranged] \\ rpt GEN_TAC \\ FIRST_X_ASSUM (fn a => ((dest_exists o snd o dest_forall o concl) a; @@ -364,15 +415,17 @@ Theorem EqualityType_from_ONTO \\ fs [EL_MAP, satTheory.AND_IMP, FUN_EQ_THM, no_closures_def, types_match_def, ctor_same_type_def, listTheory.EL_ALL_DISTINCT_EL_EQ, same_type_def] - \\ metis_tac (map TypeBase.one_one_of [``:stamp``, ``:'a option``, ``: v``])); + \\ metis_tac (map TypeBase.one_one_of [``:stamp``, ``:'a option``, ``: v``]) +QED -Theorem EqualityType_from_ONTO_Exn - `(!a. ?r. (a = num2a r) ∧ r < (N : num)) +Theorem EqualityType_from_ONTO_Exn: + (!a. ?r. (a = num2a r) ∧ r < (N : num)) ==> (!TY stamps. (GENLIST (\n v. TY (num2a n) v) N = MAP (\st v. v = Conv (SOME (ExnStamp st)) []) stamps) ==> ALL_DISTINCT stamps - ==> EqualityType TY)` - (rpt strip_tac + ==> EqualityType TY) +Proof + rpt strip_tac \\ fs [EqualityType_def_rearranged] \\ rpt GEN_TAC \\ FIRST_X_ASSUM (fn a => ((dest_exists o snd o dest_forall o concl) a; @@ -383,21 +436,26 @@ Theorem EqualityType_from_ONTO_Exn \\ fs [EL_MAP, satTheory.AND_IMP, FUN_EQ_THM, no_closures_def, types_match_def, ctor_same_type_def, listTheory.EL_ALL_DISTINCT_EL_EQ, same_type_def] - \\ metis_tac (map TypeBase.one_one_of [``:stamp``, ``:'a option``, ``: v``])); + \\ metis_tac (map TypeBase.one_one_of [``:stamp``, ``:'a option``, ``: v``]) +QED -Theorem types_match_list_length - `!vs1 vs2. types_match_list vs1 vs2 ==> LENGTH vs1 = LENGTH vs2` - (Induct \\ Cases_on`vs2` \\ rw[types_match_def]) +Theorem types_match_list_length: + !vs1 vs2. types_match_list vs1 vs2 ==> LENGTH vs1 = LENGTH vs2 +Proof + Induct \\ Cases_on`vs2` \\ rw[types_match_def] +QED -Theorem type_match_implies_do_eq_succeeds - `(!v1 v2. types_match v1 v2 ==> (do_eq v1 v2 = Eq_val (v1 = v2))) /\ +Theorem type_match_implies_do_eq_succeeds: + (!v1 v2. types_match v1 v2 ==> (do_eq v1 v2 = Eq_val (v1 = v2))) /\ (!vs1 vs2. - types_match_list vs1 vs2 ==> (do_eq_list vs1 vs2 = Eq_val (vs1 = vs2)))` - (ho_match_mp_tac do_eq_ind + types_match_list vs1 vs2 ==> (do_eq_list vs1 vs2 = Eq_val (vs1 = vs2))) +Proof + ho_match_mp_tac do_eq_ind \\ rw [do_eq_def, types_match_def] \\ imp_res_tac types_match_list_length \\ fs[] \\ Cases_on`cn1=cn2`\\fs[] - \\ imp_res_tac types_match_list_length); + \\ imp_res_tac types_match_list_length +QED val do_eq_succeeds = Q.prove(` (!a x1 v1 x2 v2. EqualityType a /\ a x1 v1 /\ a x2 v2 ==> @@ -430,24 +488,27 @@ val Eval2_tac = \\ disch_then (qspec_then `ck1'` strip_assume_tac) \\ fs [] \\ qexists_tac `ck1+ck1'` \\ fs []; -Theorem Eval_Equality - `Eval env x1 (a y1) /\ Eval env x2 (a y2) ==> +Theorem Eval_Equality: + Eval env x1 (a y1) /\ Eval env x2 (a y2) ==> EqualityType a ==> - Eval env (App Equality [x1;x2]) (BOOL (y1 = y2))` - (simp [Eval_rw,BOOL_def] \\ rw [] + Eval env (App Equality [x1;x2]) (BOOL (y1 = y2)) +Proof + simp [Eval_rw,BOOL_def] \\ rw [] \\ Eval2_tac \\ fs [do_app_def] \\ imp_res_tac do_eq_succeeds \\ fs [] - \\ rw[state_component_equality]); + \\ rw[state_component_equality] +QED (* booleans *) -Theorem Eval_Or - `(a1 ==> Eval env x1 (BOOL b1)) /\ +Theorem Eval_Or: + (a1 ==> Eval env x1 (BOOL b1)) /\ (a2 ==> Eval env x2 (BOOL b2)) ==> (a1 /\ (~CONTAINER b1 ==> a2) ==> - Eval env (Log Or x1 x2) (BOOL (b1 \/ b2)))` - (Cases_on `b1` + Eval env (Log Or x1 x2) (BOOL (b1 \/ b2))) +Proof + Cases_on `b1` \\ rw[Eval_rw,BOOL_def,CONTAINER_def] \\ fs [] THEN1 (pop_assum kall_tac @@ -458,15 +519,17 @@ Theorem Eval_Or \\ last_x_assum assume_tac \\ Eval2_tac \\ fs [EVAL``do_log Or (Boolv F) x``] - \\ fs [EVAL``Boolv F``,state_component_equality]); + \\ fs [EVAL``Boolv F``,state_component_equality] +QED -Theorem Eval_And - `(a1 ==> Eval env x1 (BOOL b1)) /\ +Theorem Eval_And: + (a1 ==> Eval env x1 (BOOL b1)) /\ (a2 ==> Eval env x2 (BOOL b2)) ==> (a1 /\ (CONTAINER b1 ==> a2) ==> - Eval env (Log And x1 x2) (BOOL (b1 /\ b2)))` - (reverse (Cases_on `b1`) + Eval env (Log And x1 x2) (BOOL (b1 /\ b2))) +Proof + reverse (Cases_on `b1`) \\ rw[Eval_rw,BOOL_def,CONTAINER_def] \\ fs [] THEN1 (pop_assum kall_tac @@ -477,57 +540,68 @@ Theorem Eval_And \\ last_x_assum assume_tac \\ Eval2_tac \\ fs [EVAL``do_log And (Boolv T) x``] - \\ fs [EVAL``Boolv F``,state_component_equality]); + \\ fs [EVAL``Boolv F``,state_component_equality] +QED -Theorem Eval_If - `(a1 ==> Eval env x1 (BOOL b1)) /\ +Theorem Eval_If: + (a1 ==> Eval env x1 (BOOL b1)) /\ (a2 ==> Eval env x2 (a b2)) /\ (a3 ==> Eval env x3 (a b3)) ==> (a1 /\ (CONTAINER b1 ==> a2) /\ (~CONTAINER b1 ==> a3) ==> - Eval env (If x1 x2 x3) (a (if b1 then b2 else b3)))` - (rw[Eval_rw,BOOL_def,CONTAINER_def] \\ fs [] + Eval env (If x1 x2 x3) (a (if b1 then b2 else b3))) +Proof + rw[Eval_rw,BOOL_def,CONTAINER_def] \\ fs [] \\ qpat_x_assum `_ ==> _` kall_tac \\ last_x_assum assume_tac \\ Eval2_tac \\ fs [EVAL``do_if (Boolv T) x y``,EVAL``do_if (Boolv F) x y``, - state_component_equality]); + state_component_equality] +QED -Theorem Eval_Bool_Not - `Eval env x1 (BOOL b1) ==> +Theorem Eval_Bool_Not: + Eval env x1 (BOOL b1) ==> Eval env (App Equality - [x1; App (Opb Lt) [Lit (IntLit 0); Lit (IntLit 0)]]) (BOOL (~b1))` - (rw[Eval_rw,BOOL_def,do_app_def,opb_lookup_def] + [x1; App (Opb Lt) [Lit (IntLit 0); Lit (IntLit 0)]]) (BOOL (~b1)) +Proof + rw[Eval_rw,BOOL_def,do_app_def,opb_lookup_def] \\ pop_assum (qspec_then `refs` strip_assume_tac) \\ qexists_tac `ck1` \\ fs [empty_state_def] \\ Cases_on `b1` \\ fs [] - \\ fs [EVAL``do_eq (Boolv T) (Boolv F)``,EVAL``do_eq (Boolv F) (Boolv F)``]); + \\ fs [EVAL``do_eq (Boolv T) (Boolv F)``,EVAL``do_eq (Boolv F) (Boolv F)``] +QED -Theorem Eval_Implies - `Eval env x1 (BOOL b1) ==> +Theorem Eval_Implies: + Eval env x1 (BOOL b1) ==> Eval env x2 (BOOL b2) ==> Eval env (If x1 x2 (App (Opb Leq) [Lit (IntLit 0); Lit (IntLit 0)])) - (BOOL (b1 ==> b2))` - (reverse (Cases_on `b1`) + (BOOL (b1 ==> b2)) +Proof + reverse (Cases_on `b1`) \\ rw[Eval_rw,BOOL_def,CONTAINER_def] \\ fs [] THEN1 (last_assum (qspec_then `refs` strip_assume_tac) \\ qexists_tac `ck1` \\ fs [EVAL ``do_if (Boolv F) x2 x1``] \\ fs [Eval_rw,do_app_def,state_component_equality] \\ EVAL_TAC) \\ last_x_assum assume_tac \\ Eval2_tac - \\ fs [EVAL ``do_if (Boolv T) x2 x1``,state_component_equality]); + \\ fs [EVAL ``do_if (Boolv T) x2 x1``,state_component_equality] +QED (* misc *) -Theorem Eval_Var_SIMP - `Eval (write x v env) (Var (Short y)) p = - if x = y then p v else Eval env (Var (Short y)) p` - (simp [LOOKUP_VAR_def,write_def,lookup_var_def,Eval_rw] - \\ rw [] \\ fs [state_component_equality]); +Theorem Eval_Var_SIMP: + Eval (write x v env) (Var (Short y)) p = + if x = y then p v else Eval env (Var (Short y)) p +Proof + simp [LOOKUP_VAR_def,write_def,lookup_var_def,Eval_rw] + \\ rw [] \\ fs [state_component_equality] +QED -Theorem Eval_Eq - `Eval env exp (a x) ==> Eval env exp ((Eq a x) x)` - (simp [Eval_def,Eq_def]); +Theorem Eval_Eq: + Eval env exp (a x) ==> Eval env exp ((Eq a x) x) +Proof + simp [Eval_def,Eq_def] +QED val FUN_FORALL = new_binder_definition("FUN_FORALL", ``($FUN_FORALL) = \(abs:'a->'b->v->bool) a v. !y. abs y a v``); @@ -535,36 +609,44 @@ val FUN_FORALL = new_binder_definition("FUN_FORALL", val FUN_EXISTS = new_binder_definition("FUN_EXISTS", ``($FUN_EXISTS) = \(abs:'a->'b->v->bool) a v. ?y. abs y a v``); -Theorem FUN_FORALL_INTRO - `(!x. p x f v) ==> (FUN_FORALL x. p x) f v` - (fs [FUN_FORALL]); - -Theorem eval_rel_11 - `eval_rel s1 env e s2 x2 /\ eval_rel s1 env e s3 x3 ==> - s2 = s3 /\ x2 = x3` - (rw [eval_rel_def] +Theorem FUN_FORALL_INTRO: + (!x. p x f v) ==> (FUN_FORALL x. p x) f v +Proof + fs [FUN_FORALL] +QED + +Theorem eval_rel_11: + eval_rel s1 env e s2 x2 /\ eval_rel s1 env e s3 x3 ==> + s2 = s3 /\ x2 = x3 +Proof + rw [eval_rel_def] \\ drule evaluate_add_to_clock \\ qpat_x_assum `evaluate _ _ _ = _` mp_tac \\ drule evaluate_add_to_clock \\ disch_then (qspec_then `ck1'` strip_assume_tac) \\ strip_tac \\ disch_then (qspec_then `ck1` strip_assume_tac) - \\ fs [state_component_equality]); + \\ fs [state_component_equality] +QED -Theorem Eval_FUN_FORALL - `(!x. Eval env exp ((p x) f)) ==> - Eval env exp ((FUN_FORALL x. p x) f)` - (rw[Eval_def,FUN_FORALL] +Theorem Eval_FUN_FORALL: + (!x. Eval env exp ((p x) f)) ==> + Eval env exp ((FUN_FORALL x. p x) f) +Proof + rw[Eval_def,FUN_FORALL] \\ first_assum (qspecl_then [`ARB`,`refs`] strip_assume_tac) \\ asm_exists_tac \\ fs [] \\ rw [] \\ first_assum (qspecl_then [`y`,`refs`] strip_assume_tac) - \\ imp_res_tac eval_rel_11 \\ fs []); + \\ imp_res_tac eval_rel_11 \\ fs [] +QED -Theorem Eval_FUN_FORALL_EQ - `(!x. Eval env exp ((p x) f)) = - Eval env exp ((FUN_FORALL x. p x) f)` - (REPEAT STRIP_TAC \\ EQ_TAC \\ FULL_SIMP_TAC std_ss [Eval_FUN_FORALL] - \\ EVAL_TAC \\ FULL_SIMP_TAC std_ss [FUN_FORALL] \\ METIS_TAC []); +Theorem Eval_FUN_FORALL_EQ: + (!x. Eval env exp ((p x) f)) = + Eval env exp ((FUN_FORALL x. p x) f) +Proof + REPEAT STRIP_TAC \\ EQ_TAC \\ FULL_SIMP_TAC std_ss [Eval_FUN_FORALL] + \\ EVAL_TAC \\ FULL_SIMP_TAC std_ss [FUN_FORALL] \\ METIS_TAC [] +QED val FUN_FORALL_PUSH1 = Q.prove( `(FUN_FORALL x. a --> (b x)) = (a --> FUN_FORALL x. b x)`, @@ -583,58 +665,70 @@ val FUN_EXISTS_Eq = Q.prove( val FUN_QUANT_SIMP = save_thm("FUN_QUANT_SIMP", LIST_CONJ [FUN_EXISTS_Eq,FUN_FORALL_PUSH1,FUN_FORALL_PUSH2]); -Theorem Eval_Recclosure_ALT - `!funs fname name body. +Theorem Eval_Recclosure_ALT: + !funs fname name body. (ALL_DISTINCT (MAP (\(f,x,e). f) funs)) ==> (!v. a n v ==> Eval (write name v (write_rec funs env2 env2)) body (b (f n))) ==> LOOKUP_VAR fname env (Recclosure env2 funs fname) ==> (find_recfun fname funs = SOME (name,body)) ==> - Eval env (Var (Short fname)) ((Eq a n --> b) f)` - (rw[write_rec_thm,write_def] + Eval env (Var (Short fname)) ((Eq a n --> b) f) +Proof + rw[write_rec_thm,write_def] \\ IMP_RES_TAC LOOKUP_VAR_THM \\ fs[Eval_rw,Arrow_def] \\ REPEAT STRIP_TAC \\ Cases_on `nsLookup env.v (Short fname)` \\ fs [state_component_equality] \\ rveq \\ rw[AppReturns_def,Eq_def,do_opapp_def,PULL_EXISTS] \\ fs[build_rec_env_def,FOLDR,eval_rel_def] - \\ METIS_TAC[APPEND_ASSOC]); + \\ METIS_TAC[APPEND_ASSOC] +QED -Theorem Eval_Recclosure - `(!v. a n v ==> +Theorem Eval_Recclosure: + (!v. a n v ==> Eval (write name v (write_rec [(fname,name,body)] env2 env2)) body (b (f n))) ==> LOOKUP_VAR fname env (Recclosure env2 [(fname,name,body)] fname) ==> - Eval env (Var (Short fname)) ((Eq a n --> b) f)` - ((Eval_Recclosure_ALT |> Q.SPECL [`[(fname,name,body)]`,`fname`] + Eval env (Var (Short fname)) ((Eq a n --> b) f) +Proof + (Eval_Recclosure_ALT |> Q.SPECL [`[(fname,name,body)]`,`fname`] |> SIMP_RULE (srw_ss()) [Once find_recfun_def] |> ASSUME_TAC) - \\ FULL_SIMP_TAC std_ss []); + \\ FULL_SIMP_TAC std_ss [] +QED val SafeVar_def = Define `SafeVar = Var`; -Theorem Eval_Eq_Recclosure - `LOOKUP_VAR name env (Recclosure x1 x2 x3) ==> +Theorem Eval_Eq_Recclosure: + LOOKUP_VAR name env (Recclosure x1 x2 x3) ==> (P f (Recclosure x1 x2 x3) = - Eval env (Var (Short name)) (P f))` - (simp [Eval_Var_SIMP,Eval_rw,LOOKUP_VAR_def,lookup_var_def] - \\ simp [state_component_equality]); - -Theorem Eval_Eq_Fun - `Eval env (Fun v x) p ==> + Eval env (Var (Short name)) (P f)) +Proof + simp [Eval_Var_SIMP,Eval_rw,LOOKUP_VAR_def,lookup_var_def] + \\ simp [state_component_equality] +QED + +Theorem Eval_Eq_Fun: + Eval env (Fun v x) p ==> !env2. Eval env2 (Var name) ($= (Closure env v x)) ==> - Eval env2 (Var name) p` - (simp [Eval_Var_SIMP,Eval_rw] \\ rw [] + Eval env2 (Var name) p +Proof + simp [Eval_Var_SIMP,Eval_rw] \\ rw [] \\ Cases_on `nsLookup env2.v name` \\ fs [] - \\ fs [state_component_equality]); + \\ fs [state_component_equality] +QED -Theorem Eval_WEAKEN - `Eval env exp P ==> (!v. P v ==> Q v) ==> Eval env exp Q` - (simp [Eval_def] \\ metis_tac []); +Theorem Eval_WEAKEN: + Eval env exp P ==> (!v. P v ==> Q v) ==> Eval env exp Q +Proof + simp [Eval_def] \\ metis_tac [] +QED -Theorem Eval_CONST - `(!v. P v = (v = x)) ==> - Eval env (Var name) ($= x) ==> Eval env (Var name) P` - (simp [Eval_def]); +Theorem Eval_CONST: + (!v. P v = (v = x)) ==> + Eval env (Var name) ($= x) ==> Eval env (Var name) P +Proof + simp [Eval_def] +QED (* arithmetic for integers *) @@ -681,11 +775,13 @@ in val Eval_INT_GREATER_EQ = f "INT_GREATER_EQ" `Geq` end; -Theorem Eval_Num - `Eval env x1 (INT i) ==> PRECONDITION (0 <= i) ==> - Eval env x1 (NUM (Num i))` - (SIMP_TAC std_ss [NUM_def,PRECONDITION_def] \\ rw [] - \\ `&Num i = i` by intLib.COOPER_TAC \\ fs []); +Theorem Eval_Num: + Eval env x1 (INT i) ==> PRECONDITION (0 <= i) ==> + Eval env x1 (NUM (Num i)) +Proof + SIMP_TAC std_ss [NUM_def,PRECONDITION_def] \\ rw [] + \\ `&Num i = i` by intLib.COOPER_TAC \\ fs [] +QED local @@ -705,53 +801,65 @@ val code = in -Theorem Eval_Num_ABS - `Eval env x1 (INT i) ==> - Eval env ^code (NUM (Num (ABS i)))` - (SIMP_TAC std_ss [NUM_def] +Theorem Eval_Num_ABS: + Eval env x1 (INT i) ==> + Eval env ^code (NUM (Num (ABS i))) +Proof + SIMP_TAC std_ss [NUM_def] \\ `&(Num (ABS i)) = let k = i in if k < 0 then 0 - k else k` by (FULL_SIMP_TAC std_ss [LET_DEF] THEN intLib.COOPER_TAC) \\ FULL_SIMP_TAC std_ss [] \\ REPEAT STRIP_TAC \\ MATCH_MP_TAC (GEN_ALL Eval_Let) \\ Q.EXISTS_TAC `INT` \\ FULL_SIMP_TAC std_ss [] \\ REPEAT STRIP_TAC \\ MATCH_MP_TAC (GEN_ALL (DISCH_ALL th)) - \\ FULL_SIMP_TAC std_ss [Eval_Var_SIMP]); + \\ FULL_SIMP_TAC std_ss [Eval_Var_SIMP] +QED end; val num_of_int_def = Define ` num_of_int i = Num (ABS i)`; -Theorem num_of_int_num[simp] - `num_of_int (& n) = n /\ num_of_int (- & n) = n` - (fs [num_of_int_def] \\ intLib.COOPER_TAC); +Theorem num_of_int_num[simp]: + num_of_int (& n) = n /\ num_of_int (- & n) = n +Proof + fs [num_of_int_def] \\ intLib.COOPER_TAC +QED val Eval_num_of_int = save_thm("Eval_num_of_int", Eval_Num_ABS |> REWRITE_RULE [GSYM num_of_int_def]); -Theorem Eval_int_of_num - `Eval env x1 (NUM n) ==> - Eval env x1 (INT (int_of_num n))` - (SIMP_TAC std_ss [NUM_def]); - -Theorem Eval_int_of_num_o - `Eval env x1 ((A --> NUM) f) ==> - Eval env x1 ((A --> INT) (int_of_num o f))` - (SIMP_TAC std_ss [NUM_def,Arrow_def]); - -Theorem Eval_o_int_of_num - `Eval env x1 ((INT --> A) f) ==> - Eval env x1 ((NUM --> A) (f o int_of_num))` - (SIMP_TAC std_ss [NUM_def,Arrow_def,Eval_def] - \\ METIS_TAC[]); - -Theorem Eval_int_negate - `Eval env x1 (INT i) ==> - Eval env (App (Opn Minus) [Lit (IntLit 0); x1]) (INT (-i))` - (rw[Eval_rw] +Theorem Eval_int_of_num: + Eval env x1 (NUM n) ==> + Eval env x1 (INT (int_of_num n)) +Proof + SIMP_TAC std_ss [NUM_def] +QED + +Theorem Eval_int_of_num_o: + Eval env x1 ((A --> NUM) f) ==> + Eval env x1 ((A --> INT) (int_of_num o f)) +Proof + SIMP_TAC std_ss [NUM_def,Arrow_def] +QED + +Theorem Eval_o_int_of_num: + Eval env x1 ((INT --> A) f) ==> + Eval env x1 ((NUM --> A) (f o int_of_num)) +Proof + SIMP_TAC std_ss [NUM_def,Arrow_def,Eval_def] + \\ METIS_TAC[] +QED + +Theorem Eval_int_negate: + Eval env x1 (INT i) ==> + Eval env (App (Opn Minus) [Lit (IntLit 0); x1]) (INT (-i)) +Proof + rw[Eval_rw] \\ first_x_assum (qspec_then `refs` strip_assume_tac) \\ qexists_tac `ck1` - \\ fs [do_app_def,INT_def,state_component_equality,opn_lookup_def]); + \\ fs [do_app_def,INT_def,state_component_equality,opn_lookup_def] +QED (* arithmetic for num *) @@ -812,11 +920,12 @@ val code = in -Theorem Eval_NUM_SUB - `Eval env x1 (NUM m) ==> +Theorem Eval_NUM_SUB: + Eval env x1 (NUM m) ==> Eval env x2 (NUM n) ==> - Eval env ^code (NUM (m - n))` - (SIMP_TAC std_ss [NUM_def] + Eval env ^code (NUM (m - n)) +Proof + SIMP_TAC std_ss [NUM_def] \\ `&(m - n:num) = let k = &m - &n in if k < 0 then 0 else k:int` by (FULL_SIMP_TAC std_ss [LET_DEF,INT_LT_SUB_RADD,INT_ADD,INT_LT] \\ Cases_on `m REWRITE_RULE [GSYM NUM_def,INT_LT,INT_LE,int_ge,int_gt] |> REWRITE_RULE [GSYM GREATER_DEF, GSYM GREATER_EQ]); -Theorem Eval_NUM_EQ_0 - `!n. Eval env x (NUM n) ==> - Eval env (App Equality [x; Lit (IntLit 0)]) (BOOL (n = 0))` - (REPEAT STRIP_TAC \\ ASSUME_TAC (Q.SPEC `0` Eval_Val_NUM) +Theorem Eval_NUM_EQ_0: + !n. Eval env x (NUM n) ==> + Eval env (App Equality [x; Lit (IntLit 0)]) (BOOL (n = 0)) +Proof + REPEAT STRIP_TAC \\ ASSUME_TAC (Q.SPEC `0` Eval_Val_NUM) \\ pop_assum mp_tac \\ drule (GEN_ALL Eval_Equality) \\ rw [] \\ res_tac \\ first_x_assum match_mp_tac - \\ fs [EqualityType_NUM_BOOL]); + \\ fs [EqualityType_NUM_BOOL] +QED (* word operations *) @@ -867,26 +979,32 @@ val tac = \\ fs [do_app_def,opw8_lookup_def,opw64_lookup_def] \\ fs [GSYM WORD_w2w_OVER_BITWISE] -Theorem Eval_word_and - `Eval env x1 (WORD (w1:'a word)) /\ +Theorem Eval_word_and: + Eval env x1 (WORD (w1:'a word)) /\ Eval env x2 (WORD (w2:'a word)) ==> Eval env (App (Opw (if dimindex (:'a) <= 8 then W8 else W64) Andw) [x1;x2]) - (WORD (word_and w1 w2))` - (tac); + (WORD (word_and w1 w2)) +Proof + tac +QED -Theorem Eval_word_or - `Eval env x1 (WORD (w1:'a word)) /\ +Theorem Eval_word_or: + Eval env x1 (WORD (w1:'a word)) /\ Eval env x2 (WORD (w2:'a word)) ==> Eval env (App (Opw (if dimindex (:'a) <= 8 then W8 else W64) Orw) [x1;x2]) - (WORD (word_or w1 w2))` - (tac); + (WORD (word_or w1 w2)) +Proof + tac +QED -Theorem Eval_word_xor - `Eval env x1 (WORD (w1:'a word)) /\ +Theorem Eval_word_xor: + Eval env x1 (WORD (w1:'a word)) /\ Eval env x2 (WORD (w2:'a word)) ==> Eval env (App (Opw (if dimindex (:'a) <= 8 then W8 else W64) Xor) [x1;x2]) - (WORD (word_xor w1 w2))` - (tac); + (WORD (word_xor w1 w2)) +Proof + tac +QED val DISTRIB_ANY = Q.prove( `(p * m + p * n = p * (m + n)) /\ @@ -914,15 +1032,17 @@ val Eval_word_add_lemma = Q.prove( rw [] \\ fs [LESS_EQ_EXISTS] \\ rw [EXP_ADD,dimword_def,MOD_COMMON_FACTOR_ANY]); -Theorem Eval_word_add - `Eval env x1 (WORD (w1:'a word)) /\ +Theorem Eval_word_add: + Eval env x1 (WORD (w1:'a word)) /\ Eval env x2 (WORD (w2:'a word)) ==> Eval env (App (Opw (if dimindex (:'a) <= 8 then W8 else W64) Add) [x1;x2]) - (WORD (word_add w1 w2))` - (tac + (WORD (word_add w1 w2)) +Proof + tac \\ Cases_on `w1` \\ Cases_on `w2` \\ fs [word_add_n2w,w2w_def,WORD_MUL_LSL,word_mul_n2w,GSYM RIGHT_ADD_DISTRIB] - \\ imp_res_tac Eval_word_add_lemma \\ fs []); + \\ imp_res_tac Eval_word_add_lemma \\ fs [] +QED val Eval_word_sub_lemma = Q.prove( `dimindex (:'a) <= k /\ n' < dimword (:α) ==> @@ -937,12 +1057,13 @@ val Eval_word_sub_lemma = Q.prove( \\ pop_assum (fn th => once_rewrite_tac [th]) \\ fs [Once (GSYM MOD_PLUS)]); -Theorem Eval_word_sub - `Eval env x1 (WORD (w1:'a word)) /\ +Theorem Eval_word_sub: + Eval env x1 (WORD (w1:'a word)) /\ Eval env x2 (WORD (w2:'a word)) ==> Eval env (App (Opw (if dimindex (:'a) <= 8 then W8 else W64) Sub) [x1;x2]) - (WORD (word_sub w1 w2))` - (tac + (WORD (word_sub w1 w2)) +Proof + tac \\ Cases_on `w1` \\ Cases_on `w2` \\ fs [word_add_n2w,w2w_def,WORD_MUL_LSL,word_mul_n2w,GSYM RIGHT_ADD_DISTRIB] \\ once_rewrite_tac [WORD_ADD_COMM] @@ -950,7 +1071,8 @@ Theorem Eval_word_sub \\ fs [word_add_n2w,w2w_def,WORD_MUL_LSL,word_mul_n2w,GSYM RIGHT_ADD_DISTRIB] \\ imp_res_tac Eval_word_add_lemma \\ fs [word_2comp_n2w,word_add_n2w] - \\ imp_res_tac Eval_word_sub_lemma \\ fs []); + \\ imp_res_tac Eval_word_sub_lemma \\ fs [] +QED val w2n_w2w_8 = Q.prove( `dimindex (:α) < 8 ==> @@ -972,8 +1094,8 @@ val w2n_w2w_64 = Q.prove( \\ fs [] \\ full_simp_tac bool_ss [GSYM (EVAL ``2n ** 64``),EXP_ADD] \\ fs [MOD_COMMON_FACTOR_ANY,MULT_DIV]); -Theorem Eval_w2n - `Eval env x1 (WORD (w:'a word)) ==> +Theorem Eval_w2n: + Eval env x1 (WORD (w:'a word)) ==> Eval env (if dimindex (:'a) = 8 then App (WordToInt W8) [x1] @@ -983,13 +1105,15 @@ Theorem Eval_w2n App (WordToInt W8) [App (Shift W8 Lsr (8 - dimindex (:'a))) [x1]] else App (WordToInt W64) [App (Shift W64 Lsr (64 - dimindex (:'a))) [x1]]) - (NUM (w2n w))` - (rw[Eval_rw,WORD_def] \\ fs [] + (NUM (w2n w)) +Proof + rw[Eval_rw,WORD_def] \\ fs [] \\ first_x_assum (qspec_then `refs` strip_assume_tac) \\ qexists_tac `ck1` \\ fs [do_app_def,state_component_equality,NUM_def,INT_def] \\ TRY (fs [w2w_def] \\ assume_tac w2n_lt \\ rfs [dimword_def] \\ NO_TAC) - \\ EVAL_TAC \\ fs [w2n_w2w_64,w2n_w2w_8]); + \\ EVAL_TAC \\ fs [w2n_w2w_64,w2n_w2w_8] +QED local val lemma = Q.prove( @@ -1021,8 +1145,8 @@ in val Eval_w2i = save_thm("Eval_w2i",th4) end; -Theorem Eval_i2w - `dimindex (:'a) <= 64 ==> +Theorem Eval_i2w: + dimindex (:'a) <= 64 ==> Eval env x1 (INT n) ==> Eval env (if dimindex (:'a) = 8 then @@ -1033,8 +1157,9 @@ Theorem Eval_i2w App (Shift W8 Lsl (8 - dimindex (:'a))) [App (WordFromInt W8) [x1]] else App (Shift W64 Lsl (64 - dimindex (:'a))) [App (WordFromInt W64) [x1]]) - (WORD ((i2w n):'a word))` - (rw[Eval_rw,WORD_def] \\ fs [] \\ rfs [] + (WORD ((i2w n):'a word)) +Proof + rw[Eval_rw,WORD_def] \\ fs [] \\ rfs [] \\ first_x_assum (qspec_then `refs` strip_assume_tac) \\ qexists_tac `ck1` \\ fs [do_app_def,INT_def] \\ fs [state_component_equality] @@ -1053,10 +1178,11 @@ Theorem Eval_i2w [GSYM (EVAL ``2n ** 8``),GSYM (EVAL ``2n ** 64``),EXP_ADD] \\ fs [MOD_COMMON_FACTOR_ANY,MULT_DIV] \\ Cases_on `n` \\ fs [] - \\ match_mp_tac MOD_MINUS \\ fs []); + \\ match_mp_tac MOD_MINUS \\ fs [] +QED -Theorem Eval_n2w - `dimindex (:'a) <= 64 ==> +Theorem Eval_n2w: + dimindex (:'a) <= 64 ==> Eval env x1 (NUM n) ==> Eval env (if dimindex (:'a) = 8 then @@ -1067,12 +1193,14 @@ Theorem Eval_n2w App (Shift W8 Lsl (8 - dimindex (:'a))) [App (WordFromInt W8) [x1]] else App (Shift W64 Lsl (64 - dimindex (:'a))) [App (WordFromInt W64) [x1]]) - (WORD ((n2w n):'a word))` - (qsuff_tac `n2w n = i2w (& n)` THEN1 fs [Eval_i2w,NUM_def] - \\ fs [integer_wordTheory.i2w_def]); - -Theorem Eval_w2w - `dimindex (:'a) <= 64 /\ dimindex (:'b) <= 64 ==> + (WORD ((n2w n):'a word)) +Proof + qsuff_tac `n2w n = i2w (& n)` THEN1 fs [Eval_i2w,NUM_def] + \\ fs [integer_wordTheory.i2w_def] +QED + +Theorem Eval_w2w: + dimindex (:'a) <= 64 /\ dimindex (:'b) <= 64 ==> Eval env x1 (WORD (w:'b word)) ==> Eval env (if (dimindex (:'a) <= 8 <=> dimindex (:'b) <= 8) then @@ -1089,8 +1217,9 @@ Theorem Eval_w2w App (Shift W8 Lsl (8 - dimindex (:'a))) [App (WordFromInt W8) [App (WordToInt W64) [App (Shift W64 Lsr (64 - dimindex (:'b))) [x1]]]]) - (WORD ((w2w w):'a word))` - (IF_CASES_TAC THEN1 + (WORD ((w2w w):'a word)) +Proof + IF_CASES_TAC THEN1 (Cases_on `dimindex (:'a) ≤ 8` \\ fs [] \\ IF_CASES_TAC \\ fs [GSYM NOT_LESS] \\ fs [NOT_LESS] @@ -1127,23 +1256,26 @@ Theorem Eval_w2w \\ qexists_tac `ck1` \\ fs [] \\ simp [do_app_def,empty_state_def] \\ fs [shift64_lookup_def,shift8_lookup_def] - \\ fs [fcpTheory.CART_EQ,w2w,fcpTheory.FCP_BETA,word_lsl_def,word_lsr_def])); + \\ fs [fcpTheory.CART_EQ,w2w,fcpTheory.FCP_BETA,word_lsl_def,word_lsr_def]) +QED -Theorem Eval_word_lsl - `!n. +Theorem Eval_word_lsl: + !n. Eval env x1 (WORD (w1:'a word)) ==> Eval env (App (Shift (if dimindex (:'a) <= 8 then W8 else W64) Lsl n) [x1]) - (WORD (word_lsl w1 n))` - (rw[Eval_rw,WORD_def] + (WORD (word_lsl w1 n)) +Proof + rw[Eval_rw,WORD_def] \\ pop_assum (qspec_then `refs` mp_tac) \\ strip_tac \\ qexists_tac `ck1` \\ fs [do_app_def,empty_state_def] \\ fs [LESS_EQ_EXISTS] \\ fs [do_app_def,shift8_lookup_def,shift64_lookup_def] \\ fs [fcpTheory.CART_EQ,word_lsl_def,fcpTheory.FCP_BETA,w2w] \\ rw [] - \\ Cases_on `w1 ' (i − (n + p))` \\ fs []); + \\ Cases_on `w1 ' (i − (n + p))` \\ fs [] +QED -Theorem Eval_word_lsr - `!n. +Theorem Eval_word_lsr: + !n. Eval env x1 (WORD (w1:'a word)) ==> Eval env (let w = (if dimindex (:'a) <= 8 then W8 else W64) in let k = (if dimindex (:'a) <= 8 then 8 else 64) - dimindex(:'a) in @@ -1151,8 +1283,9 @@ Theorem Eval_word_lsr App (Shift w Lsr n) [x1] else App (Shift w Lsl k) [App (Shift w Lsr (n+k)) [x1]]) - (WORD (word_lsr w1 n))` - (rw[Eval_rw,WORD_def] + (WORD (word_lsr w1 n)) +Proof + rw[Eval_rw,WORD_def] \\ first_x_assum (qspec_then `refs` mp_tac) \\ strip_tac \\ qexists_tac `ck1` \\ fs [do_app_def,empty_state_def] \\ TRY @@ -1166,10 +1299,11 @@ Theorem Eval_word_lsr \\ fs [fcpTheory.FCP_BETA,w2w] \\ imp_res_tac (DECIDE ``p <= i ==> (i - p + n = (i + n) - p:num)``) \\ fs [] \\ TRY (`i − p + (n + p) < 8` by decide_tac \\ fs [fcpTheory.FCP_BETA,w2w]) - \\ TRY (`i − p + (n + p) < 64` by decide_tac \\ fs [fcpTheory.FCP_BETA,w2w])); + \\ TRY (`i − p + (n + p) < 64` by decide_tac \\ fs [fcpTheory.FCP_BETA,w2w]) +QED -Theorem Eval_word_asr - `!n. +Theorem Eval_word_asr: + !n. Eval env x1 (WORD (w1:'a word)) ==> Eval env (let w = (if dimindex (:'a) <= 8 then W8 else W64) in let k = (if dimindex (:'a) <= 8 then 8 else 64) - dimindex(:'a) in @@ -1177,8 +1311,9 @@ Theorem Eval_word_asr App (Shift w Asr n) [x1] else App (Shift w Lsl k) [App (Shift w Asr (n+k)) [x1]]) - (WORD (word_asr w1 n))` - (rw[Eval_rw,WORD_def] + (WORD (word_asr w1 n)) +Proof + rw[Eval_rw,WORD_def] \\ first_x_assum (qspec_then `refs` mp_tac) \\ strip_tac \\ qexists_tac `ck1` \\ fs [do_app_def,empty_state_def] \\ TRY (* takes care of = 8 and = 64 cases *) @@ -1191,22 +1326,25 @@ Theorem Eval_word_asr \\ rw [] \\ fs [] \\ eq_tac \\ rw [] \\ fs [] \\ fs [fcpTheory.FCP_BETA,w2w,word_msb_def] \\ imp_res_tac (DECIDE ``8 = k ==> 7 = k - 1n``) \\ fs [] - \\ imp_res_tac (DECIDE ``64 = k ==> 63 = k - 1n``) \\ fs []); + \\ imp_res_tac (DECIDE ``64 = k ==> 63 = k - 1n``) \\ fs [] +QED -Theorem Eval_word_ror - `!n. +Theorem Eval_word_ror: + !n. Eval env x1 (WORD (w1:'a word)) ==> (dimindex (:'a) <> 8 ==> dimindex (:'a) = 64) ==> Eval env (App (Shift (if dimindex (:'a) <= 8 then W8 else W64) Ror n) [x1]) - (WORD (word_ror w1 n))` - (Cases_on `dimindex (:'a) = 8` \\ fs [] + (WORD (word_ror w1 n)) +Proof + Cases_on `dimindex (:'a) = 8` \\ fs [] \\ Cases_on `dimindex (:'a) = 64` \\ fs [] \\ rw[Eval_rw,WORD_def] \\ first_x_assum (qspec_then `refs` mp_tac) \\ strip_tac \\ qexists_tac `ck1` \\ fs [do_app_def,empty_state_def] \\ fs [LESS_EQ_EXISTS] \\ fs [do_app_def,shift8_lookup_def,shift64_lookup_def] - \\ fs [fcpTheory.CART_EQ,word_ror_def,fcpTheory.FCP_BETA,w2w] \\ rw []); + \\ fs [fcpTheory.CART_EQ,word_ror_def,fcpTheory.FCP_BETA,w2w] \\ rw [] +QED (* list definition *) @@ -1232,19 +1370,23 @@ val LIST_TYPE_SIMP = LIST_TYPE_SIMP' |> Q.SPECL [`xs`,`\x.F`] |> SIMP_RULE std_ss [] |> curry save_thm "LIST_TYPE_SIMP"; -Theorem LIST_TYPE_IF_ELIM -`!v. LIST_TYPE (\x v. if MEM x l then P x v else Q x v) l v = LIST_TYPE P l v` - (`!l' v. (!x. MEM x l ⇒ MEM x l') ⇒ +Theorem LIST_TYPE_IF_ELIM: + !v. LIST_TYPE (\x v. if MEM x l then P x v else Q x v) l v = LIST_TYPE P l v +Proof + `!l' v. (!x. MEM x l ⇒ MEM x l') ⇒ LIST_TYPE (\x v. if MEM x l' then P x v else Q x v) l v = LIST_TYPE P l v` suffices_by metis_tac[] >> Induct_on `l` - >> fs[LIST_TYPE_def]); + >> fs[LIST_TYPE_def] +QED -Theorem LIST_TYPE_mono - `∀P Q l v. +Theorem LIST_TYPE_mono: + ∀P Q l v. LIST_TYPE P l v ∧ (∀x v. MEM x l ∧ P x v ⇒ Q x v) ⇒ - LIST_TYPE Q l v` - (ntac 2 gen_tac \\ Induct \\ rw[LIST_TYPE_def]); + LIST_TYPE Q l v +Proof + ntac 2 gen_tac \\ Induct \\ rw[LIST_TYPE_def] +QED (* pair definition *) @@ -1262,72 +1404,88 @@ val PAIR_TYPE_SIMP = Q.prove( (* characters *) -Theorem Eval_Ord - `Eval env x (CHAR c) ==> - Eval env (App Ord [x]) (NUM (ORD c))` - (rw[Eval_rw,CHAR_def,NUM_def,INT_def] +Theorem Eval_Ord: + Eval env x (CHAR c) ==> + Eval env (App Ord [x]) (NUM (ORD c)) +Proof + rw[Eval_rw,CHAR_def,NUM_def,INT_def] \\ first_x_assum (qspec_then `refs` mp_tac) \\ strip_tac - \\ qexists_tac `ck1` \\ fs [do_app_def,empty_state_def]); + \\ qexists_tac `ck1` \\ fs [do_app_def,empty_state_def] +QED -Theorem Eval_Chr - `Eval env x (NUM n) ==> +Theorem Eval_Chr: + Eval env x (NUM n) ==> n < 256 ==> - Eval env (App Chr [x]) (CHAR (CHR n))` - (rw[Eval_rw,CHAR_def,NUM_def,INT_def] + Eval env (App Chr [x]) (CHAR (CHR n)) +Proof + rw[Eval_rw,CHAR_def,NUM_def,INT_def] \\ first_x_assum (qspec_then `refs` mp_tac) \\ strip_tac \\ qexists_tac `ck1` \\ fs [do_app_def,empty_state_def] \\ simp[integerTheory.INT_ABS_NUM] \\ srw_tac[DNF_ss][] - \\ intLib.COOPER_TAC) + \\ intLib.COOPER_TAC +QED -Theorem Boolv_11 - `(Boolv b1 = Boolv b2) <=> (b1 = b2)` - (Cases_on `b1` \\ Cases_on `b2` \\ EVAL_TAC); +Theorem Boolv_11: + (Boolv b1 = Boolv b2) <=> (b1 = b2) +Proof + Cases_on `b1` \\ Cases_on `b2` \\ EVAL_TAC +QED val tac = rw[Eval_rw,CHAR_def,NUM_def,INT_def] \\ Eval2_tac \\ fs [do_app_def,empty_state_def] \\ rw[BOOL_def,opb_lookup_def,Boolv_11] -Theorem Eval_char_lt - `!c1 c2. +Theorem Eval_char_lt: + !c1 c2. Eval env x1 (CHAR c1) ==> Eval env x2 (CHAR c2) ==> - Eval env (App (Chopb Lt) [x1;x2]) (BOOL (c1 < c2))` - (tac \\ rw[stringTheory.char_lt_def] - \\ metis_tac[APPEND_ASSOC]); - -Theorem Eval_char_le - `!c1 c2. + Eval env (App (Chopb Lt) [x1;x2]) (BOOL (c1 < c2)) +Proof + tac \\ rw[stringTheory.char_lt_def] + \\ metis_tac[APPEND_ASSOC] +QED + +Theorem Eval_char_le: + !c1 c2. Eval env x1 (CHAR c1) ==> Eval env x2 (CHAR c2) ==> - Eval env (App (Chopb Leq) [x1;x2]) (BOOL (c1 ≤ c2))` - (tac \\ rw[stringTheory.char_le_def] - \\ metis_tac[APPEND_ASSOC]); - -Theorem Eval_char_gt - `!c1 c2. + Eval env (App (Chopb Leq) [x1;x2]) (BOOL (c1 ≤ c2)) +Proof + tac \\ rw[stringTheory.char_le_def] + \\ metis_tac[APPEND_ASSOC] +QED + +Theorem Eval_char_gt: + !c1 c2. Eval env x1 (CHAR c1) ==> Eval env x2 (CHAR c2) ==> - Eval env (App (Chopb Gt) [x1;x2]) (BOOL (c1 > c2))` - (tac \\ rw[stringTheory.char_gt_def,int_gt,GREATER_DEF] - \\ metis_tac[APPEND_ASSOC]); - -Theorem Eval_char_ge - `!c1 c2. + Eval env (App (Chopb Gt) [x1;x2]) (BOOL (c1 > c2)) +Proof + tac \\ rw[stringTheory.char_gt_def,int_gt,GREATER_DEF] + \\ metis_tac[APPEND_ASSOC] +QED + +Theorem Eval_char_ge: + !c1 c2. Eval env x1 (CHAR c1) ==> Eval env x2 (CHAR c2) ==> - Eval env (App (Chopb Geq) [x1;x2]) (BOOL (c1 ≥ c2))` - (tac \\ rw[stringTheory.char_ge_def,int_ge,GREATER_EQ] - \\ metis_tac[APPEND_ASSOC]); + Eval env (App (Chopb Geq) [x1;x2]) (BOOL (c1 ≥ c2)) +Proof + tac \\ rw[stringTheory.char_ge_def,int_ge,GREATER_EQ] + \\ metis_tac[APPEND_ASSOC] +QED (* strings *) -Theorem LIST_TYPE_CHAR_v_to_char_list - `∀l v. LIST_TYPE CHAR l v ⇒ v_to_char_list v = SOME l` - (Induct +Theorem LIST_TYPE_CHAR_v_to_char_list: + ∀l v. LIST_TYPE CHAR l v ⇒ v_to_char_list v = SOME l +Proof + Induct \\ simp[LIST_TYPE_def,v_to_char_list_def,PULL_EXISTS,CHAR_def] - \\ EVAL_TAC \\ simp []); + \\ EVAL_TAC \\ simp [] +QED val tac1 = rw[Eval_rw,WORD_def] @@ -1342,36 +1500,43 @@ val tac2 = \\ rw[BOOL_def,opb_lookup_def,Boolv_11] \\ fs[STRING_TYPE_def,mlstringTheory.implode_def] -Theorem Eval_implode - `!env x1 l. +Theorem Eval_implode: + !env x1 l. Eval env x1 (LIST_TYPE CHAR l) ==> - Eval env (App Implode [x1]) (STRING_TYPE (implode l))` - (tac1 \\ fs [option_case_eq,pair_case_eq] + Eval env (App Implode [x1]) (STRING_TYPE (implode l)) +Proof + tac1 \\ fs [option_case_eq,pair_case_eq] \\ metis_tac[LIST_TYPE_CHAR_v_to_char_list, - stringTheory.IMPLODE_EXPLODE_I]); + stringTheory.IMPLODE_EXPLODE_I] +QED -Theorem Eval_strlen - `!env x1 s. +Theorem Eval_strlen: + !env x1 s. Eval env x1 (STRING_TYPE s) ==> - Eval env (App Strlen [x1]) (NUM (strlen s))` - (Cases_on`s` \\ tac1 + Eval env (App Strlen [x1]) (NUM (strlen s)) +Proof + Cases_on`s` \\ tac1 \\ fs[NUM_def,INT_def,mlstringTheory.strlen_def] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem Eval_strsub - `!env x1 x2 s n. +Theorem Eval_strsub: + !env x1 x2 s n. Eval env x1 (STRING_TYPE s) ==> Eval env x2 (NUM n) ==> n < strlen s ==> - Eval env (App Strsub [x1; x2]) (CHAR (strsub s n))` - (tac2 \\ Cases_on `s` \\ fs [STRING_TYPE_def,NUM_def,INT_def] - \\ fs[STRING_TYPE_def,CHAR_def,stringTheory.IMPLODE_EXPLODE_I,NUM_def,INT_def]); - -Theorem Eval_concat - `∀env x ls. + Eval env (App Strsub [x1; x2]) (CHAR (strsub s n)) +Proof + tac2 \\ Cases_on `s` \\ fs [STRING_TYPE_def,NUM_def,INT_def] + \\ fs[STRING_TYPE_def,CHAR_def,stringTheory.IMPLODE_EXPLODE_I,NUM_def,INT_def] +QED + +Theorem Eval_concat: + ∀env x ls. Eval env x (LIST_TYPE STRING_TYPE ls) ==> - Eval env (App Strcat [x]) (STRING_TYPE (concat ls))` - (tac1 \\ fs [option_case_eq,pair_case_eq,PULL_EXISTS] + Eval env (App Strcat [x]) (STRING_TYPE (concat ls)) +Proof + tac1 \\ fs [option_case_eq,pair_case_eq,PULL_EXISTS] \\ qhdtm_x_assum`evaluate`kall_tac \\ pop_assum mp_tac \\ qid_spec_tac`res` @@ -1383,16 +1548,18 @@ Theorem Eval_concat \\ rename1`concat (s::ls)` \\ Cases_on`s` \\ fs[STRING_TYPE_def] \\ rw[vs_to_string_def] - \\ fs[concat_def,STRING_TYPE_def] \\ EVAL_TAC); + \\ fs[concat_def,STRING_TYPE_def] \\ EVAL_TAC +QED -Theorem Eval_substring - `∀env x1 x2 x3 len off st. +Theorem Eval_substring: + ∀env x1 x2 x3 len off st. Eval env x1 (STRING_TYPE st) ==> Eval env x2 (NUM off) ==> Eval env x3 (NUM len) ==> off + len <= strlen st ==> - Eval env (App CopyStrStr [x1; x2; x3]) (STRING_TYPE (substring st off len))` - (fs [Eval_rw] \\ rw [] + Eval env (App CopyStrStr [x1; x2; x3]) (STRING_TYPE (substring st off len)) +Proof + fs [Eval_rw] \\ rw [] \\ rw[Eval_rw,WORD_def] \\ first_x_assum (qspec_then `refs` mp_tac) \\ strip_tac \\ first_x_assum (qspec_then `refs++refs'` mp_tac) \\ strip_tac @@ -1410,7 +1577,8 @@ Theorem Eval_substring \\ Cases_on`st` \\ fs[STRING_TYPE_def,empty_state_def] \\ fs[NUM_def,INT_def,IMPLODE_EXPLODE_I] \\ rw[copy_array_def,INT_ABS_NUM,INT_ADD, - substring_def,SEG_TAKE_DROP,STRING_TYPE_def]); + substring_def,SEG_TAKE_DROP,STRING_TYPE_def] +QED (* vectors *) @@ -1418,83 +1586,99 @@ val VECTOR_TYPE_def = Define ` VECTOR_TYPE a (Vector l) v <=> ?l'. v = Vectorv l' /\ LENGTH l = LENGTH l' /\ LIST_REL a l l'`; -Theorem Eval_sub - `!env x1 x2 a n v. +Theorem Eval_sub: + !env x1 x2 a n v. Eval env x1 (VECTOR_TYPE a v) ==> Eval env x2 (NUM n) ==> n < length v ==> - Eval env (App Vsub [x1; x2]) (a (sub v n))` - (tac2 + Eval env (App Vsub [x1; x2]) (a (sub v n)) +Proof + tac2 \\ `?l. v = Vector l` by metis_tac [vector_nchotomy] \\ rw [] \\ fs [VECTOR_TYPE_def, length_def, NUM_def, sub_def, INT_def] - \\ fs [LIST_REL_EL_EQN]); + \\ fs [LIST_REL_EL_EQN] +QED -Theorem Eval_vector - `!env x1 a l. +Theorem Eval_vector: + !env x1 a l. Eval env x1 (LIST_TYPE a l) ==> - Eval env (App VfromList [x1]) (VECTOR_TYPE a (Vector l))` - (tac1 \\ pop_assum mp_tac + Eval env (App VfromList [x1]) (VECTOR_TYPE a (Vector l)) +Proof + tac1 \\ pop_assum mp_tac \\ pop_assum kall_tac \\ Q.SPEC_TAC (`res`, `res`) \\ Induct_on `l` \\ rw [] \\ fs [LIST_TYPE_def, v_to_list_def, PULL_EXISTS] THEN1 (EVAL_TAC \\ fs []) \\ fs [bool_case_eq,option_case_eq,pair_case_eq,PULL_EXISTS] - \\ fs [EVAL ``list_type_num``,VECTOR_TYPE_def]); + \\ fs [EVAL ``list_type_num``,VECTOR_TYPE_def] +QED -Theorem Eval_length - `!env x1 x2 a n v. +Theorem Eval_length: + !env x1 x2 a n v. Eval env x1 (VECTOR_TYPE a v) ==> - Eval env (App Vlength [x1]) (NUM (length v))` - (tac1 \\ Cases_on `v` + Eval env (App Vlength [x1]) (NUM (length v)) +Proof + tac1 \\ Cases_on `v` \\ fs [bool_case_eq,option_case_eq,pair_case_eq,PULL_EXISTS, - VECTOR_TYPE_def,NUM_def,INT_def,length_def]); + VECTOR_TYPE_def,NUM_def,INT_def,length_def] +QED -Theorem list_to_v_LIST_TYPE - `!xs v ys. +Theorem list_to_v_LIST_TYPE: + !xs v ys. LIST_TYPE a xs v /\ v_to_list v = SOME ys ==> - LIST_TYPE a xs (list_to_v ys)` - (Induct + LIST_TYPE a xs (list_to_v ys) +Proof + Induct \\ fs [LIST_TYPE_def, v_to_list_def, list_to_v_def] \\ rw [] \\ fs [v_to_list_def] \\ FULL_CASE_TAC \\ fs [] \\ rw [] \\ fs [list_to_v_def] - \\ res_tac \\ fs []); + \\ res_tac \\ fs [] +QED (* ListAppend theorems *) -Theorem list_to_v_LIST_TYPE_APPEND - `!xs ys x y. +Theorem list_to_v_LIST_TYPE_APPEND: + !xs ys x y. LIST_TYPE a x (list_to_v xs) /\ LIST_TYPE a y (list_to_v ys) ==> - LIST_TYPE a (x ++ y) (list_to_v (xs ++ ys))` - (Induct \\ EVAL_TAC \\ rw [] - \\ Cases_on `x` \\ fs [list_to_v_def, LIST_TYPE_def]); - -Theorem v_to_list_LIST_TYPE - `!x v. - LIST_TYPE a x v ==> ?xs. v_to_list v = SOME xs` - (Induct \\ EVAL_TAC \\ rw [] \\ fs [v_to_list_def] - \\ res_tac \\ fs [] \\ EVAL_TAC); - -Theorem Eval_ListAppend - `!env x1 x2 a l1 l2. + LIST_TYPE a (x ++ y) (list_to_v (xs ++ ys)) +Proof + Induct \\ EVAL_TAC \\ rw [] + \\ Cases_on `x` \\ fs [list_to_v_def, LIST_TYPE_def] +QED + +Theorem v_to_list_LIST_TYPE: + !x v. + LIST_TYPE a x v ==> ?xs. v_to_list v = SOME xs +Proof + Induct \\ EVAL_TAC \\ rw [] \\ fs [v_to_list_def] + \\ res_tac \\ fs [] \\ EVAL_TAC +QED + +Theorem Eval_ListAppend: + !env x1 x2 a l1 l2. Eval env x2 (LIST_TYPE a l1) ==> Eval env x1 (LIST_TYPE a l2) ==> - Eval env (App ListAppend [x2;x1]) (LIST_TYPE a (l1 ++ l2))` - (tac2 \\ fs [option_case_eq,PULL_EXISTS] + Eval env (App ListAppend [x2;x1]) (LIST_TYPE a (l1 ++ l2)) +Proof + tac2 \\ fs [option_case_eq,PULL_EXISTS] \\ imp_res_tac v_to_list_LIST_TYPE \\ fs [] - \\ metis_tac [list_to_v_LIST_TYPE, list_to_v_LIST_TYPE_APPEND]); + \\ metis_tac [list_to_v_LIST_TYPE, list_to_v_LIST_TYPE_APPEND] +QED -Theorem Eval_length - `!env x1 x2 a n v. +Theorem Eval_length: + !env x1 x2 a n v. Eval env x1 (VECTOR_TYPE a v) ==> - Eval env (App Vlength [x1]) (NUM (length v))` - (tac1 \\ fs [] + Eval env (App Vlength [x1]) (NUM (length v)) +Proof + tac1 \\ fs [] \\ `?l. v = Vector l` by metis_tac [vector_nchotomy] - \\ rw [] \\ fs [VECTOR_TYPE_def, length_def, NUM_def, INT_def]); + \\ rw [] \\ fs [VECTOR_TYPE_def, length_def, NUM_def, INT_def] +QED (* This is useful to force the type inferencer to give the type unit to an unused argument. *) @@ -1502,11 +1686,12 @@ val force_unit_type_def = Define ` force_unit_type (u:unit) x = x` |> curry save_thm "force_unit_type_def[simp,compute]"; -Theorem Eval_force_unit_type - `Eval env x1 (UNIT_TYPE u) ==> +Theorem Eval_force_unit_type: + Eval env x1 (UNIT_TYPE u) ==> Eval env x2 ((a:'a -> v -> bool) y) ==> - Eval env (Mat x1 [(Pcon NONE [], x2)]) (a (force_unit_type u y))` - (fs [Eval_rw] \\ rw [] + Eval env (Mat x1 [(Pcon NONE [], x2)]) (a (force_unit_type u y)) +Proof + fs [Eval_rw] \\ rw [] \\ fs[Eval_rw,UNIT_TYPE_def] \\ last_x_assum (qspec_then `refs` mp_tac) \\ strip_tac \\ first_x_assum (qspec_then `refs++refs'` mp_tac) \\ fs [] @@ -1516,36 +1701,42 @@ Theorem Eval_force_unit_type \\ rpt (pop_assum kall_tac) \\ rw [] \\ first_x_assum (qspec_then `ck1` assume_tac) \\ qexists_tac `ck1' + ck1` \\ fs [pat_bindings_def,pmatch_def] - \\ fs [state_component_equality]); + \\ fs [state_component_equality] +QED val force_gc_to_run_def = Define ` force_gc_to_run (i1:int) (i2:int) = ()`; -Theorem Eval_force_gc_to_run - `Eval env x1 (INT i1) ==> +Theorem Eval_force_gc_to_run: + Eval env x1 (INT i1) ==> Eval env x2 (INT i2) ==> - Eval env (App ConfigGC [x1; x2]) (UNIT_TYPE (force_gc_to_run i1 i2))` - (tac2 \\ fs [do_app_def,INT_def,UNIT_TYPE_def]); + Eval env (App ConfigGC [x1; x2]) (UNIT_TYPE (force_gc_to_run i1 i2)) +Proof + tac2 \\ fs [do_app_def,INT_def,UNIT_TYPE_def] +QED val force_out_of_memory_error_def = Define ` force_out_of_memory_error (x:'a) = x`; val two_pow_64 = EVAL ``2i**64`` |> concl |> rand -Theorem Eval_force_out_of_memory_error - `Eval env x (a i) ==> +Theorem Eval_force_out_of_memory_error: + Eval env x (a i) ==> Eval env (Let (SOME "a") x (Let (SOME "n") (Lit (IntLit ^two_pow_64)) (Let NONE (App Aalloc [Var (Short "n"); Var (Short "n")]) - (Var (Short "a"))))) (a (force_out_of_memory_error i))` - (tac1 \\ fs [namespaceTheory.nsOptBind_def,store_alloc_def, - force_out_of_memory_error_def]); - -Theorem Eval_empty_ffi - `Eval env x (STRING_TYPE s) ==> + (Var (Short "a"))))) (a (force_out_of_memory_error i)) +Proof + tac1 \\ fs [namespaceTheory.nsOptBind_def,store_alloc_def, + force_out_of_memory_error_def] +QED + +Theorem Eval_empty_ffi: + Eval env x (STRING_TYPE s) ==> Eval env (App (FFI "") [x; App Aw8alloc [Lit (IntLit 0); Lit (Word8 0w)]]) - (UNIT_TYPE (empty_ffi s))` - (rw[Eval_rw,WORD_def] \\ fs [store_alloc_def,do_app_def] + (UNIT_TYPE (empty_ffi s)) +Proof + rw[Eval_rw,WORD_def] \\ fs [store_alloc_def,do_app_def] \\ first_x_assum (qspec_then `refs ++ [W8array []]` mp_tac) \\ strip_tac \\ qexists_tac `ck1` \\ fs [do_app_def,empty_state_def] \\ Cases_on `s` \\ fs [STRING_TYPE_def] @@ -1556,22 +1747,27 @@ Theorem Eval_empty_ffi \\ fs [store_assign_def] \\ simp_tac std_ss [APPEND,GSYM APPEND_ASSOC] \\ fs [EL_LENGTH_APPEND] - \\ EVAL_TAC \\ fs []); + \\ EVAL_TAC \\ fs [] +QED (* a few misc. lemmas that help the automation *) -Theorem IMP_PreImp - `!b1 b2 b3. (b1 /\ b2 ==> b3) ==> b1 ==> PreImp b2 b3` - (REPEAT Cases \\ EVAL_TAC); +Theorem IMP_PreImp: + !b1 b2 b3. (b1 /\ b2 ==> b3) ==> b1 ==> PreImp b2 b3 +Proof + REPEAT Cases \\ EVAL_TAC +QED (* -Theorem evaluate_list_SIMP - `(evaluate_list F env s [] (s',Rval ([])) = (s = s')) /\ +Theorem evaluate_list_SIMP: + (evaluate_list F env s [] (s',Rval ([])) = (s = s')) /\ (evaluate_list F env s (x::xs) (s',Rval ((y::ys))) <=> ?s''. evaluate F env s x (s'',Rval (y)) /\ - evaluate_list F env s'' xs (s',Rval (ys)))` - (REPEAT STRIP_TAC \\ SIMP_TAC std_ss [Once evaluate_cases] - \\ FULL_SIMP_TAC (srw_ss()) [EQ_IMP_THM]); + evaluate_list F env s'' xs (s',Rval (ys))) +Proof + REPEAT STRIP_TAC \\ SIMP_TAC std_ss [Once evaluate_cases] + \\ FULL_SIMP_TAC (srw_ss()) [EQ_IMP_THM] +QED *) val UNCURRY1 = Q.prove( @@ -1590,10 +1786,12 @@ val UNCURRY3 = Q.prove( val UNCURRY_SIMP = save_thm("UNCURRY_SIMP", LIST_CONJ [UNCURRY1,UNCURRY2,UNCURRY3]); -Theorem num_case_thm - `num_CASE = \n b f. if n = 0 then b else f (n-1)` - (SIMP_TAC std_ss [FUN_EQ_THM,num_case_def] \\ Cases_on `n` - \\ EVAL_TAC \\ SIMP_TAC std_ss []); +Theorem num_case_thm: + num_CASE = \n b f. if n = 0 then b else f (n-1) +Proof + SIMP_TAC std_ss [FUN_EQ_THM,num_case_def] \\ Cases_on `n` + \\ EVAL_TAC \\ SIMP_TAC std_ss [] +QED val PUSH_FORALL_INTO_IMP = save_thm("PUSH_FORALL_INTO_IMP", METIS_PROVE [] ``!P Q. (!x. P x ==> Q x) ==> (!x. P x) ==> (!x. Q x)``); @@ -1601,13 +1799,17 @@ val PUSH_FORALL_INTO_IMP = save_thm("PUSH_FORALL_INTO_IMP", val FALSE_def = Define `FALSE = F`; val TRUE_def = Define `TRUE = T`; -Theorem Eval_Val_BOOL_FALSE - `Eval env (App (Opb Lt) [Lit (IntLit 0); Lit (IntLit 0)]) (BOOL FALSE)` - (SIMP_TAC (srw_ss()) [Eval_Val_BOOL_F,FALSE_def]); +Theorem Eval_Val_BOOL_FALSE: + Eval env (App (Opb Lt) [Lit (IntLit 0); Lit (IntLit 0)]) (BOOL FALSE) +Proof + SIMP_TAC (srw_ss()) [Eval_Val_BOOL_F,FALSE_def] +QED -Theorem Eval_Val_BOOL_TRUE - `Eval env (App (Opb Leq) [Lit (IntLit 0); Lit (IntLit 0)]) (BOOL TRUE)` - (SIMP_TAC (srw_ss()) [Eval_Val_BOOL_T,TRUE_def]); +Theorem Eval_Val_BOOL_TRUE: + Eval env (App (Opb Leq) [Lit (IntLit 0); Lit (IntLit 0)]) (BOOL TRUE) +Proof + SIMP_TAC (srw_ss()) [Eval_Val_BOOL_T,TRUE_def] +QED val MEMBER_def = Define ` (MEMBER (x:'a) [] <=> F) /\ @@ -1617,23 +1819,29 @@ val MEM_EQ_MEMBER = Q.prove( `!ys x. MEM x ys = MEMBER x ys`, Induct \\ FULL_SIMP_TAC (srw_ss()) [MEMBER_def]); -Theorem MEMBER_INTRO - `(MEM = MEMBER) /\ (MEM x = MEMBER x) /\ (MEM x ys = MEMBER x ys)` - (FULL_SIMP_TAC std_ss [FUN_EQ_THM,MEM_EQ_MEMBER]); +Theorem MEMBER_INTRO: + (MEM = MEMBER) /\ (MEM x = MEMBER x) /\ (MEM x ys = MEMBER x ys) +Proof + FULL_SIMP_TAC std_ss [FUN_EQ_THM,MEM_EQ_MEMBER] +QED (* lookup cons *) -Theorem lookup_cons_write - `!funs n x env name env1. +Theorem lookup_cons_write: + !funs n x env name env1. (lookup_cons name (write n x env) = lookup_cons name env) /\ - (lookup_cons name (write_rec funs env1 env) = lookup_cons name env)` - (Induct \\ REPEAT STRIP_TAC - \\ fs [write_rec_thm,write_def,lookup_cons_def]); - -Theorem DISJOINT_set_SIMP - `(DISJOINT (set []) s <=> T) /\ - (DISJOINT (set (x::xs)) s <=> ~(x IN s) /\ DISJOINT (set xs) s)` - (REPEAT STRIP_TAC THEN1 (SRW_TAC [] []) \\ Cases_on `x IN s` \\ fs []); + (lookup_cons name (write_rec funs env1 env) = lookup_cons name env) +Proof + Induct \\ REPEAT STRIP_TAC + \\ fs [write_rec_thm,write_def,lookup_cons_def] +QED + +Theorem DISJOINT_set_SIMP: + (DISJOINT (set []) s <=> T) /\ + (DISJOINT (set (x::xs)) s <=> ~(x IN s) /\ DISJOINT (set xs) s) +Proof + REPEAT STRIP_TAC THEN1 (SRW_TAC [] []) \\ Cases_on `x IN s` \\ fs [] +QED (* removing shadowed elements from an alist *) @@ -1732,16 +1940,18 @@ val v2_size = Q.prove( \\ SRW_TAC [] [semanticPrimitivesTheory.v_size_def] \\ RES_TAC \\ DECIDE_TAC); -Theorem v_size_lemmas - `(MEM (x,y) envE ==> v_size y <= v3_size envE) /\ +Theorem v_size_lemmas: + (MEM (x,y) envE ==> v_size y <= v3_size envE) /\ (MEM (x,y) xs /\ MEM (t,xs) p1 ==> v_size y <= v2_size p1) /\ - (MEM v vs ==> v_size v < v7_size vs)` - (FULL_SIMP_TAC std_ss [] \\ REPEAT STRIP_TAC + (MEM v vs ==> v_size v < v7_size vs) +Proof + FULL_SIMP_TAC std_ss [] \\ REPEAT STRIP_TAC \\ IMP_RES_TAC v4_size \\ IMP_RES_TAC v2_size \\ IMP_RES_TAC v6_size \\ FULL_SIMP_TAC std_ss [semanticPrimitivesTheory.v_size_def] - \\ DECIDE_TAC); + \\ DECIDE_TAC +QED *) (* introducing a module (Tmod) *) @@ -1777,23 +1987,29 @@ val lookup_APPEND = Q.prove( \\ FULL_SIMP_TAC std_ss [FORALL_PROD,APPEND] \\ rw []); -Theorem FEVERY_DRESTRICT_FUPDATE - `FEVERY P (DRESTRICT (f |+ (x,y)) (COMPL s)) <=> +Theorem FEVERY_DRESTRICT_FUPDATE: + FEVERY P (DRESTRICT (f |+ (x,y)) (COMPL s)) <=> (~(x IN s) ==> P (x,y)) /\ - FEVERY P (DRESTRICT f (COMPL (x INSERT s)))` - (fs [] \\ SRW_TAC [] [finite_mapTheory.FEVERY_FUPDATE] + FEVERY P (DRESTRICT f (COMPL (x INSERT s))) +Proof + fs [] \\ SRW_TAC [] [finite_mapTheory.FEVERY_FUPDATE] THEN1 (`COMPL s INTER COMPL {x} = COMPL (x INSERT s)` by (fs [Once pred_setTheory.EXTENSION] \\ METIS_TAC []) \\ fs []) \\ `COMPL s = COMPL (x INSERT s)` by - (fs [Once pred_setTheory.EXTENSION] \\ METIS_TAC []) \\ fs []) + (fs [Once pred_setTheory.EXTENSION] \\ METIS_TAC []) \\ fs [] +QED -Theorem PULL_EXISTS_EXTRA - `(Q ==> ?x. P x) <=> ?x. Q ==> P x` - (metis_tac []); +Theorem PULL_EXISTS_EXTRA: + (Q ==> ?x. P x) <=> ?x. Q ==> P x +Proof + metis_tac [] +QED -Theorem Eval_Fun_rw - `Eval env (Fun n exp) P <=> P (Closure env n exp)` - (rw[Eval_rw,EQ_IMP_THM,empty_state_def]); +Theorem Eval_Fun_rw: + Eval env (Fun n exp) P <=> P (Closure env n exp) +Proof + rw[Eval_rw,EQ_IMP_THM,empty_state_def] +QED val evaluate_Var_nsLookup = Q.prove( `eval_rel s env (Var id) s' r <=> @@ -1806,146 +2022,208 @@ val evaluate_Var = Q.prove( ?v. lookup_var n env = SOME r ∧ s' = s`, fs [evaluate_Var_nsLookup,lookup_var_def]); -Theorem Eval_Var_nsLookup - `Eval env (Var id) P <=> case nsLookup env.v id of NONE => F | SOME v => P v` - (fs [Eval_def,evaluate_Var_nsLookup, state_component_equality] - \\ PURE_CASE_TAC \\ fs []); - -Theorem Eval_Var - `Eval env (Var (Short n)) P <=> - ?v. lookup_var n env = SOME v /\ P v` - (rw[Eval_Var_nsLookup,lookup_var_def] \\ PURE_CASE_TAC \\ fs[]); - -Theorem Eval_Fun_Var_intro - `Eval cl_env (Fun n exp) P ==> +Theorem Eval_Var_nsLookup: + Eval env (Var id) P <=> case nsLookup env.v id of NONE => F | SOME v => P v +Proof + fs [Eval_def,evaluate_Var_nsLookup, state_component_equality] + \\ PURE_CASE_TAC \\ fs [] +QED + +Theorem Eval_Var: + Eval env (Var (Short n)) P <=> + ?v. lookup_var n env = SOME v /\ P v +Proof + rw[Eval_Var_nsLookup,lookup_var_def] \\ PURE_CASE_TAC \\ fs[] +QED + +Theorem Eval_Fun_Var_intro: + Eval cl_env (Fun n exp) P ==> ∀name. LOOKUP_VAR name env (Closure cl_env n exp) ==> - Eval env (Var (Short name)) P` - (rw[Eval_Fun_rw,Eval_Var,LOOKUP_VAR_def]); - -Theorem Eval_Var_LOOKUP_VAR_elim - `(!env. LOOKUP_VAR name env v ==> Eval env (Var (Short name)) P) ==> P v` - (rw[Eval_Var,LOOKUP_VAR_def] + Eval env (Var (Short name)) P +Proof + rw[Eval_Fun_rw,Eval_Var,LOOKUP_VAR_def] +QED + +Theorem Eval_Var_LOOKUP_VAR_elim: + (!env. LOOKUP_VAR name env v ==> Eval env (Var (Short name)) P) ==> P v +Proof + rw[Eval_Var,LOOKUP_VAR_def] \\ first_x_assum match_mp_tac \\ qexists_tac`<| v := nsSing name v |>` - \\ EVAL_TAC); + \\ EVAL_TAC +QED val PRECONDITION_T = save_thm("PRECONDITION_T",EVAL ``PRECONDITION T``); -Theorem Eval_constant - `!refs. Eval env exp P ==> +Theorem Eval_constant: + !refs. Eval env exp P ==> ?v refs'. eval_rel (empty_state with refs := refs) env exp - (empty_state with refs := refs ++ refs') v` - (rw[Eval_def] + (empty_state with refs := refs ++ refs') v +Proof + rw[Eval_def] \\ first_x_assum(qspec_then`refs`strip_assume_tac) - \\ asm_exists_tac \\ fs []); + \\ asm_exists_tac \\ fs [] +QED -Theorem Eval_evaluate_IMP - `Eval env exp P /\ +Theorem Eval_evaluate_IMP: + Eval env exp P /\ eval_rel s env exp s' v ==> - P v` - (fs [Eval_def] \\ rw [] + P v +Proof + fs [Eval_def] \\ rw [] \\ first_x_assum(qspec_then`s.refs`strip_assume_tac) \\ imp_res_tac evaluate_empty_state_IMP - \\ imp_res_tac eval_rel_11 \\ fs []); - -Theorem pair_CASE_UNCURRY - `!x y. pair_CASE x y = UNCURRY y x` - (Cases \\ EVAL_TAC \\ fs []); - -Theorem IF_T `(if T then x else y) = x:'a` (SIMP_TAC std_ss []); -Theorem IF_F `(if F then x else y) = y:'a` (SIMP_TAC std_ss []); - -Theorem sat_hyp_lemma - `(b1 ==> (x1 = x2)) /\ (x1 ==> y) ==> b1 /\ x2 ==> y` - (Cases_on `b1` \\ Cases_on `x1` \\ Cases_on `x2` \\ Cases_on `y` \\ EVAL_TAC); - -Theorem IMP_EQ_F `~b ==> (b = F)` (REWRITE_TAC []) -Theorem IMP_EQ_T `b ==> (b = T)` (REWRITE_TAC []) - -Theorem IF_TAKEN - `!b x y. b ==> ((if b then x else y) = x:'unlikely)` - (SIMP_TAC std_ss []); + \\ imp_res_tac eval_rel_11 \\ fs [] +QED + +Theorem pair_CASE_UNCURRY: + !x y. pair_CASE x y = UNCURRY y x +Proof + Cases \\ EVAL_TAC \\ fs [] +QED + +Theorem IF_T: + (if T then x else y) = x:'a +Proof +SIMP_TAC std_ss [] +QED +Theorem IF_F: + (if F then x else y) = y:'a +Proof +SIMP_TAC std_ss [] +QED + +Theorem sat_hyp_lemma: + (b1 ==> (x1 = x2)) /\ (x1 ==> y) ==> b1 /\ x2 ==> y +Proof + Cases_on `b1` \\ Cases_on `x1` \\ Cases_on `x2` \\ Cases_on `y` \\ EVAL_TAC +QED + +Theorem IMP_EQ_F: + ~b ==> (b = F) +Proof +REWRITE_TAC [] +QED +Theorem IMP_EQ_T: + b ==> (b = T) +Proof +REWRITE_TAC [] +QED + +Theorem IF_TAKEN: + !b x y. b ==> ((if b then x else y) = x:'unlikely) +Proof + SIMP_TAC std_ss [] +QED val EQ_COND_INTRO = save_thm("EQ_COND_INTRO", METIS_PROVE[]``(b ==> c) ==> (c = if b then T else c)``); -Theorem LIST_TYPE_And - `LIST_TYPE (And a P) = And (LIST_TYPE a) (EVERY (P:'a->bool))` - (SIMP_TAC std_ss [FUN_EQ_THM,And_def] \\ Induct +Theorem LIST_TYPE_And: + LIST_TYPE (And a P) = And (LIST_TYPE a) (EVERY (P:'a->bool)) +Proof + SIMP_TAC std_ss [FUN_EQ_THM,And_def] \\ Induct \\ FULL_SIMP_TAC std_ss [MEM,LIST_TYPE_def] \\ REPEAT STRIP_TAC \\ EQ_TAC \\ REPEAT STRIP_TAC - \\ FULL_SIMP_TAC (srw_ss()) [And_def]) - -Theorem EVERY_MEM_CONTAINER - `!P l. EVERY P l <=> !e. CONTAINER (MEM e l) ==> P (e:'a)` - (SIMP_TAC std_ss [EVERY_MEM,CONTAINER_def]); - -Theorem PRECONDITION_EQ_CONTAINER - `(PRECONDITION p = CONTAINER p) /\ - (CONTAINER ~p = ~CONTAINER p) /\ CONTAINER T` - (EVAL_TAC); - -Theorem CONTAINER_NOT_ZERO - `!P. (~(CONTAINER (b = 0)) ==> P b) = - !n. (CONTAINER (b = SUC n)) ==> P (SUC n:num)` - (REPEAT STRIP_TAC THEN Cases_on `b` - THEN EVAL_TAC THEN SRW_TAC [] [ADD1]); - -Theorem IMP_PreImp_LEMMA - `!b1 b2 b3. (b1 ==> b3 ==> b2) ==> b3 ==> PreImp b1 b2` - (REPEAT Cases THEN REWRITE_TAC [PreImp_def,PRECONDITION_def]); - -Theorem PRE_IMP - `T /\ PRECONDITION b ==> PRECONDITION b` - (EVAL_TAC) - -Theorem PreImp_IMP_T - `PreImp b1 b2 /\ T ==> PreImp b1 b2` - (EVAL_TAC) - -Theorem CONJ_IMP - `!b1 b2 b12 b3 b4 b34. + \\ FULL_SIMP_TAC (srw_ss()) [And_def] +QED + +Theorem EVERY_MEM_CONTAINER: + !P l. EVERY P l <=> !e. CONTAINER (MEM e l) ==> P (e:'a) +Proof + SIMP_TAC std_ss [EVERY_MEM,CONTAINER_def] +QED + +Theorem PRECONDITION_EQ_CONTAINER: + (PRECONDITION p = CONTAINER p) /\ + (CONTAINER ~p = ~CONTAINER p) /\ CONTAINER T +Proof + EVAL_TAC +QED + +Theorem CONTAINER_NOT_ZERO: + !P. (~(CONTAINER (b = 0)) ==> P b) = + !n. (CONTAINER (b = SUC n)) ==> P (SUC n:num) +Proof + REPEAT STRIP_TAC THEN Cases_on `b` + THEN EVAL_TAC THEN SRW_TAC [] [ADD1] +QED + +Theorem IMP_PreImp_LEMMA: + !b1 b2 b3. (b1 ==> b3 ==> b2) ==> b3 ==> PreImp b1 b2 +Proof + REPEAT Cases THEN REWRITE_TAC [PreImp_def,PRECONDITION_def] +QED + +Theorem PRE_IMP: + T /\ PRECONDITION b ==> PRECONDITION b +Proof + EVAL_TAC +QED + +Theorem PreImp_IMP_T: + PreImp b1 b2 /\ T ==> PreImp b1 b2 +Proof + EVAL_TAC +QED + +Theorem CONJ_IMP = Q.prove(` + !b1 b2 b12 b3 b4 b34. (b1 /\ b2 ==> b12) /\ (b3 /\ b4 ==> b34) ==> - ((b1 /\ b3) /\ (b2 /\ b4) ==> b12 /\ b34)` - (REPEAT Cases THEN EVAL_TAC) |> SPEC_ALL; + ((b1 /\ b3) /\ (b2 /\ b4) ==> b12 /\ b34)`, + REPEAT Cases THEN EVAL_TAC) |> SPEC_ALL; -Theorem IMP_SPLIT - `!b12 b3 b4 b34. +Theorem IMP_SPLIT = Q.prove(` + !b12 b3 b4 b34. (b12 = b12) /\ (b3 /\ b4 ==> b34) ==> - ((b12 ==> b3) /\ (b12 ==> b4) ==> (b12 ==> b34))` - (REPEAT Cases THEN EVAL_TAC) |> SPEC_ALL; - -Theorem FORALL_SPLIT - `(!x. P1 x /\ P2 x ==> P (x:'a)) ==> - ($! P1 ) /\ ($! P2 ) ==> $! P ` - (FULL_SIMP_TAC std_ss [FORALL_THM]); - -Theorem DEFAULT_IMP - `!b1. b1 /\ b1 ==> b1` - (SIMP_TAC std_ss []); - -Theorem combine_lemma - `!b1 b2 b3 b4. (b1 /\ b2 ==> b3) /\ (b3 ==> b4) ==> b2 ==> b1 ==> b4` - (REPEAT Cases THEN SIMP_TAC std_ss []) - -Theorem IMP_PreImp_THM - `(b ==> PreImp x y) ==> ((x ==> b) ==> PreImp x y)` - (Cases_on `b` \\ FULL_SIMP_TAC std_ss [PreImp_def,PRECONDITION_def]); - -Theorem PreImp_IMP - `(PRECONDITION x ==> PreImp x y) ==> PreImp x y` - (SIMP_TAC std_ss [PreImp_def]); - -Theorem PreImp_LEMMA - `(b1 ==> PreImp b1 b2) ==> PreImp b1 b2` - (fs [PreImp_def,PRECONDITION_def]); + ((b12 ==> b3) /\ (b12 ==> b4) ==> (b12 ==> b34))`, + REPEAT Cases THEN EVAL_TAC) |> SPEC_ALL; + +Theorem FORALL_SPLIT: + (!x. P1 x /\ P2 x ==> P (x:'a)) ==> + ($! P1 ) /\ ($! P2 ) ==> $! P +Proof + FULL_SIMP_TAC std_ss [FORALL_THM] +QED + +Theorem DEFAULT_IMP: + !b1. b1 /\ b1 ==> b1 +Proof + SIMP_TAC std_ss [] +QED + +Theorem combine_lemma: + !b1 b2 b3 b4. (b1 /\ b2 ==> b3) /\ (b3 ==> b4) ==> b2 ==> b1 ==> b4 +Proof + REPEAT Cases THEN SIMP_TAC std_ss [] +QED + +Theorem IMP_PreImp_THM: + (b ==> PreImp x y) ==> ((x ==> b) ==> PreImp x y) +Proof + Cases_on `b` \\ FULL_SIMP_TAC std_ss [PreImp_def,PRECONDITION_def] +QED + +Theorem PreImp_IMP: + (PRECONDITION x ==> PreImp x y) ==> PreImp x y +Proof + SIMP_TAC std_ss [PreImp_def] +QED + +Theorem PreImp_LEMMA: + (b1 ==> PreImp b1 b2) ==> PreImp b1 b2 +Proof + fs [PreImp_def,PRECONDITION_def] +QED val SUC_SUB1_LEMMA = save_thm("SUC_SUB1_LEMMA", Q.SPECL [`n`,`1`] ADD_SUB |> REWRITE_RULE [GSYM ADD1]); -Theorem LENGTH_EQ_SUC_IMP - `LENGTH xs = SUC n ==> xs <> []` - (Cases_on `xs` \\ fs []); +Theorem LENGTH_EQ_SUC_IMP: + LENGTH xs = SUC n ==> xs <> [] +Proof + Cases_on `xs` \\ fs [] +QED val prim_exn_list = let val tm = primSemEnvTheory.prim_sem_env_eq |> concl |> rand |> rand |> rand @@ -1970,12 +2248,14 @@ val good_cons_env_def = Define ` let (name,vars,x,t1) = HD ps in EVERY (\(name,vars,x,t2). same_type t1 t2) ps` -Theorem same_type_trans - `same_type t1 t2 /\ same_type t1 t3 ==> same_type t2 t3` - (Cases_on `t1` \\ Cases_on `t2` \\ Cases_on `t3` \\ fs [same_type_def]); +Theorem same_type_trans: + same_type t1 t2 /\ same_type t1 t3 ==> same_type t2 t3 +Proof + Cases_on `t1` \\ Cases_on `t2` \\ Cases_on `t3` \\ fs [same_type_def] +QED -Theorem evaluate_match_MAP - `!l1 xs. +Theorem evaluate_match_MAP = Q.prove(` + !l1 xs. MEM (x1,x2,x3,t1) full_ps /\ full_ps <> [] /\ good_cons_env full_ps env /\ set l1 SUBSET set full_ps /\ ~MEM t1 (MAP (SND o SND o SND) l1) ==> @@ -1983,8 +2263,8 @@ Theorem evaluate_match_MAP (Conv (SOME t1) vals) (MAP (λ(name,vars,x,t). (Pcon (SOME name) (MAP Pvar vars),x)) l1 ++ xs) err = - evaluate_match s env (Conv (SOME t1) vals) xs err` - (Induct + evaluate_match s env (Conv (SOME t1) vals) xs err`, + Induct \\ fs [FORALL_PROD,evaluate_def,pmatch_def,pat_bindings_def] \\ rpt strip_tac \\ fs [good_cons_env_def,lookup_cons_def] @@ -1998,30 +2278,34 @@ Theorem evaluate_match_MAP \\ imp_res_tac same_type_trans \\ fs [] \\ fs [same_ctor_def]) |> GEN_ALL; -Theorem pmatch_list_MAP_Pvar - `!vars vals aux. +Theorem pmatch_list_MAP_Pvar: + !vars vals aux. LENGTH vars = LENGTH vals ==> pmatch_list env refs (MAP Pvar vars) vals aux = - Match (REVERSE (ZIP (vars, vals)) ++ aux)` - (Induct \\ Cases_on `vals` \\ fs [] \\ fs [pmatch_def]); + Match (REVERSE (ZIP (vars, vals)) ++ aux) +Proof + Induct \\ Cases_on `vals` \\ fs [] \\ fs [pmatch_def] +QED val write_list_def = Define ` write_list [] (env:v sem_env) = env /\ write_list ((n,v)::xs) env = write_list xs (write n v env)`; -Theorem write_list_thm - `!xs env. +Theorem write_list_thm: + !xs env. write_list xs (env:v sem_env) = - (env with v := nsAppend (alist_to_ns (REVERSE xs)) env.v)` - (Induct + (env with v := nsAppend (alist_to_ns (REVERSE xs)) env.v) +Proof + Induct \\ fs [write_list_def,FORALL_PROD,namespaceTheory.alist_to_ns_def, write_def,namespaceTheory.nsBind_def] \\ rw [] \\ Cases_on `env.v` \\ fs [namespaceTheory.nsBind_def,namespaceTheory.nsAppend_def] - \\ fs [sem_env_component_equality]); + \\ fs [sem_env_component_equality] +QED -Theorem IMP_Eval_Mat_cases - `!a (r1:'a) env exp r2 y. +Theorem IMP_Eval_Mat_cases: + !a (r1:'a) env exp r2 y. Eval env exp (a r1) /\ (case y of | INL (vars,exp) => @@ -2039,8 +2323,9 @@ Theorem IMP_Eval_Mat_cases MEM (name,vars,exp,t) ps /\ LENGTH vals = LENGTH vars /\ Eval (write_list (ZIP (vars,vals)) env) exp r2)) ==> - Eval env (Mat exp (Mat_cases y)) r2` - (rpt gen_tac \\ Cases_on `y` + Eval env (Mat exp (Mat_cases y)) r2 +Proof + rpt gen_tac \\ Cases_on `y` THEN1 (Cases_on `x` \\ fs [Eval_def,EXISTS_MEM,EXISTS_PROD,eval_rel_def] @@ -2086,7 +2371,8 @@ Theorem IMP_Eval_Mat_cases \\ fs [good_cons_env_def,lookup_cons_def] \\ `same_type t t /\ same_ctor t t` by (Cases_on `t` \\ EVAL_TAC) \\ fs [] \\ fs [pmatch_list_MAP_Pvar,GSYM write_list_thm] - \\ fs [state_component_equality]); + \\ fs [state_component_equality] +QED val Eval_Con_lemma = prove( ``!ps refs. @@ -2112,15 +2398,16 @@ val Eval_Con_lemma = prove( \\ asm_exists_tac \\ fs [] \\ fs [state_component_equality]); -Theorem Eval_Con - `!ps stamp. +Theorem Eval_Con: + !ps stamp. lookup_cons name env = SOME (LENGTH ps,stamp) /\ EVERY (\(p,x). Eval env x p) ps /\ (!vals. LIST_REL (\(p,x) v. p v) ps vals ==> q (Conv (SOME stamp) vals)) ==> - Eval env (Con (SOME name) (MAP SND ps)) q` - (rpt strip_tac \\ fs [EVERY_MEM,FORALL_PROD] \\ rw [Eval_def] + Eval env (Con (SOME name) (MAP SND ps)) q +Proof + rpt strip_tac \\ fs [EVERY_MEM,FORALL_PROD] \\ rw [Eval_def] \\ simp [eval_rel_def,PULL_EXISTS,evaluate_def,do_con_check_def] \\ fs [lookup_cons_def,build_conv_def] \\ `∀p_1 p_2. MEM (p_1,p_2) (REVERSE ps) ⇒ Eval env p_2 p_1` by fs [] @@ -2128,16 +2415,18 @@ Theorem Eval_Con \\ disch_then (qspec_then `refs` strip_assume_tac) \\ fs [pair_case_eq,result_case_eq,PULL_EXISTS,MAP_REVERSE] \\ asm_exists_tac \\ fs [] - \\ fs [GSYM EVERY2_REVERSE1]); + \\ fs [GSYM EVERY2_REVERSE1] +QED -Theorem Eval_Con_NONE - `!ps. +Theorem Eval_Con_NONE: + !ps. EVERY (\(p,x). Eval env x p) ps /\ (!vals. LIST_REL (\(p,x) v. p v) ps vals ==> q (Conv NONE vals)) ==> - Eval env (Con NONE (MAP SND ps)) q` - (rpt strip_tac \\ fs [EVERY_MEM,FORALL_PROD] \\ rw [Eval_def] + Eval env (Con NONE (MAP SND ps)) q +Proof + rpt strip_tac \\ fs [EVERY_MEM,FORALL_PROD] \\ rw [Eval_def] \\ simp [eval_rel_def,PULL_EXISTS,evaluate_def,do_con_check_def] \\ fs [lookup_cons_def,build_conv_def] \\ `∀p_1 p_2. MEM (p_1,p_2) (REVERSE ps) ⇒ Eval env p_2 p_1` by fs [] @@ -2145,7 +2434,8 @@ Theorem Eval_Con_NONE \\ disch_then (qspec_then `refs` strip_assume_tac) \\ fs [pair_case_eq,result_case_eq,PULL_EXISTS,MAP_REVERSE] \\ asm_exists_tac \\ fs [] - \\ fs [GSYM EVERY2_REVERSE1]); + \\ fs [GSYM EVERY2_REVERSE1] +QED (* terms used by the Lib file *) diff --git a/translator/ml_translator_demoScript.sml b/translator/ml_translator_demoScript.sml index 7454343fbd..8276bfcd69 100644 --- a/translator/ml_translator_demoScript.sml +++ b/translator/ml_translator_demoScript.sml @@ -43,8 +43,8 @@ val Eval_Var_lemma = Q.prove( `(lookup_var name env = SOME x) /\ P x ==> Eval env (Var (Short name)) P`, fs[Eval_Var]); -Theorem ML_QSORT_CORRECT - `!env tys a ord R l xs refs. +Theorem ML_QSORT_CORRECT: + !env tys a ord R l xs refs. nsLookup env.v (Short "qsort") = SOME qsort_v /\ LIST_TYPE a l xs /\ (lookup_var "xs" env = SOME xs) /\ (a --> a --> BOOL) ord R /\ (lookup_var "R" env = SOME R) /\ @@ -55,11 +55,13 @@ Theorem ML_QSORT_CORRECT [App Opapp [App Opapp [Var (Short "qsort"); Var (Short "R")]; Var (Short "xs")]] = (empty_state with <| clock := ck2; refs := refs ++ refs' |>,Rval [xs']) /\ - (LIST_TYPE a l' xs') /\ PERM l l' /\ SORTED ord l'` - (rw [] \\ imp_res_tac Eval_Var_lemma + (LIST_TYPE a l' xs') /\ PERM l l' /\ SORTED ord l' +Proof + rw [] \\ imp_res_tac Eval_Var_lemma \\ imp_res_tac (DISCH_ALL (hol2deep ``QSORT R xs``)) \\ fs [Eval_def,ml_progTheory.eval_rel_def] - \\ metis_tac [sortingTheory.QSORT_PERM,sortingTheory.QSORT_SORTED]); + \\ metis_tac [sortingTheory.QSORT_PERM,sortingTheory.QSORT_SORTED] +QED val _ = export_theory(); diff --git a/translator/ml_translator_testScript.sml b/translator/ml_translator_testScript.sml index 86c31a4ac8..52a2357ca1 100644 --- a/translator/ml_translator_testScript.sml +++ b/translator/ml_translator_testScript.sml @@ -232,11 +232,13 @@ val a_c_inv_num = get_type_inv ``:(num, num) a_c_type``; val st_inv = get_type_inv ``:simple_type``; val st2_inv = get_type_inv ``:simple_type2``; -Theorem EqTyp_test_lemmas - `EqualityType (^a_inv) /\ EqualityType (^a_b_inv) +Theorem EqTyp_test_lemmas: + EqualityType (^a_inv) /\ EqualityType (^a_b_inv) /\ EqualityType (^a_c_inv_num) /\ EqualityType (^st_inv) - /\ EqualityType (^st2_inv)` - (fs (eq_lemmas ())); + /\ EqualityType (^st2_inv) +Proof + fs (eq_lemmas ()) +QED (* translating within nested local blocks and modules *) diff --git a/translator/monadic/cfMonadScript.sml b/translator/monadic/cfMonadScript.sml index 9a5eeadabd..cf3f798230 100644 --- a/translator/monadic/cfMonadScript.sml +++ b/translator/monadic/cfMonadScript.sml @@ -93,14 +93,15 @@ val REFS_PRED_from_SPLIT = Q.prove( \\ rw[STAR_def] \\ metis_tac[SAT_GC]); -Theorem ArrowP_PURE_to_app - `!A B f fv x1 xv1 xv2 xvl H Q ro state p. +Theorem ArrowP_PURE_to_app: + !A B f fv x1 xv1 xv2 xvl H Q ro state p. A x1 xv1 ==> (!gv. B (f x1) gv ==> app (p : 'ffi ffi_proj) gv (xv2::xvl) (H state) (Q state)) ==> ArrowP ro (H,p) (PURE A) (PURE B) f fv ==> - app p fv (xv1::xv2::xvl) (H state) (Q state)` - (rw [app_def, app_basic_def, ArrowP_def, PURE_def] + app p fv (xv1::xv2::xvl) (H state) (Q state) +Proof + rw [app_def, app_basic_def, ArrowP_def, PURE_def] \\ drule REFS_PRED_from_SPLIT \\ disch_then drule \\ rw[] \\ fs [PULL_EXISTS] \\ first_x_assum(qspecl_then [`x1`, `state`, `st`, `xv1`] assume_tac) @@ -121,10 +122,11 @@ Theorem ArrowP_PURE_to_app \\ fs [evaluate_to_heap_def,evaluate_ck_def,with_same_refs] \\ drule evaluatePropsTheory.evaluate_set_clock \\ rw [] \\ first_x_assum (qspec_then `0` mp_tac) \\ strip_tac - \\ instantiate); + \\ instantiate +QED -Theorem ArrowP_MONAD_to_app - `!A B C f fv H x xv ro refs p. +Theorem ArrowP_MONAD_to_app: + !A B C f fv H x xv ro refs p. A x xv ==> ArrowP ro (H,p) (PURE A) (MONAD B C) f fv ==> app (p : 'ffi ffi_proj) fv [xv] (H refs) @@ -132,8 +134,9 @@ Theorem ArrowP_MONAD_to_app (\rv. SEP_EXISTS refs' r. H refs' * &(f x refs = (Success r, refs')) * &(B r rv)) (\ev. SEP_EXISTS refs' e. H refs' * - &(f x refs = (Failure e, refs')) * &(C e ev)))` - (rw [app_def, app_basic_def, ArrowP_def, EqSt_def, PURE_def] + &(f x refs = (Failure e, refs')) * &(C e ev))) +Proof + rw [app_def, app_basic_def, ArrowP_def, EqSt_def, PURE_def] \\ fs [PULL_EXISTS] \\ first_x_assum drule \\ disch_then (qspecl_then [`refs`,`st`] mp_tac) @@ -159,10 +162,11 @@ Theorem ArrowP_MONAD_to_app \\ qexists_tac `r` \\ qexists_tac `b` \\ rw [SEP_CLAUSES]) \\ qexists_tac `ck1` - \\ fs [SEP_CLAUSES,SEP_EXISTS_THM,PULL_EXISTS]); + \\ fs [SEP_CLAUSES,SEP_EXISTS_THM,PULL_EXISTS] +QED -Theorem ArrowP_MONAD_EqSt_to_app - `!A B C f fv H x xv ro refs p. +Theorem ArrowP_MONAD_EqSt_to_app: + !A B C f fv H x xv ro refs p. A x xv ==> ArrowP ro (H,p) (EqSt (PURE A) refs) (MONAD B C) f fv ==> app (p : 'ffi ffi_proj) fv [xv] (H refs) @@ -170,8 +174,9 @@ Theorem ArrowP_MONAD_EqSt_to_app (\rv. SEP_EXISTS refs' r. H refs' * &(f x refs = (Success r, refs')) * &(B r rv)) (\ev. SEP_EXISTS refs' e. H refs' * - &(f x refs = (Failure e, refs')) * &(C e ev)))` - (rw [app_def, app_basic_def, ArrowP_def, EqSt_def, PURE_def] + &(f x refs = (Failure e, refs')) * &(C e ev))) +Proof + rw [app_def, app_basic_def, ArrowP_def, EqSt_def, PURE_def] \\ fs [PULL_EXISTS] \\ first_x_assum drule \\ disch_then (qspecl_then [`st`] mp_tac) @@ -198,7 +203,8 @@ Theorem ArrowP_MONAD_EqSt_to_app \\ qexists_tac `r` \\ qexists_tac `b` \\ rw [SEP_CLAUSES]) \\ qexists_tac `ck1` - \\ fs [SEP_CLAUSES,SEP_EXISTS_THM,PULL_EXISTS]); + \\ fs [SEP_CLAUSES,SEP_EXISTS_THM,PULL_EXISTS] +QED val st2heap_with_clock = store_thm("st2heap_with_clock[simp]", (* TODO: move *) ``st2heap p (s with clock := c) = st2heap p s``, @@ -232,8 +238,8 @@ val st2heap_append_UNION = store_thm("st2heap_new_refs_UNION", (* TODO: move *) \\ fs [IN_DISJOINT,EXTENSION,IN_UNION,IN_DIFF] \\ metis_tac []); -Theorem EvalM_from_app - `!(eff_v:v) ARG_TYPE EXC_TYPE. +Theorem EvalM_from_app: + !(eff_v:v) ARG_TYPE EXC_TYPE. (!x s. ?r t. f x s = (Success r, t)) /\ (!x xv s ret new_s. ARG_TYPE x xv ==> @@ -245,8 +251,9 @@ Theorem EvalM_from_app (nsLookup env.v fun_name = SOME fun_v) ==> EvalM F env st (App Opapp [Var fun_name; fun_exp]) (MONAD RET_TYPE EXC_TYPE (f x)) - (H, p)` - (rw [EvalM_def] \\ fs [Eval_def] + (H, p) +Proof + rw [EvalM_def] \\ fs [Eval_def] \\ first_x_assum (qspec_then `s.refs` strip_assume_tac) \\ fs [cfAppTheory.app_def, cfAppTheory.app_basic_def, evaluate_to_heap_def] \\ simp [MONAD_def] @@ -321,7 +328,8 @@ Theorem EvalM_from_app \\ qpat_x_assum `_ = (_,Rval [val])` assume_tac \\ drule evaluatePropsTheory.evaluate_add_to_clock \\ disch_then (qspec_then `ck'` mp_tac) \\ fs [] - \\ simp [state_component_equality]); + \\ simp [state_component_equality] +QED val parsed_terms = save_thm("parsed_terms", packLib.pack_list diff --git a/translator/monadic/examples/floyd_warshallProgScript.sml b/translator/monadic/examples/floyd_warshallProgScript.sml index a83ef2eef3..49c29e166a 100644 --- a/translator/monadic/examples/floyd_warshallProgScript.sml +++ b/translator/monadic/examples/floyd_warshallProgScript.sml @@ -158,28 +158,33 @@ val msimps = [st_ex_bind_def,st_ex_FOR_def] val _ = temp_tight_equality(); -Theorem mk_graph_SUCCESS ` - ∃res. +Theorem mk_graph_SUCCESS: + ∃res. (mk_graph d s = (Success ():(unit,state_exn) exc,res)) ∧ - d*d = LENGTH res.adj_mat ∧ res.dim = d` - (fs[mk_graph_def]>> + d*d = LENGTH res.adj_mat ∧ res.dim = d +Proof + fs[mk_graph_def]>> fs(msimps)>> - fs [alloc_adj_mat_def,set_dim_def,Marray_alloc_def,LENGTH_REPLICATE]); + fs [alloc_adj_mat_def,set_dim_def,Marray_alloc_def,LENGTH_REPLICATE] +QED -Theorem set_weight_SUCCESS - `j + i * s.dim < LENGTH s.adj_mat ⇒ +Theorem set_weight_SUCCESS: + j + i * s.dim < LENGTH s.adj_mat ⇒ ∃r. set_weight i j k s = (Success (), r) ∧ LENGTH r.adj_mat = LENGTH s.adj_mat ∧ - r.dim = s.dim` - (rw[set_weight_def, reind_def, get_dim_def, st_ex_return_def] + r.dim = s.dim +Proof + rw[set_weight_def, reind_def, get_dim_def, st_ex_return_def] \\ rw msimps \\ rw[fetch"-""update_adj_mat_def"] \\ rw[ml_monadBaseTheory.Marray_update_def] - \\ rw[ml_monadBaseTheory.Mupdate_eq]); + \\ rw[ml_monadBaseTheory.Mupdate_eq] +QED -Theorem lemma - `∀i j d l. i < d ∧ j < d ∧ d * d ≤ l ⇒ (j:num) + i * d < l` - (rw[] +Theorem lemma: + ∀i j d l. i < d ∧ j < d ∧ d * d ≤ l ⇒ (j:num) + i * d < l +Proof + rw[] \\ qpat_x_assum`i < d` assume_tac \\ `∃m. 0 < m ∧ i + m = d` by ( IMP_RES_THEN (STRIP_THM_THEN SUBST1_TAC) LESS_ADD_1 @@ -194,14 +199,16 @@ Theorem lemma \\ qpat_x_assum`j < d` assume_tac \\ IMP_RES_THEN (STRIP_THM_THEN SUBST1_TAC) LESS_ADD_1 THEN simp[] ) \\ pop_assum mp_tac - \\ simp[]); + \\ simp[] +QED -Theorem init_diag_SUCCESS - `∀d s. d ≤ s.dim ∧ s.dim * s.dim ≤ LENGTH s.adj_mat ⇒ +Theorem init_diag_SUCCESS: + ∀d s. d ≤ s.dim ∧ s.dim * s.dim ≤ LENGTH s.adj_mat ⇒ ∃r. init_diag d s = (Success (), r) ∧ LENGTH r.adj_mat = LENGTH s.adj_mat ∧ - r.dim = s.dim` - (simp[init_diag_def] + r.dim = s.dim +Proof + simp[init_diag_def] \\ qmatch_goalsub_abbrev_tac`st_ex_FOR _ _ f` \\ Q.SPEC_TAC(`0n`,`n`) \\ qunabbrev_tac`f` @@ -221,20 +228,23 @@ Theorem init_diag_SUCCESS \\ first_x_assum(qspecl_then[`SUC d`,`n + 1`]mp_tac) \\ simp[] \\ disch_then(qspec_then`r`mp_tac) - \\ simp[] ); + \\ simp[] +QED val adj_mat_sub_def = fetch "-" "adj_mat_sub_def" -Theorem Msub_eqn[simp] ` - ∀e n ls v. +Theorem Msub_eqn[simp]: + ∀e n ls v. Msub e n ls = if n < LENGTH ls then Success (EL n ls) - else Failure e` - (ho_match_mp_tac Msub_ind>>rw[]>> + else Failure e +Proof + ho_match_mp_tac Msub_ind>>rw[]>> simp[Once Msub_def]>> Cases_on`ls`>>fs[]>> IF_CASES_TAC>>fs[]>> - Cases_on`n`>>fs[]); + Cases_on`n`>>fs[] +QED val adj_mat_sub_SUCCESS = Q.prove(` ∀s. i < s.dim ∧ j < s.dim ∧ @@ -247,18 +257,20 @@ val adj_mat_sub_SUCCESS = Q.prove(` val update_adj_mat_def = fetch "-" "update_adj_mat_def" -Theorem Mupdate_eqn[simp] ` - ∀e x n ls. +Theorem Mupdate_eqn[simp]: + ∀e x n ls. Mupdate e x n ls = if n < LENGTH ls then Success (LUPDATE x n ls) else - Failure e` - (ho_match_mp_tac Mupdate_ind>>rw[]>> + Failure e +Proof + ho_match_mp_tac Mupdate_ind>>rw[]>> simp[Once Mupdate_def]>> Cases_on`ls`>>fs[]>> IF_CASES_TAC>>fs[LUPDATE_def]>> - Cases_on`n`>>fs[LUPDATE_def]); + Cases_on`n`>>fs[LUPDATE_def] +QED val update_adj_mat_SUCCESS = Q.prove(` ∀s. @@ -345,11 +357,12 @@ val floyd_warshall_SUCCESS_k = Q.prove(` first_x_assum(qspecl_then[`res`,`k+1`] assume_tac)>>rfs[]); (* Prove that the algorithm is always successful (?) *) -Theorem do_floyd_SUCCESS ` - EVERY (λ (i,j,w). i < d ∧ j < d) ls ⇒ +Theorem do_floyd_SUCCESS: + EVERY (λ (i,j,w). i < d ∧ j < d) ls ⇒ ∃res. - do_floyd d ls init_g = (Success (),res)` - (rw[]>> + do_floyd d ls init_g = (Success (),res) +Proof + rw[]>> simp[do_floyd_def,init_g_def]>> simp msimps>> TOP_CASE_TAC >> @@ -390,7 +403,8 @@ Theorem do_floyd_SUCCESS ` \\ simp[] \\ simp[floyd_warshall_def] \\ `LENGTH s1.adj_mat = s1.dim * s1.dim` by fs[] - \\ metis_tac[floyd_warshall_SUCCESS_k]); + \\ metis_tac[floyd_warshall_SUCCESS_k] +QED diff --git a/translator/monadic/ml_monadStoreScript.sml b/translator/monadic/ml_monadStoreScript.sml index e9703e8762..43011ab66a 100644 --- a/translator/monadic/ml_monadStoreScript.sml +++ b/translator/monadic/ml_monadStoreScript.sml @@ -16,98 +16,135 @@ val SEP_EXISTS_SEPARATE = save_thm("SEP_EXISTS_SEPARATE", val SEP_EXISTS_INWARD = save_thm("SEP_EXISTS_INWARD", List.nth(SPEC_ALL SEP_CLAUSES |> CONJUNCTS, 1) |> GSYM |> GEN_ALL); -Theorem ALLOCATE_ARRAY_evaluate - `!env s n xname xv. +Theorem ALLOCATE_ARRAY_evaluate: + !env s n xname xv. (nsLookup env.v (Short xname) = SOME xv) ==> eval_rel s env (App Aalloc [Lit (IntLit &n); Var (Short xname)]) (s with refs := s.refs ++ [Varray (REPLICATE n xv)]) - (Loc (LENGTH s.refs))` - (rw[evaluate_def, do_app_def, store_alloc_def, ml_progTheory.eval_rel_def] - \\ rw[state_component_equality]); - -Theorem ALLOCATE_EMPTY_RARRAY_evaluate - `!env s. + (Loc (LENGTH s.refs)) +Proof + rw[evaluate_def, do_app_def, store_alloc_def, ml_progTheory.eval_rel_def] + \\ rw[state_component_equality] +QED + +Theorem ALLOCATE_EMPTY_RARRAY_evaluate: + !env s. eval_rel s env (App Opref [App AallocEmpty [Con NONE []]]) (s with refs := s.refs ++ [Varray []] ++ [Refv (Loc (LENGTH s.refs))]) - (Loc (LENGTH s.refs + 1))` - (rw[evaluate_def, do_app_def, do_opapp_def, do_con_check_def, build_conv_def, - store_alloc_def,state_component_equality, ml_progTheory.eval_rel_def]); - -Theorem LIST_REL_REPLICATE - `!n TYPE x v. TYPE x v ==> LIST_REL TYPE (REPLICATE n x) (REPLICATE n v)` - (rw[] \\ Cases_on `n` - \\ metis_tac[LIST_REL_REPLICATE_same]); - -Theorem GC_INWARDS - `GC * A = A * GC` (SIMP_TAC std_ss [STAR_COMM]); - -Theorem GC_DUPLICATE_0 - `H * GC = H * GC * GC` (rw[GSYM STAR_ASSOC, GC_STAR_GC]); - -Theorem GC_DUPLICATE_1 - `A * (B * GC * C) = A * GC * (B * GC * C)` - (SIMP_TAC std_ss [GSYM STAR_ASSOC, GC_INWARDS, GC_STAR_GC]); - -Theorem GC_DUPLICATE_2 - `A * (B * GC) = A * GC * (B * GC)` - (ASSUME_TAC (Thm.INST [``C : hprop`` |-> ``emp : hprop``] GC_DUPLICATE_1) - \\ FULL_SIMP_TAC std_ss [GSYM STAR_ASSOC, SEP_CLAUSES]) - -Theorem GC_DUPLICATE_3 - `A * GC * B = GC * (A * GC * B)` - (SIMP_TAC std_ss [GSYM STAR_ASSOC, GC_INWARDS, GC_STAR_GC]) - -Theorem store2heap_aux_decompose_store1 - `A (store2heap_aux n a) ==> + (Loc (LENGTH s.refs + 1)) +Proof + rw[evaluate_def, do_app_def, do_opapp_def, do_con_check_def, build_conv_def, + store_alloc_def,state_component_equality, ml_progTheory.eval_rel_def] +QED + +Theorem LIST_REL_REPLICATE: + !n TYPE x v. TYPE x v ==> LIST_REL TYPE (REPLICATE n x) (REPLICATE n v) +Proof + rw[] \\ Cases_on `n` + \\ metis_tac[LIST_REL_REPLICATE_same] +QED + +Theorem GC_INWARDS: + GC * A = A * GC +Proof +SIMP_TAC std_ss [STAR_COMM] +QED + +Theorem GC_DUPLICATE_0: + H * GC = H * GC * GC +Proof +rw[GSYM STAR_ASSOC, GC_STAR_GC] +QED + +Theorem GC_DUPLICATE_1: + A * (B * GC * C) = A * GC * (B * GC * C) +Proof + SIMP_TAC std_ss [GSYM STAR_ASSOC, GC_INWARDS, GC_STAR_GC] +QED + +Theorem GC_DUPLICATE_2: + A * (B * GC) = A * GC * (B * GC) +Proof + ASSUME_TAC (Thm.INST [``C : hprop`` |-> ``emp : hprop``] GC_DUPLICATE_1) + \\ FULL_SIMP_TAC std_ss [GSYM STAR_ASSOC, SEP_CLAUSES] +QED + +Theorem GC_DUPLICATE_3: + A * GC * B = GC * (A * GC * B) +Proof + SIMP_TAC std_ss [GSYM STAR_ASSOC, GC_INWARDS, GC_STAR_GC] +QED + +Theorem store2heap_aux_decompose_store1: + A (store2heap_aux n a) ==> B (store2heap_aux (n + LENGTH a) b) ==> - (A * B) (store2heap_aux n (a ++ b))` - (rw[STAR_def, SPLIT_def] + (A * B) (store2heap_aux n (a ++ b)) +Proof + rw[STAR_def, SPLIT_def] \\ instantiate \\ rw[Once UNION_COMM] >- fs[store2heap_aux_append_many] - \\ fs[store2heap_aux_DISJOINT]); + \\ fs[store2heap_aux_DISJOINT] +QED -Theorem store2heap_aux_decompose_store2 - `A (store2heap_aux n [a]) ==> +Theorem store2heap_aux_decompose_store2: + A (store2heap_aux n [a]) ==> B (store2heap_aux (n + 1) b) ==> - (A * B) (store2heap_aux n (a::b))` - (rw[] + (A * B) (store2heap_aux n (a::b)) +Proof + rw[] \\ `a::b = [a]++b` by fs[] \\ POP_ASSUM(fn x => PURE_ONCE_REWRITE_TAC[x]) \\ irule store2heap_aux_decompose_store1 - \\ fs[]); - -Theorem cons_to_append `a::b::c = [a; b]++c` (fs[]); - -Theorem append_empty `a = a ++ []` (fs[]); - -Theorem H_STAR_GC_SAT_IMP - `H s ==> (H * GC) s` - (rw[STAR_def] + \\ fs[] +QED + +Theorem cons_to_append: + a::b::c = [a; b]++c +Proof +fs[] +QED + +Theorem append_empty: + a = a ++ [] +Proof +fs[] +QED + +Theorem H_STAR_GC_SAT_IMP: + H s ==> (H * GC) s +Proof + rw[STAR_def] \\ qexists_tac `s` \\ qexists_tac `{}` - \\ rw[SPLIT_emp2, SAT_GC]); - -Theorem store2heap_REF_SAT - `((Loc l) ~~> v) (store2heap_aux l [Refv v])` - (fs[store2heap_aux_def] - >> fs[REF_def, SEP_EXISTS_THM, HCOND_EXTRACT, cell_def, one_def]); - -Theorem store2heap_eliminate_ffi_thm - `H (store2heap s.refs) ==> (GC * H) (st2heap (p:'ffi ffi_proj) s)` - (rw[] + \\ rw[SPLIT_emp2, SAT_GC] +QED + +Theorem store2heap_REF_SAT: + ((Loc l) ~~> v) (store2heap_aux l [Refv v]) +Proof + fs[store2heap_aux_def] + >> fs[REF_def, SEP_EXISTS_THM, HCOND_EXTRACT, cell_def, one_def] +QED + +Theorem store2heap_eliminate_ffi_thm: + H (store2heap s.refs) ==> (GC * H) (st2heap (p:'ffi ffi_proj) s) +Proof + rw[] \\ Cases_on `p` \\ fs[st2heap_def, STAR_def] \\ qexists_tac `ffi2heap (q, r) s.ffi` \\ qexists_tac `store2heap s.refs` \\ fs[SAT_GC] \\ PURE_ONCE_REWRITE_TAC[SPLIT_SYM] - \\ fs[st2heap_SPLIT_FFI]); - -Theorem rarray_exact_thm - `((l = l' + 1) /\ (n = l')) ==> - RARRAY (Loc l) av (store2heap_aux n [Varray av; Refv (Loc l')])` - (rw[] + \\ fs[st2heap_SPLIT_FFI] +QED + +Theorem rarray_exact_thm: + ((l = l' + 1) /\ (n = l')) ==> + RARRAY (Loc l) av (store2heap_aux n [Varray av; Refv (Loc l')]) +Proof + rw[] \\ rw[RARRAY_def] \\ rw[SEP_EXISTS_THM] \\ qexists_tac `Loc l'` @@ -117,49 +154,64 @@ Theorem rarray_exact_thm \\ irule store2heap_aux_decompose_store1 \\ conj_tac >-(rw[ARRAY_def, SEP_EXISTS_THM, HCOND_EXTRACT, cell_def, one_def, store2heap_aux_def]) - \\ rw[REF_def, SEP_EXISTS_THM, HCOND_EXTRACT, cell_def, one_def, store2heap_aux_def]); - -Theorem farray_exact_thm - `(n = l) ==> - ARRAY (Loc l) av (store2heap_aux n [Varray av])` - (rw[ARRAY_def, SEP_EXISTS_THM, HCOND_EXTRACT, cell_def, one_def, store2heap_aux_def]); - -Theorem eliminate_inherited_references_thm - `!a b. H (store2heap_aux (LENGTH a) b) ==> - (GC * H) (store2heap_aux 0 (a++b))` - (rw[] + \\ rw[REF_def, SEP_EXISTS_THM, HCOND_EXTRACT, cell_def, one_def, store2heap_aux_def] +QED + +Theorem farray_exact_thm: + (n = l) ==> + ARRAY (Loc l) av (store2heap_aux n [Varray av]) +Proof + rw[ARRAY_def, SEP_EXISTS_THM, HCOND_EXTRACT, cell_def, one_def, store2heap_aux_def] +QED + +Theorem eliminate_inherited_references_thm: + !a b. H (store2heap_aux (LENGTH a) b) ==> + (GC * H) (store2heap_aux 0 (a++b)) +Proof + rw[] \\ fs[STAR_def] \\ instantiate \\ qexists_tac `store2heap_aux 0 a` \\ fs[SPEC_ALL store2heap_aux_SPLIT |> Thm.INST [``n:num`` |-> ``0:num``] - |> SIMP_RULE arith_ss [], SAT_GC]); - -Theorem eliminate_substore_thm - `(H1 * GC * H2) (store2heap_aux (n + LENGTH a) b) ==> - (H1 * GC * H2) (store2heap_aux n (a++b))` - (rw[] + |> SIMP_RULE arith_ss [], SAT_GC] +QED + +Theorem eliminate_substore_thm: + (H1 * GC * H2) (store2heap_aux (n + LENGTH a) b) ==> + (H1 * GC * H2) (store2heap_aux n (a++b)) +Proof + rw[] \\ PURE_ONCE_REWRITE_TAC[GC_DUPLICATE_3] \\ rw[Once STAR_def] \\ qexists_tac `store2heap_aux n a` \\ qexists_tac `store2heap_aux (n + LENGTH a) b` - \\ simp[SAT_GC, store2heap_aux_SPLIT]); - -Theorem eliminate_store_elem_thm - `(H1 * GC * H2) (store2heap_aux (n + 1) b) ==> - (H1 * GC * H2) (store2heap_aux n (a::b))` - (rw[] + \\ simp[SAT_GC, store2heap_aux_SPLIT] +QED + +Theorem eliminate_store_elem_thm: + (H1 * GC * H2) (store2heap_aux (n + 1) b) ==> + (H1 * GC * H2) (store2heap_aux n (a::b)) +Proof + rw[] \\ PURE_ONCE_REWRITE_TAC[GC_DUPLICATE_3] \\ rw[Once STAR_def] \\ PURE_ONCE_REWRITE_TAC[CONS_APPEND] \\ qexists_tac `store2heap_aux n [a]` \\ qexists_tac `store2heap_aux (n + (LENGTH [a])) b` - \\ simp[SAT_GC, store2heap_aux_SPLIT]); - -Theorem H_STAR_empty -`H * emp = H` (rw[SEP_CLAUSES]); - -Theorem H_STAR_TRUE -`(H * &T = H) /\ (&T * H = H)` (fs[SEP_CLAUSES]); + \\ simp[SAT_GC, store2heap_aux_SPLIT] +QED + +Theorem H_STAR_empty: + H * emp = H +Proof +rw[SEP_CLAUSES] +QED + +Theorem H_STAR_TRUE: + (H * &T = H) /\ (&T * H = H) +Proof +fs[SEP_CLAUSES] +QED (* Information about the subscript exceptions *) val Conv_Subscript = EVAL ``sub_exn_v`` |> concl |> rand diff --git a/translator/monadic/ml_monad_translatorBaseScript.sml b/translator/monadic/ml_monad_translatorBaseScript.sml index fefcae2f39..85878ab5e8 100644 --- a/translator/monadic/ml_monad_translatorBaseScript.sml +++ b/translator/monadic/ml_monad_translatorBaseScript.sml @@ -23,17 +23,23 @@ val clear_first_assum = POP_ASSUM (fn x => ALL_TAC) val _ = temp_type_abbrev("state",``:'ffi semanticPrimitives$state``); (* a few basics *) -Theorem with_same_refs - `(s with refs := s.refs) = s` - (simp[state_component_equality]) - -Theorem with_same_ffi - `(s with ffi := s.ffi) = s` - (simp[state_component_equality]); - -Theorem with_same_clock - `(s with clock := s.clock) = s` - (simp[state_component_equality]); +Theorem with_same_refs: + (s with refs := s.refs) = s +Proof + simp[state_component_equality] +QED + +Theorem with_same_ffi: + (s with ffi := s.ffi) = s +Proof + simp[state_component_equality] +QED + +Theorem with_same_clock: + (s with clock := s.clock) = s +Proof + simp[state_component_equality] +QED (* REF_REL *) val REF_REL_def = Define `REF_REL TYPE r x = SEP_EXISTS v. REF r v * &TYPE x v`; @@ -54,79 +60,96 @@ val REFS_PRED_FRAME_def = Define ` (ro ==> ?refs. s2 = s1 with refs := refs) /\ !F. (h refs1 * F) (st2heap p s1) ==> (h refs2 * F * GC) (st2heap p s2)`; -Theorem EMP_STAR_GC - `!H. emp * H = H` - (fs[STAR_def, emp_def, SPLIT_def, ETA_THM]); +Theorem EMP_STAR_GC: + !H. emp * H = H +Proof + fs[STAR_def, emp_def, SPLIT_def, ETA_THM] +QED -Theorem SAT_GC - `!h. GC h` - (fs[GC_def, SEP_EXISTS_THM] \\ STRIP_TAC \\ qexists_tac `\s. T` \\ fs[]); +Theorem SAT_GC: + !h. GC h +Proof + fs[GC_def, SEP_EXISTS_THM] \\ STRIP_TAC \\ qexists_tac `\s. T` \\ fs[] +QED -Theorem REFS_PRED_FRAME_imp - `!refs1 s1 H refs2 s2. +Theorem REFS_PRED_FRAME_imp: + !refs1 s1 H refs2 s2. REFS_PRED ^H refs1 s1 ==> - REFS_PRED_FRAME ro H (refs1, s1) (refs2, s2) ==> REFS_PRED H refs2 s2` - (rw[] + REFS_PRED_FRAME ro H (refs1, s1) (refs2, s2) ==> REFS_PRED H refs2 s2 +Proof + rw[] \\ PairCases_on `H` \\ fs[REFS_PRED_def, REFS_PRED_FRAME_def] \\ fs[st2heap_def] - \\ metis_tac[GC_STAR_GC, STAR_ASSOC]); + \\ metis_tac[GC_STAR_GC, STAR_ASSOC] +QED -Theorem REFS_PRED_FRAME_trans - `REFS_PRED_FRAME ro ^H (refs1, s1) (refs2, s2) ==> +Theorem REFS_PRED_FRAME_trans: + REFS_PRED_FRAME ro ^H (refs1, s1) (refs2, s2) ==> REFS_PRED_FRAME ro H (refs2, s2) (refs3, s3) ==> - REFS_PRED_FRAME ro H (refs1, s1) (refs3, s3)` - (Cases_on `H` >> + REFS_PRED_FRAME ro H (refs1, s1) (refs3, s3) +Proof + Cases_on `H` >> rw[REFS_PRED_FRAME_def] THEN1 (fs [] \\ metis_tac []) >> PURE_REWRITE_TAC[Once (GSYM GC_STAR_GC), STAR_ASSOC] >> `q refs3 * F' * GC * GC = q refs3 * (F' * GC) * GC` by fs[STAR_ASSOC] >> POP_ASSUM (fn x => PURE_REWRITE_TAC[x]) >> first_x_assum irule >> - fs[STAR_ASSOC]); + fs[STAR_ASSOC] +QED -Theorem H_STAR_GC_SAT_IMP - `H s ==> (H * GC) s` - (rw[STAR_def] +Theorem H_STAR_GC_SAT_IMP: + H s ==> (H * GC) s +Proof + rw[STAR_def] \\ qexists_tac `s` \\ qexists_tac `{}` - \\ rw[SPLIT_emp2, SAT_GC]); + \\ rw[SPLIT_emp2, SAT_GC] +QED -Theorem REFS_PRED_FRAME_same - `!H st s. REFS_PRED_FRAME ro H (st,s) (st,s)` - (Cases_on `H` +Theorem REFS_PRED_FRAME_same: + !H st s. REFS_PRED_FRAME ro H (st,s) (st,s) +Proof + Cases_on `H` \\ rw[REFS_PRED_FRAME_def] >-(fs[state_component_equality]) \\ irule H_STAR_GC_SAT_IMP - \\ fs[]); + \\ fs[] +QED (* * Proof of REFS_PRED_APPEND: * `REFS_PRED H refs s ==> REFS_PRED H refs (s with refs := s.refs ++ junk)` *) -Theorem store2heap_aux_Mem - `!s n x. x IN (store2heap_aux n s) ==> ?n' v. x = Mem n' v` - (Induct_on `s` +Theorem store2heap_aux_Mem: + !s n x. x IN (store2heap_aux n s) ==> ?n' v. x = Mem n' v +Proof + Induct_on `s` >-(rw[IN_DEF, store2heap_def, store2heap_aux_def]) >> rw[] >> fs[IN_DEF, store2heap_def, store2heap_aux_def] >> last_x_assum IMP_RES_TAC >> - fs[]); + fs[] +QED -Theorem store2heap_aux_IN_LENGTH - `!s r x n. Mem r x IN (store2heap_aux n s) ==> r < n + LENGTH s` - (Induct THENL [all_tac, Cases] \\ +Theorem store2heap_aux_IN_LENGTH: + !s r x n. Mem r x IN (store2heap_aux n s) ==> r < n + LENGTH s +Proof + Induct THENL [all_tac, Cases] \\ fs [store2heap_aux_def] \\ Cases_on `r` \\ fs [] \\ rewrite_tac [ONE] \\ rpt strip_tac \\ fs[ADD_CLAUSES, GSYM store2heap_aux_suc] \\ - metis_tac[]); + metis_tac[] +QED val NEG_DISJ_TO_IMP = Q.prove( `!A B. ~A \/ ~B <=> A /\ B ==> F`, rw[]); -Theorem store2heap_aux_DISJOINT - `!n s1 s2. DISJOINT (store2heap_aux n s1) (store2heap_aux (n + LENGTH s1) s2)` - (rw[DISJOINT_DEF, INTER_DEF, EMPTY_DEF] >> +Theorem store2heap_aux_DISJOINT: + !n s1 s2. DISJOINT (store2heap_aux n s1) (store2heap_aux (n + LENGTH s1) s2) +Proof + rw[DISJOINT_DEF, INTER_DEF, EMPTY_DEF] >> fs[GSPECIFICATION_applied] >> `!x. {x | x ∈ store2heap_aux n s1 ∧ x ∈ store2heap_aux (n + LENGTH s1) s2} x = (\x. F) x` by @@ -138,17 +161,22 @@ Theorem store2heap_aux_DISJOINT IMP_RES_TAC store2heap_aux_IN_bound >> IMP_RES_TAC store2heap_aux_IN_LENGTH >> bossLib.DECIDE_TAC) >> - POP_ASSUM (fn x => ASSUME_TAC (EXT x)) >> fs[]); - -Theorem store2heap_aux_SPLIT - `!s1 s2 n. SPLIT (store2heap_aux n (s1 ++ s2)) - (store2heap_aux n s1, store2heap_aux (n + LENGTH s1) s2)` - (fs[SPLIT_def] >> fs[store2heap_aux_append_many] >> - metis_tac[UNION_COMM, store2heap_aux_append_many, store2heap_aux_DISJOINT]); - -Theorem store2heap_DISJOINT - `DISJOINT (store2heap s1) (store2heap_aux (LENGTH s1) s2)` - (fs[store2heap_def] >> metis_tac[store2heap_aux_DISJOINT, arithmeticTheory.ADD]); + POP_ASSUM (fn x => ASSUME_TAC (EXT x)) >> fs[] +QED + +Theorem store2heap_aux_SPLIT: + !s1 s2 n. SPLIT (store2heap_aux n (s1 ++ s2)) + (store2heap_aux n s1, store2heap_aux (n + LENGTH s1) s2) +Proof + fs[SPLIT_def] >> fs[store2heap_aux_append_many] >> + metis_tac[UNION_COMM, store2heap_aux_append_many, store2heap_aux_DISJOINT] +QED + +Theorem store2heap_DISJOINT: + DISJOINT (store2heap s1) (store2heap_aux (LENGTH s1) s2) +Proof + fs[store2heap_def] >> metis_tac[store2heap_aux_DISJOINT, arithmeticTheory.ADD] +QED (* If the goal is: (\x. P x) = (\x. Q x), applies SUFF_TAC ``!x. P x = Q x`` *) fun SUFF_ABS_TAC (g as (asl, w)) = @@ -162,31 +190,38 @@ fun SUFF_ABS_TAC (g as (asl, w)) = (SUFF_TAC w' THEN rw[]) g end; -Theorem store2heap_SPLIT - `!s1 s2. SPLIT (store2heap (s1 ++ s2)) - (store2heap s1, store2heap_aux (LENGTH s1) s2)` - (fs[store2heap_def] >> metis_tac[store2heap_aux_SPLIT, arithmeticTheory.ADD]); - -Theorem SPLIT_DECOMPOSWAP - `SPLIT s1 (s2, s3) ==> SPLIT s2 (u, v) ==> SPLIT s1 (u, v UNION s3)` - (fs[SPLIT_def, UNION_ASSOC, DISJOINT_SYM] >> rw[] >> - fs[DISJOINT_SYM, DISJOINT_UNION_BOTH]); - -Theorem STORE_APPEND_JUNK - `!H s junk. H (store2heap s) ==> (H * GC) (store2heap (s ++ junk))` - (rw[] >> +Theorem store2heap_SPLIT: + !s1 s2. SPLIT (store2heap (s1 ++ s2)) + (store2heap s1, store2heap_aux (LENGTH s1) s2) +Proof + fs[store2heap_def] >> metis_tac[store2heap_aux_SPLIT, arithmeticTheory.ADD] +QED + +Theorem SPLIT_DECOMPOSWAP: + SPLIT s1 (s2, s3) ==> SPLIT s2 (u, v) ==> SPLIT s1 (u, v UNION s3) +Proof + fs[SPLIT_def, UNION_ASSOC, DISJOINT_SYM] >> rw[] >> + fs[DISJOINT_SYM, DISJOINT_UNION_BOTH] +QED + +Theorem STORE_APPEND_JUNK: + !H s junk. H (store2heap s) ==> (H * GC) (store2heap (s ++ junk)) +Proof + rw[] >> qspecl_then [`s`, `junk`] ASSUME_TAC store2heap_SPLIT >> fs[STAR_def] >> qexists_tac `store2heap s` >> qexists_tac `store2heap_aux (LENGTH s) junk` >> `!H. GC H` by (rw[cfHeapsBaseTheory.GC_def, SEP_EXISTS] >> qexists_tac `\x. T` >> fs[]) >> - POP_ASSUM (fn x => fs[x])); - -Theorem st2heap_SPLIT_FFI - `!f st. SPLIT ((store2heap st.refs) UNION (ffi2heap f st.ffi)) - (store2heap st.refs, ffi2heap f st.ffi)` - (rw[SPLIT_def] + POP_ASSUM (fn x => fs[x]) +QED + +Theorem st2heap_SPLIT_FFI: + !f st. SPLIT ((store2heap st.refs) UNION (ffi2heap f st.ffi)) + (store2heap st.refs, ffi2heap f st.ffi) +Proof + rw[SPLIT_def] \\ fs[IN_DISJOINT] \\ STRIP_TAC \\ PURE_REWRITE_TAC[NEG_DISJ_TO_IMP] @@ -195,28 +230,38 @@ Theorem st2heap_SPLIT_FFI \\ fs[store2heap_def] \\ Cases_on `x` \\ fs[Mem_NOT_IN_ffi2heap, FFI_split_NOT_IN_store2heap_aux, - FFI_full_NOT_IN_store2heap_aux, FFI_part_NOT_IN_store2heap_aux]); - -Theorem SPLIT3_swap12 - `!h h1 h2 h3. SPLIT3 h (h1, h2, h3) = SPLIT3 h (h2, h1, h3)` - (rw[SPLIT3_def, UNION_COMM, CONJ_COMM] >> metis_tac[DISJOINT_SYM]); - -Theorem SPLIT_of_SPLIT3_1u3 - `∀h h1 h2 h3. SPLIT3 h (h1,h2,h3) ⇒ SPLIT h (h2, h1 ∪ h3)` - (metis_tac[SPLIT3_swap12, SPLIT_of_SPLIT3_2u3]); - -Theorem SPLIT2_SPLIT3 - `SPLIT s1 (s2, t3) /\ SPLIT s2 (t1, t2) ==> SPLIT3 s1 (t1, t2, t3)` - (rw[SPLIT_def] \\ fs[SPLIT3_def]); - -Theorem SPLIT_SYM - `SPLIT s (s1, s2) = SPLIT s (s2, s1)` - (fs[SPLIT_def, DISJOINT_SYM, UNION_COMM]); - -Theorem STATE_APPEND_JUNK - `!H p s refs junk. H (st2heap p (s with refs := refs)) ==> - (H * GC) (st2heap p (s with refs := refs ++ junk))` - (rw[] + FFI_full_NOT_IN_store2heap_aux, FFI_part_NOT_IN_store2heap_aux] +QED + +Theorem SPLIT3_swap12: + !h h1 h2 h3. SPLIT3 h (h1, h2, h3) = SPLIT3 h (h2, h1, h3) +Proof + rw[SPLIT3_def, UNION_COMM, CONJ_COMM] >> metis_tac[DISJOINT_SYM] +QED + +Theorem SPLIT_of_SPLIT3_1u3: + ∀h h1 h2 h3. SPLIT3 h (h1,h2,h3) ⇒ SPLIT h (h2, h1 ∪ h3) +Proof + metis_tac[SPLIT3_swap12, SPLIT_of_SPLIT3_2u3] +QED + +Theorem SPLIT2_SPLIT3: + SPLIT s1 (s2, t3) /\ SPLIT s2 (t1, t2) ==> SPLIT3 s1 (t1, t2, t3) +Proof + rw[SPLIT_def] \\ fs[SPLIT3_def] +QED + +Theorem SPLIT_SYM: + SPLIT s (s1, s2) = SPLIT s (s2, s1) +Proof + fs[SPLIT_def, DISJOINT_SYM, UNION_COMM] +QED + +Theorem STATE_APPEND_JUNK: + !H p s refs junk. H (st2heap p (s with refs := refs)) ==> + (H * GC) (st2heap p (s with refs := refs ++ junk)) +Proof + rw[] \\ Cases_on `p` \\ fs[st2heap_def] \\ Q.PAT_ABBREV_TAC `h = A UNION B` @@ -236,12 +281,14 @@ Theorem STATE_APPEND_JUNK \\ POP_ASSUM(fn x => MATCH_MP SPLIT_of_SPLIT3_1u3 x |> ASSUME_TAC) \\ fs[Once SPLIT_SYM] \\ rw[STAR_def] - \\ metis_tac[SAT_GC]); - -Theorem STATE_SPLIT_REFS - `!a b p s. SPLIT (st2heap p (s with refs := a ++ b)) - ((st2heap p (s with refs := a)), (store2heap_aux (LENGTH a) b))` - (rw[] \\ Cases_on `p` \\ fs[st2heap_def] \\ + \\ metis_tac[SAT_GC] +QED + +Theorem STATE_SPLIT_REFS: + !a b p s. SPLIT (st2heap p (s with refs := a ++ b)) + ((st2heap p (s with refs := a)), (store2heap_aux (LENGTH a) b)) +Proof + rw[] \\ Cases_on `p` \\ fs[st2heap_def] \\ sg `SPLIT3 (store2heap (a ++ b) ∪ ffi2heap (q,r) s.ffi) (store2heap a, store2heap_aux (LENGTH a) b, ffi2heap (q,r) s.ffi)` >-( @@ -255,84 +302,108 @@ Theorem STATE_SPLIT_REFS FFI_full_NOT_IN_store2heap_aux, FFI_part_NOT_IN_store2heap_aux]) \\ POP_ASSUM(fn x => MATCH_MP SPLIT_of_SPLIT3_1u3 x |> ASSUME_TAC) \\ fs[Once SPLIT_SYM] - \\ rw[STAR_def]); + \\ rw[STAR_def] +QED -Theorem REFS_PRED_append - `!H refs s. REFS_PRED H refs s ==> - REFS_PRED ^H refs (s with refs := s.refs ++ junk)` - (Cases >> +Theorem REFS_PRED_append: + !H refs s. REFS_PRED H refs s ==> + REFS_PRED ^H refs (s with refs := s.refs ++ junk) +Proof + Cases >> rw[REFS_PRED_def] >> PURE_ONCE_REWRITE_TAC [GSYM GC_STAR_GC] >> fs[STAR_ASSOC] >> - metis_tac[with_same_refs, STATE_APPEND_JUNK]); + metis_tac[with_same_refs, STATE_APPEND_JUNK] +QED -Theorem REFS_PRED_qappend - `∀H refs s. +Theorem REFS_PRED_qappend: + ∀H refs s. REFS_PRED H refs s ⇒ !junk. - REFS_PRED H refs (s with refs := s.refs ⧺ junk)` - (fs[REFS_PRED_append]); - -Theorem REFS_PRED_FRAME_append - `!H refs s. REFS_PRED_FRAME ro ^H (refs, s) (refs, s with refs := s.refs ++ junk)` - (Cases >> - rw[REFS_PRED_FRAME_def] \\ metis_tac[with_same_refs, STATE_APPEND_JUNK]); + REFS_PRED H refs (s with refs := s.refs ⧺ junk) +Proof + fs[REFS_PRED_append] +QED + +Theorem REFS_PRED_FRAME_append: + !H refs s. REFS_PRED_FRAME ro ^H (refs, s) (refs, s with refs := s.refs ++ junk) +Proof + Cases >> + rw[REFS_PRED_FRAME_def] \\ metis_tac[with_same_refs, STATE_APPEND_JUNK] +QED (* * Proof of STORE_EXTRACT_FROM_HPROP: * `!l xv H s. (REF (Loc l) xv * H) (store2heap s) ==> ?ps. ((ps ++ [Refv xv]) ≼ s) /\ LENGTH ps = l` *) -Theorem HEAP_LOC_MEM - `(l ~~>> rv * H) h ==> Mem l rv IN h` - (rw[STAR_def, SEP_EXISTS_THM, cond_def, cell_def, one_def, SPLIT_def] - \\ rw[IN_UNION]); - -Theorem st2heap_CELL_MEM - `(l ~~>> rv * H) (st2heap p s) ==> Mem l rv IN (store2heap s.refs)` - (Cases_on `p` \\ rw[st2heap_def] \\ IMP_RES_TAC HEAP_LOC_MEM +Theorem HEAP_LOC_MEM: + (l ~~>> rv * H) h ==> Mem l rv IN h +Proof + rw[STAR_def, SEP_EXISTS_THM, cond_def, cell_def, one_def, SPLIT_def] + \\ rw[IN_UNION] +QED + +Theorem st2heap_CELL_MEM: + (l ~~>> rv * H) (st2heap p s) ==> Mem l rv IN (store2heap s.refs) +Proof + Cases_on `p` \\ rw[st2heap_def] \\ IMP_RES_TAC HEAP_LOC_MEM \\ fs[IN_UNION] - \\ fs[Mem_NOT_IN_ffi2heap]); + \\ fs[Mem_NOT_IN_ffi2heap] +QED -Theorem st2heap_REF_MEM - `(Loc l ~~> xv * H) (st2heap p s) ==> Mem l (Refv xv) IN (store2heap s.refs)` - (rw[REF_def, SEP_CLAUSES, SEP_EXISTS_THM] >> +Theorem st2heap_REF_MEM: + (Loc l ~~> xv * H) (st2heap p s) ==> Mem l (Refv xv) IN (store2heap s.refs) +Proof + rw[REF_def, SEP_CLAUSES, SEP_EXISTS_THM] >> fs[GSYM STAR_ASSOC, HCOND_EXTRACT] >> - metis_tac[st2heap_CELL_MEM]); + metis_tac[st2heap_CELL_MEM] +QED -Theorem st2heap_ARRAY_MEM - `(ARRAY (Loc l) av * H) (st2heap p s) ==> Mem l (Varray av) IN (store2heap s.refs)` - (rw[ARRAY_def, SEP_CLAUSES, SEP_EXISTS_THM] >> +Theorem st2heap_ARRAY_MEM: + (ARRAY (Loc l) av * H) (st2heap p s) ==> Mem l (Varray av) IN (store2heap s.refs) +Proof + rw[ARRAY_def, SEP_CLAUSES, SEP_EXISTS_THM] >> fs[GSYM STAR_ASSOC, HCOND_EXTRACT] >> - metis_tac[st2heap_CELL_MEM]); - -Theorem store2heap_aux_LOC_MEM - `!l rv H n s. (l ~~>> rv * H) (store2heap_aux n s) ==> - Mem l rv IN (store2heap_aux n s)` - (rw[] \\ IMP_RES_TAC HEAP_LOC_MEM); - -Theorem store2heap_LOC_MEM - `!l rv H s. (l ~~>> rv * H) (store2heap s) ==> Mem l rv IN (store2heap s)` - (rw[] \\ IMP_RES_TAC HEAP_LOC_MEM); - -Theorem isPREFIX_TAKE - `!l s. isPREFIX (TAKE l s) s` - (rw[] >> + metis_tac[st2heap_CELL_MEM] +QED + +Theorem store2heap_aux_LOC_MEM: + !l rv H n s. (l ~~>> rv * H) (store2heap_aux n s) ==> + Mem l rv IN (store2heap_aux n s) +Proof + rw[] \\ IMP_RES_TAC HEAP_LOC_MEM +QED + +Theorem store2heap_LOC_MEM: + !l rv H s. (l ~~>> rv * H) (store2heap s) ==> Mem l rv IN (store2heap s) +Proof + rw[] \\ IMP_RES_TAC HEAP_LOC_MEM +QED + +Theorem isPREFIX_TAKE: + !l s. isPREFIX (TAKE l s) s +Proof + rw[] >> `isPREFIX (TAKE l s) (TAKE l s ++ DROP l s)` by fs[TAKE_DROP] >> - metis_tac[TAKE_DROP]); + metis_tac[TAKE_DROP] +QED -Theorem isPREFIX_APPEND_EQ - `!a1 a2 b1 b2. +Theorem isPREFIX_APPEND_EQ: + !a1 a2 b1 b2. LENGTH a1 = LENGTH a2 ==> - (isPREFIX (a1 ++ b1) (a2 ++ b2) <=> a2 = a1 /\ isPREFIX b1 b2)` - (Induct_on `a1` >- fs[LENGTH_NIL_SYM] >> + (isPREFIX (a1 ++ b1) (a2 ++ b2) <=> a2 = a1 /\ isPREFIX b1 b2) +Proof + Induct_on `a1` >- fs[LENGTH_NIL_SYM] >> rw[] >> Cases_on `a2` >- fs[] >> - fs[] >> metis_tac[]); + fs[] >> metis_tac[] +QED -Theorem STATE_DECOMPOS_FROM_HPROP - `!l rv H p s. (l ~~>> rv * H) (st2heap p s) ==> - ?ps. ((ps ++ [rv]) ≼ s.refs) /\ LENGTH ps = l` - (rw[] >> +Theorem STATE_DECOMPOS_FROM_HPROP: + !l rv H p s. (l ~~>> rv * H) (st2heap p s) ==> + ?ps. ((ps ++ [rv]) ≼ s.refs) /\ LENGTH ps = l +Proof + rw[] >> IMP_RES_TAC st2heap_CELL_MEM >> IMP_RES_TAC store2heap_IN_EL >> qexists_tac `TAKE l s.refs` >> @@ -348,28 +419,34 @@ Theorem STATE_DECOMPOS_FROM_HPROP ) >> irule FALSITY >> IMP_RES_TAC store2heap_IN_LENGTH >> - fs[]); - -Theorem STATE_DECOMPOS_FROM_HPROP_REF - `!l xv H p s. (REF (Loc l) xv * H) (st2heap p s) ==> - ?ps. ((ps ++ [Refv xv]) ≼ s.refs) /\ LENGTH ps = l` - (rw[REF_def, SEP_CLAUSES, SEP_EXISTS_THM] >> + fs[] +QED + +Theorem STATE_DECOMPOS_FROM_HPROP_REF: + !l xv H p s. (REF (Loc l) xv * H) (st2heap p s) ==> + ?ps. ((ps ++ [Refv xv]) ≼ s.refs) /\ LENGTH ps = l +Proof + rw[REF_def, SEP_CLAUSES, SEP_EXISTS_THM] >> fs[GSYM STAR_ASSOC, HCOND_EXTRACT] >> irule STATE_DECOMPOS_FROM_HPROP >> - instantiate); - -Theorem STATE_DECOMPOS_FROM_HPROP_ARRAY - `!l av H p s. (ARRAY (Loc l) av * H) (st2heap p s) ==> - ?ps. ((ps ++ [Varray av]) ≼ s.refs) /\ LENGTH ps = l` - (rw[ARRAY_def, SEP_CLAUSES, SEP_EXISTS_THM] >> + instantiate +QED + +Theorem STATE_DECOMPOS_FROM_HPROP_ARRAY: + !l av H p s. (ARRAY (Loc l) av * H) (st2heap p s) ==> + ?ps. ((ps ++ [Varray av]) ≼ s.refs) /\ LENGTH ps = l +Proof + rw[ARRAY_def, SEP_CLAUSES, SEP_EXISTS_THM] >> fs[GSYM STAR_ASSOC, HCOND_EXTRACT] >> irule STATE_DECOMPOS_FROM_HPROP >> - instantiate); + instantiate +QED -Theorem STATE_EXTRACT_FROM_HPROP - `!l rv H p s. (l ~~>> rv * H) (st2heap p s) ==> - !junk. EL l (s.refs ++ junk) = rv` - (rw[] >> +Theorem STATE_EXTRACT_FROM_HPROP: + !l rv H p s. (l ~~>> rv * H) (st2heap p s) ==> + !junk. EL l (s.refs ++ junk) = rv +Proof + rw[] >> IMP_RES_TAC STATE_DECOMPOS_FROM_HPROP >> fs[IS_PREFIX_APPEND] >> first_x_assum(fn x => CONV_RULE @@ -377,29 +454,35 @@ Theorem STATE_EXTRACT_FROM_HPROP `~NULL ([rv] ++ (l' ++ junk))` by fs[NULL_EQ] >> IMP_RES_TAC EL_LENGTH_APPEND >> fs[HD] >> - metis_tac[]); - -Theorem STATE_EXTRACT_FROM_HPROP_REF - `!l xv H p s. ((Loc l) ~~> xv * H) (st2heap p s) ==> - !junk. EL l (s.refs ++ junk) = Refv xv` - (rw[REF_def, ARRAY_def, SEP_CLAUSES, SEP_EXISTS_THM] >> + metis_tac[] +QED + +Theorem STATE_EXTRACT_FROM_HPROP_REF: + !l xv H p s. ((Loc l) ~~> xv * H) (st2heap p s) ==> + !junk. EL l (s.refs ++ junk) = Refv xv +Proof + rw[REF_def, ARRAY_def, SEP_CLAUSES, SEP_EXISTS_THM] >> fs[GSYM STAR_ASSOC, HCOND_EXTRACT] >> irule STATE_EXTRACT_FROM_HPROP >> - instantiate); - -Theorem STATE_EXTRACT_FROM_HPROP_ARRAY - `!l av H p s. (ARRAY (Loc l) av * H) (st2heap p s) ==> - !junk. EL l (s.refs ++ junk) = Varray av` - (rw[REF_def, ARRAY_def, SEP_CLAUSES, SEP_EXISTS_THM] >> + instantiate +QED + +Theorem STATE_EXTRACT_FROM_HPROP_ARRAY: + !l av H p s. (ARRAY (Loc l) av * H) (st2heap p s) ==> + !junk. EL l (s.refs ++ junk) = Varray av +Proof + rw[REF_def, ARRAY_def, SEP_CLAUSES, SEP_EXISTS_THM] >> fs[GSYM STAR_ASSOC, HCOND_EXTRACT] >> irule STATE_EXTRACT_FROM_HPROP >> - instantiate); + instantiate +QED -Theorem SEPARATE_STORE_ELEM_IN_HEAP - `!s0 x s1. SPLIT3 (store2heap (s0 ++ [x] ++ s1)) +Theorem SEPARATE_STORE_ELEM_IN_HEAP: + !s0 x s1. SPLIT3 (store2heap (s0 ++ [x] ++ s1)) (store2heap s0, {Mem (LENGTH s0) x}, - store2heap_aux (LENGTH s0 + 1) s1)` - (sg `!(s0 : v store) s1 x. + store2heap_aux (LENGTH s0 + 1) s1) +Proof + sg `!(s0 : v store) s1 x. SPLIT (store2heap_aux (LENGTH s0) (x::s1)) ({Mem (LENGTH s0) x}, store2heap_aux (LENGTH s0 + 1) s1)` >-( @@ -416,39 +499,51 @@ Theorem SEPARATE_STORE_ELEM_IN_HEAP rw[] >-(metis_tac[UNION_ASSOC, EQ_REFL]) >-(DISCH_TAC >> IMP_RES_TAC store2heap_IN_LENGTH >> fs[]) >> - metis_tac[DISJOINT_UNION_BOTH, EQ_REFL]); - -Theorem CELL_HPROP_SAT_EQ - `!l xv s. (l ~~>> xv) s <=> s = {Mem l xv}` - (fs[REF_def, SEP_EXISTS, HCOND_EXTRACT, cell_def, one_def]); - -Theorem REF_HPROP_SAT_EQ - `!l xv s. REF (Loc l) xv s <=> s = {Mem l (Refv xv)}` - (fs[REF_def, SEP_EXISTS, HCOND_EXTRACT, cell_def, one_def]); - -Theorem ARRAY_HPROP_SAT_EQ - `!l av s. ARRAY (Loc l) av s <=> s = {Mem l (Varray av)}` - (fs[ARRAY_def, SEP_EXISTS, HCOND_EXTRACT, cell_def, one_def]); - -Theorem SPLIT_UNICITY_R - `SPLIT s (u, v) ==> (SPLIT s (u, v') <=> v' = v)` - (fs[SPLIT_EQ]); - -Theorem DIFF_UNION_COMM - `DISJOINT s2 s3 ==> - (s1 UNION s2) DIFF s3 = (s1 DIFF s3) UNION s2` - (rw[SET_EQ_SUBSET] + metis_tac[DISJOINT_UNION_BOTH, EQ_REFL] +QED + +Theorem CELL_HPROP_SAT_EQ: + !l xv s. (l ~~>> xv) s <=> s = {Mem l xv} +Proof + fs[REF_def, SEP_EXISTS, HCOND_EXTRACT, cell_def, one_def] +QED + +Theorem REF_HPROP_SAT_EQ: + !l xv s. REF (Loc l) xv s <=> s = {Mem l (Refv xv)} +Proof + fs[REF_def, SEP_EXISTS, HCOND_EXTRACT, cell_def, one_def] +QED + +Theorem ARRAY_HPROP_SAT_EQ: + !l av s. ARRAY (Loc l) av s <=> s = {Mem l (Varray av)} +Proof + fs[ARRAY_def, SEP_EXISTS, HCOND_EXTRACT, cell_def, one_def] +QED + +Theorem SPLIT_UNICITY_R: + SPLIT s (u, v) ==> (SPLIT s (u, v') <=> v' = v) +Proof + fs[SPLIT_EQ] +QED + +Theorem DIFF_UNION_COMM: + DISJOINT s2 s3 ==> + (s1 UNION s2) DIFF s3 = (s1 DIFF s3) UNION s2 +Proof + rw[SET_EQ_SUBSET] \\ fs[SUBSET_DEF, IN_DISJOINT] \\rw[] \\ last_x_assum (fn x => PURE_ONCE_REWRITE_RULE [NEG_DISJ_TO_IMP] x |> IMP_RES_TAC) - \\ fs[]); + \\ fs[] +QED -Theorem STATE_SAT_CELL_STAR_H_EQ - `!p s s0 rv s1 H. +Theorem STATE_SAT_CELL_STAR_H_EQ: + !p s s0 rv s1 H. ((LENGTH s0) ~~>> rv * H) (st2heap p (s with refs := s0 ++ [rv] ++ s1)) <=> H ((store2heap s0) UNION (store2heap_aux (LENGTH s0 + 1) s1) UNION - (ffi2heap p s.ffi))` - (rw[] >> + (ffi2heap p s.ffi)) +Proof + rw[] >> Cases_on `p` >> fs[st2heap_def] >> qspecl_then [`p`, `s with refs := s0 ++ [rv] ++ s1`] ASSUME_TAC st2heap_SPLIT_FFI >> @@ -475,32 +570,38 @@ Theorem STATE_SAT_CELL_STAR_H_EQ >-( rw[store2heap_append_many, store2heap_aux_append_many] >> metis_tac[store2heap_aux_def, UNION_COMM, UNION_ASSOC]) - \\ fs[Mem_NOT_IN_ffi2heap]); + \\ fs[Mem_NOT_IN_ffi2heap] +QED -Theorem STATE_SAT_REF_STAR_H_EQ - `!p s s0 xv s1 H. +Theorem STATE_SAT_REF_STAR_H_EQ: + !p s s0 xv s1 H. (Loc (LENGTH s0) ~~> xv * H) (st2heap p (s with refs := s0 ++ [Refv xv] ++ s1)) <=> H ((store2heap s0) UNION - (store2heap_aux (LENGTH s0 + 1) s1) UNION (ffi2heap p s.ffi))` - (rw[REF_def, ARRAY_def, SEP_CLAUSES, SEP_EXISTS_THM] >> + (store2heap_aux (LENGTH s0 + 1) s1) UNION (ffi2heap p s.ffi)) +Proof + rw[REF_def, ARRAY_def, SEP_CLAUSES, SEP_EXISTS_THM] >> fs[GSYM STAR_ASSOC, HCOND_EXTRACT] >> - fs[STATE_SAT_CELL_STAR_H_EQ]); + fs[STATE_SAT_CELL_STAR_H_EQ] +QED -Theorem STATE_SAT_ARRAY_STAR_H_EQ - `!p s s0 av s1 H. +Theorem STATE_SAT_ARRAY_STAR_H_EQ: + !p s s0 av s1 H. (ARRAY (Loc (LENGTH s0)) av * H) (st2heap p (s with refs := s0 ++ [Varray av] ++ s1)) <=> H ((store2heap s0) UNION - (store2heap_aux (LENGTH s0 + 1) s1) UNION (ffi2heap p s.ffi))` - (rw[REF_def, ARRAY_def, SEP_CLAUSES, SEP_EXISTS_THM] >> + (store2heap_aux (LENGTH s0 + 1) s1) UNION (ffi2heap p s.ffi)) +Proof + rw[REF_def, ARRAY_def, SEP_CLAUSES, SEP_EXISTS_THM] >> fs[GSYM STAR_ASSOC, HCOND_EXTRACT] >> - fs[STATE_SAT_CELL_STAR_H_EQ]); + fs[STATE_SAT_CELL_STAR_H_EQ] +QED -Theorem STATE_UPDATE_HPROP_CELL - `(l ~~>> rv * H) (st2heap p s) ==> (l ~~>> rv' * H) - (st2heap p (s with refs := (LUPDATE rv' l s.refs)))` - (DISCH_TAC >> +Theorem STATE_UPDATE_HPROP_CELL: + (l ~~>> rv * H) (st2heap p s) ==> (l ~~>> rv' * H) + (st2heap p (s with refs := (LUPDATE rv' l s.refs))) +Proof + DISCH_TAC >> sg `?s0 s1. s.refs = s0 ++ [rv] ++ s1 /\ LENGTH s0 = l` >-( IMP_RES_TAC STATE_DECOMPOS_FROM_HPROP >> @@ -516,36 +617,43 @@ Theorem STATE_UPDATE_HPROP_CELL >> POP_ASSUM(fn x => rw[GSYM x]) ) >> POP_ASSUM(fn x => fs[x]) >> - fs[STATE_SAT_CELL_STAR_H_EQ]); - -Theorem STATE_UPDATE_HPROP_REF - `(Loc l ~~> xv * H) (st2heap p s) ==> (Loc l ~~> xv' * H) - (st2heap p (s with refs := (LUPDATE (Refv xv') l s.refs)))` - (rw[REF_def, ARRAY_def, SEP_CLAUSES, SEP_EXISTS_THM] >> + fs[STATE_SAT_CELL_STAR_H_EQ] +QED + +Theorem STATE_UPDATE_HPROP_REF: + (Loc l ~~> xv * H) (st2heap p s) ==> (Loc l ~~> xv' * H) + (st2heap p (s with refs := (LUPDATE (Refv xv') l s.refs))) +Proof + rw[REF_def, ARRAY_def, SEP_CLAUSES, SEP_EXISTS_THM] >> fs[GSYM STAR_ASSOC, HCOND_EXTRACT] >> irule STATE_UPDATE_HPROP_CELL >> - instantiate); - -Theorem STATE_UPDATE_HPROP_ARRAY - `(ARRAY (Loc l) av * H) (st2heap p s) ==> (ARRAY (Loc l) av' * H) - (st2heap p (s with refs := (LUPDATE (Varray av') l s.refs)))` - (rw[REF_def, ARRAY_def, SEP_CLAUSES, SEP_EXISTS_THM] >> + instantiate +QED + +Theorem STATE_UPDATE_HPROP_ARRAY: + (ARRAY (Loc l) av * H) (st2heap p s) ==> (ARRAY (Loc l) av' * H) + (st2heap p (s with refs := (LUPDATE (Varray av') l s.refs))) +Proof + rw[REF_def, ARRAY_def, SEP_CLAUSES, SEP_EXISTS_THM] >> fs[GSYM STAR_ASSOC, HCOND_EXTRACT] >> irule STATE_UPDATE_HPROP_CELL >> - instantiate); + instantiate +QED (* -Theorem evaluate_empty_state_IMP_junk - `!junk refs' env s exp x. +Theorem evaluate_empty_state_IMP_junk: + !junk refs' env s exp x. evaluate F env (empty_state with refs := s.refs ++ junk) exp (empty_state with refs := s.refs ++ junk ++ refs',Rval x) ⇒ evaluate F env (s with refs := s.refs ++ junk) exp - (s with refs := s.refs ++ junk ++ refs',Rval x)` - (rw[] + (s with refs := s.refs ++ junk ++ refs',Rval x) +Proof + rw[] \\ ASSUME_TAC ( Thm.INST_TYPE [``:'ffi`` |-> ``:'a``] evaluate_empty_state_IMP |> Thm.INST[``s:'a state`` |-> ``(s:'a state) with refs := s.refs ++ junk``]) - \\ fs[]); + \\ fs[] +QED *) (* Fixed-size arrays *) @@ -559,10 +667,11 @@ val RARRAY_def = Define ` val RARRAY_REL_def = Define ` RARRAY_REL TYPE rv l = SEP_EXISTS av. RARRAY rv av * &LIST_REL TYPE l av`; -Theorem RARRAY_HPROP_SAT_EQ - `RARRAY (Loc l) av s <=> - ?l'. s = {Mem l' (Varray av); Mem l (Refv (Loc l'))}` - (fs[RARRAY_def, ARRAY_def, REF_def, SEP_EXISTS, +Theorem RARRAY_HPROP_SAT_EQ: + RARRAY (Loc l) av s <=> + ?l'. s = {Mem l' (Varray av); Mem l (Refv (Loc l'))} +Proof + fs[RARRAY_def, ARRAY_def, REF_def, SEP_EXISTS, HCOND_EXTRACT, cell_def, one_def, STAR_def] \\ EQ_TAC >-(rw[SPLIT_def, cond_def] @@ -575,7 +684,8 @@ Theorem RARRAY_HPROP_SAT_EQ \\ rw[] \\ PURE_ONCE_REWRITE_TAC[UNION_COMM] \\ irule EQ_EXT - \\ rw[]); + \\ rw[] +QED val GC_ABSORB_L = Q.prove(`!A B s. (A * B * GC) s ==> (A * GC) s`, rw[] @@ -585,10 +695,11 @@ rw[] \\ qexists_tac `v` \\ fs[SAT_GC]); -Theorem st2heap_SPLIT - `SPLIT (st2heap ffi (s with refs := s.refs ++ junk)) - (st2heap ffi s, store2heap_aux (LENGTH s.refs) junk)` - (rw[SPLIT_def, st2heap_def, store2heap_def] +Theorem st2heap_SPLIT: + SPLIT (st2heap ffi (s with refs := s.refs ++ junk)) + (st2heap ffi s, store2heap_aux (LENGTH s.refs) junk) +Proof + rw[SPLIT_def, st2heap_def, store2heap_def] >-( fs[store2heap_aux_append_many] \\ metis_tac[UNION_COMM, UNION_ASSOC]) @@ -600,12 +711,14 @@ Theorem st2heap_SPLIT \\ rw[] \\ Cases_on `x` \\ fs[Mem_NOT_IN_ffi2heap, FFI_split_NOT_IN_store2heap_aux, - FFI_full_NOT_IN_store2heap_aux, FFI_part_NOT_IN_store2heap_aux]); - -Theorem REFS_PRED_FRAME_remove_junk - `REFS_PRED_FRAME ro H (n_st,s1 with refs := s1.refs ⧺ junk) (st2,s2) ==> - REFS_PRED_FRAME ro H (n_st,s1) (st2,s2)` - (Cases_on `H` + FFI_full_NOT_IN_store2heap_aux, FFI_part_NOT_IN_store2heap_aux] +QED + +Theorem REFS_PRED_FRAME_remove_junk: + REFS_PRED_FRAME ro H (n_st,s1 with refs := s1.refs ⧺ junk) (st2,s2) ==> + REFS_PRED_FRAME ro H (n_st,s1) (st2,s2) +Proof + Cases_on `H` \\ rw[REFS_PRED_FRAME_def] \\ first_x_assum (qspec_then `F' * (\h. h = store2heap_aux (LENGTH s1.refs) junk)` assume_tac) \\ first_assum set_imp_as_sg @@ -619,6 +732,7 @@ Theorem REFS_PRED_FRAME_remove_junk \\ fs[] \\ clear_first_assum \\ fs[STAR_ASSOC] \\ drule GC_ABSORB_L - \\ fs[]); + \\ fs[] +QED val _ = export_theory(); diff --git a/translator/monadic/ml_monad_translatorScript.sml b/translator/monadic/ml_monad_translatorScript.sml index 8cc53d2173..cc97ec35c9 100644 --- a/translator/monadic/ml_monad_translatorScript.sml +++ b/translator/monadic/ml_monad_translatorScript.sml @@ -24,9 +24,11 @@ val _ = temp_overload_on ("CONTAINER", ``ml_translator$CONTAINER``); val _ = hide "state"; (* TODO: move *) -Theorem s_with_same_clock[simp] - `!s. (s with clock := s.clock) = s` - (fs [state_component_equality]); +Theorem s_with_same_clock[simp]: + !s. (s with clock := s.clock) = s +Proof + fs [state_component_equality] +QED (* -- *) val GC_ABSORB_L = Q.prove(`!A B s. (A * B * GC) s ==> (A * GC) s`, @@ -146,10 +148,11 @@ val MONAD_def = Define ` val H = mk_var("H",``:('a -> hprop) # 'ffi ffi_proj``); (* return *) -Theorem EvalM_return - `!H b. Eval env exp (a x) ==> - EvalM ro env st exp (MONAD a b (ex_return x)) ^H` - (rw[Eval_def,EvalM_def,st_ex_return_def,MONAD_def] +Theorem EvalM_return: + !H b. Eval env exp (a x) ==> + EvalM ro env st exp (MONAD a b (ex_return x)) ^H +Proof + rw[Eval_def,EvalM_def,st_ex_return_def,MONAD_def] \\ first_x_assum(qspec_then`s.refs`strip_assume_tac) \\ imp_res_tac (evaluate_empty_state_IMP) \\ fs [eval_rel_def,PULL_EXISTS] @@ -159,18 +162,20 @@ Theorem EvalM_return \\ asm_exists_tac \\ simp [] \\ `(s with <|clock := s.clock; refs := s.refs ⧺ refs'|>) = (s with <|refs := s.refs ⧺ refs'|>)` by fs [state_component_equality] - \\ fs [REFS_PRED_FRAME_append]); + \\ fs [REFS_PRED_FRAME_append] +QED (* bind *) -Theorem EvalM_bind - `(a1 ==> EvalM ro env st e1 (MONAD b c (x:('refs, 'b, 'c) M)) +Theorem EvalM_bind: + (a1 ==> EvalM ro env st e1 (MONAD b c (x:('refs, 'b, 'c) M)) (H:('refs -> hprop) # 'ffi ffi_proj)) /\ (!z v. b z v ==> a2 z ==> EvalM ro (write name v env) (SND (x st)) e2 (MONAD a c ((f z):('refs, 'a, 'c) M)) H) ==> (a1 /\ !z. (CONTAINER(FST(x st) = Success z) ==> a2 z)) ==> - EvalM ro env st (Let (SOME name) e1 e2) (MONAD a c (ex_bind x f)) H` - (rw[EvalM_def,MONAD_def,st_ex_return_def,PULL_EXISTS, CONTAINER_def] \\ fs[] + EvalM ro env st (Let (SOME name) e1 e2) (MONAD a c (ex_bind x f)) H +Proof + rw[EvalM_def,MONAD_def,st_ex_return_def,PULL_EXISTS, CONTAINER_def] \\ fs[] \\ last_x_assum drule \\ rw[] \\ imp_res_tac REFS_PRED_FRAME_imp \\ Cases_on `x st` \\ fs [] @@ -199,7 +204,8 @@ Theorem EvalM_bind \\ Cases_on `res'` \\ fs [] \\ TRY (Cases_on `e`) \\ fs [] \\ imp_res_tac evaluate_sing \\ fs [] \\ rveq \\ fs [] - \\ imp_res_tac REFS_PRED_FRAME_trans); + \\ imp_res_tac REFS_PRED_FRAME_trans +QED (* lift ro refinement invariants *) @@ -213,25 +219,31 @@ val PURE_def = Define ` val EqSt_def = Define ` EqSt abs st = \x st1 (st2, res). st = st1 /\ abs x st1 (st2, res)`; -Theorem state_update_clock_id[simp] - `(s with <|clock := s.clock; refs := refs'|>) = - s with <| refs := refs'|>` - (fs [state_component_equality]); - -Theorem Eval_IMP_PURE - `!H env exp P x. Eval env exp (P x) ==> EvalM ro env st exp (PURE P x) ^H` - (rw[Eval_def,EvalM_def,PURE_def,PULL_EXISTS] +Theorem state_update_clock_id[simp]: + (s with <|clock := s.clock; refs := refs'|>) = + s with <| refs := refs'|> +Proof + fs [state_component_equality] +QED + +Theorem Eval_IMP_PURE: + !H env exp P x. Eval env exp (P x) ==> EvalM ro env st exp (PURE P x) ^H +Proof + rw[Eval_def,EvalM_def,PURE_def,PULL_EXISTS] \\ first_x_assum(qspec_then`s.refs`strip_assume_tac) \\ imp_res_tac evaluate_empty_state_IMP \\ fs[eval_rel_def] \\ drule evaluate_set_clock \\ fs [] \\ disch_then (qspec_then `s.clock` mp_tac) \\ strip_tac \\ fs [] \\ asm_exists_tac - \\ fs [REFS_PRED_FRAME_append]); + \\ fs [REFS_PRED_FRAME_append] +QED -Theorem Eval_IMP_PURE_EvalM_T - `!H env exp P x. Eval env exp (P x) ==> EvalM T env st exp (PURE P x) ^H` - (rw[Eval_IMP_PURE]); +Theorem Eval_IMP_PURE_EvalM_T: + !H env exp P x. Eval env exp (P x) ==> EvalM T env st exp (PURE P x) ^H +Proof + rw[Eval_IMP_PURE] +QED (* function abstraction and application *) @@ -281,34 +293,43 @@ val EvalM_Arrow_tac = s2' with <|clock := ck''|>` by fs [state_component_equality] \\ fs [dec_clock_def]; -Theorem EvalM_ArrowM - `EvalM ro env st x1 ((ArrowM ro H (PURE a) b) f) H ==> +Theorem EvalM_ArrowM: + EvalM ro env st x1 ((ArrowM ro H (PURE a) b) f) H ==> EvalM ro env st x2 (PURE a x) H ==> - EvalM ro env st (App Opapp [x1;x2]) (b (f x)) ^H` - (EvalM_Arrow_tac); + EvalM ro env st (App Opapp [x1;x2]) (b (f x)) ^H +Proof + EvalM_Arrow_tac +QED -Theorem EvalM_ArrowM_EqSt - `EvalM ro env st x1 ((ArrowM ro H (EqSt (PURE a) st) b) f) H ==> +Theorem EvalM_ArrowM_EqSt: + EvalM ro env st x1 ((ArrowM ro H (EqSt (PURE a) st) b) f) H ==> EvalM ro env st x2 (PURE a x) H ==> - EvalM ro env st (App Opapp [x1;x2]) (b (f x)) ^H` - (EvalM_Arrow_tac); + EvalM ro env st (App Opapp [x1;x2]) (b (f x)) ^H +Proof + EvalM_Arrow_tac +QED -Theorem EvalM_ArrowM_Eq - `EvalM ro env st x1 ((ArrowM ro H (PURE (Eq a x)) b) f) H ==> +Theorem EvalM_ArrowM_Eq: + EvalM ro env st x1 ((ArrowM ro H (PURE (Eq a x)) b) f) H ==> EvalM ro env st x2 (PURE a x) H ==> - EvalM ro env st (App Opapp [x1;x2]) (b (f x)) ^H` - (EvalM_Arrow_tac); + EvalM ro env st (App Opapp [x1;x2]) (b (f x)) ^H +Proof + EvalM_Arrow_tac +QED -Theorem EvalM_ArrowM_EqSt_Eq - `EvalM ro env st x1 ((ArrowM ro H (EqSt (PURE (Eq a x)) st) b) f) H ==> +Theorem EvalM_ArrowM_EqSt_Eq: + EvalM ro env st x1 ((ArrowM ro H (EqSt (PURE (Eq a x)) st) b) f) H ==> EvalM ro env st x2 (PURE a x) H ==> - EvalM ro env st (App Opapp [x1;x2]) (b (f x)) ^H` - (EvalM_Arrow_tac); - -Theorem EvalM_Fun - `(!v x. a x v ==> EvalM ro (write name v env) n_st body (b (f x)) H) ==> - EvalM ro env st (Fun name body) (ArrowM ro H (EqSt (PURE a) n_st) b f) ^H` - (rw[EvalM_def,ArrowM_def,ArrowP_def,PURE_def,Eq_def,evaluate_def, + EvalM ro env st (App Opapp [x1;x2]) (b (f x)) ^H +Proof + EvalM_Arrow_tac +QED + +Theorem EvalM_Fun: + (!v x. a x v ==> EvalM ro (write name v env) n_st body (b (f x)) H) ==> + EvalM ro env st (Fun name body) (ArrowM ro H (EqSt (PURE a) n_st) b f) ^H +Proof + rw[EvalM_def,ArrowM_def,ArrowP_def,PURE_def,Eq_def,evaluate_def, EqSt_def,PULL_EXISTS] \\ fs [PULL_FORALL] \\ qexists_tac `s.clock` \\ fs [REFS_PRED_FRAME_same] \\ rw [] @@ -321,20 +342,24 @@ Theorem EvalM_Fun \\ strip_tac \\ fs [write_def] \\ asm_exists_tac \\ fs [] \\ asm_exists_tac \\ fs [] - \\ drule REFS_PRED_FRAME_remove_junk \\ fs[]); + \\ drule REFS_PRED_FRAME_remove_junk \\ fs[] +QED -Theorem EvalM_Fun_Var_intro - `EvalM ro cl_env st (Fun n exp) (PURE P f) H ==> +Theorem EvalM_Fun_Var_intro: + EvalM ro cl_env st (Fun n exp) (PURE P f) H ==> ∀name. LOOKUP_VAR name env (Closure cl_env n exp) ==> - EvalM ro env st (Var (Short name)) (PURE P f) ^H` - (fs[EvalM_def, PURE_def, LOOKUP_VAR_def, evaluate_def, - PULL_EXISTS, lookup_var_def]); - -Theorem EvalM_Fun_Eq - `(!v. a x v ==> EvalM ro (write name v env) n_st body (b (f x)) H) ==> + EvalM ro env st (Var (Short name)) (PURE P f) ^H +Proof + fs[EvalM_def, PURE_def, LOOKUP_VAR_def, evaluate_def, + PULL_EXISTS, lookup_var_def] +QED + +Theorem EvalM_Fun_Eq: + (!v. a x v ==> EvalM ro (write name v env) n_st body (b (f x)) H) ==> EvalM ro env st (Fun name body) - ((ArrowM ro H (EqSt (PURE (Eq a x)) n_st) b) f) ^H` - (rw[EvalM_def,ArrowM_def,ArrowP_def,PURE_def,Eq_def, evaluate_def,EqSt_def] + ((ArrowM ro H (EqSt (PURE (Eq a x)) n_st) b) f) ^H +Proof + rw[EvalM_def,ArrowM_def,ArrowP_def,PURE_def,Eq_def, evaluate_def,EqSt_def] \\ qexists_tac `s.clock` \\ fs [] \\ `(s with clock := s.clock) = s` by simp [state_component_equality] \\ fs [REFS_PRED_FRAME_same,PULL_EXISTS] \\ rw [] @@ -346,36 +371,42 @@ Theorem EvalM_Fun_Eq \\ strip_tac \\ fs [write_def] \\ asm_exists_tac \\ fs [] \\ asm_exists_tac \\ fs [] - \\ drule REFS_PRED_FRAME_remove_junk \\ fs[]); + \\ drule REFS_PRED_FRAME_remove_junk \\ fs[] +QED (* More proofs *) -Theorem LOOKUP_VAR_EvalM_ArrowM_IMP - `(!st env. LOOKUP_VAR n env v ==> +Theorem LOOKUP_VAR_EvalM_ArrowM_IMP: + (!st env. LOOKUP_VAR n env v ==> EvalM ro env st (Var (Short n)) (ArrowM ro H a b f) H) ==> - ArrowP ro ^H a b f v` - (fs [LOOKUP_VAR_def,lookup_var_def,EvalM_def,ArrowP_def, + ArrowP ro ^H a b f v +Proof + fs [LOOKUP_VAR_def,lookup_var_def,EvalM_def,ArrowP_def, ArrowM_def,PURE_def,AND_IMP_INTRO, evaluate_def, PULL_EXISTS, VALID_REFS_PRED_def] \\ `nsLookup (<|v := nsBind n v nsEmpty|>).v (Short n) = SOME v` by EVAL_TAC \\ rw[] \\ first_x_assum drule \\ rw[] \\ drule REFS_PRED_append \\ rw[] \\ first_x_assum drule \\ rw[] - \\ first_x_assum drule \\ rw[]); + \\ first_x_assum drule \\ rw[] +QED -Theorem EvalM_Var_SIMP - `EvalM ro (write n x env) st (Var (Short y)) P ^H = +Theorem EvalM_Var_SIMP: + EvalM ro (write n x env) st (Var (Short y)) P ^H = if n = y then EvalM ro (write n x env) st (Var (Short y)) P H - else EvalM ro env st (Var (Short y)) P H` - (SIMP_TAC std_ss [EvalM_def] \\ SRW_TAC [] [] - \\ ASM_SIMP_TAC (srw_ss()) [evaluate_def,write_def]); - -Theorem EvalM_Var_SIMP_ArrowM - `(!st. EvalM ro (write nv v env) st (Var (Short n)) (ArrowM ro H a b x) H) = + else EvalM ro env st (Var (Short y)) P H +Proof + SIMP_TAC std_ss [EvalM_def] \\ SRW_TAC [] [] + \\ ASM_SIMP_TAC (srw_ss()) [evaluate_def,write_def] +QED + +Theorem EvalM_Var_SIMP_ArrowM: + (!st. EvalM ro (write nv v env) st (Var (Short n)) (ArrowM ro H a b x) H) = if nv = n then ArrowP ro H a b x v - else (!st. EvalM ro env st (Var (Short n)) (ArrowM ro H a b x) ^H)` - (SIMP_TAC std_ss [EvalM_def, ArrowM_def, VALID_REFS_PRED_def] + else (!st. EvalM ro env st (Var (Short n)) (ArrowM ro H a b x) ^H) +Proof + SIMP_TAC std_ss [EvalM_def, ArrowM_def, VALID_REFS_PRED_def] \\ reverse (SRW_TAC [] []) THEN1 fs [evaluate_def,write_def] \\ simp [PURE_def, evaluate_def,write_def] @@ -383,18 +414,20 @@ Theorem EvalM_Var_SIMP_ArrowM \\ EQ_TAC THEN1 metis_tac [] \\ rw [] \\ qexists_tac `s.clock` - \\ fs [REFS_PRED_FRAME_same]); + \\ fs [REFS_PRED_FRAME_same] +QED -Theorem EvalM_Recclosure_ALT - `!H funs fname name body. +Theorem EvalM_Recclosure_ALT: + !H funs fname name body. ALL_DISTINCT (MAP (λ(f,x,e). f) funs) ==> (∀st v. a n v ==> EvalM ro (write name v (write_rec funs env2 env2)) st body (b (f n)) H) ==> LOOKUP_VAR fname env (Recclosure env2 funs fname) ==> find_recfun fname funs = SOME (name,body) ==> - EvalM ro env st (Var (Short fname)) ((ArrowM ro H (PURE (Eq a n)) b) f) ^H` - (rw[write_rec_thm,write_def] + EvalM ro env st (Var (Short fname)) ((ArrowM ro H (PURE (Eq a n)) b) f) ^H +Proof + rw[write_rec_thm,write_def] \\ imp_res_tac LOOKUP_VAR_THM \\ fs[Eval_def, EvalM_def,ArrowM_def, ArrowP_def, PURE_def] \\ rpt strip_tac \\ first_x_assum(qspec_then`s.refs` STRIP_ASSUME_TAC) @@ -410,10 +443,11 @@ Theorem EvalM_Recclosure_ALT \\ first_x_assum drule \\ strip_tac \\ asm_exists_tac \\ fs [] \\ asm_exists_tac \\ fs [] - \\ metis_tac[REFS_PRED_FRAME_remove_junk]); + \\ metis_tac[REFS_PRED_FRAME_remove_junk] +QED -Theorem EvalM_Recclosure_ALT2 - `!H funs fname. +Theorem EvalM_Recclosure_ALT2: + !H funs fname. A n_st ==> !name body. ALL_DISTINCT (MAP (λ(f,x,e). f) funs) ==> @@ -424,8 +458,9 @@ Theorem EvalM_Recclosure_ALT2 LOOKUP_VAR fname env (Recclosure env2 funs fname) ==> find_recfun fname funs = SOME (name,body) ==> EvalM ro env st (Var (Short fname)) - ((ArrowM ro H (EqSt (PURE (Eq a n)) n_st) b) f) ^H` - (rw[write_rec_thm,write_def] + ((ArrowM ro H (EqSt (PURE (Eq a n)) n_st) b) f) ^H +Proof + rw[write_rec_thm,write_def] \\ imp_res_tac LOOKUP_VAR_THM \\ fs[Eval_def, EvalM_def,ArrowM_def, ArrowP_def, PURE_def] \\ rpt strip_tac \\ first_x_assum(qspec_then`s.refs` STRIP_ASSUME_TAC) @@ -443,10 +478,11 @@ Theorem EvalM_Recclosure_ALT2 \\ first_x_assum drule \\ strip_tac \\ asm_exists_tac \\ fs [] \\ asm_exists_tac \\ fs [] - \\ metis_tac[REFS_PRED_FRAME_remove_junk]); + \\ metis_tac[REFS_PRED_FRAME_remove_junk] +QED -Theorem EvalM_Recclosure_ALT3 - `!H funs fname name body. +Theorem EvalM_Recclosure_ALT3: + !H funs fname name body. (∀st v. A st ==> a n v ==> @@ -456,8 +492,9 @@ Theorem EvalM_Recclosure_ALT3 LOOKUP_VAR fname env (Recclosure env2 funs fname) ==> find_recfun fname funs = SOME (name,body) ==> EvalM ro env st (Var (Short fname)) - ((ArrowM ro H (EqSt (PURE (Eq a n)) n_st) b) f) ^H` - (rw[write_rec_thm,write_def] + ((ArrowM ro H (EqSt (PURE (Eq a n)) n_st) b) f) ^H +Proof + rw[write_rec_thm,write_def] \\ imp_res_tac LOOKUP_VAR_THM \\ fs[Eval_def, EvalM_def,ArrowM_def, ArrowP_def, PURE_def] \\ rpt strip_tac \\ first_x_assum(qspec_then`s.refs` STRIP_ASSUME_TAC) @@ -475,15 +512,17 @@ Theorem EvalM_Recclosure_ALT3 \\ first_x_assum drule \\ strip_tac \\ asm_exists_tac \\ fs [] \\ asm_exists_tac \\ fs [] - \\ metis_tac[REFS_PRED_FRAME_remove_junk]); + \\ metis_tac[REFS_PRED_FRAME_remove_junk] +QED -Theorem EvalM_Recclosure - `!H. (!st v. a n v ==> +Theorem EvalM_Recclosure: + !H. (!st v. a n v ==> EvalM ro (write name v (write_rec [(fname,name,body)] env2 env2)) st body (b (f n)) H) ==> LOOKUP_VAR fname env (Recclosure env2 [(fname,name,body)] fname) ==> - EvalM ro env st (Var (Short fname)) ((ArrowM ro H (PURE (Eq a n)) b) f) ^H` - (gen_tac \\ NTAC 2 strip_tac \\ imp_res_tac LOOKUP_VAR_THM + EvalM ro env st (Var (Short fname)) ((ArrowM ro H (PURE (Eq a n)) b) f) ^H +Proof + gen_tac \\ NTAC 2 strip_tac \\ imp_res_tac LOOKUP_VAR_THM \\ pop_assum mp_tac \\ pop_assum (K ALL_TAC) \\ pop_assum mp_tac \\ rw[Eval_def,Arrow_def,EvalM_def,ArrowM_def,PURE_def, ArrowP_def,Eq_def,PULL_EXISTS] @@ -498,13 +537,15 @@ Theorem EvalM_Recclosure \\ first_x_assum drule \\ rw[] \\ fs [write_def,write_rec_def,build_rec_env_def] \\ asm_exists_tac \\ fs [] \\ asm_exists_tac \\ fs [] - \\ metis_tac[REFS_PRED_FRAME_remove_junk]); + \\ metis_tac[REFS_PRED_FRAME_remove_junk] +QED -Theorem EvalM_Eq_Recclosure - `LOOKUP_VAR name env (Recclosure x1 x2 x3) ==> +Theorem EvalM_Eq_Recclosure: + LOOKUP_VAR name env (Recclosure x1 x2 x3) ==> (ArrowP ro H a b f (Recclosure x1 x2 x3) = - (!st. EvalM ro env st (Var (Short name)) (ArrowM ro H a b f) ^H))` - (rw[EvalM_Var_SIMP, EvalM_def, ArrowM_def, LOOKUP_VAR_def, lookup_var_def, + (!st. EvalM ro env st (Var (Short name)) (ArrowM ro H a b f) ^H)) +Proof + rw[EvalM_Var_SIMP, EvalM_def, ArrowM_def, LOOKUP_VAR_def, lookup_var_def, PURE_def, PULL_EXISTS, evaluate_def] \\ eq_tac THEN1 (rw[] \\ qexists_tac `s.clock` \\ fs [REFS_PRED_FRAME_same]) @@ -512,39 +553,45 @@ Theorem EvalM_Eq_Recclosure \\ simp[ArrowP_def,PULL_EXISTS] \\ rpt gen_tac \\ strip_tac \\ first_x_assum drule \\ strip_tac - \\ fs [ArrowP_def]); + \\ fs [ArrowP_def] +QED -Theorem EvalM_Var_ArrowP - `(!st. EvalM ro env st (Var (Short n)) (ArrowM ro H (PURE a) b x) H) ==> +Theorem EvalM_Var_ArrowP: + (!st. EvalM ro env st (Var (Short n)) (ArrowM ro H (PURE a) b x) H) ==> LOOKUP_VAR n env v ==> - ArrowP ro ^H (PURE a) b x v` - (rw[EvalM_def,evaluate_def] + ArrowP ro ^H (PURE a) b x v +Proof + rw[EvalM_def,evaluate_def] \\ fs[ArrowP_def, ArrowM_def,PURE_def,PULL_EXISTS,evaluate_def,option_case_eq] \\ rw [] \\ fs [LOOKUP_VAR_def,lookup_var_def] \\ first_x_assum drule \\ strip_tac \\ first_x_assum drule \\ disch_then drule - \\ strip_tac \\ fs []); + \\ strip_tac \\ fs [] +QED -Theorem EvalM_Var_ArrowP_EqSt - `(!st. EvalM ro env st (Var (Short n)) (ArrowM ro H (EqSt (PURE a) n_st) b x) H) ==> +Theorem EvalM_Var_ArrowP_EqSt: + (!st. EvalM ro env st (Var (Short n)) (ArrowM ro H (EqSt (PURE a) n_st) b x) H) ==> LOOKUP_VAR n env v ==> - ArrowP ro ^H (EqSt (PURE a) n_st) b x v` - (rw[EvalM_def,evaluate_def] + ArrowP ro ^H (EqSt (PURE a) n_st) b x v +Proof + rw[EvalM_def,evaluate_def] \\ fs[ArrowP_def, ArrowM_def,PURE_def,PULL_EXISTS,evaluate_def, option_case_eq,EqSt_def] \\ rw [] \\ fs [LOOKUP_VAR_def,lookup_var_def] \\ first_x_assum drule \\ strip_tac \\ first_x_assum drule \\ disch_then drule - \\ strip_tac \\ fs []); + \\ strip_tac \\ fs [] +QED (* Eq simps *) -Theorem EvalM_FUN_FORALL - `(!x. EvalM ro env st exp (PURE (P x) f) H) ==> - EvalM ro env st exp (PURE (FUN_FORALL x. P x) f) ^H` - (rw[EvalM_def,PURE_def,PULL_EXISTS] +Theorem EvalM_FUN_FORALL: + (!x. EvalM ro env st exp (PURE (P x) f) H) ==> + EvalM ro env st exp (PURE (FUN_FORALL x. P x) f) ^H +Proof + rw[EvalM_def,PURE_def,PULL_EXISTS] \\ first_x_assum drule \\ simp[PULL_EXISTS,FUN_FORALL] \\ strip_tac @@ -557,13 +604,16 @@ Theorem EvalM_FUN_FORALL \\ drule evaluate_add_to_clock \\ fs [] \\ disch_then (qspec_then `ck'` strip_assume_tac) \\ disch_then (qspec_then `ck` strip_assume_tac) - \\ fs []); + \\ fs [] +QED -Theorem EvalM_FUN_FORALL_EQ - `(!x. EvalM ro env st exp (PURE (P x) f) H) = - EvalM ro env st exp (PURE (FUN_FORALL x. P x) f) ^H` - (REPEAT strip_tac \\ EQ_TAC \\ FULL_SIMP_TAC std_ss [EvalM_FUN_FORALL] - \\ fs [EvalM_def,PURE_def,PULL_EXISTS,FUN_FORALL] \\ METIS_TAC []); +Theorem EvalM_FUN_FORALL_EQ: + (!x. EvalM ro env st exp (PURE (P x) f) H) = + EvalM ro env st exp (PURE (FUN_FORALL x. P x) f) ^H +Proof + REPEAT strip_tac \\ EQ_TAC \\ FULL_SIMP_TAC std_ss [EvalM_FUN_FORALL] + \\ fs [EvalM_def,PURE_def,PULL_EXISTS,FUN_FORALL] \\ METIS_TAC [] +QED val M_FUN_FORALL_PUSH1 = Q.prove( `(FUN_FORALL x. ArrowP ro ^H a (PURE (b x))) = @@ -611,14 +661,17 @@ val FUN_EXISTS_Eq = Q.prove( val M_FUN_QUANT_SIMP = save_thm("M_FUN_QUANT_SIMP", LIST_CONJ [FUN_EXISTS_Eq,M_FUN_FORALL_PUSH1,M_FUN_FORALL_PUSH2,M_FUN_FORALL_PUSH3]); -Theorem EvalM_Eq - `EvalM ro env st exp (PURE a x) H ==> EvalM ro env st exp (PURE (Eq a x) x) ^H` - (fs[EvalM_def, PURE_def, Eq_def]); - -Theorem ArrowM_EqSt_elim - `(!st_v. EvalM ro env st exp (ArrowM ro H (EqSt a st_v) b f) H) ==> - EvalM ro env st exp (ArrowM ro H a b f) ^H` - (fs[EvalM_def, ArrowP_def, ArrowM_def] +Theorem EvalM_Eq: + EvalM ro env st exp (PURE a x) H ==> EvalM ro env st exp (PURE (Eq a x) x) ^H +Proof + fs[EvalM_def, PURE_def, Eq_def] +QED + +Theorem ArrowM_EqSt_elim: + (!st_v. EvalM ro env st exp (ArrowM ro H (EqSt a st_v) b f) H) ==> + EvalM ro env st exp (ArrowM ro H a b f) ^H +Proof + fs[EvalM_def, ArrowP_def, ArrowM_def] \\ rw[] \\ first_x_assum drule \\ rw[] \\ first_assum (qspec_then `st` strip_assume_tac) @@ -637,22 +690,26 @@ Theorem ArrowM_EqSt_elim \\ fs [] \\ rveq \\ fs []) \\ rveq \\ fs [] \\ qpat_x_assum `ArrowP ro H _ b f v` mp_tac - \\ rw [ArrowP_def,EqSt_def]); + \\ rw [ArrowP_def,EqSt_def] +QED -Theorem ArrowP_EqSt_elim - `(!st_v. ArrowP ro H (EqSt a st_v) b f v) ==> ArrowP ro ^H a b f v` - (fs[EqSt_def, ArrowP_def, ArrowM_def] \\ metis_tac[]); +Theorem ArrowP_EqSt_elim: + (!st_v. ArrowP ro H (EqSt a st_v) b f v) ==> ArrowP ro ^H a b f v +Proof + fs[EqSt_def, ArrowP_def, ArrowM_def] \\ metis_tac[] +QED (* otherwise *) -Theorem EvalM_otherwise - `!H b n. +Theorem EvalM_otherwise: + !H b n. ((a1 ==> EvalM ro env st exp1 (MONAD a b x1) H) /\ (!st i. a2 st ==> EvalM ro (write n i env) st exp2 (MONAD a b x2) H)) ==> (a1 /\ !st'. (CONTAINER(SND(x1 st) = st') ==> a2 st')) ==> EvalM ro env st (Handle exp1 [(Pvar n,exp2)]) - (MONAD a b (x1 otherwise x2)) ^H` - (simp [EvalM_def, EvalM_def, evaluate_def] \\ rpt strip_tac + (MONAD a b (x1 otherwise x2)) ^H +Proof + simp [EvalM_def, EvalM_def, evaluate_def] \\ rpt strip_tac \\ fs [pair_case_eq,result_case_eq,PULL_EXISTS,PULL_EXISTS] \\ last_x_assum drule \\ rw[] \\ Cases_on `x1 st` \\ fs [CONTAINER_def] @@ -682,18 +739,20 @@ Theorem EvalM_otherwise \\ fs[MONAD_def] \\ CASE_TAC \\ fs[] \\ CASE_TAC \\ fs[] - \\ asm_exists_tac \\ fs[]); + \\ asm_exists_tac \\ fs[] +QED (* if *) -Theorem EvalM_If - `!H. +Theorem EvalM_If: + !H. (a1 ==> Eval env x1 (BOOL b1)) /\ (a2 ==> EvalM ro env st x2 (a b2) H) /\ (a3 ==> EvalM ro env st x3 (a b3) H) ==> (a1 /\ (CONTAINER b1 ==> a2) /\ (~CONTAINER b1 ==> a3) ==> - EvalM ro env st (If x1 x2 x3) (a (if b1 then b2 else b3)) ^H)` - (rpt strip_tac \\ fs[] + EvalM ro env st (If x1 x2 x3) (a (if b1 then b2 else b3)) ^H) +Proof + rpt strip_tac \\ fs[] \\ `∀H. EvalM ro env st x1 (PURE BOOL b1) ^H` by metis_tac[Eval_IMP_PURE] \\ fs[EvalM_def,PURE_def, BOOL_def,PULL_EXISTS] \\ rpt strip_tac @@ -712,16 +771,18 @@ Theorem EvalM_If \\ rw [] \\ asm_exists_tac \\ fs [] \\ fs [do_if_def] \\ asm_exists_tac \\ fs [] - \\ metis_tac[REFS_PRED_FRAME_trans]); + \\ metis_tac[REFS_PRED_FRAME_trans] +QED (* Let *) -Theorem EvalM_Let - `!H. +Theorem EvalM_Let: + !H. Eval env exp (a res) /\ (!v. a res v ==> EvalM ro (write name v env) st body (b (f res)) H) ==> - EvalM ro env st (Let (SOME name) exp body) (b (LET f res)) ^H` - (rw[] + EvalM ro env st (Let (SOME name) exp body) (b (LET f res)) ^H +Proof + rw[] \\ drule Eval_IMP_PURE \\ rw[] \\ fs[EvalM_def] \\ rpt strip_tac @@ -739,19 +800,22 @@ Theorem EvalM_Let \\ disch_then (qspec_then `ck0` strip_assume_tac) \\ rw [] \\ asm_exists_tac \\ fs [] \\ rw [] \\ asm_exists_tac \\ fs [] - \\ metis_tac[REFS_PRED_FRAME_trans]); + \\ metis_tac[REFS_PRED_FRAME_trans] +QED (* PMATCH *) -Theorem EvalM_PMATCH_NIL - `!H b x xv a. +Theorem EvalM_PMATCH_NIL: + !H b x xv a. Eval env x (a xv) ==> CONTAINER F ==> - EvalM ro env st (Mat x []) (b (PMATCH xv [])) ^H` - (rw[ml_translatorTheory.CONTAINER_def]); + EvalM ro env st (Mat x []) (b (PMATCH xv [])) ^H +Proof + rw[ml_translatorTheory.CONTAINER_def] +QED -Theorem EvalM_PMATCH - `!H b a x xv. +Theorem EvalM_PMATCH: + !H b a x xv. ALL_DISTINCT (pat_bindings pt []) ⇒ (∀v1 v2. pat v1 = pat v2 ⇒ v1 = v2) ⇒ Eval env x (a xv) ⇒ @@ -763,8 +827,9 @@ Theorem EvalM_PMATCH (∀vars. PMATCH_ROW_COND pat (K T) xv vars ⇒ pt2 vars) ∧ ((∀vars. ¬PMATCH_ROW_COND pat (K T) xv vars) ⇒ pt1 xv) ⇒ EvalM ro env st (Mat x ((pt,e)::ys)) - (b (PMATCH xv ((PMATCH_ROW pat (K T) res)::yrs))) ^H` - (rw[EvalM_def] + (b (PMATCH xv ((PMATCH_ROW pat (K T) res)::yrs))) ^H +Proof + rw[EvalM_def] \\ drule Eval_IMP_PURE \\ rw[] \\ fs[EvalM_def] \\ rw[evaluate_def,PULL_EXISTS] \\ fs[] @@ -832,7 +897,8 @@ Theorem EvalM_PMATCH \\ disch_then (qspec_then `ck'` strip_assume_tac) \\ asm_exists_tac \\ fs [] \\ asm_exists_tac \\ fs [] - \\ metis_tac[REFS_PRED_FRAME_trans]); + \\ metis_tac[REFS_PRED_FRAME_trans] +QED (* Exception handling *) val write_list_def = Define ` @@ -886,8 +952,8 @@ val nsAppend_write_list_eq = Q.prove( \\ rw[sem_env_component_equality] \\ rw[namespaceTheory.nsAppend_def]); -Theorem EvalM_handle - `!cons_name stamp CORRECT_CONS PARAMS_CONDITIONS EXN_TYPE +Theorem EvalM_handle: + !cons_name stamp CORRECT_CONS PARAMS_CONDITIONS EXN_TYPE handle_fun x1 x2 arity a2 bind_names a H. (!s E s1. CORRECT_CONS E ==> @@ -929,8 +995,9 @@ Theorem EvalM_handle EvalM ro env st (Handle exp1 [(Pcon (SOME cons_name) (MAP (\x. Pvar x) bind_names),exp2)]) - (MONAD a EXN_TYPE (handle_fun x1 x2)) H` - (rw [EvalM_def] + (MONAD a EXN_TYPE (handle_fun x1 x2)) H +Proof + rw [EvalM_def] \\ rw[evaluate_def] \\ `a1` by fs [] \\ first_x_assum drule @@ -991,7 +1058,8 @@ Theorem EvalM_handle \\ fs [pat_bindings_def] \\ drule ALL_DISTINCT_pats_bindings \\ rw [] \\ fs [pmatch_def] - \\ fs [lookup_cons_def, same_type_def, same_ctor_def]); + \\ fs [lookup_cons_def, same_type_def, same_ctor_def] +QED val ZIP3_def = Define ` ZIP3 ([],[],[]) = [] /\ @@ -1038,16 +1106,18 @@ val LIST_CONJ_Eval = prove( \\ qexists_tac `ck1'''` \\ once_rewrite_tac [evaluate_cons] \\ fs [state_component_equality]); -Theorem LIST_REL_EQ_LIST_CONJ_MAP - `!xs ys. +Theorem LIST_REL_EQ_LIST_CONJ_MAP: + !xs ys. LENGTH xs = LENGTH ys ⇒ LIST_REL (λf x. f x) xs ys = - LIST_CONJ (MAP (λ(P,v). P v) (ZIP (xs,ys)))` - (Induct \\ fs [LIST_CONJ_def] - \\ Cases_on `ys` \\ fs [LIST_CONJ_def]); - -Theorem EvalM_raise - `!cons_name stamp EXN_TYPE EVAL_CONDS arity E exprs f a H. + LIST_CONJ (MAP (λ(P,v). P v) (ZIP (xs,ys))) +Proof + Induct \\ fs [LIST_CONJ_def] + \\ Cases_on `ys` \\ fs [LIST_CONJ_def] +QED + +Theorem EvalM_raise: + !cons_name stamp EXN_TYPE EVAL_CONDS arity E exprs f a H. (!values. LENGTH values = arity ==> LIST_CONJ (MAP (\(P,v). P v) (ZIP(EVAL_CONDS,values))) ==> @@ -1059,8 +1129,9 @@ Theorem EvalM_raise lookup_cons cons_name env = SOME (arity, ExnStamp stamp) ==> LIST_CONJ (MAP (\(exp,P). Eval env exp P) (ZIP (exprs,EVAL_CONDS))) ==> EvalM ro env st (Raise (Con (SOME cons_name) exprs)) - (MONAD a EXN_TYPE f) H` - (rw [EvalM_def] + (MONAD a EXN_TYPE f) H +Proof + rw [EvalM_def] \\ rw [evaluate_def, do_con_check_def, build_conv_def] \\ fs [lookup_cons_def] \\ qpat_x_assum `LIST_CONJ _` mp_tac @@ -1081,17 +1152,19 @@ Theorem EvalM_raise \\ imp_res_tac evaluate_length \\ fs [] \\ `LENGTH EVAL_CONDS = LENGTH (REVERSE vs)` by fs [] \\ drule LIST_REL_EQ_LIST_CONJ_MAP - \\ fs [GSYM EVERY2_REVERSE1]); + \\ fs [GSYM EVERY2_REVERSE1] +QED (* read and update refs *) -Theorem EvalM_read_heap - `!vname loc TYPE EXC_TYPE H get_var. +Theorem EvalM_read_heap: + !vname loc TYPE EXC_TYPE H get_var. (nsLookup env.v (Short vname) = SOME loc) ==> EvalM ro env st (App Opderef [Var (Short vname)]) (MONAD TYPE EXC_TYPE (λrefs. (Success (get_var refs), refs))) - ((λrefs. REF_REL TYPE loc (get_var refs) * H refs), (p:'ffi ffi_proj))` - (rw[EvalM_def, REF_REL_def] + ((λrefs. REF_REL TYPE loc (get_var refs) * H refs), (p:'ffi ffi_proj)) +Proof + rw[EvalM_def, REF_REL_def] \\ rw[evaluate_def,PULL_EXISTS] \\ fs[REFS_PRED_def] \\ fs[SEP_CLAUSES, SEP_EXISTS_THM] @@ -1110,10 +1183,11 @@ Theorem EvalM_read_heap \\ fs [state_component_equality]) >> imp_res_tac st2heap_REF_MEM \\ imp_res_tac store2heap_IN_LENGTH - \\ fs[]); + \\ fs[] +QED -Theorem EvalM_write_heap - `!vname loc TYPE PINV EXC_TYPE H get_var set_var x exp env. +Theorem EvalM_write_heap: + !vname loc TYPE PINV EXC_TYPE H get_var set_var x exp env. (!refs x. get_var (set_var x refs) = x) ==> (!refs x. H (set_var x refs) = H refs) ==> nsLookup env.v (Short vname) = SOME loc ==> @@ -1121,8 +1195,9 @@ Theorem EvalM_write_heap Eval env exp (TYPE x) ==> EvalM ro env st (App Opassign [Var (Short vname); exp]) ((MONAD UNIT_TYPE EXC_TYPE) (λrefs. (Success (), set_var x refs))) - ((λrefs. REF_REL TYPE loc (get_var refs) * H refs * &PINV refs), p:'ffi ffi_proj)` - (rw[REF_REL_def] + ((λrefs. REF_REL TYPE loc (get_var refs) * H refs * &PINV refs), p:'ffi ffi_proj) +Proof + rw[REF_REL_def] \\ ASSUME_TAC (Thm.INST_TYPE [``:'a``|->``:'b``,``:'b``|->``:'a``]Eval_IMP_PURE) \\ pop_assum imp_res_tac \\ fs[EvalM_def] \\ rw[] @@ -1180,7 +1255,8 @@ Theorem EvalM_write_heap \\ fs[LUPDATE_APPEND1,LUPDATE_APPEND2,LUPDATE_def] \\ imp_res_tac STATE_UPDATE_HPROP_REF \\ last_x_assum(qspec_then `res` ASSUME_TAC) - \\ fs[with_same_ffi] \\ rfs [st2heap_def]); + \\ fs[with_same_ffi] \\ rfs [st2heap_def] +QED (* Dynamic allocation of references *) @@ -1277,16 +1353,17 @@ val valid_state_refs_reduction = Q.prove( (* Validity of ref_bind *) -Theorem EvalM_ref_bind - `Eval env xexpr (A (cons x)) ==> +Theorem EvalM_ref_bind: + Eval env xexpr (A (cons x)) ==> (!rv r. EvalM ro (write rname rv env) ((cons x)::st) exp (MONAD TYPE MON_EXN_TYPE (f r)) (STATE_REFS A (rv::ptrs),p:'ffi ffi_proj)) ==> EvalM ro env st (Let (SOME rname) (App Opref [xexpr]) exp) (MONAD TYPE MON_EXN_TYPE (ref_bind (Mref cons x) f (Mpop_ref e))) - (STATE_REFS A ptrs,p)` - (rw[] + (STATE_REFS A ptrs,p) +Proof + rw[] \\ fs[Eval_def] \\ rw[EvalM_def] \\ fs [evaluate_def] @@ -1356,7 +1433,8 @@ Theorem EvalM_ref_bind \\ fs[GSYM STAR_ASSOC, GC_STAR_GC] \\ fs[STAR_ASSOC] \\ irule valid_state_refs_reduction - \\ metis_tac[]); + \\ metis_tac[] +QED (* Validity of a deref operation *) val STATE_REFS_EXTRACT = Q.prove( @@ -1442,15 +1520,16 @@ val STATE_REFS_RECONSTRUCT = Q.prove( \\ first_x_assum (fn x => PURE_ONCE_REWRITE_RULE[GSYM STAR_ASSOC] x |> ASSUME_TAC) \\ rw[Once (GSYM STAR_ASSOC)]); -Theorem STATE_REFS_DECOMPOSE - `!ptrs1 r ptrs2 refs TYPE H (p:'ffi ffi_proj) s. ((STATE_REFS TYPE (ptrs1 ++ [r] ++ ptrs2) refs) * H) (st2heap p s) <=> +Theorem STATE_REFS_DECOMPOSE: + !ptrs1 r ptrs2 refs TYPE H (p:'ffi ffi_proj) s. ((STATE_REFS TYPE (ptrs1 ++ [r] ++ ptrs2) refs) * H) (st2heap p s) <=> ?refs1 y refs2. refs = refs1 ++ [y] ++ refs2 /\ ((STATE_REFS TYPE ptrs1 refs1 * (STATE_REF TYPE r y) * (STATE_REFS TYPE ptrs2 refs2) * - H)) (st2heap p s)` - (rpt strip_tac + H)) (st2heap p s) +Proof + rpt strip_tac \\ EQ_TAC >-( rw[] @@ -1494,66 +1573,78 @@ Theorem STATE_REFS_DECOMPOSE >> imp_res_tac STATE_REFS_EXTRACT >> metis_tac[]) \\ rw[] - \\ fs[STATE_REFS_RECONSTRUCT]); + \\ fs[STATE_REFS_RECONSTRUCT] +QED -Theorem STATE_REFS_DECOMPOSE_2 - `!ptrs1 r ptrs2 refs1 x refs2 TYPE H (p:'ffi ffi_proj) s. +Theorem STATE_REFS_DECOMPOSE_2: + !ptrs1 r ptrs2 refs1 x refs2 TYPE H (p:'ffi ffi_proj) s. LENGTH ptrs1 = LENGTH refs1 ==> LENGTH ptrs2 = LENGTH refs2 ==> (((STATE_REFS TYPE (ptrs1 ++ [r] ++ ptrs2) (refs1 ++ [x] ++ refs2)) * H) (st2heap p s) <=> ((STATE_REFS TYPE ptrs1 refs1 * (STATE_REF TYPE r x) * (STATE_REFS TYPE ptrs2 refs2) * - H)) (st2heap p s))` - (rpt strip_tac + H)) (st2heap p s)) +Proof + rpt strip_tac \\ EQ_TAC >-( rw[] >> fs[STATE_REFS_EXTRACT_2]) \\ rw[] - \\ fs[STATE_REFS_RECONSTRUCT]); + \\ fs[STATE_REFS_RECONSTRUCT] +QED -Theorem store_lookup_CELL_st2heap - `(l ~~>> res * H) (st2heap (p:'ffi ffi_proj) s) ==> store_lookup l (s.refs ++ junk) = SOME res` - (rw[] +Theorem store_lookup_CELL_st2heap: + (l ~~>> res * H) (st2heap (p:'ffi ffi_proj) s) ==> store_lookup l (s.refs ++ junk) = SOME res +Proof + rw[] \\ imp_res_tac STATE_EXTRACT_FROM_HPROP \\ imp_res_tac st2heap_CELL_MEM \\ imp_res_tac store2heap_IN_LENGTH - \\ fs[store_lookup_def]); + \\ fs[store_lookup_def] +QED -Theorem store_lookup_REF_st2heap - `(Loc l ~~> v * H) (st2heap (p:'ffi ffi_proj) s) ==> store_lookup l s.refs = SOME (Refv v)` - (rw[] +Theorem store_lookup_REF_st2heap: + (Loc l ~~> v * H) (st2heap (p:'ffi ffi_proj) s) ==> store_lookup l s.refs = SOME (Refv v) +Proof + rw[] \\ imp_res_tac STATE_EXTRACT_FROM_HPROP_REF \\ imp_res_tac st2heap_REF_MEM \\ imp_res_tac store2heap_IN_LENGTH \\ first_x_assum (qspec_then `[]` assume_tac) - \\ fs[store_lookup_def]); + \\ fs[store_lookup_def] +QED -Theorem store_lookup_REF_st2heap_junk - `(Loc l ~~> v * H) (st2heap (p:'ffi ffi_proj) s) ==> store_lookup l (s.refs ++ junk) = SOME (Refv v)` - (rw[] +Theorem store_lookup_REF_st2heap_junk: + (Loc l ~~> v * H) (st2heap (p:'ffi ffi_proj) s) ==> store_lookup l (s.refs ++ junk) = SOME (Refv v) +Proof + rw[] \\ imp_res_tac STATE_EXTRACT_FROM_HPROP_REF \\ imp_res_tac st2heap_REF_MEM \\ imp_res_tac store2heap_IN_LENGTH - \\ fs[store_lookup_def]); + \\ fs[store_lookup_def] +QED -Theorem store_lookup_ARRAY_st2heap - `(ARRAY (Loc l) av * H) (st2heap (p:'ffi ffi_proj) s) ==> store_lookup l s.refs = SOME (Varray av)` - (rw[] +Theorem store_lookup_ARRAY_st2heap: + (ARRAY (Loc l) av * H) (st2heap (p:'ffi ffi_proj) s) ==> store_lookup l s.refs = SOME (Varray av) +Proof + rw[] \\ imp_res_tac STATE_EXTRACT_FROM_HPROP_ARRAY \\ imp_res_tac st2heap_ARRAY_MEM \\ imp_res_tac store2heap_IN_LENGTH \\ first_x_assum (qspec_then `[]` assume_tac) - \\ fs[store_lookup_def]); + \\ fs[store_lookup_def] +QED -Theorem EvalM_Mdref - `nsLookup env.v (Short rname) = SOME rv ==> +Theorem EvalM_Mdref: + nsLookup env.v (Short rname) = SOME rv ==> r = LENGTH ptrs2 ==> EvalM ro env st (App Opderef [Var (Short rname)]) (MONAD TYPE (\x v. F) (Mdref e (StoreRef r))) - (STATE_REFS TYPE (ptrs1 ++ [rv] ++ ptrs2),p:'ffi ffi_proj)` - (rw[] + (STATE_REFS TYPE (ptrs1 ++ [rv] ++ ptrs2),p:'ffi ffi_proj) +Proof + rw[] \\ fs[EvalM_def] \\ rw[evaluate_def] \\ rw[do_app_def] @@ -1581,19 +1672,22 @@ Theorem EvalM_Mdref \\ fs[REFS_PRED_FRAME_def] \\ rw[state_component_equality] \\ fs[Once (GSYM with_same_refs)] - \\ irule H_STAR_GC_SAT_IMP \\ fs[]); + \\ irule H_STAR_GC_SAT_IMP \\ fs[] +QED (* Validity of an assigment operation *) -Theorem store_assign_REF_st2heap - `(Loc l ~~> v * H) (st2heap (p:'ffi ffi_proj) s) ==> - store_assign l (Refv res) (s.refs ++ junk) = SOME (LUPDATE (Refv res) l (s.refs ++ junk))` - (rw[] +Theorem store_assign_REF_st2heap: + (Loc l ~~> v * H) (st2heap (p:'ffi ffi_proj) s) ==> + store_assign l (Refv res) (s.refs ++ junk) = SOME (LUPDATE (Refv res) l (s.refs ++ junk)) +Proof + rw[] \\ simp[store_assign_def] \\ imp_res_tac st2heap_REF_MEM \\ imp_res_tac store2heap_IN_LENGTH \\ fs[store_v_same_type_def] \\ imp_res_tac store2heap_IN_EL - \\ fs[EL_APPEND1]); + \\ fs[EL_APPEND1] +QED val UPDATE_STATE_REFS = Q.prove( `!ptrs2 l ptrs1 x res TYPE junk refs p s. @@ -1632,13 +1726,14 @@ val UPDATE_STATE_REFS = Q.prove( \\ fs[LUPDATE_APPEND1] \\ metis_tac[STAR_ASSOC, STAR_COMM]); -Theorem EvalM_Mref_assign - `nsLookup env.v (Short rname) = SOME rv ==> +Theorem EvalM_Mref_assign: + nsLookup env.v (Short rname) = SOME rv ==> r = LENGTH ptrs2 ==> Eval env xexpr (TYPE x) ==> EvalM ro env st (App Opassign [Var (Short rname); xexpr]) - (MONAD UNIT_TYPE (\x v. F) (Mref_assign e (StoreRef r) x)) (STATE_REFS TYPE (ptrs1 ++ [rv] ++ ptrs2),p:'ffi ffi_proj)` - (rw[] + (MONAD UNIT_TYPE (\x v. F) (Mref_assign e (StoreRef r) x)) (STATE_REFS TYPE (ptrs1 ++ [rv] ++ ptrs2),p:'ffi ffi_proj) +Proof + rw[] \\ fs[EvalM_def,evaluate_def] \\ fs[Eval_def] \\ rw [] \\ first_x_assum(qspec_then `s.refs` STRIP_ASSUME_TAC) @@ -1666,14 +1761,16 @@ Theorem EvalM_Mref_assign \\ fs[UPDATE_STATE_REFS,with_same_ffi] \\ fs[MONAD_def] \\ imp_res_tac STATE_REFS_LENGTH - \\ fs[Mref_assign_eq]); + \\ fs[Mref_assign_eq] +QED (* Allocation of the initial store for dynamic references *) -Theorem STATE_REFS_EXTEND - `!H s refs. (STATE_REFS A ptrs refs * H) (st2heap (p:'ffi ffi_proj) s) ==> +Theorem STATE_REFS_EXTEND: + !H s refs. (STATE_REFS A ptrs refs * H) (st2heap (p:'ffi ffi_proj) s) ==> !x xv. A x xv ==> - (STATE_REFS A (Loc (LENGTH s.refs)::ptrs) (x::refs) * H)(st2heap p (s with refs := s.refs ++ [Refv xv]))` - (rw[] + (STATE_REFS A (Loc (LENGTH s.refs)::ptrs) (x::refs) * H)(st2heap p (s with refs := s.refs ++ [Refv xv])) +Proof + rw[] \\ rw[STATE_REFS_def] \\ rw[GSYM STAR_ASSOC] \\ rw[Once STAR_def] @@ -1688,7 +1785,8 @@ Theorem STATE_REFS_EXTEND \\ simp[SEP_EXISTS_THM] \\ qexists_tac `xv` \\ EXTRACT_PURE_FACTS_TAC - \\ simp[REF_def, cell_def, one_def, SEP_EXISTS_THM, HCOND_EXTRACT]); + \\ simp[REF_def, cell_def, one_def, SEP_EXISTS_THM, HCOND_EXTRACT] +QED (* Resizable arrays *) val ABS_NUM_EQ = Q.prove(`Num(ABS(&n))=n`, @@ -1713,13 +1811,14 @@ val do_app_Alength_ARRAY = Q.prove( \\ first_x_assum(qspec_then `[]` ASSUME_TAC) \\ fs[]); -Theorem EvalM_R_Marray_length - `!vname loc TYPE EXC_TYPE H get_arr x env. +Theorem EvalM_R_Marray_length: + !vname loc TYPE EXC_TYPE H get_arr x env. nsLookup env.v (Short vname) = SOME loc ==> EvalM ro env st (App Alength [App Opderef [Var (Short vname)]]) ((MONAD NUM EXC_TYPE) (Marray_length get_arr)) - ((λrefs. RARRAY_REL TYPE loc (get_arr refs) * H refs),p:'ffi ffi_proj)` - (rw[EvalM_def] + ((λrefs. RARRAY_REL TYPE loc (get_arr refs) * H refs),p:'ffi ffi_proj) +Proof + rw[EvalM_def] \\ fs[REFS_PRED_def, RARRAY_REL_def, RARRAY_def] \\ fs[SEP_CLAUSES, SEP_EXISTS_THM] \\ EXTRACT_PURE_FACTS_TAC @@ -1744,7 +1843,8 @@ Theorem EvalM_R_Marray_length \\ drule do_app_Alength_ARRAY \\ rw[] \\ fs[state_component_equality] \\ imp_res_tac LIST_REL_LENGTH - \\ fs[REFS_PRED_FRAME_same]); + \\ fs[REFS_PRED_FRAME_same] +QED val Conv_Subscript = EVAL ``sub_exn_v`` |> concl |> rand val Stamp_Subscript = Conv_Subscript |> rator |> rand |> rand @@ -1771,16 +1871,17 @@ val evaluate_empty_state_IMP_3 = |> Q.GEN`s` |> Q.SPEC`s with refs := s.refs ++ more ++ more2` |> SIMP_RULE(srw_ss())[] -Theorem EvalM_R_Marray_sub_subscript - `!vname loc TYPE EXC_TYPE H get_arr e env n nexp. +Theorem EvalM_R_Marray_sub_subscript: + !vname loc TYPE EXC_TYPE H get_arr e env n nexp. EXC_TYPE e ^Conv_Subscript ==> nsLookup env.v (Short vname) = SOME loc ==> lookup_cons (Short "Subscript") env = SOME (0,^Stamp_Subscript) ==> Eval env nexp (NUM n) ==> EvalM ro env st (App Asub [App Opderef [Var (Short vname)]; nexp]) ((MONAD TYPE EXC_TYPE) (Marray_sub get_arr e n)) - ((λrefs. RARRAY_REL TYPE loc (get_arr refs) * H refs),p:'ffi ffi_proj)` - (rw[EvalM_def] + ((λrefs. RARRAY_REL TYPE loc (get_arr refs) * H refs),p:'ffi ffi_proj) +Proof + rw[EvalM_def] \\ rw[evaluate_def] \\ fs[Eval_def, NUM_def, INT_def] \\ first_assum(fn x => SIMP_RULE bool_ss [REFS_PRED_def, RARRAY_def, RARRAY_REL_def] x |> ASSUME_TAC) @@ -1819,10 +1920,11 @@ Theorem EvalM_R_Marray_sub_subscript \\ fs[with_same_ffi] \\ qexists_tac `st` \\ fs[MONAD_def, Marray_sub_def, Msub_exn_eq] - \\ fs[REFS_PRED_FRAME_append]); + \\ fs[REFS_PRED_FRAME_append] +QED -Theorem EvalM_R_Marray_sub_handle - `!vname loc TYPE EXC_TYPE H get_arr e rexp env n nexp. +Theorem EvalM_R_Marray_sub_handle: + !vname loc TYPE EXC_TYPE H get_arr e rexp env n nexp. nsLookup env.v (Short vname) = SOME loc ==> lookup_cons (Short "Subscript") env = SOME (0,^Stamp_Subscript) ==> Eval env nexp (NUM n) ==> @@ -1830,8 +1932,9 @@ Theorem EvalM_R_Marray_sub_handle EvalM ro env st (Handle (App Asub [App Opderef [Var (Short vname)]; nexp]) [(Pcon (SOME (Short("Subscript"))) [], Raise rexp)]) ((MONAD TYPE EXC_TYPE) (Marray_sub get_arr e n)) - ((λrefs. RARRAY_REL TYPE loc (get_arr refs) * H refs),p:'ffi ffi_proj)` - (rw[EvalM_def] + ((λrefs. RARRAY_REL TYPE loc (get_arr refs) * H refs),p:'ffi ffi_proj) +Proof + rw[EvalM_def] \\ rw[evaluate_def] \\ fs[Eval_def, NUM_def, INT_def] \\ first_assum(fn x => SIMP_RULE bool_ss [REFS_PRED_def, RARRAY_def, RARRAY_REL_def] x |> ASSUME_TAC) @@ -1881,10 +1984,11 @@ Theorem EvalM_R_Marray_sub_handle \\ fs[with_same_ffi] \\ fs[MONAD_def, Marray_sub_def, Msub_exn_eq] \\ PURE_REWRITE_TAC[GSYM APPEND_ASSOC] - \\ rw[REFS_PRED_FRAME_append]); + \\ rw[REFS_PRED_FRAME_append] +QED -Theorem EvalM_R_Marray_update_subscript - `!vname loc TYPE EXC_TYPE H get_arr set_arr e env n x xexp nexp. +Theorem EvalM_R_Marray_update_subscript: + !vname loc TYPE EXC_TYPE H get_arr set_arr e env n x xexp nexp. nsLookup env.v (Short vname) = SOME loc ==> lookup_cons (Short "Subscript") env = SOME (0,^Stamp_Subscript) ==> EXC_TYPE e ^Conv_Subscript ==> @@ -1894,8 +1998,9 @@ Theorem EvalM_R_Marray_update_subscript Eval env xexp (TYPE x) ==> EvalM ro env st (App Aupdate [App Opderef [Var (Short vname)]; nexp; xexp]) ((MONAD UNIT_TYPE EXC_TYPE) (Marray_update get_arr set_arr e n x)) - ((λrefs. RARRAY_REL TYPE loc (get_arr refs) * H refs),p:'ffi ffi_proj)` - (rw[EvalM_def] + ((λrefs. RARRAY_REL TYPE loc (get_arr refs) * H refs),p:'ffi ffi_proj) +Proof + rw[EvalM_def] \\ fs[Eval_def, NUM_def, INT_def] \\ rw[evaluate_def] \\ first_assum(fn x => SIMP_RULE bool_ss [REFS_PRED_def, RARRAY_def, RARRAY_REL_def] x |> ASSUME_TAC) @@ -1987,10 +2092,11 @@ Theorem EvalM_R_Marray_update_subscript \\ fs [with_same_refs, with_same_ffi] \\ rw [do_app_def] \\ fs[MONAD_def, Marray_update_def, Mupdate_exn_eq] \\ rw[with_same_ffi,EVAL ``sub_exn_v``] - \\ metis_tac[REFS_PRED_FRAME_append, GSYM APPEND_ASSOC]); + \\ metis_tac[REFS_PRED_FRAME_append, GSYM APPEND_ASSOC] +QED -Theorem EvalM_R_Marray_update_handle - `!vname loc TYPE EXC_TYPE H get_arr set_arr e rexp env n x xexp nexp. +Theorem EvalM_R_Marray_update_handle: + !vname loc TYPE EXC_TYPE H get_arr set_arr e rexp env n x xexp nexp. nsLookup env.v (Short vname) = SOME loc ==> lookup_cons (Short "Subscript") env = SOME (0,^Stamp_Subscript) ==> (!refs x. get_arr (set_arr x refs) = x) ==> @@ -2001,8 +2107,9 @@ Theorem EvalM_R_Marray_update_handle EvalM ro env st (Handle (App Aupdate [App Opderef [Var (Short vname)]; nexp; xexp]) [(Pcon (SOME (Short("Subscript"))) [], Raise rexp)]) ((MONAD UNIT_TYPE EXC_TYPE) (Marray_update get_arr set_arr e n x)) - ((λrefs. RARRAY_REL TYPE loc (get_arr refs) * H refs),p:'ffi ffi_proj)` - (rw[EvalM_def] + ((λrefs. RARRAY_REL TYPE loc (get_arr refs) * H refs),p:'ffi ffi_proj) +Proof + rw[EvalM_def] \\ fs[Eval_def, NUM_def, INT_def] \\ rw[evaluate_def] \\ first_assum(fn x => SIMP_RULE bool_ss [REFS_PRED_def, RARRAY_def, RARRAY_REL_def] x |> ASSUME_TAC) @@ -2108,7 +2215,8 @@ Theorem EvalM_R_Marray_update_handle \\ fs[same_type_def,namespaceTheory.id_to_n_def,same_ctor_def] \\ fs[with_same_ffi] \\ fs[MONAD_def, Marray_update_def, Mupdate_exn_eq] - \\ PURE_REWRITE_TAC[GSYM APPEND_ASSOC, REFS_PRED_FRAME_append]); + \\ PURE_REWRITE_TAC[GSYM APPEND_ASSOC, REFS_PRED_FRAME_append] +QED val HPROP_TO_GC_R = Q.prove(`(A * B) s ==> (A * GC) s`, rw[STAR_def] @@ -2122,8 +2230,8 @@ val HPROP_TO_GC_L = Q.prove(`(A * B) s ==> (GC * B) s`, \\ qexists_tac `v` \\ fs[SAT_GC]); -Theorem EvalM_R_Marray_alloc - `!vname loc TYPE EXC_TYPE H get_arr set_arr n x env nexp xexp. +Theorem EvalM_R_Marray_alloc: + !vname loc TYPE EXC_TYPE H get_arr set_arr n x env nexp xexp. nsLookup env.v (Short vname) = SOME loc ==> (!refs x. get_arr (set_arr x refs) = x) ==> (!refs x. H (set_arr x refs) = H refs) ==> @@ -2131,8 +2239,9 @@ Theorem EvalM_R_Marray_alloc Eval env xexp (TYPE x) ==> EvalM ro env st (App Opassign [Var (Short vname); App Aalloc [nexp; xexp]]) ((MONAD UNIT_TYPE EXC_TYPE) (Marray_alloc set_arr n x)) - ((λrefs. RARRAY_REL TYPE loc (get_arr refs) * H refs),p:'ffi ffi_proj)` - (rw[EvalM_def] + ((λrefs. RARRAY_REL TYPE loc (get_arr refs) * H refs),p:'ffi ffi_proj) +Proof + rw[EvalM_def] \\ fs[Eval_def, NUM_def, INT_def] \\ rw[evaluate_def] \\ first_x_assum(qspec_then `s.refs` STRIP_ASSUME_TAC) @@ -2203,16 +2312,18 @@ Theorem EvalM_R_Marray_alloc \\ fs[Once (GSYM with_same_refs)] \\ first_x_assum(fn x => MATCH_MP STATE_APPEND_JUNK x |> ASSUME_TAC) \\ pop_assum(qspec_then `refs' ++ refs''` ASSUME_TAC) - \\ fs[GSYM STAR_ASSOC, GC_STAR_GC]); + \\ fs[GSYM STAR_ASSOC, GC_STAR_GC] +QED (* Fixed-size arrays *) -Theorem EvalM_F_Marray_length - `!vname loc TYPE EXC_TYPE H get_arr x env. +Theorem EvalM_F_Marray_length: + !vname loc TYPE EXC_TYPE H get_arr x env. nsLookup env.v (Short vname) = SOME loc ==> EvalM ro env st (App Alength [Var (Short vname)]) ((MONAD NUM EXC_TYPE) (Marray_length get_arr)) - ((λrefs. ARRAY_REL TYPE loc (get_arr refs) * H refs),p:'ffi ffi_proj)` - (rw[EvalM_def] + ((λrefs. ARRAY_REL TYPE loc (get_arr refs) * H refs),p:'ffi ffi_proj) +Proof + rw[EvalM_def] \\ fs [evaluate_def] \\ fs[REFS_PRED_def, ARRAY_REL_def] \\ fs[SEP_CLAUSES, SEP_EXISTS_THM] @@ -2225,18 +2336,20 @@ Theorem EvalM_F_Marray_length \\ pop_assum (fn x => fs[x]) \\ fs[MONAD_def, Marray_length_def] \\ imp_res_tac LIST_REL_LENGTH - \\ fs[REFS_PRED_FRAME_same]); + \\ fs[REFS_PRED_FRAME_same] +QED -Theorem EvalM_F_Marray_sub_subscript - `!vname loc TYPE EXC_TYPE H get_arr e env n nexp. +Theorem EvalM_F_Marray_sub_subscript: + !vname loc TYPE EXC_TYPE H get_arr e env n nexp. EXC_TYPE e ^Conv_Subscript ==> nsLookup env.v (Short vname) = SOME loc ==> lookup_cons (Short "Subscript") env = SOME (0,^Stamp_Subscript) ==> Eval env nexp (NUM n) ==> EvalM ro env st (App Asub [Var (Short vname); nexp]) ((MONAD TYPE EXC_TYPE) (Marray_sub get_arr e n)) - ((λrefs. ARRAY_REL TYPE loc (get_arr refs) * H refs),p:'ffi ffi_proj)` - (rw[EvalM_def] + ((λrefs. ARRAY_REL TYPE loc (get_arr refs) * H refs),p:'ffi ffi_proj) +Proof + rw[EvalM_def] \\ fs[Eval_def, NUM_def, INT_def] \\ first_x_assum(fn x => SIMP_RULE bool_ss [REFS_PRED_def, ARRAY_REL_def] x |> ASSUME_TAC) \\ fs[SEP_EXISTS_THM, SEP_CLAUSES] @@ -2264,10 +2377,11 @@ Theorem EvalM_F_Marray_sub_subscript \\ PURE_REWRITE_TAC[GSYM APPEND_ASSOC, REFS_PRED_FRAME_append]) \\ rw[with_same_ffi] \\ qexists_tac `st` - \\ fs[MONAD_def, Marray_sub_def, Msub_exn_eq, REFS_PRED_FRAME_append]); + \\ fs[MONAD_def, Marray_sub_def, Msub_exn_eq, REFS_PRED_FRAME_append] +QED -Theorem EvalM_F_Marray_sub_handle - `!vname loc TYPE EXC_TYPE H get_arr e rexp env n nexp. +Theorem EvalM_F_Marray_sub_handle: + !vname loc TYPE EXC_TYPE H get_arr e rexp env n nexp. nsLookup env.v (Short vname) = SOME loc ==> lookup_cons (Short "Subscript") env = SOME (0,^Stamp_Subscript) ==> Eval env nexp (NUM n) ==> @@ -2275,8 +2389,9 @@ Theorem EvalM_F_Marray_sub_handle EvalM ro env st (Handle (App Asub [Var (Short vname); nexp]) [(Pcon (SOME (Short("Subscript"))) [], Raise rexp)]) ((MONAD TYPE EXC_TYPE) (Marray_sub get_arr e n)) - ((λrefs. ARRAY_REL TYPE loc (get_arr refs) * H refs),p:'ffi ffi_proj)` - (rw[EvalM_def] + ((λrefs. ARRAY_REL TYPE loc (get_arr refs) * H refs),p:'ffi ffi_proj) +Proof + rw[EvalM_def] \\ fs[Eval_def, NUM_def, INT_def] \\ first_x_assum(fn x => SIMP_RULE bool_ss [REFS_PRED_def, ARRAY_REL_def] x |> ASSUME_TAC) \\ fs[SEP_EXISTS_THM, SEP_CLAUSES] @@ -2323,10 +2438,11 @@ Theorem EvalM_F_Marray_sub_handle \\ fs[with_same_ffi] \\ fs[MONAD_def, Marray_sub_def, Msub_exn_eq] \\ PURE_REWRITE_TAC[GSYM APPEND_ASSOC] - \\ rw[REFS_PRED_FRAME_append]); + \\ rw[REFS_PRED_FRAME_append] +QED -Theorem EvalM_F_Marray_update_subscript - `!vname loc TYPE EXC_TYPE H get_arr set_arr e env n x xexp nexp. +Theorem EvalM_F_Marray_update_subscript: + !vname loc TYPE EXC_TYPE H get_arr set_arr e env n x xexp nexp. nsLookup env.v (Short vname) = SOME loc ==> lookup_cons (Short "Subscript") env = SOME (0,^Stamp_Subscript) ==> EXC_TYPE e ^Conv_Subscript ==> @@ -2336,8 +2452,9 @@ Theorem EvalM_F_Marray_update_subscript Eval env xexp (TYPE x) ==> EvalM ro env st (App Aupdate [Var (Short vname); nexp; xexp]) ((MONAD UNIT_TYPE EXC_TYPE) (Marray_update get_arr set_arr e n x)) - ((λrefs. ARRAY_REL TYPE loc (get_arr refs) * H refs),p:'ffi ffi_proj)` - (rw[EvalM_def] + ((λrefs. ARRAY_REL TYPE loc (get_arr refs) * H refs),p:'ffi ffi_proj) +Proof + rw[EvalM_def] \\ fs[Eval_def, NUM_def, INT_def] \\ rw[evaluate_def] \\ pop_assum(fn x => SIMP_RULE bool_ss [REFS_PRED_def, ARRAY_REL_def] x |> ASSUME_TAC) @@ -2404,10 +2521,11 @@ Theorem EvalM_F_Marray_update_subscript \\ fs[with_same_ffi] \\ qexists_tac `st` \\ fs[MONAD_def,Marray_update_def,Mupdate_exn_eq,EVAL ``sub_exn_v``] - \\ metis_tac[REFS_PRED_FRAME_append, GSYM APPEND_ASSOC]); + \\ metis_tac[REFS_PRED_FRAME_append, GSYM APPEND_ASSOC] +QED -Theorem EvalM_F_Marray_update_handle - `!vname loc TYPE EXC_TYPE H get_arr set_arr e rexp env n x xexp nexp. +Theorem EvalM_F_Marray_update_handle: + !vname loc TYPE EXC_TYPE H get_arr set_arr e rexp env n x xexp nexp. nsLookup env.v (Short vname) = SOME loc ==> lookup_cons (Short "Subscript") env = SOME (0,^Stamp_Subscript) ==> (!refs x. get_arr (set_arr x refs) = x) ==> @@ -2418,8 +2536,9 @@ Theorem EvalM_F_Marray_update_handle EvalM ro env st (Handle (App Aupdate [Var (Short vname); nexp; xexp]) [(Pcon (SOME (Short("Subscript"))) [], Raise rexp)]) ((MONAD UNIT_TYPE EXC_TYPE) (Marray_update get_arr set_arr e n x)) - ((λrefs. ARRAY_REL TYPE loc (get_arr refs) * H refs),p:'ffi ffi_proj)` - (rw[EvalM_def] + ((λrefs. ARRAY_REL TYPE loc (get_arr refs) * H refs),p:'ffi ffi_proj) +Proof + rw[EvalM_def] \\ fs[Eval_def, NUM_def, INT_def] \\ rw[evaluate_def] \\ pop_assum(fn x => SIMP_RULE bool_ss [REFS_PRED_def, ARRAY_REL_def] x |> ASSUME_TAC) @@ -2493,7 +2612,8 @@ Theorem EvalM_F_Marray_update_handle \\ rw[pat_bindings_def] \\ rw[pmatch_def] \\ fs[MONAD_def, Marray_update_def, Mupdate_exn_eq] - \\ PURE_REWRITE_TAC[GSYM APPEND_ASSOC, REFS_PRED_FRAME_append]); + \\ PURE_REWRITE_TAC[GSYM APPEND_ASSOC, REFS_PRED_FRAME_append] +QED (* TODO: implement support for 2d arrays *) val ARRAY2D_def = Define ` @@ -2506,8 +2626,8 @@ val RARRAY2D_def = Define ` (* translation of cases and cons terms *) -Theorem IMP_EvalM_Mat_cases - `!st a (r1:'b) env exp r2 y. +Theorem IMP_EvalM_Mat_cases: + !st a (r1:'b) env exp r2 y. Eval env exp (a r1) /\ (case y of | INL (vars,exp) => @@ -2526,8 +2646,9 @@ Theorem IMP_EvalM_Mat_cases LENGTH vals = LENGTH vars /\ EvalM ro (write_list (ZIP (vars,vals)) env) st exp r2 H)) ==> - EvalM ro env st (Mat exp (Mat_cases y)) r2 H` - (rpt gen_tac \\ Cases_on `y` + EvalM ro env st (Mat exp (Mat_cases y)) r2 H +Proof + rpt gen_tac \\ Cases_on `y` THEN1 (Cases_on `x` \\ fs [EvalM_def,EXISTS_MEM,EXISTS_PROD,Eval_def] @@ -2592,7 +2713,8 @@ Theorem IMP_EvalM_Mat_cases \\ `same_type t t /\ same_ctor t t` by (Cases_on `t` \\ EVAL_TAC) \\ fs [] \\ drule pmatch_list_MAP_Pvar \\ CONV_TAC (DEPTH_CONV ETA_CONV) \\ fs [] - \\ fs [GSYM write_list_thm]); + \\ fs [GSYM write_list_thm] +QED (* * Run @@ -2661,9 +2783,10 @@ val REFS_PRED_FRAME_partial_frame_rule = Q.prove( \\ imp_res_tac IS_PREFIX_APPEND \\ rw[]); -Theorem EvalSt_to_Eval - `EvalSt env st exp P ((\s. emp),p) ==> Eval env exp P` - (rw[EvalSt_def, Eval_def] +Theorem EvalSt_to_Eval: + EvalSt env st exp P ((\s. emp),p) ==> Eval env exp P +Proof + rw[EvalSt_def, Eval_def] \\ fs[REFS_PRED_def, SEP_CLAUSES, SAT_GC] \\ first_x_assum(qspecl_then [`empty_state with refs := refs`] STRIP_ASSUME_TAC) @@ -2677,7 +2800,8 @@ Theorem EvalSt_to_Eval \\ qexists_tac `res` \\ fs [] \\ qexists_tac `junk` \\ fs [] \\ qexists_tac `ck` \\ fs [] - \\ fs[state_component_equality]); + \\ fs[state_component_equality] +QED val handle_mult_def = Define ` handle_mult [] exp1 ename = exp1 /\ @@ -2759,15 +2883,16 @@ val EXC_TYPE_aux_def = Define ` ∃v1_1. v = Conv (SOME (TypeStamp "Success" stamp)) [v1_1] ∧ a x_1 v1_1)`; -Theorem EvalM_to_EvalSt ` - ∀exc_stamp TYPE EXN_TYPE x exp H init_state env. +Theorem EvalM_to_EvalSt: + ∀exc_stamp TYPE EXN_TYPE x exp H init_state env. EvalM T env init_state exp (MONAD TYPE EXN_TYPE x) H ⇒ lookup_cons (Short "Success") env = SOME (1, TypeStamp "Success" exc_stamp) ⇒ lookup_cons (Short "Failure") env = SOME (1, TypeStamp "Failure" exc_stamp) ⇒ EvalSt env init_state (handle_all (Con (SOME (Short "Success")) [exp]) "Failure") - (EXC_TYPE_aux exc_stamp TYPE EXN_TYPE (run x init_state)) H` - (rw[EvalM_def, EvalSt_def] + (EXC_TYPE_aux exc_stamp TYPE EXN_TYPE (run x init_state)) H +Proof + rw[EvalM_def, EvalSt_def] \\ first_x_assum drule \\ rw[] \\ Cases_on `res` (* res is an Rval *) @@ -2805,17 +2930,20 @@ Theorem EvalM_to_EvalSt ` \\ fs[do_con_check_def, build_conv_def, namespaceTheory.nsOptBind_def, write_def,lookup_cons_def,PULL_EXISTS,pat_bindings_def,pmatch_def] \\ every_case_tac \\ fs [] - \\ rw[EXC_TYPE_aux_def, run_def]); - -Theorem EvalSt_Let_Fun - `EvalSt (write vname (Closure env xv fexp) env) st exp P H ==> - EvalSt env st (Let (SOME vname) (Fun xv fexp) exp) P H` - (rw[EvalSt_def] + \\ rw[EXC_TYPE_aux_def, run_def] +QED + +Theorem EvalSt_Let_Fun: + EvalSt (write vname (Closure env xv fexp) env) st exp P H ==> + EvalSt env st (Let (SOME vname) (Fun xv fexp) exp) P H +Proof + rw[EvalSt_def] \\ last_x_assum imp_res_tac \\ rw[evaluate_def] \\ rw[namespaceTheory.nsOptBind_def] \\ fs[write_def, merge_env_def] - \\ metis_tac[]); + \\ metis_tac[] +QED val nsAppend_build_rec_env_eq_lemma = Q.prove( `!funs funs0 cl_env v0 v1. @@ -2845,35 +2973,41 @@ val merge_build_rec_env = Q.prove( build_rec_env funs (merge_env env1 env0) (merge_env env1 env0).v`, fs[merge_env_def, nsAppend_build_rec_env_eq]); -Theorem EvalSt_Letrec_Fun - `!funs env exp st P H. +Theorem EvalSt_Letrec_Fun: + !funs env exp st P H. (ALL_DISTINCT (MAP (\(x,y,z). x) funs)) ==> EvalSt <|v := (build_rec_env funs env env.v); c := env.c|> st exp P H ==> - EvalSt env st (Letrec funs exp) P H` - (rw[EvalSt_def] + EvalSt env st (Letrec funs exp) P H +Proof + rw[EvalSt_def] \\ qpat_x_assum `!s. A` imp_res_tac \\ rw[evaluate_def] \\ `<|v := build_rec_env funs env env.v; c := env.c|> = env with v := build_rec_env funs env env.v` by fs[sem_env_component_equality] \\ fs[] - \\ metis_tac[]); + \\ metis_tac[] +QED -Theorem merge_env_bind_empty - `merge_env <| v := Bind [] []; c := Bind [] [] |> env = env` - (rw[merge_env_def] +Theorem merge_env_bind_empty: + merge_env <| v := Bind [] []; c := Bind [] [] |> env = env +Proof + rw[merge_env_def] \\ Cases_on `env` \\ Cases_on `n` \\ Cases_on `n0` - \\ rw[namespaceTheory.nsAppend_def, sem_env_component_equality]); - -Theorem Bind_list_to_write - `merge_env <|v := Bind ((vname, v)::binds) []; c := Bind [] []|> env = - write vname v (merge_env <|v := Bind binds []; c := Bind [] []|> env)` - (rw[merge_env_def, write_def] + \\ rw[namespaceTheory.nsAppend_def, sem_env_component_equality] +QED + +Theorem Bind_list_to_write: + merge_env <|v := Bind ((vname, v)::binds) []; c := Bind [] []|> env = + write vname v (merge_env <|v := Bind binds []; c := Bind [] []|> env) +Proof + rw[merge_env_def, write_def] \\ Cases_on `env` \\ rw[] \\ Cases_on `n` - \\ rw[namespaceTheory.nsAppend_def, namespaceTheory.nsBind_def]); + \\ rw[namespaceTheory.nsAppend_def, namespaceTheory.nsBind_def] +QED val evaluate_Var_IMP = Q.prove( `evaluate s1 env [Var (Short name)] = (s2, Rval [v]) ==> @@ -2885,14 +3019,15 @@ val evaluate_Var_same_state = Q.prove( evaluate s1 env [Var (Short name)] = (s2, res) /\ s2 = s1`, EQ_TAC \\ rw[evaluate_def] \\ every_case_tac \\ fs []); -Theorem EvalSt_Opref - `!exp get_ref_exp get_ref loc_name TYPE st_name env H P st. +Theorem EvalSt_Opref: + !exp get_ref_exp get_ref loc_name TYPE st_name env H P st. Eval env get_ref_exp (TYPE (get_ref st)) ==> (!loc. EvalSt (write loc_name loc env) st exp P ((\st. REF_REL TYPE loc (get_ref st) * H st),p)) ==> EvalSt env st - (Let (SOME loc_name) (App Opref [get_ref_exp]) exp) P (H,p)` - (rw[EvalSt_def] + (Let (SOME loc_name) (App Opref [get_ref_exp]) exp) P (H,p) +Proof + rw[EvalSt_def] \\ rw[evaluate_def] \\ fs[Eval_def] \\ fs[PULL_EXISTS] @@ -2963,20 +3098,22 @@ Theorem EvalSt_Opref \\ first_x_assum(fn x => PURE_ONCE_REWRITE_RULE[STAR_COMM] x |> ASSUME_TAC) \\ fs[STAR_ASSOC] \\ first_x_assum(fn x => MATCH_MP GC_ABSORB_R x |> ASSUME_TAC) - \\ fs[]); + \\ fs[] +QED val EQ_def = Define `EQ x y <=> x = y`; -Theorem EvalSt_AllocEmpty - `!exp get_ref loc_name TYPE st_name env H P st. +Theorem EvalSt_AllocEmpty: + !exp get_ref loc_name TYPE st_name env H P st. EQ (get_ref st) [] ==> (!loc. EvalSt (write loc_name loc env) st exp P ((\st. RARRAY_REL TYPE loc (get_ref st) * H st),p)) ==> EvalSt env st (Let (SOME loc_name) (App Opref [App AallocEmpty [Con NONE []]]) exp) - P (H,p)` - (rw[EvalSt_def,evaluate_def] + P (H,p) +Proof + rw[EvalSt_def,evaluate_def] \\ fs[PULL_EXISTS] \\ fs[do_con_check_def, build_conv_def] \\ rw[do_app_def,store_alloc_def,namespaceTheory.nsOptBind_def] @@ -3031,18 +3168,20 @@ Theorem EvalSt_AllocEmpty \\ first_x_assum(fn x => PURE_ONCE_REWRITE_RULE[STAR_COMM] x |> ASSUME_TAC) \\ fs[STAR_ASSOC] \\ first_x_assum(fn x => MATCH_MP GC_ABSORB_R x |> ASSUME_TAC) - \\ fs[]); + \\ fs[] +QED -Theorem EvalSt_Alloc - `!exp nexp n xexp x get_farray loc_name TYPE env H P st. +Theorem EvalSt_Alloc: + !exp nexp n xexp x get_farray loc_name TYPE env H P st. EQ (get_farray st) (REPLICATE n x) ==> Eval env nexp (\v. v = Litv (IntLit (&n))) ==> Eval env xexp (TYPE x) ==> (!loc. EvalSt (write loc_name loc env) st exp P ((\st. ARRAY_REL TYPE loc (get_farray st) * H st),p)) ==> - EvalSt env st (Let (SOME loc_name) (App Aalloc [nexp; xexp]) exp) P (H,p)` - (rw[EvalSt_def,evaluate_def] + EvalSt env st (Let (SOME loc_name) (App Aalloc [nexp; xexp]) exp) P (H,p) +Proof + rw[EvalSt_def,evaluate_def] \\ fs[PULL_EXISTS] \\ fs[Eval_def] \\ first_x_assum(qspec_then `s.refs` STRIP_ASSUME_TAC) @@ -3111,12 +3250,15 @@ Theorem EvalSt_Alloc \\ first_x_assum(fn x => REWRITE_RULE[Once STAR_COMM] x |> ASSUME_TAC) \\ fs[STAR_ASSOC] \\ first_x_assum(fn x => MATCH_MP GC_ABSORB_R x |> ASSUME_TAC) - \\ fs[]); + \\ fs[] +QED -Theorem Eval_lookup_var - `!env vname xv x TYPE. nsLookup env.v (Short vname) = SOME xv ==> - (Eval env (Var (Short vname)) (TYPE x) <=> TYPE x xv)` - (rw[Eval_def,eval_rel_def,evaluate_def,state_component_equality]); +Theorem Eval_lookup_var: + !env vname xv x TYPE. nsLookup env.v (Short vname) = SOME xv ==> + (Eval env (Var (Short vname)) (TYPE x) <=> TYPE x xv) +Proof + rw[Eval_def,eval_rel_def,evaluate_def,state_component_equality] +QED val nsBind_to_write = Q.prove( `<|v := nsBind name v env1; c := env2|> = @@ -3156,23 +3298,47 @@ val EVAL_T_F = save_thm("EVAL_T_F", val EVAL_PRECONDITION_T = save_thm("EVAL_PRECONDITION_T", EVAL (``ml_translator$PRECONDITION T``)); -Theorem H_STAR_emp - `H * emp = H` (simp[SEP_CLAUSES]); - -Theorem H_STAR_TRUE - `(H * &T = H) /\ (&T * H = H)` (fs[SEP_CLAUSES]); - -Theorem PreImp_PRECONDITION_T_SIMP - `PreImp T a /\ PRECONDITION T <=> a` - (fs[PreImp_def, PRECONDITION_def]); - -Theorem IF_T `(if T then x else y) = x:'a` (SIMP_TAC std_ss []); - -Theorem IF_F `(if F then x else y) = y:'a` (SIMP_TAC std_ss []); - -Theorem IMP_EQ_T `a ==> (a <=> T)` (fs []); - -Theorem BETA_PAIR_THM `(\(x, y). f x y) (x, y) = (\x y. f x y) x y` (fs[]); +Theorem H_STAR_emp: + H * emp = H +Proof +simp[SEP_CLAUSES] +QED + +Theorem H_STAR_TRUE: + (H * &T = H) /\ (&T * H = H) +Proof +fs[SEP_CLAUSES] +QED + +Theorem PreImp_PRECONDITION_T_SIMP: + PreImp T a /\ PRECONDITION T <=> a +Proof + fs[PreImp_def, PRECONDITION_def] +QED + +Theorem IF_T: + (if T then x else y) = x:'a +Proof +SIMP_TAC std_ss [] +QED + +Theorem IF_F: + (if F then x else y) = y:'a +Proof +SIMP_TAC std_ss [] +QED + +Theorem IMP_EQ_T: + a ==> (a <=> T) +Proof +fs [] +QED + +Theorem BETA_PAIR_THM: + (\(x, y). f x y) (x, y) = (\x y. f x y) x y +Proof +fs[] +QED (* Terms used by the ml_monad_translatorLib *) val parsed_terms = save_thm("parsed_terms", diff --git a/translator/monadic/monad_base/ml_monadBaseScript.sml b/translator/monadic/monad_base/ml_monadBaseScript.sml index 5cc993e23c..7a2289270a 100644 --- a/translator/monadic/monad_base/ml_monadBaseScript.sml +++ b/translator/monadic/monad_base/ml_monadBaseScript.sml @@ -111,19 +111,23 @@ val Msub_def = Define ` [] => Failure e | x::l' => if n = 0 then Success x else Msub e (n-1) l'`; -Theorem Msub_eq - `!l n e. n < LENGTH l ==> (Msub e n l = Success (EL n l))` - (Induct +Theorem Msub_eq: + !l n e. n < LENGTH l ==> (Msub e n l = Success (EL n l)) +Proof + Induct \\ rw[Once Msub_def] \\ Cases_on `n` - \\ fs[]); + \\ fs[] +QED -Theorem Msub_exn_eq - `!l n e. n >= LENGTH l ==> (Msub e n l = Failure e)` - (Induct +Theorem Msub_exn_eq: + !l n e. n >= LENGTH l ==> (Msub e n l = Failure e) +Proof + Induct \\ rw[Once Msub_def] \\ Cases_on `n` - \\ fs[]); + \\ fs[] +QED (* Mupdate *) val Mupdate_def = Define ` @@ -138,19 +142,23 @@ val Mupdate_def = Define ` Success l'' => Success (x'::l'') | other => other)`; -Theorem Mupdate_eq - `!l n x e. n < LENGTH l ==> (Mupdate e x n l = Success (LUPDATE x n l))` - (Induct +Theorem Mupdate_eq: + !l n x e. n < LENGTH l ==> (Mupdate e x n l = Success (LUPDATE x n l)) +Proof + Induct \\ rw[Once Mupdate_def, LUPDATE_def] \\ Cases_on `n` - \\ fs[LUPDATE_def]); + \\ fs[LUPDATE_def] +QED -Theorem Mupdate_exn_eq - `!l n x e. n >= LENGTH l ==> (Mupdate e x n l = Failure e)` - (Induct +Theorem Mupdate_exn_eq: + !l n x e. n >= LENGTH l ==> (Mupdate e x n l = Failure e) +Proof + Induct \\ rw[Once Mupdate_def, LUPDATE_def] \\ Cases_on `n` - \\ fs[LUPDATE_def]); + \\ fs[LUPDATE_def] +QED (* Array resize *) val array_resize_def = Define ` @@ -162,9 +170,11 @@ val array_resize_def = Define ` [] => x::array_resize (n-1) x a | x'::a' => x'::array_resize (n-1) x a'`; -Theorem array_resize_eq - `!a n x. array_resize n x a = TAKE n a ++ REPLICATE (n - LENGTH a) x` - (Induct \\ Induct_on `n` \\ rw [Once array_resize_def]); +Theorem array_resize_eq: + !a n x. array_resize n x a = TAKE n a ++ REPLICATE (n - LENGTH a) x +Proof + Induct \\ Induct_on `n` \\ rw [Once array_resize_def] +QED (* User functions *) val Marray_length_def = Define ` @@ -233,26 +243,31 @@ val Mref_assign_def = Define ` val ref_assign_def = Define ` ref_assign n x = \s. LUPDATE x (LENGTH s - n - 1) s`; -Theorem dref_cons_state - `n < LENGTH state ==> (dref n (x::state) = dref n state)` - (rw[Once dref_def] +Theorem dref_cons_state: + n < LENGTH state ==> (dref n (x::state) = dref n state) +Proof + rw[Once dref_def] \\ fs[SUC_ONE_ADD] \\ Cases_on `LENGTH state - n` >-(fs[]) \\ rw[] \\ rw[Once dref_def] \\ `LENGTH state - (n + 1) = LENGTH state - n - 1` by numLib.DECIDE_TAC - \\ POP_ASSUM(fn x => rw[x])); + \\ POP_ASSUM(fn x => rw[x]) +QED -Theorem dref_first - `dref (LENGTH s) (r::s) = r` - (fs[Once dref_def, SUC_ONE_ADD]); +Theorem dref_first: + dref (LENGTH s) (r::s) = r +Proof + fs[Once dref_def, SUC_ONE_ADD] +QED -Theorem Mdref_eq - `!state n. +Theorem Mdref_eq: + !state n. n < LENGTH state ==> - (Mdref e (StoreRef n) state = (Success(dref n state), state))` - (Induct + (Mdref e (StoreRef n) state = (Success(dref n state), state)) +Proof + Induct \\ rw[Once Mdref_def, Once Mdref_aux_def] >-(rw[Once dref_def] \\ fs[] @@ -264,15 +279,17 @@ Theorem Mdref_eq by (last_x_assum(fn x => ALL_TAC) \\ rw[Once Mdref_def]) \\ POP_ASSUM(fn x => PURE_REWRITE_TAC[x]) \\ rw[] - \\ rw[dref_cons_state]); + \\ rw[dref_cons_state] +QED -Theorem Mref_assign_aux_eq - `!state e n x. +Theorem Mref_assign_aux_eq: + !state e n x. n < LENGTH state ==> (Mref_assign_aux e (LENGTH state - n - 1) x state = - Success (ref_assign n x state))` - (Induct + Success (ref_assign n x state)) +Proof + Induct \\ rw[Once Mref_assign_aux_def, Once ref_assign_def] >-(rw[SUC_ONE_ADD] >> Cases_on `LENGTH state - n` >-(rw[LUPDATE_def]) @@ -284,16 +301,19 @@ Theorem Mref_assign_aux_eq \\ rw[Once ref_assign_def] \\ rw[LUPDATE_def] \\ `LENGTH state - (n + 1) = n'` by fs[SUC_ONE_ADD] - \\ rw[]); + \\ rw[] +QED -Theorem Mref_assign_eq - `!state e n x. +Theorem Mref_assign_eq: + !state e n x. n < LENGTH state ==> - (Mref_assign e (StoreRef n) x state = (Success(), ref_assign n x state))` - (rw[Once Mref_assign_def] + (Mref_assign e (StoreRef n) x state = (Success(), ref_assign n x state)) +Proof + rw[Once Mref_assign_def] \\ IMP_RES_TAC Mref_assign_aux_eq - \\ fs[]); + \\ fs[] +QED val ref_bind_def = Define ` ref_bind create f pop = diff --git a/translator/okasaki-examples/BinomialHeapScript.sml b/translator/okasaki-examples/BinomialHeapScript.sml index 222ab2151d..718bc97f1e 100644 --- a/translator/okasaki-examples/BinomialHeapScript.sml +++ b/translator/okasaki-examples/BinomialHeapScript.sml @@ -138,39 +138,46 @@ rw [is_heap_ordered_def] >> fs [is_heap_ordered_def, BAG_EVERY, heap_to_bag_def] >> metis_tac [WeakLinearOrder, WeakOrder, transitive_def, WeakLinearOrder_neg]); -Theorem insert_bag -`!get_key leq s h. - heap_to_bag (insert get_key leq s h) = BAG_INSERT s (heap_to_bag h)` -(rw [insert_def, ins_bag, heap_to_bag_def, BAG_INSERT_UNION]); - -Theorem insert_heap_ordered -`!get_key leq x h. +Theorem insert_bag: + !get_key leq s h. + heap_to_bag (insert get_key leq s h) = BAG_INSERT s (heap_to_bag h) +Proof +rw [insert_def, ins_bag, heap_to_bag_def, BAG_INSERT_UNION] +QED + +Theorem insert_heap_ordered: + !get_key leq x h. WeakLinearOrder leq ∧ is_heap_ordered get_key leq h ⇒ - is_heap_ordered get_key leq (insert get_key leq x h)` -(rw [insert_def, is_heap_ordered_def] >> + is_heap_ordered get_key leq (insert get_key leq x h) +Proof +rw [insert_def, is_heap_ordered_def] >> match_mp_tac ins_heap_ordered >> -rw [is_heap_ordered_def, BAG_EVERY, heap_to_bag_def]); +rw [is_heap_ordered_def, BAG_EVERY, heap_to_bag_def] +QED -Theorem merge_bag -`!get_key leq h1 h2. +Theorem merge_bag: + !get_key leq h1 h2. heap_to_bag (merge get_key leq h1 h2) = - BAG_UNION (heap_to_bag h1) (heap_to_bag h2)` -(HO_MATCH_MP_TAC merge_ind >> + BAG_UNION (heap_to_bag h1) (heap_to_bag h2) +Proof +HO_MATCH_MP_TAC merge_ind >> srw_tac [BAG_ss] [merge_def, heap_to_bag_def, BAG_INSERT_UNION, ins_bag] >> cases_on `t1` >> cases_on `t2` >> -srw_tac [BAG_ss] [link_def, heap_to_bag_def, BAG_INSERT_UNION]); +srw_tac [BAG_ss] [link_def, heap_to_bag_def, BAG_INSERT_UNION] +QED -Theorem merge_heap_ordered -`!get_key leq h1 h2. +Theorem merge_heap_ordered: + !get_key leq h1 h2. WeakLinearOrder leq ∧ is_heap_ordered get_key leq h1 ∧ is_heap_ordered get_key leq h2 ⇒ - is_heap_ordered get_key leq (merge get_key leq h1 h2)` -(HO_MATCH_MP_TAC merge_ind >> + is_heap_ordered get_key leq (merge get_key leq h1 h2) +Proof +HO_MATCH_MP_TAC merge_ind >> rw [merge_def, is_heap_ordered_def, heap_to_bag_def] >> fs [] >> match_mp_tac ins_heap_ordered >> @@ -179,7 +186,8 @@ cases_on `t1` >> cases_on `t2` >> rw [link_def, is_heap_ordered_def, BAG_EVERY] >> fs [is_heap_ordered_def, BAG_EVERY, heap_to_bag_def] >> -metis_tac [WeakLinearOrder, WeakOrder, transitive_def, WeakLinearOrder_neg]); +metis_tac [WeakLinearOrder, WeakOrder, transitive_def, WeakLinearOrder_neg] +QED val remove_min_tree = Q.prove ( `∀get_key leq h t h'. @@ -251,22 +259,24 @@ full_simp_tac (srw_ss()++BAG_ss) transitive_def] ]); -Theorem find_min_correct -`!h get_key leq. +Theorem find_min_correct: + !h get_key leq. WeakLinearOrder leq ∧ (h ≠ []) ∧ is_heap_ordered get_key leq h ⇒ BAG_IN (find_min get_key leq h) (heap_to_bag h) ∧ (!y. BAG_IN y (heap_to_bag h) ⇒ - leq (get_key (find_min get_key leq h)) (get_key y))` -(rw [find_min_def] >> + leq (get_key (find_min get_key leq h)) (get_key y)) +Proof +rw [find_min_def] >> `(heap_to_bag h = BAG_UNION (heap_to_bag ts') (tree_to_bag t)) ∧ (∀y. y ⋲ heap_to_bag ts' ⇒ leq (get_key (root t)) (get_key y)) ∧ (is_heap_ordered_tree get_key leq t)` by metis_tac [remove_min_tree] >> cases_on `t` >> fs [BAG_EVERY, heap_to_bag_def, root_def, is_heap_ordered_def] >> -metis_tac [WeakLinearOrder, WeakOrder, reflexive_def]); +metis_tac [WeakLinearOrder, WeakOrder, reflexive_def] +QED val reverse_heap_ordered = Q.prove ( `!get_key leq l. @@ -290,14 +300,15 @@ val reverse_bag = Q.prove ( induct_on `l` >> srw_tac [BAG_ss] [append_bag, heap_to_bag_def]); -Theorem delete_min_correct -`!h get_key leq. +Theorem delete_min_correct: + !h get_key leq. WeakLinearOrder leq ∧ (h ≠ []) ∧ is_heap_ordered get_key leq h ⇒ is_heap_ordered get_key leq (delete_min get_key leq h) ∧ (heap_to_bag (delete_min get_key leq h) = - BAG_DIFF (heap_to_bag h) (EL_BAG (find_min get_key leq h)))` -(rw [delete_min_def] >> + BAG_DIFF (heap_to_bag h) (EL_BAG (find_min get_key leq h))) +Proof +rw [delete_min_def] >> every_case_tac >> rw [merge_bag, reverse_bag] >- metis_tac [reverse_heap_ordered, merge_heap_ordered, remove_min_tree, @@ -309,7 +320,8 @@ rw [root_def] >> rw [heap_to_bag_def, BAG_DIFF, BAG_INSERT, EL_BAG, FUN_EQ_THM, EMPTY_BAG, BAG_UNION] >> cases_on `x = a` >> -srw_tac [ARITH_ss] []); +srw_tac [ARITH_ss] [] +QED (* Verify size and shape invariants *) @@ -341,9 +353,10 @@ cases_on `x = 0`>> fs [arithmeticTheory.ADD1, arithmeticTheory.EXP_ADD, arithmeticTheory.MOD_EQ_0]); -Theorem is_binomial_tree_size -`!t. is_binomial_tree t ⇒ (heap_tree_size t = 2 ** rank t)` -(recInduct is_binomial_tree_ind >> +Theorem is_binomial_tree_size: + !t. is_binomial_tree t ⇒ (heap_tree_size t = 2 ** rank t) +Proof +recInduct is_binomial_tree_ind >> rw [heap_size_def, rank_def, is_binomial_tree_def] >> fs [] >> `1 + (2 ** (r − 1) + heap_size ts) = 2 ** (r − 1) + (1 + heap_size ts)` @@ -351,7 +364,8 @@ fs [] >> rw [] >> `1 ≤ r` by decide_tac >> rw [arithmeticTheory.EXP_SUB, GSYM arithmeticTheory.TIMES2, - bitTheory.DIV_MULT_THM2, exp2_mod2]); + bitTheory.DIV_MULT_THM2, exp2_mod2] +QED val is_binomial_heap_def = Define ` is_binomial_heap h <=> @@ -405,16 +419,17 @@ fs [is_binomial_heap_def, MEM_MAP] >> metis_tac [DECIDE ``!(x:num) y . x < y ==> x < y + 1``, DECIDE ``!(x:num) y . x < y ==> x + 1 ≤ y``]); -Theorem merge_binomial_heap -`!get_key leq h1 h2. +Theorem merge_binomial_heap: + !get_key leq h1 h2. is_binomial_heap h1 ∧ is_binomial_heap h2 ⇒ is_binomial_heap (merge get_key leq h1 h2) ∧ (!r. EVERY (\t. r < rank t) h1 ∧ EVERY (\t. r < rank t) h2 ⇒ - EVERY (\t. r < rank t) (merge get_key leq h1 h2))` -(recInduct merge_ind >> + EVERY (\t. r < rank t) (merge get_key leq h1 h2)) +Proof +recInduct merge_ind >> rw [is_binomial_heap_def, merge_def, trans_less, SORTED_EQ, is_binomial_tree_def] >> fs [MEM_MAP, EVERY_MEM] >> @@ -438,14 +453,17 @@ metis_tac [is_binomial_heap_def, EVERY_MEM, ins_binomial_heap] >> (merge get_key leq ts1 ts2))` by metis_tac [ins_binomial_heap] >> fs [EVERY_MEM] >> -metis_tac [DECIDE ``!(x:num) y . x < y ==> x < y + 1``]); - -Theorem insert_binomial_heap -`!get_key leq x h. - is_binomial_heap h ⇒ is_binomial_heap (insert get_key leq x h)` -(rw [insert_def] >> +metis_tac [DECIDE ``!(x:num) y . x < y ==> x < y + 1``] +QED + +Theorem insert_binomial_heap: + !get_key leq x h. + is_binomial_heap h ⇒ is_binomial_heap (insert get_key leq x h) +Proof +rw [insert_def] >> `is_binomial_tree (Node 0 x [])` by rw [is_binomial_tree_def] >> -metis_tac [ins_binomial_heap, rank_def, DECIDE ``!(x:num). 0 ≤ x``]); +metis_tac [ins_binomial_heap, rank_def, DECIDE ``!(x:num). 0 ≤ x``] +QED val remove_min_binomial_heap = Q.prove ( `!get_key leq h t h'. @@ -484,17 +502,19 @@ rw [trans_less, SORTED_DEF, sorted_reverse, rich_listTheory.MAP_REVERSE, `(\(x:num) y. x > y) = $>` by metis_tac [] >> rw []); -Theorem delete_min_binomial_heap -`!get_key leq h. +Theorem delete_min_binomial_heap: + !get_key leq h. (h ≠ []) ∧ is_binomial_heap h ⇒ - is_binomial_heap (delete_min get_key leq h)` -(rw [delete_min_def] >> + is_binomial_heap (delete_min get_key leq h) +Proof +rw [delete_min_def] >> cases_on `remove_min_tree get_key leq h` >> rw [] >> cases_on `q` >> rw [] >> -metis_tac [delete_lem, merge_binomial_heap, remove_min_binomial_heap]); +metis_tac [delete_lem, merge_binomial_heap, remove_min_binomial_heap] +QED (* Simplify the side conditions on the generated certificate theorems *) diff --git a/translator/okasaki-examples/BottomUpMergeSortScript.sml b/translator/okasaki-examples/BottomUpMergeSortScript.sml index addba87c0a..08c5274aa1 100644 --- a/translator/okasaki-examples/BottomUpMergeSortScript.sml +++ b/translator/okasaki-examples/BottomUpMergeSortScript.sml @@ -191,24 +191,28 @@ rw [] >| [Once add_seg_def, sortable_to_bag_def, mrg_bag, mrg_length, arithmeticTheory.SUB_PLUS]]); -Theorem add_bag -`!leq x size segs. +Theorem add_bag: + !leq x size segs. sortable_inv leq (size,segs) 1 ⇒ (sortable_to_bag (add leq x (size, segs)) = - BAG_INSERT x (sortable_to_bag (size, segs)))` -(rw [add_def] >> + BAG_INSERT x (sortable_to_bag (size, segs))) +Proof +rw [add_def] >> ASSUME_TAC (Q.SPECL [`leq`, `size`, `segs`, `1`, `[x]`] add_seg_bag) >> -fs [list_to_bag_def, BAG_INSERT_UNION]); +fs [list_to_bag_def, BAG_INSERT_UNION] +QED -Theorem add_correct -`!leq x size segs. +Theorem add_correct: + !leq x size segs. WeakLinearOrder leq ∧ sortable_inv leq (size,segs) 1 ⇒ - sortable_inv leq (add leq x (size,segs)) 1` -(rw [add_def] >> + sortable_inv leq (add leq x (size,segs)) 1 +Proof +rw [add_def] >> match_mp_tac add_seg_sub_inv >> -rw [SORTED_DEF]); +rw [SORTED_DEF] +QED val mrg_all_sorted = Q.prove ( `!leq xs segs. @@ -226,24 +230,28 @@ induct_on `segs` >> rw [mrg_all_def] >> metis_tac [mrg_perm, PERM_CONG, PERM_REFL, PERM_TRANS]); -Theorem sort_sorted -`!leq size segs. +Theorem sort_sorted: + !leq size segs. WeakLinearOrder leq ∧ sortable_inv leq (size,segs) 1 ⇒ - SORTED leq (sort leq (size,segs))` -(rw [sort_def] >> -metis_tac [sortable_inv_sorted, SORTED_DEF, mrg_all_sorted]); + SORTED leq (sort leq (size,segs)) +Proof +rw [sort_def] >> +metis_tac [sortable_inv_sorted, SORTED_DEF, mrg_all_sorted] +QED val sortable_to_bag_lem = Q.prove ( `!size segs. sortable_to_bag (size,segs) = list_to_bag (FLAT segs)`, induct_on `segs` >> rw [sortable_to_bag_def, list_to_bag_def, list_to_bag_append]); -Theorem sort_bag -`!leq x size segs. - list_to_bag (sort leq (size,segs)) = sortable_to_bag (size,segs)` -(rw [sort_def, sortable_to_bag_lem, list_to_bag_perm] >> -metis_tac [mrg_all_perm, APPEND]); +Theorem sort_bag: + !leq x size segs. + list_to_bag (sort leq (size,segs)) = sortable_to_bag (size,segs) +Proof +rw [sort_def, sortable_to_bag_lem, list_to_bag_perm] >> +metis_tac [mrg_all_perm, APPEND] +QED (* Simplify the side conditions on the generated certificate theorems, based on diff --git a/translator/okasaki-examples/LazyPairingHeapScript.sml b/translator/okasaki-examples/LazyPairingHeapScript.sml index a5ec90f642..5aa1f7a5b2 100644 --- a/translator/okasaki-examples/LazyPairingHeapScript.sml +++ b/translator/okasaki-examples/LazyPairingHeapScript.sml @@ -151,24 +151,27 @@ delete_min get_key leq (Tree _ a b) = merge get_key leq a b`; (* Functional correctness *) -Theorem merge_bag -`!get_key leq h1 h2. +Theorem merge_bag: + !get_key leq h1 h2. heap_to_bag (merge get_key leq h1 h2) = - BAG_UNION (heap_to_bag h1) (heap_to_bag h2)` -(HO_MATCH_MP_TAC merge_ind >> + BAG_UNION (heap_to_bag h1) (heap_to_bag h2) +Proof +HO_MATCH_MP_TAC merge_ind >> srw_tac [BAG_ss] [merge_def, heap_to_bag_def, BAG_INSERT_UNION] >| [cases_on `h1`,cases_on `h1'`] >> fs [] >> -srw_tac [BAG_ss] [merge_def, heap_to_bag_def, BAG_INSERT_UNION]); +srw_tac [BAG_ss] [merge_def, heap_to_bag_def, BAG_INSERT_UNION] +QED -Theorem merge_heap_ordered -`!get_key leq h1 h2. +Theorem merge_heap_ordered: + !get_key leq h1 h2. WeakLinearOrder leq ∧ is_heap_ordered get_key leq h1 ∧ is_heap_ordered get_key leq h2 ⇒ - is_heap_ordered get_key leq (merge get_key leq h1 h2)` -(HO_MATCH_MP_TAC merge_ind >> + is_heap_ordered get_key leq (merge get_key leq h1 h2) +Proof +HO_MATCH_MP_TAC merge_ind >> rw [merge_def, is_heap_ordered_def, merge_bag] >| [cases_on `h1`,cases_on `h1'`] >> rw [is_heap_ordered_def, heap_to_bag_def, BAG_EVERY, merge_def] >> @@ -199,48 +202,57 @@ fs [BAG_EVERY, is_heap_ordered_def, merge_bag, heap_to_bag_def] >| cases_on `h` >> fs [heap_to_bag_def, merge_bag] >> metis_tac [WeakLinearOrder, WeakOrder, transitive_def, - WeakLinearOrder_neg]]); - -Theorem insert_bag -`!h get_key leq x. - heap_to_bag (insert get_key leq x h) = BAG_INSERT x (heap_to_bag h)` -(rw [insert_def, merge_bag, heap_to_bag_def, - BAG_INSERT_UNION]); - -Theorem insert_heap_ordered -`!get_key leq x h. + WeakLinearOrder_neg]] +QED + +Theorem insert_bag: + !h get_key leq x. + heap_to_bag (insert get_key leq x h) = BAG_INSERT x (heap_to_bag h) +Proof +rw [insert_def, merge_bag, heap_to_bag_def, + BAG_INSERT_UNION] +QED + +Theorem insert_heap_ordered: + !get_key leq x h. WeakLinearOrder leq ∧ is_heap_ordered get_key leq h ⇒ - is_heap_ordered get_key leq (insert get_key leq x h)` -(rw [insert_def] >> + is_heap_ordered get_key leq (insert get_key leq x h) +Proof +rw [insert_def] >> `is_heap_ordered get_key leq (Tree x Empty Empty)` by rw [is_heap_ordered_def, heap_to_bag_def] >> -metis_tac [merge_heap_ordered]); +metis_tac [merge_heap_ordered] +QED -Theorem find_min_correct -`!h get_key leq. +Theorem find_min_correct: + !h get_key leq. WeakLinearOrder leq ∧ (h ≠ Empty) ∧ is_heap_ordered get_key leq h ⇒ BAG_IN (find_min h) (heap_to_bag h) ∧ - (!y. BAG_IN y (heap_to_bag h) ⇒ leq (get_key (find_min h)) (get_key y))` -(rw [] >> + (!y. BAG_IN y (heap_to_bag h) ⇒ leq (get_key (find_min h)) (get_key y)) +Proof +rw [] >> cases_on `h` >> fs [find_min_def, heap_to_bag_def, is_heap_ordered_def] >> fs [BAG_EVERY] >> -metis_tac [WeakLinearOrder, WeakOrder, reflexive_def]); +metis_tac [WeakLinearOrder, WeakOrder, reflexive_def] +QED -Theorem delete_min_correct -`!h get_key leq. +Theorem delete_min_correct: + !h get_key leq. WeakLinearOrder leq ∧ (h ≠ Empty) ∧ is_heap_ordered get_key leq h ⇒ is_heap_ordered get_key leq (delete_min get_key leq h) ∧ (heap_to_bag (delete_min get_key leq h) = - BAG_DIFF (heap_to_bag h) (EL_BAG (find_min h)))` -(rw [] >> + BAG_DIFF (heap_to_bag h) (EL_BAG (find_min h))) +Proof +rw [] >> cases_on `h` >> fs [delete_min_def, is_heap_ordered_def, merge_bag] >- metis_tac [merge_heap_ordered] >> -rw [heap_to_bag_def, find_min_def, BAG_DIFF_INSERT2]); +rw [heap_to_bag_def, find_min_def, BAG_DIFF_INSERT2] +QED (* Simplify the side conditions on the generated certificate theorems *) diff --git a/translator/okasaki-examples/LeftistHeapScript.sml b/translator/okasaki-examples/LeftistHeapScript.sml index 530a46e0f2..f4390bbaa2 100644 --- a/translator/okasaki-examples/LeftistHeapScript.sml +++ b/translator/okasaki-examples/LeftistHeapScript.sml @@ -73,22 +73,25 @@ delete_min get_key leq (Tree _ x a b) = merge get_key leq a b`; (* Functional correctness proof *) -Theorem merge_bag -`!get_key leq h1 h2. +Theorem merge_bag: + !get_key leq h1 h2. heap_to_bag (merge get_key leq h1 h2) = - BAG_UNION (heap_to_bag h1) (heap_to_bag h2)` -(HO_MATCH_MP_TAC merge_ind >> + BAG_UNION (heap_to_bag h1) (heap_to_bag h2) +Proof +HO_MATCH_MP_TAC merge_ind >> srw_tac [BAG_ss] - [merge_def, heap_to_bag_def, make_node_def, BAG_INSERT_UNION]); + [merge_def, heap_to_bag_def, make_node_def, BAG_INSERT_UNION] +QED -Theorem merge_heap_ordered -`!get_key leq h1 h2. +Theorem merge_heap_ordered: + !get_key leq h1 h2. WeakLinearOrder leq ∧ is_heap_ordered get_key leq h1 ∧ is_heap_ordered get_key leq h2 ⇒ - is_heap_ordered get_key leq (merge get_key leq h1 h2)` -(HO_MATCH_MP_TAC merge_ind >> + is_heap_ordered get_key leq (merge get_key leq h1 h2) +Proof +HO_MATCH_MP_TAC merge_ind >> rw [merge_def, is_heap_ordered_def, make_node_def, merge_bag] >> rw [heap_to_bag_def] >> fs [BAG_EVERY] >| @@ -103,48 +106,57 @@ fs [BAG_EVERY] >| metis_tac [WeakLinearOrder, WeakOrder, transitive_def, WeakLinearOrder_neg], metis_tac [WeakLinearOrder, WeakOrder, transitive_def, WeakLinearOrder_neg], metis_tac [WeakLinearOrder, WeakOrder, transitive_def, WeakLinearOrder_neg], - decide_tac]); - -Theorem insert_bag -`!h get_key leq x. - heap_to_bag (insert get_key leq x h) = BAG_INSERT x (heap_to_bag h)` -(rw [insert_def, merge_bag, heap_to_bag_def, - BAG_INSERT_UNION]); - -Theorem insert_heap_ordered -`!get_key leq x h. + decide_tac] +QED + +Theorem insert_bag: + !h get_key leq x. + heap_to_bag (insert get_key leq x h) = BAG_INSERT x (heap_to_bag h) +Proof +rw [insert_def, merge_bag, heap_to_bag_def, + BAG_INSERT_UNION] +QED + +Theorem insert_heap_ordered: + !get_key leq x h. WeakLinearOrder leq ∧ is_heap_ordered get_key leq h ⇒ - is_heap_ordered get_key leq (insert get_key leq x h)` -(rw [insert_def] >> + is_heap_ordered get_key leq (insert get_key leq x h) +Proof +rw [insert_def] >> `is_heap_ordered get_key leq (Tree 1 x Empty Empty)` by rw [is_heap_ordered_def, heap_to_bag_def] >> -metis_tac [merge_heap_ordered]); +metis_tac [merge_heap_ordered] +QED -Theorem find_min_correct -`!h get_key leq. +Theorem find_min_correct: + !h get_key leq. WeakLinearOrder leq ∧ (h ≠ Empty) ∧ is_heap_ordered get_key leq h ⇒ BAG_IN (find_min h) (heap_to_bag h) ∧ - (!y. BAG_IN y (heap_to_bag h) ⇒ leq (get_key (find_min h)) (get_key y))` -(rw [] >> + (!y. BAG_IN y (heap_to_bag h) ⇒ leq (get_key (find_min h)) (get_key y)) +Proof +rw [] >> cases_on `h` >> fs [find_min_def, heap_to_bag_def, is_heap_ordered_def] >> fs [BAG_EVERY] >> -metis_tac [WeakLinearOrder, WeakOrder, reflexive_def]); +metis_tac [WeakLinearOrder, WeakOrder, reflexive_def] +QED -Theorem delete_min_correct -`!h get_key leq. +Theorem delete_min_correct: + !h get_key leq. WeakLinearOrder leq ∧ (h ≠ Empty) ∧ is_heap_ordered get_key leq h ⇒ is_heap_ordered get_key leq (delete_min get_key leq h) ∧ (heap_to_bag (delete_min get_key leq h) = - BAG_DIFF (heap_to_bag h) (EL_BAG (find_min h)))` -(rw [] >> + BAG_DIFF (heap_to_bag h) (EL_BAG (find_min h))) +Proof +rw [] >> cases_on `h` >> fs [delete_min_def, is_heap_ordered_def, merge_bag] >- metis_tac [merge_heap_ordered] >> -rw [heap_to_bag_def, find_min_def, BAG_DIFF_INSERT2]); +rw [heap_to_bag_def, find_min_def, BAG_DIFF_INSERT2] +QED (* Simplify the side conditions on the generated certificate theorems *) diff --git a/translator/okasaki-examples/PairingHeapScript.sml b/translator/okasaki-examples/PairingHeapScript.sml index be3824909f..24454f1c2f 100644 --- a/translator/okasaki-examples/PairingHeapScript.sml +++ b/translator/okasaki-examples/PairingHeapScript.sml @@ -76,51 +76,61 @@ delete_min get_key leq (Tree x hs) = merge_pairs get_key leq hs`; (* Functional correctness proof *) -Theorem merge_bag -`!get_key leq h1 h2. +Theorem merge_bag: + !get_key leq h1 h2. heap_to_bag (merge get_key leq h1 h2) = - BAG_UNION (heap_to_bag h1) (heap_to_bag h2)` -(HO_MATCH_MP_TAC merge_ind >> -srw_tac [BAG_AC_ss] [merge_def, heap_to_bag_def, BAG_INSERT_UNION]); - -Theorem merge_heap_ordered -`!get_key leq h1 h2. + BAG_UNION (heap_to_bag h1) (heap_to_bag h2) +Proof +HO_MATCH_MP_TAC merge_ind >> +srw_tac [BAG_AC_ss] [merge_def, heap_to_bag_def, BAG_INSERT_UNION] +QED + +Theorem merge_heap_ordered: + !get_key leq h1 h2. WeakLinearOrder leq ∧ is_heap_ordered get_key leq h1 ∧ is_heap_ordered get_key leq h2 ⇒ - is_heap_ordered get_key leq (merge get_key leq h1 h2)` -(HO_MATCH_MP_TAC merge_ind >> + is_heap_ordered get_key leq (merge get_key leq h1 h2) +Proof +HO_MATCH_MP_TAC merge_ind >> rw [merge_def, is_heap_ordered_def, heap_to_bag_def] >> fs [BAG_EVERY] >> -metis_tac [WeakLinearOrder, WeakOrder, transitive_def, WeakLinearOrder_neg]); - -Theorem insert_bag -`!h get_key leq x. - heap_to_bag (insert get_key leq x h) = BAG_INSERT x (heap_to_bag h)` -(rw [insert_def, merge_bag, heap_to_bag_def, BAG_INSERT_UNION]); - -Theorem insert_heap_ordered -`!get_key leq x h. +metis_tac [WeakLinearOrder, WeakOrder, transitive_def, WeakLinearOrder_neg] +QED + +Theorem insert_bag: + !h get_key leq x. + heap_to_bag (insert get_key leq x h) = BAG_INSERT x (heap_to_bag h) +Proof +rw [insert_def, merge_bag, heap_to_bag_def, BAG_INSERT_UNION] +QED + +Theorem insert_heap_ordered: + !get_key leq x h. WeakLinearOrder leq ∧ is_heap_ordered get_key leq h ⇒ - is_heap_ordered get_key leq (insert get_key leq x h)` -(rw [insert_def] >> + is_heap_ordered get_key leq (insert get_key leq x h) +Proof +rw [insert_def] >> `is_heap_ordered get_key leq (Tree x [])` by rw [is_heap_ordered_def, heap_to_bag_def] >> -metis_tac [merge_heap_ordered]); +metis_tac [merge_heap_ordered] +QED -Theorem find_min_correct -`!h get_key leq. +Theorem find_min_correct: + !h get_key leq. WeakLinearOrder leq ∧ (h ≠ Empty) ∧ is_heap_ordered get_key leq h ⇒ BAG_IN (find_min h) (heap_to_bag h) ∧ - (!y. BAG_IN y (heap_to_bag h) ⇒ leq (get_key (find_min h)) (get_key y))` -(rw [] >> + (!y. BAG_IN y (heap_to_bag h) ⇒ leq (get_key (find_min h)) (get_key y)) +Proof +rw [] >> cases_on `h` >> fs [find_min_def, heap_to_bag_def, is_heap_ordered_def] >> fs [BAG_EVERY] >> -metis_tac [WeakLinearOrder, WeakOrder, reflexive_def]); +metis_tac [WeakLinearOrder, WeakOrder, reflexive_def] +QED val merge_pairs_bag = Q.prove ( `!get_key leq hs. heap_to_bag (merge_pairs get_key leq hs) = heaps_to_bag hs`, @@ -135,18 +145,20 @@ val merge_pairs_heap_ordered = Q.prove ( recInduct merge_pairs_ind >> rw [merge_pairs_def, is_heap_ordered_def, merge_heap_ordered]); -Theorem delete_min_correct -`!h get_key leq. +Theorem delete_min_correct: + !h get_key leq. WeakLinearOrder leq ∧ (h ≠ Empty) ∧ is_heap_ordered get_key leq h ⇒ is_heap_ordered get_key leq (delete_min get_key leq h) ∧ (heap_to_bag (delete_min get_key leq h) = - BAG_DIFF (heap_to_bag h) (EL_BAG (find_min h)))` -(rw [] >> + BAG_DIFF (heap_to_bag h) (EL_BAG (find_min h))) +Proof +rw [] >> cases_on `h` >> fs [delete_min_def, is_heap_ordered_def, merge_pairs_bag] >- metis_tac [merge_pairs_heap_ordered] >> -rw [heap_to_bag_def, find_min_def, BAG_DIFF_INSERT2]); +rw [heap_to_bag_def, find_min_def, BAG_DIFF_INSERT2] +QED (* Simplify the side conditions on the generated certificate theorems *) diff --git a/translator/okasaki-examples/RedBlackSetScript.sml b/translator/okasaki-examples/RedBlackSetScript.sml index 39ad56a428..78e090c731 100644 --- a/translator/okasaki-examples/RedBlackSetScript.sml +++ b/translator/okasaki-examples/RedBlackSetScript.sml @@ -232,42 +232,48 @@ rw [is_bst_def] >> imp_res_tac ins_set >> fs [StrongLinearOrder, StrongOrder]); -Theorem insert_set -`∀lt x t. +Theorem insert_set: + ∀lt x t. StrongLinearOrder lt ⇒ - (tree_to_set (insert lt x t) = {x} ∪ tree_to_set t)` -(rw [insert_def] >> + (tree_to_set (insert lt x t) = {x} ∪ tree_to_set t) +Proof +rw [insert_def] >> `?c t1 y t2. ins lt x t = Tree c t1 y t2` by metis_tac [ins_tree] >> rw [tree_to_set_def] >> `tree_to_set (ins lt x t) = tree_to_set (Tree c t1 y t2)` by metis_tac [] >> fs [] >> imp_res_tac ins_set >> -fs [tree_to_set_def]); +fs [tree_to_set_def] +QED -Theorem insert_bst -`!lt x t. +Theorem insert_bst: + !lt x t. StrongLinearOrder lt ∧ is_bst lt t ⇒ - is_bst lt (insert lt x t)` -(rw [insert_def] >> + is_bst lt (insert lt x t) +Proof +rw [insert_def] >> `?c t1 y t2. ins lt x t = Tree c t1 y t2` by metis_tac [ins_tree] >> rw [] >> `is_bst lt (Tree c t1 y t2)` by metis_tac [ins_bst] >> -fs [is_bst_def]); +fs [is_bst_def] +QED -Theorem member_correct -`!lt t x. +Theorem member_correct: + !lt t x. StrongLinearOrder lt ∧ is_bst lt t ⇒ - (member lt x t <=> x ∈ tree_to_set t)` -(strip_tac >> induct_on `t` >> + (member lt x t <=> x ∈ tree_to_set t) +Proof +strip_tac >> induct_on `t` >> rw [member_def, is_bst_def, tree_to_set_def] >> fs [StrongLinearOrder, StrongOrder, irreflexive_def, transitive_def, trichotomous] >> -metis_tac []); +metis_tac [] +QED (* Prove the two red-black invariants that no red node has a red child, @@ -308,13 +314,14 @@ rw [] >| metis_tac [balance_inv2_black, balance'_correct], rw [balance'_def, red_black_invariant2_def, case_opt_lem]]); -Theorem insert_invariant2 -`!leq x t n. +Theorem insert_invariant2: + !leq x t n. (red_black_invariant2 t = SOME n) ⇒ (red_black_invariant2 (insert leq x t) = SOME n) ∨ - (red_black_invariant2 (insert leq x t) = SOME (n + 1))` -(rw [insert_def] >> + (red_black_invariant2 (insert leq x t) = SOME (n + 1)) +Proof +rw [insert_def] >> cases_on `ins leq x t` >> rw [] >- metis_tac [ins_tree, tree_distinct] >> @@ -323,7 +330,8 @@ POP_ASSUM MP_TAC >> rw [red_black_invariant2_def, case_opt_lem] >> cases_on `n = n''` >> cases_on `c` >> -fs []); +fs [] +QED (* Invariant one hold everywhere except for the root node, * where it may or may not. *) @@ -363,9 +371,10 @@ fs [red_black_invariant1_def, not_red_def] >| metis_tac [balance_inv1_black, balance'_correct, inv1_lemma], rw [balance'_def, rbinv1_root_def]]); -Theorem insert_invariant1 -`!leq x t. red_black_invariant1 t ⇒ red_black_invariant1 (insert leq x t)` -(rw [insert_def] >> +Theorem insert_invariant1: + !leq x t. red_black_invariant1 t ⇒ red_black_invariant1 (insert leq x t) +Proof +rw [insert_def] >> cases_on `ins leq x t` >> rw [] >- metis_tac [ins_tree, tree_distinct] >> @@ -376,7 +385,8 @@ POP_ASSUM MP_TAC >> cases_on `not_red t` >> rw [] >> cases_on `c` >> -fs [red_black_invariant1_def, rbinv1_root_def]); +fs [red_black_invariant1_def, rbinv1_root_def] +QED (* Simplify the side conditions on the generated certificate theorems, diff --git a/translator/okasaki-examples/SplayHeapScript.sml b/translator/okasaki-examples/SplayHeapScript.sml index ccaba07cf5..9a266fede3 100644 --- a/translator/okasaki-examples/SplayHeapScript.sml +++ b/translator/okasaki-examples/SplayHeapScript.sml @@ -199,23 +199,26 @@ metis_tac [partition_heap_ordered_lem] >- (fs [BAG_EVERY] >> metis_tac [transitive_def, WeakLinearOrder, WeakOrder])); -Theorem insert_bag -`!h get_key leq x. +Theorem insert_bag: + !h get_key leq x. heap_to_bag (insert get_key leq x h) = - BAG_INSERT x (heap_to_bag h)` -(induct_on `h` >> + BAG_INSERT x (heap_to_bag h) +Proof +induct_on `h` >> rw [heap_to_bag_def, insert_def] >> rw [heap_to_bag_def] >> fs [insert_def] >> imp_res_tac (GSYM partition_bags) >> -fs [heap_to_bag_def]); +fs [heap_to_bag_def] +QED -Theorem insert_heap_ordered -`!get_key leq x h. +Theorem insert_heap_ordered: + !get_key leq x h. WeakLinearOrder leq ∧ is_heap_ordered get_key leq h ⇒ - is_heap_ordered get_key leq (insert get_key leq x h)` -(rw [insert_def, is_heap_ordered_def] >> + is_heap_ordered get_key leq (insert get_key leq x h) +Proof +rw [insert_def, is_heap_ordered_def] >> rw [is_heap_ordered_def] >- metis_tac [partition_heap_ordered] >- metis_tac [partition_heap_ordered] >- @@ -223,26 +226,30 @@ metis_tac [WeakLinearOrder, WeakOrder, partition_split] >- (`BAG_EVERY (\y. ¬leq (get_key y) (get_key x)) (heap_to_bag b)` by metis_tac [partition_split, WeakLinearOrder, WeakOrder] >> fs [BAG_EVERY] >> - metis_tac [WeakLinearOrder_neg])); + metis_tac [WeakLinearOrder_neg]) +QED -Theorem merge_bag -`!get_key leq h1 h2. +Theorem merge_bag: + !get_key leq h1 h2. (heap_to_bag (merge get_key leq h1 h2) = - BAG_UNION (heap_to_bag h1) (heap_to_bag h2))` -(recInduct merge_ind >> + BAG_UNION (heap_to_bag h1) (heap_to_bag h2)) +Proof +recInduct merge_ind >> rw [merge_def, heap_to_bag_def] >> cases_on `partition get_key leq x h2` >> fs [] >> imp_res_tac (GSYM partition_bags) >> rw [heap_to_bag_def, BAG_UNION_INSERT] >> -metis_tac [ASSOC_BAG_UNION, COMM_BAG_UNION, BAG_INSERT_commutes]); +metis_tac [ASSOC_BAG_UNION, COMM_BAG_UNION, BAG_INSERT_commutes] +QED -Theorem merge_heap_ordered -`!get_key leq h1 h2. +Theorem merge_heap_ordered: + !get_key leq h1 h2. WeakLinearOrder leq ∧ is_heap_ordered get_key leq h1 ∧ is_heap_ordered get_key leq h2 ⇒ - is_heap_ordered get_key leq (merge get_key leq h1 h2)` -(recInduct merge_ind >> + is_heap_ordered get_key leq (merge get_key leq h1 h2) +Proof +recInduct merge_ind >> rw [merge_def, is_heap_ordered_def] >> rw [is_heap_ordered_def, merge_bag] >- metis_tac [partition_heap_ordered] >- @@ -251,30 +258,34 @@ metis_tac [partition_split, WeakLinearOrder, WeakOrder] >- (`BAG_EVERY (\y. ¬leq (get_key y) (get_key x)) (heap_to_bag tb)` by metis_tac [partition_split, WeakLinearOrder, WeakOrder] >> fs [BAG_EVERY] >> - metis_tac [WeakLinearOrder_neg])); + metis_tac [WeakLinearOrder_neg]) +QED -Theorem find_min_correct -`!h get_key leq. +Theorem find_min_correct: + !h get_key leq. WeakLinearOrder leq ∧ (h ≠ Empty) ∧ is_heap_ordered get_key leq h ⇒ BAG_IN (find_min h) (heap_to_bag h) ∧ (!y. BAG_IN y (heap_to_bag h) ⇒ - leq (get_key (find_min h)) (get_key y))` -(recInduct find_min_ind >> + leq (get_key (find_min h)) (get_key y)) +Proof +recInduct find_min_ind >> rw [heap_to_bag_def, find_min_def] >> fs [is_heap_ordered_def, heap_to_bag_def, BAG_EVERY] >> -metis_tac [WeakLinearOrder, WeakOrder, transitive_def, reflexive_def]); +metis_tac [WeakLinearOrder, WeakOrder, transitive_def, reflexive_def] +QED -Theorem delete_min_correct -`!h get_key leq. +Theorem delete_min_correct: + !h get_key leq. WeakLinearOrder leq ∧ (h ≠ Empty) ∧ is_heap_ordered get_key leq h ⇒ is_heap_ordered get_key leq (delete_min h) ∧ (heap_to_bag (delete_min h) = - BAG_DIFF (heap_to_bag h) (EL_BAG (find_min h)))` -(HO_MATCH_MP_TAC delete_min_ind >> + BAG_DIFF (heap_to_bag h) (EL_BAG (find_min h))) +Proof +HO_MATCH_MP_TAC delete_min_ind >> srw_tac [bagLib.BAG_ss] [delete_min_def, is_heap_ordered_def, heap_to_bag_def, find_min_def, BAG_INSERT_UNION] >| @@ -296,7 +307,8 @@ srw_tac [bagLib.BAG_ss] (EL_BAG v7 ⊎ (heap_to_bag v6 ⊎ heap_to_bag v8))` by rw [SUB_BAG_EL_BAG] >> rw [BAG_UNION_DIFF, SUB_BAG_UNION] >> - srw_tac [BAG_AC_ss] []]); + srw_tac [BAG_AC_ss] []] +QED (* Simplify the side conditions on the generated certificate theorems *) diff --git a/translator/okasaki-examples/UnbalancedSetScript.sml b/translator/okasaki-examples/UnbalancedSetScript.sml index 51b9f2e5fa..686debe28e 100644 --- a/translator/okasaki-examples/UnbalancedSetScript.sml +++ b/translator/okasaki-examples/UnbalancedSetScript.sml @@ -54,36 +54,42 @@ val insert_def = mlDefine ` (* Correctness proof *) -Theorem member_correct -`!lt t x. +Theorem member_correct: + !lt t x. StrongLinearOrder lt ∧ is_bst lt t ⇒ - (member lt x t <=> x ∈ tree_to_set t)` -(strip_tac >> induct_on `t` >> + (member lt x t <=> x ∈ tree_to_set t) +Proof +strip_tac >> induct_on `t` >> rw [member_def, is_bst_def, tree_to_set_def] >> fs [] >> fs [StrongLinearOrder, StrongOrder, irreflexive_def, transitive_def, trichotomous] >> -metis_tac []); +metis_tac [] +QED -Theorem insert_set -`∀lt x t. +Theorem insert_set: + ∀lt x t. StrongLinearOrder lt ⇒ - (tree_to_set (insert lt x t) = {x} ∪ tree_to_set t)` -(induct_on `t` >> + (tree_to_set (insert lt x t) = {x} ∪ tree_to_set t) +Proof +induct_on `t` >> srw_tac [PRED_SET_AC_ss] [insert_def, tree_to_set_def] >> `x = a` by (fs [StrongLinearOrder, StrongOrder, irreflexive_def, transitive_def, trichotomous] >> metis_tac []) >> -rw []); +rw [] +QED -Theorem insert_is_bst -`!lt x t. +Theorem insert_is_bst: + !lt x t. StrongLinearOrder lt ∧ is_bst lt t ⇒ - is_bst lt (insert lt x t)` -(induct_on `t` >> + is_bst lt (insert lt x t) +Proof +induct_on `t` >> rw [is_bst_def, insert_def, tree_to_set_def, insert_set] >> -metis_tac []); +metis_tac [] +QED val _ = export_theory (); diff --git a/translator/okasaki-examples/okasaki_miscScript.sml b/translator/okasaki-examples/okasaki_miscScript.sml index d0f9bd7ca9..45ef8efe24 100644 --- a/translator/okasaki-examples/okasaki_miscScript.sml +++ b/translator/okasaki-examples/okasaki_miscScript.sml @@ -9,26 +9,33 @@ val rw = srw_tac [] val _ = new_theory "okasaki_misc" -Theorem WeakLinearOrder_neg -`!leq x y. WeakLinearOrder leq ⇒ (~leq x y <=> leq y x ∧ x ≠ y)` -(metis_tac [WeakLinearOrder, WeakOrder, trichotomous, reflexive_def, - antisymmetric_def]); - -Theorem BAG_EVERY_DIFF -`!P b1 b2. BAG_EVERY P b1 ⇒ BAG_EVERY P (BAG_DIFF b1 b2)` -(rw [BAG_EVERY] >> -metis_tac [BAG_IN_DIFF_E]); - -Theorem BAG_EVERY_EL -`!P x. BAG_EVERY P (EL_BAG x) = P x` -(rw [BAG_EVERY, EL_BAG]); - -Theorem BAG_INN_BAG_DIFF -`!x m b1 b2. +Theorem WeakLinearOrder_neg: + !leq x y. WeakLinearOrder leq ⇒ (~leq x y <=> leq y x ∧ x ≠ y) +Proof +metis_tac [WeakLinearOrder, WeakOrder, trichotomous, reflexive_def, + antisymmetric_def] +QED + +Theorem BAG_EVERY_DIFF: + !P b1 b2. BAG_EVERY P b1 ⇒ BAG_EVERY P (BAG_DIFF b1 b2) +Proof +rw [BAG_EVERY] >> +metis_tac [BAG_IN_DIFF_E] +QED + +Theorem BAG_EVERY_EL: + !P x. BAG_EVERY P (EL_BAG x) = P x +Proof +rw [BAG_EVERY, EL_BAG] +QED + +Theorem BAG_INN_BAG_DIFF: + !x m b1 b2. BAG_INN x m (BAG_DIFF b1 b2) = ∃n1 n2. (m = n1 - n2) ∧ - BAG_INN x n1 b1 ∧ BAG_INN x n2 b2 ∧ ~BAG_INN x (n2 + 1) b2` -(rw [BAG_INN, BAG_DIFF] >> + BAG_INN x n1 b1 ∧ BAG_INN x n2 b2 ∧ ~BAG_INN x (n2 + 1) b2 +Proof +rw [BAG_INN, BAG_DIFF] >> EQ_TAC >> rw [] >| [qexists_tac `b2 x + m` >> @@ -37,27 +44,34 @@ rw [] >| qexists_tac `0` >> qexists_tac `b2 x` >> decide_tac, - decide_tac]); + decide_tac] +QED -Theorem BAG_DIFF_INSERT2 -`!x b. BAG_DIFF (BAG_INSERT x b) (EL_BAG x) = b` -(rw [BAG_DIFF, BAG_INSERT, EL_BAG, FUN_EQ_THM, EMPTY_BAG] >> +Theorem BAG_DIFF_INSERT2: + !x b. BAG_DIFF (BAG_INSERT x b) (EL_BAG x) = b +Proof +rw [BAG_DIFF, BAG_INSERT, EL_BAG, FUN_EQ_THM, EMPTY_BAG] >> cases_on `x' = x` >> -rw []); +rw [] +QED val list_to_bag_def = Define ` (list_to_bag [] = {||}) ∧ (list_to_bag (h::t) = BAG_INSERT h (list_to_bag t))`; -Theorem list_to_bag_filter -`∀P l. list_to_bag (FILTER P l) = BAG_FILTER P (list_to_bag l)` -(Induct_on `l` >> -rw [list_to_bag_def]); +Theorem list_to_bag_filter: + ∀P l. list_to_bag (FILTER P l) = BAG_FILTER P (list_to_bag l) +Proof +Induct_on `l` >> +rw [list_to_bag_def] +QED -Theorem list_to_bag_append -`∀l1 l2. list_to_bag (l1 ++ l2) = BAG_UNION (list_to_bag l1) (list_to_bag l2)` -(Induct_on `l1` >> -srw_tac [BAG_ss] [list_to_bag_def, BAG_INSERT_UNION]); +Theorem list_to_bag_append: + ∀l1 l2. list_to_bag (l1 ++ l2) = BAG_UNION (list_to_bag l1) (list_to_bag l2) +Proof +Induct_on `l1` >> +srw_tac [BAG_ss] [list_to_bag_def, BAG_INSERT_UNION] +QED val list_to_bag_to_perm = Q.prove ( `!l1 l2. PERM l1 l2 ⇒ (list_to_bag l1 = list_to_bag l2)`, @@ -80,9 +94,11 @@ val perm_to_list_to_bag = Q.prove ( rw [PERM_DEF] >> metis_tac [perm_to_list_to_bag_lem, list_to_bag_filter]); -Theorem list_to_bag_perm -`!l1 l2. (list_to_bag l1 = list_to_bag l2) = PERM l1 l2` -(metis_tac [perm_to_list_to_bag, list_to_bag_to_perm]); +Theorem list_to_bag_perm: + !l1 l2. (list_to_bag l1 = list_to_bag l2) = PERM l1 l2 +Proof +metis_tac [perm_to_list_to_bag, list_to_bag_to_perm] +QED val sorted_reverse_lem = Q.prove ( `!R l. transitive R ∧ SORTED R l ⇒ SORTED (\x y. R y x) (REVERSE l)`, @@ -94,15 +110,17 @@ rw [SORTED_DEF] >- metis_tac []) >> metis_tac [SORTED_EQ]); -Theorem sorted_reverse -`!R l. transitive R ⇒ (SORTED R (REVERSE l) = SORTED (\x y. R y x) l)` -(rw [] >> +Theorem sorted_reverse: + !R l. transitive R ⇒ (SORTED R (REVERSE l) = SORTED (\x y. R y x) l) +Proof +rw [] >> EQ_TAC >> rw [] >> imp_res_tac sorted_reverse_lem >> fs [transitive_def] >> `(\x y. R x y) = R` by metis_tac [] >> fs [] >> -metis_tac []); +metis_tac [] +QED val _ = export_theory (); diff --git a/translator/other-examples/auxiliary/ninetyOneScript.sml b/translator/other-examples/auxiliary/ninetyOneScript.sml index 9a7224b6e7..4d55fb0af4 100644 --- a/translator/other-examples/auxiliary/ninetyOneScript.sml +++ b/translator/other-examples/auxiliary/ninetyOneScript.sml @@ -123,13 +123,15 @@ val (N_def,N_ind) = Defn.tprove val _ = save_thm ("N_def", N_def); val _ = save_thm ("N_ind", N_ind); -Theorem N_correct -`!x. N x = if x > 100 then x - 10 else 91` -(HO_MATCH_MP_TAC N_ind THEN +Theorem N_correct: + !x. N x = if x > 100 then x - 10 else 91 +Proof +HO_MATCH_MP_TAC N_ind THEN SRW_TAC [] [] THEN ONCE_REWRITE_TAC [N_def] THEN SRW_TAC [] [] THEN -DECIDE_TAC); +DECIDE_TAC +QED (*--------------------------------------------------------------------------- Note that the above development is slightly cranky, since diff --git a/translator/other-examples/auxiliary/regexpMatchScript.sml b/translator/other-examples/auxiliary/regexpMatchScript.sml index 3c725771f7..4c2e0241ac 100644 --- a/translator/other-examples/auxiliary/regexpMatchScript.sml +++ b/translator/other-examples/auxiliary/regexpMatchScript.sml @@ -835,11 +835,13 @@ val sem_implies_match = Q.prove (* match correctly implements the semantics. *) (*---------------------------------------------------------------------------*) -Theorem match_is_correct -`!r w. sem r w = match [r] w NONE` - (REPEAT (STRIP_TAC ORELSE EQ_TAC) THENL +Theorem match_is_correct: + !r w. sem r w = match [r] w NONE +Proof + REPEAT (STRIP_TAC ORELSE EQ_TAC) THENL [RW_TAC list_ss [sem_implies_match], - IMP_RES_TAC match_implies_sem THEN FULL_SIMP_TAC list_ss [FOLDR,sem_def]]); + IMP_RES_TAC match_implies_sem THEN FULL_SIMP_TAC list_ss [FOLDR,sem_def]] +QED val _ = export_theory (); diff --git a/translator/std_preludeScript.sml b/translator/std_preludeScript.sml index 9aa5dda1bf..70cb6b97ee 100644 --- a/translator/std_preludeScript.sml +++ b/translator/std_preludeScript.sml @@ -77,17 +77,19 @@ val IS_SOME_OWHILE_THM = Q.prove( THEN ASM_SIMP_TAC std_ss [] THEN REPEAT STRIP_TAC THEN IMP_RES_TAC LESS_LEAST THEN FULL_SIMP_TAC std_ss []); -Theorem WHILE_ind - `!P. (!p g x. (p x ==> P p g (g x)) ==> P p g x) ==> - !p g x. IS_SOME (OWHILE p g x) ==> P p g x` - (SIMP_TAC std_ss [IS_SOME_OWHILE_THM,PULL_EXISTS,PULL_FORALL] +Theorem WHILE_ind: + !P. (!p g x. (p x ==> P p g (g x)) ==> P p g x) ==> + !p g x. IS_SOME (OWHILE p g x) ==> P p g x +Proof + SIMP_TAC std_ss [IS_SOME_OWHILE_THM,PULL_EXISTS,PULL_FORALL] THEN Induct_on `n` THEN SRW_TAC [] [] THEN FIRST_ASSUM MATCH_MP_TAC THEN SRW_TAC [] [] THEN FULL_SIMP_TAC std_ss [AND_IMP_INTRO] THEN Q.PAT_X_ASSUM `!x1 x2 x3 x4. bbb` MATCH_MP_TAC THEN SRW_TAC [] [] THEN FULL_SIMP_TAC std_ss [FUNPOW] THEN `SUC m < SUC n` by DECIDE_TAC - THEN METIS_TAC [FUNPOW]); + THEN METIS_TAC [FUNPOW] +QED val OWHILE_ind = save_thm("OWHILE_ind",WHILE_ind); @@ -97,7 +99,11 @@ val _ = next_ml_names := ["while"]; val res = translate WHILE; val res = translate OWHILE_THM; -Theorem SUC_LEMMA `SUC = \x. x+1` (SIMP_TAC std_ss [FUN_EQ_THM,ADD1]); +Theorem SUC_LEMMA: + SUC = \x. x+1 +Proof +SIMP_TAC std_ss [FUN_EQ_THM,ADD1] +QED val LEAST_LEMMA = Q.prove( `$LEAST P = WHILE (\x. ~(P x)) (\x. x + 1) 0`, diff --git a/tutorial/arith_exp_demoScript.sml b/tutorial/arith_exp_demoScript.sml index 2b0d1ed6cc..2539ccd4c6 100644 --- a/tutorial/arith_exp_demoScript.sml +++ b/tutorial/arith_exp_demoScript.sml @@ -75,9 +75,11 @@ val double_def = Define` expression. *) -Theorem double_thm - `∀e. sem (double e) = 2 * sem e` - (Induct \\ rw[double_def]); +Theorem double_thm: + ∀e. sem (double e) = 2 * sem e +Proof + Induct \\ rw[double_def] +QED (* a more detailed proof: Induct (* first subgoal solved by rewriting (sem_def is automatic; we add double_def manually) *) diff --git a/tutorial/simple_bstScript.sml b/tutorial/simple_bstScript.sml index 51254a9c14..20eed9c9d9 100644 --- a/tutorial/simple_bstScript.sml +++ b/tutorial/simple_bstScript.sml @@ -84,30 +84,32 @@ val key_set_def = Define` Let's prove this. *) -Theorem key_set_equiv - `∀cmp. +Theorem key_set_equiv: + ∀cmp. good_cmp cmp ⇒ (∀k. k ∈ key_set cmp k) ∧ (∀k1 k2. k1 ∈ key_set cmp k2 ⇒ k2 ∈ key_set cmp k1) ∧ - (∀k1 k2 k3. k1 ∈ key_set cmp k2 ∧ k2 ∈ key_set cmp k3 ⇒ k1 ∈ key_set cmp k3)` - (rw [key_set_def] >> - metis_tac [good_cmp_def]); + (∀k1 k2 k3. k1 ∈ key_set cmp k2 ∧ k2 ∈ key_set cmp k3 ⇒ k1 ∈ key_set cmp k3) +Proof + rw [key_set_def] >> + metis_tac [good_cmp_def] +QED (* A corollary of this: if two keys have the same key_set, they must be equivalent *) -Theorem key_set_eq - `∀cmp k1 k2. +Theorem key_set_eq: + ∀cmp k1 k2. good_cmp cmp ⇒ - (key_set cmp k1 = key_set cmp k2 ⇔ cmp k1 k2 = Equal)` - ((* EXERCISE: prove this *) + (key_set cmp k1 = key_set cmp k2 ⇔ cmp k1 k2 = Equal) +Proof + (* EXERCISE: prove this *) (* hint: consider the tactics used above *) (* hint: remember DB.match and DB.find to find useful theorems *) (* hint: set extensionality theorem is called EXTENSION *) - -); +QED (* A helper theorem, expanding out the definition of key_set, for use with metis_tac later. *) @@ -125,13 +127,14 @@ val to_fmap_def = Define` to_fmap cmp (Node k v l r) = to_fmap cmp l ⊌ to_fmap cmp r |+ (key_set cmp k, v)`; -Theorem to_fmap_key_set - `∀ks t. - ks ∈ FDOM (to_fmap cmp t) ⇒ ∃k. ks = key_set cmp k` - (Induct_on `t` >> +Theorem to_fmap_key_set: + ∀ks t. + ks ∈ FDOM (to_fmap cmp t) ⇒ ∃k. ks = key_set cmp k +Proof + Induct_on `t` >> (* EXERCISE: finish this proof *) (* hint: the same tactic probably works for both subgoals *) -); +QED (* Now some proofs about the basic tree operations. @@ -171,8 +174,11 @@ val wf_tree_def = Define` *) -Theorem wf_tree_singleton[simp] - `wf_tree cmp (singleton k v)` (EVAL_TAC); +Theorem wf_tree_singleton[simp]: + wf_tree cmp (singleton k v) +Proof +EVAL_TAC +QED (* The [simp] annotation above is equivalent to calling export_rewrites["wf_tree_singleton"] after storing this theorem. *) @@ -190,10 +196,11 @@ val key_ordered_insert = Q.store_thm("key_ordered_insert[simp]", (* hint: this lemma might need induction *) ); -Theorem wf_tree_insert[simp] - `good_cmp cmp ⇒ - ∀t k v. wf_tree cmp t ⇒ wf_tree cmp (insert cmp k v t)` - (strip_tac \\ +Theorem wf_tree_insert[simp]: + good_cmp cmp ⇒ + ∀t k v. wf_tree cmp t ⇒ wf_tree cmp (insert cmp k v t) +Proof + strip_tac \\ Induct \\ rw[insert_def] \\ CASE_TAC \\ fs[wf_tree_def] \\ @@ -202,40 +209,44 @@ Theorem wf_tree_insert[simp] then you can continue with: match_mp_tac key_ordered_insert ( or: match_mp_tac (MP_CANON key_ordered_insert) )*) - -); +QED (* Correctness of lookup *) -Theorem key_ordered_to_fmap - `good_cmp cmp ⇒ +Theorem key_ordered_to_fmap: + good_cmp cmp ⇒ ∀t k res. key_ordered cmp k t res ⇔ - (∀ks k'. ks ∈ FDOM (to_fmap cmp t) ∧ k' ∈ ks ⇒ cmp k k' = res)` - (strip_tac \\ + (∀ks k'. ks ∈ FDOM (to_fmap cmp t) ∧ k' ∈ ks ⇒ cmp k k' = res) +Proof + strip_tac \\ Induct \\ rw[to_fmap_def] \\ eq_tac \\ rw[] \\ - metis_tac[IN_key_set,cmp_thms]); + metis_tac[IN_key_set,cmp_thms] +QED -Theorem wf_tree_Node_imp - `good_cmp cmp ∧ +Theorem wf_tree_Node_imp: + good_cmp cmp ∧ wf_tree cmp (Node k v l r) ⇒ DISJOINT (FDOM (to_fmap cmp l)) (FDOM (to_fmap cmp r)) ∧ (∀x. key_set cmp x ∈ FDOM (to_fmap cmp l) ⇒ cmp k x = Greater) ∧ - (∀x. key_set cmp x ∈ FDOM (to_fmap cmp r) ⇒ cmp k x = Less)` - (rw[IN_DISJOINT,wf_tree_def] \\ + (∀x. key_set cmp x ∈ FDOM (to_fmap cmp r) ⇒ cmp k x = Less) +Proof + rw[IN_DISJOINT,wf_tree_def] \\ spose_not_then strip_assume_tac \\ imp_res_tac to_fmap_key_set \\ imp_res_tac key_ordered_to_fmap \\ - metis_tac[cmp_thms,IN_key_set]); + metis_tac[cmp_thms,IN_key_set] +QED -Theorem lookup_to_fmap - `good_cmp cmp ⇒ +Theorem lookup_to_fmap: + good_cmp cmp ⇒ ∀t k. wf_tree cmp t ⇒ - lookup cmp k t = FLOOKUP (to_fmap cmp t) (key_set cmp k)` - (strip_tac \\ + lookup cmp k t = FLOOKUP (to_fmap cmp t) (key_set cmp k) +Proof + strip_tac \\ Induct \\ rw[lookup_def,to_fmap_def] \\ fs[] \\ @@ -245,7 +256,6 @@ Theorem lookup_to_fmap DB.match[] ``FLOOKUP (_ ⊌ _)``; *) (* EXERCISE: fill in the rest of this proof *) - -); +QED val _ = export_theory(); diff --git a/tutorial/solutions/simple_bstScript.sml b/tutorial/solutions/simple_bstScript.sml index 63de10480b..58abf7028b 100644 --- a/tutorial/solutions/simple_bstScript.sml +++ b/tutorial/solutions/simple_bstScript.sml @@ -93,25 +93,28 @@ val key_set_def = Define` Let's prove this. *) -Theorem key_set_equiv - `∀cmp. +Theorem key_set_equiv: + ∀cmp. good_cmp cmp ⇒ (∀k. k ∈ key_set cmp k) ∧ (∀k1 k2. k1 ∈ key_set cmp k2 ⇒ k2 ∈ key_set cmp k1) ∧ - (∀k1 k2 k3. k1 ∈ key_set cmp k2 ∧ k2 ∈ key_set cmp k3 ⇒ k1 ∈ key_set cmp k3)` - (rw [key_set_def] >> - metis_tac [good_cmp_def]); + (∀k1 k2 k3. k1 ∈ key_set cmp k2 ∧ k2 ∈ key_set cmp k3 ⇒ k1 ∈ key_set cmp k3) +Proof + rw [key_set_def] >> + metis_tac [good_cmp_def] +QED (* A corollary of this: if two keys have the same key_set, they must be equivalent *) -Theorem key_set_eq - `∀cmp k1 k2. +Theorem key_set_eq: + ∀cmp k1 k2. good_cmp cmp ⇒ - (key_set cmp k1 = key_set cmp k2 ⇔ cmp k1 k2 = Equal)` - ((* EXERCISE: prove this *) + (key_set cmp k1 = key_set cmp k2 ⇔ cmp k1 k2 = Equal) +Proof + (* EXERCISE: prove this *) (* hint: consider the tactics used above *) (* hint: remember DB.match and DB.find to find useful theorems *) (* hint: set extensionality theorem is called EXTENSION *) @@ -119,8 +122,7 @@ Theorem key_set_eq rw[key_set_def,EXTENSION] \\ metis_tac[good_cmp_def] (* ex*) - -); +QED (* A helper theorem, expanding out the definition of key_set, for use with metis_tac later. *) @@ -138,17 +140,18 @@ val to_fmap_def = Define` to_fmap cmp (Node k v l r) = to_fmap cmp l ⊌ to_fmap cmp r |+ (key_set cmp k, v)`; -Theorem to_fmap_key_set - `∀ks t. - ks ∈ FDOM (to_fmap cmp t) ⇒ ∃k. ks = key_set cmp k` - (Induct_on `t` >> +Theorem to_fmap_key_set: + ∀ks t. + ks ∈ FDOM (to_fmap cmp t) ⇒ ∃k. ks = key_set cmp k +Proof + Induct_on `t` >> (* EXERCISE: finish this proof *) (* hint: the same tactic probably works for both subgoals *) (*ex *) rw[to_fmap_def] \\ metis_tac[] (* ex*) -); +QED (* Now some proofs about the basic tree operations. @@ -188,8 +191,11 @@ val wf_tree_def = Define` *) -Theorem wf_tree_singleton[simp] - `wf_tree cmp (singleton k v)` (EVAL_TAC); +Theorem wf_tree_singleton[simp]: + wf_tree cmp (singleton k v) +Proof +EVAL_TAC +QED (* The [simp] annotation above is equivalent to calling export_rewrites["wf_tree_singleton"] after storing this theorem. *) @@ -221,10 +227,11 @@ val key_ordered_insert = Q.store_thm("key_ordered_insert[simp]", (* ex*) ); -Theorem wf_tree_insert[simp] - `good_cmp cmp ⇒ - ∀t k v. wf_tree cmp t ⇒ wf_tree cmp (insert cmp k v t)` - (strip_tac \\ +Theorem wf_tree_insert[simp]: + good_cmp cmp ⇒ + ∀t k v. wf_tree cmp t ⇒ wf_tree cmp (insert cmp k v t) +Proof + strip_tac \\ Induct \\ rw[insert_def] \\ CASE_TAC \\ fs[wf_tree_def] \\ @@ -238,40 +245,44 @@ Theorem wf_tree_insert[simp] rw[] \\ metis_tac[good_cmp_def] (* ex*) - -); +QED (* Correctness of lookup *) -Theorem key_ordered_to_fmap - `good_cmp cmp ⇒ +Theorem key_ordered_to_fmap: + good_cmp cmp ⇒ ∀t k res. key_ordered cmp k t res ⇔ - (∀ks k'. ks ∈ FDOM (to_fmap cmp t) ∧ k' ∈ ks ⇒ cmp k k' = res)` - (strip_tac \\ + (∀ks k'. ks ∈ FDOM (to_fmap cmp t) ∧ k' ∈ ks ⇒ cmp k k' = res) +Proof + strip_tac \\ Induct \\ rw[to_fmap_def] \\ eq_tac \\ rw[] \\ - metis_tac[IN_key_set,cmp_thms]); + metis_tac[IN_key_set,cmp_thms] +QED -Theorem wf_tree_Node_imp - `good_cmp cmp ∧ +Theorem wf_tree_Node_imp: + good_cmp cmp ∧ wf_tree cmp (Node k v l r) ⇒ DISJOINT (FDOM (to_fmap cmp l)) (FDOM (to_fmap cmp r)) ∧ (∀x. key_set cmp x ∈ FDOM (to_fmap cmp l) ⇒ cmp k x = Greater) ∧ - (∀x. key_set cmp x ∈ FDOM (to_fmap cmp r) ⇒ cmp k x = Less)` - (rw[IN_DISJOINT,wf_tree_def] \\ + (∀x. key_set cmp x ∈ FDOM (to_fmap cmp r) ⇒ cmp k x = Less) +Proof + rw[IN_DISJOINT,wf_tree_def] \\ spose_not_then strip_assume_tac \\ imp_res_tac to_fmap_key_set \\ imp_res_tac key_ordered_to_fmap \\ - metis_tac[cmp_thms,IN_key_set]); + metis_tac[cmp_thms,IN_key_set] +QED -Theorem lookup_to_fmap - `good_cmp cmp ⇒ +Theorem lookup_to_fmap: + good_cmp cmp ⇒ ∀t k. wf_tree cmp t ⇒ - lookup cmp k t = FLOOKUP (to_fmap cmp t) (key_set cmp k)` - (strip_tac \\ + lookup cmp k t = FLOOKUP (to_fmap cmp t) (key_set cmp k) +Proof + strip_tac \\ Induct \\ rw[lookup_def,to_fmap_def] \\ fs[] \\ @@ -288,7 +299,6 @@ Theorem lookup_to_fmap every_case_tac \\ fs[FLOOKUP_DEF] \\ metis_tac[cmp_thms] (* ex*) - -); +QED val _ = export_theory(); diff --git a/tutorial/solutions/wordfreqProgScript.sml b/tutorial/solutions/wordfreqProgScript.sml index 26a12254c2..14751868a1 100644 --- a/tutorial/solutions/wordfreqProgScript.sml +++ b/tutorial/solutions/wordfreqProgScript.sml @@ -21,8 +21,11 @@ val _ = Globals.max_print_depth := 20 val lookup0_def = Define` lookup0 w t = case mlmap$lookup t w of NONE => 0n | SOME n => n`; -Theorem lookup0_empty[simp] - `!w cmp. lookup0 w (empty cmp) = 0` (EVAL_TAC \\ fs []); +Theorem lookup0_empty[simp]: + !w cmp. lookup0 w (empty cmp) = 0 +Proof +EVAL_TAC \\ fs [] +QED val insert_word_def = Define` insert_word t w = @@ -34,14 +37,16 @@ val insert_line_def = Define` (* and their verification *) -Theorem lookup0_insert - `map_ok t ⇒ +Theorem lookup0_insert: + map_ok t ⇒ lookup0 k (insert t k' v) = - if k = k' then v else lookup0 k t` - (rw [lookup0_def,lookup_insert]); + if k = k' then v else lookup0 k t +Proof + rw [lookup0_def,lookup_insert] +QED -Theorem insert_line_thm - `map_ok t ∧ +Theorem insert_line_thm: + map_ok t ∧ insert_line t s = t' ⇒ map_ok t' ∧ @@ -49,18 +54,20 @@ Theorem insert_line_thm lookup0 w t + frequency s w) ∧ cmp_of t' = cmp_of t ∧ FDOM (to_fmap t') = - FDOM (to_fmap t) ∪ set (splitwords s)` - (strip_tac \\ rveq \\ + FDOM (to_fmap t) ∪ set (splitwords s) +Proof + strip_tac \\ rveq \\ simp[insert_line_def,splitwords_def,frequency_def] \\ Q.SPEC_TAC(`tokens isSpace s`,`ls`) \\ ho_match_mp_tac SNOC_INDUCT \\ simp[] \\ ntac 3 strip_tac \\ simp[MAP_SNOC,FOLDL_SNOC,insert_word_def] \\ rw [insert_thm,lookup0_insert,FILTER_SNOC] \\ - rw [EXTENSION] \\ metis_tac []); + rw [EXTENSION] \\ metis_tac [] +QED -Theorem FOLDL_insert_line - `∀ls t t' s. +Theorem FOLDL_insert_line: + ∀ls t t' s. map_ok t ∧ t' = FOLDL insert_line t ls ∧ EVERY (λw. ∃x. w = strcat x (strlit "\n")) ls ∧ s = concat ls @@ -68,15 +75,17 @@ Theorem FOLDL_insert_line map_ok t' ∧ cmp_of t' = cmp_of t /\ (∀w. lookup0 w t' = lookup0 w t + frequency s w) ∧ - FDOM (to_fmap t') = FDOM (to_fmap t) ∪ set (splitwords s)` - (Induct \\ simp[concat_nil,concat_cons] \\ ntac 3 strip_tac \\ + FDOM (to_fmap t') = FDOM (to_fmap t) ∪ set (splitwords s) +Proof + Induct \\ simp[concat_nil,concat_cons] \\ ntac 3 strip_tac \\ rename1`insert_line t w` \\ imp_res_tac insert_line_thm \\ fs[] \\ `strlit "\n" = str #"\n"` by EVAL_TAC \\ `isSpace #"\n"` by EVAL_TAC \\ first_x_assum drule \\ rw[frequency_concat,splitwords_concat,frequency_concat_space,splitwords_concat_space] \\ - rw[EXTENSION] \\ metis_tac[]); + rw[EXTENSION] \\ metis_tac[] +QED (* Translation of wordfreq helper functions *) @@ -130,9 +139,10 @@ val valid_wordfreq_output_def = Define` file_contents and output, it is actually functional (there is only one correct output). We prove this below: existence and uniqueness. *) -Theorem valid_wordfreq_output_exists - `∃output. valid_wordfreq_output file_chars output` - (rw[valid_wordfreq_output_def] \\ +Theorem valid_wordfreq_output_exists: + ∃output. valid_wordfreq_output file_chars output +Proof + rw[valid_wordfreq_output_def] \\ qexists_tac`QSORT $<= (nub (splitwords file_chars))` \\ qmatch_goalsub_abbrev_tac`set l1 = LIST_TO_SET l2` \\ `PERM (nub l2) l1` by metis_tac[QSORT_PERM] \\ @@ -143,11 +153,13 @@ Theorem valid_wordfreq_output_exists conj_tac >- metis_tac[ALL_DISTINCT_PERM,all_distinct_nub] \\ match_mp_tac QSORT_SORTED \\ simp[transitive_def,total_def] \\ - metis_tac[mlstring_lt_trans,mlstring_lt_cases]); + metis_tac[mlstring_lt_trans,mlstring_lt_cases] +QED -Theorem valid_wordfreq_output_unique - `∀out1 out2. valid_wordfreq_output s out1 ∧ valid_wordfreq_output s out2 ⇒ out1 = out2` - (rw[valid_wordfreq_output_def] \\ +Theorem valid_wordfreq_output_unique: + ∀out1 out2. valid_wordfreq_output s out1 ∧ valid_wordfreq_output s out2 ⇒ out1 = out2 +Proof + rw[valid_wordfreq_output_def] \\ rpt AP_TERM_TAC \\ match_mp_tac (MP_CANON SORTED_PERM_EQ) \\ instantiate \\ @@ -159,7 +171,8 @@ Theorem valid_wordfreq_output_unique instantiate \\ simp[irreflexive_def] \\ metis_tac[mlstring_lt_nonrefl] ) \\ fs[ALL_DISTINCT_PERM_LIST_TO_SET_TO_LIST] \\ - metis_tac[PERM_TRANS,PERM_SYM]); + metis_tac[PERM_TRANS,PERM_SYM] +QED (* Now we can define a function that is the unique valid output for a given file_contents. Note that this function does not have a computable @@ -180,11 +193,12 @@ val wordfreq_output_spec_def = you like.) *) -Theorem wordfreq_output_valid - `!file_contents. +Theorem wordfreq_output_valid: + !file_contents. valid_wordfreq_output file_contents - (concat (compute_wordfreq_output (lines_of file_contents)))` - (rw[valid_wordfreq_output_def,compute_wordfreq_output_def] \\ + (concat (compute_wordfreq_output (lines_of file_contents))) +Proof + rw[valid_wordfreq_output_def,compute_wordfreq_output_def] \\ qmatch_goalsub_abbrev_tac`MAP format_output ls` \\ (* EXERCISE: what is the list of words to use here? *) (* hint: toAscList returns a list of pairs, and you can use @@ -228,17 +242,18 @@ Theorem wordfreq_output_valid simp[lookup0_def, lookup_thm] \\ simp[frequency_def] (* ex*) -); +QED -Theorem wordfreq_output_spec_unique - `valid_wordfreq_output file_chars output ⇒ - wordfreq_output_spec file_chars = output` - ((* EXERCISE: prove this *) +Theorem wordfreq_output_spec_unique: + valid_wordfreq_output file_chars output ⇒ + wordfreq_output_spec file_chars = output +Proof + (* EXERCISE: prove this *) (* hint: it's a one-liner *) (*ex *) metis_tac[valid_wordfreq_output_unique,wordfreq_output_spec_def] (* ex*) -); +QED (* This will be needed for xlet_auto to handle our use of List.foldl *) val empty_v_thm = MapProgTheory.empty_v_thm |> Q.GENL[`a`,`b`] |> Q.ISPECL[`STRING_TYPE`,`NUM`]; @@ -324,19 +339,21 @@ val wordfreq_spec = Q.store_thm("wordfreq_spec", (* Finally, we package the verified program up with the following boilerplate *) -Theorem wordfreq_whole_prog_spec - `hasFreeFD fs ∧ inFS_fname fs fname ∧ +Theorem wordfreq_whole_prog_spec: + hasFreeFD fs ∧ inFS_fname fs fname ∧ cl = [pname; fname] ∧ contents = implode (THE (ALOOKUP fs.inode_tbl (File (THE (ALOOKUP fs.files fname))))) ⇒ whole_prog_spec ^(fetch_v "wordfreq" (get_ml_prog_state())) cl fs NONE - ((=) (add_stdout fs (wordfreq_output_spec contents)))` - (disch_then assume_tac + ((=) (add_stdout fs (wordfreq_output_spec contents))) +Proof + disch_then assume_tac \\ simp[whole_prog_spec_def] \\ qmatch_goalsub_abbrev_tac`fs1 = _ with numchars := _` \\ qexists_tac`fs1` \\ simp[Abbr`fs1`,GSYM add_stdo_with_numchars,with_same_numchars] \\ match_mp_tac (MP_CANON (MATCH_MP app_wgframe (UNDISCH wordfreq_spec))) - \\ xsimpl); + \\ xsimpl +QED val (sem_thm,prog_tm) = whole_prog_thm (get_ml_prog_state ()) "wordfreq" (UNDISCH wordfreq_whole_prog_spec) val wordfreq_prog_def = Define `wordfreq_prog = ^prog_tm`; diff --git a/tutorial/splitwordsScript.sml b/tutorial/splitwordsScript.sml index 9cefedae7e..97ea2cfefd 100644 --- a/tutorial/splitwordsScript.sml +++ b/tutorial/splitwordsScript.sml @@ -14,26 +14,37 @@ val splitwords_def = Define` EVAL ``splitwords (strlit"hello there hello how are you one two one two three")`` *) -Theorem splitwords_nil[simp] - `splitwords (implode "") = []` (EVAL_TAC); -Theorem splitwords_nil_lit[simp] - `splitwords (strlit "") = []` (EVAL_TAC); +Theorem splitwords_nil[simp]: + splitwords (implode "") = [] +Proof +EVAL_TAC +QED +Theorem splitwords_nil_lit[simp]: + splitwords (strlit "") = [] +Proof +EVAL_TAC +QED -Theorem splitwords_concat - `isSpace sp ⇒ - splitwords (s1 ^ str sp ^ s2) = splitwords s1 ++ splitwords s2` - (rewrite_tac [GSYM strcat_assoc] - \\ rw[splitwords_def,mlstringTheory.tokens_append,mlstringTheory.strcat_assoc]); +Theorem splitwords_concat: + isSpace sp ⇒ + splitwords (s1 ^ str sp ^ s2) = splitwords s1 ++ splitwords s2 +Proof + rewrite_tac [GSYM strcat_assoc] + \\ rw[splitwords_def,mlstringTheory.tokens_append,mlstringTheory.strcat_assoc] +QED -Theorem splitwords_concat_space - `isSpace sp ⇒ splitwords (s1 ^ str sp) = splitwords s1` - (rw[] \\ qspec_then`implode ""`mp_tac(Q.GEN`s2`splitwords_concat) \\ - fs[mlstringTheory.strcat_thm]); +Theorem splitwords_concat_space: + isSpace sp ⇒ splitwords (s1 ^ str sp) = splitwords s1 +Proof + rw[] \\ qspec_then`implode ""`mp_tac(Q.GEN`s2`splitwords_concat) \\ + fs[mlstringTheory.strcat_thm] +QED -Theorem splitwords_lines_of - `FLAT (MAP splitwords (lines_of content)) = - splitwords content` - (`isSpace #"\n"` by EVAL_TAC \\ +Theorem splitwords_lines_of: + FLAT (MAP splitwords (lines_of content)) = + splitwords content +Proof + `isSpace #"\n"` by EVAL_TAC \\ rw[all_lines_def,lines_of_def,MAP_MAP_o,o_DEF, GSYM mlstringTheory.str_def,splitwords_concat_space] \\ rw[splitwords_def,mlstringTheory.TOKENS_eq_tokens_sym] \\ @@ -53,7 +64,8 @@ Theorem splitwords_lines_of match_mp_tac FLAT_MAP_TOKENS_FIELDS \\ rw[] \\ EVAL_TAC ) \\ match_mp_tac FLAT_MAP_TOKENS_FIELDS \\ - rw[] \\ EVAL_TAC); + rw[] \\ EVAL_TAC +QED val frequency_def = Define` frequency s w = LENGTH (FILTER ($= w) (splitwords s))`; @@ -64,18 +76,28 @@ EVAL``frequency (strlit"hello there hello how are you one two one two three") (s EVAL``frequency (strlit"hello there hello how are you one two one two three") (strlit"four")`` *) -Theorem frequency_nil[simp] - `frequency (implode "") w = 0` (EVAL_TAC); -Theorem frequency_nil_lit[simp] - `frequency (strlit "") w = 0` (EVAL_TAC); +Theorem frequency_nil[simp]: + frequency (implode "") w = 0 +Proof +EVAL_TAC +QED +Theorem frequency_nil_lit[simp]: + frequency (strlit "") w = 0 +Proof +EVAL_TAC +QED -Theorem frequency_concat - `isSpace sp ⇒ - frequency (s1 ^ str sp ^ s2) w = frequency s1 w + frequency s2 w` - (rw[frequency_def,splitwords_concat,FILTER_APPEND]); +Theorem frequency_concat: + isSpace sp ⇒ + frequency (s1 ^ str sp ^ s2) w = frequency s1 w + frequency s2 w +Proof + rw[frequency_def,splitwords_concat,FILTER_APPEND] +QED -Theorem frequency_concat_space - `isSpace sp ⇒ frequency (s1 ^ str sp) = frequency s1` - (rw[FUN_EQ_THM,frequency_def,splitwords_concat_space]); +Theorem frequency_concat_space: + isSpace sp ⇒ frequency (s1 ^ str sp) = frequency s1 +Proof + rw[FUN_EQ_THM,frequency_def,splitwords_concat_space] +QED val _ = export_theory(); diff --git a/tutorial/wordcountProgScript.sml b/tutorial/wordcountProgScript.sml index f3783f5c29..0a28b35091 100644 --- a/tutorial/wordcountProgScript.sml +++ b/tutorial/wordcountProgScript.sml @@ -28,8 +28,8 @@ val inputLinesFromAny = process_topdecs` val () = append_prog inputLinesFromAny; -Theorem inputLinesFromAny_spec - `OPTION_TYPE FILENAME fo fov ∧ (IS_SOME fo ⇒ hasFreeFD fs) ∧ +Theorem inputLinesFromAny_spec: + OPTION_TYPE FILENAME fo fov ∧ (IS_SOME fo ⇒ hasFreeFD fs) ∧ (IS_NONE fo ⇒ (ALOOKUP fs.infds 0 = SOME (UStream(strlit"stdin"),ReadMode,0))) ⇒ app (p:'ffi ffi_proj) ^(fetch_v "inputLinesFromAny" (get_ml_prog_state())) @@ -38,8 +38,9 @@ Theorem inputLinesFromAny_spec (if IS_SOME fo ⇒ inFS_fname fs (THE fo) then SOME (case fo of NONE => all_lines_inode fs (UStream(strlit"stdin")) | SOME f => all_lines fs f) - else NONE) sv * STDIO (if IS_SOME fo then fs else fastForwardFD fs 0))` - (xcf"inputLinesFromAny"(get_ml_prog_state()) + else NONE) sv * STDIO (if IS_SOME fo then fs else fastForwardFD fs 0)) +Proof + xcf"inputLinesFromAny"(get_ml_prog_state()) \\ reverse(Cases_on`STD_streams fs`) >- (fs[STDIO_def] \\ xpull ) \\ reverse(Cases_on`∃ll. wfFS (fs with numchars := ll)`) >- (fs[STDIO_def,IOFS_def] \\ xpull) \\ xmatch @@ -79,7 +80,8 @@ Theorem inputLinesFromAny_spec \\ EVAL_TAC ) \\ (reverse conj_tac >- (EVAL_TAC \\ rw[])) \\ xapp - \\ fs[]); + \\ fs[] +QED (* -- *) val wordcount = process_topdecs` @@ -104,13 +106,15 @@ val wordcount_precond_def = Define` ALOOKUP fs.inode_tbl (UStream (strlit"stdin")) = SOME contents ∧ fs' = fastForwardFD fs 0`; -Theorem wordcount_precond_numchars - `wordcount_precond cl fs contens fs' ⇒ fs'.numchars = fs.numchars` - (rw[wordcount_precond_def] - \\ every_case_tac \\ fs[]); +Theorem wordcount_precond_numchars: + wordcount_precond cl fs contens fs' ⇒ fs'.numchars = fs.numchars +Proof + rw[wordcount_precond_def] + \\ every_case_tac \\ fs[] +QED -Theorem wordcount_spec - `wordcount_precond cl fs contents fs' +Theorem wordcount_spec: + wordcount_precond cl fs contents fs' ⇒ app (p:'ffi ffi_proj) ^(fetch_v "wordcount" (get_ml_prog_state())) [uv] (STDIO fs * COMMANDLINE cl) @@ -120,8 +124,9 @@ Theorem wordcount_spec strlit " "; mlint$toString (&(LENGTH (splitlines contents))); strlit "\n"])) - * COMMANDLINE cl)` - (simp [concat_def] \\ + * COMMANDLINE cl) +Proof + simp [concat_def] \\ strip_tac \\ xcf "wordcount" (get_ml_prog_state()) \\ xlet_auto >- (xcon \\ xsimpl) \\ @@ -230,10 +235,11 @@ Theorem wordcount_spec \\ Cases_on`cl` \\ fs[wfcl_def] \\ Cases_on`t` \\ fs[] \\ TRY (Cases_on`t'` \\ fs[]) - \\ simp[all_lines_def,splitwords_lines_of,splitwords_def, mlstringTheory.TOKENS_eq_tokens_sym]); + \\ simp[all_lines_def,splitwords_lines_of,splitwords_def, mlstringTheory.TOKENS_eq_tokens_sym] +QED -Theorem wordcount_whole_prog_spec - `wordcount_precond cl fs contents fs' +Theorem wordcount_whole_prog_spec: + wordcount_precond cl fs contents fs' ⇒ whole_prog_spec ^(fetch_v "wordcount" (get_ml_prog_state())) cl fs NONE ((=) @@ -241,8 +247,9 @@ Theorem wordcount_whole_prog_spec (concat [mlint$toString (&(LENGTH (TOKENS isSpace contents))); strlit " "; mlint$toString (&(LENGTH (splitlines contents))); - strlit "\n"])))` - (disch_then assume_tac + strlit "\n"]))) +Proof + disch_then assume_tac \\ imp_res_tac wordcount_precond_numchars \\ pop_assum(assume_tac o SYM) \\ simp[whole_prog_spec_def] @@ -250,7 +257,8 @@ Theorem wordcount_whole_prog_spec \\ qexists_tac`fs1` \\ simp[Abbr`fs1`,GSYM add_stdo_with_numchars,with_same_numchars] \\ match_mp_tac (MP_CANON (MATCH_MP app_wgframe (UNDISCH wordcount_spec))) - \\ xsimpl); + \\ xsimpl +QED val spec = wordcount_whole_prog_spec |> UNDISCH_ALL val (sem_thm,prog_tm) = whole_prog_thm (get_ml_prog_state()) "wordcount" spec diff --git a/tutorial/wordfreqProgScript.sml b/tutorial/wordfreqProgScript.sml index 9c3497eafc..0a6f8971bf 100644 --- a/tutorial/wordfreqProgScript.sml +++ b/tutorial/wordfreqProgScript.sml @@ -21,8 +21,11 @@ val _ = Globals.max_print_depth := 20 val lookup0_def = Define` lookup0 w t = case mlmap$lookup t w of NONE => 0n | SOME n => n`; -Theorem lookup0_empty[simp] - `!w cmp. lookup0 w (empty cmp) = 0` (EVAL_TAC \\ fs []); +Theorem lookup0_empty[simp]: + !w cmp. lookup0 w (empty cmp) = 0 +Proof +EVAL_TAC \\ fs [] +QED val insert_word_def = Define` insert_word t w = @@ -34,14 +37,16 @@ val insert_line_def = Define` (* and their verification *) -Theorem lookup0_insert - `map_ok t ⇒ +Theorem lookup0_insert: + map_ok t ⇒ lookup0 k (insert t k' v) = - if k = k' then v else lookup0 k t` - (rw [lookup0_def,lookup_insert]); + if k = k' then v else lookup0 k t +Proof + rw [lookup0_def,lookup_insert] +QED -Theorem insert_line_thm - `map_ok t ∧ +Theorem insert_line_thm: + map_ok t ∧ insert_line t s = t' ⇒ map_ok t' ∧ @@ -49,18 +54,20 @@ Theorem insert_line_thm lookup0 w t + frequency s w) ∧ cmp_of t' = cmp_of t ∧ FDOM (to_fmap t') = - FDOM (to_fmap t) ∪ set (splitwords s)` - (strip_tac \\ rveq \\ + FDOM (to_fmap t) ∪ set (splitwords s) +Proof + strip_tac \\ rveq \\ simp[insert_line_def,splitwords_def,frequency_def] \\ Q.SPEC_TAC(`tokens isSpace s`,`ls`) \\ ho_match_mp_tac SNOC_INDUCT \\ simp[] \\ ntac 3 strip_tac \\ simp[MAP_SNOC,FOLDL_SNOC,insert_word_def] \\ rw [insert_thm,lookup0_insert,FILTER_SNOC] \\ - rw [EXTENSION] \\ metis_tac []); + rw [EXTENSION] \\ metis_tac [] +QED -Theorem FOLDL_insert_line - `∀ls t t' s. +Theorem FOLDL_insert_line: + ∀ls t t' s. map_ok t ∧ t' = FOLDL insert_line t ls ∧ EVERY (λw. ∃x. w = strcat x (strlit "\n")) ls ∧ s = concat ls @@ -68,15 +75,17 @@ Theorem FOLDL_insert_line map_ok t' ∧ cmp_of t' = cmp_of t /\ (∀w. lookup0 w t' = lookup0 w t + frequency s w) ∧ - FDOM (to_fmap t') = FDOM (to_fmap t) ∪ set (splitwords s)` - (Induct \\ simp[concat_nil,concat_cons] \\ ntac 3 strip_tac \\ + FDOM (to_fmap t') = FDOM (to_fmap t) ∪ set (splitwords s) +Proof + Induct \\ simp[concat_nil,concat_cons] \\ ntac 3 strip_tac \\ rename1`insert_line t w` \\ imp_res_tac insert_line_thm \\ fs[] \\ `strlit "\n" = str #"\n"` by EVAL_TAC \\ `isSpace #"\n"` by EVAL_TAC \\ first_x_assum drule \\ rw[frequency_concat,splitwords_concat,frequency_concat_space,splitwords_concat_space] \\ - rw[EXTENSION] \\ metis_tac[]); + rw[EXTENSION] \\ metis_tac[] +QED (* Translation of wordfreq helper functions *) @@ -130,9 +139,10 @@ val valid_wordfreq_output_def = Define` file_contents and output, it is actually functional (there is only one correct output). We prove this below: existence and uniqueness. *) -Theorem valid_wordfreq_output_exists - `∃output. valid_wordfreq_output file_chars output` - (rw[valid_wordfreq_output_def] \\ +Theorem valid_wordfreq_output_exists: + ∃output. valid_wordfreq_output file_chars output +Proof + rw[valid_wordfreq_output_def] \\ qexists_tac`QSORT $<= (nub (splitwords file_chars))` \\ qmatch_goalsub_abbrev_tac`set l1 = LIST_TO_SET l2` \\ `PERM (nub l2) l1` by metis_tac[QSORT_PERM] \\ @@ -143,11 +153,13 @@ Theorem valid_wordfreq_output_exists conj_tac >- metis_tac[ALL_DISTINCT_PERM,all_distinct_nub] \\ match_mp_tac QSORT_SORTED \\ simp[transitive_def,total_def] \\ - metis_tac[mlstring_lt_trans,mlstring_lt_cases]); + metis_tac[mlstring_lt_trans,mlstring_lt_cases] +QED -Theorem valid_wordfreq_output_unique - `∀out1 out2. valid_wordfreq_output s out1 ∧ valid_wordfreq_output s out2 ⇒ out1 = out2` - (rw[valid_wordfreq_output_def] \\ +Theorem valid_wordfreq_output_unique: + ∀out1 out2. valid_wordfreq_output s out1 ∧ valid_wordfreq_output s out2 ⇒ out1 = out2 +Proof + rw[valid_wordfreq_output_def] \\ rpt AP_TERM_TAC \\ match_mp_tac (MP_CANON SORTED_PERM_EQ) \\ instantiate \\ @@ -159,7 +171,8 @@ Theorem valid_wordfreq_output_unique instantiate \\ simp[irreflexive_def] \\ metis_tac[mlstring_lt_nonrefl] ) \\ fs[ALL_DISTINCT_PERM_LIST_TO_SET_TO_LIST] \\ - metis_tac[PERM_TRANS,PERM_SYM]); + metis_tac[PERM_TRANS,PERM_SYM] +QED (* Now we can define a function that is the unique valid output for a given file_contents. Note that this function does not have a computable @@ -180,11 +193,12 @@ val wordfreq_output_spec_def = you like.) *) -Theorem wordfreq_output_valid - `!file_contents. +Theorem wordfreq_output_valid: + !file_contents. valid_wordfreq_output file_contents - (concat (compute_wordfreq_output (lines_of file_contents)))` - (rw[valid_wordfreq_output_def,compute_wordfreq_output_def] \\ + (concat (compute_wordfreq_output (lines_of file_contents))) +Proof + rw[valid_wordfreq_output_def,compute_wordfreq_output_def] \\ qmatch_goalsub_abbrev_tac`MAP format_output ls` \\ (* EXERCISE: what is the list of words to use here? *) (* hint: toAscList returns a list of pairs, and you can use @@ -219,14 +233,15 @@ Theorem wordfreq_output_valid (* hint: also consider using lookup_thm *) (* hint: the following idiom is useful for specialising an assumption: first_x_assum (qspec_then `` mp_tac) *) -); +QED -Theorem wordfreq_output_spec_unique - `valid_wordfreq_output file_chars output ⇒ - wordfreq_output_spec file_chars = output` - ((* EXERCISE: prove this *) +Theorem wordfreq_output_spec_unique: + valid_wordfreq_output file_chars output ⇒ + wordfreq_output_spec file_chars = output +Proof + (* EXERCISE: prove this *) (* hint: it's a one-liner *) -); +QED (* This will be needed for xlet_auto to handle our use of List.foldl *) val empty_v_thm = MapProgTheory.empty_v_thm |> Q.GENL[`a`,`b`] |> Q.ISPECL[`STRING_TYPE`,`NUM`]; @@ -284,19 +299,21 @@ val wordfreq_spec = Q.store_thm("wordfreq_spec", (* Finally, we package the verified program up with the following boilerplate *) -Theorem wordfreq_whole_prog_spec - `hasFreeFD fs ∧ inFS_fname fs fname ∧ +Theorem wordfreq_whole_prog_spec: + hasFreeFD fs ∧ inFS_fname fs fname ∧ cl = [pname; fname] ∧ contents = implode (THE (ALOOKUP fs.inode_tbl (File (THE (ALOOKUP fs.files fname))))) ⇒ whole_prog_spec ^(fetch_v "wordfreq" (get_ml_prog_state())) cl fs NONE - ((=) (add_stdout fs (wordfreq_output_spec contents)))` - (disch_then assume_tac + ((=) (add_stdout fs (wordfreq_output_spec contents))) +Proof + disch_then assume_tac \\ simp[whole_prog_spec_def] \\ qmatch_goalsub_abbrev_tac`fs1 = _ with numchars := _` \\ qexists_tac`fs1` \\ simp[Abbr`fs1`,GSYM add_stdo_with_numchars,with_same_numchars] \\ match_mp_tac (MP_CANON (MATCH_MP app_wgframe (UNDISCH wordfreq_spec))) - \\ xsimpl); + \\ xsimpl +QED val (sem_thm,prog_tm) = whole_prog_thm (get_ml_prog_state ()) "wordfreq" (UNDISCH wordfreq_whole_prog_spec) val wordfreq_prog_def = Define `wordfreq_prog = ^prog_tm`; diff --git a/tutorial/wordfreqProofScript.sml b/tutorial/wordfreqProofScript.sml index c80cd8245b..16a41c0272 100644 --- a/tutorial/wordfreqProofScript.sml +++ b/tutorial/wordfreqProofScript.sml @@ -59,19 +59,21 @@ val x64_installed_def = Define ` (* -- *) -Theorem wordfreq_compiled_thm - `wfcl [pname; fname] ∧ wfFS fs ∧ hasFreeFD fs ∧ +Theorem wordfreq_compiled_thm: + wfcl [pname; fname] ∧ wfFS fs ∧ hasFreeFD fs ∧ (get_file_contents fs fname = SOME file_contents) ∧ x64_installed compiler_output cbspace data_sp (basis_ffi [pname; fname] fs) mc ms ⇒ ∃io_events ascii_output. machine_sem mc (basis_ffi [pname; fname] fs) ms ⊆ extend_with_resource_limit {Terminate Success io_events} ∧ (extract_fs fs io_events = SOME (add_stdout fs ascii_output)) ∧ - valid_wordfreq_output file_contents ascii_output` - (strip_tac + valid_wordfreq_output file_contents ascii_output +Proof + strip_tac \\ assume_tac wordfreq_compiled_lemma \\ rfs [get_file_contents_def,wfFS_def,compiler_output_def,x64_installed_def] \\ asm_exists_tac \\ fs [option_case_eq] - \\ metis_tac [wordfreqProgTheory.wordfreq_output_spec_def]); + \\ metis_tac [wordfreqProgTheory.wordfreq_output_spec_def] +QED val _ = export_theory(); From 1694ad30b916ca2a059685b862eaa0cf965d4fe3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Johannes=20=C3=85man=20Pohjola?= Date: Mon, 20 May 2019 15:34:31 +1000 Subject: [PATCH 2/7] Fix some broken proofs --- basis/fsFFIPropsScript.sml | 9 ++++++--- compiler/bootstrap/translation/to_closProgScript.sml | 3 +-- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/basis/fsFFIPropsScript.sml b/basis/fsFFIPropsScript.sml index ed5041d7e0..b8d73d967f 100644 --- a/basis/fsFFIPropsScript.sml +++ b/basis/fsFFIPropsScript.sml @@ -81,14 +81,17 @@ Proof fs[bumpFD_def] QED -Theorem bumpFD_inode_tbl[simp] - `(bumpFD fd fs n).inode_tbl = fs.inode_tbl` +Theorem bumpFD_inode_tbl[simp]: + (bumpFD fd fs n).inode_tbl = fs.inode_tbl +Proof + EVAL_TAC +QED Theorem bumpFD_files[simp]: (bumpFD fd fs n).files = fs.files Proof EVAL_TAC -QED (EVAL_TAC); +QED Theorem bumpFD_o: !fs fd n1 n2. diff --git a/compiler/bootstrap/translation/to_closProgScript.sml b/compiler/bootstrap/translation/to_closProgScript.sml index ff50446d87..856f95f6d4 100644 --- a/compiler/bootstrap/translation/to_closProgScript.sml +++ b/compiler/bootstrap/translation/to_closProgScript.sml @@ -256,8 +256,7 @@ val clos_annotate_shift_side = Q.prove(` ho_match_mp_tac clos_annotateTheory.shift_ind>> `∀a b c d. shift [a] b c d ≠ []` by (CCONTR_TAC>>fs[]>> - imp_res_tac clos_annotateTheory.shift_SING>> - fs[])>> + metis_tac[clos_annotateTheory.shift_SING,list_distinct])>> rw[]>> simp[Once (fetch "-" "clos_annotate_shift_side_def")]>> rw[]>> metis_tac[]) |> update_precondition; From 22678e980119bcd5c39a0c769b51f447f6dd76f3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Johannes=20=C3=85man=20Pohjola?= Date: Mon, 20 May 2019 17:20:03 +1000 Subject: [PATCH 3/7] Fix old theorem syntax in inferScript This was not patched up automatically because the script expects the goal to be a quotation, here it's a quotation-producing expression --- compiler/inference/inferScript.sml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/compiler/inference/inferScript.sml b/compiler/inference/inferScript.sml index cb42436cd9..388da337b3 100644 --- a/compiler/inference/inferScript.sml +++ b/compiler/inference/inferScript.sml @@ -611,12 +611,12 @@ constrain_op l op ts = val constrain_op_def = Define constrain_op_quotation; -Theorem constrain_op_pmatch - (`∀op ts.` @ +Theorem constrain_op_pmatch = Q.prove( + `∀op ts.` @ (constrain_op_quotation |> map (fn QUOTE s => Portable.replace_string {from="dtcase",to="case"} s |> QUOTE - | aq => aq))) - (rpt strip_tac + | aq => aq)), + rpt strip_tac >> rpt(CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac) >> fs[constrain_op_def]); From 4f331e690829ce68efcc59ba19bd90b8852623e1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Johannes=20=C3=85man=20Pohjola?= Date: Mon, 20 May 2019 17:25:56 +1000 Subject: [PATCH 4/7] Fix stray old theorem syntax in compiler backend --- compiler/backend/bvl_to_bviScript.sml | 8 ++++---- compiler/backend/stack_allocScript.sml | 16 ++++++++-------- compiler/backend/stack_namesScript.sml | 8 ++++---- compiler/backend/stack_to_labScript.sml | 8 ++++---- 4 files changed, 20 insertions(+), 20 deletions(-) diff --git a/compiler/backend/bvl_to_bviScript.sml b/compiler/backend/bvl_to_bviScript.sml index cdb4515305..a55fd0ac9f 100644 --- a/compiler/backend/bvl_to_bviScript.sml +++ b/compiler/backend/bvl_to_bviScript.sml @@ -244,12 +244,12 @@ local val compile_op_quotation = ` in val compile_op_def = Define compile_op_quotation; -Theorem compile_op_pmatch - (`∀op c1.` @ +Theorem compile_op_pmatch = Q.prove( + `∀op c1.` @ (compile_op_quotation |> map (fn QUOTE s => Portable.replace_string {from="dtcase",to="case"} s |> QUOTE - | aq => aq))) - (rpt strip_tac + | aq => aq)), + rpt strip_tac >> rpt(CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac) >> fs[compile_op_def]); end diff --git a/compiler/backend/stack_allocScript.sml b/compiler/backend/stack_allocScript.sml index 8305b89729..67f284b697 100644 --- a/compiler/backend/stack_allocScript.sml +++ b/compiler/backend/stack_allocScript.sml @@ -610,12 +610,12 @@ val next_lab_quotation = ` in val next_lab_def = Define next_lab_quotation; -Theorem next_lab_pmatch - (`∀p aux.` @ +Theorem next_lab_pmatch = Q.prove( + `∀p aux.` @ (next_lab_quotation |> map (fn QUOTE s => Portable.replace_string {from="dtcase",to="case"} s |> QUOTE - | aq => aq))) - (rpt strip_tac + | aq => aq)), + rpt strip_tac >> CONV_TAC(patternMatchesLib.PMATCH_LIFT_BOOL_CONV true) >> rpt strip_tac >> rw[Once next_lab_def] @@ -650,12 +650,12 @@ val comp_quotation = ` in val comp_def = Define comp_quotation -Theorem comp_pmatch - (`∀n m p.` @ +Theorem comp_pmatch = Q.prove( + `∀n m p.` @ (comp_quotation |> map (fn QUOTE s => Portable.replace_string {from="dtcase",to="case"} s |> QUOTE - | aq => aq))) - (rpt strip_tac + | aq => aq)), + rpt strip_tac >> CONV_TAC(patternMatchesLib.PMATCH_LIFT_BOOL_CONV true) >> rpt strip_tac >> rw[Once comp_def,pairTheory.ELIM_UNCURRY] >> every_case_tac >> fs[]); diff --git a/compiler/backend/stack_namesScript.sml b/compiler/backend/stack_namesScript.sml index 785ede5990..8be9d38f17 100644 --- a/compiler/backend/stack_namesScript.sml +++ b/compiler/backend/stack_namesScript.sml @@ -81,12 +81,12 @@ local val comp_quotation = ` in val comp_def = Define comp_quotation -Theorem comp_pmatch - (`∀f p.` @ +Theorem comp_pmatch = Q.prove( + `∀f p.` @ (comp_quotation |> map (fn QUOTE s => Portable.replace_string {from="dtcase",to="case"} s |> QUOTE - | aq => aq))) - (rpt( + | aq => aq)), + rpt( rpt strip_tac >> CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> every_case_tac diff --git a/compiler/backend/stack_to_labScript.sml b/compiler/backend/stack_to_labScript.sml index d215d1b01e..2c3699f04a 100644 --- a/compiler/backend/stack_to_labScript.sml +++ b/compiler/backend/stack_to_labScript.sml @@ -94,12 +94,12 @@ local val flatten_quotation = ` in val flatten_def = Define flatten_quotation; -Theorem flatten_pmatch - (`∀p n m.` @ +Theorem flatten_pmatch = Q.prove( + `∀p n m.` @ (flatten_quotation |> map (fn QUOTE s => Portable.replace_string {from="dtcase",to="case"} s |> QUOTE - | aq => aq))) - (rpt strip_tac + | aq => aq)), + rpt strip_tac >> CONV_TAC(patternMatchesLib.PMATCH_LIFT_BOOL_CONV true) >> rpt strip_tac >> rw[Once flatten_def,pairTheory.ELIM_UNCURRY] >> every_case_tac >> fs[]); From 433fc2b8c375b4db12062cc595adc88fab425511 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Johannes=20=C3=85man=20Pohjola?= Date: Tue, 21 May 2019 07:54:49 +1000 Subject: [PATCH 5/7] Fix old-style thm syntax in inferencer proofs --- compiler/inference/proofs/inferCompleteScript.sml | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/compiler/inference/proofs/inferCompleteScript.sml b/compiler/inference/proofs/inferCompleteScript.sml index d4db8a3e11..53083885a6 100644 --- a/compiler/inference/proofs/inferCompleteScript.sml +++ b/compiler/inference/proofs/inferCompleteScript.sml @@ -1368,8 +1368,8 @@ Proof metis_tac[env_rel_extend] QED -Theorem infer_ds_complete - `type_ds T tenv ds ids tenv' ∧ +Theorem infer_ds_complete: + type_ds T tenv ds ids tenv' ∧ env_rel tenv ienv ∧ (* do you need both of these? *) inf_set_tids_ienv (count st1.next_id) ienv ∧ @@ -1384,8 +1384,9 @@ Theorem infer_ds_complete *) tenv_equiv (remap_tenv g tenv') mapped_tenv' ∧ env_rel mapped_tenv' ienv' ∧ - st2.next_id = st1.next_id + CARD ids` - (rw[] + st2.next_id = st1.next_id + CARD ids +Proof + rw[] \\ drule(CONJUNCT2 type_d_type_d_canon) \\ simp[] \\ disch_then drule @@ -1434,7 +1435,8 @@ Theorem infer_ds_complete \\ goal_assum(first_assum o mp_then Any mp_tac) (* \\ imp_res_tac DISJOINT_SYM - \\ drule (GEN_ALL BIJ_extend_bij) \\ fs[]*)); + \\ drule (GEN_ALL BIJ_extend_bij) \\ fs[]*) +QED (* Theorem check_specs_complete: From 8f6b82687b760083212e1aa4ab21bd614445ef8e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Johannes=20=C3=85man=20Pohjola?= Date: Tue, 21 May 2019 09:52:59 +1000 Subject: [PATCH 6/7] Fix a few more old thm syntax uses --- .../proofs/data_to_word_memoryProofScript.sml | 12 +++++++----- .../encoders/monadic_enc/monadic_enc32Script.sml | 9 +++++---- .../encoders/monadic_enc/monadic_enc64Script.sml | 9 +++++---- 3 files changed, 17 insertions(+), 13 deletions(-) diff --git a/compiler/backend/proofs/data_to_word_memoryProofScript.sml b/compiler/backend/proofs/data_to_word_memoryProofScript.sml index be02374630..ebef8474e0 100644 --- a/compiler/backend/proofs/data_to_word_memoryProofScript.sml +++ b/compiler/backend/proofs/data_to_word_memoryProofScript.sml @@ -6117,8 +6117,8 @@ Proof \\ AP_THM_TAC \\ AP_TERM_TAC) QED -Theorem heap_in_memory_store_UpdateByte - `heap_in_memory_store heap a sp sp1 gens c s m dm limit ∧ +Theorem heap_in_memory_store_UpdateByte: + heap_in_memory_store heap a sp sp1 gens c s m dm limit ∧ heap = ha ++ [Bytes be fl bs ws] ++ hb ∧ i < LENGTH bs ∧ ad = curr + bytes_in_word + n2w i + (bytes_in_word:'a word) * n2w (heap_length ha) ∧ FLOOKUP s CurrHeap = SOME (Word curr) ∧ @@ -6126,8 +6126,9 @@ Theorem heap_in_memory_store_UpdateByte ⇒ heap_in_memory_store (ha ++ [Bytes be fl (LUPDATE b i bs) ws] ++ hb) a sp sp1 gens c s - ((byte_align ad =+ Word (set_byte ad b w be)) m) dm limit` - (rw[heap_in_memory_store_def] + ((byte_align ad =+ Word (set_byte ad b w be)) m) dm limit +Proof + rw[heap_in_memory_store_def] \\ fs[heap_length_Bytes,heap_length_APPEND] \\ clean_tac \\ fs[byte_aligned_def,byte_align_def] @@ -6322,7 +6323,8 @@ Theorem heap_in_memory_store_UpdateByte by ( simp[] ) \\ pop_assum SUBST1_TAC \\ simp[lupdate_append2] ) - \\ fsrw_tac[star_ss][]); + \\ fsrw_tac[star_ss][] +QED val hide_memory_rel_def = Define` hide_memory_rel = memory_rel`; diff --git a/compiler/encoders/monadic_enc/monadic_enc32Script.sml b/compiler/encoders/monadic_enc/monadic_enc32Script.sml index 48f0d23719..bb441d83d3 100644 --- a/compiler/encoders/monadic_enc/monadic_enc32Script.sml +++ b/compiler/encoders/monadic_enc/monadic_enc32Script.sml @@ -246,10 +246,10 @@ val enc_sec_hash_32_ls_correct = Q.prove(` first_x_assum drule>>rw[]>> simp[enc_sec_def]); -Theorem enc_secs_32_correct` +Theorem enc_secs_32_correct: enc_secs_32 enc n xs = - (enc_sec_list enc xs)` - ( + (enc_sec_list enc xs) +Proof fs[enc_secs_32_def,enc_secs_32_aux_def]>> fs[fetch "-" "run_ienc_state_32_def",run_def]>> simp[enc_sec_hash_32_ls_full_def]>> @@ -258,6 +258,7 @@ Theorem enc_secs_32_correct` impl_tac>- (unabbrev_all_tac>>fs[good_table_32_def,EVERY_REPLICATE])>> rw[]>> - fs[enc_sec_list_def]); + fs[enc_sec_list_def] +QED val _ = export_theory(); diff --git a/compiler/encoders/monadic_enc/monadic_enc64Script.sml b/compiler/encoders/monadic_enc/monadic_enc64Script.sml index 215528939e..ce93438590 100644 --- a/compiler/encoders/monadic_enc/monadic_enc64Script.sml +++ b/compiler/encoders/monadic_enc/monadic_enc64Script.sml @@ -246,10 +246,10 @@ val enc_sec_hash_64_ls_correct = Q.prove(` first_x_assum drule>>rw[]>> simp[enc_sec_def]); -Theorem enc_secs_64_correct` +Theorem enc_secs_64_correct: enc_secs_64 enc n xs = - (enc_sec_list enc xs)` - ( + (enc_sec_list enc xs) +Proof fs[enc_secs_64_def,enc_secs_64_aux_def]>> fs[fetch "-" "run_ienc_state_64_def",run_def]>> simp[enc_sec_hash_64_ls_full_def]>> @@ -258,6 +258,7 @@ Theorem enc_secs_64_correct` impl_tac>- (unabbrev_all_tac>>fs[good_table_64_def,EVERY_REPLICATE])>> rw[]>> - fs[enc_sec_list_def]); + fs[enc_sec_list_def] +QED val _ = export_theory(); From cfefc5ef488c0a47e68c80c41a37349892bbaff6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Johannes=20=C3=85man=20Pohjola?= Date: Wed, 22 May 2019 10:01:08 +1000 Subject: [PATCH 7/7] Fix a broken ag32 proof --- compiler/backend/ag32/proofs/ag32_basis_ffiProofScript.sml | 3 --- 1 file changed, 3 deletions(-) diff --git a/compiler/backend/ag32/proofs/ag32_basis_ffiProofScript.sml b/compiler/backend/ag32/proofs/ag32_basis_ffiProofScript.sml index 168ce50ca3..bcaabca46f 100644 --- a/compiler/backend/ag32/proofs/ag32_basis_ffiProofScript.sml +++ b/compiler/backend/ag32/proofs/ag32_basis_ffiProofScript.sml @@ -3231,7 +3231,6 @@ Proof fs[word_add_n2w]>> qmatch_goalsub_abbrev_tac`ls MOD _`>> qexists_tac`ls`>>simp[]>> - qexists_tac`inp`>>simp[]>> rw[] >- (simp[fsFFITheory.bumpFD_def,AFUPDKEY_ALOOKUP]>> @@ -3252,8 +3251,6 @@ Proof `SUC strm = output_buffer_size + 1` by rfs[ag32_fs_ok_def, ADD1] >> `nn ≤ output_buffer_size + 1` by simp[Abbr`nn`, MIN_DEF] >> fs[EVAL``output_buffer_size``]) - >- - (EVAL_TAC \\fs[]) >- (pop_assum mp_tac>>EVAL_TAC) >- (