From 3fe61a3329599e526317c05b2807b27dcb5a8658 Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Tue, 31 May 2022 17:06:19 +0200 Subject: [PATCH 01/36] Init of the project, start of functions --- compiler/backend/word_comSubExpElimScript.sml | 86 +++++++++++++++++++ 1 file changed, 86 insertions(+) create mode 100644 compiler/backend/word_comSubExpElimScript.sml diff --git a/compiler/backend/word_comSubExpElimScript.sml b/compiler/backend/word_comSubExpElimScript.sml new file mode 100644 index 0000000000..2e0fec3001 --- /dev/null +++ b/compiler/backend/word_comSubExpElimScript.sml @@ -0,0 +1,86 @@ +(* +This file is a Work in Progress. +It gives some functions and verification proofs about a Common Sub-Expression Elimination occuring right atfer the SSA-like renaming. +*) + +(* +Mind map / TODO: +- the register equivalence form + -> num list list + -> Grouping equivalent registers together, keeping the first register added to a group in the head. + -> Adding a r2 -> r1 to the existing mapping consits of looking if ∃group∈map. r1∈group. + If so, we look if ∃group'∈map. r2∈group'. + If so, we merge group and group'. + Else, we add r2 to group in the second place. + Else, we look if ∃group'∈map. r2∈group'. + If so, we add r1 to group' in the second place. + Else, we create a group=[r1;r2] that we add to map. + -> !!! Case of function call we context conservation !!! + One solution could be +*) + +open preamble wordLangTheory boolTheory + +Definition listEquality_def: + listEquality (hd1::tl1) (hd2::tl2) = (hd1=hd2 ∧ listEquality tl1 tl2) ∧ + listEquality [] [] = T ∧ + listEquality (hd1::tl1) [] = F ∧ + listEquality [] (hd2::tl2) = F +End + +Theorem listEquality_correct: + ∀L1 L2. listEquality L1 L2 ⇔ L1 = L2 +Proof + strip_tac >> + Induct_on ‘L1’ + >- (Cases_on ‘L2’ + \\ rw[listEquality_def]) + >- (Cases_on ‘L2’ + >- rw[listEquality_def] + >- (strip_tac >> + Cases_on ‘h=h'’ + \\ rw[listEquality_def])) +QED + + +(* +Principle: + We keep track of a map containing all instructions already dealt with, and we explore the program to find instuctions matching one in the map. + If we find one, we change the instruction by a simple move and we keep track of the registers equivalence. + If we don't find any, depending on the instruction, we store it into the map under the shape of an num list. +Signification of the terms: + r -> registers or imm_registers + i -> instructions + e -> expressions + x -> "store_name" + p -> programs + c -> comparisons + m -> num_set + b -> binop + s -> string +*) +Definition instrToList_def: + instrToList regs instrs (Skip) = (regs, instrs, Skip) ∧ + instrToList regs instrs (Move r1 r2) = ((r1,r2)::regs, instrs, Move r1 r2) ∧ + instrToList regs instrs (Inst i) = (regs, instrs, Skip) ∧ + instrToList regs instrs (Assign r e) = (regs, instrs, Skip) ∧ + instrToList regs instrs (Get r x) = (regs, instrs, Skip) ∧ + instrToList regs instrs (Set x r) = (regs, instrs, Skip) ∧ + instrToList regs instrs (Store e r) = (regs, instrs, Skip) ∧ + instrToList regs instrs (MustTerminate p) = (regs, instrs, Skip) ∧ + instrToList regs instrs (Call arg1 arg2 arg3 arg4) = (regs, instrs, Skip) ∧ + instrToList regs instrs (Seq p1 p2) = (regs, instrs, Skip) ∧ + instrToList regs instrs (If c r1 r2 p1 p2) = (regs, instrs, Skip) ∧ + instrToList regs instrs (Alloc r m) = (regs, instrs, Skip) ∧ + instrToList regs instrs (Raise r) = (regs, instrs, Skip) ∧ + instrToList regs instrs (Return r1 r2) = (regs, instrs, Skip) ∧ + instrToList regs instrs (Tick) = (regs, instrs, Skip) ∧ + instrToList regs instrs (OpCurrHeap b r1 r2) = (regs, instrs, Skip) ∧ + instrToList regs instrs (LocValue r1 r2) = (regs, instrs, Skip) ∧ + instrToList regs instrs (Install r1 r2 r3 r4 m) = (regs, instrs, Skip) ∧ + instrToList regs instrs (CodeBufferWrite r1 r2) = (regs, instrs, Skip) ∧ + instrToList regs instrs (DataBufferWrite r1 r2) = (regs, instrs, Skip) ∧ + instrToList regs instrs (FFI s r1 r2 r3 r4 m) = (regs, instrs, Skip) +End + + From a6c68db0322313bb3f733b2f616112c21edc1c7a Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Wed, 1 Jun 2022 11:14:33 +0200 Subject: [PATCH 02/36] Comparison between lists using ordering --- compiler/backend/word_comSubExpElimScript.sml | 32 +++++++++++-------- 1 file changed, 19 insertions(+), 13 deletions(-) diff --git a/compiler/backend/word_comSubExpElimScript.sml b/compiler/backend/word_comSubExpElimScript.sml index 2e0fec3001..7cc8afcfd2 100644 --- a/compiler/backend/word_comSubExpElimScript.sml +++ b/compiler/backend/word_comSubExpElimScript.sml @@ -19,30 +19,36 @@ Mind map / TODO: One solution could be *) -open preamble wordLangTheory boolTheory +open preamble wordLangTheory boolTheory mlmapTheory -Definition listEquality_def: - listEquality (hd1::tl1) (hd2::tl2) = (hd1=hd2 ∧ listEquality tl1 tl2) ∧ - listEquality [] [] = T ∧ - listEquality (hd1::tl1) [] = F ∧ - listEquality [] (hd2::tl2) = F +val _ = new_theory "comSubExpElim"; + +(* + Can not figure out how to make `NotGE` work, HOL keep raising: + > The following variables are free in the right hand side of the proposed definition: "NotGE" + So I replaced it with `Greater`. +*) +Definition listCmp_def: + (listCmp ( (hd1:num) :: tl1) ( (hd2:num) :: tl2) = if hd1=hd2 then listCmp tl1 tl2 else if hd1>hd2 then Greater else Greater) ∧ + (listCmp [] [] = Equal) ∧ + (listCmp (hd1::tl1) [] = Greater) ∧ + (listCmp [] (hd2::tl2) = Greater) End -Theorem listEquality_correct: - ∀L1 L2. listEquality L1 L2 ⇔ L1 = L2 +Theorem listCmp_correct: + ∀L1 L2. (listCmp L1 L2 = Equal) ⇔ L1 = L2 Proof strip_tac >> Induct_on ‘L1’ >- (Cases_on ‘L2’ - \\ rw[listEquality_def]) + \\ rw[listCmp_def]) >- (Cases_on ‘L2’ - >- rw[listEquality_def] + >- rw[listCmp_def] >- (strip_tac >> Cases_on ‘h=h'’ - \\ rw[listEquality_def])) + \\ rw[listCmp_def])) QED - (* Principle: We keep track of a map containing all instructions already dealt with, and we explore the program to find instuctions matching one in the map. @@ -59,7 +65,7 @@ Signification of the terms: b -> binop s -> string *) -Definition instrToList_def: +Definition comSubExpElim_def: instrToList regs instrs (Skip) = (regs, instrs, Skip) ∧ instrToList regs instrs (Move r1 r2) = ((r1,r2)::regs, instrs, Move r1 r2) ∧ instrToList regs instrs (Inst i) = (regs, instrs, Skip) ∧ From b17beccaea7ebb861aec9850558f0b55e6107204 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Wed, 1 Jun 2022 15:34:57 +0200 Subject: [PATCH 03/36] Set up compilation to wordLang (at SSA transformation) --- examples/compilation/to_word/Holmakefile | 43 +++++++++++ .../to_word/to_wordCompileScript.sml | 75 +++++++++++++++++++ 2 files changed, 118 insertions(+) create mode 100644 examples/compilation/to_word/Holmakefile create mode 100644 examples/compilation/to_word/to_wordCompileScript.sml diff --git a/examples/compilation/to_word/Holmakefile b/examples/compilation/to_word/Holmakefile new file mode 100644 index 0000000000..a805b47127 --- /dev/null +++ b/examples/compilation/to_word/Holmakefile @@ -0,0 +1,43 @@ +INCLUDES = $(CAKEMLDIR)/misc $(CAKEMLDIR)/basis $(CAKEMLDIR)/compiler ../.. + +all: $(DEFAULT_TARGETS) README.md exec +.PHONY: all + +README_SOURCES = $(wildcard *Script.sml) $(wildcard *Lib.sml) $(wildcard *Syntax.sml) +DIRS = $(wildcard */) +README.md: $(CAKEMLDIR)/developers/readme_gen readmePrefix $(patsubst %,%readmePrefix,$(DIRS)) $(README_SOURCES) + $(protect $(CAKEMLDIR)/developers/readme_gen) $(README_SOURCES) + +ifndef CC +CC=gcc +endif +cat.S: *catCompileScript.sml +cake_cat: cat.S $(CAKEMLDIR)/basis/basis_ffi.o + $(CC) $< $(protect $(CAKEMLDIR)/basis/basis_ffi.o) $(GCCFLAGS) -o $@ +grep.S: *grepCompileScript.sml +cake_grep: grep.S $(CAKEMLDIR)/basis/basis_ffi.o + $(CC) $< $(protect $(CAKEMLDIR)/basis/basis_ffi.o) $(GCCFLAGS) -o $@ +patch.S: *patchCompileScript.sml +cake_patch: patch.S $(CAKEMLDIR)/basis/basis_ffi.o + $(CC) $< $(protect $(CAKEMLDIR)/basis/basis_ffi.o) $(GCCFLAGS) -o $@ +diff.S: *diffCompileScript.sml +cake_diff: diff.S $(CAKEMLDIR)/basis/basis_ffi.o + $(CC) $< $(protect $(CAKEMLDIR)/basis/basis_ffi.o) $(GCCFLAGS) -o $@ +hello.S: *helloCompileScript.sml +cake_hello: hello.S $(CAKEMLDIR)/basis/basis_ffi.o + $(CC) $< $(protect $(CAKEMLDIR)/basis/basis_ffi.o) $(GCCFLAGS) -o $@ +sort.S: *sortCompileScript.sml +cake_sort: sort.S $(CAKEMLDIR)/basis/basis_ffi.o + $(CC) $< $(protect $(CAKEMLDIR)/basis/basis_ffi.o) $(GCCFLAGS) -o $@ +echo.S: *echoCompileScript.sml +cake_echo: echo.S $(CAKEMLDIR)/basis/basis_ffi.o + $(CC) $< $(protect $(CAKEMLDIR)/basis/basis_ffi.o) $(GCCFLAGS) -o $@ +helloErr.S: *helloErrCompileScript.sml +cake_helloErr: helloErr.S $(CAKEMLDIR)/basis/basis_ffi.o + $(CC) $< $(protect $(CAKEMLDIR)/basis/basis_ffi.o) $(GCCFLAGS) -o $@ +iocat.S: *iocatCompileScript.sml +cake_iocat: iocat.S $(CAKEMLDIR)/basis/basis_ffi.o + $(CC) $< $(protect $(CAKEMLDIR)/basis/basis_ffi.o) $(GCCFLAGS) -o $@ + +exec: cake_cat cake_grep cake_patch cake_diff cake_hello cake_sort cake_echo cake_helloErr cake_iocat +.PHONY: exec diff --git a/examples/compilation/to_word/to_wordCompileScript.sml b/examples/compilation/to_word/to_wordCompileScript.sml new file mode 100644 index 0000000000..4e69c96cf6 --- /dev/null +++ b/examples/compilation/to_word/to_wordCompileScript.sml @@ -0,0 +1,75 @@ +(* + Compiles a program to wordLang +*) +open preamble compilationLib basis + +val _ = new_theory "to_wordCompile" + +val _ = (max_print_depth := 500); + +Overload "▸" = “wordLang$Seq” +val _ = set_fixity "▸" (Infixl 500); + +Definition comp_to_ssa_def: + comp_to_ssa c b (name_num,arg_count,prog) = + let prog = compile_exp prog; + maxv = max_var prog + 1; + inst_prog = inst_select c maxv prog; + ssa_prog = (if b then full_ssa_cc_trans arg_count else I) inst_prog + in + compile_exp ssa_prog +End + +Definition get_ssa_for_def: + get_ssa_for fun_name b c p = + let (_,funs,names) = to_word_0 c p in + let xs = MAP (λ(x,y). (lookup x names,y)) funs in + let fun_name = implode fun_name in + let ys = FILTER (λ(x,y). case x of NONE => F | SOME s => fun_name = s) xs in + comp_to_ssa c.lab_conf.asm_conf b (HD ys) +End + +fun comp_to_ssa do_ssa fun_name prog_def = + let + val cs = compilation_compset() + val conf_def = x64_configTheory.x64_backend_config_def + val data_prog_name = "data_prog" + val to_data_thm = compile_to_data cs conf_def prog_def data_prog_name + val _ = save_thm("to_data_thm", to_data_thm) + val data_prog_def = definition(mk_abbrev_name data_prog_name) + val to_word_0_thm = compile_to_word_0 data_prog_def to_data_thm + val word_0_p_def = fetch "-" "word_0_p_def" + val word_0_names_def = fetch "-" "word_0_names_def" + val () = computeLib.extend_compset + [computeLib.Defs [word_0_p_def,word_0_names_def,comp_to_ssa_def, + x64_backend_config_def, x64_targetTheory.x64_config_def, x64_names_def]] cs; + val eval = computeLib.CBV_CONV cs; + val s = stringSyntax.fromMLstring fun_name + val tm = to_word_0_thm |> concl |> dest_eq |> fst + val b = if do_ssa then T else F + val l = “get_ssa_for ^s ^b ^(rand (rator tm)) ^(rand tm)” + in + l |> (REWR_CONV get_ssa_for_def THENC + REWRITE_CONV [to_word_0_thm] THENC eval) + end; + +(* foldr example *) + +val decs = process_topdecs ‘ + fun foldr f e xs = + case xs of + [] => e + | (y::ys) => f y (foldr f e ys); + val _ = foldr (fn x => x);’ + +Definition foldr_prog_def: + foldr_prog = ^decs +End + +Theorem foldr_example = + comp_to_ssa false "foldr" foldr_prog_def; + +Theorem foldr_example_ssa = + comp_to_ssa true "foldr" foldr_prog_def; + +val _ = export_theory (); From 7f5ca8d1e56d50732c8afc536df05344c1267524 Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Fri, 3 Jun 2022 11:45:25 +0200 Subject: [PATCH 04/36] progToNumList (except wordToNum), canonical form. Progress in comSubExpElim. --- compiler/backend/word_comSubExpElimScript.sml | 550 ++++++++++++++++-- 1 file changed, 500 insertions(+), 50 deletions(-) diff --git a/compiler/backend/word_comSubExpElimScript.sml b/compiler/backend/word_comSubExpElimScript.sml index 7cc8afcfd2..19e5234c14 100644 --- a/compiler/backend/word_comSubExpElimScript.sml +++ b/compiler/backend/word_comSubExpElimScript.sml @@ -1,14 +1,17 @@ (* This file is a Work in Progress. -It gives some functions and verification proofs about a Common Sub-Expression Elimination occuring right atfer the SSA-like renaming. +It gives some functions and verification proofs about a Common Sub-Expression +Elimination occuring right atfer the SSA-like renaming. *) (* Mind map / TODO: - the register equivalence form -> num list list - -> Grouping equivalent registers together, keeping the first register added to a group in the head. - -> Adding a r2 -> r1 to the existing mapping consits of looking if ∃group∈map. r1∈group. + -> Grouping equivalent registers together, keeping the first register + added to a group in the head. + -> Adding a r2 -> r1 to the existing mapping consits of looking if + ∃group∈map. r1∈group. If so, we look if ∃group'∈map. r2∈group'. If so, we merge group and group'. Else, we add r2 to group in the second place. @@ -16,46 +19,456 @@ Mind map / TODO: If so, we add r1 to group' in the second place. Else, we create a group=[r1;r2] that we add to map. -> !!! Case of function call we context conservation !!! - One solution could be -*) - + One solution could be +*) + open preamble wordLangTheory boolTheory mlmapTheory val _ = new_theory "comSubExpElim"; - -(* - Can not figure out how to make `NotGE` work, HOL keep raising: - > The following variables are free in the right hand side of the proposed definition: "NotGE" - So I replaced it with `Greater`. -*) + +Type regsT = ``:num list list`` + +(* LIST COMPARISON *) + Definition listCmp_def: - (listCmp ( (hd1:num) :: tl1) ( (hd2:num) :: tl2) = if hd1=hd2 then listCmp tl1 tl2 else if hd1>hd2 then Greater else Greater) ∧ + (listCmp ((hd1:num) :: tl1) ((hd2:num) :: tl2) = + if hd1=hd2 + then listCmp tl1 tl2 + else if hd1>hd2 then Greater else Less) ∧ (listCmp [] [] = Equal) ∧ (listCmp (hd1::tl1) [] = Greater) ∧ - (listCmp [] (hd2::tl2) = Greater) + (listCmp [] (hd2::tl2) = Less) +End + +Theorem listCmpEq_correct: + ∀L1 L2. listCmp L1 L2 = Equal ⇔ L1 = L2 +Proof + strip_tac + \\Induct_on ‘L1’ + >- (Cases_on ‘L2’ + \\ rw[listCmp_def]) + >- (Cases_on ‘L2’ + >- rw[listCmp_def] + >- (strip_tac >> + Cases_on ‘h=h'’ + \\ rw[listCmp_def])) +QED + +(* REGISTERS EQUIVALENCE MEMORY *) + +Definition listLookup_def: + listLookup x [] = F ∧ + listLookup x (y::tl) = if x=y then T else listLookup x tl +End + +Definition regsLookup_def: + regsLookup r [] = F ∧ + regsLookup r (hd::tl) = if listLookup r hd then T else regsLookup r tl +End + +Definition regsUpdate1Aux_def: + regsUpdate1Aux r l (hd::tl) = + if listLookup r hd + then (l ++ hd)::tl + else hd::(regsUpdate1Aux r l tl) +End + +Definition regsUpdate1_def: + regsUpdate1 r1 r2 (hd::tl) = + if listLookup r1 hd + then if listLookup r2 hd + then (hd::tl) + else regsUpdate1Aux r2 hd tl + else if listLookup r2 hd + then regsUpdate1Aux r1 hd tl + else hd::(regsUpdate1 r1 r2 tl) +End + +Definition regsUpdate2_def: + regsUpdate2 r1 r2 ((hd::tl)::tl') = + if listLookup r1 (hd::tl) + then (hd::r2::tl)::tl' + else (hd::tl)::(regsUpdate2 r1 r2 tl') End -Theorem listCmp_correct: - ∀L1 L2. (listCmp L1 L2 = Equal) ⇔ L1 = L2 +Definition regsUpdate_def: + regsUpdate r1 r2 [] = [[r1;r2]] ∧ + regsUpdate r1 r2 (hd::tl) = + if regsLookup r1 (hd::tl) + then if regsLookup r2 (hd::tl) + then regsUpdate1 r1 r2 (hd::tl) + else regsUpdate2 r1 r2 (hd::tl) + else if regsLookup r2 (hd::tl) + then regsUpdate2 r2 r1 (hd::tl) + else [r1;r2]::hd::tl +End + +Theorem regsUpdate_test_merge1: + regsUpdate 1 6 [[1;2;3];[4;5;6];[7;8;9]] = [[1;2;3;4;5;6];[7;8;9]] +Proof + rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, + regsUpdate2_def,regsLookup_def,listLookup_def] +QED + +Theorem regsUpdate_test_merge2: + regsUpdate 1 7 [[1;2;3];[4;5;6];[7;8;9]] = [[4;5;6];[1;2;3;7;8;9]] +Proof + rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, + regsUpdate2_def,regsLookup_def,listLookup_def] +QED + +Theorem regsUpdate_test_merge3: + regsUpdate 5 7 [[1;2;3];[4;5;6];[7;8;9]] = [[1;2;3]; [4;5;6;7;8;9]] +Proof + rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, + regsUpdate2_def,regsLookup_def,listLookup_def] +QED + +Theorem regsUpdate_test_merge4: + regsUpdate 6 1 [[1;2;3];[4;5;6];[7;8;9]] = [[1;2;3;4;5;6];[7;8;9]] +Proof + rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, + regsUpdate2_def,regsLookup_def,listLookup_def] +QED + +Theorem regsUpdate_test_merge5: + regsUpdate 7 1 [[1;2;3];[4;5;6];[7;8;9]] = [[4;5;6];[1;2;3;7;8;9]] +Proof + rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, + regsUpdate2_def,regsLookup_def,listLookup_def] +QED + +Theorem regsUpdate_test_merge6: + regsUpdate 7 5 [[1;2;3];[4;5;6];[7;8;9]] = [[1;2;3]; [4;5;6;7;8;9]] +Proof + rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, + regsUpdate2_def,regsLookup_def,listLookup_def] +QED + +Theorem regsUpdate_test_eq1: + regsUpdate 1 2 [[1;2;3];[4;5;6];[7;8;9]] = [[1;2;3];[4;5;6];[7;8;9]] +Proof + rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, + regsUpdate2_def,regsLookup_def,listLookup_def] +QED + +Theorem regsUpdate_test_eq2: + regsUpdate 4 5 [[1;2;3];[4;5;6];[7;8;9]] = [[1;2;3];[4;5;6];[7;8;9]] +Proof + rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, + regsUpdate2_def,regsLookup_def,listLookup_def] +QED + +Theorem regsUpdate_test_eq3: + regsUpdate 8 9 [[1;2;3];[4;5;6];[7;8;9]] = [[1;2;3];[4;5;6];[7;8;9]] +Proof + rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, + regsUpdate2_def,regsLookup_def,listLookup_def] +QED + +Theorem regsUpdate_test_add1: + regsUpdate 2 10 [[1;2;3];[4;5;6];[7;8;9]] = [[1;10;2;3];[4;5;6];[7;8;9]] Proof - strip_tac >> - Induct_on ‘L1’ - >- (Cases_on ‘L2’ - \\ rw[listCmp_def]) - >- (Cases_on ‘L2’ - >- rw[listCmp_def] - >- (strip_tac >> - Cases_on ‘h=h'’ - \\ rw[listCmp_def])) + rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, + regsUpdate2_def,regsLookup_def,listLookup_def] +QED + +Theorem regsUpdate_test_add2: + regsUpdate 6 10 [[1;2;3];[4;5;6];[7;8;9]] = [[1;2;3];[4;10;5;6];[7;8;9]] +Proof + rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, + regsUpdate2_def,regsLookup_def,listLookup_def] +QED + +Theorem regsUpdate_test_add3: + regsUpdate 9 10 [[1;2;3];[4;5;6];[7;8;9]] = [[1;2;3];[4;5;6];[7;10;8;9]] +Proof + rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, + regsUpdate2_def,regsLookup_def,listLookup_def] +QED + +Theorem regsUpdate_test_add4: + regsUpdate 10 2 [[1;2;3];[4;5;6];[7;8;9]] = [[1;10;2;3];[4;5;6];[7;8;9]] +Proof + rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, + regsUpdate2_def,regsLookup_def,listLookup_def] +QED + +Theorem regsUpdate_test_add5: + regsUpdate 10 6 [[1;2;3];[4;5;6];[7;8;9]] = [[1;2;3];[4;10;5;6];[7;8;9]] +Proof + rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, + regsUpdate2_def,regsLookup_def,listLookup_def] +QED + +Theorem regsUpdate_test_add6: + regsUpdate 10 9 [[1;2;3];[4;5;6];[7;8;9]] = [[1;2;3];[4;5;6];[7;10;8;9]] +Proof + rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, + regsUpdate2_def,regsLookup_def,listLookup_def] +QED + +(* REGISTER TRANSFORMATIONS *) + +Definition canonicalRegs_def: + canonicalRegs (r:num) [] = r ∧ + canonicalRegs r (hd::tl) = + if listLookup r hd + then HD hd + else canonicalRegs r tl +End + +Definition canonicalExp_def: + canonicalExp e regs = e +End + +Definition canonicalMultExp_def: + canonicalMultExp [] regs = [] ∧ + canonicalMultExp (hd::tl) regs = (canonicalExp hd regs)::(canonicalMultExp tl regs) +End + +Definition canonicalMoveRegs_def: + canonicalMoveRegs [] regs = ([], regs) ∧ + canonicalMoveRegs ((r1,r2)::tl) regs = + let r2' = canonicalRegs r2 regs in + let regs' = regsUpdate r1 r2' regs in + let (tl', regs'') = canonicalMoveRegs tl regs' in + (r1,r2')::tl', regs'' +End + +Definition canonicalExp_def: + canonicalExp (Const w) regs = Const w ∧ + canonicalExp (Var r) regs = Var (canonicalRegs r regs) ∧ + canonicalExp (Lookup s) regs = Lookup s ∧ + canonicalExp (Load e) regs = Load (canonicalExp e regs) ∧ + canonicalExp (Op op nl) regs = Op op (canonicalMultExp nl regs) ∧ + canonicalExp (Shift s e n) regs = Shift s (canonicalExp e regs) n +End + +(* SEEN INSTRUCTIONS MEMORY *) + +(* TODO *) +Definition wordToNum_def: + wordToNum w = (0:num) +End + +Definition shiftToNum_def: + shiftToNum Lsl = (69:num) ∧ + shiftToNum Lsr = 70 ∧ + shiftToNum Asr = 71 ∧ + shiftToNum Ror = 72 +End + +Theorem shiftToNum_unique: + ∀s1 s2. s1 = s2 ⇔ shiftToNum s1 = shiftToNum s2 +Proof + rpt strip_tac >> + Cases_on ‘s1’ \\ + (Cases_on ‘s2’ \\ + rw[shiftToNum_def]) +QED + +Definition storeNameToNumList_def: + storeNameToNumList NextFree = [(51:num)] ∧ + storeNameToNumList EndOfHeap = [52] ∧ + storeNameToNumList TriggerGC = [53] ∧ + storeNameToNumList HeapLength = [54] ∧ + storeNameToNumList ProgStart = [55] ∧ + storeNameToNumList BitmapBase = [56] ∧ + storeNameToNumList CurrHeap = [57] ∧ + storeNameToNumList OtherHeap = [58] ∧ + storeNameToNumList AllocSize = [59] ∧ + storeNameToNumList Globals = [60] ∧ + storeNameToNumList GlobReal = [61] ∧ + storeNameToNumList Handler = [62] ∧ + storeNameToNumList GenStart = [63] ∧ + storeNameToNumList CodeBuffer = [64] ∧ + storeNameToNumList CodeBufferEnd = [65] ∧ + storeNameToNumList BitmapBuffer = [66] ∧ + storeNameToNumList BitmapBufferEnd = [67] ∧ + storeNameToNumList (Temp w) = [68; wordToNum w] +End + +Definition arithOpToNum_def: + arithOpToNum Add = (46:num) ∧ + arithOpToNum Sub = 47 ∧ + arithOpToNum And = 48 ∧ + arithOpToNum Or = 49 ∧ + arithOpToNum Xor = 50 +End + +Theorem arithOpToNum_unique: + ∀op1 op2. op1 = op2 ⇔ arithOpToNum op1 = arithOpToNum op2 +Proof + rpt strip_tac >> + Cases_on ‘op1’ \\ + (Cases_on ‘op2’ \\ + rw[arithOpToNum_def]) QED + +Definition expListToNumList_def: + expListToNumList el = [] +End + +Definition expToNumList_def: + expToNumList (Const w) = [40; wordToNum w] ∧ + expToNumList (Var r) = [41; r+100] ∧ + expToNumList (Lookup n) = 42::(storeNameToNumList n) ∧ + expToNumList (Load e) = 43::(expToNumList e) ∧ + expToNumList (Op op el) = [44; arithOpToNum op] ++ (expListToNumList el) ∧ + expToNumList (Shift s e r) = [45; shiftToNum s] ++ (expToNumList e) ++ [r+100] +End + +(* !!!! Op has exp list, need to end list by unique id too !!!! *) +Definition expListToNumList_def: + expListToNumList [] = [(38:num)] ∧ + expListToNumList (hd::tl) = (expToNumList hd) ++ 39::(expListToNumList tl) +End + +Definition regImmToNumList_def: + regImmToNumList (Reg r) = [36; r+100] ∧ + regImmToNumList (Imm w) = [37; wordToNum w] +End + +Definition arithToNumList_def: + arithToNumList (Binop op r1 r2 ri) = [28; arithOpToNum op; r1+100; r2+100] ++ regImmToNumList ri ∧ + arithToNumList (LongMul r1 r2 r3 r4) = [29; r1+100; r2+100; r3+100; r4+100] ∧ + arithToNumList (LongDiv r1 r2 r3 r4 r5) = [30; r1+100; r2+100; r3+100; r4+100; r5+100] ∧ + arithToNumList (Shift s r1 r2 n) = [31; shiftToNum s; r1+100; r2+100; n] ∧ + arithToNumList (Div r1 r2 r3) = [32; r1+100; r2+100; r3+100] ∧ + arithToNumList (AddCarry r1 r2 r3 r4) = [33; r1+100; r2+100; r3+100; r4+100] ∧ + arithToNumList (AddOverflow r1 r2 r3 r4) = [34; r1+100; r2+100; r3+100; r4+100] ∧ + arithToNumList (SubOverflow r1 r2 r3 r4) = [35; r1+100; r2+100; r2+100; r4+100] +End + +Definition memOpToNum_def: + memOpToNum Load = (24:num) ∧ + memOpToNum Load8 = 25 ∧ + memOpToNum Store = 26 ∧ + memOpToNum Store8 = 27 +End + +Theorem memOpToNum_def: + ∀op1 op2. op1 = op2 ⇔ memOpToNum op1 = memOpToNum op2 +Proof + rpt strip_tac >> + Cases_on ‘op1’ \\ + (Cases_on ‘op2’ \\ + rw[memOpToNum_def]) +QED + +Definition fpToNumList_def: + fpToNumList (FPLess r1 r2 r3) = [8; r1+100; r2+100; r3+100] ∧ + fpToNumList (FPLessEqual r1 r2 r3) = [9; r1+100; r2+100; r3+100] ∧ + fpToNumList (FPEqual r1 r2 r3) = [10; r1+100; r2+100; r3+100] ∧ + fpToNumList (FPAbs r1 r2) = [11; r1+100; r2+100] ∧ + fpToNumList (FPNeg r1 r2) = [12; r1+100; r2+100] ∧ + fpToNumList (FPSqrt r1 r2) = [13; r1+100; r2+100] ∧ + fpToNumList (FPAdd r1 r2 r3) = [14; r1+100; r2+100; r3+100] ∧ + fpToNumList (FPSub r1 r2 r3) = [15; r1+100; r2+100; r3+100] ∧ + fpToNumList (FPMul r1 r2 r3) = [16; r1+100; r2+100; r3+100] ∧ + fpToNumList (FPDiv r1 r2 r3) = [17; r1+100; r2+100; r3+100] ∧ + fpToNumList (FPFma r1 r2 r3) = [18; r1+100; r2+100; r3+100] ∧ + fpToNumList (FPMov r1 r2) = [19; r1+100; r2+100] ∧ + fpToNumList (FPMovToReg r1 r2 r3) = [20; r1+100; r2+100; r3+100] ∧ + fpToNumList (FPMovFromReg r1 r2 r3) = [21; r1+100; r2+100; r3+100] ∧ + fpToNumList (FPToInt r1 r2) = [22; r1+100; r2+100] ∧ + fpToNumList (FPFromInt r1 r2) = [23; r1+100; r2+100] +End + +Theorem fpToNumList_def: + ∀fp1 fp2. fp1 = fp2 ⇔ fpToNumList fp1 = fpToNumList fp2 +Proof + rpt strip_tac >> + Cases_on ‘fp1’ \\ + (Cases_on ‘fp2’ \\ + rw[fpToNumList_def]) +QED + + +Definition instToNumList_def: + instToNumList (Skip) = [3] ∧ + instToNumList (Const r w) = [4;r+100; wordToNum w] ∧ + instToNumList (Arith a) = 5::(arithToNumList a) ∧ + instToNumList (Mem op r (Addr r' w)) = [6; memOpToNum op; r+100; r'+100; wordToNum w] ∧ + instToNumList (FP fp) = 7::(fpToNumList fp) +End + (* Principle: - We keep track of a map containing all instructions already dealt with, and we explore the program to find instuctions matching one in the map. - If we find one, we change the instruction by a simple move and we keep track of the registers equivalence. - If we don't find any, depending on the instruction, we store it into the map under the shape of an num list. +Each unique instruction is converted to a unique num list. +Numbers between 0 and 99 corresponds to a unique identifier of an instruction. +Numbers above 99 corresponds to a register or a word value. +*) +(* TODO : rename instruction numbers such that each is unique *) +Definition progToNumList_def: + progToNumList (Assign r e) = 0::(expToNumList e) ∧ + progToNumList (LocValue r1 r2) = [1; r1 + 100; r2 + 100] ∧ + progToNumList (Inst i) = 2::(instToNumList i) ∧ + progToNumList (Skip) = [3] ∧ + progToNumList (Move _ _) = [4] ∧ + progToNumList (Get _ _) = [5] ∧ + progToNumList (Set _ _) = [6] ∧ + progToNumList (Store _ _) = [7] ∧ + progToNumList (MustTerminate _) = [8] ∧ + progToNumList (Call _ _ _ _) = [9] ∧ + progToNumList (Seq _ _) = [10] ∧ + progToNumList (If _ _ _ _ _) = [11] ∧ + progToNumList (Alloc _ _) = [12] ∧ + progToNumList (Raise _) = [13] ∧ + progToNumList (Return _ _) = [14] ∧ + progToNumList (Tick) = [15] ∧ + progToNumList (OpCurrHeap _ _ _) = [16] ∧ + progToNumList (Install _ _ _ _ _) = [17] ∧ + progToNumList (CodeBufferWrite _ _) = [18] ∧ + progToNumList (DataBufferWrite _ _) = [19] ∧ + progToNumList (FFI _ _ _ _ _ _) = [20] +End + +(* +Theorem progToNumList_unique: + ∀p1 p2. (p1 = p2) ⇔ (progToNumList p1 = progToNumList p2) +Proof + +strip_tac +Induct_on ‘p1’ + \\(strip_tac >> + eq_tac >> + rw[] >> + Cases_on ‘p2’ \\ rw[progToNumList_def]) + + + >- Induct_on ‘p1’ + \\Cases_on ‘progToNumList p2’ + \\rw[wordToNum_def, shiftToNum_def, storeNameToNumList_def, arithOpToNum_def, expListToNumList_def, expToNumList_def, expListToNumList_def, regImmToNumList_def, arithToNumList_def, memOpToNum_def, fpToNumList_def, instToNumList_def, progToNumList_def] + +QED + +wordToNum_def, shiftToNum_def, storeNameToNumList_def, arithOpToNum_def, expListToNumList_def, expToNumList_def, expListToNumList_def, regImmToNumList_def, arithToNumList_def, memOpToNum_def, fpToNumList_def, instToNumList_def, progToNumList_def +*) + + +(* TODO *) +Definition comSubExpElimInst_def: + comSubExpElimInst regs instrs Skip = (regs, instrs, Inst Skip) ∧ + comSubExpElimInst regs instrs (Const r w) = (regs, instrs, Inst Skip) ∧ + comSubExpElimInst regs instrs (Arith a) = (regs, instrs, Inst Skip) ∧ + comSubExpElimInst regs instrs (Mem op r addr) = (regs, instrs, Inst Skip) ∧ + comSubExpElimInst regs instrs (FP f) = (regs, instrs, Inst Skip) +End + +(* +Principle: + We keep track of a map containing all instructions already dealt with, + and we explore the program to find instuctions matching one in the map. + If we find one, we change the instruction by a simple move and we keep track + of the registers equivalence. + If we don't find any, depending on the instruction, we store it into the map + under the shape of an num list. Signification of the terms: r -> registers or imm_registers + rs-> multiple registers associations ((num # num) list) (For the Move) i -> instructions e -> expressions x -> "store_name" @@ -65,28 +478,65 @@ Signification of the terms: b -> binop s -> string *) +(* TODO *) Definition comSubExpElim_def: - instrToList regs instrs (Skip) = (regs, instrs, Skip) ∧ - instrToList regs instrs (Move r1 r2) = ((r1,r2)::regs, instrs, Move r1 r2) ∧ - instrToList regs instrs (Inst i) = (regs, instrs, Skip) ∧ - instrToList regs instrs (Assign r e) = (regs, instrs, Skip) ∧ - instrToList regs instrs (Get r x) = (regs, instrs, Skip) ∧ - instrToList regs instrs (Set x r) = (regs, instrs, Skip) ∧ - instrToList regs instrs (Store e r) = (regs, instrs, Skip) ∧ - instrToList regs instrs (MustTerminate p) = (regs, instrs, Skip) ∧ - instrToList regs instrs (Call arg1 arg2 arg3 arg4) = (regs, instrs, Skip) ∧ - instrToList regs instrs (Seq p1 p2) = (regs, instrs, Skip) ∧ - instrToList regs instrs (If c r1 r2 p1 p2) = (regs, instrs, Skip) ∧ - instrToList regs instrs (Alloc r m) = (regs, instrs, Skip) ∧ - instrToList regs instrs (Raise r) = (regs, instrs, Skip) ∧ - instrToList regs instrs (Return r1 r2) = (regs, instrs, Skip) ∧ - instrToList regs instrs (Tick) = (regs, instrs, Skip) ∧ - instrToList regs instrs (OpCurrHeap b r1 r2) = (regs, instrs, Skip) ∧ - instrToList regs instrs (LocValue r1 r2) = (regs, instrs, Skip) ∧ - instrToList regs instrs (Install r1 r2 r3 r4 m) = (regs, instrs, Skip) ∧ - instrToList regs instrs (CodeBufferWrite r1 r2) = (regs, instrs, Skip) ∧ - instrToList regs instrs (DataBufferWrite r1 r2) = (regs, instrs, Skip) ∧ - instrToList regs instrs (FFI s r1 r2 r3 r4 m) = (regs, instrs, Skip) + (comSubExpElim (regs:regsT) (instrs:(num list,num)map) (Skip) = + (regs, instrs, Skip)) ∧ + (comSubExpElim regs instrs (Move r rs) = + let (rs', regs') = canonicalMoveRegs rs regs in + (regs', instrs, Move r rs')) ∧ + (comSubExpElim regs instrs (Inst i) = + let (regs', instrs', p) = comSubExpElimInst regs instrs i in + (regs', instrs', p)) ∧ + (comSubExpElim regs instrs (Assign r e) = + let e' = canonicalExp e regs in + let i = progToNumList (Assign r e') in + case lookup instrs i of + |NONE => (regs, insert instrs i r, Assign r e') + |SOME r' => (regsUpdate r r' regs, instrs, Move 0 [(r,r')])) ∧ + (comSubExpElim regs instrs (Get r x) = + (regs, instrs, Get r x)) ∧ + (comSubExpElim regs instrs (Set x e) = + let e' = canonicalExp e regs in + (regs, instrs, Set x e')) ∧ + (comSubExpElim regs instrs (Store e r) = + (regs, instrs, Store e r)) ∧ + (comSubExpElim regs instrs (MustTerminate p) = + let (regs', instrs', p') = comSubExpElim regs instrs p in + (regs', instrs', MustTerminate p')) ∧ + (comSubExpElim regs instrs (Call arg1 arg2 arg3 arg4) = + (regs, instrs, Call arg1 arg2 arg3 arg4)) ∧ + + (comSubExpElim regs instrs (Seq p1 p2) = + let (regs1, instrs1, p1') = comSubExpElim regs instrs p1 in + let (regs2, instrs2, p2') = comSubExpElim regs1 instrs1 p2 in + (regs2, instrs2, Seq p1' p2')) ∧ + (comSubExpElim regs instrs (If c r1 r2 p1 p2) = + (regs, instrs, If c r1 r2 p1 p2)) ∧ + + (comSubExpElim regs instrs (Alloc r m) = + (regs, instrs, Alloc r m)) ∧ + (comSubExpElim regs instrs (Raise r) = + let r' = canonicalRegs r regs in + (regs, instrs, Raise r')) ∧ + (comSubExpElim regs instrs (Return r1 r2) = + let r1' = canonicalRegs r1 regs in + let r2' = canonicalRegs r2 regs in + (regs, instrs, Return r1' r2')) ∧ + (comSubExpElim regs instrs (Tick) = (regs, instrs, Tick)) ∧ + (comSubExpElim regs instrs (OpCurrHeap b r1 r2) = + let r2' = canonicalRegs r2 regs in + (regs, instrs, OpCurrHeap b r1 r2')) ∧ + (comSubExpElim regs instrs (LocValue r1 r2) = + (regs, instrs, LocValue r1 r2)) ∧ + (comSubExpElim regs instrs (Install r1 r2 r3 r4 m) = + (regs, instrs, Install r1 r2 r3 r4 m)) ∧ + (comSubExpElim regs instrs (CodeBufferWrite r1 r2) = + (regs, instrs, CodeBufferWrite r1 r2)) ∧ + (comSubExpElim regs instrs (DataBufferWrite r1 r2) = + (regs, instrs, DataBufferWrite r1 r2)) ∧ + (comSubExpElim regs instrs (FFI s r1 r2 r3 r4 m) = + (regs, instrs, FFI s r1 r2 r3 r4 m)) End - +val _ = export_theory (); From f9f417ab12405bc9752c78a83eb7a5b144c40f7d Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Wed, 8 Jun 2022 18:31:50 +0200 Subject: [PATCH 05/36] First version that seems to work. More tests have to be run. --- compiler/backend/word_comSubExpElimScript.sml | 577 ++++++++++++------ 1 file changed, 376 insertions(+), 201 deletions(-) diff --git a/compiler/backend/word_comSubExpElimScript.sml b/compiler/backend/word_comSubExpElimScript.sml index 19e5234c14..f57f850dca 100644 --- a/compiler/backend/word_comSubExpElimScript.sml +++ b/compiler/backend/word_comSubExpElimScript.sml @@ -19,14 +19,15 @@ Mind map / TODO: If so, we add r1 to group' in the second place. Else, we create a group=[r1;r2] that we add to map. -> !!! Case of function call we context conservation !!! - One solution could be *) -open preamble wordLangTheory boolTheory mlmapTheory +open preamble wordLangTheory wordsTheory boolTheory mlmapTheory sptreeTheory -val _ = new_theory "comSubExpElim"; +val _ = new_theory "word_comSubExpElim"; -Type regsT = ``:num list list`` +Type regsE = ``:num list list`` +Type regsM = ``:num num_map`` +Type instrsM = ``:(num list,num)map`` (* LIST COMPARISON *) @@ -211,52 +212,124 @@ QED (* REGISTER TRANSFORMATIONS *) Definition canonicalRegs_def: - canonicalRegs (r:num) [] = r ∧ - canonicalRegs r (hd::tl) = - if listLookup r hd - then HD hd - else canonicalRegs r tl + canonicalRegs (regsMap:num num_map) (r:num) = + case sptree$lookup r regsMap of + | SOME r' => r' + | NONE => r End -Definition canonicalExp_def: - canonicalExp e regs = e +Definition canonicalImmReg_def: + canonicalImmReg regsMap (Reg r) = Reg (canonicalRegs regsMap r) ∧ + canonicalImmReg regsMap (Imm w) = Imm w End -Definition canonicalMultExp_def: - canonicalMultExp [] regs = [] ∧ - canonicalMultExp (hd::tl) regs = (canonicalExp hd regs)::(canonicalMultExp tl regs) +Definition canonicalMultRegs_def: + canonicalMultRegs regsMap [] = [] ∧ + canonicalMultRegs regsMap (hd::tl) = + (canonicalRegs regsMap hd)::(canonicalMultRegs regsMap tl) End Definition canonicalMoveRegs_def: - canonicalMoveRegs [] regs = ([], regs) ∧ - canonicalMoveRegs ((r1,r2)::tl) regs = - let r2' = canonicalRegs r2 regs in - let regs' = regsUpdate r1 r2' regs in - let (tl', regs'') = canonicalMoveRegs tl regs' in - (r1,r2')::tl', regs'' + canonicalMoveRegs regsEq regsMap [] = (regsEq, regsMap, []) ∧ + canonicalMoveRegs regsEq regsMap ((r1,r2)::tl) = + let r2' = canonicalRegs regsMap r2 in + let regsEq' = regsUpdate r2' r1 regsEq in + let regsMap' = sptree$insert r1 r2' regsMap in + let (regsEq'', regsMap'', tl') = canonicalMoveRegs regsEq' regsMap' tl in + regsEq'', regsMap'', (r1,r2')::tl' +End + +Definition canonicalExp_def: + canonicalExp regsMap e = e +End + +Definition canonicalMultExp_def: + canonicalMultExp regsMap [] = [] ∧ + canonicalMultExp regsMap (hd::tl) = + (canonicalExp regsMap hd)::(canonicalMultExp regsMap tl) End Definition canonicalExp_def: - canonicalExp (Const w) regs = Const w ∧ - canonicalExp (Var r) regs = Var (canonicalRegs r regs) ∧ - canonicalExp (Lookup s) regs = Lookup s ∧ - canonicalExp (Load e) regs = Load (canonicalExp e regs) ∧ - canonicalExp (Op op nl) regs = Op op (canonicalMultExp nl regs) ∧ - canonicalExp (Shift s e n) regs = Shift s (canonicalExp e regs) n + canonicalExp regsMap (Const w) = Const w ∧ + canonicalExp regsMap (Var r) = Var (canonicalRegs regsMap r) ∧ + canonicalExp regsMap (Lookup s) = Lookup s ∧ + canonicalExp regsMap (Load e) = Load (canonicalExp regsMap e) ∧ + canonicalExp regsMap (Op op nl) = Op op (canonicalMultExp regsMap nl) ∧ + canonicalExp regsMap (Shift s e n) = Shift s (canonicalExp regsMap e) n +End + +Definition canonicalArith_def: + canonicalArith regsMap (Binop op r1 r2 r3) = + Binop op r1 (canonicalRegs regsMap r2) (canonicalImmReg regsMap r3) ∧ + canonicalArith regsMap (Shift s r1 r2 n) = + Shift s (canonicalRegs regsMap r1) (canonicalRegs regsMap r2) n ∧ + canonicalArith regsMap (Div r1 r2 r3) = + Div r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) ∧ + canonicalArith regsMap (LongMul r1 r2 r3 r4) = + LongMul r1 r2 (canonicalRegs regsMap r3) (canonicalRegs regsMap r4) ∧ + canonicalArith regsMap (LongDiv r1 r2 r3 r4 r5) = + LongDiv r1 r2 (canonicalRegs regsMap r3) (canonicalRegs regsMap r4) (canonicalRegs regsMap r5) ∧ + canonicalArith regsMap (AddCarry r1 r2 r3 r4) = + AddCarry r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) r4 ∧ + canonicalArith regsMap (AddOverflow r1 r2 r3 r4) = + AddOverflow r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) r4 ∧ + canonicalArith regsMap (SubOverflow r1 r2 r3 r4) = + SubOverflow r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) r4 +End + +Definition canonicalFp_def: + canonicalFp regsMap (FPLess r1 r2 r3) = + FPLess r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) ∧ + canonicalFp regsMap (FPLessEqual r1 r2 r3) = + FPLessEqual r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) ∧ + canonicalFp regsMap (FPEqual r1 r2 r3) = + FPEqual r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) ∧ + canonicalFp regsMap (FPAbs r1 r2) = + FPAbs r1 (canonicalRegs regsMap r2) ∧ + canonicalFp regsMap (FPNeg r1 r2) = + FPNeg r1 (canonicalRegs regsMap r2) ∧ + canonicalFp regsMap (FPSqrt r1 r2) = + FPSqrt r1 (canonicalRegs regsMap r2) ∧ + canonicalFp regsMap (FPAdd r1 r2 r3) = + FPAdd r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) ∧ + canonicalFp regsMap (FPSub r1 r2 r3) = + FPSub r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) ∧ + canonicalFp regsMap (FPMul r1 r2 r3) = + FPMul r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) ∧ + canonicalFp regsMap (FPDiv r1 r2 r3) = + FPDiv r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) ∧ + canonicalFp regsMap (FPFma r1 r2 r3) = + FPFma r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) ∧ + canonicalFp regsMap (FPMov r1 r2) = + FPMov r1 (canonicalRegs regsMap r2) ∧ + canonicalFp regsMap (FPMovToReg r1 r2 r3) = + FPMovToReg r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) ∧ + canonicalFp regsMap (FPMovFromReg r1 r2 r3) = + FPMovFromReg r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) ∧ + canonicalFp regsMap (FPToInt r1 r2) = + FPToInt r1 (canonicalRegs regsMap r2) ∧ + canonicalFp regsMap (FPFromInt r1 r2) = + FPFromInt r1 (canonicalRegs regsMap r2) End (* SEEN INSTRUCTIONS MEMORY *) -(* TODO *) Definition wordToNum_def: - wordToNum w = (0:num) + wordToNum w = w2n w End +Theorem wordToNum_unique: + ∀w1 w2. w1 = w2 ⇔ wordToNum w1 = wordToNum w2 +Proof + rw[wordToNum_def] +QED + + Definition shiftToNum_def: - shiftToNum Lsl = (69:num) ∧ - shiftToNum Lsr = 70 ∧ - shiftToNum Asr = 71 ∧ - shiftToNum Ror = 72 + shiftToNum Lsl = (38:num) ∧ + shiftToNum Lsr = 39 ∧ + shiftToNum Asr = 40 ∧ + shiftToNum Ror = 41 End Theorem shiftToNum_unique: @@ -268,6 +341,26 @@ Proof rw[shiftToNum_def]) QED + +Definition arithOpToNum_def: + arithOpToNum Add = (33:num) ∧ + arithOpToNum Sub = 34 ∧ + arithOpToNum And = 35 ∧ + arithOpToNum Or = 36 ∧ + arithOpToNum Xor = 37 +End + +Theorem arithOpToNum_unique: + ∀op1 op2. op1 = op2 ⇔ arithOpToNum op1 = arithOpToNum op2 +Proof + rpt strip_tac >> + Cases_on ‘op1’ \\ + (Cases_on ‘op2’ \\ + rw[arithOpToNum_def]) +QED + + +(* Definition storeNameToNumList_def: storeNameToNumList NextFree = [(51:num)] ∧ storeNameToNumList EndOfHeap = [52] ∧ @@ -288,68 +381,94 @@ Definition storeNameToNumList_def: storeNameToNumList BitmapBufferEnd = [67] ∧ storeNameToNumList (Temp w) = [68; wordToNum w] End - -Definition arithOpToNum_def: - arithOpToNum Add = (46:num) ∧ - arithOpToNum Sub = 47 ∧ - arithOpToNum And = 48 ∧ - arithOpToNum Or = 49 ∧ - arithOpToNum Xor = 50 -End - -Theorem arithOpToNum_unique: - ∀op1 op2. op1 = op2 ⇔ arithOpToNum op1 = arithOpToNum op2 +Theorem storeNameToNumList_unique: + ∀n1 n2. n1 = n2 ⇔ storeNameToNumList n1 = storeNameToNumList n2 Proof rpt strip_tac >> - Cases_on ‘op1’ \\ - (Cases_on ‘op2’ \\ - rw[arithOpToNum_def]) + Cases_on ‘n1’ \\ + (Cases_on ‘n2’ \\ + rw[storeNameToNumList_def, wordToNum_unique]) QED - - Definition expListToNumList_def: - expListToNumList el = [] + expListToNumList [] = [(38:num)] ∧ + expListToNumList ((Const w)::tl) = 40::(wordToNum w)::(expListToNumList tl) ∧ + expListToNumList ((Var r)::tl) = 41::(r+100)::(expListToNumList tl) ∧ + expListToNumList ((Lookup n)::tl) = 42::(storeNameToNumList n) ++ expListToNumList tl ∧ + expListToNumList ((Load e)::tl) = 43::(expListToNumList [e]) ++ expListToNumList tl ∧ + expListToNumList ((Op op el)::tl) = [44; arithOpToNum op] ++ (expListToNumList el) ++ expListToNumList tl ∧ + expListToNumList ((Shift s e r)::tl) = 45::(shiftToNum s)::(expListToNumList [e]) ++ [r+100] ++ expListToNumList tl +End +Definition expToNumList_def: + expToNumList e = expListToNumList [e] +End +Definition expListToNumList_def: + expListToNumList (hd::tl) = (expToNumList hd) ++ 39::(expListToNumList tl) End - Definition expToNumList_def: expToNumList (Const w) = [40; wordToNum w] ∧ expToNumList (Var r) = [41; r+100] ∧ expToNumList (Lookup n) = 42::(storeNameToNumList n) ∧ expToNumList (Load e) = 43::(expToNumList e) ∧ - expToNumList (Op op el) = [44; arithOpToNum op] ++ (expListToNumList el) ∧ + expToNumList (Op op []) = [38] ∧ + expToNumList (Op op (hd::tl)) = [arithOpToNum op] ++ (expToNumList hd) ++ (expToNumList (Op op tl)) ∧ expToNumList (Shift s e r) = [45; shiftToNum s] ++ (expToNumList e) ++ [r+100] End - -(* !!!! Op has exp list, need to end list by unique id too !!!! *) -Definition expListToNumList_def: - expListToNumList [] = [(38:num)] ∧ - expListToNumList (hd::tl) = (expToNumList hd) ++ 39::(expListToNumList tl) -End +Theorem expToNumList_unique: + ∀e1 e2. e1 = e2 ⇔ expToNumList e1 = expToNumList e2 +Proof ho_match_mp_tac expToNumList_ind + strip_tac >> + Induct_on ‘e1’ \\ + (Cases_on ‘e2’ \\ + rw[expToNumList_def, wordToNum_unique, storeNameToNumList_unique, arithOpToNum_unique, shiftToNum_unique]) + decide_tac + Cases_on ‘l’ +QED +*) Definition regImmToNumList_def: - regImmToNumList (Reg r) = [36; r+100] ∧ - regImmToNumList (Imm w) = [37; wordToNum w] + regImmToNumList (Reg r) = [31; r+100] ∧ + regImmToNumList (Imm w) = [32; wordToNum w] End +Theorem regImmToNumList_unique: + ∀ri1 ri2. ri1 = ri2 ⇔ regImmToNumList ri1 = regImmToNumList ri2 +Proof + rpt strip_tac >> + Cases_on ‘ri1’ \\ + (Cases_on ‘ri2’ \\ + rw[regImmToNumList_def, wordToNum_unique]) +QED + + Definition arithToNumList_def: - arithToNumList (Binop op r1 r2 ri) = [28; arithOpToNum op; r1+100; r2+100] ++ regImmToNumList ri ∧ - arithToNumList (LongMul r1 r2 r3 r4) = [29; r1+100; r2+100; r3+100; r4+100] ∧ - arithToNumList (LongDiv r1 r2 r3 r4 r5) = [30; r1+100; r2+100; r3+100; r4+100; r5+100] ∧ - arithToNumList (Shift s r1 r2 n) = [31; shiftToNum s; r1+100; r2+100; n] ∧ - arithToNumList (Div r1 r2 r3) = [32; r1+100; r2+100; r3+100] ∧ - arithToNumList (AddCarry r1 r2 r3 r4) = [33; r1+100; r2+100; r3+100; r4+100] ∧ - arithToNumList (AddOverflow r1 r2 r3 r4) = [34; r1+100; r2+100; r3+100; r4+100] ∧ - arithToNumList (SubOverflow r1 r2 r3 r4) = [35; r1+100; r2+100; r2+100; r4+100] + arithToNumList (Binop op r1 r2 ri) = [23; arithOpToNum op; r2+100] ++ regImmToNumList ri ∧ + arithToNumList (LongMul r1 r2 r3 r4) = [24; r3+100; r4+100] ∧ + arithToNumList (LongDiv r1 r2 r3 r4 r5) = [25; r3+100; r4+100; r5+100] ∧ + arithToNumList (Shift s r1 r2 n) = [26; shiftToNum s; r2+100; n] ∧ + arithToNumList (Div r1 r2 r3) = [27; r2+100; r3+100] ∧ + arithToNumList (AddCarry r1 r2 r3 r4) = [28; r2+100; r3+100] ∧ + arithToNumList (AddOverflow r1 r2 r3 r4) = [29; r2+100; r3+100] ∧ + arithToNumList (SubOverflow r1 r2 r3 r4) = [30; r2+100; r3+100] End +(* +Theorem arithToNumList_unique: + ∀a1 a2. a1 = a2 ⇔ arithToNumList a1 = arithToNumList a2 +Proof + rpt strip_tac >> + Cases_on ‘a1’ \\ + (Cases_on ‘a2’ \\ + rw[arithToNumList_def, regImmToNumList_unique, shiftToNum_unique, arithOpToNum_unique]) +QED +*) Definition memOpToNum_def: - memOpToNum Load = (24:num) ∧ - memOpToNum Load8 = 25 ∧ - memOpToNum Store = 26 ∧ - memOpToNum Store8 = 27 + memOpToNum Load = (19:num) ∧ + memOpToNum Load8 = 20 ∧ + memOpToNum Store = 21 ∧ + memOpToNum Store8 = 22 End -Theorem memOpToNum_def: +Theorem memOpToNum_unique: ∀op1 op2. op1 = op2 ⇔ memOpToNum op1 = memOpToNum op2 Proof rpt strip_tac >> @@ -358,42 +477,67 @@ Proof rw[memOpToNum_def]) QED + Definition fpToNumList_def: - fpToNumList (FPLess r1 r2 r3) = [8; r1+100; r2+100; r3+100] ∧ - fpToNumList (FPLessEqual r1 r2 r3) = [9; r1+100; r2+100; r3+100] ∧ - fpToNumList (FPEqual r1 r2 r3) = [10; r1+100; r2+100; r3+100] ∧ - fpToNumList (FPAbs r1 r2) = [11; r1+100; r2+100] ∧ - fpToNumList (FPNeg r1 r2) = [12; r1+100; r2+100] ∧ - fpToNumList (FPSqrt r1 r2) = [13; r1+100; r2+100] ∧ - fpToNumList (FPAdd r1 r2 r3) = [14; r1+100; r2+100; r3+100] ∧ - fpToNumList (FPSub r1 r2 r3) = [15; r1+100; r2+100; r3+100] ∧ - fpToNumList (FPMul r1 r2 r3) = [16; r1+100; r2+100; r3+100] ∧ - fpToNumList (FPDiv r1 r2 r3) = [17; r1+100; r2+100; r3+100] ∧ - fpToNumList (FPFma r1 r2 r3) = [18; r1+100; r2+100; r3+100] ∧ - fpToNumList (FPMov r1 r2) = [19; r1+100; r2+100] ∧ - fpToNumList (FPMovToReg r1 r2 r3) = [20; r1+100; r2+100; r3+100] ∧ - fpToNumList (FPMovFromReg r1 r2 r3) = [21; r1+100; r2+100; r3+100] ∧ - fpToNumList (FPToInt r1 r2) = [22; r1+100; r2+100] ∧ - fpToNumList (FPFromInt r1 r2) = [23; r1+100; r2+100] -End - -Theorem fpToNumList_def: - ∀fp1 fp2. fp1 = fp2 ⇔ fpToNumList fp1 = fpToNumList fp2 + fpToNumList (FPLess r1 r2 r3) = [3; r2+100; r3+100] ∧ + fpToNumList (FPLessEqual r1 r2 r3) = [4; r2+100; r3+100] ∧ + fpToNumList (FPEqual r1 r2 r3) = [5; r2+100; r3+100] ∧ + fpToNumList (FPAbs r1 r2) = [6; r2+100] ∧ + fpToNumList (FPNeg r1 r2) = [7; r2+100] ∧ + fpToNumList (FPSqrt r1 r2) = [8; r2+100] ∧ + fpToNumList (FPAdd r1 r2 r3) = [9; r2+100; r3+100] ∧ + fpToNumList (FPSub r1 r2 r3) = [10; r2+100; r3+100] ∧ + fpToNumList (FPMul r1 r2 r3) = [11; r2+100; r3+100] ∧ + fpToNumList (FPDiv r1 r2 r3) = [12; r2+100; r3+100] ∧ + fpToNumList (FPFma r1 r2 r3) = [13; r1+100; r2+100; r3+100] ∧ (* List never matched again *) + fpToNumList (FPMov r1 r2) = [14; r2+100] ∧ + fpToNumList (FPMovToReg r1 r2 r3) = [15; r2+100; r3+100] ∧ + fpToNumList (FPMovFromReg r1 r2 r3) = [16; r2+100; r3+100] ∧ + fpToNumList (FPToInt r1 r2) = [17; r2+100] ∧ + fpToNumList (FPFromInt r1 r2) = [18; r2+100] +End +(* +Theorem fpToNumList_unique: + ∀fp1 fp2. fpToNumList fp1 = fpToNumList fp2 ⇒ ∃r r' Proof rpt strip_tac >> Cases_on ‘fp1’ \\ (Cases_on ‘fp2’ \\ rw[fpToNumList_def]) QED +*) +(* +Definition addrToNumList_def: + addrToNumList (Addr r w) = [r+100; wordToNum w] +End +Theorem addrToNumList_unique: + ∀a1 a2. a1 = a2 ⇔ addrToNumList a1 = addrToNumList a2 +Proof + rpt strip_tac >> + Cases_on ‘a1’ \\ + (Cases_on ‘a2’ \\ + rw[addrToNumList_def, wordToNum_unique]) +QED +*) Definition instToNumList_def: - instToNumList (Skip) = [3] ∧ - instToNumList (Const r w) = [4;r+100; wordToNum w] ∧ - instToNumList (Arith a) = 5::(arithToNumList a) ∧ - instToNumList (Mem op r (Addr r' w)) = [6; memOpToNum op; r+100; r'+100; wordToNum w] ∧ - instToNumList (FP fp) = 7::(fpToNumList fp) + instToNumList (Skip) = [1] ∧ + instToNumList (Const r w) = [2;wordToNum w] ∧ + instToNumList (Arith a) = arithToNumList a ∧ + instToNumList (FP fp) = fpToNumList fp End +(* +Theorem instToNumList_unique: + ∀i1 i2. i1 = i2 ⇔ instToNumList i1 = instToNumList i2 +Proof + rpt strip_tac >> + Cases_on ‘i1’ \\ + (Cases_on ‘i2’ \\ + rw[instToNumList_def, wordToNum_unique, arithToNumList_unique, + memOpToNum_unique, addrToNumList_unique, fpToNumList_unique]) +QED +*) (* Principle: @@ -401,61 +545,72 @@ Each unique instruction is converted to a unique num list. Numbers between 0 and 99 corresponds to a unique identifier of an instruction. Numbers above 99 corresponds to a register or a word value. *) -(* TODO : rename instruction numbers such that each is unique *) +(* TODO : redo the rename of instruction numbers such that each is unique *) Definition progToNumList_def: - progToNumList (Assign r e) = 0::(expToNumList e) ∧ - progToNumList (LocValue r1 r2) = [1; r1 + 100; r2 + 100] ∧ - progToNumList (Inst i) = 2::(instToNumList i) ∧ - progToNumList (Skip) = [3] ∧ - progToNumList (Move _ _) = [4] ∧ - progToNumList (Get _ _) = [5] ∧ - progToNumList (Set _ _) = [6] ∧ - progToNumList (Store _ _) = [7] ∧ - progToNumList (MustTerminate _) = [8] ∧ - progToNumList (Call _ _ _ _) = [9] ∧ - progToNumList (Seq _ _) = [10] ∧ - progToNumList (If _ _ _ _ _) = [11] ∧ - progToNumList (Alloc _ _) = [12] ∧ - progToNumList (Raise _) = [13] ∧ - progToNumList (Return _ _) = [14] ∧ - progToNumList (Tick) = [15] ∧ - progToNumList (OpCurrHeap _ _ _) = [16] ∧ - progToNumList (Install _ _ _ _ _) = [17] ∧ - progToNumList (CodeBufferWrite _ _) = [18] ∧ - progToNumList (DataBufferWrite _ _) = [19] ∧ - progToNumList (FFI _ _ _ _ _ _) = [20] + progToNumList (Inst i) = 0::(instToNumList i) End - (* Theorem progToNumList_unique: - ∀p1 p2. (p1 = p2) ⇔ (progToNumList p1 = progToNumList p2) + ∀p1 p2. (∃i. p1 = Inst i)∧(∃i. p2 = Inst i) ⇒ + (p1 = p2 ⇔ progToNumList p1 = progToNumList p2) Proof - -strip_tac -Induct_on ‘p1’ - \\(strip_tac >> - eq_tac >> - rw[] >> - Cases_on ‘p2’ \\ rw[progToNumList_def]) - - - >- Induct_on ‘p1’ - \\Cases_on ‘progToNumList p2’ - \\rw[wordToNum_def, shiftToNum_def, storeNameToNumList_def, arithOpToNum_def, expListToNumList_def, expToNumList_def, expListToNumList_def, regImmToNumList_def, arithToNumList_def, memOpToNum_def, fpToNumList_def, instToNumList_def, progToNumList_def] - + rw[progToNumList_def, instToNumList_unique] QED - -wordToNum_def, shiftToNum_def, storeNameToNumList_def, arithOpToNum_def, expListToNumList_def, expToNumList_def, expListToNumList_def, regImmToNumList_def, arithToNumList_def, memOpToNum_def, fpToNumList_def, instToNumList_def, progToNumList_def *) - -(* TODO *) +Definition firstRegOfArith_def: + firstRegOfArith (Binop _ r _ _) = r ∧ + firstRegOfArith (Shift _ r _ _) = r ∧ + firstRegOfArith (Div r _ _) = r ∧ + firstRegOfArith (LongMul r _ _ _) = r ∧ + firstRegOfArith (LongDiv r _ _ _ _) = r ∧ + firstRegOfArith (AddCarry r _ _ _) = r ∧ + firstRegOfArith (AddOverflow r _ _ _) = r ∧ + firstRegOfArith (SubOverflow r _ _ _) = r +End + +Definition firstRegOfFp_def: + firstRegOfFp (FPLess r _ _) = r ∧ + firstRegOfFp (FPLessEqual r _ _) = r ∧ + firstRegOfFp (FPEqual r _ _) = r ∧ + firstRegOfFp (FPAbs r _) = r ∧ + firstRegOfFp (FPNeg r _) = r ∧ + firstRegOfFp (FPSqrt r _) = r ∧ + firstRegOfFp (FPAdd r _ _) = r ∧ + firstRegOfFp (FPSub r _ _) = r ∧ + firstRegOfFp (FPMul r _ _) = r ∧ + firstRegOfFp (FPDiv r _ _) = r ∧ + firstRegOfFp (FPFma r _ _) = r ∧ + firstRegOfFp (FPMov r _) = r ∧ + firstRegOfFp (FPMovToReg r _ _) = r ∧ + firstRegOfFp (FPMovFromReg r _ _) = r ∧ + firstRegOfFp (FPToInt r _) = r ∧ + firstRegOfFp (FPFromInt r _) = r +End + Definition comSubExpElimInst_def: - comSubExpElimInst regs instrs Skip = (regs, instrs, Inst Skip) ∧ - comSubExpElimInst regs instrs (Const r w) = (regs, instrs, Inst Skip) ∧ - comSubExpElimInst regs instrs (Arith a) = (regs, instrs, Inst Skip) ∧ - comSubExpElimInst regs instrs (Mem op r addr) = (regs, instrs, Inst Skip) ∧ - comSubExpElimInst regs instrs (FP f) = (regs, instrs, Inst Skip) + (comSubExpElimInst (n:num) (regsEq:regsE) (regsMap:regsM) (instrs:instrsM) Skip = (n, regsEq, regsMap, instrs, Inst Skip)) ∧ + (comSubExpElimInst n regsEq regsMap instrs (Const r w) = + let i = instToNumList (Const r w) in + case mlmap$lookup instrs i of + | SOME r' => (n+1, regsUpdate r' r regsEq, insert r r' regsMap, instrs, Move 0 [(r,r')]) + | NONE => (n, regsEq, regsMap, insert instrs i r, Inst (Const r w))) ∧ + (comSubExpElimInst n regsEq regsMap instrs (Arith a) = + let a' = canonicalArith regsMap a in + let r = firstRegOfArith a' in + let i = instToNumList (Arith a') in + case mlmap$lookup instrs i of + | SOME r' => (n+1, regsUpdate r' r regsEq, insert r r' regsMap, instrs, Move 0 [(r,r')]) + | NONE => (n, regsEq, regsMap, insert instrs i r, Inst (Arith a'))) ∧ + (comSubExpElimInst n regsEq regsMap instrs (Mem op r (Addr r' w)) = + (n, regsEq, regsMap, instrs, Inst (Mem op (canonicalRegs regsMap r) (Addr (canonicalRegs regsMap r') w)))) ∧ + (comSubExpElimInst n regsEq regsMap instrs ((FP f):'a inst) = + let f' = canonicalFp regsMap f in + let r = firstRegOfFp f' in + let i = instToNumList ((FP f'):'a inst) in + case mlmap$lookup instrs i of + | SOME r' => (n+1, regsUpdate r' r regsEq, insert r r' regsMap, instrs, Move 0 [(r,r')]) + | NONE => (n, regsEq, regsMap, insert instrs i r, Inst (FP f'))) End (* @@ -478,65 +633,85 @@ Signification of the terms: b -> binop s -> string *) -(* TODO *) Definition comSubExpElim_def: - (comSubExpElim (regs:regsT) (instrs:(num list,num)map) (Skip) = - (regs, instrs, Skip)) ∧ - (comSubExpElim regs instrs (Move r rs) = - let (rs', regs') = canonicalMoveRegs rs regs in - (regs', instrs, Move r rs')) ∧ - (comSubExpElim regs instrs (Inst i) = - let (regs', instrs', p) = comSubExpElimInst regs instrs i in - (regs', instrs', p)) ∧ - (comSubExpElim regs instrs (Assign r e) = - let e' = canonicalExp e regs in - let i = progToNumList (Assign r e') in - case lookup instrs i of - |NONE => (regs, insert instrs i r, Assign r e') - |SOME r' => (regsUpdate r r' regs, instrs, Move 0 [(r,r')])) ∧ - (comSubExpElim regs instrs (Get r x) = - (regs, instrs, Get r x)) ∧ - (comSubExpElim regs instrs (Set x e) = - let e' = canonicalExp e regs in - (regs, instrs, Set x e')) ∧ - (comSubExpElim regs instrs (Store e r) = - (regs, instrs, Store e r)) ∧ - (comSubExpElim regs instrs (MustTerminate p) = - let (regs', instrs', p') = comSubExpElim regs instrs p in - (regs', instrs', MustTerminate p')) ∧ - (comSubExpElim regs instrs (Call arg1 arg2 arg3 arg4) = - (regs, instrs, Call arg1 arg2 arg3 arg4)) ∧ - - (comSubExpElim regs instrs (Seq p1 p2) = - let (regs1, instrs1, p1') = comSubExpElim regs instrs p1 in - let (regs2, instrs2, p2') = comSubExpElim regs1 instrs1 p2 in - (regs2, instrs2, Seq p1' p2')) ∧ - (comSubExpElim regs instrs (If c r1 r2 p1 p2) = - (regs, instrs, If c r1 r2 p1 p2)) ∧ - - (comSubExpElim regs instrs (Alloc r m) = - (regs, instrs, Alloc r m)) ∧ - (comSubExpElim regs instrs (Raise r) = - let r' = canonicalRegs r regs in - (regs, instrs, Raise r')) ∧ - (comSubExpElim regs instrs (Return r1 r2) = - let r1' = canonicalRegs r1 regs in - let r2' = canonicalRegs r2 regs in - (regs, instrs, Return r1' r2')) ∧ - (comSubExpElim regs instrs (Tick) = (regs, instrs, Tick)) ∧ - (comSubExpElim regs instrs (OpCurrHeap b r1 r2) = - let r2' = canonicalRegs r2 regs in - (regs, instrs, OpCurrHeap b r1 r2')) ∧ - (comSubExpElim regs instrs (LocValue r1 r2) = - (regs, instrs, LocValue r1 r2)) ∧ - (comSubExpElim regs instrs (Install r1 r2 r3 r4 m) = - (regs, instrs, Install r1 r2 r3 r4 m)) ∧ - (comSubExpElim regs instrs (CodeBufferWrite r1 r2) = - (regs, instrs, CodeBufferWrite r1 r2)) ∧ - (comSubExpElim regs instrs (DataBufferWrite r1 r2) = - (regs, instrs, DataBufferWrite r1 r2)) ∧ - (comSubExpElim regs instrs (FFI s r1 r2 r3 r4 m) = - (regs, instrs, FFI s r1 r2 r3 r4 m)) + (comSubExpElim (n:num) (regsEq:regsE) (regsMap:regsM) (instrs:instrsM) (Skip) = + (n, regsEq, regsMap, instrs, Skip)) ∧ + (comSubExpElim n regsEq regsMap instrs (Move r rs) = + let (regsEq', regsMap', rs') = canonicalMoveRegs regsEq regsMap rs in + (n, regsEq', regsMap', instrs, Move r rs')) ∧ + (comSubExpElim n regsEq regsMap instrs (Inst i) = + let (n', regsEq', regsMap', instrs', p) = comSubExpElimInst n regsEq regsMap instrs i in + (n', regsEq', regsMap', instrs', p)) ∧ + (comSubExpElim n regsEq regsMap instrs (Assign r e) = + let e' = canonicalExp regsMap e in + (n, regsEq, regsMap, instrs, Assign r e')) ∧ + (comSubExpElim n regsEq regsMap instrs (Get r x) = + (n, regsEq, regsMap, instrs, Get r x)) ∧ + (comSubExpElim n regsEq regsMap instrs (Set x e) = + let e' = canonicalExp regsMap e in + (n, regsEq, regsMap, instrs, Set x e')) ∧ + (comSubExpElim n regsEq regsMap instrs (Store e r) = + let r' = canonicalRegs regsMap r in + (n, regsEq, regsMap, instrs, Store e r')) ∧ + (comSubExpElim n regsEq regsMap instrs (MustTerminate p) = + let (n', regsEq', regsMap', instrs', p') = comSubExpElim n regsEq regsMap instrs p in + (n', regsEq', regsMap', instrs', MustTerminate p')) ∧ + (comSubExpElim n regsEq regsMap instrs (Call ret dest args handler) = + let args' = canonicalMultRegs regsMap args in + (n, [], LN, empty listCmp, Call ret dest args' handler)) ∧ + (comSubExpElim n regsEq regsMap instrs (Seq p1 p2) = + let (n', regsEq1, regsMap1, instrs1, p1') = comSubExpElim n regsEq regsMap instrs p1 in + let (n'', regsEq2, regsMap2, instrs2, p2') = comSubExpElim n' regsEq1 regsMap1 instrs1 p2 in + (n'', regsEq2, regsMap2, instrs2, Seq p1' p2')) ∧ + (comSubExpElim n regsEq regsMap instrs (If c r1 r2 p1 p2) = + let r1' = canonicalRegs regsMap r1 in + let r2' = canonicalImmReg regsMap r2 in + let (n', regsEq', regsMap', instrs', p1') = comSubExpElim n regsEq regsMap instrs p1 in + let (n'', regsEq', regsMap', instrs', p2') = comSubExpElim n' regsEq regsMap instrs p2 in + (n'', regsEq, regsMap, instrs, If c r1' r2' p1' p2')) ∧ + (comSubExpElim n regsEq regsMap instrs (Alloc r m) = + (n, regsEq, regsMap, instrs, Alloc r m)) ∧ + (comSubExpElim n regsEq regsMap instrs (Raise r) = + let r' = canonicalRegs regsMap r in + (n, regsEq, regsMap, instrs, Raise r')) ∧ + (comSubExpElim n regsEq regsMap instrs (Return r1 r2) = + let r1' = canonicalRegs regsMap r1 in + let r2' = canonicalRegs regsMap r2 in + (n, regsEq, regsMap, instrs, Return r1' r2')) ∧ + (comSubExpElim n regsEq regsMap instrs (Tick) = + (n, regsEq, regsMap, instrs, Tick)) ∧ + (comSubExpElim n regsEq regsMap instrs (OpCurrHeap b r1 r2) = + let r2' = canonicalRegs regsMap r2 in + (n, regsEq, regsMap, instrs, OpCurrHeap b r1 r2')) ∧ + (comSubExpElim n regsEq regsMap instrs (LocValue r1 l) = + (n, regsEq, regsMap, instrs, LocValue r1 l)) ∧ + (comSubExpElim n regsEq regsMap instrs (Install p l dp dl m) = + (n, regsEq, regsMap, instrs, Install p l dp dl m)) ∧ + (comSubExpElim n regsEq regsMap instrs (CodeBufferWrite r1 r2) = + (n, regsEq, regsMap, instrs, CodeBufferWrite r1 r2)) ∧ + (comSubExpElim n regsEq regsMap instrs (DataBufferWrite r1 r2) = + (n, regsEq, regsMap, instrs, DataBufferWrite r1 r2)) ∧ + (comSubExpElim n regsEq regsMap instrs (FFI s p1 l1 p2 l2 m) = + (n, regsEq, regsMap, instrs, FFI s p1 l1 p2 l2 m)) End +Definition optSubExp_def: + optSubExp p = comSubExpElim 0 [] LN (empty listCmp) p +End + +(* +EVAL “optSubExp (Seq (Inst (Arith (Binop Add 3 1 (Reg 2)))) (Inst (Arith (Binop Add 4 1 (Reg 2)))))” + +EVAL “optSubExp + (Seq + (Inst (Arith (Binop Add 3 1 (Reg 2)))) + (Seq + (Inst (Arith (Binop Add 4 1 (Reg 2)))) + (Seq + (Inst (Arith (Binop Sub 5 1 (Reg 3)))) + (Inst (Arith (Binop Sub 6 1 (Reg 4)))) + ))) +” +*) + val _ = export_theory (); From 7f006850e048ff3a75a7e4034ff3ebe3f515e5af Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Fri, 10 Jun 2022 13:33:52 +0200 Subject: [PATCH 06/36] Adding tests for first version --- compiler/backend/README.md | 7 ++- examples/compilation/to_word/Holmakefile | 36 +---------- examples/compilation/to_word/README.md | 4 ++ examples/compilation/to_word/readmePrefix | 1 + .../to_word/to_wordCompileScript.sml | 63 ++++++++++++++++++- 5 files changed, 73 insertions(+), 38 deletions(-) create mode 100644 examples/compilation/to_word/README.md create mode 100644 examples/compilation/to_word/readmePrefix diff --git a/compiler/backend/README.md b/compiler/backend/README.md index 3654f71d96..98ef447fda 100644 --- a/compiler/backend/README.md +++ b/compiler/backend/README.md @@ -11,7 +11,7 @@ This directory contains the ARMv7-specific part of the compiler backend. This directory contains the ARMv8-specific part of the compiler backend. [arm8_asl](arm8_asl): -This directory contains the ASL-derived ARMv8-specific part of the +This directory contains proofs for the ASL-derived ARMv8-specific part of the compiler backend. [backendComputeLib.sml](backendComputeLib.sml): @@ -314,6 +314,11 @@ The bignum library used by the CakeML compiler. Note that the implementation is automatically generated from a shallow embedding that is part of the HOL distribution in mc_multiwordTheory. +[word_comSubExpElimScript.sml](word_comSubExpElimScript.sml): +This file is a Work in Progress. +It gives some functions and verification proofs about a Common Sub-Expression +Elimination occuring right atfer the SSA-like renaming. + [word_depthScript.sml](word_depthScript.sml): Computes the call graph for wordLang program with an acyclic call graph. This graph is in turn used to compute the max stack depth diff --git a/examples/compilation/to_word/Holmakefile b/examples/compilation/to_word/Holmakefile index a805b47127..f0ed8421f0 100644 --- a/examples/compilation/to_word/Holmakefile +++ b/examples/compilation/to_word/Holmakefile @@ -1,43 +1,9 @@ INCLUDES = $(CAKEMLDIR)/misc $(CAKEMLDIR)/basis $(CAKEMLDIR)/compiler ../.. -all: $(DEFAULT_TARGETS) README.md exec +all: $(DEFAULT_TARGETS) README.md .PHONY: all README_SOURCES = $(wildcard *Script.sml) $(wildcard *Lib.sml) $(wildcard *Syntax.sml) DIRS = $(wildcard */) README.md: $(CAKEMLDIR)/developers/readme_gen readmePrefix $(patsubst %,%readmePrefix,$(DIRS)) $(README_SOURCES) $(protect $(CAKEMLDIR)/developers/readme_gen) $(README_SOURCES) - -ifndef CC -CC=gcc -endif -cat.S: *catCompileScript.sml -cake_cat: cat.S $(CAKEMLDIR)/basis/basis_ffi.o - $(CC) $< $(protect $(CAKEMLDIR)/basis/basis_ffi.o) $(GCCFLAGS) -o $@ -grep.S: *grepCompileScript.sml -cake_grep: grep.S $(CAKEMLDIR)/basis/basis_ffi.o - $(CC) $< $(protect $(CAKEMLDIR)/basis/basis_ffi.o) $(GCCFLAGS) -o $@ -patch.S: *patchCompileScript.sml -cake_patch: patch.S $(CAKEMLDIR)/basis/basis_ffi.o - $(CC) $< $(protect $(CAKEMLDIR)/basis/basis_ffi.o) $(GCCFLAGS) -o $@ -diff.S: *diffCompileScript.sml -cake_diff: diff.S $(CAKEMLDIR)/basis/basis_ffi.o - $(CC) $< $(protect $(CAKEMLDIR)/basis/basis_ffi.o) $(GCCFLAGS) -o $@ -hello.S: *helloCompileScript.sml -cake_hello: hello.S $(CAKEMLDIR)/basis/basis_ffi.o - $(CC) $< $(protect $(CAKEMLDIR)/basis/basis_ffi.o) $(GCCFLAGS) -o $@ -sort.S: *sortCompileScript.sml -cake_sort: sort.S $(CAKEMLDIR)/basis/basis_ffi.o - $(CC) $< $(protect $(CAKEMLDIR)/basis/basis_ffi.o) $(GCCFLAGS) -o $@ -echo.S: *echoCompileScript.sml -cake_echo: echo.S $(CAKEMLDIR)/basis/basis_ffi.o - $(CC) $< $(protect $(CAKEMLDIR)/basis/basis_ffi.o) $(GCCFLAGS) -o $@ -helloErr.S: *helloErrCompileScript.sml -cake_helloErr: helloErr.S $(CAKEMLDIR)/basis/basis_ffi.o - $(CC) $< $(protect $(CAKEMLDIR)/basis/basis_ffi.o) $(GCCFLAGS) -o $@ -iocat.S: *iocatCompileScript.sml -cake_iocat: iocat.S $(CAKEMLDIR)/basis/basis_ffi.o - $(CC) $< $(protect $(CAKEMLDIR)/basis/basis_ffi.o) $(GCCFLAGS) -o $@ - -exec: cake_cat cake_grep cake_patch cake_diff cake_hello cake_sort cake_echo cake_helloErr cake_iocat -.PHONY: exec diff --git a/examples/compilation/to_word/README.md b/examples/compilation/to_word/README.md new file mode 100644 index 0000000000..ae8ba32fe1 --- /dev/null +++ b/examples/compilation/to_word/README.md @@ -0,0 +1,4 @@ +Example compilation + +[to_wordCompileScript.sml](to_wordCompileScript.sml): +Compiles a program to wordLang diff --git a/examples/compilation/to_word/readmePrefix b/examples/compilation/to_word/readmePrefix new file mode 100644 index 0000000000..0d3fa3d758 --- /dev/null +++ b/examples/compilation/to_word/readmePrefix @@ -0,0 +1 @@ +Example compilation \ No newline at end of file diff --git a/examples/compilation/to_word/to_wordCompileScript.sml b/examples/compilation/to_word/to_wordCompileScript.sml index 4e69c96cf6..0ff7a005a3 100644 --- a/examples/compilation/to_word/to_wordCompileScript.sml +++ b/examples/compilation/to_word/to_wordCompileScript.sml @@ -1,8 +1,7 @@ (* Compiles a program to wordLang *) -open preamble compilationLib basis - +open preamble compilationLib basis word_comSubExpElimTheory val _ = new_theory "to_wordCompile" val _ = (max_print_depth := 500); @@ -72,4 +71,64 @@ Theorem foldr_example = Theorem foldr_example_ssa = comp_to_ssa true "foldr" foldr_prog_def; +val tm = foldr_example_ssa |> concl |> rand + +Definition test_def: + test p = let (n,regsEq, regsMap, instrs, p') = comSubExpElim 0 [] LN (empty listCmp) p in p' +End + +Definition progCmp_def: + progCmp p1 p2 = + if p1=p2 + then [] + else case (p1,p2) of + | (wordLang$Seq p11 p12, wordLang$Seq p21 p22) => (progCmp p11 p21) ++ (progCmp p12 p22) + | (wordLang$If _ _ _ p11 p12, wordLang$If _ _ _ p21 p22) => (progCmp p11 p21) ++ (progCmp p12 p22) + | (_,_) => [(p1,p2)] +End + +(* +Definition prog1_def: + prog1 = + Move 1 [(37,0); (41,2); (45,4); (49,6)] ▸ + If Equal 41 (Imm 2w) + (Inst (Const 53 18w) ▸ Move 0 [(2,45)] ▸ Return 37 2 ▸ + Move 1 [(181,37); (177,49)] ▸ Inst (Const 185 0w) ▸ + Inst (Const 189 0w) ▸ Inst (Const 193 0w) ▸ Move 1 [(197,53)] ▸ + Inst (Const 201 0w) ▸ Move 1 [(205,41)] ▸ Move 1 [(209,45)] ▸ + Inst (Const 213 0w) ▸ Inst (Const 217 0w)) + (Inst (Const 57 2w) ▸ Move 0 [(61,41)] ▸ + Inst (Arith (Shift Lsr 65 61 9)) ▸ OpCurrHeap Add 69 65 ▸ + Inst (Mem Load 73 (Addr 69 8w)) ▸ Move 0 [(77,41)] ▸ + Inst (Arith (Shift Lsr 81 77 9)) ▸ OpCurrHeap Add 85 81 ▸ + Inst (Mem Load 89 (Addr 85 16w)) ▸ + Move 1 [(95,37); (99,49); (103,73)] ▸ + Move 0 [(2,89); (4,45); (6,49)] ▸ + Call + (SOME + (2,insert 95 () (insert 99 () (insert 103 () LN)), + Move 1 [(109,95); (113,99); (117,103)] ▸ Move 0 [(121,2)], + 249,2)) (SOME 249) [2; 4; 6] NONE ▸ Move 0 [(125,113)] ▸ + Inst (Arith (Shift Lsr 129 125 9)) ▸ OpCurrHeap Add 133 129 ▸ + Inst (Mem Load 137 (Addr 133 16w)) ▸ + If Equal 137 (Imm 4w) + (Inst (Const 141 18w) ▸ Move 0 [(145,113)] ▸ + Inst (Arith (Shift Lsr 149 145 9)) ▸ OpCurrHeap Add 153 149 ▸ + Inst (Mem Load 157 (Addr 153 8w)) ▸ + Move 0 [(0,109); (2,121); (4,117); (6,113); (8,157)] ▸ + Call NONE NONE [0; 2; 4; 6; 8] NONE ▸ + Move 1 [(169,153); (165,141)] ▸ Move 1 [(173,157)]) + (Inst (Const 161 2w) ▸ + Move 0 [(0,109); (2,121); (4,117); (6,113)] ▸ + Call NONE (SOME 69) [0; 2; 4; 6] NONE ▸ + Move 1 [(169,133); (165,161)] ▸ Inst (Const 173 0w)) ▸ + Move 1 [(181,109); (177,113)] ▸ Move 1 [(185,137)] ▸ + Move 1 [(189,117)] ▸ Move 1 [(193,121)] ▸ Inst (Const 197 0w) ▸ + Move 1 [(201,173)] ▸ Inst (Const 205 0w) ▸ Inst (Const 209 0w) ▸ + Move 1 [(213,165)] ▸ Move 1 [(217,169)]) +End + + +EVAL “progCmp ^tm (test ^tm)” +*) val _ = export_theory (); From 1408abd83ef0d5417a1d3af6c3f230cbf7372f22 Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Mon, 13 Jun 2022 11:16:53 +0200 Subject: [PATCH 07/36] Final first version (added OpCurrHeap case). --- compiler/backend/word_comSubExpElimScript.sml | 322 +++++++++--------- examples/compilation/to_word/README.md | 3 + .../to_word/to_wordCompileScript.sml | 2 +- .../to_word/word_cse_testScript.sml | 19 ++ 4 files changed, 189 insertions(+), 157 deletions(-) create mode 100644 examples/compilation/to_word/word_cse_testScript.sml diff --git a/compiler/backend/word_comSubExpElimScript.sml b/compiler/backend/word_comSubExpElimScript.sml index f57f850dca..ee4ec63267 100644 --- a/compiler/backend/word_comSubExpElimScript.sml +++ b/compiler/backend/word_comSubExpElimScript.sml @@ -212,104 +212,110 @@ QED (* REGISTER TRANSFORMATIONS *) Definition canonicalRegs_def: - canonicalRegs (regsMap:num num_map) (r:num) = - case sptree$lookup r regsMap of + canonicalRegs (instMap:regsM) (ochMap:regsM) (r:num) = + case sptree$lookup r instMap of | SOME r' => r' - | NONE => r + | NONE => case sptree$lookup r ochMap of + | NONE => r + | SOME r' => r' End Definition canonicalImmReg_def: - canonicalImmReg regsMap (Reg r) = Reg (canonicalRegs regsMap r) ∧ - canonicalImmReg regsMap (Imm w) = Imm w + canonicalImmReg instMap ochMap (Reg r) = Reg (canonicalRegs instMap ochMap r) ∧ + canonicalImmReg instMap ochMap (Imm w) = Imm w End Definition canonicalMultRegs_def: - canonicalMultRegs regsMap [] = [] ∧ - canonicalMultRegs regsMap (hd::tl) = - (canonicalRegs regsMap hd)::(canonicalMultRegs regsMap tl) + canonicalMultRegs instMap ochMap[] = [] ∧ + canonicalMultRegs instMap ochMap (hd::tl) = + (canonicalRegs instMap ochMap hd)::(canonicalMultRegs instMap ochMap tl) End Definition canonicalMoveRegs_def: - canonicalMoveRegs regsEq regsMap [] = (regsEq, regsMap, []) ∧ - canonicalMoveRegs regsEq regsMap ((r1,r2)::tl) = - let r2' = canonicalRegs regsMap r2 in - let regsEq' = regsUpdate r2' r1 regsEq in - let regsMap' = sptree$insert r1 r2' regsMap in - let (regsEq'', regsMap'', tl') = canonicalMoveRegs regsEq' regsMap' tl in - regsEq'', regsMap'', (r1,r2')::tl' + canonicalMoveRegs instEq instMap ochMap [] = (instEq, instMap, ochMap, []) ∧ + canonicalMoveRegs instEq instMap ochMap ((r1,r2)::tl) = + case sptree$lookup r2 ochMap of + | SOME r2' => let ochMap' = sptree$insert r1 r2' ochMap in + let (instEq', instMap', ochMap'', tl') = canonicalMoveRegs instEq instMap ochMap' tl in + (instEq', instMap', ochMap'', (r1,r2')::tl') + | NONE => let r2' = (case sptree$lookup r2 instMap of SOME r => r | NONE => r2) in + let instEq' = regsUpdate r2' r1 instEq in + let instMap' = sptree$insert r1 r2' instMap in + let (instEq'', instMap'', ochMap', tl') = canonicalMoveRegs instEq' instMap' ochMap tl in + (instEq'', instMap'', ochMap', (r1,r2')::tl') End Definition canonicalExp_def: - canonicalExp regsMap e = e + canonicalExp instMap ochMap e = e End Definition canonicalMultExp_def: - canonicalMultExp regsMap [] = [] ∧ - canonicalMultExp regsMap (hd::tl) = - (canonicalExp regsMap hd)::(canonicalMultExp regsMap tl) + canonicalMultExp instMap ochMap [] = [] ∧ + canonicalMultExp instMap ochMap (hd::tl) = + (canonicalExp instMap ochMap hd)::(canonicalMultExp instMap ochMap tl) End Definition canonicalExp_def: - canonicalExp regsMap (Const w) = Const w ∧ - canonicalExp regsMap (Var r) = Var (canonicalRegs regsMap r) ∧ - canonicalExp regsMap (Lookup s) = Lookup s ∧ - canonicalExp regsMap (Load e) = Load (canonicalExp regsMap e) ∧ - canonicalExp regsMap (Op op nl) = Op op (canonicalMultExp regsMap nl) ∧ - canonicalExp regsMap (Shift s e n) = Shift s (canonicalExp regsMap e) n + canonicalExp instMap ochMap (Const w) = Const w ∧ + canonicalExp instMap ochMap (Var r) = Var (canonicalRegs instMap ochMap r) ∧ + canonicalExp instMap ochMap (Lookup s) = Lookup s ∧ + canonicalExp instMap ochMap (Load e) = Load (canonicalExp instMap ochMap e) ∧ + canonicalExp instMap ochMap (Op op nl) = Op op (canonicalMultExp instMap ochMap nl) ∧ + canonicalExp instMap ochMap (Shift s e n) = Shift s (canonicalExp instMap ochMap e) n End Definition canonicalArith_def: - canonicalArith regsMap (Binop op r1 r2 r3) = - Binop op r1 (canonicalRegs regsMap r2) (canonicalImmReg regsMap r3) ∧ - canonicalArith regsMap (Shift s r1 r2 n) = - Shift s (canonicalRegs regsMap r1) (canonicalRegs regsMap r2) n ∧ - canonicalArith regsMap (Div r1 r2 r3) = - Div r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) ∧ - canonicalArith regsMap (LongMul r1 r2 r3 r4) = - LongMul r1 r2 (canonicalRegs regsMap r3) (canonicalRegs regsMap r4) ∧ - canonicalArith regsMap (LongDiv r1 r2 r3 r4 r5) = - LongDiv r1 r2 (canonicalRegs regsMap r3) (canonicalRegs regsMap r4) (canonicalRegs regsMap r5) ∧ - canonicalArith regsMap (AddCarry r1 r2 r3 r4) = - AddCarry r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) r4 ∧ - canonicalArith regsMap (AddOverflow r1 r2 r3 r4) = - AddOverflow r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) r4 ∧ - canonicalArith regsMap (SubOverflow r1 r2 r3 r4) = - SubOverflow r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) r4 + canonicalArith instMap ochMap (Binop op r1 r2 r3) = + Binop op r1 (canonicalRegs instMap ochMap r2) (canonicalImmReg instMap ochMap r3) ∧ + canonicalArith instMap ochMap (Shift s r1 r2 n) = + Shift s (canonicalRegs instMap ochMap r1) (canonicalRegs instMap ochMap r2) n ∧ + canonicalArith instMap ochMap (Div r1 r2 r3) = + Div r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) ∧ + canonicalArith instMap ochMap (LongMul r1 r2 r3 r4) = + LongMul r1 r2 (canonicalRegs instMap ochMap r3) (canonicalRegs instMap ochMap r4) ∧ + canonicalArith instMap ochMap (LongDiv r1 r2 r3 r4 r5) = + LongDiv r1 r2 (canonicalRegs instMap ochMap r3) (canonicalRegs instMap ochMap r4) (canonicalRegs instMap ochMap r5) ∧ + canonicalArith instMap ochMap (AddCarry r1 r2 r3 r4) = + AddCarry r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) r4 ∧ + canonicalArith instMap ochMap (AddOverflow r1 r2 r3 r4) = + AddOverflow r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) r4 ∧ + canonicalArith instMap ochMap (SubOverflow r1 r2 r3 r4) = + SubOverflow r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) r4 End Definition canonicalFp_def: - canonicalFp regsMap (FPLess r1 r2 r3) = - FPLess r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) ∧ - canonicalFp regsMap (FPLessEqual r1 r2 r3) = - FPLessEqual r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) ∧ - canonicalFp regsMap (FPEqual r1 r2 r3) = - FPEqual r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) ∧ - canonicalFp regsMap (FPAbs r1 r2) = - FPAbs r1 (canonicalRegs regsMap r2) ∧ - canonicalFp regsMap (FPNeg r1 r2) = - FPNeg r1 (canonicalRegs regsMap r2) ∧ - canonicalFp regsMap (FPSqrt r1 r2) = - FPSqrt r1 (canonicalRegs regsMap r2) ∧ - canonicalFp regsMap (FPAdd r1 r2 r3) = - FPAdd r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) ∧ - canonicalFp regsMap (FPSub r1 r2 r3) = - FPSub r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) ∧ - canonicalFp regsMap (FPMul r1 r2 r3) = - FPMul r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) ∧ - canonicalFp regsMap (FPDiv r1 r2 r3) = - FPDiv r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) ∧ - canonicalFp regsMap (FPFma r1 r2 r3) = - FPFma r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) ∧ - canonicalFp regsMap (FPMov r1 r2) = - FPMov r1 (canonicalRegs regsMap r2) ∧ - canonicalFp regsMap (FPMovToReg r1 r2 r3) = - FPMovToReg r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) ∧ - canonicalFp regsMap (FPMovFromReg r1 r2 r3) = - FPMovFromReg r1 (canonicalRegs regsMap r2) (canonicalRegs regsMap r3) ∧ - canonicalFp regsMap (FPToInt r1 r2) = - FPToInt r1 (canonicalRegs regsMap r2) ∧ - canonicalFp regsMap (FPFromInt r1 r2) = - FPFromInt r1 (canonicalRegs regsMap r2) + canonicalFp instMap ochMap (FPLess r1 r2 r3) = + FPLess r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) ∧ + canonicalFp instMap ochMap (FPLessEqual r1 r2 r3) = + FPLessEqual r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) ∧ + canonicalFp instMap ochMap (FPEqual r1 r2 r3) = + FPEqual r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) ∧ + canonicalFp instMap ochMap (FPAbs r1 r2) = + FPAbs r1 (canonicalRegs instMap ochMap r2) ∧ + canonicalFp instMap ochMap (FPNeg r1 r2) = + FPNeg r1 (canonicalRegs instMap ochMap r2) ∧ + canonicalFp instMap ochMap (FPSqrt r1 r2) = + FPSqrt r1 (canonicalRegs instMap ochMap r2) ∧ + canonicalFp instMap ochMap (FPAdd r1 r2 r3) = + FPAdd r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) ∧ + canonicalFp instMap ochMap (FPSub r1 r2 r3) = + FPSub r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) ∧ + canonicalFp instMap ochMap (FPMul r1 r2 r3) = + FPMul r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) ∧ + canonicalFp instMap ochMap (FPDiv r1 r2 r3) = + FPDiv r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) ∧ + canonicalFp instMap ochMap (FPFma r1 r2 r3) = + FPFma r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) ∧ + canonicalFp instMap ochMap (FPMov r1 r2) = + FPMov r1 (canonicalRegs instMap ochMap r2) ∧ + canonicalFp instMap ochMap (FPMovToReg r1 r2 r3) = + FPMovToReg r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) ∧ + canonicalFp instMap ochMap (FPMovFromReg r1 r2 r3) = + FPMovFromReg r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) ∧ + canonicalFp instMap ochMap (FPToInt r1 r2) = + FPToInt r1 (canonicalRegs instMap ochMap r2) ∧ + canonicalFp instMap ochMap (FPFromInt r1 r2) = + FPFromInt r1 (canonicalRegs instMap ochMap r2) End (* SEEN INSTRUCTIONS MEMORY *) @@ -547,7 +553,8 @@ Numbers above 99 corresponds to a register or a word value. *) (* TODO : redo the rename of instruction numbers such that each is unique *) Definition progToNumList_def: - progToNumList (Inst i) = 0::(instToNumList i) + progToNumList (Inst i) = 0::(instToNumList i) ∧ + progToNumList (OpCurrHeap op r1 r2) = [1; arithOpToNum op; r2+100] End (* Theorem progToNumList_unique: @@ -589,28 +596,28 @@ Definition firstRegOfFp_def: End Definition comSubExpElimInst_def: - (comSubExpElimInst (n:num) (regsEq:regsE) (regsMap:regsM) (instrs:instrsM) Skip = (n, regsEq, regsMap, instrs, Inst Skip)) ∧ - (comSubExpElimInst n regsEq regsMap instrs (Const r w) = + (comSubExpElimInst (n:num) (instEq:regsE) (instMap:regsM) (instInstrs:instrsM) (ochMap:regsM) Skip = (n, instEq, instMap, instInstrs, Inst Skip)) ∧ + (comSubExpElimInst n instEq instMap instInstrs ochMap (Const r w) = let i = instToNumList (Const r w) in - case mlmap$lookup instrs i of - | SOME r' => (n+1, regsUpdate r' r regsEq, insert r r' regsMap, instrs, Move 0 [(r,r')]) - | NONE => (n, regsEq, regsMap, insert instrs i r, Inst (Const r w))) ∧ - (comSubExpElimInst n regsEq regsMap instrs (Arith a) = - let a' = canonicalArith regsMap a in + case mlmap$lookup instInstrs i of + | SOME r' => (n+1, regsUpdate r' r instEq, insert r r' instMap, instInstrs, Move 0 [(r,r')]) + | NONE => (n, instEq, instMap, insert instInstrs i r, Inst (Const r w))) ∧ + (comSubExpElimInst n instEq instMap instInstrs ochMap (Arith a) = + let a' = canonicalArith instMap ochMap a in let r = firstRegOfArith a' in let i = instToNumList (Arith a') in - case mlmap$lookup instrs i of - | SOME r' => (n+1, regsUpdate r' r regsEq, insert r r' regsMap, instrs, Move 0 [(r,r')]) - | NONE => (n, regsEq, regsMap, insert instrs i r, Inst (Arith a'))) ∧ - (comSubExpElimInst n regsEq regsMap instrs (Mem op r (Addr r' w)) = - (n, regsEq, regsMap, instrs, Inst (Mem op (canonicalRegs regsMap r) (Addr (canonicalRegs regsMap r') w)))) ∧ - (comSubExpElimInst n regsEq regsMap instrs ((FP f):'a inst) = - let f' = canonicalFp regsMap f in + case mlmap$lookup instInstrs i of + | SOME r' => (n+1, regsUpdate r' r instEq, insert r r' instMap, instInstrs, Move 0 [(r,r')]) + | NONE => (n, instEq, instMap, insert instInstrs i r, Inst (Arith a'))) ∧ + (comSubExpElimInst n instEq instMap instInstrs ochMap (Mem op r (Addr r' w)) = + (n, instEq, instMap, instInstrs, Inst (Mem op (canonicalRegs instMap ochMap r) (Addr (canonicalRegs instMap ochMap r') w)))) ∧ + (comSubExpElimInst n instEq instMap instInstrs ochMap ((FP f):'a inst) = + let f' = canonicalFp instMap ochMap f in let r = firstRegOfFp f' in let i = instToNumList ((FP f'):'a inst) in - case mlmap$lookup instrs i of - | SOME r' => (n+1, regsUpdate r' r regsEq, insert r r' regsMap, instrs, Move 0 [(r,r')]) - | NONE => (n, regsEq, regsMap, insert instrs i r, Inst (FP f'))) + case mlmap$lookup instInstrs i of + | SOME r' => (n+1, regsUpdate r' r instEq, insert r r' instMap, instInstrs, Move 0 [(r,r')]) + | NONE => (n, instEq, instMap, insert instInstrs i r, Inst (FP f'))) End (* @@ -634,75 +641,78 @@ Signification of the terms: s -> string *) Definition comSubExpElim_def: - (comSubExpElim (n:num) (regsEq:regsE) (regsMap:regsM) (instrs:instrsM) (Skip) = - (n, regsEq, regsMap, instrs, Skip)) ∧ - (comSubExpElim n regsEq regsMap instrs (Move r rs) = - let (regsEq', regsMap', rs') = canonicalMoveRegs regsEq regsMap rs in - (n, regsEq', regsMap', instrs, Move r rs')) ∧ - (comSubExpElim n regsEq regsMap instrs (Inst i) = - let (n', regsEq', regsMap', instrs', p) = comSubExpElimInst n regsEq regsMap instrs i in - (n', regsEq', regsMap', instrs', p)) ∧ - (comSubExpElim n regsEq regsMap instrs (Assign r e) = - let e' = canonicalExp regsMap e in - (n, regsEq, regsMap, instrs, Assign r e')) ∧ - (comSubExpElim n regsEq regsMap instrs (Get r x) = - (n, regsEq, regsMap, instrs, Get r x)) ∧ - (comSubExpElim n regsEq regsMap instrs (Set x e) = - let e' = canonicalExp regsMap e in - (n, regsEq, regsMap, instrs, Set x e')) ∧ - (comSubExpElim n regsEq regsMap instrs (Store e r) = - let r' = canonicalRegs regsMap r in - (n, regsEq, regsMap, instrs, Store e r')) ∧ - (comSubExpElim n regsEq regsMap instrs (MustTerminate p) = - let (n', regsEq', regsMap', instrs', p') = comSubExpElim n regsEq regsMap instrs p in - (n', regsEq', regsMap', instrs', MustTerminate p')) ∧ - (comSubExpElim n regsEq regsMap instrs (Call ret dest args handler) = - let args' = canonicalMultRegs regsMap args in - (n, [], LN, empty listCmp, Call ret dest args' handler)) ∧ - (comSubExpElim n regsEq regsMap instrs (Seq p1 p2) = - let (n', regsEq1, regsMap1, instrs1, p1') = comSubExpElim n regsEq regsMap instrs p1 in - let (n'', regsEq2, regsMap2, instrs2, p2') = comSubExpElim n' regsEq1 regsMap1 instrs1 p2 in - (n'', regsEq2, regsMap2, instrs2, Seq p1' p2')) ∧ - (comSubExpElim n regsEq regsMap instrs (If c r1 r2 p1 p2) = - let r1' = canonicalRegs regsMap r1 in - let r2' = canonicalImmReg regsMap r2 in - let (n', regsEq', regsMap', instrs', p1') = comSubExpElim n regsEq regsMap instrs p1 in - let (n'', regsEq', regsMap', instrs', p2') = comSubExpElim n' regsEq regsMap instrs p2 in - (n'', regsEq, regsMap, instrs, If c r1' r2' p1' p2')) ∧ - (comSubExpElim n regsEq regsMap instrs (Alloc r m) = - (n, regsEq, regsMap, instrs, Alloc r m)) ∧ - (comSubExpElim n regsEq regsMap instrs (Raise r) = - let r' = canonicalRegs regsMap r in - (n, regsEq, regsMap, instrs, Raise r')) ∧ - (comSubExpElim n regsEq regsMap instrs (Return r1 r2) = - let r1' = canonicalRegs regsMap r1 in - let r2' = canonicalRegs regsMap r2 in - (n, regsEq, regsMap, instrs, Return r1' r2')) ∧ - (comSubExpElim n regsEq regsMap instrs (Tick) = - (n, regsEq, regsMap, instrs, Tick)) ∧ - (comSubExpElim n regsEq regsMap instrs (OpCurrHeap b r1 r2) = - let r2' = canonicalRegs regsMap r2 in - (n, regsEq, regsMap, instrs, OpCurrHeap b r1 r2')) ∧ - (comSubExpElim n regsEq regsMap instrs (LocValue r1 l) = - (n, regsEq, regsMap, instrs, LocValue r1 l)) ∧ - (comSubExpElim n regsEq regsMap instrs (Install p l dp dl m) = - (n, regsEq, regsMap, instrs, Install p l dp dl m)) ∧ - (comSubExpElim n regsEq regsMap instrs (CodeBufferWrite r1 r2) = - (n, regsEq, regsMap, instrs, CodeBufferWrite r1 r2)) ∧ - (comSubExpElim n regsEq regsMap instrs (DataBufferWrite r1 r2) = - (n, regsEq, regsMap, instrs, DataBufferWrite r1 r2)) ∧ - (comSubExpElim n regsEq regsMap instrs (FFI s p1 l1 p2 l2 m) = - (n, regsEq, regsMap, instrs, FFI s p1 l1 p2 l2 m)) -End - -Definition optSubExp_def: - optSubExp p = comSubExpElim 0 [] LN (empty listCmp) p + (comSubExpElim (n:num) (instEq:regsE) (instMap:regsM) (instInstrs:instrsM) (ochMap:regsM) (ochInstrs:instrsM) (Skip) = + (n, instEq, instMap, instInstrs, ochMap, ochInstrs, Skip)) ∧ + (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Move r rs) = + let (instEq', instMap', ochMap', rs') = canonicalMoveRegs instEq instMap ochMap rs in + (n, instEq', instMap', instInstrs, ochMap', ochInstrs, Move r rs')) ∧ + (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Inst i) = + let (n', instEq', instMap', instInstrs', p) = comSubExpElimInst n instEq instMap instInstrs ochMap i in + (n', instEq', instMap', instInstrs', ochMap, ochInstrs, p)) ∧ + (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Assign r e) = + let e' = canonicalExp instMap ochMap e in + (n, instEq, instMap, instInstrs, ochMap, ochInstrs, Assign r e')) ∧ + (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Get r x) = + (n, instEq, instMap, instInstrs, ochMap, ochInstrs, Get r x)) ∧ + (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Set x e) = + let e' = canonicalExp instMap ochMap e in + (n, instEq, instMap, instInstrs, LN, empty listCmp, Set x e')) ∧ + (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Store e r) = + let r' = canonicalRegs instMap ochMap r in + (n, instEq, instMap, instInstrs, ochMap, ochInstrs, Store e r')) ∧ + (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (MustTerminate p) = + let (n', instEq', instMap', instInstrs', ochMap', ochInstrs', p') = comSubExpElim n instEq instMap instInstrs ochMap ochInstrs p in + (n', instEq', instMap', instInstrs', ochMap', ochInstrs', MustTerminate p')) ∧ + (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Call ret dest args handler) = + (n, [], LN, empty listCmp, LN, empty listCmp, Call ret dest args handler)) ∧ + (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Seq p1 p2) = + let (n1, regsEq1, regsMap1, instrs1, ochMap1, ochInstrs1, p1') = comSubExpElim n instEq instMap instInstrs ochMap ochInstrs p1 in + let (n2, regsEq2, regsMap2, instrs2, ochMap2, ochInstrs2, p2') = comSubExpElim n1 regsEq1 regsMap1 instrs1 ochMap1 ochInstrs1 p2 in + (n2, regsEq2, regsMap2, instrs2, ochMap2, ochInstrs2, Seq p1' p2')) ∧ + (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (If c r1 r2 p1 p2) = + let r1' = canonicalRegs instMap ochMap r1 in + let r2' = canonicalImmReg instMap ochMap r2 in + let (n1, instEq1, instMap1, instInstrs1, ochMap1, ochInstrs1, p1') = comSubExpElim n instEq instMap instInstrs ochMap ochInstrs p1 in + let (n2, instEq2, instMap2, instInstrs2, ochMap2, ochInstrs2, p2') = comSubExpElim n1 instEq instMap instInstrs ochMap ochInstrs p2 in + (n2, [], LN, empty listCmp, LN, empty listCmp, If c r1' r2' p1' p2')) ∧ + (* We don't know what happen in the IF. Intersection would be the best. *) + (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Alloc r m) = + (n, instEq, instMap, instInstrs, LN, empty listCmp, Alloc r m)) ∧ + (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Raise r) = + let r' = canonicalRegs instMap ochMap r in + (n, instEq, instMap, instInstrs, ochMap, ochInstrs, Raise r')) ∧ + (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Return r1 r2) = + let r1' = canonicalRegs instMap ochMap r1 in + let r2' = canonicalRegs instMap ochMap r2 in + (n, instEq, instMap, instInstrs, ochMap, ochInstrs, Return r1' r2')) ∧ + (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Tick) = + (n, instEq, instMap, instInstrs, ochMap, ochInstrs, Tick)) ∧ + (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs ((OpCurrHeap b r1 r2):'a prog) = + let r2' = canonicalRegs instMap ochMap r2 in + let pL = progToNumList ((OpCurrHeap b r1 r2'):'a prog) in + case lookup ochInstrs pL of + | NONE => (n, instEq, instMap, instInstrs, ochMap, insert ochInstrs pL r1, OpCurrHeap b r1 r2') + | SOME r1' => (n+1, instEq, instMap, instInstrs, insert r1 r1' ochMap, ochInstrs, Move 0 [(r1, r1')])) ∧ + (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (LocValue r1 l) = + (n, instEq, instMap, instInstrs, ochMap, ochInstrs, LocValue r1 l)) ∧ + (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Install p l dp dl m) = + (n, instEq, instMap, instInstrs, ochMap, ochInstrs, Install p l dp dl m)) ∧ + (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (CodeBufferWrite r1 r2) = + (n, instEq, instMap, instInstrs, ochMap, ochInstrs, CodeBufferWrite r1 r2)) ∧ + (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (DataBufferWrite r1 r2) = + (n, instEq, instMap, instInstrs, ochMap, ochInstrs, DataBufferWrite r1 r2)) ∧ + (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (FFI s p1 l1 p2 l2 m) = + (n, instEq, instMap, instInstrs, ochMap, ochInstrs, FFI s p1 l1 p2 l2 m)) +End + +Definition word_cse_def: + word_cse p = let (_,_,_,_,_,_,p') = comSubExpElim 0 [] LN (empty listCmp) LN (empty listCmp) p in p' End (* -EVAL “optSubExp (Seq (Inst (Arith (Binop Add 3 1 (Reg 2)))) (Inst (Arith (Binop Add 4 1 (Reg 2)))))” +EVAL “word_cse (Seq (Inst (Arith (Binop Add 3 1 (Reg 2)))) (Inst (Arith (Binop Add 4 1 (Reg 2)))))” -EVAL “optSubExp +EVAL “word_cse (Seq (Inst (Arith (Binop Add 3 1 (Reg 2)))) (Seq diff --git a/examples/compilation/to_word/README.md b/examples/compilation/to_word/README.md index ae8ba32fe1..c3759ed4a3 100644 --- a/examples/compilation/to_word/README.md +++ b/examples/compilation/to_word/README.md @@ -2,3 +2,6 @@ Example compilation [to_wordCompileScript.sml](to_wordCompileScript.sml): Compiles a program to wordLang + +[word_cse_testScript.sml](word_cse_testScript.sml): +Testing of the word common sub-expression elimination. diff --git a/examples/compilation/to_word/to_wordCompileScript.sml b/examples/compilation/to_word/to_wordCompileScript.sml index 0ff7a005a3..a1d7d14df4 100644 --- a/examples/compilation/to_word/to_wordCompileScript.sml +++ b/examples/compilation/to_word/to_wordCompileScript.sml @@ -74,7 +74,7 @@ Theorem foldr_example_ssa = val tm = foldr_example_ssa |> concl |> rand Definition test_def: - test p = let (n,regsEq, regsMap, instrs, p') = comSubExpElim 0 [] LN (empty listCmp) p in p' + test p = word_cse p End Definition progCmp_def: diff --git a/examples/compilation/to_word/word_cse_testScript.sml b/examples/compilation/to_word/word_cse_testScript.sml new file mode 100644 index 0000000000..d45b54d638 --- /dev/null +++ b/examples/compilation/to_word/word_cse_testScript.sml @@ -0,0 +1,19 @@ +(* + Testing of the word common sub-expression elimination. +*) + +open preamble to_wordCompileTheory word_comSubExpElimTheory word_allocTheory; + +val _ = new_theory "word_cse_test"; + +val tm = foldr_example_ssa |> concl |> dest_eq |> snd + +val tm' = “let p = word_cse ^tm in + remove_dead p LN” + +EVAL tm' + +EVAL “word_cse ^tm” + + +val _ = export_theory(); From b44c5f622442a7aceefce31cc7a4b0e45161a782 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Mon, 13 Jun 2022 13:58:45 +0200 Subject: [PATCH 08/36] Write structure for proof of WordLang CSE --- .../backend/proofs/word_cseProofScript.sml | 174 ++++++++++++++++++ .../to_word/word_cse_testScript.sml | 5 +- 2 files changed, 176 insertions(+), 3 deletions(-) create mode 100644 compiler/backend/proofs/word_cseProofScript.sml diff --git a/compiler/backend/proofs/word_cseProofScript.sml b/compiler/backend/proofs/word_cseProofScript.sml new file mode 100644 index 0000000000..2d3fecdfa7 --- /dev/null +++ b/compiler/backend/proofs/word_cseProofScript.sml @@ -0,0 +1,174 @@ +(* + Correctness proof for word_cse +*) +open preamble alistTheory; +open wordLangTheory wordSemTheory wordPropsTheory word_simpTheory word_comSubExpElimTheory; + +val _ = new_theory "word_cseProof"; + +val _ = set_grammar_ancestry ["wordLang", "wordSem", "wordProps", "word_comSubExpElim"]; + +(* setting up the goal *) + +val goal = “ + λ(p:'a wordLang$prog,s:('a,'c,'ffi) wordSem$state). + ∀res s' n instEq instMap instInstrs ochMap ochInstrs + n' instEq' instMap' instInstrs' ochMap' ochInstrs'. + evaluate (p, s) = (res, s') ∧ flat_exp_conventions p ∧ + comSubExpElim n instEq instMap instInstrs ochMap ochInstrs p = + (n', instEq', instMap', instInstrs', ochMap', ochInstrs', p') ⇒ + evaluate (p', s) = (res, s')” + +local + val gst = goal |> Ho_Rewrite.PURE_ONCE_REWRITE_CONV [Once PFORALL_THM] |> concl |> rhs + val ind_thm = evaluate_ind |> ISPEC goal |> GEN_BETA_RULE + val ind_goals = ind_thm |> concl |> dest_imp |> fst |> helperLib.list_dest dest_conj +in + fun get_goal s = first (can (find_term (can (match_term (Term [QUOTE s]))))) ind_goals + fun compile_correct_tm () = ind_thm |> concl |> rand + fun the_ind_thm () = ind_thm +end + +(* proof of the cases *) + +Theorem comp_Skip_correct: + ^(get_goal "Skip") +Proof + cheat +QED + +Theorem comp_Alloc_correct: + ^(get_goal "Alloc") +Proof + cheat +QED + +Theorem comp_Move_correct: + ^(get_goal "Move") +Proof + cheat +QED + +Theorem comp_Inst_correct: + ^(get_goal "Inst") +Proof + cheat +QED + +Theorem comp_Assign_correct: + ^(get_goal "Assign") +Proof + fs[flat_exp_conventions_def] +QED + +Theorem comp_Get_correct: + ^(get_goal "Get") +Proof + cheat +QED + +Theorem comp_Set_correct: + ^(get_goal "wordLang$Set") +Proof + cheat +QED + +Theorem comp_OpCurrHeap_correct: + ^(get_goal "OpCurrHeap") +Proof + cheat +QED + +Theorem comp_Store_correct: + ^(get_goal "Store") +Proof + fs[flat_exp_conventions_def] +QED + +Theorem comp_Tick_correct: + ^(get_goal "Tick") +Proof + cheat +QED + +Theorem comp_MustTerminate_correct: + ^(get_goal "MustTerminate") +Proof + cheat +QED + +Theorem comp_Seq_correct: + ^(get_goal "wordLang$Seq") +Proof + cheat +QED + +Theorem comp_Return_correct: + ^(get_goal "Return") +Proof + cheat +QED + +Theorem comp_Raise_correct: + ^(get_goal "wordLang$Raise") +Proof + cheat +QED + +Theorem comp_If_correct: + ^(get_goal "wordLang$If") +Proof + cheat +QED + +Theorem comp_LocValue_correct: + ^(get_goal "wordLang$LocValue") +Proof + cheat +QED + +Theorem comp_Install_correct: + ^(get_goal "wordLang$Install") +Proof + cheat +QED + +Theorem comp_CodeBufferWrite_correct: + ^(get_goal "wordLang$CodeBufferWrite") +Proof + cheat +QED + +Theorem comp_DataBufferWrite_correct: + ^(get_goal "wordLang$DataBufferWrite") +Proof + cheat +QED + +Theorem comp_FFI_correct: + ^(get_goal "wordLang$FFI") +Proof + cheat +QED + +Theorem comp_Call_correct: + ^(get_goal "wordLang$Call") +Proof + cheat +QED + +Theorem comp_correct: + ^(compile_correct_tm ()) +Proof + match_mp_tac (the_ind_thm()) >> + rpt conj_tac >> + MAP_FIRST MATCH_ACCEPT_TAC + [comp_Skip_correct,comp_Alloc_correct,comp_Move_correct,comp_Inst_correct,comp_Assign_correct, + comp_Get_correct,comp_Set_correct,comp_Store_correct,comp_Tick_correct,comp_MustTerminate_correct, + comp_Seq_correct,comp_Return_correct,comp_Raise_correct,comp_If_correct,comp_LocValue_correct, + comp_Install_correct,comp_CodeBufferWrite_correct,comp_DataBufferWrite_correct, + comp_FFI_correct,comp_OpCurrHeap_correct,comp_Call_correct + ] +QED + +val _ = export_theory(); diff --git a/examples/compilation/to_word/word_cse_testScript.sml b/examples/compilation/to_word/word_cse_testScript.sml index d45b54d638..d32b1437da 100644 --- a/examples/compilation/to_word/word_cse_testScript.sml +++ b/examples/compilation/to_word/word_cse_testScript.sml @@ -11,9 +11,8 @@ val tm = foldr_example_ssa |> concl |> dest_eq |> snd val tm' = “let p = word_cse ^tm in remove_dead p LN” -EVAL tm' - -EVAL “word_cse ^tm” +val res = EVAL tm'; +val res2 = EVAL “word_cse ^tm”; val _ = export_theory(); From b5b92443a4af06b9120e3aed2d76c4edb740409f Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Tue, 14 Jun 2022 11:25:20 +0200 Subject: [PATCH 09/36] Renaming of the Theory : word_cseTheory, wrap of all data structure into one : knowledge. --- ...ubExpElimScript.sml => word_cseScript.sml} | 354 ++++++++++-------- .../to_word/to_wordCompileScript.sml | 52 +-- .../to_word/word_cse_testScript.sml | 12 +- 3 files changed, 208 insertions(+), 210 deletions(-) rename compiler/backend/{word_comSubExpElimScript.sml => word_cseScript.sml} (59%) diff --git a/compiler/backend/word_comSubExpElimScript.sml b/compiler/backend/word_cseScript.sml similarity index 59% rename from compiler/backend/word_comSubExpElimScript.sml rename to compiler/backend/word_cseScript.sml index ee4ec63267..267c7681b5 100644 --- a/compiler/backend/word_comSubExpElimScript.sml +++ b/compiler/backend/word_cseScript.sml @@ -23,12 +23,29 @@ Mind map / TODO: open preamble wordLangTheory wordsTheory boolTheory mlmapTheory sptreeTheory -val _ = new_theory "word_comSubExpElim"; +val _ = new_theory "word_cse"; Type regsE = ``:num list list`` Type regsM = ``:num num_map`` Type instrsM = ``:(num list,num)map`` +val _ = Datatype `knowledge = <| n:num; + instEq:regsE; + instMap:regsM; + instInstrs:instrsM; + ochMap:regsM; + ochInstrs:instrsM |>`; + +Definition test_def: + test (data:knowledge) = data with <|n := 10|> +End + +Definition test2_def: + test2 (data:knowledge) = data.n +End + +EVAL “test2 (test (<|n:=0;instEq:=[];instMap:=LN;instInstrs:=empty listCmp;ochMap:=LN;ochInstrs:=empty listCmp|>))”; + (* LIST COMPARISON *) Definition listCmp_def: @@ -55,6 +72,15 @@ Proof \\ rw[listCmp_def])) QED +Definition empty_data_def: + empty_data = <| n:=0; + instEq:=[]; + instMap:=LN; + instInstrs:=empty listCmp; + ochMap:=LN; + ochInstrs:=empty listCmp |> +End + (* REGISTERS EQUIVALENCE MEMORY *) Definition listLookup_def: @@ -104,6 +130,7 @@ Definition regsUpdate_def: else [r1;r2]::hd::tl End +(* Theorem regsUpdate_test_merge1: regsUpdate 1 6 [[1;2;3];[4;5;6];[7;8;9]] = [[1;2;3;4;5;6];[7;8;9]] Proof @@ -208,114 +235,133 @@ Proof rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, regsUpdate2_def,regsLookup_def,listLookup_def] QED +*) (* REGISTER TRANSFORMATIONS *) Definition canonicalRegs_def: - canonicalRegs (instMap:regsM) (ochMap:regsM) (r:num) = - case sptree$lookup r instMap of + canonicalRegs (data:knowledge) (r:num) = + case sptree$lookup r data.instMap of | SOME r' => r' - | NONE => case sptree$lookup r ochMap of + | NONE => case sptree$lookup r data.ochMap of | NONE => r | SOME r' => r' End Definition canonicalImmReg_def: - canonicalImmReg instMap ochMap (Reg r) = Reg (canonicalRegs instMap ochMap r) ∧ - canonicalImmReg instMap ochMap (Imm w) = Imm w + canonicalImmReg data (Reg r) = Reg (canonicalRegs data r) ∧ + canonicalImmReg data (Imm w) = Imm w End Definition canonicalMultRegs_def: - canonicalMultRegs instMap ochMap[] = [] ∧ - canonicalMultRegs instMap ochMap (hd::tl) = - (canonicalRegs instMap ochMap hd)::(canonicalMultRegs instMap ochMap tl) + canonicalMultRegs data [] = [] ∧ + canonicalMultRegs data (hd::tl) = + (canonicalRegs data hd)::(canonicalMultRegs data tl) End Definition canonicalMoveRegs_def: - canonicalMoveRegs instEq instMap ochMap [] = (instEq, instMap, ochMap, []) ∧ - canonicalMoveRegs instEq instMap ochMap ((r1,r2)::tl) = - case sptree$lookup r2 ochMap of - | SOME r2' => let ochMap' = sptree$insert r1 r2' ochMap in - let (instEq', instMap', ochMap'', tl') = canonicalMoveRegs instEq instMap ochMap' tl in - (instEq', instMap', ochMap'', (r1,r2')::tl') - | NONE => let r2' = (case sptree$lookup r2 instMap of SOME r => r | NONE => r2) in - let instEq' = regsUpdate r2' r1 instEq in - let instMap' = sptree$insert r1 r2' instMap in - let (instEq'', instMap'', ochMap', tl') = canonicalMoveRegs instEq' instMap' ochMap tl in - (instEq'', instMap'', ochMap', (r1,r2')::tl') + canonicalMoveRegs data [] = (data, []) ∧ + canonicalMoveRegs data ((r1,r2)::tl) = + case sptree$lookup r2 data.ochMap of + | SOME r2' => let ochMap' = sptree$insert r1 r2' data.ochMap in + let (data', tl') = canonicalMoveRegs (data with ochMap:=ochMap') tl in + (data', (r1,r2')::tl') + | NONE => let r2' = (case sptree$lookup r2 data.instMap of SOME r => r | NONE => r2) in + let instEq' = regsUpdate r2' r1 data.instEq in + let instMap' = sptree$insert r1 r2' data.instMap in + let (data', tl') = canonicalMoveRegs (data with <| instEq:=instEq'; instMap:=instMap' |>) tl in + (data', (r1,r2')::tl') +End + +Definition canonicalMoveRegs2_def: + canonicalMoveRegs2 data [] = (data, []) ∧ + canonicalMoveRegs2 data ((r1,r2)::tl) = + if (?r. 2*r = r1 ∨ 2*r = r2) + then let (data', tl') = canonicalMoveRegs2 data tl in + (data', (r1,r2)::tl') + else + case sptree$lookup r2 data.ochMap of + | SOME r2' => let ochMap' = sptree$insert r1 r2' data.ochMap in + let (data', tl') = canonicalMoveRegs2 (data with ochMap:=ochMap') tl in + (data', (r1,r2')::tl') + | NONE => let r2' = (case sptree$lookup r2 data.instMap of SOME r => r | NONE => r2) in + let instEq' = regsUpdate r2' r1 data.instEq in + let instMap' = sptree$insert r1 r2' data.instMap in + let (data', tl') = canonicalMoveRegs2 (data with <| instEq:=instEq'; instMap:=instMap' |>) tl in + (data', (r1,r2')::tl') End Definition canonicalExp_def: - canonicalExp instMap ochMap e = e + canonicalExp data e = e End Definition canonicalMultExp_def: - canonicalMultExp instMap ochMap [] = [] ∧ - canonicalMultExp instMap ochMap (hd::tl) = - (canonicalExp instMap ochMap hd)::(canonicalMultExp instMap ochMap tl) + canonicalMultExp data [] = [] ∧ + canonicalMultExp data (hd::tl) = + (canonicalExp data hd)::(canonicalMultExp data tl) End Definition canonicalExp_def: - canonicalExp instMap ochMap (Const w) = Const w ∧ - canonicalExp instMap ochMap (Var r) = Var (canonicalRegs instMap ochMap r) ∧ - canonicalExp instMap ochMap (Lookup s) = Lookup s ∧ - canonicalExp instMap ochMap (Load e) = Load (canonicalExp instMap ochMap e) ∧ - canonicalExp instMap ochMap (Op op nl) = Op op (canonicalMultExp instMap ochMap nl) ∧ - canonicalExp instMap ochMap (Shift s e n) = Shift s (canonicalExp instMap ochMap e) n + canonicalExp data (Const w) = Const w ∧ + canonicalExp data (Var r) = Var (canonicalRegs data r) ∧ + canonicalExp data (Lookup s) = Lookup s ∧ + canonicalExp data (Load e) = Load (canonicalExp data e) ∧ + canonicalExp data (Op op nl) = Op op (canonicalMultExp data nl) ∧ + canonicalExp data (Shift s e n) = Shift s (canonicalExp data e) n End Definition canonicalArith_def: - canonicalArith instMap ochMap (Binop op r1 r2 r3) = - Binop op r1 (canonicalRegs instMap ochMap r2) (canonicalImmReg instMap ochMap r3) ∧ - canonicalArith instMap ochMap (Shift s r1 r2 n) = - Shift s (canonicalRegs instMap ochMap r1) (canonicalRegs instMap ochMap r2) n ∧ - canonicalArith instMap ochMap (Div r1 r2 r3) = - Div r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) ∧ - canonicalArith instMap ochMap (LongMul r1 r2 r3 r4) = - LongMul r1 r2 (canonicalRegs instMap ochMap r3) (canonicalRegs instMap ochMap r4) ∧ - canonicalArith instMap ochMap (LongDiv r1 r2 r3 r4 r5) = - LongDiv r1 r2 (canonicalRegs instMap ochMap r3) (canonicalRegs instMap ochMap r4) (canonicalRegs instMap ochMap r5) ∧ - canonicalArith instMap ochMap (AddCarry r1 r2 r3 r4) = - AddCarry r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) r4 ∧ - canonicalArith instMap ochMap (AddOverflow r1 r2 r3 r4) = - AddOverflow r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) r4 ∧ - canonicalArith instMap ochMap (SubOverflow r1 r2 r3 r4) = - SubOverflow r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) r4 + canonicalArith data (Binop op r1 r2 r3) = + Binop op r1 (canonicalRegs data r2) (canonicalImmReg data r3) ∧ + canonicalArith data (Shift s r1 r2 n) = + Shift s (canonicalRegs data r1) (canonicalRegs data r2) n ∧ + canonicalArith data (Div r1 r2 r3) = + Div r1 (canonicalRegs data r2) (canonicalRegs data r3) ∧ + canonicalArith data (LongMul r1 r2 r3 r4) = + LongMul r1 r2 (canonicalRegs data r3) (canonicalRegs data r4) ∧ + canonicalArith data (LongDiv r1 r2 r3 r4 r5) = + LongDiv r1 r2 (canonicalRegs data r3) (canonicalRegs data r4) (canonicalRegs data r5) ∧ + canonicalArith data (AddCarry r1 r2 r3 r4) = + AddCarry r1 (canonicalRegs data r2) (canonicalRegs data r3) r4 ∧ + canonicalArith data (AddOverflow r1 r2 r3 r4) = + AddOverflow r1 (canonicalRegs data r2) (canonicalRegs data r3) r4 ∧ + canonicalArith data (SubOverflow r1 r2 r3 r4) = + SubOverflow r1 (canonicalRegs data r2) (canonicalRegs data r3) r4 End Definition canonicalFp_def: - canonicalFp instMap ochMap (FPLess r1 r2 r3) = - FPLess r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) ∧ - canonicalFp instMap ochMap (FPLessEqual r1 r2 r3) = - FPLessEqual r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) ∧ - canonicalFp instMap ochMap (FPEqual r1 r2 r3) = - FPEqual r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) ∧ - canonicalFp instMap ochMap (FPAbs r1 r2) = - FPAbs r1 (canonicalRegs instMap ochMap r2) ∧ - canonicalFp instMap ochMap (FPNeg r1 r2) = - FPNeg r1 (canonicalRegs instMap ochMap r2) ∧ - canonicalFp instMap ochMap (FPSqrt r1 r2) = - FPSqrt r1 (canonicalRegs instMap ochMap r2) ∧ - canonicalFp instMap ochMap (FPAdd r1 r2 r3) = - FPAdd r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) ∧ - canonicalFp instMap ochMap (FPSub r1 r2 r3) = - FPSub r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) ∧ - canonicalFp instMap ochMap (FPMul r1 r2 r3) = - FPMul r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) ∧ - canonicalFp instMap ochMap (FPDiv r1 r2 r3) = - FPDiv r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) ∧ - canonicalFp instMap ochMap (FPFma r1 r2 r3) = - FPFma r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) ∧ - canonicalFp instMap ochMap (FPMov r1 r2) = - FPMov r1 (canonicalRegs instMap ochMap r2) ∧ - canonicalFp instMap ochMap (FPMovToReg r1 r2 r3) = - FPMovToReg r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) ∧ - canonicalFp instMap ochMap (FPMovFromReg r1 r2 r3) = - FPMovFromReg r1 (canonicalRegs instMap ochMap r2) (canonicalRegs instMap ochMap r3) ∧ - canonicalFp instMap ochMap (FPToInt r1 r2) = - FPToInt r1 (canonicalRegs instMap ochMap r2) ∧ - canonicalFp instMap ochMap (FPFromInt r1 r2) = - FPFromInt r1 (canonicalRegs instMap ochMap r2) + canonicalFp data (FPLess r1 r2 r3) = + FPLess r1 (canonicalRegs data r2) (canonicalRegs data r3) ∧ + canonicalFp data (FPLessEqual r1 r2 r3) = + FPLessEqual r1 (canonicalRegs data r2) (canonicalRegs data r3) ∧ + canonicalFp data (FPEqual r1 r2 r3) = + FPEqual r1 (canonicalRegs data r2) (canonicalRegs data r3) ∧ + canonicalFp data (FPAbs r1 r2) = + FPAbs r1 (canonicalRegs data r2) ∧ + canonicalFp data (FPNeg r1 r2) = + FPNeg r1 (canonicalRegs data r2) ∧ + canonicalFp data (FPSqrt r1 r2) = + FPSqrt r1 (canonicalRegs data r2) ∧ + canonicalFp data (FPAdd r1 r2 r3) = + FPAdd r1 (canonicalRegs data r2) (canonicalRegs data r3) ∧ + canonicalFp data (FPSub r1 r2 r3) = + FPSub r1 (canonicalRegs data r2) (canonicalRegs data r3) ∧ + canonicalFp data (FPMul r1 r2 r3) = + FPMul r1 (canonicalRegs data r2) (canonicalRegs data r3) ∧ + canonicalFp data (FPDiv r1 r2 r3) = + FPDiv r1 (canonicalRegs data r2) (canonicalRegs data r3) ∧ + canonicalFp data (FPFma r1 r2 r3) = + FPFma r1 (canonicalRegs data r2) (canonicalRegs data r3) ∧ + canonicalFp data (FPMov r1 r2) = + FPMov r1 (canonicalRegs data r2) ∧ + canonicalFp data (FPMovToReg r1 r2 r3) = + FPMovToReg r1 (canonicalRegs data r2) (canonicalRegs data r3) ∧ + canonicalFp data (FPMovFromReg r1 r2 r3) = + FPMovFromReg r1 (canonicalRegs data r2) (canonicalRegs data r3) ∧ + canonicalFp data (FPToInt r1 r2) = + FPToInt r1 (canonicalRegs data r2) ∧ + canonicalFp data (FPFromInt r1 r2) = + FPFromInt r1 (canonicalRegs data r2) End (* SEEN INSTRUCTIONS MEMORY *) @@ -595,29 +641,32 @@ Definition firstRegOfFp_def: firstRegOfFp (FPFromInt r _) = r End -Definition comSubExpElimInst_def: - (comSubExpElimInst (n:num) (instEq:regsE) (instMap:regsM) (instInstrs:instrsM) (ochMap:regsM) Skip = (n, instEq, instMap, instInstrs, Inst Skip)) ∧ - (comSubExpElimInst n instEq instMap instInstrs ochMap (Const r w) = +Definition word_cseInst_def: + (word_cseInst (data:knowledge) Skip = (data, Inst Skip)) ∧ + (word_cseInst data (Const r w) = let i = instToNumList (Const r w) in - case mlmap$lookup instInstrs i of - | SOME r' => (n+1, regsUpdate r' r instEq, insert r r' instMap, instInstrs, Move 0 [(r,r')]) - | NONE => (n, instEq, instMap, insert instInstrs i r, Inst (Const r w))) ∧ - (comSubExpElimInst n instEq instMap instInstrs ochMap (Arith a) = - let a' = canonicalArith instMap ochMap a in + case mlmap$lookup data.instInstrs i of + | SOME r' => (data with <| n:=data.n+1; instEq:=regsUpdate r' r data.instEq; instMap:=insert r r' data.instMap |>, Move 0 [(r,r')]) + | NONE => (data with instInstrs:=insert data.instInstrs i r, Inst (Const r w))) ∧ + (word_cseInst data (Arith a) = + let a' = canonicalArith data a in let r = firstRegOfArith a' in let i = instToNumList (Arith a') in - case mlmap$lookup instInstrs i of - | SOME r' => (n+1, regsUpdate r' r instEq, insert r r' instMap, instInstrs, Move 0 [(r,r')]) - | NONE => (n, instEq, instMap, insert instInstrs i r, Inst (Arith a'))) ∧ - (comSubExpElimInst n instEq instMap instInstrs ochMap (Mem op r (Addr r' w)) = - (n, instEq, instMap, instInstrs, Inst (Mem op (canonicalRegs instMap ochMap r) (Addr (canonicalRegs instMap ochMap r') w)))) ∧ - (comSubExpElimInst n instEq instMap instInstrs ochMap ((FP f):'a inst) = + case mlmap$lookup data.instInstrs i of + | SOME r' => (data with <| n:=data.n+1; instEq:=regsUpdate r' r data.instEq; instMap:=insert r r' data.instMap |>, Move 0 [(r,r')]) + | NONE => (data with instInstrs:=insert data.instInstrs i r, Inst (Arith a'))) ∧ + (word_cseInst data (Mem op r (Addr r' w)) = + (data, Inst (Mem op (canonicalRegs data r) (Addr (canonicalRegs data r') w)))) ∧ + (word_cseInst data ((FP f):'a inst) = + (data, Inst (FP f))) + (* Not relevant: issue with fp regs having same id as regs, possible confusion let f' = canonicalFp instMap ochMap f in let r = firstRegOfFp f' in let i = instToNumList ((FP f'):'a inst) in case mlmap$lookup instInstrs i of | SOME r' => (n+1, regsUpdate r' r instEq, insert r r' instMap, instInstrs, Move 0 [(r,r')]) | NONE => (n, instEq, instMap, insert instInstrs i r, Inst (FP f'))) + *) End (* @@ -640,73 +689,64 @@ Signification of the terms: b -> binop s -> string *) -Definition comSubExpElim_def: - (comSubExpElim (n:num) (instEq:regsE) (instMap:regsM) (instInstrs:instrsM) (ochMap:regsM) (ochInstrs:instrsM) (Skip) = - (n, instEq, instMap, instInstrs, ochMap, ochInstrs, Skip)) ∧ - (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Move r rs) = - let (instEq', instMap', ochMap', rs') = canonicalMoveRegs instEq instMap ochMap rs in - (n, instEq', instMap', instInstrs, ochMap', ochInstrs, Move r rs')) ∧ - (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Inst i) = - let (n', instEq', instMap', instInstrs', p) = comSubExpElimInst n instEq instMap instInstrs ochMap i in - (n', instEq', instMap', instInstrs', ochMap, ochInstrs, p)) ∧ - (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Assign r e) = - let e' = canonicalExp instMap ochMap e in - (n, instEq, instMap, instInstrs, ochMap, ochInstrs, Assign r e')) ∧ - (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Get r x) = - (n, instEq, instMap, instInstrs, ochMap, ochInstrs, Get r x)) ∧ - (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Set x e) = - let e' = canonicalExp instMap ochMap e in - (n, instEq, instMap, instInstrs, LN, empty listCmp, Set x e')) ∧ - (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Store e r) = - let r' = canonicalRegs instMap ochMap r in - (n, instEq, instMap, instInstrs, ochMap, ochInstrs, Store e r')) ∧ - (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (MustTerminate p) = - let (n', instEq', instMap', instInstrs', ochMap', ochInstrs', p') = comSubExpElim n instEq instMap instInstrs ochMap ochInstrs p in - (n', instEq', instMap', instInstrs', ochMap', ochInstrs', MustTerminate p')) ∧ - (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Call ret dest args handler) = - (n, [], LN, empty listCmp, LN, empty listCmp, Call ret dest args handler)) ∧ - (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Seq p1 p2) = - let (n1, regsEq1, regsMap1, instrs1, ochMap1, ochInstrs1, p1') = comSubExpElim n instEq instMap instInstrs ochMap ochInstrs p1 in - let (n2, regsEq2, regsMap2, instrs2, ochMap2, ochInstrs2, p2') = comSubExpElim n1 regsEq1 regsMap1 instrs1 ochMap1 ochInstrs1 p2 in - (n2, regsEq2, regsMap2, instrs2, ochMap2, ochInstrs2, Seq p1' p2')) ∧ - (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (If c r1 r2 p1 p2) = - let r1' = canonicalRegs instMap ochMap r1 in - let r2' = canonicalImmReg instMap ochMap r2 in - let (n1, instEq1, instMap1, instInstrs1, ochMap1, ochInstrs1, p1') = comSubExpElim n instEq instMap instInstrs ochMap ochInstrs p1 in - let (n2, instEq2, instMap2, instInstrs2, ochMap2, ochInstrs2, p2') = comSubExpElim n1 instEq instMap instInstrs ochMap ochInstrs p2 in - (n2, [], LN, empty listCmp, LN, empty listCmp, If c r1' r2' p1' p2')) ∧ +Definition word_cse_def: + (word_cse (data:knowledge) (Skip) = + (data, Skip)) ∧ + (word_cse data (Move r rs) = + let (data', rs') = canonicalMoveRegs data rs in + (data, Move r rs')) ∧ + (word_cse data (Inst i) = + let (data', p) = word_cseInst data i in + (data, p)) ∧ + (word_cse data (Assign r e) = + (data, Assign r e)) ∧ + (word_cse data (Get r x) = + (data, Get r x)) ∧ + (word_cse data (Set x e) = + let e' = canonicalExp data e in + (data with <|ochMap:=LN; ochInstrs:=empty listCmp|>, Set x e')) ∧ + (word_cse data (Store e r) = + (data, Store e r)) ∧ + (word_cse data (MustTerminate p) = + let (data', p') = word_cse data p in + (data', MustTerminate p')) ∧ + (word_cse data (Call ret dest args handler) = + (empty_data with n:=data.n, Call ret dest args handler)) ∧ + (word_cse data (Seq p1 p2) = + let (data1, p1') = word_cse data p1 in + let (data2, p2') = word_cse data1 p2 in + (data2, Seq p1' p2')) ∧ + (word_cse data (If c r1 r2 p1 p2) = + let r1' = canonicalRegs data r1 in + let r2' = canonicalImmReg data r2 in + let (data1, p1') = word_cse data p1 in + let (data2, p2') = word_cse (data with n:=data1.n) p2 in + (empty_data with n:=data2.n, If c r1' r2' p1' p2')) ∧ (* We don't know what happen in the IF. Intersection would be the best. *) - (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Alloc r m) = - (n, instEq, instMap, instInstrs, LN, empty listCmp, Alloc r m)) ∧ - (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Raise r) = - let r' = canonicalRegs instMap ochMap r in - (n, instEq, instMap, instInstrs, ochMap, ochInstrs, Raise r')) ∧ - (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Return r1 r2) = - let r1' = canonicalRegs instMap ochMap r1 in - let r2' = canonicalRegs instMap ochMap r2 in - (n, instEq, instMap, instInstrs, ochMap, ochInstrs, Return r1' r2')) ∧ - (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Tick) = - (n, instEq, instMap, instInstrs, ochMap, ochInstrs, Tick)) ∧ - (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs ((OpCurrHeap b r1 r2):'a prog) = - let r2' = canonicalRegs instMap ochMap r2 in + (word_cse data (Alloc r m) = + (data with <| ochMap:=LN; ochInstrs:=empty listCmp |>, Alloc r m)) ∧ + (word_cse data (Raise r) = + (data, Raise r)) ∧ + (word_cse data (Return r1 r2) = + (data, Return r1 r2)) ∧ + (word_cse data (Tick) = + (data, Tick)) ∧ + (word_cse data ((OpCurrHeap b r1 r2):'a prog) = + let r2' = canonicalRegs data r2 in let pL = progToNumList ((OpCurrHeap b r1 r2'):'a prog) in - case lookup ochInstrs pL of - | NONE => (n, instEq, instMap, instInstrs, ochMap, insert ochInstrs pL r1, OpCurrHeap b r1 r2') - | SOME r1' => (n+1, instEq, instMap, instInstrs, insert r1 r1' ochMap, ochInstrs, Move 0 [(r1, r1')])) ∧ - (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (LocValue r1 l) = - (n, instEq, instMap, instInstrs, ochMap, ochInstrs, LocValue r1 l)) ∧ - (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (Install p l dp dl m) = - (n, instEq, instMap, instInstrs, ochMap, ochInstrs, Install p l dp dl m)) ∧ - (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (CodeBufferWrite r1 r2) = - (n, instEq, instMap, instInstrs, ochMap, ochInstrs, CodeBufferWrite r1 r2)) ∧ - (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (DataBufferWrite r1 r2) = - (n, instEq, instMap, instInstrs, ochMap, ochInstrs, DataBufferWrite r1 r2)) ∧ - (comSubExpElim n instEq instMap instInstrs ochMap ochInstrs (FFI s p1 l1 p2 l2 m) = - (n, instEq, instMap, instInstrs, ochMap, ochInstrs, FFI s p1 l1 p2 l2 m)) -End - -Definition word_cse_def: - word_cse p = let (_,_,_,_,_,_,p') = comSubExpElim 0 [] LN (empty listCmp) LN (empty listCmp) p in p' + case lookup data.ochInstrs pL of + | NONE => (data with ochInstrs:=(insert data.ochInstrs pL r1), OpCurrHeap b r1 r2') + | SOME r1' => (data with <| n:=data.n+1; ochMap:=(insert r1 r1' data.ochMap) |>, Move 0 [(r1, r1')])) ∧ + (word_cse data (LocValue r1 l) = + (data, LocValue r1 l)) ∧ + (word_cse data (Install p l dp dl m) = + (data, Install p l dp dl m)) ∧ + (word_cse data (CodeBufferWrite r1 r2) = + (data, CodeBufferWrite r1 r2)) ∧ + (word_cse data (DataBufferWrite r1 r2) = + (data, DataBufferWrite r1 r2)) ∧ + (word_cse data (FFI s p1 l1 p2 l2 m) = + (data, FFI s p1 l1 p2 l2 m)) End (* diff --git a/examples/compilation/to_word/to_wordCompileScript.sml b/examples/compilation/to_word/to_wordCompileScript.sml index a1d7d14df4..191f2bd468 100644 --- a/examples/compilation/to_word/to_wordCompileScript.sml +++ b/examples/compilation/to_word/to_wordCompileScript.sml @@ -1,7 +1,7 @@ (* Compiles a program to wordLang *) -open preamble compilationLib basis word_comSubExpElimTheory +open preamble compilationLib basis word_cseTheory val _ = new_theory "to_wordCompile" val _ = (max_print_depth := 500); @@ -73,10 +73,6 @@ Theorem foldr_example_ssa = val tm = foldr_example_ssa |> concl |> rand -Definition test_def: - test p = word_cse p -End - Definition progCmp_def: progCmp p1 p2 = if p1=p2 @@ -87,48 +83,4 @@ Definition progCmp_def: | (_,_) => [(p1,p2)] End -(* -Definition prog1_def: - prog1 = - Move 1 [(37,0); (41,2); (45,4); (49,6)] ▸ - If Equal 41 (Imm 2w) - (Inst (Const 53 18w) ▸ Move 0 [(2,45)] ▸ Return 37 2 ▸ - Move 1 [(181,37); (177,49)] ▸ Inst (Const 185 0w) ▸ - Inst (Const 189 0w) ▸ Inst (Const 193 0w) ▸ Move 1 [(197,53)] ▸ - Inst (Const 201 0w) ▸ Move 1 [(205,41)] ▸ Move 1 [(209,45)] ▸ - Inst (Const 213 0w) ▸ Inst (Const 217 0w)) - (Inst (Const 57 2w) ▸ Move 0 [(61,41)] ▸ - Inst (Arith (Shift Lsr 65 61 9)) ▸ OpCurrHeap Add 69 65 ▸ - Inst (Mem Load 73 (Addr 69 8w)) ▸ Move 0 [(77,41)] ▸ - Inst (Arith (Shift Lsr 81 77 9)) ▸ OpCurrHeap Add 85 81 ▸ - Inst (Mem Load 89 (Addr 85 16w)) ▸ - Move 1 [(95,37); (99,49); (103,73)] ▸ - Move 0 [(2,89); (4,45); (6,49)] ▸ - Call - (SOME - (2,insert 95 () (insert 99 () (insert 103 () LN)), - Move 1 [(109,95); (113,99); (117,103)] ▸ Move 0 [(121,2)], - 249,2)) (SOME 249) [2; 4; 6] NONE ▸ Move 0 [(125,113)] ▸ - Inst (Arith (Shift Lsr 129 125 9)) ▸ OpCurrHeap Add 133 129 ▸ - Inst (Mem Load 137 (Addr 133 16w)) ▸ - If Equal 137 (Imm 4w) - (Inst (Const 141 18w) ▸ Move 0 [(145,113)] ▸ - Inst (Arith (Shift Lsr 149 145 9)) ▸ OpCurrHeap Add 153 149 ▸ - Inst (Mem Load 157 (Addr 153 8w)) ▸ - Move 0 [(0,109); (2,121); (4,117); (6,113); (8,157)] ▸ - Call NONE NONE [0; 2; 4; 6; 8] NONE ▸ - Move 1 [(169,153); (165,141)] ▸ Move 1 [(173,157)]) - (Inst (Const 161 2w) ▸ - Move 0 [(0,109); (2,121); (4,117); (6,113)] ▸ - Call NONE (SOME 69) [0; 2; 4; 6] NONE ▸ - Move 1 [(169,133); (165,161)] ▸ Inst (Const 173 0w)) ▸ - Move 1 [(181,109); (177,113)] ▸ Move 1 [(185,137)] ▸ - Move 1 [(189,117)] ▸ Move 1 [(193,121)] ▸ Inst (Const 197 0w) ▸ - Move 1 [(201,173)] ▸ Inst (Const 205 0w) ▸ Inst (Const 209 0w) ▸ - Move 1 [(213,165)] ▸ Move 1 [(217,169)]) -End - - -EVAL “progCmp ^tm (test ^tm)” -*) -val _ = export_theory (); +val _ = export_theory (); \ No newline at end of file diff --git a/examples/compilation/to_word/word_cse_testScript.sml b/examples/compilation/to_word/word_cse_testScript.sml index d32b1437da..33027b3e0a 100644 --- a/examples/compilation/to_word/word_cse_testScript.sml +++ b/examples/compilation/to_word/word_cse_testScript.sml @@ -2,17 +2,23 @@ Testing of the word common sub-expression elimination. *) -open preamble to_wordCompileTheory word_comSubExpElimTheory word_allocTheory; +open preamble to_wordCompileTheory word_cseTheory word_allocTheory; val _ = new_theory "word_cse_test"; val tm = foldr_example_ssa |> concl |> dest_eq |> snd -val tm' = “let p = word_cse ^tm in +Definition word_cse_compact_def: + word_cse_compact p = + let (_,_,_,_,_,_,p') = word_cse 0 [] LN (empty listCmp) LN (empty listCmp) p in + p' +End + +val tm' = “let p = word_cse_compact ^tm in remove_dead p LN” val res = EVAL tm'; -val res2 = EVAL “word_cse ^tm”; +val res2 = EVAL “word_cse_compact ^tm”; val _ = export_theory(); From 34645ddd6ba0ad43704f86831304a863345afccc Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Tue, 14 Jun 2022 11:25:57 +0200 Subject: [PATCH 10/36] first easy proofs of word_cseProof --- .../backend/proofs/word_cseProofScript.sml | 41 ++++++++++++------- 1 file changed, 27 insertions(+), 14 deletions(-) diff --git a/compiler/backend/proofs/word_cseProofScript.sml b/compiler/backend/proofs/word_cseProofScript.sml index 2d3fecdfa7..6d5e047da2 100644 --- a/compiler/backend/proofs/word_cseProofScript.sml +++ b/compiler/backend/proofs/word_cseProofScript.sml @@ -2,11 +2,11 @@ Correctness proof for word_cse *) open preamble alistTheory; -open wordLangTheory wordSemTheory wordPropsTheory word_simpTheory word_comSubExpElimTheory; +open wordLangTheory wordSemTheory wordPropsTheory word_simpTheory word_cseTheory; val _ = new_theory "word_cseProof"; -val _ = set_grammar_ancestry ["wordLang", "wordSem", "wordProps", "word_comSubExpElim"]; +val _ = set_grammar_ancestry ["wordLang", "wordSem", "wordProps", "word_cse"]; (* setting up the goal *) @@ -15,7 +15,7 @@ val goal = “ ∀res s' n instEq instMap instInstrs ochMap ochInstrs n' instEq' instMap' instInstrs' ochMap' ochInstrs'. evaluate (p, s) = (res, s') ∧ flat_exp_conventions p ∧ - comSubExpElim n instEq instMap instInstrs ochMap ochInstrs p = + word_cse n instEq instMap instInstrs ochMap ochInstrs p = (n', instEq', instMap', instInstrs', ochMap', ochInstrs', p') ⇒ evaluate (p', s) = (res, s')” @@ -34,19 +34,23 @@ end Theorem comp_Skip_correct: ^(get_goal "Skip") Proof - cheat + rpt strip_tac \\ + fs[word_cse_def] QED Theorem comp_Alloc_correct: ^(get_goal "Alloc") Proof - cheat + rpt strip_tac \\ + fs[word_cse_def] QED Theorem comp_Move_correct: ^(get_goal "Move") Proof cheat + rpt strip_tac + rw[word_cse_def] QED Theorem comp_Inst_correct: @@ -64,13 +68,15 @@ QED Theorem comp_Get_correct: ^(get_goal "Get") Proof - cheat + rpt strip_tac \\ + fs[word_cse_def] QED Theorem comp_Set_correct: ^(get_goal "wordLang$Set") Proof - cheat + rpt strip_tac \\ + fs[word_cse_def] QED Theorem comp_OpCurrHeap_correct: @@ -88,7 +94,8 @@ QED Theorem comp_Tick_correct: ^(get_goal "Tick") Proof - cheat + rpt strip_tac \\ + fs[word_cse_def] QED Theorem comp_MustTerminate_correct: @@ -112,7 +119,8 @@ QED Theorem comp_Raise_correct: ^(get_goal "wordLang$Raise") Proof - cheat + rpt strip_tac \\ + fs[word_cse_def] QED Theorem comp_If_correct: @@ -124,31 +132,36 @@ QED Theorem comp_LocValue_correct: ^(get_goal "wordLang$LocValue") Proof - cheat + rpt strip_tac \\ + fs[word_cse_def] QED Theorem comp_Install_correct: ^(get_goal "wordLang$Install") Proof - cheat + rpt strip_tac \\ + fs[word_cse_def] QED Theorem comp_CodeBufferWrite_correct: ^(get_goal "wordLang$CodeBufferWrite") Proof - cheat + rpt strip_tac \\ + fs[word_cse_def] QED Theorem comp_DataBufferWrite_correct: ^(get_goal "wordLang$DataBufferWrite") Proof - cheat + rpt strip_tac \\ + fs[word_cse_def] QED Theorem comp_FFI_correct: ^(get_goal "wordLang$FFI") Proof - cheat + rpt strip_tac \\ + fs[word_cse_def] QED Theorem comp_Call_correct: From f821fa66eb34cd0526e3e07c66d7fafd669c6495 Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Fri, 17 Jun 2022 14:33:31 +0200 Subject: [PATCH 11/36] Start of proofs, patches on word_cse --- .../backend/proofs/word_cseProofScript.sml | 22 ++++++---- compiler/backend/word_cseScript.sml | 42 ++++++++++++------- .../to_word/word_cse_testScript.sml | 11 ++++- 3 files changed, 51 insertions(+), 24 deletions(-) diff --git a/compiler/backend/proofs/word_cseProofScript.sml b/compiler/backend/proofs/word_cseProofScript.sml index 6d5e047da2..9f31298879 100644 --- a/compiler/backend/proofs/word_cseProofScript.sml +++ b/compiler/backend/proofs/word_cseProofScript.sml @@ -12,11 +12,11 @@ val _ = set_grammar_ancestry ["wordLang", "wordSem", "wordProps", "word_cse"]; val goal = “ λ(p:'a wordLang$prog,s:('a,'c,'ffi) wordSem$state). - ∀res s' n instEq instMap instInstrs ochMap ochInstrs - n' instEq' instMap' instInstrs' ochMap' ochInstrs'. + ∀res s' data p' + data'. evaluate (p, s) = (res, s') ∧ flat_exp_conventions p ∧ - word_cse n instEq instMap instInstrs ochMap ochInstrs p = - (n', instEq', instMap', instInstrs', ochMap', ochInstrs', p') ⇒ + word_cse data p = + (data', p') ⇒ evaluate (p', s) = (res, s')” local @@ -49,8 +49,10 @@ Theorem comp_Move_correct: ^(get_goal "Move") Proof cheat +(* rpt strip_tac rw[word_cse_def] +*) QED Theorem comp_Inst_correct: @@ -101,7 +103,14 @@ QED Theorem comp_MustTerminate_correct: ^(get_goal "MustTerminate") Proof - cheat + rpt strip_tac \\ + gs[word_cse_def] \\ + pairarg_tac \\ gvs [evaluate_def,flat_exp_conventions_def] \\ + gvs [AllCaseEqs()] \\ + pairarg_tac \\ gvs [] \\ + pairarg_tac \\ gvs [] \\ + first_x_assum drule \\ + gvs [] QED Theorem comp_Seq_correct: @@ -113,13 +122,12 @@ QED Theorem comp_Return_correct: ^(get_goal "Return") Proof - cheat + fs[word_cse_def] QED Theorem comp_Raise_correct: ^(get_goal "wordLang$Raise") Proof - rpt strip_tac \\ fs[word_cse_def] QED diff --git a/compiler/backend/word_cseScript.sml b/compiler/backend/word_cseScript.sml index 267c7681b5..20a080d21e 100644 --- a/compiler/backend/word_cseScript.sml +++ b/compiler/backend/word_cseScript.sml @@ -36,15 +36,11 @@ val _ = Datatype `knowledge = <| n:num; ochMap:regsM; ochInstrs:instrsM |>`; -Definition test_def: - test (data:knowledge) = data with <|n := 10|> -End - -Definition test2_def: - test2 (data:knowledge) = data.n -End +(* add a (all_names:num_set) ⇒ when seeing a new register, add it in all_names +if a register is affected and is in all_names, throw everything -EVAL “test2 (test (<|n:=0;instEq:=[];instMap:=LN;instInstrs:=empty listCmp;ochMap:=LN;ochInstrs:=empty listCmp|>))”; +!!! even registers !!! +*) (* LIST COMPARISON *) @@ -256,7 +252,8 @@ End Definition canonicalMultRegs_def: canonicalMultRegs data [] = [] ∧ canonicalMultRegs data (hd::tl) = - (canonicalRegs data hd)::(canonicalMultRegs data tl) + (canonicalRegs data hd)::(canonicalMultRegs data tl) +(* rewrite with a map *) End Definition canonicalMoveRegs_def: @@ -273,10 +270,13 @@ Definition canonicalMoveRegs_def: (data', (r1,r2')::tl') End +(* make a lookup_data to wrap case matching +lookup_any x sp d = lookup x sp otherwise return d*) + Definition canonicalMoveRegs2_def: canonicalMoveRegs2 data [] = (data, []) ∧ canonicalMoveRegs2 data ((r1,r2)::tl) = - if (?r. 2*r = r1 ∨ 2*r = r2) + if (EVEN r1 ∨ EVEN r2) then let (data', tl') = canonicalMoveRegs2 data tl in (data', (r1,r2)::tl') else @@ -291,6 +291,12 @@ Definition canonicalMoveRegs2_def: (data', (r1,r2')::tl') End +(* +Move [(1,2);(2,3);(3,1)] +Move [(1,can 2);(2,can 3);(3,can 1)] +Knowledge : 1 ⇔ can 2 / 2 ⇔ can 3 / 3 ⇔ can 1 +*) + Definition canonicalExp_def: canonicalExp data e = e End @@ -581,7 +587,7 @@ Definition instToNumList_def: End (* Theorem instToNumList_unique: - ∀i1 i2. i1 = i2 ⇔ instToNumList i1 = instToNumList i2 + ∀i1 i2. instToNumList i1 = instToNumList i2 ⇒ ∀n. setDest i1 n = setDest i2 n Proof rpt strip_tac >> Cases_on ‘i1’ \\ @@ -610,6 +616,10 @@ Proof rw[progToNumList_def, instToNumList_unique] QED *) +(* +Theorem progToNumList_: + ∀p1 p2. ( +*) Definition firstRegOfArith_def: firstRegOfArith (Binop _ r _ _) = r ∧ @@ -693,11 +703,11 @@ Definition word_cse_def: (word_cse (data:knowledge) (Skip) = (data, Skip)) ∧ (word_cse data (Move r rs) = - let (data', rs') = canonicalMoveRegs data rs in - (data, Move r rs')) ∧ + let (data', rs') = canonicalMoveRegs2 data rs in + (data', Move r rs')) ∧ (word_cse data (Inst i) = let (data', p) = word_cseInst data i in - (data, p)) ∧ + (data', p)) ∧ (word_cse data (Assign r e) = (data, Assign r e)) ∧ (word_cse data (Get r x) = @@ -750,9 +760,9 @@ Definition word_cse_def: End (* -EVAL “word_cse (Seq (Inst (Arith (Binop Add 3 1 (Reg 2)))) (Inst (Arith (Binop Add 4 1 (Reg 2)))))” +EVAL “word_cse empty_data (Seq (Inst (Arith (Binop Add 3 1 (Reg 2)))) (Inst (Arith (Binop Add 4 1 (Reg 2)))))” -EVAL “word_cse +EVAL “word_cse empty_data (Seq (Inst (Arith (Binop Add 3 1 (Reg 2)))) (Seq diff --git a/examples/compilation/to_word/word_cse_testScript.sml b/examples/compilation/to_word/word_cse_testScript.sml index 33027b3e0a..a050c1d9b2 100644 --- a/examples/compilation/to_word/word_cse_testScript.sml +++ b/examples/compilation/to_word/word_cse_testScript.sml @@ -10,13 +10,22 @@ val tm = foldr_example_ssa |> concl |> dest_eq |> snd Definition word_cse_compact_def: word_cse_compact p = - let (_,_,_,_,_,_,p') = word_cse 0 [] LN (empty listCmp) LN (empty listCmp) p in + let (_,p') = word_cse empty_data p in p' End val tm' = “let p = word_cse_compact ^tm in remove_dead p LN” +val prog = “(Seq (Inst (Arith (Binop Add 3 1 (Reg 2)))) (Inst (Arith (Binop Add 4 1 (Reg 2)))))” + +val prog2 = “Seq (Move 0 [(37,2);(39,4)]) (If Equal 41 (Imm 2w) (Return 37 2) (Return 37 2))”; + + +EVAL “^tm”; + +EVAL “word_cse_compact ^prog2”; + val res = EVAL tm'; val res2 = EVAL “word_cse_compact ^tm”; From d94a23925f8d5a2c2403f2a4a54992fe2e268cb1 Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Fri, 17 Jun 2022 14:37:51 +0200 Subject: [PATCH 12/36] More proofs --- .../backend/proofs/word_cseProofScript.sml | 37 ++++++++++++++----- 1 file changed, 27 insertions(+), 10 deletions(-) diff --git a/compiler/backend/proofs/word_cseProofScript.sml b/compiler/backend/proofs/word_cseProofScript.sml index 9f31298879..fc25fca6a1 100644 --- a/compiler/backend/proofs/word_cseProofScript.sml +++ b/compiler/backend/proofs/word_cseProofScript.sml @@ -8,16 +8,20 @@ val _ = new_theory "word_cseProof"; val _ = set_grammar_ancestry ["wordLang", "wordSem", "wordProps", "word_cse"]; +Definition data_inv_def: + data_inv (data:knowledge) (s:('a,'c,'ffi) wordSem$state) = T +End + (* setting up the goal *) val goal = “ λ(p:'a wordLang$prog,s:('a,'c,'ffi) wordSem$state). - ∀res s' data p' - data'. - evaluate (p, s) = (res, s') ∧ flat_exp_conventions p ∧ - word_cse data p = - (data', p') ⇒ - evaluate (p', s) = (res, s')” + ∀res s' data p' data'. + evaluate (p, s) = (res, s') ∧ flat_exp_conventions p ∧ + data_inv data s ∧ + word_cse data p = (data', p') ⇒ + evaluate (p', s) = (res, s') ∧ + (res = NONE ⇒ data_inv data' s')” local val gst = goal |> Ho_Rewrite.PURE_ONCE_REWRITE_CONV [Once PFORALL_THM] |> concl |> rhs @@ -50,8 +54,8 @@ Theorem comp_Move_correct: Proof cheat (* - rpt strip_tac - rw[word_cse_def] + rpt strip_tac \\ + rw[word_cse_def] *) QED @@ -116,7 +120,20 @@ QED Theorem comp_Seq_correct: ^(get_goal "wordLang$Seq") Proof - cheat + rpt gen_tac \\ + strip_tac \\ + rpt gen_tac \\ + strip_tac \\ + gvs[word_cse_def, evaluate_def, flat_exp_conventions_def] \\ + rpt (pairarg_tac \\ gvs []) \\ + reverse(gvs [AllCaseEqs(),evaluate_def]) + >- (pairarg_tac \\ gvs [] \\ + first_x_assum drule_all \\ gs []) \\ + pairarg_tac \\ gvs [] \\ + first_x_assum drule_all \\ gs [] \\ + strip_tac \\ gvs [] \\ + first_x_assum drule_all \\ + fs [] QED Theorem comp_Return_correct: @@ -175,7 +192,7 @@ QED Theorem comp_Call_correct: ^(get_goal "wordLang$Call") Proof - cheat + fs[word_cse_def] QED Theorem comp_correct: From 22ec0c4ec1b03ae262ebefb1942b3a04d319f039 Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Tue, 21 Jun 2022 16:25:32 +0200 Subject: [PATCH 13/36] Next proofs --- .../backend/proofs/word_cseProofScript.sml | 111 ++++++++++++------ compiler/backend/word_cseScript.sml | 106 +++++++++-------- 2 files changed, 133 insertions(+), 84 deletions(-) diff --git a/compiler/backend/proofs/word_cseProofScript.sml b/compiler/backend/proofs/word_cseProofScript.sml index fc25fca6a1..c7d21dc994 100644 --- a/compiler/backend/proofs/word_cseProofScript.sml +++ b/compiler/backend/proofs/word_cseProofScript.sml @@ -9,19 +9,31 @@ val _ = new_theory "word_cseProof"; val _ = set_grammar_ancestry ["wordLang", "wordSem", "wordProps", "word_cse"]; Definition data_inv_def: - data_inv (data:knowledge) (s:('a,'c,'ffi) wordSem$state) = T + data_inv (data:knowledge) (s:('a,'c,'ffi) wordSem$state) ⇔ + (∀r v. lookup r data.inst_map = SOME v ⇒ get_var r s = get_var v s) ∧ + (∀r v. lookup r data.och_map = SOME v ⇒ get_var r s = get_var v s) End +Theorem canonicalRegs_correct[simp]: + ∀data r s. data_inv data s ⇒ get_var (canonicalRegs data r) s = get_var r s +Proof + rpt strip_tac \\ + gvs [data_inv_def, canonicalRegs_def] \\ + fs [lookup_any_def] \\ + Cases_on ‘lookup r data.inst_map’ \\ fs [] \\ + Cases_on ‘lookup r data.och_map’ \\ fs [] +QED + (* setting up the goal *) val goal = “ - λ(p:'a wordLang$prog,s:('a,'c,'ffi) wordSem$state). - ∀res s' data p' data'. - evaluate (p, s) = (res, s') ∧ flat_exp_conventions p ∧ - data_inv data s ∧ - word_cse data p = (data', p') ⇒ - evaluate (p', s) = (res, s') ∧ - (res = NONE ⇒ data_inv data' s')” + λ(p:'a wordLang$prog,s:('a,'c,'ffi) wordSem$state). + ∀res s' data p' data'. + evaluate (p, s) = (res, s') ∧ flat_exp_conventions p ∧ + data_inv data s ∧ + word_cse data p = (data', p') ⇒ + evaluate (p', s) = (res, s') ∧ + (res = NONE ⇒ data_inv data' s')” local val gst = goal |> Ho_Rewrite.PURE_ONCE_REWRITE_CONV [Once PFORALL_THM] |> concl |> rhs @@ -31,22 +43,23 @@ in fun get_goal s = first (can (find_term (can (match_term (Term [QUOTE s]))))) ind_goals fun compile_correct_tm () = ind_thm |> concl |> rand fun the_ind_thm () = ind_thm -end +end; (* proof of the cases *) Theorem comp_Skip_correct: ^(get_goal "Skip") Proof - rpt strip_tac \\ - fs[word_cse_def] + gvs[word_cse_def, evaluate_def] QED Theorem comp_Alloc_correct: ^(get_goal "Alloc") Proof - rpt strip_tac \\ - fs[word_cse_def] + gvs[word_cse_def, data_inv_def, lookup_def, evaluate_def] \\ + gvs [AllCaseEqs()] \\ + cheat + (* TODO make alloc forget everything for now *) QED Theorem comp_Move_correct: @@ -74,15 +87,16 @@ QED Theorem comp_Get_correct: ^(get_goal "Get") Proof - rpt strip_tac \\ - fs[word_cse_def] + gvs[word_cse_def, data_inv_def, evaluate_def] \\ + gvs[AllCaseEqs(), PULL_EXISTS] \\ + cheat QED Theorem comp_Set_correct: ^(get_goal "wordLang$Set") Proof - rpt strip_tac \\ - fs[word_cse_def] + cheat + (*gvs[word_cse_def, data_inv_def]*) QED Theorem comp_OpCurrHeap_correct: @@ -100,21 +114,29 @@ QED Theorem comp_Tick_correct: ^(get_goal "Tick") Proof - rpt strip_tac \\ - fs[word_cse_def] + gvs[word_cse_def, data_inv_def, evaluate_def] \\ + rw [] \\ + fs [get_var_def, dec_clock_def] QED Theorem comp_MustTerminate_correct: ^(get_goal "MustTerminate") Proof - rpt strip_tac \\ + rpt gen_tac \\ + strip_tac \\ + rpt gen_tac \\ gs[word_cse_def] \\ pairarg_tac \\ gvs [evaluate_def,flat_exp_conventions_def] \\ gvs [AllCaseEqs()] \\ + strip_tac + >- gvs [evaluate_def] \\ pairarg_tac \\ gvs [] \\ - pairarg_tac \\ gvs [] \\ - first_x_assum drule \\ - gvs [] + first_x_assum (drule_at Any) \\ + impl_tac + >- fs [data_inv_def, get_var_def] \\ + fs [evaluate_def] \\ + rw [] \\ + gvs [AllCaseEqs(), data_inv_def, get_var_def] QED Theorem comp_Seq_correct: @@ -139,54 +161,69 @@ QED Theorem comp_Return_correct: ^(get_goal "Return") Proof - fs[word_cse_def] + fs[word_cse_def, evaluate_def, flat_exp_conventions_def] + \\ rw [] + \\ gvs [AllCaseEqs()] QED Theorem comp_Raise_correct: ^(get_goal "wordLang$Raise") Proof - fs[word_cse_def] + fs[word_cse_def, evaluate_def, flat_exp_conventions_def] + \\ rw [] + \\ gvs [AllCaseEqs()] + QED Theorem comp_If_correct: ^(get_goal "wordLang$If") Proof - cheat + rpt gen_tac + \\ strip_tac + \\ rpt gen_tac + \\ simp_tac std_ss [evaluate_def, AllCaseEqs(), word_cse_def, LET_THM] + \\ rpt (pairarg_tac \\ simp []) + \\ strip_tac + \\ gvs [evaluate_def] + \\ ‘get_var_imm (canonicalImmReg data ri) s = get_var_imm ri s’ by + (Cases_on ‘ri’ \\ fs [get_var_imm_def, canonicalImmReg_def]) + \\ fs [flat_exp_conventions_def] + \\ first_x_assum drule_all + \\ rw [] + \\ simp [data_inv_def, empty_data_def, get_var_def, lookup_def] QED Theorem comp_LocValue_correct: ^(get_goal "wordLang$LocValue") Proof - rpt strip_tac \\ - fs[word_cse_def] + gvs[word_cse_def, data_inv_def] + \\ cheat QED +(* DATA EMPTY *) + Theorem comp_Install_correct: ^(get_goal "wordLang$Install") Proof - rpt strip_tac \\ - fs[word_cse_def] + gvs[word_cse_def, data_inv_def] QED Theorem comp_CodeBufferWrite_correct: ^(get_goal "wordLang$CodeBufferWrite") Proof - rpt strip_tac \\ - fs[word_cse_def] + gvs[word_cse_def, data_inv_def] QED Theorem comp_DataBufferWrite_correct: ^(get_goal "wordLang$DataBufferWrite") Proof - rpt strip_tac \\ - fs[word_cse_def] + gvs[word_cse_def, data_inv_def] QED Theorem comp_FFI_correct: ^(get_goal "wordLang$FFI") Proof - rpt strip_tac \\ - fs[word_cse_def] + gvs[word_cse_def, data_inv_def, evaluate_def] QED Theorem comp_Call_correct: @@ -195,6 +232,8 @@ Proof fs[word_cse_def] QED +(* DATA EMPTY *) + Theorem comp_correct: ^(compile_correct_tm ()) Proof diff --git a/compiler/backend/word_cseScript.sml b/compiler/backend/word_cseScript.sml index 20a080d21e..9e475dc678 100644 --- a/compiler/backend/word_cseScript.sml +++ b/compiler/backend/word_cseScript.sml @@ -30,11 +30,12 @@ Type regsM = ``:num num_map`` Type instrsM = ``:(num list,num)map`` val _ = Datatype `knowledge = <| n:num; - instEq:regsE; - instMap:regsM; - instInstrs:instrsM; - ochMap:regsM; - ochInstrs:instrsM |>`; + inst_eq:regsE; + inst_map:regsM; + inst_instrs:instrsM; + och_map:regsM; + och_instrs:instrsM; + all_names:num_set |>`; (* add a (all_names:num_set) ⇒ when seeing a new register, add it in all_names if a register is affected and is in all_names, throw everything @@ -70,11 +71,12 @@ QED Definition empty_data_def: empty_data = <| n:=0; - instEq:=[]; - instMap:=LN; - instInstrs:=empty listCmp; - ochMap:=LN; - ochInstrs:=empty listCmp |> + inst_eq:=[]; + inst_map:=LN; + inst_instrs:=empty listCmp; + och_map:=LN; + och_instrs:=empty listCmp; + all_names:=LN |> End (* REGISTERS EQUIVALENCE MEMORY *) @@ -237,11 +239,14 @@ QED Definition canonicalRegs_def: canonicalRegs (data:knowledge) (r:num) = - case sptree$lookup r data.instMap of + lookup_any r data.inst_map (lookup_any r data.och_map r) +(* + case sptree$lookup r data.inst_map of | SOME r' => r' - | NONE => case sptree$lookup r data.ochMap of + | NONE => case sptree$lookup r data.och_map of | NONE => r | SOME r' => r' +*) End Definition canonicalImmReg_def: @@ -250,44 +255,44 @@ Definition canonicalImmReg_def: End Definition canonicalMultRegs_def: - canonicalMultRegs data [] = [] ∧ - canonicalMultRegs data (hd::tl) = - (canonicalRegs data hd)::(canonicalMultRegs data tl) -(* rewrite with a map *) + canonicalMultRegs (data:knowledge) (regs:num list) = MAP (canonicalRegs data) regs End Definition canonicalMoveRegs_def: canonicalMoveRegs data [] = (data, []) ∧ canonicalMoveRegs data ((r1,r2)::tl) = - case sptree$lookup r2 data.ochMap of - | SOME r2' => let ochMap' = sptree$insert r1 r2' data.ochMap in - let (data', tl') = canonicalMoveRegs (data with ochMap:=ochMap') tl in + if sptree$lookup r1 data.all_names ≠ NONE then (empty_data, ((r1,r2)::tl)) else + case sptree$lookup r2 data.och_map of + | SOME r2' => let och_map' = sptree$insert r1 r2' data.och_map in + let (data', tl') = canonicalMoveRegs (data with och_map:=och_map') tl in (data', (r1,r2')::tl') - | NONE => let r2' = (case sptree$lookup r2 data.instMap of SOME r => r | NONE => r2) in - let instEq' = regsUpdate r2' r1 data.instEq in - let instMap' = sptree$insert r1 r2' data.instMap in - let (data', tl') = canonicalMoveRegs (data with <| instEq:=instEq'; instMap:=instMap' |>) tl in + | NONE => let r2' = (case sptree$lookup r2 data.inst_map of SOME r => r | NONE => r2) in + let inst_eq' = regsUpdate r2' r1 data.inst_eq in + let inst_map' = sptree$insert r1 r2' data.inst_map in + let (data', tl') = canonicalMoveRegs (data with <| inst_eq:=inst_eq'; inst_map:=inst_map' |>) tl in (data', (r1,r2')::tl') End (* make a lookup_data to wrap case matching -lookup_any x sp d = lookup x sp otherwise return d*) +lookup_any x sp d = lookup x sp otherwise return d +To discuss*) Definition canonicalMoveRegs2_def: canonicalMoveRegs2 data [] = (data, []) ∧ canonicalMoveRegs2 data ((r1,r2)::tl) = + if sptree$lookup r1 data.all_names ≠ NONE then (empty_data, ((r1,r2)::tl)) else if (EVEN r1 ∨ EVEN r2) then let (data', tl') = canonicalMoveRegs2 data tl in (data', (r1,r2)::tl') else - case sptree$lookup r2 data.ochMap of - | SOME r2' => let ochMap' = sptree$insert r1 r2' data.ochMap in - let (data', tl') = canonicalMoveRegs2 (data with ochMap:=ochMap') tl in + case sptree$lookup r2 data.och_map of + | SOME r2' => let och_map' = sptree$insert r1 r2' data.och_map in + let (data', tl') = canonicalMoveRegs2 (data with och_map:=och_map') tl in (data', (r1,r2')::tl') - | NONE => let r2' = (case sptree$lookup r2 data.instMap of SOME r => r | NONE => r2) in - let instEq' = regsUpdate r2' r1 data.instEq in - let instMap' = sptree$insert r1 r2' data.instMap in - let (data', tl') = canonicalMoveRegs2 (data with <| instEq:=instEq'; instMap:=instMap' |>) tl in + | NONE => let r2' = (case sptree$lookup r2 data.inst_map of SOME r => r | NONE => r2) in + let inst_eq' = regsUpdate r2' r1 data.inst_eq in + let inst_map' = sptree$insert r1 r2' data.inst_map in + let (data', tl') = canonicalMoveRegs2 (data with <| inst_eq:=inst_eq'; inst_map:=inst_map' |>) tl in (data', (r1,r2')::tl') End @@ -654,28 +659,31 @@ End Definition word_cseInst_def: (word_cseInst (data:knowledge) Skip = (data, Inst Skip)) ∧ (word_cseInst data (Const r w) = + if sptree$lookup r data.all_names ≠ NONE then (empty_data, Inst (Const r w)) else let i = instToNumList (Const r w) in - case mlmap$lookup data.instInstrs i of - | SOME r' => (data with <| n:=data.n+1; instEq:=regsUpdate r' r data.instEq; instMap:=insert r r' data.instMap |>, Move 0 [(r,r')]) - | NONE => (data with instInstrs:=insert data.instInstrs i r, Inst (Const r w))) ∧ + case mlmap$lookup data.inst_instrs i of + | SOME r' => (data with <| n:=data.n+1; inst_eq:=regsUpdate r' r data.inst_eq; inst_map:=insert r r' data.inst_map |>, Move 0 [(r,r')]) + | NONE => (data with inst_instrs:=insert data.inst_instrs i r, Inst (Const r w))) ∧ (word_cseInst data (Arith a) = let a' = canonicalArith data a in let r = firstRegOfArith a' in + if sptree$lookup r data.all_names ≠ NONE then (empty_data, Inst (Arith a')) else let i = instToNumList (Arith a') in - case mlmap$lookup data.instInstrs i of - | SOME r' => (data with <| n:=data.n+1; instEq:=regsUpdate r' r data.instEq; instMap:=insert r r' data.instMap |>, Move 0 [(r,r')]) - | NONE => (data with instInstrs:=insert data.instInstrs i r, Inst (Arith a'))) ∧ + case mlmap$lookup data.inst_instrs i of + | SOME r' => (data with <| n:=data.n+1; inst_eq:=regsUpdate r' r data.inst_eq; inst_map:=insert r r' data.inst_map |>, Move 0 [(r,r')]) + | NONE => (data with inst_instrs:=insert data.inst_instrs i r, Inst (Arith a'))) ∧ (word_cseInst data (Mem op r (Addr r' w)) = + if sptree$lookup r data.all_names ≠ NONE then (empty_data, Inst (Mem op r (Addr r' w))) else (data, Inst (Mem op (canonicalRegs data r) (Addr (canonicalRegs data r') w)))) ∧ (word_cseInst data ((FP f):'a inst) = (data, Inst (FP f))) (* Not relevant: issue with fp regs having same id as regs, possible confusion - let f' = canonicalFp instMap ochMap f in + let f' = canonicalFp inst_map och_map f in let r = firstRegOfFp f' in let i = instToNumList ((FP f'):'a inst) in - case mlmap$lookup instInstrs i of - | SOME r' => (n+1, regsUpdate r' r instEq, insert r r' instMap, instInstrs, Move 0 [(r,r')]) - | NONE => (n, instEq, instMap, insert instInstrs i r, Inst (FP f'))) + case mlmap$lookup inst_instrs i of + | SOME r' => (n+1, regsUpdate r' r inst_eq, insert r r' inst_map, inst_instrs, Move 0 [(r,r')]) + | NONE => (n, inst_eq, inst_map, insert inst_instrs i r, Inst (FP f'))) *) End @@ -714,7 +722,7 @@ Definition word_cse_def: (data, Get r x)) ∧ (word_cse data (Set x e) = let e' = canonicalExp data e in - (data with <|ochMap:=LN; ochInstrs:=empty listCmp|>, Set x e')) ∧ + (data with <|och_map:=LN; och_instrs:=empty listCmp|>, Set x e')) ∧ (word_cse data (Store e r) = (data, Store e r)) ∧ (word_cse data (MustTerminate p) = @@ -730,11 +738,11 @@ Definition word_cse_def: let r1' = canonicalRegs data r1 in let r2' = canonicalImmReg data r2 in let (data1, p1') = word_cse data p1 in - let (data2, p2') = word_cse (data with n:=data1.n) p2 in - (empty_data with n:=data2.n, If c r1' r2' p1' p2')) ∧ + let (data2, p2') = word_cse data p2 in + (empty_data, If c r1' r2' p1' p2')) ∧ (* We don't know what happen in the IF. Intersection would be the best. *) (word_cse data (Alloc r m) = - (data with <| ochMap:=LN; ochInstrs:=empty listCmp |>, Alloc r m)) ∧ + (data with <| och_map:=LN; och_instrs:=empty listCmp |>, Alloc r m)) ∧ (word_cse data (Raise r) = (data, Raise r)) ∧ (word_cse data (Return r1 r2) = @@ -742,11 +750,12 @@ Definition word_cse_def: (word_cse data (Tick) = (data, Tick)) ∧ (word_cse data ((OpCurrHeap b r1 r2):'a prog) = + if sptree$lookup r1 data.all_names ≠ NONE then (empty_data, OpCurrHeap b r1 r2) else let r2' = canonicalRegs data r2 in let pL = progToNumList ((OpCurrHeap b r1 r2'):'a prog) in - case lookup data.ochInstrs pL of - | NONE => (data with ochInstrs:=(insert data.ochInstrs pL r1), OpCurrHeap b r1 r2') - | SOME r1' => (data with <| n:=data.n+1; ochMap:=(insert r1 r1' data.ochMap) |>, Move 0 [(r1, r1')])) ∧ + case lookup data.och_instrs pL of + | NONE => (data with och_instrs:=(insert data.och_instrs pL r1), OpCurrHeap b r1 r2') + | SOME r1' => (data with <| n:=data.n+1; och_map:=(insert r1 r1' data.och_map) |>, Move 0 [(r1, r1')])) ∧ (word_cse data (LocValue r1 l) = (data, LocValue r1 l)) ∧ (word_cse data (Install p l dp dl m) = @@ -759,6 +768,7 @@ Definition word_cse_def: (data, FFI s p1 l1 p2 l2 m)) End + (* EVAL “word_cse empty_data (Seq (Inst (Arith (Binop Add 3 1 (Reg 2)))) (Inst (Arith (Binop Add 4 1 (Reg 2)))))” From 4645661265198c2f5fac3ddfcc741a96063c807f Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Mon, 27 Jun 2022 10:08:25 +0200 Subject: [PATCH 14/36] Some more proof and data_inv completion --- .../backend/proofs/word_cseProofScript.sml | 253 ++++++++++++++++-- compiler/backend/word_cseScript.sml | 180 +++---------- 2 files changed, 272 insertions(+), 161 deletions(-) diff --git a/compiler/backend/proofs/word_cseProofScript.sml b/compiler/backend/proofs/word_cseProofScript.sml index c7d21dc994..d91eb6df3a 100644 --- a/compiler/backend/proofs/word_cseProofScript.sml +++ b/compiler/backend/proofs/word_cseProofScript.sml @@ -10,9 +10,28 @@ val _ = set_grammar_ancestry ["wordLang", "wordSem", "wordProps", "word_cse"]; Definition data_inv_def: data_inv (data:knowledge) (s:('a,'c,'ffi) wordSem$state) ⇔ - (∀r v. lookup r data.inst_map = SOME v ⇒ get_var r s = get_var v s) ∧ - (∀r v. lookup r data.och_map = SOME v ⇒ get_var r s = get_var v s) + (∀r v. lookup r data.inst_map = SOME v ⇒ + get_var r s = get_var v s ∧ + v IN domain data.all_names ∧ r IN domain data.all_names) ∧ + (∀r v. lookup r data.och_map = SOME v ⇒ + get_var r s = get_var v s ∧ + v IN domain data.all_names ∧ r IN domain data.all_names) ∧ + (∀n c v. lookup data.inst_instrs (instToNumList (Const n c)) = SOME v ⇒ + lookup v s.locals = SOME (Word c) ∧ + v IN domain data.all_names) ∧ + (∀(a:'a arith) v. lookup data.inst_instrs (instToNumList (Arith a)) = SOME v ⇒ + get_var v s = get_var (firstRegOfArith a) s ∧ + v IN domain data.all_names ∧ firstRegOfArith a IN domain data.all_names) ∧ + map_ok data.inst_instrs + (* + (∀r (c:'a word) x v. lookup data.inst_instrs (instToNumList (Const r c)) = SOME x ⇒ + x IN domain data.all_names ∧ get_var x s = SOME (Word c)) ∧ + (∀r v (a:'a arith). lookup data.inst_instrs (instToNumList (Arith a)) = SOME v ∧ firstRegOfArith a = r ⇒ + get_var r s = get_var v s ∧ + r IN domain data.all_names ∧ v IN domain data.all_names) + *) End +(* domain_lookup lookup_insert*) Theorem canonicalRegs_correct[simp]: ∀data r s. data_inv data s ⇒ get_var (canonicalRegs data r) s = get_var r s @@ -24,6 +43,56 @@ Proof Cases_on ‘lookup r data.och_map’ \\ fs [] QED +Theorem canonicalArith_correct[simp]: + ∀data s a. data_inv data s ⇒ inst (Arith (canonicalArith data a)) s = inst (Arith a) s +Proof + cheat +QED + +Theorem firstRegOfArith_canonicalArith[simp]: + ∀data a. firstRegOfArith (canonicalArith data a) = firstRegOfArith a +Proof + rpt gen_tac \\ Cases_on ‘a’ \\ gvs [firstRegOfArith_def, canonicalArith_def] +QED + + +(* Some usefull proofs to automize *) + +Theorem lookup_empty[simp]: + ∀l. lookup (empty listCmp) l = NONE +Proof + gen_tac + \\ gvs [mlmapTheory.lookup_def, balanced_mapTheory.lookup_def, + mlmapTheory.empty_def, balanced_mapTheory.empty_def] +QED + +Theorem data_inv_insert_all_names[simp]: + ∀data s r. data_inv data s ⇒ data_inv (data with all_names:=insert r () data.all_names) s +Proof + rpt gen_tac + \\ gvs [data_inv_def] + \\ rpt strip_tac + \\ first_x_assum drule_all \\ rw [] +QED + +Theorem TotOrd_listCmp[simp]: + TotOrd listCmp +Proof + cheat +QED + +Theorem map_ok_empty[simp]: + map_ok (empty listCmp) +Proof + gvs [mlmapTheory.empty_thm] +QED + +Theorem map_ok_insert[simp]: + ∀m l v. map_ok m ⇒ map_ok (insert m l v) +Proof + gvs [mlmapTheory.insert_thm] +QED + (* setting up the goal *) val goal = “ @@ -56,10 +125,7 @@ QED Theorem comp_Alloc_correct: ^(get_goal "Alloc") Proof - gvs[word_cse_def, data_inv_def, lookup_def, evaluate_def] \\ - gvs [AllCaseEqs()] \\ - cheat - (* TODO make alloc forget everything for now *) + gvs[word_cse_def, data_inv_def, empty_data_def, sptreeTheory.lookup_def] QED Theorem comp_Move_correct: @@ -75,7 +141,127 @@ QED Theorem comp_Inst_correct: ^(get_goal "Inst") Proof - cheat + rpt gen_tac + \\ strip_tac + \\ Cases_on ‘i’ + >- (* Skip *) + ( gvs [evaluate_def, data_inv_def, word_cse_def, word_cseInst_def, + inst_def, flat_exp_conventions_def] + \\ strip_tac + \\ rw [] \\ gvs [] + \\ first_x_assum (drule_at Any) \\ gvs [] ) + + >- (* Const *) + ( gvs [evaluate_def, word_cse_def, word_cseInst_def, data_inv_def] + \\ Cases_on ‘is_seen n data’ \\ gvs [evaluate_def] + >- gvs [data_inv_def, empty_data_def, lookup_def] + \\ gvs [is_seen_def] \\ Cases_on ‘lookup n data.all_names’ \\ gvs [] + \\ Cases_on ‘lookup data.inst_instrs (instToNumList (Const n c))’ \\ gvs[evaluate_def] + >- ( Cases_on ‘inst (Const n c) s’ \\ gvs [data_inv_def, inst_def, assign_def] + \\ Cases_on ‘word_exp s (Const c)’ + \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, word_exp_def] + \\ strip_tac + >- (rpt gen_tac \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [] + \\ strip_tac \\ first_x_assum drule_all \\ rw []) + \\ strip_tac + >- (rpt gen_tac \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [] + \\ strip_tac \\ first_x_assum drule_all \\ rw []) + \\ strip_tac + >- ( rpt gen_tac \\ gvs [mlmapTheory.lookup_insert] + \\ Cases_on ‘c = c'’ \\ gvs [instToNumList_def, wordToNum_def] + \\ strip_tac \\ first_x_assum drule_all + \\ strip_tac + \\ Cases_on ‘v = n’ \\ gvs []) + \\ rpt gen_tac \\ gvs [instToNumList_def, arithToNumList_def, mlmapTheory.lookup_insert] + \\ strip_tac + \\ first_assum drule_all + \\ strip_tac + \\ Cases_on ‘v=n’ \\ gvs [] + \\ Cases_on ‘firstRegOfArith a = n’ \\ gvs [] + ) + \\ Cases_on ‘inst (Const n c) s’ \\ gvs [inst_def, assign_def, word_exp_def] + \\ strip_tac + >- (first_x_assum drule_all \\ strip_tac + \\ gvs [get_vars_def, get_var_def, set_vars_def, alist_insert_def, set_var_def]) + \\ strip_tac + >- (first_x_assum drule_all \\ strip_tac + \\ rpt gen_tac + \\ gvs [sptreeTheory.lookup_insert] + \\ Cases_on ‘r = n’ \\ strip_tac \\ gvs [] + >- (Cases_on ‘n=v’ \\ gvs [set_var_def, get_var_def, lookup_insert]) + \\ gvs [set_var_def, get_var_def, lookup_insert] + \\ first_x_assum drule_all \\ strip_tac \\ gvs [] + \\ Cases_on ‘v = n’ \\ gvs [domain_lookup]) + \\ strip_tac + >- (first_x_assum drule_all \\ strip_tac + \\ rpt gen_tac \\ strip_tac + \\ first_x_assum drule_all \\ strip_tac \\ gvs [] + \\ gvs [set_var_def, get_var_def, lookup_insert] + \\ Cases_on ‘r = n’ \\ Cases_on ‘v = n’ \\ gvs [domain_lookup]) + \\ rpt gen_tac \\ strip_tac + >- (first_assum drule_all \\ strip_tac \\ rpt gen_tac \\ strip_tac \\ first_x_assum drule_all + \\ strip_tac \\ gvs [set_var_def, lookup_insert, domain_lookup] + \\ Cases_on ‘v=n’ \\ gvs [] ) + \\ first_assum drule_all \\ strip_tac \\ rpt gen_tac \\ strip_tac \\ first_x_assum drule_all + \\ strip_tac \\ gvs [set_var_def, get_var_def, lookup_insert, domain_lookup] + \\ Cases_on ‘v = n’ \\ gvs [] + \\ Cases_on ‘firstRegOfArith a = n’ \\ gvs [] + ) + + >- (* Arith *) + ( gvs [word_cse_def, word_cseInst_def] + \\ pairarg_tac \\ gvs [] + \\ Cases_on ‘is_seen (firstRegOfArith a) data’ \\ gvs [] + >- gvs [data_inv_def, empty_data_def, lookup_def] + \\ Cases_on ‘lookup data.inst_instrs (instToNumList (Arith (canonicalArith data a)))’ \\ gvs [evaluate_def] + >- ( strip_tac \\ cases_on ‘inst (Arith a) s’ \\ gvs [] + \\ gvs [data_inv_def] + \\ strip_tac + >- (rpt gen_tac \\ strip_tac \\ first_x_assum drule_all \\ strip_tac + \\ Cases_on ‘a’ \\ gvs [inst_def, assign_def] + >- (Cases_on ‘word_exp s (Op b [Var n0; case r' of Reg r3 => Var r3 | Imm w => Const w])’ + \\ gvs [get_var_def, set_var_def, lookup_insert] + \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [word_exp_def] + \\ gvs [firstRegOfArith_def, is_seen_def, domain_lookup]) + >- (Cases_on ‘word_exp s (Shift s'' (Var n0) n1)’ + \\ gvs [get_var_def, set_var_def, lookup_insert] + \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [word_exp_def] + \\ gvs [firstRegOfArith_def, is_seen_def, domain_lookup]) + >- (Cases_on ‘get_vars [n1; n0] s’ \\ gvs [get_var_def, set_var_def] + \\ Cases_on ‘x’ \\ gvs [] + \\ Cases_on ‘t’ \\ gvs [] + \\ Cases_on ‘h'’ \\ gvs [] + \\ Cases_on ‘h’ \\ gvs [] + \\ Cases_on ‘t'’ \\ gvs [] + \\ gvs [lookup_insert] + \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [] + \\ gvs [firstRegOfArith_def, is_seen_def, domain_lookup]) + >- (Cases_on ‘get_vars [n1; n2] s’ + \\ gvs [get_var_def, set_var_def, lookup_insert] + \\ Cases_on ‘x’ \\ gvs [] + \\ Cases_on ‘t’ \\ gvs [] + \\ Cases_on ‘h'’ \\ gvs [] + \\ Cases_on ‘h’ \\ gvs [] + \\ Cases_on ‘t'’ \\ gvs [] + \\ gvs [lookup_insert] + \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [word_exp_def] + \\ gvs [firstRegOfArith_def, is_seen_def, domain_lookup] + \\ Cases_on ‘r=n0’ \\ Cases_on ‘v=n0’ \\ gvs [word_exp_def] + \\ gvs [firstRegOfArith_def, is_seen_def, domain_lookup] + \\ cheat) + >- (cheat) + >- (cheat) + >- (cheat) + >- (cheat) + ) + \\ cheat) + \\ cheat + ) + >- (* Mem *) + ( Cases_on ‘a’ + \\ gvs [evaluate_def, word_cse_def, word_cseInst_def, data_inv_def, empty_data_def, lookup_def] ) + >- (* FP *) + ( gvs [evaluate_def, word_cse_def, word_cseInst_def, data_inv_def, empty_data_def, lookup_def] ) QED Theorem comp_Assign_correct: @@ -87,10 +273,18 @@ QED Theorem comp_Get_correct: ^(get_goal "Get") Proof - gvs[word_cse_def, data_inv_def, evaluate_def] \\ - gvs[AllCaseEqs(), PULL_EXISTS] \\ - cheat + gvs[word_cse_def, data_inv_def, evaluate_def] + \\ rpt gen_tac \\ strip_tac + \\ Cases_on ‘is_seen v data’ \\ gvs [evaluate_def] + >- gvs [empty_data_def, lookup_def, lookup_empty, sptreeTheory.lookup_def] + \\ strip_tac + \\ Cases_on ‘FLOOKUP s.store name’ \\ gvs[] + \\ fs [get_var_def, set_var_def] + \\ fs [lookup_insert, is_seen_def] + \\ Cases_on ‘lookup v data.all_names’ \\ gvs [domain_lookup] + \\ metis_tac [NOT_NONE_SOME] QED +(* similare cases : Loc *) Theorem comp_Set_correct: ^(get_goal "wordLang$Set") @@ -116,7 +310,8 @@ Theorem comp_Tick_correct: Proof gvs[word_cse_def, data_inv_def, evaluate_def] \\ rw [] \\ - fs [get_var_def, dec_clock_def] + fs [get_var_def, dec_clock_def] \\ + first_x_assum drule_all \\ gs [] QED Theorem comp_MustTerminate_correct: @@ -129,14 +324,15 @@ Proof pairarg_tac \\ gvs [evaluate_def,flat_exp_conventions_def] \\ gvs [AllCaseEqs()] \\ strip_tac - >- gvs [evaluate_def] \\ + >- (gvs [evaluate_def] \\ + pairarg_tac \\ gvs []) \\ pairarg_tac \\ gvs [] \\ first_x_assum (drule_at Any) \\ impl_tac - >- fs [data_inv_def, get_var_def] \\ + >- fs [data_inv_def, get_var_def, SF SFY_ss] \\ fs [evaluate_def] \\ rw [] \\ - gvs [AllCaseEqs(), data_inv_def, get_var_def] + gvs [AllCaseEqs(), data_inv_def, get_var_def, SF SFY_ss] QED Theorem comp_Seq_correct: @@ -172,7 +368,6 @@ Proof fs[word_cse_def, evaluate_def, flat_exp_conventions_def] \\ rw [] \\ gvs [AllCaseEqs()] - QED Theorem comp_If_correct: @@ -196,8 +391,16 @@ QED Theorem comp_LocValue_correct: ^(get_goal "wordLang$LocValue") Proof - gvs[word_cse_def, data_inv_def] - \\ cheat + gvs[word_cse_def, data_inv_def, evaluate_def] + \\ rpt gen_tac \\ strip_tac + \\ Cases_on ‘is_seen r data’ \\ gvs [evaluate_def] + >- gvs [empty_data_def, lookup_def] + \\ strip_tac + \\ Cases_on ‘l1 ∈ domain s.code’ \\ gvs[] + \\ fs [get_var_def, set_var_def] + \\ fs [lookup_insert, is_seen_def] + \\ Cases_on ‘lookup r data.all_names’ \\ gvs [domain_lookup] + \\ metis_tac [NOT_NONE_SOME] QED (* DATA EMPTY *) @@ -205,31 +408,37 @@ QED Theorem comp_Install_correct: ^(get_goal "wordLang$Install") Proof - gvs[word_cse_def, data_inv_def] + gvs[word_cse_def, data_inv_def, empty_data_def, lookup_def] QED Theorem comp_CodeBufferWrite_correct: ^(get_goal "wordLang$CodeBufferWrite") Proof - gvs[word_cse_def, data_inv_def] + gvs[word_cse_def, data_inv_def, empty_data_def, lookup_def] QED Theorem comp_DataBufferWrite_correct: ^(get_goal "wordLang$DataBufferWrite") Proof - gvs[word_cse_def, data_inv_def] + gvs[word_cse_def, data_inv_def, empty_data_def, lookup_def] QED Theorem comp_FFI_correct: ^(get_goal "wordLang$FFI") Proof - gvs[word_cse_def, data_inv_def, evaluate_def] + gvs[word_cse_def, data_inv_def, empty_data_def, lookup_def] QED Theorem comp_Call_correct: ^(get_goal "wordLang$Call") Proof - fs[word_cse_def] + rpt gen_tac + \\ strip_tac + \\ rpt gen_tac + \\ cheat +(* never end + gvs[word_cse_def, data_inv_def, empty_data_def, lookup_def] + *) QED (* DATA EMPTY *) diff --git a/compiler/backend/word_cseScript.sml b/compiler/backend/word_cseScript.sml index 9e475dc678..8d9de9fe04 100644 --- a/compiler/backend/word_cseScript.sml +++ b/compiler/backend/word_cseScript.sml @@ -79,6 +79,11 @@ Definition empty_data_def: all_names:=LN |> End +Definition is_seen_def: + is_seen r data = case sptree$lookup r data.all_names of SOME _ => T | NONE => F +End + + (* REGISTERS EQUIVALENCE MEMORY *) Definition listLookup_def: @@ -128,113 +133,6 @@ Definition regsUpdate_def: else [r1;r2]::hd::tl End -(* -Theorem regsUpdate_test_merge1: - regsUpdate 1 6 [[1;2;3];[4;5;6];[7;8;9]] = [[1;2;3;4;5;6];[7;8;9]] -Proof - rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, - regsUpdate2_def,regsLookup_def,listLookup_def] -QED - -Theorem regsUpdate_test_merge2: - regsUpdate 1 7 [[1;2;3];[4;5;6];[7;8;9]] = [[4;5;6];[1;2;3;7;8;9]] -Proof - rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, - regsUpdate2_def,regsLookup_def,listLookup_def] -QED - -Theorem regsUpdate_test_merge3: - regsUpdate 5 7 [[1;2;3];[4;5;6];[7;8;9]] = [[1;2;3]; [4;5;6;7;8;9]] -Proof - rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, - regsUpdate2_def,regsLookup_def,listLookup_def] -QED - -Theorem regsUpdate_test_merge4: - regsUpdate 6 1 [[1;2;3];[4;5;6];[7;8;9]] = [[1;2;3;4;5;6];[7;8;9]] -Proof - rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, - regsUpdate2_def,regsLookup_def,listLookup_def] -QED - -Theorem regsUpdate_test_merge5: - regsUpdate 7 1 [[1;2;3];[4;5;6];[7;8;9]] = [[4;5;6];[1;2;3;7;8;9]] -Proof - rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, - regsUpdate2_def,regsLookup_def,listLookup_def] -QED - -Theorem regsUpdate_test_merge6: - regsUpdate 7 5 [[1;2;3];[4;5;6];[7;8;9]] = [[1;2;3]; [4;5;6;7;8;9]] -Proof - rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, - regsUpdate2_def,regsLookup_def,listLookup_def] -QED - -Theorem regsUpdate_test_eq1: - regsUpdate 1 2 [[1;2;3];[4;5;6];[7;8;9]] = [[1;2;3];[4;5;6];[7;8;9]] -Proof - rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, - regsUpdate2_def,regsLookup_def,listLookup_def] -QED - -Theorem regsUpdate_test_eq2: - regsUpdate 4 5 [[1;2;3];[4;5;6];[7;8;9]] = [[1;2;3];[4;5;6];[7;8;9]] -Proof - rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, - regsUpdate2_def,regsLookup_def,listLookup_def] -QED - -Theorem regsUpdate_test_eq3: - regsUpdate 8 9 [[1;2;3];[4;5;6];[7;8;9]] = [[1;2;3];[4;5;6];[7;8;9]] -Proof - rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, - regsUpdate2_def,regsLookup_def,listLookup_def] -QED - -Theorem regsUpdate_test_add1: - regsUpdate 2 10 [[1;2;3];[4;5;6];[7;8;9]] = [[1;10;2;3];[4;5;6];[7;8;9]] -Proof - rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, - regsUpdate2_def,regsLookup_def,listLookup_def] -QED - -Theorem regsUpdate_test_add2: - regsUpdate 6 10 [[1;2;3];[4;5;6];[7;8;9]] = [[1;2;3];[4;10;5;6];[7;8;9]] -Proof - rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, - regsUpdate2_def,regsLookup_def,listLookup_def] -QED - -Theorem regsUpdate_test_add3: - regsUpdate 9 10 [[1;2;3];[4;5;6];[7;8;9]] = [[1;2;3];[4;5;6];[7;10;8;9]] -Proof - rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, - regsUpdate2_def,regsLookup_def,listLookup_def] -QED - -Theorem regsUpdate_test_add4: - regsUpdate 10 2 [[1;2;3];[4;5;6];[7;8;9]] = [[1;10;2;3];[4;5;6];[7;8;9]] -Proof - rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, - regsUpdate2_def,regsLookup_def,listLookup_def] -QED - -Theorem regsUpdate_test_add5: - regsUpdate 10 6 [[1;2;3];[4;5;6];[7;8;9]] = [[1;2;3];[4;10;5;6];[7;8;9]] -Proof - rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, - regsUpdate2_def,regsLookup_def,listLookup_def] -QED - -Theorem regsUpdate_test_add6: - regsUpdate 10 9 [[1;2;3];[4;5;6];[7;8;9]] = [[1;2;3];[4;5;6];[7;10;8;9]] -Proof - rw[regsUpdate_def,regsUpdate1_def,regsUpdate1Aux_def, - regsUpdate2_def,regsLookup_def,listLookup_def] -QED -*) - (* REGISTER TRANSFORMATIONS *) Definition canonicalRegs_def: @@ -261,16 +159,16 @@ End Definition canonicalMoveRegs_def: canonicalMoveRegs data [] = (data, []) ∧ canonicalMoveRegs data ((r1,r2)::tl) = - if sptree$lookup r1 data.all_names ≠ NONE then (empty_data, ((r1,r2)::tl)) else - case sptree$lookup r2 data.och_map of - | SOME r2' => let och_map' = sptree$insert r1 r2' data.och_map in - let (data', tl') = canonicalMoveRegs (data with och_map:=och_map') tl in - (data', (r1,r2')::tl') - | NONE => let r2' = (case sptree$lookup r2 data.inst_map of SOME r => r | NONE => r2) in - let inst_eq' = regsUpdate r2' r1 data.inst_eq in - let inst_map' = sptree$insert r1 r2' data.inst_map in - let (data', tl') = canonicalMoveRegs (data with <| inst_eq:=inst_eq'; inst_map:=inst_map' |>) tl in - (data', (r1,r2')::tl') + if is_seen r1 data then empty_data, ((r1,r2)::tl) else + case sptree$lookup r2 data.och_map of + | SOME r2' => let och_map' = sptree$insert r1 r2' data.och_map in + let (data', tl') = canonicalMoveRegs (data with och_map:=och_map') tl in + (data', (r1,r2')::tl') + | NONE => let r2' = (case sptree$lookup r2 data.inst_map of SOME r => r | NONE => r2) in + let inst_eq' = regsUpdate r2' r1 data.inst_eq in + let inst_map' = sptree$insert r1 r2' data.inst_map in + let (data', tl') = canonicalMoveRegs (data with <| inst_eq:=inst_eq'; inst_map:=inst_map' |>) tl in + (data', (r1,r2')::tl') End (* make a lookup_data to wrap case matching @@ -280,10 +178,10 @@ To discuss*) Definition canonicalMoveRegs2_def: canonicalMoveRegs2 data [] = (data, []) ∧ canonicalMoveRegs2 data ((r1,r2)::tl) = - if sptree$lookup r1 data.all_names ≠ NONE then (empty_data, ((r1,r2)::tl)) else + if is_seen r1 data then empty_data, ((r1,r2)::tl) else if (EVEN r1 ∨ EVEN r2) then let (data', tl') = canonicalMoveRegs2 data tl in - (data', (r1,r2)::tl') + (data', (r1, canonicalRegs data r2)::tl') else case sptree$lookup r2 data.och_map of | SOME r2' => let och_map' = sptree$insert r1 r2' data.och_map in @@ -325,7 +223,7 @@ Definition canonicalArith_def: canonicalArith data (Binop op r1 r2 r3) = Binop op r1 (canonicalRegs data r2) (canonicalImmReg data r3) ∧ canonicalArith data (Shift s r1 r2 n) = - Shift s (canonicalRegs data r1) (canonicalRegs data r2) n ∧ + Shift s r1 (canonicalRegs data r2) n ∧ canonicalArith data (Div r1 r2 r3) = Div r1 (canonicalRegs data r2) (canonicalRegs data r3) ∧ canonicalArith data (LongMul r1 r2 r3 r4) = @@ -587,8 +485,8 @@ QED Definition instToNumList_def: instToNumList (Skip) = [1] ∧ instToNumList (Const r w) = [2;wordToNum w] ∧ - instToNumList (Arith a) = arithToNumList a ∧ - instToNumList (FP fp) = fpToNumList fp + instToNumList (Arith a) = 3::(arithToNumList a) ∧ + instToNumList (FP fp) = 4::(fpToNumList fp) End (* Theorem instToNumList_unique: @@ -659,24 +557,28 @@ End Definition word_cseInst_def: (word_cseInst (data:knowledge) Skip = (data, Inst Skip)) ∧ (word_cseInst data (Const r w) = - if sptree$lookup r data.all_names ≠ NONE then (empty_data, Inst (Const r w)) else + if is_seen r data then (empty_data, Inst (Const r w)) else + let data = data with <| all_names:=insert r () data.all_names |> in let i = instToNumList (Const r w) in case mlmap$lookup data.inst_instrs i of - | SOME r' => (data with <| n:=data.n+1; inst_eq:=regsUpdate r' r data.inst_eq; inst_map:=insert r r' data.inst_map |>, Move 0 [(r,r')]) + | SOME r' => (data with <| inst_eq:=regsUpdate r' r data.inst_eq; inst_map:=insert r r' data.inst_map |>, Move 0 [(r,r')]) | NONE => (data with inst_instrs:=insert data.inst_instrs i r, Inst (Const r w))) ∧ (word_cseInst data (Arith a) = + let r = firstRegOfArith a in + if is_seen r data then (empty_data, Inst (Arith a)) else let a' = canonicalArith data a in - let r = firstRegOfArith a' in - if sptree$lookup r data.all_names ≠ NONE then (empty_data, Inst (Arith a')) else let i = instToNumList (Arith a') in case mlmap$lookup data.inst_instrs i of - | SOME r' => (data with <| n:=data.n+1; inst_eq:=regsUpdate r' r data.inst_eq; inst_map:=insert r r' data.inst_map |>, Move 0 [(r,r')]) - | NONE => (data with inst_instrs:=insert data.inst_instrs i r, Inst (Arith a'))) ∧ + | SOME r' => (data with <| inst_eq:=regsUpdate r' r data.inst_eq; inst_map:=insert r r' data.inst_map; all_names:=insert r () data.all_names |>, Move 0 [(r,r')]) + | NONE => (data with <| inst_instrs:=insert data.inst_instrs i r; all_names:=insert r () data.all_names |>, Inst (Arith a'))) ∧ (word_cseInst data (Mem op r (Addr r' w)) = + (empty_data, Inst (Mem op r (Addr r' w))) + (* !!! meaning difference of r between Load and Store if sptree$lookup r data.all_names ≠ NONE then (empty_data, Inst (Mem op r (Addr r' w))) else - (data, Inst (Mem op (canonicalRegs data r) (Addr (canonicalRegs data r') w)))) ∧ + (data, Inst (Mem op (canonicalRegs data r) (Addr (canonicalRegs data r') w))) + *) ) ∧ (word_cseInst data ((FP f):'a inst) = - (data, Inst (FP f))) + (empty_data, Inst (FP f))) (* Not relevant: issue with fp regs having same id as regs, possible confusion let f' = canonicalFp inst_map och_map f in let r = firstRegOfFp f' in @@ -719,7 +621,7 @@ Definition word_cse_def: (word_cse data (Assign r e) = (data, Assign r e)) ∧ (word_cse data (Get r x) = - (data, Get r x)) ∧ + if is_seen r data then (empty_data, Get r x) else (data, Get r x)) ∧ (word_cse data (Set x e) = let e' = canonicalExp data e in (data with <|och_map:=LN; och_instrs:=empty listCmp|>, Set x e')) ∧ @@ -729,7 +631,7 @@ Definition word_cse_def: let (data', p') = word_cse data p in (data', MustTerminate p')) ∧ (word_cse data (Call ret dest args handler) = - (empty_data with n:=data.n, Call ret dest args handler)) ∧ + (empty_data, Call ret dest args handler)) ∧ (word_cse data (Seq p1 p2) = let (data1, p1') = word_cse data p1 in let (data2, p2') = word_cse data1 p2 in @@ -742,7 +644,7 @@ Definition word_cse_def: (empty_data, If c r1' r2' p1' p2')) ∧ (* We don't know what happen in the IF. Intersection would be the best. *) (word_cse data (Alloc r m) = - (data with <| och_map:=LN; och_instrs:=empty listCmp |>, Alloc r m)) ∧ + (empty_data, Alloc r m)) ∧ (word_cse data (Raise r) = (data, Raise r)) ∧ (word_cse data (Return r1 r2) = @@ -756,16 +658,16 @@ Definition word_cse_def: case lookup data.och_instrs pL of | NONE => (data with och_instrs:=(insert data.och_instrs pL r1), OpCurrHeap b r1 r2') | SOME r1' => (data with <| n:=data.n+1; och_map:=(insert r1 r1' data.och_map) |>, Move 0 [(r1, r1')])) ∧ - (word_cse data (LocValue r1 l) = - (data, LocValue r1 l)) ∧ + (word_cse data (LocValue r l) = + if is_seen r data then (empty_data, LocValue r l) else (data, LocValue r l)) ∧ (word_cse data (Install p l dp dl m) = - (data, Install p l dp dl m)) ∧ + (empty_data, Install p l dp dl m)) ∧ (word_cse data (CodeBufferWrite r1 r2) = - (data, CodeBufferWrite r1 r2)) ∧ + (empty_data, CodeBufferWrite r1 r2)) ∧ (word_cse data (DataBufferWrite r1 r2) = - (data, DataBufferWrite r1 r2)) ∧ + (empty_data, DataBufferWrite r1 r2)) ∧ (word_cse data (FFI s p1 l1 p2 l2 m) = - (data, FFI s p1 l1 p2 l2 m)) + (empty_data, FFI s p1 l1 p2 l2 m)) End From acb13214d0199cef3638463f59c43e5540dc18ce Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Thu, 30 Jun 2022 13:15:49 +0200 Subject: [PATCH 15/36] Saving current state before rework of knowledge datatype --- .../backend/proofs/word_cseProofScript.sml | 202 +++++++++++++++--- compiler/backend/word_cseScript.sml | 46 ++-- 2 files changed, 190 insertions(+), 58 deletions(-) diff --git a/compiler/backend/proofs/word_cseProofScript.sml b/compiler/backend/proofs/word_cseProofScript.sml index d91eb6df3a..296bed11d3 100644 --- a/compiler/backend/proofs/word_cseProofScript.sml +++ b/compiler/backend/proofs/word_cseProofScript.sml @@ -1,7 +1,7 @@ (* Correctness proof for word_cse *) -open preamble alistTheory; +open preamble alistTheory totoTheory; open wordLangTheory wordSemTheory wordPropsTheory word_simpTheory word_cseTheory; val _ = new_theory "word_cseProof"; @@ -43,10 +43,32 @@ Proof Cases_on ‘lookup r data.och_map’ \\ fs [] QED +Theorem canonicalRegs_correct_bis[simp]: + ∀data r s. data_inv data s ⇒ lookup (canonicalRegs data r) s.locals = lookup r s.locals +Proof + rpt strip_tac + \\ gvs [data_inv_def, canonicalRegs_def] + \\ fs [lookup_any_def] + \\ Cases_on ‘lookup r data.inst_map’ \\ fs [get_var_def] + \\ Cases_on ‘lookup r data.och_map’ \\ fs [get_var_def] +QED + Theorem canonicalArith_correct[simp]: ∀data s a. data_inv data s ⇒ inst (Arith (canonicalArith data a)) s = inst (Arith a) s Proof - cheat + rpt gen_tac + \\ strip_tac + \\ Cases_on ‘a’ \\ gvs [canonicalArith_def, inst_def, assign_def, word_exp_def, the_words_def] + \\ cheat +QED + +Theorem canonicalExp_correct[simp]: + ∀data s exp. data_inv data s ⇒ word_exp s (canonicalExp data exp) = word_exp s exp +Proof + gen_tac \\ gen_tac + \\ Cases_on ‘exp’ + \\ rpt gen_tac \\ strip_tac + \\ gvs [canonicalExp_def, word_exp_def] QED Theorem firstRegOfArith_canonicalArith[simp]: @@ -55,7 +77,6 @@ Proof rpt gen_tac \\ Cases_on ‘a’ \\ gvs [firstRegOfArith_def, canonicalArith_def] QED - (* Some usefull proofs to automize *) Theorem lookup_empty[simp]: @@ -66,6 +87,31 @@ Proof mlmapTheory.empty_def, balanced_mapTheory.empty_def] QED +Theorem not_in_all_names_impl: + ∀r data s. data_inv data s ⇒ ¬is_seen r data ⇒ lookup r data.inst_map = NONE ∧ lookup r data.och_map = NONE +Proof + rpt strip_tac + \\ gvs [data_inv_def, is_seen_def] \\ Cases_on ‘lookup r data.all_names’ \\ gvs [] + >- (Cases_on ‘lookup r data.inst_map’ \\ gvs [] \\ first_x_assum drule_all \\ strip_tac \\ gvs [domain_lookup]) + \\ Cases_on ‘lookup r data.och_map’ \\ gvs [] \\ first_x_assum drule_all \\ strip_tac \\ gvs [domain_lookup] +QED + +Theorem data_inv_locals: + ∀data s. data_inv data s ⇒ data_inv data (s with locals := s.locals) +Proof + rpt gen_tac + \\ gvs [data_inv_def, get_var_def] \\ strip_tac \\ gvs [] + \\ rpt strip_tac \\ first_x_assum drule_all \\ strip_tac \\ gvs [] +QED + +Theorem not_seen_data_inv_insert[simp]: + ∀data s r v. ¬is_seen r data ⇒ data_inv data (s with locals := insert r v s.locals) = data_inv data s +Proof + rpt strip_tac + \\ eq_tac + \\ cheat +QED + Theorem data_inv_insert_all_names[simp]: ∀data s r. data_inv data s ⇒ data_inv (data with all_names:=insert r () data.all_names) s Proof @@ -75,10 +121,55 @@ Proof \\ first_x_assum drule_all \\ rw [] QED +Theorem listCmpEq_correct: + ∀L1 L2. listCmp L1 L2 = Equal ⇔ L1 = L2 +Proof + strip_tac + \\Induct_on ‘L1’ + >- (Cases_on ‘L2’ + \\ rw[listCmp_def]) + >- (Cases_on ‘L2’ + >- rw[listCmp_def] + >- (strip_tac >> + Cases_on ‘h=h'’ + \\ rw[listCmp_def])) +QED + +Theorem antisym_listCmp: + ∀x y. listCmp x y = Greater ⇔ listCmp y x = Less +Proof + gen_tac \\ Induct_on ‘x’ + >- (Cases_on ‘y’ \\ gvs [listCmp_def]) + \\ rpt gen_tac + \\ Cases_on ‘y’ \\ gvs [listCmp_def] + \\ Cases_on ‘h=h'’ \\ gvs [] + \\ Cases_on ‘h>h'’ \\ gvs [] +QED + +Theorem transit_listCmp: + ∀x y z. listCmp x y = Less ∧ listCmp y z = Less ⇒ listCmp x z = Less +Proof + gen_tac + \\ Induct_on ‘x’ + >- (Cases_on ‘y’ \\ Cases_on ‘z’ \\ gvs [listCmp_def]) + \\ rpt gen_tac \\ strip_tac + \\ Cases_on ‘y’ \\ Cases_on ‘z’ \\ gvs [listCmp_def] + \\ Cases_on ‘h=h'’ \\ Cases_on ‘h'=h''’ \\ gvs [listCmp_def] + >- (‘listCmp x t = Less ∧ listCmp t t' = Less’ by gvs [] + \\ first_x_assum drule_all \\ gvs []) + \\ Cases_on ‘h>h'’ \\ Cases_on ‘h'>h''’ \\ gvs [] +QED + Theorem TotOrd_listCmp[simp]: TotOrd listCmp Proof - cheat + gvs [TotOrd, listCmpEq_correct, antisym_listCmp, transit_listCmp, SF SFY_ss] +QED + +Theorem map_ok_insert[simp]: + ∀m l v. map_ok m ⇒ map_ok (insert m l v) +Proof + gvs [mlmapTheory.insert_thm] QED Theorem map_ok_empty[simp]: @@ -87,10 +178,10 @@ Proof gvs [mlmapTheory.empty_thm] QED -Theorem map_ok_insert[simp]: - ∀m l v. map_ok m ⇒ map_ok (insert m l v) +Theorem data_inv_empty[simp]: + ∀s. data_inv empty_data s Proof - gvs [mlmapTheory.insert_thm] + gvs [data_inv_def, empty_data_def, lookup_def] QED (* setting up the goal *) @@ -100,6 +191,7 @@ val goal = “ ∀res s' data p' data'. evaluate (p, s) = (res, s') ∧ flat_exp_conventions p ∧ data_inv data s ∧ + res ≠ SOME Error ∧ word_cse data p = (data', p') ⇒ evaluate (p', s) = (res, s') ∧ (res = NONE ⇒ data_inv data' s')” @@ -128,14 +220,56 @@ Proof gvs[word_cse_def, data_inv_def, empty_data_def, sptreeTheory.lookup_def] QED +Theorem MAP_FST_lemma[local]: + ∀moves. MAP FST (MAP (λ(a,b). (a,canonicalRegs data b)) moves) = MAP FST moves +Proof + Induct \\ gvs [] + \\ gen_tac \\ Cases_on ‘h’ \\ gvs [] +QED + +Theorem MAP_SND_lemma[local]: + ∀moves x. + get_vars (MAP SND moves) s = SOME x ∧ data_inv data s ⇒ + get_vars (MAP SND (MAP (λ(a,b). (a,canonicalRegs data b)) moves)) s = SOME x +Proof + Induct \\ gvs [] + \\ rpt strip_tac + \\ Cases_on ‘h’ \\ gvs [get_vars_def] + \\ Cases_on ‘get_var r s’ \\ gvs [] + \\ Cases_on ‘get_vars (MAP SND moves) s’ \\ gvs [] +QED + Theorem comp_Move_correct: ^(get_goal "Move") Proof - cheat -(* - rpt strip_tac \\ - rw[word_cse_def] -*) + gen_tac \\ gen_tac + \\ gvs [evaluate_def, word_cse_def] + \\ rpt gen_tac + \\ Cases_on ‘ALL_DISTINCT (MAP FST moves)’ \\ strip_tac \\ gvs [flat_exp_conventions_def] + \\ pairarg_tac \\ gvs [] + \\ gvs [canonicalMoveRegs3_def] + \\ ‘rs' = MAP (λ(a,b). (a,canonicalRegs data b)) moves’ by gvs [AllCaseEqs()] + \\ gvs [evaluate_def, MAP_FST_lemma] + \\ Cases_on ‘get_vars (MAP SND moves) s’ \\ gvs [] + \\ drule_all MAP_SND_lemma + \\ strip_tac \\ gvs [] + \\ gvs [AllCaseEqs()] + (*\\ gvs [EVERY_MEM, FORALL_PROD]*) + \\ pop_assum kall_tac + \\ pop_assum kall_tac + \\ rpt (pop_assum mp_tac) + \\ qid_spec_tac ‘data’ + \\ qid_spec_tac ‘s’ + \\ qid_spec_tac ‘moves’ + \\ Induct + >- gvs [set_vars_def, canonicalMoveRegs_aux_def, alist_insert_def, data_inv_locals] + \\ rpt strip_tac + \\ gvs [] + \\ Cases_on ‘h’ \\ gvs [] + \\ gvs [canonicalMoveRegs_aux_def] + \\ Cases_on ‘EVEN q’ \\ gvs [set_vars_def] + + \\ cheat QED Theorem comp_Inst_correct: @@ -289,8 +423,16 @@ QED Theorem comp_Set_correct: ^(get_goal "wordLang$Set") Proof - cheat - (*gvs[word_cse_def, data_inv_def]*) + rpt gen_tac + \\ strip_tac + \\ gvs [word_cse_def, evaluate_def] + \\ Cases_on ‘exp’ \\ gvs [flat_exp_conventions_def] + \\ Cases_on ‘v=CurrHeap’ \\ gvs [evaluate_def] + \\ Cases_on ‘v = Handler ∨ v = BitmapBase’ \\ gvs [word_exp_def] + \\ strip_tac + \\ Cases_on ‘lookup n s.locals’ \\ gvs [set_store_def, get_var_def] + \\ gvs [data_inv_def, get_var_def] + \\ rpt strip_tac \\ first_x_assum drule_all \\ gvs [] QED Theorem comp_OpCurrHeap_correct: @@ -317,22 +459,20 @@ QED Theorem comp_MustTerminate_correct: ^(get_goal "MustTerminate") Proof - rpt gen_tac \\ - strip_tac \\ - rpt gen_tac \\ - gs[word_cse_def] \\ - pairarg_tac \\ gvs [evaluate_def,flat_exp_conventions_def] \\ - gvs [AllCaseEqs()] \\ - strip_tac - >- (gvs [evaluate_def] \\ - pairarg_tac \\ gvs []) \\ - pairarg_tac \\ gvs [] \\ - first_x_assum (drule_at Any) \\ - impl_tac - >- fs [data_inv_def, get_var_def, SF SFY_ss] \\ - fs [evaluate_def] \\ - rw [] \\ - gvs [AllCaseEqs(), data_inv_def, get_var_def, SF SFY_ss] + rpt gen_tac + \\ strip_tac + \\ rpt gen_tac + \\ gs[word_cse_def] + \\ pairarg_tac \\ gvs [evaluate_def,flat_exp_conventions_def] + \\ gvs [AllCaseEqs()] + \\ strip_tac + \\ pairarg_tac \\ gvs [] + \\ first_x_assum (drule_at Any) + \\ impl_tac + >- (gvs [data_inv_def, get_var_def, SF SFY_ss] \\ Cases_on ‘res' = SOME TimeOut’ \\ gvs []) + \\ gvs [evaluate_def] + \\ rw [] + \\ gvs [AllCaseEqs(), data_inv_def, get_var_def, SF SFY_ss] QED Theorem comp_Seq_correct: @@ -437,7 +577,7 @@ Proof \\ rpt gen_tac \\ cheat (* never end - gvs[word_cse_def, data_inv_def, empty_data_def, lookup_def] + gvs [data_inv_def] *) QED diff --git a/compiler/backend/word_cseScript.sml b/compiler/backend/word_cseScript.sml index 8d9de9fe04..6c1b085434 100644 --- a/compiler/backend/word_cseScript.sml +++ b/compiler/backend/word_cseScript.sml @@ -55,20 +55,6 @@ Definition listCmp_def: (listCmp [] (hd2::tl2) = Less) End -Theorem listCmpEq_correct: - ∀L1 L2. listCmp L1 L2 = Equal ⇔ L1 = L2 -Proof - strip_tac - \\Induct_on ‘L1’ - >- (Cases_on ‘L2’ - \\ rw[listCmp_def]) - >- (Cases_on ‘L2’ - >- rw[listCmp_def] - >- (strip_tac >> - Cases_on ‘h=h'’ - \\ rw[listCmp_def])) -QED - Definition empty_data_def: empty_data = <| n:=0; inst_eq:=[]; @@ -200,23 +186,26 @@ Move [(1,can 2);(2,can 3);(3,can 1)] Knowledge : 1 ⇔ can 2 / 2 ⇔ can 3 / 3 ⇔ can 1 *) -Definition canonicalExp_def: - canonicalExp data e = e +Definition canonicalMoveRegs_aux_def: + canonicalMoveRegs_aux data [] = data ∧ + canonicalMoveRegs_aux data ((r1,r2)::tl) = + if EVEN r1 then canonicalMoveRegs_aux data tl + else let och_map' = sptree$insert r1 r2 data.och_map in + let all_names' = sptree$insert r1 () data.all_names in + let data' = data with <| och_map := och_map'; all_names := all_names' |> in + canonicalMoveRegs_aux data' tl End -Definition canonicalMultExp_def: - canonicalMultExp data [] = [] ∧ - canonicalMultExp data (hd::tl) = - (canonicalExp data hd)::(canonicalMultExp data tl) +Definition canonicalMoveRegs3_def: + canonicalMoveRegs3 data moves = + let moves' = MAP (λ(a,b). (a, canonicalRegs data b)) moves in + if EXISTS (λ(a,b). is_seen a data) moves then (empty_data, moves') + else (canonicalMoveRegs_aux data moves', moves') End Definition canonicalExp_def: - canonicalExp data (Const w) = Const w ∧ canonicalExp data (Var r) = Var (canonicalRegs data r) ∧ - canonicalExp data (Lookup s) = Lookup s ∧ - canonicalExp data (Load e) = Load (canonicalExp data e) ∧ - canonicalExp data (Op op nl) = Op op (canonicalMultExp data nl) ∧ - canonicalExp data (Shift s e n) = Shift s (canonicalExp data e) n + canonicalExp data exp = exp End Definition canonicalArith_def: @@ -613,7 +602,7 @@ Definition word_cse_def: (word_cse (data:knowledge) (Skip) = (data, Skip)) ∧ (word_cse data (Move r rs) = - let (data', rs') = canonicalMoveRegs2 data rs in + let (data', rs') = canonicalMoveRegs3 data rs in (data', Move r rs')) ∧ (word_cse data (Inst i) = let (data', p) = word_cseInst data i in @@ -624,7 +613,10 @@ Definition word_cse_def: if is_seen r data then (empty_data, Get r x) else (data, Get r x)) ∧ (word_cse data (Set x e) = let e' = canonicalExp data e in - (data with <|och_map:=LN; och_instrs:=empty listCmp|>, Set x e')) ∧ + if x = CurrHeap then + (empty_data, Set x e') + else + (data, Set x e'))∧ (word_cse data (Store e r) = (data, Store e r)) ∧ (word_cse data (MustTerminate p) = From 57a9af910c503f93564715d3c45d8f5ba5b65e26 Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Thu, 30 Jun 2022 16:32:00 +0200 Subject: [PATCH 16/36] merge of och and inst data --- .../backend/proofs/word_cseProofScript.sml | 169 ++++++++++++------ compiler/backend/word_cseScript.sml | 53 +++--- 2 files changed, 130 insertions(+), 92 deletions(-) diff --git a/compiler/backend/proofs/word_cseProofScript.sml b/compiler/backend/proofs/word_cseProofScript.sml index 296bed11d3..6cea6011d0 100644 --- a/compiler/backend/proofs/word_cseProofScript.sml +++ b/compiler/backend/proofs/word_cseProofScript.sml @@ -10,19 +10,20 @@ val _ = set_grammar_ancestry ["wordLang", "wordSem", "wordProps", "word_cse"]; Definition data_inv_def: data_inv (data:knowledge) (s:('a,'c,'ffi) wordSem$state) ⇔ - (∀r v. lookup r data.inst_map = SOME v ⇒ + (∀r v. lookup r data.map = SOME v ⇒ get_var r s = get_var v s ∧ - v IN domain data.all_names ∧ r IN domain data.all_names) ∧ - (∀r v. lookup r data.och_map = SOME v ⇒ - get_var r s = get_var v s ∧ - v IN domain data.all_names ∧ r IN domain data.all_names) ∧ - (∀n c v. lookup data.inst_instrs (instToNumList (Const n c)) = SOME v ⇒ + v IN domain data.all_names ∧ + r IN domain data.all_names) ∧ + (∀n c v. lookup data.instrs (instToNumList (Const n c)) = SOME v ⇒ lookup v s.locals = SOME (Word c) ∧ v IN domain data.all_names) ∧ - (∀(a:'a arith) v. lookup data.inst_instrs (instToNumList (Arith a)) = SOME v ⇒ + (∀(a:'a arith) v. lookup data.instrs (instToNumList (Arith a)) = SOME v ⇒ get_var v s = get_var (firstRegOfArith a) s ∧ v IN domain data.all_names ∧ firstRegOfArith a IN domain data.all_names) ∧ - map_ok data.inst_instrs + (∀op src dst v. lookup data.instrs (progToNumList (OpCurrHeap op dst src : 'a prog)) = SOME v ⇒ + get_var v s = get_var dst s ∧ + v IN domain data.all_names ∧ dst IN domain data.all_names) ∧ + map_ok data.instrs (* (∀r (c:'a word) x v. lookup data.inst_instrs (instToNumList (Const r c)) = SOME x ⇒ x IN domain data.all_names ∧ get_var x s = SOME (Word c)) ∧ @@ -36,11 +37,10 @@ End Theorem canonicalRegs_correct[simp]: ∀data r s. data_inv data s ⇒ get_var (canonicalRegs data r) s = get_var r s Proof - rpt strip_tac \\ - gvs [data_inv_def, canonicalRegs_def] \\ - fs [lookup_any_def] \\ - Cases_on ‘lookup r data.inst_map’ \\ fs [] \\ - Cases_on ‘lookup r data.och_map’ \\ fs [] + rpt strip_tac + \\ gvs [data_inv_def, canonicalRegs_def] + \\ fs [lookup_any_def] + \\ Cases_on ‘lookup r data.map’ \\ fs [] QED Theorem canonicalRegs_correct_bis[simp]: @@ -49,8 +49,7 @@ Proof rpt strip_tac \\ gvs [data_inv_def, canonicalRegs_def] \\ fs [lookup_any_def] - \\ Cases_on ‘lookup r data.inst_map’ \\ fs [get_var_def] - \\ Cases_on ‘lookup r data.och_map’ \\ fs [get_var_def] + \\ Cases_on ‘lookup r data.map’ \\ fs [get_var_def] QED Theorem canonicalArith_correct[simp]: @@ -88,12 +87,11 @@ Proof QED Theorem not_in_all_names_impl: - ∀r data s. data_inv data s ⇒ ¬is_seen r data ⇒ lookup r data.inst_map = NONE ∧ lookup r data.och_map = NONE + ∀r data s. data_inv data s ⇒ ¬is_seen r data ⇒ lookup r data.map = NONE Proof rpt strip_tac \\ gvs [data_inv_def, is_seen_def] \\ Cases_on ‘lookup r data.all_names’ \\ gvs [] - >- (Cases_on ‘lookup r data.inst_map’ \\ gvs [] \\ first_x_assum drule_all \\ strip_tac \\ gvs [domain_lookup]) - \\ Cases_on ‘lookup r data.och_map’ \\ gvs [] \\ first_x_assum drule_all \\ strip_tac \\ gvs [domain_lookup] + \\ Cases_on ‘lookup r data.map’ \\ gvs [] \\ first_x_assum drule_all \\ strip_tac \\ gvs [domain_lookup] QED Theorem data_inv_locals: @@ -104,11 +102,13 @@ Proof \\ rpt strip_tac \\ first_x_assum drule_all \\ strip_tac \\ gvs [] QED -Theorem not_seen_data_inv_insert[simp]: - ∀data s r v. ¬is_seen r data ⇒ data_inv data (s with locals := insert r v s.locals) = data_inv data s +Theorem not_seen_data_inv_alist_insert[simp]: + ∀data s l r v. + ¬is_seen r data ⇒ + data_inv data (s with locals := insert r v l) = + data_inv data (s with locals := l) Proof rpt strip_tac - \\ eq_tac \\ cheat QED @@ -239,36 +239,67 @@ Proof \\ Cases_on ‘get_vars (MAP SND moves) s’ \\ gvs [] QED +Theorem data_inv_insert[local]: + ∀moves data s q h t. + ¬MEM q (MAP FST moves) ⇒ + ¬is_seen q data ⇒ + data_inv (canonicalMoveRegs_aux data (MAP (λ(a,b). (a,canonicalRegs data b)) moves)) + (s with locals := insert q h (alist_insert (MAP FST moves) t s.locals)) = + data_inv (canonicalMoveRegs_aux data (MAP (λ(a,b). (a,canonicalRegs data b)) moves)) + (s with locals := alist_insert (MAP FST moves) t s.locals) +Proof + cheat +QED + Theorem comp_Move_correct: ^(get_goal "Move") Proof - gen_tac \\ gen_tac + rpt gen_tac \\ strip_tac \\ gvs [evaluate_def, word_cse_def] - \\ rpt gen_tac - \\ Cases_on ‘ALL_DISTINCT (MAP FST moves)’ \\ strip_tac \\ gvs [flat_exp_conventions_def] - \\ pairarg_tac \\ gvs [] - \\ gvs [canonicalMoveRegs3_def] + \\ Cases_on ‘ALL_DISTINCT (MAP FST moves)’ \\ gvs [flat_exp_conventions_def] + \\ Cases_on ‘get_vars (MAP SND moves) s’ \\ gvs [] + \\ pairarg_tac \\ gvs [canonicalMoveRegs3_def] \\ ‘rs' = MAP (λ(a,b). (a,canonicalRegs data b)) moves’ by gvs [AllCaseEqs()] \\ gvs [evaluate_def, MAP_FST_lemma] - \\ Cases_on ‘get_vars (MAP SND moves) s’ \\ gvs [] \\ drule_all MAP_SND_lemma \\ strip_tac \\ gvs [] \\ gvs [AllCaseEqs()] (*\\ gvs [EVERY_MEM, FORALL_PROD]*) - \\ pop_assum kall_tac - \\ pop_assum kall_tac \\ rpt (pop_assum mp_tac) \\ qid_spec_tac ‘data’ \\ qid_spec_tac ‘s’ + \\ qid_spec_tac ‘x’ \\ qid_spec_tac ‘moves’ \\ Induct >- gvs [set_vars_def, canonicalMoveRegs_aux_def, alist_insert_def, data_inv_locals] \\ rpt strip_tac - \\ gvs [] \\ Cases_on ‘h’ \\ gvs [] \\ gvs [canonicalMoveRegs_aux_def] \\ Cases_on ‘EVEN q’ \\ gvs [set_vars_def] - + >- (rpt gen_tac + \\ Cases_on ‘x’ \\ gvs [alist_insert_def] + >- (gvs [get_vars_def] + \\ Cases_on ‘get_var r s’ \\ gvs [] + \\ Cases_on ‘get_vars (MAP SND (MAP (λ(a,b). (a,canonicalRegs data b)) moves)) s’ \\ gvs []) + \\ gvs [data_inv_insert] + \\ last_x_assum irule \\ gvs [get_vars_def] + \\ Cases_on ‘get_var r s’ \\ gvs [] + \\ Cases_on ‘get_vars (MAP SND (MAP (λ(a,b). (a,canonicalRegs data b)) moves)) s’ \\ gvs [] + \\ rpt (first_x_assum mp_tac) + \\ qid_spec_tac ‘t’ + \\ Induct_on ‘moves’ \\ gvs [] + \\ rpt strip_tac + \\ Cases_on ‘get_vars (SND h'::MAP SND moves) s’ \\ gvs [] + ) + \\ Cases_on ‘x’ \\ gvs [alist_insert_def] + \\ gvs [get_vars_def] + \\ Cases_on ‘get_var r s’ \\ gvs [] + \\ Cases_on ‘get_vars (MAP SND (MAP (λ(a,b). (a,canonicalRegs data b)) moves)) s’ \\ gvs [] + \\ gvs [data_inv_def] \\ rpt strip_tac + >- (first_x_assum (drule_at Any) \\ strip_tac \\ gvs [get_var_def, lookup_insert] + \\ Cases_on ‘r' = q’ \\ gvs [] + \\ Cases_on ‘v = q’ \\ gvs [] \\ cheat) + (* Proof hard stuck *) \\ cheat QED @@ -290,7 +321,7 @@ Proof \\ Cases_on ‘is_seen n data’ \\ gvs [evaluate_def] >- gvs [data_inv_def, empty_data_def, lookup_def] \\ gvs [is_seen_def] \\ Cases_on ‘lookup n data.all_names’ \\ gvs [] - \\ Cases_on ‘lookup data.inst_instrs (instToNumList (Const n c))’ \\ gvs[evaluate_def] + \\ Cases_on ‘lookup data.instrs (instToNumList (Const n c))’ \\ gvs[evaluate_def] >- ( Cases_on ‘inst (Const n c) s’ \\ gvs [data_inv_def, inst_def, assign_def] \\ Cases_on ‘word_exp s (Const c)’ \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, word_exp_def] @@ -298,20 +329,21 @@ Proof >- (rpt gen_tac \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [] \\ strip_tac \\ first_x_assum drule_all \\ rw []) \\ strip_tac - >- (rpt gen_tac \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [] - \\ strip_tac \\ first_x_assum drule_all \\ rw []) - \\ strip_tac - >- ( rpt gen_tac \\ gvs [mlmapTheory.lookup_insert] - \\ Cases_on ‘c = c'’ \\ gvs [instToNumList_def, wordToNum_def] - \\ strip_tac \\ first_x_assum drule_all - \\ strip_tac - \\ Cases_on ‘v = n’ \\ gvs []) - \\ rpt gen_tac \\ gvs [instToNumList_def, arithToNumList_def, mlmapTheory.lookup_insert] + >- (rpt gen_tac \\ gvs [mlmapTheory.lookup_insert] + \\ Cases_on ‘c = c'’ \\ gvs [instToNumList_def, wordToNum_def] + \\ strip_tac \\ first_x_assum drule_all + \\ strip_tac + \\ Cases_on ‘v = n’ \\ gvs []) \\ strip_tac - \\ first_assum drule_all - \\ strip_tac - \\ Cases_on ‘v=n’ \\ gvs [] - \\ Cases_on ‘firstRegOfArith a = n’ \\ gvs [] + >- (rpt gen_tac \\ gvs [instToNumList_def, arithToNumList_def, mlmapTheory.lookup_insert] + \\ strip_tac + \\ first_assum drule_all + \\ strip_tac + \\ Cases_on ‘v=n’ \\ gvs [] + \\ Cases_on ‘firstRegOfArith a = n’ \\ gvs []) + \\ rpt gen_tac \\ strip_tac + \\ gvs [mlmapTheory.lookup_insert, instToNumList_def, progToNumList_def] + \\ first_x_assum drule_all \\ strip_tac \\ gvs [] ) \\ Cases_on ‘inst (Const n c) s’ \\ gvs [inst_def, assign_def, word_exp_def] \\ strip_tac @@ -327,27 +359,25 @@ Proof \\ first_x_assum drule_all \\ strip_tac \\ gvs [] \\ Cases_on ‘v = n’ \\ gvs [domain_lookup]) \\ strip_tac - >- (first_x_assum drule_all \\ strip_tac - \\ rpt gen_tac \\ strip_tac - \\ first_x_assum drule_all \\ strip_tac \\ gvs [] - \\ gvs [set_var_def, get_var_def, lookup_insert] - \\ Cases_on ‘r = n’ \\ Cases_on ‘v = n’ \\ gvs [domain_lookup]) - \\ rpt gen_tac \\ strip_tac >- (first_assum drule_all \\ strip_tac \\ rpt gen_tac \\ strip_tac \\ first_x_assum drule_all \\ strip_tac \\ gvs [set_var_def, lookup_insert, domain_lookup] \\ Cases_on ‘v=n’ \\ gvs [] ) - \\ first_assum drule_all \\ strip_tac \\ rpt gen_tac \\ strip_tac \\ first_x_assum drule_all - \\ strip_tac \\ gvs [set_var_def, get_var_def, lookup_insert, domain_lookup] - \\ Cases_on ‘v = n’ \\ gvs [] - \\ Cases_on ‘firstRegOfArith a = n’ \\ gvs [] + \\ strip_tac + >- (first_assum drule_all \\ strip_tac \\ rpt gen_tac \\ strip_tac \\ first_x_assum drule_all + \\ strip_tac \\ gvs [set_var_def, get_var_def, lookup_insert, domain_lookup] + \\ Cases_on ‘v = n’ \\ gvs [] + \\ Cases_on ‘firstRegOfArith a = n’ \\ gvs []) + \\ first_x_assum drule_all \\ strip_tac + \\ rpt gen_tac \\ strip_tac + \\ first_x_assum drule_all \\ strip_tac \\ gvs[get_var_def, set_var_def, lookup_insert] + \\ Cases_on ‘v=n’ \\ Cases_on ‘dst=n’ \\ gvs [domain_lookup] ) >- (* Arith *) ( gvs [word_cse_def, word_cseInst_def] \\ pairarg_tac \\ gvs [] \\ Cases_on ‘is_seen (firstRegOfArith a) data’ \\ gvs [] - >- gvs [data_inv_def, empty_data_def, lookup_def] - \\ Cases_on ‘lookup data.inst_instrs (instToNumList (Arith (canonicalArith data a)))’ \\ gvs [evaluate_def] + \\ Cases_on ‘lookup data.instrs (instToNumList (Arith (canonicalArith data a)))’ \\ gvs [evaluate_def] >- ( strip_tac \\ cases_on ‘inst (Arith a) s’ \\ gvs [] \\ gvs [data_inv_def] \\ strip_tac @@ -377,7 +407,7 @@ Proof \\ Cases_on ‘h'’ \\ gvs [] \\ Cases_on ‘h’ \\ gvs [] \\ Cases_on ‘t'’ \\ gvs [] - \\ gvs [lookup_insert] + \\ gvs [lookup_insert] \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [word_exp_def] \\ gvs [firstRegOfArith_def, is_seen_def, domain_lookup] \\ Cases_on ‘r=n0’ \\ Cases_on ‘v=n0’ \\ gvs [word_exp_def] @@ -438,7 +468,28 @@ QED Theorem comp_OpCurrHeap_correct: ^(get_goal "OpCurrHeap") Proof - cheat + rpt gen_tac \\ strip_tac + \\ gvs [evaluate_def, word_cse_def] + \\ Cases_on ‘word_exp s (Op b [Var src; Lookup CurrHeap])’ \\ gvs [] + \\ Cases_on ‘lookup dst data.all_names ≠ NONE’ \\ gvs [evaluate_def] + \\ Cases_on ‘lookup data.instrs (progToNumList (OpCurrHeap b dst (canonicalRegs data src)))’ + \\ gvs [evaluate_def, word_exp_def] + >- (gvs [the_words_def] + \\ Cases_on ‘lookup src s.locals’ \\ gvs [] + \\ Cases_on ‘x'’ \\ gvs [] + \\ Cases_on ‘FLOOKUP s.store CurrHeap’ \\ gvs [] + \\ Cases_on ‘x'’ \\ gvs [] + + \\ gvs [data_inv_def] + \\ strip_tac + >- (rpt gen_tac \\ strip_tac \\ first_x_assum drule_all \\ strip_tac + \\ gvs [get_var_def, set_var_def, lookup_insert] + \\ Cases_on ‘r = dst’ \\ Cases_on ‘v = dst’ \\ gvs [] + \\ cheat + ) + \\ cheat + ) + \\ cheat QED Theorem comp_Store_correct: diff --git a/compiler/backend/word_cseScript.sml b/compiler/backend/word_cseScript.sml index 6c1b085434..d538835905 100644 --- a/compiler/backend/word_cseScript.sml +++ b/compiler/backend/word_cseScript.sml @@ -29,12 +29,9 @@ Type regsE = ``:num list list`` Type regsM = ``:num num_map`` Type instrsM = ``:(num list,num)map`` -val _ = Datatype `knowledge = <| n:num; - inst_eq:regsE; - inst_map:regsM; - inst_instrs:instrsM; - och_map:regsM; - och_instrs:instrsM; +val _ = Datatype `knowledge = <| eq:regsE; + map:regsM; + instrs:instrsM; all_names:num_set |>`; (* add a (all_names:num_set) ⇒ when seeing a new register, add it in all_names @@ -56,12 +53,9 @@ Definition listCmp_def: End Definition empty_data_def: - empty_data = <| n:=0; - inst_eq:=[]; - inst_map:=LN; - inst_instrs:=empty listCmp; - och_map:=LN; - och_instrs:=empty listCmp; + empty_data = <| eq:=[]; + map:=LN; + instrs:=empty listCmp; all_names:=LN |> End @@ -123,14 +117,7 @@ End Definition canonicalRegs_def: canonicalRegs (data:knowledge) (r:num) = - lookup_any r data.inst_map (lookup_any r data.och_map r) -(* - case sptree$lookup r data.inst_map of - | SOME r' => r' - | NONE => case sptree$lookup r data.och_map of - | NONE => r - | SOME r' => r' -*) + lookup_any r data.map r End Definition canonicalImmReg_def: @@ -141,7 +128,7 @@ End Definition canonicalMultRegs_def: canonicalMultRegs (data:knowledge) (regs:num list) = MAP (canonicalRegs data) regs End - +(* Definition canonicalMoveRegs_def: canonicalMoveRegs data [] = (data, []) ∧ canonicalMoveRegs data ((r1,r2)::tl) = @@ -179,7 +166,7 @@ Definition canonicalMoveRegs2_def: let (data', tl') = canonicalMoveRegs2 (data with <| inst_eq:=inst_eq'; inst_map:=inst_map' |>) tl in (data', (r1,r2')::tl') End - +*) (* Move [(1,2);(2,3);(3,1)] Move [(1,can 2);(2,can 3);(3,can 1)] @@ -190,9 +177,9 @@ Definition canonicalMoveRegs_aux_def: canonicalMoveRegs_aux data [] = data ∧ canonicalMoveRegs_aux data ((r1,r2)::tl) = if EVEN r1 then canonicalMoveRegs_aux data tl - else let och_map' = sptree$insert r1 r2 data.och_map in + else let map' = sptree$insert r1 r2 data.map in let all_names' = sptree$insert r1 () data.all_names in - let data' = data with <| och_map := och_map'; all_names := all_names' |> in + let data' = data with <| map := map'; all_names := all_names' |> in canonicalMoveRegs_aux data' tl End @@ -549,17 +536,17 @@ Definition word_cseInst_def: if is_seen r data then (empty_data, Inst (Const r w)) else let data = data with <| all_names:=insert r () data.all_names |> in let i = instToNumList (Const r w) in - case mlmap$lookup data.inst_instrs i of - | SOME r' => (data with <| inst_eq:=regsUpdate r' r data.inst_eq; inst_map:=insert r r' data.inst_map |>, Move 0 [(r,r')]) - | NONE => (data with inst_instrs:=insert data.inst_instrs i r, Inst (Const r w))) ∧ + case mlmap$lookup data.instrs i of + | SOME r' => (data with <| eq:=regsUpdate r' r data.eq; map:=insert r r' data.map |>, Move 0 [(r,r')]) + | NONE => (data with instrs:=insert data.instrs i r, Inst (Const r w))) ∧ (word_cseInst data (Arith a) = let r = firstRegOfArith a in if is_seen r data then (empty_data, Inst (Arith a)) else let a' = canonicalArith data a in let i = instToNumList (Arith a') in - case mlmap$lookup data.inst_instrs i of - | SOME r' => (data with <| inst_eq:=regsUpdate r' r data.inst_eq; inst_map:=insert r r' data.inst_map; all_names:=insert r () data.all_names |>, Move 0 [(r,r')]) - | NONE => (data with <| inst_instrs:=insert data.inst_instrs i r; all_names:=insert r () data.all_names |>, Inst (Arith a'))) ∧ + case mlmap$lookup data.instrs i of + | SOME r' => (data with <| eq:=regsUpdate r' r data.eq; map:=insert r r' data.map; all_names:=insert r () data.all_names |>, Move 0 [(r,r')]) + | NONE => (data with <| instrs:=insert data.instrs i r; all_names:=insert r () data.all_names |>, Inst (Arith a'))) ∧ (word_cseInst data (Mem op r (Addr r' w)) = (empty_data, Inst (Mem op r (Addr r' w))) (* !!! meaning difference of r between Load and Store @@ -647,9 +634,9 @@ Definition word_cse_def: if sptree$lookup r1 data.all_names ≠ NONE then (empty_data, OpCurrHeap b r1 r2) else let r2' = canonicalRegs data r2 in let pL = progToNumList ((OpCurrHeap b r1 r2'):'a prog) in - case lookup data.och_instrs pL of - | NONE => (data with och_instrs:=(insert data.och_instrs pL r1), OpCurrHeap b r1 r2') - | SOME r1' => (data with <| n:=data.n+1; och_map:=(insert r1 r1' data.och_map) |>, Move 0 [(r1, r1')])) ∧ + case lookup data.instrs pL of + | NONE => (data with instrs:=(insert data.instrs pL r1), OpCurrHeap b r1 r2') + | SOME r1' => (data with <| map:=(insert r1 r1' data.map) |>, Move 0 [(r1, r1')])) ∧ (word_cse data (LocValue r l) = if is_seen r data then (empty_data, LocValue r l) else (data, LocValue r l)) ∧ (word_cse data (Install p l dp dl m) = From 5307eb4741b5dc6bb4f2a392a3ffb78f77f31ea7 Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Fri, 1 Jul 2022 18:39:06 +0200 Subject: [PATCH 17/36] Improvement of data_inv and of word_cse --- .../backend/proofs/word_cseProofScript.sml | 99 ++++++++++++++----- compiler/backend/word_cseScript.sml | 84 ++++++++++------ 2 files changed, 128 insertions(+), 55 deletions(-) diff --git a/compiler/backend/proofs/word_cseProofScript.sml b/compiler/backend/proofs/word_cseProofScript.sml index 6cea6011d0..102df0cb6e 100644 --- a/compiler/backend/proofs/word_cseProofScript.sml +++ b/compiler/backend/proofs/word_cseProofScript.sml @@ -18,11 +18,14 @@ Definition data_inv_def: lookup v s.locals = SOME (Word c) ∧ v IN domain data.all_names) ∧ (∀(a:'a arith) v. lookup data.instrs (instToNumList (Arith a)) = SOME v ⇒ - get_var v s = get_var (firstRegOfArith a) s ∧ - v IN domain data.all_names ∧ firstRegOfArith a IN domain data.all_names) ∧ - (∀op src dst v. lookup data.instrs (progToNumList (OpCurrHeap op dst src : 'a prog)) = SOME v ⇒ - get_var v s = get_var dst s ∧ - v IN domain data.all_names ∧ dst IN domain data.all_names) ∧ + v IN domain data.all_names ∧ + ¬is_complex a ∧ + ∃w. get_var v s = SOME w ∧ + evaluate (Inst (Arith a), s) = (NONE, set_var (firstRegOfArith a) w s)) ∧ + (∀op src v. lookup data.instrs (OpCurrHeapToNumList op src) = SOME v ⇒ + v IN domain data.all_names ∧ + ∃w. word_exp s (Op op [Var src; Lookup CurrHeap]) = SOME w ∧ + get_var v s = SOME w) ∧ map_ok data.instrs (* (∀r (c:'a word) x v. lookup data.inst_instrs (instToNumList (Const r c)) = SOME x ⇒ @@ -58,7 +61,10 @@ Proof rpt gen_tac \\ strip_tac \\ Cases_on ‘a’ \\ gvs [canonicalArith_def, inst_def, assign_def, word_exp_def, the_words_def] - \\ cheat + >- (Cases_on ‘lookup n0 s.locals’ \\ gvs [] + \\ Cases_on ‘x’ \\ gvs [] + \\ Cases_on ‘r’ \\ gvs [canonicalImmReg_def, word_exp_def]) + \\ gvs [get_vars_def] QED Theorem canonicalExp_correct[simp]: @@ -94,19 +100,18 @@ Proof \\ Cases_on ‘lookup r data.map’ \\ gvs [] \\ first_x_assum drule_all \\ strip_tac \\ gvs [domain_lookup] QED -Theorem data_inv_locals: - ∀data s. data_inv data s ⇒ data_inv data (s with locals := s.locals) +Theorem data_inv_locals[simp]: + ∀s. s with locals := s.locals = s Proof rpt gen_tac - \\ gvs [data_inv_def, get_var_def] \\ strip_tac \\ gvs [] - \\ rpt strip_tac \\ first_x_assum drule_all \\ strip_tac \\ gvs [] + \\ gvs [state_component_equality] QED Theorem not_seen_data_inv_alist_insert[simp]: ∀data s l r v. ¬is_seen r data ⇒ - data_inv data (s with locals := insert r v l) = - data_inv data (s with locals := l) + data_inv data (s with locals := l) ⇒ + data_inv data (s with locals := insert r v l) Proof rpt strip_tac \\ cheat @@ -244,11 +249,25 @@ Theorem data_inv_insert[local]: ¬MEM q (MAP FST moves) ⇒ ¬is_seen q data ⇒ data_inv (canonicalMoveRegs_aux data (MAP (λ(a,b). (a,canonicalRegs data b)) moves)) - (s with locals := insert q h (alist_insert (MAP FST moves) t s.locals)) = + (s with locals := alist_insert (MAP FST moves) t s.locals) ⇒ data_inv (canonicalMoveRegs_aux data (MAP (λ(a,b). (a,canonicalRegs data b)) moves)) - (s with locals := alist_insert (MAP FST moves) t s.locals) + (s with locals := insert q h (alist_insert (MAP FST moves) t s.locals)) Proof - cheat + Induct + >- gvs [alist_insert_def, canonicalMoveRegs_aux_def] + \\ rpt strip_tac + \\ Cases_on ‘h’ \\ gvs [] + \\ Cases_on ‘t’ \\ gvs [] + >- (‘∀data s q h. + ¬MEM q (MAP FST moves) ⇒ + ¬is_seen q data ⇒ + data_inv (canonicalMoveRegs_aux data (MAP (λ(a,b). (a,canonicalRegs data b)) moves)) + (s with locals := alist_insert (MAP FST moves) [] s.locals) ⇒ + data_inv (canonicalMoveRegs_aux data (MAP (λ(a,b). (a,canonicalRegs data b)) moves)) + (s with locals := insert q h (alist_insert (MAP FST moves) [] s.locals))’ + by gvs [] \\ cheat) + \\ cheat + (* may be false, may need more assumptions like ‘get_vars (MAP SND moves) s = t’ *) QED Theorem comp_Move_correct: @@ -275,13 +294,15 @@ Proof \\ rpt strip_tac \\ Cases_on ‘h’ \\ gvs [] \\ gvs [canonicalMoveRegs_aux_def] - \\ Cases_on ‘EVEN q’ \\ gvs [set_vars_def] - >- (rpt gen_tac + \\ IF_CASES_TAC + >- (pop_assum kall_tac + \\ gvs [set_vars_def] + \\ rpt gen_tac \\ Cases_on ‘x’ \\ gvs [alist_insert_def] >- (gvs [get_vars_def] \\ Cases_on ‘get_var r s’ \\ gvs [] \\ Cases_on ‘get_vars (MAP SND (MAP (λ(a,b). (a,canonicalRegs data b)) moves)) s’ \\ gvs []) - \\ gvs [data_inv_insert] + \\ irule data_inv_insert \\ gvs [] \\ last_x_assum irule \\ gvs [get_vars_def] \\ Cases_on ‘get_var r s’ \\ gvs [] \\ Cases_on ‘get_vars (MAP SND (MAP (λ(a,b). (a,canonicalRegs data b)) moves)) s’ \\ gvs [] @@ -290,9 +311,34 @@ Proof \\ Induct_on ‘moves’ \\ gvs [] \\ rpt strip_tac \\ Cases_on ‘get_vars (SND h'::MAP SND moves) s’ \\ gvs [] - ) - \\ Cases_on ‘x’ \\ gvs [alist_insert_def] - \\ gvs [get_vars_def] + ) + + \\ gvs [set_vars_def, get_vars_def, AllCaseEqs()] + \\ gvs [alist_insert_def] + + \\ qabbrev_tac ‘data1 = data with <|map := insert q (canonicalRegs data r) data.map; + all_names := insert q () data.all_names|>’ + + \\ qsuff_tac ‘data_inv + (canonicalMoveRegs_aux + (data with + <|map := insert q (canonicalRegs data r) data.map; + all_names := insert q () data.all_names|>) + (MAP (λ(a,b). (a,canonicalRegs data b)) moves)) + ((s with locals := insert q x' s.locals) with + locals := (alist_insert (MAP FST moves) xs (s with locals := insert q x' s.locals).locals))’ + >- cheat (* easier *) + \\ cheat + + (* + \\ last_x_assum irule + + \\ ‘data_inv (data with <|map := insert q (canonicalRegs data r) data.map; all_names := insert q () data.all_names|>) + (s with locals := insert q x' s.locals)’ by cheat + \\ last_x_assum drule + \\ disch_then (qspec_then ‘xs’ mp_tac) + \\ impl_tac + \\ Cases_on ‘get_var r s’ \\ gvs [] \\ Cases_on ‘get_vars (MAP SND (MAP (λ(a,b). (a,canonicalRegs data b)) moves)) s’ \\ gvs [] \\ gvs [data_inv_def] \\ rpt strip_tac @@ -301,6 +347,7 @@ Proof \\ Cases_on ‘v = q’ \\ gvs [] \\ cheat) (* Proof hard stuck *) \\ cheat + *) QED Theorem comp_Inst_correct: @@ -342,7 +389,7 @@ Proof \\ Cases_on ‘v=n’ \\ gvs [] \\ Cases_on ‘firstRegOfArith a = n’ \\ gvs []) \\ rpt gen_tac \\ strip_tac - \\ gvs [mlmapTheory.lookup_insert, instToNumList_def, progToNumList_def] + \\ gvs [mlmapTheory.lookup_insert, instToNumList_def, OpCurrHeapToNumList_def] \\ first_x_assum drule_all \\ strip_tac \\ gvs [] ) \\ Cases_on ‘inst (Const n c) s’ \\ gvs [inst_def, assign_def, word_exp_def] @@ -446,7 +493,11 @@ Proof \\ fs [get_var_def, set_var_def] \\ fs [lookup_insert, is_seen_def] \\ Cases_on ‘lookup v data.all_names’ \\ gvs [domain_lookup] - \\ metis_tac [NOT_NONE_SOME] + \\ strip_tac + >- metis_tac [NOT_NONE_SOME] + \\ strip_tac + >- metis_tac [NOT_NONE_SOME] + \\ cheat QED (* similare cases : Loc *) @@ -472,7 +523,7 @@ Proof \\ gvs [evaluate_def, word_cse_def] \\ Cases_on ‘word_exp s (Op b [Var src; Lookup CurrHeap])’ \\ gvs [] \\ Cases_on ‘lookup dst data.all_names ≠ NONE’ \\ gvs [evaluate_def] - \\ Cases_on ‘lookup data.instrs (progToNumList (OpCurrHeap b dst (canonicalRegs data src)))’ + \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs data src))’ \\ gvs [evaluate_def, word_exp_def] >- (gvs [the_words_def] \\ Cases_on ‘lookup src s.locals’ \\ gvs [] diff --git a/compiler/backend/word_cseScript.sml b/compiler/backend/word_cseScript.sml index d538835905..0349380199 100644 --- a/compiler/backend/word_cseScript.sml +++ b/compiler/backend/word_cseScript.sml @@ -176,11 +176,11 @@ Knowledge : 1 ⇔ can 2 / 2 ⇔ can 3 / 3 ⇔ can 1 Definition canonicalMoveRegs_aux_def: canonicalMoveRegs_aux data [] = data ∧ canonicalMoveRegs_aux data ((r1,r2)::tl) = - if EVEN r1 then canonicalMoveRegs_aux data tl - else let map' = sptree$insert r1 r2 data.map in - let all_names' = sptree$insert r1 () data.all_names in - let data' = data with <| map := map'; all_names := all_names' |> in - canonicalMoveRegs_aux data' tl + if EVEN r1 ∨ EVEN r2 then canonicalMoveRegs_aux data tl + else let data' = canonicalMoveRegs_aux data tl in + let map' = sptree$insert r1 r2 data'.map in + let all_names' = sptree$insert r1 () data'.all_names in + data' with <| map := map'; all_names := all_names' |> End Definition canonicalMoveRegs3_def: @@ -483,9 +483,8 @@ Numbers between 0 and 99 corresponds to a unique identifier of an instruction. Numbers above 99 corresponds to a register or a word value. *) (* TODO : redo the rename of instruction numbers such that each is unique *) -Definition progToNumList_def: - progToNumList (Inst i) = 0::(instToNumList i) ∧ - progToNumList (OpCurrHeap op r1 r2) = [1; arithOpToNum op; r2+100] +Definition OpCurrHeapToNumList_def: + OpCurrHeapToNumList op r2 = [1; arithOpToNum op; r2+100] End (* Theorem progToNumList_unique: @@ -530,29 +529,54 @@ Definition firstRegOfFp_def: firstRegOfFp (FPFromInt r _) = r End + +Definition add_to_data_aux_def: + add_to_data_aux data r i x = + case mlmap$lookup data.instrs i of + | SOME r' => (data with <| eq:=regsUpdate r' r data.eq; map:=insert r r' data.map; all_names:=insert r () data.all_names |>, Move 0 [(r,r')]) + | NONE => (data with <| instrs:=insert data.instrs i r; all_names:=insert r () data.all_names |>, x) +End + +Definition add_to_data_def: + add_to_data data r x = + let i = instToNumList x in + add_to_data_aux data r i (Inst x) +End + +Definition is_store_def: + is_store Load = F ∧ + is_store Load8 = F ∧ + is_store Store = T ∧ + is_store Store8 = T +End + +Definition is_complex_def: + is_complex (Binop _ _ _ _) = F ∧ + is_complex (Div _ _ _) = F ∧ + is_complex (Shift _ _ _ _) = F ∧ + is_complex _ = T +End + Definition word_cseInst_def: (word_cseInst (data:knowledge) Skip = (data, Inst Skip)) ∧ (word_cseInst data (Const r w) = if is_seen r data then (empty_data, Inst (Const r w)) else - let data = data with <| all_names:=insert r () data.all_names |> in - let i = instToNumList (Const r w) in - case mlmap$lookup data.instrs i of - | SOME r' => (data with <| eq:=regsUpdate r' r data.eq; map:=insert r r' data.map |>, Move 0 [(r,r')]) - | NONE => (data with instrs:=insert data.instrs i r, Inst (Const r w))) ∧ + add_to_data data r (Const r w)) ∧ (word_cseInst data (Arith a) = - let r = firstRegOfArith a in - if is_seen r data then (empty_data, Inst (Arith a)) else - let a' = canonicalArith data a in - let i = instToNumList (Arith a') in - case mlmap$lookup data.instrs i of - | SOME r' => (data with <| eq:=regsUpdate r' r data.eq; map:=insert r r' data.map; all_names:=insert r () data.all_names |>, Move 0 [(r,r')]) - | NONE => (data with <| instrs:=insert data.instrs i r; all_names:=insert r () data.all_names |>, Inst (Arith a'))) ∧ + let r = firstRegOfArith a in + let a' = canonicalArith data a in + if is_seen r data ∨ is_complex a' then + (empty_data, Inst (Arith a')) + else + add_to_data data r (Arith a')) ∧ (word_cseInst data (Mem op r (Addr r' w)) = - (empty_data, Inst (Mem op r (Addr r' w))) - (* !!! meaning difference of r between Load and Store - if sptree$lookup r data.all_names ≠ NONE then (empty_data, Inst (Mem op r (Addr r' w))) else - (data, Inst (Mem op (canonicalRegs data r) (Addr (canonicalRegs data r') w))) - *) ) ∧ + if is_store op then + (data, Inst (Mem op (canonicalRegs data r) (Addr (canonicalRegs data r') w))) + else + if is_seen r data then + (empty_data, Inst (Mem op r (Addr (canonicalRegs data r') w))) + else + (data, Inst (Mem op r (Addr (canonicalRegs data r') w))) ) ∧ (word_cseInst data ((FP f):'a inst) = (empty_data, Inst (FP f))) (* Not relevant: issue with fp regs having same id as regs, possible confusion @@ -562,7 +586,7 @@ Definition word_cseInst_def: case mlmap$lookup inst_instrs i of | SOME r' => (n+1, regsUpdate r' r inst_eq, insert r r' inst_map, inst_instrs, Move 0 [(r,r')]) | NONE => (n, inst_eq, inst_map, insert inst_instrs i r, Inst (FP f'))) - *) + *) End (* @@ -632,11 +656,9 @@ Definition word_cse_def: (data, Tick)) ∧ (word_cse data ((OpCurrHeap b r1 r2):'a prog) = if sptree$lookup r1 data.all_names ≠ NONE then (empty_data, OpCurrHeap b r1 r2) else - let r2' = canonicalRegs data r2 in - let pL = progToNumList ((OpCurrHeap b r1 r2'):'a prog) in - case lookup data.instrs pL of - | NONE => (data with instrs:=(insert data.instrs pL r1), OpCurrHeap b r1 r2') - | SOME r1' => (data with <| map:=(insert r1 r1' data.map) |>, Move 0 [(r1, r1')])) ∧ + let r2' = canonicalRegs data r2 in + let pL = OpCurrHeapToNumList b r2' in + add_to_data_aux data r1 pL (OpCurrHeap b r1 r2')) ∧ (word_cse data (LocValue r l) = if is_seen r data then (empty_data, LocValue r l) else (data, LocValue r l)) ∧ (word_cse data (Install p l dp dl m) = From 92e438bc188f1f26cbfa3c1c0f6f4a7d5480f2a5 Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Mon, 4 Jul 2022 18:50:42 +0200 Subject: [PATCH 18/36] Starting to fix broken proofs (due to changes of data_inv) --- .../backend/proofs/word_cseProofScript.sml | 57 ++++++++++++------- 1 file changed, 38 insertions(+), 19 deletions(-) diff --git a/compiler/backend/proofs/word_cseProofScript.sml b/compiler/backend/proofs/word_cseProofScript.sml index 102df0cb6e..c7259794ce 100644 --- a/compiler/backend/proofs/word_cseProofScript.sml +++ b/compiler/backend/proofs/word_cseProofScript.sml @@ -364,29 +364,28 @@ Proof \\ first_x_assum (drule_at Any) \\ gvs [] ) >- (* Const *) - ( gvs [evaluate_def, word_cse_def, word_cseInst_def, data_inv_def] + ( gvs [evaluate_def, word_cse_def, word_cseInst_def] \\ Cases_on ‘is_seen n data’ \\ gvs [evaluate_def] - >- gvs [data_inv_def, empty_data_def, lookup_def] \\ gvs [is_seen_def] \\ Cases_on ‘lookup n data.all_names’ \\ gvs [] \\ Cases_on ‘lookup data.instrs (instToNumList (Const n c))’ \\ gvs[evaluate_def] - >- ( Cases_on ‘inst (Const n c) s’ \\ gvs [data_inv_def, inst_def, assign_def] - \\ Cases_on ‘word_exp s (Const c)’ - \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, word_exp_def] + >- ( Cases_on ‘inst (Const n c) s’ \\ gvs [evaluate_def, add_to_data_def, add_to_data_aux_def] + \\ gvs [inst_def, assign_def] + \\ Cases_on ‘word_exp s (Const c)’ \\ gvs [data_inv_def] \\ strip_tac - >- (rpt gen_tac \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [] + >- (rpt gen_tac \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup] + \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [] \\ strip_tac \\ first_x_assum drule_all \\ rw []) \\ strip_tac - >- (rpt gen_tac \\ gvs [mlmapTheory.lookup_insert] - \\ Cases_on ‘c = c'’ \\ gvs [instToNumList_def, wordToNum_def] + >- (rpt gen_tac \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup] + \\ Cases_on ‘c = c'’ \\ gvs [instToNumList_def, wordToNum_def, mlmapTheory.lookup_insert, word_exp_def] \\ strip_tac \\ first_x_assum drule_all - \\ strip_tac - \\ Cases_on ‘v = n’ \\ gvs []) + \\ strip_tac \\ Cases_on ‘v = n’ \\ gvs []) \\ strip_tac >- (rpt gen_tac \\ gvs [instToNumList_def, arithToNumList_def, mlmapTheory.lookup_insert] - \\ strip_tac - \\ first_assum drule_all - \\ strip_tac - \\ Cases_on ‘v=n’ \\ gvs [] + \\ strip_tac \\ first_assum drule_all \\ strip_tac + \\ Cases_on ‘v=n’ \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup] + + \\ Cases_on ‘firstRegOfArith a = n’ \\ gvs []) \\ rpt gen_tac \\ strip_tac \\ gvs [mlmapTheory.lookup_insert, instToNumList_def, OpCurrHeapToNumList_def] @@ -513,7 +512,21 @@ Proof \\ strip_tac \\ Cases_on ‘lookup n s.locals’ \\ gvs [set_store_def, get_var_def] \\ gvs [data_inv_def, get_var_def] - \\ rpt strip_tac \\ first_x_assum drule_all \\ gvs [] + \\ strip_tac + >- (rpt gen_tac \\ strip_tac \\ first_x_assum drule_all \\ strip_tac \\ gvs []) + \\ strip_tac + >- (rpt gen_tac \\ strip_tac \\ first_x_assum drule_all \\ strip_tac \\ gvs []) + \\ strip_tac + >- (rpt gen_tac \\ strip_tac \\ first_x_assum drule_all \\ strip_tac \\ gvs [] + \\ Cases_on ‘a’ \\ gvs [is_complex_def, firstRegOfArith_def] + >- (gvs [evaluate_def, inst_def, assign_def] \\ Cases_on ‘r’ \\ gvs [word_exp_def, the_words_def] + \\ gvs [AllCaseEqs()] + \\ gvs [set_var_def, state_component_equality]) + \\ gvs [evaluate_def, inst_def, assign_def] \\ gvs [word_exp_def, the_words_def, get_vars_def, get_var_def] + \\ gvs [AllCaseEqs()] + \\ gvs [set_var_def, state_component_equality]) + \\ rpt gen_tac \\ strip_tac \\ first_x_assum drule_all \\ strip_tac + \\ gvs [word_exp_def, the_words_def, FLOOKUP_UPDATE] QED Theorem comp_OpCurrHeap_correct: @@ -552,10 +565,16 @@ QED Theorem comp_Tick_correct: ^(get_goal "Tick") Proof - gvs[word_cse_def, data_inv_def, evaluate_def] \\ - rw [] \\ - fs [get_var_def, dec_clock_def] \\ - first_x_assum drule_all \\ gs [] + rpt gen_tac \\ strip_tac + \\ gvs[word_cse_def, evaluate_def] + \\ Cases_on ‘s.clock = 0’ \\ gvs [] + \\ fs [get_var_def, dec_clock_def, data_inv_def] + \\ rw [] + \\ first_assum drule_all \\ gs [] + \\ first_x_assum drule_all \\ strip_tac + \\ Cases_on ‘a’ \\ gvs [is_complex_def] + \\ gvs [evaluate_def, inst_def, firstRegOfArith_def, word_exp_def, the_words_def] + \\ gvs [AllCaseEqs()] QED Theorem comp_MustTerminate_correct: From c8bfef23ee0e88b5eac3616e0fca4bbeface7b4c Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Tue, 5 Jul 2022 13:11:42 +0200 Subject: [PATCH 19/36] Unsuccessful try to patch Inst proof --- .../backend/proofs/word_cseProofScript.sml | 77 +++++++++++++------ 1 file changed, 53 insertions(+), 24 deletions(-) diff --git a/compiler/backend/proofs/word_cseProofScript.sml b/compiler/backend/proofs/word_cseProofScript.sml index c7259794ce..47723222d4 100644 --- a/compiler/backend/proofs/word_cseProofScript.sml +++ b/compiler/backend/proofs/word_cseProofScript.sml @@ -365,58 +365,87 @@ Proof >- (* Const *) ( gvs [evaluate_def, word_cse_def, word_cseInst_def] - \\ Cases_on ‘is_seen n data’ \\ gvs [evaluate_def] - \\ gvs [is_seen_def] \\ Cases_on ‘lookup n data.all_names’ \\ gvs [] + \\ pairarg_tac \\ gvs [] + \\ Cases_on ‘is_seen n data’ \\ gvs [evaluate_def, add_to_data_def, add_to_data_aux_def] \\ Cases_on ‘lookup data.instrs (instToNumList (Const n c))’ \\ gvs[evaluate_def] - >- ( Cases_on ‘inst (Const n c) s’ \\ gvs [evaluate_def, add_to_data_def, add_to_data_aux_def] - \\ gvs [inst_def, assign_def] - \\ Cases_on ‘word_exp s (Const c)’ \\ gvs [data_inv_def] + >- ( gvs [inst_def, assign_def, word_exp_def, data_inv_def] \\ strip_tac - >- (rpt gen_tac \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup] - \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [] - \\ strip_tac \\ first_x_assum drule_all \\ rw []) + >- (rpt gen_tac \\ strip_tac \\ first_x_assum drule_all \\ strip_tac + \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup] + \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [is_seen_def]) \\ strip_tac - >- (rpt gen_tac \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup] + >- (rpt gen_tac \\ gvs [set_var_def, lookup_insert, domain_lookup] \\ Cases_on ‘c = c'’ \\ gvs [instToNumList_def, wordToNum_def, mlmapTheory.lookup_insert, word_exp_def] \\ strip_tac \\ first_x_assum drule_all - \\ strip_tac \\ Cases_on ‘v = n’ \\ gvs []) + \\ strip_tac \\ Cases_on ‘v = n’ \\ gvs [is_seen_def]) \\ strip_tac >- (rpt gen_tac \\ gvs [instToNumList_def, arithToNumList_def, mlmapTheory.lookup_insert] \\ strip_tac \\ first_assum drule_all \\ strip_tac - \\ Cases_on ‘v=n’ \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup] - - - \\ Cases_on ‘firstRegOfArith a = n’ \\ gvs []) - \\ rpt gen_tac \\ strip_tac - \\ gvs [mlmapTheory.lookup_insert, instToNumList_def, OpCurrHeapToNumList_def] - \\ first_x_assum drule_all \\ strip_tac \\ gvs [] + \\ Cases_on ‘v=n’ + >- gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def] + \\ Cases_on ‘a’ \\ gvs [is_complex_def, get_var_def, set_var_def, lookup_insert] + >- (last_x_assum kall_tac + \\ last_x_assum kall_tac + \\ last_x_assum kall_tac + \\ last_x_assum kall_tac + \\ last_x_assum kall_tac + \\ Cases_on ‘n0=n’ + \\ Cases_on ‘r=Reg n’ + >- (cheat) + >- (cheat) + >- (cheat) + >- (cheat) + ) + >- (last_x_assum kall_tac + \\ last_x_assum kall_tac + \\ last_x_assum kall_tac + \\ last_x_assum kall_tac + \\ last_x_assum kall_tac + \\ Cases_on ‘n0=n’ + >- (cheat) + >- (cheat) + ) + \\ last_x_assum kall_tac + \\ last_x_assum kall_tac + \\ last_x_assum kall_tac + \\ last_x_assum kall_tac + \\ last_x_assum kall_tac + \\ Cases_on ‘n0=n’ + \\ Cases_on ‘n1=n’ + >- (cheat) + >- (cheat) + >- (cheat) + >- (cheat) + ) + \\ cheat ) - \\ Cases_on ‘inst (Const n c) s’ \\ gvs [inst_def, assign_def, word_exp_def] + \\ Cases_on ‘inst (Const n c) s’ \\ gvs [inst_def, assign_def, word_exp_def, data_inv_def] \\ strip_tac >- (first_x_assum drule_all \\ strip_tac \\ gvs [get_vars_def, get_var_def, set_vars_def, alist_insert_def, set_var_def]) \\ strip_tac >- (first_x_assum drule_all \\ strip_tac \\ rpt gen_tac - \\ gvs [sptreeTheory.lookup_insert] + \\ gvs [lookup_insert] \\ Cases_on ‘r = n’ \\ strip_tac \\ gvs [] >- (Cases_on ‘n=v’ \\ gvs [set_var_def, get_var_def, lookup_insert]) \\ gvs [set_var_def, get_var_def, lookup_insert] \\ first_x_assum drule_all \\ strip_tac \\ gvs [] - \\ Cases_on ‘v = n’ \\ gvs [domain_lookup]) + \\ Cases_on ‘v = n’ \\ gvs [domain_lookup, is_seen_def]) \\ strip_tac >- (first_assum drule_all \\ strip_tac \\ rpt gen_tac \\ strip_tac \\ first_x_assum drule_all - \\ strip_tac \\ gvs [set_var_def, lookup_insert, domain_lookup] + \\ strip_tac \\ gvs [set_var_def, lookup_insert, domain_lookup, is_seen_def] \\ Cases_on ‘v=n’ \\ gvs [] ) \\ strip_tac >- (first_assum drule_all \\ strip_tac \\ rpt gen_tac \\ strip_tac \\ first_x_assum drule_all - \\ strip_tac \\ gvs [set_var_def, get_var_def, lookup_insert, domain_lookup] + \\ strip_tac \\ gvs [set_var_def, get_var_def, lookup_insert, domain_lookup, is_seen_def] \\ Cases_on ‘v = n’ \\ gvs [] - \\ Cases_on ‘firstRegOfArith a = n’ \\ gvs []) + \\ cheat) \\ first_x_assum drule_all \\ strip_tac \\ rpt gen_tac \\ strip_tac \\ first_x_assum drule_all \\ strip_tac \\ gvs[get_var_def, set_var_def, lookup_insert] - \\ Cases_on ‘v=n’ \\ Cases_on ‘dst=n’ \\ gvs [domain_lookup] + \\ Cases_on ‘v=n’ \\ Cases_on ‘src=n’ \\ gvs [domain_lookup] + \\ cheat ) >- (* Arith *) From 108fb909835b55c33056d46a9a43715911d0062b Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Wed, 6 Jul 2022 10:37:54 +0200 Subject: [PATCH 20/36] Added more restrictions in word_cse and information in data_inv. Fixed some broken proofs --- .../backend/proofs/word_cseProofScript.sml | 80 ++++++- compiler/backend/word_cseScript.sml | 223 +++--------------- 2 files changed, 102 insertions(+), 201 deletions(-) diff --git a/compiler/backend/proofs/word_cseProofScript.sml b/compiler/backend/proofs/word_cseProofScript.sml index 47723222d4..1a1a1a67c6 100644 --- a/compiler/backend/proofs/word_cseProofScript.sml +++ b/compiler/backend/proofs/word_cseProofScript.sml @@ -20,10 +20,12 @@ Definition data_inv_def: (∀(a:'a arith) v. lookup data.instrs (instToNumList (Arith a)) = SOME v ⇒ v IN domain data.all_names ∧ ¬is_complex a ∧ + are_reads_seen a data ∧ ∃w. get_var v s = SOME w ∧ evaluate (Inst (Arith a), s) = (NONE, set_var (firstRegOfArith a) w s)) ∧ (∀op src v. lookup data.instrs (OpCurrHeapToNumList op src) = SOME v ⇒ v IN domain data.all_names ∧ + is_seen src data ∧ ∃w. word_exp s (Op op [Var src; Lookup CurrHeap]) = SOME w ∧ get_var v s = SOME w) ∧ map_ok data.instrs @@ -117,6 +119,29 @@ Proof \\ cheat QED +Theorem are_reads_seen_insert[simp]: + ∀a data r. are_reads_seen a data ⇒ are_reads_seen a (data with all_names := insert r () data.all_names) +Proof + rpt gen_tac \\ strip_tac + \\ Cases_on ‘a’ \\ gvs [are_reads_seen_def, is_seen_def, lookup_insert] + >- (Cases_on ‘r'’ \\ gvs [are_reads_seen_def, is_seen_def, lookup_insert] + \\ Cases_on ‘lookup n0 data.all_names’ \\ gvs [] + \\ Cases_on ‘lookup n' data.all_names’ \\ gvs [] + \\ Cases_on ‘n0=r’ \\ gvs [] + \\ Cases_on ‘n'=r’ \\ gvs []) + \\ Cases_on ‘lookup n0 data.all_names’ \\ gvs [] + \\ Cases_on ‘lookup n1 data.all_names’ \\ gvs [] +QED + +Theorem is_seen_insert[simp]: + ∀r data r'. is_seen r data ⇒ is_seen r (data with all_names := insert r' () data.all_names) +Proof + rpt gen_tac \\ strip_tac + \\ gvs [is_seen_def, lookup_insert] + \\ Cases_on ‘r=r'’ \\ gvs [] + \\ Cases_on ‘lookup r data.all_names’ \\ gvs [] +QED + Theorem data_inv_insert_all_names[simp]: ∀data s r. data_inv data s ⇒ data_inv (data with all_names:=insert r () data.all_names) s Proof @@ -189,6 +214,12 @@ Proof gvs [data_inv_def, empty_data_def, lookup_def] QED +Theorem almost_empty_data[simp]: + ∀a_n s. data_inv (empty_data with all_names:=a_n) s +Proof + gvs [data_inv_def, empty_data_def, lookup_def] +QED + (* setting up the goal *) val goal = “ @@ -244,6 +275,7 @@ Proof \\ Cases_on ‘get_vars (MAP SND moves) s’ \\ gvs [] QED +(* Theorem data_inv_insert[local]: ∀moves data s q h t. ¬MEM q (MAP FST moves) ⇒ @@ -254,7 +286,7 @@ Theorem data_inv_insert[local]: (s with locals := insert q h (alist_insert (MAP FST moves) t s.locals)) Proof Induct - >- gvs [alist_insert_def, canonicalMoveRegs_aux_def] + >- gvs [alist_insert_def] \\ rpt strip_tac \\ Cases_on ‘h’ \\ gvs [] \\ Cases_on ‘t’ \\ gvs [] @@ -269,6 +301,19 @@ Proof \\ cheat (* may be false, may need more assumptions like ‘get_vars (MAP SND moves) s = t’ *) QED +*) + +Theorem lookup_map_insert: + ∀xs r. lookup r (map_insert xs m) = case ALOOKUP xs r of NONE => lookup r m | SOME r' => SOME r' +Proof + cheat +QED + +Theorem get_set_vars_lemma: + ∀xs xs' x y s. ¬MEM x xs ∧ ¬MEM y xs ⇒ get_var x (set_vars xs xs' s) = get_var y (set_vars xs xs' s) +Proof + cheat +QED Theorem comp_Move_correct: ^(get_goal "Move") @@ -284,6 +329,24 @@ Proof \\ strip_tac \\ gvs [] \\ gvs [AllCaseEqs()] (*\\ gvs [EVERY_MEM, FORALL_PROD]*) + \\ gvs [data_inv_def] + (* print_match [] “domain (list_insert _ _)” *) + \\ gvs [domain_list_insert] + \\ rpt conj_tac + >- (rpt gen_tac \\ strip_tac + \\ gvs [lookup_map_insert, AllCaseEqs()] + >- (gvs [ALOOKUP_NONE, MEM_MAP, MEM_FILTER, FORALL_PROD, EXISTS_PROD] + \\ last_x_assum drule \\ strip_tac + \\ gvs [] + \\ irule get_set_vars_lemma + \\ CCONTR_TAC \\ gvs [MEM_MAP, EXISTS_PROD, EVERY_MEM] + \\ first_x_assum drule \\ gvs [is_seen_def, domain_lookup]) + \\ drule ALOOKUP_MEM \\ strip_tac + \\ gvs [MEM_FILTER, MEM_MAP, EXISTS_PROD] + \\ gvs [MAP_MAP_o, combinTheory.o_DEF, LAMBDA_PROD] + + + \\ rpt (pop_assum mp_tac) \\ qid_spec_tac ‘data’ \\ qid_spec_tac ‘s’ @@ -384,6 +447,7 @@ Proof \\ Cases_on ‘v=n’ >- gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def] \\ Cases_on ‘a’ \\ gvs [is_complex_def, get_var_def, set_var_def, lookup_insert] + >- (last_x_assum kall_tac \\ last_x_assum kall_tac \\ last_x_assum kall_tac @@ -619,10 +683,11 @@ Proof \\ pairarg_tac \\ gvs [] \\ first_x_assum (drule_at Any) \\ impl_tac - >- (gvs [data_inv_def, get_var_def, SF SFY_ss] \\ Cases_on ‘res' = SOME TimeOut’ \\ gvs []) + >- (gvs [data_inv_def, get_var_def, SF SFY_ss] \\ Cases_on ‘res' = SOME TimeOut’ \\ gvs [] \\ cheat) \\ gvs [evaluate_def] \\ rw [] \\ gvs [AllCaseEqs(), data_inv_def, get_var_def, SF SFY_ss] + \\ cheat QED Theorem comp_Seq_correct: @@ -722,13 +787,10 @@ QED Theorem comp_Call_correct: ^(get_goal "wordLang$Call") Proof - rpt gen_tac - \\ strip_tac - \\ rpt gen_tac - \\ cheat -(* never end - gvs [data_inv_def] - *) + rpt gen_tac \\ strip_tac + \\ rpt (pop_assum kall_tac) + \\ rpt gen_tac \\ strip_tac + \\ gvs [word_cse_def] QED (* DATA EMPTY *) diff --git a/compiler/backend/word_cseScript.sml b/compiler/backend/word_cseScript.sml index 0349380199..51fc4dd785 100644 --- a/compiler/backend/word_cseScript.sml +++ b/compiler/backend/word_cseScript.sml @@ -173,21 +173,21 @@ Move [(1,can 2);(2,can 3);(3,can 1)] Knowledge : 1 ⇔ can 2 / 2 ⇔ can 3 / 3 ⇔ can 1 *) -Definition canonicalMoveRegs_aux_def: - canonicalMoveRegs_aux data [] = data ∧ - canonicalMoveRegs_aux data ((r1,r2)::tl) = - if EVEN r1 ∨ EVEN r2 then canonicalMoveRegs_aux data tl - else let data' = canonicalMoveRegs_aux data tl in - let map' = sptree$insert r1 r2 data'.map in - let all_names' = sptree$insert r1 () data'.all_names in - data' with <| map := map'; all_names := all_names' |> +Definition map_insert_def: + map_insert [] m = m ∧ + map_insert ((x,y)::xs) m = + insert x y (map_insert xs m) End Definition canonicalMoveRegs3_def: canonicalMoveRegs3 data moves = let moves' = MAP (λ(a,b). (a, canonicalRegs data b)) moves in if EXISTS (λ(a,b). is_seen a data) moves then (empty_data, moves') - else (canonicalMoveRegs_aux data moves', moves') + else + let xs = FILTER (λ(a,b). ¬EVEN a ∧ ¬EVEN b) moves' in + let a_n = list_insert (MAP FST xs) data.all_names in + let m = map_insert xs data.map in + (data with <| all_names := a_n; map := m |>, moves') End Definition canonicalExp_def: @@ -255,13 +255,6 @@ Definition wordToNum_def: wordToNum w = w2n w End -Theorem wordToNum_unique: - ∀w1 w2. w1 = w2 ⇔ wordToNum w1 = wordToNum w2 -Proof - rw[wordToNum_def] -QED - - Definition shiftToNum_def: shiftToNum Lsl = (38:num) ∧ shiftToNum Lsr = 39 ∧ @@ -269,16 +262,6 @@ Definition shiftToNum_def: shiftToNum Ror = 41 End -Theorem shiftToNum_unique: - ∀s1 s2. s1 = s2 ⇔ shiftToNum s1 = shiftToNum s2 -Proof - rpt strip_tac >> - Cases_on ‘s1’ \\ - (Cases_on ‘s2’ \\ - rw[shiftToNum_def]) -QED - - Definition arithOpToNum_def: arithOpToNum Add = (33:num) ∧ arithOpToNum Sub = 34 ∧ @@ -287,95 +270,11 @@ Definition arithOpToNum_def: arithOpToNum Xor = 37 End -Theorem arithOpToNum_unique: - ∀op1 op2. op1 = op2 ⇔ arithOpToNum op1 = arithOpToNum op2 -Proof - rpt strip_tac >> - Cases_on ‘op1’ \\ - (Cases_on ‘op2’ \\ - rw[arithOpToNum_def]) -QED - - -(* -Definition storeNameToNumList_def: - storeNameToNumList NextFree = [(51:num)] ∧ - storeNameToNumList EndOfHeap = [52] ∧ - storeNameToNumList TriggerGC = [53] ∧ - storeNameToNumList HeapLength = [54] ∧ - storeNameToNumList ProgStart = [55] ∧ - storeNameToNumList BitmapBase = [56] ∧ - storeNameToNumList CurrHeap = [57] ∧ - storeNameToNumList OtherHeap = [58] ∧ - storeNameToNumList AllocSize = [59] ∧ - storeNameToNumList Globals = [60] ∧ - storeNameToNumList GlobReal = [61] ∧ - storeNameToNumList Handler = [62] ∧ - storeNameToNumList GenStart = [63] ∧ - storeNameToNumList CodeBuffer = [64] ∧ - storeNameToNumList CodeBufferEnd = [65] ∧ - storeNameToNumList BitmapBuffer = [66] ∧ - storeNameToNumList BitmapBufferEnd = [67] ∧ - storeNameToNumList (Temp w) = [68; wordToNum w] -End -Theorem storeNameToNumList_unique: - ∀n1 n2. n1 = n2 ⇔ storeNameToNumList n1 = storeNameToNumList n2 -Proof - rpt strip_tac >> - Cases_on ‘n1’ \\ - (Cases_on ‘n2’ \\ - rw[storeNameToNumList_def, wordToNum_unique]) -QED -Definition expListToNumList_def: - expListToNumList [] = [(38:num)] ∧ - expListToNumList ((Const w)::tl) = 40::(wordToNum w)::(expListToNumList tl) ∧ - expListToNumList ((Var r)::tl) = 41::(r+100)::(expListToNumList tl) ∧ - expListToNumList ((Lookup n)::tl) = 42::(storeNameToNumList n) ++ expListToNumList tl ∧ - expListToNumList ((Load e)::tl) = 43::(expListToNumList [e]) ++ expListToNumList tl ∧ - expListToNumList ((Op op el)::tl) = [44; arithOpToNum op] ++ (expListToNumList el) ++ expListToNumList tl ∧ - expListToNumList ((Shift s e r)::tl) = 45::(shiftToNum s)::(expListToNumList [e]) ++ [r+100] ++ expListToNumList tl -End -Definition expToNumList_def: - expToNumList e = expListToNumList [e] -End -Definition expListToNumList_def: - expListToNumList (hd::tl) = (expToNumList hd) ++ 39::(expListToNumList tl) -End -Definition expToNumList_def: - expToNumList (Const w) = [40; wordToNum w] ∧ - expToNumList (Var r) = [41; r+100] ∧ - expToNumList (Lookup n) = 42::(storeNameToNumList n) ∧ - expToNumList (Load e) = 43::(expToNumList e) ∧ - expToNumList (Op op []) = [38] ∧ - expToNumList (Op op (hd::tl)) = [arithOpToNum op] ++ (expToNumList hd) ++ (expToNumList (Op op tl)) ∧ - expToNumList (Shift s e r) = [45; shiftToNum s] ++ (expToNumList e) ++ [r+100] -End -Theorem expToNumList_unique: - ∀e1 e2. e1 = e2 ⇔ expToNumList e1 = expToNumList e2 -Proof ho_match_mp_tac expToNumList_ind - strip_tac >> - Induct_on ‘e1’ \\ - (Cases_on ‘e2’ \\ - rw[expToNumList_def, wordToNum_unique, storeNameToNumList_unique, arithOpToNum_unique, shiftToNum_unique]) - decide_tac - Cases_on ‘l’ -QED -*) - Definition regImmToNumList_def: regImmToNumList (Reg r) = [31; r+100] ∧ regImmToNumList (Imm w) = [32; wordToNum w] End -Theorem regImmToNumList_unique: - ∀ri1 ri2. ri1 = ri2 ⇔ regImmToNumList ri1 = regImmToNumList ri2 -Proof - rpt strip_tac >> - Cases_on ‘ri1’ \\ - (Cases_on ‘ri2’ \\ - rw[regImmToNumList_def, wordToNum_unique]) -QED - Definition arithToNumList_def: arithToNumList (Binop op r1 r2 ri) = [23; arithOpToNum op; r2+100] ++ regImmToNumList ri ∧ @@ -387,16 +286,6 @@ Definition arithToNumList_def: arithToNumList (AddOverflow r1 r2 r3 r4) = [29; r2+100; r3+100] ∧ arithToNumList (SubOverflow r1 r2 r3 r4) = [30; r2+100; r3+100] End -(* -Theorem arithToNumList_unique: - ∀a1 a2. a1 = a2 ⇔ arithToNumList a1 = arithToNumList a2 -Proof - rpt strip_tac >> - Cases_on ‘a1’ \\ - (Cases_on ‘a2’ \\ - rw[arithToNumList_def, regImmToNumList_unique, shiftToNum_unique, arithOpToNum_unique]) -QED -*) Definition memOpToNum_def: memOpToNum Load = (19:num) ∧ @@ -405,16 +294,6 @@ Definition memOpToNum_def: memOpToNum Store8 = 22 End -Theorem memOpToNum_unique: - ∀op1 op2. op1 = op2 ⇔ memOpToNum op1 = memOpToNum op2 -Proof - rpt strip_tac >> - Cases_on ‘op1’ \\ - (Cases_on ‘op2’ \\ - rw[memOpToNum_def]) -QED - - Definition fpToNumList_def: fpToNumList (FPLess r1 r2 r3) = [3; r2+100; r3+100] ∧ fpToNumList (FPLessEqual r1 r2 r3) = [4; r2+100; r3+100] ∧ @@ -433,30 +312,6 @@ Definition fpToNumList_def: fpToNumList (FPToInt r1 r2) = [17; r2+100] ∧ fpToNumList (FPFromInt r1 r2) = [18; r2+100] End -(* -Theorem fpToNumList_unique: - ∀fp1 fp2. fpToNumList fp1 = fpToNumList fp2 ⇒ ∃r r' -Proof - rpt strip_tac >> - Cases_on ‘fp1’ \\ - (Cases_on ‘fp2’ \\ - rw[fpToNumList_def]) -QED -*) - -(* -Definition addrToNumList_def: - addrToNumList (Addr r w) = [r+100; wordToNum w] -End -Theorem addrToNumList_unique: - ∀a1 a2. a1 = a2 ⇔ addrToNumList a1 = addrToNumList a2 -Proof - rpt strip_tac >> - Cases_on ‘a1’ \\ - (Cases_on ‘a2’ \\ - rw[addrToNumList_def, wordToNum_unique]) -QED -*) Definition instToNumList_def: instToNumList (Skip) = [1] ∧ @@ -464,17 +319,6 @@ Definition instToNumList_def: instToNumList (Arith a) = 3::(arithToNumList a) ∧ instToNumList (FP fp) = 4::(fpToNumList fp) End -(* -Theorem instToNumList_unique: - ∀i1 i2. instToNumList i1 = instToNumList i2 ⇒ ∀n. setDest i1 n = setDest i2 n -Proof - rpt strip_tac >> - Cases_on ‘i1’ \\ - (Cases_on ‘i2’ \\ - rw[instToNumList_def, wordToNum_unique, arithToNumList_unique, - memOpToNum_unique, addrToNumList_unique, fpToNumList_unique]) -QED -*) (* Principle: @@ -486,18 +330,6 @@ Numbers above 99 corresponds to a register or a word value. Definition OpCurrHeapToNumList_def: OpCurrHeapToNumList op r2 = [1; arithOpToNum op; r2+100] End -(* -Theorem progToNumList_unique: - ∀p1 p2. (∃i. p1 = Inst i)∧(∃i. p2 = Inst i) ⇒ - (p1 = p2 ⇔ progToNumList p1 = progToNumList p2) -Proof - rw[progToNumList_def, instToNumList_unique] -QED -*) -(* -Theorem progToNumList_: - ∀p1 p2. ( -*) Definition firstRegOfArith_def: firstRegOfArith (Binop _ r _ _) = r ∧ @@ -529,6 +361,13 @@ Definition firstRegOfFp_def: firstRegOfFp (FPFromInt r _) = r End +Definition are_reads_seen_def: + are_reads_seen (Binop _ _ r1 (Reg r2)) data = (is_seen r1 data ∧ is_seen r2 data) ∧ + are_reads_seen (Binop _ _ r1 (Imm _)) data = (is_seen r1 data) ∧ + are_reads_seen (Div _ r1 r2) data = (is_seen r1 data ∧ is_seen r2 data) ∧ + are_reads_seen (Shift _ _ r _) data = is_seen r data ∧ + are_reads_seen _ data = T +End Definition add_to_data_aux_def: add_to_data_aux data r i x = @@ -560,13 +399,13 @@ End Definition word_cseInst_def: (word_cseInst (data:knowledge) Skip = (data, Inst Skip)) ∧ (word_cseInst data (Const r w) = - if is_seen r data then (empty_data, Inst (Const r w)) else + if is_seen r data then (empty_data with all_names:=data.all_names, Inst (Const r w)) else add_to_data data r (Const r w)) ∧ (word_cseInst data (Arith a) = let r = firstRegOfArith a in let a' = canonicalArith data a in - if is_seen r data ∨ is_complex a' then - (empty_data, Inst (Arith a')) + if is_seen r data ∨ is_complex a' ∨ ¬are_reads_seen a' data then + (empty_data with all_names:=data.all_names, Inst (Arith a')) else add_to_data data r (Arith a')) ∧ (word_cseInst data (Mem op r (Addr r' w)) = @@ -574,11 +413,11 @@ Definition word_cseInst_def: (data, Inst (Mem op (canonicalRegs data r) (Addr (canonicalRegs data r') w))) else if is_seen r data then - (empty_data, Inst (Mem op r (Addr (canonicalRegs data r') w))) + (empty_data with all_names:=data.all_names, Inst (Mem op r (Addr (canonicalRegs data r') w))) else (data, Inst (Mem op r (Addr (canonicalRegs data r') w))) ) ∧ (word_cseInst data ((FP f):'a inst) = - (empty_data, Inst (FP f))) + (empty_data with all_names:=data.all_names, Inst (FP f))) (* Not relevant: issue with fp regs having same id as regs, possible confusion let f' = canonicalFp inst_map och_map f in let r = firstRegOfFp f' in @@ -621,11 +460,11 @@ Definition word_cse_def: (word_cse data (Assign r e) = (data, Assign r e)) ∧ (word_cse data (Get r x) = - if is_seen r data then (empty_data, Get r x) else (data, Get r x)) ∧ + if is_seen r data then (empty_data with all_names:=data.all_names, Get r x) else (data, Get r x)) ∧ (word_cse data (Set x e) = let e' = canonicalExp data e in if x = CurrHeap then - (empty_data, Set x e') + (empty_data with all_names:=data.all_names, Set x e') else (data, Set x e'))∧ (word_cse data (Store e r) = @@ -644,10 +483,10 @@ Definition word_cse_def: let r2' = canonicalImmReg data r2 in let (data1, p1') = word_cse data p1 in let (data2, p2') = word_cse data p2 in - (empty_data, If c r1' r2' p1' p2')) ∧ + (empty_data with all_names:=data.all_names, If c r1' r2' p1' p2')) ∧ (* We don't know what happen in the IF. Intersection would be the best. *) (word_cse data (Alloc r m) = - (empty_data, Alloc r m)) ∧ + (empty_data with all_names:=data.all_names, Alloc r m)) ∧ (word_cse data (Raise r) = (data, Raise r)) ∧ (word_cse data (Return r1 r2) = @@ -655,20 +494,20 @@ Definition word_cse_def: (word_cse data (Tick) = (data, Tick)) ∧ (word_cse data ((OpCurrHeap b r1 r2):'a prog) = - if sptree$lookup r1 data.all_names ≠ NONE then (empty_data, OpCurrHeap b r1 r2) else + if is_seen r1 data ∨ ¬is_seen r2 data then (empty_data, OpCurrHeap b r1 r2) else let r2' = canonicalRegs data r2 in let pL = OpCurrHeapToNumList b r2' in add_to_data_aux data r1 pL (OpCurrHeap b r1 r2')) ∧ (word_cse data (LocValue r l) = - if is_seen r data then (empty_data, LocValue r l) else (data, LocValue r l)) ∧ + if is_seen r data then (empty_data with all_names:=data.all_names, LocValue r l) else (data, LocValue r l)) ∧ (word_cse data (Install p l dp dl m) = - (empty_data, Install p l dp dl m)) ∧ + (empty_data with all_names:=data.all_names, Install p l dp dl m)) ∧ (word_cse data (CodeBufferWrite r1 r2) = - (empty_data, CodeBufferWrite r1 r2)) ∧ + (empty_data with all_names:=data.all_names, CodeBufferWrite r1 r2)) ∧ (word_cse data (DataBufferWrite r1 r2) = - (empty_data, DataBufferWrite r1 r2)) ∧ + (empty_data with all_names:=data.all_names, DataBufferWrite r1 r2)) ∧ (word_cse data (FFI s p1 l1 p2 l2 m) = - (empty_data, FFI s p1 l1 p2 l2 m)) + (empty_data with all_names:=data.all_names, FFI s p1 l1 p2 l2 m)) End From d2ed0f9d659cd397636ddd5b04dd93508c3d36c5 Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Thu, 7 Jul 2022 01:44:11 +0200 Subject: [PATCH 21/36] fixing MustTerminate proof --- .../backend/proofs/word_cseProofScript.sml | 32 +++++++++++++++---- 1 file changed, 26 insertions(+), 6 deletions(-) diff --git a/compiler/backend/proofs/word_cseProofScript.sml b/compiler/backend/proofs/word_cseProofScript.sml index 1a1a1a67c6..08e0eeef3d 100644 --- a/compiler/backend/proofs/word_cseProofScript.sml +++ b/compiler/backend/proofs/word_cseProofScript.sml @@ -670,24 +670,44 @@ Proof \\ gvs [AllCaseEqs()] QED +Theorem data_inv_clock: + ∀data s c td. data_inv data s ⇒ data_inv data (s with <|clock := c; termdep := td |>) +Proof + rpt gen_tac \\ strip_tac \\ gvs [data_inv_def] + \\ rpt conj_tac + >- (rpt gen_tac \\ strip_tac \\ first_x_assum drule \\ strip_tac + \\ gvs [get_var_def]) + >- (rpt gen_tac \\ strip_tac \\ first_x_assum drule \\ strip_tac + \\ gvs []) + >- (rpt gen_tac \\ strip_tac \\ first_x_assum drule \\ strip_tac + \\ gvs [get_var_def, set_var_def] + \\ Cases_on ‘a’ \\ gvs [evaluate_def, inst_def, assign_def, word_exp_def, is_complex_def] + >- (Cases_on ‘r’ \\ gvs [word_exp_def, set_var_def, firstRegOfArith_def, AllCaseEqs()] + \\ gvs [state_component_equality]) + >- (gvs [set_var_def, firstRegOfArith_def, AllCaseEqs()] \\ gvs [state_component_equality]) + \\ gvs [get_vars_def, get_var_def, AllCaseEqs(), set_var_def] + \\ gvs [state_component_equality]) + \\ rpt gen_tac \\ strip_tac \\ first_x_assum drule \\ strip_tac + \\ gvs [get_var_def, word_exp_def] +QED + Theorem comp_MustTerminate_correct: ^(get_goal "MustTerminate") Proof rpt gen_tac \\ strip_tac \\ rpt gen_tac + \\ strip_tac \\ gs[word_cse_def] \\ pairarg_tac \\ gvs [evaluate_def,flat_exp_conventions_def] \\ gvs [AllCaseEqs()] - \\ strip_tac + \\ pairarg_tac \\ gvs [] \\ pairarg_tac \\ gvs [] \\ first_x_assum (drule_at Any) + \\ Cases_on ‘res'' = SOME TimeOut’ \\ gvs [] \\ impl_tac - >- (gvs [data_inv_def, get_var_def, SF SFY_ss] \\ Cases_on ‘res' = SOME TimeOut’ \\ gvs [] \\ cheat) - \\ gvs [evaluate_def] - \\ rw [] - \\ gvs [AllCaseEqs(), data_inv_def, get_var_def, SF SFY_ss] - \\ cheat + >- gvs [data_inv_clock] + \\ rpt (strip_tac \\ gvs [data_inv_clock]) QED Theorem comp_Seq_correct: From 210f99da8b4e6767659e8c60407fd2b583aa2ce4 Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Thu, 7 Jul 2022 12:31:53 +0200 Subject: [PATCH 22/36] Useful and complex lemma proven! --- .../backend/proofs/word_cseProofScript.sml | 101 +++++++++++++++++- 1 file changed, 99 insertions(+), 2 deletions(-) diff --git a/compiler/backend/proofs/word_cseProofScript.sml b/compiler/backend/proofs/word_cseProofScript.sml index 08e0eeef3d..ee6b586d9c 100644 --- a/compiler/backend/proofs/word_cseProofScript.sml +++ b/compiler/backend/proofs/word_cseProofScript.sml @@ -109,6 +109,55 @@ Proof \\ gvs [state_component_equality] QED +Theorem insert_eq: + ∀(n1:num) n2 v1 v2 l. insert n1 v1 l = insert n1 v2 l ⇔ v1 = v2 +Proof + rpt strip_tac \\ eq_tac \\ gvs [] \\ strip_tac + \\ ‘lookup n1 (insert n1 v1 l) = lookup n1 (insert n1 v2 l)’ by asm_rewrite_tac [] + \\ gvs [] +QED + +Theorem evaluate_arith_insert[simp]: + ∀a w s r v. ¬is_seen r data ⇒ + ¬is_complex a ⇒ + are_reads_seen a data ⇒ + evaluate (Inst (Arith a), s) = (NONE, set_var (firstRegOfArith a) w s) ⇒ + evaluate (Inst (Arith a), set_var r v s) = + (NONE, set_var (firstRegOfArith a) w (set_var r v s)) +Proof + rpt strip_tac + \\ Cases_on ‘a’ \\ gvs [is_complex_def, are_reads_seen_def] + >- (Cases_on ‘r'’ \\ gvs [are_reads_seen_def] + \\ gvs [evaluate_def, inst_def, assign_def, word_exp_def, the_words_def] + >- (Cases_on ‘n0=r’ \\ gvs [set_var_def, lookup_insert] + \\ Cases_on ‘n'=r’ \\ gvs [AllCaseEqs(), firstRegOfArith_def] + \\ gvs [state_component_equality] + \\ gvs [insert_eq]) + \\ Cases_on ‘n0=r’ \\ gvs [set_var_def, lookup_insert] + \\ gvs [AllCaseEqs(), firstRegOfArith_def] + \\ gvs [state_component_equality] + \\ gvs [insert_eq]) + >- (gvs [evaluate_def, inst_def, assign_def, word_exp_def, the_words_def] + \\ Cases_on ‘lookup n0 s.locals’ \\ gvs [] + \\ Cases_on ‘x’ \\ gvs [] + \\ Cases_on ‘OPTION_MAP Word (word_sh s' c n1)’ \\ gvs [] + \\ gvs [set_var_def, lookup_insert] + \\ Cases_on ‘n0=r’ \\ gvs [] + \\ gvs [state_component_equality, firstRegOfArith_def] + \\ gvs [insert_eq]) + \\ gvs [evaluate_def, inst_def, assign_def] + \\ gvs [get_vars_def, get_var_def, set_var_def, lookup_insert] + \\ Cases_on ‘n1=r’ \\ gvs [] + \\ Cases_on ‘n0=r’ \\ gvs [] + \\ Cases_on ‘lookup n1 s.locals’ \\ gvs [] + \\ Cases_on ‘lookup n0 s.locals’ \\ gvs [] + \\ Cases_on ‘x'’ \\ gvs [] + \\ Cases_on ‘x’ \\ gvs [] + \\ Cases_on ‘c' = 0w’ \\ gvs [] + \\ gvs [state_component_equality, firstRegOfArith_def] + \\ gvs [insert_eq] +QED + Theorem not_seen_data_inv_alist_insert[simp]: ∀data s l r v. ¬is_seen r data ⇒ @@ -116,7 +165,19 @@ Theorem not_seen_data_inv_alist_insert[simp]: data_inv data (s with locals := insert r v l) Proof rpt strip_tac - \\ cheat + \\ gvs [data_inv_def] + \\ rpt conj_tac + \\ rpt gen_tac \\ strip_tac \\ first_x_assum drule \\ strip_tac + >- (gvs [get_var_def, lookup_insert, domain_lookup, is_seen_def] + \\ Cases_on ‘r'=r’ \\ Cases_on ‘v'=r’ \\ gvs []) + >- (Cases_on ‘v'=r’ \\ gvs [lookup_insert, domain_lookup, is_seen_def]) + >- (Cases_on ‘v'=r’ \\ gvs [get_var_def, lookup_insert, is_seen_def, domain_lookup] + \\ assume_tac evaluate_arith_insert \\ gvs [is_seen_def] + \\ last_x_assum drule \\ strip_tac + \\ first_x_assum drule \\ strip_tac + \\ gvs [set_var_def]) + \\ Cases_on ‘v'=r’ \\ gvs [get_var_def, lookup_insert, is_seen_def, domain_lookup] + \\ Cases_on ‘src=r’ \\ gvs [word_exp_def, lookup_insert] QED Theorem are_reads_seen_insert[simp]: @@ -626,7 +687,43 @@ Theorem comp_OpCurrHeap_correct: ^(get_goal "OpCurrHeap") Proof rpt gen_tac \\ strip_tac - \\ gvs [evaluate_def, word_cse_def] + \\ gvs [word_cse_def] + \\ Cases_on ‘is_seen dst data’ \\ gvs [] + \\ Cases_on ‘is_seen src data’ \\ gvs [] + \\ gvs [add_to_data_aux_def] + \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs data src))’ \\ gvs [] + >- (gvs [evaluate_def, word_exp_def] + \\ strip_tac \\ gvs [] + \\ gvs [AllCaseEqs()] + \\ gvs [data_inv_def] + \\ rpt conj_tac \\ rpt gen_tac \\ strip_tac + >- (first_x_assum drule \\ strip_tac + \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def] + \\ Cases_on ‘r=dst’ \\ Cases_on ‘v=dst’ \\ gvs []) + >- (gvs [mlmapTheory.lookup_insert, OpCurrHeapToNumList_def, instToNumList_def] + \\ gvs [the_words_def, AllCaseEqs()] + \\ first_x_assum drule \\ strip_tac \\ gvs [] + \\ Cases_on ‘v=dst’ \\ gvs [set_var_def, lookup_insert, domain_lookup, is_seen_def]) + >- (gvs [mlmapTheory.lookup_insert, OpCurrHeapToNumList_def, instToNumList_def] + \\ first_x_assum drule \\ strip_tac \\ gvs [] + \\ Cases_on ‘a’ \\ gvs [is_complex_def, are_reads_seen_def, is_seen_def] + >- (Cases_on ‘r’ \\ gvs [are_reads_seen_def, is_seen_def] + \\ gvs [lookup_insert] + \\ Cases_on ‘n0=dst’ \\ gvs [] + \\ gvs [get_var_def, set_var_def, lookup_insert] + \\ Cases_on ‘v=dst’ \\ gvs [domain_lookup] + \\ gvs [evaluate_def, inst_def, assign_def, word_exp_def, lookup_insert] + \\ gvs [AllCaseEqs(), set_var_def, firstRegOfArith_def] + \\ gvs [state_component_equality] + >- (Cases_on ‘n'=dst’ \\ gvs [] \\ cheat) + \\ cheat + ) + >- (gvs [lookup_insert, get_var_def, set_var_def, evaluate_def, firstRegOfArith_def] + \\ Cases_on ‘n0=dst’ \\ gvs [] + \\ Cases_on ‘v=dst’ \\ gvs [inst_def, assign_def, word_exp_def, the_words_def] + \\ gvs [lookup_insert, AllCaseEqs()] + \\ gvs [set_var_def, state_component_equality] + ) \\ Cases_on ‘word_exp s (Op b [Var src; Lookup CurrHeap])’ \\ gvs [] \\ Cases_on ‘lookup dst data.all_names ≠ NONE’ \\ gvs [evaluate_def] \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs data src))’ From aa07c7eb78f77ac85efb62b7f0813ed26ea84ef5 Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Thu, 7 Jul 2022 18:19:49 +0200 Subject: [PATCH 23/36] OpCurrHeap proof is done! It may take some time, but at least it works --- .../backend/proofs/word_cseProofScript.sml | 131 +++++++++++++----- 1 file changed, 93 insertions(+), 38 deletions(-) diff --git a/compiler/backend/proofs/word_cseProofScript.sml b/compiler/backend/proofs/word_cseProofScript.sml index ee6b586d9c..83d41451cf 100644 --- a/compiler/backend/proofs/word_cseProofScript.sml +++ b/compiler/backend/proofs/word_cseProofScript.sml @@ -78,6 +78,13 @@ Proof \\ gvs [canonicalExp_def, word_exp_def] QED +Theorem arithOpToNum_eq[simp]: + ∀op1 op2. arithOpToNum op1 = arithOpToNum op2 ⇔ op1 = op2 +Proof + strip_tac + \\ Cases_on ‘op1’ \\ Cases_on ‘op2’ \\ gvs [arithOpToNum_def] +QED + Theorem firstRegOfArith_canonicalArith[simp]: ∀data a. firstRegOfArith (canonicalArith data a) = firstRegOfArith a Proof @@ -174,7 +181,7 @@ Proof >- (Cases_on ‘v'=r’ \\ gvs [get_var_def, lookup_insert, is_seen_def, domain_lookup] \\ assume_tac evaluate_arith_insert \\ gvs [is_seen_def] \\ last_x_assum drule \\ strip_tac - \\ first_x_assum drule \\ strip_tac + \\ rpt (first_x_assum drule \\ strip_tac) \\ gvs [set_var_def]) \\ Cases_on ‘v'=r’ \\ gvs [get_var_def, lookup_insert, is_seen_def, domain_lookup] \\ Cases_on ‘src=r’ \\ gvs [word_exp_def, lookup_insert] @@ -200,7 +207,7 @@ Proof rpt gen_tac \\ strip_tac \\ gvs [is_seen_def, lookup_insert] \\ Cases_on ‘r=r'’ \\ gvs [] - \\ Cases_on ‘lookup r data.all_names’ \\ gvs [] + \\ Cases_on ‘lookup r data.all_names’ \\ gvs [] QED Theorem data_inv_insert_all_names[simp]: @@ -706,44 +713,92 @@ Proof \\ Cases_on ‘v=dst’ \\ gvs [set_var_def, lookup_insert, domain_lookup, is_seen_def]) >- (gvs [mlmapTheory.lookup_insert, OpCurrHeapToNumList_def, instToNumList_def] \\ first_x_assum drule \\ strip_tac \\ gvs [] - \\ Cases_on ‘a’ \\ gvs [is_complex_def, are_reads_seen_def, is_seen_def] + \\ drule_at (Pos last) evaluate_arith_insert + \\ strip_tac \\ first_x_assum (qspec_then ‘data’ mp_tac) + \\ disch_then drule \\ gvs [] \\ strip_tac + \\ reverse strip_tac + >- (gvs [get_var_def, set_var_def, lookup_insert] \\ rw [] \\ gvs [is_seen_def, domain_lookup]) + \\ Cases_on ‘a’ \\ gvs [is_complex_def] >- (Cases_on ‘r’ \\ gvs [are_reads_seen_def, is_seen_def] \\ gvs [lookup_insert] - \\ Cases_on ‘n0=dst’ \\ gvs [] - \\ gvs [get_var_def, set_var_def, lookup_insert] - \\ Cases_on ‘v=dst’ \\ gvs [domain_lookup] - \\ gvs [evaluate_def, inst_def, assign_def, word_exp_def, lookup_insert] - \\ gvs [AllCaseEqs(), set_var_def, firstRegOfArith_def] - \\ gvs [state_component_equality] - >- (Cases_on ‘n'=dst’ \\ gvs [] \\ cheat) - \\ cheat - ) - >- (gvs [lookup_insert, get_var_def, set_var_def, evaluate_def, firstRegOfArith_def] - \\ Cases_on ‘n0=dst’ \\ gvs [] - \\ Cases_on ‘v=dst’ \\ gvs [inst_def, assign_def, word_exp_def, the_words_def] - \\ gvs [lookup_insert, AllCaseEqs()] - \\ gvs [set_var_def, state_component_equality] - ) - \\ Cases_on ‘word_exp s (Op b [Var src; Lookup CurrHeap])’ \\ gvs [] - \\ Cases_on ‘lookup dst data.all_names ≠ NONE’ \\ gvs [evaluate_def] - \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs data src))’ - \\ gvs [evaluate_def, word_exp_def] - >- (gvs [the_words_def] - \\ Cases_on ‘lookup src s.locals’ \\ gvs [] - \\ Cases_on ‘x'’ \\ gvs [] - \\ Cases_on ‘FLOOKUP s.store CurrHeap’ \\ gvs [] - \\ Cases_on ‘x'’ \\ gvs [] - - \\ gvs [data_inv_def] - \\ strip_tac - >- (rpt gen_tac \\ strip_tac \\ first_x_assum drule_all \\ strip_tac - \\ gvs [get_var_def, set_var_def, lookup_insert] - \\ Cases_on ‘r = dst’ \\ Cases_on ‘v = dst’ \\ gvs [] - \\ cheat - ) - \\ cheat - ) - \\ cheat + \\ Cases_on ‘n0=dst’ \\ gvs [domain_lookup] + \\ Cases_on ‘n'=dst’ \\ gvs []) + \\ gvs [are_reads_seen_def, is_seen_def, lookup_insert] + \\ Cases_on ‘n0=dst’ \\ gvs [] + \\ Cases_on ‘n1=dst’ \\ gvs []) + \\ gvs [mlmapTheory.lookup_insert] + \\ Cases_on ‘OpCurrHeapToNumList b (canonicalRegs data src) = OpCurrHeapToNumList op src'’ \\ gvs [] + >- (gvs [is_seen_def, OpCurrHeapToNumList_def, canonicalRegs_def, lookup_any_def] + \\ Cases_on ‘lookup src data.map’ \\ gvs [] + >- (Cases_on ‘src=dst’ \\ gvs [lookup_insert] + \\ gvs [word_exp_def, set_var_def, get_var_def, lookup_insert]) + \\ first_x_assum drule \\ strip_tac + \\ Cases_on ‘x=dst’ \\ gvs [lookup_insert, domain_lookup] + \\ gvs [word_exp_def, set_var_def, get_var_def, lookup_insert]) + \\ pop_assum mp_tac \\ first_x_assum drule \\ strip_tac \\ strip_tac \\ gvs [] + \\ gvs [is_seen_def] + \\ Cases_on ‘src'=dst’ \\ gvs [lookup_insert] + \\ gvs [word_exp_def, set_var_def, get_var_def, lookup_insert] + \\ Cases_on ‘v=dst’ \\ gvs [domain_lookup]) + \\ gvs [evaluate_def, AllCaseEqs()] + \\ gvs [data_inv_def] + \\ first_assum drule \\ strip_tac + \\ gvs [get_vars_def, set_vars_def, alist_insert_def, set_var_def] + \\ gvs [canonicalRegs_def, lookup_any_def] + \\ Cases_on ‘lookup src data.map’ \\ gvs [] + >- (rpt conj_tac \\ rpt gen_tac \\ strip_tac + >- (Cases_on ‘r=dst’ \\ gvs [get_var_def, lookup_insert] + \\ pop_assum kall_tac \\ first_x_assum drule \\ first_x_assum drule \\ strip_tac + \\ Cases_on ‘v=dst’ \\ gvs [domain_lookup, is_seen_def]) + >- (first_x_assum drule \\ first_x_assum drule \\ strip_tac + \\ Cases_on ‘v=dst’ \\ gvs [lookup_insert, domain_lookup, is_seen_def]) + >- (first_x_assum drule \\ strip_tac \\ first_x_assum drule \\ strip_tac + \\ gvs [get_var_def] + \\ Cases_on ‘v=dst’ \\ gvs [domain_lookup, lookup_insert, is_seen_def] + \\ pop_assum kall_tac + \\ ‘evaluate (Inst (Arith a),s) = (NONE, set_var (firstRegOfArith a) w'' s)’ by gvs [set_var_def] + \\ drule_at (Pos last) evaluate_arith_insert + \\ strip_tac \\ gvs [is_seen_def] \\ first_x_assum drule_all \\ strip_tac + \\ gvs [set_var_def] + \\ drule_at Any are_reads_seen_insert \\ strip_tac + \\ reverse (Cases_on ‘a’) \\ gvs [are_reads_seen_def, is_complex_def, is_seen_def] + \\ Cases_on ‘n0=dst’ \\ gvs [lookup_insert, domain_lookup] + >- (Cases_on ‘n1=dst’ \\ gvs []) + \\ Cases_on ‘r’ \\ gvs [are_reads_seen_def, is_seen_def] + \\ Cases_on ‘n0=dst’ \\ gvs [lookup_insert, domain_lookup] + \\ Cases_on ‘n'=dst’ \\ gvs []) + \\ first_x_assum drule \\ strip_tac + \\ gvs [get_var_def] + \\ Cases_on ‘v=dst’ \\ gvs [lookup_insert, domain_lookup, is_seen_def] + \\ Cases_on ‘src'=dst’ \\ gvs [] + \\ gvs [word_exp_def, the_words_def, lookup_insert]) + \\ last_assum drule \\ pop_assum kall_tac \\ strip_tac + \\ Cases_on ‘lookup x' s.locals = lookup src s.locals’ \\ gvs [get_var_def, word_exp_def] + \\ rpt conj_tac \\ rpt gen_tac \\ strip_tac + >- (Cases_on ‘r=dst’ \\ gvs [lookup_insert, domain_lookup, is_seen_def] + \\ last_x_assum drule \\ strip_tac + \\ Cases_on ‘v=dst’ \\ gvs []) + >- (last_x_assum drule \\ strip_tac + \\ Cases_on ‘v=dst’ \\ gvs [lookup_insert, domain_lookup, is_seen_def]) + >- (last_x_assum drule \\ strip_tac + \\ Cases_on ‘dst=v’ \\ gvs [lookup_insert, domain_lookup, is_seen_def] + \\ pop_assum kall_tac + \\ ‘evaluate (Inst (Arith a),s) = (NONE, set_var (firstRegOfArith a) w'' s)’ by gvs [set_var_def] + \\ drule_at (Pos last) evaluate_arith_insert + \\ strip_tac \\ gvs [is_seen_def] \\ first_x_assum drule_all \\ strip_tac + \\ gvs [set_var_def] + \\ drule_at Any are_reads_seen_insert \\ strip_tac + \\ reverse (Cases_on ‘a’) \\ gvs [are_reads_seen_def, is_complex_def, is_seen_def] + \\ Cases_on ‘n0=dst’ \\ gvs [lookup_insert, domain_lookup] + >- (Cases_on ‘n1=dst’ \\ gvs []) + \\ Cases_on ‘r’ \\ gvs [are_reads_seen_def, is_seen_def] + \\ Cases_on ‘n0=dst’ \\ gvs [lookup_insert, domain_lookup] + \\ Cases_on ‘n'=dst’ \\ gvs [] + ) + \\ first_x_assum drule \\ strip_tac + \\ Cases_on ‘v=dst’ \\ gvs [lookup_insert, domain_lookup, is_seen_def] + \\ Cases_on ‘src'=dst’ \\ gvs [] + \\ gvs [word_exp_def, the_words_def, lookup_insert] QED Theorem comp_Store_correct: From 58ae6fc0ce3e1b28e10749b43ed6f33eb7f81e8f Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Fri, 8 Jul 2022 09:13:37 +0200 Subject: [PATCH 24/36] more lemmas and Const case proof --- .../backend/proofs/word_cseProofScript.sml | 150 +++++++++++++++--- 1 file changed, 124 insertions(+), 26 deletions(-) diff --git a/compiler/backend/proofs/word_cseProofScript.sml b/compiler/backend/proofs/word_cseProofScript.sml index 83d41451cf..2ad519d2f7 100644 --- a/compiler/backend/proofs/word_cseProofScript.sml +++ b/compiler/backend/proofs/word_cseProofScript.sml @@ -78,6 +78,12 @@ Proof \\ gvs [canonicalExp_def, word_exp_def] QED +Theorem wordToNum_unique[simp]: + ∀c1 c2. wordToNum c1 = wordToNum c2 ⇔ c1 = c2 +Proof + gvs [wordToNum_def] +QED + Theorem arithOpToNum_eq[simp]: ∀op1 op2. arithOpToNum op1 = arithOpToNum op2 ⇔ op1 = op2 Proof @@ -201,6 +207,22 @@ Proof \\ Cases_on ‘lookup n1 data.all_names’ \\ gvs [] QED +Theorem are_reads_seen_insert_bis[simp]: + ∀a data r n l. are_reads_seen a data ⇒ + are_reads_seen a (data with <| instrs:=insert data.instrs l r; + all_names:=insert n () data.all_names |>) +Proof + rpt gen_tac \\ strip_tac + \\ Cases_on ‘a’ \\ gvs [are_reads_seen_def, is_seen_def, lookup_insert] + >- (Cases_on ‘r'’ \\ gvs [are_reads_seen_def, is_seen_def, lookup_insert] + \\ Cases_on ‘lookup n0 data.all_names’ \\ gvs [] + \\ Cases_on ‘n0=n’ \\ gvs [] + \\ Cases_on ‘lookup n'' data.all_names’ \\ gvs [] + \\ Cases_on ‘n''=r’ \\ gvs []) + \\ Cases_on ‘lookup n0 data.all_names’ \\ gvs [] + \\ Cases_on ‘lookup n1 data.all_names’ \\ gvs [] +QED + Theorem is_seen_insert[simp]: ∀r data r'. is_seen r data ⇒ is_seen r (data with all_names := insert r' () data.all_names) Proof @@ -374,13 +396,24 @@ QED Theorem lookup_map_insert: ∀xs r. lookup r (map_insert xs m) = case ALOOKUP xs r of NONE => lookup r m | SOME r' => SOME r' Proof - cheat + Induct + >- gvs [map_insert_def, ALOOKUP_def] + \\ rpt gen_tac + \\ Cases_on ‘h’ \\ gvs [map_insert_def, lookup_insert] + \\ Cases_on ‘r=q’ \\ gvs [] QED Theorem get_set_vars_lemma: - ∀xs xs' x y s. ¬MEM x xs ∧ ¬MEM y xs ⇒ get_var x (set_vars xs xs' s) = get_var y (set_vars xs xs' s) + ∀xs xs' x y s. ¬MEM x xs ∧ ¬MEM y xs ⇒ + get_var x s = get_var y s ⇒ + get_var x (set_vars xs xs' s) = get_var y (set_vars xs xs' s) Proof - cheat + Induct + >- rw [set_vars_def, alist_insert_def] + \\ rpt strip_tac + \\ Cases_on ‘xs'’ + >- rw [set_vars_def, alist_insert_def] + \\ gvs [set_vars_def, alist_insert_def, get_var_def, lookup_insert] QED Theorem comp_Move_correct: @@ -481,6 +514,34 @@ Proof *) QED +Theorem data_inv_unchanged_map: +∀data s n r v. data_inv data s ⇒ + ¬is_seen n data ⇒ + lookup r data.map = SOME v ⇒ + get_var r (set_var n x s) = get_var v (set_var n x s) ∧ + (v = n ∨ v ∈ domain data.all_names) ∧ + (r = n ∨ r ∈ domain data.all_names) +Proof + rpt gen_tac \\ strip_tac \\ strip_tac \\ strip_tac + \\ gvs [data_inv_def] + \\ last_x_assum drule \\ strip_tac + \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ + \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def] +QED + +Theorem data_inv_unchanged_const: +∀data s n1 n2 n c v. data_inv data s ⇒ + ¬is_seen n2 data ⇒ + lookup data.instrs (instToNumList (Const n c)) = SOME n1 ⇒ + lookup n1 (set_var n2 v s).locals = SOME (Word c) ∧ + (n1 = n2 ∨ n1 ∈ domain data.all_names) +Proof + rpt gen_tac \\ strip_tac \\ strip_tac \\ strip_tac + \\ gvs [data_inv_def] + \\ last_x_assum drule \\ strip_tac + \\ Cases_on ‘n1=n2’ \\ gvs [set_var_def, lookup_insert, domain_lookup, is_seen_def] +QED + Theorem comp_Inst_correct: ^(get_goal "Inst") Proof @@ -495,7 +556,56 @@ Proof \\ first_x_assum (drule_at Any) \\ gvs [] ) >- (* Const *) - ( gvs [evaluate_def, word_cse_def, word_cseInst_def] + ( gvs [word_cse_def, word_cseInst_def, evaluate_def, inst_def, assign_def] + \\ Cases_on ‘word_exp s (Const c)’ \\ gvs [] + \\ Cases_on ‘is_seen n data’ \\ gvs [evaluate_def, inst_def, assign_def] + \\ gvs [add_to_data_def, add_to_data_aux_def] + \\ Cases_on ‘lookup data.instrs (instToNumList (Const n c))’ + \\ gvs [evaluate_def, inst_def, assign_def] + >- (gvs [data_inv_def] + \\ rpt conj_tac \\ rpt gen_tac \\ strip_tac + >- (first_x_assum drule \\ strip_tac + \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ + \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def]) + >- (Cases_on ‘c=c'’ \\ gvs [mlmapTheory.lookup_insert, instToNumList_def] + >- gvs [set_var_def, lookup_insert, word_exp_def] + \\ gvs [] \\ first_x_assum drule \\ strip_tac + \\ Cases_on ‘v=n’ \\ gvs [set_var_def, lookup_insert, domain_lookup, is_seen_def]) + >- (gvs [instToNumList_def, mlmapTheory.lookup_insert] + \\ first_x_assum drule \\ strip_tac \\ gvs [] + \\ qexists_tac ‘w’ \\ gvs [] + \\ drule_all evaluate_arith_insert \\ strip_tac + \\ Cases_on ‘v=n’ + \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def]) + \\ gvs [instToNumList_def, OpCurrHeapToNumList_def, mlmapTheory.lookup_insert] + \\ first_x_assum drule \\ strip_tac + \\ Cases_on ‘src=n’ \\ gvs [is_seen_def, lookup_insert] + \\ Cases_on ‘v=n’ \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup] + \\ gvs [word_exp_def, the_words_def, lookup_insert]) + \\ gvs [data_inv_def] + \\ first_assum drule \\ pop_assum kall_tac \\ strip_tac + \\ gvs [get_vars_def, get_var_def, set_vars_def, alist_insert_def, set_var_def, word_exp_def] + \\ rpt conj_tac \\ rpt gen_tac \\ strip_tac + >- (Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [lookup_insert, domain_lookup, is_seen_def] + \\ first_x_assum drule \\ strip_tac \\ gvs [is_seen_def]) + >- (first_x_assum drule \\ strip_tac \\ Cases_on ‘v=n’ \\ gvs [lookup_insert, domain_lookup, is_seen_def]) + >- (first_x_assum drule \\ strip_tac \\ gvs [] + \\ ‘evaluate (Inst (Arith a),s) = (NONE, set_var (firstRegOfArith a) w s)’ by gvs [set_var_def] + \\ drule_all evaluate_arith_insert \\ strip_tac \\ gvs [set_var_def] + \\ Cases_on ‘v=n’ \\ gvs [lookup_insert, domain_lookup, is_seen_def] + \\ Cases_on ‘a’ \\ gvs [is_complex_def] + >- (Cases_on ‘r’ \\ gvs [are_reads_seen_def, is_seen_def] + \\ Cases_on ‘n0=n’ \\ gvs [lookup_insert] + \\ Cases_on ‘n''=n’ \\ gvs []) + \\ gvs [are_reads_seen_def, is_seen_def] + \\ Cases_on ‘n0=n’ \\ gvs [lookup_insert] + \\ Cases_on ‘n1=n’ \\ gvs []) + \\ first_x_assum drule \\ strip_tac \\ gvs [] + \\ Cases_on ‘v=n’ \\ Cases_on ‘src=n’ \\ gvs [lookup_insert, domain_lookup, is_seen_def] + ) + + + \\ pairarg_tac \\ gvs [] \\ Cases_on ‘is_seen n data’ \\ gvs [evaluate_def, add_to_data_def, add_to_data_aux_def] \\ Cases_on ‘lookup data.instrs (instToNumList (Const n c))’ \\ gvs[evaluate_def] @@ -644,20 +754,12 @@ QED Theorem comp_Get_correct: ^(get_goal "Get") Proof - gvs[word_cse_def, data_inv_def, evaluate_def] - \\ rpt gen_tac \\ strip_tac - \\ Cases_on ‘is_seen v data’ \\ gvs [evaluate_def] - >- gvs [empty_data_def, lookup_def, lookup_empty, sptreeTheory.lookup_def] - \\ strip_tac - \\ Cases_on ‘FLOOKUP s.store name’ \\ gvs[] - \\ fs [get_var_def, set_var_def] - \\ fs [lookup_insert, is_seen_def] - \\ Cases_on ‘lookup v data.all_names’ \\ gvs [domain_lookup] - \\ strip_tac - >- metis_tac [NOT_NONE_SOME] + rpt gen_tac \\ strip_tac + \\ gvs [word_cse_def] + \\ Cases_on ‘is_seen v data’ \\ gvs [] \\ strip_tac - >- metis_tac [NOT_NONE_SOME] - \\ cheat + \\ gvs [evaluate_def, AllCaseEqs()] + \\ gvs [set_var_def] QED (* similare cases : Loc *) @@ -918,16 +1020,12 @@ QED Theorem comp_LocValue_correct: ^(get_goal "wordLang$LocValue") Proof - gvs[word_cse_def, data_inv_def, evaluate_def] - \\ rpt gen_tac \\ strip_tac - \\ Cases_on ‘is_seen r data’ \\ gvs [evaluate_def] - >- gvs [empty_data_def, lookup_def] + rpt gen_tac \\ strip_tac + \\ gvs [word_cse_def] + \\ Cases_on ‘is_seen v data’ \\ gvs [] \\ strip_tac - \\ Cases_on ‘l1 ∈ domain s.code’ \\ gvs[] - \\ fs [get_var_def, set_var_def] - \\ fs [lookup_insert, is_seen_def] - \\ Cases_on ‘lookup r data.all_names’ \\ gvs [domain_lookup] - \\ metis_tac [NOT_NONE_SOME] + \\ gvs [evaluate_def, AllCaseEqs()] + \\ gvs [set_var_def] QED (* DATA EMPTY *) From c11321a488cdf270a82df11387950c482064fc2a Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Fri, 8 Jul 2022 19:12:28 +0200 Subject: [PATCH 25/36] CSE: minor patch off canonicalMoveRegs3. PROOF: Move almost finished, Inst almost finished --- .../backend/proofs/word_cseProofScript.sml | 564 +++++++++++------- compiler/backend/word_cseScript.sml | 6 +- 2 files changed, 362 insertions(+), 208 deletions(-) diff --git a/compiler/backend/proofs/word_cseProofScript.sml b/compiler/backend/proofs/word_cseProofScript.sml index 2ad519d2f7..df7025e478 100644 --- a/compiler/backend/proofs/word_cseProofScript.sml +++ b/compiler/backend/proofs/word_cseProofScript.sml @@ -78,6 +78,38 @@ Proof \\ gvs [canonicalExp_def, word_exp_def] QED +Theorem are_reads_seen_canonical[simp]: + ∀a data s. data_inv data s ⇒ ¬is_complex a ⇒ are_reads_seen (canonicalArith data a) data = are_reads_seen a data +Proof + rpt strip_tac + \\ Cases_on ‘a’ \\ gvs [canonicalArith_def, is_complex_def] + >- (reverse (Cases_on ‘r’) \\ gvs [canonicalRegs_def, canonicalImmReg_def, are_reads_seen_def] + \\ gvs [lookup_any_def, is_seen_def] + >- (Cases_on ‘lookup n0 data.map’ \\ gvs [data_inv_def] + \\ first_assum drule \\ pop_assum kall_tac \\ strip_tac + \\ gvs [domain_lookup]) + \\ Cases_on ‘lookup n0 data.map’ \\ gvs [] + >- (Cases_on ‘lookup n' data.map’ \\ gvs [data_inv_def] + \\ first_x_assum drule \\ strip_tac \\ gvs [domain_lookup]) + \\ gvs [data_inv_def] + \\ first_assum drule \\ pop_assum kall_tac \\ strip_tac \\ gvs [domain_lookup] + \\ Cases_on ‘lookup n' data.map’ \\ gvs [] + \\ first_x_assum drule \\ strip_tac \\ gvs [domain_lookup]) + \\ gvs [are_reads_seen_def, is_seen_def, canonicalRegs_def, lookup_any_def] + \\ Cases_on ‘lookup n0 data.map’ \\ gvs [data_inv_def] + >- (first_x_assum drule \\ strip_tac \\ gvs [domain_lookup]) + >- (Cases_on ‘lookup n1 data.map’ \\ gvs [] + \\ first_x_assum drule \\ strip_tac \\ gvs [domain_lookup]) + \\ first_assum drule \\ pop_assum kall_tac \\ strip_tac \\ gvs [domain_lookup] + \\ Cases_on ‘lookup n1 data.map’ \\ gvs [] \\ first_x_assum drule \\ strip_tac \\ gvs [domain_lookup] +QED + +Theorem is_complex_canonical[simp]: + ∀data a. is_complex (canonicalArith data a) = is_complex a +Proof + Cases_on ‘a’ \\ gvs [canonicalArith_def, is_complex_def] +QED + Theorem wordToNum_unique[simp]: ∀c1 c2. wordToNum c1 = wordToNum c2 ⇔ c1 = c2 Proof @@ -194,7 +226,8 @@ Proof QED Theorem are_reads_seen_insert[simp]: - ∀a data r. are_reads_seen a data ⇒ are_reads_seen a (data with all_names := insert r () data.all_names) + ∀a data r. are_reads_seen a data ⇒ + are_reads_seen a (data with all_names := insert r () data.all_names) Proof rpt gen_tac \\ strip_tac \\ Cases_on ‘a’ \\ gvs [are_reads_seen_def, is_seen_def, lookup_insert] @@ -207,14 +240,30 @@ Proof \\ Cases_on ‘lookup n1 data.all_names’ \\ gvs [] QED -Theorem are_reads_seen_insert_bis[simp]: - ∀a data r n l. are_reads_seen a data ⇒ - are_reads_seen a (data with <| instrs:=insert data.instrs l r; +Theorem are_reads_seen_insert_instrs[simp]: + ∀a data n l. are_reads_seen a data ⇒ + are_reads_seen a (data with <| instrs:= l ; all_names:=insert n () data.all_names |>) Proof rpt gen_tac \\ strip_tac \\ Cases_on ‘a’ \\ gvs [are_reads_seen_def, is_seen_def, lookup_insert] - >- (Cases_on ‘r'’ \\ gvs [are_reads_seen_def, is_seen_def, lookup_insert] + >- (Cases_on ‘r’ \\ gvs [are_reads_seen_def, is_seen_def, lookup_insert] + \\ Cases_on ‘lookup n0 data.all_names’ \\ gvs [] + \\ Cases_on ‘n0=n’ \\ gvs [] + \\ Cases_on ‘lookup n'' data.all_names’ \\ gvs [] + \\ Cases_on ‘n''=r’ \\ gvs []) + \\ Cases_on ‘lookup n0 data.all_names’ \\ gvs [] + \\ Cases_on ‘lookup n1 data.all_names’ \\ gvs [] +QED + +Theorem are_reads_seen_insert_map[simp]: + ∀a data n l. are_reads_seen a data ⇒ + are_reads_seen a (data with <| map:= l ; + all_names:=insert n () data.all_names |>) +Proof + rpt gen_tac \\ strip_tac + \\ Cases_on ‘a’ \\ gvs [are_reads_seen_def, is_seen_def, lookup_insert] + >- (Cases_on ‘r’ \\ gvs [are_reads_seen_def, is_seen_def, lookup_insert] \\ Cases_on ‘lookup n0 data.all_names’ \\ gvs [] \\ Cases_on ‘n0=n’ \\ gvs [] \\ Cases_on ‘lookup n'' data.all_names’ \\ gvs [] @@ -416,6 +465,181 @@ Proof \\ gvs [set_vars_def, alist_insert_def, get_var_def, lookup_insert] QED +Theorem get_set_vars_not_in[local]: + ∀rs vs r s. ¬MEM r rs ⇒ get_var r (set_vars rs vs s) = get_var r s +Proof + Induct \\ gvs [set_vars_def] + >- gvs [alist_insert_def, get_var_def] + \\ rpt strip_tac + \\ gvs [get_var_def] + \\ Cases_on ‘vs’ \\ gvs [alist_insert_def, lookup_insert] +QED + +Theorem MEM_FST_reduc: + ∀moves r p_2. MEM (r,p_2) moves ⇒ MEM r (MAP FST moves) +Proof + Induct \\ gvs [] + \\ rpt strip_tac + >- (Cases_on ‘h’ \\ gvs []) + \\ first_x_assum drule \\ rw [] +QED + +Theorem get_set_vars_in[local]: + ∀moves r p_2 x s. + MEM (r,p_2) moves ⇒ + ALL_DISTINCT (MAP FST moves) ⇒ + get_vars (MAP SND moves) s = SOME x ⇒ + get_var r (set_vars (MAP FST moves) x s) = get_var p_2 s +Proof + Induct \\ gvs [set_vars_def] + \\ rpt strip_tac + >- (Cases_on ‘x’ \\ gvs [alist_insert_def, get_vars_def, AllCaseEqs()] + \\ gvs [get_var_def, lookup_insert]) + \\ gvs [get_vars_def, AllCaseEqs()] + \\ first_x_assum drule_all \\ strip_tac + \\ gvs [alist_insert_def, get_var_def] + \\ Cases_on ‘h’ \\ gvs [lookup_insert] + \\ drule MEM_FST_reduc \\ strip_tac + \\ Cases_on ‘r=q’ \\ gvs [] +QED + +Theorem get_set_vars_in_2[local]: + ∀moves r p_2 x' x data s. + MEM (r,p_2) moves ⇒ + ALL_DISTINCT (MAP FST moves) ⇒ + lookup p_2 data.map = SOME x' ⇒ + get_vars (MAP SND (MAP (λ(a,b). (a,canonicalRegs data b)) moves)) s = SOME x ⇒ + get_var r (set_vars (MAP FST moves) x s) = get_var x' s +Proof + Induct \\ gvs [set_vars_def] + \\ rpt strip_tac + >- (Cases_on ‘x’ \\ gvs [alist_insert_def, get_vars_def, AllCaseEqs()] + \\ gvs [get_var_def, lookup_insert, canonicalRegs_def, lookup_any_def]) + \\ gvs [get_vars_def, AllCaseEqs()] + \\ first_x_assum drule_all \\ strip_tac + \\ gvs [alist_insert_def, get_var_def] + \\ Cases_on ‘h’ \\ gvs [lookup_insert] + \\ drule MEM_FST_reduc \\ strip_tac + \\ Cases_on ‘r=q’ \\ gvs [canonicalRegs_def, lookup_any_def] +QED + +val insert_insert = store_thm("insert_insert", + ``!x1 x2 v1 v2 t. + insert x1 v1 (insert x2 v2 t) = + if x1 = x2 then insert x1 v1 t else insert x2 v2 (insert x1 v1 t)``, + rpt strip_tac + \\ qspec_tac (`x1`,`x1`) + \\ qspec_tac (`v1`,`v1`) + \\ qspec_tac (`t`,`t`) + \\ qspec_tac (`v2`,`v2`) + \\ qspec_tac (`x2`,`x2`) + \\ recInduct insert_ind \\ rpt strip_tac \\ + (Cases_on `k = 0` \\ fs [] THEN1 + (once_rewrite_tac [insert_def] \\ fs [] \\ rw [] + THEN1 (once_rewrite_tac [insert_def] \\ fs []) + \\ once_rewrite_tac [insert_def] \\ fs [] \\ rw []) + \\ once_rewrite_tac [insert_def] \\ fs [] \\ rw [] + \\ simp [Once insert_def] + \\ once_rewrite_tac [EQ_SYM_EQ] + \\ simp [Once insert_def] + \\ Cases_on `x1` \\ fs [ADD1] + \\ Cases_on `k` \\ fs [ADD1] + \\ rw [] \\ fs [EVEN_ADD] + \\ fs [GSYM ODD_EVEN] + \\ fs [EVEN_EXISTS,ODD_EXISTS] \\ rpt BasicProvers.var_eq_tac + \\ fs [ADD1,DIV_MULT|>ONCE_REWRITE_RULE[MULT_COMM], + MULT_DIV|>ONCE_REWRITE_RULE[MULT_COMM]])); + +Theorem lookup_set_vars_not_in[local]: + ∀moves v data c x. + ¬MEM v (MAP FST moves) ⇒ + lookup v s.locals = SOME (Word c) ⇒ + lookup v (set_vars (MAP FST moves) x s).locals = SOME (Word c) +Proof + Induct \\ gvs [set_vars_def] + >- gvs [alist_insert_def, get_var_def] + \\ rpt strip_tac + \\ gvs [get_var_def] + \\ Cases_on ‘x’ \\ gvs [alist_insert_def, lookup_insert] +QED + +Theorem list_insert_insert[local]: + ∀l n an. list_insert l (insert n () an) = insert n () (list_insert l an) +Proof + Induct \\ gvs [list_insert_def] + \\ rpt gen_tac + \\ Cases_on ‘h=n’ \\ gvs [] + \\ qspecl_then [‘h’, ‘n’, ‘()’, ‘()’, ‘list_insert l an’] assume_tac insert_insert + \\ gvs [] +QED + +Theorem are_reads_seen_insert_list[local]: + ∀l a data m. + ¬is_complex a ⇒ + are_reads_seen a data ⇒ + are_reads_seen a (data with <| map:= m ; + all_names:=list_insert l data.all_names |>) +Proof + Induct \\ rpt strip_tac \\ gvs [list_insert_def] + \\ Cases_on ‘a’ \\ gvs [is_complex_def, are_reads_seen_def, is_seen_def] + >- (Cases_on ‘r’ \\ gvs [are_reads_seen_def, is_seen_def]) + >- (Cases_on ‘r’ \\ gvs [are_reads_seen_def, is_seen_def] + \\ gvs [list_insert_insert, lookup_insert] + >- (‘¬is_complex (Binop Add n n0 (Reg n'))’ by gvs [is_complex_def] + \\ last_x_assum drule \\ strip_tac + \\ gvs [are_reads_seen_def, is_seen_def] + \\ pop_assum drule_all \\ strip_tac + \\ Cases_on ‘n0=h’ \\ Cases_on ‘n'=h’ \\ gvs []) + \\ ‘¬is_complex (Binop Add n n0 (Imm x))’ by gvs [is_complex_def] + \\ last_x_assum drule \\ strip_tac + \\ gvs [are_reads_seen_def, is_seen_def] + \\ pop_assum drule_all \\ strip_tac + \\ Cases_on ‘n0=h’ \\ gvs []) + >- (‘¬is_complex (Shift s d n0 x)’ by gvs [is_complex_def] + \\ last_x_assum drule \\ strip_tac + \\ gvs [are_reads_seen_def, is_seen_def, list_insert_insert] + \\ pop_assum drule_all \\ strip_tac + \\ Cases_on ‘n0=h’ \\ gvs [lookup_insert]) + \\ ‘¬is_complex (Div n n0 n1)’ by gvs [is_complex_def] + \\ last_x_assum drule \\ strip_tac + \\ gvs [are_reads_seen_def, is_seen_def, list_insert_insert] + \\ pop_assum drule_all \\ strip_tac + \\ Cases_on ‘n0=h’ \\ Cases_on ‘n1=h’ \\ gvs [lookup_insert] +QED + +Theorem evaluate_arith_insert_list[local]: + ∀x a w s y. (∀p. MEM p x ⇒ ¬is_seen p data) ⇒ + ¬is_complex a ⇒ + are_reads_seen a data ⇒ + evaluate (Inst (Arith a), s) = (NONE, set_var (firstRegOfArith a) w s) ⇒ + evaluate (Inst (Arith a), set_vars x y s) = + (NONE, set_var (firstRegOfArith a) w (set_vars x y s)) +Proof + Induct \\ gvs [set_vars_def, alist_insert_def] + \\ rpt strip_tac + \\ ‘∀p. MEM p x ⇒ ¬is_seen p data’ by metis_tac [] + \\ last_x_assum drule_all \\ strip_tac + \\ Cases_on ‘y’ \\ gvs [alist_insert_def] + \\ first_x_assum (qspec_then ‘t’ mp_tac) \\ strip_tac + \\ last_x_assum (qspec_then ‘h’ mp_tac) \\ strip_tac + \\ gvs [] + \\ drule_all evaluate_arith_insert + \\ gvs [set_var_def] +QED + +Theorem MEM_FST_not_seen[local]: + ∀moves data. + (∀p_1 p_2. MEM (p_1,p_2) moves ⇒ ¬is_seen p_1 data) ⇒ + ∀p. MEM p (MAP FST moves) ⇒ ¬is_seen p data +Proof + Induct \\ gvs [] + \\ rpt gen_tac \\ strip_tac \\ gen_tac \\ strip_tac + >- (Cases_on ‘h’ \\ gvs []) + \\ ‘∀p_1 p_2. MEM (p_1,p_2) moves ⇒ ¬is_seen p_1 data’ by metis_tac [] + \\ strip_tac + \\ last_x_assum drule \\ disch_then drule \\ gvs [] +QED + Theorem comp_Move_correct: ^(get_goal "Move") Proof @@ -432,11 +656,12 @@ Proof (*\\ gvs [EVERY_MEM, FORALL_PROD]*) \\ gvs [data_inv_def] (* print_match [] “domain (list_insert _ _)” *) - \\ gvs [domain_list_insert] + \\ gvs [domain_list_insert, MEM_FILTER, ODD_EVEN] \\ rpt conj_tac >- (rpt gen_tac \\ strip_tac \\ gvs [lookup_map_insert, AllCaseEqs()] - >- (gvs [ALOOKUP_NONE, MEM_MAP, MEM_FILTER, FORALL_PROD, EXISTS_PROD] + >- (qpat_x_assum ‘EVERY _ _’ kall_tac + \\ gvs [ALOOKUP_NONE, MEM_MAP, MEM_FILTER, FORALL_PROD, EXISTS_PROD] \\ last_x_assum drule \\ strip_tac \\ gvs [] \\ irule get_set_vars_lemma @@ -444,74 +669,48 @@ Proof \\ first_x_assum drule \\ gvs [is_seen_def, domain_lookup]) \\ drule ALOOKUP_MEM \\ strip_tac \\ gvs [MEM_FILTER, MEM_MAP, EXISTS_PROD] - \\ gvs [MAP_MAP_o, combinTheory.o_DEF, LAMBDA_PROD] - - - - \\ rpt (pop_assum mp_tac) - \\ qid_spec_tac ‘data’ - \\ qid_spec_tac ‘s’ - \\ qid_spec_tac ‘x’ - \\ qid_spec_tac ‘moves’ - \\ Induct - >- gvs [set_vars_def, canonicalMoveRegs_aux_def, alist_insert_def, data_inv_locals] - \\ rpt strip_tac - \\ Cases_on ‘h’ \\ gvs [] - \\ gvs [canonicalMoveRegs_aux_def] - \\ IF_CASES_TAC - >- (pop_assum kall_tac - \\ gvs [set_vars_def] - \\ rpt gen_tac - \\ Cases_on ‘x’ \\ gvs [alist_insert_def] - >- (gvs [get_vars_def] - \\ Cases_on ‘get_var r s’ \\ gvs [] - \\ Cases_on ‘get_vars (MAP SND (MAP (λ(a,b). (a,canonicalRegs data b)) moves)) s’ \\ gvs []) - \\ irule data_inv_insert \\ gvs [] - \\ last_x_assum irule \\ gvs [get_vars_def] - \\ Cases_on ‘get_var r s’ \\ gvs [] - \\ Cases_on ‘get_vars (MAP SND (MAP (λ(a,b). (a,canonicalRegs data b)) moves)) s’ \\ gvs [] - \\ rpt (first_x_assum mp_tac) - \\ qid_spec_tac ‘t’ - \\ Induct_on ‘moves’ \\ gvs [] - \\ rpt strip_tac - \\ Cases_on ‘get_vars (SND h'::MAP SND moves) s’ \\ gvs [] - ) - - \\ gvs [set_vars_def, get_vars_def, AllCaseEqs()] - \\ gvs [alist_insert_def] - - \\ qabbrev_tac ‘data1 = data with <|map := insert q (canonicalRegs data r) data.map; - all_names := insert q () data.all_names|>’ - - \\ qsuff_tac ‘data_inv - (canonicalMoveRegs_aux - (data with - <|map := insert q (canonicalRegs data r) data.map; - all_names := insert q () data.all_names|>) - (MAP (λ(a,b). (a,canonicalRegs data b)) moves)) - ((s with locals := insert q x' s.locals) with - locals := (alist_insert (MAP FST moves) xs (s with locals := insert q x' s.locals).locals))’ - >- cheat (* easier *) - \\ cheat - - (* - \\ last_x_assum irule - - \\ ‘data_inv (data with <|map := insert q (canonicalRegs data r) data.map; all_names := insert q () data.all_names|>) - (s with locals := insert q x' s.locals)’ by cheat - \\ last_x_assum drule - \\ disch_then (qspec_then ‘xs’ mp_tac) - \\ impl_tac - - \\ Cases_on ‘get_var r s’ \\ gvs [] - \\ Cases_on ‘get_vars (MAP SND (MAP (λ(a,b). (a,canonicalRegs data b)) moves)) s’ \\ gvs [] - \\ gvs [data_inv_def] \\ rpt strip_tac - >- (first_x_assum (drule_at Any) \\ strip_tac \\ gvs [get_var_def, lookup_insert] - \\ Cases_on ‘r' = q’ \\ gvs [] - \\ Cases_on ‘v = q’ \\ gvs [] \\ cheat) - (* Proof hard stuck *) + \\ Cases_on ‘lookup p_2 data.map’ \\ gvs [] + >- (‘canonicalRegs data p_2 = p_2’ by gvs [canonicalRegs_def, lookup_any_def] + \\ gvs [EVERY_MEM, FORALL_PROD] + \\ first_assum drule \\ strip_tac \\ gvs [] + \\ ‘¬MEM p_2 (MAP FST moves)’ + by (CCONTR_TAC \\ gvs [MEM_MAP] + \\ Cases_on ‘y’ \\ gvs [] + \\ last_x_assum drule \\ gvs []) + \\ simp [get_set_vars_not_in] + \\ simp [get_set_vars_in] + \\ gvs [is_seen_def, domain_lookup] + \\ Cases_on ‘lookup p_2 data.all_names’ \\ gvs [] + \\ metis_tac []) + \\ last_x_assum drule \\ strip_tac \\ gvs [] + \\ simp [canonicalRegs_def, lookup_any_def] + \\ gvs [EVERY_MEM, FORALL_PROD] + \\ ‘¬MEM x' (MAP FST moves)’ + by (CCONTR_TAC \\ gvs [MEM_MAP] + \\ Cases_on ‘y’ \\ gvs [] + \\ last_x_assum drule \\ gvs [is_seen_def, domain_lookup]) + \\ simp [get_set_vars_not_in] + \\ drule_all get_set_vars_in_2 \\ metis_tac []) + >- (rpt gen_tac \\ strip_tac + \\ first_x_assum drule \\ strip_tac + \\ gvs [EVERY_MEM, FORALL_PROD] + \\ ‘¬MEM v (MAP FST moves)’ + by (strip_tac \\ drule MEM_FST_not_seen \\ strip_tac + \\ pop_assum drule \\ gvs [is_seen_def, domain_lookup]) + \\ drule_all lookup_set_vars_not_in + \\ rw []) + >- (rpt gen_tac \\ strip_tac + \\ first_x_assum drule \\ strip_tac + \\ gvs [EVERY_MEM, FORALL_PROD] + \\ drule are_reads_seen_insert_list \\ rw [] + \\ drule MEM_FST_not_seen \\ strip_tac + \\ drule_all evaluate_arith_insert_list \\ strip_tac + \\ qexists_tac ‘w’ \\ gvs [] + \\ ‘¬MEM v (MAP FST moves)’ + by (CCONTR_TAC \\ gvs [] + \\ first_x_assum drule \\ gvs [is_seen_def, domain_lookup]) + \\ rw [get_set_vars_not_in]) \\ cheat - *) QED Theorem data_inv_unchanged_map: @@ -542,6 +741,30 @@ Proof \\ Cases_on ‘n1=n2’ \\ gvs [set_var_def, lookup_insert, domain_lookup, is_seen_def] QED +Theorem Inst_Arith_NONE_lemma: + ∀data s s' a. + data_inv data s ⇒ + inst (Arith a) s = SOME s' ⇒ + ¬is_complex a ⇒ are_reads_seen a data ⇒ ¬is_seen (firstRegOfArith a) data ⇒ + data_inv (data with <|instrs:=insert data.instrs (instToNumList (Arith (canonicalArith data a))) (firstRegOfArith a); + all_names:=insert (firstRegOfArith a) () data.all_names|>) s' +Proof + cheat +QED + +Theorem Inst_Arith_SOME_lemma: + ∀data s s' a x. + data_inv data s ⇒ + inst (Arith a) s = SOME s' ⇒ + ¬is_complex a ⇒ are_reads_seen a data ⇒ ¬is_seen (firstRegOfArith a) data ⇒ + lookup data.instrs (instToNumList (Arith (canonicalArith data a))) = SOME x ⇒ + data_inv (data with <|eq := regsUpdate x (firstRegOfArith a) data.eq; + map := insert (firstRegOfArith a) x data.map; + all_names := insert (firstRegOfArith a) () data.all_names|>) s' +Proof + cheat +QED + Theorem comp_Inst_correct: ^(get_goal "Inst") Proof @@ -604,143 +827,72 @@ Proof \\ Cases_on ‘v=n’ \\ Cases_on ‘src=n’ \\ gvs [lookup_insert, domain_lookup, is_seen_def] ) - - - \\ pairarg_tac \\ gvs [] - \\ Cases_on ‘is_seen n data’ \\ gvs [evaluate_def, add_to_data_def, add_to_data_aux_def] - \\ Cases_on ‘lookup data.instrs (instToNumList (Const n c))’ \\ gvs[evaluate_def] - >- ( gvs [inst_def, assign_def, word_exp_def, data_inv_def] - \\ strip_tac - >- (rpt gen_tac \\ strip_tac \\ first_x_assum drule_all \\ strip_tac - \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup] - \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [is_seen_def]) - \\ strip_tac - >- (rpt gen_tac \\ gvs [set_var_def, lookup_insert, domain_lookup] - \\ Cases_on ‘c = c'’ \\ gvs [instToNumList_def, wordToNum_def, mlmapTheory.lookup_insert, word_exp_def] - \\ strip_tac \\ first_x_assum drule_all - \\ strip_tac \\ Cases_on ‘v = n’ \\ gvs [is_seen_def]) - \\ strip_tac - >- (rpt gen_tac \\ gvs [instToNumList_def, arithToNumList_def, mlmapTheory.lookup_insert] - \\ strip_tac \\ first_assum drule_all \\ strip_tac - \\ Cases_on ‘v=n’ - >- gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def] - \\ Cases_on ‘a’ \\ gvs [is_complex_def, get_var_def, set_var_def, lookup_insert] - - >- (last_x_assum kall_tac - \\ last_x_assum kall_tac - \\ last_x_assum kall_tac - \\ last_x_assum kall_tac - \\ last_x_assum kall_tac - \\ Cases_on ‘n0=n’ - \\ Cases_on ‘r=Reg n’ - >- (cheat) - >- (cheat) - >- (cheat) - >- (cheat) - ) - >- (last_x_assum kall_tac - \\ last_x_assum kall_tac - \\ last_x_assum kall_tac - \\ last_x_assum kall_tac - \\ last_x_assum kall_tac - \\ Cases_on ‘n0=n’ - >- (cheat) - >- (cheat) - ) - \\ last_x_assum kall_tac - \\ last_x_assum kall_tac - \\ last_x_assum kall_tac - \\ last_x_assum kall_tac - \\ last_x_assum kall_tac - \\ Cases_on ‘n0=n’ - \\ Cases_on ‘n1=n’ - >- (cheat) - >- (cheat) - >- (cheat) - >- (cheat) - ) - \\ cheat - ) - \\ Cases_on ‘inst (Const n c) s’ \\ gvs [inst_def, assign_def, word_exp_def, data_inv_def] - \\ strip_tac - >- (first_x_assum drule_all \\ strip_tac - \\ gvs [get_vars_def, get_var_def, set_vars_def, alist_insert_def, set_var_def]) - \\ strip_tac - >- (first_x_assum drule_all \\ strip_tac - \\ rpt gen_tac - \\ gvs [lookup_insert] - \\ Cases_on ‘r = n’ \\ strip_tac \\ gvs [] - >- (Cases_on ‘n=v’ \\ gvs [set_var_def, get_var_def, lookup_insert]) - \\ gvs [set_var_def, get_var_def, lookup_insert] - \\ first_x_assum drule_all \\ strip_tac \\ gvs [] - \\ Cases_on ‘v = n’ \\ gvs [domain_lookup, is_seen_def]) - \\ strip_tac - >- (first_assum drule_all \\ strip_tac \\ rpt gen_tac \\ strip_tac \\ first_x_assum drule_all - \\ strip_tac \\ gvs [set_var_def, lookup_insert, domain_lookup, is_seen_def] - \\ Cases_on ‘v=n’ \\ gvs [] ) - \\ strip_tac - >- (first_assum drule_all \\ strip_tac \\ rpt gen_tac \\ strip_tac \\ first_x_assum drule_all - \\ strip_tac \\ gvs [set_var_def, get_var_def, lookup_insert, domain_lookup, is_seen_def] - \\ Cases_on ‘v = n’ \\ gvs [] - \\ cheat) - \\ first_x_assum drule_all \\ strip_tac - \\ rpt gen_tac \\ strip_tac - \\ first_x_assum drule_all \\ strip_tac \\ gvs[get_var_def, set_var_def, lookup_insert] - \\ Cases_on ‘v=n’ \\ Cases_on ‘src=n’ \\ gvs [domain_lookup] - \\ cheat - ) - >- (* Arith *) - ( gvs [word_cse_def, word_cseInst_def] + (gvs [word_cse_def, word_cseInst_def] \\ pairarg_tac \\ gvs [] - \\ Cases_on ‘is_seen (firstRegOfArith a) data’ \\ gvs [] + \\ Cases_on ‘is_seen (firstRegOfArith a) data’ \\ gvs [evaluate_def] + \\ Cases_on ‘is_complex a’ \\ gvs [evaluate_def] + \\ drule_all are_reads_seen_canonical \\ strip_tac \\ gvs [] + \\ Cases_on ‘are_reads_seen a data’ \\ gvs [evaluate_def] + \\ Cases_on ‘inst (Arith a) s’ \\ gvs [add_to_data_def, add_to_data_aux_def] \\ Cases_on ‘lookup data.instrs (instToNumList (Arith (canonicalArith data a)))’ \\ gvs [evaluate_def] - >- ( strip_tac \\ cases_on ‘inst (Arith a) s’ \\ gvs [] - \\ gvs [data_inv_def] - \\ strip_tac - >- (rpt gen_tac \\ strip_tac \\ first_x_assum drule_all \\ strip_tac - \\ Cases_on ‘a’ \\ gvs [inst_def, assign_def] - >- (Cases_on ‘word_exp s (Op b [Var n0; case r' of Reg r3 => Var r3 | Imm w => Const w])’ - \\ gvs [get_var_def, set_var_def, lookup_insert] - \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [word_exp_def] - \\ gvs [firstRegOfArith_def, is_seen_def, domain_lookup]) - >- (Cases_on ‘word_exp s (Shift s'' (Var n0) n1)’ - \\ gvs [get_var_def, set_var_def, lookup_insert] - \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [word_exp_def] - \\ gvs [firstRegOfArith_def, is_seen_def, domain_lookup]) - >- (Cases_on ‘get_vars [n1; n0] s’ \\ gvs [get_var_def, set_var_def] - \\ Cases_on ‘x’ \\ gvs [] - \\ Cases_on ‘t’ \\ gvs [] - \\ Cases_on ‘h'’ \\ gvs [] - \\ Cases_on ‘h’ \\ gvs [] - \\ Cases_on ‘t'’ \\ gvs [] - \\ gvs [lookup_insert] - \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [] - \\ gvs [firstRegOfArith_def, is_seen_def, domain_lookup]) - >- (Cases_on ‘get_vars [n1; n2] s’ - \\ gvs [get_var_def, set_var_def, lookup_insert] - \\ Cases_on ‘x’ \\ gvs [] - \\ Cases_on ‘t’ \\ gvs [] - \\ Cases_on ‘h'’ \\ gvs [] - \\ Cases_on ‘h’ \\ gvs [] - \\ Cases_on ‘t'’ \\ gvs [] - \\ gvs [lookup_insert] - \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [word_exp_def] - \\ gvs [firstRegOfArith_def, is_seen_def, domain_lookup] - \\ Cases_on ‘r=n0’ \\ Cases_on ‘v=n0’ \\ gvs [word_exp_def] - \\ gvs [firstRegOfArith_def, is_seen_def, domain_lookup] - \\ cheat) - >- (cheat) - >- (cheat) - >- (cheat) - >- (cheat) - ) - \\ cheat) - \\ cheat - ) + >- (drule_all Inst_Arith_NONE_lemma \\ rw []) + \\ drule_all Inst_Arith_SOME_lemma \\ rw [] + \\ pop_assum kall_tac + \\ gvs [get_vars_def, data_inv_def] + \\ first_x_assum drule \\ pop_assum kall_tac \\ strip_tac \\ gvs [] + \\ Cases_on ‘a’ \\ gvs [is_complex_def, firstRegOfArith_def, inst_def, assign_def] + >- (Cases_on ‘r’ \\ gvs [word_exp_def] + \\ gvs [are_reads_seen_def, canonicalArith_def, canonicalRegs_def, + canonicalImmReg_def, lookup_any_def] + >- (Cases_on ‘lookup n0 data.map’ \\ gvs [] + >- (Cases_on ‘lookup n' data.map’ \\ gvs [] + >- gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, + assign_def, word_exp_def, set_var_def] + \\ first_x_assum drule \\ strip_tac + \\ gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, + assign_def, word_exp_def, set_var_def, get_var_def]) + \\ first_assum drule \\ pop_assum kall_tac \\ strip_tac + \\ Cases_on ‘lookup n' data.map’ \\ gvs [] + >- gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, + assign_def, word_exp_def, set_var_def, get_var_def] + \\ first_x_assum drule \\ strip_tac + \\ gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, + assign_def, word_exp_def, set_var_def, get_var_def]) + \\ Cases_on ‘lookup n0 data.map’ \\ gvs [] + >- gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, + assign_def, word_exp_def, set_var_def] + \\ first_x_assum drule \\ strip_tac + \\ gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, + assign_def, word_exp_def, set_var_def, get_var_def]) + >- (gvs [word_exp_def, are_reads_seen_def, canonicalArith_def, + canonicalRegs_def, canonicalImmReg_def, lookup_any_def] + \\ Cases_on ‘lookup n0 data.map’ \\ gvs [] + >- gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, + assign_def, word_exp_def, set_var_def] + \\ first_x_assum drule \\ strip_tac + \\ gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, + assign_def, word_exp_def, set_var_def, get_var_def]) + \\ gvs [word_exp_def, are_reads_seen_def, canonicalArith_def, + canonicalRegs_def, canonicalImmReg_def, lookup_any_def] + \\ Cases_on ‘lookup n0 data.map’ \\ gvs [] + >- (Cases_on ‘lookup n1 data.map’ \\ gvs [] + >- gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, + assign_def, word_exp_def, set_var_def] + \\ first_x_assum drule \\ strip_tac + \\ gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, + assign_def, word_exp_def, set_var_def, get_var_def, get_vars_def]) + \\ first_assum drule \\ pop_assum kall_tac \\ strip_tac + \\ Cases_on ‘lookup n1 data.map’ \\ gvs [] + >- gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, + assign_def, word_exp_def, set_var_def, get_var_def, get_vars_def] + \\ first_assum drule \\ pop_assum kall_tac \\ strip_tac + \\ gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, + assign_def, word_exp_def, set_var_def, get_var_def, get_vars_def]) + >- (* Mem *) ( Cases_on ‘a’ - \\ gvs [evaluate_def, word_cse_def, word_cseInst_def, data_inv_def, empty_data_def, lookup_def] ) + \\ gvs [evaluate_def, word_cse_def, word_cseInst_def, data_inv_def, empty_data_def, lookup_def] \\ cheat) >- (* FP *) ( gvs [evaluate_def, word_cse_def, word_cseInst_def, data_inv_def, empty_data_def, lookup_def] ) QED diff --git a/compiler/backend/word_cseScript.sml b/compiler/backend/word_cseScript.sml index 51fc4dd785..06bac2c6b8 100644 --- a/compiler/backend/word_cseScript.sml +++ b/compiler/backend/word_cseScript.sml @@ -182,10 +182,12 @@ End Definition canonicalMoveRegs3_def: canonicalMoveRegs3 data moves = let moves' = MAP (λ(a,b). (a, canonicalRegs data b)) moves in - if EXISTS (λ(a,b). is_seen a data) moves then (empty_data, moves') + if EXISTS (λ(a,b). is_seen a data) moves ∨ + ¬EVERY (λ(a,b). EVEN b ∨ is_seen b data) moves + then (empty_data, moves') else let xs = FILTER (λ(a,b). ¬EVEN a ∧ ¬EVEN b) moves' in - let a_n = list_insert (MAP FST xs) data.all_names in + let a_n = list_insert (FILTER ODD (MAP FST moves)) data.all_names in let m = map_insert xs data.map in (data with <| all_names := a_n; map := m |>, moves') End From cea689850b7402be3671749c1fc33e2afc7f69ac Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Fri, 8 Jul 2022 19:44:43 +0200 Subject: [PATCH 26/36] Inst Mem case proof --- .../backend/proofs/word_cseProofScript.sml | 21 +++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/compiler/backend/proofs/word_cseProofScript.sml b/compiler/backend/proofs/word_cseProofScript.sml index df7025e478..11cc8fa2cf 100644 --- a/compiler/backend/proofs/word_cseProofScript.sml +++ b/compiler/backend/proofs/word_cseProofScript.sml @@ -888,11 +888,28 @@ Proof assign_def, word_exp_def, set_var_def, get_var_def, get_vars_def] \\ first_assum drule \\ pop_assum kall_tac \\ strip_tac \\ gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, - assign_def, word_exp_def, set_var_def, get_var_def, get_vars_def]) + assign_def, word_exp_def, set_var_def, get_var_def, get_vars_def] + ) >- (* Mem *) ( Cases_on ‘a’ - \\ gvs [evaluate_def, word_cse_def, word_cseInst_def, data_inv_def, empty_data_def, lookup_def] \\ cheat) + \\ gvs [word_cse_def, word_cseInst_def] + \\ Cases_on ‘is_store m’ \\ gvs [] + >- (Cases_on ‘m’ \\ gvs [is_store_def, evaluate_def, inst_def, word_exp_def, the_words_def] + \\ gvs [AllCaseEqs()] + \\ gvs [mem_store_def, data_inv_def, get_var_def, set_var_def] + \\ reverse(rpt conj_tac) + \\ rpt strip_tac \\ first_x_assum drule \\ strip_tac \\ gvs [word_exp_def] + \\ reverse(Cases_on ‘a'’) + \\ gvs [is_complex_def, evaluate_def, inst_def, assign_def, get_vars_def, + get_var_def, firstRegOfArith_def, set_var_def, AllCaseEqs()] + \\ gvs [state_component_equality, word_exp_def] + \\ Cases_on ‘r’ \\ gvs [word_exp_def, the_words_def]) + \\ Cases_on ‘is_seen n data’ \\ gvs [] + \\ Cases_on ‘m’ \\ gvs [is_store_def, evaluate_def, inst_def, word_exp_def, the_words_def] + \\ gvs [AllCaseEqs()] + \\ gvs [set_var_def] + ) >- (* FP *) ( gvs [evaluate_def, word_cse_def, word_cseInst_def, data_inv_def, empty_data_def, lookup_def] ) QED From aa01e222ac94e99c5a97ffa5d8a1044943079724 Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Fri, 8 Jul 2022 23:32:04 +0200 Subject: [PATCH 27/36] End of Move case, struggle on final lemmas of Inst case --- .../backend/proofs/word_cseProofScript.sml | 192 ++++++++++++++---- 1 file changed, 158 insertions(+), 34 deletions(-) diff --git a/compiler/backend/proofs/word_cseProofScript.sml b/compiler/backend/proofs/word_cseProofScript.sml index 11cc8fa2cf..c1db0053e4 100644 --- a/compiler/backend/proofs/word_cseProofScript.sml +++ b/compiler/backend/proofs/word_cseProofScript.sml @@ -523,33 +523,6 @@ Proof \\ Cases_on ‘r=q’ \\ gvs [canonicalRegs_def, lookup_any_def] QED -val insert_insert = store_thm("insert_insert", - ``!x1 x2 v1 v2 t. - insert x1 v1 (insert x2 v2 t) = - if x1 = x2 then insert x1 v1 t else insert x2 v2 (insert x1 v1 t)``, - rpt strip_tac - \\ qspec_tac (`x1`,`x1`) - \\ qspec_tac (`v1`,`v1`) - \\ qspec_tac (`t`,`t`) - \\ qspec_tac (`v2`,`v2`) - \\ qspec_tac (`x2`,`x2`) - \\ recInduct insert_ind \\ rpt strip_tac \\ - (Cases_on `k = 0` \\ fs [] THEN1 - (once_rewrite_tac [insert_def] \\ fs [] \\ rw [] - THEN1 (once_rewrite_tac [insert_def] \\ fs []) - \\ once_rewrite_tac [insert_def] \\ fs [] \\ rw []) - \\ once_rewrite_tac [insert_def] \\ fs [] \\ rw [] - \\ simp [Once insert_def] - \\ once_rewrite_tac [EQ_SYM_EQ] - \\ simp [Once insert_def] - \\ Cases_on `x1` \\ fs [ADD1] - \\ Cases_on `k` \\ fs [ADD1] - \\ rw [] \\ fs [EVEN_ADD] - \\ fs [GSYM ODD_EVEN] - \\ fs [EVEN_EXISTS,ODD_EXISTS] \\ rpt BasicProvers.var_eq_tac - \\ fs [ADD1,DIV_MULT|>ONCE_REWRITE_RULE[MULT_COMM], - MULT_DIV|>ONCE_REWRITE_RULE[MULT_COMM]])); - Theorem lookup_set_vars_not_in[local]: ∀moves v data c x. ¬MEM v (MAP FST moves) ⇒ @@ -640,6 +613,30 @@ Proof \\ last_x_assum drule \\ disch_then drule \\ gvs [] QED +Theorem lookup_list_insert[local]: + ∀l (n:num) an. lookup n an = SOME () ⇒ + lookup n (list_insert l an) = SOME () +Proof + Induct \\ gvs [list_insert_def] + \\ rpt strip_tac + \\ first_x_assum drule \\ strip_tac + \\ gvs [list_insert_insert] + \\ Cases_on ‘n=h’ \\ gvs [lookup_insert] +QED + +Theorem word_exp_set_vars_not_in: + ∀nl vl n s op. + ¬MEM n nl ⇒ + word_exp (set_vars nl vl s) (Op op [Var n; Lookup CurrHeap]) = + word_exp s (Op op [Var n; Lookup CurrHeap]) +Proof + Induct \\ gvs [set_vars_def, alist_insert_def] + \\ rpt strip_tac + \\ first_x_assum drule \\ strip_tac + \\ Cases_on ‘vl’ \\ gvs [alist_insert_def] + \\ gvs [word_exp_def, lookup_insert] +QED + Theorem comp_Move_correct: ^(get_goal "Move") Proof @@ -710,7 +707,26 @@ Proof by (CCONTR_TAC \\ gvs [] \\ first_x_assum drule \\ gvs [is_seen_def, domain_lookup]) \\ rw [get_set_vars_not_in]) - \\ cheat + \\ rpt gen_tac \\ strip_tac + \\ first_x_assum drule \\ strip_tac + \\ gvs [EVERY_MEM, FORALL_PROD] + \\ gvs [is_seen_def] + \\ Cases_on ‘lookup src data.all_names’ \\ gvs [] + \\ drule lookup_list_insert \\ strip_tac \\ gvs [] + \\ ‘(∀p_1 p_2. MEM (p_1,p_2) moves ⇒ ¬is_seen p_1 data)’ by gvs [is_seen_def, SF SFY_ss] + \\ drule MEM_FST_not_seen \\ strip_tac + \\ ‘¬MEM src (MAP FST moves)’ + by (qspecl_then [‘moves’, ‘data’] assume_tac MEM_FST_not_seen \\ gvs [is_seen_def] + \\ strip_tac + \\ first_x_assum drule \\ rw []) + \\ qspecl_then [‘MAP FST moves’, ‘x’, ‘src’, ‘s’, ‘op’] assume_tac word_exp_set_vars_not_in + \\ rw [] + \\ ‘¬MEM v (MAP FST moves)’ + by (qspecl_then [‘moves’, ‘data’] assume_tac MEM_FST_not_seen \\ gvs [is_seen_def, domain_lookup] + \\ strip_tac + \\ first_x_assum drule \\ rw []) + \\ qspecl_then [‘MAP FST moves’, ‘x’, ‘v’, ‘s’] assume_tac get_set_vars_not_in + \\ pop_assum drule \\ rw [] QED Theorem data_inv_unchanged_map: @@ -746,10 +762,120 @@ Theorem Inst_Arith_NONE_lemma: data_inv data s ⇒ inst (Arith a) s = SOME s' ⇒ ¬is_complex a ⇒ are_reads_seen a data ⇒ ¬is_seen (firstRegOfArith a) data ⇒ - data_inv (data with <|instrs:=insert data.instrs (instToNumList (Arith (canonicalArith data a))) (firstRegOfArith a); + data_inv (data with <|instrs:=insert data.instrs + (instToNumList (Arith (canonicalArith data a))) + (firstRegOfArith a); all_names:=insert (firstRegOfArith a) () data.all_names|>) s' Proof - cheat + rpt strip_tac + \\ Cases_on ‘a’ \\ gvs [is_complex_def, inst_def, assign_def, firstRegOfArith_def, AllCaseEqs()] + \\ gvs [data_inv_def] + >- (rpt conj_tac + >- (rpt gen_tac \\ strip_tac \\ last_x_assum drule \\ strip_tac + \\ gvs [get_var_def, set_var_def, domain_lookup, is_seen_def] + \\ Cases_on ‘r'=n’ \\ Cases_on ‘v=n’ \\ gvs [lookup_insert]) + >- (rpt gen_tac \\ strip_tac \\ gvs [mlmapTheory.lookup_insert, instToNumList_def] + \\ first_x_assum drule \\ strip_tac + \\ Cases_on ‘v=n’ \\ gvs [set_var_def, lookup_insert, is_seen_def, domain_lookup]) + >- (rpt gen_tac \\ strip_tac \\ gvs [mlmapTheory.lookup_insert, instToNumList_def] + \\ Cases_on ‘arithToNumList (canonicalArith data (Binop b n n0 r)) = arithToNumList a’ + \\ gvs [] + >- (Cases_on ‘a’ \\ gvs [arithToNumList_def, canonicalArith_def] + \\ Cases_on ‘r’ \\ Cases_on ‘r'’ + \\ gvs [canonicalRegs_def, canonicalImmReg_def, regImmToNumList_def, lookup_any_def] + \\ gvs [is_complex_def, are_reads_seen_def, is_seen_def] + >- (Cases_on ‘lookup n0 data.map’ \\ gvs [] + \\ Cases_on ‘n0=n’ \\ gvs [lookup_insert] + >- (Cases_on ‘lookup n'' data.map’ \\ gvs [] + \\ Cases_on ‘n''=n’ \\ gvs [] + \\ gvs [get_var_def, set_var_def, lookup_insert] + \\ gvs [evaluate_def, inst_def, assign_def, word_exp_def, lookup_insert] + \\ gvs [set_var_def, firstRegOfArith_def] + \\ first_x_assum drule \\ strip_tac + \\ last_x_assum kall_tac + \\ last_x_assum kall_tac + \\ last_x_assum kall_tac + \\ Cases_on ‘x=n’ \\ gvs [domain_lookup] + ) + \\ first_assum drule \\ pop_assum mp_tac \\ pop_assum kall_tac + \\ strip_tac \\ strip_tac + \\ Cases_on ‘x=n’ \\ gvs [domain_lookup] + \\ Cases_on ‘lookup n'' data.map’ \\ gvs [] + >- (Cases_on ‘n''=n’ \\ gvs [] + \\ gvs [get_var_def, set_var_def, lookup_insert] + \\ gvs [evaluate_def, inst_def, assign_def, word_exp_def, lookup_insert] + \\ gvs [set_var_def, firstRegOfArith_def]) + \\ first_x_assum drule \\ strip_tac + \\ Cases_on ‘x'=n’ \\ gvs [domain_lookup] + \\ gvs [get_var_def, set_var_def, lookup_insert] + \\ gvs [evaluate_def, inst_def, assign_def, word_exp_def, lookup_insert] + \\ gvs [set_var_def, firstRegOfArith_def]) + \\ Cases_on ‘lookup n0 data.map’ \\ gvs [lookup_insert] + >- (Cases_on ‘n0=n’ \\ gvs [] + \\ gvs [get_var_def, set_var_def, lookup_insert] + \\ gvs [evaluate_def, inst_def, assign_def, word_exp_def, lookup_insert] + \\ gvs [set_var_def, firstRegOfArith_def]) + \\ first_x_assum drule \\ strip_tac \\ gvs [] + \\ Cases_on ‘x=n’ \\ gvs [domain_lookup] + \\ gvs [get_var_def, set_var_def, lookup_insert] + \\ gvs [evaluate_def, inst_def, assign_def, word_exp_def, lookup_insert] + \\ gvs [set_var_def, firstRegOfArith_def] + ) + \\ first_x_assum drule \\ strip_tac + \\ Cases_on ‘v=n’ \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def] + \\ qspecl_then [‘a’, ‘w'’, ‘s’, ‘n’, ‘w’] assume_tac evaluate_arith_insert + \\ gvs [is_seen_def, set_var_def]) + \\ rpt gen_tac \\ strip_tac \\ gvs [mlmapTheory.lookup_insert, + instToNumList_def, OpCurrHeapToNumList_def] + \\ first_x_assum drule \\ strip_tac \\ gvs [is_seen_def] + \\ Cases_on ‘src=n’ \\ gvs [lookup_insert] + \\ Cases_on ‘v=n’ \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup] + \\ gvs [word_exp_def, lookup_insert]) + >- (rpt conj_tac + >- (rpt gen_tac \\ strip_tac \\ last_x_assum drule \\ strip_tac + \\ gvs [get_var_def, set_var_def, domain_lookup, is_seen_def] + \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [lookup_insert]) + >- (rpt gen_tac \\ strip_tac \\ gvs [mlmapTheory.lookup_insert, instToNumList_def] + \\ first_x_assum drule \\ strip_tac + \\ Cases_on ‘v=n’ \\ gvs [set_var_def, lookup_insert, is_seen_def, domain_lookup]) + >- (rpt gen_tac \\ strip_tac \\ gvs [mlmapTheory.lookup_insert, instToNumList_def] + \\ Cases_on ‘arithToNumList (canonicalArith data (Shift s'' n n0 n1)) = arithToNumList a’ + \\ gvs [] + >- (Cases_on ‘a’ \\ gvs [arithToNumList_def, canonicalArith_def] + \\ ‘s'=s''’ by (Cases_on ‘s'’ \\ Cases_on ‘s''’ \\ gvs [shiftToNum_def]) + \\ gvs [canonicalRegs_def, canonicalImmReg_def, regImmToNumList_def, lookup_any_def] + \\ gvs [is_complex_def, are_reads_seen_def, is_seen_def] + \\ Cases_on ‘lookup n0 data.map’ \\ gvs [] + >- (Cases_on ‘n0=n’ \\ gvs [lookup_insert] + \\ gvs [get_var_def, set_var_def, lookup_insert] + \\ gvs [evaluate_def, inst_def, assign_def, word_exp_def] + \\ gvs [set_var_def, firstRegOfArith_def, lookup_insert]) + \\ first_x_assum drule \\ strip_tac + \\ Cases_on ‘x=n’ \\ gvs [lookup_insert, domain_lookup] + \\ gvs [get_var_def, set_var_def, lookup_insert] + \\ gvs [evaluate_def, inst_def, assign_def, word_exp_def] + \\ gvs [lookup_insert, set_var_def, firstRegOfArith_def]) + \\ cheat) + \\ rpt gen_tac \\ strip_tac \\ gvs [mlmapTheory.lookup_insert, + instToNumList_def, OpCurrHeapToNumList_def] + \\ first_x_assum drule \\ strip_tac \\ gvs [is_seen_def] + \\ Cases_on ‘src=n’ \\ gvs [lookup_insert] + \\ Cases_on ‘v=n’ \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup] + \\ gvs [word_exp_def, lookup_insert]) + \\ rpt conj_tac + >- (rpt gen_tac \\ strip_tac \\ last_x_assum drule \\ strip_tac + \\ gvs [get_var_def, set_var_def, domain_lookup, is_seen_def] + \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [lookup_insert]) + >- (rpt gen_tac \\ strip_tac \\ gvs [mlmapTheory.lookup_insert, instToNumList_def] + \\ first_x_assum drule \\ strip_tac + \\ Cases_on ‘v=n’ \\ gvs [set_var_def, lookup_insert, is_seen_def, domain_lookup]) + >- (cheat) + \\ rpt gen_tac \\ strip_tac \\ gvs [mlmapTheory.lookup_insert, + instToNumList_def, OpCurrHeapToNumList_def] + \\ first_x_assum drule \\ strip_tac \\ gvs [is_seen_def] + \\ Cases_on ‘src=n’ \\ gvs [lookup_insert] + \\ Cases_on ‘v=n’ \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup] + \\ gvs [word_exp_def, lookup_insert] QED Theorem Inst_Arith_SOME_lemma: @@ -776,8 +902,8 @@ Proof inst_def, flat_exp_conventions_def] \\ strip_tac \\ rw [] \\ gvs [] - \\ first_x_assum (drule_at Any) \\ gvs [] ) - + \\ first_x_assum (drule_at Any) \\ gvs [] + ) >- (* Const *) ( gvs [word_cse_def, word_cseInst_def, evaluate_def, inst_def, assign_def] \\ Cases_on ‘word_exp s (Const c)’ \\ gvs [] @@ -826,7 +952,6 @@ Proof \\ first_x_assum drule \\ strip_tac \\ gvs [] \\ Cases_on ‘v=n’ \\ Cases_on ‘src=n’ \\ gvs [lookup_insert, domain_lookup, is_seen_def] ) - >- (* Arith *) (gvs [word_cse_def, word_cseInst_def] \\ pairarg_tac \\ gvs [] @@ -890,7 +1015,6 @@ Proof \\ gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, assign_def, word_exp_def, set_var_def, get_var_def, get_vars_def] ) - >- (* Mem *) ( Cases_on ‘a’ \\ gvs [word_cse_def, word_cseInst_def] From 7d10ebda5c699375265427d657f7f12026961ee1 Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Sun, 10 Jul 2022 13:23:56 +0200 Subject: [PATCH 28/36] End of the proof. First version of word_cse is working and proven! --- .../backend/proofs/word_cseProofScript.sml | 171 +++++++++++------- 1 file changed, 103 insertions(+), 68 deletions(-) diff --git a/compiler/backend/proofs/word_cseProofScript.sml b/compiler/backend/proofs/word_cseProofScript.sml index c1db0053e4..92fdf27583 100644 --- a/compiler/backend/proofs/word_cseProofScript.sml +++ b/compiler/backend/proofs/word_cseProofScript.sml @@ -272,6 +272,22 @@ Proof \\ Cases_on ‘lookup n1 data.all_names’ \\ gvs [] QED +Theorem are_reads_seen_insert_eq_map[simp]: + ∀a data n l e. are_reads_seen a data ⇒ + are_reads_seen a (data with <| eq:=e ; map:= l ; + all_names:=insert n () data.all_names |>) +Proof + rpt gen_tac \\ strip_tac + \\ Cases_on ‘a’ \\ gvs [are_reads_seen_def, is_seen_def, lookup_insert] + >- (Cases_on ‘r’ \\ gvs [are_reads_seen_def, is_seen_def, lookup_insert] + \\ Cases_on ‘lookup n0 data.all_names’ \\ gvs [] + \\ Cases_on ‘n0=n’ \\ gvs [] + \\ Cases_on ‘lookup n'' data.all_names’ \\ gvs [] + \\ Cases_on ‘n''=r’ \\ gvs []) + \\ Cases_on ‘lookup n0 data.all_names’ \\ gvs [] + \\ Cases_on ‘lookup n1 data.all_names’ \\ gvs [] +QED + Theorem is_seen_insert[simp]: ∀r data r'. is_seen r data ⇒ is_seen r (data with all_names := insert r' () data.all_names) Proof @@ -414,34 +430,6 @@ Proof \\ Cases_on ‘get_vars (MAP SND moves) s’ \\ gvs [] QED -(* -Theorem data_inv_insert[local]: - ∀moves data s q h t. - ¬MEM q (MAP FST moves) ⇒ - ¬is_seen q data ⇒ - data_inv (canonicalMoveRegs_aux data (MAP (λ(a,b). (a,canonicalRegs data b)) moves)) - (s with locals := alist_insert (MAP FST moves) t s.locals) ⇒ - data_inv (canonicalMoveRegs_aux data (MAP (λ(a,b). (a,canonicalRegs data b)) moves)) - (s with locals := insert q h (alist_insert (MAP FST moves) t s.locals)) -Proof - Induct - >- gvs [alist_insert_def] - \\ rpt strip_tac - \\ Cases_on ‘h’ \\ gvs [] - \\ Cases_on ‘t’ \\ gvs [] - >- (‘∀data s q h. - ¬MEM q (MAP FST moves) ⇒ - ¬is_seen q data ⇒ - data_inv (canonicalMoveRegs_aux data (MAP (λ(a,b). (a,canonicalRegs data b)) moves)) - (s with locals := alist_insert (MAP FST moves) [] s.locals) ⇒ - data_inv (canonicalMoveRegs_aux data (MAP (λ(a,b). (a,canonicalRegs data b)) moves)) - (s with locals := insert q h (alist_insert (MAP FST moves) [] s.locals))’ - by gvs [] \\ cheat) - \\ cheat - (* may be false, may need more assumptions like ‘get_vars (MAP SND moves) s = t’ *) -QED -*) - Theorem lookup_map_insert: ∀xs r. lookup r (map_insert xs m) = case ALOOKUP xs r of NONE => lookup r m | SOME r' => SOME r' Proof @@ -839,8 +827,7 @@ Proof \\ first_x_assum drule \\ strip_tac \\ Cases_on ‘v=n’ \\ gvs [set_var_def, lookup_insert, is_seen_def, domain_lookup]) >- (rpt gen_tac \\ strip_tac \\ gvs [mlmapTheory.lookup_insert, instToNumList_def] - \\ Cases_on ‘arithToNumList (canonicalArith data (Shift s'' n n0 n1)) = arithToNumList a’ - \\ gvs [] + \\ gvs [AllCaseEqs()] >- (Cases_on ‘a’ \\ gvs [arithToNumList_def, canonicalArith_def] \\ ‘s'=s''’ by (Cases_on ‘s'’ \\ Cases_on ‘s''’ \\ gvs [shiftToNum_def]) \\ gvs [canonicalRegs_def, canonicalImmReg_def, regImmToNumList_def, lookup_any_def] @@ -855,7 +842,9 @@ Proof \\ gvs [get_var_def, set_var_def, lookup_insert] \\ gvs [evaluate_def, inst_def, assign_def, word_exp_def] \\ gvs [lookup_insert, set_var_def, firstRegOfArith_def]) - \\ cheat) + \\ first_x_assum drule \\ pop_assum kall_tac \\ strip_tac + \\ drule_all evaluate_arith_insert \\ rw [] + \\ Cases_on ‘v=n’ \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def]) \\ rpt gen_tac \\ strip_tac \\ gvs [mlmapTheory.lookup_insert, instToNumList_def, OpCurrHeapToNumList_def] \\ first_x_assum drule \\ strip_tac \\ gvs [is_seen_def] @@ -869,7 +858,38 @@ Proof >- (rpt gen_tac \\ strip_tac \\ gvs [mlmapTheory.lookup_insert, instToNumList_def] \\ first_x_assum drule \\ strip_tac \\ Cases_on ‘v=n’ \\ gvs [set_var_def, lookup_insert, is_seen_def, domain_lookup]) - >- (cheat) + >- (rpt gen_tac \\ strip_tac \\ gvs [mlmapTheory.lookup_insert, instToNumList_def] + \\ gvs [AllCaseEqs()] + >- (Cases_on ‘a’ \\ gvs [arithToNumList_def, canonicalArith_def] + \\ gvs [canonicalRegs_def, lookup_any_def] + \\ gvs [is_complex_def, are_reads_seen_def, is_seen_def] + \\ Cases_on ‘lookup n0 data.map’ \\ gvs [] + >- (Cases_on ‘n0=n’ \\ gvs [lookup_insert] + \\ Cases_on ‘lookup n1 data.map’ \\ gvs [] + >- (Cases_on ‘n1=n’ \\ gvs [] + \\ gvs [get_var_def, set_var_def] + \\ gvs [evaluate_def, inst_def, get_vars_def, get_var_def, lookup_insert] + \\ gvs [set_var_def, firstRegOfArith_def]) + \\ first_x_assum drule \\ strip_tac + \\ Cases_on ‘x=n’ \\ gvs [domain_lookup] + \\ gvs [get_var_def, set_var_def] + \\ gvs [evaluate_def, inst_def, get_vars_def, get_var_def, lookup_insert] + \\ gvs [set_var_def, firstRegOfArith_def]) + \\ first_assum drule \\ pop_assum kall_tac \\ strip_tac + \\ Cases_on ‘x=n’ \\ gvs [lookup_insert, domain_lookup] + \\ Cases_on ‘lookup n1 data.map’ \\ gvs [] + >- (Cases_on ‘n1=n’ \\ gvs [] + \\ gvs [get_var_def, set_var_def] + \\ gvs [evaluate_def, inst_def, get_vars_def, get_var_def, lookup_insert] + \\ gvs [set_var_def, firstRegOfArith_def]) + \\ first_x_assum drule \\ strip_tac + \\ Cases_on ‘x'=n’ \\ gvs [] + \\ gvs [get_var_def, set_var_def] + \\ gvs [evaluate_def, inst_def, get_vars_def, get_var_def, lookup_insert] + \\ gvs [set_var_def, firstRegOfArith_def]) + \\ first_x_assum drule \\ strip_tac + \\ drule_all evaluate_arith_insert \\ rw [] + \\ Cases_on ‘v=n’ \\ gvs [domain_lookup, is_seen_def, get_var_def, set_var_def, lookup_insert, firstRegOfArith_def]) \\ rpt gen_tac \\ strip_tac \\ gvs [mlmapTheory.lookup_insert, instToNumList_def, OpCurrHeapToNumList_def] \\ first_x_assum drule \\ strip_tac \\ gvs [is_seen_def] @@ -888,7 +908,52 @@ Theorem Inst_Arith_SOME_lemma: map := insert (firstRegOfArith a) x data.map; all_names := insert (firstRegOfArith a) () data.all_names|>) s' Proof - cheat + rpt strip_tac + \\ imp_res_tac canonicalArith_correct + \\ last_x_assum mp_tac \\ simp [data_inv_def] \\ strip_tac + \\ first_assum drule \\ strip_tac + \\ qpat_x_assum ‘_ = SOME x’ kall_tac + \\ gvs [evaluate_def] + \\ Cases_on ‘a’ \\ gvs [is_complex_def, firstRegOfArith_def, are_reads_seen_def] + >- (* Binop *) + ( Cases_on ‘r’ \\ gvs [are_reads_seen_def] + \\ (rpt conj_tac + >- (rpt gen_tac + \\ Cases_on ‘r'=n’ \\ gvs [lookup_insert, domain_lookup, is_seen_def] + >- (strip_tac \\ Cases_on ‘v=n’ \\ gvs [get_var_def, set_var_def, lookup_insert]) + \\ strip_tac \\ first_x_assum drule \\ strip_tac + \\ Cases_on ‘r'=n’ \\ Cases_on ‘v=n’ \\ gvs [set_var_def, get_var_def, lookup_insert]) + >- (rpt gen_tac \\ strip_tac + \\ first_x_assum drule \\ pop_assum kall_tac \\ strip_tac + \\ Cases_on ‘v=n’ \\ gvs [set_var_def, lookup_insert, domain_lookup, is_seen_def]) + >- (rpt gen_tac \\ strip_tac + \\ first_x_assum drule \\ pop_assum kall_tac \\ strip_tac + \\ Cases_on ‘v=n’ \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def] + \\ qspecl_then [‘a'’, ‘w'’, ‘s’, ‘n’, ‘w’] assume_tac evaluate_arith_insert + \\ gvs [is_seen_def, evaluate_def, set_var_def]) + \\rpt gen_tac \\ strip_tac + \\ first_x_assum drule \\ pop_assum kall_tac \\ strip_tac + \\ Cases_on ‘v=n’ \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def] + \\ Cases_on ‘src=n’ \\ gvs [word_exp_def, lookup_insert])) + (* Shift and Div *) + \\ (rpt conj_tac + >- (rpt gen_tac + \\ Cases_on ‘r=n’ \\ gvs [lookup_insert, domain_lookup, is_seen_def] + >- (strip_tac \\ Cases_on ‘v=n’ \\ gvs [get_var_def, set_var_def, lookup_insert]) + \\ strip_tac \\ first_x_assum drule \\ strip_tac + \\ Cases_on ‘r'=n’ \\ Cases_on ‘v=n’ \\ gvs [set_var_def, get_var_def, lookup_insert]) + >- (rpt gen_tac \\ strip_tac + \\ first_x_assum drule \\ pop_assum kall_tac \\ strip_tac + \\ Cases_on ‘v=n’ \\ gvs [set_var_def, lookup_insert, domain_lookup, is_seen_def]) + >- (rpt gen_tac \\ strip_tac + \\ first_x_assum drule \\ pop_assum kall_tac \\ strip_tac + \\ Cases_on ‘v=n’ \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def] + \\ qspecl_then [‘a'’, ‘w'’, ‘s’, ‘n’, ‘w’] assume_tac evaluate_arith_insert + \\ gvs [is_seen_def, evaluate_def, set_var_def]) + \\rpt gen_tac \\ strip_tac + \\ first_x_assum drule \\ pop_assum kall_tac \\ strip_tac + \\ Cases_on ‘v=n’ \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def] + \\ Cases_on ‘src=n’ \\ gvs [word_exp_def, lookup_insert]) QED Theorem comp_Inst_correct: @@ -941,14 +1006,7 @@ Proof >- (first_x_assum drule \\ strip_tac \\ gvs [] \\ ‘evaluate (Inst (Arith a),s) = (NONE, set_var (firstRegOfArith a) w s)’ by gvs [set_var_def] \\ drule_all evaluate_arith_insert \\ strip_tac \\ gvs [set_var_def] - \\ Cases_on ‘v=n’ \\ gvs [lookup_insert, domain_lookup, is_seen_def] - \\ Cases_on ‘a’ \\ gvs [is_complex_def] - >- (Cases_on ‘r’ \\ gvs [are_reads_seen_def, is_seen_def] - \\ Cases_on ‘n0=n’ \\ gvs [lookup_insert] - \\ Cases_on ‘n''=n’ \\ gvs []) - \\ gvs [are_reads_seen_def, is_seen_def] - \\ Cases_on ‘n0=n’ \\ gvs [lookup_insert] - \\ Cases_on ‘n1=n’ \\ gvs []) + \\ Cases_on ‘v=n’ \\ gvs [lookup_insert, domain_lookup, is_seen_def]) \\ first_x_assum drule \\ strip_tac \\ gvs [] \\ Cases_on ‘v=n’ \\ Cases_on ‘src=n’ \\ gvs [lookup_insert, domain_lookup, is_seen_def] ) @@ -1111,16 +1169,8 @@ Proof \\ drule_at (Pos last) evaluate_arith_insert \\ strip_tac \\ first_x_assum (qspec_then ‘data’ mp_tac) \\ disch_then drule \\ gvs [] \\ strip_tac - \\ reverse strip_tac - >- (gvs [get_var_def, set_var_def, lookup_insert] \\ rw [] \\ gvs [is_seen_def, domain_lookup]) - \\ Cases_on ‘a’ \\ gvs [is_complex_def] - >- (Cases_on ‘r’ \\ gvs [are_reads_seen_def, is_seen_def] - \\ gvs [lookup_insert] - \\ Cases_on ‘n0=dst’ \\ gvs [domain_lookup] - \\ Cases_on ‘n'=dst’ \\ gvs []) - \\ gvs [are_reads_seen_def, is_seen_def, lookup_insert] - \\ Cases_on ‘n0=dst’ \\ gvs [] - \\ Cases_on ‘n1=dst’ \\ gvs []) + \\ Cases_on ‘v=dst’ + \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def]) \\ gvs [mlmapTheory.lookup_insert] \\ Cases_on ‘OpCurrHeapToNumList b (canonicalRegs data src) = OpCurrHeapToNumList op src'’ \\ gvs [] >- (gvs [is_seen_def, OpCurrHeapToNumList_def, canonicalRegs_def, lookup_any_def] @@ -1154,14 +1204,7 @@ Proof \\ ‘evaluate (Inst (Arith a),s) = (NONE, set_var (firstRegOfArith a) w'' s)’ by gvs [set_var_def] \\ drule_at (Pos last) evaluate_arith_insert \\ strip_tac \\ gvs [is_seen_def] \\ first_x_assum drule_all \\ strip_tac - \\ gvs [set_var_def] - \\ drule_at Any are_reads_seen_insert \\ strip_tac - \\ reverse (Cases_on ‘a’) \\ gvs [are_reads_seen_def, is_complex_def, is_seen_def] - \\ Cases_on ‘n0=dst’ \\ gvs [lookup_insert, domain_lookup] - >- (Cases_on ‘n1=dst’ \\ gvs []) - \\ Cases_on ‘r’ \\ gvs [are_reads_seen_def, is_seen_def] - \\ Cases_on ‘n0=dst’ \\ gvs [lookup_insert, domain_lookup] - \\ Cases_on ‘n'=dst’ \\ gvs []) + \\ gvs [set_var_def]) \\ first_x_assum drule \\ strip_tac \\ gvs [get_var_def] \\ Cases_on ‘v=dst’ \\ gvs [lookup_insert, domain_lookup, is_seen_def] @@ -1181,15 +1224,7 @@ Proof \\ ‘evaluate (Inst (Arith a),s) = (NONE, set_var (firstRegOfArith a) w'' s)’ by gvs [set_var_def] \\ drule_at (Pos last) evaluate_arith_insert \\ strip_tac \\ gvs [is_seen_def] \\ first_x_assum drule_all \\ strip_tac - \\ gvs [set_var_def] - \\ drule_at Any are_reads_seen_insert \\ strip_tac - \\ reverse (Cases_on ‘a’) \\ gvs [are_reads_seen_def, is_complex_def, is_seen_def] - \\ Cases_on ‘n0=dst’ \\ gvs [lookup_insert, domain_lookup] - >- (Cases_on ‘n1=dst’ \\ gvs []) - \\ Cases_on ‘r’ \\ gvs [are_reads_seen_def, is_seen_def] - \\ Cases_on ‘n0=dst’ \\ gvs [lookup_insert, domain_lookup] - \\ Cases_on ‘n'=dst’ \\ gvs [] - ) + \\ gvs [set_var_def]) \\ first_x_assum drule \\ strip_tac \\ Cases_on ‘v=dst’ \\ gvs [lookup_insert, domain_lookup, is_seen_def] \\ Cases_on ‘src'=dst’ \\ gvs [] From f0fc80625d4536698b709893761a533a2d645645 Mon Sep 17 00:00:00 2001 From: Matthieu Rodet Date: Tue, 9 Aug 2022 00:05:34 +0200 Subject: [PATCH 29/36] End of conventions. Necessity to weaken word_cse to satisfy conventions (still one cheat to discuss). Two conventions theorem done: after cheking, the first wasn't good, the second is not cheated and fully proved. TODO: clean the code, gently rename functions to match the conventions. --- .../backend/proofs/word_cseProofScript.sml | 867 ++++++++++++++++-- compiler/backend/word_cseScript.sml | 200 ++-- .../to_word/word_cse_testScript.sml | 31 +- 3 files changed, 894 insertions(+), 204 deletions(-) diff --git a/compiler/backend/proofs/word_cseProofScript.sml b/compiler/backend/proofs/word_cseProofScript.sml index 92fdf27583..7a07a9f6ff 100644 --- a/compiler/backend/proofs/word_cseProofScript.sml +++ b/compiler/backend/proofs/word_cseProofScript.sml @@ -2,7 +2,7 @@ Correctness proof for word_cse *) open preamble alistTheory totoTheory; -open wordLangTheory wordSemTheory wordPropsTheory word_simpTheory word_cseTheory; +open wordLangTheory wordSemTheory wordPropsTheory reg_allocTheory word_simpTheory word_cseTheory; val _ = new_theory "word_cseProof"; @@ -29,15 +29,7 @@ Definition data_inv_def: ∃w. word_exp s (Op op [Var src; Lookup CurrHeap]) = SOME w ∧ get_var v s = SOME w) ∧ map_ok data.instrs - (* - (∀r (c:'a word) x v. lookup data.inst_instrs (instToNumList (Const r c)) = SOME x ⇒ - x IN domain data.all_names ∧ get_var x s = SOME (Word c)) ∧ - (∀r v (a:'a arith). lookup data.inst_instrs (instToNumList (Arith a)) = SOME v ∧ firstRegOfArith a = r ⇒ - get_var r s = get_var v s ∧ - r IN domain data.all_names ∧ v IN domain data.all_names) - *) End -(* domain_lookup lookup_insert*) Theorem canonicalRegs_correct[simp]: ∀data r s. data_inv data s ⇒ get_var (canonicalRegs data r) s = get_var r s @@ -203,6 +195,74 @@ Proof \\ gvs [insert_eq] QED +Theorem evaluate_remove_insert_arith: + ∀a w s r v. ¬is_seen r data ⇒ + ¬is_complex a ⇒ + are_reads_seen a data ⇒ + evaluate (Inst (Arith a), set_var r v s) = + (NONE, set_var (firstRegOfArith a) w (set_var r v s)) ⇒ + evaluate (Inst (Arith a), s) = (NONE, set_var (firstRegOfArith a) w s) +Proof + rpt strip_tac + \\ Cases_on ‘a’ \\ gvs [is_complex_def, are_reads_seen_def] + >- (Cases_on ‘r'’ \\ gvs [are_reads_seen_def] + \\ gvs [evaluate_def, inst_def, assign_def, word_exp_def, the_words_def] + >- (Cases_on ‘n0=r’ \\ gvs [set_var_def, lookup_insert] + \\ Cases_on ‘n'=r’ \\ gvs [AllCaseEqs(), firstRegOfArith_def] + \\ gvs [state_component_equality] + \\ gvs [insert_eq]) + \\ Cases_on ‘n0=r’ \\ gvs [set_var_def, lookup_insert] + \\ gvs [AllCaseEqs(), firstRegOfArith_def] + \\ gvs [state_component_equality] + \\ gvs [insert_eq]) + >- (gvs [evaluate_def, inst_def, assign_def, word_exp_def, the_words_def] + \\ gvs [set_var_def, lookup_insert] + \\ Cases_on ‘lookup n0 s.locals’ \\ gvs [] + \\ Cases_on ‘n0=r’ \\ gvs [AllCaseEqs()] + \\ gvs [state_component_equality, firstRegOfArith_def] + \\ gvs [insert_eq]) + \\ gvs [evaluate_def, inst_def, assign_def] + \\ gvs [get_vars_def, get_var_def, set_var_def, lookup_insert] + \\ Cases_on ‘n1=r’ \\ gvs [] + \\ Cases_on ‘n0=r’ \\ gvs [] + \\ Cases_on ‘lookup n1 s.locals’ \\ gvs [] + \\ Cases_on ‘lookup n0 s.locals’ \\ gvs [] + \\ Cases_on ‘x'’ \\ gvs [] + \\ Cases_on ‘x’ \\ gvs [] + \\ Cases_on ‘c' = 0w’ \\ gvs [] + \\ gvs [state_component_equality, firstRegOfArith_def] + \\ gvs [insert_eq] +QED + +Theorem data_inv_set_var: + ∀data s n v. ¬is_seen n data ⇒ data_inv data (set_var n v s) = data_inv data s +Proof + rpt gen_tac \\ strip_tac + \\ eq_tac + >- (strip_tac \\ gvs [data_inv_def] + \\ rpt conj_tac \\ rpt gen_tac \\ strip_tac \\ first_x_assum drule \\ strip_tac \\ gvs [] + >- (Cases_on ‘r=n’ \\ Cases_on ‘v'=n’ + \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def]) + >- (Cases_on ‘v'=n’ + \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def]) + >- (drule_all evaluate_remove_insert_arith + \\ Cases_on ‘v'=n’ \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def]) + \\ Cases_on ‘v'=n’ \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def] + \\ gvs [word_exp_def, the_words_def, lookup_insert] + \\ Cases_on ‘src=n’ \\ gvs []) + \\ strip_tac \\ gvs [data_inv_def] + \\ rpt conj_tac \\ rpt gen_tac \\ strip_tac \\ first_x_assum drule \\ strip_tac \\ gvs [] + >- (Cases_on ‘r=n’ \\ Cases_on ‘v'=n’ + \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def]) + >- (Cases_on ‘v'=n’ + \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def]) + >- (drule_all evaluate_arith_insert + \\ Cases_on ‘v'=n’ \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def]) + \\ Cases_on ‘v'=n’ \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def] + \\ gvs [word_exp_def, the_words_def, lookup_insert] + \\ Cases_on ‘src=n’ \\ gvs [] +QED + Theorem not_seen_data_inv_alist_insert[simp]: ∀data s l r v. ¬is_seen r data ⇒ @@ -956,6 +1016,17 @@ Proof \\ Cases_on ‘src=n’ \\ gvs [word_exp_def, lookup_insert]) QED +Theorem data_inv_Arith_update: + ∀data s a s'. + data_inv data s ∧ + inst (Arith a) s = SOME s' ∧ + ¬is_complex a ∧ ¬is_seen (firstRegOfArith a) data ⇒ + data_inv data s' +Proof + rpt strip_tac + \\ Cases_on ‘a’ \\ gvs [is_complex_def, inst_def, assign_def, firstRegOfArith_def, AllCaseEqs(), data_inv_set_var] +QED + Theorem comp_Inst_correct: ^(get_goal "Inst") Proof @@ -975,8 +1046,8 @@ Proof \\ Cases_on ‘is_seen n data’ \\ gvs [evaluate_def, inst_def, assign_def] \\ gvs [add_to_data_def, add_to_data_aux_def] \\ Cases_on ‘lookup data.instrs (instToNumList (Const n c))’ - \\ gvs [evaluate_def, inst_def, assign_def] - >- (gvs [data_inv_def] + >- (Cases_on ‘EVEN n’ \\ gvs [evaluate_def, inst_def, assign_def, data_inv_set_var] + \\ gvs [data_inv_def] \\ rpt conj_tac \\ rpt gen_tac \\ strip_tac >- (first_x_assum drule \\ strip_tac \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ @@ -996,8 +1067,9 @@ Proof \\ Cases_on ‘src=n’ \\ gvs [is_seen_def, lookup_insert] \\ Cases_on ‘v=n’ \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup] \\ gvs [word_exp_def, the_words_def, lookup_insert]) + \\ Cases_on ‘EVEN n’ \\ gvs [evaluate_def, inst_def, assign_def, data_inv_set_var] \\ gvs [data_inv_def] - \\ first_assum drule \\ pop_assum kall_tac \\ strip_tac + \\ first_assum drule \\ pop_assum kall_tac \\ pop_assum kall_tac \\ strip_tac \\ gvs [get_vars_def, get_var_def, set_vars_def, alist_insert_def, set_var_def, word_exp_def] \\ rpt conj_tac \\ rpt gen_tac \\ strip_tac >- (Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [lookup_insert, domain_lookup, is_seen_def] @@ -1018,9 +1090,15 @@ Proof \\ drule_all are_reads_seen_canonical \\ strip_tac \\ gvs [] \\ Cases_on ‘are_reads_seen a data’ \\ gvs [evaluate_def] \\ Cases_on ‘inst (Arith a) s’ \\ gvs [add_to_data_def, add_to_data_aux_def] - \\ Cases_on ‘lookup data.instrs (instToNumList (Arith (canonicalArith data a)))’ \\ gvs [evaluate_def] - >- (drule_all Inst_Arith_NONE_lemma \\ rw []) - \\ drule_all Inst_Arith_SOME_lemma \\ rw [] + \\ Cases_on ‘lookup data.instrs (instToNumList (Arith (canonicalArith data a)))’ \\ gvs [] + >- (Cases_on ‘EVEN (firstRegOfArith a)’ \\ gvs [evaluate_def] + >- (drule_all data_inv_Arith_update \\ rw []) + \\ drule_all Inst_Arith_NONE_lemma \\ rw []) + \\ ‘data_inv data' s' ∧ p = Move 0 [(firstRegOfArith a,x)]’ + by (Cases_on ‘EVEN (firstRegOfArith a)’ \\ gvs [evaluate_def] + >- (drule_all data_inv_Arith_update \\ rw []) + \\ drule_all Inst_Arith_SOME_lemma \\ rw []) + \\ gvs [evaluate_def] \\ pop_assum kall_tac \\ gvs [get_vars_def, data_inv_def] \\ first_x_assum drule \\ pop_assum kall_tac \\ strip_tac \\ gvs [] @@ -1152,9 +1230,8 @@ Proof \\ Cases_on ‘is_seen src data’ \\ gvs [] \\ gvs [add_to_data_aux_def] \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs data src))’ \\ gvs [] - >- (gvs [evaluate_def, word_exp_def] - \\ strip_tac \\ gvs [] - \\ gvs [AllCaseEqs()] + >- (Cases_on ‘EVEN dst’ + \\ gvs [evaluate_def, word_exp_def, AllCaseEqs(), data_inv_set_var] \\ gvs [data_inv_def] \\ rpt conj_tac \\ rpt gen_tac \\ strip_tac >- (first_x_assum drule \\ strip_tac @@ -1185,50 +1262,34 @@ Proof \\ Cases_on ‘src'=dst’ \\ gvs [lookup_insert] \\ gvs [word_exp_def, set_var_def, get_var_def, lookup_insert] \\ Cases_on ‘v=dst’ \\ gvs [domain_lookup]) - \\ gvs [evaluate_def, AllCaseEqs()] - \\ gvs [data_inv_def] - \\ first_assum drule \\ strip_tac - \\ gvs [get_vars_def, set_vars_def, alist_insert_def, set_var_def] - \\ gvs [canonicalRegs_def, lookup_any_def] - \\ Cases_on ‘lookup src data.map’ \\ gvs [] - >- (rpt conj_tac \\ rpt gen_tac \\ strip_tac - >- (Cases_on ‘r=dst’ \\ gvs [get_var_def, lookup_insert] - \\ pop_assum kall_tac \\ first_x_assum drule \\ first_x_assum drule \\ strip_tac - \\ Cases_on ‘v=dst’ \\ gvs [domain_lookup, is_seen_def]) - >- (first_x_assum drule \\ first_x_assum drule \\ strip_tac - \\ Cases_on ‘v=dst’ \\ gvs [lookup_insert, domain_lookup, is_seen_def]) - >- (first_x_assum drule \\ strip_tac \\ first_x_assum drule \\ strip_tac - \\ gvs [get_var_def] - \\ Cases_on ‘v=dst’ \\ gvs [domain_lookup, lookup_insert, is_seen_def] - \\ pop_assum kall_tac - \\ ‘evaluate (Inst (Arith a),s) = (NONE, set_var (firstRegOfArith a) w'' s)’ by gvs [set_var_def] - \\ drule_at (Pos last) evaluate_arith_insert - \\ strip_tac \\ gvs [is_seen_def] \\ first_x_assum drule_all \\ strip_tac - \\ gvs [set_var_def]) + \\ ‘p' = Move 0 [(dst,x)]’ by gvs [AllCaseEqs()] \\ gvs [] + \\ conj_tac + >- (drule canonicalRegs_correct_bis \\ strip_tac + \\ gvs [evaluate_def, AllCaseEqs(), data_inv_def] \\ first_x_assum drule \\ strip_tac - \\ gvs [get_var_def] - \\ Cases_on ‘v=dst’ \\ gvs [lookup_insert, domain_lookup, is_seen_def] - \\ Cases_on ‘src'=dst’ \\ gvs [] - \\ gvs [word_exp_def, the_words_def, lookup_insert]) - \\ last_assum drule \\ pop_assum kall_tac \\ strip_tac - \\ Cases_on ‘lookup x' s.locals = lookup src s.locals’ \\ gvs [get_var_def, word_exp_def] + \\ gvs [word_exp_def, the_words_def, AllCaseEqs()] + \\ gvs [get_vars_def, set_vars_def, alist_insert_def, set_var_def] + ) + \\ strip_tac + \\ Cases_on ‘EVEN dst’ \\ gvs [evaluate_def, AllCaseEqs(), data_inv_set_var] + \\ drule canonicalRegs_correct + \\ gvs [data_inv_def] + \\ first_assum drule \\ pop_assum kall_tac \\ pop_assum kall_tac + \\ strip_tac \\ strip_tac \\ rpt conj_tac \\ rpt gen_tac \\ strip_tac - >- (Cases_on ‘r=dst’ \\ gvs [lookup_insert, domain_lookup, is_seen_def] - \\ last_x_assum drule \\ strip_tac - \\ Cases_on ‘v=dst’ \\ gvs []) - >- (last_x_assum drule \\ strip_tac - \\ Cases_on ‘v=dst’ \\ gvs [lookup_insert, domain_lookup, is_seen_def]) - >- (last_x_assum drule \\ strip_tac - \\ Cases_on ‘dst=v’ \\ gvs [lookup_insert, domain_lookup, is_seen_def] - \\ pop_assum kall_tac - \\ ‘evaluate (Inst (Arith a),s) = (NONE, set_var (firstRegOfArith a) w'' s)’ by gvs [set_var_def] - \\ drule_at (Pos last) evaluate_arith_insert - \\ strip_tac \\ gvs [is_seen_def] \\ first_x_assum drule_all \\ strip_tac - \\ gvs [set_var_def]) - \\ first_x_assum drule \\ strip_tac + >- (gvs [word_exp_def, the_words_def, get_var_def, AllCaseEqs()] + \\ Cases_on ‘r=dst’ \\ gvs [set_var_def, lookup_insert] + \\ first_x_assum drule \\ strip_tac + \\ Cases_on ‘v=dst’ \\ gvs [is_seen_def, domain_lookup]) + >- (first_x_assum drule \\ strip_tac + \\ Cases_on ‘v=dst’ \\ gvs [set_var_def, lookup_insert, domain_lookup, is_seen_def]) + >- (first_x_assum drule \\ strip_tac + \\ drule_all evaluate_arith_insert + \\ Cases_on ‘v=dst’ \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def]) + \\ first_x_assum drule \\ strip_tac \\ gvs [] \\ Cases_on ‘v=dst’ \\ gvs [lookup_insert, domain_lookup, is_seen_def] \\ Cases_on ‘src'=dst’ \\ gvs [] - \\ gvs [word_exp_def, the_words_def, lookup_insert] + \\ gvs [word_exp_def, the_words_def, get_var_def, set_var_def, lookup_insert] QED Theorem comp_Store_correct: @@ -1388,7 +1449,10 @@ Proof rpt gen_tac \\ strip_tac \\ rpt (pop_assum kall_tac) \\ rpt gen_tac \\ strip_tac - \\ gvs [word_cse_def] + \\ gvs [word_cse_def, AllCaseEqs()] + \\ pairarg_tac \\ gvs [] + \\ gvs [evaluate_def] + \\ gvs [AllCaseEqs(), add_ret_loc_def] QED (* DATA EMPTY *) @@ -1407,4 +1471,689 @@ Proof ] QED +Definition data_conventions_def: + data_conventions (data:knowledge) ⇔ + (∀r v. lookup r data.map = SOME v ⇒ + ¬EVEN r ∧ ¬EVEN v ∧ is_seen r data ∧ is_seen v data) ∧ + (∀r l. lookup data.instrs l = SOME r ⇒ + ¬EVEN r ∧ is_seen r data) ∧ + (∀r. is_seen r data ⇒ ¬EVEN r) ∧ + map_ok data.instrs +End + +Theorem empty_data_conventions[simp]: + ∀data. data_conventions empty_data +Proof + gvs [data_conventions_def, empty_data_def, lookup_def, is_seen_def] +QED + +Theorem almost_empty_data_conventions[simp]: + ∀data an. data_conventions data ⇒ data_conventions (empty_data with all_names:=data.all_names) +Proof + gvs [data_conventions_def, empty_data_def, lookup_def, is_seen_def] +QED + +(*Theorem almost_empty_data_conventions_any: + ∀an. data_conventions (empty_data with all_names:=an) +Proof + EVAL_TAC \\ gvs [lookup_def] +QED*) + +Theorem MAP_FST_simp: + ∀l f. MAP FST (MAP (λ(a,b). (a, f b)) l) = MAP FST l +Proof + Induct \\ gvs [] + \\ Cases_on ‘h’ \\ gvs [] +QED + +Theorem MAP_SND_simp: + ∀l f. MAP SND (MAP (λ(a,b). (a,f b)) l) = MAP f (MAP SND l) +Proof + Induct \\ gvs [] + \\ Cases_on ‘h’ \\ gvs [] +QED + +Theorem is_phy_var_EVEN: + ∀x. is_phy_var x ⇔ EVEN x +Proof + gvs [is_phy_var_def, EVEN_MOD2] +QED + +Theorem is_phy_var_canonicalRegs: + ∀data r. data_conventions data ⇒ (is_phy_var (canonicalRegs data r) ⇔ is_phy_var r) +Proof + rpt gen_tac \\ strip_tac \\ gvs [data_conventions_def, lookup_any_def, canonicalRegs_def] + \\ Cases_on ‘lookup r data.map’ \\ gvs [] + \\ last_x_assum drule \\ strip_tac \\ gvs [is_phy_var_EVEN] +QED + +Theorem EVERY_is_phy_var_canonicalRegs: + ∀l data. + EVERY is_phy_var (MAP SND l) ∧ data_conventions data ⇒ + EVERY is_phy_var (MAP (λb. canonicalRegs data b) (MAP SND l)) +Proof + Induct \\ gvs [] + \\ rpt gen_tac \\ Cases_on ‘h’ \\ gvs [is_phy_var_canonicalRegs] +QED + +Theorem lookup_map_insert: + ∀l m r v. lookup r (map_insert l m) = if ∃v. ALOOKUP l r = SOME v then ALOOKUP l r else lookup r m +Proof + Induct \\ gvs [map_insert_def] + \\ rpt gen_tac \\ Cases_on ‘h’ + \\ gvs [map_insert_def, lookup_insert] + \\ Cases_on ‘q=r’ \\ gvs [] +QED + +Theorem ALOOKUP_LOOKUP: + ∀l r v. ALOOKUP l r = SOME v ⇒ MEM (r,v) l +Proof + Induct \\ gvs [] \\ rpt gen_tac + \\ Cases_on ‘h’ \\ gvs [AllCaseEqs()] + \\ strip_tac \\ gvs [] +QED + +Theorem lookup_insert_instrs: + ∀r n l1 l2 data. + map_ok data.instrs ⇒ + lookup (insert data.instrs l1 n) l2 = SOME r ⇒ + (if l1 = l2 then SOME n else lookup data.instrs l2) = SOME r +Proof + gvs [mlmapTheory.lookup_insert] +QED + +Theorem lookup_SOME_map_insert: + ∀l r v data. lookup r (map_insert l data.map) = SOME v ⇒ + (MEM (r,v) l ∨ lookup r data.map = SOME v) +Proof + Induct \\ gvs [map_insert_def] + \\ rpt gen_tac \\ strip_tac + \\ Cases_on ‘h’ \\ gvs [map_insert_def] + \\ Cases_on ‘r=q’ \\ gvs [lookup_insert] +QED + +Theorem is_seen_list_insert: + ∀l (r:num) map. lookup r map = SOME () ⇒ lookup r (list_insert l map) = SOME () +Proof + Induct \\ rpt gen_tac + \\ gvs [list_insert_def] + \\ first_x_assum (qspecl_then [‘r’, ‘insert h () map'’] assume_tac) \\ gvs [] + \\ Cases_on ‘r=h’ \\ gvs [lookup_insert] +QED + +Theorem lookup_SOME_list_insert: + ∀l r map. lookup r (list_insert l map) = SOME () ⇒ + (MEM r l ∨ lookup r map = SOME ()) +Proof + Induct \\ gvs [list_insert_def] + \\ rpt gen_tac \\ strip_tac + \\ first_x_assum drule \\ strip_tac \\ gvs [] + \\ Cases_on ‘r=h’ \\ gvs [lookup_insert] +QED + +Theorem lookup_SOME_list_insert_RW: + ∀l r map. lookup r (list_insert l map) = if MEM r l then SOME () else lookup r map +Proof + Induct \\ gvs [list_insert_def] + \\ rpt gen_tac + \\ Cases_on ‘r=h’ \\ gvs [lookup_insert] +QED + +Theorem word_cse_data_conventions: + ∀p data. + let data' = FST (word_cse data p) in + data_conventions data ⇒ data_conventions data' +Proof + Induct \\ gvs [flat_exp_conventions_def, word_cse_def, AllCaseEqs()] + \\ rpt gen_tac \\ strip_tac + >- (pairarg_tac \\ gvs [] + \\ gvs [canonicalMoveRegs3_def, AllCaseEqs()] + \\ gvs [data_conventions_def] + \\ rpt conj_tac \\ rpt gen_tac + >- (strip_tac + \\ drule lookup_SOME_map_insert + \\ strip_tac + >- (gvs [MEM_FILTER, MEM_MAP, EVERY_MEM] + \\ first_assum drule \\ strip_tac + \\ first_assum drule \\ strip_tac + \\ Cases_on ‘y’ \\ gvs [is_seen_def] + >- (gvs [lookup_SOME_list_insert_RW, MEM_FILTER] + \\ ‘MEM (q,r') l ⇒ MEM q (MAP FST l)’ + by (rpt (first_x_assum kall_tac) \\ strip_tac + \\ Induct_on ‘l’ \\ gvs [] + \\ gen_tac \\ Cases_on ‘h’ \\ gvs [] + \\ strip_tac \\ gvs []) + \\ first_x_assum drule \\ strip_tac \\ gvs [ODD_EVEN] + \\ ‘¬EVEN r'’ + by (gvs [canonicalRegs_def, lookup_any_def] + \\ Cases_on ‘lookup r' data.map’ \\ gvs [])) + \\ gvs [lookup_SOME_list_insert_RW, MEM_FILTER, ODD_EVEN] + \\ strip_tac + >- (Cases_on ‘MEM q (MAP FST l)’ \\ gvs [] \\ gvs [MEM_MAP]) + \\ Cases_on ‘MEM (canonicalRegs data r') (MAP FST l)’ \\ gvs [] + \\ Cases_on ‘lookup r' data.map’ \\ simp [canonicalRegs_def, lookup_any_def] + \\ last_x_assum drule \\ strip_tac) + \\ last_x_assum drule \\ strip_tac \\ gvs [is_seen_def] + \\ Cases_on ‘lookup v data.all_names’ \\ gvs [] + \\ drule is_seen_list_insert \\ gvs [] + \\ Cases_on ‘lookup r data.all_names’ \\ gvs [] + \\ drule is_seen_list_insert \\ gvs [] + ) + >- (strip_tac \\ first_x_assum drule \\ strip_tac + \\ Cases_on ‘lookup r data.all_names’ + \\ gvs [is_seen_def, is_seen_list_insert]) + \\ gvs [is_seen_def] \\ strip_tac + \\ Cases_on ‘lookup r (list_insert (FILTER ODD (MAP FST l)) data.all_names)’ \\ gvs [] + \\ drule lookup_SOME_list_insert \\ strip_tac + >- gvs [MEM_FILTER, ODD_EVEN] + \\ ‘is_seen r data’ by gvs [is_seen_def] + \\ gvs [is_seen_def]) + >- (pairarg_tac + \\ Cases_on ‘i’ \\ gvs [word_cseInst_def, AllCaseEqs()] + >- (gvs [add_to_data_def, add_to_data_aux_def, AllCaseEqs()] + \\ gvs [data_conventions_def] + >- (rpt conj_tac \\ rpt gen_tac + \\ strip_tac + >- (first_x_assum drule \\ strip_tac + \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [lookup_insert, is_seen_def]) + >- (drule_all lookup_insert_instrs \\ strip_tac \\ gvs [AllCaseEqs(), is_seen_def] + \\ first_x_assum drule + \\ Cases_on ‘r=n’ \\ gvs [lookup_insert]) + \\ Cases_on ‘r=n’ \\ gvs [is_seen_def, lookup_insert]) + \\ rpt conj_tac \\ rpt gen_tac + \\ strip_tac + >- (Cases_on ‘r=n’ \\ gvs [is_seen_def, lookup_insert] + >- (Cases_on ‘r'=n’ \\ gvs [] + \\ last_x_assum drule \\ gvs []) + \\ Cases_on ‘v=n’ \\ gvs [] + \\ last_x_assum drule \\ gvs []) + >- (first_x_assum drule \\ strip_tac + \\ Cases_on ‘r=n’ \\ gvs [is_seen_def, lookup_insert]) + \\ Cases_on ‘r=n’ \\ gvs [is_seen_def, lookup_insert]) + >- (gvs [add_to_data_def, add_to_data_aux_def, AllCaseEqs()] + \\ gvs [data_conventions_def] + >- (rpt conj_tac \\ rpt gen_tac + \\ strip_tac + >- (first_x_assum drule \\ strip_tac + \\ Cases_on ‘r=firstRegOfArith a’ + \\ Cases_on ‘v=firstRegOfArith a’ + \\ gvs [lookup_insert, is_seen_def]) + >- (drule_all lookup_insert_instrs \\ strip_tac \\ gvs [AllCaseEqs(), is_seen_def] + \\ first_x_assum drule + \\ Cases_on ‘r=firstRegOfArith a’ \\ gvs [lookup_insert]) + \\ Cases_on ‘r=firstRegOfArith a’ \\ gvs [is_seen_def, lookup_insert]) + \\ rpt conj_tac \\ rpt gen_tac + \\ strip_tac + >- (Cases_on ‘r = firstRegOfArith a’ \\ gvs [is_seen_def, lookup_insert] + >- (Cases_on ‘r'=firstRegOfArith a’ \\ gvs [] + \\ last_x_assum drule \\ gvs []) + \\ Cases_on ‘v=firstRegOfArith a’ \\ gvs [] + \\ last_x_assum drule \\ gvs []) + >- (first_x_assum drule \\ strip_tac + \\ Cases_on ‘r=firstRegOfArith a’ \\ gvs [is_seen_def, lookup_insert]) + \\ Cases_on ‘r=firstRegOfArith a’ \\ gvs [is_seen_def, lookup_insert]) + \\ Cases_on ‘a’ \\ gvs [word_cseInst_def, AllCaseEqs()]) + >- (Cases_on ‘is_seen n data’ \\ gvs []) + >- (Cases_on ‘s=CurrHeap’ \\ gvs []) + >- (pairarg_tac \\ first_x_assum drule \\ gvs []) + >- (Cases_on ‘o'’ \\ gvs [] + \\ Cases_on ‘x’ \\ gvs [] + \\ Cases_on ‘r’ \\ gvs [] + \\ gvs [data_conventions_def] + \\ gvs [empty_data_def, lookup_def, is_seen_def, lookup_inter] + \\ gen_tac \\ Cases_on ‘lookup r data.all_names’ \\ gvs []) + >- (pairarg_tac \\ gvs [] + \\ pairarg_tac \\ gvs [] + \\ last_x_assum drule \\ strip_tac + \\ last_x_assum drule \\ strip_tac + \\ gvs []) + >- (pairarg_tac \\ gvs [] + \\ pairarg_tac \\ gvs [] + \\ last_x_assum drule \\ strip_tac + \\ last_x_assum drule \\ strip_tac + \\ gvs [data_conventions_def, empty_data_def, lookup_def, is_seen_def, lookup_inter] + \\ gen_tac \\ Cases_on ‘lookup r data1.all_names’ \\ gvs []) + >- (Cases_on ‘is_seen n data’ \\ gvs [] + \\ Cases_on ‘is_seen n0 data’ \\ gvs [add_to_data_aux_def] + \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs data n0))’ + \\ Cases_on ‘EVEN n’ \\ gvs [] + \\ gvs [data_conventions_def] + >- (rpt conj_tac \\ rpt gen_tac + \\ strip_tac + >- (last_x_assum drule \\ strip_tac + \\ Cases_on ‘r=n’ \\ Cases_on ‘v=n’ \\ gvs [lookup_insert, is_seen_def]) + >- (drule_all lookup_insert_instrs \\ strip_tac \\ gvs [AllCaseEqs(), is_seen_def] + \\ last_x_assum drule + \\ Cases_on ‘r=n’ \\ gvs [lookup_insert]) + \\ Cases_on ‘r=n’ \\ gvs [is_seen_def, lookup_insert]) + \\ rpt conj_tac \\ rpt gen_tac + \\ strip_tac + >- (Cases_on ‘r=n’ \\ gvs [is_seen_def, lookup_insert] + \\ Cases_on ‘v=n’ \\ gvs [] + \\ last_x_assum drule \\ gvs []) + >- (last_x_assum drule \\ strip_tac + \\ Cases_on ‘r=n’ \\ gvs [is_seen_def, lookup_insert]) + \\ Cases_on ‘r=n’ \\ gvs [is_seen_def, lookup_insert]) + \\ Cases_on ‘is_seen n data’ \\ gvs [] +QED + +Theorem word_cse_flat_exp_conventions: + ∀p data. + let p' = SND (word_cse data p) in + flat_exp_conventions p ⇒ flat_exp_conventions p' +Proof + Induct \\ gvs [flat_exp_conventions_def, word_cse_def, AllCaseEqs()] + >- (Cases_on ‘canonicalMoveRegs3 data l’ \\ gvs [flat_exp_conventions_def]) + >- (rpt gen_tac + \\ pairarg_tac \\ gvs [] + \\ Cases_on ‘i’ \\ gvs [word_cseInst_def, flat_exp_conventions_def, + add_to_data_def, add_to_data_aux_def, AllCaseEqs()] + \\ Cases_on ‘a’ \\ gvs [word_cseInst_def, flat_exp_conventions_def, AllCaseEqs()]) + >- (Cases_on ‘is_seen n data’ \\ gvs [flat_exp_conventions_def]) + >- (Cases_on ‘s = CurrHeap’ \\ Cases_on ‘e’ \\ gvs [flat_exp_conventions_def, canonicalExp_def]) + >- (gen_tac \\ first_x_assum (qspec_then ‘data’ assume_tac) + \\ Cases_on ‘word_cse data p’ \\ gvs [flat_exp_conventions_def]) + >- (Cases_on ‘o'’ \\ gvs [flat_exp_conventions_def] + \\ Cases_on ‘x’ \\ gvs [] + \\ Cases_on ‘r’ \\ gvs [flat_exp_conventions_def]) + >- (gen_tac \\ strip_tac + \\ rpt (first_x_assum drule \\ strip_tac) + \\ Cases_on ‘word_cse data p’ \\ gvs [] + \\ first_x_assum (qspec_then ‘data’ assume_tac) \\ gvs [] + \\ Cases_on ‘word_cse q p'’ \\ gvs [] + \\ first_x_assum (qspec_then ‘q’ assume_tac) \\ gvs [flat_exp_conventions_def]) + >- (rpt gen_tac + \\ Cases_on ‘word_cse data p’ \\ gvs [] + \\ Cases_on ‘word_cse data p'’ \\ gvs [] + \\ strip_tac \\ gvs [] + \\ last_x_assum (qspec_then ‘data’ assume_tac) \\ gvs [] + \\ last_x_assum (qspec_then ‘data’ assume_tac) \\ gvs [flat_exp_conventions_def]) + >- (Cases_on ‘is_seen n data ∨ ¬is_seen n0 data’ \\ gvs [flat_exp_conventions_def] + \\ gvs [add_to_data_aux_def] + \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs data n0))’ + \\ Cases_on ‘EVEN n’ \\ gvs [flat_exp_conventions_def]) + >- (Cases_on ‘is_seen n data’ \\ gvs [flat_exp_conventions_def]) +QED + +Theorem inst_ok_canonicalArith_lemma: + ∀a data c. + data_conventions data ⇒ + ¬is_seen (firstRegOfArith a) data ⇒ + inst_ok_less c (Arith a) ⇒ + inst_ok_less c (Arith (canonicalArith data a)) +Proof + rpt strip_tac + \\ Cases_on ‘a’ \\ gvs [inst_ok_less_def, canonicalArith_def, canonicalRegs_def, lookup_any_def] + >- (Cases_on ‘r’ \\ gvs [canonicalImmReg_def, inst_ok_less_def]) + >- (strip_tac \\ gvs [data_conventions_def] + \\ Cases_on ‘lookup n1 data.map’ \\ gvs [] + \\ Cases_on ‘lookup n2 data.map’ \\ gvs [] + \\ first_assum drule \\ first_x_assum kall_tac \\ strip_tac + \\ Cases_on ‘n=x’ \\ gvs [firstRegOfArith_def] + \\ last_x_assum drule \\ gvs [] + \\ Cases_on ‘n=x'’ \\ gvs []) + \\ (strip_tac \\ gvs [data_conventions_def] + \\ Cases_on ‘lookup n1 data.map’ \\ gvs [] + \\ first_x_assum drule \\ strip_tac \\ gvs [] + \\ Cases_on ‘n=x’ \\ gvs [firstRegOfArith_def]) +QED + +Theorem word_cse_full_inst_ok_less: + ∀p data c. + let p' = SND (word_cse data p) in + data_conventions data ⇒ + full_inst_ok_less c p ⇒ full_inst_ok_less c p' +Proof + Induct \\ gvs [full_inst_ok_less_def, word_cse_def] + >- (Cases_on ‘canonicalMoveRegs3 data l’ \\ gvs [full_inst_ok_less_def]) + >- (rpt gen_tac + \\ Cases_on ‘i’ \\ gvs [word_cseInst_def, full_inst_ok_less_def] + >- (Cases_on ‘is_seen n data’ \\ gvs [full_inst_ok_less_def, add_to_data_def, add_to_data_aux_def] + \\ Cases_on ‘lookup data.instrs (instToNumList (Const n c'))’ + \\ Cases_on ‘EVEN n’ \\ gvs [full_inst_ok_less_def]) + >- (Cases_on ‘is_seen (firstRegOfArith a) data’ + \\ Cases_on ‘is_complex a’ + \\ Cases_on ‘are_reads_seen (canonicalArith data a) data’ + \\ gvs [full_inst_ok_less_def, inst_ok_less_def, add_to_data_def, add_to_data_aux_def, canonicalArith_def] + \\ Cases_on ‘lookup data.instrs (instToNumList (Arith (canonicalArith data a)))’ + \\ Cases_on ‘EVEN (firstRegOfArith a)’ + \\ gvs [full_inst_ok_less_def, inst_ok_canonicalArith_lemma]) + \\ Cases_on ‘a’ \\ gvs [word_cseInst_def, full_inst_ok_less_def] + \\ Cases_on ‘is_store m’ \\ gvs [full_inst_ok_less_def] + \\ Cases_on ‘is_seen n data’ \\ gvs [inst_ok_less_def, full_inst_ok_less_def]) + >- (Cases_on ‘is_seen n data’ \\ gvs [full_inst_ok_less_def]) + >- (Cases_on ‘s = CurrHeap’ \\ Cases_on ‘e’ \\ gvs [full_inst_ok_less_def, canonicalExp_def]) + >- (gen_tac \\ first_x_assum (qspec_then ‘data’ assume_tac) + \\ Cases_on ‘word_cse data p’ \\ gvs [full_inst_ok_less_def]) + >- (Cases_on ‘o'’ \\ gvs [full_inst_ok_less_def] + \\ Cases_on ‘x’ \\ gvs [] + \\ Cases_on ‘r’ \\ gvs [full_inst_ok_less_def]) + >- (rpt strip_tac + \\ pairarg_tac \\ gvs [] + \\ pairarg_tac \\ gvs [] + \\ last_x_assum drule_all + \\ assume_tac word_cse_data_conventions + \\ first_x_assum (qspecl_then [‘p’, ‘data’] assume_tac) \\ gvs [] + \\ last_x_assum drule_all + \\ gvs [full_inst_ok_less_def]) + >- (rpt strip_tac + \\ pairarg_tac \\ gvs [] + \\ pairarg_tac \\ gvs [] + \\ last_x_assum drule_all + \\ last_x_assum drule_all + \\ gvs [full_inst_ok_less_def] + \\ Cases_on ‘r’ \\ gvs [canonicalImmReg_def]) + >- (Cases_on ‘is_seen n data ∨ ¬is_seen n0 data’ \\ gvs [full_inst_ok_less_def] + \\ gvs [add_to_data_aux_def] + \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs data n0))’ + \\ Cases_on ‘EVEN n’ \\ gvs [full_inst_ok_less_def]) + \\ Cases_on ‘is_seen n data’ \\ gvs [full_inst_ok_less_def] +QED + +Theorem every_is_phy_var_canonicalArith: + ∀a data. data_conventions data ⇒ + ¬is_complex a ⇒ + every_var is_phy_var (Inst (Arith a)) ⇒ + every_var is_phy_var (Inst (Arith (canonicalArith data a))) +Proof + rpt strip_tac + \\ Cases_on ‘a’ \\ gvs [is_complex_def] + \\ gvs [canonicalArith_def, every_var_def, every_var_inst_def, is_phy_var_canonicalRegs] + \\ Cases_on ‘r’ \\ gvs [canonicalImmReg_def, every_var_imm_def, is_phy_var_canonicalRegs] +QED + +Theorem inst_arg_convention_canonicalArith: + ∀a data. data_conventions data ⇒ + ¬is_complex a ⇒ + inst_arg_convention (Arith (canonicalArith data a)) +Proof + rpt strip_tac + \\ Cases_on ‘a’ \\ gvs [is_complex_def] + \\ gvs [canonicalArith_def, inst_arg_convention_def] +QED + +Theorem word_cse_pre_alloc_conventions: + ∀p data. + let p' = SND (word_cse data p) in + data_conventions data ⇒ + pre_alloc_conventions p ⇒ pre_alloc_conventions p' +Proof + Induct \\ gvs [pre_alloc_conventions_def, word_cse_def, AllCaseEqs()] + \\ rpt gen_tac \\ strip_tac + >- (strip_tac + \\ pairarg_tac \\ gvs [every_var_def, every_stack_var_def, call_arg_convention_def]) + >- (pairarg_tac \\ gvs [] + \\ strip_tac \\ Cases_on ‘i’ \\ gvs [word_cseInst_def] + >- (gvs [AllCaseEqs(), data_conventions_def, add_to_data_def, add_to_data_aux_def, + every_stack_var_def, call_arg_convention_def]) + >- (gvs [add_to_data_def, add_to_data_aux_def, AllCaseEqs(), + every_stack_var_def, call_arg_convention_def] + \\ Cases_on ‘a’ + \\ gvs [is_complex_def, canonicalArith_def, inst_arg_convention_def]) + \\ Cases_on ‘a’ \\ gvs [word_cseInst_def] + \\ Cases_on ‘m’ + \\ gvs [is_store_def, every_stack_var_def, call_arg_convention_def, + inst_arg_convention_def, AllCaseEqs()]) + >- (Cases_on ‘is_seen n data’ \\ gvs []) + >- (Cases_on ‘s = CurrHeap’ \\ Cases_on ‘e’ \\ gvs [every_stack_var_def, call_arg_convention_def]) + >- (pairarg_tac \\ gvs [every_stack_var_def, call_arg_convention_def] + \\ strip_tac \\ first_x_assum drule_all \\ gvs []) + >- (Cases_on ‘o'’ \\ gvs [] + \\ Cases_on ‘x’ \\ gvs [] + \\ Cases_on ‘r’ \\ gvs []) + >- (strip_tac + \\ gvs [every_stack_var_def, call_arg_convention_def] + \\ last_x_assum drule_all \\ strip_tac \\ gvs [] + \\ pairarg_tac \\ gvs [] + \\ ‘data_conventions data1’ + by (assume_tac word_cse_data_conventions + \\ first_x_assum (qspecl_then [‘p’, ‘data’] assume_tac) \\ gvs []) + \\ last_x_assum drule_all \\ strip_tac + \\ pairarg_tac \\ gvs [] + \\ gvs [every_stack_var_def, call_arg_convention_def]) + >- (strip_tac + \\ rpt (pairarg_tac \\ gvs []) + \\ gvs [every_stack_var_def, call_arg_convention_def] + \\ last_x_assum drule_all \\ strip_tac \\ gvs [] + \\ last_x_assum drule_all \\ strip_tac + \\ gvs [every_stack_var_def, call_arg_convention_def]) + >- (strip_tac + \\ Cases_on ‘is_seen n data’ \\ gvs [] + \\ Cases_on ‘is_seen n0 data’ \\ gvs [add_to_data_aux_def] + \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs data n0))’ \\ gvs [] + \\ Cases_on ‘EVEN n’ \\ gvs [every_stack_var_def, call_arg_convention_def]) + \\ strip_tac + \\ Cases_on ‘is_seen n data’ \\ gvs [] +QED + +Theorem word_cse_post_alloc_conventions: + ∀p data k. + let p' = SND (word_cse data p) in + data_conventions data ⇒ + post_alloc_conventions k p ⇒ post_alloc_conventions k p' +Proof + Induct \\ gvs [post_alloc_conventions_def, word_cse_def, AllCaseEqs()] + \\ rpt gen_tac \\ strip_tac + >- (strip_tac + \\ pairarg_tac \\ gvs [every_var_def, every_stack_var_def, call_arg_convention_def] + \\ gvs [canonicalMoveRegs3_def] + \\ ‘rs' = MAP (λ(a,b). (a,canonicalRegs data b)) l’ by gvs [AllCaseEqs()] + \\ gvs [MAP_FST_simp, MAP_SND_simp, EVERY_is_phy_var_canonicalRegs]) + >- (pairarg_tac \\ gvs [] + \\ strip_tac \\ Cases_on ‘i’ \\ gvs [word_cseInst_def] + >- (‘EVEN n’ by gvs [every_var_def, every_var_inst_def, is_phy_var_EVEN] + \\ gvs [AllCaseEqs(), data_conventions_def, add_to_data_def, add_to_data_aux_def] + \\ first_x_assum drule \\ strip_tac + \\ gvs [every_var_def, every_stack_var_def, call_arg_convention_def] + \\ gvs [every_var_inst_def] + \\ cheat) (* Transformation from [Inst (Const n c)] to [Move 0 (n, r')] + because we know that [r'] contains the value of [c]. + This break the convention stating that + if all vars are initialy physical (ie EVEN) + then all vars are still physical after transformation. + This is not true because [r'] is not physical. + Solution: not replacing [Inst (Const n c)] when [n] is physical + Cons: Weakening of our CSE + NB: after checking, post_alloc_conventions doesn't seem to be necessary *) + >- (gvs [AllCaseEqs()] + \\ gvs [add_to_data_def, add_to_data_aux_def, AllCaseEqs()] + \\ gvs [every_var_def, every_stack_var_def, call_arg_convention_def] + \\ drule every_is_phy_var_canonicalArith \\ strip_tac + \\ gvs[every_var_def, inst_arg_convention_canonicalArith] + \\ (Cases_on ‘a’ \\ gvs [is_complex_def, are_reads_seen_def, every_var_inst_def, + canonicalArith_def] + >- (Cases_on ‘r’ + \\ gvs [firstRegOfArith_def, are_reads_seen_def, + canonicalImmReg_def, canonicalRegs_def, + lookup_any_def, every_var_imm_def] + \\ gvs [data_conventions_def] + \\ first_x_assum drule \\ strip_tac + >- (Cases_on ‘lookup n' data.map’ \\ gvs [is_phy_var_EVEN]) + \\ Cases_on ‘lookup n0 data.map’ \\ gvs [is_phy_var_EVEN]) + \\ gvs [data_conventions_def] + \\ first_x_assum drule \\ strip_tac + \\ gvs [canonicalRegs_def, lookup_any_def] + >- (Cases_on ‘lookup n0 data.map’ \\ gvs [is_phy_var_EVEN] + \\ last_x_assum drule \\ strip_tac \\ gvs [is_phy_var_EVEN] + \\ gvs [is_seen_def, lookup_any_def]) + \\ Cases_on ‘lookup n1 data.map’ \\ gvs [is_phy_var_EVEN] + \\ last_x_assum drule \\ strip_tac \\ gvs [is_phy_var_EVEN] + \\ gvs [is_seen_def, lookup_any_def]) + ) + \\ Cases_on ‘a’ \\ gvs [word_cseInst_def] + \\ Cases_on ‘m’ \\ gvs [AllCaseEqs()] + \\ gvs [is_store_def, every_var_def, every_var_inst_def, every_stack_var_def, + call_arg_convention_def, inst_arg_convention_def] + \\ gvs [is_phy_var_canonicalRegs]) + >- (Cases_on ‘is_seen n data’ \\ gvs []) + >- (Cases_on ‘s = CurrHeap’ \\ Cases_on ‘e’ + \\ gvs [every_var_def, every_stack_var_def, call_arg_convention_def, canonicalExp_def] + \\ gvs [every_var_exp_def, data_conventions_def, canonicalRegs_def, lookup_any_def] + \\ Cases_on ‘lookup n data.map’ \\ gvs [] + \\ strip_tac \\ first_x_assum drule + \\ gvs [is_phy_var_EVEN]) + >- (pairarg_tac \\ gvs [every_var_def, every_stack_var_def, call_arg_convention_def] + \\ strip_tac \\ first_x_assum drule_all \\ gvs []) + >- (Cases_on ‘o'’ \\ gvs [] + \\ Cases_on ‘x’ \\ gvs [] + \\ Cases_on ‘r’ \\ gvs []) + >- (strip_tac + \\ gvs [every_var_def, every_stack_var_def, call_arg_convention_def] + \\ last_x_assum drule_all \\ strip_tac \\ gvs [] + \\ pairarg_tac \\ gvs [] + \\ ‘data_conventions data1’ + by (assume_tac word_cse_data_conventions + \\ first_x_assum (qspecl_then [‘p’, ‘data’] assume_tac) \\ gvs []) + \\ last_x_assum drule_all \\ strip_tac + \\ pairarg_tac \\ gvs [] + \\ gvs [every_var_def, every_stack_var_def, call_arg_convention_def]) + >- (strip_tac + \\ rpt (pairarg_tac \\ gvs []) + \\ gvs [every_var_def, every_stack_var_def, call_arg_convention_def] + \\ last_x_assum drule_all \\ strip_tac \\ gvs [] + \\ last_x_assum drule_all \\ strip_tac + \\ gvs [every_var_def, every_stack_var_def, call_arg_convention_def] + \\ Cases_on ‘r’ + \\ gvs [is_phy_var_canonicalRegs, canonicalImmReg_def, every_var_imm_def]) + >- (strip_tac + \\ Cases_on ‘is_seen n data’ \\ gvs [] + \\ Cases_on ‘is_seen n0 data’ \\ gvs [add_to_data_aux_def] + \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs data n0))’ \\ gvs [] + \\ Cases_on ‘EVEN n’ \\ gvs [every_var_def, every_stack_var_def, call_arg_convention_def] + \\ gvs [is_phy_var_canonicalRegs] + \\ gvs [data_conventions_def] + \\ first_x_assum drule \\ strip_tac \\ gvs [is_phy_var_EVEN]) + >- (strip_tac + \\ Cases_on ‘is_seen n data’ \\ gvs []) +QED + +Theorem word_cse_wf_cutsets: + ∀p data. + let p' = SND (word_cse data p) in + data_conventions data ⇒ + wf_cutsets p ⇒ wf_cutsets p' +Proof + Induct \\ gvs [wf_cutsets_def, word_cse_def, AllCaseEqs()] + \\ rpt gen_tac \\ strip_tac + >- (pairarg_tac \\ gvs [wf_cutsets_def]) + >- (pairarg_tac \\ gvs [] + \\ Cases_on ‘i’ + \\ gvs [word_cseInst_def, add_to_data_def, add_to_data_aux_def, + wf_cutsets_def, AllCaseEqs()] + \\ Cases_on ‘a’ + \\ gvs [word_cseInst_def, add_to_data_def, add_to_data_aux_def, + wf_cutsets_def, AllCaseEqs()]) + >- (Cases_on ‘is_seen n data’ \\ gvs [wf_cutsets_def]) + >- (Cases_on ‘s’ \\ gvs [wf_cutsets_def]) + >- (pairarg_tac \\ strip_tac \\ gvs [] \\ last_x_assum drule_all \\ gvs [wf_cutsets_def]) + >- (Cases_on ‘o'’ \\ gvs [wf_cutsets_def] + \\ Cases_on ‘x’ \\ gvs [wf_cutsets_def] + \\ Cases_on ‘r’ \\ gvs [wf_cutsets_def]) + >- (pairarg_tac \\ gvs [] \\ strip_tac + \\ last_x_assum drule_all \\ strip_tac + \\ ‘data_conventions data1’ + by (assume_tac word_cse_data_conventions + \\ first_x_assum (qspecl_then [‘p’, ‘data’] assume_tac) \\ gvs []) + \\ last_x_assum drule_all \\ strip_tac + \\ pairarg_tac \\ gvs [wf_cutsets_def]) + >- (strip_tac + \\ rpt (pairarg_tac \\ gvs []) + \\ rpt (last_x_assum drule \\ strip_tac) + \\ gvs [wf_cutsets_def]) + >- (Cases_on ‘is_seen n data’ \\ gvs [wf_cutsets_def] + \\ Cases_on ‘¬is_seen n0 data’ \\ gvs [wf_cutsets_def] + \\ gvs [add_to_data_aux_def] + \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs data n0))’ \\ gvs [] + \\ Cases_on ‘EVEN n’ \\ gvs [wf_cutsets_def]) + \\ Cases_on ‘is_seen n data’ \\ gvs [wf_cutsets_def] +QED + +Theorem is_seen_canonical: + ∀n data. data_conventions data ⇒ is_seen (canonicalRegs data n) data ⇒ is_seen n data +Proof + rpt strip_tac \\ gvs [canonicalRegs_def, lookup_any_def, data_conventions_def] + \\ Cases_on ‘lookup n data.map’ \\ gvs [] +QED + +Theorem word_cse_every_inst_two_reg: + ∀p data. + let p' = SND (word_cse data p) in + data_conventions data ⇒ + every_inst two_reg_inst p ⇒ every_inst two_reg_inst p' +Proof + Induct \\ gvs [every_inst_def, word_cse_def, AllCaseEqs()] + \\ rpt gen_tac \\ strip_tac + >- (pairarg_tac \\ gvs [every_inst_def]) + >- (pairarg_tac \\ gvs [] + \\ reverse (Cases_on ‘i’) + \\ gvs [word_cseInst_def, add_to_data_def, add_to_data_aux_def, + every_inst_def, two_reg_inst_def, AllCaseEqs()] + >- (Cases_on ‘a’ \\ gvs [word_cseInst_def, every_inst_def, two_reg_inst_def, AllCaseEqs()]) + \\ Cases_on ‘a’ \\ gvs [is_complex_def, firstRegOfArith_def] + \\ strip_tac + \\ gvs [two_reg_inst_def, are_reads_seen_def, canonicalArith_def, is_seen_canonical] + \\ gvs [canonicalRegs_def, lookup_any_def] + \\ Cases_on ‘lookup n data.map’ \\ gvs [data_conventions_def]) + >- (Cases_on ‘is_seen n data’ \\ gvs [every_inst_def]) + >- (Cases_on ‘s’ \\ gvs [every_inst_def]) + >- (pairarg_tac \\ strip_tac \\ gvs [] \\ last_x_assum drule_all \\ gvs [every_inst_def]) + >- (Cases_on ‘o'’ \\ gvs [every_inst_def] + \\ Cases_on ‘x’ \\ gvs [every_inst_def] + \\ Cases_on ‘r’ \\ gvs [every_inst_def]) + >- (pairarg_tac \\ gvs [] \\ strip_tac + \\ last_x_assum drule_all \\ strip_tac + \\ ‘data_conventions data1’ + by (assume_tac word_cse_data_conventions + \\ first_x_assum (qspecl_then [‘p’, ‘data’] assume_tac) \\ gvs []) + \\ last_x_assum drule_all \\ strip_tac + \\ pairarg_tac \\ gvs [every_inst_def]) + >- (strip_tac + \\ rpt (pairarg_tac \\ gvs []) + \\ rpt (last_x_assum drule \\ strip_tac) + \\ gvs [every_inst_def]) + >- (Cases_on ‘is_seen n data’ \\ gvs [every_inst_def] + \\ Cases_on ‘¬is_seen n0 data’ \\ gvs [every_inst_def] + \\ gvs [add_to_data_aux_def] + \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs data n0))’ \\ gvs [] + \\ Cases_on ‘EVEN n’ \\ gvs [every_inst_def, two_reg_inst_def] + \\ strip_tac \\ gvs []) + \\ Cases_on ‘is_seen n data’ \\ gvs [every_inst_def] +QED + +Theorem word_cse_conventions: + ∀p data c k. + data_conventions data ⇒ + let (data', p') = word_cse data p in + (flat_exp_conventions p ⇒ flat_exp_conventions p') ∧ + (full_inst_ok_less c p ⇒ full_inst_ok_less c p') ∧ + (post_alloc_conventions k p ⇒ post_alloc_conventions k p') ∧ + (data_conventions data') +Proof + rpt gen_tac \\ gvs [] \\ pairarg_tac + \\ qspecl_then [‘p’, ‘data’] assume_tac word_cse_flat_exp_conventions \\ gvs [] + \\ qspecl_then [‘p’, ‘data’] assume_tac word_cse_full_inst_ok_less \\ gvs [] + \\ qspecl_then [‘p’, ‘data’] assume_tac word_cse_post_alloc_conventions \\ gvs [] + \\ qspecl_then [‘p’, ‘data’] assume_tac word_cse_data_conventions \\ gvs [] +QED + +Theorem word_cse_conventions2: + ∀p data c. + data_conventions data ⇒ + let (data', p') = word_cse data p in + (flat_exp_conventions p ⇒ flat_exp_conventions p') ∧ + (full_inst_ok_less c p ⇒ full_inst_ok_less c p') ∧ + (pre_alloc_conventions p ⇒ pre_alloc_conventions p') ∧ + (wf_cutsets p ⇒ wf_cutsets p') ∧ + (every_inst two_reg_inst p ⇒ every_inst two_reg_inst p') ∧ + (data_conventions data') +Proof + rpt gen_tac \\ gvs [] \\ pairarg_tac \\ gvs [] + \\ qspecl_then [‘p’, ‘data’] assume_tac word_cse_flat_exp_conventions \\ gvs [] + \\ qspecl_then [‘p’, ‘data’] assume_tac word_cse_full_inst_ok_less \\ gvs [] + \\ qspecl_then [‘p’, ‘data’] assume_tac word_cse_pre_alloc_conventions \\ gvs [] + \\ qspecl_then [‘p’, ‘data’] assume_tac word_cse_wf_cutsets \\ gvs [] + \\ qspecl_then [‘p’, ‘data’] assume_tac word_cse_every_inst_two_reg \\ gvs [] + \\ qspecl_then [‘p’, ‘data’] assume_tac word_cse_data_conventions \\ gvs [] +QED + val _ = export_theory(); diff --git a/compiler/backend/word_cseScript.sml b/compiler/backend/word_cseScript.sml index 06bac2c6b8..e0dade8e2e 100644 --- a/compiler/backend/word_cseScript.sml +++ b/compiler/backend/word_cseScript.sml @@ -1,26 +1,9 @@ (* This file is a Work in Progress. -It gives some functions and verification proofs about a Common Sub-Expression +It gives some functions about a Common Sub-Expression Elimination occuring right atfer the SSA-like renaming. *) -(* -Mind map / TODO: -- the register equivalence form - -> num list list - -> Grouping equivalent registers together, keeping the first register - added to a group in the head. - -> Adding a r2 -> r1 to the existing mapping consits of looking if - ∃group∈map. r1∈group. - If so, we look if ∃group'∈map. r2∈group'. - If so, we merge group and group'. - Else, we add r2 to group in the second place. - Else, we look if ∃group'∈map. r2∈group'. - If so, we add r1 to group' in the second place. - Else, we create a group=[r1;r2] that we add to map. - -> !!! Case of function call we context conservation !!! -*) - open preamble wordLangTheory wordsTheory boolTheory mlmapTheory sptreeTheory val _ = new_theory "word_cse"; @@ -34,12 +17,6 @@ val _ = Datatype `knowledge = <| eq:regsE; instrs:instrsM; all_names:num_set |>`; -(* add a (all_names:num_set) ⇒ when seeing a new register, add it in all_names -if a register is affected and is in all_names, throw everything - -!!! even registers !!! -*) - (* LIST COMPARISON *) Definition listCmp_def: @@ -63,7 +40,6 @@ Definition is_seen_def: is_seen r data = case sptree$lookup r data.all_names of SOME _ => T | NONE => F End - (* REGISTERS EQUIVALENCE MEMORY *) Definition listLookup_def: @@ -128,50 +104,6 @@ End Definition canonicalMultRegs_def: canonicalMultRegs (data:knowledge) (regs:num list) = MAP (canonicalRegs data) regs End -(* -Definition canonicalMoveRegs_def: - canonicalMoveRegs data [] = (data, []) ∧ - canonicalMoveRegs data ((r1,r2)::tl) = - if is_seen r1 data then empty_data, ((r1,r2)::tl) else - case sptree$lookup r2 data.och_map of - | SOME r2' => let och_map' = sptree$insert r1 r2' data.och_map in - let (data', tl') = canonicalMoveRegs (data with och_map:=och_map') tl in - (data', (r1,r2')::tl') - | NONE => let r2' = (case sptree$lookup r2 data.inst_map of SOME r => r | NONE => r2) in - let inst_eq' = regsUpdate r2' r1 data.inst_eq in - let inst_map' = sptree$insert r1 r2' data.inst_map in - let (data', tl') = canonicalMoveRegs (data with <| inst_eq:=inst_eq'; inst_map:=inst_map' |>) tl in - (data', (r1,r2')::tl') -End - -(* make a lookup_data to wrap case matching -lookup_any x sp d = lookup x sp otherwise return d -To discuss*) - -Definition canonicalMoveRegs2_def: - canonicalMoveRegs2 data [] = (data, []) ∧ - canonicalMoveRegs2 data ((r1,r2)::tl) = - if is_seen r1 data then empty_data, ((r1,r2)::tl) else - if (EVEN r1 ∨ EVEN r2) - then let (data', tl') = canonicalMoveRegs2 data tl in - (data', (r1, canonicalRegs data r2)::tl') - else - case sptree$lookup r2 data.och_map of - | SOME r2' => let och_map' = sptree$insert r1 r2' data.och_map in - let (data', tl') = canonicalMoveRegs2 (data with och_map:=och_map') tl in - (data', (r1,r2')::tl') - | NONE => let r2' = (case sptree$lookup r2 data.inst_map of SOME r => r | NONE => r2) in - let inst_eq' = regsUpdate r2' r1 data.inst_eq in - let inst_map' = sptree$insert r1 r2' data.inst_map in - let (data', tl') = canonicalMoveRegs2 (data with <| inst_eq:=inst_eq'; inst_map:=inst_map' |>) tl in - (data', (r1,r2')::tl') -End -*) -(* -Move [(1,2);(2,3);(3,1)] -Move [(1,can 2);(2,can 3);(3,can 1)] -Knowledge : 1 ⇔ can 2 / 2 ⇔ can 3 / 3 ⇔ can 1 -*) Definition map_insert_def: map_insert [] m = m ∧ @@ -258,61 +190,61 @@ Definition wordToNum_def: End Definition shiftToNum_def: - shiftToNum Lsl = (38:num) ∧ - shiftToNum Lsr = 39 ∧ - shiftToNum Asr = 40 ∧ - shiftToNum Ror = 41 + shiftToNum Lsl = (40:num) ∧ + shiftToNum Lsr = 41 ∧ + shiftToNum Asr = 42 ∧ + shiftToNum Ror = 43 End Definition arithOpToNum_def: - arithOpToNum Add = (33:num) ∧ - arithOpToNum Sub = 34 ∧ - arithOpToNum And = 35 ∧ - arithOpToNum Or = 36 ∧ - arithOpToNum Xor = 37 + arithOpToNum Add = (35:num) ∧ + arithOpToNum Sub = 36 ∧ + arithOpToNum And = 37 ∧ + arithOpToNum Or = 38 ∧ + arithOpToNum Xor = 39 End Definition regImmToNumList_def: - regImmToNumList (Reg r) = [31; r+100] ∧ - regImmToNumList (Imm w) = [32; wordToNum w] + regImmToNumList (Reg r) = [33; r+100] ∧ + regImmToNumList (Imm w) = [34; wordToNum w] End Definition arithToNumList_def: - arithToNumList (Binop op r1 r2 ri) = [23; arithOpToNum op; r2+100] ++ regImmToNumList ri ∧ - arithToNumList (LongMul r1 r2 r3 r4) = [24; r3+100; r4+100] ∧ - arithToNumList (LongDiv r1 r2 r3 r4 r5) = [25; r3+100; r4+100; r5+100] ∧ - arithToNumList (Shift s r1 r2 n) = [26; shiftToNum s; r2+100; n] ∧ - arithToNumList (Div r1 r2 r3) = [27; r2+100; r3+100] ∧ - arithToNumList (AddCarry r1 r2 r3 r4) = [28; r2+100; r3+100] ∧ - arithToNumList (AddOverflow r1 r2 r3 r4) = [29; r2+100; r3+100] ∧ - arithToNumList (SubOverflow r1 r2 r3 r4) = [30; r2+100; r3+100] + arithToNumList (Binop op r1 r2 ri) = [25; arithOpToNum op; r2+100] ++ regImmToNumList ri ∧ + arithToNumList (LongMul r1 r2 r3 r4) = [26; r3+100; r4+100] ∧ + arithToNumList (LongDiv r1 r2 r3 r4 r5) = [27; r3+100; r4+100; r5+100] ∧ + arithToNumList (Shift s r1 r2 n) = [28; shiftToNum s; r2+100; n] ∧ + arithToNumList (Div r1 r2 r3) = [29; r2+100; r3+100] ∧ + arithToNumList (AddCarry r1 r2 r3 r4) = [30; r2+100; r3+100] ∧ + arithToNumList (AddOverflow r1 r2 r3 r4) = [31; r2+100; r3+100] ∧ + arithToNumList (SubOverflow r1 r2 r3 r4) = [32; r2+100; r3+100] End Definition memOpToNum_def: - memOpToNum Load = (19:num) ∧ - memOpToNum Load8 = 20 ∧ - memOpToNum Store = 21 ∧ - memOpToNum Store8 = 22 + memOpToNum Load = (21:num) ∧ + memOpToNum Load8 = 22 ∧ + memOpToNum Store = 23 ∧ + memOpToNum Store8 = 24 End Definition fpToNumList_def: - fpToNumList (FPLess r1 r2 r3) = [3; r2+100; r3+100] ∧ - fpToNumList (FPLessEqual r1 r2 r3) = [4; r2+100; r3+100] ∧ - fpToNumList (FPEqual r1 r2 r3) = [5; r2+100; r3+100] ∧ - fpToNumList (FPAbs r1 r2) = [6; r2+100] ∧ - fpToNumList (FPNeg r1 r2) = [7; r2+100] ∧ - fpToNumList (FPSqrt r1 r2) = [8; r2+100] ∧ - fpToNumList (FPAdd r1 r2 r3) = [9; r2+100; r3+100] ∧ - fpToNumList (FPSub r1 r2 r3) = [10; r2+100; r3+100] ∧ - fpToNumList (FPMul r1 r2 r3) = [11; r2+100; r3+100] ∧ - fpToNumList (FPDiv r1 r2 r3) = [12; r2+100; r3+100] ∧ - fpToNumList (FPFma r1 r2 r3) = [13; r1+100; r2+100; r3+100] ∧ (* List never matched again *) - fpToNumList (FPMov r1 r2) = [14; r2+100] ∧ - fpToNumList (FPMovToReg r1 r2 r3) = [15; r2+100; r3+100] ∧ - fpToNumList (FPMovFromReg r1 r2 r3) = [16; r2+100; r3+100] ∧ - fpToNumList (FPToInt r1 r2) = [17; r2+100] ∧ - fpToNumList (FPFromInt r1 r2) = [18; r2+100] + fpToNumList (FPLess r1 r2 r3) = [5; r2+100; r3+100] ∧ + fpToNumList (FPLessEqual r1 r2 r3) = [6; r2+100; r3+100] ∧ + fpToNumList (FPEqual r1 r2 r3) = [7; r2+100; r3+100] ∧ + fpToNumList (FPAbs r1 r2) = [8; r2+100] ∧ + fpToNumList (FPNeg r1 r2) = [9; r2+100] ∧ + fpToNumList (FPSqrt r1 r2) = [10; r2+100] ∧ + fpToNumList (FPAdd r1 r2 r3) = [11; r2+100; r3+100] ∧ + fpToNumList (FPSub r1 r2 r3) = [12; r2+100; r3+100] ∧ + fpToNumList (FPMul r1 r2 r3) = [13; r2+100; r3+100] ∧ + fpToNumList (FPDiv r1 r2 r3) = [14; r2+100; r3+100] ∧ + fpToNumList (FPFma r1 r2 r3) = [15; r1+100; r2+100; r3+100] ∧ (* List never matched again *) + fpToNumList (FPMov r1 r2) = [16; r2+100] ∧ + fpToNumList (FPMovToReg r1 r2 r3) = [17; r2+100; r3+100] ∧ + fpToNumList (FPMovFromReg r1 r2 r3) = [18; r2+100; r3+100] ∧ + fpToNumList (FPToInt r1 r2) = [19; r2+100] ∧ + fpToNumList (FPFromInt r1 r2) = [20; r2+100] End Definition instToNumList_def: @@ -328,11 +260,12 @@ Each unique instruction is converted to a unique num list. Numbers between 0 and 99 corresponds to a unique identifier of an instruction. Numbers above 99 corresponds to a register or a word value. *) -(* TODO : redo the rename of instruction numbers such that each is unique *) Definition OpCurrHeapToNumList_def: - OpCurrHeapToNumList op r2 = [1; arithOpToNum op; r2+100] + OpCurrHeapToNumList op r2 = [0; arithOpToNum op; r2+100] End +(* WORD CSE FUNCTIONS *) + Definition firstRegOfArith_def: firstRegOfArith (Binop _ r _ _) = r ∧ firstRegOfArith (Shift _ r _ _) = r ∧ @@ -374,8 +307,14 @@ End Definition add_to_data_aux_def: add_to_data_aux data r i x = case mlmap$lookup data.instrs i of - | SOME r' => (data with <| eq:=regsUpdate r' r data.eq; map:=insert r r' data.map; all_names:=insert r () data.all_names |>, Move 0 [(r,r')]) - | NONE => (data with <| instrs:=insert data.instrs i r; all_names:=insert r () data.all_names |>, x) + | SOME r' => if EVEN r then + (data, Move 0 [(r,r')]) + else + (data with <| eq:=regsUpdate r' r data.eq; map:=insert r r' data.map; all_names:=insert r () data.all_names |>, Move 0 [(r,r')]) + | NONE => if EVEN r then + (data, x) + else + (data with <| instrs:=insert data.instrs i r; all_names:=insert r () data.all_names |>, x) End Definition add_to_data_def: @@ -402,12 +341,12 @@ Definition word_cseInst_def: (word_cseInst (data:knowledge) Skip = (data, Inst Skip)) ∧ (word_cseInst data (Const r w) = if is_seen r data then (empty_data with all_names:=data.all_names, Inst (Const r w)) else - add_to_data data r (Const r w)) ∧ + add_to_data data r (Const r w)) ∧ (word_cseInst data (Arith a) = let r = firstRegOfArith a in let a' = canonicalArith data a in if is_seen r data ∨ is_complex a' ∨ ¬are_reads_seen a' data then - (empty_data with all_names:=data.all_names, Inst (Arith a')) + (empty_data with all_names:=data.all_names, Inst (Arith a)) else add_to_data data r (Arith a')) ∧ (word_cseInst data (Mem op r (Addr r' w)) = @@ -420,14 +359,6 @@ Definition word_cseInst_def: (data, Inst (Mem op r (Addr (canonicalRegs data r') w))) ) ∧ (word_cseInst data ((FP f):'a inst) = (empty_data with all_names:=data.all_names, Inst (FP f))) - (* Not relevant: issue with fp regs having same id as regs, possible confusion - let f' = canonicalFp inst_map och_map f in - let r = firstRegOfFp f' in - let i = instToNumList ((FP f'):'a inst) in - case mlmap$lookup inst_instrs i of - | SOME r' => (n+1, regsUpdate r' r inst_eq, insert r r' inst_map, inst_instrs, Move 0 [(r,r')]) - | NONE => (n, inst_eq, inst_map, insert inst_instrs i r, Inst (FP f'))) - *) End (* @@ -475,7 +406,10 @@ Definition word_cse_def: let (data', p') = word_cse data p in (data', MustTerminate p')) ∧ (word_cse data (Call ret dest args handler) = - (empty_data, Call ret dest args handler)) ∧ + case ret of + | NONE => (empty_data, Call ret dest args handler) + | SOME (ret_reg, cut_set, p, l1, k) => + (empty_data with all_names:=inter data.all_names cut_set, Call ret dest args handler)) ∧ (word_cse data (Seq p1 p2) = let (data1, p1') = word_cse data p1 in let (data2, p2') = word_cse data1 p2 in @@ -485,7 +419,7 @@ Definition word_cse_def: let r2' = canonicalImmReg data r2 in let (data1, p1') = word_cse data p1 in let (data2, p2') = word_cse data p2 in - (empty_data with all_names:=data.all_names, If c r1' r2' p1' p2')) ∧ + (empty_data with all_names:=inter data1.all_names data2.all_names, If c r1' r2' p1' p2')) ∧ (* We don't know what happen in the IF. Intersection would be the best. *) (word_cse data (Alloc r m) = (empty_data with all_names:=data.all_names, Alloc r m)) ∧ @@ -496,7 +430,7 @@ Definition word_cse_def: (word_cse data (Tick) = (data, Tick)) ∧ (word_cse data ((OpCurrHeap b r1 r2):'a prog) = - if is_seen r1 data ∨ ¬is_seen r2 data then (empty_data, OpCurrHeap b r1 r2) else + if is_seen r1 data ∨ ¬is_seen r2 data then (empty_data with all_names:=data.all_names, OpCurrHeap b r1 r2) else let r2' = canonicalRegs data r2 in let pL = OpCurrHeapToNumList b r2' in add_to_data_aux data r1 pL (OpCurrHeap b r1 r2')) ∧ @@ -512,20 +446,4 @@ Definition word_cse_def: (empty_data with all_names:=data.all_names, FFI s p1 l1 p2 l2 m)) End - -(* -EVAL “word_cse empty_data (Seq (Inst (Arith (Binop Add 3 1 (Reg 2)))) (Inst (Arith (Binop Add 4 1 (Reg 2)))))” - -EVAL “word_cse empty_data - (Seq - (Inst (Arith (Binop Add 3 1 (Reg 2)))) - (Seq - (Inst (Arith (Binop Add 4 1 (Reg 2)))) - (Seq - (Inst (Arith (Binop Sub 5 1 (Reg 3)))) - (Inst (Arith (Binop Sub 6 1 (Reg 4)))) - ))) -” -*) - val _ = export_theory (); diff --git a/examples/compilation/to_word/word_cse_testScript.sml b/examples/compilation/to_word/word_cse_testScript.sml index a050c1d9b2..4899fe17b3 100644 --- a/examples/compilation/to_word/word_cse_testScript.sml +++ b/examples/compilation/to_word/word_cse_testScript.sml @@ -17,15 +17,38 @@ End val tm' = “let p = word_cse_compact ^tm in remove_dead p LN” -val prog = “(Seq (Inst (Arith (Binop Add 3 1 (Reg 2)))) (Inst (Arith (Binop Add 4 1 (Reg 2)))))” +val prog = “Seq (Inst (Const 1 0w)) (Inst (Const 3 5w))” -val prog2 = “Seq (Move 0 [(37,2);(39,4)]) (If Equal 41 (Imm 2w) (Return 37 2) (Return 37 2))”; +val prog = “Seq (Inst (Const 1 0w)) + (Seq (Inst (Arith (Binop Add 3 1 (Reg 1)))) + (Inst (Arith (Binop Add 4 1 (Reg 1)))))” +val prog2 = “(Seq (Move 0 [(37,2);(39,4)]) (If Equal 41 (Imm 2w) (Return 37 2) (Return 37 2))):64 wordLang$prog”; -EVAL “^tm”; +val fact_begin = “Move 1 [(37,0); (41,2); (45,4); (49,6)] ▸ + Inst (Const 189 0w) ▸ Inst (Const 193 0w) ▸ + OpCurrHeap Add 69 37 ▸ + OpCurrHeap Add 71 37 ▸ + Inst (Arith (Shift Lsr 65 41 9)) ▸ + Inst (Arith (Shift Lsr 67 41 9)) + ” (*works *) -EVAL “word_cse_compact ^prog2”; +val fact_begin2 = “Move 1 [(37,0); (41,2); (45,4); (49,6)] ▸ + Inst (Const 53 18w) ▸ Move 0 [(2,45)] ▸ + Move 1 [(181,37); (177,49)] ▸ Inst (Const 185 0w) ▸ + Inst (Const 189 0w) ▸ Inst (Const 193 0w) ▸ Move 1 [(197,53)] ▸ + Inst (Const 201 0w) ▸ Move 1 [(205,41)] ▸ Move 1 [(209,45)] ▸ + Inst (Const 213 0w) ▸ Inst (Const 217 0w) + ” +EVAL “^tm'”; + +EVAL “word_cse_compact ^prog”; + + EVAL “w2n 5w = w2n 0w”; + +EVAL “word_cse_compact ^fact_begin”; +EVAL “w2n_def 0w” val res = EVAL tm'; val res2 = EVAL “word_cse_compact ^tm”; From 4916e576ba9d5b2fc0beb2a5fb966102354ea27b Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Thu, 1 Sep 2022 14:41:40 +0200 Subject: [PATCH 30/36] Fixes for StoreConsts --- .../backend/proofs/word_cseProofScript.sml | 24 +++++++++++++------ compiler/backend/word_cseScript.sml | 10 ++++---- 2 files changed, 23 insertions(+), 11 deletions(-) diff --git a/compiler/backend/proofs/word_cseProofScript.sml b/compiler/backend/proofs/word_cseProofScript.sml index 7a07a9f6ff..6a921a5a82 100644 --- a/compiler/backend/proofs/word_cseProofScript.sml +++ b/compiler/backend/proofs/word_cseProofScript.sml @@ -2,7 +2,8 @@ Correctness proof for word_cse *) open preamble alistTheory totoTheory; -open wordLangTheory wordSemTheory wordPropsTheory reg_allocTheory word_simpTheory word_cseTheory; +open wordLangTheory wordSemTheory wordPropsTheory reg_allocTheory; +open word_simpTheory word_cseTheory; val _ = new_theory "word_cseProof"; @@ -1455,6 +1456,12 @@ Proof \\ gvs [AllCaseEqs(), add_ret_loc_def] QED +Theorem comp_StoreConsts_correct: + ^(get_goal "wordLang$StoreConsts") +Proof + gvs[word_cse_def, empty_data_def, lookup_def, data_inv_def] +QED + (* DATA EMPTY *) Theorem comp_correct: @@ -1463,12 +1470,15 @@ Proof match_mp_tac (the_ind_thm()) >> rpt conj_tac >> MAP_FIRST MATCH_ACCEPT_TAC - [comp_Skip_correct,comp_Alloc_correct,comp_Move_correct,comp_Inst_correct,comp_Assign_correct, - comp_Get_correct,comp_Set_correct,comp_Store_correct,comp_Tick_correct,comp_MustTerminate_correct, - comp_Seq_correct,comp_Return_correct,comp_Raise_correct,comp_If_correct,comp_LocValue_correct, - comp_Install_correct,comp_CodeBufferWrite_correct,comp_DataBufferWrite_correct, - comp_FFI_correct,comp_OpCurrHeap_correct,comp_Call_correct - ] + [comp_Skip_correct, comp_Alloc_correct, comp_Move_correct, + comp_Inst_correct, comp_Assign_correct, comp_Get_correct, + comp_Set_correct, comp_Store_correct, comp_Tick_correct, + comp_MustTerminate_correct, comp_Seq_correct, + comp_Return_correct, comp_Raise_correct, comp_If_correct, + comp_LocValue_correct, comp_Install_correct, + comp_StoreConsts_correct, comp_CodeBufferWrite_correct, + comp_DataBufferWrite_correct, comp_FFI_correct, + comp_OpCurrHeap_correct, comp_Call_correct ] QED Definition data_conventions_def: diff --git a/compiler/backend/word_cseScript.sml b/compiler/backend/word_cseScript.sml index e0dade8e2e..10d9c6f12e 100644 --- a/compiler/backend/word_cseScript.sml +++ b/compiler/backend/word_cseScript.sml @@ -1,7 +1,6 @@ (* -This file is a Work in Progress. -It gives some functions about a Common Sub-Expression -Elimination occuring right atfer the SSA-like renaming. + Defines a common sub-expression elimination pass on a wordLang program. + This pass is to run immeidately atfer the SSA-like renaming. *) open preamble wordLangTheory wordsTheory boolTheory mlmapTheory sptreeTheory @@ -443,7 +442,10 @@ Definition word_cse_def: (word_cse data (DataBufferWrite r1 r2) = (empty_data with all_names:=data.all_names, DataBufferWrite r1 r2)) ∧ (word_cse data (FFI s p1 l1 p2 l2 m) = - (empty_data with all_names:=data.all_names, FFI s p1 l1 p2 l2 m)) + (empty_data with all_names:=data.all_names, FFI s p1 l1 p2 l2 m)) ∧ + (word_cse data (StoreConsts r1 r2 r3 r4 payload) = + (empty_data with all_names:=data.all_names, + StoreConsts r1 r2 r3 r4 payload)) End val _ = export_theory (); From 120bb004f1dc6ae0b4ce7ca6a5c85fc73c652e47 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Sun, 4 Sep 2022 18:33:46 +0200 Subject: [PATCH 31/36] Insert word_common_subexp_elim into word_to_word compiler --- compiler/backend/README.md | 12 +++++++----- compiler/backend/backendScript.sml | 6 ++++-- compiler/backend/data_to_wordScript.sml | 4 ++-- compiler/backend/word_cseScript.sml | 6 ++++++ compiler/backend/word_to_wordScript.sml | 14 ++++++++++---- 5 files changed, 29 insertions(+), 13 deletions(-) diff --git a/compiler/backend/README.md b/compiler/backend/README.md index f32e42613d..fac12bc9e0 100644 --- a/compiler/backend/README.md +++ b/compiler/backend/README.md @@ -257,12 +257,15 @@ Proofs and automation for serialising HOL values. [source_letScript.sml](source_letScript.sml): This is a source-to-source transformation that lifts Let/Letrec expressions -out of Dlet/Dletrecs when they are independent of function arguments. +that sit at the top of Dlet:s into their own Dlet/Dletrec:s. [source_to_flatScript.sml](source_to_flatScript.sml): This is the compiler phase that translates the CakeML source language into flatLang. +[source_to_sourceScript.sml](source_to_sourceScript.sml): +This phase collects all source-to-source transformations. + [stackLangScript.sml](stackLangScript.sml): The stackLang intermediate language is a structured programming language with function calls, while loops, if statements, etc. All @@ -318,10 +321,9 @@ The bignum library used by the CakeML compiler. Note that the implementation is automatically generated from a shallow embedding that is part of the HOL distribution in mc_multiwordTheory. -[word_comSubExpElimScript.sml](word_comSubExpElimScript.sml): -This file is a Work in Progress. -It gives some functions and verification proofs about a Common Sub-Expression -Elimination occuring right atfer the SSA-like renaming. +[word_cseScript.sml](word_cseScript.sml): +Defines a common sub-expression elimination pass on a wordLang program. +This pass is to run immeidately atfer the SSA-like renaming. [word_depthScript.sml](word_depthScript.sml): Computes the call graph for wordLang program with an acyclic call diff --git a/compiler/backend/backendScript.sml b/compiler/backend/backendScript.sml index ccd74e9678..95b3cb2753 100644 --- a/compiler/backend/backendScript.sml +++ b/compiler/backend/backendScript.sml @@ -309,7 +309,8 @@ val to_livesets_def = Define` let maxv = max_var prog + 1 in let inst_prog = inst_select asm_conf maxv prog in let ssa_prog = full_ssa_cc_trans arg_count inst_prog in - let rm_prog = FST(remove_dead ssa_prog LN) in + let cse_prog = word_common_subexp_elim ssa_prog in + let rm_prog = FST(remove_dead cse_prog LN) in let prog = if two_reg_arith then three_to_two_reg rm_prog else rm_prog in (name_num,arg_count,prog)) p in @@ -330,7 +331,8 @@ val to_livesets_0_def = Define` let maxv = max_var prog + 1 in let inst_prog = inst_select asm_conf maxv prog in let ssa_prog = full_ssa_cc_trans arg_count inst_prog in - let rm_prog = FST(remove_dead ssa_prog LN) in + let cse_prog = word_common_subexp_elim ssa_prog in + let rm_prog = FST(remove_dead cse_prog LN) in let prog = if two_reg_arith then three_to_two_reg rm_prog else rm_prog in (name_num,arg_count,prog)) p in diff --git a/compiler/backend/data_to_wordScript.sml b/compiler/backend/data_to_wordScript.sml index 319ebceef4..2ecd551c9f 100644 --- a/compiler/backend/data_to_wordScript.sml +++ b/compiler/backend/data_to_wordScript.sml @@ -1167,7 +1167,7 @@ End Definition lookup_mem_def: lookup_mem m a = - dtcase lookup a m of + dtcase sptree$lookup a m of | NONE => (F,Word (0w:'a word)) | SOME x => x End @@ -1224,7 +1224,7 @@ Definition part_to_words_def: | NONE => NONE | SOME hd => SOME ((T,(make_ptr c offset (0w:'a word) (LENGTH ws))), MAP (λw. (F,Word w)) (hd::ws))) ∧ - part_to_words c m (Con t ns) (offset:'a word) = + part_to_words c m (closLang$Con t ns) (offset:'a word) = (if NULL ns then if t < dimword (:'a) DIV 16 then SOME ((F,Word (n2w (16 * t + 2))),[]) else NONE diff --git a/compiler/backend/word_cseScript.sml b/compiler/backend/word_cseScript.sml index 10d9c6f12e..f09d3fad26 100644 --- a/compiler/backend/word_cseScript.sml +++ b/compiler/backend/word_cseScript.sml @@ -448,4 +448,10 @@ Definition word_cse_def: StoreConsts r1 r2 r3 r4 payload)) End +Definition word_common_subexp_elim_def: + word_common_subexp_elim prog = + let (_,new_prog) = word_cse empty_data prog in + new_prog +End + val _ = export_theory (); diff --git a/compiler/backend/word_to_wordScript.sml b/compiler/backend/word_to_wordScript.sml index 380925bf27..c85af99bd3 100644 --- a/compiler/backend/word_to_wordScript.sml +++ b/compiler/backend/word_to_wordScript.sml @@ -7,7 +7,8 @@ 5) reg_alloc; 6) word_to_stack. *) -open preamble asmTheory wordLangTheory word_allocTheory word_removeTheory word_simpTheory +open preamble asmTheory wordLangTheory word_allocTheory word_removeTheory +open word_simpTheory word_cseTheory local open word_instTheory in (* word-to-word transformations *) end open mlstringTheory @@ -25,7 +26,8 @@ val compile_single_def = Define` let maxv = max_var prog + 1 in let inst_prog = inst_select c maxv prog in let ssa_prog = full_ssa_cc_trans arg_count inst_prog in - let rm_prog = FST(remove_dead ssa_prog LN) in + let cse_prog = word_common_subexp_elim ssa_prog in + let rm_prog = FST(remove_dead cse_prog LN) in let prog = if two_reg_arith then three_to_two_reg rm_prog else rm_prog in let reg_prog = word_alloc name_num c alg reg_count prog col_opt in @@ -60,7 +62,9 @@ Definition full_compile_single_for_eval_def: let _ = empty_ffi (strlit "finished: word_inst") in let ssa_prog = full_ssa_cc_trans arg_count inst_prog in let _ = empty_ffi (strlit "finished: word_ssa") in - let rm_prog = FST(remove_dead ssa_prog LN) in + let cse_prog = word_common_subexp_elim ssa_prog in + let _ = empty_ffi (strlit "finished: word_cse") in + let rm_prog = FST(remove_dead cse_prog LN) in let _ = empty_ffi (strlit "finished: word_remove_dead") in let prog = if two_reg_arith then three_to_two_reg rm_prog else rm_prog in @@ -94,7 +98,9 @@ Theorem compile_alt: let _ = empty_ffi (strlit "finished: word_inst") in let ssa_ps = MAP2 (λa p. full_ssa_cc_trans a p) args inst_ps in let _ = empty_ffi (strlit "finished: word_ssa") in - let dead_ps = MAP (\p. FST (remove_dead p LN)) ssa_ps in + let cse_ps = MAP word_common_subexp_elim ssa_ps in + let _ = empty_ffi (strlit "finished: word_cse") in + let dead_ps = MAP (\p. FST (remove_dead p LN)) cse_ps in let _ = empty_ffi (strlit "finished: word_remove_dead") in let two_ps = if two_reg_arith then MAP three_to_two_reg dead_ps else dead_ps in let _ = empty_ffi (strlit "finished: word_two_reg") in From 3323459f33ceb33d7ddf13562b25801c5b420c81 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Tue, 13 Sep 2022 19:35:44 +0200 Subject: [PATCH 32/36] Get backend/proofs and bootstrap/translation to build for word_cse --- compiler/backend/backendComputeLib.sml | 8 + compiler/backend/proofs/README.md | 3 + .../proofs/data_to_wordProofScript.sml | 10 +- .../proofs/data_to_word_assignProofScript.sml | 4 +- .../proofs/data_to_word_bignumProofScript.sml | 2 +- .../proofs/data_to_word_gcProofScript.sml | 4 +- .../proofs/data_to_word_memoryProofScript.sml | 2 +- .../backend/proofs/stack_allocProofScript.sml | 2 +- .../proofs/stack_rawcallProofScript.sml | 6 +- .../backend/proofs/word_cseProofScript.sml | 445 ++++++++++++------ .../proofs/word_to_wordProofScript.sml | 36 +- compiler/backend/semantics/dataSemScript.sml | 18 +- compiler/backend/word_cseScript.sml | 47 +- .../translation/to_word32ProgScript.sml | 20 + .../translation/to_word64ProgScript.sml | 20 + 15 files changed, 445 insertions(+), 182 deletions(-) diff --git a/compiler/backend/backendComputeLib.sml b/compiler/backend/backendComputeLib.sml index 346a9b1a5f..1d8629b69a 100644 --- a/compiler/backend/backendComputeLib.sml +++ b/compiler/backend/backendComputeLib.sml @@ -116,6 +116,14 @@ val add_backend_compset = computeLib.extend_compset ,computeLib.Defs (theory_computes "flat_to_clos") + ,computeLib.Defs (theory_computes "word_cse") + ,computeLib.Tys [``:word_cse$knowledge``] + + ,computeLib.Defs (theory_computes "mlmap") + ,computeLib.Tys [``:('k,'v) mlmap$map``] + ,computeLib.Defs (theory_computes "balanced_map") + ,computeLib.Tys [``:('k,'v) balanced_map$balanced_map``] + ,computeLib.Tys [``:closLang$exp`` ,``:closLang$op`` diff --git a/compiler/backend/proofs/README.md b/compiler/backend/proofs/README.md index 3332e2fc94..9f10666a6a 100644 --- a/compiler/backend/proofs/README.md +++ b/compiler/backend/proofs/README.md @@ -147,6 +147,9 @@ Correctness proof for word_alloc [word_bignumProofScript.sml](word_bignumProofScript.sml): Correctness proof for word_bignum +[word_cseProofScript.sml](word_cseProofScript.sml): +Correctness proof for word_cse + [word_depthProofScript.sml](word_depthProofScript.sml): Proves correctness of the max_depth applied to the call graph of a wordLang program as produced by the word_depth$call_graph function. diff --git a/compiler/backend/proofs/data_to_wordProofScript.sml b/compiler/backend/proofs/data_to_wordProofScript.sml index c2f7bc8fde..31ac64fe4e 100644 --- a/compiler/backend/proofs/data_to_wordProofScript.sml +++ b/compiler/backend/proofs/data_to_wordProofScript.sml @@ -2070,11 +2070,12 @@ Proof simp[COND_RAND]>> fs[word_good_handlers_three_to_two_reg]>> match_mp_tac word_good_handlers_remove_dead>> + match_mp_tac word_cseProofTheory.word_good_handlers_word_common_subexp_elim >> simp[word_good_handlers_full_ssa_cc_trans,word_good_handlers_inst_select]>> match_mp_tac word_good_handlers_word_simp>> fs[FORALL_PROD]>> metis_tac[EL_MEM] -QED; +QED Theorem word_get_code_labels_word_to_word_incr_helper: ∀oracles. @@ -2097,7 +2098,8 @@ Proof fs[COND_RAND]>> fs[word_get_code_labels_three_to_two_reg]>> old_drule (word_get_code_labels_remove_dead|>SIMP_RULE std_ss [SUBSET_DEF])>> - simp[word_get_code_labels_full_ssa_cc_trans,word_get_code_labels_inst_select]>> + simp[word_get_code_labels_full_ssa_cc_trans,word_get_code_labels_inst_select, + word_cseProofTheory.word_get_code_labels_word_common_subexp_elim]>> strip_tac>> old_drule (word_get_code_labels_word_simp|>SIMP_RULE std_ss [SUBSET_DEF])>> rw[]>>fs[FORALL_PROD,EXISTS_PROD,PULL_EXISTS,EVERY_MEM]>> @@ -2170,7 +2172,7 @@ val word_get_code_labels_MemEqList = Q.prove(` Triviality part_to_words_isWord: ∀h c m i w ws. part_to_words c m h i = SOME (w,ws) ∧ - (∀n v. lookup n m = SOME v ⇒ isWord (SND v)) ⇒ + (∀n v. sptree$lookup n m = SOME v ⇒ isWord (SND v)) ⇒ EVERY isWord (MAP SND ws) ∧ isWord (SND w) Proof Cases_on ‘h’ \\ fs [part_to_words_def] \\ rw [] @@ -2187,7 +2189,7 @@ QED Triviality parts_to_words_isWord: ∀ps c w ws m n i. parts_to_words c m n ps i = SOME (w,ws) ∧ - (∀n v. lookup n m = SOME v ⇒ isWord (SND v)) ⇒ + (∀n v. sptree$lookup n m = SOME v ⇒ isWord (SND v)) ⇒ EVERY isWord (MAP SND ws) ∧ isWord (SND w) Proof Induct diff --git a/compiler/backend/proofs/data_to_word_assignProofScript.sml b/compiler/backend/proofs/data_to_word_assignProofScript.sml index eb552d5e00..5cbff63e90 100644 --- a/compiler/backend/proofs/data_to_word_assignProofScript.sml +++ b/compiler/backend/proofs/data_to_word_assignProofScript.sml @@ -33,6 +33,8 @@ val shift_def = backend_commonTheory.word_shift_def val isWord_def = wordSemTheory.isWord_def val theWord_def = wordSemTheory.theWord_def +Overload lookup[local] = “sptree$lookup”; + val assign_def = data_to_wordTheory.assign_def |> REWRITE_RULE [arg1_def, arg2_def, arg3_def, arg4_def, all_assign_defs]; @@ -13221,7 +13223,7 @@ Proof >- ( first_x_assum (mp_tac o GSYM) \\ simp[DROP_LENGTH_NIL_rwt,wordSemTheory.write_bytearray_def] - \\ qpat_abbrev_tac`refs = insert _ _ x.refs` + \\ qpat_abbrev_tac`refs = sptree$insert _ _ x.refs` \\ `refs = x.refs` by simp[Abbr`refs`,insert_unchanged] \\ rw[] >- (qpat_x_assum `memory_rel _ _ _ _ _ _ _ _ (_ :: _ :: _)` mp_tac diff --git a/compiler/backend/proofs/data_to_word_bignumProofScript.sml b/compiler/backend/proofs/data_to_word_bignumProofScript.sml index 7ab7b7dd58..12ad62c4ad 100644 --- a/compiler/backend/proofs/data_to_word_bignumProofScript.sml +++ b/compiler/backend/proofs/data_to_word_bignumProofScript.sml @@ -5,7 +5,7 @@ open preamble dataSemTheory dataPropsTheory copying_gcTheory int_bitwiseTheory finite_mapTheory data_to_word_memoryProofTheory data_to_word_gcProofTheory data_to_wordTheory wordPropsTheory labPropsTheory - set_sepTheory semanticsPropsTheory word_to_wordProofTheory + set_sepTheory semanticsPropsTheory helperLib alignmentTheory blastLib word_bignumTheory wordLangTheory word_bignumProofTheory gen_gc_partialTheory gc_sharedTheory word_gcFunctionsTheory word_depthProofTheory; diff --git a/compiler/backend/proofs/data_to_word_gcProofScript.sml b/compiler/backend/proofs/data_to_word_gcProofScript.sml index 44eaef167c..2abb9f3a82 100644 --- a/compiler/backend/proofs/data_to_word_gcProofScript.sml +++ b/compiler/backend/proofs/data_to_word_gcProofScript.sml @@ -4,7 +4,7 @@ open preamble dataSemTheory dataPropsTheory copying_gcTheory int_bitwiseTheory data_to_word_memoryProofTheory finite_mapTheory data_to_wordTheory wordPropsTheory labPropsTheory whileTheory - set_sepTheory semanticsPropsTheory word_to_wordProofTheory + set_sepTheory semanticsPropsTheory helperLib alignmentTheory blastLib word_bignumTheory wordLangTheory word_bignumProofTheory gen_gc_partialTheory gc_sharedTheory word_gcFunctionsTheory backendPropsTheory @@ -27,6 +27,8 @@ val isWord_def = wordSemTheory.isWord_def val theWord_def = wordSemTheory.theWord_def val is_fwd_ptr_def = wordSemTheory.is_fwd_ptr_def +Overload lookup[local] = “sptree$lookup”; + val _ = hide "next"; val drule = old_drule diff --git a/compiler/backend/proofs/data_to_word_memoryProofScript.sml b/compiler/backend/proofs/data_to_word_memoryProofScript.sml index 4e54155f2e..624d1e2a8f 100644 --- a/compiler/backend/proofs/data_to_word_memoryProofScript.sml +++ b/compiler/backend/proofs/data_to_word_memoryProofScript.sml @@ -252,7 +252,7 @@ val v_all_ts_def = tDefine"v_all_ts" ` (* TODO: MOVE *) val all_ts_def = Define` all_ts refs stack = - let refs_v = {x | ∃n l. lookup n refs = SOME (ValueArray l) ∧ MEM x l} + let refs_v = {x | ∃n l. sptree$lookup n refs = SOME (ValueArray l) ∧ MEM x l} in {ts | ∃x. (x ∈ refs_v ∨ MEM x stack) ∧ MEM ts (v_all_ts x)} ` diff --git a/compiler/backend/proofs/stack_allocProofScript.sml b/compiler/backend/proofs/stack_allocProofScript.sml index e9a7560664..d95bca5f3b 100644 --- a/compiler/backend/proofs/stack_allocProofScript.sml +++ b/compiler/backend/proofs/stack_allocProofScript.sml @@ -5035,7 +5035,7 @@ val alloc_correct = Q.prove( val find_code_IMP_lookup = Q.prove( `find_code dest regs (s:'a num_map) = SOME x ==> - ?k. lookup k s = SOME x /\ + ?k. sptree$lookup k s = SOME x /\ (find_code dest regs = ((lookup k):'a num_map -> 'a option))`, Cases_on `dest` \\ full_simp_tac(srw_ss())[find_code_def,FUN_EQ_THM] \\ every_case_tac \\ full_simp_tac(srw_ss())[] \\ metis_tac []); diff --git a/compiler/backend/proofs/stack_rawcallProofScript.sml b/compiler/backend/proofs/stack_rawcallProofScript.sml index c5896257c6..e4fd4f4342 100644 --- a/compiler/backend/proofs/stack_rawcallProofScript.sml +++ b/compiler/backend/proofs/stack_rawcallProofScript.sml @@ -21,8 +21,8 @@ Type prog[pp] = “:α stackLang$prog” Definition state_ok_def: state_ok i code <=> !n v. - lookup n i = SOME v ==> - ?p. lookup n code = SOME (Seq (StackAlloc v) p) + sptree$lookup n i = SOME v ==> + ?p. sptree$lookup n code = SOME (Seq (StackAlloc v) p) End Definition state_rel_def: @@ -36,7 +36,7 @@ Definition state_rel_def: t.compile_oracle = (I ## compile ## I) o s.compile_oracle /\ *) state_ok i s.code /\ !n b. - lookup n s.code = SOME b ==> + sptree$lookup n s.code = SOME b ==> ?i. state_ok i s.code /\ lookup n c = SOME (comp_top i b) End diff --git a/compiler/backend/proofs/word_cseProofScript.sml b/compiler/backend/proofs/word_cseProofScript.sml index 6a921a5a82..8688c6bd83 100644 --- a/compiler/backend/proofs/word_cseProofScript.sml +++ b/compiler/backend/proofs/word_cseProofScript.sml @@ -41,6 +41,12 @@ Proof \\ Cases_on ‘lookup r data.map’ \\ fs [] QED +Theorem canonicalRegs'_correct[simp]: + ∀a data r s. data_inv data s ⇒ get_var (canonicalRegs' a data r) s = get_var r s +Proof + rw [canonicalRegs'_def] +QED + Theorem canonicalRegs_correct_bis[simp]: ∀data r s. data_inv data s ⇒ lookup (canonicalRegs data r) s.locals = lookup r s.locals Proof @@ -56,10 +62,12 @@ Proof rpt gen_tac \\ strip_tac \\ Cases_on ‘a’ \\ gvs [canonicalArith_def, inst_def, assign_def, word_exp_def, the_words_def] - >- (Cases_on ‘lookup n0 s.locals’ \\ gvs [] - \\ Cases_on ‘x’ \\ gvs [] - \\ Cases_on ‘r’ \\ gvs [canonicalImmReg_def, word_exp_def]) \\ gvs [get_vars_def] + \\ fs [GSYM get_var_def] + \\ Cases_on ‘get_var n0 s’ \\ fs [] + \\ Cases_on ‘x’ \\ fs [] + \\ Cases_on ‘r’ \\ fs [] + \\ gvs [canonicalImmReg'_def, word_exp_def, GSYM get_var_def] QED Theorem canonicalExp_correct[simp]: @@ -71,30 +79,36 @@ Proof \\ gvs [canonicalExp_def, word_exp_def] QED +Theorem is_seen_canonicalRegs: + data_inv data s ⇒ + is_seen (canonicalRegs data n') data = is_seen n' data +Proof + rw [canonicalRegs_def,is_seen_def,lookup_any_def] + \\ every_case_tac \\ fs [] + \\ fs [data_inv_def] + \\ gvs [domain_lookup] + \\ res_tac \\ fs [] +QED + +Theorem is_seen_canonicalRegs': + data_inv data s ⇒ + is_seen (canonicalRegs' n data n') data = is_seen n' data +Proof + rw [canonicalRegs'_def] + \\ irule is_seen_canonicalRegs \\ fs [] \\ pop_assum $ irule_at Any +QED + Theorem are_reads_seen_canonical[simp]: - ∀a data s. data_inv data s ⇒ ¬is_complex a ⇒ are_reads_seen (canonicalArith data a) data = are_reads_seen a data + ∀a data s. + data_inv data s ⇒ ¬is_complex a ⇒ + are_reads_seen (canonicalArith data a) data = are_reads_seen a data Proof rpt strip_tac + \\ imp_res_tac is_seen_canonicalRegs' \\ fs [] + \\ imp_res_tac is_seen_canonicalRegs \\ fs [] \\ Cases_on ‘a’ \\ gvs [canonicalArith_def, is_complex_def] - >- (reverse (Cases_on ‘r’) \\ gvs [canonicalRegs_def, canonicalImmReg_def, are_reads_seen_def] - \\ gvs [lookup_any_def, is_seen_def] - >- (Cases_on ‘lookup n0 data.map’ \\ gvs [data_inv_def] - \\ first_assum drule \\ pop_assum kall_tac \\ strip_tac - \\ gvs [domain_lookup]) - \\ Cases_on ‘lookup n0 data.map’ \\ gvs [] - >- (Cases_on ‘lookup n' data.map’ \\ gvs [data_inv_def] - \\ first_x_assum drule \\ strip_tac \\ gvs [domain_lookup]) - \\ gvs [data_inv_def] - \\ first_assum drule \\ pop_assum kall_tac \\ strip_tac \\ gvs [domain_lookup] - \\ Cases_on ‘lookup n' data.map’ \\ gvs [] - \\ first_x_assum drule \\ strip_tac \\ gvs [domain_lookup]) - \\ gvs [are_reads_seen_def, is_seen_def, canonicalRegs_def, lookup_any_def] - \\ Cases_on ‘lookup n0 data.map’ \\ gvs [data_inv_def] - >- (first_x_assum drule \\ strip_tac \\ gvs [domain_lookup]) - >- (Cases_on ‘lookup n1 data.map’ \\ gvs [] - \\ first_x_assum drule \\ strip_tac \\ gvs [domain_lookup]) - \\ first_assum drule \\ pop_assum kall_tac \\ strip_tac \\ gvs [domain_lookup] - \\ Cases_on ‘lookup n1 data.map’ \\ gvs [] \\ first_x_assum drule \\ strip_tac \\ gvs [domain_lookup] + \\ gvs [are_reads_seen_def] + \\ Cases_on ‘r’ \\ fs [are_reads_seen_def,canonicalImmReg'_def] QED Theorem is_complex_canonical[simp]: @@ -831,7 +845,8 @@ Proof \\ gvs [] >- (Cases_on ‘a’ \\ gvs [arithToNumList_def, canonicalArith_def] \\ Cases_on ‘r’ \\ Cases_on ‘r'’ - \\ gvs [canonicalRegs_def, canonicalImmReg_def, regImmToNumList_def, lookup_any_def] + \\ gvs [canonicalRegs_def, canonicalImmReg_def, + canonicalRegs'_def, canonicalImmReg'_def, regImmToNumList_def, lookup_any_def] \\ gvs [is_complex_def, are_reads_seen_def, is_seen_def] >- (Cases_on ‘lookup n0 data.map’ \\ gvs [] \\ Cases_on ‘n0=n’ \\ gvs [lookup_insert] @@ -891,7 +906,9 @@ Proof \\ gvs [AllCaseEqs()] >- (Cases_on ‘a’ \\ gvs [arithToNumList_def, canonicalArith_def] \\ ‘s'=s''’ by (Cases_on ‘s'’ \\ Cases_on ‘s''’ \\ gvs [shiftToNum_def]) - \\ gvs [canonicalRegs_def, canonicalImmReg_def, regImmToNumList_def, lookup_any_def] + \\ gvs [canonicalRegs_def, canonicalImmReg_def, + canonicalRegs'_def, canonicalImmReg'_def, + regImmToNumList_def, lookup_any_def] \\ gvs [is_complex_def, are_reads_seen_def, is_seen_def] \\ Cases_on ‘lookup n0 data.map’ \\ gvs [] >- (Cases_on ‘n0=n’ \\ gvs [lookup_insert] @@ -1028,6 +1045,12 @@ Proof \\ Cases_on ‘a’ \\ gvs [is_complex_def, inst_def, assign_def, firstRegOfArith_def, AllCaseEqs(), data_inv_set_var] QED +Triviality if_eq_rw[simp]: + (if x = y then y else x) = x +Proof + rw [] +QED + Theorem comp_Inst_correct: ^(get_goal "Inst") Proof @@ -1101,57 +1124,17 @@ Proof \\ drule_all Inst_Arith_SOME_lemma \\ rw []) \\ gvs [evaluate_def] \\ pop_assum kall_tac + \\ drule canonicalRegs'_correct \\ rewrite_tac [get_var_def] \\ strip_tac + \\ drule canonicalRegs_correct \\ rewrite_tac [get_var_def] \\ strip_tac \\ gvs [get_vars_def, data_inv_def] - \\ first_x_assum drule \\ pop_assum kall_tac \\ strip_tac \\ gvs [] + \\ simp [AllCaseEqs(),PULL_EXISTS, set_vars_def,alist_insert_def] + \\ first_x_assum drule \\ strip_tac \\ gvs [] + \\ qpat_x_assum ‘(if _ then _ else _) = _’ kall_tac \\ Cases_on ‘a’ \\ gvs [is_complex_def, firstRegOfArith_def, inst_def, assign_def] - >- (Cases_on ‘r’ \\ gvs [word_exp_def] - \\ gvs [are_reads_seen_def, canonicalArith_def, canonicalRegs_def, - canonicalImmReg_def, lookup_any_def] - >- (Cases_on ‘lookup n0 data.map’ \\ gvs [] - >- (Cases_on ‘lookup n' data.map’ \\ gvs [] - >- gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, - assign_def, word_exp_def, set_var_def] - \\ first_x_assum drule \\ strip_tac - \\ gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, - assign_def, word_exp_def, set_var_def, get_var_def]) - \\ first_assum drule \\ pop_assum kall_tac \\ strip_tac - \\ Cases_on ‘lookup n' data.map’ \\ gvs [] - >- gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, - assign_def, word_exp_def, set_var_def, get_var_def] - \\ first_x_assum drule \\ strip_tac - \\ gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, - assign_def, word_exp_def, set_var_def, get_var_def]) - \\ Cases_on ‘lookup n0 data.map’ \\ gvs [] - >- gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, - assign_def, word_exp_def, set_var_def] - \\ first_x_assum drule \\ strip_tac - \\ gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, - assign_def, word_exp_def, set_var_def, get_var_def]) - >- (gvs [word_exp_def, are_reads_seen_def, canonicalArith_def, - canonicalRegs_def, canonicalImmReg_def, lookup_any_def] - \\ Cases_on ‘lookup n0 data.map’ \\ gvs [] - >- gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, - assign_def, word_exp_def, set_var_def] - \\ first_x_assum drule \\ strip_tac - \\ gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, - assign_def, word_exp_def, set_var_def, get_var_def]) - \\ gvs [word_exp_def, are_reads_seen_def, canonicalArith_def, - canonicalRegs_def, canonicalImmReg_def, lookup_any_def] - \\ Cases_on ‘lookup n0 data.map’ \\ gvs [] - >- (Cases_on ‘lookup n1 data.map’ \\ gvs [] - >- gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, - assign_def, word_exp_def, set_var_def] - \\ first_x_assum drule \\ strip_tac - \\ gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, - assign_def, word_exp_def, set_var_def, get_var_def, get_vars_def]) - \\ first_assum drule \\ pop_assum kall_tac \\ strip_tac - \\ Cases_on ‘lookup n1 data.map’ \\ gvs [] - >- gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, - assign_def, word_exp_def, set_var_def, get_var_def, get_vars_def] - \\ first_assum drule \\ pop_assum kall_tac \\ strip_tac - \\ gvs [set_vars_def, alist_insert_def, evaluate_def, inst_def, - assign_def, word_exp_def, set_var_def, get_var_def, get_vars_def] - ) + \\ fs [AllCaseEqs(),evaluate_def,inst_def,assign_def] + \\ gvs [are_reads_seen_def, canonicalArith_def, word_exp_def, get_vars_def, get_var_def] + \\ gvs [AllCaseEqs()] + \\ TRY (Cases_on ‘r’) \\ gvs [word_exp_def,canonicalImmReg'_def,set_var_def]) >- (* Mem *) ( Cases_on ‘a’ \\ gvs [word_cse_def, word_cseInst_def] @@ -1169,10 +1152,10 @@ Proof \\ Cases_on ‘is_seen n data’ \\ gvs [] \\ Cases_on ‘m’ \\ gvs [is_store_def, evaluate_def, inst_def, word_exp_def, the_words_def] \\ gvs [AllCaseEqs()] - \\ gvs [set_var_def] - ) + \\ gvs [set_var_def]) >- (* FP *) - ( gvs [evaluate_def, word_cse_def, word_cseInst_def, data_inv_def, empty_data_def, lookup_def] ) + ( gvs [evaluate_def, word_cse_def, word_cseInst_def, + data_inv_def, empty_data_def, lookup_def ] ) QED Theorem comp_Assign_correct: @@ -1229,64 +1212,73 @@ Proof \\ gvs [word_cse_def] \\ Cases_on ‘is_seen dst data’ \\ gvs [] \\ Cases_on ‘is_seen src data’ \\ gvs [] - \\ gvs [add_to_data_aux_def] - \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs data src))’ \\ gvs [] - >- (Cases_on ‘EVEN dst’ - \\ gvs [evaluate_def, word_exp_def, AllCaseEqs(), data_inv_set_var] - \\ gvs [data_inv_def] - \\ rpt conj_tac \\ rpt gen_tac \\ strip_tac - >- (first_x_assum drule \\ strip_tac - \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def] - \\ Cases_on ‘r=dst’ \\ Cases_on ‘v=dst’ \\ gvs []) - >- (gvs [mlmapTheory.lookup_insert, OpCurrHeapToNumList_def, instToNumList_def] - \\ gvs [the_words_def, AllCaseEqs()] - \\ first_x_assum drule \\ strip_tac \\ gvs [] - \\ Cases_on ‘v=dst’ \\ gvs [set_var_def, lookup_insert, domain_lookup, is_seen_def]) - >- (gvs [mlmapTheory.lookup_insert, OpCurrHeapToNumList_def, instToNumList_def] - \\ first_x_assum drule \\ strip_tac \\ gvs [] - \\ drule_at (Pos last) evaluate_arith_insert - \\ strip_tac \\ first_x_assum (qspec_then ‘data’ mp_tac) - \\ disch_then drule \\ gvs [] \\ strip_tac - \\ Cases_on ‘v=dst’ - \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def]) - \\ gvs [mlmapTheory.lookup_insert] - \\ Cases_on ‘OpCurrHeapToNumList b (canonicalRegs data src) = OpCurrHeapToNumList op src'’ \\ gvs [] - >- (gvs [is_seen_def, OpCurrHeapToNumList_def, canonicalRegs_def, lookup_any_def] - \\ Cases_on ‘lookup src data.map’ \\ gvs [] - >- (Cases_on ‘src=dst’ \\ gvs [lookup_insert] - \\ gvs [word_exp_def, set_var_def, get_var_def, lookup_insert]) - \\ first_x_assum drule \\ strip_tac - \\ Cases_on ‘x=dst’ \\ gvs [lookup_insert, domain_lookup] - \\ gvs [word_exp_def, set_var_def, get_var_def, lookup_insert]) - \\ pop_assum mp_tac \\ first_x_assum drule \\ strip_tac \\ strip_tac \\ gvs [] - \\ gvs [is_seen_def] - \\ Cases_on ‘src'=dst’ \\ gvs [lookup_insert] - \\ gvs [word_exp_def, set_var_def, get_var_def, lookup_insert] - \\ Cases_on ‘v=dst’ \\ gvs [domain_lookup]) - \\ ‘p' = Move 0 [(dst,x)]’ by gvs [AllCaseEqs()] \\ gvs [] + \\ gvs [add_to_data_aux_def,CaseEq"option"] + >- + (Cases_on ‘EVEN dst’ \\ gvs [evaluate_def, word_exp_def] + \\ gvs [evaluate_def, word_exp_def, AllCaseEqs(), data_inv_set_var] + \\ gvs [PULL_EXISTS,GSYM get_var_def] + \\ gvs [data_inv_def] + \\ rpt conj_tac \\ rpt gen_tac \\ strip_tac + >- (first_x_assum drule \\ strip_tac + \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def] + \\ Cases_on ‘r=dst’ \\ Cases_on ‘v=dst’ \\ gvs []) + >- (gvs [mlmapTheory.lookup_insert, OpCurrHeapToNumList_def, instToNumList_def] + \\ gvs [the_words_def, AllCaseEqs()] + \\ first_x_assum drule \\ strip_tac \\ gvs [] + \\ Cases_on ‘v=dst’ \\ gvs [set_var_def, lookup_insert, domain_lookup, is_seen_def]) + >- (gvs [mlmapTheory.lookup_insert, OpCurrHeapToNumList_def, instToNumList_def] + \\ first_x_assum drule \\ strip_tac \\ gvs [] + \\ drule_at (Pos last) evaluate_arith_insert + \\ strip_tac \\ first_x_assum (qspec_then ‘data’ mp_tac) + \\ disch_then drule \\ gvs [] \\ strip_tac + \\ Cases_on ‘v=dst’ + \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def]) + \\ gvs [mlmapTheory.lookup_insert] + \\ Cases_on ‘OpCurrHeapToNumList b (canonicalRegs' dst data src) = OpCurrHeapToNumList op src'’ \\ gvs [] + >- (gvs [is_seen_def, OpCurrHeapToNumList_def, canonicalRegs_def, + canonicalRegs'_def, lookup_any_def] + \\ Cases_on ‘lookup src data.map’ \\ gvs [] + >- (Cases_on ‘src=dst’ \\ gvs [lookup_insert] + \\ gvs [word_exp_def, set_var_def, get_var_def, lookup_insert]) + \\ first_x_assum drule \\ strip_tac + \\ Cases_on ‘x=dst’ \\ gvs [lookup_insert, domain_lookup] + \\ gvs [word_exp_def, set_var_def, get_var_def, lookup_insert]) + \\ pop_assum mp_tac \\ first_x_assum drule \\ strip_tac \\ strip_tac \\ gvs [] + \\ gvs [is_seen_def] + \\ Cases_on ‘src'=dst’ \\ gvs [lookup_insert] + \\ gvs [word_exp_def, set_var_def, get_var_def, lookup_insert] + \\ Cases_on ‘v=dst’ \\ gvs [domain_lookup]) + \\ ‘p' = Move 0 [(dst,r')]’ by gvs [AllCaseEqs()] \\ gvs [] \\ conj_tac - >- (drule canonicalRegs_correct_bis \\ strip_tac - \\ gvs [evaluate_def, AllCaseEqs(), data_inv_def] + >- (drule canonicalRegs'_correct \\ rewrite_tac [get_var_def] \\ strip_tac + \\ gvs [evaluate_def,get_vars_def,AllCaseEqs(), PULL_EXISTS] + \\ gvs [evaluate_def, AllCaseEqs(), data_inv_def, get_vars_def] \\ first_x_assum drule \\ strip_tac \\ gvs [word_exp_def, the_words_def, AllCaseEqs()] - \\ gvs [get_vars_def, set_vars_def, alist_insert_def, set_var_def] - ) + \\ gvs [get_vars_def, set_vars_def, alist_insert_def, set_var_def]) \\ strip_tac \\ Cases_on ‘EVEN dst’ \\ gvs [evaluate_def, AllCaseEqs(), data_inv_set_var] - \\ drule canonicalRegs_correct + \\ drule canonicalRegs'_correct \\ gvs [data_inv_def] \\ first_assum drule \\ pop_assum kall_tac \\ pop_assum kall_tac \\ strip_tac \\ strip_tac \\ rpt conj_tac \\ rpt gen_tac \\ strip_tac - >- (gvs [word_exp_def, the_words_def, get_var_def, AllCaseEqs()] + >- (gvs [word_exp_def, the_words_def, get_var_def, AllCaseEqs(), set_var_def, lookup_insert] \\ Cases_on ‘r=dst’ \\ gvs [set_var_def, lookup_insert] \\ first_x_assum drule \\ strip_tac - \\ Cases_on ‘v=dst’ \\ gvs [is_seen_def, domain_lookup]) - >- (first_x_assum drule \\ strip_tac - \\ Cases_on ‘v=dst’ \\ gvs [set_var_def, lookup_insert, domain_lookup, is_seen_def]) + \\ Cases_on ‘v=dst’ \\ gvs [is_seen_def, domain_lookup] + \\ res_tac \\ fs []) >- (first_x_assum drule \\ strip_tac - \\ drule_all evaluate_arith_insert - \\ Cases_on ‘v=dst’ \\ gvs [get_var_def, set_var_def, lookup_insert, domain_lookup, is_seen_def]) + \\ Cases_on ‘v=dst’ \\ gvs [set_var_def, lookup_insert, domain_lookup, is_seen_def] + \\ gvs [get_var_def] \\ res_tac \\ fs []) + >- (first_x_assum drule \\ strip_tac \\ gvs [] + \\ Cases_on ‘v=dst’ \\ gvs [lookup_insert, domain_lookup, is_seen_def] + \\ irule_at Any evaluate_arith_insert + \\ gvs [set_var_def, lookup_insert, get_var_def] + \\ first_x_assum drule + \\ fs [] \\ strip_tac \\ fs [] + \\ first_x_assum $ irule_at $ Pos last + \\ fs [is_seen_def]) \\ first_x_assum drule \\ strip_tac \\ gvs [] \\ Cases_on ‘v=dst’ \\ gvs [lookup_insert, domain_lookup, is_seen_def] \\ Cases_on ‘src'=dst’ \\ gvs [] @@ -1481,6 +1473,17 @@ Proof comp_OpCurrHeap_correct, comp_Call_correct ] QED +Theorem word_common_subexp_elim_correct: + evaluate (p, s) = (res,s1) ∧ + flat_exp_conventions p ∧ res ≠ SOME Error ⇒ + evaluate (word_common_subexp_elim p, s) = (res,s1) +Proof + rw [word_common_subexp_elim_def] + \\ pairarg_tac \\ gvs [] + \\ drule comp_correct \\ fs [] + \\ disch_then imp_res_tac \\ fs [] +QED + Definition data_conventions_def: data_conventions (data:knowledge) ⇔ (∀r v. lookup r data.map = SOME v ⇒ @@ -1537,6 +1540,13 @@ Proof \\ last_x_assum drule \\ strip_tac \\ gvs [is_phy_var_EVEN] QED +Theorem is_phy_var_canonicalRegs': + ∀data r. data_conventions data ⇒ (is_phy_var (canonicalRegs' a data r) ⇔ is_phy_var r) +Proof + rw [canonicalRegs'_def] + \\ irule is_phy_var_canonicalRegs \\ fs [] +QED + Theorem EVERY_is_phy_var_canonicalRegs: ∀l data. EVERY is_phy_var (MAP SND l) ∧ data_conventions data ⇒ @@ -1725,7 +1735,7 @@ Proof \\ gen_tac \\ Cases_on ‘lookup r data1.all_names’ \\ gvs []) >- (Cases_on ‘is_seen n data’ \\ gvs [] \\ Cases_on ‘is_seen n0 data’ \\ gvs [add_to_data_aux_def] - \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs data n0))’ + \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs' n data n0))’ \\ Cases_on ‘EVEN n’ \\ gvs [] \\ gvs [data_conventions_def] >- (rpt conj_tac \\ rpt gen_tac @@ -1780,7 +1790,7 @@ Proof \\ last_x_assum (qspec_then ‘data’ assume_tac) \\ gvs [flat_exp_conventions_def]) >- (Cases_on ‘is_seen n data ∨ ¬is_seen n0 data’ \\ gvs [flat_exp_conventions_def] \\ gvs [add_to_data_aux_def] - \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs data n0))’ + \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs' n data n0))’ \\ Cases_on ‘EVEN n’ \\ gvs [flat_exp_conventions_def]) >- (Cases_on ‘is_seen n data’ \\ gvs [flat_exp_conventions_def]) QED @@ -1794,7 +1804,7 @@ Theorem inst_ok_canonicalArith_lemma: Proof rpt strip_tac \\ Cases_on ‘a’ \\ gvs [inst_ok_less_def, canonicalArith_def, canonicalRegs_def, lookup_any_def] - >- (Cases_on ‘r’ \\ gvs [canonicalImmReg_def, inst_ok_less_def]) + >- (Cases_on ‘r’ \\ gvs [canonicalImmReg'_def, inst_ok_less_def]) >- (strip_tac \\ gvs [data_conventions_def] \\ Cases_on ‘lookup n1 data.map’ \\ gvs [] \\ Cases_on ‘lookup n2 data.map’ \\ gvs [] @@ -1803,6 +1813,7 @@ Proof \\ last_x_assum drule \\ gvs [] \\ Cases_on ‘n=x'’ \\ gvs []) \\ (strip_tac \\ gvs [data_conventions_def] + \\ rw [canonicalRegs'_def] \\ Cases_on ‘lookup n1 data.map’ \\ gvs [] \\ first_x_assum drule \\ strip_tac \\ gvs [] \\ Cases_on ‘n=x’ \\ gvs [firstRegOfArith_def]) @@ -1855,7 +1866,7 @@ Proof \\ Cases_on ‘r’ \\ gvs [canonicalImmReg_def]) >- (Cases_on ‘is_seen n data ∨ ¬is_seen n0 data’ \\ gvs [full_inst_ok_less_def] \\ gvs [add_to_data_aux_def] - \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs data n0))’ + \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs' n data n0))’ \\ Cases_on ‘EVEN n’ \\ gvs [full_inst_ok_less_def]) \\ Cases_on ‘is_seen n data’ \\ gvs [full_inst_ok_less_def] QED @@ -1868,8 +1879,10 @@ Theorem every_is_phy_var_canonicalArith: Proof rpt strip_tac \\ Cases_on ‘a’ \\ gvs [is_complex_def] - \\ gvs [canonicalArith_def, every_var_def, every_var_inst_def, is_phy_var_canonicalRegs] - \\ Cases_on ‘r’ \\ gvs [canonicalImmReg_def, every_var_imm_def, is_phy_var_canonicalRegs] + \\ gvs [canonicalArith_def, every_var_def, every_var_inst_def, is_phy_var_canonicalRegs, + is_phy_var_canonicalRegs'] + \\ Cases_on ‘r’ \\ gvs [canonicalImmReg'_def, every_var_imm_def, is_phy_var_canonicalRegs, + is_phy_var_canonicalRegs'] QED Theorem inst_arg_convention_canonicalArith: @@ -1930,12 +1943,13 @@ Proof >- (strip_tac \\ Cases_on ‘is_seen n data’ \\ gvs [] \\ Cases_on ‘is_seen n0 data’ \\ gvs [add_to_data_aux_def] - \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs data n0))’ \\ gvs [] + \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs' n data n0))’ \\ gvs [] \\ Cases_on ‘EVEN n’ \\ gvs [every_stack_var_def, call_arg_convention_def]) \\ strip_tac \\ Cases_on ‘is_seen n data’ \\ gvs [] QED +(* Theorem word_cse_post_alloc_conventions: ∀p data k. let p' = SND (word_cse data p) in @@ -2036,6 +2050,7 @@ Proof >- (strip_tac \\ Cases_on ‘is_seen n data’ \\ gvs []) QED +*) Theorem word_cse_wf_cutsets: ∀p data. @@ -2073,7 +2088,7 @@ Proof >- (Cases_on ‘is_seen n data’ \\ gvs [wf_cutsets_def] \\ Cases_on ‘¬is_seen n0 data’ \\ gvs [wf_cutsets_def] \\ gvs [add_to_data_aux_def] - \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs data n0))’ \\ gvs [] + \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs' n data n0))’ \\ gvs [] \\ Cases_on ‘EVEN n’ \\ gvs [wf_cutsets_def]) \\ Cases_on ‘is_seen n data’ \\ gvs [wf_cutsets_def] QED @@ -2085,6 +2100,53 @@ Proof \\ Cases_on ‘lookup n data.map’ \\ gvs [] QED +Theorem word_cse_every_inst_distinct_tar_reg: + ∀p data. + let p' = SND (word_cse data p) in + data_conventions data ⇒ + every_inst distinct_tar_reg p ⇒ every_inst distinct_tar_reg p' +Proof + Induct \\ gvs [every_inst_def, word_cse_def, AllCaseEqs()] + \\ rpt gen_tac \\ strip_tac + >- (pairarg_tac \\ gvs [every_inst_def]) + >- (pairarg_tac \\ gvs [] + \\ reverse (Cases_on ‘i’) + \\ gvs [word_cseInst_def, add_to_data_def, add_to_data_aux_def, + every_inst_def, distinct_tar_reg_def, AllCaseEqs()] + >- (Cases_on ‘a’ \\ gvs [word_cseInst_def, every_inst_def, distinct_tar_reg_def, AllCaseEqs()]) + \\ Cases_on ‘a’ \\ gvs [is_complex_def, firstRegOfArith_def] + \\ strip_tac + \\ gvs [distinct_tar_reg_def, are_reads_seen_def, canonicalArith_def, is_seen_canonical] + \\ gvs [canonicalRegs_def, canonicalRegs'_def, lookup_any_def] \\ rw [] + \\ gvs [AllCaseEqs()] + \\ Cases_on ‘lookup n data.map’ \\ gvs [data_conventions_def] + \\ Cases_on ‘r’ \\ fs [canonicalImmReg'_def,canonicalRegs'_def]) + >- (Cases_on ‘is_seen n data’ \\ gvs [every_inst_def]) + >- (Cases_on ‘s’ \\ gvs [every_inst_def]) + >- (pairarg_tac \\ strip_tac \\ gvs [] \\ last_x_assum drule_all \\ gvs [every_inst_def]) + >- (Cases_on ‘o'’ \\ gvs [every_inst_def] + \\ Cases_on ‘x’ \\ gvs [every_inst_def] + \\ Cases_on ‘r’ \\ gvs [every_inst_def]) + >- (pairarg_tac \\ gvs [] \\ strip_tac + \\ last_x_assum drule_all \\ strip_tac + \\ ‘data_conventions data1’ + by (assume_tac word_cse_data_conventions + \\ first_x_assum (qspecl_then [‘p’, ‘data’] assume_tac) \\ gvs []) + \\ last_x_assum drule_all \\ strip_tac + \\ pairarg_tac \\ gvs [every_inst_def]) + >- (strip_tac + \\ rpt (pairarg_tac \\ gvs []) + \\ rpt (last_x_assum drule \\ strip_tac) + \\ gvs [every_inst_def]) + >- (Cases_on ‘is_seen n data’ \\ gvs [every_inst_def] + \\ Cases_on ‘¬is_seen n0 data’ \\ gvs [every_inst_def] + \\ gvs [add_to_data_aux_def] + \\ Cases_on ‘lookup data.instrs (OpCurrHeapToNumList b (canonicalRegs' n data n0))’ \\ gvs [] + \\ Cases_on ‘EVEN n’ \\ gvs [every_inst_def, distinct_tar_reg_def] + \\ strip_tac \\ gvs [canonicalRegs'_def,lookup_any_def] \\ every_case_tac \\ fs []) + \\ Cases_on ‘is_seen n data’ \\ gvs [every_inst_def] +QED + Theorem word_cse_every_inst_two_reg: ∀p data. let p' = SND (word_cse data p) in @@ -2102,7 +2164,8 @@ Proof \\ Cases_on ‘a’ \\ gvs [is_complex_def, firstRegOfArith_def] \\ strip_tac \\ gvs [two_reg_inst_def, are_reads_seen_def, canonicalArith_def, is_seen_canonical] - \\ gvs [canonicalRegs_def, lookup_any_def] + \\ gvs [canonicalRegs_def, canonicalRegs'_def, lookup_any_def] \\ rw [] + \\ gvs [AllCaseEqs()] \\ Cases_on ‘lookup n data.map’ \\ gvs [data_conventions_def]) >- (Cases_on ‘is_seen n data’ \\ gvs [every_inst_def]) >- (Cases_on ‘s’ \\ gvs [every_inst_def]) @@ -2136,13 +2199,13 @@ Theorem word_cse_conventions: let (data', p') = word_cse data p in (flat_exp_conventions p ⇒ flat_exp_conventions p') ∧ (full_inst_ok_less c p ⇒ full_inst_ok_less c p') ∧ - (post_alloc_conventions k p ⇒ post_alloc_conventions k p') ∧ + (* (post_alloc_conventions k p ⇒ post_alloc_conventions k p') ∧ *) (data_conventions data') Proof rpt gen_tac \\ gvs [] \\ pairarg_tac \\ qspecl_then [‘p’, ‘data’] assume_tac word_cse_flat_exp_conventions \\ gvs [] \\ qspecl_then [‘p’, ‘data’] assume_tac word_cse_full_inst_ok_less \\ gvs [] - \\ qspecl_then [‘p’, ‘data’] assume_tac word_cse_post_alloc_conventions \\ gvs [] +(*\\ qspecl_then [‘p’, ‘data’] assume_tac word_cse_post_alloc_conventions \\ gvs []*) \\ qspecl_then [‘p’, ‘data’] assume_tac word_cse_data_conventions \\ gvs [] QED @@ -2155,6 +2218,7 @@ Theorem word_cse_conventions2: (pre_alloc_conventions p ⇒ pre_alloc_conventions p') ∧ (wf_cutsets p ⇒ wf_cutsets p') ∧ (every_inst two_reg_inst p ⇒ every_inst two_reg_inst p') ∧ + (every_inst distinct_tar_reg p ⇒ every_inst distinct_tar_reg p') ∧ (data_conventions data') Proof rpt gen_tac \\ gvs [] \\ pairarg_tac \\ gvs [] @@ -2163,7 +2227,120 @@ Proof \\ qspecl_then [‘p’, ‘data’] assume_tac word_cse_pre_alloc_conventions \\ gvs [] \\ qspecl_then [‘p’, ‘data’] assume_tac word_cse_wf_cutsets \\ gvs [] \\ qspecl_then [‘p’, ‘data’] assume_tac word_cse_every_inst_two_reg \\ gvs [] + \\ qspecl_then [‘p’, ‘data’] assume_tac word_cse_every_inst_distinct_tar_reg \\ gvs [] \\ qspecl_then [‘p’, ‘data’] assume_tac word_cse_data_conventions \\ gvs [] QED +Theorem word_cse_extract_labels: + ∀p d d1 p1. word_cse d p = (d1,p1) ⇒ extract_labels p1 = extract_labels p +Proof + Induct \\ fs [word_cse_def,extract_labels_def] \\ rw [] + \\ rpt (pairarg_tac \\ gvs []) + \\ fs [extract_labels_def] + \\ res_tac \\ gvs [AllCaseEqs()] + \\ fs [extract_labels_def,PULL_EXISTS] + \\ every_case_tac \\ fs [] + \\ gvs [add_to_data_aux_def,AllCaseEqs(),extract_labels_def] + \\ rename [‘word_cseInst d i = (d1,p)’] + \\ Cases_on ‘i’ + \\ gvs [word_cseInst_def,extract_labels_def,AllCaseEqs(),add_to_data_def, + add_to_data_aux_def] + \\ Cases_on ‘a’ + \\ gvs [word_cseInst_def,extract_labels_def,AllCaseEqs(),add_to_data_def, + add_to_data_aux_def] +QED + +Theorem wf_cutsets_word_common_subexp_elim: + wf_cutsets p ⇒ wf_cutsets (word_common_subexp_elim p) +Proof + fs [word_common_subexp_elim_def] \\ pairarg_tac \\ gvs [] + \\ qspecl_then [‘p’,‘empty_data’,‘acc’] mp_tac word_cse_conventions2 \\ fs [] +QED + +Theorem every_inst_distinct_tar_reg_word_common_subexp_elim: + every_inst distinct_tar_reg p ⇒ + every_inst distinct_tar_reg (word_common_subexp_elim p) +Proof + fs [word_common_subexp_elim_def] \\ pairarg_tac \\ gvs [] + \\ qspecl_then [‘p’,‘empty_data’,‘acc’] mp_tac word_cse_conventions2 + \\ fs [] +QED + +Theorem extract_labels_word_common_subexp_elim: + extract_labels (word_common_subexp_elim p) = extract_labels p +Proof + fs [word_common_subexp_elim_def] \\ pairarg_tac \\ rw [] + \\ drule word_cse_extract_labels \\ fs [] +QED + +Theorem flat_exp_conventions_word_common_subexp_elim: + flat_exp_conventions p ⇒ + flat_exp_conventions (word_common_subexp_elim p) +Proof + fs [word_common_subexp_elim_def] \\ pairarg_tac \\ gvs [] + \\ qspecl_then [‘p’,‘empty_data’,‘acc’] mp_tac word_cse_conventions2 \\ fs [] +QED + +Theorem pre_alloc_conventions_word_common_subexp_elim: + pre_alloc_conventions p ⇒ + pre_alloc_conventions (word_common_subexp_elim p) +Proof + fs [word_common_subexp_elim_def] \\ pairarg_tac \\ gvs [] + \\ qspecl_then [‘p’,‘empty_data’,‘acc’] mp_tac word_cse_conventions2 \\ fs [] +QED + +Theorem full_inst_ok_less_word_common_subexp_elim: + full_inst_ok_less ac p ⇒ + full_inst_ok_less ac (word_common_subexp_elim p) +Proof + fs [word_common_subexp_elim_def] \\ pairarg_tac \\ gvs [] + \\ qspecl_then [‘p’,‘empty_data’,‘ac’] mp_tac word_cse_conventions2 \\ fs [] +QED + +Overload word_get_code_labels[local] = ``wordProps$get_code_labels`` +Overload word_good_handlers[local] = ``wordProps$good_handlers`` + +Theorem word_good_handlers_word_common_subexp_elim: + word_good_handlers q p ⇒ + word_good_handlers q (word_common_subexp_elim p) +Proof + fs [word_common_subexp_elim_def] + \\ pairarg_tac \\ fs [] + \\ rename [‘_ k _ = (a,np)’] + \\ pop_assum mp_tac + \\ qid_spec_tac ‘k’ + \\ qid_spec_tac ‘a’ + \\ qid_spec_tac ‘np’ + \\ qid_spec_tac ‘q’ + \\ qid_spec_tac ‘p’ + \\ Induct \\ fs [word_cse_def] + \\ rw [] \\ rpt (pairarg_tac \\ gvs []) + \\ gvs [AllCaseEqs()] + \\ res_tac \\ fs [] + \\ gvs [add_to_data_aux_def,AllCaseEqs()] + \\ gvs [word_cseInst_def |> DefnBase.one_line_ify NONE,AllCaseEqs()] + \\ gvs [add_to_data_def,add_to_data_aux_def,AllCaseEqs()] +QED + +Theorem word_get_code_labels_word_common_subexp_elim: + word_get_code_labels (word_common_subexp_elim p) = word_get_code_labels p +Proof + fs [word_common_subexp_elim_def] + \\ pairarg_tac \\ fs [] + \\ rename [‘_ k _ = (a,np)’] + \\ pop_assum mp_tac + \\ qid_spec_tac ‘k’ + \\ qid_spec_tac ‘a’ + \\ qid_spec_tac ‘np’ + \\ qid_spec_tac ‘q’ + \\ qid_spec_tac ‘p’ + \\ Induct \\ fs [word_cse_def] + \\ rw [] \\ rpt (pairarg_tac \\ gvs []) + \\ gvs [AllCaseEqs()] + \\ res_tac \\ fs [] + \\ gvs [add_to_data_aux_def,AllCaseEqs()] + \\ gvs [word_cseInst_def |> DefnBase.one_line_ify NONE,AllCaseEqs()] + \\ gvs [add_to_data_def,add_to_data_aux_def,AllCaseEqs()] +QED + val _ = export_theory(); diff --git a/compiler/backend/proofs/word_to_wordProofScript.sml b/compiler/backend/proofs/word_to_wordProofScript.sml index 88a2fbf5c9..a5ad6052f4 100644 --- a/compiler/backend/proofs/word_to_wordProofScript.sml +++ b/compiler/backend/proofs/word_to_wordProofScript.sml @@ -3,7 +3,7 @@ *) open preamble word_to_wordTheory wordSemTheory word_simpProofTheory wordPropsTheory word_allocProofTheory word_instProofTheory - word_removeProofTheory; + word_removeProofTheory word_cseProofTheory; val _ = new_theory "word_to_wordProof"; @@ -31,7 +31,7 @@ QED (*Chains up compile_single theorems*) Theorem compile_single_lem: - ∀prog n st. + ∀prog n st. domain st.locals = set(even_list n) ∧ gc_fun_const_ok st.gc_fun ⇒ @@ -49,10 +49,11 @@ 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`>> + qpat_abbrev_tac`p2a = word_common_subexp_elim p2`>> TRY( - qpat_abbrev_tac`p3 = FST (remove_dead p2 LN)`>> + qpat_abbrev_tac`p3 = FST (remove_dead p2a LN)`>> qpat_abbrev_tac`p4 = three_to_two_reg p3`)>> - TRY(qpat_abbrev_tac`p4 = FST (remove_dead p2 LN)`)>> + TRY(qpat_abbrev_tac`p4 = FST (remove_dead p2a LN)`)>> Q.ISPECL_THEN [`name`,`c`,`a`,`p4`,`k`,`col`,`st`] mp_tac word_alloc_correct>> (impl_tac>- (full_simp_tac(srw_ss())[even_starting_locals_def]>> @@ -63,6 +64,7 @@ Proof unabbrev_all_tac>>fs[full_ssa_cc_trans_wf_cutsets]>> TRY(ho_match_mp_tac three_to_two_reg_wf_cutsets)>> match_mp_tac (el 5 rmd_thms)>> + irule wf_cutsets_word_common_subexp_elim >> fs[full_ssa_cc_trans_wf_cutsets]))>> rw[]>> Q.ISPECL_THEN [`p1`,`st with permute:= perm'`,`n`] assume_tac full_ssa_cc_trans_correct>> @@ -84,16 +86,25 @@ Proof qpat_x_assum`(λ(x,y). _) _`mp_tac >> pairarg_tac>>fs[]>> strip_tac>> - Cases_on`remove_dead p2 LN`>>fs[]>> - Q.ISPECL_THEN [`p2`,`LN:num_set`,`q`,`r`,`st with permute := perm'`,`st.locals`,`res'`,`rcst`] mp_tac evaluate_remove_dead>> + Cases_on`remove_dead p2a LN`>>fs[]>> + drule word_common_subexp_elim_correct >> + (impl_tac >- (fs [] >> + unabbrev_all_tac >> + irule word_allocProofTheory.full_ssa_cc_trans_flat_exp_conventions >> + fs [word_instProofTheory.inst_select_flat_exp_conventions])) >> + gvs [] >> strip_tac >> + Q.ISPECL_THEN [`p2a`,`LN:num_set`,`q`,`r`,`st with permute := perm'`,`st.locals`,`res`,`rcst`] mp_tac evaluate_remove_dead>> impl_tac>>fs[strong_locals_rel_def]>> strip_tac >- - (Q.ISPECL_THEN[`p3`,`st with permute:=perm'`,`res'`,`rcst with locals:=t'`] mp_tac three_to_two_reg_correct>> + (Q.ISPECL_THEN[`p3`,`st with permute:=perm'`,`res`,`rcst with locals:=t'`] mp_tac three_to_two_reg_correct>> impl_tac>- (rev_full_simp_tac(srw_ss())[]>> - unabbrev_all_tac>>rpt var_eq_tac >> fs[]>> - metis_tac[full_ssa_cc_trans_distinct_tar_reg,el 4 rmd_thms,FST,PAIR])>> + qspecl_then [‘p2a’,‘LN’] mp_tac (el 4 rmd_thms) >> + fs [] >> disch_then irule >> + unabbrev_all_tac>>rpt var_eq_tac >> fs[] >> + irule every_inst_distinct_tar_reg_word_common_subexp_elim >> + fs [full_ssa_cc_trans_distinct_tar_reg]) >> srw_tac[][]>> full_simp_tac(srw_ss())[word_state_eq_rel_def]>> Cases_on`res`>>full_simp_tac(srw_ss())[]) @@ -691,7 +702,9 @@ Proof fs[compile_single_def]>> fs[GSYM (el 5 rmt_thms),GSYM word_alloc_lab_pres]>> IF_CASES_TAC>> - fs[GSYM three_to_two_reg_lab_pres,GSYM full_ssa_cc_trans_lab_pres,GSYM inst_select_lab_pres,GSYM (el 6 rmd_thms)])>> + fs[GSYM three_to_two_reg_lab_pres,GSYM full_ssa_cc_trans_lab_pres, + GSYM inst_select_lab_pres,GSYM (el 6 rmd_thms), + extract_labels_word_common_subexp_elim])>> fs[EVERY_MAP,EVERY_MEM,MEM_ZIP,FORALL_PROD]>>rw[]>> fs[full_compile_single_def,compile_single_def]>> CONJ_TAC>- @@ -700,6 +713,7 @@ Proof IF_CASES_TAC>> TRY(match_mp_tac three_to_two_reg_flat_exp_conventions)>> match_mp_tac (el 1 rmd_thms)>> + irule flat_exp_conventions_word_common_subexp_elim >> match_mp_tac full_ssa_cc_trans_flat_exp_conventions>> fs[inst_select_flat_exp_conventions])>> CONJ_TAC>- @@ -708,12 +722,14 @@ Proof IF_CASES_TAC>> TRY(match_mp_tac three_to_two_reg_pre_alloc_conventions)>> match_mp_tac (el 3 rmd_thms)>> + irule pre_alloc_conventions_word_common_subexp_elim >> fs[full_ssa_cc_trans_pre_alloc_conventions])>> CONJ_TAC>- (rw[]>>match_mp_tac (el 2 rmt_thms)>> match_mp_tac word_alloc_full_inst_ok_less>> TRY(match_mp_tac three_to_two_reg_full_inst_ok_less)>> match_mp_tac (el 2 rmd_thms)>> + irule full_inst_ok_less_word_common_subexp_elim >> match_mp_tac full_ssa_cc_trans_full_inst_ok_less>> match_mp_tac inst_select_full_inst_ok_less>> fs[]>> diff --git a/compiler/backend/semantics/dataSemScript.sml b/compiler/backend/semantics/dataSemScript.sml index 7397373367..8afdf5354e 100644 --- a/compiler/backend/semantics/dataSemScript.sml +++ b/compiler/backend/semantics/dataSemScript.sml @@ -71,7 +71,7 @@ End Definition check_res_def: check_res r (n, refs, seen) = - if size refs <= size r then (n, refs, seen) else (n, r, seen) + if sptree$size refs <= sptree$size r then (n, refs, seen) else (n, r, seen) End Theorem check_res_IMP: @@ -127,14 +127,14 @@ Definition size_of_def: (if small_num lims.arch_64_bit i then 0 else bignum_size lims.arch_64_bit i, refs, seen)) /\ (size_of lims [CodePtr _] refs seen = (0, refs, seen)) /\ (size_of lims [RefPtr r] refs seen = - case lookup r refs of + case sptree$lookup r refs of | NONE => (0, refs, seen) | SOME (ByteArray _ bs) => (LENGTH bs DIV (arch_size lims DIV 8) + 2, delete r refs, seen) | SOME (ValueArray vs) => let (n,refs,seen) = size_of lims vs (delete r refs) seen in (n + LENGTH vs + 1, refs, seen)) /\ (size_of lims [Block ts tag []]) refs seen = (0, refs, seen) /\ (size_of lims [Block ts tag vs] refs seen = - if IS_SOME (lookup ts seen) then (0, refs, seen) else + if IS_SOME (sptree$lookup ts seen) then (0, refs, seen) else let (n,refs,seen) = size_of lims vs refs (insert ts () seen) in (n + LENGTH vs + 1, refs, seen)) Termination @@ -283,7 +283,7 @@ Definition eq_code_stack_max_def: eq_code_stack_max n tsz = OPTION_MAP ($* n) (OPTION_MAP2 MAX - (lookup Equal_location tsz) + (sptree$lookup Equal_location tsz) (OPTION_MAP2 MAX (lookup Equal1_location tsz) (lookup Compare1_location tsz))) @@ -292,7 +292,7 @@ End Definition stack_consumed_def: (stack_consumed sfs lims (CopyByte _) vs = OPTION_MAP2 MAX - (lookup ByteCopy_location sfs) + (sptree$lookup ByteCopy_location sfs) (OPTION_MAP2 MAX (lookup ByteCopyAdd_location sfs) (lookup ByteCopySub_location sfs))) /\ @@ -438,7 +438,7 @@ val do_eq_def = tDefine"do_eq"` (do_eq _ (Word64 _) _ = Eq_type_error) ∧ (do_eq _ _ (Word64 _) = Eq_type_error) ∧ (do_eq refs (RefPtr n1) (RefPtr n2) = - case (lookup n1 refs, lookup n2 refs) of + case (sptree$lookup n1 refs, sptree$lookup n2 refs) of (SOME (ByteArray T bs1), SOME (ByteArray T bs2)) => Eq_val (bs1 = bs2) | (SOME (ByteArray T bs1), _) => Eq_type_error @@ -712,7 +712,7 @@ Definition do_app_aux_def: (case xs of | [] => (case s.global of | SOME ptr => - (case lookup ptr s.refs of + (case sptree$lookup ptr s.refs of | SOME (ValueArray xs) => (if n < LENGTH xs then Rval (EL n xs, s) @@ -1001,7 +1001,7 @@ val do_app_def = Define ` | SOME s1 => do_app_aux op vs (do_stack op vs (do_lim_safe s1 op vs))` val get_var_def = Define ` - get_var v = lookup v`; + get_var v = sptree$lookup v`; val get_vars_def = Define ` (get_vars [] s = SOME []) /\ @@ -1126,7 +1126,7 @@ val push_env_clock = Q.prove( val find_code_def = Define ` (find_code (SOME p) args code ssize = - case lookup p code of + case sptree$lookup p code of | NONE => NONE | SOME (arity,exp) => if LENGTH args = arity diff --git a/compiler/backend/word_cseScript.sml b/compiler/backend/word_cseScript.sml index f09d3fad26..93a923012a 100644 --- a/compiler/backend/word_cseScript.sml +++ b/compiler/backend/word_cseScript.sml @@ -53,27 +53,30 @@ End Definition regsUpdate1Aux_def: regsUpdate1Aux r l (hd::tl) = - if listLookup r hd + (if listLookup r hd then (l ++ hd)::tl - else hd::(regsUpdate1Aux r l tl) + else hd::(regsUpdate1Aux r l tl)) ∧ + regsUpdate1Aux r l _ = [] End Definition regsUpdate1_def: regsUpdate1 r1 r2 (hd::tl) = - if listLookup r1 hd + (if listLookup r1 hd then if listLookup r2 hd then (hd::tl) else regsUpdate1Aux r2 hd tl else if listLookup r2 hd then regsUpdate1Aux r1 hd tl - else hd::(regsUpdate1 r1 r2 tl) + else hd::(regsUpdate1 r1 r2 tl)) ∧ + regsUpdate1 r1 r2 _ = [] End Definition regsUpdate2_def: regsUpdate2 r1 r2 ((hd::tl)::tl') = - if listLookup r1 (hd::tl) + (if listLookup r1 (hd::tl) then (hd::r2::tl)::tl' - else (hd::tl)::(regsUpdate2 r1 r2 tl') + else (hd::tl)::(regsUpdate2 r1 r2 tl')) ∧ + regsUpdate2 r1 r2 _ = [] End Definition regsUpdate_def: @@ -95,11 +98,22 @@ Definition canonicalRegs_def: lookup_any r data.map r End +Definition canonicalRegs'_def: + canonicalRegs' avoid (data:knowledge) (r:num) = + let n = canonicalRegs (data:knowledge) (r:num) in + if n = avoid then r else n +End + Definition canonicalImmReg_def: canonicalImmReg data (Reg r) = Reg (canonicalRegs data r) ∧ canonicalImmReg data (Imm w) = Imm w End +Definition canonicalImmReg'_def: + canonicalImmReg' avoid data (Reg r) = Reg (canonicalRegs' avoid data r) ∧ + canonicalImmReg' avoid data (Imm w) = Imm w +End + Definition canonicalMultRegs_def: canonicalMultRegs (data:knowledge) (regs:num list) = MAP (canonicalRegs data) regs End @@ -130,9 +144,9 @@ End Definition canonicalArith_def: canonicalArith data (Binop op r1 r2 r3) = - Binop op r1 (canonicalRegs data r2) (canonicalImmReg data r3) ∧ + Binop op r1 (canonicalRegs' r1 data r2) (canonicalImmReg' r1 data r3) ∧ canonicalArith data (Shift s r1 r2 n) = - Shift s r1 (canonicalRegs data r2) n ∧ + Shift s r1 (canonicalRegs' r1 data r2) n ∧ canonicalArith data (Div r1 r2 r3) = Div r1 (canonicalRegs data r2) (canonicalRegs data r3) ∧ canonicalArith data (LongMul r1 r2 r3 r4) = @@ -140,11 +154,11 @@ Definition canonicalArith_def: canonicalArith data (LongDiv r1 r2 r3 r4 r5) = LongDiv r1 r2 (canonicalRegs data r3) (canonicalRegs data r4) (canonicalRegs data r5) ∧ canonicalArith data (AddCarry r1 r2 r3 r4) = - AddCarry r1 (canonicalRegs data r2) (canonicalRegs data r3) r4 ∧ + AddCarry r1 (canonicalRegs' r1 data r2) (canonicalRegs' r1 data r3) r4 ∧ canonicalArith data (AddOverflow r1 r2 r3 r4) = - AddOverflow r1 (canonicalRegs data r2) (canonicalRegs data r3) r4 ∧ + AddOverflow r1 (canonicalRegs' r1 data r2) (canonicalRegs' r1 data r3) r4 ∧ canonicalArith data (SubOverflow r1 r2 r3 r4) = - SubOverflow r1 (canonicalRegs data r2) (canonicalRegs data r3) r4 + SubOverflow r1 (canonicalRegs' r1 data r2) (canonicalRegs' r1 data r3) r4 End Definition canonicalFp_def: @@ -208,7 +222,6 @@ Definition regImmToNumList_def: regImmToNumList (Imm w) = [34; wordToNum w] End - Definition arithToNumList_def: arithToNumList (Binop op r1 r2 ri) = [25; arithOpToNum op; r2+100] ++ regImmToNumList ri ∧ arithToNumList (LongMul r1 r2 r3 r4) = [26; r3+100; r4+100] ∧ @@ -247,10 +260,10 @@ Definition fpToNumList_def: End Definition instToNumList_def: - instToNumList (Skip) = [1] ∧ instToNumList (Const r w) = [2;wordToNum w] ∧ instToNumList (Arith a) = 3::(arithToNumList a) ∧ - instToNumList (FP fp) = 4::(fpToNumList fp) + instToNumList (FP fp) = 4::(fpToNumList fp) ∧ + instToNumList _ = [1] End (* @@ -356,8 +369,8 @@ Definition word_cseInst_def: (empty_data with all_names:=data.all_names, Inst (Mem op r (Addr (canonicalRegs data r') w))) else (data, Inst (Mem op r (Addr (canonicalRegs data r') w))) ) ∧ - (word_cseInst data ((FP f):'a inst) = - (empty_data with all_names:=data.all_names, Inst (FP f))) + (word_cseInst data (x:'a inst) = + (empty_data with all_names:=data.all_names, Inst x)) End (* @@ -430,7 +443,7 @@ Definition word_cse_def: (data, Tick)) ∧ (word_cse data ((OpCurrHeap b r1 r2):'a prog) = if is_seen r1 data ∨ ¬is_seen r2 data then (empty_data with all_names:=data.all_names, OpCurrHeap b r1 r2) else - let r2' = canonicalRegs data r2 in + let r2' = canonicalRegs' r1 data r2 in let pL = OpCurrHeapToNumList b r2' in add_to_data_aux data r1 pL (OpCurrHeap b r1 r2')) ∧ (word_cse data (LocValue r l) = diff --git a/compiler/bootstrap/translation/to_word32ProgScript.sml b/compiler/bootstrap/translation/to_word32ProgScript.sml index b52b8d0b8a..ecfc8444c0 100644 --- a/compiler/bootstrap/translation/to_word32ProgScript.sml +++ b/compiler/bootstrap/translation/to_word32ProgScript.sml @@ -305,6 +305,26 @@ open word_simpTheory word_allocTheory word_instTheory val _ = matches:= [``foo:'a wordLang$prog``,``foo:'a wordLang$exp``,``foo:'a word``,``foo: 'a reg_imm``,``foo:'a arith``,``foo: 'a addr``] +val res = word_cseTheory.map_insert_def |> DefnBase.one_line_ify NONE |> translate; +val res = translate (word_cseTheory.word_cseInst_def |> spec32); +val res = translate_no_ind (word_cseTheory.word_cse_def |> spec32); + +Theorem word_cse_ind[local]: + ^(hyp res |> first is_forall) +Proof + rpt strip_tac + \\ rename [‘P x y’] + \\ qid_spec_tac ‘x’ + \\ qid_spec_tac ‘y’ + \\ ho_match_mp_tac word_simpTheory.simp_if_ind + \\ rpt strip_tac + \\ last_x_assum irule + \\ fs [] +QED +val _ = word_cse_ind |> update_precondition; + +val res = translate (word_cseTheory.word_common_subexp_elim_def |> spec32); + val _ = translate (const_fp_inst_cs_def |> spec32 |> econv) val rws = Q.prove(` diff --git a/compiler/bootstrap/translation/to_word64ProgScript.sml b/compiler/bootstrap/translation/to_word64ProgScript.sml index 21660804a6..e60cbe01a9 100644 --- a/compiler/bootstrap/translation/to_word64ProgScript.sml +++ b/compiler/bootstrap/translation/to_word64ProgScript.sml @@ -295,6 +295,26 @@ open word_simpTheory word_allocTheory word_instTheory val _ = matches:= [``foo:'a wordLang$prog``,``foo:'a wordLang$exp``,``foo:'a word``,``foo: 'a reg_imm``,``foo:'a arith``,``foo: 'a addr``] +val res = word_cseTheory.map_insert_def |> DefnBase.one_line_ify NONE |> translate; +val res = translate (word_cseTheory.word_cseInst_def |> spec64); +val res = translate_no_ind (word_cseTheory.word_cse_def |> spec64); + +Theorem word_cse_ind[local]: + ^(hyp res |> first is_forall) +Proof + rpt strip_tac + \\ rename [‘P x y’] + \\ qid_spec_tac ‘x’ + \\ qid_spec_tac ‘y’ + \\ ho_match_mp_tac word_simpTheory.simp_if_ind + \\ rpt strip_tac + \\ last_x_assum irule + \\ fs [] +QED +val _ = word_cse_ind |> update_precondition; + +val res = translate (word_cseTheory.word_common_subexp_elim_def |> spec64); + val _ = translate (const_fp_inst_cs_def |> spec64 |> econv) val rws = Q.prove(` From 9fea01376fcb1bbf113f80a3028b6f29c6292725 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Tue, 13 Sep 2022 20:51:14 +0200 Subject: [PATCH 33/36] Update compilationLib for word_cse --- compiler/backend/backendComputeLib.sml | 3 ++- compiler/compilationLib.sml | 7 +++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/compiler/backend/backendComputeLib.sml b/compiler/backend/backendComputeLib.sml index 1d8629b69a..0b5fec3ed5 100644 --- a/compiler/backend/backendComputeLib.sml +++ b/compiler/backend/backendComputeLib.sml @@ -122,7 +122,8 @@ val add_backend_compset = computeLib.extend_compset ,computeLib.Defs (theory_computes "mlmap") ,computeLib.Tys [``:('k,'v) mlmap$map``] ,computeLib.Defs (theory_computes "balanced_map") - ,computeLib.Tys [``:('k,'v) balanced_map$balanced_map``] + ,computeLib.Tys [``:('k,'v) balanced_map$balanced_map``, + ``:ternaryComparisons$ordering``] ,computeLib.Tys [``:closLang$exp`` diff --git a/compiler/compilationLib.sml b/compiler/compilationLib.sml index 1f48c9e214..fe9d12d7fc 100644 --- a/compiler/compilationLib.sml +++ b/compiler/compilationLib.sml @@ -264,10 +264,9 @@ fun compile_to_lab_new conf_tm word_0_tm lab_prog_name = REWR_CONV LET_THM THENC PAIRED_BETA_CONV THENC REWR_CONV LET_THM THENC PATH_CONV "rlrraraalralrarllr" eval THENC - PATH_CONV"rlrraraalralralralralrar" + PATH_CONV"rlrraraalralralralralralrar" (RATOR_CONV(RATOR_CONV(RAND_CONV eval)) THENC (FIRST_CONV (map REWR_CONV (CONJUNCTS bool_case_thm))))) - val tm0 = to_livesets_0_thm0 |> rconc |> rand |> rand val thm0 = el 2 word_0_abbrevs; @@ -291,7 +290,7 @@ fun compile_to_lab_new conf_tm word_0_tm lab_prog_name = val conv = RATOR_CONV(REWR_CONV word_to_word_fn_eq) THENC eval in conv tm - end + end; val ths = time_with_size thms_size "inst,ssa,two-reg (par)" (parl eval_fn) word_prog; val thm1 = @@ -744,7 +743,7 @@ fun compile_to_lab data_prog_def to_data_thm lab_prog_name = REWR_CONV LET_THM THENC PAIRED_BETA_CONV THENC REWR_CONV LET_THM THENC PATH_CONV "rlrraraalralrarllr" eval THENC - PATH_CONV"rlrraraalralralralralrar" + PATH_CONV"rlrraraalralralralralralrar" (RATOR_CONV(RATOR_CONV(RAND_CONV eval)) THENC (FIRST_CONV (map REWR_CONV (CONJUNCTS bool_case_thm))))) val tm0 = to_livesets_thm0 |> rconc |> rand |> rand From 6d7c8cba4c6b3a5f1a50ba2994c49034f30eaf9c Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Tue, 13 Sep 2022 22:55:22 +0200 Subject: [PATCH 34/36] Get word_to_wordProof to build again --- .../proofs/word_to_wordProofScript.sml | 44 ++++++++++++++++++- 1 file changed, 43 insertions(+), 1 deletion(-) diff --git a/compiler/backend/proofs/word_to_wordProofScript.sml b/compiler/backend/proofs/word_to_wordProofScript.sml index a79adcfa78..e2aefc10a3 100644 --- a/compiler/backend/proofs/word_to_wordProofScript.sml +++ b/compiler/backend/proofs/word_to_wordProofScript.sml @@ -3,7 +3,7 @@ *) open preamble word_to_wordTheory wordSemTheory word_simpProofTheory wordPropsTheory word_allocProofTheory word_instProofTheory - word_removeProofTheory word_cseProofTheory (* word_elimTheory word_elimProofTheory *); + word_removeProofTheory word_cseProofTheory word_elimTheory word_elimProofTheory; val _ = new_theory "word_to_wordProof"; @@ -991,6 +991,26 @@ Proof rveq>>irule apply_colour_no_install>>rw[] QED +Theorem word_common_subexp_elim_no_install: + no_install prog ⇒ + no_install (word_common_subexp_elim prog) +Proof + fs [word_cseTheory.word_common_subexp_elim_def] + \\ pairarg_tac \\ fs [] + \\ rename [‘_ e p = (a,np)’] + \\ pop_assum mp_tac + \\ MAP_EVERY qid_spec_tac [‘np’,‘e’,‘a’,‘p’] + \\ ho_match_mp_tac word_simpTheory.simp_if_ind + \\ rpt strip_tac \\ fs [] + \\ fs [word_cseTheory.word_cse_def] + \\ rpt (pairarg_tac \\ fs []) + \\ gvs [no_install_def,AllCaseEqs(),word_cseTheory.add_to_data_aux_def] + \\ res_tac \\ fs [] + \\ gvs [word_cseTheory.word_cseInst_def |> DefnBase.one_line_ify NONE,AllCaseEqs()] + \\ gvs [no_install_def,AllCaseEqs(),word_cseTheory.add_to_data_aux_def, + word_cseTheory.add_to_data_def] +QED + Theorem compile_single_no_install: no_install prog ∧ (q, r) = (SND (compile_single two_reg_arith reg_count alg c @@ -1001,6 +1021,7 @@ Proof irule word_alloc_no_install>> TRY (irule three_to_two_reg_no_install)>> irule remove_dead_no_install>> + irule word_common_subexp_elim_no_install>> irule full_ssa_cc_trans_no_install>> irule inst_select_no_install>> irule compile_exp_no_install>>rw[] @@ -1273,6 +1294,26 @@ Proof irule apply_colour_no_alloc>>rw[] QED +Theorem word_common_subexp_elim_no_alloc: + no_alloc prog ⇒ + no_alloc (word_common_subexp_elim prog) +Proof + fs [word_cseTheory.word_common_subexp_elim_def] + \\ pairarg_tac \\ fs [] + \\ rename [‘_ e p = (a,np)’] + \\ pop_assum mp_tac + \\ MAP_EVERY qid_spec_tac [‘np’,‘e’,‘a’,‘p’] + \\ ho_match_mp_tac word_simpTheory.simp_if_ind + \\ rpt strip_tac \\ fs [] + \\ fs [word_cseTheory.word_cse_def] + \\ rpt (pairarg_tac \\ fs []) + \\ gvs [no_alloc_def,AllCaseEqs(),word_cseTheory.add_to_data_aux_def] + \\ res_tac \\ fs [] + \\ gvs [word_cseTheory.word_cseInst_def |> DefnBase.one_line_ify NONE,AllCaseEqs()] + \\ gvs [no_alloc_def,AllCaseEqs(),word_cseTheory.add_to_data_aux_def, + word_cseTheory.add_to_data_def] +QED + Theorem compile_single_no_alloc: no_alloc prog ∧ (q, r) = (SND (compile_single two_reg_arith reg_count alg c @@ -1283,6 +1324,7 @@ Proof irule word_alloc_no_alloc>> TRY (irule three_to_two_reg_no_alloc)>> irule remove_dead_no_alloc>> + irule word_common_subexp_elim_no_alloc>> irule full_ssa_cc_trans_no_alloc>> irule inst_select_no_alloc>> irule compile_exp_no_alloc>>rw[] From f2df689d09c81d4d1e2bb92ea7ece382501321ba Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Tue, 13 Sep 2022 23:06:06 +0200 Subject: [PATCH 35/36] Tidy up word_cse test and add to build-sequence --- developers/build-sequence | 1 + .../to_word/word_cse_testScript.sml | 46 ++----------------- 2 files changed, 4 insertions(+), 43 deletions(-) diff --git a/developers/build-sequence b/developers/build-sequence index d82344d636..e5f425deb0 100644 --- a/developers/build-sequence +++ b/developers/build-sequence @@ -98,6 +98,7 @@ examples/compilation/x64 examples/compilation/x64/proofs examples/compilation/ag32 examples/compilation/ag32/proofs +examples/compilation/to_word # examples/cost examples/lpr_checker examples/lpr_checker/array diff --git a/examples/compilation/to_word/word_cse_testScript.sml b/examples/compilation/to_word/word_cse_testScript.sml index 4899fe17b3..ac1e2a924d 100644 --- a/examples/compilation/to_word/word_cse_testScript.sml +++ b/examples/compilation/to_word/word_cse_testScript.sml @@ -8,49 +8,9 @@ val _ = new_theory "word_cse_test"; val tm = foldr_example_ssa |> concl |> dest_eq |> snd -Definition word_cse_compact_def: - word_cse_compact p = - let (_,p') = word_cse empty_data p in - p' -End +val tm2 = “let p = word_common_subexp_elim ^tm in + remove_dead p LN” -val tm' = “let p = word_cse_compact ^tm in - remove_dead p LN” - -val prog = “Seq (Inst (Const 1 0w)) (Inst (Const 3 5w))” - -val prog = “Seq (Inst (Const 1 0w)) - (Seq (Inst (Arith (Binop Add 3 1 (Reg 1)))) - (Inst (Arith (Binop Add 4 1 (Reg 1)))))” - -val prog2 = “(Seq (Move 0 [(37,2);(39,4)]) (If Equal 41 (Imm 2w) (Return 37 2) (Return 37 2))):64 wordLang$prog”; - -val fact_begin = “Move 1 [(37,0); (41,2); (45,4); (49,6)] ▸ - Inst (Const 189 0w) ▸ Inst (Const 193 0w) ▸ - OpCurrHeap Add 69 37 ▸ - OpCurrHeap Add 71 37 ▸ - Inst (Arith (Shift Lsr 65 41 9)) ▸ - Inst (Arith (Shift Lsr 67 41 9)) - ” (*works *) - -val fact_begin2 = “Move 1 [(37,0); (41,2); (45,4); (49,6)] ▸ - Inst (Const 53 18w) ▸ Move 0 [(2,45)] ▸ - Move 1 [(181,37); (177,49)] ▸ Inst (Const 185 0w) ▸ - Inst (Const 189 0w) ▸ Inst (Const 193 0w) ▸ Move 1 [(197,53)] ▸ - Inst (Const 201 0w) ▸ Move 1 [(205,41)] ▸ Move 1 [(209,45)] ▸ - Inst (Const 213 0w) ▸ Inst (Const 217 0w) - ” - -EVAL “^tm'”; - -EVAL “word_cse_compact ^prog”; - - EVAL “w2n 5w = w2n 0w”; - -EVAL “word_cse_compact ^fact_begin”; -EVAL “w2n_def 0w” -val res = EVAL tm'; - -val res2 = EVAL “word_cse_compact ^tm”; +Theorem test = EVAL tm2; val _ = export_theory(); From e1a091a98456edccc763187c818c3e290eb52abb Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Wed, 14 Sep 2022 22:27:21 +0200 Subject: [PATCH 36/36] Fix some parsing issues --- compiler/backend/semantics/data_monadScript.sml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/compiler/backend/semantics/data_monadScript.sml b/compiler/backend/semantics/data_monadScript.sml index 645a3cc314..e304089917 100644 --- a/compiler/backend/semantics/data_monadScript.sml +++ b/compiler/backend/semantics/data_monadScript.sml @@ -41,7 +41,7 @@ End Definition if_var_def: if_var n ^f ^g s = - case lookup n s.locals of + case sptree$lookup n s.locals of | NONE => fail s | SOME v => if isBool T v then f s else if isBool F v then g s else fail s @@ -49,7 +49,7 @@ End Definition return_def[simp]: return n s = - case lookup n s.locals of + case sptree$lookup n s.locals of | NONE => fail s | SOME v => (SOME (Rval v), flush_state F s) End @@ -124,7 +124,7 @@ val _ = set_fixity ":≡" (Infixl 480); Definition move_def: move dest src s = - case lookup src s.locals of + case sptree$lookup src s.locals of | NONE => fail s | SOME v => (NONE, set_var dest v s) End