diff --git a/.gitignore b/.gitignore index b2c9450b46..afc079b506 100644 --- a/.gitignore +++ b/.gitignore @@ -74,3 +74,4 @@ compiler/benchmarks/sml/polyc_* compiler/benchmarks/sml/sml_* compiler/benchmarks/*.dat compiler/benchmarks/*.eps +.DS_Store diff --git a/compiler/backend/semantics/README.md b/compiler/backend/semantics/README.md index 7658a45fcf..93dc99f038 100644 --- a/compiler/backend/semantics/README.md +++ b/compiler/backend/semantics/README.md @@ -46,6 +46,18 @@ Properties about labLang and its semantics [labSemScript.sml](labSemScript.sml): The formal semantics of labLang +<<<<<<< HEAD +[panSemScript.sml](panSemScript.sml): +The formal semantics of panLang + +[patPropsScript.sml](patPropsScript.sml): +Properties about patLang and its semantics + +[patSemScript.sml](patSemScript.sml): +The formal semantics of patLang + +======= +>>>>>>> master [stackPropsScript.sml](stackPropsScript.sml): Properties about stackLang and its semantics diff --git a/developers/build-sequence b/developers/build-sequence index af5d87afa9..d8cfe1c4a1 100644 --- a/developers/build-sequence +++ b/developers/build-sequence @@ -74,6 +74,12 @@ candle/standard/ml_kernel candle/overloading/syntax candle/overloading/semantics +# pancake +pancake +pancake/ffi +pancake/semantics +pancake/proofs + # examples and tests characteristic/examples tutorial/solutions diff --git a/pancake/Holmakefile b/pancake/Holmakefile new file mode 100644 index 0000000000..df679c3d72 --- /dev/null +++ b/pancake/Holmakefile @@ -0,0 +1,14 @@ +INCLUDES = $(HOLDIR)/examples/machine-code/multiword\ + $(CAKEMLDIR)/misc\ + $(CAKEMLDIR)/basis/pure\ + $(CAKEMLDIR)/compiler/backend/\ + $(CAKEMLDIR)/compiler/encoders/asm + + +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 $(README_SOURCES) + $(protect $(CAKEMLDIR)/developers/readme_gen) $(README_SOURCES) diff --git a/pancake/README.md b/pancake/README.md new file mode 100644 index 0000000000..e6b6694e27 --- /dev/null +++ b/pancake/README.md @@ -0,0 +1,65 @@ +Abstract syntax and compiler for Pancake and its intermediate languages. + +[crepLangScript.sml](crepLangScript.sml): +Abstract syntax of Crepe language +Crepe: instrctuons are similar to that of +Pancake, but we flatten locals from +struct-layout to word-layout + +[crep_to_loopScript.sml](crep_to_loopScript.sml): +Compilation from crepLang to panLang. + +[ffi](ffi): +FFI for Pancake + +[loopLangScript.sml](loopLangScript.sml): +loopLang intermediate language + +[loop_callScript.sml](loop_callScript.sml): +Call optimisation for loopLang + +[loop_liveScript.sml](loop_liveScript.sml): +Correctness proof for loop to loop_remove + +[loop_removeScript.sml](loop_removeScript.sml): +Correctness proof for loop_remove + +[loop_to_wordScript.sml](loop_to_wordScript.sml): +Compilation from looLang to wordLang. + +[panLangScript.sml](panLangScript.sml): +Abstract syntax for Pancake language. +Pancake is an imperative language with +instructions for conditionals, While loop, +memory load and store, functions, +and foreign function calls. + +[pan_commonScript.sml](pan_commonScript.sml): +Common definitions for Pancake compiler + +[pan_simpScript.sml](pan_simpScript.sml): +Compilation from panLang to crepLang. + +[pan_to_crepScript.sml](pan_to_crepScript.sml): +Compilation from panLang to crepLang. + +[pan_to_wordScript.sml](pan_to_wordScript.sml): +Correctness proof for -- + +[proofs](proofs): +Proofs files for compiling Pancake. + +[semantics](semantics): +Semantics for Pancake and its intermediate languages. + +[taParserScript.sml](taParserScript.sml): +Parser for compactDSL programs + +[ta_progs](ta_progs): +Same TA programs + +[timeLangScript.sml](timeLangScript.sml): +Abstract syntax for timeLang + +[time_to_panScript.sml](time_to_panScript.sml): +Compilation from timeLang to panLang diff --git a/pancake/crepLangScript.sml b/pancake/crepLangScript.sml new file mode 100644 index 0000000000..e7d7feba15 --- /dev/null +++ b/pancake/crepLangScript.sml @@ -0,0 +1,210 @@ +(* + Abstract syntax of Crepe language + Crepe: instrctuons are similar to that of + Pancake, but we flatten locals from + struct-layout to word-layout +*) + +open preamble + mlstringTheory + asmTheory (* for binop and cmp *) + backend_commonTheory (* for overloading the shift operation *); + +val _ = new_theory "crepLang"; + +Type shift = ``:ast$shift`` + +Type varname = ``:num`` + +Type funname = ``:mlstring`` + +Datatype: + exp = Const ('a word) + | Var varname + | Label funname + | Load exp + | LoadByte exp + | LoadGlob (5 word) + | Op binop (exp list) + | Cmp cmp exp exp + | Shift shift exp num +End + +Datatype: + prog = Skip + | Dec varname ('a exp) prog + | Assign varname ('a exp) (* dest, source *) + | Store ('a exp) ('a exp) (* dest, source *) + | StoreByte ('a exp) ('a exp) (* dest, source *) + | StoreGlob (5 word) ('a exp) (* dest, source *) + | Seq prog prog + | If ('a exp) prog prog + | While ('a exp) prog + | Break + | Continue + | Call ret ('a exp) (('a exp) list) + | ExtCall funname varname varname varname varname + | Raise ('a word) + | Return ('a exp) + | Tick; + + ret = Tail | Ret (varname option) prog (handler option); + + handler = Handle ('a word) prog +End + +(* we can make return varaiable an option, but then might not be able to + compile to loopLang *) + +Theorem MEM_IMP_exp_size: + !xs a. MEM a xs ==> (exp_size l a < exp1_size l xs) +Proof + Induct \\ FULL_SIMP_TAC (srw_ss()) [] + \\ REPEAT STRIP_TAC \\ SRW_TAC [] [definition"exp_size_def"] + \\ RES_TAC \\ DECIDE_TAC +QED + +Definition load_shape_def: + (load_shape a 0 e = []) ∧ + (load_shape a (SUC i) e = + if a = 0w then (Load e) :: load_shape (a + byte$bytes_in_word) i e + else (Load (Op Add [e; Const a])) :: load_shape (a + byte$bytes_in_word) i e) +End + +Definition nested_seq_def: + (nested_seq [] = Skip) /\ + (nested_seq (e::es) = Seq e (nested_seq es)) +End + + +Definition stores_def: + (stores ad [] a = []) /\ + (stores ad (e::es) a = + if a = 0w then Store ad e :: stores ad es (a + byte$bytes_in_word) + else Store (Op Add [ad; Const a]) e :: stores ad es (a + byte$bytes_in_word)) +End + +Definition nested_decs_def: + (nested_decs [] [] p = p) /\ + (nested_decs (n::ns) (e::es) p = Dec n e (nested_decs ns es p)) /\ + (nested_decs [] _ p = Skip) /\ + (nested_decs _ [] p = Skip) +End + +Definition store_globals_def: + (store_globals ad [] = []) ∧ + (store_globals ad (e::es) = + StoreGlob ad e :: store_globals (ad+1w) es) +End + + +Definition load_globals_def: + (load_globals _ 0 = []) ∧ + (load_globals ad (SUC n) = (LoadGlob ad) :: load_globals (ad+1w) n) +End + + +Definition assign_ret_def: + assign_ret ns = + nested_seq (MAP2 Assign ns (load_globals 0w (LENGTH ns))) +End + + +Definition var_cexp_def: + (var_cexp (Const w) = ([]:num list)) ∧ + (var_cexp (Var v) = [v]) ∧ + (var_cexp (Label f) = []) ∧ + (var_cexp (Load e) = var_cexp e) ∧ + (var_cexp (LoadByte e) = var_cexp e) ∧ + (var_cexp (LoadGlob a) = []) ∧ + (var_cexp (Op bop es) = FLAT (MAP var_cexp es)) ∧ + (var_cexp (Cmp c e1 e2) = var_cexp e1 ++ var_cexp e2) ∧ + (var_cexp (Shift sh e num) = var_cexp e) +Termination + wf_rel_tac `measure (\e. exp_size ARB e)` >> + rpt strip_tac >> + imp_res_tac MEM_IMP_exp_size >> + TRY (first_x_assum (assume_tac o Q.SPEC `ARB`)) >> + decide_tac +End + +Definition assigned_vars_def: + (assigned_vars Skip = ([]:num list)) ∧ + (assigned_vars (Dec n e p) = (n::assigned_vars p)) ∧ + (assigned_vars (Assign n e) = [n]) ∧ + (assigned_vars (Seq p p') = assigned_vars p ++ assigned_vars p') ∧ + (assigned_vars (If e p p') = assigned_vars p ++ assigned_vars p') ∧ + (assigned_vars (While e p) = assigned_vars p) ∧ + (assigned_vars (Call (Ret NONE rp (SOME (Handle _ p))) e es) = + assigned_vars rp ++ assigned_vars p) ∧ + (assigned_vars (Call (Ret NONE rp NONE) e es) = assigned_vars rp) ∧ + (assigned_vars (Call (Ret (SOME rt) rp (SOME (Handle _ p))) e es) = + rt :: assigned_vars rp ++ assigned_vars p) ∧ + (assigned_vars (Call (Ret (SOME rt) rp NONE) e es) = rt :: assigned_vars rp) ∧ + (assigned_vars _ = []) +End + +(* +Definition declared_vars_def: + (declared_vars Skip l = l) ∧ + (declared_vars (Dec n e p) l = insert n () (declared_vars p l)) ∧ + (declared_vars (Seq p q) l = declared_vars q (declared_vars p l)) ∧ + (declared_vars (If e p q) l = declared_vars q (declared_vars p l)) ∧ + (declared_vars (While e p) l = declared_vars p l) ∧ + (declared_vars (Call (Ret _ rp NONE) _ _) l = declared_vars rp l) ∧ + (declared_vars (Call (Ret _ rp (SOME (Handle w ep))) _ _) l = + declared_vars ep (declared_vars rp l)) ∧ + (declared_vars _ l = l) +End +*) + +Definition exps_def: + (exps (Const w) = [Const w]) ∧ + (exps (Var v) = [Var v]) ∧ + (exps (Label f) = [Label f]) ∧ + (exps (Load e) = exps e) ∧ + (exps (LoadByte e) = exps e) ∧ + (exps (LoadGlob a) = [LoadGlob a]) ∧ + (exps (Op bop es) = FLAT (MAP exps es)) ∧ + (exps (Cmp c e1 e2) = exps e1 ++ exps e2) ∧ + (exps (Shift sh e num) = exps e) +Termination + wf_rel_tac `measure (\e. exp_size ARB e)` >> + rpt strip_tac >> + imp_res_tac MEM_IMP_exp_size >> + TRY (first_x_assum (assume_tac o Q.SPEC `ARB`)) >> + decide_tac +End + + +Definition acc_vars_def: + (acc_vars Skip l = l) ∧ + (acc_vars (Dec n e p) l = acc_vars p (list_insert (n::var_cexp e) l)) ∧ + (acc_vars (Assign n e) l = list_insert (n::var_cexp e) l) ∧ + (acc_vars (Store e1 e2) l = list_insert (var_cexp e1 ++ var_cexp e2) l) ∧ + (acc_vars (StoreByte e1 e2) l = list_insert (var_cexp e1 ++ var_cexp e2) l) ∧ + (acc_vars (StoreGlob _ e) l = list_insert (var_cexp e) l) ∧ + (acc_vars (Seq p q) l = acc_vars p (acc_vars q l)) ∧ + (acc_vars (If e p q) l = acc_vars p (acc_vars q (list_insert (var_cexp e) l))) ∧ + (acc_vars (While e p) l = acc_vars p (list_insert (var_cexp e) l)) ∧ + (acc_vars (Return e) l = list_insert (var_cexp e) l) ∧ + (acc_vars (ExtCall f v1 v2 v3 v4) l = list_insert [v1; v2; v3; v4] l) ∧ + (acc_vars (Call Tail trgt args) l = list_insert (FLAT (MAP var_cexp (trgt::args))) l) ∧ + (acc_vars (Call (Ret NONE rp NONE) trgt args) l = + let nl = list_insert (FLAT (MAP var_cexp (trgt::args))) l in + acc_vars rp nl) ∧ + (acc_vars (Call (Ret NONE rp (SOME (Handle w ep))) trgt args) l = + let nl = list_insert (FLAT (MAP var_cexp (trgt::args))) l in + acc_vars rp (acc_vars ep nl)) ∧ + (acc_vars (Call (Ret (SOME rv) rp NONE) trgt args) l = + let nl = list_insert (rv :: FLAT (MAP var_cexp (trgt::args))) l in + acc_vars rp nl) ∧ + (acc_vars (Call (Ret (SOME rv) rp (SOME (Handle w ep))) trgt args) l = + let nl = list_insert (rv :: FLAT (MAP var_cexp (trgt::args))) l in + acc_vars rp (acc_vars ep nl)) ∧ + (acc_vars _ l = l) +End + +Overload shift = “backend_common$word_shift” + +val _ = export_theory(); diff --git a/pancake/crep_to_loopScript.sml b/pancake/crep_to_loopScript.sml new file mode 100644 index 0000000000..aa3e82ff2e --- /dev/null +++ b/pancake/crep_to_loopScript.sml @@ -0,0 +1,227 @@ +(* + Compilation from crepLang to panLang. +*) +open preamble crepLangTheory + loopLangTheory sptreeTheory + loop_liveTheory + +val _ = new_theory "crep_to_loop" + +val _ = set_grammar_ancestry + ["crepLang", "loopLang", + "backend_common", "sptree"]; + +Datatype: + context = + <| vars : crepLang$varname |-> num; + funcs : crepLang$funname |-> num # num; (* loc, length args *) + vmax : num|> +End + +Definition find_var_def: + find_var ct v = + case FLOOKUP ct.vars v of + | SOME n => n + | NONE => 0 +End + +Definition find_lab_def: + find_lab ct f = + case FLOOKUP ct.funcs f of + | SOME (n, _) => n + | NONE => 0 +End + +Definition prog_if_def: + prog_if cmp p q e e' n m l = + p ++ q ++ [ + Assign n e; Assign m e'; + If cmp n (Reg m) + (Assign n (Const 1w)) (Assign n (Const 0w)) (list_insert [n; m] l)] +End + + +Definition compile_exp_def: + (compile_exp ctxt tmp l ((Const c):'a crepLang$exp) = ([], Const c, tmp, l)) /\ + (compile_exp ctxt tmp l (Var v) = ([], Var (find_var ctxt v), tmp, l)) /\ + (compile_exp ctxt tmp l (Label f) = ([LocValue tmp (find_lab ctxt f)], + Var tmp, tmp + 1, insert tmp () l)) /\ + (compile_exp ctxt tmp l (Load ad) = + let (p, le, tmp, l) = compile_exp ctxt tmp l ad in (p, Load le, tmp, l)) /\ + (compile_exp ctxt tmp l (LoadByte ad) = + let (p, le, tmp, l) = compile_exp ctxt tmp l ad in + (p ++ [Assign tmp le; LoadByte tmp tmp], Var tmp, tmp + 1, insert tmp () l)) /\ + (compile_exp ctxt tmp l (LoadGlob gadr) = ([], Lookup gadr, tmp, l)) /\ + (compile_exp ctxt tmp l (Op bop es) = + let (p, les, tmp, l) = compile_exps ctxt tmp l es in + (p, Op bop les, tmp, l)) /\ + (compile_exp ctxt tmp l (Cmp cmp e e') = + let (p, le, tmp, l) = compile_exp ctxt tmp l e in + let (p', le', tmp', l) = compile_exp ctxt tmp l e' in + (prog_if cmp p p' le le' (tmp' + 1) (tmp' + 2) l, Var (tmp' + 1), tmp' + 3, + list_insert [tmp' + 1; tmp' + 2] l)) /\ + (compile_exp ctxt tmp l (Shift sh e n) = + let (p, le, tmp, l) = compile_exp ctxt tmp l e in (p, Shift sh le n, tmp, l)) /\ + + (compile_exps ctxt tmp l cps = (* to generate ind thm *) + case cps of + | [] => ([], [], tmp, l) + | e::es => + let (p, le, tmp, l) = compile_exp ctxt tmp l e in + let (p1, les, tmp, l) = compile_exps ctxt tmp l es in + (p ++ p1, le::les, tmp, l)) +Termination + wf_rel_tac ‘measure (\x. case ISR x of + | T => list_size (crepLang$exp_size ARB) (SND(SND(SND (OUTR x)))) + | F => crepLang$exp_size ARB (SND(SND(SND (OUTL x)))))’ >> + rw [] >> + TRY (rw [list_size_def, + crepLangTheory.exp_size_def] >> NO_TAC) >> + qid_spec_tac ‘es’ >> + Induct >> rw [] >> + fs [list_size_def, crepLangTheory.exp_size_def] +End + +Definition gen_temps_def: + gen_temps n l = GENLIST (\x. n + x) l +End + +Definition rt_var_def: + rt_var fm NONE (n:num) mx = n /\ + rt_var fm (SOME v) n mx = + case FLOOKUP fm v of + | NONE => mx+1 (* impossible, greater than max to prove a prop later *) + | SOME m => m +End + +Definition compile_def: + (compile _ _ (Skip:'a crepLang$prog) = (Skip:'a loopLang$prog)) /\ + (compile _ _ Break = Break) /\ + (compile _ _ Continue = Continue) /\ + (compile _ _ Tick = Tick) /\ + (compile ctxt l (Return e) = + let (p, le, ntmp, nl) = compile_exp ctxt (ctxt.vmax + 1) l e in + nested_seq (p ++ [Assign ntmp le; Return ntmp])) /\ + (compile ctxt l (Raise eid) = + Seq (Assign (ctxt.vmax + 1) (Const eid)) (Raise (ctxt.vmax + 1))) /\ + (compile ctxt l (Store dst src) = + let (p, le, tmp, l) = compile_exp ctxt (ctxt.vmax + 1) l dst in + let (p', le', tmp, l) = compile_exp ctxt tmp l src in + nested_seq (p ++ p' ++ [Assign tmp le'; Store le tmp])) /\ + (compile ctxt l (StoreByte dst src) = + let (p, le, tmp, l) = compile_exp ctxt (ctxt.vmax + 1) l dst in + let (p', le', tmp, l) = compile_exp ctxt tmp l src in + nested_seq (p ++ p' ++ + [Assign tmp le; Assign (tmp + 1) le'; + StoreByte tmp (tmp + 1)])) /\ + (compile ctxt l (StoreGlob adr e) = + let (p, le, tmp, l) = compile_exp ctxt (ctxt.vmax + 1) l e in + nested_seq (p ++ [SetGlobal adr le])) /\ + (compile ctxt l (Seq p q) = + Seq (compile ctxt l p) (compile ctxt l q)) /\ + (compile ctxt l (Assign v e) = + case FLOOKUP ctxt.vars v of + | SOME n => + let (p,le,tmp, l) = compile_exp ctxt (ctxt.vmax + 1) l e in + nested_seq (p ++ [Assign n le]) + | NONE => Skip) /\ + (compile ctxt l (Dec v e prog) = + let (p,le,tmp,nl) = compile_exp ctxt (ctxt.vmax + 1) l e; + nctxt = ctxt with <|vars := ctxt.vars |+ (v,tmp); + vmax := tmp|>; + fl = insert tmp () l; + lp = compile nctxt fl prog in + Seq (nested_seq p) (Seq (Assign tmp le) lp)) /\ + (compile ctxt l (If e p q) = + let (np, le, tmp, nl) = compile_exp ctxt (ctxt.vmax + 1) l e; + lp = compile ctxt l p; + lq = compile ctxt l q in + nested_seq (np ++ [Assign tmp le; + If NotEqual tmp (Imm 0w) lp lq l])) /\ + + (compile ctxt l (While e p) = + let (np, le, tmp, nl) = compile_exp ctxt (ctxt.vmax + 1) l e; + lp = compile ctxt l p in + Loop l (nested_seq (np ++ [ + Assign tmp le; + If NotEqual tmp (Imm 0w) + (Seq lp Continue) Break l])) + l) /\ + (compile ctxt l (Call Tail e es) = + let (p, les, tmp, nl) = compile_exps ctxt (ctxt.vmax + 1) l (es ++ [e]); + nargs = gen_temps tmp (LENGTH les) in + nested_seq (p ++ MAP2 Assign nargs les ++ + [Call NONE NONE nargs NONE])) /\ + (compile ctxt l (Call (Ret rt rp hdl) e es) = + let (p, les, tmp, nl) = compile_exps ctxt (ctxt.vmax + 1) l (es ++ [e]); + nargs = gen_temps tmp (LENGTH les); + rn = rt_var ctxt.vars rt (ctxt.vmax + 1) (ctxt.vmax + 1); + en = ctxt.vmax + 1; + pr = compile ctxt l rp; + pe = case hdl of + | NONE => Raise en + | SOME (Handle eid ep) => + let cpe = compile ctxt l ep in + (If NotEqual en (Imm eid) (Raise en) (Seq Tick cpe) l) + in + nested_seq (p ++ MAP2 Assign nargs les ++ + [Call (SOME (rn, l)) NONE nargs + (SOME (en, pe, pr, l))])) /\ + (compile ctxt l (ExtCall f ptr1 len1 ptr2 len2) = + case (FLOOKUP ctxt.vars ptr1, FLOOKUP ctxt.vars len1, + FLOOKUP ctxt.vars ptr2, FLOOKUP ctxt.vars len2) of + | (SOME pc, SOME lc, SOME pc', SOME lc') => + FFI (explode f) pc lc pc' lc' l + | _ => Skip) +End + + +Definition ocompile_def: + ocompile ctxt l p = (loop_live$optimise o compile ctxt l) p +End + + +Definition mk_ctxt_def: + mk_ctxt vmap fs vmax = + <|vars := vmap; + funcs := fs; + vmax := vmax|> +End + +Definition make_vmap_def: + make_vmap params = + FEMPTY |++ ZIP (params, GENLIST I (LENGTH params)) +End + +Definition comp_func_def: + comp_func fs params body = + let vmap = make_vmap params; + vmax = LENGTH params - 1; + l = list_to_num_set (GENLIST I (LENGTH params)) in + compile (mk_ctxt vmap fs vmax) l body +End + + +Definition make_funcs_def: + make_funcs prog = + let fnames = MAP FST prog; + fnums = GENLIST I (LENGTH prog); + lens = MAP (LENGTH o FST o SND) prog; + fnums_lens = MAP2 (λx y. (x,y)) fnums lens; + fs = MAP2 (λx y. (x,y)) fnames fnums_lens in + alist_to_fmap fs +End + +Definition compile_prog_def: + compile_prog prog = + let fnums = GENLIST I (LENGTH prog); + comp = comp_func (make_funcs prog) in + MAP2 (λn (name, params, body). + (n, + (GENLIST I o LENGTH) params, + loop_live$optimise (comp params body))) + fnums prog +End + + +val _ = export_theory(); diff --git a/pancake/ffi/README.md b/pancake/ffi/README.md new file mode 100644 index 0000000000..cf0e78ae4e --- /dev/null +++ b/pancake/ffi/README.md @@ -0,0 +1 @@ +FFI for Pancake diff --git a/pancake/loopLangScript.sml b/pancake/loopLangScript.sml new file mode 100644 index 0000000000..aba6ff00cb --- /dev/null +++ b/pancake/loopLangScript.sml @@ -0,0 +1,125 @@ +(* + loopLang intermediate language +*) +open preamble + asmTheory (* for importing binop and cmp *) + backend_commonTheory (* for overloading shift operation *); + +val _ = new_theory "loopLang"; + +Type shift = ``:ast$shift`` + +Datatype: + exp = Const ('a word) + | Var num + | Lookup (5 word) + | Load exp + | Op binop (exp list) + | Shift shift exp num +End + +Datatype: + prog = Skip + | Assign num ('a exp) (* dest, source *) + | Store ('a exp) num (* dest, source *) + | SetGlobal (5 word) ('a exp) (* dest, source *) + | LoadByte num num (* TODISC: have removed imm, why num num? *) + | StoreByte num num + | Seq prog prog + | If cmp num ('a reg_imm) prog prog num_set + | Loop num_set prog num_set (* names in, body, names out *) + | Break + | Continue + | Raise num + | Return num + | Tick + | Mark prog + | Fail + | LocValue num num (* assign v1 := Loc v2 0 *) + | Call ((num # num_set) option) (* return var *) + (num option) (* target of call *) + (num list) (* arguments *) + ((num # prog # prog # num_set) option) (* var to store exception, + exception-handler code, + normal-return handler code, + live vars after call *) + | FFI string num num num num num_set + (* FFI name, conf_ptr, conf_len, array_ptr, array_len, cut-set *) +End + +Theorem MEM_IMP_exp_size: + !xs a. MEM a xs ==> (exp_size l a < exp1_size l xs) +Proof + Induct \\ FULL_SIMP_TAC (srw_ss()) [] + \\ REPEAT STRIP_TAC \\ SRW_TAC [] [definition"exp_size_def"] + \\ RES_TAC \\ DECIDE_TAC +QED + +Definition nested_seq_def: + (nested_seq [] = Skip) /\ + (nested_seq (e::es) = Seq e (nested_seq es)) +End + +Definition locals_touched_def: + (locals_touched (Const w) = []) /\ + (locals_touched (Var v) = [v]) /\ + (locals_touched (Lookup name) = []) /\ + (locals_touched (Load addr) = locals_touched addr) /\ + (locals_touched (Op op wexps) = FLAT (MAP locals_touched wexps)) /\ + (locals_touched (Shift sh wexp n) = locals_touched wexp) +Termination + wf_rel_tac `measure (\e. exp_size ARB e)` >> + rpt strip_tac >> + imp_res_tac MEM_IMP_exp_size >> + TRY (first_x_assum (assume_tac o Q.SPEC `ARB`)) >> + decide_tac +End + +Definition assigned_vars_def: + (assigned_vars Skip = []) ∧ + (assigned_vars (Assign n e) = [n]) ∧ + (assigned_vars (LoadByte n m) = [m]) ∧ + (assigned_vars (Seq p q) = assigned_vars p ++ assigned_vars q) ∧ + (assigned_vars (If cmp n r p q ns) = assigned_vars p ++ assigned_vars q) ∧ + (assigned_vars (LocValue n m) = [n]) ∧ + (assigned_vars (Mark p) = assigned_vars p) ∧ + (assigned_vars (Loop _ p _) = assigned_vars p) ∧ + (assigned_vars (Call NONE _ _ _) = []) ∧ + (assigned_vars (Call (SOME (n,_)) _ _ NONE) = [n]) ∧ + (assigned_vars (Call (SOME (n,_)) _ _ (SOME (m,p,q, _))) = + n::m::assigned_vars p ++ assigned_vars q) ∧ + (assigned_vars _ = []) +End + +Definition acc_vars_def: + (acc_vars (Seq p1 p2) l = acc_vars p1 (acc_vars p2 l)) ∧ + (acc_vars Break l = (l:num_set)) ∧ + (acc_vars Continue l = l) ∧ + (acc_vars (Loop l1 body l2) l = acc_vars body l) ∧ + (acc_vars (If x1 x2 x3 p1 p2 l1) l = acc_vars p1 (acc_vars p2 l)) ∧ + (acc_vars (Mark p1) l = acc_vars p1 l) /\ + (acc_vars Tick l = l) /\ + (acc_vars Skip l = l) /\ + (acc_vars Fail l = l) /\ + (acc_vars (Raise v) l = l) /\ + (acc_vars (Return v) l = l) /\ + (acc_vars (Call ret dest args handler) l = + case ret of + | NONE => l + | SOME (v,live) => + let l = insert v () l in + case handler of + | NONE => l + | SOME (n,p1,p2,l1) => + acc_vars p1 (acc_vars p2 (insert n () l))) /\ + (acc_vars (LocValue n m) l = insert n () l) /\ + (acc_vars (Assign n exp) l = insert n () l) /\ + (acc_vars (Store exp n) l = l) /\ + (acc_vars (SetGlobal w exp) l = l) /\ + (acc_vars (LoadByte n m) l = insert m () l) /\ + (acc_vars (StoreByte n m) l = l) /\ + (acc_vars (FFI name n1 n2 n3 n4 live) l = l) +End + + +val _ = export_theory(); diff --git a/pancake/loop_callScript.sml b/pancake/loop_callScript.sml new file mode 100644 index 0000000000..e8f23e4a0e --- /dev/null +++ b/pancake/loop_callScript.sml @@ -0,0 +1,80 @@ +(* + Call optimisation for loopLang +*) +open preamble loopLangTheory + +val _ = new_theory "loop_call" + +Definition comp_def: + (comp l Skip = (Skip, l)) /\ + (comp l (Call ret dest args handler) = + ((case dest of + | SOME _ => Call ret dest args handler + | NONE => ( + case args of + | [] => Skip + | _ => ( + case lookup (LAST args) l of + | NONE => Call ret NONE args handler + | SOME n => Call ret (SOME n) (BUTLAST args) handler))), LN)) /\ + (comp l (LocValue n m) = (LocValue n m, insert n m l)) /\ + (comp l (Assign n (Var m)) = (Assign n (Var m), + case (lookup n l, lookup m l) of + | NONE, NONE => l + | SOME _ , NONE => delete n l + | _, SOME loc => insert n loc l)) /\ + (comp l (Assign n e) = (Assign n e, + case lookup n l of + | NONE => l + | _ => delete n l)) /\ + (comp l (LoadByte m n) = (LoadByte m n, + case lookup n l of + | NONE => l + | _ => delete n l)) /\ + (comp l (Seq p q) = + let (np, nl) = comp l p; + (nq, nl) = comp nl q in + (Seq np nq, LN)) /\ + (comp l (If c n ri p q ns) = + let (np, nl) = comp l p; + (nq, ml) = comp l q in + (If c n ri np nq ns, LN)) /\ + (comp l (Loop ns p ms) = + let (np, nl) = comp LN p in + (Loop ns np ms, LN)) /\ + (comp l (Mark p) = + let (np, nl) = comp l p in + (Mark np, nl)) /\ + (comp l (FFI str n m n' m' nl) = + (FFI str n m n' m' nl, LN)) /\ + (comp l Tick = (Tick, LN)) /\ + (comp l (Raise n) = (Raise n, LN)) /\ + (comp l (Return n) = (Return n, LN)) /\ + (comp l p = (p, l)) +End + + +(* +EVAL “comp LN (LocValue 1 3)”; + +EVAL “comp LN + (Seq (LocValue 1 3) + (Assign 2 (Var 1)))”; + +EVAL “comp LN + (Seq (LocValue 1 3) + (Seq (Assign 2 (Var 1)) + (Seq (Call NONE NONE [2] NONE) Skip)))” + + + + +EVAL “(comp + (Seq (LocValue 1 3) + (Seq (Assign 2 (Var 1)) + (Seq (Call NONE NONE [2] NONE) Skip))), s)” + +*) + + +val _ = export_theory(); diff --git a/pancake/loop_liveScript.sml b/pancake/loop_liveScript.sml new file mode 100644 index 0000000000..391b1815b3 --- /dev/null +++ b/pancake/loop_liveScript.sml @@ -0,0 +1,196 @@ +(* + Correctness proof for loop to loop_remove +*) + +open preamble loopLangTheory + loop_callTheory + + +val _ = new_theory "loop_live"; + +Definition vars_of_exp_def: + vars_of_exp (loopLang$Var v) l = insert v () l ∧ + vars_of_exp (Const _) l = l ∧ + vars_of_exp (Lookup _) l = l ∧ + vars_of_exp (Load a) l = vars_of_exp a l ∧ + vars_of_exp (Op x vs) l = vars_of_exp_list vs l ∧ + vars_of_exp (Shift _ x _) l = vars_of_exp x l ∧ + vars_of_exp_list xs l = + (case xs of [] => l + | (x::xs) => vars_of_exp x (vars_of_exp_list xs l)) +Termination + WF_REL_TAC ‘measure (λx. case x of INL (x,_) => exp_size (K 0) x + | INR (x,_) => exp1_size (K 0) x)’ +End + +Theorem size_mk_BN: + ∀t1 t2. size (mk_BN t1 t2) = size (BN t1 t2) +Proof + Cases \\ Cases \\ fs [mk_BN_def,size_def] +QED + +Theorem size_mk_BS: + ∀t1 t2 x. size (mk_BS t1 x t2) = size (BS t1 x t2) +Proof + Cases \\ Cases \\ fs [mk_BS_def,size_def] +QED + +Theorem size_inter: + ∀l1 l2. size (inter l1 l2) <= size l1 +Proof + Induct \\ fs [inter_def] + \\ Cases_on ‘l2’ \\ fs [size_mk_BN,size_mk_BS] + \\ rewrite_tac [ADD_ASSOC,DECIDE “m+1≤n+1 ⇔ m ≤ n:num”] + \\ metis_tac [DECIDE “n1 ≤ m1 ∧ n2 ≤ m2 ⇒ n1+n2 ≤ m1+m2:num ∧ n1+n2 ≤ m1+m2+1”] +QED + + +(* This optimisation shrinks all cutsets and also deletes assignments + to unused variables. The Loop case is the interesting one: an + auxiliary function is used to find a fixed-point. *) + +Definition shrink_def: + (shrink b (Seq p1 p2) l = + let (p2,l) = shrink b p2 l in + let (p1,l) = shrink b p1 l in + (Seq p1 p2, l)) /\ + (shrink b (Loop live_in body live_out) l = + let l2 = inter live_out l in + case fixedpoint live_in LN l2 body of + | SOME (body,l0) => + (let l = inter live_in l0 in (Loop l body l2, l)) + | NONE => let (b,_) = shrink (live_in,l2) body l2 in + (Loop live_in b l2, live_in)) /\ + (shrink b (If x1 x2 x3 p1 p2 l1) l = + let l = inter l l1 in + let (p1,l1) = shrink b p1 l in + let (p2,l2) = shrink b p2 l in + let l3 = (case x3 of Reg r => insert r () LN | _ => LN) in + (If x1 x2 x3 p1 p2 l, insert x2 () (union l3 (union l1 l2)))) /\ + (shrink b (Mark p1) l = shrink b p1 l) /\ + (shrink b Break l = (Break,SND b)) /\ + (shrink b Continue l = (Continue,FST b)) /\ + (shrink b Fail l = (Fail,LN)) /\ + (shrink b Skip l = (Skip,l)) /\ + (shrink b (Return v) l = (Return v, insert v () LN)) /\ + (shrink b (Raise v) l = (Raise v, insert v () LN)) /\ + (shrink b (LocValue n m) l = + case lookup n l of + | NONE => (Skip,l) + | SOME _ => (LocValue n m, delete n l)) ∧ + (shrink b (Assign n x) l = + case lookup n l of + | NONE => (Skip,l) + | SOME _ => (Assign n x, vars_of_exp x (delete n l))) ∧ + (shrink b (Store e n) l = + (Store e n, vars_of_exp e (insert n () l))) ∧ + (shrink b (SetGlobal name e) l = + (SetGlobal name e, vars_of_exp e l)) ∧ + (shrink b (Call ret dest args handler) l = + let a = fromAList (MAP (λx. (x,())) args) in + case ret of + | NONE => (Call NONE dest args NONE, union a l) + | SOME (n,l1) => + case handler of + | NONE => let l3 = (delete n (inter l l1)) in + (Call (SOME (n,l3)) dest args NONE, union a l3) + | SOME (e,h,r,live_out) => + let (r,l2) = shrink b r l in + let (h,l3) = shrink b h l in + let l1 = inter l1 (union (delete n l2) (delete e l3)) in + (Call (SOME (n,l1)) dest args (SOME (e,h,r,inter l live_out)), + union a l1)) ∧ + (shrink b (FFI n r1 r2 r3 r4 l1) l = + (FFI n r1 r2 r3 r4 (inter l1 l), + insert r1 () (insert r2 () (insert r3 () (insert r4 () (inter l1 l)))))) ∧ + (shrink b (LoadByte x y) l = + (LoadByte x y, insert x () (delete y l))) ∧ + (shrink b (StoreByte x y) l = + (StoreByte x y, insert x () (insert y () l))) ∧ + (shrink b prog l = (prog,l)) /\ + + + (fixedpoint live_in l1 l2 body = + let (b,l0) = shrink (inter live_in l1,l2) body l2 in + let l0' = inter live_in l0 in + if l0' = l1 then (* fixed point found! *) SOME (b,l0) else + if size l0' ≤ size l1 then (* no progress made, not possible *) NONE else + fixedpoint live_in l0' l2 body) +Termination + WF_REL_TAC `inv_image (measure I LEX measure I LEX measure I) + (λx. case x of + | INL (_,c,_) => (prog_size (K 0) c, 0:num, 0) + | INR (live_in,l1,l2,body) => + (prog_size (K 0) body, 1, size live_in - size l1))` + \\ rw [] \\ fs [GSYM NOT_LESS] + \\ qsuff_tac ‘size l1 < size live_in’ \\ fs [] + \\ match_mp_tac LESS_LESS_EQ_TRANS + \\ asm_exists_tac \\ fs [size_inter] +End + +Theorem exp_ind = vars_of_exp_ind + |> Q.SPECL [‘λx l. P x’,‘λx l. Q x’] + |> SIMP_RULE std_ss [] + |> Q.GENL [‘P’,‘Q’]; + +Theorem fixedpoint_thm: + ∀live_in l1 l2 (body:'a loopLang$prog) l0 b. + fixedpoint live_in l1 l2 body = SOME (b, l0) ⇒ + shrink (inter live_in l0, l2) body l2 = (b, l0) +Proof + qmatch_abbrev_tac ‘entire_goal’ + \\ qsuff_tac + ‘(∀b (prog:'a loopLang$prog) l d. shrink b prog l = d ⇒ T) ∧ entire_goal’ + THEN1 fs [] + \\ unabbrev_all_tac + \\ ho_match_mp_tac shrink_ind \\ fs [] \\ rw [] + \\ pop_assum mp_tac \\ once_rewrite_tac [shrink_def] + \\ fs [] \\ pairarg_tac \\ fs [] + \\ fs [CaseEq"bool"] \\ rw [] \\ fs [] + \\ fs [inter_assoc] + \\ pop_assum (fn th => rewrite_tac [GSYM th]) + \\ rpt AP_THM_TAC \\ AP_TERM_TAC \\ fs [] + \\ fs [lookup_inter_alt] \\ rw [] + \\ fs [domain_lookup] + \\ Cases_on ‘lookup x live_in’ \\ fs [] +QED + +Definition mark_all_def: + (mark_all (Seq p1 p2) = + let (p1,t1) = mark_all p1 in + let (p2,t2) = mark_all p2 in + let t3 = (t1 /\ t2) in + (if t3 then Mark (Seq p1 p2) else Seq p1 p2, t3)) /\ + (mark_all (Loop l1 body l2) = + let (body,t1) = mark_all body in + (Loop l1 body l2, F)) /\ + (mark_all (If x1 x2 x3 p1 p2 l1) = + let (p1,t1) = mark_all p1 in + let (p2,t2) = mark_all p2 in + let p3 = If x1 x2 x3 p1 p2 l1 in + let t3 = (t1 /\ t2) in + (if t3 then Mark p3 else p3, t3)) /\ + (mark_all (Mark p1) = mark_all p1) /\ + (mark_all (Call ret dest args handler) = + case handler of + | NONE => (Mark (Call ret dest args handler), T) + | SOME (n,p1,p2,l) => + let (p1,t1) = mark_all p1 in + let (p2,t2) = mark_all p2 in + let t3 = (t1 ∧ t2) in + let p3 = Call ret dest args (SOME (n,p1,p2,l)) in + (if t3 then Mark p3 else p3, t3)) /\ + (mark_all prog = (Mark prog,T)) +End + +Definition comp_def: + comp prog = FST (mark_all (FST (shrink (LN,LN) prog LN))) +End + + +Definition optimise_def: + optimise prog = (comp o FST o loop_call$comp LN) prog +End + + +val _ = export_theory(); diff --git a/pancake/loop_removeScript.sml b/pancake/loop_removeScript.sml new file mode 100644 index 0000000000..5b8af39e7e --- /dev/null +++ b/pancake/loop_removeScript.sml @@ -0,0 +1,78 @@ +(* + Correctness proof for loop_remove +*) + +open preamble loopLangTheory + +val _ = new_theory "loop_remove"; + +Definition comp_no_loop_def: + (comp_no_loop p (Seq p1 p2) = + Seq (comp_no_loop p p1) (comp_no_loop p p2)) /\ + (comp_no_loop p (If x1 x2 x3 p1 p2 l1) = + If x1 x2 x3 (comp_no_loop p p1) (comp_no_loop p p2) l1) /\ + (comp_no_loop p (Call ret dest args handler) = + Call ret dest args + (case handler of + | SOME (n,q,r,l) => SOME (n, comp_no_loop p q, comp_no_loop p r, l) + | NONE => NONE)) /\ + (comp_no_loop p Break = FST p) /\ + (comp_no_loop p Continue = SND p) /\ + (comp_no_loop p (Mark prog) = comp_no_loop p prog) /\ + (comp_no_loop p (Loop l1 b l2) = Fail) /\ + (comp_no_loop p prog = prog) +End + +Definition store_cont_def: + store_cont live code (n,funs) = + let params = MAP FST (toAList live) in + let funs = (n,params,code) :: funs in + let cont = Call NONE (SOME n) params NONE in + (cont:'a loopLang$prog, (n+1,funs)) +End + +Definition comp_with_loop_def: + (comp_with_loop p (Seq p1 p2) cont s = + let (q2,s) = comp_with_loop p p2 cont s in + comp_with_loop p p1 q2 s) ∧ + (comp_with_loop p (If x1 x2 x3 p1 p2 l1) cont s = + let (cont,s) = store_cont l1 cont s in + let (q1,s) = comp_with_loop p p1 cont s in + let (q2,s) = comp_with_loop p p2 cont s in + (If x1 x2 x3 q1 q2 LN,s)) /\ + (comp_with_loop p (Call ret dest args handler) cont s = + case handler of + | NONE => (Seq (Call ret dest args NONE) cont,s) + | SOME (n,q,r,l) => + let (cont,s) = store_cont l cont s in + let (q,s) = comp_with_loop p q cont s in + let (r,s) = comp_with_loop p r cont s in + (Call ret dest args (SOME (n,q,r,l)),s)) /\ + (comp_with_loop p Break cont s = (FST p,s)) /\ + (comp_with_loop p Continue cons s = (SND p,s)) /\ + (comp_with_loop p (Mark prog) cont s = (Seq (comp_no_loop p prog) cont,s)) /\ + (comp_with_loop p (Loop live_in body live_out) cont s = + let (cont,s) = store_cont live_out cont s in + let params = MAP FST (toAList live_in) in + let (n,funs) = s in + let enter = Call NONE (SOME n) params NONE in + let (body,m,funs) = comp_with_loop (cont,enter) body Fail (n+1,funs) in + let funs = (n,params,body) :: funs in + (enter,(m,funs))) ∧ + (comp_with_loop p prog cont s = (Fail,s)) (* impossible case *) +End + +Definition comp_def: + comp (name,params,prog) s = + let (body,n,funs) = comp_with_loop (Fail,Fail) prog Fail s in + (n,(name,params,body)::funs) +End + +Definition comp_prog_def: + comp_prog code = + let n = FOLDR MAX 0 (MAP FST code) + 1 in + SND (FOLDR comp (n,[]) code) +End + + +val _ = export_theory(); diff --git a/pancake/loop_to_wordScript.sml b/pancake/loop_to_wordScript.sml new file mode 100644 index 0000000000..f2063da673 --- /dev/null +++ b/pancake/loop_to_wordScript.sml @@ -0,0 +1,145 @@ +(* + Compilation from looLang to wordLang. +*) +open preamble loopLangTheory + wordLangTheory + loop_removeTheory + +val _ = new_theory "loop_to_word" + +val _ = set_grammar_ancestry + ["loopLang", "wordLang", + "backend_common"]; + + +Definition find_var_def: + find_var ctxt v = + case lookup v ctxt of + | NONE => 0 + | SOME n => (n:num) +End + +Definition find_reg_imm_def: + (find_reg_imm ctxt (Imm w) = Imm w) ∧ + (find_reg_imm ctxt (Reg n) = Reg (find_var ctxt n)) +End + +Definition comp_exp_def : + (comp_exp ctxt (loopLang$Const w) = wordLang$Const w) /\ + (comp_exp ctxt (Var n) = Var (find_var ctxt n)) /\ + (comp_exp ctxt (Lookup m) = Lookup (Temp m)) /\ + (comp_exp ctxt (Load exp) = Load (comp_exp ctxt exp)) /\ + (comp_exp ctxt (Shift s exp n) = Shift s (comp_exp ctxt exp) n) /\ + (comp_exp ctxt (Op op wexps) = + let wexps = MAP (comp_exp ctxt) wexps in + Op op wexps) +Termination + WF_REL_TAC ‘measure (loopLang$exp_size (K 0) o SND)’ >> + rw [] >> + rename [‘MEM x xs’] >> + Induct_on ‘xs’ >> fs [] >> + fs [loopLangTheory.exp_size_def] >> + rw [] >> fs [] +End + +Definition toNumSet_def: + toNumSet [] = LN ∧ + toNumSet (n::ns) = insert n () (toNumSet ns) +End + +Definition fromNumSet_def: + fromNumSet t = MAP FST (toAList t) +End + +Definition mk_new_cutset_def: + mk_new_cutset ctxt (l:num_set) = + insert 0 () (toNumSet (MAP (find_var ctxt) (fromNumSet l))) +End + +Definition comp_def: + (comp ctxt Skip l = (wordLang$Skip,l)) /\ + (comp ctxt (Assign n e) l = + (Assign (find_var ctxt n) (comp_exp ctxt e),l)) /\ + (comp ctxt (Store e v) l = + (Store (comp_exp ctxt e) (find_var ctxt v), l)) /\ + (comp ctxt (SetGlobal a e) l = + (Set (Temp a) (comp_exp ctxt e), l)) /\ + (comp ctxt (LoadByte a v) l = + (Inst (Mem Load8 (find_var ctxt v) + (Addr (find_var ctxt a) 0w)), l)) /\ + (comp ctxt (StoreByte a v) l = + (Inst (Mem Store8 (find_var ctxt v) + (Addr (find_var ctxt a) 0w)), l)) /\ + (comp ctxt (Seq p q) l = + let (wp,l) = comp ctxt p l in + let (wq,l) = comp ctxt q l in + (Seq wp wq,l)) /\ + (comp ctxt (If c n ri p q l1) l = + let (wp,l) = comp ctxt p l in + let (wq,l) = comp ctxt q l in + (Seq (If c (find_var ctxt n) (find_reg_imm ctxt ri) wp wq) Tick,l)) /\ + (comp ctxt (Loop l1 body l2) l = (Skip,l)) /\ (* not present in input *) + (comp ctxt Break l = (Skip,l)) /\ (* not present in input *) + (comp ctxt Continue l = (Skip,l)) /\ (* not present in input *) + (comp ctxt (Raise v) l = (Raise (find_var ctxt v),l)) /\ + (comp ctxt (Return v) l = (Return 0 (find_var ctxt v),l)) /\ + (comp ctxt Tick l = (Tick,l)) /\ + (comp ctxt (Mark p) l = comp ctxt p l) /\ + (comp ctxt Fail l = (Skip,l)) /\ + (comp ctxt (LocValue n m) l = (LocValue (find_var ctxt n) m,l)) /\ + (comp ctxt (Call ret dest args handler) l = + let args = MAP (find_var ctxt) args in + case ret of + | NONE (* tail-call *) => (wordLang$Call NONE dest (0::args) NONE,l) + | SOME (v,live) => + let v = find_var ctxt v in + let live = mk_new_cutset ctxt live in + let new_l = (FST l, SND l+1) in + case handler of + | NONE => (wordLang$Call (SOME (v,live,Skip,l)) dest args NONE, new_l) + | SOME (n,p1,p2,_) => + let (p1,l1) = comp ctxt p1 new_l in + let (p2,l1) = comp ctxt p2 l1 in + let new_l = (FST l1, SND l1+1) in + (Seq (Call (SOME (v,live,p2,l)) dest args + (SOME (find_var ctxt n,p1,l1))) Tick, new_l)) /\ + (comp ctxt (FFI f ptr1 len1 ptr2 len2 live) l = + let live = mk_new_cutset ctxt live in + (FFI f (find_var ctxt ptr1) (find_var ctxt len1) + (find_var ctxt ptr2) (find_var ctxt len2) live,l)) +End + +Definition make_ctxt_def: + make_ctxt n [] l = l ∧ + make_ctxt n (x::xs) l = make_ctxt (n+2:num) xs (insert x n l) +End + +(* + acc_vars body LN: accumulates the assigned variable with the given num_set + The main function below is make_ctxt, we do the difference so that we do not + replicate the parameters (variable names) that we are providing with the + exsiting assigned variables present in the body of the program already +*) + + +Definition comp_func_def: + comp_func name params body = + let vs = fromNumSet (difference (acc_vars body LN) (toNumSet params)) in + let ctxt = make_ctxt 2 (params ++ vs) LN in + FST (comp ctxt body (name,2)) +End + + +Definition compile_prog_def: + compile_prog p = MAP (λ(name, params, body). + (name, LENGTH params+1, comp_func name params body)) p +End + +Definition compile_def: + compile p = + let p = loop_remove$comp_prog p in + compile_prog p +End + + +val _ = export_theory(); diff --git a/pancake/panLangScript.sml b/pancake/panLangScript.sml new file mode 100644 index 0000000000..674efd3047 --- /dev/null +++ b/pancake/panLangScript.sml @@ -0,0 +1,189 @@ +(* + Abstract syntax for Pancake language. + Pancake is an imperative language with + instructions for conditionals, While loop, + memory load and store, functions, + and foreign function calls. +*) + +open preamble + mlstringTheory + asmTheory (* for binop and cmp *) + backend_commonTheory; (* for overloading the shift operation *) + +val _ = new_theory "panLang"; + +Type shift = ``:ast$shift`` + +Type sname = ``:mlstring`` + +Type varname = ``:mlstring`` + +Type funname = ``:mlstring`` + +Type eid = ``:mlstring`` + +Type decname = ``:mlstring`` + +Type index = ``:num`` + +Datatype: + shape = One + | Comb (shape list) +End + +Datatype: + exp = Const ('a word) + | Var varname + | Label funname + (* | GetAddr decname *) + | Struct (exp list) + | Field index exp + | Load shape exp + | LoadByte exp + | Op binop (exp list) + | Cmp cmp exp exp + | Shift shift exp num +End + +Datatype: + prog = Skip + | Dec varname ('a exp) prog + | Assign varname ('a exp) (* dest, source *) + | Store ('a exp) ('a exp) (* dest, source *) + | StoreByte ('a exp) ('a exp) (* dest, source *) + | Seq prog prog + | If ('a exp) prog prog + | While ('a exp) prog + | Break + | Continue + | Call ret ('a exp) (('a exp) list) + | ExtCall funname varname varname varname varname + (* FFI name, conf_ptr, conf_len, array_ptr, array_len *) + | Raise eid ('a exp) + | Return ('a exp) + | Tick; + + ret = Tail | Ret varname (handler option); + + handler = Handle eid varname prog (* excp id and var *) +End + +Overload TailCall = “Call Tail” +Overload RetCall = “\s h. Call (Ret s h)” + +(* +Datatype: + decl = Decl decname string + | Func funname (shape option) shape ('a prog) +End +*) + +Theorem MEM_IMP_shape_size: + !shapes a. MEM a shapes ==> (shape_size a < 1 + shape1_size shapes) +Proof + Induct >> fs [] >> + rpt strip_tac >> rw [fetch "-" "shape_size_def"] >> + res_tac >> decide_tac +QED + + +Definition size_of_shape_def: + size_of_shape One = 1 /\ + size_of_shape (Comb shapes) = SUM (MAP size_of_shape shapes) +Termination + wf_rel_tac `measure shape_size` >> + fs [MEM_IMP_shape_size] +End + +Theorem MEM_IMP_exp_size: + !xs a. MEM a xs ==> (exp_size l a < exp1_size l xs) +Proof + Induct \\ FULL_SIMP_TAC (srw_ss()) [] + \\ REPEAT STRIP_TAC \\ SRW_TAC [] [definition"exp_size_def"] + \\ RES_TAC \\ DECIDE_TAC +QED + + +Definition nested_seq_def: + (nested_seq [] = Skip) /\ + (nested_seq (e::es) = Seq e (nested_seq es)) +End + +Definition with_shape_def: + (with_shape [] _ = []) ∧ + (with_shape (sh::shs) e = + TAKE (size_of_shape sh) e :: with_shape shs (DROP (size_of_shape sh) e)) +End + +Definition exp_ids_def: + (exp_ids Skip = ([]:mlstring list)) ∧ + (exp_ids (Raise e _) = [e]) ∧ + (exp_ids (Dec _ _ p) = exp_ids p) ∧ + (exp_ids (Seq p q) = exp_ids p ++ exp_ids q) ∧ + (exp_ids (If _ p q) = exp_ids p ++ exp_ids q) ∧ + (exp_ids (While _ p) = exp_ids p) ∧ + (exp_ids (Call (Ret _ (SOME (Handle e _ ep))) _ _) = e::exp_ids ep) ∧ + (exp_ids _ = []) +End + +(* defining here for insead of in pan_to_crep for pan_simpProof*) +Definition remove_dup: + (remove_dup [] = []) ∧ + (remove_dup (x::xs) = + if MEM x xs then remove_dup xs + else x::remove_dup xs) +End + +Definition size_of_eids_def: + size_of_eids prog = + let eids = FLAT (MAP (exp_ids o SND o SND) prog) in + LENGTH (remove_dup eids) +End + +(* + for time_to_pancake compiler: +*) + +(* optimise this function *) +Definition assigns_def: + (assigns [] n = Skip) ∧ + (assigns (v::vs) n = + Seq (Assign v n) (assigns vs n)) +End + + +Definition decs_def: + (decs [] p = p) /\ + (decs ((v,e)::es) p = + Dec v e (decs es p)) +End + + +Definition var_exp_def: + (var_exp (Const w) = ([]:mlstring list)) ∧ + (var_exp (Var v) = [v]) ∧ + (var_exp (Label f) = []) ∧ + (var_exp (Struct es) = FLAT (MAP var_exp es)) ∧ + (var_exp (Field i e) = var_exp e) ∧ + (var_exp (Load sh e) = var_exp e) ∧ + (var_exp (LoadByte e) = var_exp e) ∧ + (var_exp (Op bop es) = FLAT (MAP var_exp es)) ∧ + (var_exp (Cmp c e1 e2) = var_exp e1 ++ var_exp e2) ∧ + (var_exp (Shift sh e num) = var_exp e) +Termination + wf_rel_tac `measure (\e. exp_size ARB e)` >> + rpt strip_tac >> + imp_res_tac MEM_IMP_exp_size >> + TRY (first_x_assum (assume_tac o Q.SPEC `ARB`)) >> + decide_tac +End + + +Definition destruct_def: + (destruct (Struct es) = es) /\ + (destruct _ = []) +End + + +val _ = export_theory(); diff --git a/pancake/pan_commonScript.sml b/pancake/pan_commonScript.sml new file mode 100644 index 0000000000..f3ee9e5491 --- /dev/null +++ b/pancake/pan_commonScript.sml @@ -0,0 +1,14 @@ +(* + Common definitions for Pancake compiler +*) +open preamble + +val _ = new_theory "pan_common" + +Definition distinct_lists_def: + distinct_lists xs ys = + EVERY (\x. ~MEM x ys) xs +End + + +val _ = export_theory(); diff --git a/pancake/pan_simpScript.sml b/pancake/pan_simpScript.sml new file mode 100644 index 0000000000..462f2f3419 --- /dev/null +++ b/pancake/pan_simpScript.sml @@ -0,0 +1,132 @@ +(* + Compilation from panLang to crepLang. +*) + +open preamble panLangTheory + +val _ = new_theory "pan_simp" + +val _ = set_grammar_ancestry ["panLang","backend_common"]; + +val _ = patternMatchesLib.ENABLE_PMATCH_CASES(); + +Definition SmartSeq_def[simp]: + SmartSeq p q = + if p = Skip then q else Seq p q +End + +Definition seq_assoc_def: + (seq_assoc p Skip = p) /\ + (seq_assoc p (Dec v e q) = + SmartSeq p (Dec v e (seq_assoc Skip q))) /\ + (seq_assoc p (Seq q r) = seq_assoc (seq_assoc p q) r) /\ + (seq_assoc p (If e q r) = + SmartSeq p (If e (seq_assoc Skip q) (seq_assoc Skip r))) /\ + (seq_assoc p (While e q) = + SmartSeq p (While e (seq_assoc Skip q))) /\ + (seq_assoc p (Call Tail name args) = + SmartSeq p (Call Tail name args)) /\ + (seq_assoc p (Call (Ret rv exp) name args) = + SmartSeq p (Call + (dtcase exp of + | NONE => Ret rv NONE + | SOME (Handle eid ev ep) => + Ret rv (SOME (Handle eid ev (seq_assoc Skip ep)))) + name args)) /\ + (seq_assoc p q = SmartSeq p q) +End + +Definition seq_call_ret_def: + seq_call_ret prog = + dtcase prog of + | Seq (RetCall rv NONE trgt args) (Return (Var rv')) => + if rv = rv' then (TailCall trgt args) else prog + | other => other +End + +Definition ret_to_tail_def: + (ret_to_tail Skip = Skip) /\ + (ret_to_tail (Dec v e q) = Dec v e (ret_to_tail q)) /\ + (ret_to_tail (Seq p q) = + seq_call_ret (Seq (ret_to_tail p) (ret_to_tail q))) /\ + (ret_to_tail (If e p q) = If e (ret_to_tail p) (ret_to_tail q)) /\ + (ret_to_tail (While e p) = While e (ret_to_tail p)) /\ + (ret_to_tail (Call Tail name args) = Call Tail name args) /\ + (ret_to_tail (Call (Ret rv exp) name args) = + Call + (dtcase exp of + | NONE => Ret rv NONE + | (SOME (Handle eid ev ep)) => + Ret rv (SOME (Handle eid ev (ret_to_tail ep)))) + name args) /\ + (ret_to_tail p = p) +End + +Definition compile_def: + compile p = + let p = seq_assoc Skip p in + ret_to_tail p +End + +Definition compile_prog_def: + compile_prog prog = + MAP (λ(name, params, body). + (name, + params, + compile body)) prog +End + + +Theorem seq_assoc_pmatch: + !p prog. + seq_assoc p prog = + case prog of + | Skip => p + | (Dec v e q) => SmartSeq p (Dec v e (seq_assoc Skip q)) + | (Seq q r) => seq_assoc (seq_assoc p q) r + | (If e q r) => + SmartSeq p (If e (seq_assoc Skip q) (seq_assoc Skip r)) + | (While e q) => + SmartSeq p (While e (seq_assoc Skip q)) + | (Call rtyp name args) => + SmartSeq p (Call + (dtcase rtyp of + | Tail => Tail + | Ret rv NONE => Ret rv NONE + | Ret rv (SOME (Handle eid ev ep)) => + Ret rv (SOME (Handle eid ev (seq_assoc Skip ep)))) + name args) + | q => SmartSeq p q +Proof + rpt strip_tac >> + CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> + every_case_tac >> fs[seq_assoc_def] +QED + +Theorem ret_to_tail_pmatch: + !p. + ret_to_tail p = + case p of + | Skip => Skip + | (Dec v e q) => Dec v e (ret_to_tail q) + | (Seq q r) => seq_call_ret (Seq (ret_to_tail q) (ret_to_tail r)) + | (If e q r) => + If e (ret_to_tail q) (ret_to_tail r) + | (While e q) => + While e (ret_to_tail q) + | (Call rtyp name args) => + Call + (dtcase rtyp of + | Tail => Tail + | Ret rv NONE => Ret rv NONE + | Ret rv (SOME (Handle eid ev ep)) => + Ret rv (SOME (Handle eid ev (ret_to_tail ep)))) + name args + | p => p +Proof + rpt strip_tac >> + CONV_TAC(RAND_CONV patternMatchesLib.PMATCH_ELIM_CONV) >> + every_case_tac >> fs[ret_to_tail_def] +QED + +val _ = export_theory(); diff --git a/pancake/pan_to_crepScript.sml b/pancake/pan_to_crepScript.sml new file mode 100644 index 0000000000..4708887ecf --- /dev/null +++ b/pancake/pan_to_crepScript.sml @@ -0,0 +1,302 @@ +(* + Compilation from panLang to crepLang. +*) +open preamble pan_commonTheory panLangTheory crepLangTheory + +val _ = new_theory "pan_to_crep" + +val _ = set_grammar_ancestry ["pan_common", "panLang","crepLang", "backend_common"]; + +Datatype: + context = + <| vars : panLang$varname |-> shape # num list; + funcs : panLang$funname |-> (panLang$varname # shape) list; + eids : panLang$eid |-> 'a word; + vmax : num|> +End + +(* using this style to avoid using HD for code extraction later *) +Definition cexp_heads_def: + (cexp_heads [] = SOME []) /\ + (cexp_heads (e::es) = + case (e,cexp_heads es) of + | [], _ => NONE + | _ , NONE => NONE + | x::xs, SOME ys => SOME (x::ys)) +End + +Definition comp_field_def: + (comp_field i [] es = ([Const 0w], One)) ∧ + (comp_field i (sh::shs) es = + if i = (0:num) then (TAKE (size_of_shape sh) es, sh) + else comp_field (i-1) shs (DROP (size_of_shape sh) es)) +End + +Definition compile_exp_def: + (compile_exp ctxt ((Const c):'a panLang$exp) = + ([(Const c): 'a crepLang$exp], One)) /\ + (compile_exp ctxt (Var vname) = + case FLOOKUP ctxt.vars vname of + | SOME (shape, ns) => (MAP Var ns, shape) + | NONE => ([Const 0w], One)) /\ + (compile_exp ctxt (Label fname) = ([Label fname], One)) /\ + (compile_exp ctxt (Struct es) = + let cexps = MAP (compile_exp ctxt) es in + (FLAT (MAP FST cexps), Comb (MAP SND cexps))) /\ + (compile_exp ctxt (Field index e) = + let (cexp, shape) = compile_exp ctxt e in + case shape of + | One => ([Const 0w], One) + | Comb shapes => comp_field index shapes cexp) /\ + (compile_exp ctxt (Load sh e) = + let (cexp, shape) = compile_exp ctxt e in + case cexp of + | e::es => (load_shape (0w) (size_of_shape sh) e, sh) + | _ => ([Const 0w], One)) /\ + (compile_exp ctxt (LoadByte e) = + let (cexp, shape) = compile_exp ctxt e in + case (cexp, shape) of + | (e::es, One) => ([LoadByte e], One) + | (_, _) => ([Const 0w], One)) /\ + (* have a check here for the shape *) + (compile_exp ctxt (Op bop es) = + let cexps = MAP FST (MAP (compile_exp ctxt) es) in + case cexp_heads cexps of + | SOME es => ([Op bop es], One) + | _ => ([Const 0w], One)) /\ + (compile_exp ctxt (Cmp cmp e e') = + let ce = FST (compile_exp ctxt e); + ce' = FST (compile_exp ctxt e') in + case (ce, ce') of + | (e::es, e'::es') => ([Cmp cmp e e'], One) + | (_, _) => ([Const 0w], One)) /\ + (compile_exp ctxt (Shift sh e n) = + case FST (compile_exp ctxt e) of + | [] => ([Const 0w], One) + | e::es => ([Shift sh e n], One)) +Termination + wf_rel_tac `measure (\e. panLang$exp_size ARB (SND e))` >> + rpt strip_tac >> + imp_res_tac panLangTheory.MEM_IMP_exp_size >> + TRY (first_x_assum (assume_tac o Q.SPEC `ARB`)) >> + decide_tac +End + +Definition exp_hdl_def: + exp_hdl fm v = + case FLOOKUP fm v of + | NONE => Skip + | SOME (vshp, ns) => nested_seq + (MAP2 Assign ns (load_globals 0w (LENGTH ns))) +End + +Definition ret_var_def: + (ret_var One ns = oHD ns) /\ + (ret_var (Comb sh) ns = + if size_of_shape (Comb sh) = 1 then oHD ns + else NONE) +End + +Definition ret_hdl_def: + (ret_hdl One ns = Skip) /\ + (ret_hdl (Comb sh) ns = + if 1 < size_of_shape (Comb sh) then (assign_ret ns) + else Skip) +End + +(* defining it with inner case to enable rewriting later *) +Definition wrap_rt_def: + wrap_rt n = + case n of + | NONE => NONE + | SOME (One, []) => NONE + | m => m +End + +Definition compile_def: + (compile _ (Skip:'a panLang$prog) = (Skip:'a crepLang$prog)) /\ + (compile ctxt (Dec v e p) = + let (es, sh) = compile_exp ctxt e; + vmax = ctxt.vmax; + nvars = GENLIST (λx. vmax + SUC x) (size_of_shape sh); + nctxt = ctxt with <|vars := ctxt.vars |+ (v, (sh, nvars)); + vmax := ctxt.vmax + size_of_shape sh|> in + if size_of_shape sh = LENGTH es + then nested_decs nvars es (compile nctxt p) + else Skip) /\ + (compile ctxt (Assign v e) = + let (es, sh) = compile_exp ctxt e in + case FLOOKUP ctxt.vars v of + | SOME (vshp, ns) => + if LENGTH ns = LENGTH es + then if distinct_lists ns (FLAT (MAP var_cexp es)) + then nested_seq (MAP2 Assign ns es) + else let vmax = ctxt.vmax; + temps = GENLIST (λx. vmax + SUC x) (LENGTH ns) in + nested_decs temps es + (nested_seq (MAP2 Assign ns (MAP Var temps))) + else Skip:'a crepLang$prog + | NONE => Skip) /\ + (compile ctxt (Store ad v) = + case compile_exp ctxt ad of + | (e::es',sh') => + let (es,sh) = compile_exp ctxt v; + adv = ctxt.vmax + 1; + temps = GENLIST (λx. adv + SUC x) (size_of_shape sh) in + if size_of_shape sh = LENGTH es + then nested_decs (adv::temps) (e::es) + (nested_seq (stores (Var adv) (MAP Var temps) 0w)) + else Skip + | (_,_) => Skip) /\ + (compile ctxt (StoreByte dest src) = + case (compile_exp ctxt dest, compile_exp ctxt src) of + | (ad::ads, _), (e::es, _) => StoreByte ad e + | _ => Skip) /\ + (compile ctxt (Return rt) = + let (ces,sh) = compile_exp ctxt rt in + if size_of_shape sh = 0 then Return (Const 0w) + else case ces of + | [] => Skip + | e::es => if size_of_shape sh = 1 then (Return e) else + let temps = GENLIST (λx. ctxt.vmax + SUC x) (size_of_shape sh) in + if size_of_shape sh = LENGTH (e::es) + then Seq (nested_decs temps (e::es) + (nested_seq (store_globals 0w (MAP Var temps)))) (Return (Const 0w)) + else Skip) /\ + (compile ctxt (Raise eid excp) = + case FLOOKUP ctxt.eids eid of + | SOME n => + let (ces,sh) = compile_exp ctxt excp; + temps = GENLIST (λx. ctxt.vmax + SUC x) (size_of_shape sh) in + if size_of_shape sh = LENGTH ces + then Seq (nested_decs temps ces (nested_seq (store_globals 0w (MAP Var temps)))) + (Raise n) + else Skip + | NONE => Skip) /\ + (compile ctxt (Seq p p') = + Seq (compile ctxt p) (compile ctxt p')) /\ + (compile ctxt (If e p p') = + case compile_exp ctxt e of + | (ce::ces, _) => + If ce (compile ctxt p) (compile ctxt p') + | _ => Skip) /\ + (compile ctxt (While e p) = + case compile_exp ctxt e of + | (ce::ces, _) => + While ce (compile ctxt p) + | _ => Skip) /\ + (compile ctxt Break = Break) /\ + (compile ctxt Continue = Continue) /\ + (compile ctxt (Call rtyp e es) = + let (cs, sh) = compile_exp ctxt e; + cexps = MAP (compile_exp ctxt) es; + args = FLAT (MAP FST cexps) in + case cs of + | ce::ces => + (case rtyp of + | Tail => Call Tail ce args + | Ret rt hdl => + (case wrap_rt (FLOOKUP ctxt.vars rt) of + | NONE => + (case hdl of + | NONE => Call Tail ce args + | SOME (Handle eid evar p) => + (case FLOOKUP ctxt.eids eid of + | NONE => Call Tail ce args + | SOME neid => + let comp_hdl = compile ctxt p; + hndlr = Seq (exp_hdl ctxt.vars evar) comp_hdl in + Call (Ret NONE Skip (SOME (Handle neid hndlr))) ce args)) + | SOME (sh, ns) => + (case hdl of + | NONE => Call (Ret (ret_var sh ns) (ret_hdl sh ns) NONE) ce args + | SOME (Handle eid evar p) => + (case FLOOKUP ctxt.eids eid of + | NONE => Call (Ret (ret_var sh ns) (ret_hdl sh ns) NONE) ce args + | SOME neid => + let comp_hdl = compile ctxt p; + hndlr = Seq (exp_hdl ctxt.vars evar) comp_hdl in + Call (Ret (ret_var sh ns) (ret_hdl sh ns) + (SOME (Handle neid hndlr))) ce args)))) + | [] => Skip) /\ + (compile ctxt (ExtCall f ptr1 len1 ptr2 len2) = + case (FLOOKUP ctxt.vars ptr1, FLOOKUP ctxt.vars len1, + FLOOKUP ctxt.vars ptr2, FLOOKUP ctxt.vars len2) of + | (SOME (One, pc::pcs), SOME (One, lc::lcs), + SOME (One, pc'::pcs'), SOME (One, lc'::lcs')) => ExtCall f pc lc pc' lc' + | _ => Skip) /\ + (compile ctxt Tick = Tick) +End + + +Definition mk_ctxt_def: + mk_ctxt vmap fs m (es:panLang$eid |-> 'a word) = + <|vars := vmap; + funcs := fs; + eids := es; + vmax := m|> +End + +(* +Definition shape_vars_def: + (shape_vars [] ns = []) ∧ + (shape_vars (sh::shs) ns = (sh, TAKE (size_of_shape sh) ns) :: + shape_vars shs (DROP (size_of_shape sh) ns)) +End +*) + +(* params : (varname # shape) list *) +Definition make_vmap_def: + make_vmap params = + let pvars = MAP FST params; + shs = MAP SND params; + ns = GENLIST I (size_of_shape (Comb shs)); + (* defining in this way to make proof in sync with "with_shape" *) + cvars = ZIP (shs, with_shape shs ns) in + FEMPTY |++ ZIP (pvars, cvars) +End + +Definition comp_func_def: + comp_func fs eids params body = + let vmap = make_vmap params; + shapes = MAP SND params; + vmax = size_of_shape (Comb shapes) - 1 in + compile (mk_ctxt vmap fs vmax eids) body +End + +Definition get_eids_def: + get_eids prog = + let eids = remove_dup (FLAT (MAP (exp_ids o SND o SND) prog)); + ns = GENLIST (λx. n2w x) (LENGTH eids); + es = MAP2 (λx y. (x,y)) eids ns in + alist_to_fmap es +End + + +Definition make_funcs_def: + make_funcs prog = + let fnames = MAP FST prog; + params = MAP (FST o SND) prog; + fs = MAP2 (λx y. (x,y)) fnames params in + alist_to_fmap fs +End + + +Definition crep_vars_def: + crep_vars params = + let shapes = MAP SND params; + len = size_of_shape (Comb shapes) in + GENLIST I len +End + + +Definition compile_prog_def: + compile_prog prog = + let comp = comp_func (make_funcs prog) (get_eids prog) in + MAP (λ(name, params, body). + (name, + crep_vars params, + comp params body)) prog +End + +val _ = export_theory(); diff --git a/pancake/pan_to_wordScript.sml b/pancake/pan_to_wordScript.sml new file mode 100644 index 0000000000..26db18c4dd --- /dev/null +++ b/pancake/pan_to_wordScript.sml @@ -0,0 +1,21 @@ +(* + Correctness proof for -- +*) + +open preamble + pan_simpTheory pan_to_crepTheory + crep_to_loopTheory loop_to_wordTheory + +val _ = new_theory "pan_to_word"; + + +Definition compile_prog_def: + compile_prog prog = + let prog = pan_simp$compile_prog prog; + prog = pan_to_crep$compile_prog prog; + prog = crep_to_loop$compile_prog prog in + loop_to_word$compile prog +End + + +val _ = export_theory(); diff --git a/pancake/proofs/Holmakefile b/pancake/proofs/Holmakefile new file mode 100644 index 0000000000..5fb3b66f3e --- /dev/null +++ b/pancake/proofs/Holmakefile @@ -0,0 +1,16 @@ +INCLUDES = $(HOLDIR)/examples/machine-code/multiword\ + $(CAKEMLDIR)/misc\ + $(CAKEMLDIR)/basis/pure\ + $(CAKEMLDIR)/compiler/backend/\ + $(CAKEMLDIR)/compiler/encoders/asm\ + $(CAKEMLDIR)/pancake\ + $(CAKEMLDIR)/pancake/semantics + + +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) diff --git a/pancake/proofs/README.md b/pancake/proofs/README.md new file mode 100644 index 0000000000..1694dda33d --- /dev/null +++ b/pancake/proofs/README.md @@ -0,0 +1,28 @@ +Proofs files for compiling Pancake. + +[crep_to_loopProofScript.sml](crep_to_loopProofScript.sml): +Correctness proof for --- + +[loop_callProofScript.sml](loop_callProofScript.sml): +loop_call proof + +[loop_liveProofScript.sml](loop_liveProofScript.sml): +Correctness proof for loop_live + +[loop_removeProofScript.sml](loop_removeProofScript.sml): +Correctness proof for loop_remove + +[loop_to_wordProofScript.sml](loop_to_wordProofScript.sml): +Correctness proof for loop_to_word + +[pan_simpProofScript.sml](pan_simpProofScript.sml): +Correctness proof for pan_simp + +[pan_to_crepProofScript.sml](pan_to_crepProofScript.sml): +Correctness proof for -- + +[pan_to_wordProofScript.sml](pan_to_wordProofScript.sml): +Correctness proof for -- + +[time_to_panProofScript.sml](time_to_panProofScript.sml): +Correctness proof for -- diff --git a/pancake/proofs/crep_to_loopProofScript.sml b/pancake/proofs/crep_to_loopProofScript.sml new file mode 100644 index 0000000000..0ce6a6eb8c --- /dev/null +++ b/pancake/proofs/crep_to_loopProofScript.sml @@ -0,0 +1,5437 @@ +(* + Correctness proof for --- +*) + +open preamble + crepSemTheory crepPropsTheory + loopLangTheory loopSemTheory loopPropsTheory + pan_commonTheory pan_commonPropsTheory + listRangeTheory rich_listTheory + loop_liveProofTheory crep_to_loopTheory + +val _ = new_theory "crep_to_loopProof"; + +val _ = set_grammar_ancestry + ["listRange", "rich_list", "crepProps", + "loopProps", "pan_commonProps", + "loop_liveProof", "crep_to_loop"]; + + +Theorem evaluate_nested_seq_append_first = +evaluate_nested_seq_cases |> CONJUNCT1 +Theorem evaluate_none_nested_seq_append = + evaluate_nested_seq_cases |> CONJUNCT2 |> CONJUNCT1 +Theorem evaluate_not_none_nested_seq_append = + evaluate_nested_seq_cases |> CONJUNCT2 |> CONJUNCT2 + +(* state relation *) + +val s = ``(s:('a,'ffi) crepSem$state)`` + +Definition state_rel_def: + state_rel (s:('a,'ffi) crepSem$state) (t:('a,'ffi) loopSem$state) <=> + s.memaddrs = t.mdomain ∧ + s.clock = t.clock ∧ + s.be = t.be ∧ + s.ffi = t.ffi +End + +(* + Loc encodes label of a function, e.g: + Loc n1 n2 represents the label n2 + inside the function n1 +*) + +Definition wlab_wloc_def: + (wlab_wloc _ (Word w) = Word w) /\ + (wlab_wloc funcs (Label fname) = + case FLOOKUP funcs fname of + | SOME (n, _) => Loc n 0 + | NONE => Loc 0 0) (* impossible *) +End + +Definition mem_rel_def: + mem_rel funcs smem tmem <=> + !ad. wlab_wloc funcs (smem ad) = tmem ad /\ + !f. smem ad = Label f ==> + ?n m. FLOOKUP funcs f = SOME (n, m) +End + +Definition globals_rel_def: + globals_rel funcs sglobals tglobals <=> + !ad v. FLOOKUP sglobals ad = SOME v ==> + FLOOKUP tglobals ad = SOME (wlab_wloc funcs v) /\ + !f. v = Label f ==> + ?n m. FLOOKUP funcs f = SOME (n, m) +End + +Definition distinct_funcs_def: + distinct_funcs fm <=> + !x y n m rm rm'. FLOOKUP fm x = SOME (n, rm) /\ + FLOOKUP fm y = SOME (m, rm') /\ n = m ==> x = y +End + +(* could have been stated differently *) +Definition ctxt_fc_def: + ctxt_fc cvs ns args = + <|vars := FEMPTY |++ ZIP (ns, args); + funcs := cvs; + vmax := list_max args|> +End + +Definition code_rel_def: + code_rel ctxt s_code t_code <=> + distinct_funcs ctxt.funcs /\ + ∀f ns prog. + FLOOKUP s_code f = SOME (ns, prog) ==> + ?loc len. FLOOKUP ctxt.funcs f = SOME (loc, len) /\ + LENGTH ns = len /\ + let args = GENLIST I len; + nctxt = ctxt_fc ctxt.funcs ns args in + lookup loc t_code = + SOME (args, + ocompile nctxt (list_to_num_set args) prog) +End + +Definition ctxt_max_def: + ctxt_max (n:num) fm <=> + !v m. FLOOKUP fm v = SOME m ==> m <= n +End + +Definition distinct_vars_def: + distinct_vars fm <=> + (!x y n m. FLOOKUP fm x = SOME n /\ + FLOOKUP fm y = SOME m /\ n = m ==> x = y) +End + +Definition locals_rel_def: + locals_rel ctxt (l:sptree$num_set) (s_locals:num |-> 'a word_lab) t_locals <=> + distinct_vars ctxt.vars /\ ctxt_max ctxt.vmax ctxt.vars /\ domain l ⊆ domain t_locals /\ + ∀vname v. + FLOOKUP s_locals vname = SOME v ==> + ∃n. FLOOKUP ctxt.vars vname = SOME n ∧ n ∈ domain l ∧ + lookup n t_locals = SOME (wlab_wloc ctxt.funcs v) /\ + !f. v = Label f ==> + ?n m. FLOOKUP ctxt.funcs f = SOME (n, m) +End + +val goal = + ``λ(prog, s). ∀res s1 t ctxt l. + evaluate (prog,s) = (res,s1) ∧ res ≠ SOME Error ∧ + state_rel s t ∧ mem_rel ctxt.funcs s.memory t.memory ∧ + globals_rel ctxt.funcs s.globals t.globals ∧ + code_rel ctxt s.code t.code ∧ + locals_rel ctxt l s.locals t.locals ⇒ + ∃ck res1 t1. evaluate (compile ctxt l prog, + t with clock := t.clock + ck) = (res1,t1) /\ + state_rel s1 t1 ∧ mem_rel ctxt.funcs s1.memory t1.memory ∧ + globals_rel ctxt.funcs s1.globals t1.globals ∧ + code_rel ctxt s1.code t1.code ∧ + case res of + | NONE => res1 = NONE /\ locals_rel ctxt l s1.locals t1.locals + + | SOME Break => res1 = SOME Break /\ + locals_rel ctxt l s1.locals t1.locals + | SOME Continue => res1 = SOME Continue /\ + locals_rel ctxt l s1.locals t1.locals + | SOME (Return v) => res1 = SOME (Result (wlab_wloc ctxt.funcs v)) /\ + (!f. v = Label f ==> f ∈ FDOM ctxt.funcs) + | SOME (Exception eid) => res1 = SOME (Exception (Word eid)) + | SOME TimeOut => res1 = SOME TimeOut + | SOME (FinalFFI f) => res1 = SOME (FinalFFI f) + | SOME Error => F`` + +local + val ind_thm = crepSemTheory.evaluate_ind + |> ISPEC goal + |> CONV_RULE (DEPTH_CONV PairRules.PBETA_CONV) |> REWRITE_RULE []; + fun list_dest_conj tm = if not (is_conj tm) then [tm] else let + val (c1,c2) = dest_conj tm in list_dest_conj c1 @ list_dest_conj c2 end + val ind_goals = ind_thm |> concl |> dest_imp |> fst |> list_dest_conj +in + fun get_goal s = first (can (find_term (can (match_term (Term [QUOTE s]))))) ind_goals + fun compile_prog_tm () = ind_thm |> concl |> rand + fun the_ind_thm () = ind_thm +end + +Theorem state_rel_intro: + state_rel ^s (t:('a,'ffi) loopSem$state) <=> + s.memaddrs = t.mdomain ∧ + s.clock = t.clock ∧ + s.be = t.be ∧ + s.ffi = t.ffi +Proof + rw [state_rel_def] +QED + +Theorem locals_rel_intro: + locals_rel ctxt l (s_locals:num |-> 'a word_lab) t_locals ==> + distinct_vars ctxt.vars /\ ctxt_max ctxt.vmax ctxt.vars /\ domain l ⊆ domain t_locals /\ + ∀vname v. + FLOOKUP s_locals vname = SOME v ==> + ∃n. FLOOKUP ctxt.vars vname = SOME n ∧ n ∈ domain l ∧ + lookup n t_locals = SOME (wlab_wloc ctxt.funcs v) /\ + !f. v = Label f ==> + ?n m. FLOOKUP ctxt.funcs f = SOME (n, m) +Proof + rw [locals_rel_def] +QED + +Theorem code_rel_intro: + code_rel ctxt s_code t_code ==> + distinct_funcs ctxt.funcs /\ + ∀f ns prog. + FLOOKUP s_code f = SOME (ns, prog) ==> + ?loc len. FLOOKUP ctxt.funcs f = SOME (loc, len) /\ + LENGTH ns = len /\ + let args = GENLIST I len; + nctxt = ctxt_fc ctxt.funcs ns args in + lookup loc t_code = + SOME (args, + ocompile nctxt (list_to_num_set args) prog) +Proof + rw [code_rel_def] +QED + +Theorem mem_rel_intro: + mem_rel funcs smem tmem ==> + !ad. wlab_wloc funcs (smem ad) = tmem ad /\ + !f. smem ad = Label f ==> + ?n m. FLOOKUP funcs f = SOME (n, m) +Proof + rw [mem_rel_def] >> + metis_tac [] +QED + +Theorem globals_rel_intro: + globals_rel funcs sglobals tglobals ==> + !ad v. FLOOKUP sglobals ad = SOME v ==> + FLOOKUP tglobals ad = SOME (wlab_wloc funcs v) /\ + !f. v = Label f ==> + ?n m. FLOOKUP funcs f = SOME (n, m) +Proof + rw [globals_rel_def] >> metis_tac [] +QED + +Theorem state_rel_clock_add_zero: + !s t. state_rel s t ==> + ?ck. state_rel s (t with clock := ck + t.clock) +Proof + rw [] >> + qexists_tac ‘0’ >> + fs [state_rel_def, state_component_equality] +QED + +Theorem locals_rel_insert_gt_vmax: + !ct cset lcl lcl' n w. + locals_rel ct cset lcl lcl' /\ ct.vmax < n ==> + locals_rel ct cset lcl (insert n w lcl') +Proof + rw [] >> + fs [locals_rel_def, SUBSET_INSERT_RIGHT, AllCaseEqs(), + lookup_insert, ctxt_max_def] >> + rw [] >> rpt (res_tac >> fs []) +QED + +Theorem locals_rel_cutset_prop: + !ct cset lcl lcl' cset' lcl''. + locals_rel ct cset lcl lcl' /\ + locals_rel ct cset' lcl lcl'' /\ + subspt cset cset' ==> + locals_rel ct cset lcl lcl'' +Proof + rw [locals_rel_def] + >- metis_tac [subspt_domain, SUBSET_TRANS] >> + res_tac >> fs [] >> rveq >> fs [] +QED + +Theorem write_bytearray_mem_rel: + !nb funcs sm tm w dm be. + mem_rel funcs sm tm ==> + mem_rel funcs (write_bytearray w nb sm dm be) + (write_bytearray w nb tm dm be) +Proof + Induct >> + rw [panSemTheory.write_bytearray_def, + wordSemTheory.write_bytearray_def] >> + TOP_CASE_TAC >> fs [] + >- ( + ‘mem_store_byte_aux (write_bytearray (w + 1w) nb tm dm be) dm be + w h = NONE’ suffices_by fs [] >> + fs [panSemTheory.mem_store_byte_def, + wordSemTheory.mem_store_byte_aux_def, + CaseEq "word_lab", CaseEq "option"] + >- (TOP_CASE_TAC >> fs []) >> + first_x_assum drule >> + disch_then (qspecl_then [‘w+1w’, ‘dm’, ‘be’] mp_tac) >> + strip_tac >> fs [] >> + last_x_assum kall_tac >> + fs [mem_rel_def] >> + first_x_assum (qspec_then ‘byte_align w’ mp_tac) >> + strip_tac >> + rfs [] >> pop_assum mp_tac >> + pop_assum (mp_tac o GSYM) >> + rw [] >> fs [wlab_wloc_def]) >> + fs [panSemTheory.mem_store_byte_def, + wordSemTheory.mem_store_byte_aux_def, + CaseEq "word_lab", CaseEq "option"] >> + rveq >> + first_x_assum drule >> + disch_then (qspecl_then [‘w+1w’, ‘dm’, ‘be’] mp_tac) >> + strip_tac >> fs [] >> + fs [mem_rel_def] >> + rw [] + >- ( + fs [APPLY_UPDATE_THM] >> + TOP_CASE_TAC >> fs [] + >- ( + first_x_assum (qspec_then ‘ad’ assume_tac) >> + rfs [] >> pop_assum (assume_tac o GSYM) >> + fs [] >> + fs [wlab_wloc_def] >> + fs [APPLY_UPDATE_THM]) >> + TOP_CASE_TAC >> fs [CaseEq "word_loc", CaseEq "option"] + >- ( + first_x_assum (qspec_then ‘byte_align w’ assume_tac) >> + rfs [wlab_wloc_def]) >> + rveq >> fs [APPLY_UPDATE_THM]) >> + fs [APPLY_UPDATE_THM] >> + FULL_CASE_TAC >> fs [] >> + res_tac >> fs [] +QED + +(* +Theorem mem_rel_ctxt_vmax_preserve: + mem_rel (ctxt with vmax := m) s.memory t.memory ==> + mem_rel ctxt s.memory t.memory +Proof + rw [mem_rel_def] >> + fs [] >> + first_x_assum (qspec_then ‘ad’ assume_tac) >> + fs [] >> + cases_on ‘s.memory ad’ >> + cases_on ‘t.memory ad’ >> + fs [wlab_wloc_def] +QED + + +Theorem globals_rel_ctxt_vmax_preserve: + globals_rel (ctxt with vmax := m) s.globals t.globals ==> + globals_rel ctxt s.globals t.globals +Proof + rw [globals_rel_def] >> + fs [] >> + TRY (cases_on ‘v’) >> + fs [wlab_wloc_def] >> + res_tac >> fs [wlab_wloc_def] +QED +*) + +Theorem evaluate_comb_seq: + !p s t q r. + loopSem$evaluate (p,s) = (NONE, t) /\ loopSem$evaluate (q,t) = (NONE,r) ==> + loopSem$evaluate (Seq p q,s) = (NONE,r) +Proof + rw [] >> + fs [evaluate_def] +QED + + +Theorem compile_exp_out_rel_cases: + (!ct tmp l (e:'a crepLang$exp) p le ntmp nl. + compile_exp ct tmp l e = (p,le,ntmp, nl) ==> + comp_syntax_ok l (nested_seq p) /\ tmp <= ntmp /\ nl = cut_sets l (nested_seq p)) /\ + (!ct tmp l (e:'a crepLang$exp list) p le ntmp nl. + compile_exps ct tmp l e = (p,le,ntmp, nl) ==> + comp_syntax_ok l (nested_seq p) /\ tmp <= ntmp /\ nl = cut_sets l (nested_seq p) /\ + LENGTH le = LENGTH e) +Proof + ho_match_mp_tac compile_exp_ind >> + rpt conj_tac >> rpt gen_tac >> strip_tac >> + TRY ( + fs [Once compile_exp_def] >> rveq >> + TRY (pairarg_tac >> fs [] >> rveq >> NO_TAC) >> + fs [nested_seq_def, comp_syn_ok_basic_cases, cut_sets_def] >> NO_TAC) + >- ( + rename [‘compile_exp _ _ _ (Label f)’] >> + fs [compile_exp_def] >> rveq >> + fs [nested_seq_def, cut_sets_def] >> + match_mp_tac comp_syn_ok_seq2 >> + fs [comp_syn_ok_basic_cases]) + >- ( + rename [‘compile_exp _ _ _ (LoadByte e)’] >> + rpt gen_tac >> strip_tac >> + conj_asm1_tac + >- ( + fs [compile_exp_def] >> + pairarg_tac >> fs [] >> rveq >> fs [] >> + match_mp_tac comp_syn_ok_nested_seq >> + fs [] >> + fs [nested_seq_def] >> + rpt ( + match_mp_tac comp_syn_ok_seq2 >> + fs [comp_syn_ok_basic_cases])) >> + fs [compile_exp_def] >> + pairarg_tac >> fs [] >> rveq >> + res_tac >> fs [] >> + imp_res_tac comp_syn_ok_nested_seq2 >> + last_x_assum assume_tac >> + qmatch_goalsub_abbrev_tac ‘p' ++ np’ >> + fs [cut_sets_nested_seq] >> + fs [Abbr ‘np’] >> pop_assum kall_tac >> + fs [nested_seq_def, cut_sets_def, Once insert_insert]) + >- ( + rename [‘compile_exp _ _ _ (Op _ _)’] >> + fs [Once compile_exp_def] >> + pairarg_tac >> fs [] >> rveq >> + cases_on ‘e’ + >- fs [compile_exp_def] >> + fs [] >> + fs [Once compile_exp_def]) + >- ( + rename [‘compile_exp _ _ _ (Cmp _ _ _)’] >> + rpt gen_tac >> strip_tac >> + fs [compile_exp_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> rveq >> + conj_tac + >- ( + fs [prog_if_def] >> + match_mp_tac comp_syn_ok_nested_seq >> + conj_tac + >- ( + match_mp_tac comp_syn_ok_nested_seq >> + fs []) >> + fs [list_insert_def, nested_seq_def, cut_sets_def] >> + rpt (match_mp_tac comp_syn_ok_seq2 >> + fs [comp_syn_ok_basic_cases]) >> + fs [cut_sets_def] >> + rw [Once comp_syntax_ok_def, list_insert_def] >> + fs [cut_sets_nested_seq] >> + qmatch_goalsub_abbrev_tac ‘insert t2 _ (insert t1 _ cc)’ >> + match_mp_tac EQ_SYM >> + ‘insert t1 () (insert t2 () (insert t1 () cc)) = insert t2 () (insert t1 () cc)’ by ( + ‘insert t2 () (insert t1 () cc) = insert t1 () (insert t2 () cc)’ + by (fs [Abbr ‘t1’, Abbr ‘t2’] >> match_mp_tac insert_swap >> fs []) >> + fs [Abbr ‘t1’, Abbr ‘t2’] >> fs [Once insert_insert]) >> + fs [] >> pop_assum kall_tac >> + fs [Once insert_insert]) >> + conj_tac >- (res_tac >> fs []) >> + res_tac >> fs [] >> + qmatch_goalsub_abbrev_tac ‘list_insert _ ll’ >> + fs [prog_if_def] >> + qmatch_goalsub_abbrev_tac ‘p' ++ p'' ++ np’ >> + ‘comp_syntax_ok l (nested_seq (p' ++ p''))’ by ( + match_mp_tac comp_syn_ok_nested_seq >> + fs []) >> + ‘comp_syntax_ok (cut_sets l (nested_seq (p' ++ p''))) (nested_seq np)’ by ( + fs [Abbr ‘np’, nested_seq_def] >> + ntac 3 (rw [Once comp_syntax_ok_def]) >> + rw [Once comp_syntax_ok_def, cut_sets_def, Abbr ‘l''’, list_insert_def] >> + fs [cut_sets_nested_seq] >> + qmatch_goalsub_abbrev_tac ‘insert t2 _ (insert t1 _ cc)’ >> + match_mp_tac EQ_SYM >> + ‘insert t1 () (insert t2 () (insert t1 () cc)) = insert t2 () (insert t1 () cc)’ by ( + ‘insert t2 () (insert t1 () cc) = insert t1 () (insert t2 () cc)’ + by (fs [Abbr ‘t1’, Abbr ‘t2’] >> match_mp_tac insert_swap >> fs []) >> + fs [Abbr ‘t1’, Abbr ‘t2’] >> fs [Once insert_insert]) >> + fs [] >> pop_assum kall_tac >> + fs [Once insert_insert]) >> + qpat_x_assum ‘comp_syntax_ok l (nested_seq (p' ++ p''))’ assume_tac >> + fs [cut_sets_nested_seq] >> + fs [Abbr ‘np’, nested_seq_def, cut_sets_def]) >> + rpt gen_tac >> + strip_tac >> + cases_on ‘e’ >> fs [] + >- ( + fs [compile_exp_def] >> + rveq >> fs [] >> + fs [nested_seq_def, Once comp_syntax_ok_def, every_prog_def, cut_sets_def]) >> + pop_assum mp_tac >> + once_rewrite_tac [compile_exp_def] >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> rveq >> + cases_on ‘t’ + >- ( + fs [compile_exp_def] >> + strip_tac >> rveq >> fs []) >> + strip_tac >> fs [] >> rveq >> + conj_tac >- metis_tac [subspt_trans, comp_syn_ok_nested_seq] >> + fs [cut_sets_nested_seq] +QED + +Theorem compile_exp_out_rel = compile_exp_out_rel_cases |> CONJUNCT1 +Theorem compile_exps_out_rel = compile_exp_out_rel_cases |> CONJUNCT2 + + +Theorem comp_exp_assigned_vars_tmp_bound_cases: + (!ct tmp l (e :α crepLang$exp) p le ntmp nl n. + compile_exp ct tmp l e = (p,le,ntmp,nl) /\ MEM n (assigned_vars (nested_seq p)) ==> + tmp <= n /\ n < ntmp) /\ + (!ct tmp l (e :α crepLang$exp list) p le ntmp nl n. + compile_exps ct tmp l e = (p,le,ntmp,nl) /\ MEM n (assigned_vars (nested_seq p)) ==> + tmp <= n /\ n < ntmp) +Proof + ho_match_mp_tac compile_exp_ind >> + rpt conj_tac >> rpt gen_tac >> strip_tac >> + TRY ( + fs [Once compile_exp_def] >> TRY (pairarg_tac >> fs []) >> + rveq >> fs [nested_seq_def, assigned_vars_def] >> NO_TAC) + >- ( + rpt gen_tac >> strip_tac >> + fs [compile_exp_def] >> rveq >> + pairarg_tac >> fs [] >> rveq >> + drule compile_exp_out_rel >> + strip_tac >> fs [] >> + fs [assigned_vars_nested_seq_split] + >- (res_tac >> fs []) >> + fs [nested_seq_def, assigned_vars_def]) + >- ( + once_rewrite_tac [compile_exp_def] >> fs [] >> strip_tac >> + pairarg_tac >> fs []) + >- ( + rpt gen_tac >> strip_tac >> + fs [compile_exp_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> rveq >> + fs [prog_if_def] >> + ‘tmp <= tmp' /\ tmp' <= tmp''’ by metis_tac [compile_exp_out_rel_cases] >> + dxrule compile_exp_out_rel >> + dxrule compile_exp_out_rel >> + strip_tac >> fs [] >> + fs [assigned_vars_nested_seq_split] + >- (res_tac >> fs []) + >- (res_tac >> fs []) >> + fs [nested_seq_def] >> + fs [assigned_vars_seq_split, assigned_vars_def]) >> + rpt gen_tac >> strip_tac >> + pop_assum mp_tac >> fs [] >> + once_rewrite_tac [compile_exp_def] >> + cases_on ‘e’ >> fs [] + >- ( + fs [compile_exp_def] >> rveq >> + fs [nested_seq_def, assigned_vars_def]) >> + pop_assum mp_tac >> + once_rewrite_tac [compile_exp_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + strip_tac >> rveq >> fs [] >> + strip_tac >> + ‘tmp <= tmp' /\ tmp' <= ntmp’ by metis_tac [compile_exp_out_rel_cases] >> + fs [assigned_vars_nested_seq_split] >> + res_tac >> fs [] +QED + +Theorem comp_exp_assigned_vars_tmp_bound = comp_exp_assigned_vars_tmp_bound_cases |> CONJUNCT1 +Theorem comp_exps_assigned_vars_tmp_bound = comp_exp_assigned_vars_tmp_bound_cases |> CONJUNCT2 + +Theorem compile_exp_le_tmp_domain_cases: + (!ct tmp l (e:'a crepLang$exp) p le tmp' l' n. + ctxt_max ct.vmax ct.vars /\ + compile_exp ct tmp l e = (p,le,tmp', l') /\ ct.vmax < tmp /\ + (!n. MEM n (var_cexp e) ==> ?m. FLOOKUP ct.vars n = SOME m /\ m ∈ domain l) /\ + MEM n (locals_touched le) ==> n < tmp' /\ n ∈ domain l') /\ + (!ct tmp l (es:'a crepLang$exp list) p les tmp' l' n. + ctxt_max ct.vmax ct.vars /\ + compile_exps ct tmp l es = (p,les,tmp', l') /\ ct.vmax < tmp /\ + (!n. MEM n (FLAT (MAP var_cexp es)) ==> ?m. FLOOKUP ct.vars n = SOME m /\ m ∈ domain l) /\ + MEM n (FLAT (MAP locals_touched les)) ==> n < tmp' /\ n ∈ domain l') +Proof + ho_match_mp_tac compile_exp_ind >> + rpt conj_tac >> rpt gen_tac >> strip_tac >> + TRY ( + rename [‘Op bop es’] >> + rpt gen_tac >> + strip_tac >> + qpat_x_assum ‘compile_exp _ _ _ _ = _’ mp_tac >> + once_rewrite_tac [compile_exp_def] >> + strip_tac >> fs [] >> + pairarg_tac >> fs [] >> rveq >> + fs [locals_touched_def, crepLangTheory.var_cexp_def, ETA_AX]) >> + TRY ( + rename [‘compile_exps’] >> + rpt gen_tac >> + strip_tac >> + qpat_x_assum ‘compile_exps _ _ _ _ = _’ mp_tac >> + once_rewrite_tac [compile_exp_def] >> + cases_on ‘es’ >> fs [] >> rveq + >- ( + strip_tac >> rveq >> + fs [MAP]) >> + strip_tac >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> rveq >> + ‘tmp <= tmp'' /\ tmp'' <= tmp' /\ l'' = cut_sets l (nested_seq p') /\ + l' = cut_sets l'' (nested_seq p1)’ by + metis_tac [compile_exp_out_rel_cases] >> + fs [MAP] + >- ( + res_tac >> fs [subspt_domain] >> + drule compile_exps_out_rel >> + strip_tac >> + drule cut_sets_union_domain_union >> + strip_tac >> fs []) >> + last_x_assum match_mp_tac >> + fs [] >> + rw [] >> + res_tac >> fs [subspt_domain] >> + drule compile_exp_out_rel >> + strip_tac >> + drule cut_sets_union_domain_union >> + strip_tac >> fs [] >> NO_TAC) >> + fs [compile_exp_def] >> + TRY (pairarg_tac >> fs []) >> rveq >> + TRY (pairarg_tac >> fs []) >> rveq >> + fs [locals_touched_def, find_var_def, crepLangTheory.var_cexp_def, + ctxt_max_def, list_insert_def] >> + rfs [] >> rveq >> res_tac >> fs [] +QED + +Theorem compile_exp_le_tmp_domain = compile_exp_le_tmp_domain_cases |> CONJUNCT1 +Theorem compile_exps_le_tmp_domain = compile_exp_le_tmp_domain_cases |> CONJUNCT2 + + +Theorem comp_exp_preserves_eval: + ∀s e v (t :('a, 'b) state) ctxt tmp l p le ntmp nl. + eval s e = SOME v /\ + state_rel s t /\ mem_rel ctxt.funcs s.memory t.memory /\ + globals_rel ctxt.funcs s.globals t.globals /\ + code_rel ctxt s.code t.code /\ + locals_rel ctxt l s.locals t.locals /\ + compile_exp ctxt tmp l e = (p,le, ntmp, nl) /\ + ctxt.vmax < tmp ==> + ?ck st. evaluate (nested_seq p,t with clock := t.clock + ck) = (NONE,st) /\ + eval st le = SOME (wlab_wloc ctxt.funcs v) /\ + state_rel s st /\ mem_rel ctxt.funcs s.memory st.memory /\ + globals_rel ctxt.funcs s.globals st.globals /\ + code_rel ctxt s.code st.code /\ + locals_rel ctxt nl s.locals st.locals +Proof + ho_match_mp_tac crepSemTheory.eval_ind >> + rpt conj_tac >> rpt gen_tac >> strip_tac >> + TRY ( + rename [‘eval s (Op op es)’] >> + rw [] >> + fs [Once compile_exp_def] >> fs [] >> + pairarg_tac >> fs [] >> rveq >> + fs [crepSemTheory.eval_def, CaseEq "option"] >> rveq >> + fs [loopSemTheory.eval_def, wlab_wloc_def] >> + qsuff_tac ‘∃ck st. + evaluate (nested_seq p,t with clock := ck + t.clock) = (NONE,st) ∧ + the_words (MAP (λa. eval st a) les) = + SOME ((MAP (λw. case w of Word n => n | Label v1 => ARB) ws)) /\ + state_rel s st ∧ mem_rel ctxt.funcs s.memory st.memory ∧ + globals_rel ctxt.funcs s.globals st.globals ∧ + code_rel ctxt s.code st.code ∧ locals_rel ctxt l' s.locals st.locals’ + >- ( + strip_tac >> + qexists_tac ‘ck’ >> + fs [wlab_wloc_def]) >> + qpat_x_assum ‘word_op _ _ = _’ kall_tac >> + rpt (pop_assum mp_tac) >> + MAP_EVERY qid_spec_tac [‘t’, ‘p’, ‘les’ , ‘tmp’, ‘l’,‘ws’, ‘es’] >> + Induct + >- ( + rw [] >> + fs [OPT_MMAP_def] >> rveq >> + fs [compile_exp_def] >> rveq >> + fs [nested_seq_def, loopSemTheory.evaluate_def, + wordSemTheory.the_words_def, state_rel_clock_add_zero]) >> + rw [] >> + last_x_assum mp_tac >> + impl_tac >- metis_tac [] >> + strip_tac >> fs [] >> + qpat_x_assum ‘compile_exps _ _ _ (h::_) = _’ mp_tac >> + once_rewrite_tac [compile_exp_def] >> + fs [] >> pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + strip_tac >> rveq >> + fs [OPT_MMAP_def] >> rveq >> + last_x_assum (qspec_then ‘h’ mp_tac) >> + fs [] >> + disch_then drule_all >> + strip_tac >> fs [] >> rveq >> + qmatch_asmsub_rename_tac ‘compile_exp _ _ _ h = (p,le,itmp,il)’ >> + qmatch_asmsub_rename_tac ‘compile_exps _ _ _ _ = (fp,les,ntmp,nl)’ >> + last_x_assum (qspecl_then + [‘t'’, ‘il’, ‘itmp’, ‘les’, ‘fp’, ‘st’] mp_tac) >> + fs [] >> + imp_res_tac compile_exp_out_rel >> + fs [] >> + strip_tac >> fs [] >> + qpat_x_assum ‘evaluate (nested_seq p, _) = _’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck'’ assume_tac) >> + drule evaluate_comb_seq >> + disch_then drule >> + fs [evaluate_nested_seq_comb_seq] >> + strip_tac >> + qexists_tac ‘ck + ck'’ >> + qexists_tac ‘st'’ >> + fs [] >> + cases_on ‘h'’ >> fs [] >> + fs [wordSemTheory.the_words_def] >> + ‘eval st' le = eval st le’ suffices_by fs [wlab_wloc_def] >> + imp_res_tac compile_exps_out_rel >> + qpat_x_assum ‘evaluate (nested_seq fp, _) = _’ assume_tac >> + drule comp_syn_ok_upd_local_clock >> + disch_then drule >> + fs [] >> strip_tac >> + qpat_x_assum ‘evaluate (nested_seq p,_) = _’ mp_tac >> + once_rewrite_tac [ADD_ASSOC] >> + strip_tac >> + fs [wlab_wloc_def] >> + assume_tac nested_seq_pure_evaluation >> + pop_assum (qspecl_then [‘p’, ‘fp’, ‘t’, ‘st'’, ‘st with clock := ck' + st.clock’, ‘l’, + ‘itmp’, ‘le’, ‘Word c’, ‘ck + ck'’, ‘0’] mp_tac) >> + fs [] >> + impl_tac + >- ( + fs [eval_upd_clock_eq] >> + drule comp_exp_assigned_vars_tmp_bound >> fs [] >> + strip_tac >> + drule comp_exps_assigned_vars_tmp_bound >> fs [] >> + strip_tac >> + gen_tac >> + strip_tac >> fs [] >> + imp_res_tac locals_rel_intro >> + drule compile_exp_le_tmp_domain >> + disch_then (qspecl_then [‘tmp’, ‘l’, ‘h’, ‘p’, ‘le’, + ‘itmp’, ‘cut_sets l (nested_seq p)’, ‘n’] mp_tac) >> + fs [] >> + impl_tac + >- ( + rw [] >> + drule eval_some_var_cexp_local_lookup >> + disch_then drule >> + strip_tac >> res_tac >> fs []) >> + fs []) >> + fs []) >> + TRY ( + rename [‘Const w’] >> + fs [crepSemTheory.eval_def, compile_exp_def] >> rveq >> + fs [nested_seq_def, evaluate_def, eval_def, + wlab_wloc_def, state_rel_clock_add_zero]) >> + TRY ( + rename [‘eval s (Var vname)’] >> + fs [crepSemTheory.eval_def, compile_exp_def] >> rveq >> + fs [nested_seq_def, evaluate_def, find_var_def] >> + imp_res_tac locals_rel_intro >> + fs [eval_def, state_rel_clock_add_zero]) >> + TRY ( + rename [‘eval s (Label fname)’] >> + fs [crepSemTheory.eval_def, compile_exp_def, CaseEq "option"] >> + rveq >> + qexists_tac ‘0’ >> fs [] >> + ‘t with clock := t.clock = t’ by fs [state_component_equality] >> + fs [] >> pop_assum kall_tac >> + fs [nested_seq_def, evaluate_def, find_lab_def] >> + cases_on ‘v1’ >> rveq >> + imp_res_tac code_rel_intro >> + fs [eval_def, set_var_def, domain_lookup, wlab_wloc_def, + state_rel_def, locals_rel_def, SUBSET_INSERT_RIGHT] >> + rw [] >> + first_x_assum drule >> fs [] >> + strip_tac >> fs [] >> + fs [lookup_insert] >> + TOP_CASE_TAC >> fs [] >> + fs [ctxt_max_def] >> + first_x_assum drule >> fs []) >> + TRY ( + rename [‘eval s (Load e)’] >> + fs [crepSemTheory.eval_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + rw [] >> + fs [compile_exp_def] >> + pairarg_tac >> fs [] >> rveq >> + last_x_assum drule_all >> fs [] >> rveq >> + strip_tac >> fs [] >> + qexists_tac ‘ck’ >> fs [] >> + fs [loopSemTheory.eval_def, wlab_wloc_def] >> + fs [crepSemTheory.mem_load_def, loopSemTheory.mem_load_def] >> rveq >> + imp_res_tac state_rel_intro >> + imp_res_tac mem_rel_intro >> + last_x_assum (qspec_then ‘c’ mp_tac) >> fs []) >> + TRY ( + rename [‘eval s (LoadByte e)’] >> + fs [crepSemTheory.eval_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + rw [] >> + fs [compile_exp_def] >> + pairarg_tac >> fs [] >> rveq >> + last_x_assum drule_all >> + fs [] >> rveq >> + strip_tac >> fs [] >> + qexists_tac ‘ck’ >> fs [] >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then + ‘[Assign tmp' le'; LoadByte tmp' tmp']’ mp_tac) >> + strip_tac >> fs [] >> + pop_assum kall_tac >> + fs [nested_seq_def, loopSemTheory.evaluate_def] >> + fs [set_var_def, wlab_wloc_def] >> + fs [panSemTheory.mem_load_byte_def, CaseEq "word_lab", + wordSemTheory.mem_load_byte_aux_def] >> + imp_res_tac mem_rel_intro >> + last_x_assum (qspec_then ‘byte_align c’ (mp_tac o GSYM)) >> + strip_tac >> fs [] >> + last_x_assum (qspec_then ‘byte_align c’ (mp_tac o GSYM)) >> + strip_tac >> fs [wlab_wloc_def] >> + imp_res_tac state_rel_intro >> + fs [eval_def, state_rel_def] >> + imp_res_tac compile_exp_out_rel >> + fs [locals_rel_def, SUBSET_INSERT_RIGHT] >> rw [] >> + first_x_assum drule >> fs [] >> + strip_tac >> fs [] >> + fs [lookup_insert] >> + TOP_CASE_TAC >> fs [] >> + fs [ctxt_max_def] >> + first_x_assum drule >> fs []) >> + TRY ( + rename [‘eval s (LoadGlob gadr)’] >> + fs [crepSemTheory.eval_def, compile_exp_def] >> rveq >> + fs [nested_seq_def, loopSemTheory.evaluate_def] >> + fs [eval_def] >> + imp_res_tac globals_rel_intro >> + fs [] >> + qexists_tac ‘0’ >> fs [] >> + ‘t with clock := t.clock = t’ suffices_by fs [] >> + fs [state_component_equality]) >> + TRY ( + rename [‘Shift’] >> + rw [] >> + fs [crepSemTheory.eval_def, CaseEq "option", CaseEq "word_lab", + compile_exp_def] >> + rveq >> fs [] >> + pairarg_tac >> fs [] >> rveq >> + fs [loopSemTheory.evaluate_def] >> + last_x_assum drule_all >> + strip_tac >> rfs [] >> + qexists_tac ‘ck’ >> fs [] >> + fs [loopSemTheory.eval_def, wlab_wloc_def]) >> + rw [] >> + fs [crepSemTheory.eval_def, CaseEq "option", CaseEq "word_lab"] >> + rveq >> fs [compile_exp_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rveq >> fs [] >> + fs [prog_if_def] >> + last_x_assum drule_all >> + strip_tac >> fs [] >> rveq >> + qmatch_asmsub_rename_tac ‘compile_exp _ _ _ e = (p1,le1,tmp1,l1)’ >> + qmatch_asmsub_rename_tac ‘compile_exp _ _ _ e' = (p2,le2,tmp2,l2)’ >> + last_x_assum (qspecl_then [‘st’, ‘ctxt’, ‘tmp1’, ‘l1’] mp_tac) >> + fs [] >> + imp_res_tac compile_exp_out_rel >> fs [] >> rveq >> + strip_tac >> fs [] >> + qmatch_goalsub_abbrev_tac ‘nested_seq (_ ++ _ ++ np)’ >> + qpat_x_assum ‘evaluate (nested_seq p1,_) = _’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck'’ assume_tac) >> + drule evaluate_comb_seq >> + disch_then drule >> + fs [evaluate_nested_seq_comb_seq] >> + strip_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘1’ assume_tac) >> + fs [] >> + qexists_tac ‘ck + ck' + 1’ >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘np’ assume_tac) >> + fs [] >> pop_assum kall_tac >> + fs [Abbr ‘np’, nested_seq_def] >> + fs [evaluate_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> rveq >> + rfs [eval_upd_clock_eq] >> + ‘eval st' le1 = eval st le1’ by ( + qpat_x_assum ‘_ = (_, st)’ assume_tac >> + drule nested_seq_pure_evaluation >> + disch_then (qspecl_then [‘p2’, ‘st'’, ‘l’, ‘tmp1’, ‘le1’, ‘Word w1’, ‘ck'’] mp_tac) >> + fs [wlab_wloc_def] >> + impl_tac + >- ( + imp_res_tac comp_exp_assigned_vars_tmp_bound >> fs [] >> + gen_tac >> + strip_tac >> fs [] >> + imp_res_tac locals_rel_intro >> + drule compile_exp_le_tmp_domain >> + disch_then (qspecl_then [‘tmp’, ‘l’, ‘e’, ‘p1’, ‘le1’, + ‘tmp1’, ‘cut_sets l (nested_seq p1)’, ‘n’] mp_tac) >> + fs [] >> + impl_tac + >- ( + rw [] >> + imp_res_tac eval_some_var_cexp_local_lookup >> + res_tac >> fs []) >> + fs []) >> + fs []) >> + fs [] >> rfs [] >> + pop_assum kall_tac >> + rveq >> + fs [wlab_wloc_def, loopSemTheory.set_var_def, + loopSemTheory.eval_def] >> + fs [Once eval_upd_locals_clock_eq] >> + ‘eval (st' with locals := insert (tmp2 + 1) (Word w1) st'.locals) le2 = + eval st' le2’ by ( + ho_match_mp_tac locals_touched_eq_eval_eq >> + fs [] >> rw [] >> fs [lookup_insert] >> + TOP_CASE_TAC >> fs [] >> + imp_res_tac locals_rel_intro >> + drule compile_exp_le_tmp_domain >> + disch_then (qspecl_then + [‘tmp1’, ‘cut_sets l (nested_seq p1)’, ‘e'’, ‘p2’, ‘le2’, ‘tmp2’, + ‘cut_sets (cut_sets l (nested_seq p1)) (nested_seq p2)’, + ‘n’] mp_tac) >> + impl_tac + >- ( + fs [] >> + rw [] >> + drule_all eval_some_var_cexp_local_lookup >> + strip_tac >> res_tac >> fs [] >> rveq >> fs []) >> + fs []) >> + fs [] >> + pop_assum kall_tac >> + fs [] >> rfs [] >> rveq >> + fs [lookup_insert] >> + fs [get_var_imm_def, list_insert_def] >> + cases_on ‘word_cmp cmp w1 w2’ >> + fs [loopSemTheory.evaluate_def, loopSemTheory.eval_def, + loopSemTheory.set_var_def] >> ( + fs [cut_res_def, list_insert_def] >> + fs [cut_state_def] >> + imp_res_tac locals_rel_intro >> + fs [SUBSET_INSERT_RIGHT] >> + rveq >> fs [dec_clock_def] >> + fs [lookup_inter, lookup_insert] >> + conj_tac >- EVAL_TAC >> + conj_tac >- fs [state_rel_def] >> + fs [list_insert_def, locals_rel_def, domain_inter, SUBSET_INSERT_RIGHT] >> + rw [] >> + fs [lookup_inter, lookup_insert] >> + res_tac >> fs [] >> rveq >> fs [] >> + ‘n <= tmp2’ by (fs [ctxt_max_def] >> res_tac >> fs []) >> + fs [domain_lookup]) +QED + +Theorem comp_exps_preserves_eval: + ∀es s vs (t :('a, 'b) state) ctxt tmp l p les ntmp nl. + OPT_MMAP (eval s) es = SOME vs /\ + state_rel s t /\ mem_rel ctxt.funcs s.memory t.memory /\ + globals_rel ctxt.funcs s.globals t.globals /\ + code_rel ctxt s.code t.code /\ + locals_rel ctxt l s.locals t.locals /\ + compile_exps ctxt tmp l es = (p,les, ntmp, nl) /\ + ctxt.vmax < tmp ==> + ?ck st. evaluate (nested_seq p,t with clock := t.clock + ck) = (NONE,st) /\ + OPT_MMAP (eval st) les = SOME (MAP (wlab_wloc ctxt.funcs) vs) /\ + state_rel s st /\ mem_rel ctxt.funcs s.memory st.memory /\ + globals_rel ctxt.funcs s.globals st.globals /\ + code_rel ctxt s.code st.code /\ + locals_rel ctxt nl s.locals st.locals +Proof + Induct >> rw [] + >- ( + fs [OPT_MMAP_def] >> rveq >> + fs [Once compile_exp_def] >> rveq >> + fs [nested_seq_def] >> + fs [evaluate_def] >> + fs [OPT_MMAP_def] >> + qexists_tac ‘0’ >> fs [state_rel_def]) >> + fs [OPT_MMAP_def] >> rveq >> fs [] >> + pop_assum mp_tac >> + pop_assum mp_tac >> + rewrite_tac [Once compile_exp_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + strip_tac >> strip_tac >> fs [] >> rveq >> + fs [OPT_MMAP_def] >> + drule_all comp_exp_preserves_eval >> + strip_tac >> fs [] >> + first_x_assum drule >> + disch_then (qspecl_then [‘st’, ‘ctxt’, ‘tmp'’ , ‘l'’] mp_tac) >> + fs [] >> + impl_tac + >- ( + imp_res_tac compile_exp_out_rel_cases >> fs []) >> + strip_tac >> fs [] >> + qexists_tac ‘ck + ck'’ >> fs [] >> + qpat_x_assum ‘evaluate (_,_) = (NONE,st)’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck'’ assume_tac) >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘p1’ mp_tac) >> + strip_tac >> fs [] >> + assume_tac nested_seq_pure_evaluation >> + pop_assum (qspecl_then [‘p'’, ‘p1’, ‘t’, ‘st'’, ‘st’, ‘l’, + ‘tmp'’, ‘le’, ‘wlab_wloc ctxt.funcs h'’, ‘ck’, ‘ck'’] mp_tac) >> + fs [] >> + impl_tac + >- ( + imp_res_tac compile_exp_out_rel_cases >> + fs [] >> rveq >> fs [] >> + drule comp_exp_assigned_vars_tmp_bound >> fs [] >> + strip_tac >> + drule comp_exps_assigned_vars_tmp_bound >> fs [] >> + strip_tac >> + gen_tac >> + strip_tac >> fs [] >> + imp_res_tac locals_rel_intro >> + drule compile_exp_le_tmp_domain >> + disch_then (qspecl_then [‘tmp’, ‘l’, ‘h’, ‘p'’, ‘le’, + ‘tmp'’, ‘cut_sets l (nested_seq p')’, ‘n’] mp_tac) >> + fs [] >> + impl_tac + >- ( + rw [] >> + drule eval_some_var_cexp_local_lookup >> + disch_then drule >> + strip_tac >> res_tac >> fs []) >> + fs []) >> + fs [] +QED + + +Theorem member_cutset_survives_comp_exp_cases: + (!ct tmp l (e:'a crepLang$exp) p le ntmp nl n. + n ∈ domain l /\ + compile_exp ct tmp l e = (p,le,ntmp,nl) ==> + survives n (nested_seq p)) /\ + (!ct tmp l (e:'a crepLang$exp list) p le ntmp nl n. + n ∈ domain l /\ + compile_exps ct tmp l e = (p,le,ntmp,nl) ==> + survives n (nested_seq p)) +Proof + ho_match_mp_tac compile_exp_ind >> + rpt conj_tac >> rpt gen_tac >> strip_tac >> + TRY ( + fs [Once compile_exp_def, AllCaseEqs()] >> rveq >> + fs [nested_seq_def, survives_def] >> NO_TAC) + >- ( + fs [compile_exp_def, AllCaseEqs()] >> rveq >> + pairarg_tac >> fs []) + >- ( + rw [] >> + fs [compile_exp_def, AllCaseEqs()] >> rveq >> + pairarg_tac >> fs [] >> rveq >> + match_mp_tac survives_nested_seq_intro >> + fs [nested_seq_def, survives_def]) + >- ( + rw [] >> + pop_assum mp_tac >> + rw [Once compile_exp_def, AllCaseEqs()] >> rveq >> + pairarg_tac >> fs []) + >- ( + rw [] >> + pop_assum mp_tac >> + rw [Once compile_exp_def, AllCaseEqs()] >> rveq >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> rveq >> + fs [prog_if_def] >> + match_mp_tac survives_nested_seq_intro >> + conj_tac + >- ( + match_mp_tac survives_nested_seq_intro >> + fs [] >> + pop_assum mp_tac >> + drule compile_exp_out_rel >> + strip_tac >> fs [] >> rveq >> + drule cut_sets_union_domain_subset >> + rpt strip_tac >> + ‘n ∈ domain (cut_sets l (nested_seq p'))’ by + fs [SUBSET_DEF] >> + fs []) >> + fs [nested_seq_def, survives_def] >> + fs [list_insert_def] >> + imp_res_tac compile_exp_out_rel >> rveq >> + fs [] >> + imp_res_tac cut_sets_union_domain_subset >> + fs [SUBSET_DEF]) + >- ( + rw [] >> + pop_assum mp_tac >> + rw [Once compile_exp_def, AllCaseEqs()] >> rveq >> + pairarg_tac >> fs []) >> + rpt gen_tac >> strip_tac >> + cases_on ‘e’ >> fs [] + >- ( + fs [compile_exp_def] >> rveq >> + fs [nested_seq_def, survives_def]) >> + pop_assum mp_tac >> + once_rewrite_tac [compile_exp_def] >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> rveq >> + cases_on ‘t’ + >- ( + fs [compile_exp_def] >> + strip_tac >> rveq >> fs []) >> + strip_tac >> fs [] >> rveq >> + match_mp_tac survives_nested_seq_intro >> + imp_res_tac compile_exp_out_rel >> rveq >> + fs [] >> + imp_res_tac cut_sets_union_domain_subset >> + fs [SUBSET_DEF] +QED + + +Theorem member_cutset_survives_comp_exp = + member_cutset_survives_comp_exp_cases |> CONJUNCT1 +Theorem member_cutset_survives_comp_exps = + member_cutset_survives_comp_exp_cases |> CONJUNCT2 + + +Theorem member_cutset_survives_comp_prog: + !ctxt l p n. + n ∈ domain l ==> + survives n (compile ctxt l p) +Proof + ho_match_mp_tac compile_ind >> + rw [] >> fs [] >> + TRY ( + fs [compile_def, survives_def, AllCaseEqs()] >> + TRY (rpt TOP_CASE_TAC) >> + TRY (pairarg_tac) >> fs [survives_def] >> + rveq >> fs [] >> + TRY (match_mp_tac survives_nested_seq_intro) >> + fs [nested_seq_def, survives_def] >> + metis_tac [member_cutset_survives_comp_exp] >> NO_TAC) >> + TRY ( + fs [compile_def, survives_def, AllCaseEqs()] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + match_mp_tac survives_nested_seq_intro >> + fs [nested_seq_def, survives_def] >> + match_mp_tac survives_nested_seq_intro >> + conj_tac >- metis_tac [member_cutset_survives_comp_exp] >> + pop_assum mp_tac >> + drule compile_exp_out_rel >> + strip_tac >> fs [] >> rveq >> + drule cut_sets_union_domain_subset >> + rpt strip_tac >> + ‘n ∈ domain (cut_sets l (nested_seq p))’ by + fs [SUBSET_DEF] >> + metis_tac [member_cutset_survives_comp_exp] >> NO_TAC) + >- ( + fs [compile_def, survives_def, AllCaseEqs()] >> + pairarg_tac >> fs [] >> + match_mp_tac survives_nested_seq_intro >> + fs [nested_seq_def, survives_def] >> + match_mp_tac survives_nested_seq_intro >> + conj_tac >- metis_tac [member_cutset_survives_comp_exps] >> + match_mp_tac nested_assigns_survives >> + fs [gen_temps_def]) >> + fs [compile_def, survives_def, AllCaseEqs()] >> + pairarg_tac >> fs [] >> + match_mp_tac survives_nested_seq_intro >> + conj_tac + >- ( + match_mp_tac survives_nested_seq_intro >> + conj_tac >- metis_tac [member_cutset_survives_comp_exps] >> + match_mp_tac nested_assigns_survives >> + fs [gen_temps_def]) >> + fs [nested_seq_def, survives_def] >> + TRY (rpt TOP_CASE_TAC) >> + fs [survives_def] +QED + + +Theorem not_mem_assigned_mem_gt_comp_exp_cases: + (!ctxt tmp l (e:'a crepLang$exp) p le ntmp nl n. + compile_exp ctxt tmp l e = (p,le,ntmp,nl) /\ + ctxt_max ctxt.vmax ctxt.vars /\ + (!v m. FLOOKUP ctxt.vars v = SOME m ==> n <> m) ∧ n < tmp ==> + ~MEM n (assigned_vars (nested_seq p))) /\ + (!ctxt tmp l (e:'a crepLang$exp list) p le ntmp nl n. + compile_exps ctxt tmp l e = (p,le,ntmp,nl) /\ + ctxt_max ctxt.vmax ctxt.vars /\ + (!v m. FLOOKUP ctxt.vars v = SOME m ==> n <> m) ∧ n < tmp ==> + ~MEM n (assigned_vars (nested_seq p))) +Proof + ho_match_mp_tac compile_exp_ind >> + rpt conj_tac >> rpt gen_tac >> strip_tac >> + TRY ( + fs [Once compile_exp_def, AllCaseEqs()] >> rveq >> + fs [nested_seq_def, assigned_vars_def] >> NO_TAC) + >- ( + fs [compile_exp_def, AllCaseEqs()] >> rveq >> + pairarg_tac >> fs []) + >- ( + rw [] >> + fs [compile_exp_def, AllCaseEqs()] >> rveq >> + pairarg_tac >> fs [] >> rveq >> + fs [assigned_vars_nested_seq_split] >> + fs [nested_seq_def, assigned_vars_def] >> + drule compile_exp_out_rel >> + strip_tac >> fs []) + >- ( + rw [] >> + qpat_x_assum ‘compile_exp _ _ _ (Op _ _) = _’ mp_tac >> + rw [Once compile_exp_def, AllCaseEqs()] >> rveq >> + pairarg_tac >> fs []) + >- ( + rw [] >> + qpat_x_assum ‘compile_exp _ _ _ (Cmp _ _ _) = _’ mp_tac >> + rw [Once compile_exp_def, AllCaseEqs()] >> rveq >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> rveq >> + fs [prog_if_def] >> + fs [assigned_vars_nested_seq_split] >> + fs [nested_seq_def, assigned_vars_def] >> + imp_res_tac compile_exp_out_rel >> + fs []) + >- ( + rw [] >> + qpat_x_assum ‘compile_exp _ _ _ (Shift _ _ _) = _’ mp_tac >> + rw [Once compile_exp_def, AllCaseEqs()] >> rveq >> + pairarg_tac >> fs []) >> + rpt gen_tac >> strip_tac >> + cases_on ‘e’ >> fs [] + >- ( + fs [compile_exp_def] >> rveq >> + fs [nested_seq_def, assigned_vars_def]) >> + qpat_x_assum ‘compile_exps _ _ _ _ = _’ mp_tac >> + once_rewrite_tac [compile_exp_def] >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> rveq >> + cases_on ‘t’ + >- ( + fs [compile_exp_def] >> + strip_tac >> rveq >> fs []) >> + strip_tac >> fs [] >> rveq >> + fs [assigned_vars_nested_seq_split] >> + imp_res_tac compile_exp_out_rel >> + fs [] +QED + +Theorem not_mem_assigned_mem_gt_comp_exp = + not_mem_assigned_mem_gt_comp_exp_cases |> CONJUNCT1 +Theorem not_mem_assigned_mem_gt_comp_exps = + not_mem_assigned_mem_gt_comp_exp_cases |> CONJUNCT2 + +Theorem not_mem_context_assigned_mem_gt: + !ctxt l p n. + ctxt_max ctxt.vmax ctxt.vars /\ + (!v m. FLOOKUP ctxt.vars v = SOME m ==> n <> m) ∧ + n <= ctxt.vmax ==> + ~MEM n (assigned_vars (compile ctxt l p)) +Proof + ho_match_mp_tac compile_ind >> rw [] >> + TRY ( + fs [compile_def, assigned_vars_def] >> NO_TAC) >> + TRY ( + fs [compile_def, assigned_vars_def] >> + pairarg_tac >> fs [] >> + fs [assigned_vars_nested_seq_split] >> + conj_tac + >- (drule not_mem_assigned_mem_gt_comp_exp >> strip_tac >> + res_tac >> fs []) >> + imp_res_tac compile_exp_out_rel >> + fs [nested_seq_def, assigned_vars_def] >> NO_TAC) >> + TRY ( + fs [compile_def, assigned_vars_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + fs [assigned_vars_nested_seq_split] >> + imp_res_tac compile_exp_out_rel >> rveq >> + conj_tac + >- ( + conj_tac >> + imp_res_tac not_mem_assigned_mem_gt_comp_exp >> + res_tac >> fs []) >> + fs [nested_seq_def, assigned_vars_def] >> NO_TAC) + >- ( + fs [compile_def, assigned_vars_def] >> + TOP_CASE_TAC >> fs [assigned_vars_def] >> + pairarg_tac >> fs [] >> + fs [assigned_vars_nested_seq_split] >> + drule compile_exp_out_rel >> strip_tac >> + fs [] >> rveq >> + drule not_mem_assigned_mem_gt_comp_exp >> strip_tac >> + fs [nested_seq_def, assigned_vars_def] >> + CCONTR_TAC >> fs [] >> + fs [ctxt_max_def] >> + res_tac >> rfs []) + >- ( + fs [compile_def, assigned_vars_def] >> + pairarg_tac >> fs [] >> + fs [assigned_vars_def] >> + conj_tac + >- ( + imp_res_tac not_mem_assigned_mem_gt_comp_exp >> + res_tac >> fs []) >> + conj_tac + >- (drule compile_exp_out_rel >> strip_tac >> fs []) >> + drule compile_exp_out_rel >> + strip_tac >> rveq >> fs [] >> + last_x_assum match_mp_tac >> fs [] >> + conj_tac + >- ( + fs [ctxt_max_def] >> + rw [FLOOKUP_UPDATE] >> + res_tac >> fs []) >> + rw [FLOOKUP_UPDATE] >> + res_tac >> fs []) + >- ( + fs [compile_def, assigned_vars_def] >> + pairarg_tac >> fs [] >> + drule compile_exp_out_rel >> + strip_tac >> rveq >> fs [] >> + fs [assigned_vars_def, + assigned_vars_nested_seq_split, nested_seq_def] >> + drule not_mem_assigned_mem_gt_comp_exp >> + res_tac >> fs []) + >- ( + fs [compile_def, assigned_vars_def] >> + pairarg_tac >> fs [] >> + drule compile_exps_out_rel >> + strip_tac >> rveq >> fs [] >> + fs [assigned_vars_def, + assigned_vars_nested_seq_split, nested_seq_def] >> + conj_tac + >- ( + imp_res_tac not_mem_assigned_mem_gt_comp_exps >> + res_tac >> fs []) >> + ‘assigned_vars + (nested_seq (MAP2 Assign (gen_temps tmp (LENGTH es + 1)) les)) = + gen_temps tmp (LENGTH es + 1)’ by ( + match_mp_tac assigned_vars_nested_assign >> + fs [gen_temps_def]) >> + fs [] >> + fs [gen_temps_def] >> + CCONTR_TAC >> fs [MEM_GENLIST]) + >- ( + fs [compile_def, assigned_vars_def] >> + pairarg_tac >> fs [] >> + drule compile_exps_out_rel >> + strip_tac >> rveq >> fs [] >> + fs [assigned_vars_def, + assigned_vars_nested_seq_split, nested_seq_def] >> + conj_tac + >- ( + conj_tac + >- ( + imp_res_tac not_mem_assigned_mem_gt_comp_exps >> + res_tac >> fs []) >> + ‘assigned_vars + (nested_seq (MAP2 Assign (gen_temps tmp (LENGTH es + 1)) les)) = + gen_temps tmp (LENGTH es + 1)’ by ( + match_mp_tac assigned_vars_nested_assign >> + fs [gen_temps_def]) >> + fs [] >> + fs [gen_temps_def] >> + CCONTR_TAC >> fs [MEM_GENLIST]) >> + conj_tac + >- ( + cases_on ‘rt’ >> + fs [rt_var_def] >> + TOP_CASE_TAC >> fs [] >> + CCONTR_TAC >> fs [] >> + fs [ctxt_max_def] >> + res_tac >> rfs []) >> + TOP_CASE_TAC >> fs [assigned_vars_def] >> + TOP_CASE_TAC >> fs [assigned_vars_def]) >> + fs [compile_def, assigned_vars_def] >> + rpt (TOP_CASE_TAC) >> fs [] >> rveq >> + fs [assigned_vars_def] +QED + + + +Theorem compile_Skip_Break_Continue: + ^(get_goal "compile _ _ crepLang$Skip") /\ + ^(get_goal "compile _ _ crepLang$Break") /\ + ^(get_goal "compile _ _ crepLang$Continue") +Proof + rpt strip_tac >> + fs [crepSemTheory.evaluate_def, evaluate_def, + compile_def] >> rveq >> + fs [state_rel_clock_add_zero] +QED + +Theorem compile_Tick: + ^(get_goal "compile _ _ crepLang$Tick") +Proof + rw [] >> + fs [crepSemTheory.evaluate_def, evaluate_def, + compile_def, AllCaseEqs ()] >> rveq >> + fs [state_rel_def, empty_locals_def, + crepSemTheory.dec_clock_def, dec_clock_def] >> + qexists_tac ‘0’ >> fs [] +QED + +Theorem compile_Seq: + ^(get_goal "compile _ _ (crepLang$Seq _ _)") +Proof + rw [] >> + fs [crepSemTheory.evaluate_def] >> + pairarg_tac >> fs [] >> + cases_on ‘res' = NONE’ >> fs [] >> rveq + >- ( + fs [compile_def] >> + fs [evaluate_def] >> + first_x_assum drule_all >> + strip_tac >> fs [] >> + first_x_assum drule_all >> + strip_tac >> fs [] >> + qexists_tac ‘ck + ck'’ >> rfs [] >> + qpat_x_assum ‘_ (compile _ _ c1, _) = _’ assume_tac >> + drule evaluate_add_clock_eq >> + fs []) >> + fs [compile_def] >> + fs [evaluate_def] >> + first_x_assum drule_all >> + strip_tac >> fs [] >> + qexists_tac ‘ck’ >> rfs [] >> + cases_on ‘res’ >> fs [] >> + cases_on ‘x’ >> fs [] +QED + + +Theorem compile_Return: + ^(get_goal "compile _ _ (crepLang$Return _)") +Proof + rw [] >> + fs [crepSemTheory.evaluate_def, evaluate_def, + compile_def, AllCaseEqs ()] >> rveq >> + pairarg_tac >> fs [] >> + drule comp_exp_preserves_eval >> + disch_then (qspecl_then [‘t’, ‘ctxt’, ‘ctxt.vmax + 1’, ‘l’, + ‘p’,‘le’,‘ntmp’,‘nl’] mp_tac) >> + fs [] >> strip_tac >> fs [] >> + qexists_tac ‘ck’ >> fs [] >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘[Assign ntmp le; Return ntmp]’ mp_tac) >> + strip_tac >> fs [] >> pop_assum kall_tac >> + fs [nested_seq_def, evaluate_def] >> + pairarg_tac >> + fs [set_var_def, lookup_insert, call_env_def] >> + rveq >> fs [crepSemTheory.empty_locals_def, state_rel_def] >> + cases_on ‘w’ >> fs [wlab_wloc_def] >> + imp_res_tac locals_rel_intro >> + imp_res_tac code_rel_intro >> + imp_res_tac globals_rel_intro >> + imp_res_tac mem_rel_intro >> + drule eval_label_eq_state_contains_label >> + rw [FDOM_FLOOKUP] >> res_tac >> fs [] +QED + +Theorem compile_Raise: + ^(get_goal "compile _ _ (crepLang$Raise _)") +Proof + rw [] >> + fs [crepSemTheory.evaluate_def, evaluate_def, + compile_def, eval_def, set_var_def, lookup_insert, + call_env_def, state_rel_def, crepSemTheory.empty_locals_def] >> rveq >> + fs [] >> + qexists_tac ‘0’ >> + fs [] +QED + +Theorem compile_Store: + ^(get_goal "compile _ _ (crepLang$Store _ _)") +Proof + rw [] >> + fs [crepSemTheory.evaluate_def, evaluate_def, + compile_def, AllCaseEqs ()] >> rveq >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_rename_tac ‘compile_exp _ _ _ dst = (dp, dle,dtmp,dl)’ >> + qmatch_asmsub_rename_tac ‘compile_exp _ _ _ src = (sp, sle, stmp, sl)’ >> + qpat_x_assum ‘eval _ dst = _’ assume_tac >> + drule comp_exp_preserves_eval >> + disch_then (qspecl_then [‘t’, ‘ctxt’, ‘ctxt.vmax + 1’, ‘l’, + ‘dp’,‘dle’,‘dtmp’,‘dl’] mp_tac) >> + fs [] >> strip_tac >> fs [] >> + qpat_x_assum ‘eval _ src = _’ assume_tac >> + drule comp_exp_preserves_eval >> + disch_then (qspecl_then [‘st’, ‘ctxt’, ‘dtmp’, ‘dl’, + ‘sp’,‘sle’,‘stmp’,‘sl’] mp_tac) >> + fs [] >> + impl_tac + >- ( + imp_res_tac compile_exp_out_rel >> fs []) >> + strip_tac >> fs [] >> + qexists_tac ‘ck + ck'’ >> fs [] >> + qpat_x_assum ‘evaluate (nested_seq dp, _) = _’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck'’ mp_tac) >> + strip_tac >> + drule evaluate_comb_seq >> + disch_then drule >> + fs [evaluate_nested_seq_comb_seq] >> + strip_tac >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then + ‘[Assign stmp sle; Store dle stmp]’ mp_tac) >> + fs [] >> + strip_tac >> pop_assum kall_tac >> + fs [nested_seq_def, evaluate_def, set_var_def] >> + fs [wlab_wloc_def] >> + ‘eval (st' with locals := insert stmp (wlab_wloc ctxt.funcs w) st'.locals) dle = + SOME (Word adr)’ by ( + qpat_x_assum ‘evaluate (nested_seq dp,_ with clock := ck + _) = _’ assume_tac >> + drule nested_seq_pure_evaluation >> + disch_then (qspecl_then [‘sp’, ‘st'’, ‘l’, ‘dtmp’, ‘dle’, + ‘Word adr’,‘ck'’] mp_tac) >> fs [] >> + impl_tac + >- ( + imp_res_tac compile_exp_out_rel >> rveq >> fs [] >> + imp_res_tac comp_exp_assigned_vars_tmp_bound >> fs [] >> + gen_tac >> strip_tac >> fs [] >> + imp_res_tac locals_rel_intro >> + drule compile_exp_le_tmp_domain >> + disch_then (qspecl_then [‘(ctxt.vmax + 1)’, ‘l’, ‘dst’, ‘dp’, ‘dle’, + ‘dtmp’, ‘cut_sets l (nested_seq dp)’, ‘n’] mp_tac) >> + fs [] >> + impl_tac + >- ( + rw [] >> + imp_res_tac eval_some_var_cexp_local_lookup >> + res_tac >> fs []) >> + fs []) >> + strip_tac >> + pop_assum (assume_tac o GSYM) >> + fs [] >> + pop_assum kall_tac >> + match_mp_tac locals_touched_eq_eval_eq >> + fs [] >> rw [] >> + fs [lookup_insert] >> + TOP_CASE_TAC >> fs [] >> rveq >> + + + imp_res_tac compile_exp_out_rel >> rveq >> fs [] >> + imp_res_tac comp_exp_assigned_vars_tmp_bound >> fs [] >> + imp_res_tac locals_rel_intro >> + drule compile_exp_le_tmp_domain >> + disch_then (qspecl_then [‘(ctxt.vmax + 1)’, ‘l’, ‘dst’, ‘dp’, ‘dle’, + ‘dtmp’, ‘cut_sets l (nested_seq dp)’, ‘n’] mp_tac) >> + fs [] >> + strip_tac >> fs [] >> + imp_res_tac eval_some_var_cexp_local_lookup >> + res_tac >> fs []) >> + fs [] >> pop_assum kall_tac >> + fs [mem_store_def, panSemTheory.mem_store_def] >> + rveq >> fs [state_rel_def] >> + reverse conj_tac + >- ( + ‘subspt l sl’ by ( + imp_res_tac compile_exp_out_rel >> fs [] >> + imp_res_tac comp_syn_impl_cut_sets_subspt >> fs [] >> + rveq >> metis_tac [subspt_trans]) >> + match_mp_tac locals_rel_insert_gt_vmax >> + imp_res_tac compile_exp_out_rel >> + fs [] >> + match_mp_tac locals_rel_cutset_prop >> + metis_tac []) >> + imp_res_tac mem_rel_intro >> + rw [mem_rel_def] >> + fs [APPLY_UPDATE_THM] >> + reverse FULL_CASE_TAC >> fs [] >> rveq + >- (res_tac >> fs []) >> + imp_res_tac locals_rel_intro >> + imp_res_tac code_rel_intro >> + imp_res_tac globals_rel_intro >> + drule eval_label_eq_state_contains_label >> + rw [] >> res_tac >> fs [] +QED + + +Theorem compile_StoreByte: + ^(get_goal "compile _ _ (crepLang$StoreByte _ _)") +Proof + rw [] >> + fs [crepSemTheory.evaluate_def, evaluate_def, + compile_def, AllCaseEqs ()] >> rveq >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_rename_tac ‘compile_exp _ _ _ dst = (dp, dle,dtmp,dl)’ >> + qmatch_asmsub_rename_tac ‘compile_exp _ _ _ src = (sp, sle, stmp, sl)’ >> + qpat_x_assum ‘eval _ dst = _’ assume_tac >> + drule comp_exp_preserves_eval >> + disch_then (qspecl_then [‘t’, ‘ctxt’, ‘ctxt.vmax + 1’, ‘l’, + ‘dp’,‘dle’,‘dtmp’,‘dl’] mp_tac) >> + fs [] >> strip_tac >> fs [] >> + qpat_x_assum ‘eval _ src = _’ assume_tac >> + drule comp_exp_preserves_eval >> + disch_then (qspecl_then [‘st’, ‘ctxt’, ‘dtmp’, ‘dl’, + ‘sp’,‘sle’,‘stmp’,‘sl’] mp_tac) >> + fs [] >> + impl_tac + >- ( + imp_res_tac compile_exp_out_rel >> fs []) >> + strip_tac >> fs [] >> + qexists_tac ‘ck + ck'’ >> fs [] >> + qpat_x_assum ‘evaluate (nested_seq dp, _) = _’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck'’ mp_tac) >> + strip_tac >> + drule evaluate_comb_seq >> + disch_then drule >> + fs [evaluate_nested_seq_comb_seq] >> + strip_tac >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then + ‘[Assign stmp dle; Assign (stmp + 1) sle; + StoreByte stmp (stmp + 1)]’ mp_tac) >> + fs [] >> + strip_tac >> pop_assum kall_tac >> + fs [nested_seq_def, evaluate_def, set_var_def] >> + fs [wlab_wloc_def] >> + ‘eval st' dle = SOME (Word adr)’ by ( + qpat_x_assum ‘evaluate (nested_seq dp,_ with clock := ck + _) = _’ assume_tac >> + drule nested_seq_pure_evaluation >> + disch_then (qspecl_then [‘sp’, ‘st'’, ‘l’, ‘dtmp’, ‘dle’, + ‘Word adr’,‘ck'’] mp_tac) >> fs [] >> + impl_tac + >- ( + imp_res_tac compile_exp_out_rel >> rveq >> fs [] >> + imp_res_tac comp_exp_assigned_vars_tmp_bound >> fs [] >> + gen_tac >> strip_tac >> fs [] >> + imp_res_tac locals_rel_intro >> + drule compile_exp_le_tmp_domain >> + disch_then (qspecl_then [‘ctxt.vmax + 1’, ‘l’, ‘dst’, ‘dp’, ‘dle’, + ‘dtmp’, ‘cut_sets l (nested_seq dp)’, ‘n’] mp_tac) >> + fs [] >> + impl_tac + >- ( + rw [] >> + imp_res_tac eval_some_var_cexp_local_lookup >> + res_tac >> fs []) >> + fs []) >> + fs []) >> + fs [] >> pop_assum kall_tac >> + ‘eval (st' with locals := insert stmp (Word adr) st'.locals) sle = + eval st' sle’ by ( + match_mp_tac locals_touched_eq_eval_eq >> + fs [] >> rw [] >> + fs [lookup_insert] >> + TOP_CASE_TAC >> fs [] >> rveq >> + imp_res_tac compile_exp_out_rel >> rveq >> fs [] >> + imp_res_tac comp_exp_assigned_vars_tmp_bound >> fs [] >> + imp_res_tac locals_rel_intro >> + drule compile_exp_le_tmp_domain >> + disch_then (qspecl_then [‘dtmp’, ‘cut_sets l (nested_seq dp)’, ‘src’, + ‘sp’, ‘sle’, ‘n’, + ‘cut_sets (cut_sets l (nested_seq dp)) (nested_seq sp)’, + ‘n’] mp_tac) >> + fs [] >> + strip_tac >> fs [] >> + imp_res_tac eval_some_var_cexp_local_lookup >> + res_tac >> fs [] >> rveq >> rfs []) >> + fs [] >> pop_assum kall_tac >> + fs [wordSemTheory.mem_store_byte_aux_def, panSemTheory.mem_store_byte_def, + AllCaseEqs ()] >> + rveq >> fs [lookup_insert] >> + ‘st'.memory (byte_align adr) = Word v’ by ( + imp_res_tac mem_rel_intro >> + last_x_assum (qspec_then ‘byte_align adr’ mp_tac) >> + metis_tac [wlab_wloc_def]) >> + fs [state_rel_def] >> + reverse conj_tac + >- ( + ‘subspt l sl’ by ( + imp_res_tac compile_exp_out_rel >> fs [] >> + imp_res_tac comp_syn_impl_cut_sets_subspt >> fs [] >> + rveq >> metis_tac [subspt_trans]) >> + match_mp_tac locals_rel_insert_gt_vmax >> + imp_res_tac compile_exp_out_rel >> + fs [] >> + match_mp_tac locals_rel_insert_gt_vmax >> + imp_res_tac compile_exp_out_rel >> + fs [] >> + match_mp_tac locals_rel_cutset_prop >> + metis_tac []) >> + imp_res_tac mem_rel_intro >> + rw [mem_rel_def] >> + fs [APPLY_UPDATE_THM] >> + reverse FULL_CASE_TAC >> fs [] >> rveq + >- (res_tac >> fs [wlab_wloc_def]) >> + imp_res_tac locals_rel_intro >> + imp_res_tac code_rel_intro >> + imp_res_tac globals_rel_intro >> + drule eval_label_eq_state_contains_label >> + rw [] >> res_tac >> fs [] +QED + +Theorem compile_StoreGlob: + ^(get_goal "compile _ _ (crepLang$StoreGlob _ _)") +Proof + rw [] >> + fs [crepSemTheory.evaluate_def, evaluate_def, + compile_def, AllCaseEqs ()] >> rveq >> + pairarg_tac >> fs [] >> + drule comp_exp_preserves_eval >> + disch_then (qspecl_then [‘t’, ‘ctxt’, ‘ctxt.vmax + 1’, ‘l’, + ‘p’,‘le’,‘tmp’,‘l'’] mp_tac) >> + fs [] >> strip_tac >> fs [] >> + qexists_tac ‘ck’ >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘[SetGlobal dst le]’ assume_tac) >> + fs [] >> pop_assum kall_tac >> + fs [nested_seq_def, evaluate_def] >> + fs [crepSemTheory.set_globals_def, set_globals_def] >> + fs [state_rel_def] >> + reverse conj_tac + >- ( + ‘subspt l l'’ by ( + imp_res_tac compile_exp_out_rel >> fs [] >> + imp_res_tac comp_syn_impl_cut_sets_subspt >> fs [] >> + rveq >> metis_tac [subspt_trans]) >> + match_mp_tac locals_rel_cutset_prop >> + metis_tac []) >> + imp_res_tac globals_rel_intro >> + rw [globals_rel_def, FLOOKUP_UPDATE] + >- (TOP_CASE_TAC >> res_tac >> fs []) >> + reverse FULL_CASE_TAC >> fs [] >> rveq + >- (res_tac >> fs []) >> + imp_res_tac locals_rel_intro >> + imp_res_tac code_rel_intro >> + imp_res_tac mem_rel_intro >> + drule eval_label_eq_state_contains_label >> + rw [] >> res_tac >> fs [] +QED + +Theorem compile_Assign: + ^(get_goal "compile _ _ (crepLang$Assign _ _)") +Proof + rw [] >> + fs [crepSemTheory.evaluate_def, evaluate_def, + compile_def, AllCaseEqs ()] >> rveq >> + pairarg_tac >> fs [] >> + TOP_CASE_TAC >> fs [] + >- (imp_res_tac locals_rel_intro >> fs []) >> + qmatch_goalsub_rename_tac ‘Assign n le’ >> + drule comp_exp_preserves_eval >> + disch_then (qspecl_then [‘t’, ‘ctxt’, ‘ctxt.vmax + 1’, ‘l’, + ‘p’,‘le’,‘tmp’,‘l'’] mp_tac) >> + fs [] >> strip_tac >> fs [] >> + qexists_tac ‘ck’ >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘[Assign n le]’ assume_tac) >> + fs [] >> pop_assum kall_tac >> + fs [nested_seq_def, evaluate_def] >> + fs [crepSemTheory.set_var_def, set_var_def] >> + fs [state_rel_def] >> + imp_res_tac compile_exp_out_rel >> + rveq >> + drule cut_sets_union_domain_subset >> + strip_tac >> + fs [locals_rel_def] >> + rw [] + >- ( + match_mp_tac SUBSET_TRANS >> + qexists_tac ‘domain (cut_sets l (nested_seq p))’ >> fs [] >> + metis_tac [SUBSET_INSERT_RIGHT]) >> + fs [FLOOKUP_UPDATE] >> reverse FULL_CASE_TAC >> rveq >> fs [] + >- ( + res_tac >> fs [] >> rveq >> fs [] >> + ‘n <> n'’ suffices_by fs [lookup_insert] >> + CCONTR_TAC >> + fs [distinct_vars_def] >> + res_tac >> fs []) >> + last_x_assum drule_all >> + strip_tac >> rfs [] >> rveq >> + rw [] >> + imp_res_tac globals_rel_intro >> + imp_res_tac code_rel_intro >> + imp_res_tac mem_rel_intro >> + drule eval_label_eq_state_contains_label >> + rw [] >> res_tac >> fs [] +QED + +Theorem compile_Dec: + ^(get_goal "compile _ _ (crepLang$Dec _ _ _)") +Proof + rw [] >> + fs [crepSemTheory.evaluate_def, evaluate_def, + compile_def, AllCaseEqs ()] >> rveq >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> rveq >> + drule comp_exp_preserves_eval >> + disch_then (qspecl_then [‘t’, ‘ctxt’, ‘ctxt.vmax + 1’, ‘l’, + ‘p’, ‘le’, ‘tmp’, ‘nl’] mp_tac) >> + fs [] >> + strip_tac >> fs [] >> + last_x_assum (qspecl_then + [‘st' with locals := insert tmp (wlab_wloc ctxt.funcs value) st'.locals’, + ‘ctxt with <|vars := ctxt.vars |+ (v,tmp); vmax := tmp|>’, + ‘insert tmp () l’] mp_tac) >> + impl_tac + >- ( + fs [] >> + conj_tac >- fs [state_rel_def] >> + imp_res_tac compile_exp_out_rel >> + conj_tac >- fs [code_rel_def] >> + imp_res_tac locals_rel_intro >> + rw [locals_rel_def] + >- ( + fs [distinct_vars_def] >> + rw [] >> + fs [FLOOKUP_UPDATE] >> + FULL_CASE_TAC >> fs [] >> + FULL_CASE_TAC >> fs [] >> rveq >> + fs [ctxt_max_def] >> res_tac >> rfs []) + >- ( + rw [ctxt_max_def] >> + fs [FLOOKUP_UPDATE] >> + FULL_CASE_TAC >> fs [] >> + fs [ctxt_max_def] >> res_tac >> rfs []) + >- ( + drule cut_sets_union_domain_subset >> + strip_tac >> + metis_tac [SUBSET_TRANS, SUBSET_INSERT_RIGHT]) >> + fs [FLOOKUP_UPDATE] >> + TOP_CASE_TAC >> fs [] >> rveq + >- ( + cases_on ‘v'’ >> fs [wlab_wloc_def] >> + imp_res_tac globals_rel_intro >> + imp_res_tac code_rel_intro >> + imp_res_tac mem_rel_intro >> + drule eval_label_eq_state_contains_label >> + rw [] >> res_tac >> fs []) >> + res_tac >> fs [] >> rveq >> + fs [lookup_insert] >> TOP_CASE_TAC >> fs [] >> rveq + >- ( + fs [ctxt_max_def] >> res_tac >> rfs []) >> + cases_on ‘v'’ >> fs [wlab_wloc_def]) >> + strip_tac >> fs [] >> + qpat_x_assum ‘evaluate (nested_seq p,_) = _’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> disch_then (qspec_then ‘ck'’ assume_tac) >> + qexists_tac ‘ck + ck'’ >> + fs [evaluate_def] >> + fs [Once eval_upd_clock_eq] >> + fs [set_var_def] >> + conj_tac >- fs [state_rel_def] >> + conj_tac >- fs [code_rel_def] >> + imp_res_tac compile_exp_out_rel_cases >> + TOP_CASE_TAC >> fs [] >> rveq + >- ( + imp_res_tac locals_rel_intro >> + rw [locals_rel_def] + >- fs [domain_insert] >> + cases_on ‘vname = v’ >> rveq + >- ( + cases_on ‘FLOOKUP s.locals v’ >> + fs [crepSemTheory.res_var_def] >> + fs [FLOOKUP_UPDATE] >> rveq >> + qmatch_asmsub_rename_tac ‘FLOOKUP s.locals v = SOME pv’ >> + res_tac >> fs [] >> rveq >> + qmatch_asmsub_rename_tac ‘FLOOKUP ctxt.vars v = SOME pn’ >> + qpat_x_assum ‘evaluate (compile _ _ _, _) = _’ assume_tac >> + drule unassigned_vars_evaluate_same >> + fs [] >> + disch_then (qspecl_then [‘pn’,‘wlab_wloc ctxt.funcs pv’] mp_tac) >> + impl_tac + >- ( + conj_tac + >- ( + ‘pn <> tmp’ suffices_by fs [lookup_insert] >> + CCONTR_TAC >> + fs [] >> + imp_res_tac compile_exp_out_rel_cases >> + fs [ctxt_max_def] >> res_tac >> fs []) >> + conj_tac + >- ( + match_mp_tac not_mem_context_assigned_mem_gt >> + fs [] >> + imp_res_tac compile_exp_out_rel_cases >> + fs [ctxt_max_def] >> res_tac >> fs [] >> + rw [FLOOKUP_UPDATE] >> + CCONTR_TAC >> + fs [distinct_vars_def] >> + res_tac >> fs []) >> + match_mp_tac member_cutset_survives_comp_prog >> + fs [domain_insert]) >> + fs []) >> + cases_on ‘FLOOKUP s.locals v’ >> + fs [crepSemTheory.res_var_def] + >- ( + fs [DOMSUB_FLOOKUP_THM] >> + last_x_assum drule >> + strip_tac >> fs [] >> rveq + >- ( + rfs [FLOOKUP_UPDATE] >> rveq >> + fs [ctxt_max_def] >> res_tac >> rfs []) >> + rfs [FLOOKUP_UPDATE] >> + cases_on ‘v'’ >> fs [wlab_wloc_def]) >> + qmatch_asmsub_rename_tac ‘FLOOKUP s.locals v = SOME rv’ >> + fs [FLOOKUP_UPDATE] >> + last_x_assum drule >> + strip_tac >> fs [] >> rveq + >- ( + rfs [FLOOKUP_UPDATE] >> rveq >> + fs [ctxt_max_def] >> res_tac >> rfs []) >> + rfs [FLOOKUP_UPDATE] >> + cases_on ‘v'’ >> fs [wlab_wloc_def]) >> + cases_on ‘x’ >> fs [] >> rveq >> ( + imp_res_tac locals_rel_intro >> + rw [locals_rel_def] + >- fs [domain_insert] >> + cases_on ‘vname = v’ >> rveq + >- ( + cases_on ‘FLOOKUP s.locals v’ >> + fs [crepSemTheory.res_var_def] >> + fs [FLOOKUP_UPDATE] >> rveq >> + qmatch_asmsub_rename_tac ‘FLOOKUP s.locals v = SOME pv’ >> + res_tac >> fs [] >> rveq >> + qmatch_asmsub_rename_tac ‘FLOOKUP ctxt.vars v = SOME pn’ >> + qpat_x_assum ‘evaluate (compile _ _ _, _) = _’ assume_tac >> + drule unassigned_vars_evaluate_same >> + fs [] >> + disch_then (qspecl_then [‘pn’,‘wlab_wloc ctxt.funcs pv’] mp_tac) >> + impl_tac + >- ( + conj_tac + >- ( + ‘pn <> tmp’ suffices_by fs [lookup_insert] >> + CCONTR_TAC >> + fs [] >> + imp_res_tac compile_exp_out_rel_cases >> + fs [ctxt_max_def] >> res_tac >> fs []) >> + conj_tac + >- ( + match_mp_tac not_mem_context_assigned_mem_gt >> + fs [] >> + imp_res_tac compile_exp_out_rel_cases >> + fs [ctxt_max_def] >> res_tac >> fs [] >> + rw [FLOOKUP_UPDATE] >> + CCONTR_TAC >> + fs [distinct_vars_def] >> + res_tac >> fs []) >> + match_mp_tac member_cutset_survives_comp_prog >> + fs [domain_insert]) >> + fs []) >> + cases_on ‘FLOOKUP s.locals v’ >> + fs [crepSemTheory.res_var_def] + >- ( + fs [DOMSUB_FLOOKUP_THM] >> + last_x_assum drule >> + strip_tac >> fs [] >> rveq + >- ( + rfs [FLOOKUP_UPDATE] >> rveq >> + fs [ctxt_max_def] >> res_tac >> rfs []) >> + rfs [FLOOKUP_UPDATE] >> + cases_on ‘v'’ >> fs [wlab_wloc_def]) >> + qmatch_asmsub_rename_tac ‘FLOOKUP s.locals v = SOME rv’ >> + fs [FLOOKUP_UPDATE] >> + last_x_assum drule >> + strip_tac >> fs [] >> rveq + >- ( + rfs [FLOOKUP_UPDATE] >> rveq >> + fs [ctxt_max_def] >> res_tac >> rfs []) >> + rfs [FLOOKUP_UPDATE] >> + cases_on ‘v'’ >> fs [wlab_wloc_def]) +QED + +Theorem compile_If: + ^(get_goal "compile _ _ (crepLang$If _ _ _)") +Proof + rw [] >> + fs [crepSemTheory.evaluate_def, evaluate_def, + compile_def, AllCaseEqs ()] >> rveq >> + pairarg_tac >> fs [] >> + drule comp_exp_preserves_eval >> + disch_then (qspecl_then [‘t’, ‘ctxt’, ‘ctxt.vmax + 1’, ‘l’, + ‘np’,‘le’,‘tmp’,‘nl’] mp_tac) >> + fs [] >> + strip_tac >> + fs [wlab_wloc_def] >> + last_x_assum mp_tac >> + disch_then (qspecl_then + [‘st with locals := insert tmp (Word w) st.locals’, + ‘ctxt’, ‘l’] mp_tac) >> + impl_tac + >- ( + fs [] >> + conj_tac >- fs [state_rel_def] >> + imp_res_tac locals_rel_intro >> + imp_res_tac compile_exp_out_rel >> + rveq >> + drule cut_sets_union_domain_subset >> + strip_tac >> + rw [locals_rel_def] + >- ( + drule cut_sets_union_domain_subset >> + strip_tac >> + ‘domain l ⊆ domain st.locals’ + suffices_by fs [SUBSET_INSERT_RIGHT] >> + match_mp_tac SUBSET_TRANS >> + qexists_tac ‘domain (cut_sets l (nested_seq np))’ >> + fs []) >> + res_tac >> fs [] >> rveq >> + ‘n <> tmp’ suffices_by fs [lookup_insert] >> + CCONTR_TAC >> fs [] >> rveq >> + fs [ctxt_max_def] >> res_tac >> rfs []) >> + strip_tac >> fs [] >> + cases_on ‘res’ >> fs [] >> rveq + >- ( + qpat_x_assum ‘evaluate (compile _ _ _, _) = _’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘1’ assume_tac) >> + qpat_x_assum ‘evaluate (nested_seq np, _) = _’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck' + 1’ assume_tac) >> + qexists_tac ‘ck + ck' + 1’ >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then + ‘[Assign tmp le; + If NotEqual tmp (Imm 0w) (compile ctxt l c1) + (compile ctxt l c2) l]’ assume_tac) >> + fs [] >> pop_assum kall_tac >> + fs [nested_seq_def] >> + fs [evaluate_def, eval_upd_clock_eq, set_var_def] >> + fs [get_var_imm_def] >> + cases_on ‘w <> 0w’ >> + fs [asmTheory.word_cmp_def, cut_res_def, cut_state_def] >> + TOP_CASE_TAC >> fs [] >> rveq >> + TRY (imp_res_tac locals_rel_intro >> fs [] >> NO_TAC) >> + fs [dec_clock_def] >> conj_tac >> + TRY (fs [state_rel_def] >> NO_TAC) >> + imp_res_tac locals_rel_intro >> + imp_res_tac compile_exp_out_rel >> + rveq >> + drule cut_sets_union_domain_subset >> + strip_tac >> + rw [locals_rel_def] >> + TRY ( + fs [domain_inter] >> + match_mp_tac SUBSET_TRANS >> + qexists_tac ‘domain (cut_sets l (nested_seq np))’ >> + fs [] >> NO_TAC) >> + res_tac >> rfs [] >> + fs [lookup_inter, domain_lookup]) >> + qpat_x_assum ‘evaluate (nested_seq np, _) = _’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck'’ assume_tac) >> + qexists_tac ‘ck + ck'’ >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then + ‘[Assign tmp le; + If NotEqual tmp (Imm 0w) (compile ctxt l c1) + (compile ctxt l c2) l]’ assume_tac) >> + fs [] >> pop_assum kall_tac >> + fs [nested_seq_def] >> + fs [evaluate_def, eval_upd_clock_eq, set_var_def] >> + fs [get_var_imm_def] >> + cases_on ‘x’ >> fs [] >> rveq >> + cases_on ‘w <> 0w’ >> + fs [asmTheory.word_cmp_def, cut_res_def] +QED + + +Theorem compile_FFI: + ^(get_goal "compile _ _ (crepLang$ExtCall _ _ _ _ _)") +Proof + rw [] >> + fs [crepSemTheory.evaluate_def, evaluate_def, + compile_def, AllCaseEqs ()] >> rveq >> fs [] >> + imp_res_tac locals_rel_intro >> + res_tac >> rfs [] >> + fs [evaluate_def, wlab_wloc_def] >> + fs [cut_state_def] >> + ‘mem_load_byte_aux t.memory t.mdomain t.be = + mem_load_byte s.memory s.memaddrs s.be’ by ( + match_mp_tac EQ_EXT >> + rw [] >> + fs [state_rel_def, panSemTheory.mem_load_byte_def, + wordSemTheory.mem_load_byte_aux_def] >> + fs [mem_rel_def] >> + first_x_assum (qspec_then ‘byte_align x’ assume_tac) >> + TOP_CASE_TAC >> fs [wlab_wloc_def] >> + cases_on ‘s.memory (byte_align x)’ >> + fs [wlab_wloc_def, AllCaseEqs ()]) >> + fs [state_rel_def] + >- ( + qexists_tac ‘0’ >> fs [] >> + reverse conj_tac + >- ( + fs [locals_rel_def] >> + fs [domain_inter] >> + rw [] >> + res_tac >> fs [] >> rveq >> + rfs [lookup_inter, domain_lookup]) >> + match_mp_tac write_bytearray_mem_rel >> + fs []) >> + fs [call_env_def] >> + qexists_tac ‘0’ >> fs [] +QED + + +Theorem compile_While: + ^(get_goal "compile _ _ (crepLang$While _ _)") +Proof + rpt gen_tac >> rpt strip_tac >> + qpat_x_assum ‘evaluate (While e c,s) = (res,s1)’ mp_tac >> + once_rewrite_tac [crepSemTheory.evaluate_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + reverse TOP_CASE_TAC >> fs [] + >- ( + (* False case *) + strip_tac >> fs [] >> rveq >> + rw [compile_def] >> + pairarg_tac >> fs [] >> + drule comp_exp_preserves_eval >> + disch_then (qspecl_then [‘t with locals := inter t.locals l’, + ‘ctxt’, ‘ctxt.vmax + 1’, ‘l’, + ‘np’,‘le’,‘tmp’,‘nl’] mp_tac) >> + fs [] >> + impl_tac + >- ( + conj_tac >- fs [state_rel_def] >> + fs [locals_rel_def] >> + fs [domain_inter] >> + rw [] >> + res_tac >> fs [] >> + fs [lookup_inter, domain_lookup]) >> + strip_tac >> + fs [wlab_wloc_def] >> + qexists_tac ‘ck + 2’ >> + fs [Once evaluate_def] >> + fs [cut_res_def, cut_state_def] >> + ‘domain l ⊆ domain t.locals’ by ( + fs [locals_rel_def]) >> + fs [dec_clock_def] >> + qmatch_goalsub_abbrev_tac ‘nested_seq (_ ++ pp)’ >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘1’ assume_tac) >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘pp’ assume_tac) >> + fs [] >> pop_assum kall_tac >> + (* to avoid looping *) + ‘evaluate (Assign tmp le, st with clock := st.clock + 1) = + (NONE, st with <|locals := insert tmp (Word 0w) st.locals; + clock := st.clock + 1|>)’ by ( + rw [evaluate_def, set_var_def, eval_upd_clock_eq]) >> + fs [Abbr ‘pp’, nested_seq_def] >> + rw [Once evaluate_def] >> + pop_assum kall_tac >> + rw [Once evaluate_def] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rw [Once evaluate_def] >> + fs [Once evaluate_def] + >- ( + fs [get_var_imm_def, asmTheory.word_cmp_def] >> + fs [Once evaluate_def] >> + fs [cut_res_def]) >> + fs [get_var_imm_def] >> + fs [asmTheory.word_cmp_def] >> + fs [Once evaluate_def] >> + fs [cut_res_def] >> rveq >> + fs [] >> + ‘domain l ⊆ tmp INSERT domain st.locals’ by ( + imp_res_tac compile_exp_out_rel >> + rveq >> + imp_res_tac locals_rel_intro >> + drule cut_sets_union_domain_subset >> + strip_tac >> + match_mp_tac SUBSET_TRANS >> + qexists_tac ‘domain (cut_sets l (nested_seq np))’ >> + fs [] >> + fs [SUBSET_INSERT_RIGHT]) >> + fs [] >> + conj_tac >- fs [state_rel_def] >> + fs [locals_rel_def] >> + fs [domain_inter, domain_insert, SUBSET_INSERT_RIGHT] >> + rw [] >> + res_tac >> fs [] >> rveq >> fs [] >> + ‘n <> tmp’ by ( + CCONTR_TAC >> fs [] >> rveq >> + imp_res_tac compile_exp_out_rel >> + rveq >> + fs [ctxt_max_def] >> res_tac >> rfs []) >> + fs [lookup_inter, lookup_insert, domain_lookup]) >> + TOP_CASE_TAC >> fs [] >> rveq >> rfs [] + >- ( + (* Timeout case *) + strip_tac >> rveq >> fs [] >> + fs [Once compile_def] >> + pairarg_tac >> fs [] >> + ‘t.clock = 0’ by fs [state_rel_def] >> + ‘domain l ⊆ domain t.locals’ by fs [locals_rel_def] >> + qexists_tac ‘0’ >> + fs [Once evaluate_def] >> + fs [cut_res_def, cut_state_def] >> + fs [state_rel_def, crepSemTheory.empty_locals_def]) >> + pairarg_tac >> fs [] >> + ‘t.clock <> 0’ by fs [state_rel_def] >> + ‘domain l ⊆ domain t.locals’ by fs [locals_rel_def] >> + ‘eval (dec_clock s) e = SOME (Word c')’ by ( + fs [crepSemTheory.dec_clock_def] >> + fs [crepPropsTheory.eval_upd_clock_eq]) >> + fs [compile_def] >> + pairarg_tac >> fs [] >> + drule comp_exp_preserves_eval >> + disch_then (qspecl_then [‘t with <|locals := inter t.locals l; clock := t.clock - 1|>’, + ‘ctxt’, ‘ctxt.vmax + 1’, ‘l’, + ‘np’,‘le’,‘tmp’,‘nl’] mp_tac) >> + fs [crepSemTheory.dec_clock_def] >> + impl_tac + >- ( + conj_tac >- fs [state_rel_def] >> + fs [locals_rel_def] >> + fs [domain_inter] >> + rw [] >> + last_x_assum drule >> + strip_tac >> fs [] >> + fs [lookup_inter, domain_lookup]) >> + strip_tac >> fs [] >> + fs [wlab_wloc_def] >> + rfs [] >> + reverse TOP_CASE_TAC >> fs [] >> rveq + (* first iteration non-NONE results *) + >- ( + cases_on ‘x = Error’ >> fs [] >> + last_x_assum (qspecl_then + [‘st with locals := insert tmp (Word c') st.locals’, + ‘ctxt’, ‘l’] mp_tac) >> + impl_tac + >- ( + fs [state_rel_def] >> + imp_res_tac compile_exp_out_rel >> + rveq >> + fs [locals_rel_def] >> + conj_tac + >- ( + drule cut_sets_union_domain_subset >> + strip_tac >> + match_mp_tac SUBSET_TRANS >> + qexists_tac ‘domain (cut_sets l (nested_seq np))’ >> + fs [] >> + fs [SUBSET_INSERT_RIGHT]) >> + rw [] >> res_tac >> fs [] >> + rveq >> fs [] >> + ‘n <> tmp’ by ( + CCONTR_TAC >> fs [] >> rveq >> + imp_res_tac compile_exp_out_rel >> + rveq >> + fs [ctxt_max_def] >> res_tac >> rfs []) >> + fs [lookup_insert, domain_lookup]) >> + strip_tac >> fs [] >> + TOP_CASE_TAC >> fs [] >> + strip_tac >> rveq >> fs [] >> + TRY ( + rename [‘evaluate _ = (SOME Break,_)’] >> + qmatch_goalsub_abbrev_tac ‘nested_seq (_ ++ pp)’ >> + qpat_x_assum ‘evaluate (nested_seq np, _) = _’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck' + 1’ assume_tac) >> + qpat_x_assum ‘evaluate _ = (SOME Break,t1)’ assume_tac >> + drule evaluate_add_clock_eq >> + disch_then (qspec_then ‘1’ assume_tac) >> + qexists_tac ‘ck + ck' + 1’ >> + simp [Once evaluate_def] >> + fs [cut_res_def, cut_state_def, dec_clock_def] >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘pp’ assume_tac) >> + fs [] >> + pop_assum kall_tac >> + ‘evaluate (Assign tmp le, st with clock := ck' + 1 + st.clock) = + (NONE, st with <|locals := insert tmp (Word c') st.locals; + clock := ck' + 1 + st.clock|>)’ by ( + rw [evaluate_def, set_var_def, eval_upd_clock_eq]) >> + fs [Abbr ‘pp’, nested_seq_def] >> + simp [Once evaluate_def] >> + pop_assum kall_tac >> + simp [Once evaluate_def] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + simp [Once evaluate_def] >> + fs [get_var_imm_def] >> + rfs [asmTheory.word_cmp_def] >> + pop_assum mp_tac >> + simp [Once evaluate_def] >> + fs [] >> + strip_tac >> fs [] >> + strip_tac >> fs [] >> + rveq >> fs [cut_res_def] >> + rveq >> fs [] >> + ‘domain l ⊆ domain t1.locals’ by + fs [locals_rel_def] >> + fs [] >> + conj_tac >- fs [state_rel_def] >> + fs [locals_rel_def] >> + fs [domain_inter, domain_insert, SUBSET_INSERT_RIGHT] >> + rw [] >> + res_tac >> fs [] >> rveq >> fs [] >> + ‘n <> tmp’ by ( + CCONTR_TAC >> fs [] >> rveq >> + imp_res_tac compile_exp_out_rel >> + rveq >> + fs [ctxt_max_def] >> res_tac >> rfs []) >> + fs [lookup_inter, lookup_insert, domain_lookup]) >> + TRY ( + rename [‘evaluate _ = (SOME Continue,_)’] >> + (* instantiating IH *) + first_x_assum (qspecl_then [‘t1’, ‘ctxt’ , ‘l’] mp_tac) >> + impl_tac >- fs [] >> + strip_tac >> fs [] >> + fs [Once compile_def] >> + pairarg_tac >> fs [] >> + rveq >> rfs [] >> + qpat_x_assum ‘evaluate _ = (SOME Continue,t1)’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck''’ assume_tac) >> + cases_on ‘res’ >> fs [] >> rveq >> + TRY ( cases_on ‘x’ >> fs [] >> rveq) >> + qexists_tac ‘ck + ck' + ck''’ >> + simp [Once evaluate_def] >> + fs [cut_res_def, cut_state_def] >> + fs [dec_clock_def] >> + qmatch_goalsub_abbrev_tac ‘nested_seq (_ ++ pp)’ >> + qpat_x_assum ‘evaluate (nested_seq np, _) = _’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck' + ck''’ assume_tac) >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘pp’ assume_tac) >> + fs [] >> + pop_assum kall_tac >> + ‘evaluate (Assign tmp le, st with clock := ck' + (ck'' + st.clock)) = + (NONE, st with <|locals := insert tmp (Word c') st.locals; + clock := ck' + (ck'' + st.clock)|>)’ by ( + rw [evaluate_def, set_var_def, eval_upd_clock_eq]) >> + fs [Abbr ‘pp’, nested_seq_def] >> + simp [Once evaluate_def] >> + pop_assum kall_tac >> + simp [Once evaluate_def] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + simp [Once evaluate_def] >> + fs [get_var_imm_def] >> + rfs [asmTheory.word_cmp_def] >> + pop_assum mp_tac >> + simp [Once evaluate_def] >> + fs [] >> + strip_tac >> fs [] >> + strip_tac >> fs [] >> + rveq >> fs [cut_res_def] >> + rveq >> fs []) >> + qmatch_goalsub_abbrev_tac ‘nested_seq (_ ++ pp)’ >> + qpat_x_assum ‘evaluate (nested_seq np, _) = _’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck'’ assume_tac) >> + qexists_tac ‘ck + ck'’ >> + simp [Once evaluate_def] >> + fs [cut_res_def, cut_state_def, dec_clock_def] >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘pp’ assume_tac) >> + fs [] >> + pop_assum kall_tac >> + ‘evaluate (Assign tmp le, st with clock := ck' + st.clock) = + (NONE, st with <|locals := insert tmp (Word c') st.locals; + clock := ck' + st.clock|>)’ by ( + rw [evaluate_def, set_var_def, eval_upd_clock_eq]) >> + fs [Abbr ‘pp’, nested_seq_def] >> + simp [Once evaluate_def] >> + pop_assum kall_tac >> + simp [Once evaluate_def] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + simp [Once evaluate_def] >> + fs [get_var_imm_def] >> + rfs [asmTheory.word_cmp_def] >> + pop_assum mp_tac >> + simp [Once evaluate_def] >> + fs [] >> + strip_tac >> fs [] >> + strip_tac >> fs [] >> + rveq >> fs [cut_res_def] >> + rveq >> fs []) >> + strip_tac >> + fs [] >> rfs [] >> + last_x_assum (qspecl_then + [‘st with locals := insert tmp (Word c') st.locals’, + ‘ctxt’, ‘l’] mp_tac) >> + impl_tac + >- ( + fs [state_rel_def] >> + imp_res_tac compile_exp_out_rel >> + rveq >> + fs [locals_rel_def] >> + conj_tac + >- ( + drule cut_sets_union_domain_subset >> + strip_tac >> + match_mp_tac SUBSET_TRANS >> + qexists_tac ‘domain (cut_sets l (nested_seq np))’ >> + fs [] >> + fs [SUBSET_INSERT_RIGHT]) >> + rw [] >> res_tac >> fs [] >> + rveq >> fs [] >> + ‘n <> tmp’ by ( + CCONTR_TAC >> fs [] >> rveq >> + imp_res_tac compile_exp_out_rel >> + rveq >> + fs [ctxt_max_def] >> res_tac >> rfs []) >> + fs [lookup_insert, domain_lookup]) >> + strip_tac >> fs [] >> + first_x_assum drule_all >> + strip_tac >> fs [] >> + pairarg_tac >> fs [] >> rveq >> fs [] >> + qpat_x_assum ‘evaluate _ = (NONE,t1)’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck''’ assume_tac) >> + + qexists_tac ‘ck + ck' + ck''’ >> + simp [Once evaluate_def] >> + fs [cut_res_def, cut_state_def] >> + fs [dec_clock_def] >> + qmatch_goalsub_abbrev_tac ‘nested_seq (_ ++ pp)’ >> + qpat_x_assum ‘evaluate (nested_seq np, _) = _’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck' + ck''’ assume_tac) >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘pp’ assume_tac) >> + fs [] >> + pop_assum kall_tac >> + ‘evaluate (Assign tmp le, st with clock := ck' + (ck'' + st.clock)) = + (NONE, st with <|locals := insert tmp (Word c') st.locals; + clock := ck' + (ck'' + st.clock)|>)’ by ( + rw [evaluate_def, set_var_def, eval_upd_clock_eq]) >> + fs [Abbr ‘pp’, nested_seq_def] >> + simp [Once evaluate_def] >> + pop_assum kall_tac >> + simp [Once evaluate_def] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + simp [Once evaluate_def] >> + fs [get_var_imm_def] >> + rfs [asmTheory.word_cmp_def] >> + simp [Once evaluate_def] >> + simp [Once evaluate_def] >> + fs [cut_res_def] >> + strip_tac >> fs [] >> rveq >> + fs [] +QED + + +Theorem call_preserve_state_code_locals_rel: + !ns lns args s st ctxt nl fname argexps prog loc. + ALL_DISTINCT ns /\ ALL_DISTINCT lns /\ + LENGTH ns = LENGTH lns /\ + LENGTH args = LENGTH lns /\ + state_rel s st /\ + mem_rel ctxt.funcs s.memory st.memory /\ + globals_rel ctxt.funcs s.globals st.globals /\ + code_rel ctxt s.code st.code /\ + locals_rel ctxt nl s.locals st.locals /\ + FLOOKUP s.code fname = SOME (ns,prog) /\ + FLOOKUP ctxt.funcs fname = SOME (loc,LENGTH lns) /\ + MAP (eval s) argexps = MAP SOME args ==> + let nctxt = ctxt_fc ctxt.funcs ns lns in + state_rel + (s with + <|locals := FEMPTY |++ ZIP (ns,args); clock := s.clock − 1|>) + (st with + <|locals := + fromAList + (ZIP (lns,FRONT (MAP (wlab_wloc ctxt.funcs) args ++ [Loc loc 0]))); + clock := st.clock − 1|>) ∧ + code_rel nctxt s.code st.code ∧ + locals_rel nctxt (list_to_num_set lns) + (FEMPTY |++ ZIP (ns,args)) + (fromAList + (ZIP (lns,FRONT (MAP (wlab_wloc ctxt.funcs) args ++ [Loc loc 0])))) +Proof + rw [] >> + fs [ctxt_fc_def] + >- fs [state_rel_def] + >- fs [code_rel_def] >> + fs [locals_rel_def] >> + conj_tac + >- ( + fs [distinct_vars_def] >> + rw [] >> + qpat_x_assum ‘LENGTH ns = LENGTH lns’ assume_tac >> + drule fm_empty_zip_flookup >> + fs [] >> + disch_then (qspecl_then [‘x’ ,‘m’] mp_tac) >> + fs [] >> strip_tac >> fs [] >> + drule fm_empty_zip_flookup >> + fs [] >> + disch_then (qspecl_then [‘y’ ,‘m’] mp_tac) >> + fs [] >> strip_tac >> fs [] >> + ‘EL n (ZIP (ns,lns)) = (EL n ns,EL n lns)’ by metis_tac [EL_ZIP] >> + ‘EL n' (ZIP (ns,lns)) = (EL n' ns,EL n' lns)’ by metis_tac [EL_ZIP] >> + fs [] >> rveq >> metis_tac [ALL_DISTINCT_EL_IMP]) >> + conj_tac + >- ( + fs [ctxt_max_def] >> + rw [] >> + ‘MEM m lns’ by ( + qpat_x_assum ‘LENGTH ns = LENGTH lns’ assume_tac >> + drule fm_empty_zip_flookup >> + fs [] >> + disch_then (qspecl_then [‘v’ ,‘m’] mp_tac) >> + fs [] >> + strip_tac >> fs [] >> + fs [MEM_EL] >> + qexists_tac ‘n’ >> fs [] >> + drule EL_ZIP >> + disch_then (qspec_then ‘n’ mp_tac) >> fs []) >> + assume_tac list_max_max >> + pop_assum (qspec_then ‘lns’ assume_tac) >> + fs [EVERY_MEM]) >> + ‘FRONT (MAP (wlab_wloc ctxt.funcs) args ++ [Loc loc 0]) = + MAP (wlab_wloc ctxt.funcs) args’ by ( + cases_on ‘[Loc loc 0]’ >- fs [] >> + rewrite_tac [FRONT_APPEND, FRONT_DEF] >> + fs []) >> + fs [] >> + pop_assum kall_tac >> + conj_tac + >- ( + fs [domain_fromAList] >> + ‘LENGTH lns = LENGTH (MAP (wlab_wloc ctxt.funcs) args)’ by + fs [LENGTH_MAP] >> + drule MAP_ZIP >> + fs [GSYM PULL_FORALL] >> + strip_tac >> fs [] >> + fs [SUBSET_DEF] >> rw [] >> + fs [domain_list_to_num_set]) >> + rw [] >> + ‘LENGTH ns = LENGTH args’ by fs [] >> + drule fm_empty_zip_flookup >> + disch_then (qspecl_then [‘vname’, ‘v’] mp_tac) >> + fs [] >> + drule EL_ZIP >> + strip_tac >> + strip_tac >> fs [] >> + first_x_assum (qspec_then ‘n’ mp_tac) >> + fs [] >> + strip_tac >> rveq >> fs [] >> + qexists_tac ‘EL n lns’ >> + conj_tac + >- ( + match_mp_tac update_eq_zip_flookup >> + fs [])>> + conj_tac + >- ( + fs [domain_list_to_num_set] >> + metis_tac [EL_MEM]) >> + ‘lookup (EL n lns) (fromAList (ZIP (lns,MAP (wlab_wloc ctxt.funcs) args))) = + SOME (EL n (MAP (wlab_wloc ctxt.funcs) args))’ by ( + fs [lookup_fromAList] >> + ‘n < LENGTH (ZIP (lns,MAP (wlab_wloc ctxt.funcs) args))’ by + fs [LENGTH_MAP, LENGTH_ZIP] >> + drule ALOOKUP_ALL_DISTINCT_EL >> + impl_tac + >- metis_tac [MAP_ZIP, LENGTH_MAP] >> + strip_tac >> + metis_tac [EL_ZIP, FST, SND, LENGTH_MAP]) >> + fs [] >> pop_assum kall_tac >> + ‘n < LENGTH args’ by fs [] >> + drule (INST_TYPE [``:'a``|->``:'a word_lab``, + ``:'b``|->``:'a word_loc``] EL_MAP) >> + disch_then (qspec_then ‘wlab_wloc ctxt.funcs’ assume_tac) >> + fs [] >> + cases_on ‘EL n args’ >> + fs [wlab_wloc_def] >> + reverse FULL_CASE_TAC >> fs [] >> rveq + >- (cases_on ‘x’ >> fs []) >> + ‘eval s (EL n argexps) = SOME (Label m)’ by ( + ‘n < LENGTH argexps’ by metis_tac [LENGTH_MAP] >> + metis_tac [EL_MAP]) >> + drule eval_label_eq_state_contains_label >> + disch_then (qspec_then ‘m’ assume_tac) >> + fs [] + >- ( + imp_res_tac locals_rel_intro >> + res_tac >> rfs []) + >- ( + qpat_x_assum ‘code_rel ctxt s.code t.code’ assume_tac >> + drule code_rel_intro >> + strip_tac >> fs [] >> + res_tac >> rfs []) + >- ( + qpat_x_assum ‘mem_rel ctxt.funcs s.memory t.memory’ assume_tac >> + drule mem_rel_intro >> + strip_tac >> fs [] >> + res_tac >> rfs []) >> + qpat_x_assum ‘globals_rel ctxt.funcs s.globals st.globals’ assume_tac >> + drule globals_rel_intro >> + strip_tac >> fs [] >> + res_tac >> rfs [] +QED + +val tail_case_tac = + fs [crepSemTheory.evaluate_def, + CaseEq "option", CaseEq "word_lab",CaseEq "prod" ] >> + rveq >> fs [] >> + fs [compile_def] >> + pairarg_tac >> fs [] >> + ‘OPT_MMAP (eval s) (argexps ++ [trgt]) = + SOME (args ++ [Label fname])’ by fs [opt_mmap_eq_some] >> + drule comp_exps_preserves_eval >> + disch_then (qspecl_then [‘t’, + ‘ctxt’, ‘ctxt.vmax + 1’, ‘l’, + ‘p’,‘les’,‘tmp’,‘nl’] mp_tac) >> + fs [] >> + strip_tac >> + fs [opt_mmap_eq_some] >> + (* Keep progressing in crep's Call to estimate clock *) + fs [lookup_code_def, CaseEq "option", CaseEq "prod"] >> + rveq >> fs [] >> + cases_on ‘evaluate + (prog,dec_clock s with locals := FEMPTY |++ ZIP (ns,args))’ >> + fs [] >> + reverse (cases_on ‘s.clock = 0’) >> fs [] >> rveq >> fs [] + >- ( + ‘q ≠ SOME Error’ by fs [AllCaseEqs()] >> + fs [] >> + drule code_rel_intro >> + strip_tac >> + pop_assum mp_tac >> + disch_then (qspecl_then [‘fname’, ‘ns’, ‘prog’] mp_tac) >> + fs [] >> + strip_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘lookup _ st.code = SOME (lns,_)’ >> + ‘ALL_DISTINCT lns’ by fs [Abbr ‘lns’, ALL_DISTINCT_GENLIST] >> + last_x_assum + (qspecl_then [ + ‘dec_clock (st with locals := fromAList + (ZIP (lns,FRONT (MAP (wlab_wloc ctxt.funcs) args ++ [Loc loc 0]))))’, + ‘(ctxt_fc ctxt.funcs ns lns)’, ‘list_to_num_set lns’] mp_tac) >> + impl_tac + >- ( + fs [crepSemTheory.dec_clock_def, dec_clock_def] >> + ‘(ctxt_fc ctxt.funcs ns lns).funcs = ctxt.funcs’ by ( + fs [ctxt_fc_def]) >> fs [] >> + match_mp_tac (call_preserve_state_code_locals_rel |> SIMP_RULE bool_ss [LET_THM]) >> + fs [Abbr ‘lns’] >> + metis_tac []) >> + fs [Abbr ‘lns’] >> + strip_tac >> fs [dec_clock_def] >> + qexists_tac ‘ck + ck'’ >> + qpat_x_assum ‘ evaluate (_,_) = (NONE,st)’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck'’ assume_tac) >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then + ‘MAP2 Assign (gen_temps tmp (LENGTH les)) les ++ + [Call NONE NONE (gen_temps tmp (LENGTH les)) NONE]’ assume_tac) >> + fs [] >> pop_assum kall_tac >> + ‘MAP (eval st) les = MAP (eval (st with clock := ck' + st.clock)) les’ by ( + ho_match_mp_tac MAP_CONG >> + fs [] >> rw [] >> + fs[eval_upd_clock_eq]) >> + fs [] >> pop_assum kall_tac >> + ‘MAP (eval (st with clock := ck' + st.clock)) les = + MAP SOME (MAP (wlab_wloc ctxt.funcs) (args ++ [Label fname]))’ by fs [] >> + drule loop_eval_nested_assign_distinct_eq >> + disch_then (qspec_then ‘gen_temps tmp (LENGTH les)’ mp_tac) >> + impl_tac + >- ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + rewrite_tac [distinct_lists_def] >> + fs [EVERY_GENLIST] >> + rw [] >> + CCONTR_TAC >> fs [] >> + imp_res_tac locals_rel_intro >> + drule compile_exps_le_tmp_domain >> + disch_then drule >> + disch_then (qspec_then ‘tmp + x’ assume_tac) >> + rfs [] >> + fs [MEM_FLAT, MEM_MAP] >> rveq >> fs [] + >- ( + ‘?v. eval s y' = SOME v’ by ( + qpat_x_assum ‘MAP _ _ = MAP SOME args’ assume_tac >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN, MEM_EL]) >> + drule_all eval_some_var_cexp_local_lookup >> + strip_tac >> res_tac >> rfs [] >> rveq >> fs []) >> + drule_all eval_some_var_cexp_local_lookup >> + strip_tac >> res_tac >> rfs [] >> rveq >> fs []) >> + strip_tac >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘[Call NONE NONE (gen_temps tmp (LENGTH les)) NONE]’ + assume_tac) >> + fs [] >> pop_assum kall_tac >> + fs [nested_seq_def] >> + rewrite_tac [evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + fs [get_vars_local_clock_upd_eq] >> + ‘get_vars (gen_temps tmp (LENGTH les)) + (st with locals := + alist_insert (gen_temps tmp (LENGTH les)) + (MAP (wlab_wloc ctxt.funcs) args ++ [wlab_wloc ctxt.funcs (Label fname)]) st.locals) = + SOME (MAP (wlab_wloc ctxt.funcs) args ++ [wlab_wloc ctxt.funcs (Label fname)])’ by ( + ho_match_mp_tac get_vars_local_update_some_eq >> + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + fs [] >> pop_assum kall_tac >> + fs [find_code_def] >> + pop_assum mp_tac >> + rewrite_tac [wlab_wloc_def] >> + rfs [] >> + ‘st.clock <> 0’ by fs [state_rel_def] >> + fs [] >> + fs [dec_clock_def] >> + strip_tac >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs [] >> rveq >> + fs [] >> rveq >> fs [] >> + TRY ( + fs [ocompile_def] >> + qpat_x_assum ‘evaluate (compile _ _ _, _) = _’ assume_tac >> + drule loop_liveProofTheory.optimise_correct >> + fs [] >> + strip_tac >> fs [] >> rveq >> fs [] >> + fs [crepSemTheory.empty_locals_def, ctxt_fc_def] >> + fs [state_rel_def, code_rel_def])) >> + drule code_rel_intro >> + strip_tac >> + pop_assum mp_tac >> + disch_then (qspecl_then [‘fname’, ‘ns’, ‘prog’] mp_tac) >> + fs [] >> + strip_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘lookup _ st.code = SOME (lns,_)’ >> + ‘ALL_DISTINCT lns’ by fs [Abbr ‘lns’, ALL_DISTINCT_GENLIST] >> + fs [Abbr ‘lns’] >> + qexists_tac ‘ck’ >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then + ‘MAP2 Assign (gen_temps tmp (LENGTH les)) les ++ + [Call NONE NONE (gen_temps tmp (LENGTH les)) NONE]’ assume_tac) >> + fs [] >> pop_assum kall_tac >> + ‘MAP (eval st) les = + MAP SOME (MAP (wlab_wloc ctxt.funcs) (args ++ [Label fname]))’ by fs [] >> + drule loop_eval_nested_assign_distinct_eq >> + disch_then (qspec_then ‘gen_temps tmp (LENGTH les)’ mp_tac) >> + impl_tac + >- ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + rewrite_tac [distinct_lists_def] >> + fs [EVERY_GENLIST] >> + rw [] >> + CCONTR_TAC >> fs [] >> + imp_res_tac locals_rel_intro >> + drule compile_exps_le_tmp_domain >> + disch_then drule >> + disch_then (qspec_then ‘tmp + x’ assume_tac) >> + rfs [] >> + fs [MEM_FLAT, MEM_MAP] >> rveq >> fs [] + >- ( + ‘?v. eval s y' = SOME v’ by ( + qpat_x_assum ‘MAP _ _ = MAP SOME args’ assume_tac >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN, MEM_EL]) >> + drule_all eval_some_var_cexp_local_lookup >> + strip_tac >> res_tac >> rfs [] >> rveq >> fs []) >> + drule_all eval_some_var_cexp_local_lookup >> + strip_tac >> res_tac >> rfs [] >> rveq >> fs []) >> + strip_tac >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘[Call NONE NONE (gen_temps tmp (LENGTH les)) NONE]’ + assume_tac) >> + fs [] >> pop_assum kall_tac >> + fs [nested_seq_def] >> + rewrite_tac [evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + ‘get_vars (gen_temps tmp (LENGTH les)) + (st with locals := + alist_insert (gen_temps tmp (LENGTH les)) + (MAP (wlab_wloc ctxt.funcs) args ++ [wlab_wloc ctxt.funcs (Label fname)]) st.locals) = + SOME (MAP (wlab_wloc ctxt.funcs) args ++ [wlab_wloc ctxt.funcs (Label fname)])’ by ( + ho_match_mp_tac get_vars_local_update_some_eq >> + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + fs [] >> pop_assum kall_tac >> + fs [find_code_def] >> + pop_assum mp_tac >> + rewrite_tac [wlab_wloc_def] >> + rfs [] >> + ‘st.clock = 0’ by fs [state_rel_def] >> + fs [] >> strip_tac >> rveq >> fs [] >> + fs [crepSemTheory.empty_locals_def] >> + fs [state_rel_def] + +val timed_out_before_call_tac = + drule code_rel_intro >> + strip_tac >> + pop_assum mp_tac >> + disch_then (qspecl_then [‘fname’, ‘ns’, ‘prog’] mp_tac) >> + fs [] >> + strip_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘lookup _ st.code = SOME (lns,_)’ >> + ‘ALL_DISTINCT lns’ by fs [Abbr ‘lns’, ALL_DISTINCT_GENLIST] >> + qmatch_goalsub_abbrev_tac ‘nested_seq (p' ++ ptmp ++ pcal)’ >> + qexists_tac ‘ck’ >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘ptmp ++ pcal’ assume_tac) >> + fs [] >> pop_assum kall_tac >> + ‘MAP (eval st) les = + MAP SOME (MAP (wlab_wloc ctxt.funcs) (args ++ [Label fname]))’ by fs [] >> + drule loop_eval_nested_assign_distinct_eq >> + disch_then (qspec_then ‘gen_temps tmp (LENGTH les)’ mp_tac) >> + fs [Abbr ‘lns’] >> + impl_tac + >- ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + rewrite_tac [distinct_lists_def] >> + fs [EVERY_GENLIST] >> + rw [] >> + CCONTR_TAC >> fs [] >> + imp_res_tac locals_rel_intro >> + drule compile_exps_le_tmp_domain >> + disch_then drule >> + disch_then (qspec_then ‘tmp + x’ assume_tac) >> + rfs [] >> + fs [MEM_FLAT, MEM_MAP] >> rveq >> fs [] + >- ( + ‘?v. eval s y' = SOME v’ by ( + qpat_x_assum ‘MAP _ _ = MAP SOME args’ assume_tac >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN, MEM_EL]) >> + drule_all eval_some_var_cexp_local_lookup >> + strip_tac >> res_tac >> rfs [] >> rveq >> fs []) >> + drule_all eval_some_var_cexp_local_lookup >> + strip_tac >> res_tac >> rfs [] >> rveq >> fs []) >> + strip_tac >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘pcal’ assume_tac) >> + fs [Abbr ‘ptmp’] >> pop_assum kall_tac >> + fs [Abbr ‘pcal’, nested_seq_def] >> + rewrite_tac [evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + ‘get_vars (gen_temps tmp (LENGTH les)) + (st with locals := + alist_insert (gen_temps tmp (LENGTH les)) + (MAP (wlab_wloc ctxt.funcs) args ++ [wlab_wloc ctxt.funcs (Label fname)]) st.locals) = + SOME (MAP (wlab_wloc ctxt.funcs) args ++ [wlab_wloc ctxt.funcs (Label fname)])’ by ( + ho_match_mp_tac get_vars_local_update_some_eq >> + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + fs [] >> pop_assum kall_tac >> + fs [find_code_def] >> + pop_assum mp_tac >> + rewrite_tac [wlab_wloc_def] >> + rfs [] >> + fs [cut_res_def, cut_state_def] >> + ‘LENGTH ((gen_temps tmp (LENGTH les))) = + LENGTH (MAP (wlab_wloc ctxt.funcs) args ++ [Loc loc 0])’ by ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + drule domain_alist_insert >> + disch_then (qspec_then ‘st.locals’ mp_tac) >> + strip_tac >> fs [] >> + ‘domain l ⊆ domain st.locals ∪ set (gen_temps tmp (LENGTH les))’ by ( + qsuff_tac ‘domain l ⊆ domain st.locals’ + >- fs [SUBSET_DEF] >> + imp_res_tac compile_exps_out_rel >> rveq >> fs [] >> + imp_res_tac locals_rel_intro >> + imp_res_tac cut_sets_union_domain_subset >> + fs [SUBSET_DEF]) >> + ‘st.clock = 0’ by fs [state_rel_def] >> + fs [] >> strip_tac >> rveq >> fs [] >> + fs [crepSemTheory.empty_locals_def] >> + fs [state_rel_def] + + +val fcalled_timed_out_tac = + (* Timeout case of the called function *) + fs [Abbr ‘lns’] >> + qexists_tac ‘ck + ck'’ >> + qpat_x_assum ‘ evaluate (_,_) = (NONE,st)’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck'’ assume_tac) >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘ptmp ++ pcal’ assume_tac) >> + fs [] >> pop_assum kall_tac >> + ‘MAP (eval st) les = + MAP SOME (MAP (wlab_wloc ctxt.funcs) (args ++ [Label fname]))’ by fs [] >> + drule loop_eval_nested_assign_distinct_eq >> + disch_then (qspec_then ‘gen_temps tmp (LENGTH les)’ mp_tac) >> + impl_tac + >- ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + rewrite_tac [distinct_lists_def] >> + fs [EVERY_GENLIST] >> + rw [] >> + CCONTR_TAC >> fs [] >> + imp_res_tac locals_rel_intro >> + drule compile_exps_le_tmp_domain >> + disch_then drule >> + disch_then (qspec_then ‘tmp + x’ assume_tac) >> + rfs [] >> + fs [MEM_FLAT, MEM_MAP] >> rveq >> fs [] + >- ( + ‘?v. eval s y' = SOME v’ by ( + qpat_x_assum ‘MAP _ _ = MAP SOME args’ assume_tac >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN, MEM_EL]) >> + drule_all eval_some_var_cexp_local_lookup >> + strip_tac >> res_tac >> rfs [] >> rveq >> fs []) >> + drule_all eval_some_var_cexp_local_lookup >> + strip_tac >> res_tac >> rfs [] >> rveq >> fs []) >> + strip_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck'’ assume_tac) >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘pcal’ assume_tac) >> + fs [Abbr ‘ptmp’] >> pop_assum kall_tac >> + fs [Abbr ‘pcal’, nested_seq_def] >> + rewrite_tac [evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + fs [get_vars_local_clock_upd_eq] >> + ‘get_vars (gen_temps tmp (LENGTH les)) + (st with locals := + alist_insert (gen_temps tmp (LENGTH les)) + (MAP (wlab_wloc ctxt.funcs) args ++ [wlab_wloc ctxt.funcs (Label fname)]) st.locals) = + SOME (MAP (wlab_wloc ctxt.funcs) args ++ [wlab_wloc ctxt.funcs (Label fname)])’ by ( + ho_match_mp_tac get_vars_local_update_some_eq >> + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + fs [] >> pop_assum kall_tac >> + fs [find_code_def] >> + pop_assum mp_tac >> + rewrite_tac [wlab_wloc_def] >> + rfs [] >> + fs [cut_res_def, cut_state_def] >> + ‘LENGTH ((gen_temps tmp (LENGTH les))) = + LENGTH (MAP (wlab_wloc ctxt.funcs) args ++ [Loc loc 0])’ by ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + drule domain_alist_insert >> + disch_then (qspec_then ‘st.locals’ mp_tac) >> + strip_tac >> fs [] >> + ‘domain l ⊆ domain st.locals ∪ set (gen_temps tmp (LENGTH les))’ by ( + qsuff_tac ‘domain l ⊆ domain st.locals’ + >- fs [SUBSET_DEF] >> + imp_res_tac compile_exps_out_rel >> rveq >> fs [] >> + imp_res_tac locals_rel_intro >> + imp_res_tac cut_sets_union_domain_subset >> + fs [SUBSET_DEF]) >> + fs [] >> + ‘st.clock <> 0’ by fs [state_rel_def] >> + fs [dec_clock_def] >> + strip_tac >> rveq >> fs [] >> + fs [ocompile_def] >> + qpat_x_assum ‘evaluate (compile _ _ _, _) = _’ assume_tac >> + drule loop_liveProofTheory.optimise_correct >> + fs [] >> + strip_tac >> fs [] >> rveq >> fs [] >> + fs [crepSemTheory.empty_locals_def] >> + fs [state_rel_def] >> + conj_tac + >- ( + qpat_x_assum ‘mem_rel _ r.memory s1.memory’ assume_tac >> + fs [mem_rel_def, ctxt_fc_def] >> + rw [] >> + cases_on ‘s1.memory ad’ >> fs [] >> + cases_on ‘r.memory ad’ >> fs [] >> + first_x_assum (qspec_then ‘ad’ assume_tac) >> + rfs [wlab_wloc_def]) >> + conj_tac + >- ( + qpat_x_assum ‘globals_rel _ r.globals s1.globals’ assume_tac >> + fs [globals_rel_def, ctxt_fc_def] >> + rw [] >> + first_x_assum (qspec_then ‘ad’ assume_tac) >> + TRY (cases_on ‘v’) >> + rfs [wlab_wloc_def]) >> + fs [code_rel_def, ctxt_fc_def] + + +val fcalled_ffi_case_tac = +(* FFI case of the called function *) + fs [Abbr ‘lns’] >> + qexists_tac ‘ck + ck'’ >> + qpat_x_assum ‘ evaluate (_,_) = (NONE,st)’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck'’ assume_tac) >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘ptmp ++ pcal’ assume_tac) >> + fs [] >> pop_assum kall_tac >> + ‘MAP (eval st) les = + MAP SOME (MAP (wlab_wloc ctxt.funcs) (args ++ [Label fname]))’ by fs [] >> + drule loop_eval_nested_assign_distinct_eq >> + disch_then (qspec_then ‘gen_temps tmp (LENGTH les)’ mp_tac) >> + impl_tac + >- ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + rewrite_tac [distinct_lists_def] >> + fs [EVERY_GENLIST] >> + rw [] >> + CCONTR_TAC >> fs [] >> + imp_res_tac locals_rel_intro >> + drule compile_exps_le_tmp_domain >> + disch_then drule >> + disch_then (qspec_then ‘tmp + x’ assume_tac) >> + rfs [] >> + fs [MEM_FLAT, MEM_MAP] >> rveq >> fs [] + >- ( + ‘?v. eval s y' = SOME v’ by ( + qpat_x_assum ‘MAP _ _ = MAP SOME args’ assume_tac >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN, MEM_EL]) >> + drule_all eval_some_var_cexp_local_lookup >> + strip_tac >> res_tac >> rfs [] >> rveq >> fs []) >> + drule_all eval_some_var_cexp_local_lookup >> + strip_tac >> res_tac >> rfs [] >> rveq >> fs []) >> + strip_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck'’ assume_tac) >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘pcal’ assume_tac) >> + fs [Abbr ‘ptmp’] >> pop_assum kall_tac >> + fs [Abbr ‘pcal’, nested_seq_def] >> + rewrite_tac [evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + fs [get_vars_local_clock_upd_eq] >> + ‘get_vars (gen_temps tmp (LENGTH les)) + (st with locals := + alist_insert (gen_temps tmp (LENGTH les)) + (MAP (wlab_wloc ctxt.funcs) args ++ [wlab_wloc ctxt.funcs (Label fname)]) st.locals) = + SOME (MAP (wlab_wloc ctxt.funcs) args ++ [wlab_wloc ctxt.funcs (Label fname)])’ by ( + ho_match_mp_tac get_vars_local_update_some_eq >> + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + fs [] >> pop_assum kall_tac >> + fs [find_code_def] >> + pop_assum mp_tac >> + rewrite_tac [wlab_wloc_def] >> + rfs [] >> + fs [cut_res_def, cut_state_def] >> + ‘LENGTH ((gen_temps tmp (LENGTH les))) = + LENGTH (MAP (wlab_wloc ctxt.funcs) args ++ [Loc loc 0])’ by ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + drule domain_alist_insert >> + disch_then (qspec_then ‘st.locals’ mp_tac) >> + strip_tac >> fs [] >> + ‘domain l ⊆ domain st.locals ∪ set (gen_temps tmp (LENGTH les))’ by ( + qsuff_tac ‘domain l ⊆ domain st.locals’ + >- fs [SUBSET_DEF] >> + imp_res_tac compile_exps_out_rel >> rveq >> fs [] >> + imp_res_tac locals_rel_intro >> + imp_res_tac cut_sets_union_domain_subset >> + fs [SUBSET_DEF]) >> + fs [] >> + ‘st.clock <> 0’ by fs [state_rel_def] >> + fs [dec_clock_def] >> + strip_tac >> rveq >> fs [] >> + fs [crepSemTheory.empty_locals_def] >> + fs [state_rel_def] >> + conj_tac + >- ( + qpat_x_assum ‘mem_rel _ r.memory s1.memory’ assume_tac >> + fs [mem_rel_def, ctxt_fc_def] >> + rw [] >> + cases_on ‘s1.memory ad’ >> fs [] >> + cases_on ‘r.memory ad’ >> fs [] >> + first_x_assum (qspec_then ‘ad’ assume_tac) >> + rfs [wlab_wloc_def]) >> + conj_tac + >- ( + qpat_x_assum ‘globals_rel _ r.globals s1.globals’ assume_tac >> + fs [globals_rel_def, ctxt_fc_def] >> + rw [] >> + first_x_assum (qspec_then ‘ad’ assume_tac) >> + TRY (cases_on ‘v’) >> + rfs [wlab_wloc_def]) >> + fs [code_rel_def, ctxt_fc_def] + + +Theorem compile_Call: + ^(get_goal "compile _ _ (crepLang$Call _ _ _)") +Proof + rw [] >> + cases_on ‘caltyp’ >> fs [] + (* Tail case *) + >- tail_case_tac >> + (* Return case *) + fs [crepSemTheory.evaluate_def, + CaseEq "option", CaseEq "word_lab",CaseEq "prod"] >> + rveq >> fs [] >> + fs [compile_def] >> + pairarg_tac >> fs [] >> + ‘OPT_MMAP (eval s) (argexps ++ [trgt]) = + SOME (args ++ [Label fname])’ by fs [opt_mmap_eq_some] >> + drule comp_exps_preserves_eval >> + disch_then (qspecl_then [‘t’, + ‘ctxt’, ‘ctxt.vmax + 1’, ‘l’, + ‘p'’,‘les’,‘tmp’,‘nl’] mp_tac) >> + fs [] >> + strip_tac >> + fs [opt_mmap_eq_some] >> + (* Keep progressing in crep's Call to estimate clock *) + fs [lookup_code_def, CaseEq "option", CaseEq "prod"] >> + rveq >> fs [] >> + cases_on ‘evaluate + (prog,dec_clock s with locals := FEMPTY |++ ZIP (ns,args))’ >> + fs [] >> + cases_on ‘s.clock = 0’ >> fs [] >> rveq >> fs [] + (* time-out before the function call *) + >- timed_out_before_call_tac >> + ‘q ≠ SOME Error’ by fs [AllCaseEqs()] >> + fs [] >> + drule code_rel_intro >> + strip_tac >> + pop_assum mp_tac >> + disch_then (qspecl_then [‘fname’, ‘ns’, ‘prog’] mp_tac) >> + fs [] >> + strip_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘lookup _ st.code = SOME (lns,_)’ >> + qmatch_goalsub_abbrev_tac ‘nested_seq (p' ++ ptmp ++ pcal)’ >> + ‘ALL_DISTINCT lns’ by fs [Abbr ‘lns’, ALL_DISTINCT_GENLIST] >> + first_x_assum + (qspecl_then [ + ‘dec_clock (st with locals := fromAList + (ZIP (lns,FRONT (MAP (wlab_wloc ctxt.funcs) args ++ [Loc loc 0]))))’, + ‘(ctxt_fc ctxt.funcs ns lns)’, ‘list_to_num_set lns’] mp_tac) >> + impl_tac + >- ( + fs [crepSemTheory.dec_clock_def, dec_clock_def] >> + ‘(ctxt_fc ctxt.funcs ns lns).funcs = ctxt.funcs’ by ( + fs [ctxt_fc_def]) >> fs [] >> + match_mp_tac (call_preserve_state_code_locals_rel |> SIMP_RULE bool_ss [LET_THM]) >> + fs [Abbr ‘lns’] >> + metis_tac []) >> + strip_tac >> fs [dec_clock_def] >> + cases_on ‘q’ >> fs [] >> rveq >> + cases_on ‘x’ >> fs [] >> rveq + (* time-out in the called function *) + >- fcalled_timed_out_tac + (* return from called function *) + >- ( + (* case split on return option variable *) + fs [CaseEq "option"] >> rveq >> + fs [rt_var_def] >> + ‘(ctxt_fc ctxt.funcs ns lns).funcs = ctxt.funcs’ by ( + fs [ctxt_fc_def]) >> + fs [] >> pop_assum kall_tac >> + TRY ( + fs [rt_var_def] >> + ‘IS_SOME (FLOOKUP ctxt.vars rt)’ by ( + imp_res_tac locals_rel_intro >> + res_tac >> rfs [IS_SOME_DEF]) >> + cases_on ‘FLOOKUP ctxt.vars rt’ >> + fs [IS_SOME_DEF]) >> + qmatch_asmsub_abbrev_tac ‘Call (SOME (rn,_))’ >> + last_x_assum (qspecl_then + [‘t1 with locals := + insert rn + (wlab_wloc ctxt.funcs w) + (inter (alist_insert (gen_temps tmp (LENGTH les)) + (MAP (wlab_wloc ctxt.funcs) args ++ [Loc loc 0]) + st.locals) l)’, + ‘ctxt’, ‘l’] mp_tac) >> + impl_tac >> + TRY ( + fs [Abbr ‘lns’] >> + fs [crepSemTheory.set_var_def, ctxt_fc_def] >> + conj_tac >- fs [state_rel_def] >> + conj_tac + >- ( + FULL_CASE_TAC >> fs [] >> rveq >> fs [] >> + fs [code_rel_def]) >> + fs [locals_rel_def] >> + conj_tac + >- ( + fs [domain_inter] >> + ‘LENGTH (gen_temps tmp (LENGTH les)) = + LENGTH (MAP (wlab_wloc ctxt.funcs) args ++ [Loc loc 0])’ by ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + drule domain_alist_insert >> + disch_then (qspec_then ‘st.locals’ assume_tac) >> + fs [] >> + qsuff_tac + ‘(domain st.locals ∪ set (gen_temps tmp (LENGTH les))) ∩ domain l = domain l’ + >- fs [SUBSET_INSERT_RIGHT] >> + fs [INTER_SUBSET_EQN |> CONJUNCT2] >> + imp_res_tac compile_exps_out_rel >> fs [] >> rveq >> fs [] >> + imp_res_tac cut_sets_union_domain_subset >> + fs [SUBSET_DEF]) >> + TRY ( + rename [‘rn = ctxt.vmax + 1’] >> + rw [] >> + res_tac >> rfs [] >> + ‘n' <> rn’ by ( + fs [Abbr ‘rn’] >> + fs [ctxt_max_def] >> res_tac >> rfs [])) >> + TRY ( + rename [‘s.locals |+ (rt,w)’] >> + rw [FLOOKUP_UPDATE] >> + res_tac >> fs [] >> rveq >> fs [] + >- ( + cases_on ‘v’ >> fs [wlab_wloc_def] >> + rfs [FDOM_FLOOKUP] >> + cases_on ‘v’ >> fs []) >> + ‘n <> n'’ by ( + CCONTR_TAC >> fs [] >> rveq >> + fs [distinct_vars_def] >> res_tac >> rfs [])) >> + qmatch_goalsub_rename_tac ‘lookup nn _’ >> + qmatch_goalsub_rename_tac ‘insert rn _ _’ >> + fs [lookup_insert, lookup_inter] >> + ‘LENGTH (gen_temps tmp (LENGTH les)) = + LENGTH (MAP (wlab_wloc ctxt.funcs) args ++ [Loc loc 0])’ by ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + drule MEM_ZIP >> + strip_tac >> + drule lookup_alist_insert >> + disch_then (qspec_then ‘st.locals’ assume_tac) >> + fs [] >> + ‘ALOOKUP (ZIP + (gen_temps tmp (LENGTH les), + MAP (wlab_wloc ctxt.funcs) args ++ [Loc loc 0])) nn = NONE’ by ( + TRY (fs [Abbr ‘rn’]) >> + fs [ALOOKUP_NONE] >> + CCONTR_TAC >> fs [MEM_MAP] >> + first_x_assum (qspec_then ‘y’ assume_tac) >> + fs [] >> rveq >> fs [FST] >> + qmatch_asmsub_rename_tac ‘nt < LENGTH _’ >> + + ‘tmp <= EL nt (gen_temps tmp (LENGTH les))’ by + fs [gen_temps_def] >> + imp_res_tac compile_exps_out_rel >> + fs [ctxt_max_def] >> res_tac >> rfs []) >> + fs [domain_lookup] >> + TRY (cases_on ‘v’ >> fs [wlab_wloc_def]) >> NO_TAC) >> + ( + strip_tac >> fs [Abbr ‘rn’, Abbr ‘lns’] >> + cases_on ‘res’ >> fs [] >> rveq + (* NONE case of return handler *) + >- ( + qexists_tac ‘ck + ck' + ck'' + 1’ >> + qpat_x_assum ‘ evaluate (_,_) = (NONE,st)’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck' + ck'' + 1’ assume_tac) >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘ptmp ++ pcal’ assume_tac) >> + fs [] >> pop_assum kall_tac >> + ‘MAP (eval st) les = + MAP SOME (MAP (wlab_wloc ctxt.funcs) (args ++ [Label fname]))’ by fs [] >> + drule loop_eval_nested_assign_distinct_eq >> + disch_then (qspec_then ‘gen_temps tmp (LENGTH les)’ mp_tac) >> + impl_tac + >- ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + rewrite_tac [distinct_lists_def] >> + fs [EVERY_GENLIST] >> + rw [] >> + CCONTR_TAC >> fs [] >> + imp_res_tac locals_rel_intro >> + drule compile_exps_le_tmp_domain >> + disch_then drule >> + qmatch_asmsub_rename_tac ‘tmp + nx’ >> + disch_then (qspec_then ‘tmp + nx’ assume_tac) >> + rfs [] >> + fs [MEM_FLAT, MEM_MAP] >> rveq >> fs [] + >- ( + qmatch_asmsub_rename_tac ‘ MEM _ (var_cexp cv)’ >> + ‘?v. eval s cv = SOME v’ by ( + qpat_x_assum ‘MAP _ _ = MAP SOME args’ assume_tac >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN, MEM_EL]) >> + drule_all eval_some_var_cexp_local_lookup >> + strip_tac >> fs [locals_rel_def] >> + res_tac >> rfs [] >> rveq >> fs []) >> + drule_all eval_some_var_cexp_local_lookup >> + strip_tac >> fs [locals_rel_def] >> + res_tac >> rfs [] >> rveq >> fs []) >> + strip_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck' + ck'' + 1’ assume_tac) >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘pcal’ assume_tac) >> + fs [Abbr ‘ptmp’] >> pop_assum kall_tac >> + fs [Abbr ‘pcal’, nested_seq_def] >> + rewrite_tac [evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + fs [get_vars_local_clock_upd_eq] >> + ‘get_vars (gen_temps tmp (LENGTH les)) + (st with locals := + alist_insert (gen_temps tmp (LENGTH les)) + (MAP (wlab_wloc ctxt.funcs) args ++ [wlab_wloc ctxt.funcs (Label fname)]) st.locals) = + SOME (MAP (wlab_wloc ctxt.funcs) args ++ [wlab_wloc ctxt.funcs (Label fname)])’ by ( + ho_match_mp_tac get_vars_local_update_some_eq >> + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + fs [] >> pop_assum kall_tac >> + fs [find_code_def] >> + pop_assum mp_tac >> + rewrite_tac [wlab_wloc_def] >> + rfs [] >> + fs [cut_res_def, cut_state_def] >> + ‘LENGTH ((gen_temps tmp (LENGTH les))) = + LENGTH (MAP (wlab_wloc ctxt.funcs) args ++ [Loc loc 0])’ by ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + drule domain_alist_insert >> + disch_then (qspec_then ‘st.locals’ mp_tac) >> + strip_tac >> fs [] >> + ‘domain l ⊆ domain st.locals ∪ set (gen_temps tmp (LENGTH les))’ by ( + qsuff_tac ‘domain l ⊆ domain st.locals’ + >- fs [SUBSET_DEF] >> + imp_res_tac compile_exps_out_rel >> rveq >> fs [] >> + imp_res_tac locals_rel_intro >> + imp_res_tac cut_sets_union_domain_subset >> + fs [SUBSET_DEF]) >> + fs [] >> + ‘st.clock <> 0’ by fs [state_rel_def] >> + fs [dec_clock_def] >> + rfs [set_var_def] >> + qpat_x_assum ‘ evaluate (compile _ _ prog, _) = (_,t1)’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck'' + 1’ assume_tac) >> + fs [] >> + fs [ocompile_def] >> + drule loop_liveProofTheory.optimise_correct >> + fs [] >> + strip_tac >> fs [] >> rveq >> fs [] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + rfs [] >> + qpat_x_assum ‘evaluate (compile _ _ p, _) = (_,t1')’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘1’ assume_tac) >> + fs [] >> pop_assum kall_tac >> + strip_tac >> + fs [cut_res_def, cut_state_def] >> + ‘domain l ⊆ domain t1'.locals’ by ( + imp_res_tac locals_rel_intro >> + fs [SUBSET_INSERT_RIGHT]) >> + fs [dec_clock_def] >> rveq >> fs [] >> + conj_tac >- fs [state_rel_def] >> + qpat_x_assum ‘locals_rel _ _ s1.locals _’ assume_tac >> + fs [locals_rel_def] >> + conj_tac >- fs [domain_inter, SUBSET_DEF] >> + rw [] >> + res_tac >> fs [] >> + fs [lookup_inter, domain_lookup]) >> + qexists_tac ‘ck + ck' + ck''’ >> + qpat_x_assum ‘ evaluate (_,_) = (NONE,st)’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck' + ck''’ assume_tac) >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘ptmp ++ pcal’ assume_tac) >> + fs [] >> pop_assum kall_tac >> + ‘MAP (eval st) les = + MAP SOME (MAP (wlab_wloc ctxt.funcs) (args ++ [Label fname]))’ by fs [] >> + drule loop_eval_nested_assign_distinct_eq >> + disch_then (qspec_then ‘gen_temps tmp (LENGTH les)’ mp_tac) >> + impl_tac + >- ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + rewrite_tac [distinct_lists_def] >> + fs [EVERY_GENLIST] >> + rw [] >> + CCONTR_TAC >> fs [] >> + imp_res_tac locals_rel_intro >> + drule compile_exps_le_tmp_domain >> + disch_then drule >> + qmatch_asmsub_rename_tac ‘tmp + nx’ >> + disch_then (qspec_then ‘tmp + nx’ assume_tac) >> + rfs [] >> + fs [MEM_FLAT, MEM_MAP] >> rveq >> fs [] + >- ( + qmatch_asmsub_rename_tac ‘MEM _ (var_cexp cv)’ >> + ‘?v. eval s cv = SOME v’ by ( + qpat_x_assum ‘MAP _ _ = MAP SOME args’ assume_tac >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN, MEM_EL]) >> + drule_all eval_some_var_cexp_local_lookup >> + strip_tac >> fs [locals_rel_def] >> + res_tac >> rfs [] >> rveq >> fs []) >> + drule_all eval_some_var_cexp_local_lookup >> + strip_tac >> fs [locals_rel_def] >> + res_tac >> rfs [] >> rveq >> fs []) >> + strip_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck' + ck''’ assume_tac) >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘pcal’ assume_tac) >> + fs [Abbr ‘ptmp’] >> pop_assum kall_tac >> + fs [Abbr ‘pcal’, nested_seq_def] >> + rewrite_tac [evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + fs [get_vars_local_clock_upd_eq] >> + ‘get_vars (gen_temps tmp (LENGTH les)) + (st with locals := + alist_insert (gen_temps tmp (LENGTH les)) + (MAP (wlab_wloc ctxt.funcs) args ++ [wlab_wloc ctxt.funcs (Label fname)]) st.locals) = + SOME (MAP (wlab_wloc ctxt.funcs) args ++ [wlab_wloc ctxt.funcs (Label fname)])’ by ( + ho_match_mp_tac get_vars_local_update_some_eq >> + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + fs [] >> pop_assum kall_tac >> + fs [find_code_def] >> + pop_assum mp_tac >> + rewrite_tac [wlab_wloc_def] >> + rfs [] >> + fs [cut_res_def, cut_state_def] >> + ‘LENGTH ((gen_temps tmp (LENGTH les))) = + LENGTH (MAP (wlab_wloc ctxt.funcs) args ++ [Loc loc 0])’ by ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + drule domain_alist_insert >> + disch_then (qspec_then ‘st.locals’ mp_tac) >> + strip_tac >> fs [] >> + ‘domain l ⊆ domain st.locals ∪ set (gen_temps tmp (LENGTH les))’ by ( + qsuff_tac ‘domain l ⊆ domain st.locals’ + >- fs [SUBSET_DEF] >> + imp_res_tac compile_exps_out_rel >> rveq >> fs [] >> + imp_res_tac locals_rel_intro >> + imp_res_tac cut_sets_union_domain_subset >> + fs [SUBSET_DEF]) >> + fs [] >> + ‘st.clock <> 0’ by fs [state_rel_def] >> + fs [dec_clock_def] >> + qpat_x_assum ‘ evaluate (compile _ _ prog, _) = (_,t1)’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck''’ assume_tac) >> + fs [] >> + fs [ocompile_def] >> + drule loop_liveProofTheory.optimise_correct >> + fs [] >> + strip_tac >> fs [] >> rveq >> fs [] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + rfs [set_var_def] >> + qmatch_asmsub_rename_tac ‘rx ≠ Error’ >> + cases_on ‘rx’ >> fs [] >> rveq >> fs [] >> + fs [cut_res_def, cut_state_def] >> + strip_tac >> fs [] >> rveq >> fs [] >> + fs [code_rel_def])) + >- ( + (* case split on handler option variable *) + fs [CaseEq "option"] >> rveq >> fs [] + (* NONE case of excp handler *) + >- ( + fs [Abbr ‘lns’] >> + qexists_tac ‘ck + ck'’ >> + qpat_x_assum ‘ evaluate (_,_) = (NONE,st)’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck'’ assume_tac) >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘ptmp ++ pcal’ assume_tac) >> + fs [] >> pop_assum kall_tac >> + ‘MAP (eval st) les = + MAP SOME (MAP (wlab_wloc ctxt.funcs) (args ++ [Label fname]))’ by fs [] >> + drule loop_eval_nested_assign_distinct_eq >> + disch_then (qspec_then ‘gen_temps tmp (LENGTH les)’ mp_tac) >> + impl_tac + >- ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + rewrite_tac [distinct_lists_def] >> + fs [EVERY_GENLIST] >> + rw [] >> + CCONTR_TAC >> fs [] >> + imp_res_tac locals_rel_intro >> + drule compile_exps_le_tmp_domain >> + disch_then drule >> + qmatch_asmsub_rename_tac ‘tmp + nx’ >> + disch_then (qspec_then ‘tmp + nx’ assume_tac) >> + rfs [] >> + fs [MEM_FLAT, MEM_MAP] >> rveq >> fs [] + >- ( + qmatch_asmsub_rename_tac ‘ MEM _ (var_cexp cv)’ >> + ‘?v. eval s cv = SOME v’ by ( + qpat_x_assum ‘MAP _ _ = MAP SOME args’ assume_tac >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN, MEM_EL]) >> + drule_all eval_some_var_cexp_local_lookup >> + strip_tac >> fs [locals_rel_def] >> + res_tac >> rfs [] >> rveq >> fs []) >> + drule_all eval_some_var_cexp_local_lookup >> + strip_tac >> fs [locals_rel_def] >> + res_tac >> rfs [] >> rveq >> fs []) >> + strip_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck'’ assume_tac) >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘pcal’ assume_tac) >> + fs [Abbr ‘ptmp’] >> pop_assum kall_tac >> + fs [Abbr ‘pcal’, nested_seq_def] >> + rewrite_tac [evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + fs [get_vars_local_clock_upd_eq] >> + ‘get_vars (gen_temps tmp (LENGTH les)) + (st with locals := + alist_insert (gen_temps tmp (LENGTH les)) + (MAP (wlab_wloc ctxt.funcs) args ++ [wlab_wloc ctxt.funcs (Label fname)]) st.locals) = + SOME (MAP (wlab_wloc ctxt.funcs) args ++ [wlab_wloc ctxt.funcs (Label fname)])’ by ( + ho_match_mp_tac get_vars_local_update_some_eq >> + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + fs [] >> pop_assum kall_tac >> + fs [find_code_def] >> + pop_assum mp_tac >> + rewrite_tac [wlab_wloc_def] >> + rfs [] >> + fs [cut_res_def, cut_state_def] >> + ‘LENGTH ((gen_temps tmp (LENGTH les))) = + LENGTH (MAP (wlab_wloc ctxt.funcs) args ++ [Loc loc 0])’ by ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + drule domain_alist_insert >> + disch_then (qspec_then ‘st.locals’ mp_tac) >> + strip_tac >> fs [] >> + ‘domain l ⊆ domain st.locals ∪ set (gen_temps tmp (LENGTH les))’ by ( + qsuff_tac ‘domain l ⊆ domain st.locals’ + >- fs [SUBSET_DEF] >> + imp_res_tac compile_exps_out_rel >> rveq >> fs [] >> + imp_res_tac locals_rel_intro >> + imp_res_tac cut_sets_union_domain_subset >> + fs [SUBSET_DEF]) >> + fs [] >> + ‘st.clock <> 0’ by fs [state_rel_def] >> + fs [dec_clock_def] >> + rfs [set_var_def] >> + qpat_x_assum ‘ evaluate (compile _ _ prog, _) = (_,t1)’ assume_tac >> + fs [ocompile_def] >> + drule loop_liveProofTheory.optimise_correct >> + fs [] >> + strip_tac >> fs [] >> rveq >> fs [] >> + pop_assum kall_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘1’ assume_tac) >> + fs [] >> + pop_assum kall_tac >> + rfs [] >> + fs [evaluate_def, cut_res_def] >> + strip_tac >> fs [] >> rveq >> + fs [call_env_def] >> + fs [crepSemTheory.empty_locals_def, ctxt_fc_def] >> + fs [state_rel_def, code_rel_def]) >> + (* SOME case of excp handler *) + cases_on ‘v3’ >> fs [] >> + fs [Abbr ‘lns’] >> + (* cannot delay case split on exp values + because of clock inst *) + reverse (cases_on ‘c = c'’) >> fs [] + >- ( + (* absent eid *) + qexists_tac ‘ck + ck'’ >> + qpat_x_assum ‘ evaluate (_,_) = (NONE,st)’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck'’ assume_tac) >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘ptmp ++ pcal’ assume_tac) >> + fs [] >> pop_assum kall_tac >> + ‘MAP (eval st) les = + MAP SOME (MAP (wlab_wloc ctxt.funcs) (args ++ [Label fname]))’ by fs [] >> + drule loop_eval_nested_assign_distinct_eq >> + disch_then (qspec_then ‘gen_temps tmp (LENGTH les)’ mp_tac) >> + impl_tac + >- ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + rewrite_tac [distinct_lists_def] >> + fs [EVERY_GENLIST] >> + rw [] >> + CCONTR_TAC >> fs [] >> + imp_res_tac locals_rel_intro >> + drule compile_exps_le_tmp_domain >> + disch_then drule >> + qmatch_asmsub_rename_tac ‘tmp + nx’ >> + disch_then (qspec_then ‘tmp + nx’ assume_tac) >> + rfs [] >> + fs [MEM_FLAT, MEM_MAP] >> rveq >> fs [] + >- ( + qmatch_asmsub_rename_tac ‘ MEM _ (var_cexp cv)’ >> + ‘?v. eval s cv = SOME v’ by ( + qpat_x_assum ‘MAP _ _ = MAP SOME args’ assume_tac >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN, MEM_EL]) >> + drule_all eval_some_var_cexp_local_lookup >> + strip_tac >> fs [locals_rel_def] >> + res_tac >> rfs [] >> rveq >> fs []) >> + drule_all eval_some_var_cexp_local_lookup >> + strip_tac >> fs [locals_rel_def] >> + res_tac >> rfs [] >> rveq >> fs []) >> + strip_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck'’ assume_tac) >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘pcal’ assume_tac) >> + fs [Abbr ‘ptmp’] >> pop_assum kall_tac >> + fs [Abbr ‘pcal’, nested_seq_def] >> + rewrite_tac [evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + fs [get_vars_local_clock_upd_eq] >> + ‘get_vars (gen_temps tmp (LENGTH les)) + (st with locals := + alist_insert (gen_temps tmp (LENGTH les)) + (MAP (wlab_wloc ctxt.funcs) args ++ [wlab_wloc ctxt.funcs (Label fname)]) st.locals) = + SOME (MAP (wlab_wloc ctxt.funcs) args ++ [wlab_wloc ctxt.funcs (Label fname)])’ by ( + ho_match_mp_tac get_vars_local_update_some_eq >> + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + fs [] >> pop_assum kall_tac >> + fs [find_code_def] >> + pop_assum mp_tac >> + rewrite_tac [wlab_wloc_def] >> + rfs [] >> + fs [cut_res_def, cut_state_def] >> + ‘LENGTH ((gen_temps tmp (LENGTH les))) = + LENGTH (MAP (wlab_wloc ctxt.funcs) args ++ [Loc loc 0])’ by ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + drule domain_alist_insert >> + disch_then (qspec_then ‘st.locals’ mp_tac) >> + strip_tac >> fs [] >> + ‘domain l ⊆ domain st.locals ∪ set (gen_temps tmp (LENGTH les))’ by ( + qsuff_tac ‘domain l ⊆ domain st.locals’ + >- fs [SUBSET_DEF] >> + imp_res_tac compile_exps_out_rel >> rveq >> fs [] >> + imp_res_tac locals_rel_intro >> + imp_res_tac cut_sets_union_domain_subset >> + fs [SUBSET_DEF]) >> + fs [] >> + ‘st.clock <> 0’ by fs [state_rel_def] >> + fs [dec_clock_def] >> + rfs [set_var_def] >> + qpat_x_assum ‘ evaluate (compile _ _ prog, _) = (_,t1)’ assume_tac >> + fs [ocompile_def] >> + drule loop_liveProofTheory.optimise_correct >> + fs [] >> + strip_tac >> fs [] >> rveq >> fs [] >> + pop_assum kall_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘1’ assume_tac) >> + fs [] >> pop_assum kall_tac >> + rfs [] >> + fs [evaluate_def] >> + fs [get_var_imm_def, asmTheory.word_cmp_def] >> + fs [evaluate_def] >> + fs [cut_res_def] >> + strip_tac >> fs [] >> rveq >> + fs [call_env_def] >> + fs [crepSemTheory.empty_locals_def, ctxt_fc_def] >> + fs [state_rel_def, code_rel_def]) >> + (* handling exception *) + last_x_assum (qspecl_then + [‘t1 with locals := + insert (ctxt.vmax + 1) (Word c') + (inter (alist_insert (gen_temps tmp (LENGTH les)) + (MAP (wlab_wloc ctxt.funcs) args ++ [Loc loc 0]) + st.locals) l)’, + ‘ctxt’, ‘l’] mp_tac) >> + impl_tac + >- ( + fs [crepSemTheory.set_var_def, ctxt_fc_def] >> + conj_tac >- fs [state_rel_def] >> + conj_tac >- fs [code_rel_def] >> + fs [locals_rel_def] >> + conj_tac + >- ( + fs [domain_inter] >> + ‘LENGTH (gen_temps tmp (LENGTH les)) = + LENGTH (MAP (wlab_wloc ctxt.funcs) args ++ [Loc loc 0])’ by ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + drule domain_alist_insert >> + disch_then (qspec_then ‘st.locals’ assume_tac) >> + fs [] >> + qsuff_tac + ‘(domain st.locals ∪ set (gen_temps tmp (LENGTH les))) ∩ domain l = domain l’ + >- fs [SUBSET_INSERT_RIGHT] >> + fs [INTER_SUBSET_EQN |> CONJUNCT2] >> + imp_res_tac compile_exps_out_rel >> fs [] >> rveq >> fs [] >> + imp_res_tac cut_sets_union_domain_subset >> + fs [SUBSET_DEF]) >> + rw [] >> + res_tac >> rfs [] >> + ‘n' <> ctxt.vmax + 1’ by ( + fs [ctxt_max_def] >> res_tac >> rfs []) >> + qmatch_goalsub_rename_tac ‘lookup nn _’ >> + fs [lookup_insert, lookup_inter] >> + ‘LENGTH (gen_temps tmp (LENGTH les)) = + LENGTH (MAP (wlab_wloc ctxt.funcs) args ++ [Loc loc 0])’ by ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + drule MEM_ZIP >> + strip_tac >> + drule lookup_alist_insert >> + disch_then (qspec_then ‘st.locals’ assume_tac) >> + fs [] >> + ‘ALOOKUP (ZIP + (gen_temps tmp (LENGTH les), + MAP (wlab_wloc ctxt.funcs) args ++ [Loc loc 0])) nn = NONE’ by ( + fs [ALOOKUP_NONE] >> + CCONTR_TAC >> fs [MEM_MAP] >> + first_x_assum (qspec_then ‘y’ assume_tac) >> + fs [] >> rveq >> fs [FST] >> + qmatch_asmsub_rename_tac ‘nt < LENGTH _’ >> + ‘tmp <= EL nt (gen_temps tmp (LENGTH les))’ by + fs [gen_temps_def] >> + imp_res_tac compile_exps_out_rel >> + fs [ctxt_max_def] >> res_tac >> rfs []) >> + fs [domain_lookup]) >> + strip_tac >> fs [] >> + cases_on ‘res’ >> fs [] + >- ( + qexists_tac ‘ck + ck' + ck'' + 3’ >> + qpat_x_assum ‘ evaluate (_,_) = (NONE,st)’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck' + ck'' + 3’ assume_tac) >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘ptmp ++ pcal’ assume_tac) >> + fs [] >> pop_assum kall_tac >> + ‘MAP (eval st) les = + MAP SOME (MAP (wlab_wloc ctxt.funcs) (args ++ [Label fname]))’ by fs [] >> + drule loop_eval_nested_assign_distinct_eq >> + disch_then (qspec_then ‘gen_temps tmp (LENGTH les)’ mp_tac) >> + impl_tac + >- ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + rewrite_tac [distinct_lists_def] >> + fs [EVERY_GENLIST] >> + rw [] >> + CCONTR_TAC >> fs [] >> + imp_res_tac locals_rel_intro >> + drule compile_exps_le_tmp_domain >> + disch_then drule >> + qmatch_asmsub_rename_tac ‘tmp + nx’ >> + disch_then (qspec_then ‘tmp + nx’ assume_tac) >> + rfs [] >> + fs [MEM_FLAT, MEM_MAP] >> rveq >> fs [] + >- ( + qmatch_asmsub_rename_tac ‘ MEM _ (var_cexp cv)’ >> + ‘?v. eval s cv = SOME v’ by ( + qpat_x_assum ‘MAP _ _ = MAP SOME args’ assume_tac >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN, MEM_EL]) >> + drule_all eval_some_var_cexp_local_lookup >> + strip_tac >> fs [locals_rel_def] >> + res_tac >> rfs [] >> rveq >> fs []) >> + drule_all eval_some_var_cexp_local_lookup >> + strip_tac >> fs [locals_rel_def] >> + res_tac >> rfs [] >> rveq >> fs []) >> + strip_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck' + ck'' + 3’ assume_tac) >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘pcal’ assume_tac) >> + fs [Abbr ‘ptmp’] >> pop_assum kall_tac >> + fs [Abbr ‘pcal’, nested_seq_def] >> + rewrite_tac [evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + fs [get_vars_local_clock_upd_eq] >> + ‘get_vars (gen_temps tmp (LENGTH les)) + (st with locals := + alist_insert (gen_temps tmp (LENGTH les)) + (MAP (wlab_wloc ctxt.funcs) args ++ [wlab_wloc ctxt.funcs (Label fname)]) st.locals) = + SOME (MAP (wlab_wloc ctxt.funcs) args ++ [wlab_wloc ctxt.funcs (Label fname)])’ by ( + ho_match_mp_tac get_vars_local_update_some_eq >> + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + fs [] >> pop_assum kall_tac >> + fs [find_code_def] >> + pop_assum mp_tac >> + rewrite_tac [wlab_wloc_def] >> + rfs [] >> + fs [cut_res_def, cut_state_def] >> + ‘LENGTH ((gen_temps tmp (LENGTH les))) = + LENGTH (MAP (wlab_wloc ctxt.funcs) args ++ [Loc loc 0])’ by ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + drule domain_alist_insert >> + disch_then (qspec_then ‘st.locals’ mp_tac) >> + strip_tac >> fs [] >> + ‘domain l ⊆ domain st.locals ∪ set (gen_temps tmp (LENGTH les))’ by ( + qsuff_tac ‘domain l ⊆ domain st.locals’ + >- fs [SUBSET_DEF] >> + imp_res_tac compile_exps_out_rel >> rveq >> fs [] >> + imp_res_tac locals_rel_intro >> + imp_res_tac cut_sets_union_domain_subset >> + fs [SUBSET_DEF]) >> + fs [] >> + ‘st.clock <> 0’ by fs [state_rel_def] >> + fs [dec_clock_def] >> + rfs [set_var_def] >> + qpat_x_assum ‘evaluate (compile _ _ prog, _) = (_,t1)’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck'' + 3’ assume_tac) >> + fs [] >> + fs [ocompile_def] >> + drule loop_liveProofTheory.optimise_correct >> + fs [] >> + strip_tac >> fs [] >> rveq >> fs [] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + rfs [] >> + fs [evaluate_def] >> + fs [get_var_imm_def, asmTheory.word_cmp_def] >> + fs [evaluate_def, dec_clock_def] >> + qpat_x_assum ‘evaluate (compile _ _ p'', _) = _’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘2’ assume_tac) >> + fs [] >> pop_assum kall_tac >> + strip_tac >> + fs [cut_res_def, cut_state_def] >> + ‘domain l ⊆ domain t1'.locals’ by ( + imp_res_tac locals_rel_intro >> + fs [SUBSET_INSERT_RIGHT]) >> + fs [dec_clock_def] >> rveq >> fs [] >> + fs [cut_res_def, cut_state_def] >> + fs [domain_inter] >> + fs [dec_clock_def] >> rveq >> fs [] >> + conj_tac >- fs [state_rel_def] >> + qpat_x_assum ‘locals_rel _ _ s1.locals _’ assume_tac >> + fs [locals_rel_def] >> + conj_tac >- fs [domain_inter, SUBSET_DEF] >> + rw [] >> + res_tac >> fs [] >> + fs [lookup_inter, domain_lookup]) >> + cases_on ‘x’ >> fs [] >> rveq >> fs [] >> + ( + qexists_tac ‘ck + ck' + ck'' + 1’ >> + qpat_x_assum ‘ evaluate (_,_) = (NONE,st)’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck' + ck'' + 1’ assume_tac) >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘ptmp ++ pcal’ assume_tac) >> + fs [] >> pop_assum kall_tac >> + ‘MAP (eval st) les = + MAP SOME (MAP (wlab_wloc ctxt.funcs) (args ++ [Label fname]))’ by fs [] >> + drule loop_eval_nested_assign_distinct_eq >> + disch_then (qspec_then ‘gen_temps tmp (LENGTH les)’ mp_tac) >> + impl_tac + >- ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + rewrite_tac [distinct_lists_def] >> + fs [EVERY_GENLIST] >> + rw [] >> + CCONTR_TAC >> fs [] >> + imp_res_tac locals_rel_intro >> + drule compile_exps_le_tmp_domain >> + disch_then drule >> + qmatch_asmsub_rename_tac ‘tmp + nx’ >> + disch_then (qspec_then ‘tmp + nx’ assume_tac) >> + rfs [] >> + fs [MEM_FLAT, MEM_MAP] >> rveq >> fs [] + >- ( + qmatch_asmsub_rename_tac ‘ MEM _ (var_cexp cv)’ >> + ‘?v. eval s cv = SOME v’ by ( + qpat_x_assum ‘MAP _ _ = MAP SOME args’ assume_tac >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN, MEM_EL]) >> + drule_all eval_some_var_cexp_local_lookup >> + strip_tac >> fs [locals_rel_def] >> + res_tac >> rfs [] >> rveq >> fs []) >> + drule_all eval_some_var_cexp_local_lookup >> + strip_tac >> fs [locals_rel_def] >> + res_tac >> rfs [] >> rveq >> fs []) >> + strip_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck' + ck'' + 1’ assume_tac) >> + drule evaluate_none_nested_seq_append >> + disch_then (qspec_then ‘pcal’ assume_tac) >> + fs [Abbr ‘ptmp’] >> pop_assum kall_tac >> + fs [Abbr ‘pcal’, nested_seq_def] >> + rewrite_tac [evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + fs [get_vars_local_clock_upd_eq] >> + ‘get_vars (gen_temps tmp (LENGTH les)) + (st with locals := + alist_insert (gen_temps tmp (LENGTH les)) + (MAP (wlab_wloc ctxt.funcs) args ++ [wlab_wloc ctxt.funcs (Label fname)]) st.locals) = + SOME (MAP (wlab_wloc ctxt.funcs) args ++ [wlab_wloc ctxt.funcs (Label fname)])’ by ( + ho_match_mp_tac get_vars_local_update_some_eq >> + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + fs [] >> pop_assum kall_tac >> + fs [find_code_def] >> + pop_assum mp_tac >> + rewrite_tac [wlab_wloc_def] >> + rfs [] >> + fs [cut_res_def, cut_state_def] >> + ‘LENGTH ((gen_temps tmp (LENGTH les))) = + LENGTH (MAP (wlab_wloc ctxt.funcs) args ++ [Loc loc 0])’ by ( + fs [gen_temps_def, ALL_DISTINCT_GENLIST] >> + imp_res_tac compile_exps_out_rel >> fs [] >> + metis_tac [LENGTH_MAP]) >> + drule domain_alist_insert >> + disch_then (qspec_then ‘st.locals’ mp_tac) >> + strip_tac >> fs [] >> + ‘domain l ⊆ domain st.locals ∪ set (gen_temps tmp (LENGTH les))’ by ( + qsuff_tac ‘domain l ⊆ domain st.locals’ + >- fs [SUBSET_DEF] >> + imp_res_tac compile_exps_out_rel >> rveq >> fs [] >> + imp_res_tac locals_rel_intro >> + imp_res_tac cut_sets_union_domain_subset >> + fs [SUBSET_DEF]) >> + fs [] >> + ‘st.clock <> 0’ by fs [state_rel_def] >> + fs [dec_clock_def] >> + rfs [set_var_def] >> + qpat_x_assum ‘evaluate (compile _ _ prog, _) = (_,t1)’ assume_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘ck'' + 1’ assume_tac) >> + fs [] >> + fs [ocompile_def] >> + drule loop_liveProofTheory.optimise_correct >> + fs [] >> + strip_tac >> fs [] >> rveq >> fs [] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + rfs [] >> + fs [evaluate_def] >> + fs [get_var_imm_def, asmTheory.word_cmp_def] >> + fs [evaluate_def, dec_clock_def] >> + fs [cut_res_def] >> + strip_tac >> fs [] >> rveq >> fs [])) >> + fcalled_timed_out_tac +QED + + +Theorem ncompile_correct: + ^(compile_prog_tm ()) +Proof + match_mp_tac (the_ind_thm()) >> + EVERY (map strip_assume_tac + [compile_Skip_Break_Continue, compile_Tick, + compile_Seq, compile_Return, compile_Raise, + compile_Store, compile_StoreByte, compile_StoreGlob, + compile_Assign, compile_Dec, compile_If, compile_FFI, + compile_While, compile_Call]) >> + asm_rewrite_tac [] >> rw [] >> rpt (pop_assum kall_tac) +QED + + +Theorem ocompile_correct: + evaluate (p,s) = (res,s1) ∧ state_rel s t ∧ + mem_rel ctxt.funcs s.memory t.memory ∧ + globals_rel ctxt.funcs s.globals t.globals ∧ code_rel ctxt s.code t.code ∧ + locals_rel ctxt l s.locals t.locals ∧ res ≠ SOME Error ∧ res ≠ SOME Break ∧ + res ≠ SOME Continue ∧ res ≠ NONE ⇒ + ∃ck res1 t1. + evaluate (ocompile ctxt l p,t with clock := t.clock + ck) = + (res1,t1) ∧ state_rel s1 t1 ∧ mem_rel ctxt.funcs s1.memory t1.memory ∧ + globals_rel ctxt.funcs s1.globals t1.globals ∧ + code_rel ctxt s1.code t1.code ∧ + case res of + | NONE => F + | SOME Error => F + | SOME TimeOut => res1 = SOME TimeOut + | SOME Break => F + | SOME Continue => F + | SOME (Return v) => res1 = SOME (Result (wlab_wloc ctxt.funcs v)) ∧ + ∀f. v = Label f ⇒ f ∈ FDOM ctxt.funcs + | SOME (Exception eid) => res1 = SOME (Exception (Word eid)) + | SOME (FinalFFI f) => res1 = SOME (FinalFFI f) + +Proof + rw [] >> + drule_all ncompile_correct >> + strip_tac >> fs [] >> + fs [ocompile_def] >> + drule loop_liveProofTheory.optimise_correct >> + impl_tac + >- ( + cases_on ‘res’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + strip_tac >> + qexists_tac ‘ck’ >> fs [] >> + cases_on ‘res’ >> fs [] >> + cases_on ‘x’ >> fs [] +QED + + +Theorem distinct_make_funcs: + !crep_code. distinct_funcs (make_funcs crep_code) +Proof + rw [distinct_funcs_def] >> + fs [make_funcs_def] >> + qmatch_asmsub_abbrev_tac ‘MAP2 _ (GENLIST _ _) ps’ >> + dxrule ALOOKUP_MEM >> + dxrule ALOOKUP_MEM >> + strip_tac >> + strip_tac >> + fs [MEM_EL] >> + ‘n < MIN (LENGTH (MAP FST crep_code)) + (LENGTH (MAP2 (λx y. (x,y)) (GENLIST I (LENGTH crep_code)) ps))’ by + fs [LENGTH_MAP] >> + dxrule (INST_TYPE [“:'a”|->“:'a”, + “:'b”|->“:num # num”, + “:'c” |-> “:'a # num # num”] EL_MAP2) >> + ‘n' < MIN (LENGTH (MAP FST crep_code)) + (LENGTH (MAP2 (λx y. (x,y)) (GENLIST I (LENGTH crep_code)) ps))’ by + fs [LENGTH_MAP] >> + dxrule (INST_TYPE [“:'a”|->“:'a”, + “:'b”|->“:num # num”, + “:'c” |-> “:'a # num # num”] EL_MAP2) >> + disch_then (qspec_then ‘(λx y. (x,y))’ assume_tac) >> + disch_then (qspec_then ‘(λx y. (x,y))’ assume_tac) >> + fs [] >> rveq >> fs [] >> + ‘n < MIN (LENGTH (GENLIST I (LENGTH crep_code))) (LENGTH ps)’ by + fs [LENGTH_GENLIST] >> + drule (INST_TYPE [“:'a”|->“:num”, + “:'b”|->“:num”, + “:'c” |-> “:num # num”] EL_MAP2) >> + ‘n' < MIN (LENGTH (GENLIST I (LENGTH crep_code))) (LENGTH ps)’ by + fs [LENGTH_GENLIST] >> + dxrule (INST_TYPE [“:'a”|->“:num”, + “:'b”|->“:num”, + “:'c” |-> “:num # num”] EL_MAP2) >> + disch_then (qspec_then ‘(λx y. (x,y))’ assume_tac) >> + disch_then (qspec_then ‘(λx y. (x,y))’ assume_tac) >> + fs [] >> rveq >> fs [] +QED + + +Theorem map_map2_fst: + !xs ys h. LENGTH xs = LENGTH ys ==> + MAP FST + (MAP2 + (λx (n,p,b). (x,GENLIST I (LENGTH p),h p b)) xs ys) = xs +Proof + Induct_on ‘xs’ >> + rw [] >> + fs [] >> + cases_on ‘ys’ >> fs [] >> + cases_on ‘h''’ >> fs [] >> + cases_on ‘r’ >> fs [] +QED + +Theorem mem_lookup_fromalist_some: + !xs n x. + ALL_DISTINCT (MAP FST xs) ∧ + MEM (n,x) xs ==> + lookup n (fromAList xs) = SOME x +Proof + Induct >> + rw [] >> fs [] >> + fs [fromAList_def] >> + cases_on ‘h’ >> + fs [fromAList_def] >> + fs [lookup_insert] >> + TOP_CASE_TAC >> fs [] >> + rveq >> fs [MEM_MAP] >> + first_x_assum (qspec_then ‘(n,x)’ mp_tac) >> + fs [] +QED + + +Theorem first_compile_prog_all_distinct: + !crep_code. + ALL_DISTINCT (MAP FST (compile_prog crep_code)) +Proof + rw [] >> + fs [crep_to_loopTheory.compile_prog_def] >> + qmatch_goalsub_abbrev_tac ‘MAP FST ls’ >> + qsuff_tac ‘MAP FST ls = GENLIST I (LENGTH crep_code)’ + >- ( + strip_tac >> + fs [ALL_DISTINCT_GENLIST]) >> + fs [Abbr ‘ls’] >> + fs [MAP_MAP_o] >> + ‘LENGTH (GENLIST I (LENGTH crep_code)) = LENGTH crep_code’ by fs [] >> + drule (INST_TYPE [“:'a”|->“:num”, + “:'b”|->“:mlstring”, + “:'c”|->“:num”, + “:'d”|->“:'a crepLang$prog”, + “:'e”|-> “:'a prog”] map_map2_fst) >> + disch_then (qspec_then ‘λparams body. loop_live$optimise + (comp_func (make_funcs crep_code) + params body)’ mp_tac) >> fs [] +QED + +Theorem mk_ctxt_code_imp_code_rel: + !crep_code start np. ALL_DISTINCT (MAP FST crep_code) /\ + ALOOKUP crep_code start = SOME ([],np) ==> + code_rel (mk_ctxt FEMPTY (make_funcs crep_code) 0) + (alist_to_fmap crep_code) + (fromAList (crep_to_loop$compile_prog crep_code)) +Proof + rw [code_rel_def, mk_ctxt_def] + >- fs [distinct_make_funcs] >> + fs [mk_ctxt_def, make_funcs_def] >> + drule ALOOKUP_MEM >> + strip_tac >> + fs [MEM_EL] >> rveq >> + qexists_tac ‘n’ >> + conj_tac + >- ( + ho_match_mp_tac ALOOKUP_ALL_DISTINCT_MEM >> + conj_tac + >- ( + qmatch_goalsub_abbrev_tac ‘MAP FST ls’ >> + ‘MAP FST ls = MAP FST crep_code’ by ( + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + conj_tac >- fs [Abbr ‘ls’] >> + conj_tac >- fs [Abbr ‘ls’] >> + rw [] >> + fs [Abbr ‘ls’] >> + qmatch_goalsub_abbrev_tac ‘MAP2 _ _ ps’ >> + ‘n' < MIN (LENGTH (MAP FST crep_code)) (LENGTH ps)’ by fs [Abbr ‘ps’] >> + drule (INST_TYPE [“:'a”|->“:mlstring”, + “:'b”|->“:num # num”, + “:'c”|-> “:mlstring # num # num”] EL_MAP2) >> + disch_then (qspec_then ‘λx y. (x,y)’ mp_tac) >> + strip_tac >> fs [] >> + match_mp_tac EL_MAP >> + fs []) >> + fs []) >> + fs [MEM_EL] >> + qexists_tac ‘n’ >> + fs [] >> + qmatch_goalsub_abbrev_tac ‘MAP2 _ _ ps’ >> + ‘n < MIN (LENGTH (MAP FST crep_code)) (LENGTH ps)’ by fs [Abbr ‘ps’] >> + drule (INST_TYPE [“:'a”|->“:mlstring”, + “:'b”|->“:num # num”, + “:'c”|-> “:mlstring # num # num”] EL_MAP2) >> + disch_then (qspec_then ‘λx y. (x,y)’ mp_tac) >> + strip_tac >> fs [] >> + conj_asm1_tac + >- ( + fs [EL_MAP] >> + qpat_x_assum ‘_ = EL n crep_code’ (mp_tac o GSYM) >> + fs []) >> + fs [Abbr ‘ps’] >> + qmatch_goalsub_abbrev_tac ‘MAP2 _ _ ps’ >> + ‘n < MIN (LENGTH (GENLIST I (LENGTH crep_code))) (LENGTH ps)’ by fs [Abbr ‘ps’] >> + drule (INST_TYPE [“:'a”|->“:num”, + “:'b”|->“:num”, + “:'c”|-> “:num # num”] EL_MAP2) >> + disch_then (qspec_then ‘λx y. (x,y)’ mp_tac) >> + strip_tac >> fs [] >> + fs [Abbr ‘ps’] >> + ‘n < LENGTH (MAP (LENGTH ∘ FST ∘ SND) crep_code)’ by fs [] >> + drule (INST_TYPE [“:'a”|->“:mlstring # num list # 'a crepLang$prog”, + “:'b”|->“:num”] EL_MAP) >> + disch_then (qspec_then ‘LENGTH ∘ FST ∘ SND’ mp_tac) >> + strip_tac >> + fs [] >> + qpat_x_assum ‘_ = EL n crep_code’ (assume_tac o GSYM) >> + fs []) >> + fs [compile_prog_def, ctxt_fc_def] >> + match_mp_tac mem_lookup_fromalist_some >> + conj_tac + >- metis_tac [(REWRITE_RULE + [crep_to_loopTheory.compile_prog_def, LET_THM] + first_compile_prog_all_distinct)] >> + fs [MEM_EL] >> + qexists_tac ‘n’ >> + fs [] >> + qmatch_goalsub_abbrev_tac ‘EL _ (MAP2 _ ps _)’ >> + ‘n < MIN (LENGTH ps) (LENGTH crep_code)’ by fs [Abbr ‘ps’] >> + drule (INST_TYPE [“:'a”|->“:num”, + “:'b”|->“:mlstring # num list # 'a crepLang$prog”, + “:'c”|-> “:num # num list # 'a prog”] EL_MAP2) >> + disch_then (qspec_then ‘λn' (name,params,body). + (n',GENLIST I (LENGTH params), + loop_live$optimise (comp_func (make_funcs crep_code) + params body))’ mp_tac) >> + strip_tac >> fs [] >> + pop_assum kall_tac >> fs [] >> + fs [Abbr ‘ps’] >> + qpat_x_assum ‘_ = EL n crep_code’ (assume_tac o GSYM) >> + fs [] >> + fs [comp_func_def] >> + fs [mk_ctxt_def, make_vmap_def, make_funcs_def] >> + fs [loop_liveTheory.optimise_def, ocompile_def] >> + fs [pan_commonPropsTheory.list_max_i_genlist] +QED + + +Theorem make_funcs_domain_compile_prog: + !start lc crep_code. FLOOKUP (make_funcs crep_code) start = SOME (lc,0) ==> + lc ∈ domain (fromAList (compile_prog crep_code)) +Proof + rw [] >> + fs [domain_fromAList] >> + fs [make_funcs_def] >> + drule ALOOKUP_MEM >> + pop_assum kall_tac >> + strip_tac >> + fs [MEM_EL] >> + qexists_tac ‘n’ >> + conj_tac + >- fs [compile_prog_def] >> + qmatch_asmsub_abbrev_tac ‘MAP2 _ (GENLIST I _) ps’ >> + ‘n < MIN (LENGTH (MAP FST crep_code)) + (LENGTH (MAP2 (λx y. (x,y)) (GENLIST I (LENGTH crep_code)) ps))’ by + fs [Abbr ‘ps’, LENGTH_MAP] >> + dxrule (INST_TYPE [“:'a”|->“:mlstring”, + “:'b”|->“:num # num”, + “:'c” |-> “:mlstring # num # num”] EL_MAP2) >> + disch_then (qspec_then ‘λx y. (x,y)’ mp_tac) >> + strip_tac >> fs [] >> + fs [compile_prog_def] >> + qmatch_goalsub_abbrev_tac ‘EL n (MAP _ pps)’ >> + ‘n < LENGTH pps’ by fs [Abbr ‘pps’] >> + dxrule (INST_TYPE [“:'a”|->“:num # num list # 'a prog”, + “:'b”|->“:num”] EL_MAP) >> + disch_then (qspec_then ‘FST’ mp_tac) >> + strip_tac >> fs [] >> + pop_assum kall_tac >> + fs [Abbr ‘pps’] >> + qmatch_goalsub_abbrev_tac ‘EL n (MAP2 ffs _ _)’ >> + ‘n < MIN (LENGTH (GENLIST I (LENGTH crep_code))) + (LENGTH crep_code)’ by fs [] >> + dxrule (INST_TYPE [“:'a”|->“:num”, + “:'b”|->“:mlstring # num list # 'a crepLang$prog”, + “:'c” |-> “:num # num list # 'a prog”] EL_MAP2) >> + disch_then (qspec_then ‘ffs’ mp_tac) >> + fs [] >> + strip_tac >> + fs [Abbr ‘ffs’] >> + cases_on ‘EL n crep_code’ >> fs [] >> + cases_on ‘r’ >> fs [] >> + ‘n < MIN (LENGTH (GENLIST I (LENGTH crep_code))) + (LENGTH ps)’ by fs [Abbr ‘ps’] >> + dxrule (INST_TYPE [“:'a”|->“:num”, + “:'b”|->“:num”, + “:'c” |-> “:num # num”] EL_MAP2) >> + disch_then (qspec_then ‘λx y. (x,y)’ mp_tac) >> + strip_tac >> fs [] +QED + +(* move to pan_commonProps *) +Theorem alookup_el_pair_eq_el: + !prog start cp n. + EL n prog = (start, [], SND(SND(EL n prog))) /\ + ALL_DISTINCT (MAP FST prog) /\ n < LENGTH prog /\ + ALOOKUP prog start = SOME ([],cp) ==> + EL n prog = (start, [], cp) +Proof + Induct >> rw [] >> + cases_on ‘n’ >> fs [] >> rveq >> fs [] + >- (cases_on ‘h’ >> rfs []) >> + last_x_assum match_mp_tac >> + cases_on ‘h’ >> fs [] >> + cases_on ‘q = start’ >> fs [] >> rveq >> fs [] >> + fs [MEM_EL] >> + last_x_assum (qspec_then ‘n'’ mp_tac) >> + fs [] >> + strip_tac >> + metis_tac [el_pair_map_fst_el] +QED + + +Theorem initial_prog_make_funcs_el: + !prog start n. FLOOKUP (make_funcs prog) start = SOME (n,0) ==> + (start, [], (SND o SND) (EL n prog)) = EL n prog /\ n < LENGTH prog +Proof + rw [] >> + fs [crep_to_loopTheory.make_funcs_def] >> + dxrule ALOOKUP_MEM >> + fs [] >> + strip_tac >> + fs [MEM_EL] >> + pop_assum mp_tac >> + qmatch_goalsub_abbrev_tac ‘EL _ (MAP2 ff ws xs)’ >> + ‘EL n' (MAP2 ff ws xs) = ff (EL n' ws) (EL n' xs)’ by ( + match_mp_tac EL_MAP2 >> + unabbrev_all_tac >> fs []) >> + fs [] >> + unabbrev_all_tac >> fs [] >> + strip_tac >> + fs [] >> + pop_assum mp_tac >> + qmatch_goalsub_abbrev_tac ‘EL _ (MAP2 ff ws xs)’ >> + ‘EL n' (MAP2 ff ws xs) = ff (EL n' ws) (EL n' xs)’ by ( + match_mp_tac EL_MAP2 >> + unabbrev_all_tac >> fs []) >> + fs [] >> + unabbrev_all_tac >> fs [] >> + strip_tac >> fs [] >> rveq >> fs [] >> + ‘EL n (MAP FST prog) = FST (EL n prog)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [] >> + pop_assum kall_tac >> + ‘EL n (MAP (LENGTH ∘ FST ∘ SND) prog) = + (LENGTH ∘ FST ∘ SND) (EL n prog)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [] >> + pop_assum kall_tac >> + pop_assum (assume_tac o GSYM) >> + fs [] >> + cases_on ‘EL n prog’ >> + fs [] >> + cases_on ‘r’ >> fs [] +QED + +Theorem compile_prog_distinct_params: + ∀prog. + EVERY (λ(name,params,body). ALL_DISTINCT params) prog ⇒ + EVERY (λ(name,params,body). ALL_DISTINCT params) (compile_prog prog) +Proof + rw [] >> + fs [EVERY_MEM] >> + rw [] >> + PairCases_on ‘e’ >> fs [] >> + fs [compile_prog_def] >> + fs [MEM_EL] >> + qmatch_asmsub_abbrev_tac ‘MAP2 ff xs _’ >> + ‘EL n (MAP2 ff xs prog) = ff (EL n xs) (EL n prog)’ by ( + match_mp_tac EL_MAP2 >> + fs [Abbr ‘xs’]) >> + fs [] >> + pop_assum kall_tac >> + fs [Abbr ‘ff’] >> + cases_on ‘EL n prog’ >> + cases_on ‘r’ >> fs [] >> rveq >> + fs [ALL_DISTINCT_GENLIST] +QED + + +Theorem state_rel_imp_semantics: + !s t crep_code start prog lc. s.memaddrs = t.mdomain ∧ + s.be = t.be ∧ + s.ffi = t.ffi ∧ + mem_rel (make_funcs crep_code) s.memory t.memory ∧ + globals_rel (make_funcs crep_code) s.globals t.globals ∧ + ALL_DISTINCT (MAP FST crep_code) ∧ + s.code = alist_to_fmap crep_code ∧ + t.code = fromAList (crep_to_loop$compile_prog crep_code) ∧ + s.locals = FEMPTY ∧ + ALOOKUP crep_code start = SOME ([],prog) ∧ + FLOOKUP (make_funcs crep_code) start = SOME (lc, 0) ∧ + semantics s start <> Fail ==> + semantics t lc = semantics s start +Proof + rw [] >> + drule mk_ctxt_code_imp_code_rel >> + disch_then (qspecl_then [‘start’, ‘prog’] mp_tac) >> + fs [] >> strip_tac >> + qmatch_asmsub_abbrev_tac ‘code_rel nctxt _ _’ >> + reverse (Cases_on ‘semantics s start’) >> fs [] + >- ( + (* Termination case of crep semantics *) + fs [crepSemTheory.semantics_def] >> + pop_assum mp_tac >> + IF_CASES_TAC >> fs [] >> + DEEP_INTRO_TAC some_intro >> simp[] >> + rw [] >> + rw [loopSemTheory.semantics_def] + >- ( + (* the fail case of loop semantics *) + qhdtm_x_assum ‘crepSem$evaluate’ kall_tac >> + pop_assum mp_tac >> + pop_assum kall_tac >> + strip_tac >> + last_x_assum(qspec_then ‘k'’ mp_tac) >> simp[] >> + (fn g => subterm (fn tm => Cases_on ‘^(assert(has_pair_type)tm)’) (#2 g) g) >> + CCONTR_TAC >> fs [] >> + drule ocompile_correct >> fs [] >> + map_every qexists_tac [‘t with clock := k'’, ‘LN’, ‘nctxt’] >> + fs [] >> + Ho_Rewrite.PURE_REWRITE_TAC[GSYM PULL_EXISTS] >> + conj_tac + >- ( + fs [state_rel_def, Abbr ‘nctxt’, mk_ctxt_def] >> + fs [locals_rel_def, distinct_vars_def, ctxt_max_def] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + CCONTR_TAC >> + fs [] >> + fs [ocompile_def, compile_def] >> + fs [compile_exp_def] >> + fs [gen_temps_def, MAP2_DEF] >> + fs [nested_seq_def] >> + ‘find_lab nctxt start = lc’ by ( + fs [find_lab_def, Abbr ‘nctxt’, mk_ctxt_def]) >> + fs [] >> + drule make_funcs_domain_compile_prog >> + strip_tac >> + fs [loop_liveTheory.optimise_def] >> + fs [loop_callTheory.comp_def, loop_liveTheory.comp_def] >> + fs [] >> + fs [loop_liveTheory.shrink_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rveq >> fs [] >> + fs [loop_liveTheory.mark_all_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rveq >> gs [] >> + cases_on ‘t1' ∧ t1''’ >> + gs [] + >- ( + qpat_x_assum ‘loopSem$evaluate (Mark _, _) = (_,_)’ mp_tac >> + rw [Once loopSemTheory.evaluate_def] >> + rw [Once loopSemTheory.evaluate_def] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def] >> rveq >> + ‘res = NONE ∧ s1 = t with clock := ck + k' ∧ res' = NONE ∧ s1' = s1’ by + fs [evaluate_def] >> + qpat_x_assum ‘evaluate(Mark Skip, _) = _’ kall_tac >> + qpat_x_assum ‘evaluate(Mark Skip, _) = _’ kall_tac >> + rveq >> fs [] >> + CCONTR_TAC >> fs [] >> + cases_on ‘evaluate + (Call NONE (SOME (find_lab nctxt start)) [] NONE, + t with clock := k')’ >> + fs [] >> + cases_on ‘q'’ >> fs [] + >- ( + drule evaluate_add_clock_eq >> + disch_then (qspec_then ‘ck’ mp_tac) >> + strip_tac >> fs [] >> rveq >> fs [] >> + qpat_x_assum ‘_ = (res1,t1)’ mp_tac >> + rw [evaluate_def] >> + CCONTR_TAC >> + fs [] >> rveq >> fs [] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs [] >> rveq >> fs []) >> + cases_on ‘x’ >> fs [] >> ( + drule evaluate_add_clock_eq >> + disch_then (qspec_then ‘ck’ mp_tac) >> + strip_tac >> fs [] >> rveq >> fs [] >> + rveq >> fs [] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs [] >> rveq >> fs [])) + >- ( + cases_on ‘t1''’ >> fs [] + >- ( + qpat_x_assum ‘loopSem$evaluate (Seq _ _, _) = (_,_)’ mp_tac >> + rw [Once loopSemTheory.evaluate_def] >> + rw [Once loopSemTheory.evaluate_def] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def]) >> + qpat_x_assum ‘loopSem$evaluate (Seq _ _, _) = (_,_)’ mp_tac >> + rw [Once loopSemTheory.evaluate_def] >> + rw [Once loopSemTheory.evaluate_def] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def]) >> + qpat_x_assum ‘loopSem$evaluate (Seq _ _, _) = (_,_)’ mp_tac >> + rw [Once loopSemTheory.evaluate_def] >> + rw [Once loopSemTheory.evaluate_def] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def]) >> + (* the termination/diverging case of loop semantics *) + DEEP_INTRO_TAC some_intro >> simp[] >> + conj_tac + (* the termination case of loop semantics *) + >- ( + rw [] >> fs [] >> + drule ocompile_correct >> fs [] >> + ‘r ≠ SOME Error ∧ + r ≠ SOME Break ∧ r ≠ SOME Continue ∧ r ≠ NONE’ by ( + cases_on ‘r’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + fs [] >> + disch_then (qspecl_then [‘t with clock := k’, ‘LN’, ‘nctxt’] mp_tac) >> + impl_tac + >- ( + fs [Abbr ‘nctxt’, mk_ctxt_def, state_rel_def] >> + fs [locals_rel_def, distinct_vars_def, ctxt_max_def]) >> + strip_tac >> fs [] >> + fs [ocompile_def, compile_def] >> + fs [compile_exp_def] >> + fs [gen_temps_def, MAP2_DEF] >> + fs [nested_seq_def] >> + ‘find_lab nctxt start = lc’ by ( + fs [find_lab_def, Abbr ‘nctxt’, mk_ctxt_def]) >> + fs [] >> + drule make_funcs_domain_compile_prog >> + strip_tac >> + fs [loop_liveTheory.optimise_def] >> + fs [loop_callTheory.comp_def, loop_liveTheory.comp_def] >> + fs [loop_liveTheory.shrink_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rveq >> fs [] >> + fs [loop_liveTheory.mark_all_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rveq >> gs [] >> + cases_on ‘t1' ∧ t1''’ >> + gs [] + >- ( + qpat_x_assum ‘loopSem$evaluate (Mark _, _) = (_,_)’ mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def] >> rveq >> + ‘res = NONE ∧ s1 = t with clock := ck + k ∧ res' = NONE ∧ s1' = s1’ by + fs [evaluate_def] >> + qpat_x_assum ‘evaluate(Mark Skip, _) = _’ kall_tac >> + qpat_x_assum ‘evaluate(Mark Skip, _) = _’ kall_tac >> + rveq >> fs [] >> + strip_tac >> + drule loopPropsTheory.evaluate_add_clock_eq >> + disch_then (qspec_then ‘k'’ mp_tac) >> + impl_tac + >- ( + CCONTR_TAC >> fs[] >> rveq >> fs[] >> every_case_tac >> fs[]) >> + qpat_x_assum ‘evaluate _ = (r', _)’ assume_tac >> + drule loopPropsTheory.evaluate_add_clock_eq >> + disch_then (qspec_then ‘ck + k’ mp_tac) >> + impl_tac >- (CCONTR_TAC >> fs[]) >> + ntac 2 strip_tac >> fs[] >> rveq >> fs[] >> + Cases_on ‘r’ >> fs[] >> + Cases_on ‘r'’ >> fs [] >> + Cases_on ‘x’ >> fs [] >> rveq >> fs [] >> + fs [state_rel_def] >> + fs [loopSemTheory.state_accfupds, loopSemTheory.state_component_equality]) + >- ( + cases_on ‘t1''’ >> fs [] + >- ( + qpat_x_assum ‘loopSem$evaluate (Seq _ _, _) = (_,_)’ mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def]) >> + qpat_x_assum ‘loopSem$evaluate (Seq _ _, _) = (_,_)’ mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def]) >> + qpat_x_assum ‘loopSem$evaluate (Seq _ _, _) = (_,_)’ mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def]) >> + (* the diverging case of loop semantics *) + rw[] >> fs[] >> CCONTR_TAC >> fs [] >> + drule ocompile_correct >> fs [] >> + ‘r ≠ SOME Error ∧ + r ≠ SOME Break ∧ r ≠ SOME Continue ∧ r ≠ NONE’ by ( + cases_on ‘r’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + fs [] >> + map_every qexists_tac [‘t with clock := k’, ‘LN’, ‘nctxt’] >> + fs [] >> + Ho_Rewrite.PURE_REWRITE_TAC[GSYM PULL_EXISTS] >> + conj_tac + >- ( + fs [state_rel_def, Abbr ‘nctxt’, mk_ctxt_def] >> + fs [locals_rel_def, distinct_vars_def, ctxt_max_def] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + CCONTR_TAC >> fs [] >> + fs [ocompile_def, compile_def] >> + fs [compile_exp_def] >> + fs [gen_temps_def, MAP2_DEF] >> + fs [nested_seq_def] >> + ‘find_lab nctxt start = lc’ by ( + fs [find_lab_def, Abbr ‘nctxt’, mk_ctxt_def]) >> + fs [] >> + drule make_funcs_domain_compile_prog >> + strip_tac >> + fs [loop_liveTheory.optimise_def] >> + fs [loop_callTheory.comp_def, loop_liveTheory.comp_def] >> + fs [loop_liveTheory.shrink_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rveq >> fs [] >> + fs [loop_liveTheory.mark_all_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rveq >> gs [] >> + cases_on ‘t1' ∧ t1''’ >> + gs [] + >- ( + qpat_x_assum ‘loopSem$evaluate (Mark _, _) = (_,_)’ mp_tac >> + rw [Once loopSemTheory.evaluate_def] >> + rw [Once loopSemTheory.evaluate_def] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def] >> rveq >> + ‘res = NONE ∧ s1 = t with clock := ck + k ∧ res' = NONE ∧ s1' = s1’ by + fs [evaluate_def] >> + qpat_x_assum ‘evaluate(Mark Skip, _) = _’ kall_tac >> + qpat_x_assum ‘evaluate(Mark Skip, _) = _’ kall_tac >> + rveq >> fs [] >> + strip_tac >> + first_x_assum (qspec_then ‘ck + k’ mp_tac) >> simp[] >> + first_x_assum(qspec_then ‘ck + k’ mp_tac) >> simp[] >> + every_case_tac >> fs[] >> rw[] >> rfs[]) + >- ( + cases_on ‘t1''’ >> fs [] + >- ( + qpat_x_assum ‘loopSem$evaluate (Seq _ _, _) = (_,_)’ mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def]) >> + qpat_x_assum ‘loopSem$evaluate (Seq _ _, _) = (_,_)’ mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def]) >> + qpat_x_assum ‘loopSem$evaluate (Seq _ _, _) = (_,_)’ mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def]) >> + (* the diverging case of crep semantics *) + fs [crepSemTheory.semantics_def] >> + pop_assum mp_tac >> + IF_CASES_TAC >> fs [] >> + DEEP_INTRO_TAC some_intro >> simp[] >> + rw [] >> + rw [loopSemTheory.semantics_def] + >- ( + (* the fail case of loop semantics *) + fs[] >> rveq >> fs[] >> + last_x_assum (qspec_then ‘k’ mp_tac) >> simp[] >> + (fn g => subterm (fn tm => Cases_on ‘^(assert(has_pair_type)tm)’) (#2 g) g) >> + CCONTR_TAC >> fs [] >> + drule ocompile_correct >> fs [] >> + map_every qexists_tac [‘t with clock := k’, ‘LN’, ‘nctxt’] >> + fs [] >> + Ho_Rewrite.PURE_REWRITE_TAC[GSYM PULL_EXISTS] >> + conj_tac + >- ( + fs [state_rel_def, Abbr ‘nctxt’, mk_ctxt_def] >> + fs [locals_rel_def, distinct_vars_def, ctxt_max_def] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + CCONTR_TAC >> + fs [] >> + fs [ocompile_def, compile_def] >> + fs [compile_exp_def] >> + fs [gen_temps_def, MAP2_DEF] >> + fs [nested_seq_def] >> + ‘find_lab nctxt start = lc’ by ( + fs [find_lab_def, Abbr ‘nctxt’, mk_ctxt_def]) >> + fs [] >> + drule make_funcs_domain_compile_prog >> + strip_tac >> + fs [loop_liveTheory.optimise_def] >> + fs [loop_callTheory.comp_def, loop_liveTheory.comp_def] >> + fs [loop_liveTheory.shrink_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rveq >> fs [] >> + fs [loop_liveTheory.mark_all_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rveq >> gs [] >> + cases_on ‘t1' ∧ t1''’ >> + gs [] + >- ( + qpat_x_assum ‘loopSem$evaluate (Mark _, _) = (_,_)’ mp_tac >> + rw [Once loopSemTheory.evaluate_def] >> + rw [Once loopSemTheory.evaluate_def] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def] >> rveq >> + ‘res = NONE ∧ s1 = t with clock := ck + k ∧ res' = NONE ∧ s1' = s1’ by + fs [evaluate_def] >> + qpat_x_assum ‘evaluate(Mark Skip, _) = _’ kall_tac >> + qpat_x_assum ‘evaluate(Mark Skip, _) = _’ kall_tac >> + rveq >> fs [] >> + CCONTR_TAC >> fs [] >> + cases_on ‘evaluate + (Call NONE (SOME (find_lab nctxt start)) [] NONE, + t with clock := k)’ >> + fs [] >> + cases_on ‘q'’ >> fs [] + >- ( + drule evaluate_add_clock_eq >> + disch_then (qspec_then ‘ck’ mp_tac) >> + strip_tac >> fs [] >> rveq >> fs [] >> + qpat_x_assum ‘_ = (res1,t1)’ mp_tac >> + rw [evaluate_def] >> + CCONTR_TAC >> + fs [] >> rveq >> fs [] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs [] >> rveq >> fs []) >> + cases_on ‘x’ >> fs [] >> ( + drule evaluate_add_clock_eq >> + disch_then (qspec_then ‘ck’ mp_tac) >> + strip_tac >> fs [] >> rveq >> fs [] >> + rveq >> fs [] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs [] >> rveq >> fs [])) + >- ( + cases_on ‘t1''’ >> fs [] + >- ( + qpat_x_assum ‘loopSem$evaluate (Seq _ _, _) = (_,_)’ mp_tac >> + rw [Once loopSemTheory.evaluate_def] >> + rw [Once loopSemTheory.evaluate_def] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def]) >> + qpat_x_assum ‘loopSem$evaluate (Seq _ _, _) = (_,_)’ mp_tac >> + rw [Once loopSemTheory.evaluate_def] >> + rw [Once loopSemTheory.evaluate_def] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def]) >> + qpat_x_assum ‘loopSem$evaluate (Seq _ _, _) = (_,_)’ mp_tac >> + rw [Once loopSemTheory.evaluate_def] >> + rw [Once loopSemTheory.evaluate_def] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def]) >> + (* the termination/diverging case of loop semantics *) + DEEP_INTRO_TAC some_intro >> simp[] >> + conj_tac + (* the termination case of loop semantics *) + >- ( + rw [] >> fs[] >> + qpat_x_assum ‘∀x y. _’ (qspec_then ‘k’ mp_tac)>> + (fn g => subterm (fn tm => Cases_on ‘^(assert(has_pair_type)tm)’) (#2 g) g) >> + strip_tac >> + drule ocompile_correct >> fs [] >> + map_every qexists_tac [‘t with clock := k’, ‘LN’, ‘nctxt’] >> + fs [] >> + Ho_Rewrite.PURE_REWRITE_TAC[GSYM PULL_EXISTS] >> + conj_tac + >- ( + fs [state_rel_def, Abbr ‘nctxt’, mk_ctxt_def] >> + fs [locals_rel_def, distinct_vars_def, ctxt_max_def] >> + last_x_assum (qspec_then ‘k’ assume_tac) >> + rfs [] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + CCONTR_TAC >> + fs [] >> + fs [ocompile_def, compile_def] >> + fs [compile_exp_def] >> + fs [gen_temps_def, MAP2_DEF] >> + fs [nested_seq_def] >> + ‘find_lab nctxt start = lc’ by ( + fs [find_lab_def, Abbr ‘nctxt’, mk_ctxt_def]) >> + fs [] >> + drule make_funcs_domain_compile_prog >> + strip_tac >> + fs [loop_liveTheory.optimise_def] >> + fs [loop_callTheory.comp_def, loop_liveTheory.comp_def] >> + fs [loop_liveTheory.shrink_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rveq >> fs [] >> + fs [loop_liveTheory.mark_all_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rveq >> gs [] >> + cases_on ‘t1' ∧ t1''’ >> + gs [] + >- ( + qpat_x_assum ‘loopSem$evaluate (Mark _, _) = (_,_)’ mp_tac >> + rw [Once loopSemTheory.evaluate_def] >> + rw [Once loopSemTheory.evaluate_def] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def] >> rveq >> + ‘res = NONE ∧ s1 = t with clock := ck + k ∧ res' = NONE ∧ s1' = s1’ by + fs [evaluate_def] >> + qpat_x_assum ‘evaluate(Mark Skip, _) = _’ kall_tac >> + qpat_x_assum ‘evaluate(Mark Skip, _) = _’ kall_tac >> + rveq >> fs [] >> + cases_on ‘evaluate + (Call NONE (SOME (find_lab nctxt start)) [] NONE, + t with clock := k)’ >> + fs [] >> + cases_on ‘q'’ >> fs [] + >- ( + drule evaluate_add_clock_eq >> + disch_then (qspec_then ‘ck’ mp_tac) >> + strip_tac >> fs [] >> rveq >> fs [] >> + qpat_x_assum ‘_ = (res1,t1)’ mp_tac >> + rw [evaluate_def] >> + CCONTR_TAC >> + fs [] >> rveq >> fs [] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs [] >> rveq >> fs []) >> + cases_on ‘x’ >> fs [] >> ( + drule evaluate_add_clock_eq >> + disch_then (qspec_then ‘ck’ mp_tac) >> + strip_tac >> fs [] >> rveq >> fs [] >> + rveq >> fs [] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs [] >> rveq >> fs [])) + >- ( + cases_on ‘t1''’ >> fs [] + >- ( + qpat_x_assum ‘loopSem$evaluate (Seq _ _, _) = (_,_)’ mp_tac >> + rw [Once loopSemTheory.evaluate_def] >> + rw [Once loopSemTheory.evaluate_def] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def]) >> + qpat_x_assum ‘loopSem$evaluate (Seq _ _, _) = (_,_)’ mp_tac >> + rw [Once loopSemTheory.evaluate_def] >> + rw [Once loopSemTheory.evaluate_def] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def]) >> + qpat_x_assum ‘loopSem$evaluate (Seq _ _, _) = (_,_)’ mp_tac >> + rw [Once loopSemTheory.evaluate_def] >> + rw [Once loopSemTheory.evaluate_def] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def]) >> + (* the diverging case of word semantics *) + rw [] >> + qmatch_abbrev_tac ‘build_lprefix_lub l1 = build_lprefix_lub l2’ >> + ‘(lprefix_chain l1 ∧ lprefix_chain l2) ∧ equiv_lprefix_chain l1 l2’ + suffices_by metis_tac[build_lprefix_lub_thm,lprefix_lub_new_chain,unique_lprefix_lub] >> + conj_asm1_tac + >- ( + UNABBREV_ALL_TAC >> + conj_tac >> + Ho_Rewrite.ONCE_REWRITE_TAC[GSYM o_DEF] >> + REWRITE_TAC[IMAGE_COMPOSE] >> + match_mp_tac prefix_chain_lprefix_chain >> + simp[prefix_chain_def,PULL_EXISTS] >> + qx_genl_tac [‘k1’, ‘k2’] >> + qspecl_then [‘k1’, ‘k2’] mp_tac LESS_EQ_CASES >> + simp[LESS_EQ_EXISTS] >> + rw [] >> + assume_tac (INST_TYPE [``:'a``|->``:'a``, + ``:'b``|->``:'b``] + crepPropsTheory.evaluate_add_clock_io_events_mono) >> + assume_tac (INST_TYPE [``:'a``|->``:'a``, + ``:'b``|->``:'b``] + loopPropsTheory.evaluate_add_clock_io_events_mono) >> + first_assum (qspecl_then + [‘Call NONE (SOME lc) [] NONE’, ‘t with clock := k1’, ‘p’] mp_tac) >> + first_assum (qspecl_then + [‘Call NONE (SOME lc) [] NONE’, ‘t with clock := k2’, ‘p’] mp_tac) >> + first_assum (qspecl_then + [‘Call Tail (Label start) []’, ‘s with clock := k1’, ‘p’] mp_tac) >> + first_assum (qspecl_then + [‘Call Tail (Label start) []’, ‘s with clock := k2’, ‘p’] mp_tac) >> + fs []) >> + simp [equiv_lprefix_chain_thm] >> + fs [Abbr ‘l1’, Abbr ‘l2’] >> simp[PULL_EXISTS] >> + pop_assum kall_tac >> + simp[LNTH_fromList,PULL_EXISTS] >> + simp[GSYM FORALL_AND_THM] >> + rpt gen_tac >> + reverse conj_tac >> strip_tac + >- ( + qmatch_assum_abbrev_tac`n < LENGTH (_ (_ (SND p)))` >> + Cases_on`p` >> pop_assum(assume_tac o SYM o REWRITE_RULE[markerTheory.Abbrev_def]) >> + drule ocompile_correct >> fs [] >> + ‘q ≠ SOME Error ∧ + q ≠ SOME Break ∧ q ≠ SOME Continue ∧ q ≠ NONE’ by ( + last_x_assum (qspec_then ‘k’ assume_tac) >> rfs [] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + fs [] >> + disch_then (qspecl_then [‘t with clock := k’, ‘LN’, ‘nctxt’] mp_tac) >> + impl_tac + >- ( + fs [Abbr ‘nctxt’, mk_ctxt_def, state_rel_def] >> + fs [locals_rel_def, distinct_vars_def, ctxt_max_def]) >> + strip_tac >> fs [] >> + qexists_tac ‘ck+k’ >> simp[] >> + fs [ocompile_def, compile_def] >> + fs [compile_exp_def] >> + fs [gen_temps_def, MAP2_DEF] >> + fs [nested_seq_def] >> + ‘find_lab nctxt start = lc’ by ( + fs [find_lab_def, Abbr ‘nctxt’, mk_ctxt_def]) >> + fs [] >> + drule make_funcs_domain_compile_prog >> + strip_tac >> + fs [] >> + fs [loop_liveTheory.optimise_def] >> + fs [loop_callTheory.comp_def, loop_liveTheory.comp_def] >> + fs [loop_liveTheory.shrink_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rveq >> fs [] >> + fs [loop_liveTheory.mark_all_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rveq >> gs [] >> + cases_on ‘t1' ∧ t1''’ >> + gs [] + >- ( + qpat_x_assum ‘loopSem$evaluate (Mark _, _) = (_,_)’ mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def] >> rveq >> + ‘res = NONE ∧ s1 = t with clock := ck + k ∧ res' = NONE ∧ s1' = s1’ by + fs [evaluate_def] >> + qpat_x_assum ‘evaluate(Mark Skip, _) = _’ kall_tac >> + qpat_x_assum ‘evaluate(Mark Skip, _) = _’ kall_tac >> + rveq >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def, LET_THM] >> + strip_tac >> + first_x_assum (qspec_then ‘ck’ kall_tac) >> + first_x_assum (qspec_then ‘ck+k’ mp_tac) >> + fs [] >> + strip_tac >> + cases_on ‘res''’ >> fs [] >> rveq >> fs [] >> + TRY (cases_on ‘x’ >> fs [] >> rveq >> fs []) >> + fs [state_rel_def]) + >- ( + cases_on ‘t1''’ >> fs [] + >- ( + qpat_x_assum ‘loopSem$evaluate (Seq _ _, _) = (_,_)’ mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def]) >> + qpat_x_assum ‘loopSem$evaluate (Seq _ _, _) = (_,_)’ mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def]) >> + qpat_x_assum ‘loopSem$evaluate (Seq _ _, _) = (_,_)’ mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def]) >> + (fn g => subterm (fn tm => Cases_on`^(Term.subst[{redex = #1(dest_exists(#2 g)), residue = ``k:num``}] + (assert(has_pair_type)tm))`) (#2 g) g) >> + drule ocompile_correct >> fs [] >> + ‘q ≠ SOME Error ∧ + q ≠ SOME Break ∧ q ≠ SOME Continue ∧ q ≠ NONE’ by ( + last_x_assum (qspec_then ‘k’ assume_tac) >> rfs [] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + fs [] >> + disch_then (qspecl_then [‘t with clock := k’, ‘LN’, ‘nctxt’] mp_tac) >> + impl_tac + >- ( + fs [Abbr ‘nctxt’, mk_ctxt_def, state_rel_def] >> + fs [locals_rel_def, distinct_vars_def, ctxt_max_def]) >> + strip_tac >> fs [] >> + fs [ocompile_def, compile_def] >> + fs [compile_exp_def] >> + fs [gen_temps_def, MAP2_DEF] >> + fs [nested_seq_def] >> + ‘find_lab nctxt start = lc’ by ( + fs [find_lab_def, Abbr ‘nctxt’, mk_ctxt_def]) >> + fs [] >> + drule make_funcs_domain_compile_prog >> + strip_tac >> + fs [] >> + fs [loop_liveTheory.optimise_def] >> + fs [loop_callTheory.comp_def, loop_liveTheory.comp_def] >> + fs [loop_liveTheory.shrink_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rveq >> fs [] >> + fs [loop_liveTheory.mark_all_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rveq >> gs [] >> + cases_on ‘t1' ∧ t1''’ >> + gs [] + >- ( + qpat_x_assum ‘loopSem$evaluate (Mark _, _) = (_,_)’ mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def] >> rveq >> + ‘res = NONE ∧ s1 = t with clock := ck + k ∧ res' = NONE ∧ s1' = s1’ by + fs [evaluate_def] >> + qpat_x_assum ‘evaluate(Mark Skip, _) = _’ kall_tac >> + qpat_x_assum ‘evaluate(Mark Skip, _) = _’ kall_tac >> + rveq >> fs [] >> + strip_tac >> + assume_tac (INST_TYPE [``:'a``|->``:'a``, + ``:'b``|->``:'b``] + loopPropsTheory.evaluate_add_clock_io_events_mono) >> + first_x_assum (qspecl_then + [‘Call NONE (SOME (find_lab nctxt start)) [] NONE’, + ‘t with clock := k’, ‘ck’] mp_tac) >> + strip_tac >> rfs [] >> + qexists_tac ‘k’ >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs [] >> rveq >> fs [] + >- ( + qpat_x_assum ‘_ = (_,t1)’ mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def, LET_THM] >> + TOP_CASE_TAC >> fs [] >> strip_tac >> rveq >> fs [] >> rveq >> + fs [state_rel_def, IS_PREFIX_THM]) + >- ( + qpat_x_assum ‘_ = (_,t1)’ mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def, LET_THM] >> + TOP_CASE_TAC >> fs [] >> strip_tac >> rveq >> fs [] >> rveq >> + fs [state_rel_def, IS_PREFIX_THM]) + >- ( + qpat_x_assum ‘_ = (_,t1)’ mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def, LET_THM] >> + TOP_CASE_TAC >> fs [] >> strip_tac >> rveq >> fs [] >> rveq >> + fs [state_rel_def, IS_PREFIX_THM]) >> + qpat_x_assum ‘_ = (_,t1)’ mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def, LET_THM] >> + TOP_CASE_TAC >> fs [] >> strip_tac >> rveq >> fs [] >> rveq >> + fs [state_rel_def, IS_PREFIX_THM]) + >- ( + cases_on ‘t1''’ >> fs [] + >- ( + qpat_x_assum ‘loopSem$evaluate (Seq _ _, _) = (_,_)’ mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def]) >> + qpat_x_assum ‘loopSem$evaluate (Seq _ _, _) = (_,_)’ mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def]) >> + qpat_x_assum ‘loopSem$evaluate (Seq _ _, _) = (_,_)’ mp_tac >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + rewrite_tac [Once loopSemTheory.evaluate_def] >> + strip_tac >> + fs [loop_liveTheory.shrink_def, + lookup_insert, lookup_def, fromAList_def, loop_liveTheory.vars_of_exp_def] >> + rveq >> fs [lookup_def] >> rveq >> fs [] >> + gs [loop_liveTheory.mark_all_def] +QED + + +val _ = export_theory(); diff --git a/pancake/proofs/loop_callProofScript.sml b/pancake/proofs/loop_callProofScript.sml new file mode 100644 index 0000000000..0c41d7febe --- /dev/null +++ b/pancake/proofs/loop_callProofScript.sml @@ -0,0 +1,407 @@ +(* + loop_call proof +*) + +open preamble + loopSemTheory loopPropsTheory + loop_callTheory + +val _ = new_theory "loop_callProof"; + +Definition labels_in_def: + labels_in l locals = + !n x. lookup n l = SOME x ==> lookup n locals = SOME (Loc x 0) +End + +val goal = + “λ(prog, s). ∀res s1 l p nl. + evaluate (prog,s) = (res,s1) ∧ res ≠ SOME Error ∧ + comp l prog = (p, nl) /\ labels_in l s.locals ==> + evaluate (p,s) = (res,s1) /\ labels_in nl s1.locals” + +local + val ind_thm = loopSemTheory.evaluate_ind |> ISPEC goal + |> CONV_RULE (DEPTH_CONV PairRules.PBETA_CONV) |> REWRITE_RULE []; + fun list_dest_conj tm = if not (is_conj tm) then [tm] else let + val (c1,c2) = dest_conj tm in list_dest_conj c1 @ list_dest_conj c2 end + val ind_goals = ind_thm |> concl |> dest_imp |> fst |> list_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 + + +Theorem compile_Seq: + ^(get_goal "comp _ (loopLang$Seq _ _)") +Proof + rpt gen_tac >> strip_tac >> + rpt gen_tac >> strip_tac >> + fs [loopSemTheory.evaluate_def, labels_in_def] >> + pairarg_tac >> fs [comp_def] >> + rpt (pairarg_tac >> fs []) >> + fs [evaluate_def] >> + rpt (pairarg_tac >> fs []) >> + rveq >> fs [] >> + cases_on ‘res' = NONE’ >> + fs [] >> rveq >> fs [] + >- ( + first_x_assum (qspecl_then [‘l’, ‘np’, ‘nl'’] mp_tac) >> + impl_tac + >- ( + fs [] >> + rveq >> fs [] >> + CCONTR_TAC >> fs []) >> + strip_tac >> rveq >> + fs [evaluate_def] >> rveq >> fs [] >> + last_x_assum (qspecl_then [‘nl'’, ‘nq’, ‘nl''’] mp_tac) >> + fs [lookup_def]) >> + first_x_assum (qspecl_then [‘l’, ‘np’, ‘nl'’] mp_tac) >> + fs [] >> + strip_tac >> + fs [evaluate_def, lookup_def] +QED + + +Theorem compile_LocValue: + ^(get_goal "comp _ (loopLang$LocValue _ _)") +Proof + rpt gen_tac >> + strip_tac >> + fs [evaluate_def, labels_in_def, comp_def] >> + rveq >> fs [] >> + fs [evaluate_def] >> + cases_on ‘res’ >> fs [] >> + every_case_tac >> fs [] >> + last_x_assum (assume_tac o GSYM) >> + rveq >> fs [set_var_def] >> + rw [] >> + fs [lookup_insert] >> + every_case_tac >> fs [] +QED + + +Theorem compile_Assign: + ^(get_goal "comp _ (loopLang$Assign _ _)") +Proof + rpt gen_tac >> + strip_tac >> + cases_on ‘exp’ >> + TRY ( + rename [‘Assign n (Var m)’] >> + fs [evaluate_def, comp_def] >> + rveq >> fs [] >> + fs [evaluate_def] >> + fs [CaseEq "option"] >> rveq >> fs [] >> + reverse TOP_CASE_TAC >> fs [] + >- ( + fs [labels_in_def, eval_def] >> + rw [] >> fs [] >> + fs [set_var_def] >> + cases_on ‘n = n'’ >> + fs [lookup_insert] >> + rveq >> res_tac >> fs []) >> + TOP_CASE_TAC >> fs [] >> + fs [labels_in_def, eval_def] >> + rw [] >> fs [] >> + fs [set_var_def] >> + fs [lookup_insert, lookup_delete] >> + every_case_tac >> fs [] >> rveq >> fs []) >> + fs [evaluate_def, labels_in_def, comp_def] >> + rveq >> fs [] >> + fs [evaluate_def] >> + every_case_tac >> fs [] >> + last_x_assum (assume_tac o GSYM) >> + rveq >> fs [set_var_def] >> + rw [] >> + fs [lookup_insert] >> + every_case_tac >> fs [] >> + rveq >> fs [lookup_delete] +QED + +Theorem compile_LoadByte: + ^(get_goal "comp _ (loopLang$LoadByte _ _)") +Proof + rpt gen_tac >> + strip_tac >> + fs [evaluate_def,labels_in_def, comp_def] >> + rveq >> fs [] >> + fs [evaluate_def] >> + cases_on ‘res’ >> fs [] >> + every_case_tac >> fs [] >> + last_x_assum (assume_tac o GSYM) >> + rveq >> fs [set_var_def] >> + rw [] >> + fs [lookup_insert] >> + every_case_tac >> fs [] >> + rveq >> fs [lookup_delete] +QED + + +Theorem compile_Mark: + ^(get_goal "comp _ (loopLang$Mark _)") +Proof + rpt gen_tac >> + strip_tac >> + rpt gen_tac >> + fs [comp_def] >> + pairarg_tac >> fs [] >> rveq >> + fs [] >> + strip_tac >> fs [] >> + rveq >> fs [] >> + fs [evaluate_def] >> + res_tac >> fs [] +QED + + +Theorem compile_FFI: + ^(get_goal "comp _ (loopLang$FFI _ _ _ _ _ _)") +Proof + rpt gen_tac >> + strip_tac >> + rpt gen_tac >> + fs [labels_in_def, comp_def] >> + every_case_tac >> fs [] >> + rveq >> fs [] >> + fs [evaluate_def] >> + every_case_tac >> fs [] >> rveq >> + fs [] >> + fs [cut_state_def] >> rveq >> fs [lookup_def] +QED + + +Theorem compile_If: + ^(get_goal "comp _ (loopLang$If _ _ _ _ _ _)") +Proof + rpt gen_tac >> + strip_tac >> + rpt gen_tac >> + strip_tac >> + fs [evaluate_def, labels_in_def, comp_def] >> + rveq >> fs [] >> + fs [evaluate_def, CaseEq "option", CaseEq "word_loc"] >> + rveq >> fs [] >> + cases_on ‘word_cmp cmp x y’ >> fs [] >> rveq >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> rveq >> fs [] + >- ( + cases_on ‘evaluate (c1,s)’ >> fs [] >> + fs [cut_res_def] >> + cases_on ‘q ≠ NONE’ >> fs [] >> rveq >> fs [] + >- ( + last_x_assum drule >> + fs [] >> + strip_tac >> fs [] >> + fs [evaluate_def] >> + cases_on ‘q’ >> fs [cut_res_def, lookup_def]) >> + last_x_assum drule >> + fs [] >> + strip_tac >> fs [CaseEq "option"] >> + rveq >> fs [] >> + fs [evaluate_def, lookup_def] >> + fs [cut_res_def]) >> + cases_on ‘evaluate (c2,s)’ >> fs [] >> + fs [cut_res_def, lookup_def] >> + cases_on ‘q ≠ NONE’ >> fs [] >> rveq >> fs [] + >- ( + last_x_assum drule >> + fs [] >> + strip_tac >> fs [] >> + fs [evaluate_def] >> + cases_on ‘q’ >> fs [cut_res_def]) >> + last_x_assum drule >> + fs [] >> + strip_tac >> fs [CaseEq "option"] >> + rveq >> fs [] >> + fs [evaluate_def] >> + fs [cut_res_def] +QED + +Theorem compile_StoreByte: + ^(get_goal "comp _ (loopLang$StoreByte _ _)") +Proof + rpt gen_tac >> + strip_tac >> + fs [evaluate_def, labels_in_def, comp_def] >> + rveq >> fs [] >> + fs [evaluate_def] >> + cases_on ‘res’ >> fs [] >> + every_case_tac >> fs [] >> + last_x_assum (assume_tac o GSYM) >> + rveq >> fs [] +QED + + +Theorem compile_Store: + ^(get_goal "comp _ (loopLang$Store _ _)") +Proof + rpt gen_tac >> + strip_tac >> + fs [evaluate_def, labels_in_def, comp_def] >> + rveq >> fs [] >> + fs [evaluate_def] >> + cases_on ‘res’ >> fs [] >> + every_case_tac >> fs [mem_store_def] >> + last_x_assum (assume_tac o GSYM) >> + rveq >> fs [] +QED + +Theorem get_vars_front: + !xs ys s. get_vars xs s = SOME ys /\ xs <> []==> + get_vars (FRONT xs) s = SOME (FRONT ys) +Proof + Induct >> + rw [] >> + fs [FRONT_DEF] >> + every_case_tac >> fs [] + >- ( + fs [get_vars_def] >> + every_case_tac >> fs [] >> + pop_assum (assume_tac o GSYM) >> + fs []) >> + fs [get_vars_def] >> + every_case_tac >> fs [] >> + pop_assum (assume_tac o GSYM) >> + fs [] >> + res_tac >> fs [] >> + fs [FRONT_DEF] >> + TOP_CASE_TAC >> fs [] >> + rveq >> fs [] >> + cases_on ‘xs’ >> + fs [get_vars_def] >> + every_case_tac >> fs [] +QED + + +Theorem get_vars_last: + !xs ys s. get_vars xs s = SOME ys /\ xs <> []==> + lookup (LAST xs) s.locals = SOME (LAST ys) +Proof + Induct >> + rw [] >> + fs [LAST_DEF] >> + every_case_tac >> fs [] + >- ( + fs [get_vars_def] >> + every_case_tac >> fs [] >> + pop_assum (assume_tac o GSYM) >> + fs []) >> + fs [get_vars_def] >> + every_case_tac >> fs [] >> + pop_assum (assume_tac o GSYM) >> + fs [] >> + res_tac >> fs [] >> + fs [LAST_DEF] >> + TOP_CASE_TAC >> fs [] >> + rveq >> fs [] >> + cases_on ‘xs’ >> + fs [get_vars_def] >> + every_case_tac >> fs [] +QED + +Theorem compile_Call: + ^(get_goal "comp _ (loopLang$Call _ _ _ _)") +Proof + rpt gen_tac >> + strip_tac >> + rpt gen_tac >> + rpt (pop_assum kall_tac) >> + strip_tac >> + reverse (cases_on ‘dest’) + >- ( + fs [loop_callTheory.comp_def] >> + rveq >> fs [] >> + fs [labels_in_def, lookup_def]) >> + cases_on ‘argvars’ + >- ( + fs [loop_callTheory.comp_def, evaluate_def, get_vars_def] >> + fs [find_code_def]) >> + fs [loop_callTheory.comp_def] >> rveq >> + TOP_CASE_TAC >> fs [] + >- fs [labels_in_def, lookup_def] >> + fs [labels_in_def, lookup_def] >> + fs [evaluate_def] >> + cases_on ‘get_vars (h::t) s’ >> fs [] >> + qmatch_asmsub_rename_tac ‘get_vars (h::t) _ = SOME argsval’ >> + cases_on ‘find_code NONE argsval s.code’ >> + fs [] >> + ‘get_vars (FRONT (h::t)) s = SOME (FRONT argsval)’ by ( + fs [] >> + drule get_vars_front >> + fs []) >> + fs [] >> + ‘find_code (SOME x) (FRONT argsval) s.code = SOME x'’ suffices_by fs [] >> + ‘LAST argsval = (Loc x 0)’ by ( + ‘LAST argsval = THE(lookup (LAST (h::t)) s.locals)’ by ( + fs [] >> + pop_assum mp_tac >> + drule get_vars_last >> + fs []) >> + fs [] >> + res_tac >> fs []) >> + fs [find_code_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + fs [LENGTH_FRONT] +QED + + +Theorem compile_Loop: + ^(get_goal "comp _ (loopLang$Loop _ _ _)") +Proof + rpt gen_tac >> strip_tac >> + rpt gen_tac >> strip_tac >> + fs [comp_def] >> + pairarg_tac >> fs [] >> + rveq >> fs [] >> + qpat_x_assum ‘evaluate (Loop _ _ _,_) = (_,_)’ mp_tac >> + once_rewrite_tac [evaluate_def] >> + TOP_CASE_TAC >> fs [] >> rveq >> + reverse TOP_CASE_TAC >> fs [] >> rveq >> fs [] + >- ( + strip_tac >> rveq >> + fs [labels_in_def, lookup_def]) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> ( + strip_tac >> rveq >> fs [] >> + res_tac >> fs [labels_in_def, lookup_def]) >> + first_x_assum (qspec_then ‘LN’ mp_tac) >> + fs [labels_in_def, lookup_def] +QED + + +Theorem compile_others: + ^(get_goal "comp _ loopLang$Skip") ∧ + ^(get_goal "comp _ loopLang$Fail") ∧ + ^(get_goal "comp _ (loopLang$SetGlobal _ _)") ∧ + ^(get_goal "comp _ loopLang$Tick") ∧ + ^(get_goal "comp _ loopLang$Break") ∧ + ^(get_goal "comp _ loopLang$Continue") ∧ + ^(get_goal "comp _ (loopLang$Return _)") ∧ + ^(get_goal "comp _ (loopLang$Raise _)") +Proof + rpt conj_tac >> + rpt gen_tac >> strip_tac >> + fs [evaluate_def, labels_in_def, comp_def] >> + rveq >> fs [] >> + fs [evaluate_def] >> + every_case_tac >> fs [dec_clock_def] >> + last_x_assum (assume_tac o GSYM) >> + rveq >> fs [set_globals_def, lookup_def] +QED + + +Theorem compile_correct: + ^(compile_correct_tm()) +Proof + match_mp_tac (the_ind_thm()) >> + EVERY (map strip_assume_tac + [compile_others,compile_LocValue,compile_LoadByte,compile_StoreByte, + compile_Mark, compile_Assign, compile_Store, + compile_Call, compile_Seq, compile_If, compile_FFI, compile_Loop]) >> + asm_rewrite_tac [] >> rw [] >> rpt (pop_assum kall_tac) +QED + + +val _ = export_theory(); diff --git a/pancake/proofs/loop_liveProofScript.sml b/pancake/proofs/loop_liveProofScript.sml new file mode 100644 index 0000000000..f3e9aa688e --- /dev/null +++ b/pancake/proofs/loop_liveProofScript.sml @@ -0,0 +1,740 @@ +(* + Correctness proof for loop_live +*) + +open preamble + loopSemTheory loopPropsTheory + loop_liveTheory loop_callProofTheory + +local open wordSemTheory in end + +val _ = new_theory "loop_liveProof"; + + +val goal = + “λ(prog, s). ∀res s1 p l0 locals prog1 l1. + evaluate (prog,s) = (res,s1) ∧ res ≠ SOME Error ∧ + shrink p prog l0 = (prog1,l1) ∧ + subspt (inter s.locals l1) locals ⇒ + ∃new_locals. + evaluate (prog1,s with locals := locals) = + (res,s1 with locals := new_locals) ∧ + case res of + | NONE => subspt (inter s1.locals l0) new_locals + | SOME Continue => subspt (inter s1.locals (FST p)) new_locals + | SOME Break => subspt (inter s1.locals (SND p)) new_locals + | _ => new_locals = s1.locals” + +local + val ind_thm = loopSemTheory.evaluate_ind |> ISPEC goal + |> CONV_RULE (DEPTH_CONV PairRules.PBETA_CONV) |> REWRITE_RULE []; + fun list_dest_conj tm = if not (is_conj tm) then [tm] else let + val (c1,c2) = dest_conj tm in list_dest_conj c1 @ list_dest_conj c2 end + val ind_goals = ind_thm |> concl |> dest_imp |> fst |> list_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 + + +Theorem compile_Skip: + ^(get_goal "loopLang$Skip") ∧ + ^(get_goal "loopLang$Fail") ∧ + ^(get_goal "loopLang$Tick") +Proof + fs [shrink_def,evaluate_def] \\ fs [CaseEq"bool"] \\ rw [] + \\ fs [dec_clock_def,state_component_equality] +QED + +Theorem compile_Continue: + ^(get_goal "loopLang$Continue") ∧ + ^(get_goal "loopLang$Break") +Proof + fs [shrink_def,evaluate_def] + \\ fs [state_component_equality] +QED + +Theorem compile_Mark: + ^(get_goal "loopLang$Mark") +Proof + fs [shrink_def,evaluate_def] +QED + +Theorem compile_Return: + ^(get_goal "loopLang$Return") ∧ + ^(get_goal "loopLang$Raise") +Proof + fs [shrink_def,evaluate_def,CaseEq"option"] \\ rw [] + \\ fs [call_env_def] \\ fs [state_component_equality] + \\ fs [subspt_lookup,lookup_inter_alt] +QED + +Theorem compile_Seq: + ^(get_goal "loopLang$Seq") +Proof + fs [shrink_def,evaluate_def,CaseEq"option"] \\ rw [] + \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] + \\ rename [‘_ = (res7,s7)’] + \\ reverse (Cases_on ‘res7’) \\ fs [] + THEN1 + (rveq \\ fs [] \\ first_x_assum drule + \\ disch_then drule \\ fs [] \\ strip_tac \\ fs [evaluate_def] + \\ rveq \\ fs [] \\ fs [state_component_equality]) + \\ first_x_assum drule + \\ disch_then drule \\ fs [] \\ strip_tac \\ fs [evaluate_def] +QED + +Triviality subspt_IMP_domain: + subspt l1 l2 ⇒ domain l1 SUBSET domain l2 +Proof + fs [subspt_def,SUBSET_DEF] +QED + +Theorem compile_Loop: + ^(get_goal "loopLang$Loop") +Proof + rpt gen_tac \\ disch_then assume_tac \\ fs [] \\ rpt gen_tac + \\ once_rewrite_tac [evaluate_def] + \\ once_rewrite_tac [shrink_def] \\ fs [] + \\ TOP_CASE_TAC + \\ reverse (Cases_on ‘q’) \\ fs [] + THEN1 + (fs [cut_res_def,cut_state_def,CaseEq"option",CaseEq"bool"] \\ rveq \\ fs [] + \\ strip_tac \\ fs [] \\ rveq \\ fs [] + \\ rpt (pairarg_tac \\ fs []) + \\ rveq \\ fs [] + \\ TRY (PairCases_on ‘v’ \\ fs [] \\ rveq \\ fs []) + \\ once_rewrite_tac [evaluate_def] \\ fs [cut_res_def,cut_state_def] + \\ IF_CASES_TAC \\ fs [] + \\ fs [subspt_lookup,lookup_inter_alt,SUBSET_DEF,domain_lookup] + \\ res_tac \\ res_tac \\ rfs []) + \\ fs [cut_res_def,cut_state_def,CaseEq"option",CaseEq"prod",CaseEq"bool",dec_clock_def] + \\ Cases_on ‘evaluate (body,r)’ \\ fs [] + \\ Cases_on ‘q’ THEN1 (rw[] \\ fs []) \\ fs [PULL_EXISTS] + \\ reverse (Cases_on ‘fixedpoint live_in LN (inter live_out l0) body’) \\ fs [] + THEN1 + (strip_tac \\ rveq \\ fs [] + \\ drule fixedpoint_thm \\ strip_tac + \\ rename [‘_ = (new_body,new_in)’] + \\ once_rewrite_tac [evaluate_def] + \\ fs [cut_res_def,cut_state_def] + \\ reverse IF_CASES_TAC THEN1 + (qsuff_tac ‘F’ \\ fs [] \\ drule subspt_IMP_domain + \\ fs [domain_inter,SUBSET_DEF] \\ metis_tac []) + \\ fs [dec_clock_def] + \\ Cases_on ‘x = Error’ \\ rveq \\ fs [] + \\ qmatch_goalsub_abbrev_tac ‘(_,s6)’ + \\ last_x_assum drule + \\ disch_then (qspec_then ‘s6.locals’ mp_tac) + \\ impl_tac THEN1 + (unabbrev_all_tac \\ fs [] + \\ fs [subspt_lookup,lookup_inter_alt,domain_inter]) + \\ strip_tac \\ fs [Abbr‘s6’] + \\ Cases_on ‘x’ \\ fs [] \\ rveq \\ fs [] + THEN1 + (Cases_on ‘domain live_out ⊆ domain r'.locals’ \\ fs [] + \\ reverse IF_CASES_TAC \\ fs [] THEN1 + (imp_res_tac subspt_IMP_domain \\ fs [domain_inter,SUBSET_DEF] + \\ metis_tac []) + \\ IF_CASES_TAC \\ fs [] \\ rveq \\ fs [] + \\ fs [state_component_equality] + \\ fs [subspt_lookup,lookup_inter_alt,domain_inter]) + \\ first_x_assum (qspecl_then [‘p’,‘l0’] mp_tac) + \\ once_rewrite_tac [shrink_def] \\ fs []) + \\ pairarg_tac \\ fs [] + \\ strip_tac \\ rveq \\ fs [] + \\ Cases_on ‘x = Error’ \\ rveq \\ fs [] + \\ once_rewrite_tac [evaluate_def] + \\ fs [cut_res_def,cut_state_def] + \\ reverse IF_CASES_TAC THEN1 + (qsuff_tac ‘F’ \\ fs [] \\ drule subspt_IMP_domain + \\ fs [domain_inter,SUBSET_DEF] \\ metis_tac []) + \\ fs [dec_clock_def] + \\ qmatch_goalsub_abbrev_tac ‘(_,s6)’ + \\ last_x_assum drule + \\ disch_then (qspec_then ‘s6.locals’ mp_tac) + \\ impl_tac THEN1 + (unabbrev_all_tac \\ fs [] + \\ fs [subspt_lookup,lookup_inter_alt,domain_inter]) + \\ strip_tac \\ fs [Abbr‘s6’] + \\ Cases_on ‘x’ \\ fs [] \\ rveq \\ fs [] + THEN1 + (Cases_on ‘domain live_out ⊆ domain r'.locals’ \\ fs [] + \\ reverse IF_CASES_TAC \\ fs [] THEN1 + (imp_res_tac subspt_IMP_domain \\ fs [domain_inter,SUBSET_DEF] + \\ metis_tac []) + \\ IF_CASES_TAC \\ fs [] \\ rveq \\ fs [] + \\ fs [state_component_equality] + \\ fs [subspt_lookup,lookup_inter_alt,domain_inter]) + \\ first_x_assum (qspecl_then [‘p’,‘l0’] mp_tac) + \\ once_rewrite_tac [shrink_def] \\ fs [] +QED + +Theorem vars_of_exp_acc: + ∀(exp:'a loopLang$exp) l. + domain (vars_of_exp exp l) = + domain (union (vars_of_exp exp LN) l) +Proof + qsuff_tac ‘ + (∀(exp:'a loopLang$exp) (l:num_set) l. + domain (vars_of_exp exp l) = + domain (union (vars_of_exp exp LN) l)) ∧ + (∀(exp:'a loopLang$exp list) (l:num_set) l x. + domain (vars_of_exp_list exp l) = + domain (union (vars_of_exp_list exp LN) l))’ THEN1 metis_tac [] + \\ ho_match_mp_tac vars_of_exp_ind \\ rw [] + \\ once_rewrite_tac [vars_of_exp_def] + THEN1 fs [domain_insert,domain_union,EXTENSION] + THEN1 fs [domain_insert,domain_union,EXTENSION] + \\ TRY (rpt (pop_assum (qspec_then ‘l’ mp_tac)) \\ fs [] \\ NO_TAC) + \\ TRY (rpt (pop_assum (qspec_then ‘l'’ mp_tac)) \\ fs [] \\ NO_TAC) + \\ Cases_on ‘exp’ \\ fs [] + \\ simp_tac std_ss [domain_union] + \\ rpt (pop_assum (fn th => once_rewrite_tac [th])) + \\ simp_tac std_ss [domain_union] + \\ fs [domain_insert,domain_union,EXTENSION] \\ metis_tac [] +QED + +Theorem eval_lemma: + ∀s exp w l. + eval s exp = SOME w ∧ + subspt (inter s.locals (vars_of_exp exp l)) locals ⇒ + eval (s with locals := locals) exp = SOME w +Proof + ho_match_mp_tac eval_ind \\ rw [] \\ fs [eval_def] + THEN1 fs [vars_of_exp_def,subspt_lookup,lookup_inter_alt] + THEN1 + (fs [CaseEq"option",CaseEq"word_loc",vars_of_exp_def,PULL_EXISTS] \\ rveq + \\ res_tac \\ fs[] \\ fs [mem_load_def]) + THEN1 + (fs [CaseEq"option",CaseEq"word_loc"] \\ rveq + \\ goal_assum (first_assum o mp_then Any mp_tac) + \\ pop_assum mp_tac + \\ once_rewrite_tac [vars_of_exp_def] + \\ pop_assum kall_tac + \\ pop_assum mp_tac + \\ qid_spec_tac ‘ws’ + \\ Induct_on ‘wexps’ \\ fs [] \\ rw [] + \\ fs [wordSemTheory.the_words_def,CaseEq"option",CaseEq"word_loc",PULL_EXISTS] + \\ rveq \\ fs [] \\ conj_tac + \\ fs [PULL_FORALL,AND_IMP_INTRO] + \\ first_x_assum match_mp_tac + THEN1 (fs [Once vars_of_exp_def] \\ metis_tac []) + \\ pop_assum mp_tac \\ simp [Once vars_of_exp_def] + \\ rw [] THEN1 metis_tac [] + \\ fs [subspt_lookup,lookup_inter_alt] + \\ pop_assum mp_tac + \\ once_rewrite_tac [vars_of_exp_acc] + \\ fs [domain_union]) + THEN1 + (fs [CaseEq"option",CaseEq"word_loc",vars_of_exp_def,PULL_EXISTS] \\ rveq + \\ res_tac \\ fs[] \\ fs [mem_load_def]) +QED + +Theorem compile_Assign: + ^(get_goal "loopLang$Assign") ∧ + ^(get_goal "loopLang$SetGlobal") ∧ + ^(get_goal "loopLang$LocValue") +Proof + reverse (rw []) THEN1 + (fs [shrink_def,CaseEq"option"] \\ rveq \\ fs [] + THEN1 + (fs [evaluate_def,CaseEq"bool"] \\ rveq \\ fs [set_var_def] + \\ fs [state_component_equality] + \\ ‘~(r IN domain l0)’ by fs [domain_lookup] + \\ fs [subspt_lookup,lookup_inter_alt,lookup_insert] + \\ rw [] \\ fs []) + \\ fs [evaluate_def,CaseEq"bool"] \\ rveq \\ fs [set_var_def] + \\ fs [state_component_equality] + \\ fs [subspt_lookup,lookup_inter_alt,lookup_insert] \\ rw []) + \\ fs [shrink_def,CaseEq"option"] \\ rveq \\ fs [] + THEN1 + (fs [evaluate_def,CaseEq"option"] \\ rveq \\ fs [PULL_EXISTS,set_globals_def] + \\ fs [state_component_equality] + \\ drule eval_lemma \\ disch_then drule \\ fs [] + \\ fs [subspt_lookup,lookup_inter_alt] + \\ pop_assum mp_tac + \\ once_rewrite_tac [vars_of_exp_acc] \\ fs [domain_union]) + THEN1 + (fs [evaluate_def,state_component_equality,CaseEq"option",set_var_def] + \\ rveq \\ fs [] \\ fs [subspt_lookup,lookup_inter,CaseEq"option"] + \\ rw [] \\ res_tac + \\ qpat_x_assum ‘insert _ _ _ = _’ (assume_tac o GSYM) + \\ fs [lookup_insert,CaseEq"bool"] \\ rveq \\ fs []) + \\ fs [evaluate_def,CaseEq"option"] \\ rveq \\ fs [] + \\ fs [state_component_equality,set_var_def,PULL_EXISTS] + \\ qexists_tac ‘w’ \\ fs [] + \\ reverse conj_tac THEN1 + (pop_assum mp_tac + \\ fs [subspt_lookup,lookup_inter_alt] + \\ fs [lookup_insert] + \\ once_rewrite_tac [vars_of_exp_acc] \\ fs [domain_union] + \\ metis_tac []) + \\ drule eval_lemma + \\ disch_then drule \\ fs [] +QED + +Theorem compile_If: + ^(get_goal "loopLang$If") +Proof + fs [evaluate_def,CaseEq"option",CaseEq"word_loc",PULL_EXISTS] + \\ rpt strip_tac \\ fs [] \\ rveq \\ fs [] + \\ Cases_on ‘evaluate (if word_cmp cmp x y then c1 else c2,s)’ \\ fs [] + \\ Cases_on ‘q = SOME Error’ THEN1 fs [cut_res_def] \\ fs [] + \\ fs [shrink_def] + \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] + \\ fs [evaluate_def] + \\ ‘lookup r1 locals = SOME (Word x) ∧ + get_var_imm ri (s with locals := locals) = SOME (Word y)’ by + (Cases_on ‘ri’ \\ fs [subspt_lookup,lookup_inter_alt,domain_union] + \\ fs [get_var_imm_def]) + \\ fs [] \\ IF_CASES_TAC \\ fs [] + \\ first_x_assum drule + \\ disch_then (qspec_then ‘locals’ mp_tac) + \\ (impl_tac THEN1 fs [subspt_lookup,lookup_inter_alt,domain_union]) + \\ strip_tac \\ fs [] + \\ (reverse (Cases_on ‘q’) \\ fs [cut_res_def] + THEN1 (Cases_on ‘x'’ \\ fs [] \\ rveq \\ fs [] \\ fs [state_component_equality])) + \\ fs [cut_state_def,CaseEq"option",CaseEq"bool"] + \\ rveq \\ fs [] \\ fs [state_component_equality,domain_inter] + \\ imp_res_tac subspt_IMP_domain + \\ fs [domain_inter,domain_insert,domain_union,SUBSET_DEF] + \\ fs [dec_clock_def] + \\ fs [subspt_lookup,lookup_inter_alt,domain_inter] +QED + +Theorem compile_Call: + ^(get_goal "loopLang$Call") +Proof + rw [] \\ fs [evaluate_def] + \\ Cases_on ‘get_vars argvars s’ \\ fs [] + \\ Cases_on ‘find_code dest x s.code’ \\ fs [] + \\ rename [‘_ = SOME y’] \\ PairCases_on ‘y’ \\ fs [] + \\ ‘set argvars SUBSET domain l1’ by + (Cases_on ‘ret’ \\ Cases_on ‘handler’ \\ fs [shrink_def,CaseEq"prod"] + \\ rpt (pairarg_tac \\ fs []) + \\ rveq \\ fs [domain_union,domain_fromAList,MAP_MAP_o,o_DEF,SUBSET_DEF]) + \\ ‘get_vars argvars (s with locals := locals) = SOME x’ by + (pop_assum mp_tac \\ pop_assum kall_tac + \\ ntac 2 (pop_assum mp_tac) + \\ qid_spec_tac ‘x’ + \\ qid_spec_tac ‘argvars’ \\ rpt (pop_assum kall_tac) + \\ Induct + \\ fs [get_vars_def,CaseEq"option",PULL_EXISTS,PULL_FORALL] + \\ rw [] \\ fs [subspt_lookup,lookup_inter_alt]) + \\ Cases_on ‘ret’ \\ fs [] + THEN1 + (Cases_on ‘handler’ \\ fs [] + \\ fs [shrink_def] \\ rveq \\ fs [] + \\ fs [evaluate_def] + \\ IF_CASES_TAC \\ fs [] \\ rveq \\ fs [] + \\ fs [dec_clock_def] \\ fs [state_component_equality] + \\ Cases_on ‘res’ \\ fs [] \\ fs [subspt_lookup,lookup_inter_alt] + \\ Cases_on ‘x'’ \\ fs [] \\ fs [subspt_lookup,lookup_inter_alt]) + \\ rename [‘Call (SOME z)’] \\ PairCases_on ‘z’ \\ fs [] + \\ Cases_on ‘handler’ \\ fs [shrink_def] \\ rveq \\ fs [] + THEN1 + (fs [evaluate_def,cut_res_def,cut_state_def] + \\ Cases_on ‘domain z1 ⊆ domain s.locals’ \\ fs [] + \\ reverse IF_CASES_TAC \\ fs [] + THEN1 + (imp_res_tac subspt_IMP_domain + \\ fs [domain_inter,domain_union,domain_delete,SUBSET_DEF] + \\ pop_assum mp_tac \\ fs [] \\ metis_tac []) + \\ IF_CASES_TAC \\ fs [] \\ rveq \\ fs [dec_clock_def] + \\ fs [CaseEq"prod",CaseEq"option"] \\ rveq \\ fs [] + \\ fs [CaseEq"result"] \\ rveq \\ fs [set_var_def] + \\ fs [state_component_equality] + \\ fs [subspt_lookup,lookup_insert,lookup_inter_alt] + \\ rw [] \\ fs [domain_inter,domain_union] + \\ CCONTR_TAC \\ fs []) + \\ PairCases_on ‘x'’ \\ fs [] + \\ fs [evaluate_def,cut_res_def,cut_state_def] + \\ Cases_on ‘domain z1 ⊆ domain s.locals’ \\ fs [] + \\ rpt (pairarg_tac \\ fs []) \\ rveq + \\ fs [evaluate_def,cut_res_def,cut_state_def] + \\ reverse IF_CASES_TAC \\ fs [] + THEN1 + (imp_res_tac subspt_IMP_domain + \\ fs [domain_inter,domain_union,domain_delete,SUBSET_DEF] + \\ pop_assum mp_tac \\ fs [] \\ metis_tac []) + \\ IF_CASES_TAC \\ fs [] \\ rveq \\ fs [] + \\ fs [dec_clock_def,CaseEq"prod",CaseEq"option"] \\ rveq \\ fs [] + \\ qpat_x_assum ‘∀x. _’ kall_tac + \\ fs [CaseEq"result"] \\ rveq \\ fs [] + \\ rpt (fs [state_component_equality] \\ NO_TAC) + \\ fs [set_var_def] + THEN1 + (qmatch_goalsub_abbrev_tac ‘evaluate (r1,st1)’ + \\ Cases_on ‘evaluate + (x'2,st with locals := insert z0 retv (inter s.locals z1))’ \\ fs [] + \\ Cases_on ‘q = SOME Error’ THEN1 fs [cut_res_def] \\ fs [] + \\ first_x_assum drule + \\ disch_then (qspec_then ‘st1.locals’ mp_tac) + \\ impl_tac THEN1 + (fs [Abbr‘st1’,subspt_lookup,lookup_inter_alt,lookup_insert, + domain_union,domain_inter] \\ rw [] \\ fs []) + \\ strip_tac \\ fs [] + \\ unabbrev_all_tac \\ fs [] + \\ reverse (Cases_on ‘q’) \\ fs [] + THEN1 + (Cases_on ‘x'’ \\ fs [cut_res_def,state_component_equality] + \\ Cases_on ‘res’ \\ fs [] + \\ Cases_on ‘x'’ \\ fs [] \\ fs [subspt_lookup]) + \\ fs [cut_res_def,cut_state_def,CaseEq"option",CaseEq"bool"] + \\ fs [state_component_equality,domain_inter,domain_union,dec_clock_def] + \\ fs [SUBSET_DEF] \\ rw [] + \\ rpt (qpat_x_assum ‘inter _ _ = _’ (assume_tac o GSYM)) \\ fs [] + \\ fs [subspt_lookup,lookup_inter_alt,domain_inter] + \\ fs [domain_lookup] \\ res_tac \\ res_tac \\ fs []) + THEN1 + (qmatch_goalsub_abbrev_tac ‘evaluate (r1,st1)’ + \\ Cases_on ‘evaluate + (x'1,st with locals := insert x'0 exn (inter s.locals z1))’ \\ fs [] + \\ Cases_on ‘q = SOME Error’ THEN1 fs [cut_res_def] \\ fs [] + \\ first_x_assum drule + \\ disch_then (qspec_then ‘st1.locals’ mp_tac) + \\ impl_tac THEN1 + (fs [Abbr‘st1’,subspt_lookup,lookup_inter_alt,lookup_insert, + domain_union,domain_inter] \\ rw [] \\ fs []) + \\ strip_tac \\ fs [] + \\ unabbrev_all_tac \\ fs [] + \\ reverse (Cases_on ‘q’) \\ fs [] + THEN1 + (Cases_on ‘x'’ \\ fs [cut_res_def,state_component_equality] + \\ Cases_on ‘res’ \\ fs [] + \\ Cases_on ‘x'’ \\ fs [] \\ fs [subspt_lookup]) + \\ fs [cut_res_def,cut_state_def,CaseEq"option",CaseEq"bool"] + \\ fs [state_component_equality,domain_inter,domain_union,dec_clock_def] + \\ fs [SUBSET_DEF] \\ rw [] + \\ rpt (qpat_x_assum ‘inter _ _ = _’ (assume_tac o GSYM)) \\ fs [] + \\ fs [subspt_lookup,lookup_inter_alt,domain_inter] + \\ fs [domain_lookup] \\ res_tac \\ res_tac \\ fs []) +QED + +Theorem compile_Store: + ^(get_goal "loopLang$Store") ∧ + ^(get_goal "loopLang$StoreByte") ∧ + ^(get_goal "loopLang$LoadByte") +Proof + rw [] \\ fs [shrink_def] \\ rveq + THEN1 + (fs [evaluate_def,CaseEq"option",CaseEq"word_loc"] \\ rveq \\ fs [] + \\ fs [PULL_EXISTS] + \\ fs [mem_store_def] \\ rveq \\ fs [] + \\ simp [state_component_equality] + \\ drule eval_lemma + \\ disch_then drule \\ fs [] + \\ fs [subspt_lookup,lookup_inter_alt] + \\ qpat_x_assum ‘∀x. _’ mp_tac + \\ once_rewrite_tac [vars_of_exp_acc] \\ fs [domain_union] + \\ strip_tac + \\ ‘lookup v locals = SOME w’ by metis_tac [] \\ fs []) + THEN1 + (fs [evaluate_def,CaseEq"option",CaseEq"word_loc"] \\ rveq \\ fs [] + \\ fs [PULL_EXISTS] + \\ simp [state_component_equality] + \\ fs [subspt_lookup,lookup_inter_alt] + \\ res_tac \\ fs []) + THEN1 + (fs [evaluate_def,CaseEq"option",CaseEq"word_loc"] \\ rveq \\ fs [] + \\ fs [PULL_EXISTS] + \\ simp [state_component_equality,set_var_def] + \\ fs [subspt_lookup,lookup_inter_alt,lookup_insert] + \\ res_tac \\ fs [] \\ rw []) +QED + +Theorem compile_FFI: + ^(get_goal "loopLang$FFI") +Proof + fs [evaluate_def] \\ rw [] + \\ fs [CaseEq"option",CaseEq"word_loc"] \\ rveq \\ fs [] + \\ fs [shrink_def] \\ rveq \\ fs [] + \\ fs [subspt_lookup,evaluate_def,lookup_inter_alt,domain_insert, + cut_state_def, domain_inter] + \\ ‘domain cutset ∩ domain l0 ⊆ domain locals’ by ( + fs [SUBSET_DEF] + \\ rw [] + \\ res_tac \\ fs [] + \\ fs [domain_lookup] \\ metis_tac []) + \\ fs [] + \\ res_tac \\ fs [] \\ fs [] + \\ fs [CaseEq"ffi_result"] + \\ simp [state_component_equality] + \\ Cases_on ‘res’ \\ fs [] + \\ fs [SUBSET_DEF,call_env_def] + \\ rveq \\ fs [] + \\ qexists_tac ‘inter locals (inter cutset l0)’ + \\ fs [] + \\ rw [lookup_inter, domain_lookup] + \\ fs [CaseEq "option"] + \\ res_tac \\ fs [domain_lookup] +QED + +Theorem compile_correct: + ^(compile_correct_tm()) +Proof + match_mp_tac (the_ind_thm()) + \\ EVERY (map strip_assume_tac [compile_Skip, compile_Continue, + compile_Mark, compile_Return, compile_Assign, compile_Store, + compile_Call, compile_Seq, compile_If, compile_FFI, compile_Loop]) + \\ asm_rewrite_tac [] \\ rw [] \\ rpt (pop_assum kall_tac) +QED + +Theorem mark_correct: + ∀prog s res s1. evaluate (prog,s) = (res,s1) ⇒ + evaluate (FST (mark_all prog),s) = (res,s1) +Proof + recInduct evaluate_ind >> rw [] >> + fs [] >> + TRY ( + rename [‘Seq’] >> + fs [mark_all_def] >> + rpt (pairarg_tac >> fs [] >> rveq) >> + TOP_CASE_TAC >> fs [] >> + fs [evaluate_def] >> + rpt (pairarg_tac >> gs [] >> rveq) >> + every_case_tac >> fs []) >> + TRY ( + rename [‘If’] >> + fs [mark_all_def] >> + rpt (pairarg_tac >> fs [] >> rveq) >> + TOP_CASE_TAC >> fs [] >> + fs [evaluate_def] >> + every_case_tac >> fs [] >> + cases_on ‘evaluate (c1,s)’ >> fs [] >> + cases_on ‘q’ >> fs [cut_res_def] >> rveq >> gs [] >> + fs [cut_res_def] >> + cases_on ‘evaluate (c2,s)’ >> fs [] >> + cases_on ‘q’ >> fs [cut_res_def] >> rveq >> gs [] >> + fs [cut_res_def]) >> + TRY ( + rename [‘Mark’] >> + fs [mark_all_def] >> + fs [evaluate_def]) >> + TRY ( + rename [‘Loop’] >> + fs [mark_all_def] >> + rpt (pairarg_tac >> fs [] >> rveq) >> + fs [cut_res_def] >> + FULL_CASE_TAC >> fs [] + >- ( + fs [cut_state_def] >> + fs [Once evaluate_def, cut_res_def] >> + fs [cut_state_def]) >> + FULL_CASE_TAC >> fs [] + >- ( + fs [cut_state_def] >> + fs [Once evaluate_def, cut_res_def] >> + fs [cut_state_def]) >> + cases_on ‘evaluate (body,dec_clock x)’ >> fs [] >> + cases_on ‘q’ >> fs [] + >- ( + fs [Once evaluate_def] >> + every_case_tac >> fs [] >> rveq >> + gs [cut_res_def]) >> + cases_on ‘x'’ >> + TRY ( + rename [‘SOME Continue’] >> + gs [] >> + last_x_assum mp_tac >> + rewrite_tac [Once evaluate_def] >> + strip_tac >> + rewrite_tac [Once evaluate_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + fs [cut_res_def] >> + cases_on ‘cut_state live_in s’ >> fs [] >> + cases_on ‘x'.clock = 0’ >> fs [] >> rveq >> gs []) >> + fs [Once evaluate_def] >> + every_case_tac >> fs [] >> rveq >> + gs [cut_res_def]) >> + TRY ( + rename [‘Raise’] >> + fs [mark_all_def] >> + fs [evaluate_def]) >> + TRY ( + rename [‘Return’] >> + fs [mark_all_def] >> + fs [evaluate_def]) >> + TRY ( + rename [‘Tick’] >> + fs [mark_all_def] >> + fs [evaluate_def]) >> + TRY ( + rename [‘Call’] >> + fs [mark_all_def] >> + fs [evaluate_def] >> + TOP_CASE_TAC >> fs [] + >- rw [evaluate_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + TOP_CASE_TAC >> fs [] >> + ( + rw [evaluate_def] >> + every_case_tac >> fs [] >> rveq >> fs [] + >- ( + cases_on ‘evaluate (q'',set_var q'³' w (r'⁴' with locals := r''.locals))’ >> + fs [] >> + cases_on ‘q'⁵'’ >> fs [cut_res_def] >> + every_case_tac >> fs [] >> rveq >> gs [cut_res_def]) >> + cases_on ‘evaluate (q',set_var q w (r'⁴' with locals := r''.locals))’ >> + fs [] >> + cases_on ‘q'⁵'’ >> fs [cut_res_def] >> + every_case_tac >> fs [] >> rveq >> gs [cut_res_def])) >> + TRY ( + rename [‘FFI’] >> + fs [mark_all_def] >> + fs [evaluate_def]) >> + fs [evaluate_def, mark_all_def] +QED + + +Theorem comp_correct: + evaluate (prog,s) = (res,s1) ∧ + res ≠ SOME Error ∧ + res ≠ SOME Break ∧ + res ≠ SOME Continue ∧ + res ≠ NONE ⇒ + evaluate (comp prog,s) = (res,s1) +Proof + strip_tac + \\ drule compile_correct \\ fs [] + \\ fs [comp_def] + \\ Cases_on ‘shrink (LN,LN) prog LN’ \\ fs [] + \\ disch_then drule + \\ disch_then (qspec_then ‘s.locals’ mp_tac) + \\ impl_tac THEN1 fs [subspt_lookup,lookup_inter_alt] + \\ strip_tac + \\ ‘s with locals := s.locals = s’ by fs [state_component_equality] \\ fs [] + \\ fs [state_component_equality] + \\ Cases_on ‘res’ \\ fs [] + \\ Cases_on ‘x’ \\ fs [] + \\ match_mp_tac mark_correct + \\ fs [state_component_equality] +QED + + +Theorem optimise_correct: + evaluate (prog,s) = (res,s1) ∧ + res ≠ SOME Error ∧ + res ≠ SOME Break ∧ + res ≠ SOME Continue ∧ + res ≠ NONE ⇒ + evaluate (optimise prog,s) = (res,s1) +Proof + rw [] >> + fs [optimise_def] >> + cases_on ‘comp LN prog’ >> + drule loop_callProofTheory.compile_correct >> + fs [] >> + disch_then (qspecl_then [‘LN’, ‘q’, ‘r’] mp_tac) >> + fs [] >> + impl_tac >- fs [labels_in_def, lookup_def] >> + strip_tac >> fs [] >> + drule comp_correct >> + fs [] +QED + +Theorem mark_all_true_no_loop: + ∀p q. mark_all p = (q,T) ⇒ + every_prog (λq. ∀l1 x l2. q ≠ Loop l1 x l2) q +Proof + ho_match_mp_tac mark_all_ind >> rw [] >> + fs [] >> + TRY ( + rename [‘Call’] >> + fs [mark_all_def] >> rveq >> + every_case_tac >> gs [] >> rveq + >- fs [every_prog_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + cases_on ‘t1 ∧ t2’ >> fs [] >> rveq >> + fs [every_prog_def]) >> + fs [mark_all_def] >> rveq >> + TRY (pairarg_tac >> fs [] >> rveq) >> + TRY (pairarg_tac >> fs [] >> rveq) >> + fs [every_prog_def] +QED + +Theorem mark_all_false_loop: + ∀p q. mark_all p = (q,F) ⇒ + ~every_prog (λq. ∀l1 x l2. q ≠ Loop l1 x l2) q +Proof + ho_match_mp_tac mark_all_ind >> rw [] >> + CCONTR_TAC >> + fs [] >> + TRY ( + rename [‘Call’] >> + fs [mark_all_def] >> rveq >> + every_case_tac >> gs [] >> rveq >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + cases_on ‘t1 ∧ t2’ >> fs [] >> rveq >> + fs [every_prog_def]) >> + fs [mark_all_def] >> rveq >> + TRY (pairarg_tac >> fs [] >> rveq) >> + TRY (pairarg_tac >> fs [] >> rveq) >> + fs [every_prog_def] +QED + +Theorem mark_all_syntax_ok: + ∀p. syntax_ok (FST (mark_all p)) +Proof + ho_match_mp_tac mark_all_ind >> rw [] >> + fs [] >> + TRY ( + rename [‘Seq’] >> + fs [mark_all_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + cases_on ‘t1 ∧ t2’ >> fs [] + >- ( + fs [syntax_ok_def, no_Loop_def, every_prog_def] >> + imp_res_tac mark_all_true_no_loop >> fs []) >> + fs [syntax_ok_def, no_Loop_def, every_prog_def] >> + imp_res_tac mark_all_false_loop >> fs []) >> + TRY ( + rename [‘Loop’] >> + fs [mark_all_def] >> + pairarg_tac >> fs [] >> + fs [syntax_ok_def]) >> + TRY ( + rename [‘If’] >> + fs [mark_all_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + cases_on ‘t1 ∧ t2’ >> fs [] + >- ( + fs [syntax_ok_def, no_Loop_def, every_prog_def] >> + imp_res_tac mark_all_true_no_loop >> fs []) >> + fs [syntax_ok_def, no_Loop_def, every_prog_def] >> + imp_res_tac mark_all_false_loop >> fs []) >> + TRY ( + rename [‘Mark’] >> + fs [mark_all_def]) >> + TRY ( + rename [‘Call’] >> + fs [mark_all_def] >> + TOP_CASE_TAC >> fs [] + >- fs [syntax_ok_def, no_Loop_def, every_prog_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + cases_on ‘t1 ∧ t2’ >> fs [] + >- ( + fs [syntax_ok_def, no_Loop_def, every_prog_def] >> + imp_res_tac mark_all_true_no_loop >> fs []) >> + fs [syntax_ok_def, no_Loop_def, every_prog_def] >> + imp_res_tac mark_all_false_loop >> fs []) >> + fs [mark_all_def, syntax_ok_def, no_Loop_def, every_prog_def] +QED + + +val _ = export_theory(); diff --git a/pancake/proofs/loop_removeProofScript.sml b/pancake/proofs/loop_removeProofScript.sml new file mode 100644 index 0000000000..c10e0fa70e --- /dev/null +++ b/pancake/proofs/loop_removeProofScript.sml @@ -0,0 +1,1869 @@ +(* + Correctness proof for loop_remove +*) + +open preamble loopLangTheory loopSemTheory + loopPropsTheory loop_removeTheory + +local open wordSemTheory in end + +val _ = new_theory"loop_removeProof"; + +Definition has_code_def: + has_code (n,funs) code = + EVERY (\(n,p,b). lookup n code = SOME (p,b)) funs +End + +Definition state_rel_def: + state_rel s t <=> + ∃c. t = s with code := c ∧ + ∀n params body. + lookup n s.code = SOME (params, body) ⇒ + syntax_ok body ∧ + ∃init. has_code (comp (n,params,body) init) t.code +End + +Definition break_ok_def: + break_ok Fail = T ∧ + break_ok (Call _ _ _ (SOME (_,p,q,_))) = (break_ok p ∧ break_ok q) ∧ + break_ok (Call NONE _ _ _) = T ∧ + break_ok (Seq p q) = + (break_ok q ∧ every_prog (\r. r ≠ Break ∧ r ≠ Continue) p) ∧ + break_ok (If _ _ _ p q _) = (break_ok p ∧ break_ok q) ∧ + break_ok _ = F +End + +Definition breaks_ok_def: + breaks_ok (p:'a loopLang$prog,q:'a loopLang$prog) <=> break_ok p ∧ break_ok q +End + +val goal = + ``λ(prog, s). ∀res s1 t p. + evaluate (prog,s) = (res,s1) ∧ state_rel s t ∧ res ≠ SOME Error ∧ + breaks_ok p ⇒ + (syntax_ok prog ⇒ + ∀cont s q s'. + comp_with_loop p prog cont s = (q,s') ∧ + has_code s' t.code ∧ break_ok cont ⇒ + ∃t1. + (let result = evaluate (q,t) in + state_rel s1 t1 ∧ t1.code = t.code ∧ + case res of + | NONE => result = evaluate (cont,t1) + | SOME Break => result = evaluate (FST p,t1) + | SOME Continue => result = evaluate (SND p,t1) + | _ => result = (res,t1))) ∧ + (no_Loop prog ⇒ + ∃t1. + (let result = evaluate (comp_no_loop p prog,t) in + state_rel s1 t1 ∧ t1.code = t.code ∧ + case res of + | SOME Continue => result = evaluate (SND p,t1) + | SOME Break => result = evaluate (FST p,t1) + | _ => result = (res,t1)))`` + +local + val ind_thm = loopSemTheory.evaluate_ind + |> ISPEC goal + |> CONV_RULE (DEPTH_CONV PairRules.PBETA_CONV) |> REWRITE_RULE []; + fun list_dest_conj tm = if not (is_conj tm) then [tm] else let + val (c1,c2) = dest_conj tm in list_dest_conj c1 @ list_dest_conj c2 end + val ind_goals = ind_thm |> concl |> dest_imp |> fst |> list_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 + +Theorem compile_Skip: + ^(get_goal "loopLang$Skip") ∧ + ^(get_goal "loopLang$Fail") ∧ + ^(get_goal "loopLang$Tick") +Proof + fs [syntax_ok_def,comp_no_loop_def,evaluate_def] + \\ rw [] \\ fs [] + \\ fs [state_rel_def,call_env_def,dec_clock_def] + \\ rveq \\ fs [state_component_equality] + \\ rw [] \\ res_tac +QED + +Theorem compile_Continue: + ^(get_goal "loopLang$Continue") ∧ + ^(get_goal "loopLang$Break") +Proof + fs [syntax_ok_def,comp_no_loop_def,evaluate_def] + \\ rw [] \\ fs [] + \\ asm_exists_tac \\ fs [] +QED + +Theorem evaluate_break_ok: + ∀p t res t1. evaluate (p,t) = (res,t1) ∧ break_ok p ⇒ res ≠ NONE +Proof + ho_match_mp_tac break_ok_ind \\ rw [] \\ fs [break_ok_def] + \\ fs [evaluate_def] \\ rveq \\ fs [] + \\ fs [CaseEq"option",pair_case_eq,CaseEq"bool",CaseEq"word_loc"] \\ rveq \\ fs [] + \\ rpt (pairarg_tac \\ fs []) \\ rw [] \\ fs [] + \\ CCONTR_TAC \\ fs [] + \\ every_case_tac \\ gvs [] + \\ rename [‘cut_res _ (evaluate (pp,t))’] + \\ Cases_on ‘evaluate (pp,t)’ \\ fs [cut_res_def,cut_state_def] + \\ fs [CaseEq"option",pair_case_eq,CaseEq"bool",CaseEq"word_loc"] \\ rveq \\ fs [] + \\ gvs [] +QED + +Theorem compile_Mark: + ^(get_goal "syntax_ok (Mark _)") +Proof + simp_tac std_ss [evaluate_def,syntax_ok_def] + \\ full_simp_tac std_ss [no_Loop_def,every_prog_def] + \\ full_simp_tac std_ss [GSYM no_Loop_def,comp_with_loop_def] + \\ rw [] \\ fs [] + \\ first_x_assum drule + \\ disch_then drule \\ strip_tac + \\ asm_exists_tac \\ fs [] + \\ Cases_on ‘res’ \\ fs [evaluate_def,comp_no_loop_def] + \\ Cases_on ‘x’ \\ fs [evaluate_def,comp_no_loop_def] + \\ Cases_on ‘p'’ \\ fs [] + \\ rename [‘_ = evaluate (qq,_)’] + \\ fs [breaks_ok_def] + \\ Cases_on ‘evaluate (qq,t1)’ \\ fs [] \\ rw [] + \\ imp_res_tac evaluate_break_ok \\ fs [] +QED + +Theorem compile_Return: + ^(get_goal "loopLang$Return") ∧ + ^(get_goal "loopLang$Raise") +Proof + fs [syntax_ok_def,comp_no_loop_def,evaluate_def] + \\ rw [] \\ fs [CaseEq"option"] \\ rveq \\ fs [] + \\ fs [state_rel_def,call_env_def,state_component_equality] + \\ metis_tac [] +QED + +Theorem comp_with_loop_has_code: + ∀p prog cont s0 q s1 code. + comp_with_loop p prog cont s0 = (q,s1) ∧ has_code s1 code ⇒ has_code s0 code +Proof + ho_match_mp_tac comp_with_loop_ind \\ rpt strip_tac + \\ fs [comp_with_loop_def] \\ fs [] + \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] + \\ res_tac \\ fs [] + \\ res_tac \\ fs [] + \\ Cases_on ‘s0’ + \\ fs [store_cont_def] + \\ rveq \\ fs [] \\ fs [has_code_def] + \\ fs [CaseEq"option"] + \\ rveq \\ fs [] + \\ fs [has_code_def] + \\ PairCases_on ‘v’ \\ fs [] + \\ rpt (pairarg_tac \\ fs []) +QED + +Theorem helper_call_lemma: + ∀t live_in:num_set. + domain live_in ⊆ domain t.locals ⇒ + ∃vals. get_vars (MAP FST (toAList live_in)) t = SOME vals ∧ + LENGTH vals = LENGTH (toAList live_in) ∧ + fromAList (ZIP (MAP FST (toAList live_in),vals)) = + inter t.locals live_in +Proof + rw [] + \\ ‘∀i x. MEM (i,x) (toAList live_in) ⇔ lookup i live_in = SOME x’ by fs [MEM_toAList] + \\ ‘domain live_in = set (MAP FST (toAList live_in))’ + by fs [EXTENSION,domain_lookup,MEM_MAP,EXISTS_PROD] + \\ fs [spt_eq_thm,wf_inter,wf_fromAList,lookup_fromAList,lookup_inter_alt] + \\ pop_assum kall_tac \\ pop_assum kall_tac + \\ rename [‘MAP FST xs’] + \\ Induct_on ‘xs’ \\ fs [get_vars_def,FORALL_PROD] + \\ rw [] \\ fs [domain_lookup] \\ rw [] \\ fs [] +QED + +Theorem break_ok_no_Break_Continue: + ∀p. break_ok p ⇒ every_prog (\r. r ≠ Break ∧ r ≠ Continue) p +Proof + ho_match_mp_tac break_ok_ind + \\ fs [break_ok_def,every_prog_def] +QED + +Theorem compile_Loop: + ^(get_goal "loopLang$Loop") +Proof + fs [no_Loop_def,every_prog_def] + \\ fs [GSYM no_Loop_def] + \\ rpt strip_tac + \\ qpat_x_assum ‘evaluate _ = _’ mp_tac + \\ once_rewrite_tac [evaluate_def] + \\ reverse TOP_CASE_TAC + \\ reverse TOP_CASE_TAC + THEN1 + (strip_tac \\ rveq \\ fs [] + \\ fs [comp_with_loop_def] + \\ fs [cut_res_def,CaseEq"option",CaseEq"bool",cut_state_def] \\ rveq \\ fs [] + \\ rpt (pairarg_tac \\ fs []) + \\ rveq \\ fs [evaluate_def] + \\ ‘s.clock = t.clock’ by fs [state_rel_def] \\ fs [] + \\ ‘s.locals = t.locals’ by fs [state_rel_def] \\ fs [] + \\ drule helper_call_lemma \\ strip_tac \\ fs [find_code_def] + \\ fs [has_code_def] \\ fs [state_rel_def,state_component_equality] + \\ rw [] \\ res_tac) + \\ TOP_CASE_TAC \\ fs [syntax_ok_def] \\ rfs [] + \\ rename [‘evaluate _ = (res1,_)’] + \\ Cases_on ‘res1’ \\ fs [] + \\ Cases_on ‘x = Error’ \\ fs [] + \\ fs [cut_res_def,CaseEq"option",CaseEq"bool",cut_state_def] \\ rveq \\ fs [] + \\ qpat_x_assum ‘x = Contine ⇒ _’ assume_tac + \\ fs [PULL_FORALL,AND_IMP_INTRO] + \\ pop_assum (qpat_assum ‘comp_with_loop _ _ _ _ = _’ o mp_then Any mp_tac) + \\ strip_tac \\ fs [GSYM CONJ_ASSOC] + \\ ‘state_rel (dec_clock (s with locals := inter s.locals live_in)) + (dec_clock (t with locals := inter t.locals live_in))’ by + (fs [state_rel_def,dec_clock_def,state_component_equality] + \\ metis_tac []) + \\ first_x_assum drule + \\ simp [dec_clock_def] + \\ fs [comp_with_loop_def] + \\ rpt (pairarg_tac \\ fs []) + \\ qmatch_asmsub_abbrev_tac ‘comp_with_loop (cc,new_cont) body Fail s3’ + \\ ‘breaks_ok (cc,new_cont)’ by + (fs [breaks_ok_def,break_ok_def,Abbr‘new_cont’,Abbr‘cc’] + \\ Cases_on ‘s'’ \\ fs [store_cont_def] \\ rveq \\ fs [break_ok_def]) + \\ disch_then drule + \\ strip_tac + \\ rfs [GSYM PULL_FORALL] + \\ qpat_x_assum ‘no_Loop _ ⇒ _’ kall_tac + \\ pop_assum drule + \\ impl_tac + THEN1 (rveq \\ fs [] \\ unabbrev_all_tac \\ fs [break_ok_def] \\ fs [has_code_def]) + \\ strip_tac + \\ rveq \\ fs [] + \\ fs [Abbr‘new_cont’] + \\ strip_tac + \\ fs [has_code_def] + \\ once_rewrite_tac [evaluate_def] + \\ fs [find_code_def] + \\ ‘s.locals = t.locals ∧ s.clock = t.clock’ by fs [state_rel_def] \\ fs [] + \\ drule helper_call_lemma \\ strip_tac \\ fs [dec_clock_def] + \\ Cases_on ‘x’ \\ fs [] \\ rveq \\ fs [] + THEN1 + (Cases_on ‘domain live_out ⊆ domain r'.locals’ \\ fs [] + \\ PairCases_on ‘s'’ \\ fs [store_cont_def] \\ rpt (pairarg_tac \\ fs []) + \\ rveq \\ fs [] + \\ ‘r'.locals = t1.locals’ by fs [state_rel_def] \\ fs [] + \\ drule helper_call_lemma \\ strip_tac + \\ imp_res_tac comp_with_loop_has_code + \\ fs [has_code_def] \\ pop_assum drule + \\ strip_tac \\ fs [Abbr‘s3’,has_code_def] + \\ simp [evaluate_def,find_code_def] + \\ rename [‘state_rel s3 t3’] + \\ ‘s3.clock = t3.clock’ by fs [state_rel_def] + \\ IF_CASES_TAC \\ fs [] \\ rveq \\ fs [] + THEN1 + (fs [state_rel_def,state_component_equality] \\ rw [] \\ res_tac) + \\ qmatch_goalsub_abbrev_tac ‘evaluate (_,t4)’ + \\ qexists_tac ‘t4’ \\ fs [] \\ rw [] + THEN1 + (fs [Abbr‘t4’,dec_clock_def] + \\ qpat_x_assum ‘state_rel s3 t3’ mp_tac + \\ rpt (pop_assum kall_tac) + \\ fs [state_rel_def] \\ rw [] \\ fs [state_component_equality] + \\ rw[] \\ res_tac) + THEN1 fs [Abbr‘t4’,dec_clock_def] + \\ Cases_on ‘evaluate (cont,t4)’ \\ fs [] + \\ drule evaluate_no_Break_Continue + \\ imp_res_tac break_ok_no_Break_Continue \\ fs [] + \\ Cases_on ‘q’ \\ fs [] + \\ imp_res_tac evaluate_break_ok \\ fs [] + \\ Cases_on ‘x’ \\ fs []) + \\ first_x_assum drule + \\ impl_tac THEN1 fs [] + \\ strip_tac \\ fs [] + \\ asm_exists_tac \\ fs [] + \\ Cases_on ‘res’ \\ fs [] + THEN1 + (fs [breaks_ok_def] + \\ Cases_on ‘evaluate (cont,t1')’ \\ fs [] \\ rw [] + \\ drule evaluate_no_Break_Continue + \\ imp_res_tac break_ok_no_Break_Continue \\ fs [] + \\ imp_res_tac evaluate_break_ok \\ fs [] + \\ every_case_tac \\ fs []) + \\ Cases_on ‘x’ \\ fs [] + \\ Cases_on ‘p’ \\ fs [] + \\ rename [‘_ = evaluate (qq,_)’] + \\ fs [breaks_ok_def] + \\ Cases_on ‘evaluate (qq,t1')’ \\ fs [] \\ rw [] + \\ drule evaluate_no_Break_Continue + \\ imp_res_tac break_ok_no_Break_Continue \\ fs [] + \\ imp_res_tac evaluate_break_ok \\ fs [] + \\ every_case_tac \\ fs [] +QED + +Theorem comp_no_loop_no_Break_Continue: + ∀p prog. + every_prog (λr. r ≠ Break ∧ r ≠ Continue) (FST p) ∧ + every_prog (λr. r ≠ Break ∧ r ≠ Continue) (SND p) ⇒ + every_prog (λr. r ≠ Break ∧ r ≠ Continue) (comp_no_loop p prog) +Proof + ho_match_mp_tac comp_no_loop_ind \\ rw [] \\ fs [] + \\ fs [comp_no_loop_def,every_prog_def] + \\ every_case_tac \\ fs [] +QED + +Theorem comp_with_loop_break_ok: + ∀p prog cont s q s1. + comp_with_loop p prog cont s = (q,s1) ∧ break_ok cont ∧ breaks_ok p ⇒ break_ok q +Proof + ho_match_mp_tac comp_with_loop_ind \\ rw [] + \\ fs [comp_with_loop_def] \\ rveq \\ fs [break_ok_def] + \\ Cases_on ‘p’ \\ fs [breaks_ok_def] + \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [break_ok_def] + \\ TRY (match_mp_tac comp_no_loop_no_Break_Continue \\ fs [] + \\ imp_res_tac break_ok_no_Break_Continue \\ fs []) + \\ Cases_on ‘s’ \\ fs [store_cont_def] \\ rveq \\ fs [break_ok_def] + \\ every_case_tac \\ fs [] \\ rveq \\ fs [break_ok_def] + \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [break_ok_def] + \\ Cases_on ‘ret’ \\ fs [break_ok_def,every_prog_def] +QED + +Theorem state_rel_IMP_get_vars: + ∀s t args vs. state_rel s t ∧ get_vars args s = SOME vs ⇒ get_vars args t = SOME vs +Proof + strip_tac \\ strip_tac + \\ Induct_on ‘args’ \\ fs [get_vars_def] \\ rw [] \\ fs [] + \\ ‘t.locals = s.locals’ by fs [state_rel_def] \\ fs [] + \\ fs [CaseEq"option"] \\ rveq \\ fs [] +QED + +Triviality case_cut_res: + cut_res x y = (res,s) ⇒ + ∃part1 part2. cut_res x (part1, part2) = (res,s) ∧ y = (part1, part2) +Proof + Cases_on ‘y’ \\ fs [] +QED + +Triviality state_rel_IMP_locals: + state_rel s t ⇒ s.locals = t.locals +Proof + fs [state_rel_def] \\ rw [] \\ rveq \\ fs [] +QED + +Triviality state_rel_IMP_clock: + state_rel s t ⇒ s.clock = t.clock +Proof + fs [state_rel_def] \\ rw [] \\ rveq \\ fs [] +QED + +Theorem compile_Call: + ^(get_goal "syntax_ok (loopLang$Call _ _ _ _)") +Proof + fs [no_Loop_def,every_prog_def] + \\ fs [GSYM no_Loop_def] + \\ reverse (rpt strip_tac) + THEN1 + (fs [evaluate_def] + \\ Cases_on ‘get_vars argvars s’ \\ fs [] + \\ Cases_on ‘find_code dest x s.code’ \\ fs [] + \\ rename [‘_ = SOME tt’] \\ PairCases_on ‘tt’ \\ fs [] + \\ drule state_rel_IMP_get_vars + \\ disch_then drule \\ strip_tac \\ fs [] + \\ rename [‘_ = SOME (new_env,new_prog)’] + \\ ‘∃s body n funs. + find_code dest x t.code = SOME (new_env,body) ∧ syntax_ok new_prog ∧ + comp_with_loop (Fail,Fail) new_prog Fail s = (body,n,funs) ∧ + has_code (n,funs) t.code’ by + (Cases_on ‘dest’ \\ fs [find_code_def] + \\ qpat_x_assum ‘_ = (_,_)’ kall_tac + \\ fs [CaseEq"word_loc",CaseEq"num",CaseEq"option",CaseEq"bool",CaseEq"prod"] + \\ rveq \\ fs [] \\ fs [state_rel_def] \\ rveq \\ fs [] + \\ first_x_assum drule + \\ strip_tac \\ fs [] + \\ fs [comp_def] \\ pairarg_tac \\ fs [] + \\ qexists_tac ‘init’ \\ fs [has_code_def]) + \\ simp [comp_no_loop_def,evaluate_def] + \\ Cases_on ‘ret’ \\ fs [] + THEN1 + (Cases_on ‘handler’ \\ fs [] + \\ ‘t.clock = s.clock’ by fs [state_rel_def] \\ fs [] + \\ IF_CASES_TAC \\ fs [] \\ rveq \\ fs [] + THEN1 + (fs [state_rel_def,state_component_equality] \\ rw [] \\ res_tac) + \\ ‘state_rel (dec_clock s with locals := new_env) + (dec_clock t with locals := new_env)’ by + (qpat_x_assum ‘state_rel s t’ mp_tac \\ rpt (pop_assum kall_tac) + \\ fs [state_rel_def,state_component_equality,dec_clock_def] + \\ rw [] \\ res_tac) + \\ ‘breaks_ok (Fail:'a loopLang$prog,Fail:'a loopLang$prog) ∧ + break_ok (Fail:'a loopLang$prog)’ by EVAL_TAC + \\ fs [CaseEq"prod",CaseEq"result",CaseEq"option"] \\ rveq \\ fs [] + \\ first_x_assum drule \\ disch_then drule \\ rewrite_tac [GSYM AND_IMP_INTRO] + \\ disch_then drule \\ fs [dec_clock_def] \\ fs []) + \\ PairCases_on ‘x'’ \\ fs [] + \\ rename [‘cut_res live_in (NONE,_)’] + \\ qpat_x_assum ‘_ = (res,s1)’ mp_tac + \\ TOP_CASE_TAC \\ fs [] + \\ reverse TOP_CASE_TAC THEN1 + (strip_tac \\ rveq \\ fs [] + \\ fs [cut_res_def,CaseEq"option",CaseEq"prod",cut_state_def] \\ rveq \\ fs [] + \\ fs [CaseEq"bool"] \\ rveq \\ fs [] + \\ ‘s.clock = t.clock ∧ t.locals = s.locals’ by fs [state_rel_def] + \\ qexists_tac ‘t with locals := LN’ \\ fs [] + \\ fs [state_rel_def,state_component_equality] + \\ rw [] \\ res_tac \\ fs []) + \\ fs [] + \\ rename [‘cut_res live_in (NONE,s) = (NONE,r)’] + \\ qpat_abbrev_tac ‘ttt = _ live_in (NONE,_)’ + \\ ‘∃tr. ttt = (NONE,tr) ∧ state_rel r tr ∧ tr.code = t.code’ by + (fs [cut_res_def,cut_state_def,CaseEq"option",CaseEq"bool",CaseEq"prod",Abbr‘ttt’] + \\ rveq \\ fs [state_rel_def,dec_clock_def] + \\ fs [state_component_equality] + \\ rpt strip_tac \\ first_x_assum drule \\ simp_tac std_ss [] \\ metis_tac []) + \\ fs [Abbr‘ttt’] + \\ TOP_CASE_TAC \\ fs [] + \\ strip_tac + \\ last_x_assum (qspecl_then [‘tr with locals := new_env’,‘(Fail,Fail)’] mp_tac) + \\ impl_tac THEN1 + (fs [breaks_ok_def,break_ok_def] + \\ reverse conj_tac + THEN1 (CCONTR_TAC \\ fs []) + \\ fs [state_rel_def] + \\ fs [state_component_equality] + \\ rpt strip_tac \\ first_x_assum drule \\ simp_tac std_ss [] \\ metis_tac []) + \\ rewrite_tac [GSYM AND_IMP_INTRO] + \\ disch_then drule + \\ impl_tac THEN1 fs [break_ok_def] + \\ strip_tac \\ disch_then kall_tac + \\ Cases_on ‘q’ \\ fs [] + \\ Cases_on ‘x' = TimeOut’ \\ fs [] THEN1 (rveq \\ fs []) + \\ Cases_on ‘∃ff. x' = FinalFFI ff’ \\ fs [] THEN1 (rveq \\ fs [] \\ rveq \\ fs []) + \\ Cases_on ‘handler’ \\ fs [] THEN1 + (Cases_on ‘∃retv. x' = Result retv’ \\ fs [] THEN1 + (rveq \\ fs [] \\ rveq \\ fs [] \\ fs [set_var_def] \\ fs [state_rel_def] + \\ fs [state_component_equality] + \\ rpt strip_tac \\ first_x_assum drule \\ simp_tac std_ss [] \\ metis_tac []) + \\ Cases_on ‘∃exn. x' = Exception exn’ \\ fs [] THEN1 + (rveq \\ fs [] \\ rveq \\ fs [] \\ fs [set_var_def] \\ fs [state_rel_def] + \\ fs [state_component_equality] + \\ rpt strip_tac \\ first_x_assum drule \\ simp_tac std_ss [] \\ metis_tac []) + \\ Cases_on ‘x'’ \\ fs []) + \\ qabbrev_tac ‘h = x''’ \\ pop_assum kall_tac \\ PairCases_on ‘h’ \\ fs [] + \\ Cases_on ‘∃vret. x' = Result vret’ \\ fs [] + THEN1 + (rveq \\ fs [] \\ drule case_cut_res \\ strip_tac \\ fs [] + \\ rename [‘state_rel r2 t1’] + \\ qpat_x_assum ‘∀x. _’ mp_tac + \\ disch_then (qspecl_then [‘set_var x'0 vret (t1 with locals := r.locals)’,‘p’] mp_tac) + \\ impl_tac THEN1 + (fs [] \\ reverse conj_tac + THEN1 (CCONTR_TAC \\ fs [cut_res_def]) + \\ fs [set_var_def,state_rel_def] \\ fs [state_component_equality] + \\ rw [] \\ fs [] \\ res_tac \\ rfs[] \\ asm_exists_tac \\ fs []) + \\ asm_rewrite_tac [GSYM AND_IMP_INTRO] + \\ disch_then kall_tac \\ strip_tac + \\ fs [cut_res_def] + \\ reverse (Cases_on ‘part1’) \\ fs [] + THEN1 + (Cases_on ‘x'’ \\ rveq \\ fs [] + \\ imp_res_tac state_rel_IMP_locals \\ fs [cut_res_def,set_var_def] + \\ asm_exists_tac \\ fs [] + \\ Cases_on ‘p’ \\ fs [breaks_ok_def] + \\ rename [‘cut_res _ (evaluate (r5,t5))’] + \\ Cases_on ‘evaluate (r5,t5)’ + \\ imp_res_tac evaluate_break_ok \\ fs [] + \\ Cases_on ‘q’ \\ fs [cut_res_def]) + \\ fs [CaseEq"option"] \\ rveq \\ fs [] + \\ fs [cut_state_def,CaseEq"bool"] \\ rveq \\ fs [] + \\ imp_res_tac state_rel_IMP_locals + \\ imp_res_tac state_rel_IMP_clock \\ fs [] + \\ fs [cut_res_def,cut_state_def] + \\ fs [set_var_def,dec_clock_def] + \\ fs [state_rel_def,state_component_equality] \\ rw [] \\ res_tac \\ fs [] + \\ rfs [] \\ asm_exists_tac \\ fs []) + \\ Cases_on ‘∃vexn. x' = Exception vexn’ \\ fs [] + THEN1 + (rveq \\ fs [] \\ drule case_cut_res \\ strip_tac \\ fs [] + \\ rename [‘evaluate _ = (SOME (Exception vexn),r2)’] + \\ rename [‘set_var vname vexn (r3 with locals := r.locals)’] + \\ qpat_x_assum ‘∀x. _’ mp_tac + \\ rename [‘set_var vname vexn (r2 with locals := r.locals)’] + \\ disch_then (qspecl_then + [‘set_var vname vexn (r3 with locals := r.locals)’,‘p’] mp_tac) + \\ impl_tac THEN1 + (fs [] \\ reverse conj_tac + THEN1 (CCONTR_TAC \\ fs [cut_res_def]) + \\ fs [set_var_def,state_rel_def] \\ fs [state_component_equality] + \\ rw [] \\ fs [] \\ res_tac \\ rfs[] \\ asm_exists_tac \\ fs []) + \\ asm_rewrite_tac [GSYM AND_IMP_INTRO] + \\ disch_then kall_tac \\ strip_tac + \\ fs [cut_res_def] + \\ reverse (Cases_on ‘part1’) \\ fs [] + THEN1 + (Cases_on ‘x'’ \\ rveq \\ fs [] + \\ imp_res_tac state_rel_IMP_locals \\ fs [cut_res_def,set_var_def] + \\ asm_exists_tac \\ fs [] + \\ Cases_on ‘p’ \\ fs [breaks_ok_def] + \\ rename [‘cut_res _ (evaluate (r5,_))’] + \\ Cases_on ‘evaluate (r5,t1)’ + \\ imp_res_tac evaluate_break_ok \\ fs [] + \\ Cases_on ‘q’ \\ fs [cut_res_def]) + \\ fs [CaseEq"option"] \\ rveq \\ fs [] + \\ fs [cut_state_def,CaseEq"bool"] \\ rveq \\ fs [] + \\ imp_res_tac state_rel_IMP_locals + \\ imp_res_tac state_rel_IMP_clock \\ fs [] + \\ fs [cut_res_def,cut_state_def] + \\ fs [set_var_def,dec_clock_def] + \\ fs [state_rel_def,state_component_equality] \\ rw [] \\ res_tac \\ fs [] + \\ rfs [] \\ asm_exists_tac \\ fs []) + \\ Cases_on ‘x'’ \\ fs []) + \\ fs [syntax_ok_def] + \\ Cases_on ‘handler’ \\ fs [] + \\ PairCases_on ‘x’ \\ fs [] + \\ Cases_on ‘ret’ + THEN1 fs [evaluate_def,CaseEq"option",CaseEq"prod"] + \\ PairCases_on ‘x’ \\ fs [] + \\ fs [evaluate_def] + \\ Cases_on ‘get_vars argvars s’ \\ fs [] + \\ Cases_on ‘find_code dest x s.code’ \\ fs [] + \\ rename [‘_ = SOME tt’] \\ PairCases_on ‘tt’ \\ fs [] + \\ fs [comp_with_loop_def] + \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] + \\ fs [CaseEq"prod"] + \\ rename [‘cut_res x11 (NONE,s) = (vv,s9)’] + \\ rename [‘_ = SOME (new_env,new_prog)’] + \\ ‘∃s body n funs. + find_code dest x t.code = SOME (new_env,body) ∧ syntax_ok new_prog ∧ + comp_with_loop (Fail,Fail) new_prog Fail s = (body,n,funs) ∧ + has_code (n,funs) t.code’ by + (Cases_on ‘dest’ \\ fs [find_code_def] + \\ qpat_x_assum ‘_ = (_,_)’ kall_tac + \\ fs [CaseEq"word_loc",CaseEq"num",CaseEq"option",CaseEq"bool",CaseEq"prod"] + \\ rveq \\ fs [] \\ fs [state_rel_def] \\ rveq \\ fs [] + \\ first_x_assum drule + \\ strip_tac \\ fs [] + \\ fs [comp_def] \\ pairarg_tac \\ fs [] + \\ qexists_tac ‘init’ \\ fs [has_code_def]) + \\ reverse (Cases_on ‘vv’) \\ fs [] THEN1 + (imp_res_tac state_rel_IMP_clock \\ fs [] + \\ imp_res_tac state_rel_IMP_locals \\ fs [] + \\ rveq \\ fs [] \\ fs [cut_res_def,cut_state_def,CaseEq"option",CaseEq"bool"] + \\ rveq \\ fs [] + \\ fs [evaluate_def,cut_res_def,cut_state_def] + \\ drule state_rel_IMP_get_vars + \\ disch_then drule \\ strip_tac \\ fs [] + \\ fs [state_rel_def,state_component_equality] + \\ metis_tac []) + \\ fs [cut_res_def,CaseEq"option",CaseEq"prod",cut_state_def] + \\ rveq \\ fs [] + \\ imp_res_tac state_rel_IMP_clock \\ fs [] + \\ imp_res_tac state_rel_IMP_locals \\ fs [] + \\ fs [CaseEq"bool",dec_clock_def] \\ rveq \\ fs [] + \\ Cases_on ‘v11 = Error’ \\ fs [] + \\ first_x_assum (qspecl_then + [‘t with <|locals := new_env; clock := t.clock - 1|>’,‘Fail,Fail’] mp_tac) + \\ impl_tac THEN1 + (qpat_x_assum ‘state_rel s t’ mp_tac + \\ rpt (pop_assum kall_tac) + \\ fs [breaks_ok_def,break_ok_def,state_rel_def] + \\ strip_tac \\ fs [] + \\ qexists_tac ‘c’ \\ fs [] + \\ rw [] \\ res_tac) + \\ strip_tac \\ fs [] + \\ pop_assum kall_tac + \\ pop_assum drule + \\ impl_tac THEN1 fs [break_ok_def] + \\ strip_tac + \\ qpat_x_assum ‘state_rel s t’ assume_tac + \\ drule state_rel_IMP_get_vars + \\ disch_then drule \\ strip_tac \\ fs [] + \\ fs [evaluate_def] + \\ simp [cut_res_def,cut_state_def,dec_clock_def] + \\ Cases_on ‘v11’ \\ fs [] \\ rveq \\ fs [] + THEN1 + (Cases_on ‘evaluate (x2,set_var x0' w (st with locals := inter t.locals x11))’ \\ fs [] + \\ rename [‘set_var vvv’] + \\ Cases_on ‘q = SOME Error’ THEN1 fs [cut_res_def] \\ fs [] + \\ first_x_assum (qspecl_then [ + ‘(set_var vvv w (t1 with locals := inter t.locals x11))’,‘p’] mp_tac) + \\ impl_tac THEN1 + (fs [set_var_def] \\ qpat_x_assum ‘state_rel st t1’ mp_tac + \\ rpt (pop_assum kall_tac) \\ fs [state_rel_def] \\ rw [] \\ fs [] + \\ fs [state_component_equality] \\ rw[] \\ res_tac) + \\ strip_tac \\ fs [] \\ pop_assum kall_tac + \\ pop_assum drule \\ impl_tac THEN1 + (fs [breaks_ok_def,set_var_def] + \\ PairCases_on ‘s'’ \\ fs [store_cont_def] \\ rveq \\ fs [break_ok_def]) + \\ strip_tac + \\ reverse (Cases_on ‘q’) \\ fs [] + THEN1 + (fs [cut_res_def] \\ rveq \\ fs [] \\ asm_exists_tac \\ fs [] + \\ conj_tac THEN1 fs [set_var_def] + \\ Cases_on ‘x'’ \\ fs [] \\ rveq \\ fs [cut_res_def] + \\ Cases_on ‘p’ \\ fs [] + \\ rename [‘_ = evaluate (qq,_)’] + \\ fs [breaks_ok_def] + \\ Cases_on ‘evaluate (qq,t1')’ \\ fs [] \\ rw [] + \\ imp_res_tac evaluate_break_ok \\ fs [] + \\ Cases_on ‘q’ \\ fs [cut_res_def]) + \\ fs [cut_res_def,cut_state_def,CaseEq"bool",CaseEq"option"] + \\ rveq \\ fs [] + THEN1 + (qexists_tac ‘t1' with locals := LN’ \\ fs [] + \\ simp [set_var_def] + \\ conj_tac THEN1 + (qpat_x_assum ‘state_rel _ _’ mp_tac + \\ rpt (pop_assum kall_tac) \\ fs [state_rel_def] + \\ rw [] \\ fs [] \\ fs [state_component_equality] + \\ rw [] \\ res_tac \\ fs []) + \\ PairCases_on ‘s'’ \\ fs [store_cont_def] \\ rveq \\ fs [] + \\ imp_res_tac comp_with_loop_has_code + \\ fs [set_var_def,has_code_def,evaluate_def] + \\ drule helper_call_lemma + \\ drule state_rel_IMP_get_vars \\ rpt strip_tac + \\ first_x_assum drule \\ strip_tac \\ fs [] + \\ imp_res_tac state_rel_IMP_clock + \\ fs [dec_clock_def,find_code_def,cut_res_def]) + \\ rveq \\ fs [] \\ fs [dec_clock_def] + \\ qexists_tac ‘(t1' with <|locals := inter r.locals x3; clock := r.clock - 1|>)’ + \\ fs [] \\ simp [set_var_def] + \\ conj_tac THEN1 + (qpat_x_assum ‘state_rel _ _’ mp_tac \\ rpt (pop_assum kall_tac) + \\ fs [state_rel_def] \\ rw [] \\ fs [state_component_equality] + \\ rw [] \\ res_tac \\ fs []) + \\ PairCases_on ‘s'’ \\ fs [store_cont_def] \\ rveq \\ fs [] + \\ imp_res_tac comp_with_loop_has_code + \\ fs [set_var_def,has_code_def] + \\ simp [evaluate_def,find_code_def] + \\ drule helper_call_lemma + \\ drule state_rel_IMP_get_vars \\ rpt strip_tac + \\ first_x_assum drule \\ strip_tac \\ fs [] + \\ imp_res_tac state_rel_IMP_clock \\ fs [dec_clock_def] + \\ qmatch_goalsub_abbrev_tac ‘_ = xx’ \\ PairCases_on ‘xx’ + \\ fs [] \\ pop_assum (assume_tac o REWRITE_RULE [markerTheory.Abbrev_def] o GSYM) + \\ pop_assum (assume_tac o GSYM) + \\ drule evaluate_break_ok \\ fs [] + \\ Cases_on ‘xx0’ \\ fs [] + \\ imp_res_tac break_ok_no_Break_Continue + \\ imp_res_tac evaluate_no_Break_Continue \\ fs [] + \\ TOP_CASE_TAC \\ fs [cut_res_def]) + THEN1 + (Cases_on ‘evaluate (x1,set_var x0 w (st with locals := inter t.locals x11))’ \\ fs [] + \\ rename [‘set_var vvv’] + \\ Cases_on ‘q = SOME Error’ THEN1 fs [cut_res_def] \\ fs [] + \\ first_x_assum (qspecl_then [ + ‘(set_var vvv w (t1 with locals := inter t.locals x11))’,‘p’] mp_tac) + \\ impl_tac THEN1 + (fs [set_var_def] \\ qpat_x_assum ‘state_rel st t1’ mp_tac + \\ rpt (pop_assum kall_tac) \\ fs [state_rel_def] \\ rw [] \\ fs [] + \\ fs [state_component_equality] \\ rw[] \\ res_tac) + \\ strip_tac \\ fs [] \\ pop_assum kall_tac + \\ pop_assum drule \\ impl_tac THEN1 + (fs [breaks_ok_def,set_var_def] + \\ PairCases_on ‘s'’ \\ fs [store_cont_def] \\ rveq \\ fs [break_ok_def] + \\ imp_res_tac comp_with_loop_has_code) + \\ strip_tac + \\ reverse (Cases_on ‘q’) \\ fs [] + THEN1 + (fs [cut_res_def] \\ rveq \\ fs [] \\ asm_exists_tac \\ fs [] + \\ conj_tac THEN1 fs [set_var_def] + \\ Cases_on ‘x'’ \\ fs [] \\ rveq \\ fs [cut_res_def] + \\ Cases_on ‘p’ \\ fs [] + \\ rename [‘_ = evaluate (qq,_)’] + \\ fs [breaks_ok_def] + \\ Cases_on ‘evaluate (qq,t1')’ \\ fs [] \\ rw [] + \\ imp_res_tac evaluate_break_ok \\ fs [] + \\ Cases_on ‘q’ \\ fs [cut_res_def]) + \\ fs [cut_res_def,cut_state_def,CaseEq"bool",CaseEq"option"] + \\ rveq \\ fs [] + THEN1 + (qexists_tac ‘t1' with locals := LN’ \\ fs [] + \\ simp [set_var_def] + \\ conj_tac THEN1 + (qpat_x_assum ‘state_rel _ _’ mp_tac + \\ rpt (pop_assum kall_tac) \\ fs [state_rel_def] + \\ rw [] \\ fs [] \\ fs [state_component_equality] + \\ rw [] \\ res_tac \\ fs []) + \\ PairCases_on ‘s'’ \\ fs [store_cont_def] \\ rveq \\ fs [] + \\ imp_res_tac comp_with_loop_has_code + \\ fs [set_var_def,has_code_def,evaluate_def] + \\ drule helper_call_lemma + \\ drule state_rel_IMP_get_vars \\ rpt strip_tac + \\ first_x_assum drule \\ strip_tac \\ fs [] + \\ imp_res_tac state_rel_IMP_clock + \\ fs [dec_clock_def,find_code_def,cut_res_def]) + \\ rveq \\ fs [] \\ fs [dec_clock_def] + \\ qexists_tac ‘(t1' with <|locals := inter r.locals x3; clock := r.clock - 1|>)’ + \\ fs [] \\ simp [set_var_def] + \\ conj_tac THEN1 + (qpat_x_assum ‘state_rel _ _’ mp_tac \\ rpt (pop_assum kall_tac) + \\ fs [state_rel_def] \\ rw [] \\ fs [state_component_equality] + \\ rw [] \\ res_tac \\ fs []) + \\ PairCases_on ‘s'’ \\ fs [store_cont_def] \\ rveq \\ fs [] + \\ imp_res_tac comp_with_loop_has_code + \\ fs [set_var_def,has_code_def] + \\ simp [evaluate_def,find_code_def] + \\ drule helper_call_lemma + \\ drule state_rel_IMP_get_vars \\ rpt strip_tac + \\ first_x_assum drule \\ strip_tac \\ fs [] + \\ imp_res_tac state_rel_IMP_clock \\ fs [dec_clock_def] + \\ qmatch_goalsub_abbrev_tac ‘_ = xx’ \\ PairCases_on ‘xx’ + \\ fs [] \\ pop_assum (assume_tac o REWRITE_RULE [markerTheory.Abbrev_def] o GSYM) + \\ pop_assum (assume_tac o GSYM) + \\ drule evaluate_break_ok \\ fs [] + \\ Cases_on ‘xx0’ \\ fs [] + \\ imp_res_tac break_ok_no_Break_Continue + \\ imp_res_tac evaluate_no_Break_Continue \\ fs [] + \\ TOP_CASE_TAC \\ fs [cut_res_def]) +QED + +Theorem compile_If: + ^(get_goal "loopLang$If") +Proof + fs [no_Loop_def,every_prog_def] + \\ fs [GSYM no_Loop_def] + \\ reverse (rpt strip_tac) + \\ qpat_x_assum ‘evaluate _ = _’ mp_tac + \\ once_rewrite_tac [evaluate_def] + THEN1 + (fs [CaseEq"option",CaseEq"word_loc"] \\ rw [] + \\ ‘t.locals = s.locals’ by fs [state_rel_def] + \\ ‘get_var_imm ri t = SOME (Word y)’ by + (Cases_on ‘ri’ \\ fs [get_var_imm_def]) + \\ simp [comp_no_loop_def,evaluate_def] + \\ Cases_on ‘evaluate (if word_cmp cmp x y then c1 else c2,s)’ \\ fs [] + \\ Cases_on ‘q = SOME Error’ THEN1 fs [cut_res_def] \\ fs [] + \\ first_x_assum drule \\ disch_then drule + \\ strip_tac \\ pop_assum mp_tac \\ pop_assum kall_tac + \\ impl_tac THEN1 (fs [no_Loop_def,every_prog_def] \\ rw []) + \\ strip_tac \\ fs [] \\ IF_CASES_TAC \\ fs [] + \\ Cases_on ‘evaluate (comp_no_loop p c1,t)’ \\ fs [cut_res_def] + \\ Cases_on ‘evaluate (comp_no_loop p c2,t)’ \\ fs [cut_res_def] + \\ reverse (Cases_on ‘q’) \\ fs [] \\ rveq + THEN1 + (rename [‘_ = (SOME xx,_)’] \\ Cases_on ‘xx’ \\ fs [] + \\ asm_exists_tac \\ fs [cut_res_def] + \\ TRY (rename [‘(x1,x2) = evaluate _’]) + \\ TRY (qpat_x_assum ‘(x1,x2) = evaluate _’ (assume_tac o GSYM)) \\ fs [] + \\ Cases_on ‘p’ \\ fs [breaks_ok_def] + \\ imp_res_tac evaluate_break_ok \\ fs []) + THEN1 + (rename [‘state_rel s5 t5’] + \\ fs [cut_state_def,CaseEq"bool",CaseEq"option"] \\ rveq \\ fs [] + \\ fs [dec_clock_def] \\ fs [state_rel_def,state_component_equality] + \\ rw [] \\ res_tac) + THEN1 + (rename [‘_ = (SOME xx,_)’] \\ Cases_on ‘xx’ \\ fs [] + \\ asm_exists_tac \\ fs [cut_res_def] + \\ TRY (rename [‘(x1,x2) = evaluate _’]) + \\ TRY (qpat_x_assum ‘(x1,x2) = evaluate _’ (assume_tac o GSYM)) \\ fs [] + \\ Cases_on ‘p’ \\ fs [breaks_ok_def] + \\ imp_res_tac evaluate_break_ok \\ fs []) + THEN1 + (rename [‘state_rel s5 t5’] + \\ fs [cut_state_def,CaseEq"bool",CaseEq"option"] \\ rveq \\ fs [] + \\ fs [dec_clock_def] \\ fs [state_rel_def,state_component_equality] + \\ rw [] \\ res_tac)) + \\ ‘syntax_ok c1 ∧ syntax_ok c2’ by fs [syntax_ok_def] + \\ fs [CaseEq"option",CaseEq"word_loc"] \\ rw [] + \\ ‘t.locals = s.locals’ by fs [state_rel_def] + \\ ‘get_var_imm ri t = SOME (Word y)’ by + (Cases_on ‘ri’ \\ fs [get_var_imm_def]) + \\ fs [comp_with_loop_def] \\ rpt (pairarg_tac \\ fs []) \\ rveq \\ fs [] + \\ imp_res_tac comp_with_loop_has_code + \\ Cases_on ‘word_cmp cmp x y’ \\ fs [] + \\ rename [‘cut_res live_out (evaluate (cc,s)) = (res,s1)’] + THEN + (Cases_on ‘evaluate (cc,s)’ \\ fs [] + \\ first_x_assum drule + \\ Cases_on ‘q = SOME Error’ THEN1 fs [cut_res_def] \\ fs [] + \\ disch_then drule \\ simp [GSYM AND_IMP_INTRO] + \\ disch_then drule \\ fs [] + \\ impl_tac + THEN1 (Cases_on ‘s'’ \\ fs [store_cont_def] \\ rveq \\ fs [break_ok_def]) + \\ strip_tac \\ disch_then kall_tac + \\ fs [evaluate_def] + \\ rename [‘evaluate (qq,t) = evaluate _’] + \\ Cases_on ‘evaluate (qq,t)’ \\ fs [] + \\ fs [cut_res_def] \\ reverse (Cases_on ‘q’) \\ fs [] \\ rveq \\ fs [] + THEN1 + (Cases_on ‘x'’ \\ fs [] \\ asm_exists_tac \\ fs [] + \\ TRY (rename [‘(x1,x2) = evaluate _’]) + \\ TRY (qpat_x_assum ‘(x1,x2) = evaluate _’ (assume_tac o GSYM)) \\ fs [] + \\ Cases_on ‘p’ \\ fs [breaks_ok_def] + \\ imp_res_tac evaluate_break_ok \\ fs []) + \\ TRY (rename [‘(x1,x2) = evaluate _’]) + \\ TRY (qpat_x_assum ‘(x1,x2) = evaluate _’ (assume_tac o GSYM)) \\ fs [] + \\ ‘break_ok cont'’ by + (Cases_on ‘s'’ \\ fs [store_cont_def] \\ rveq \\ fs [break_ok_def]) + \\ imp_res_tac evaluate_break_ok \\ fs [] + \\ fs [CaseEq"option",CaseEq"bool",cut_state_def] \\ rveq \\ fs [] + \\ rename [‘state_rel s1 t1’] + \\ Cases_on ‘s'’ \\ fs [store_cont_def] \\ rveq \\ fs [evaluate_def] + \\ ‘s1.locals = t1.locals ∧ s1.clock = t1.clock’ by fs [state_rel_def] \\ fs [] + \\ drule helper_call_lemma \\ strip_tac \\ fs [find_code_def] + \\ rfs [has_code_def] \\ rveq \\ fs [dec_clock_def] + THEN1 (fs [state_rel_def,state_component_equality] \\ rw [] \\ res_tac) + \\ qmatch_asmsub_abbrev_tac ‘evaluate (_,t2)’ + \\ qexists_tac ‘t2’ \\ Cases_on ‘evaluate (cont,t2)’ + \\ Cases_on ‘q' = NONE’ \\ rveq \\ rfs [] + \\ Cases_on ‘q'’ \\ fs [] \\ fs [Abbr‘t2’] + \\ drule evaluate_no_Break_Continue + \\ imp_res_tac break_ok_no_Break_Continue \\ fs [] + \\ qpat_x_assum ‘state_rel s1 t1’ mp_tac + \\ Cases_on ‘x'’ \\ fs [] + \\ rpt (pop_assum kall_tac) \\ fs [state_rel_def] + \\ rpt strip_tac \\ fs [state_component_equality] \\ rw [] \\ res_tac) +QED + +Theorem compile_Seq: + ^(get_goal "syntax_ok (loopLang$Seq _ _)") +Proof + reverse (rpt strip_tac) + THEN1 + (fs [comp_no_loop_def,no_Loop_def,every_prog_def] + \\ fs [GSYM no_Loop_def] + \\ qpat_x_assum ‘evaluate _ = _’ mp_tac + \\ simp [Once evaluate_def] + \\ pairarg_tac \\ fs [] + \\ reverse IF_CASES_TAC + THEN1 + (strip_tac \\ fs [] \\ rveq \\ fs [] + \\ first_x_assum drule + \\ disch_then drule + \\ strip_tac \\ asm_exists_tac \\ fs [] + \\ Cases_on ‘res’ \\ fs [] + \\ Cases_on ‘x’ \\ fs [evaluate_def] + \\ Cases_on ‘p’ \\ fs [] + \\ rename [‘_ = evaluate (qq,_)’] + \\ fs [breaks_ok_def] + \\ Cases_on ‘evaluate (qq,t1)’ \\ fs [] \\ rw [] + \\ imp_res_tac evaluate_break_ok \\ fs []) + \\ rveq \\ fs [] \\ strip_tac \\ fs [] + \\ first_x_assum drule + \\ disch_then drule \\ strip_tac + \\ first_x_assum drule + \\ disch_then drule \\ strip_tac + \\ asm_exists_tac \\ fs [] + \\ Cases_on ‘res’ \\ fs [evaluate_def]) + \\ fs [syntax_ok_def] + \\ qpat_x_assum ‘evaluate _ = _’ mp_tac + \\ simp [Once evaluate_def] + \\ pairarg_tac \\ fs [] + \\ reverse IF_CASES_TAC + THEN1 + (strip_tac \\ fs [] \\ rveq \\ fs [] + \\ first_x_assum drule + \\ disch_then drule + \\ strip_tac \\ pop_assum kall_tac + \\ fs [comp_with_loop_def] + \\ pairarg_tac \\ fs [] + \\ first_x_assum drule \\ fs [] + \\ impl_tac THEN1 imp_res_tac comp_with_loop_break_ok + \\ strip_tac \\ fs [] + \\ asm_exists_tac \\ fs [] + \\ Cases_on ‘res’ \\ fs []) + \\ rveq \\ fs [] \\ strip_tac \\ fs [] + \\ fs [comp_with_loop_def] + \\ pairarg_tac \\ fs [] + \\ first_x_assum drule + \\ disch_then drule + \\ strip_tac \\ pop_assum kall_tac + \\ first_x_assum drule \\ simp [] + \\ impl_tac THEN1 imp_res_tac comp_with_loop_break_ok + \\ strip_tac \\ fs [] + \\ first_x_assum drule + \\ disch_then drule + \\ strip_tac \\ pop_assum kall_tac + \\ first_x_assum drule + \\ imp_res_tac comp_with_loop_has_code \\ fs [] +QED + +Theorem eval_lemma: + ∀s exp w t. + eval s exp = SOME w ∧ state_rel s t ⇒ eval t exp = SOME w +Proof + ho_match_mp_tac eval_ind \\ rw [] \\ fs [eval_def] + \\ fs [state_rel_def] \\ rveq \\ fs [] + \\ fs [CaseEq"option",CaseEq"word_loc",PULL_EXISTS] + \\ rveq \\ fs [mem_load_def] + \\ goal_assum (first_assum o mp_then Any mp_tac) + \\ qpat_x_assum ‘_ = SOME z’ kall_tac + \\ rpt (pop_assum mp_tac) + \\ qid_spec_tac ‘wexps’ + \\ qid_spec_tac ‘ws’ + \\ Induct_on ‘wexps’ \\ fs [] + \\ fs [wordSemTheory.the_words_def,CaseEq"option",CaseEq"word_loc"] \\ rw [] +QED + +Theorem compile_Assign: + ^(get_goal "loopLang$Assign") ∧ + ^(get_goal "loopLang$LocValue") +Proof + fs [syntax_ok_def,no_Loop_def,every_prog_def] + \\ fs [evaluate_def,CaseEq"option",CaseEq"word_loc",PULL_EXISTS] + \\ rw [] \\ fs [comp_no_loop_def] + \\ fs [evaluate_def,CaseEq"option",CaseEq"word_loc",PULL_EXISTS] + \\ fs [set_var_def] + \\ imp_res_tac eval_lemma \\ fs [] + \\ fs [state_rel_def] + \\ fs [state_component_equality] + \\ rw [] \\ res_tac \\ fs [] + \\ fs [domain_lookup] \\ res_tac + \\ PairCases_on ‘v’ \\ res_tac \\ fs [] + \\ fs [comp_def,has_code_def] + \\ rpt (pairarg_tac \\ fs []) + \\ fs [has_code_def] +QED + +Theorem compile_Store: + ^(get_goal "loopLang$Store") ∧ + ^(get_goal "loopLang$StoreByte") ∧ + ^(get_goal "loopLang$LoadByte") +Proof + fs [syntax_ok_def,no_Loop_def,every_prog_def] + \\ fs [evaluate_def,CaseEq"option",CaseEq"word_loc",PULL_EXISTS] + \\ rw [] \\ fs [comp_no_loop_def] + \\ fs [evaluate_def,CaseEq"option",CaseEq"word_loc",PULL_EXISTS] + \\ imp_res_tac eval_lemma \\ fs [] + \\ fs [state_rel_def] + \\ fs [state_component_equality] + \\ fs [mem_store_def] + \\ rveq \\ fs [] + \\ rw [] \\ res_tac + \\ fs [set_var_def] + \\ res_tac \\ fs [] +QED + +Theorem compile_SetGlobal: + ^(get_goal "loopLang$SetGlobal") +Proof + fs [syntax_ok_def,no_Loop_def,every_prog_def] + \\ fs [evaluate_def,CaseEq"option",CaseEq"word_loc",PULL_EXISTS] + \\ rw [] \\ fs [comp_no_loop_def] + \\ fs [evaluate_def,CaseEq"option",CaseEq"word_loc",PULL_EXISTS] + \\ fs [set_globals_def] + \\ imp_res_tac eval_lemma \\ fs [] + \\ fs [state_rel_def] + \\ fs [state_component_equality] + \\ rw [] \\ res_tac \\ fs [] +QED + +Theorem compile_FFI: + ^(get_goal "loopLang$FFI") +Proof + fs [syntax_ok_def,no_Loop_def,every_prog_def] + \\ fs [evaluate_def,CaseEq"option",CaseEq"word_loc",PULL_EXISTS] + \\ rw [] \\ fs [comp_no_loop_def] + \\ fs [evaluate_def,CaseEq"option",CaseEq"word_loc",PULL_EXISTS] + \\ fs [state_rel_def] \\ rveq \\ fs [] \\ fs [PULL_EXISTS] + \\ fs [cut_state_def] \\ rveq \\ fs [] \\ fs [PULL_EXISTS] + \\ fs [evaluate_def,CaseEq"option",CaseEq"word_loc",PULL_EXISTS] + \\ fs [CaseEq"ffi_result"] \\ rveq \\ fs [] + \\ fs [call_env_def] +QED + +Theorem compile_correct: + ^(compile_correct_tm()) +Proof + match_mp_tac (the_ind_thm()) + \\ EVERY (map strip_assume_tac [compile_Skip, compile_Continue, + compile_Mark, compile_Return, compile_Assign, compile_Store, + compile_SetGlobal, compile_Call, compile_Seq, compile_If, + compile_FFI, compile_Loop]) + \\ asm_rewrite_tac [] \\ rw [] \\ rpt (pop_assum kall_tac) +QED + +Theorem comp_no_loop_no_loop: + !p prog. + no_Loops (FST p) ∧ no_Loops (SND p) ⇒ + no_Loops (comp_no_loop p prog) +Proof + ho_match_mp_tac comp_no_loop_ind >> + rw [] >> + fs [comp_no_loop_def, no_Loops_def, no_Loop_def, every_prog_def] >> + every_case_tac >> fs [] +QED + +Theorem store_cont_no_loop: + !l cont s cont' s'. + store_cont l cont s = (cont',s') ∧ + no_Loops cont ∧ + EVERY (λ(name,params,body). no_Loops body) (SND s) ⇒ + no_Loops cont' ∧ EVERY (λ(name,params,body). no_Loops body) (SND s') +Proof + rw [] >> + cases_on ‘s’ >> + fs [store_cont_def, no_Loops_def, no_Loop_def] >> rveq >> + fs [every_prog_def] +QED + +Theorem comp_with_loop_no_loop: + !p q cont s body n fs. + comp_with_loop p q cont s = (body,n,fs) ∧ + no_Loops (FST p) ∧ no_Loops (SND p) ∧ no_Loops cont ∧ + EVERY (λ(name,params,body). no_Loops body) (SND s) ==> + no_Loops body ∧ EVERY (λ(name,params,body). no_Loops body) fs +Proof + ho_match_mp_tac comp_with_loop_ind >> + rpt conj_tac >> rpt gen_tac >> + strip_tac >> rpt gen_tac >> + TRY ( + rename [‘Mark’] >> + fs [comp_with_loop_def] >> rveq >> + imp_res_tac comp_no_loop_no_loop >> + fs [no_Loops_def, no_Loop_def, every_prog_def]) >> + TRY ( + rename [‘Seq’] >> + strip_tac >> + fs [comp_with_loop_def, no_Loops_def, no_Loop_def] >> fs [] >> + rpt (pairarg_tac >> fs []) >> rveq >> fs [] >> + Cases_on ‘s'’ >> + gs [every_prog_def]) >> + TRY ( + rename [‘If’] >> + strip_tac >> + fs [comp_with_loop_def] >> fs [] >> + rpt (pairarg_tac >> fs []) >> rveq >> fs [] >> + imp_res_tac store_cont_no_loop >> + fs [] >> + Cases_on ‘s''’ >> + gs [no_Loops_def, no_Loop_def, every_prog_def]) >> + TRY ( + rename [‘Loop’] >> + fs [Once comp_with_loop_def] >> + rpt (pairarg_tac >> fs []) >> rveq >> fs [] >> + strip_tac >> rveq >> + drule store_cont_no_loop >> + strip_tac >> + rpt (pairarg_tac >> fs []) >> rveq >> fs [] >> + fs [no_Loops_def, no_Loop_def, every_prog_def]) >> + TRY ( + rename [‘Call’] >> + rewrite_tac [comp_with_loop_def] >> + TOP_CASE_TAC + >- ( + strip_tac >> rveq >> fs [] >> + fs [no_Loops_def, no_Loop_def, every_prog_def]) >> + rpt TOP_CASE_TAC >> + rewrite_tac [LET_THM] >> + pairarg_tac >> + drule store_cont_no_loop >> + strip_tac >> + last_x_assum mp_tac >> + disch_then (qspecl_then [‘(q,q',q'',r)’, ‘q’, ‘SND (q,q',q'',r)’, + ‘q'’, ‘SND (q',q'',r)’, ‘q''’, ‘SND (q'',r)’, + ‘cont'’, ‘s'’] mp_tac) >> + rewrite_tac [UNCURRY] >> + last_x_assum mp_tac >> + disch_then (qspecl_then [‘(q,q',q'',r)’, ‘q’, ‘SND (q,q',q'',r)’, + ‘q'’, ‘SND (q',q'',r)’, ‘q''’, ‘SND (q'',r)’, + ‘cont'’, ‘s'’] mp_tac) >> + rewrite_tac [UNCURRY] >> + qpat_x_assum ‘store_cont _ _ _ = _’ (mp_tac o GSYM) >> + rewrite_tac [] >> + simp [] >> + strip_tac >> + pop_assum (mp_tac o GSYM) >> + simp [] >> + strip_tac >> + strip_tac >> + strip_tac >> + strip_tac >> rveq >> + gs [no_Loops_def, no_Loop_def, every_prog_def] >> + cases_on ‘comp_with_loop p q' cont' s'’ >> + fs [] >> + cases_on ‘r'’ >> fs [] >> + cases_on ‘comp_with_loop p q'' cont' (q'³',r'')’ >> fs []) >> + fs [comp_with_loop_def, no_Loops_def, no_Loop_def] >> fs [] >> + rpt (pairarg_tac >> fs []) >> rveq >> fs [] >> + fs [every_prog_def] +QED + + +Theorem comp_all_no_loop: + !prog l n q r name params body. + FOLDR comp (n,l) prog = (q,r) ∧ + EVERY (λ(name, params,body). no_Loops body) l /\ + MEM (name, params,body) r ==> + no_Loops body +Proof + Induct >> rw [] >> + fs [] + >- ( + fs [EVERY_MEM, UNCURRY] >> + res_tac >> fs []) >> + cases_on ‘h’ >> + cases_on ‘r'’ >> + fs [comp_def] >> + pairarg_tac >> fs [] >> rveq >> fs [] >> rveq + >- ( + cases_on ‘FOLDR comp (n,l) prog’ >> + drule comp_with_loop_no_loop >> + impl_tac + >- ( + fs [] >> + last_x_assum drule >> + fs [] >> + strip_tac >> + fs [EVERY_MEM] >> + fs [no_Loops_def, no_Loop_def, every_prog_def] >> + rw [] >> fs [] >> + cases_on ‘e’ >> + cases_on ‘r'’ >> res_tac >> fs []) >> + fs []) >> + cases_on ‘FOLDR comp (n,l) prog’ >> + drule comp_with_loop_no_loop >> + impl_tac + >- ( + fs [] >> + last_x_assum drule >> + fs [] >> + strip_tac >> + fs [EVERY_MEM] >> + fs [no_Loops_def, no_Loop_def, every_prog_def] >> + rw [] >> fs [] >> + cases_on ‘e’ >> + cases_on ‘r'’ >> res_tac >> fs []) >> + fs [] >> + strip_tac >> + fs [EVERY_MEM] >> + res_tac >> fs [] +QED + +Theorem comp_prog_no_loops: + !prog name params body. + MEM (name,params,body) (comp_prog prog) ==> + no_Loops body +Proof + rw [] >> + fs [comp_prog_def] >> + qmatch_asmsub_abbrev_tac ‘(n, [])’ >> + cases_on ‘FOLDR comp (n,[]) prog’ >> + fs [] >> + drule comp_all_no_loop >> + fs [EVERY_DEF] >> + disch_then drule >> + fs [] +QED + +Theorem store_cont_params_distinct: + !l cont s cont' t. + store_cont l cont s = (cont',t) ∧ + EVERY (λ(name,params,body). ALL_DISTINCT params) (SND s) ⇒ + EVERY (λ(name,params,body). ALL_DISTINCT params) (SND t) +Proof + rw [] >> + cases_on ‘s’ >> cases_on ‘t’ >> + fs [store_cont_def] >> rveq >> + fs [EVERY_MEM, ALL_DISTINCT_MAP_FST_toAList] +QED + +Theorem comp_with_loop_params_distinct: + !p q cont s body t. + comp_with_loop p q cont s = (body,t) ∧ + EVERY (λ(name,params,body). ALL_DISTINCT params) (SND s) ⇒ + EVERY (λ(name,params,body). ALL_DISTINCT params) (SND t) +Proof + ho_match_mp_tac comp_with_loop_ind >> + rpt conj_tac >> rpt gen_tac >> + strip_tac >> rpt gen_tac >> + TRY ( + rename [‘Seq’] >> + strip_tac >> + fs [comp_with_loop_def] >> fs [] >> + rpt (pairarg_tac >> fs []) >> rveq >> fs [] >> + Cases_on ‘s'’ >> + gs []) >> + TRY ( + rename [‘If’] >> + strip_tac >> + fs [comp_with_loop_def] >> fs [] >> + rpt (pairarg_tac >> fs []) >> rveq >> fs [] >> + drule store_cont_params_distinct >> + fs []) >> + TRY ( + rename [‘Loop’] >> + rewrite_tac [comp_with_loop_def] >> + fs [] >> + rpt (pairarg_tac >> fs []) >> rveq >> fs [] >> + strip_tac >> rveq >> + gs [] >> + drule store_cont_params_distinct >> + gs [] >> + strip_tac >> gs [] >> + fs [ALL_DISTINCT_MAP_FST_toAList]) >> + TRY ( + rename [‘Call’] >> + rewrite_tac [comp_with_loop_def] >> + every_case_tac >> fs [] >> rveq >> + rpt (pairarg_tac >> fs []) >> rveq >> gs [] >> + strip_tac >> rveq >> fs [] >> + drule store_cont_params_distinct >> + strip_tac >> gs []) >> + fs [comp_with_loop_def] >> + rpt (pairarg_tac >> fs []) >> rveq >> fs [] +QED + + +Theorem first_params_comp_all_distinct: + !prog l n q r name params. + FOLDR comp (n,l) prog = (q,r) ∧ + EVERY (λ(name,params,body). ALL_DISTINCT params) prog ∧ + EVERY (λ(name,params,body). ALL_DISTINCT params) l ==> + EVERY (λ(name,params,body). ALL_DISTINCT params) r +Proof + Induct >> rw [] >> + fs [] >> + PairCases_on ‘h’ >> + fs [comp_def] >> + pairarg_tac >> fs [] >> rveq >> gs [] >> + cases_on ‘FOLDR comp (n,l) prog’ >> + last_x_assum drule >> + gs [] >> + strip_tac >> + drule comp_with_loop_params_distinct >> + fs [] +QED + +Theorem compile_prog_distinct_params: + !prog name params body. + MEM (name,params,body) (comp_prog prog) ∧ + EVERY (λ(name,params,body). ALL_DISTINCT params) prog ⇒ + ALL_DISTINCT params +Proof + rw [] >> + fs [comp_prog_def] >> + qmatch_asmsub_abbrev_tac ‘(n, [])’ >> + cases_on ‘FOLDR comp (n,[]) prog’ >> + fs [] >> + drule first_params_comp_all_distinct >> + fs [] >> + strip_tac >> + gs [EVERY_MEM] >> + first_x_assum (qspec_then ‘(name,params,body)’ mp_tac) >> + fs [] +QED + + +Definition acc_ok_def: + acc_ok (n:num,fs) ⇔ + (∀x. MEM x (MAP FST fs) ⇒ x < n) ∧ + ALL_DISTINCT (MAP FST fs) +End + +Theorem store_cont_names_distinct: + !l cont s cont' t. + store_cont l cont s = (cont',t) ∧ + acc_ok s ⇒ + acc_ok t ∧ FST s ≤ FST t ∧ + (∀x. x < FST s ∧ MEM x (MAP FST (SND t)) ⇒ + MEM x (MAP FST (SND s))) ∧ + (∀x. MEM x (SND s) ⇒ MEM x (SND t)) +Proof + rw [] >> + cases_on ‘s’ >> cases_on ‘t’ >> + fs [store_cont_def, acc_ok_def] >> rveq >> + fs [] >> + rw [] >> fs [] >> + res_tac >> fs [] >> + CCONTR_TAC >> fs [] >> + res_tac >> fs [] +QED + +Theorem comp_with_loop_names_distinct: + !p q cont s body t. + comp_with_loop p q cont s = (body,t) ∧ + acc_ok s ⇒ + acc_ok t ∧ FST s ≤ FST t ∧ + (∀x. MEM x (MAP FST (SND t)) ∧ x < FST s ⇒ + MEM x (MAP FST (SND s))) ∧ + (∀x. MEM x (SND s) ⇒ MEM x (SND t)) +Proof + ho_match_mp_tac comp_with_loop_ind >> + rpt conj_tac >> rpt gen_tac >> + strip_tac >> rpt gen_tac >> + TRY ( + rename [‘Seq’] >> + strip_tac >> + fs [comp_with_loop_def] >> fs [] >> + rpt (pairarg_tac >> fs []) >> rveq >> fs [] >> + Cases_on ‘s'’ >> + gs []) >> + TRY ( + rename [‘If’] >> + strip_tac >> + fs [comp_with_loop_def] >> fs [] >> + rpt (pairarg_tac >> fs []) >> rveq >> fs [] >> + drule store_cont_names_distinct >> + strip_tac >> gs []) >> + TRY ( + rename [‘Loop’] >> + rewrite_tac [comp_with_loop_def] >> + fs [] >> + rpt (pairarg_tac >> fs []) >> rveq >> fs [] >> + strip_tac >> rveq >> + gs [] >> + drule store_cont_names_distinct >> + gs [] >> + strip_tac >> gs [] >> + ‘acc_ok (n + 1,funs)’ by ( + fs [acc_ok_def] >> + rw [] >> gs [] >> + res_tac >> fs []) >> + conj_tac + >- ( + fs [acc_ok_def] >> + rw [] >> gs [] >> + CCONTR_TAC >> fs [] >> + last_x_assum drule >> + strip_tac >> fs [] >> + last_x_assum drule >> + impl_tac >- fs [] >> + strip_tac >> + last_x_assum drule >> fs []) >> + fs [] >> + rw [] >> gs []) >> + TRY ( + rename [‘Call’] >> + rewrite_tac [comp_with_loop_def] >> + every_case_tac >> fs [] >> rveq >> + rpt (pairarg_tac >> fs []) >> rveq >> gs [] >> + strip_tac >> rveq >> fs [] >> + drule store_cont_names_distinct >> + strip_tac >> gs []) >> + fs [comp_with_loop_def] >> + rpt (pairarg_tac >> fs []) >> rveq >> fs [] +QED + +Theorem first_comp_all_distinct: + !prog n l q r. + ALL_DISTINCT (MAP FST prog ++ MAP FST l) ∧ + FOLDR comp (n,l) prog = (q,r) ∧ + (!x. MEM x (MAP FST prog) ==> x < n) ∧ + acc_ok (n,l) ⇒ + acc_ok (q,r) ∧ n ≤ q ∧ + (∀x. MEM x (MAP FST r) ∧ x < n ⇒ + MEM x (MAP FST l) ∨ MEM x (MAP FST prog)) ∧ + (∀x. MEM x l ⇒ MEM x r) +Proof + Induct + >- (rw [] >> fs []) >> + rpt gen_tac >> + strip_tac >> fs [] >> + PairCases_on ‘h’ >> + fs [comp_def] >> + pairarg_tac >> fs [] >> rveq >> + gs [] >> + cases_on ‘FOLDR comp (n,l) prog’ >> fs [] >> + last_x_assum drule >> + fs [] >> strip_tac >> + first_x_assum drule >> + fs [] >> + strip_tac >> + drule comp_with_loop_names_distinct >> + fs [] >> + simp [acc_ok_def] >> + strip_tac >> + rpt conj_tac + >- ( + rw [] >> fs [] >> + last_x_assum (qspec_then ‘h0’ mp_tac) >> fs []) + >- ( + CCONTR_TAC >> fs [] >> + last_x_assum (qspec_then ‘h0’ mp_tac) >> + fs [] >> + CCONTR_TAC >> fs [] >> + first_x_assum drule >> + fs [] >> + CCONTR_TAC >> fs [] >> + last_x_assum drule >> + fs []) >> + rw [] >> + fs [] >> + CCONTR_TAC >> fs [] >> + last_x_assum (qspec_then ‘x’ mp_tac) >> + last_x_assum (qspec_then ‘x’ mp_tac) >> + fs [] +QED + + +Theorem first_comp_prog_all_distinct: + !prog. + ALL_DISTINCT (MAP FST prog) ⇒ + ALL_DISTINCT (MAP FST (comp_prog prog)) +Proof + rw [] >> + fs [comp_prog_def] >> + qmatch_goalsub_abbrev_tac ‘(n, [])’ >> + cases_on ‘FOLDR comp (n,[]) prog’ >> + fs [] >> + imp_res_tac first_comp_all_distinct >> + gs [] >> + fs [acc_ok_def] >> + qsuff_tac ‘(∀x. MEM x (MAP FST prog) ⇒ x < n)’ >> + fs [] >> + rw [] >> + fs [Abbr ‘n’, MEM_MAP] >> + cases_on ‘y’ >> fs [] >> rveq >> + match_mp_tac pan_commonPropsTheory.max_foldr_lt >> + fs [MEM_MAP] >> + qexists_tac ‘(q', r')’ >> fs [] +QED + +Triviality state_rel_imp_code_rel: + state_rel s t ⇒ ∃c. t = s with code := c +Proof + rw [state_rel_def] >> + metis_tac [] +QED + +val comp_Call = + compile_correct |> Q.SPEC ‘Call NONE (SOME start) [] NONE’ |> + REWRITE_RULE [syntax_ok_def] + + +Theorem state_rel_imp_semantics: + state_rel s t ∧ + s.code = fromAList loop_code /\ + t.code = fromAList (loop_remove$comp_prog loop_code) /\ + (∃prog. lookup start s.code = SOME ([], prog)) /\ + semantics s start <> Fail ==> + semantics t start = semantics s start +Proof + rw [] >> + drule state_rel_imp_code_rel >> + strip_tac >> rveq >> fs [] >> + qpat_x_assum ‘c = fromAList (comp_prog loop_code)’ kall_tac >> + reverse (Cases_on ‘semantics s start’) >> fs [] >> rveq + >- ( + (* termination case of original loop program *) + fs [semantics_def] >> + pop_assum mp_tac >> + IF_CASES_TAC >> fs [] >> + DEEP_INTRO_TAC some_intro >> simp [] >> + rw [] + >- ( + (* fail case of loop_remove *) + last_x_assum (qspec_then ‘k'’ mp_tac) >> simp [] >> + (fn g => subterm (fn tm => Cases_on ‘^(assert(has_pair_type)tm)’) (#2 g) g) >> + CCONTR_TAC >> + drule comp_Call >> + disch_then (qspec_then ‘s with <|code := fromAList (comp_prog loop_code); + clock := k'|>’ mp_tac) >> + disch_then (qspec_then ‘(Fail,Fail)’ mp_tac) >> + impl_tac + >- ( + conj_tac >- (fs [state_rel_def] >> metis_tac []) >> + conj_tac + >- ( + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + fs [breaks_ok_def, break_ok_def]) >> + ‘no_Loop (Call NONE (SOME start) [] NONE)’ by ( + fs [no_Loop_def, every_prog_def]) >> + strip_tac >> rfs [] >> + fs [] >> rveq >> fs [] >> + fs [comp_no_loop_def] >> + cases_on ‘q’ >> fs [] >> rveq >> + cases_on ‘x’ >> fs []) >> + (* termination/diverging case of loopremove *) + DEEP_INTRO_TAC some_intro >> simp[] >> + conj_tac + (* termination case of loopremove *) + >- ( + rw [] >> fs [] >> + last_x_assum (qspec_then ‘k'’ assume_tac) >> + cases_on ‘evaluate (Call NONE (SOME start) [] NONE,s with clock := k')’ >> fs [] >> + drule comp_Call >> + disch_then (qspec_then ‘s with <|code := fromAList (comp_prog loop_code); + clock := k'|>’ mp_tac) >> + disch_then (qspec_then ‘(Fail,Fail)’ mp_tac) >> + impl_tac + >- ( + conj_tac >- (fs [state_rel_def] >> metis_tac []) >> + conj_tac + >- ( + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + fs [breaks_ok_def, break_ok_def]) >> + ‘no_Loop (Call NONE (SOME start) [] NONE)’ by ( + fs [no_Loop_def, every_prog_def]) >> + strip_tac >> rfs [] >> + fs [] >> rveq >> fs [] >> + fs [comp_no_loop_def] >> + cases_on ‘q’ >> fs [] >> rveq >> + cases_on ‘x’ >> fs [] >> rveq >> fs [] + >- ( + last_x_assum (qspec_then ‘k'’ assume_tac) >> + rfs [] >> + fs [] >> + cases_on ‘r’ >> fs [] >> + cases_on ‘x’ >> fs [] + >- ( + qpat_x_assum ‘evaluate (_,_) = _’ kall_tac >> + dxrule evaluate_add_clock_eq >> + dxrule evaluate_add_clock_eq >> + disch_then (qspec_then ‘k'’ assume_tac) >> + disch_then (qspec_then ‘k’ assume_tac) >> + fs [] >> rveq >> fs [state_rel_def] >> + rveq >> fs [state_component_equality]) >> + qpat_x_assum ‘evaluate (_,_) = _’ kall_tac >> + dxrule evaluate_add_clock_eq >> + dxrule evaluate_add_clock_eq >> + disch_then (qspec_then ‘k'’ assume_tac) >> + disch_then (qspec_then ‘k’ assume_tac) >> + fs []) >> + last_x_assum (qspec_then ‘k'’ assume_tac) >> + rfs [] >> + fs [] >> + cases_on ‘r’ >> fs [] >> + cases_on ‘x’ >> fs [] + >- ( + qpat_x_assum ‘evaluate (_,_) = _’ kall_tac >> + dxrule evaluate_add_clock_eq >> + dxrule evaluate_add_clock_eq >> + disch_then (qspec_then ‘k'’ assume_tac) >> + disch_then (qspec_then ‘k’ assume_tac) >> + fs []) >> + qpat_x_assum ‘evaluate (_,_) = _’ kall_tac >> + dxrule evaluate_add_clock_eq >> + dxrule evaluate_add_clock_eq >> + disch_then (qspec_then ‘k'’ assume_tac) >> + disch_then (qspec_then ‘k’ assume_tac) >> + fs [] >> rveq >> fs [state_rel_def] >> + rveq >> fs [state_component_equality]) >> + (* diverging case of loopremove *) + rw [] >> fs [] >> + last_x_assum (qspec_then ‘k’ assume_tac) >> + cases_on ‘evaluate (Call NONE (SOME start) [] NONE,s with clock := k)’ >> fs [] >> + drule comp_Call >> + disch_then (qspec_then ‘s with <|code := fromAList (comp_prog loop_code); + clock := k|>’ mp_tac) >> + disch_then (qspec_then ‘(Fail,Fail)’ mp_tac) >> + impl_tac + >- ( + conj_tac >- (fs [state_rel_def] >> metis_tac []) >> + conj_tac + >- ( + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + fs [breaks_ok_def, break_ok_def]) >> + ‘no_Loop (Call NONE (SOME start) [] NONE)’ by ( + fs [no_Loop_def, every_prog_def]) >> + strip_tac >> rfs [] >> + fs [] >> rveq >> fs [] >> + fs [comp_no_loop_def] >> + cases_on ‘q’ >> fs [] >> rveq >> + cases_on ‘x’ >> fs [] >> rveq >> fs [] + >- ( + qexists_tac ‘k’ >> + fs []) >> + last_x_assum (qspec_then ‘k’ assume_tac) >> + rfs [] >> fs [] >> + qexists_tac ‘k’ >> fs []) >> + (* diverging case of orginal program *) + fs [semantics_def] >> + pop_assum mp_tac >> + IF_CASES_TAC >> fs [] >> + DEEP_INTRO_TAC some_intro >> simp[] >> + rw [] + >- ( + (* fail case of loopremove semantics *) + fs[] >> rveq >> fs[] >> + last_x_assum (qspec_then ‘k’ mp_tac) >> simp[] >> + (fn g => subterm (fn tm => Cases_on ‘^(assert(has_pair_type)tm)’) (#2 g) g) >> + CCONTR_TAC >> + drule comp_Call >> + disch_then (qspec_then ‘s with <|code := fromAList (comp_prog loop_code); + clock := k|>’ mp_tac) >> + disch_then (qspec_then ‘(Fail,Fail)’ mp_tac) >> + impl_tac + >- ( + conj_tac >- (fs [state_rel_def] >> metis_tac []) >> + conj_tac + >- ( + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + fs [breaks_ok_def, break_ok_def]) >> + ‘no_Loop (Call NONE (SOME start) [] NONE)’ by ( + fs [no_Loop_def, every_prog_def]) >> + strip_tac >> rfs [] >> + fs [] >> rveq >> fs [] >> + fs [comp_no_loop_def] >> + cases_on ‘q’ >> fs [] >> rveq >> + cases_on ‘x’ >> fs []) >> + (* termination/diverging case of loopremove *) + DEEP_INTRO_TAC some_intro >> simp[] >> + conj_tac + (* termination case of loopremove *) + >- ( + rw [] >> fs[] >> + cases_on ‘r’ >> fs [] >> + cases_on ‘x’ >> fs [] >> ( + last_x_assum (qspec_then ‘k’ mp_tac) >> + last_x_assum (qspec_then ‘k’ mp_tac) >> + strip_tac >> rfs [] >> rveq >> + cases_on ‘evaluate (Call NONE (SOME start) [] NONE,s with clock := k)’ >> + fs [] >> + last_x_assum (qspec_then ‘k’ mp_tac) >> + fs [] >> strip_tac >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs [] >> + drule comp_Call >> + disch_then (qspec_then ‘s with <|code := fromAList (comp_prog loop_code); + clock := k|>’ mp_tac) >> + disch_then (qspec_then ‘(Fail,Fail)’ mp_tac) >> + impl_tac + >- ( + conj_tac >- (fs [state_rel_def] >> metis_tac []) >> + fs [breaks_ok_def, break_ok_def]) >> + ‘no_Loop (Call NONE (SOME start) [] NONE)’ by ( + fs [no_Loop_def, every_prog_def]) >> + strip_tac >> rfs [] >> + fs [] >> rveq >> fs [] >> + fs [comp_no_loop_def])) >> + rw [] >> + qmatch_abbrev_tac ‘build_lprefix_lub l1 = build_lprefix_lub l2’ >> + ‘(lprefix_chain l1 ∧ lprefix_chain l2) ∧ equiv_lprefix_chain l1 l2’ + suffices_by metis_tac[build_lprefix_lub_thm,lprefix_lub_new_chain,unique_lprefix_lub] >> + conj_asm1_tac + >- ( + UNABBREV_ALL_TAC >> + conj_tac >> + Ho_Rewrite.ONCE_REWRITE_TAC[GSYM o_DEF] >> + REWRITE_TAC[IMAGE_COMPOSE] >> + match_mp_tac prefix_chain_lprefix_chain >> + simp[prefix_chain_def,PULL_EXISTS] >> + qx_genl_tac [‘k1’, ‘k2’] >> + qspecl_then [‘k1’, ‘k2’] mp_tac LESS_EQ_CASES >> + simp[LESS_EQ_EXISTS] >> + rw [] >> + assume_tac (INST_TYPE [``:'a``|->``:'a``, + ``:'b``|->``:'b``] + loopPropsTheory.evaluate_add_clock_io_events_mono) >> + first_assum (qspecl_then + [‘Call NONE (SOME start) [] NONE’, ‘s with + <|clock := k1; code := fromAList (comp_prog loop_code)|>’, ‘p’] mp_tac) >> + first_assum (qspecl_then + [‘Call NONE (SOME start) [] NONE’, ‘s with + <|clock := k2; code := fromAList (comp_prog loop_code)|>’, ‘p’] mp_tac) >> + first_assum (qspecl_then + [‘Call NONE (SOME start) [] NONE’, ‘s with clock := k1’, ‘p’] mp_tac) >> + first_assum (qspecl_then + [‘Call NONE (SOME start) [] NONE’, ‘s with clock := k2’, ‘p’] mp_tac) >> + fs []) >> + simp[equiv_lprefix_chain_thm] >> + fs [Abbr ‘l1’, Abbr ‘l2’] >> simp[PULL_EXISTS] >> + pop_assum kall_tac >> + simp[LNTH_fromList,PULL_EXISTS] >> + simp[GSYM FORALL_AND_THM] >> + rpt gen_tac >> + reverse conj_tac >> strip_tac + >- ( + qmatch_assum_abbrev_tac`n < LENGTH (_ (_ (SND p)))` >> + Cases_on`p` >> pop_assum(assume_tac o SYM o REWRITE_RULE[markerTheory.Abbrev_def]) >> + drule comp_Call >> + disch_then (qspec_then ‘s with <|code := fromAList (comp_prog loop_code); + clock := k|>’ mp_tac) >> + disch_then (qspec_then ‘(Fail,Fail)’ mp_tac) >> + impl_tac + >- ( + conj_tac >- (fs [state_rel_def] >> metis_tac []) >> + conj_tac + >- ( + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs [] >> + last_x_assum (qspec_then ‘k’ mp_tac) >> + fs []) >> + fs [breaks_ok_def, break_ok_def]) >> + ‘no_Loop (Call NONE (SOME start) [] NONE)’ by ( + fs [no_Loop_def, every_prog_def]) >> + strip_tac >> rfs [] >> + qexists_tac ‘k’ >> simp[] >> + cases_on ‘q’ >> fs [] >> + TRY (cases_on ‘x’) >> + fs [comp_no_loop_def] >> + fs [state_rel_def] >> + rveq >> fs [] >> + fs [evaluate_def]) >> + cases_on ‘evaluate + (Call NONE (SOME start) [] NONE,s with clock := k)’ >> + drule comp_Call >> + disch_then (qspec_then ‘s with <|code := fromAList (comp_prog loop_code); + clock := k|>’ mp_tac) >> + disch_then (qspec_then ‘(Fail,Fail)’ mp_tac) >> + impl_tac + >- ( + conj_tac >- (fs [state_rel_def] >> metis_tac []) >> + conj_tac + >- ( + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs [] >> + last_x_assum (qspec_then ‘k’ mp_tac) >> + fs []) >> + fs [breaks_ok_def, break_ok_def]) >> + ‘no_Loop (Call NONE (SOME start) [] NONE)’ by ( + fs [no_Loop_def, every_prog_def]) >> + strip_tac >> rfs [] >> + qexists_tac ‘k’ >> simp[] >> + cases_on ‘q’ >> fs [] >> + TRY (cases_on ‘x’) >> + fs [comp_no_loop_def] >> + fs [state_rel_def] >> + rveq >> fs [] >> + fs [evaluate_def] +QED + +Theorem comp_comp_with_loop_mem: + ∀fprog lprog n l q r name params body body' accum t. + FOLDR comp (n,l) (fprog ++ [(name,params,body)] ++ lprog) = (q,r) ∧ + acc_ok (n,l) ∧ + (∀x. MEM x (MAP FST (fprog ++ [(name,params,body)] ++ lprog)) ⇒ x < n) ∧ + ALL_DISTINCT (MAP FST (fprog ++ [(name,params,body)] ++ lprog) ++ MAP FST l) ∧ + accum = FOLDR comp (n,l) lprog ∧ + comp_with_loop (Fail,Fail) body Fail accum = (body',t) ⇒ + MEM (name,params,body') r ∧ + (∀n' p b. MEM (n',p,b) (SND t) ⇒ MEM (n',p,b) r) +Proof + Induct >> + rpt gen_tac >> strip_tac + >- ( + fs [comp_def] >> + pairarg_tac >> fs [] >> rveq >> gs []) >> + cases_on ‘FOLDR comp (n,l) (fprog ++ [(name,params,body)] ++ lprog)’ >> + fs [] >> + last_x_assum drule >> + fs [] >> + strip_tac >> + last_x_assum assume_tac >> + PairCases_on ‘h’ >> + fs [comp_def] >> + pairarg_tac >> fs [] >> + rveq >> gs [] >> + drule comp_with_loop_names_distinct >> + impl_tac + >- ( + ‘ALL_DISTINCT (MAP FST (fprog ++ [(name,params,body)] ++ lprog) ++ MAP FST l)’ by fs [] >> + drule first_comp_all_distinct >> + fs [] >> + disch_then (qspecl_then [‘n’, ‘q'’, ‘r'’] mp_tac) >> + impl_tac + >- ( + fs [] >> + rw [] >> gs []) >> + strip_tac >> rfs []) >> + strip_tac >> + res_tac >> gs [] >> + ‘∀x. (MEM x (MAP FST fprog) ∨ x = name) ∨ MEM x (MAP FST lprog) ⇒ + x < n’ by (rw [] >> gs []) >> + last_x_assum drule >> + strip_tac >> + fs [] +QED + +Theorem comp_prog_has_code: + ∀prog name params body. + ALL_DISTINCT (MAP FST prog) ∧ + MEM (name,params,body) prog ⇒ + ∃init. + has_code (comp (name,params,body) init) + (fromAList (comp_prog prog)) +Proof + rw [] >> + fs [MEM_SPLIT] >> + rename [‘ prog = fprog ++ [(name,params,body)] ++ lprog’] >> + fs [] >> + pop_assum kall_tac >> + fs [ALL_DISTINCT_APPEND] >> + ‘~MEM (name,params,body) fprog’ by ( + CCONTR_TAC >> + gs [MEM_MAP] >> + last_x_assum (qspec_then ‘(name,params,body)’ mp_tac) >> + fs []) >> + ‘~MEM (name,params,body) lprog’ by ( + CCONTR_TAC >> + gs [MEM_MAP] >> + first_x_assum (qspec_then ‘(name,params,body)’ mp_tac) >> + fs [] >> + first_x_assum (qspec_then ‘name’ mp_tac) >> + fs [] >> + qexists_tac ‘(name,params,body)’ >> fs []) >> + qmatch_goalsub_abbrev_tac ‘comp_prog prog’ >> + fs [loop_removeTheory.comp_prog_def] >> + qmatch_goalsub_abbrev_tac ‘(nn,[])’ >> + qexists_tac ‘FOLDR comp (nn, []) lprog’ >> + qmatch_goalsub_abbrev_tac ‘comp _ accum’ >> + fs [comp_def] >> + pairarg_tac >> fs [] >> + fs [has_code_def] >> + fs [lookup_fromAList] >> + conj_asm1_tac + >- ( + match_mp_tac ALOOKUP_ALL_DISTINCT_MEM >> + cases_on ‘FOLDR comp (nn,[]) prog’ >> fs [] >> + ‘ALL_DISTINCT (MAP FST prog ++ + MAP FST ([] :(num # num list # α loopLang$prog) list))’ by ( + fs [ALL_DISTINCT_APPEND] >> + gs [Abbr ‘prog’, ALL_DISTINCT_APPEND] >> + rw [] >> + last_x_assum (qspec_then ‘e’ mp_tac) >> + fs []) >> + drule first_comp_all_distinct >> + disch_then (qspecl_then [‘nn’, ‘q’, ‘r’] mp_tac) >> + impl_tac + >- ( + fs [acc_ok_def] >> + fs [Abbr ‘nn’] >> rw [] >> gs [] >> + match_mp_tac pan_commonPropsTheory.max_foldr_lt >> + fs []) >> + strip_tac >> + conj_asm1_tac + >- fs [acc_ok_def] >> + fs [Abbr ‘prog’] >> + drule comp_comp_with_loop_mem >> + disch_then (qspecl_then [‘body'’, ‘accum’, ‘(n,funs)’] mp_tac) >> + fs [acc_ok_def] >> + impl_tac + >- ( + fs [Abbr ‘nn’] >> + rw [] >> gs [] >> + match_mp_tac pan_commonPropsTheory.max_foldr_lt >> + fs []) >> + fs []) >> + fs [EVERY_MEM] >> + rw [] >> + pairarg_tac >> fs [] >> + pop_assum kall_tac >> + match_mp_tac ALOOKUP_ALL_DISTINCT_MEM >> + cases_on ‘FOLDR comp (nn,[]) prog’ >> fs [] >> + ‘ALL_DISTINCT (MAP FST prog ++ + MAP FST ([] :(num # num list # α loopLang$prog) list))’ by ( + fs [ALL_DISTINCT_APPEND] >> + gs [Abbr ‘prog’, ALL_DISTINCT_APPEND] >> + rw [] >> + last_x_assum (qspec_then ‘e’ mp_tac) >> + fs []) >> + drule first_comp_all_distinct >> + disch_then (qspecl_then [‘nn’, ‘q’, ‘r’] mp_tac) >> + impl_tac + >- ( + fs [acc_ok_def] >> + fs [Abbr ‘nn’] >> rw [] >> gs [] >> + match_mp_tac pan_commonPropsTheory.max_foldr_lt >> + fs []) >> + strip_tac >> + conj_asm1_tac + >- fs [acc_ok_def] >> + fs [Abbr ‘prog’] >> + drule comp_comp_with_loop_mem >> + disch_then (qspecl_then [‘body'’, ‘accum’, ‘(n,funs)’] mp_tac) >> + fs [acc_ok_def] >> + impl_tac + >- ( + fs [Abbr ‘nn’] >> + rw [] >> gs [] >> + match_mp_tac pan_commonPropsTheory.max_foldr_lt >> + fs []) >> + fs [] +QED + + + +val _ = export_theory(); diff --git a/pancake/proofs/loop_to_wordProofScript.sml b/pancake/proofs/loop_to_wordProofScript.sml new file mode 100644 index 0000000000..d0656ac730 --- /dev/null +++ b/pancake/proofs/loop_to_wordProofScript.sml @@ -0,0 +1,1473 @@ +(* + Correctness proof for loop_to_word +*) + +open preamble + loopSemTheory loopPropsTheory + wordLangTheory wordSemTheory wordPropsTheory + pan_commonTheory pan_commonPropsTheory + loop_to_wordTheory loop_removeProofTheory + +val _ = new_theory "loop_to_wordProof"; + +val _ = temp_delsimps ["lift_disj_eq", "lift_imp_disj"]; + +Definition locals_rel_def: + locals_rel ctxt l1 l2 ⇔ + INJ (find_var ctxt) (domain ctxt) UNIV ∧ + (∀n m. lookup n ctxt = SOME m ==> m ≠ 0) ∧ + ∀n v. lookup n l1 = SOME v ⇒ + ∃m. lookup n ctxt = SOME m ∧ lookup m l2 = SOME v +End + +Definition globals_rel_def: + globals_rel g1 g2 = + ∀n v. FLOOKUP g1 n = SOME v ⇒ FLOOKUP g2 (Temp n) = SOME v +End + +Definition code_rel_def: + code_rel s_code t_code = + ∀name params body. + lookup name s_code = SOME (params,body) ⇒ + lookup name t_code = SOME (LENGTH params+1, comp_func name params body) ∧ + no_Loops body ∧ ALL_DISTINCT params +End + +Definition state_rel_def: + state_rel s t <=> + t.memory = s.memory ∧ + t.mdomain = s.mdomain ∧ + t.clock = s.clock ∧ + t.be = s.be ∧ + t.ffi = s.ffi ∧ + globals_rel s.globals t.store ∧ + code_rel s.code t.code +End + +val goal = + ``λ(prog, s). ∀res s1 t ctxt retv l. + evaluate (prog,s) = (res,s1) ∧ res ≠ SOME Error ∧ + state_rel s t ∧ locals_rel ctxt s.locals t.locals ∧ + lookup 0 t.locals = SOME retv ∧ no_Loops prog ∧ + ~(isWord retv) ∧ + domain (acc_vars prog LN) ⊆ domain ctxt ⇒ + ∃t1 res1. + evaluate (FST (comp ctxt prog l),t) = (res1,t1) ∧ + state_rel s1 t1 ∧ + case res of + | NONE => res1 = NONE ∧ lookup 0 t1.locals = SOME retv ∧ + (* always return to the label stored in Var 0 for wordLang's prog *) + locals_rel ctxt s1.locals t1.locals ∧ + t1.stack = t.stack ∧ t1.handler = t.handler + | SOME (Result v) => res1 = SOME (Result retv v) ∧ + t1.stack = t.stack ∧ t1.handler = t.handler + | SOME TimeOut => res1 = SOME TimeOut + | SOME (FinalFFI f) => res1 = SOME (FinalFFI f) + | SOME (Exception v) => + (res1 ≠ SOME Error ⇒ ∃u1 u2. res1 = SOME (Exception u1 u2)) ∧ + ∀r l1 l2. jump_exc (t1 with <| stack := t.stack; + handler := t.handler |>) = SOME (r,l1,l2) ⇒ + res1 = SOME (Exception (Loc l1 l2) v) ∧ r = t1 + | _ => F`` + +local + val ind_thm = loopSemTheory.evaluate_ind + |> ISPEC goal + |> CONV_RULE (DEPTH_CONV PairRules.PBETA_CONV) |> REWRITE_RULE []; + fun list_dest_conj tm = if not (is_conj tm) then [tm] else let + val (c1,c2) = dest_conj tm in list_dest_conj c1 @ list_dest_conj c2 end + val ind_goals = ind_thm |> concl |> dest_imp |> fst |> list_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 + +Theorem locals_rel_intro: + locals_rel ctxt l1 l2 ==> + INJ (find_var ctxt) (domain ctxt) UNIV ∧ + (∀n m. lookup n ctxt = SOME m ==> m ≠ 0) ∧ + ∀n v. lookup n l1 = SOME v ⇒ + ∃m. lookup n ctxt = SOME m ∧ lookup m l2 = SOME v +Proof + rw [locals_rel_def] +QED + +Theorem globals_rel_intro: + globals_rel g1 g2 ==> + ∀n v. FLOOKUP g1 n = SOME v ⇒ FLOOKUP g2 (Temp n) = SOME v +Proof + rw [globals_rel_def] +QED + +Theorem code_rel_intro: + code_rel s_code t_code ==> + ∀name params body. + lookup name s_code = SOME (params,body) ⇒ + lookup name t_code = SOME (LENGTH params+1, comp_func name params body) ∧ + no_Loops body ∧ ALL_DISTINCT params +Proof + rw [code_rel_def] >> metis_tac [] +QED + +Theorem state_rel_intro: + state_rel s t ==> + t.memory = s.memory ∧ + t.mdomain = s.mdomain ∧ + t.clock = s.clock ∧ + t.be = s.be ∧ + t.ffi = s.ffi ∧ + globals_rel s.globals t.store ∧ + code_rel s.code t.code +Proof + rw [state_rel_def] +QED + +Theorem find_var_neq_0: + v ∈ domain ctxt ∧ locals_rel ctxt lcl lcl' ⇒ + find_var ctxt v ≠ 0 +Proof + fs [locals_rel_def, find_var_def] >> rw [] >> + Cases_on ‘lookup var_name ctxt’ >> fs [] >> + fs [domain_lookup] >> res_tac >> metis_tac [] +QED + +Theorem locals_rel_insert: + locals_rel ctxt lcl lcl' ∧ v IN domain ctxt ⇒ + locals_rel ctxt (insert v w lcl) + (insert (find_var ctxt v) w lcl') +Proof + fs [locals_rel_def,lookup_insert] >> rw [] >> + fs [CaseEq"bool"] >> rveq >> fs [] >> + fs [domain_lookup,find_var_def] >> + res_tac >> fs [] >> + disj2_tac >> CCONTR_TAC >> fs [] >> rveq >> fs [] >> + fs [INJ_DEF,domain_lookup] >> + first_x_assum (qspecl_then [‘v’,‘n’] mp_tac) >> + fs [] >> fs [find_var_def] +QED + +Theorem locals_rel_get_var: + locals_rel ctxt l t.locals ∧ lookup n l = SOME w ⇒ + wordSem$get_var (find_var ctxt n) t = SOME w +Proof + fs [locals_rel_def] >> rw[] >> res_tac >> + fs [find_var_def, get_var_def] +QED + +Theorem locals_rel_get_vars: + ∀argvars argvals. + locals_rel ctxt s.locals t.locals ∧ + loopSem$get_vars argvars s = SOME argvals ⇒ + wordSem$get_vars (MAP (find_var ctxt) argvars) t = SOME argvals ∧ + LENGTH argvals = LENGTH argvars +Proof + Induct >> fs [loopSemTheory.get_vars_def,get_vars_def,CaseEq"option"] + >> rw [] >> imp_res_tac locals_rel_get_var >> fs [] +QED + + +Triviality state_rel_IMP: + state_rel s t ⇒ t.clock = s.clock +Proof + fs [state_rel_def] +QED + +Theorem set_fromNumSet: + set (fromNumSet t) = domain t +Proof + fs [fromNumSet_def,EXTENSION,MEM_MAP,EXISTS_PROD,MEM_toAList,domain_lookup] +QED + +Theorem domain_toNumSet: + domain (toNumSet ps) = set ps +Proof + Induct_on ‘ps’ >> fs [toNumSet_def] +QED + +Theorem domain_make_ctxt: + ∀n ps l. domain (make_ctxt n ps l) = domain l UNION set ps +Proof + Induct_on ‘ps’ >> fs [make_ctxt_def] >> fs [EXTENSION] >> metis_tac [] +QED + +Theorem make_ctxt_inj: + ∀xs l n. (∀x y v. lookup x l = SOME v ∧ lookup y l = SOME v ⇒ x = y ∧ v < n) ⇒ + (∀x y v. lookup x (make_ctxt n xs l) = SOME v ∧ + lookup y (make_ctxt n xs l) = SOME v ⇒ x = y) +Proof + Induct_on ‘xs’ >> fs [make_ctxt_def] >> rw [] + >> first_x_assum (qspecl_then [‘insert h n l’,‘n+2’] mp_tac) + >> impl_tac >- + (fs [lookup_insert] >> rw [] + >> CCONTR_TAC >> fs [] >> res_tac >> fs []) + >> metis_tac [] +QED + +Triviality make_ctxt_APPEND: + ∀xs ys n l. + make_ctxt n (xs ++ ys) l = + make_ctxt (n + 2 * LENGTH xs) ys (make_ctxt n xs l) +Proof + Induct >> fs [make_ctxt_def,MULT_CLAUSES] +QED + +Triviality make_ctxt_NOT_MEM: + ∀xs n l x. ~MEM x xs ⇒ lookup x (make_ctxt n xs l) = lookup x l +Proof + Induct >> fs [make_ctxt_def,lookup_insert] +QED + +Theorem lookup_EL_make_ctxt: + ∀params k n l. + k < LENGTH params ∧ ALL_DISTINCT params ⇒ + lookup (EL k params) (make_ctxt n params l) = SOME (2 * k + n) +Proof + Induct >> Cases_on ‘k’ >> fs [] >> fs [make_ctxt_def,make_ctxt_NOT_MEM] +QED + +Theorem lookup_make_ctxt_range: + ∀xs m l n y. + lookup n (make_ctxt m xs l) = SOME y ⇒ + lookup n l = SOME y ∨ m ≤ y +Proof + Induct >> fs [make_ctxt_def] >> rw [] + >> first_x_assum drule + >> fs [lookup_insert] >> rw [] >> fs [] +QED + +Theorem locals_rel_make_ctxt: + ALL_DISTINCT params ∧ DISJOINT (set params) (set xs) ∧ + LENGTH params = LENGTH l ⇒ + locals_rel (make_ctxt 2 (params ++ xs) LN) + (fromAList (ZIP (params,l))) (fromList2 (retv::l)) +Proof + fs [locals_rel_def] >> rw [] + >- + (fs [INJ_DEF,find_var_def,domain_lookup] >> rw [] >> rfs [] + >> rveq >> fs [] + >> imp_res_tac (MP_CANON make_ctxt_inj) >> fs [lookup_def]) + >- + (Cases_on ‘lookup n (make_ctxt 2 (params ++ xs) LN)’ >> simp [] + >> drule lookup_make_ctxt_range >> fs [lookup_def]) + >> fs [lookup_fromAList] + >> imp_res_tac ALOOKUP_MEM + >> rfs [MEM_ZIP] >> rveq >> fs [make_ctxt_APPEND] + >> rename [‘k < LENGTH _’] + >> ‘k < LENGTH params’ by fs [] + >> drule EL_MEM >> strip_tac + >> ‘~MEM (EL k params) xs’ by (fs [IN_DISJOINT] >> metis_tac []) + >> fs [make_ctxt_NOT_MEM] + >> fs [lookup_EL_make_ctxt] + >> fs [lookup_fromList2,EVEN_ADD,EVEN_DOUBLE] + >> ‘2 * k + 2 = (SUC k) * 2’ by fs [] + >> asm_rewrite_tac [MATCH_MP MULT_DIV (DECIDE “0 < 2:num”)] + >> fs [lookup_fromList] +QED + +Theorem domain_mk_new_cutset_not_empty: + domain (mk_new_cutset ctxt x1) ≠ ∅ +Proof + fs [mk_new_cutset_def] +QED + +Theorem cut_env_mk_new_cutset: + locals_rel ctxt l1 l2 ∧ domain x1 ⊆ domain l1 ∧ lookup 0 l2 = SOME y ⇒ + ∃env1. cut_env (mk_new_cutset ctxt x1) l2 = SOME env1 ∧ + locals_rel ctxt (inter l1 x1) env1 +Proof + fs [locals_rel_def,SUBSET_DEF,cut_env_def] >> fs [lookup_inter_alt] + >> fs [mk_new_cutset_def,domain_toNumSet,MEM_MAP,set_fromNumSet,PULL_EXISTS] + >> fs [DISJ_IMP_THM,PULL_EXISTS] + >> strip_tac >> fs [domain_lookup] + >> rw [] >> res_tac >> fs [] >> rveq >> fs [find_var_def] + >> rw [] >> res_tac >> fs [] >> rveq >> fs [find_var_def] + >> disj2_tac >> qexists_tac ‘n’ >> fs [] +QED + +Theorem env_to_list_IMP: + env_to_list env1 t.permute = (l,permute) ⇒ + domain (fromAList l) = domain env1 ∧ + ∀x. lookup x (fromAList l) = lookup x env1 +Proof + strip_tac >> drule env_to_list_lookup_equiv + >> fs [EXTENSION,domain_lookup,lookup_fromAList] +QED + +Theorem cut_env_mk_new_cutset_IMP: + cut_env (mk_new_cutset ctxt x1) l1 = SOME l2 ⇒ + lookup 0 l2 = lookup 0 l1 +Proof + fs [cut_env_def] >> rw [] + >> fs [SUBSET_DEF,mk_new_cutset_def] + >> fs [lookup_inter_alt] +QED + +Triviality LASTN_ADD_CONS: + ~(LENGTH xs <= n) ⇒ LASTN (n + 1) (x::xs) = LASTN (n + 1) xs +Proof + fs [LASTN_CONS] +QED + + +Theorem comp_exp_preserves_eval: + !s e v t ctxt. + eval s e = SOME v ∧ + state_rel s t /\ locals_rel ctxt s.locals t.locals ==> + word_exp t (comp_exp ctxt e) = SOME v +Proof + ho_match_mp_tac eval_ind >> + rw [] >> + fs [eval_def, comp_exp_def, word_exp_def] + >- ( + fs [find_var_def, locals_rel_def] >> + TOP_CASE_TAC >> fs [] >> + first_x_assum drule >> + strip_tac >> fs [] >> rveq >> fs []) + >- fs [state_rel_def, globals_rel_def] + >- ( + cases_on ‘eval s e’ >> fs [] >> + cases_on ‘x’ >> fs [] >> + first_x_assum drule_all >> fs [] >> + strip_tac >> + fs [state_rel_def, mem_load_def, + loopSemTheory.mem_load_def]) + >- ( + fs [CaseEq "option"] >> + qsuff_tac + ‘the_words (MAP (λa. word_exp t a) + (MAP (λa. comp_exp ctxt a) wexps)) = SOME ws’ + >- fs [] >> + ntac 2 (pop_assum mp_tac) >> + ntac 2 (pop_assum kall_tac) >> + rpt (pop_assum mp_tac) >> + qid_spec_tac ‘ws’ >> + qid_spec_tac ‘wexps’ >> + Induct >> rw [] >> + last_assum mp_tac >> + impl_tac >- metis_tac [] >> + fs [the_words_def, CaseEq"option", CaseEq"word_loc"] >> + rveq >> fs []) >> + fs [CaseEq"option", CaseEq"word_loc"] >> rveq >> fs [] +QED + + +Theorem compile_Skip: + ^(get_goal "comp _ loopLang$Skip") ∧ + ^(get_goal "comp _ loopLang$Fail") ∧ + ^(get_goal "comp _ loopLang$Tick") +Proof + rpt strip_tac >> + fs [loopSemTheory.evaluate_def, comp_def, + evaluate_def] >> + rveq >> fs [] >> + TOP_CASE_TAC >> + fs [flush_state_def, state_rel_def, + loopSemTheory.dec_clock_def, dec_clock_def] >> rveq >> + fs [] +QED + +Theorem compile_Loop: + ^(get_goal "comp _ loopLang$Continue") ∧ + ^(get_goal "comp _ loopLang$Break") ∧ + ^(get_goal "comp _ (loopLang$Loop _ _ _)") +Proof + rpt strip_tac >> + fs [no_Loops_def, every_prog_def] >> + fs [no_Loop_def, every_prog_def] +QED + +Theorem compile_Mark: + ^(get_goal "comp _ (Mark _)") +Proof + rpt strip_tac >> + fs [loopSemTheory.evaluate_def, comp_def, + evaluate_def, no_Loops_def, + loopLangTheory.acc_vars_def, no_Loop_def, every_prog_def] +QED + +Theorem compile_Return: + ^(get_goal "loopLang$Return") +Proof + rpt strip_tac >> + fs [loopSemTheory.evaluate_def, comp_def, evaluate_def] >> + cases_on ‘lookup n s.locals’ >> + fs [] >> rveq >> + TOP_CASE_TAC >> + fs [find_var_def, locals_rel_def, get_var_def] >> + res_tac >> rveq >> + TOP_CASE_TAC >> fs [isWord_def] >> + fs [flush_state_def, state_rel_def, + loopSemTheory.call_env_def] +QED + + +Theorem compile_Raise: + ^(get_goal "loopLang$Raise") +Proof + fs [comp_def,loopSemTheory.evaluate_def,CaseEq"option"] >> + rw [] >> fs [evaluate_def] >> + imp_res_tac locals_rel_get_var >> fs [] >> + Cases_on ‘jump_exc t’ >> fs [] + >- fs [jump_exc_def, state_rel_def, loopSemTheory.call_env_def] >> + fs [CaseEq"prod",PULL_EXISTS] >> + PairCases_on ‘x’ >> fs [loopSemTheory.call_env_def] >> + pop_assum mp_tac >> + fs [CaseEq"option",CaseEq"prod", jump_exc_def, + CaseEq"stack_frame", CaseEq"list"] >> + strip_tac >> fs [] >> rveq >> fs [] >> + fs [state_rel_def] +QED + + +Theorem compile_Seq: + ^(get_goal "comp _ (loopLang$Seq _ _)") +Proof + rpt strip_tac >> + fs [loopSemTheory.evaluate_def] >> + pairarg_tac >> fs [comp_def] >> + rpt (pairarg_tac >> fs []) >> + fs [evaluate_def] >> + rpt (pairarg_tac >> fs []) >> + first_x_assum (qspecl_then [‘t’,‘ctxt’,‘retv’,‘l’] mp_tac) >> + impl_tac + >- ( + fs [] >> + conj_tac >- (CCONTR_TAC >> fs []) >> + fs [no_Loops_def, no_Loop_def, every_prog_def] >> + qpat_x_assum ‘_ ⊆ domain ctxt’ mp_tac >> + fs [loopLangTheory.acc_vars_def] >> + once_rewrite_tac [acc_vars_acc] >> fs []) >> + fs [] >> strip_tac >> + reverse (Cases_on ‘res'’) >> fs [] >> rveq >> fs [] + >- ( + Cases_on ‘x’ >> fs [] >> + IF_CASES_TAC >> fs []) >> + rename [‘state_rel s2 t2’] >> + first_x_assum drule >> + rpt (disch_then drule) >> + disch_then (qspec_then ‘l'’ mp_tac) >> + impl_tac + >- ( + qpat_x_assum ‘_ ⊆ domain ctxt’ mp_tac >> + fs [no_Loops_def, no_Loop_def, every_prog_def] >> + fs [loopLangTheory.acc_vars_def] >> + once_rewrite_tac [acc_vars_acc] >> fs []) >> + fs [] >> strip_tac >> fs [] >> + Cases_on ‘res’ >> fs [] >> + Cases_on ‘x’ >> fs [] +QED + +Theorem compile_Assign: + ^(get_goal "loopLang$Assign") ∧ + ^(get_goal "loopLang$LocValue") +Proof + rpt strip_tac >> + fs [loopSemTheory.evaluate_def, + comp_def, evaluate_def] + >- ( + cases_on ‘eval s exp’ >> fs [] >> + rveq >> fs [] >> + imp_res_tac comp_exp_preserves_eval >> + fs [loopSemTheory.set_var_def, set_var_def] >> + conj_tac >- fs [state_rel_def] >> + conj_tac + >- ( + fs [lookup_insert, CaseEq "bool", loopLangTheory.acc_vars_def] >> + imp_res_tac find_var_neq_0 >> fs []) >> + match_mp_tac locals_rel_insert >> + fs [loopLangTheory.acc_vars_def]) >> + fs [CaseEq "bool"] >> rveq >> fs [] >> + fs [loopSemTheory.set_var_def, set_var_def] >> + conj_tac + >- ( + fs [state_rel_def, + code_rel_def,domain_lookup,EXISTS_PROD] >> + metis_tac []) >> + conj_tac >- fs [state_rel_def] >> + conj_tac + >- ( + fs [lookup_insert, CaseEq "bool", loopLangTheory.acc_vars_def] >> + imp_res_tac find_var_neq_0 >> fs []) >> + match_mp_tac locals_rel_insert >> + fs [loopLangTheory.acc_vars_def] +QED + +Theorem compile_Store: + ^(get_goal "loopLang$Store") ∧ + ^(get_goal "loopLang$StoreByte") +Proof + rpt strip_tac >> + fs [loopSemTheory.evaluate_def, + comp_def, evaluate_def] + >- ( + fs [CaseEq "option", CaseEq "word_loc"] >> rveq >> + imp_res_tac comp_exp_preserves_eval >> + fs [] >> + drule_all locals_rel_get_var >> + strip_tac >> fs [] >> + fs [loopSemTheory.mem_store_def, mem_store_def] >> + rveq >> fs [state_rel_def]) >> + fs [CaseEq "option", CaseEq "word_loc"] >> rveq >> + fs [inst_def, word_exp_def] >> + drule locals_rel_intro >> + strip_tac >> + res_tac >> fs [] >> + fs [find_var_def, the_words_def, word_op_def] >> + fs [get_var_def] >> + fs [state_rel_def] +QED + +Theorem compile_LoadByte: + ^(get_goal "loopLang$LoadByte") +Proof + rpt strip_tac >> + fs [loopSemTheory.evaluate_def, + comp_def, evaluate_def] >> + fs [CaseEq "option", CaseEq "word_loc"] >> rveq >> + fs [inst_def, word_exp_def] >> + drule locals_rel_intro >> + strip_tac >> + res_tac >> fs [] >> + fs [find_var_def, the_words_def, word_op_def] >> + drule state_rel_intro >> + strip_tac >> fs [] >> + fs [loopSemTheory.set_var_def, set_var_def] >> + conj_tac >- fs [state_rel_def] >> + fs [loopLangTheory.acc_vars_def] >> + imp_res_tac find_var_neq_0 >> + fs [domain_lookup, lookup_insert, CaseEq "bool"] >> + conj_tac + >- (CCONTR_TAC >> res_tac >> fs []) >> + drule locals_rel_insert >> + disch_then (qspecl_then [‘Word (w2w b)’, ‘v’] mp_tac) >> + fs [domain_lookup, find_var_def] +QED + +Theorem compile_SetGlobal: + ^(get_goal "loopLang$SetGlobal") +Proof + rpt strip_tac >> + fs [loopSemTheory.evaluate_def, + comp_def, evaluate_def] >> + fs [CaseEq "option"] >> + rveq >> fs [] >> + imp_res_tac comp_exp_preserves_eval >> + fs [] >> + fs [state_rel_def, set_store_def, + loopSemTheory.set_globals_def, globals_rel_def] >> + rw [FLOOKUP_UPDATE] +QED + +Theorem compile_If: + ^(get_goal "loopLang$If") +Proof + rpt strip_tac >> + fs [loopSemTheory.evaluate_def, comp_def] >> + fs [CaseEq "option", CaseEq "word_loc"] >> + rveq >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + fs [evaluate_def] >> + fs [find_var_def, get_var_def] >> + imp_res_tac locals_rel_intro >> fs [] >> + cases_on ‘ri’ >> + fs [loopSemTheory.get_var_imm_def] >> + fs [find_reg_imm_def, get_var_imm_def] >> + fs [find_var_def, get_var_def] >> + imp_res_tac locals_rel_intro >> fs [] >> rveq >> + pairarg_tac >> fs [] >> + rename [‘word_cmp cmp x cy’] >> ( + cases_on ‘word_cmp cmp x cy’ >> fs [] >> + rename [‘cut_res live_out (evaluate (cc,s)) = _’] >> + qpat_x_assum ‘comp _ cc _ = _’ mp_tac >> + qmatch_goalsub_rename_tac ‘comp _ cc cl = _’ >> + strip_tac >> ( + cases_on ‘evaluate (cc,s)’ >> + cases_on ‘q’ >> TRY (cases_on ‘x'’) >> + fs [loopSemTheory.cut_res_def, + loopSemTheory.cut_state_def] >> rveq >> fs [] >> + TRY ( + last_x_assum drule >> + disch_then (qspecl_then [‘ctxt’, ‘retv’, ‘cl’] mp_tac) >> + fs [] >> + impl_tac + >- ( + fs [loopLangTheory.acc_vars_def, no_Loops_def, no_Loop_def, + every_prog_def] >> + qpat_x_assum ‘_ ⊆ domain ctxt’ mp_tac >> + once_rewrite_tac [acc_vars_acc] >> + fs []) >> + fs [] >> strip_tac >> + fs [state_rel_def, flush_state_def, loopSemTheory.dec_clock_def, + dec_clock_def] >> NO_TAC) + >- ( + cases_on ‘domain live_out ⊆ domain r.locals’ >> fs [] >> + cases_on ‘r.clock = 0’ >> fs [] >> rveq >> fs [] >> ( + last_x_assum drule >> + disch_then (qspecl_then [‘ctxt’, ‘retv’, ‘cl’] mp_tac) >> + fs [] >> + impl_tac + >- ( + fs [loopLangTheory.acc_vars_def, no_Loops_def, no_Loop_def, + every_prog_def] >> + qpat_x_assum ‘_ ⊆ domain ctxt’ mp_tac >> + once_rewrite_tac [acc_vars_acc] >> + fs []) >> + fs [] >> strip_tac >> + fs [state_rel_def, flush_state_def, loopSemTheory.dec_clock_def, + dec_clock_def] >> + TRY ( + fs [locals_rel_def] >> rw [] >> + fs [lookup_inter, CaseEq "option"]))) + >- ( + last_x_assum drule >> + disch_then (qspecl_then [‘ctxt’, ‘retv’, ‘cl’] mp_tac) >> + fs [] >> + impl_tac + >- ( + fs [loopLangTheory.acc_vars_def, no_Loops_def, no_Loop_def, + every_prog_def] >> + qpat_x_assum ‘_ ⊆ domain ctxt’ mp_tac >> + once_rewrite_tac [acc_vars_acc] >> + fs []) >> + fs [] >> strip_tac >> + cases_on ‘res' = SOME Error’ >> + fs [] >> rw [] >> fs []) >> + last_x_assum (qspecl_then [‘t’, ‘ctxt’, ‘retv’] mp_tac) >> + fs [] >> CCONTR_TAC >> fs [] >> + fs [no_Loops_def, no_Loop_def, loopLangTheory.acc_vars_def, every_prog_def] >> + TRY (metis_tac []) >> + qpat_x_assum ‘_ ⊆ domain ctxt’ mp_tac >> + simp [Once acc_vars_acc])) +QED + +Theorem compile_Call: + ^(get_goal "comp _ (loopLang$Call _ _ _ _)") +Proof + rw [] >> qpat_x_assum ‘evaluate _ = (res,_)’ mp_tac >> simp [loopSemTheory.evaluate_def] + >> simp [CaseEq"option"] + >> strip_tac >> fs [] + >> rename [‘find_code _ _ _ = SOME x’] + >> PairCases_on ‘x’ >> fs [] + >> rename [‘find_code _ _ _ = SOME (new_env,new_code)’] + >> ‘~bad_dest_args dest (MAP (find_var ctxt) argvars)’ by + (pop_assum kall_tac >> Cases_on ‘dest’ >> fs [bad_dest_args_def] + >> fs [loopSemTheory.find_code_def] + >> imp_res_tac locals_rel_get_vars >> CCONTR_TAC >> fs []) + >> Cases_on ‘ret’ >> fs [] + >- + (fs [comp_def,evaluate_def] + >> imp_res_tac locals_rel_get_vars >> fs [add_ret_loc_def] + >> fs [get_vars_def,get_var_def] + >> simp [bad_dest_args_def,call_env_def,dec_clock_def] + >> ‘∃args1 prog1 ss1 name1 ctxt1 l1. + find_code dest (retv::argvals) t.code t.stack_size = SOME (args1,prog1,ss1) ∧ + FST (comp ctxt1 new_code l1) = prog1 ∧ + lookup 0 (fromList2 args1) = SOME retv ∧ + locals_rel ctxt1 new_env (fromList2 args1) ∧ no_Loops new_code ∧ + domain (acc_vars new_code LN) ⊆ domain ctxt1’ by + (qpat_x_assum ‘_ = (res,_)’ kall_tac + >> Cases_on ‘dest’ >> fs [loopSemTheory.find_code_def] + >- + (fs [CaseEq"word_loc",CaseEq"num",CaseEq"option",CaseEq"prod",CaseEq"bool"] + >> rveq >> fs [code_rel_def,state_rel_def] + >> first_x_assum drule >> strip_tac >> fs [] + >> fs [find_code_def] + >> ‘∃x l. argvals = SNOC x l’ by metis_tac [SNOC_CASES] + >> qpat_x_assum ‘_ = Loc loc 0’ mp_tac + >> rveq >> rewrite_tac [GSYM SNOC,LAST_SNOC,FRONT_SNOC] >> fs [] + >> strip_tac >> rveq >> fs [] + >> simp [comp_func_def] + >> qmatch_goalsub_abbrev_tac ‘comp ctxt2 _ ll2’ + >> qexists_tac ‘ctxt2’ >> qexists_tac ‘ll2’ >> fs [] + >> conj_tac >- fs [lookup_fromList2,lookup_fromList] + >> simp [Abbr‘ctxt2’,domain_make_ctxt,set_fromNumSet, + domain_difference,domain_toNumSet, SUBSET_DEF] + >> match_mp_tac locals_rel_make_ctxt + >> fs [IN_DISJOINT,set_fromNumSet,domain_difference, + domain_toNumSet,GSYM IMP_DISJ_THM]) + >> fs [CaseEq"word_loc",CaseEq"num",CaseEq"option",CaseEq"prod",CaseEq"bool"] + >> rveq >> fs [code_rel_def,state_rel_def] + >> first_x_assum drule >> strip_tac >> fs [] + >> fs [find_code_def] + >> simp [comp_func_def] + >> qmatch_goalsub_abbrev_tac ‘comp ctxt2 _ ll2’ + >> qexists_tac ‘ctxt2’ >> qexists_tac ‘ll2’ >> fs [] + >> conj_tac >- fs [lookup_fromList2,lookup_fromList] + >> simp [Abbr‘ctxt2’,domain_make_ctxt,set_fromNumSet, + domain_difference,domain_toNumSet, SUBSET_DEF] + >> match_mp_tac locals_rel_make_ctxt + >> fs [IN_DISJOINT,set_fromNumSet,domain_difference, + domain_toNumSet,GSYM IMP_DISJ_THM]) + >> fs [] >> imp_res_tac state_rel_IMP + >> fs [] >> IF_CASES_TAC >> fs [] + >- + (fs [CaseEq"bool"] >> rveq >> fs [] + >> fs [state_rel_def,flush_state_def]) + >> Cases_on ‘handler = NONE’ >> fs [] >> rveq + >> Cases_on ‘evaluate (new_code,dec_clock s with locals := new_env)’ >> fs [] + >> Cases_on ‘q’ >> fs [] + >> Cases_on ‘x = Error’ >> rveq >> fs [] + >> qmatch_goalsub_abbrev_tac ‘wordSem$evaluate (_,tt)’ + >> first_x_assum (qspecl_then [‘tt’,‘ctxt1’,‘retv’,‘l1’] mp_tac) + >> impl_tac + >- (fs [Abbr‘tt’] >> fs [state_rel_def,loopSemTheory.dec_clock_def]) + >> strip_tac >> fs [] + >> Cases_on ‘x’ >> fs [] >> rveq >> fs [] + >- fs [Abbr‘tt’] + >> qexists_tac ‘t1’ >> fs [] + >> qexists_tac ‘res1’ >> fs [] + >> conj_tac >- (Cases_on ‘res1’ >> simp [CaseEq"option"] >> fs []) + >> rpt gen_tac >> strip_tac >> pop_assum mp_tac + >> qunabbrev_tac ‘tt’ >> fs []) + >> fs [comp_def,evaluate_def] + >> imp_res_tac locals_rel_get_vars >> fs [add_ret_loc_def] + >> fs [get_vars_def,get_var_def] + >> simp [bad_dest_args_def,call_env_def,dec_clock_def] + >> PairCases_on ‘x’ >> PairCases_on ‘l’ + >> fs [] >> imp_res_tac state_rel_IMP + >> ‘∃args1 prog1 ss1 name1 ctxt1 l2. + find_code dest (Loc l0 l1::argvals) t.code t.stack_size = SOME (args1,prog1,ss1) ∧ + FST (comp ctxt1 new_code l2) = prog1 ∧ + lookup 0 (fromList2 args1) = SOME (Loc l0 l1) ∧ + locals_rel ctxt1 new_env (fromList2 args1) ∧ no_Loops new_code ∧ + domain (acc_vars new_code LN) ⊆ domain ctxt1’ by + (qpat_x_assum ‘_ = (res,_)’ kall_tac + >> rpt (qpat_x_assum ‘∀x. _’ kall_tac) + >> Cases_on ‘dest’ >> fs [loopSemTheory.find_code_def] + >- + (fs [CaseEq"word_loc",CaseEq"num",CaseEq"option",CaseEq"prod",CaseEq"bool"] + >> rveq >> fs [code_rel_def,state_rel_def] + >> first_x_assum drule >> strip_tac >> fs [] + >> fs [find_code_def] + >> ‘∃x l. argvals = SNOC x l’ by metis_tac [SNOC_CASES] + >> qpat_x_assum ‘_ = Loc loc 0’ mp_tac + >> rveq >> rewrite_tac [GSYM SNOC,LAST_SNOC,FRONT_SNOC] >> fs [] + >> strip_tac >> rveq >> fs [] + >> simp [comp_func_def] + >> qmatch_goalsub_abbrev_tac ‘comp ctxt2 _ ll2’ + >> qexists_tac ‘ctxt2’ >> qexists_tac ‘ll2’ >> fs [] + >> conj_tac >- fs [lookup_fromList2,lookup_fromList] + >> simp [Abbr‘ctxt2’,domain_make_ctxt,set_fromNumSet, + domain_difference,domain_toNumSet, SUBSET_DEF] + >> match_mp_tac locals_rel_make_ctxt + >> fs [IN_DISJOINT,set_fromNumSet,domain_difference, + domain_toNumSet,GSYM IMP_DISJ_THM]) + >> fs [CaseEq"word_loc",CaseEq"num",CaseEq"option",CaseEq"prod",CaseEq"bool"] + >> rveq >> fs [code_rel_def,state_rel_def] + >> first_x_assum drule >> strip_tac >> fs [] + >> fs [find_code_def] + >> simp [comp_func_def] + >> qmatch_goalsub_abbrev_tac ‘comp ctxt2 _ ll2’ + >> qexists_tac ‘ctxt2’ >> qexists_tac ‘ll2’ >> fs [] + >> conj_tac >- fs [lookup_fromList2,lookup_fromList] + >> simp [Abbr‘ctxt2’,domain_make_ctxt,set_fromNumSet, + domain_difference,domain_toNumSet, SUBSET_DEF] + >> match_mp_tac locals_rel_make_ctxt + >> fs [IN_DISJOINT,set_fromNumSet,domain_difference, + domain_toNumSet,GSYM IMP_DISJ_THM]) + >> Cases_on ‘handler’ >> fs [] + >- + (fs [evaluate_def,add_ret_loc_def,domain_mk_new_cutset_not_empty,cut_res_def] + >> fs [loopSemTheory.cut_state_def] + >> Cases_on ‘domain x1 ⊆ domain s.locals’ >> fs [] + >> qpat_x_assum ‘locals_rel _ s.locals _’ assume_tac + >> drule cut_env_mk_new_cutset + >> rpt (disch_then drule) >> strip_tac >> fs [] + >> (IF_CASES_TAC >> fs [] >- (rveq >> fs [flush_state_def,state_rel_def])) + >> fs [CaseEq"prod",CaseEq"option"] >> fs [] >> rveq >> fs [] + >> rename [‘_ = (SOME res2,st)’] + >> qmatch_goalsub_abbrev_tac ‘wordSem$evaluate (_,tt)’ + >> fs [PULL_EXISTS] + >> Cases_on ‘res2 = Error’ >> fs [] + >> first_x_assum (qspecl_then [‘tt’,‘ctxt1’,‘Loc l0 l1’,‘l2’] mp_tac) + >> (impl_tac >- + (fs [Abbr‘tt’,call_env_def,push_env_def,isWord_def] + >> pairarg_tac >> fs [dec_clock_def,loopSemTheory.dec_clock_def,state_rel_def])) + >> strip_tac >> fs [] + >> Cases_on ‘res2’ >> fs [] >> rveq >> fs [] + >- + (fs [Abbr‘tt’,call_env_def,push_env_def,dec_clock_def] + >> pairarg_tac >> fs [pop_env_def,set_var_def] + >> imp_res_tac env_to_list_IMP + >> fs [loopSemTheory.set_var_def,loopSemTheory.dec_clock_def] + >> fs [state_rel_def] + >> rename [‘find_var ctxt var_name’] + >> ‘var_name IN domain ctxt’ by fs [loopLangTheory.acc_vars_def] + >> simp [lookup_insert] + >> imp_res_tac find_var_neq_0 >> fs [] + >> imp_res_tac cut_env_mk_new_cutset_IMP >> fs [] + >> match_mp_tac locals_rel_insert >> fs [] + >> fs [locals_rel_def]) + >> qunabbrev_tac ‘tt’ + >> pop_assum mp_tac + >> Cases_on ‘res1’ >- fs [] + >> disch_then (fn th => assume_tac (REWRITE_RULE [IMP_DISJ_THM] th)) + >> fs [] >> Cases_on ‘x’ >> fs [] + >> fs [state_rel_def] + >> fs [call_env_def,push_env_def] >> pairarg_tac >> fs [dec_clock_def] + >> fs [jump_exc_def,NOT_LESS] + >> Cases_on ‘LENGTH t.stack <= t.handler’ >> fs [LASTN_ADD_CONS] + >> simp [CaseEq"option",CaseEq"prod",CaseEq"bool",set_var_def,CaseEq"list", + CaseEq"stack_frame"] >> rw [] >> fs []) + >> PairCases_on ‘x’ >> fs [] + >> rpt (pairarg_tac >> fs []) + >> fs [evaluate_def,add_ret_loc_def,domain_mk_new_cutset_not_empty,cut_res_def] + >> fs [loopSemTheory.cut_state_def] + >> Cases_on ‘domain x1 ⊆ domain s.locals’ >> fs [] + >> qpat_x_assum ‘locals_rel _ s.locals _’ assume_tac + >> drule cut_env_mk_new_cutset + >> rpt (disch_then drule) >> strip_tac >> fs [] + >> (IF_CASES_TAC >> fs [] >- (rveq >> fs [flush_state_def,state_rel_def])) + >> fs [CaseEq"prod",CaseEq"option"] >> fs [] >> rveq >> fs [] + >> rename [‘_ = (SOME res2,st)’] + >> qmatch_goalsub_abbrev_tac ‘wordSem$evaluate (_,tt)’ + >> fs [PULL_EXISTS] + >> Cases_on ‘res2 = Error’ >> fs [] + >> first_x_assum (qspecl_then [‘tt’,‘ctxt1’,‘Loc l0 l1’,‘l2’] mp_tac) + >> (impl_tac >- + (fs [Abbr‘tt’] >> rename [‘SOME (find_var _ _,p1,l8)’] + >> PairCases_on ‘l8’ >> fs [call_env_def,push_env_def,isWord_def] + >> pairarg_tac >> fs [dec_clock_def,loopSemTheory.dec_clock_def,state_rel_def])) + >> strip_tac >> fs [] + >> Cases_on ‘res2’ >> fs [] >> rveq >> fs [] + >> fs [loopSemTheory.dec_clock_def] + >- + (rename [‘loopSem$set_var hvar w _’] + >> Cases_on ‘evaluate (x2,set_var hvar w (st with locals := inter s.locals x1))’ + >> fs [] + >> Cases_on ‘q = SOME Error’ >- fs [cut_res_def] >> fs [] + >> fs [pop_env_def,Abbr‘tt’] >> fs [call_env_def,push_env_def] + >> rename [‘SOME (find_var _ _,p1,l8)’] + >> PairCases_on ‘l8’ >> fs [call_env_def,push_env_def] + >> pairarg_tac >> fs [dec_clock_def,loopSemTheory.dec_clock_def] + >> pop_assum mp_tac + >> pairarg_tac >> fs [dec_clock_def,loopSemTheory.dec_clock_def] + >> reverse IF_CASES_TAC >- (imp_res_tac env_to_list_IMP >> fs []) + >> strip_tac >> fs [] >> pop_assum mp_tac >> fs [set_var_def] + >> fs [cut_res_def] + >> qmatch_goalsub_abbrev_tac ‘wordSem$evaluate (_,tt)’ >> strip_tac + >> first_x_assum (qspecl_then [‘tt’,‘ctxt’,‘retv’,‘l1'’] mp_tac) + >> impl_tac >- + (fs [loopSemTheory.set_var_def,state_rel_def,Abbr‘tt’] + >> qpat_x_assum ‘_ SUBSET domain ctxt’ mp_tac + >> simp [loopLangTheory.acc_vars_def] + >> once_rewrite_tac [acc_vars_acc] + >> once_rewrite_tac [acc_vars_acc] >> fs [] >> strip_tac + >> qpat_x_assum ‘no_Loops (Call _ _ _ _)’ mp_tac + >> simp [no_Loops_def,every_prog_def,no_Loop_def] >> strip_tac + >> imp_res_tac env_to_list_IMP >> fs [] + >> fs [lookup_insert] + >> imp_res_tac find_var_neq_0 >> fs [] + >> imp_res_tac cut_env_mk_new_cutset_IMP >> fs [] + >> match_mp_tac locals_rel_insert >> fs [locals_rel_def]) + >> fs [] >> strip_tac + >> Cases_on ‘q’ >> fs [] >> rveq >> fs [] + >- + (rename [‘cut_state names s9’] + >> fs [loopSemTheory.cut_state_def] + >> Cases_on ‘domain names ⊆ domain s9.locals’ >> fs [] + >> imp_res_tac state_rel_IMP >> fs [] + >> IF_CASES_TAC + >> fs [flush_state_def] >> rveq >> fs [] >> fs [state_rel_def,dec_clock_def] + >> fs [loopSemTheory.dec_clock_def,Abbr‘tt’] + >> fs [locals_rel_def,lookup_inter_alt]) + >> Cases_on ‘x’ >> fs [] + >- fs [Abbr‘tt’] + >> pop_assum mp_tac >> rewrite_tac [IMP_DISJ_THM] + >> IF_CASES_TAC >> fs [] + >> fs [Abbr‘tt’] >> metis_tac []) + >> qpat_x_assum ‘∀x. _’ (assume_tac o REWRITE_RULE [IMP_DISJ_THM]) + >> rename [‘loopSem$set_var hvar w _’] + >> Cases_on ‘evaluate (x1',set_var hvar w (st with locals := inter s.locals x1))’ + >> fs [] + >> Cases_on ‘q = SOME Error’ >- fs [cut_res_def] >> fs [] + >> fs [pop_env_def,Abbr‘tt’] >> fs [call_env_def,push_env_def] + >> rename [‘SOME (find_var _ _,p1,l8)’] + >> PairCases_on ‘l8’ >> fs [call_env_def,push_env_def] + >> pairarg_tac >> fs [dec_clock_def,loopSemTheory.dec_clock_def] + >> pop_assum mp_tac + >> pairarg_tac >> fs [dec_clock_def,loopSemTheory.dec_clock_def] + >> Cases_on ‘res1’ >> fs [] >> rveq >> fs [] + >> qpat_x_assum ‘∀x. _’ mp_tac + >> simp [jump_exc_def] + >> qmatch_goalsub_abbrev_tac ‘LASTN n1 xs1’ + >> ‘LASTN n1 xs1 = xs1’ by + (qsuff_tac ‘n1 = LENGTH xs1’ >> fs [LASTN_LENGTH_ID] + >> unabbrev_all_tac >> fs []) + >> fs [] >> fs [Abbr‘n1’,Abbr‘xs1’] >> strip_tac >> rveq >> fs [] + >> ‘t1.locals = fromAList l ∧ + t1.stack = t.stack ∧ t1.handler = t.handler’ by fs [state_component_equality] + >> reverse IF_CASES_TAC >- (imp_res_tac env_to_list_IMP >> fs [] >> rfs []) + >> strip_tac >> fs [] + >> pop_assum mp_tac >> fs [set_var_def] + >> fs [cut_res_def] + >> qmatch_goalsub_abbrev_tac ‘wordSem$evaluate (_,tt)’ >> strip_tac + >> first_x_assum (qspecl_then [‘tt’,‘ctxt’,‘retv’,‘(l0,l1 + 1)’] mp_tac) + >> impl_tac >- + (fs [loopSemTheory.set_var_def,state_rel_def,Abbr‘tt’] + >> qpat_x_assum ‘_ SUBSET domain ctxt’ mp_tac + >> simp [loopLangTheory.acc_vars_def] + >> once_rewrite_tac [acc_vars_acc] + >> once_rewrite_tac [acc_vars_acc] >> fs [] >> strip_tac + >> qpat_x_assum ‘no_Loops (Call _ _ _ _)’ mp_tac + >> simp [no_Loops_def,every_prog_def,no_Loop_def] >> strip_tac + >> imp_res_tac env_to_list_IMP >> fs [] + >> fs [lookup_insert] + >> imp_res_tac find_var_neq_0 >> fs [] + >> imp_res_tac cut_env_mk_new_cutset_IMP >> fs [] + >> match_mp_tac locals_rel_insert >> fs [locals_rel_def]) + >> fs [] >> strip_tac + >> Cases_on ‘q’ >> fs [] >> rveq >> fs [] + >- + (rename [‘cut_state names s9’] + >> fs [loopSemTheory.cut_state_def] + >> Cases_on ‘domain names ⊆ domain s9.locals’ >> fs [] + >> imp_res_tac state_rel_IMP >> fs [] + >> IF_CASES_TAC + >> fs [flush_state_def] >> rveq >> fs [] >> fs [state_rel_def,dec_clock_def] + >> fs [loopSemTheory.dec_clock_def,Abbr‘tt’] + >> fs [locals_rel_def,lookup_inter_alt]) + >> pop_assum (assume_tac o REWRITE_RULE [IMP_DISJ_THM]) + >> Cases_on ‘x’ >> fs [] + >- fs [Abbr‘tt’] + >> rveq >> fs [] + >> pop_assum mp_tac + >> fs [Abbr‘tt’,jump_exc_def] + >> metis_tac [] +QED + +Theorem compile_FFI: + ^(get_goal "loopLang$FFI") +Proof + rpt strip_tac >> + fs [loopSemTheory.evaluate_def, + comp_def, evaluate_def] >> + fs [CaseEq "option", CaseEq "word_loc"] >> + rveq >> fs [] >> + fs [find_var_def, get_var_def] >> + imp_res_tac state_rel_intro >> + imp_res_tac locals_rel_intro >> + res_tac >> fs [] >> + fs [loopSemTheory.cut_state_def] >> rveq >> + drule_all cut_env_mk_new_cutset >> + strip_tac >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + fs [state_rel_def, flush_state_def, + loopSemTheory.call_env_def] >> + fs [cut_env_def] >> + rveq >> fs [] >> + fs [lookup_inter] >> + TOP_CASE_TAC >> + fs [mk_new_cutset_def] +QED + +Theorem compile_correct: + ^(compile_correct_tm()) +Proof + match_mp_tac (the_ind_thm()) + >> EVERY (map strip_assume_tac [compile_Skip, compile_Raise, + compile_Mark, compile_Return, compile_Assign, compile_Store, + compile_SetGlobal, compile_Call, compile_Seq, compile_If, + compile_FFI, compile_Loop, compile_LoadByte]) + >> asm_rewrite_tac [] >> rw [] >> rpt (pop_assum kall_tac) +QED + +Theorem state_rel_with_clock: + state_rel s t ==> + state_rel (s with clock := k) (t with clock := k) +Proof + rw [] >> + fs [state_rel_def] +QED + +Theorem locals_rel_mk_ctxt_ln: + 0 < n ==> + locals_rel (make_ctxt n xs LN) LN lc +Proof + rw [locals_rel_def] + >- ( + rw [INJ_DEF] >> + fs [find_var_def, domain_lookup] >> + rfs [] >> rveq >> + imp_res_tac (MP_CANON make_ctxt_inj) >> + rfs [lookup_def]) + >- ( + CCONTR_TAC >> fs [] >> + drule lookup_make_ctxt_range >> + fs [lookup_def]) >> + fs [lookup_def] +QED + +(* + initialising the compiler correctness theorem for a labeled call with + zero arguments and no exception handler +*) +val comp_Call = + compile_correct |> Q.SPEC ‘Call NONE (SOME start) [] NONE’ + +(* druling th by first rewriting it into AND_IMP_INTRO *) +fun drule0 th = + first_assum (mp_tac o MATCH_MP (ONCE_REWRITE_RULE[GSYM AND_IMP_INTRO] th)) + +Theorem state_rel_imp_semantics: + !s t start prog. state_rel s t ∧ + isEmpty s.locals /\ + lookup 0 t.locals = SOME (Loc 1 0) (* for the returning code *) /\ + (∃prog. lookup start s.code = SOME ([], prog)) /\ + semantics s start <> Fail ==> + semantics t start = semantics s start +Proof + rw [] >> + ‘code_rel s.code t.code’ by + fs [state_rel_def] >> + drule code_rel_intro >> + disch_then (qspecl_then [‘start’, ‘[]’, ‘prog’] mp_tac) >> + fs [] >> + strip_tac >> + fs [comp_func_def] >> + qmatch_asmsub_abbrev_tac ‘comp ctxt _ _’ >> + reverse (Cases_on ‘semantics s start’) >> fs [] + >- ( + (* Termination case of loop semantics *) + fs [loopSemTheory.semantics_def] >> + pop_assum mp_tac >> + IF_CASES_TAC >> fs [] >> + DEEP_INTRO_TAC some_intro >> simp[] >> + rw [] >> + rw [wordSemTheory.semantics_def] + >- ( + (* the fail case of word semantics *) + qhdtm_x_assum ‘loopSem$evaluate’ kall_tac >> + last_x_assum(qspec_then ‘k'’ mp_tac) >> simp[] >> + (fn g => subterm (fn tm => Cases_on ‘^(assert(has_pair_type)tm)’) (#2 g) g) >> + CCONTR_TAC >> + drule0 comp_Call >> fs[] >> + drule0(GEN_ALL state_rel_with_clock) >> + disch_then(qspec_then ‘k'’ strip_assume_tac) >> + map_every qexists_tac [‘t with clock := k'’] >> + qexists_tac ‘ctxt’ >> + fs [] >> + (* what is l in comp, what is new_l in the comp for Call, + understand how comp for Call works, its only updated for the + return call, in the tail call the same l is passed along *) + Ho_Rewrite.PURE_REWRITE_TAC[GSYM PULL_EXISTS] >> + conj_tac + >- ( + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + conj_tac + >- ( + fs [Abbr ‘ctxt’] >> + match_mp_tac locals_rel_mk_ctxt_ln >> + fs []) >> + conj_tac + >- ( + fs [no_Loops_def, no_Loop_def] >> + fs [every_prog_def]) >> + conj_tac >- fs [wordSemTheory.isWord_def] >> + conj_tac >- fs [loopLangTheory.acc_vars_def] >> + fs [comp_def] >> + (* casing on the evaluation results of loopLang *) + cases_on ‘r’ >> fs [] >> + cases_on ‘x’ >> fs [] >> rveq >> fs [] >> ( + cases_on ‘evaluate (Call NONE (SOME start) [0] NONE,t with clock := k')’ >> + fs [] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs [] >> + rveq >> fs [] >> + cases_on ‘q'’ >> fs [] >> + cases_on ‘x’ >> fs [])) >> + (* the termination/diverging case of word semantics *) + DEEP_INTRO_TAC some_intro >> simp[] >> + conj_tac + (* the termination case of word semantics *) + >- ( + rw [] >> fs [] >> + drule0 comp_Call >> + ‘r <> SOME Error’ by(CCONTR_TAC >> fs[]) >> + simp[] >> + drule0 (GEN_ALL state_rel_with_clock) >> simp[] >> + disch_then (qspec_then ‘k’ mp_tac) >> simp[] >> + strip_tac >> + disch_then drule >> + disch_then (qspec_then ‘ctxt’ mp_tac) >> + fs [] >> + Ho_Rewrite.PURE_REWRITE_TAC[GSYM PULL_FORALL] >> + impl_tac + >- ( + conj_tac + >- ( + fs [Abbr ‘ctxt’] >> + match_mp_tac locals_rel_mk_ctxt_ln >> + fs []) >> + conj_tac + >- ( + fs [no_Loops_def, no_Loop_def] >> + fs [every_prog_def]) >> + fs [wordSemTheory.isWord_def, loopLangTheory.acc_vars_def]) >> + fs [comp_def] >> + strip_tac >> + drule0 (GEN_ALL wordPropsTheory.evaluate_add_clock) >> + disch_then (qspec_then ‘k'’ mp_tac) >> + impl_tac + >- ( + CCONTR_TAC >> fs[] >> rveq >> fs[] >> every_case_tac >> fs[]) >> + qpat_x_assum ‘evaluate _ = (r', _)’ assume_tac >> + drule0 (GEN_ALL wordPropsTheory.evaluate_add_clock) >> + disch_then (qspec_then ‘k’ mp_tac) >> + impl_tac >- (CCONTR_TAC >> fs[]) >> + ntac 2 strip_tac >> fs[] >> rveq >> fs[] >> + Cases_on ‘r’ >> fs[] >> + Cases_on ‘r'’ >> fs [] >> + Cases_on ‘x’ >> fs [] >> rveq >> fs [] >> + fs [state_rel_def] >> + ‘t1.ffi = t''.ffi’ by + fs [wordSemTheory.state_accfupds, wordSemTheory.state_component_equality] >> + qpat_x_assum ‘t1.ffi = t'.ffi’ (assume_tac o GSYM) >> + fs []) >> + (* the diverging case of word semantics *) + rw[] >> fs[] >> CCONTR_TAC >> fs [] >> + drule0 comp_Call >> + ‘r ≠ SOME Error’ by ( + last_x_assum (qspec_then ‘k'’ mp_tac) >> simp[] >> + rw[] >> strip_tac >> fs[]) >> + simp [] >> + map_every qexists_tac [‘t with clock := k’] >> + drule0 (GEN_ALL state_rel_with_clock) >> + disch_then(qspec_then ‘k’ strip_assume_tac) >> + simp [] >> + qexists_tac ‘ctxt’ >> + Ho_Rewrite.PURE_REWRITE_TAC[GSYM PULL_EXISTS] >> + conj_tac + >- ( + fs [Abbr ‘ctxt’] >> + match_mp_tac locals_rel_mk_ctxt_ln >> + fs []) >> + conj_tac + >- ( + fs [no_Loops_def, no_Loop_def] >> + fs [every_prog_def]) >> + conj_tac >- fs [wordSemTheory.isWord_def] >> + conj_tac >- fs [loopLangTheory.acc_vars_def] >> + fs [comp_def] >> + CCONTR_TAC >> fs [] >> + first_x_assum (qspec_then ‘k’ mp_tac) >> simp[] >> + first_x_assum(qspec_then ‘k’ mp_tac) >> simp[] >> + every_case_tac >> fs[] >> rw[] >> rfs[]) >> + (* the diverging case of loop semantics *) + fs [loopSemTheory.semantics_def] >> + pop_assum mp_tac >> + IF_CASES_TAC >> fs [] >> + DEEP_INTRO_TAC some_intro >> simp[] >> + rw [] >> + rw [wordSemTheory.semantics_def] + >- ( + (* the fail case of word semantics *) + fs[] >> rveq >> fs[] >> + last_x_assum (qspec_then ‘k’ mp_tac) >> simp[] >> + (fn g => subterm (fn tm => Cases_on ‘^(assert(has_pair_type)tm)’) (#2 g) g) >> + CCONTR_TAC >> + drule0 comp_Call >> fs[] >> + drule0(GEN_ALL state_rel_with_clock) >> + disch_then (qspec_then ‘k’ strip_assume_tac) >> + map_every qexists_tac [‘t with clock := k’] >> + fs [] >> + qexists_tac ‘ctxt’ >> + Ho_Rewrite.PURE_REWRITE_TAC [GSYM PULL_EXISTS] >> + fs [] >> + conj_tac + >- ( + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + conj_tac + >- ( + fs [Abbr ‘ctxt’] >> + match_mp_tac locals_rel_mk_ctxt_ln >> + fs []) >> + conj_tac + >- ( + fs [no_Loops_def, no_Loop_def] >> + fs [every_prog_def]) >> + conj_tac >- fs [wordSemTheory.isWord_def] >> + conj_tac >- fs [loopLangTheory.acc_vars_def] >> + fs [comp_def] >> + CCONTR_TAC >> fs [] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + (* the termination/diverging case of word semantics *) + DEEP_INTRO_TAC some_intro >> simp[] >> + conj_tac + (* the termination case of word semantics *) + >- ( + rw [] >> fs[] >> + qpat_x_assum ‘∀x y. _’ (qspec_then ‘k’ mp_tac)>> + (fn g => subterm (fn tm => Cases_on ‘^(assert(has_pair_type)tm)’) (#2 g) g) >> + strip_tac >> + drule0 comp_Call >> fs [] >> + drule0(GEN_ALL state_rel_with_clock) >> + disch_then(qspec_then ‘k’ strip_assume_tac) >> + map_every qexists_tac [‘t with clock := k’] >> + fs [] >> + qexists_tac ‘ctxt’ >> + Ho_Rewrite.PURE_REWRITE_TAC [GSYM PULL_EXISTS] >> + fs [] >> + conj_tac + >- ( + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs [] >> + last_x_assum (qspec_then ‘k’ mp_tac) >> + fs []) >> + conj_tac + >- ( + fs [Abbr ‘ctxt’] >> + match_mp_tac locals_rel_mk_ctxt_ln >> + fs []) >> + conj_tac + >- ( + fs [no_Loops_def, no_Loop_def] >> + fs [every_prog_def]) >> + conj_tac >- fs [wordSemTheory.isWord_def] >> + conj_tac >- fs [loopLangTheory.acc_vars_def] >> + fs [comp_def] >> + CCONTR_TAC >> fs [] >> + first_x_assum(qspec_then ‘k’ mp_tac) >> + fsrw_tac[ARITH_ss][] >> + first_x_assum(qspec_then ‘k’ mp_tac) >> + fsrw_tac[ARITH_ss][] >> + every_case_tac >> fs[] >> rfs[] >> rw[]>> fs[]) >> + (* the diverging case of word semantics *) + rw [] >> + qmatch_abbrev_tac ‘build_lprefix_lub l1 = build_lprefix_lub l2’ >> + ‘(lprefix_chain l1 ∧ lprefix_chain l2) ∧ equiv_lprefix_chain l1 l2’ + suffices_by metis_tac[build_lprefix_lub_thm,lprefix_lub_new_chain,unique_lprefix_lub] >> + conj_asm1_tac + >- ( + UNABBREV_ALL_TAC >> + conj_tac >> + Ho_Rewrite.ONCE_REWRITE_TAC[GSYM o_DEF] >> + REWRITE_TAC[IMAGE_COMPOSE] >> + match_mp_tac prefix_chain_lprefix_chain >> + simp[prefix_chain_def,PULL_EXISTS] >> + qx_genl_tac [‘k1’, ‘k2’] >> + qspecl_then [‘k1’, ‘k2’] mp_tac LESS_EQ_CASES >> + simp[LESS_EQ_EXISTS] >> + rw [] >> + assume_tac (INST_TYPE [``:'a``|->``:'a``, + ``:'b``|->``:'b``] + loopPropsTheory.evaluate_add_clock_io_events_mono) >> + assume_tac (INST_TYPE [``:'a``|->``:'a``, + ``:'b``|->``:'c``, + ``:'c``|->``:'b``] + wordPropsTheory.evaluate_add_clock_io_events_mono) >> + first_assum (qspecl_then + [‘Call NONE (SOME start) [0] NONE’, ‘t with clock := k1’, ‘p’] mp_tac) >> + first_assum (qspecl_then + [‘Call NONE (SOME start) [0] NONE’, ‘t with clock := k2’, ‘p’] mp_tac) >> + first_assum (qspecl_then + [‘Call NONE (SOME start) [] NONE’, ‘s with clock := k1’, ‘p’] mp_tac) >> + first_assum (qspecl_then + [‘Call NONE (SOME start) [] NONE’, ‘s with clock := k2’, ‘p’] mp_tac) >> + fs []) >> + simp [equiv_lprefix_chain_thm] >> + fs [Abbr ‘l1’, Abbr ‘l2’] >> simp[PULL_EXISTS] >> + pop_assum kall_tac >> + simp[LNTH_fromList,PULL_EXISTS] >> + simp[GSYM FORALL_AND_THM] >> + rpt gen_tac >> + reverse conj_tac >> strip_tac + >- ( + qmatch_assum_abbrev_tac`n < LENGTH (_ (_ (SND p)))` >> + Cases_on`p` >> pop_assum(assume_tac o SYM o REWRITE_RULE[markerTheory.Abbrev_def]) >> + drule0 comp_Call >> + simp[GSYM AND_IMP_INTRO,RIGHT_FORALL_IMP_THM] >> + impl_tac + >- ( + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs [] >> + last_x_assum (qspec_then ‘k’ mp_tac) >> + fs []) >> + drule0(GEN_ALL state_rel_with_clock) >> + disch_then(qspec_then`k`strip_assume_tac) >> + disch_then drule0 >> + simp[] >> + disch_then (qspec_then ‘ctxt’ mp_tac) >> + impl_tac + >- ( + fs [Abbr ‘ctxt’] >> + match_mp_tac locals_rel_mk_ctxt_ln >> + fs []) >> + impl_tac + >- ( + fs [no_Loops_def, no_Loop_def] >> + fs [every_prog_def]) >> + impl_tac >- fs [wordSemTheory.isWord_def] >> + impl_tac >- fs [loopLangTheory.acc_vars_def] >> + fs [comp_def] >> + strip_tac >> + qexists_tac`k`>>simp[]>> + first_x_assum(qspec_then`k`mp_tac)>>simp[]>> + BasicProvers.TOP_CASE_TAC >> simp[] >> + fs [state_rel_def]) >> + (fn g => subterm (fn tm => Cases_on`^(Term.subst[{redex = #1(dest_exists(#2 g)), residue = ``k:num``}] + (assert(has_pair_type)tm))`) (#2 g) g) >> + drule0 comp_Call >> + simp[GSYM AND_IMP_INTRO,RIGHT_FORALL_IMP_THM] >> + impl_tac + >- ( + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs [] >> + last_x_assum (qspec_then ‘k’ mp_tac) >> + fs []) >> + drule0(GEN_ALL state_rel_with_clock) >> + disch_then(qspec_then`k`strip_assume_tac) >> + disch_then drule0 >> + simp[] >> + disch_then (qspec_then ‘ctxt’ mp_tac) >> + impl_tac + >- ( + fs [Abbr ‘ctxt’] >> + match_mp_tac locals_rel_mk_ctxt_ln >> + fs []) >> + impl_tac + >- ( + fs [no_Loops_def, no_Loop_def] >> + fs [every_prog_def]) >> + impl_tac >- fs [wordSemTheory.isWord_def] >> + impl_tac >- fs [loopLangTheory.acc_vars_def] >> + fs [comp_def] >> + strip_tac >> + qmatch_assum_abbrev_tac`n < LENGTH (SND (wordSem$evaluate (exps,ss))).ffi.io_events` >> + assume_tac (INST_TYPE [``:'a``|->``:'a``, + ``:'b``|->``:'c``, + ``:'c``|->``:'b``] + wordPropsTheory.evaluate_io_events_mono) >> + first_x_assum (qspecl_then + [‘Call NONE (SOME start) [0] NONE’, ‘t with clock := k’] mp_tac) >> + strip_tac >> fs [] >> + qexists_tac ‘k’ >> fs [] >> + fs [state_rel_def] +QED + +Definition st_rel_def: + st_rel s t prog <=> + let c = fromAList (loop_remove$comp_prog prog); + s' = s with code := c in + loop_removeProof$state_rel s s' ∧ + state_rel s' t /\ + code_rel c t.code +End + +Theorem st_rel_intro: + st_rel s t prog ==> + let c = fromAList (loop_remove$comp_prog prog); + s' = s with code := c in + loop_removeProof$state_rel s s' ∧ + state_rel s' t /\ + code_rel c t.code +Proof + rw [] >> + fs [st_rel_def] >> + metis_tac [] +QED + +Theorem first_compile_prog_all_distinct: + !prog. ALL_DISTINCT (MAP FST prog) ==> + ALL_DISTINCT (MAP FST (compile_prog prog)) +Proof + rw [] >> + fs [loop_to_wordTheory.compile_prog_def] >> + fs [MAP_MAP_o] >> + qmatch_goalsub_abbrev_tac ‘MAP ls _’ >> + ‘MAP ls prog = MAP FST prog’ by ( + fs [Abbr ‘ls’] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + cases_on ‘EL n prog’ >> fs [] >> + cases_on ‘r’ >> fs []) >> + fs [] +QED + +Theorem first_compile_all_distinct: + !prog. ALL_DISTINCT (MAP FST prog) ==> + ALL_DISTINCT (MAP FST (compile prog)) +Proof + rw [] >> + fs [compile_def] >> + match_mp_tac first_compile_prog_all_distinct >> + match_mp_tac first_comp_prog_all_distinct >> + fs [] +QED + +Theorem mem_prog_mem_compile_prog: + !prog name params body. + MEM (name,params,body) prog ==> + MEM (name,LENGTH params + 1,comp_func name params body) + (compile_prog prog) +Proof + rw [] >> + fs [MEM_EL] >> + qexists_tac ‘n’ >> + fs [compile_prog_def] >> + qmatch_goalsub_abbrev_tac ‘MAP ls _’ >> + ‘EL n (MAP ls prog) = ls (EL n prog)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [Abbr ‘ls’] >> + cases_on ‘EL n prog’ >> fs [] >> + cases_on ‘r’ >> fs [] +QED + +Theorem lookup_prog_some_lookup_compile_prog: + !prog name params body. lookup name (fromAList prog) = SOME (params,body) ==> + lookup name (fromAList (compile_prog prog)) = + SOME (LENGTH params + 1,comp_func name params body) +Proof + Induct >> rw [] + >- fs [compile_prog_def, fromAList_def, lookup_def] >> + fs [compile_prog_def] >> + cases_on ‘h’ >> fs [] >> + cases_on ‘r’ >> fs [] >> + fs [fromAList_def] >> + fs [lookup_insert] >> + TOP_CASE_TAC >> fs [] +QED + +Theorem fstate_rel_imp_semantics: + !s t loop_code start prog. + st_rel s t loop_code ∧ + isEmpty s.locals ∧ + s.code = fromAList loop_code ∧ + t.code = fromAList (loop_to_word$compile loop_code) ∧ + lookup 0 t.locals = SOME (Loc 1 0) (* for the returning code *) ∧ + lookup start s.code = SOME ([], prog) ∧ + semantics s start <> Fail ==> + semantics t start = semantics s start +Proof + rw [] >> + drule st_rel_intro >> + strip_tac >> fs [] >> + drule loop_removeProofTheory.state_rel_imp_semantics >> + disch_then (qspecl_then [‘start’, ‘loop_code’] mp_tac) >> + fs [] >> + strip_tac >> + pop_assum (assume_tac o GSYM) >> + fs [] >> + pop_assum kall_tac >> + drule state_rel_imp_semantics >> + disch_then (qspecl_then [‘start’] mp_tac) >> + (* might need to replace prog with something else *) + fs [] >> + fs [loop_removeProofTheory.state_rel_def] >> rveq >> + res_tac >> fs [] >> + cases_on ‘(comp (start,[],prog) init)’ >> + fs [has_code_def] >> + fs [loop_removeTheory.comp_def] >> + cases_on ‘(comp_with_loop (Fail,Fail) prog Fail init)’ >> + fs [] >> + cases_on ‘r'’ >> fs [] >> + rveq >> fs [EVERY_DEF] +QED + +val _ = export_theory(); diff --git a/pancake/proofs/pan_simpProofScript.sml b/pancake/proofs/pan_simpProofScript.sml new file mode 100644 index 0000000000..2affffe1b0 --- /dev/null +++ b/pancake/proofs/pan_simpProofScript.sml @@ -0,0 +1,1108 @@ +(* + Correctness proof for pan_simp +*) + +open preamble + panSemTheory pan_simpTheory panPropsTheory + +val _ = new_theory "pan_simpProof"; + +val _ = set_grammar_ancestry ["panSem", "pan_simp", "panProps"]; + +val s = ``s:('a,'ffi) panSem$state`` + +Theorem exp_ids_ret_to_tail_eq: + !p. exp_ids (ret_to_tail p) = exp_ids p +Proof + ho_match_mp_tac ret_to_tail_ind >> rw [] >> + fs [ret_to_tail_def, panLangTheory.exp_ids_def] + >- ( + fs [seq_call_ret_def] >> + every_case_tac >> fs [panLangTheory.exp_ids_def]) >> + every_case_tac >> fs [panLangTheory.exp_ids_def] +QED + + +Theorem exp_ids_seq_assoc_eq: + !p q. exp_ids (seq_assoc p q) = exp_ids p ++ exp_ids q +Proof + ho_match_mp_tac seq_assoc_ind >> rw [] >> + fs [seq_assoc_def, panLangTheory.exp_ids_def] >> + every_case_tac >> fs [seq_assoc_def, panLangTheory.exp_ids_def] +QED + + +Theorem exp_ids_compile_eq: + !p. exp_ids (compile p) = exp_ids p +Proof + rw [] >> + fs [compile_def] >> + fs [exp_ids_ret_to_tail_eq, exp_ids_seq_assoc_eq, + panLangTheory.exp_ids_def] +QED + +Theorem map_snd_f_eq: + !p f g. MAP (g ∘ SND ∘ SND ∘ (λ(name,params,body). (name,params,f body))) p = + MAP (g ∘ f) (MAP (SND ∘ SND) p) +Proof + Induct >> rw [] >> + cases_on ‘h’ >> fs [] >> + cases_on ‘r’ >> fs [] +QED + +Theorem size_of_eids_compile_eq: + !pan_code. + size_of_eids (compile_prog pan_code) = + size_of_eids pan_code +Proof + rw [] >> + fs [panLangTheory.size_of_eids_def] >> + fs [pan_simpTheory.compile_prog_def] >> + qmatch_goalsub_abbrev_tac ‘remove_dup (FLAT es)’ >> + qmatch_goalsub_abbrev_tac ‘_ = LENGTH + (remove_dup (FLAT ces))’ >> + qsuff_tac ‘es = ces’ + >- fs [] >> + fs [Abbr ‘es’, Abbr ‘ces’, pan_simpTheory.compile_prog_def] >> + fs [MAP_MAP_o] >> + fs [map_snd_f_eq] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + ‘EL n (MAP (SND ∘ SND) pan_code) = + (SND ∘ SND) (EL n pan_code)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [] >> + fs [exp_ids_compile_eq] +QED + + +Theorem evaluate_SmartSeq: + evaluate (SmartSeq p q,s) = evaluate (Seq p q,^s) +Proof + rw [SmartSeq_def, evaluate_def] +QED + +Theorem evaluate_seq_skip: + !p s. evaluate (Seq p Skip,s) = evaluate (p,^s) +Proof + Induct >> fs [Once evaluate_def] >> rw [] >> + rpt (pairarg_tac >> fs [] >> rw [evaluate_def] >> fs []) +QED + +Theorem evaluate_skip_seq: + evaluate (Seq Skip p,s) = evaluate (p,^s) +Proof + fs [evaluate_def] +QED + +Theorem evaluate_while_body_same: + (!(s:('a,'b)state). evaluate (body,s) = evaluate (body',s)) ==> + !(s:('a,'b)state). evaluate (While e body,s) = evaluate (While e body',s) +Proof + rw [] >> completeInduct_on ‘s.clock’ >> + rw [] >> fs [PULL_EXISTS,PULL_FORALL] >> + once_rewrite_tac [evaluate_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + rpt (pairarg_tac >> fs [] >> rveq) >> + last_x_assum (qspec_then ‘s’ mp_tac) >> + fs [] >> rw [] >> + every_case_tac >> + imp_res_tac evaluate_clock >> + fs [dec_clock_def] +QED + + +Theorem evaluate_while_no_error_imp: + eval s e = SOME (ValWord w) /\ + w <> 0w /\ s.clock <> 0 /\ + FST (evaluate (While e c,s)) <> SOME Error ==> + FST (evaluate (c,dec_clock s)) <> SOME Error +Proof + rw [] >> + pop_assum mp_tac >> + once_rewrite_tac [evaluate_def] >> + TOP_CASE_TAC >> fs [] >> + pairarg_tac >> fs [] >> rveq >> + every_case_tac >> fs [] +QED + +Theorem evaluate_seq_assoc: + !p q s. evaluate (seq_assoc p q,s) = evaluate (Seq p q,^s) +Proof + ho_match_mp_tac seq_assoc_ind >> rw [] >> + fs [evaluate_seq_skip, seq_assoc_def] >> + TRY ( + rename1 ‘While’ >> + TOP_CASE_TAC >> fs [] >> rveq >> + fs [evaluate_skip_seq] + >- metis_tac [evaluate_while_body_same] >> + once_rewrite_tac [evaluate_def] >> fs [] >> + rpt (pairarg_tac >> fs [] >> rveq) >> + TOP_CASE_TAC >> fs [] >> + metis_tac [evaluate_while_body_same]) >> + gvs [evaluate_def] >> rpt (pairarg_tac >> fs [] >> rw [] >> gvs[]) >> + every_case_tac >> gvs [evaluate_skip_seq, evaluate_def] >> + every_case_tac >> gvs [evaluate_skip_seq, evaluate_def] +QED + + +Theorem evaluate_seq_call_ret_eq: + !p s. + FST (evaluate (p,s)) <> SOME Error ==> + evaluate (seq_call_ret p,s) = evaluate (p,s) +Proof + rw [seq_call_ret_def] >> + every_case_tac >> fs [] >> rveq >> + fs [evaluate_def] >> + pairarg_tac >> fs [] >> + every_case_tac >> fs [] >> rveq >> + TRY (metis_tac [] >> NO_TAC) >> + fs [empty_locals_def, set_var_def] >> + fs [eval_def, FLOOKUP_UPDATE] +QED + + +Theorem evaluate_seq_no_error_fst: + FST (evaluate (Seq p p',s)) ≠ SOME Error ==> + FST (evaluate (p,s)) ≠ SOME Error +Proof + rw [evaluate_def] >> + rpt (pairarg_tac >> fs []) >> + every_case_tac >> fs[] +QED + + +Theorem eval_seq_assoc_eq_evaluate: + evaluate ((seq_assoc Skip p),s) = (res, t) ==> + evaluate (p,s) = (res, t) +Proof + rw [] >> + fs [evaluate_seq_assoc] >> + fs [evaluate_def] +QED + +Theorem eval_seq_assoc_not_error: + FST (evaluate (p,s)) ≠ SOME Error ==> + FST (evaluate ((seq_assoc Skip p),s)) ≠ SOME Error +Proof + rw [evaluate_seq_assoc] >> + rw [evaluate_def] +QED + + +val goal = + ``λ(prog, s). + FST (evaluate (prog,s)) <> SOME Error ==> + evaluate (ret_to_tail prog, s) = evaluate (prog,s)`` + +local + val ind_thm = panSemTheory.evaluate_ind + |> ISPEC goal + |> CONV_RULE (DEPTH_CONV PairRules.PBETA_CONV) |> REWRITE_RULE []; + fun list_dest_conj tm = if not (is_conj tm) then [tm] else let + val (c1,c2) = dest_conj tm in list_dest_conj c1 @ list_dest_conj c2 end + val ind_goals = ind_thm |> concl |> dest_imp |> fst |> list_dest_conj +in + fun get_goal s = first (can (find_term (can (match_term (Term [QUOTE s]))))) ind_goals + fun ret_to_tail_tm () = ind_thm |> concl |> rand + fun the_ind_thm () = ind_thm +end + + +Theorem ret_to_tail_Dec: + ^(get_goal "panLang$Dec") +Proof + rw [ret_to_tail_def] >> + fs [evaluate_def] >> + TOP_CASE_TAC >> fs [] >> + rpt (pairarg_tac >> fs [] >> rveq) +QED + + +Theorem ret_to_tail_Seq: + ^(get_goal "panLang$Seq") +Proof + rw [ret_to_tail_def] >> + qmatch_goalsub_abbrev_tac ‘seq_call_ret sprog’ >> + ‘evaluate (seq_call_ret sprog,s) = evaluate (sprog,s)’ by ( + ho_match_mp_tac evaluate_seq_call_ret_eq >> + unabbrev_all_tac >> + imp_res_tac evaluate_seq_no_error_fst >> fs [] >> + fs [evaluate_def] >> + pairarg_tac >> fs [] >> + TOP_CASE_TAC >> fs []) >> + fs [] >> pop_assum kall_tac >> + unabbrev_all_tac >> + rw [evaluate_def] >> + rpt (pairarg_tac >> fs []) >> + every_case_tac >> fs [] >> rveq >> + fs [evaluate_def] +QED + +Theorem ret_to_tail_If: + ^(get_goal "panLang$If") +Proof + rw [ret_to_tail_def] >> + fs [evaluate_def] >> + every_case_tac >> fs [] >> + rpt (pairarg_tac >> fs [] >> rveq) +QED + +Theorem ret_to_tail_While: + ^(get_goal "panLang$While") +Proof + rw [] >> + fs [ret_to_tail_def] >> + once_rewrite_tac [evaluate_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + drule evaluate_while_no_error_imp >> + disch_then (qspec_then ‘c’ mp_tac) >> + rw [] >> fs [] >> + rpt (pairarg_tac >> fs [] >> rveq) >> + every_case_tac >> fs [] >> + ‘FST (evaluate (While e c,s1)) ≠ SOME Error’ by + fs [Once evaluate_def] >> + fs [] +QED + +Theorem ret_to_tail_Call: + ^(get_goal "panLang$Call") +Proof + rw [] >> + fs [ret_to_tail_def, evaluate_def] >> + every_case_tac >> + fs [evaluate_def, ret_to_tail_def] +QED + +Theorem ret_to_tail_Others: + ^(get_goal "panLang$Skip") /\ + ^(get_goal "panLang$Assign") /\ + ^(get_goal "panLang$Store") /\ + ^(get_goal "panLang$StoreByte") /\ + ^(get_goal "panLang$Break") /\ + ^(get_goal "panLang$Continue") /\ + ^(get_goal "panLang$ExtCall") /\ + ^(get_goal "panLang$Raise") /\ + ^(get_goal "panLang$Return") /\ + ^(get_goal "panLang$Tick") +Proof + rw [ret_to_tail_def] +QED + +Theorem ret_to_tail_correct: + ^(ret_to_tail_tm()) +Proof + match_mp_tac (the_ind_thm()) >> + EVERY (map strip_assume_tac + [ret_to_tail_Dec, ret_to_tail_Seq, + ret_to_tail_If, ret_to_tail_While, ret_to_tail_Call, + ret_to_tail_Others]) >> + asm_rewrite_tac [] >> rw [] >> rpt (pop_assum kall_tac) +QED + +Theorem compile_correct_same_state: + FST (evaluate (p,s)) <> SOME Error ==> + evaluate (compile p, s) = evaluate (p,s) +Proof + rw [compile_def] >> + dxrule eval_seq_assoc_not_error >> strip_tac >> + imp_res_tac ret_to_tail_correct >> fs [] >> + rw [evaluate_seq_assoc, evaluate_def] +QED + +Theorem evaluate_seq_simp: + evaluate (p,s) = (res, t) /\ res <> SOME Error ==> + evaluate (compile p, s) = (res,t) +Proof + fs [compile_correct_same_state] +QED + + +Definition state_rel_def: + state_rel s t c <=> + (t = s with code := c) /\ + (∀f. + FLOOKUP s.code f = NONE ==> + FLOOKUP c f = NONE) /\ + (∀f vshs prog. + FLOOKUP s.code f = SOME (vshs, prog) ==> + FLOOKUP c f = SOME (vshs, pan_simp$compile prog)) +End + + +Theorem state_rel_intro: + !s t c. state_rel s t c ==> + (t = s with code := c) /\ + (∀f vshs prog. + FLOOKUP s.code f = SOME (vshs, prog) ==> + FLOOKUP c f = SOME (vshs, pan_simp$compile prog)) +Proof + rw [state_rel_def] +QED + + +Theorem compile_eval_correct: + ∀s e v t. + eval s e = SOME v /\ + state_rel s t t.code ==> + eval t e = SOME v +Proof + ho_match_mp_tac panSemTheory.eval_ind >> + rpt conj_tac >> rpt gen_tac >> strip_tac + >- ( + rename [‘Const w’] >> + fs [panSemTheory.eval_def]) + >- ( + rename [‘eval s (Var vname)’] >> + fs [panSemTheory.eval_def] >> rveq >> + fs [state_rel_def, state_component_equality]) + >- ( + rename [‘eval s (Label fname)’] >> + fs [panSemTheory.eval_def, option_case_eq] >> rveq >> + cases_on ‘v1’ >> + fs [state_rel_def, state_component_equality] >> + res_tac >> fs []) + >- ( + rename [‘eval s (Struct es)’] >> + rpt gen_tac >> strip_tac >> fs [] >> + fs [panSemTheory.eval_def, option_case_eq] >> rveq >> + rpt (pop_assum mp_tac) >> + MAP_EVERY qid_spec_tac [‘vs’, ‘es’] >> + Induct >> fs [] + >- fs [OPT_MMAP_def] >> + rpt gen_tac >> strip_tac >> fs [OPT_MMAP_def] >> + rewrite_tac [AND_IMP_INTRO] >> strip_tac >> rveq >> + rename [‘_ = SOME vs’] >> + fs []) + >- ( + rename [‘eval s (Field index e)’] >> + rpt gen_tac >> strip_tac >> fs [] >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq] >> rveq >> + fs []) + >- ( + rename [‘eval s (Load sh e)’] >> + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq, + CaseEq "word_lab"] >> rveq >> fs [] >> + fs [state_rel_def, state_component_equality]) + >- ( + rename [‘eval s (LoadByte e)’] >> + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq, + CaseEq "word_lab", option_case_eq] >> rveq >> fs [] >> + fs [state_rel_def, state_component_equality]) + >- ( + rename [‘eval s (Op op es)’] >> + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq, + CaseEq "word_lab", option_case_eq] >> rveq >> fs [] >> + qsuff_tac ‘OPT_MMAP (λa. eval t a) es = SOME ws’ + >- fs [] >> + pop_assum mp_tac >> + pop_assum kall_tac >> + pop_assum kall_tac >> + pop_assum mp_tac >> + pop_assum mp_tac >> + MAP_EVERY qid_spec_tac [‘ws’, ‘es’] >> + Induct >> fs [] + >- fs [OPT_MMAP_def] >> + rpt gen_tac >> strip_tac >> fs [OPT_MMAP_def] >> + rewrite_tac [AND_IMP_INTRO] >> strip_tac >> rveq >> + fs []) + >- ( + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def] >> + fs [option_case_eq, v_case_eq, word_lab_case_eq] >> rveq >> + fs []) >> + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def] >> + fs [option_case_eq, v_case_eq, word_lab_case_eq] >> rveq >> + fs [] +QED + + +Theorem compile_eval_correct_none: + ∀s e t. + eval s e = NONE /\ + state_rel s t t.code ==> + eval t e = NONE +Proof + ho_match_mp_tac panSemTheory.eval_ind >> + rpt conj_tac >> rpt gen_tac >> strip_tac + >- ( + rename [‘Const w’] >> + fs [panSemTheory.eval_def]) + >- ( + rename [‘eval s (Var vname)’] >> + fs [panSemTheory.eval_def] >> rveq >> + fs [state_rel_def, state_component_equality]) + >- ( + rename [‘eval s (Label fname)’] >> + fs [panSemTheory.eval_def, option_case_eq] >> rveq >> + fs [state_rel_def, state_component_equality] >> + res_tac >> fs []) + >- ( + rename [‘eval s (Struct es)’] >> + rpt gen_tac >> strip_tac >> fs [] >> + fs [panSemTheory.eval_def, option_case_eq] >> rveq >> + rpt (pop_assum mp_tac) >> + MAP_EVERY qid_spec_tac [‘es’] >> + Induct >> fs [] + >- fs [OPT_MMAP_def] >> + rpt gen_tac >> strip_tac >> fs [OPT_MMAP_def] >> + rewrite_tac [AND_IMP_INTRO] >> strip_tac >> rveq >> + fs [] >> + drule compile_eval_correct >> + fs []) + >- ( + rename [‘eval s (Field index e)’] >> + rpt gen_tac >> strip_tac >> fs [] >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq] >> rveq >> + imp_res_tac compile_eval_correct >> + fs []) + >- ( + rename [‘eval s (Load sh e)’] >> + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq, + CaseEq "word_lab"] >> rveq >> fs [] >> + imp_res_tac compile_eval_correct >> + fs [] >> + fs [state_rel_def, state_component_equality]) + >- ( + rename [‘eval s (LoadByte e)’] >> + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq, + CaseEq "word_lab", option_case_eq] >> rveq >> fs [] >> + imp_res_tac compile_eval_correct >> + fs [] >> + fs [state_rel_def, state_component_equality]) + >- ( + rename [‘eval s (Op op es)’] >> + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq, + CaseEq "word_lab", option_case_eq] >> rveq >> fs [] + >- ( + qsuff_tac ‘OPT_MMAP (λa. eval t a) es = NONE’ + >- fs [] >> + pop_assum mp_tac >> + pop_assum mp_tac >> + pop_assum mp_tac >> + MAP_EVERY qid_spec_tac [‘es’] >> + Induct >> fs [] + >- fs [OPT_MMAP_def] >> + rpt gen_tac >> strip_tac >> fs [OPT_MMAP_def] >> + rewrite_tac [AND_IMP_INTRO] >> strip_tac >> rveq >> + fs [] >> + imp_res_tac compile_eval_correct >> + fs []) >> + qsuff_tac ‘OPT_MMAP (λa. eval t a) es = SOME ws’ + >- fs [] >> + pop_assum mp_tac >> + pop_assum kall_tac >> + pop_assum mp_tac >> + pop_assum mp_tac >> + MAP_EVERY qid_spec_tac [‘ws’, ‘es’] >> + Induct >> fs [] + >- fs [OPT_MMAP_def] >> + rpt gen_tac >> strip_tac >> fs [OPT_MMAP_def] >> + rewrite_tac [AND_IMP_INTRO] >> strip_tac >> rveq >> + fs [] >> + imp_res_tac compile_eval_correct >> + fs []) + >- ( + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def] >> + fs [option_case_eq, v_case_eq, word_lab_case_eq] >> rveq >> + fs [] >> + imp_res_tac compile_eval_correct >> + fs []) >> + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def] >> + fs [option_case_eq, v_case_eq, word_lab_case_eq] >> rveq >> + fs [] >> + imp_res_tac compile_eval_correct >> + fs [] +QED + +val goal = + ``λ comp (prog, s). ∀res s1 t ctxt. + evaluate (prog,s) = (res,s1) ∧ res ≠ SOME Error ∧ + state_rel s t t.code ==> + ∃t1. evaluate (comp prog,t) = (res,t1) /\ + state_rel s1 t1 t1.code`` + +local + val goal = beta_conv ``^goal (pan_simp$seq_assoc Skip)`` + val ind_thm = panSemTheory.evaluate_ind + |> ISPEC goal + |> CONV_RULE (DEPTH_CONV PairRules.PBETA_CONV) |> REWRITE_RULE []; + fun list_dest_conj tm = if not (is_conj tm) then [tm] else let + val (c1,c2) = dest_conj tm in list_dest_conj c1 @ list_dest_conj c2 end + val ind_goals = ind_thm |> concl |> dest_imp |> fst |> list_dest_conj +in + fun get_goal s = first (can (find_term (can (match_term (Term [QUOTE s]))))) ind_goals + fun compile_tm () = ind_thm |> concl |> rand + fun the_ind_thm () = ind_thm +end + + +Theorem compile_Seq: + ^(get_goal "panLang$Seq") +Proof + rw [] >> + fs [evaluate_seq_assoc, evaluate_skip_seq] >> + fs [evaluate_def] >> + pairarg_tac >> fs [] >> rveq >> fs [] >> + pairarg_tac >> fs [] >> rveq >> fs [] >> + cases_on ‘res''’ >> fs [] >> rveq >> fs [] + >- ( + ‘res' = NONE’ by ( + res_tac >> fs []) >> + fs [] >> + first_x_assum drule >> + strip_tac >> + fs [] >> rveq >> fs []) >> + ‘res' <> NONE’ by ( + res_tac >> fs [] >> rveq >> fs []) >> + fs [] >> + res_tac >> fs [] >> + rveq >> fs [] +QED + +Theorem compile_Dec: + ^(get_goal "panLang$Dec") +Proof + rw [] >> + fs [evaluate_seq_assoc, evaluate_skip_seq] >> + fs [evaluate_def] >> + cases_on ‘eval s e’ >> fs [] >> rveq >> + drule compile_eval_correct >> + disch_then drule >> + strip_tac >> + fs [] >> + pairarg_tac >> fs [] >> rveq >> fs [] >> + pairarg_tac >> fs [] >> rveq >> fs [] >> + first_x_assum (qspec_then ‘t with locals := t.locals |+ (v,x)’ mp_tac) >> + impl_tac + >- fs [state_rel_def, state_component_equality] >> + strip_tac >> fs [] >> rveq >> + rfs [state_rel_def] >> + fs [state_component_equality] +QED + +Theorem compile_If: + ^(get_goal "panLang$If") +Proof + rw [] >> + fs [evaluate_seq_assoc, evaluate_skip_seq] >> + fs [evaluate_def] >> + cases_on ‘eval s e’ >> fs [] >> rveq >> + drule compile_eval_correct >> + disch_then drule >> + strip_tac >> + fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] +QED + + +Theorem compile_Call: + ^(get_goal "panLang$Call") +Proof + rw [] >> + fs [evaluate_seq_assoc, evaluate_skip_seq] >> + fs [evaluate_def] >> + cases_on ‘eval s trgt’ >> fs [] >> rveq >> fs [] >> + imp_res_tac compile_eval_correct >> + fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + cases_on ‘OPT_MMAP (eval s) argexps’ >> + fs [] >> + ‘OPT_MMAP (eval t) argexps = OPT_MMAP (eval s) argexps’ by ( + match_mp_tac IMP_OPT_MMAP_EQ >> + fs [pan_commonPropsTheory.opt_mmap_eq_some] >> + fs [MAP_EQ_EVERY2] >> + fs [LIST_REL_EL_EQN] >> + rw [] >> + metis_tac [compile_eval_correct]) >> + fs [] >> + cases_on ‘lookup_code s.code m x’ >> fs [] >> + fs [lookup_code_def] >> + cases_on ‘FLOOKUP s.code m’ >> fs [] >> + cases_on ‘ x''’ >> fs [] >> rveq >> + qpat_x_assum ‘state_rel s t t.code’ assume_tac >> + drule state_rel_intro >> + strip_tac >> rveq >> fs [] >> + pop_assum drule >> + strip_tac >> fs [] >> + ‘t.clock = s.clock’ by + fs [state_rel_def, state_component_equality] >> + fs [] >> + cases_on ‘s.clock = 0’ >> fs [] + >- ( + fs [empty_locals_def] >> rveq >> + fs [state_rel_def, state_component_equality]) >> + cases_on ‘evaluate + (r,dec_clock s with locals := FEMPTY |++ ZIP (MAP FST q,x))’ >> + fs [] >> + cases_on ‘q'’ >> fs [] >> + cases_on ‘x'’ >> fs [] >> rveq >> fs [] + >- ( + last_x_assum (qspec_then ‘dec_clock t with + locals := FEMPTY |++ ZIP (MAP FST q,x)’ mp_tac) >> + impl_tac + >- fs [dec_clock_def, state_rel_def, state_component_equality] >> + strip_tac >> fs [] >> + drule evaluate_seq_simp >> + fs [] >> + strip_tac >> + fs [empty_locals_def] >> rveq >> + fs [state_rel_def, state_component_equality]) + >- ( + last_x_assum (qspec_then ‘dec_clock t with + locals := FEMPTY |++ ZIP (MAP FST q,x)’ mp_tac) >> + impl_tac + >- fs [dec_clock_def, state_rel_def, state_component_equality] >> + strip_tac >> fs [] >> + drule evaluate_seq_simp >> + fs [] >> + strip_tac >> + fs [] >> rveq >> + cases_on ‘caltyp’ >> rfs [] >> + fs [empty_locals_def] >> rveq >> + fs [state_rel_def, state_component_equality] >> + every_case_tac >> fs [set_var_def] >> rveq >> rfs []) + >- ( + last_x_assum (qspec_then ‘dec_clock t with + locals := FEMPTY |++ ZIP (MAP FST q,x)’ mp_tac) >> + impl_tac + >- fs [dec_clock_def, state_rel_def, state_component_equality] >> + strip_tac >> fs [] >> + drule evaluate_seq_simp >> + fs [] >> + strip_tac >> + fs [] >> rveq >> + cases_on ‘caltyp’ >> rfs [] >> + fs [empty_locals_def] >> rveq >> + fs [state_rel_def, state_component_equality] >> + every_case_tac >> fs [set_var_def] >> rveq >> rfs []) >> + last_x_assum (qspec_then ‘dec_clock t with + locals := FEMPTY |++ ZIP (MAP FST q,x)’ mp_tac) >> + impl_tac + >- fs [dec_clock_def, state_rel_def, state_component_equality] >> + strip_tac >> fs [] >> + drule evaluate_seq_simp >> + fs [] >> + strip_tac >> + fs [empty_locals_def] >> rveq >> + fs [state_rel_def, state_component_equality] +QED + + +Theorem compile_While: + ^(get_goal "panLang$While") +Proof + rw [] >> + fs [evaluate_seq_assoc, evaluate_skip_seq] >> + qpat_x_assum ‘ evaluate (While e c,s) = (res,s1)’ mp_tac >> + once_rewrite_tac [evaluate_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] + >- ( + TOP_CASE_TAC >> fs [] >> + strip_tac >> rveq >> fs [] >> + imp_res_tac compile_eval_correct >> + fs [] + >- ( + ‘t.clock = 0’ by + fs [state_rel_def, state_component_equality] >> + fs [] >> + fs [empty_locals_def, state_rel_def, state_component_equality]) >> + ‘t.clock <> 0’ by + fs [state_rel_def, state_component_equality] >> + fs [] >> + cases_on ‘evaluate (c,dec_clock s)’ >> + fs [] >> + cases_on ‘q’ >> fs [] >> rveq >> fs [] >> + TRY (cases_on ‘x’ >> fs [] >> rveq >> fs []) >> ( + last_x_assum (qspec_then ‘dec_clock t’ mp_tac) >> + impl_tac + >- fs [dec_clock_def, state_rel_def, state_component_equality] >> + strip_tac >> fs [])) >> + strip_tac >> rveq >> fs [] >> + imp_res_tac compile_eval_correct >> + fs [] +QED + +Theorem compile_ExtCall: + ^(get_goal "panLang$ExtCall") +Proof + rw [] >> + fs [evaluate_seq_assoc, evaluate_skip_seq] >> + fs [evaluate_def] >> rveq >> fs [] >> + last_x_assum mp_tac >> + rpt (TOP_CASE_TAC >> fs []) >> + TRY ( + rfs [state_rel_def, state_component_equality, + empty_locals_def, dec_clock_def] >> rveq >> fs [] >> NO_TAC) >> + rfs [state_rel_def, state_component_equality, + empty_locals_def, dec_clock_def] >> rveq >> fs [] >> + rveq >> fs [] >> rveq >> rfs [] >> + strip_tac >> fs [] +QED + +Theorem compile_Others: + ^(get_goal "panLang$Skip") /\ + ^(get_goal "panLang$Assign") /\ + ^(get_goal "panLang$Store") /\ + ^(get_goal "panLang$StoreByte") /\ + ^(get_goal "panLang$Break") /\ + ^(get_goal "panLang$Continue") /\ + ^(get_goal "panLang$Raise") /\ + ^(get_goal "panLang$Return") /\ + ^(get_goal "panLang$Tick") +Proof + rw [] >> + fs [evaluate_seq_assoc, evaluate_skip_seq] >> + fs [evaluate_def] >> rveq >> fs [] >> + ( + every_case_tac >> gvs [] >> + imp_res_tac compile_eval_correct >> + gvs [state_rel_def, state_component_equality, + empty_locals_def, dec_clock_def]) +QED + +Theorem compile_correct: + ^(compile_tm()) +Proof + match_mp_tac (the_ind_thm()) >> + EVERY (map strip_assume_tac + [compile_Dec, compile_Seq, + compile_If, compile_While, compile_Call, + compile_ExtCall, compile_Call,compile_Others]) >> + asm_rewrite_tac [] >> rw [] >> rpt (pop_assum kall_tac) +QED + + +Theorem first_compile_prog_all_distinct: + ALL_DISTINCT (MAP FST prog) ==> + ALL_DISTINCT (MAP FST (pan_simp$compile_prog prog)) +Proof + rw [] >> + fs [pan_simpTheory.compile_prog_def] >> + fs [MAP_MAP_o] >> + qmatch_goalsub_abbrev_tac ‘MAP ls _’ >> + ‘MAP ls prog = MAP FST prog’ suffices_by fs [] >> + fs [Abbr ‘ls’] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + cases_on ‘EL n prog’ >> + fs [] >> + cases_on ‘r’ >> + fs [] +QED + + +Theorem el_compile_prog_el_prog_eq: + !prog n start pprog p. + EL n (compile_prog prog) = (start,[],pprog) /\ + ALL_DISTINCT (MAP FST prog) /\ n < LENGTH prog /\ + ALOOKUP prog start = SOME ([],p) ==> + EL n prog = (start,[],p) +Proof + Induct >> rw [] >> + fs [compile_prog_def] >> + cases_on ‘n’ >> fs [] >> rveq >> fs [] + >- ( + cases_on ‘h’ >> rfs [] >> + cases_on ‘r’ >> rfs [] >> rveq >> fs []) >> + last_x_assum match_mp_tac >> + qexists_tac ‘pprog’ >> fs [] >> + cases_on ‘h’ >> fs [] >> + cases_on ‘q = start’ >> fs [] >> rveq >> fs [] >> + fs [MEM_EL] >> + first_x_assum (qspec_then ‘n'’ mp_tac) >> + fs [] >> + strip_tac >> + qmatch_asmsub_abbrev_tac ‘EL _ (MAP ff _) = _’ >> + ‘EL n' (MAP ff prog) = ff (EL n' prog)’ by ( + match_mp_tac EL_MAP >> fs []) >> + fs [] >> + fs [Abbr ‘ff’] >> + cases_on ‘EL n' prog’ >> fs [] >> + cases_on ‘r’ >> fs [] >> rveq >> rfs [] >> + metis_tac [pan_commonPropsTheory.el_pair_map_fst_el] +QED + + +Theorem compile_prog_distinct_params: + ∀prog. + EVERY (λ(name,params,body). ALL_DISTINCT params) prog ⇒ + EVERY (λ(name,params,body). ALL_DISTINCT params) (compile_prog prog) +Proof + rw [] >> + fs [EVERY_MEM] >> + rw [] >> + PairCases_on ‘e’ >> fs [] >> + fs [compile_prog_def] >> + fs [MEM_EL] >> + qmatch_asmsub_abbrev_tac ‘MAP ff _’ >> + ‘EL n (MAP ff prog) = ff (EL n prog)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [] >> rveq >> fs [] >> + pop_assum kall_tac >> + fs [Abbr ‘ff’] >> + cases_on ‘EL n prog’ >> + cases_on ‘r’ >> fs [] >> rveq >> + last_x_assum (qspec_then ‘(e0,e1,r')’ mp_tac) >> + fs [] >> + impl_tac + >- metis_tac [] >> + fs [] +QED + + +Theorem state_rel_imp_semantics: + !s t pan_code start prog. state_rel s t t.code ∧ + ALL_DISTINCT (MAP FST pan_code) ∧ + s.code = alist_to_fmap pan_code ∧ + t.code = alist_to_fmap (pan_simp$compile_prog pan_code) ∧ + ALOOKUP pan_code start = SOME ([],prog) ∧ + semantics s start <> Fail ==> + semantics t start = semantics s start +Proof + rw [] >> + fs [] >> + reverse (Cases_on ‘semantics s start’) >> fs [] + >- ( + (* Termination case of pan semantics *) + fs [panSemTheory.semantics_def] >> + pop_assum mp_tac >> + IF_CASES_TAC >> fs [] >> + DEEP_INTRO_TAC some_intro >> simp[] >> + rw [] + >- ( + (* the fail case of pan_simp semantics *) + CCONTR_TAC >> fs [] >> rveq >> fs [] >> + last_x_assum (qspec_then ‘k'’ mp_tac) >> + (fn g => subterm (fn tm => Cases_on ‘^(assert(has_pair_type)tm)’) (#2 g) g) >> + strip_tac >> + fs [] >> + drule compile_correct >> fs [] >> + qexists_tac ‘t with clock := k'’ >> + fs [] >> + Ho_Rewrite.PURE_REWRITE_TAC[GSYM PULL_EXISTS] >> + conj_tac + >- ( + fs [state_rel_def] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + CCONTR_TAC >> + fs [] >> + dxrule eval_seq_assoc_eq_evaluate >> + strip_tac >> fs []) >> + DEEP_INTRO_TAC some_intro >> simp[] >> + conj_tac + (* the termination case of pan-simp semantics *) + >- ( + rw [] >> fs [] >> + last_x_assum (qspec_then ‘k'’ mp_tac) >> + (fn g => subterm (fn tm => Cases_on ‘^(assert(has_pair_type)tm)’) (#2 g) g) >> + strip_tac >> + fs [] >> + drule compile_correct >> fs [] >> + last_x_assum (qspec_then ‘k'’ mp_tac) >> + fs [] >> + strip_tac >> fs [] >> + disch_then (qspecl_then [‘t with clock := k'’] mp_tac) >> + impl_tac + >- ( + fs [state_rel_def] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + strip_tac >> fs [] >> + dxrule eval_seq_assoc_eq_evaluate >> + strip_tac >> fs [] >> rveq >> fs [] >> + pop_assum mp_tac >> + dxrule panPropsTheory.evaluate_add_clock_eq >> + dxrule panPropsTheory.evaluate_add_clock_eq >> + disch_then (qspec_then ‘k'’ assume_tac) >> + disch_then (qspec_then ‘k’ assume_tac) >> + fs [] >> + strip_tac >> + cases_on ‘r’ >> fs [] >> + cases_on ‘x’ >> fs [] >>( + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs [] >> rveq >> fs [] >> + fs [state_rel_def, state_component_equality])) >> + (* the diverging case of pan-simp semantics *) + rw[] >> fs[] >> CCONTR_TAC >> fs [] >> + drule compile_correct >> fs [] >> + ‘r ≠ SOME Error ∧ + r ≠ SOME Break ∧ r ≠ SOME Continue ∧ r ≠ NONE’ by ( + cases_on ‘r’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + fs [] >> + qexists_tac ‘t with clock := k’ >> + fs [] >> + Ho_Rewrite.PURE_REWRITE_TAC[GSYM PULL_EXISTS] >> + conj_tac + >- ( + fs [state_rel_def] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + CCONTR_TAC >> fs [] >> + fs [] >> + dxrule eval_seq_assoc_eq_evaluate >> + strip_tac >> fs [] >> rveq >> fs [] >> + first_x_assum (qspec_then ‘k’ mp_tac) >> simp[] >> + first_x_assum(qspec_then ‘k’ mp_tac) >> simp[] >> + every_case_tac >> fs[] >> rw[] >> rfs[]) >> + fs [panSemTheory.semantics_def] >> + pop_assum mp_tac >> + IF_CASES_TAC >> fs [] >> + DEEP_INTRO_TAC some_intro >> simp[] >> + rw [] + >- ( + (* the fail case of pan-simp semantics *) + fs[] >> rveq >> fs[] >> + last_x_assum (qspec_then ‘k’ mp_tac) >> simp[] >> + (fn g => subterm (fn tm => Cases_on ‘^(assert(has_pair_type)tm)’) (#2 g) g) >> + CCONTR_TAC >> fs [] >> + drule compile_correct >> fs [] >> + qexists_tac ‘t with clock := k’ >> + fs [] >> + Ho_Rewrite.PURE_REWRITE_TAC[GSYM PULL_EXISTS] >> + conj_tac + >- ( + fs [state_rel_def] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + CCONTR_TAC >> + fs [] >> + dxrule eval_seq_assoc_eq_evaluate >> + strip_tac >> fs [] >> rveq >> fs []) >> + (* the termination/diverging case of pan-simp semantics *) + DEEP_INTRO_TAC some_intro >> simp[] >> + conj_tac + (* the termination case of pan-simp semantics *) + >- ( + rw [] >> fs[] >> + qpat_x_assum ‘∀x y. _’ (qspec_then ‘k’ mp_tac)>> + (fn g => subterm (fn tm => Cases_on ‘^(assert(has_pair_type)tm)’) (#2 g) g) >> + strip_tac >> + drule compile_correct >> fs [] >> + qexists_tac ‘t with clock := k’ >> + fs [] >> + Ho_Rewrite.PURE_REWRITE_TAC[GSYM PULL_EXISTS] >> + conj_tac + >- ( + fs [state_rel_def] >> + last_x_assum (qspec_then ‘k’ assume_tac) >> + rfs [] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + CCONTR_TAC >> + fs [] >> + dxrule eval_seq_assoc_eq_evaluate >> + strip_tac >> fs [] >> rveq >> fs []) >> + (* the diverging case of pan-simp semantics *) + rw [] >> + qmatch_abbrev_tac ‘build_lprefix_lub l1 = build_lprefix_lub l2’ >> + ‘(lprefix_chain l1 ∧ lprefix_chain l2) ∧ equiv_lprefix_chain l1 l2’ + suffices_by metis_tac[build_lprefix_lub_thm,lprefix_lub_new_chain,unique_lprefix_lub] >> + conj_asm1_tac + >- ( + UNABBREV_ALL_TAC >> + conj_tac >> + Ho_Rewrite.ONCE_REWRITE_TAC[GSYM o_DEF] >> + REWRITE_TAC[IMAGE_COMPOSE] >> + match_mp_tac prefix_chain_lprefix_chain >> + simp[prefix_chain_def,PULL_EXISTS] >> + qx_genl_tac [‘k1’, ‘k2’] >> + qspecl_then [‘k1’, ‘k2’] mp_tac LESS_EQ_CASES >> + simp[LESS_EQ_EXISTS] >> + rw [] >> + assume_tac (INST_TYPE [``:'a``|->``:'a``, + ``:'b``|->``:'b``] + panPropsTheory.evaluate_add_clock_io_events_mono) >> + first_assum (qspecl_then + [‘Call Tail (Label start) []’, ‘t with clock := k1’, ‘p’] mp_tac) >> + first_assum (qspecl_then + [‘Call Tail (Label start) []’, ‘t with clock := k2’, ‘p’] mp_tac) >> + first_assum (qspecl_then + [‘TailCall (Label start) []’, ‘s with clock := k1’, ‘p’] mp_tac) >> + first_assum (qspecl_then + [‘TailCall (Label start) []’, ‘s with clock := k2’, ‘p’] mp_tac) >> + fs []) >> + simp [equiv_lprefix_chain_thm] >> + fs [Abbr ‘l1’, Abbr ‘l2’] >> simp[PULL_EXISTS] >> + pop_assum kall_tac >> + simp[LNTH_fromList,PULL_EXISTS] >> + simp[GSYM FORALL_AND_THM] >> + rpt gen_tac >> + reverse conj_tac >> strip_tac + >- ( + qmatch_assum_abbrev_tac`n < LENGTH (_ (_ (SND p)))` >> + Cases_on`p` >> pop_assum(assume_tac o SYM o REWRITE_RULE[markerTheory.Abbrev_def]) >> + drule compile_correct >> fs [] >> + ‘q ≠ SOME Error ∧ + q ≠ SOME Break ∧ q ≠ SOME Continue ∧ q ≠ NONE’ by ( + last_x_assum (qspec_then ‘k’ assume_tac) >> rfs [] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + fs [] >> + disch_then (qspec_then ‘t with clock := k’ mp_tac) >> + impl_tac + >- fs [state_rel_def] >> + strip_tac >> fs [] >> + qexists_tac ‘ck+k’ >> simp[] >> + dxrule eval_seq_assoc_eq_evaluate >> + strip_tac >> fs [] >> rveq >> fs [] >> + first_x_assum (qspec_then ‘k’ kall_tac) >> + first_x_assum (qspec_then ‘k’ mp_tac) >> + fs [] >> + strip_tac >> + cases_on ‘q’ >> fs [] >> rveq >> fs [] >> + cases_on ‘x’ >> fs [] >> rveq >> fs [] >> + assume_tac (INST_TYPE [``:'a``|->``:'a``, + ``:'b``|->``:'b``] + panPropsTheory.evaluate_add_clock_io_events_mono) >> + first_x_assum (qspecl_then + [‘TailCall (Label start) []’, + ‘t with clock := k’, ‘ck’] mp_tac) >> + strip_tac >> rfs [] >> + rfs [state_rel_def, state_component_equality, IS_PREFIX_THM]) >> + (fn g => subterm (fn tm => Cases_on`^(Term.subst[{redex = #1(dest_exists(#2 g)), residue = ``k:num``}] + (assert(has_pair_type)tm))`) (#2 g) g) >> + drule compile_correct >> fs [] >> + ‘q ≠ SOME Error ∧ + q ≠ SOME Break ∧ q ≠ SOME Continue ∧ q ≠ NONE’ by ( + last_x_assum (qspec_then ‘k’ assume_tac) >> rfs [] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + fs [] >> + disch_then (qspec_then ‘t with clock := k’ mp_tac) >> + impl_tac + >- fs [state_rel_def] >> + strip_tac >> fs [] >> + dxrule eval_seq_assoc_eq_evaluate >> + strip_tac >> fs [] >> rveq >> fs [] >> + qexists_tac ‘k’ >> + fs [] >> + fs [state_rel_def, state_component_equality, IS_PREFIX_THM] +QED + +val _ = export_theory(); diff --git a/pancake/proofs/pan_to_crepProofScript.sml b/pancake/proofs/pan_to_crepProofScript.sml new file mode 100644 index 0000000000..8dd3cdd819 --- /dev/null +++ b/pancake/proofs/pan_to_crepProofScript.sml @@ -0,0 +1,3547 @@ +(* + Correctness proof for -- +*) + +open preamble + panSemTheory panPropsTheory + crepLangTheory crepSemTheory crepPropsTheory + pan_commonTheory pan_commonPropsTheory + listRangeTheory pan_to_crepTheory + +val _ = new_theory "pan_to_crepProof"; + +val _ = set_grammar_ancestry ["listRange", "crepProps", "pan_commonProps", "pan_to_crep"]; + + +(* state relation *) + +val s = ``(s:('a,'ffi) panSem$state)`` + +Definition excp_rel_def: + excp_rel ceids seids <=> + FDOM seids = FDOM ceids /\ + (!e e' n n'. + FLOOKUP ceids e = SOME n /\ + FLOOKUP ceids e' = SOME n' /\ + n = n' ==> e = e') +End + +Definition ctxt_fc_def: + ctxt_fc cvs em vs shs ns = + <|vars := FEMPTY |++ ZIP (vs, ZIP (shs, with_shape shs ns)); + funcs := cvs; eids := em; vmax := list_max ns |> +End + + +Definition code_rel_def: + code_rel ctxt s_code t_code <=> + ∀f vshs prog. + FLOOKUP s_code f = SOME (vshs, prog) ==> + FLOOKUP ctxt.funcs f = SOME vshs /\ + let vs = MAP FST vshs; + shs = MAP SND vshs; + ns = GENLIST I (size_of_shape (Comb shs)); + nctxt = ctxt_fc ctxt.funcs ctxt.eids vs shs ns in + FLOOKUP t_code f = SOME (ns, compile nctxt prog) +End + +Definition state_rel_def: + state_rel ^s (t:('a,'ffi) crepSem$state) <=> + s.memory = t.memory ∧ + s.memaddrs = t.memaddrs ∧ + s.clock = t.clock ∧ + s.be = t.be ∧ + s.ffi = t.ffi +End + +Definition locals_rel_def: + locals_rel ctxt (s_locals:mlstring |-> 'a v) t_locals <=> + no_overlap ctxt.vars /\ ctxt_max ctxt.vmax ctxt.vars /\ + ∀vname v. + FLOOKUP s_locals vname = SOME v ==> + ∃ns vs. FLOOKUP (ctxt.vars) vname = SOME (shape_of v, ns) ∧ + OPT_MMAP (FLOOKUP t_locals) ns = SOME vs ∧ flatten v = vs +End + +Theorem code_rel_imp: + code_rel ctxt s_code t_code ==> + ∀f vshs prog. + FLOOKUP s_code f = SOME (vshs, prog) ==> + FLOOKUP ctxt.funcs f = SOME vshs /\ + let vs = MAP FST vshs; + shs = MAP SND vshs; + ns = GENLIST I (size_of_shape (Comb shs)); + nctxt = ctxt_fc ctxt.funcs ctxt.eids vs shs ns in + FLOOKUP t_code f = SOME (ns, compile nctxt prog) +Proof + fs [code_rel_def] +QED + +Theorem code_rel_empty_locals: + code_rel ctxt s.code t.code ==> + code_rel ctxt (empty_locals s).code (empty_locals t).code +Proof + fs [code_rel_def, empty_locals_def, panSemTheory.empty_locals_def] +QED + +Theorem cexp_heads_eq: + !es. cexp_heads es = cexp_heads_simp es +Proof + Induct >> + rw [cexp_heads_def, cexp_heads_simp_def] >> + fs [] >> + every_case_tac >> fs [] +QED + +Theorem compile_exp_val_rel: + ∀s e v (t :('a, 'b) state) ct es sh. + panSem$eval s e = SOME v ∧ + state_rel s t ∧ + code_rel ct s.code t.code ∧ + locals_rel ct s.locals t.locals ∧ + compile_exp ct e = (es, sh) ==> + MAP (eval t) es = MAP SOME (flatten v) ∧ + LENGTH es = size_of_shape sh ∧ + shape_of v = sh +Proof + ho_match_mp_tac panSemTheory.eval_ind >> + rpt conj_tac >> rpt gen_tac >> strip_tac + >- ( + rename [‘Const w’] >> + fs [panSemTheory.eval_def] >> rveq >> + fs [flatten_def] >> + fs [compile_exp_def] >> rveq >> + fs [OPT_MMAP_def, eval_def, + panLangTheory.size_of_shape_def, shape_of_def]) + >- ( + rename [‘eval s (Var vname)’] >> + fs [panSemTheory.eval_def] >> rveq >> + fs [locals_rel_def] >> + first_x_assum drule >> + fs [] >> strip_tac >> fs [] >> + fs [compile_exp_def] >> rveq >> + fs [lookup_locals_eq_map_vars] >> + fs [opt_mmap_eq_some] >> + fs [MAP_MAP_o] >> + metis_tac [LENGTH_MAP, length_flatten_eq_size_of_shape]) + >- ( + rename [‘eval s (Label fname)’] >> + fs [panSemTheory.eval_def, option_case_eq] >> rveq >> + fs [flatten_def] >> + fs [compile_exp_def] >> rveq >> + fs [OPT_MMAP_def] >> + fs [eval_def] >> fs [code_rel_def] >> + cases_on ‘v1’ >> + last_x_assum drule_all >> strip_tac >> + fs [panLangTheory.size_of_shape_def, shape_of_def]) + >- ( + rename [‘eval s (Struct es)’] >> + rpt gen_tac >> strip_tac >> fs [] >> + fs [panSemTheory.eval_def, option_case_eq] >> rveq >> + fs [compile_exp_def] >> rveq >> + fs [panLangTheory.size_of_shape_def, shape_of_def] >> + fs [MAP_MAP_o, MAP_FLAT, flatten_def] >> + fs [o_DEF] >> + rpt (pop_assum mp_tac) >> + MAP_EVERY qid_spec_tac [‘vs’, ‘es’] >> + Induct >> fs [] + >- fs [OPT_MMAP_def] >> + rpt gen_tac >> strip_tac >> fs [OPT_MMAP_def] >> + rewrite_tac [AND_IMP_INTRO] >> strip_tac >> rveq >> + rename [‘_ = SOME vs’] >> + fs [] >> + last_x_assum mp_tac >> + impl_tac >- + metis_tac [] >> + strip_tac >> fs [] >> + last_x_assum (qspec_then ‘h’ mp_tac) >> fs [] >> + disch_then drule >> disch_then drule >> + cases_on ‘compile_exp ct h’ >> fs []) + >- + ( + (* Field case *) + rename [‘eval s (Field index e)’] >> + rpt gen_tac >> strip_tac >> fs [] >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq] >> rveq >> + fs [compile_exp_def] >> rveq >> + pairarg_tac >> fs [CaseEq "shape"] >> rveq >> + first_x_assum drule_all >> fs [shape_of_def] >> + strip_tac >> fs [] >> rveq >> + qpat_x_assum ‘_ = SOME (Struct _)’ kall_tac >> + qpat_x_assum ‘compile_exp _ _ = _’ kall_tac >> + rpt (pop_assum mp_tac) >> + MAP_EVERY qid_spec_tac + [‘ct’,‘cexp’ ,‘sh’ , ‘es’, ‘t’, ‘s’, ‘index’, ‘vs’] >> + Induct >> rpt gen_tac >- fs [] >> + rewrite_tac [AND_IMP_INTRO] >> + strip_tac >> fs [] >> + cases_on ‘index’ >> fs [] + >- ( + fs [comp_field_def] >> rveq >> + fs [MAP_TAKE, flatten_def] >> + fs [panLangTheory.size_of_shape_def] >> + fs [GSYM length_flatten_eq_size_of_shape] >> + metis_tac [LENGTH_MAP, TAKE_LENGTH_APPEND]) >> + fs [comp_field_def] >> + last_x_assum drule >> + ntac 4 (disch_then drule) >> + fs [panLangTheory.size_of_shape_def, flatten_def] >> + drule map_append_eq_drop >> + fs [LENGTH_MAP, length_flatten_eq_size_of_shape]) + >- ( + rename [‘eval s (Load sh e)’] >> + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq, + CaseEq "word_lab"] >> rveq >> + fs [compile_exp_def] >> rveq >> + pairarg_tac >> fs [CaseEq "shape"] >> rveq >> + last_x_assum drule_all >> + strip_tac >> + fs [shape_of_def, panLangTheory.size_of_shape_def,flatten_def] >> + rveq >> fs [] >> rveq >> + fs [length_load_shape_eq_shape] >> + drule mem_load_some_shape_eq >> + strip_tac >> fs [] >> + fs [MAP_EQ_EVERY2] >> fs [length_load_shape_eq_shape] >> + rveq >> fs [GSYM length_flatten_eq_size_of_shape] >> + fs [LIST_REL_EL_EQN] >> fs [length_load_shape_eq_shape] >> + rw [] >> fs [state_rel_def] >> + drule mem_load_flat_rel >> + disch_then drule >> + strip_tac >> fs [] >> + drule eval_load_shape_el_rel >> + disch_then (qspecl_then [‘0w’, ‘t’,‘x0’] mp_tac) >> fs [] >> + strip_tac >> + fs [eval_def, OPT_MMAP_def] >> + every_case_tac >> fs [] >> rveq >> + fs[EVERY_DEF] >> cases_on ‘h’ >> fs [] >> + fs [wordLangTheory.word_op_def] >> rveq >> + qpat_x_assum ‘mem_load _ _ = _’ (mp_tac o GSYM) >> + strip_tac >> fs []) + >- ( + rename [‘eval s (LoadByte e)’] >> + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq, + CaseEq "word_lab", option_case_eq] >> rveq >> + fs [compile_exp_def] >> rveq >> + pairarg_tac >> fs [CaseEq "shape"] >> rveq >> + first_x_assum drule_all >> fs [shape_of_def] >> + strip_tac >> fs [] >> rveq >> + cases_on ‘cexp’ >> fs [panLangTheory.size_of_shape_def, flatten_def] >> rveq >> + fs [panLangTheory.size_of_shape_def] >> + fs [eval_def, state_rel_def]) + >- ( + rename [‘eval s (Op op es)’] >> + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq, + CaseEq "word_lab", option_case_eq] >> rveq >> + fs [compile_exp_def] >> rveq >> + fs [cexp_heads_eq] >> + fs [cexp_heads_simp_def] >> + ‘~MEM [] (MAP FST (MAP (λa. compile_exp ct a) es))’ by ( + CCONTR_TAC >> fs [] >> rveq >> + fs [MEM_MAP] >> rveq >> + drule opt_mmap_mem_func >> + disch_then drule >> + strip_tac >> fs [] >> + rename1 ‘MEM e es’ >> + cases_on ‘compile_exp ct e’ >> fs [] >> + ‘shape_of m = One’ by ( + ‘MEM m ws’ by ( + drule opt_mmap_mem_defined >> + strip_tac >> res_tac >> fs []) >> + qpat_x_assum ‘EVERY _ ws’ mp_tac >> + fs [EVERY_MEM] >> + disch_then (qspec_then ‘m’ mp_tac) >> + fs [] >> TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [shape_of_def]) >> + last_x_assum drule_all >> + strip_tac >> rveq >> rfs [panLangTheory.size_of_shape_def]) >> + fs [] >> rveq >> + fs [panLangTheory.size_of_shape_def, shape_of_def] >> + fs [flatten_def, eval_def, MAP_MAP_o] >> + ‘OPT_MMAP (λa. eval t a) + (MAP (HD ∘ FST ∘ (λa. compile_exp ct a)) es) = + OPT_MMAP (λa. OPTION_MAP v2word (eval s a)) es’ by ( + ho_match_mp_tac IMP_OPT_MMAP_EQ >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + drule opt_mmap_length_eq >> + strip_tac >> fs [] >> + first_x_assum (qspec_then ‘EL n es’ mp_tac) >> + impl_tac >- metis_tac [EL_MEM] >> + drule opt_mmap_el >> fs [] >> + disch_then drule >> + strip_tac >> fs [] >> + disch_then drule >> + disch_then drule >> + disch_then (qspecl_then [‘FST (compile_exp ct (EL n es))’, + ‘SND(compile_exp ct (EL n es))’] mp_tac) >> + fs [] >> + strip_tac >> + fs [EVERY_EL] >> + last_x_assum (qspec_then ‘n’ mp_tac) >> + fs [] >> TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + qpat_x_assum ‘LENGTH es = LENGTH _’ (mp_tac o GSYM) >> + strip_tac >> fs [] >> + drule (INST_TYPE [``:'a``|->``:'a panLang$exp``, + ``:'b``|->``:'a crepLang$exp``] EL_MAP) >> + disch_then (qspec_then ‘(HD ∘ FST ∘ (λa. compile_exp ct a))’ mp_tac) >> + strip_tac >> fs [] >> + fs [flatten_def, v2word_def] >> rveq) >> + fs [] >> + ‘OPT_MMAP (λa. OPTION_MAP v2word (eval s a)) es = + SOME (MAP v2word ws)’ by ( + ho_match_mp_tac opt_mmap_opt_map >> fs []) >> + fs [EVERY_MAP, MAP_MAP_o] >> + ‘∀x. (λw. case w of ValWord v6 => T | ValLabel v7 => F | Struct v3 => F) x ==> + (λx. case v2word x of Word v2 => T | Label v3 => F) x’ by ( + rw [] >> every_case_tac >> fs [v2word_def]) >> + drule MONO_EVERY >> + disch_then (qspec_then ‘ws’ mp_tac) >> fs [] >> + strip_tac >> fs [flatten_def] >> + fs [GSYM MAP_MAP_o] >> + qmatch_goalsub_abbrev_tac ‘word_op op ins’ >> + qmatch_asmsub_abbrev_tac ‘word_op op ins'’ >> + ‘ins = ins'’ by ( + unabbrev_all_tac >> fs [MAP_EQ_EVERY2] >> + fs [LIST_REL_EL_EQN] >> + rw [] >> + fs [EVERY_EL] >> (* for some reason, drule EL_MAP is not being inst. properly*) + ‘EL n (MAP v2word ws) = v2word (EL n ws)’ by ( + match_mp_tac EL_MAP >> fs []) >> + fs [] >> + last_x_assum (qspec_then ‘n’ mp_tac) >> + fs [] >> TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [v2word_def]) >> + unabbrev_all_tac >> fs []) + >- ( + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def] >> + fs [option_case_eq, v_case_eq, word_lab_case_eq] >> rveq >> + (* open compile_exp *) + fs [compile_exp_def] >> + cases_on ‘compile_exp ct e’ >> + cases_on ‘compile_exp ct e'’ >> + first_x_assum drule_all >> + first_x_assum drule_all >> + strip_tac >> strip_tac >> + fs [panLangTheory.size_of_shape_def, shape_of_def, flatten_def] >> + rveq >> + fs [panLangTheory.size_of_shape_def, shape_of_def] >> + rveq >> + fs [panLangTheory.size_of_shape_def, shape_of_def] >> + fs [eval_def] >> + every_case_tac >> fs [] >> EVAL_TAC) >> + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def] >> + fs [option_case_eq, v_case_eq, word_lab_case_eq] >> rveq >> + fs [compile_exp_def] >> + cases_on ‘compile_exp ct e’ >> + first_x_assum drule_all >> + strip_tac >> fs [] >> + fs [panLangTheory.size_of_shape_def, shape_of_def, flatten_def] >> + rveq >> + fs [panLangTheory.size_of_shape_def, shape_of_def] >> rveq >> + fs [eval_def] >> every_case_tac >> + fs [panLangTheory.size_of_shape_def, shape_of_def] +QED + + + +Definition globals_lookup_def: + globals_lookup t v = + OPT_MMAP (FLOOKUP t.globals) + (GENLIST (λx. n2w x) (size_of_shape (shape_of v))) +End + + +val gen_goal = + ``λ comp (prog, s). ∀res s1 t ctxt. + evaluate (prog,s) = (res,s1) ∧ res ≠ SOME Error ∧ + state_rel s t ∧ code_rel ctxt s.code t.code /\ + excp_rel ctxt.eids s.eshapes /\ + locals_rel ctxt s.locals t.locals ⇒ + ∃res1 t1. evaluate (comp ctxt prog,t) = (res1,t1) /\ + state_rel s1 t1 ∧ code_rel ctxt s1.code t1.code /\ + excp_rel ctxt.eids s1.eshapes /\ + case res of + | NONE => res1 = NONE /\ locals_rel ctxt s1.locals t1.locals + | SOME Break => res1 = SOME Break /\ + locals_rel ctxt s1.locals t1.locals + | SOME Continue => res1 = SOME Continue /\ + locals_rel ctxt s1.locals t1.locals + | SOME (Return v) => + (size_of_shape (shape_of v) = 0 ==> res1 = SOME (Return (Word 0w))) ∧ + (size_of_shape (shape_of v) = 1 ==> res1 = SOME (Return (HD(flatten v)))) ∧ + (1 < size_of_shape (shape_of v) ==> + res1 = SOME (Return (Word 0w)) /\ globals_lookup t1 v = SOME (flatten v) ∧ + size_of_shape (shape_of v) <= 32) + | SOME (Exception eid v) => + (case FLOOKUP ctxt.eids eid of + | SOME n => res1 = SOME (Exception n) ∧ + (1 <= size_of_shape (shape_of v) ==> + globals_lookup t1 v = SOME (flatten v) ∧ + size_of_shape (shape_of v) <= 32) + | NONE => F) + | SOME TimeOut => res1 = SOME TimeOut + | SOME (FinalFFI f) => res1 = SOME (FinalFFI f) + | _ => F`` + +local + val goal = beta_conv ``^gen_goal pan_to_crep$compile`` + val ind_thm = panSemTheory.evaluate_ind + |> ISPEC goal + |> CONV_RULE (DEPTH_CONV PairRules.PBETA_CONV) |> REWRITE_RULE []; + fun list_dest_conj tm = if not (is_conj tm) then [tm] else let + val (c1,c2) = dest_conj tm in list_dest_conj c1 @ list_dest_conj c2 end + val ind_goals = ind_thm |> concl |> dest_imp |> fst |> list_dest_conj +in + fun get_goal s = first (can (find_term (can (match_term (Term [QUOTE s]))))) ind_goals + fun compile_tm () = ind_thm |> concl |> rand + fun the_ind_thm () = ind_thm + val fgoal = beta_conv ``^gen_goal pan_to_crep$compile`` +end + + + +Theorem compile_Skip_Break_Continue: + ^(get_goal "compile _ panLang$Skip") /\ + ^(get_goal "compile _ panLang$Break") /\ + ^(get_goal "compile _ panLang$Continue") +Proof + rpt strip_tac >> + fs [panSemTheory.evaluate_def, evaluate_def, + compile_def] >> rveq >> fs [] +QED + + +Theorem compile_Tick: + ^(get_goal "compile _ panLang$Tick") +Proof + rpt strip_tac >> + fs [panSemTheory.evaluate_def, evaluate_def, + compile_def] >> rveq >> fs [] >> + every_case_tac >> fs [panSemTheory.empty_locals_def, empty_locals_def, + panSemTheory.dec_clock_def, dec_clock_def] >> + rveq >> fs [state_rel_def] +QED + + +Theorem locals_rel_lookup_ctxt: + locals_rel ctxt lcl lcl' /\ + FLOOKUP lcl vr = SOME v ==> + ?ns. FLOOKUP ctxt.vars vr = SOME (shape_of v,ns) /\ + LENGTH ns = LENGTH (flatten v) /\ + OPT_MMAP (FLOOKUP lcl') ns = SOME (flatten v) +Proof + rw [locals_rel_def] >> + metis_tac [opt_mmap_length_eq] +QED + + +Theorem eval_nested_assign_distinct_eq: + !es ns t ev vs. + MAP (eval t) es = MAP SOME ev /\ + OPT_MMAP (FLOOKUP t.locals) ns = SOME vs /\ + distinct_lists ns (FLAT (MAP var_cexp es)) /\ + ALL_DISTINCT ns /\ + LENGTH ns = LENGTH es ==> + evaluate (nested_seq (MAP2 Assign ns es),t) = + (NONE, t with locals := t.locals |++ ZIP (ns, ev)) +Proof + Induct + >- ( + rpt gen_tac >> strip_tac >> + cases_on ‘ns’ >> fs [] >> + fs [nested_seq_def, evaluate_def, + FUPDATE_LIST_THM, + state_component_equality]) >> + rpt gen_tac >> + strip_tac >> + cases_on ‘ns’ >> + fs [nested_seq_def] >> + fs [evaluate_def] >> + pairarg_tac >> fs [] >> + fs [MAP_EQ_CONS] >> + rveq >> rfs [] >> + fs [OPT_MMAP_def] >> + rveq >> rfs [] >> + rveq >> + rename [‘eval t e = SOME v’] >> + rename [‘MAP (eval t) es = MAP SOME ev’] >> + rename [‘FLOOKUP t.locals n = SOME nv’] >> + qpat_x_assum ‘distinct_lists _ _’ + (assume_tac o REWRITE_RULE [Once CONS_APPEND]) >> + drule distinct_lists_cons >> + strip_tac >> + drule opt_mmap_flookup_update >> + disch_then drule >> + disch_then (qspec_then ‘v’ assume_tac) >> + ‘MAP (eval (t with locals := t.locals |+ (n,v))) es = MAP SOME ev’ by ( + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + first_x_assum (qspec_then ‘n'’ assume_tac) >> + rfs [] >> + ho_match_mp_tac update_locals_not_vars_eval_eq >> + fs [distinct_lists_def] >> + CCONTR_TAC >> + metis_tac [MEM_FLAT, EL_MEM, MEM_MAP]) >> + qpat_x_assum ‘MAP (eval t) es = MAP SOME ev’ kall_tac >> + first_x_assum drule >> + fs [state_accfupds] >> + disch_then drule >> + strip_tac >> fs [] >> + fs [FUPDATE_LIST_THM] +QED + + +Theorem eval_nested_decs_seq_res_var_eq: + !es ns t ev p. + MAP (eval t) es = MAP SOME ev /\ + LENGTH ns = LENGTH es /\ + distinct_lists ns (FLAT (MAP var_cexp es)) /\ + ALL_DISTINCT ns ==> + let (q,r) = evaluate (p, t with locals := t.locals |++ ZIP (ns, ev)) in + evaluate (nested_decs ns es p, t) = + (q, r with locals := + FOLDL res_var r.locals (ZIP (ns, MAP (FLOOKUP t.locals) ns))) +Proof + Induct + >- ( + rpt gen_tac >> strip_tac >> + cases_on ‘ns’ >> fs [] >> + pairarg_tac >> fs [] >> + fs [nested_decs_def, FUPDATE_LIST_THM] >> + cases_on ‘t’ >> cases_on ‘r’ >> + fs [state_component_equality, recordtype_state_seldef_locals_fupd_def]) >> + rpt gen_tac >> + strip_tac >> + cases_on ‘ns’ >> + fs [nested_decs_def] >> + fs [evaluate_def] >> + fs [MAP_EQ_CONS] >> + pairarg_tac >> fs [] >> + rveq >> rfs [] >> + pairarg_tac >> fs [] >> + rename [‘eval t e = SOME v’] >> + rename [‘MAP (eval t) es = MAP SOME ev’] >> + rename [‘~MEM n t'’] >> + qpat_x_assum ‘distinct_lists _ _’ + (assume_tac o REWRITE_RULE [Once CONS_APPEND]) >> + drule distinct_lists_cons >> + strip_tac >> + ‘MAP (eval (t with locals := t.locals |+ (n,v))) es = MAP SOME ev’ by ( + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + first_x_assum (qspec_then ‘n'’ assume_tac) >> + rfs [] >> + ho_match_mp_tac update_locals_not_vars_eval_eq >> + fs [distinct_lists_def] >> + CCONTR_TAC >> + metis_tac [MEM_FLAT, EL_MEM, MEM_MAP]) >> + qpat_x_assum ‘MAP (eval t) es = MAP SOME ev’ kall_tac >> + first_x_assum drule_all >> + disch_then (qspec_then ‘p’ assume_tac) >> + pairarg_tac >> fs [] >> + rveq >> + fs [FUPDATE_LIST_THM] >> + fs [state_component_equality] >> + ‘MAP (FLOOKUP (t.locals |+ (n,v))) t' = + MAP (FLOOKUP t.locals) t'’ by + metis_tac [MAP_EQ_f, FLOOKUP_UPDATE] >> + fs [] >> + pop_assum kall_tac >> + qpat_x_assum ‘~MEM n t'’ mp_tac >> + rpt (pop_assum kall_tac) >> + MAP_EVERY qid_spec_tac [‘r’, ‘n’,‘t’, ‘t'’] >> + Induct >> rw [] >> + first_x_assum (qspec_then ‘t’ mp_tac) >> + disch_then (qspec_then ‘n’ mp_tac) >> + fs [] >> + disch_then (qspec_then ‘r with locals := + res_var r.locals (h,FLOOKUP t.locals h)’ mp_tac) >> + fs [] >> + metis_tac [res_var_commutes] + +QED + +Theorem mem_comp_field: + !sh i e shp ce es vs. + i < LENGTH vs /\ + LENGTH e = size_of_shape (shape_of (Struct vs)) /\ + comp_field i sh e = (es,shp) /\ + Comb sh = shape_of (Struct vs) /\ + MEM ce es ==> MEM ce e +Proof + Induct >> rw [comp_field_def] >> + fs [] >> rveq + >- fs [shape_of_def] + >- ( + cases_on ‘vs’ >> fs [] >> + fs [panLangTheory.size_of_shape_def, shape_of_def] >> + rveq >> fs [] >> + ‘size_of_shape (shape_of h') <= LENGTH e’ by DECIDE_TAC >> + metis_tac [MEM_TAKE]) >> + cases_on ‘vs’ >> fs [] >> + fs [panLangTheory.size_of_shape_def, shape_of_def] >> + rveq >> fs [] >> + first_x_assum (qspecl_then [‘i-1’, ‘(DROP (size_of_shape (shape_of h')) e)’, + ‘shp’, ‘ce’, ‘es’, ‘t’] mp_tac) >> + fs [] >> + metis_tac [MEM_DROP_IMP] +QED + + +Theorem eval_var_cexp_present_ctxt: + ∀(s :('a, 'b) panSem$state) e v (t :('a, 'b) state) ct es sh. + state_rel s t /\ + eval s e = SOME v /\ + code_rel ct s.code t.code /\ + locals_rel ct s.locals t.locals /\ + compile_exp ct e = (es,sh) ==> + (∀n. MEM n (FLAT (MAP var_cexp es)) ==> + ?v shp ns. FLOOKUP ct.vars v = SOME (shp,ns) /\ + MEM n ns) +Proof + ho_match_mp_tac panSemTheory.eval_ind >> + rpt conj_tac >> rpt gen_tac >> strip_tac + >- ( + rename [‘Const w’] >> + fs [panSemTheory.eval_def] >> rveq >> + fs [compile_exp_def] >> rveq >> + fs [var_cexp_def]) + >- ( + rename [‘eval s (Var vname)’] >> + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def] >> rveq >> + fs [compile_exp_def] >> rveq >> + fs [var_cexp_def] >> + fs [CaseEq "option"] >> rveq + >- fs [var_cexp_def] >> + cases_on ‘v'’ >> fs [] >> + rveq >> + fs [MEM_MAP, MEM_FLAT] >> + rveq >> + fs [var_cexp_def] >> + metis_tac []) + >- ( + fs [panSemTheory.eval_def] >> rveq >> + fs [compile_exp_def] >> rveq >> + fs [var_cexp_def]) + >- ( + rename [‘eval s (Struct es)’] >> + rpt gen_tac >> strip_tac >> fs [] >> + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def, option_case_eq] >> rveq >> + fs [compile_exp_def] >> rveq >> + fs [MAP_MAP_o, MAP_FLAT] >> + fs [o_DEF] >> + rpt (pop_assum mp_tac) >> + MAP_EVERY qid_spec_tac [‘vs’, ‘es’] >> + Induct >> fs [] >> + rpt gen_tac >> strip_tac >> + fs [OPT_MMAP_def] >> + strip_tac >> + strip_tac >> + rveq >> + last_x_assum mp_tac >> + impl_tac >- metis_tac [] >> + strip_tac >> fs [] >> + last_x_assum (qspec_then ‘h’ mp_tac) >> fs [] >> + disch_then drule >> + cases_on ‘compile_exp ct h’ >> fs [] >> + strip_tac >> + strip_tac >> + metis_tac []) + >- ( + rename [‘eval s (Field index e)’] >> + rpt gen_tac >> strip_tac >> fs [] >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq] >> rveq >> + fs [compile_exp_def] >> rveq >> + pairarg_tac >> fs [CaseEq "shape"] >> rveq + >- rw [var_cexp_def] >> + rpt gen_tac >> strip_tac >> + fs [MEM_FLAT, MEM_MAP] >> rveq >> + first_x_assum drule >> + disch_then (qspec_then ‘ct’ mp_tac) >> + cases_on ‘compile_exp ct e’ >> fs [] >> + disch_then (qspec_then ‘n’ mp_tac) >> + fs [] >> rveq >> + impl_tac + >- ( + qexists_tac ‘var_cexp y’ >> + fs [] >> + qexists_tac ‘y’ >> fs [] >> + drule compile_exp_val_rel >> + disch_then drule_all >> + strip_tac >> fs [] >> rveq >> + metis_tac [mem_comp_field]) >> + fs []) + >- ( + rename [‘eval s (Load sh e)’] >> + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq, + CaseEq "word_lab"] >> rveq >> + fs [compile_exp_def] >> rveq >> + pairarg_tac >> fs [CaseEq "shape"] >> rveq >> + cases_on ‘cexp’ >> fs [] >> rveq + >- (rw [] >> fs [MEM_FLAT, MEM_MAP, var_cexp_def]) >> + rpt gen_tac >> + strip_tac >> + fs [MEM_FLAT, MEM_MAP] >> rveq >> + last_x_assum drule >> + disch_then (qspec_then ‘ct’ mp_tac) >> + cases_on ‘compile_exp ct e’ >> fs [] >> + rveq >> + disch_then (qspec_then ‘n’ mp_tac) >> + rveq >> fs [] >> + impl_tac + >- ( + qexists_tac ‘var_cexp y’ >> + fs [] >> + qexists_tac ‘h’ >> fs [] >> + metis_tac [var_exp_load_shape]) >> + fs []) + >- ( + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq, + CaseEq "word_lab"] >> rveq >> + fs [compile_exp_def] >> rveq >> + pairarg_tac >> fs [CaseEq "shape"] >> rveq >> + cases_on ‘cexp’ >> fs [] >> rveq + >- (rw [] >> fs [MEM_FLAT, MEM_MAP, var_cexp_def]) >> + reverse (cases_on ‘shape’) >> fs [] >> rveq + >- (rw [] >> fs [MEM_FLAT, MEM_MAP, var_cexp_def]) >> + rw [] >> + fs [var_cexp_def] >> + last_x_assum drule >> + disch_then (qspec_then ‘ct’ mp_tac) >> + cases_on ‘compile_exp ct e’ >> fs []) + >- ( + rename [‘eval s (Op op es)’] >> + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq, + CaseEq "word_lab", option_case_eq] >> rveq >> + fs [compile_exp_def] >> rveq >> + FULL_CASE_TAC >> + fs [] >> rveq + >- (rw [] >> fs [MEM_FLAT, MEM_MAP, var_cexp_def]) >> + fs [var_cexp_def, ETA_AX] >> + rveq >> + rw [] >> + ntac 4 (pop_assum mp_tac) >> + pop_assum kall_tac >> + pop_assum kall_tac >> + ntac 3 (pop_assum mp_tac) >> + MAP_EVERY qid_spec_tac [‘n’,‘ws’, ‘x’, ‘es’] >> + Induct + >- ( + rw [] >> fs [cexp_heads_def, var_cexp_def] >> + rveq >> fs [MAP, FLAT]) >> + rpt gen_tac >> strip_tac >> + fs [OPT_MMAP_def] >> + rpt strip_tac >> + rveq >> + fs [cexp_heads_def] >> + fs [CaseEq "list", CaseEq "option"] >> + rveq >> + fs [MAP, MEM_FLAT, MEM_MAP] >> rveq + >- ( + first_x_assum (qspec_then ‘h’ mp_tac) >> + fs [] >> + disch_then drule >> + disch_then (qspec_then ‘ct’ mp_tac) >> + cases_on ‘compile_exp ct h’ >> fs []) >> + last_x_assum mp_tac >> + impl_tac >- metis_tac [] >> + disch_then (qspec_then ‘n’ mp_tac) >> + impl_tac + >- ( + qexists_tac ‘var_cexp y’ >> + fs [] >> metis_tac []) >> + fs []) + >- ( + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq, + CaseEq "word_lab"] >> rveq >> + fs [compile_exp_def] >> rveq >> + fs [CaseEq "list", CaseEq "option"] >> + rveq >> fs [MEM_FLAT, MEM_MAP, var_cexp_def] >> + rw [] + >- ( + last_x_assum drule >> + disch_then (qspec_then ‘ct’ mp_tac) >> + cases_on ‘compile_exp ct e’ >> fs []) >> + first_x_assum drule >> + disch_then (qspec_then ‘ct’ mp_tac) >> + cases_on ‘compile_exp ct e'’ >> fs []) >> + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq, + CaseEq "word_lab"] >> rveq >> + fs [compile_exp_def] >> rveq >> + fs [CaseEq "list", CaseEq "option"] >> + rveq >> fs [MEM_FLAT, MEM_MAP, var_cexp_def] >> + rw [] >> last_x_assum drule >> + disch_then (qspec_then ‘ct’ mp_tac) >> + cases_on ‘compile_exp ct e’ >> fs [] +QED + + +Theorem compile_Assign: + ^(get_goal "compile _ (panLang$Assign _ _)") +Proof + rpt gen_tac >> + rpt strip_tac >> + rename [‘Assign vr e’] >> + fs [panSemTheory.evaluate_def, is_valid_value_def] >> + fs [CaseEq "option", CaseEq "bool"] >> rveq >> fs [] >> + rename [‘eval _ e = SOME ev’] >> + rename [‘FLOOKUP _ vr = SOME v’] >> + (* open compiler def *) + fs [compile_def] >> + pairarg_tac >> fs [] >> + drule locals_rel_lookup_ctxt >> + disch_then drule_all >> + strip_tac >> fs [] >> + drule compile_exp_val_rel >> + disch_then drule_all >> + strip_tac >> fs [] >> rveq >> + fs [length_flatten_eq_size_of_shape] >> + TOP_CASE_TAC >> fs [] >> rveq + >- ( + ‘ALL_DISTINCT ns’ + by metis_tac [locals_rel_def, no_overlap_def] >> + drule eval_nested_assign_distinct_eq >> + disch_then drule >> + strip_tac >> fs [] >> + conj_tac + >- fs [state_rel_def] >> + fs [locals_rel_def] >> + rpt gen_tac >> strip_tac >> fs [] >> + cases_on ‘vr = vname’ >> fs [] >> rveq + >- ( + pop_assum (assume_tac o REWRITE_RULE [FLOOKUP_DEF]) >> + fs [] >> rveq >> + match_mp_tac opt_mmap_some_eq_zip_flookup >> + fs [] >> + metis_tac [all_distinct_flookup_all_distinct, + length_flatten_eq_size_of_shape]) >> + fs [FLOOKUP_UPDATE] >> + last_x_assum drule >> + strip_tac >> fs [] >> + rfs [] >> + drule no_overlap_flookup_distinct >> + disch_then drule_all >> + strip_tac >> + drule (INST_TYPE [``:'a``|->``:num``, + ``:'b``|->``:'a word_lab``] + opt_mmap_disj_zip_flookup) >> + disch_then (qspecl_then [‘t.locals’, ‘flatten ev’] mp_tac) >> + fs [length_flatten_eq_size_of_shape]) >> + (* non-distinct Assign *) + qmatch_goalsub_abbrev_tac ‘nested_decs temps es _’ >> + ‘distinct_lists temps (FLAT (MAP var_cexp es))’ by ( + unabbrev_all_tac >> + ho_match_mp_tac genlist_distinct_max >> + rw [] >> + drule eval_var_cexp_present_ctxt >> + disch_then drule_all >> + rw [] >> fs [] >> + rfs [] >> + fs [locals_rel_def, ctxt_max_def] >> + first_x_assum drule >> + fs [] >> + first_x_assum drule >> + fs [EVERY_MEM] >> + res_tac >> fs []) >> + ‘ALL_DISTINCT temps ∧ LENGTH es = LENGTH temps’ by ( + unabbrev_all_tac >> + fs [LENGTH_GENLIST, ALL_DISTINCT_GENLIST]) >> + fs [] >> + ‘ALL_DISTINCT ns’ by metis_tac [locals_rel_def, no_overlap_def] >> + ‘distinct_lists ns temps’ by ( + unabbrev_all_tac >> + once_rewrite_tac [distinct_lists_commutes] >> + ho_match_mp_tac genlist_distinct_max >> + metis_tac [locals_rel_def, ctxt_max_def]) >> + assume_tac eval_nested_decs_seq_res_var_eq >> + pop_assum (qspecl_then [‘es’, ‘temps’, ‘t’, ‘flatten ev’, + ‘nested_seq (MAP2 Assign ns (MAP Var temps))’] mp_tac) >> + impl_tac >- fs [] >> + fs [] >> + pairarg_tac >> fs [] >> rveq >> + strip_tac >> + pop_assum kall_tac >> + ‘MAP (eval (t with locals := t.locals |++ ZIP (temps,flatten ev))) + (MAP Var temps) = MAP SOME (flatten ev)’ by ( + fs [MAP_MAP_o, MAP_EQ_EVERY2] >> + fs [LIST_REL_EL_EQN] >> + rw [] >> rfs [] >> + ‘n < LENGTH temps’ by ( + unabbrev_all_tac >> fs [MAP_MAP_o, MAP_EQ_EVERY2]>> + metis_tac []) >> + drule (INST_TYPE [``:'a``|->``:num``, + ``:'b``|->``:'a crepLang$exp``] EL_MAP) >> + disch_then (qspec_then ‘Var’ assume_tac) >> fs [] >> + fs [eval_def] >> + metis_tac [update_eq_zip_flookup]) >> + drule eval_nested_assign_distinct_eq >> + disch_then (qspec_then ‘ns’ mp_tac) >> + disch_then (qspec_then ‘flatten v’ mp_tac) >> + impl_tac + >- ( + fs [map_var_cexp_eq_var] >> + fs [Once distinct_lists_commutes] >> + drule (INST_TYPE [``:'a``|->``:num``, + ``:'b``|->``:'a word_lab``] + opt_mmap_disj_zip_flookup) >> + disch_then (qspecl_then [‘t.locals’, ‘flatten ev’] mp_tac) >> + fs [length_flatten_eq_size_of_shape]) >> + strip_tac >> fs [] >> + rveq >> + fs [state_rel_def] >> + fs [locals_rel_def] >> + rw [] >> fs [] >> + (* writing in this style for druling below *) + ‘DISJOINT (set (MAP FST (ZIP (temps,flatten ev)))) + (set (MAP FST (ZIP (ns,flatten ev))))’ by ( + ‘LENGTH ns = LENGTH (flatten ev)’ by + fs [length_flatten_eq_size_of_shape] >> + fs [GSYM length_flatten_eq_size_of_shape, MAP_ZIP] >> + fs [distinct_lists_def, IN_DISJOINT, EVERY_DEF, EVERY_MEM] >> + metis_tac []) >> + drule FUPDATE_LIST_APPEND_COMMUTES >> + disch_then (qspec_then ‘t.locals’ assume_tac) >> + fs [] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + cases_on ‘vr = vname’ >> fs [] >> rveq + >- ( + pop_assum (assume_tac o REWRITE_RULE [FLOOKUP_DEF]) >> + fs [] >> rveq >> + fs [opt_mmap_eq_some] >> + fs [Once distinct_lists_commutes] >> + drule (INST_TYPE [``:'a``|->``:num``, + ``:'b``|->``:'a word_lab``] + flookup_res_var_zip_distinct) >> + disch_then (qspecl_then [‘flatten ev’, + ‘MAP (FLOOKUP t.locals) temps’, + ‘t.locals |++ ZIP (ns,flatten ev)’] mp_tac) >> + fs [length_flatten_eq_size_of_shape] >> + strip_tac >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> rfs [] >> + ‘n < LENGTH ns’ by metis_tac [] >> + metis_tac [update_eq_zip_flookup]) >> + fs [FLOOKUP_UPDATE] >> + last_x_assum drule >> + strip_tac >> fs [] >> + rfs [] >> + fs [opt_mmap_eq_some] >> + ‘distinct_lists temps ns'’ by ( + unabbrev_all_tac >> + ho_match_mp_tac genlist_distinct_max >> + metis_tac [locals_rel_def, ctxt_max_def]) >> + drule (INST_TYPE [``:'a``|->``:num``, + ``:'b``|->``:'a word_lab``] + flookup_res_var_zip_distinct) >> + disch_then (qspecl_then [‘flatten ev’, + ‘MAP (FLOOKUP t.locals) temps’, + ‘t.locals |++ ZIP (ns,flatten ev)’] mp_tac) >> + fs [length_flatten_eq_size_of_shape] >> + strip_tac >> + drule no_overlap_flookup_distinct >> + disch_then drule_all >> + strip_tac >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> rfs [] >> + qpat_x_assum ‘LENGTH _ = LENGTH _’ (assume_tac o GSYM) >> + fs [] >> + last_x_assum drule >> strip_tac >> + ‘~MEM (EL n ns') ns’ by ( + fs [Once distinct_lists_commutes] >> + fs [distinct_lists_def, EVERY_MEM, EL_MEM]) >> + metis_tac [flookup_fupdate_zip_not_mem] +QED + + + +Theorem not_mem_context_assigned_mem_gt: + !ctxt p x. + ctxt_max ctxt.vmax ctxt.vars /\ + (!v sh ns'. FLOOKUP ctxt.vars v = SOME (sh, ns') ==> ~MEM x ns') ∧ + x <= ctxt.vmax ==> + ~MEM x (assigned_vars (compile ctxt p)) +Proof + ho_match_mp_tac compile_ind >> rw [] + >- fs [compile_def, assigned_vars_def] + >- ( + fs [compile_def, assigned_vars_def] >> + pairarg_tac >> fs [] >> rveq >> + FULL_CASE_TAC >> fs [assigned_vars_def] >> + qmatch_goalsub_abbrev_tac ‘nested_decs dvs es’ >> + ‘LENGTH dvs = LENGTH es’ by (unabbrev_all_tac >> fs []) >> + drule assigned_vars_nested_decs_append >> + qmatch_goalsub_abbrev_tac ‘compile nctxt p’ >> + disch_then (qspec_then ‘compile nctxt p’ assume_tac) >> + fs [] >> + pop_assum kall_tac >> + conj_asm1_tac + >- (fs [Abbr ‘dvs’] >> fs[MEM_GENLIST]) >> + last_x_assum match_mp_tac >> + rename [‘(vname,sh,dvs)’] >> + conj_tac + >- ( + fs [ctxt_max_def] >> + rw [] >> + fs [FLOOKUP_UPDATE] >> + FULL_CASE_TAC >> fs [] >> rveq >> res_tac >> fs [] >> + fs [Abbr ‘dvs’, MEM_GENLIST]) >> + rw [] >> + fs [FLOOKUP_UPDATE] >> + FULL_CASE_TAC >> rveq >> fs [] >> res_tac >> fs []) + >- ( + fs [compile_def, assigned_vars_def] >> + pairarg_tac >> fs [] >> rveq >> + FULL_CASE_TAC >> fs [assigned_vars_def] >> + FULL_CASE_TAC >> FULL_CASE_TAC >> fs [] + >- ( + FULL_CASE_TAC >> fs [assigned_vars_def] >> + drule nested_seq_assigned_vars_eq >> + fs [] >> res_tac >> fs []) >> + FULL_CASE_TAC >> fs [assigned_vars_def] >> + qmatch_goalsub_abbrev_tac ‘nested_decs dvs es’ >> + ‘LENGTH dvs = LENGTH es’ by (unabbrev_all_tac >> fs []) >> + drule assigned_vars_nested_decs_append >> + disch_then (qspec_then ‘nested_seq (MAP2 Assign r (MAP Var dvs))’ assume_tac) >> + fs [] >> + pop_assum kall_tac >> + conj_asm1_tac + >- ( + fs [Abbr ‘dvs’] >> fs[MEM_GENLIST]) >> + ‘LENGTH r = LENGTH (MAP Var dvs)’ by fs [Abbr ‘dvs’, LENGTH_GENLIST] >> + drule nested_seq_assigned_vars_eq >> + fs [] >> res_tac >> fs []) + >- ( + fs [compile_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [assigned_vars_def] >> + pairarg_tac >> fs [] >> + TOP_CASE_TAC >> fs [assigned_vars_def] >> + fs [nested_decs_def] >> + fs [assigned_vars_def] >> + qmatch_goalsub_abbrev_tac ‘nested_decs dvs es’ >> + ‘LENGTH dvs = LENGTH es’ by (unabbrev_all_tac >> fs []) >> + drule assigned_vars_nested_decs_append >> + disch_then (qspec_then ‘nested_seq (stores (Var (ctxt.vmax + 1)) + (MAP Var dvs) 0w)’ assume_tac) >> + fs [] >> + pop_assum kall_tac >> + conj_asm1_tac + >- ( + fs [Abbr ‘dvs’] >> fs[MEM_GENLIST]) >> + fs [assigned_vars_seq_store_empty]) >> + TRY (fs [compile_def, assigned_vars_def] >> every_case_tac >> + fs [assigned_vars_def] >> metis_tac [] >> NO_TAC) + >- ( + fs [compile_def] >> + pairarg_tac >> fs [] >> + ntac 4 (TOP_CASE_TAC >> fs [assigned_vars_def]) >> + qmatch_goalsub_abbrev_tac ‘nested_decs dvs es’ >> + ‘LENGTH dvs = LENGTH es’ by (unabbrev_all_tac >> fs []) >> + drule assigned_vars_nested_decs_append >> + disch_then (qspec_then ‘nested_seq (store_globals 0w (MAP Var dvs))’ assume_tac) >> + fs [] >> + pop_assum kall_tac >> + conj_asm1_tac + >- ( + fs [Abbr ‘dvs’] >> fs[MEM_GENLIST]) >> + fs [assigned_vars_store_globals_empty]) + >- ( + fs [compile_def] >> + pairarg_tac >> fs [] >> + ntac 2 (TOP_CASE_TAC >> fs [assigned_vars_def]) >> + qmatch_goalsub_abbrev_tac ‘nested_decs dvs es’ >> + ‘LENGTH dvs = LENGTH es’ by (unabbrev_all_tac >> fs []) >> + drule assigned_vars_nested_decs_append >> + disch_then (qspec_then ‘nested_seq (store_globals 0w (MAP Var dvs))’ assume_tac) >> + fs [] >> + pop_assum kall_tac >> + conj_asm1_tac + >- ( + fs [Abbr ‘dvs’] >> fs[MEM_GENLIST]) >> + fs [assigned_vars_store_globals_empty]) >> + fs [compile_def] >> + pairarg_tac >> fs [] >> + rpt (TOP_CASE_TAC >> fs []) >> + TRY (fs [assigned_vars_def]) >> + TRY ( + cases_on ‘q’ >> + fs [ret_var_def] >> + TRY (TOP_CASE_TAC) >> + fs [] >> + TRY ( + fs [ret_hdl_def] >> + cases_on ‘r’ >> + fs [assigned_vars_def, wrap_rt_def, + CaseEq "option", CaseEq "prod", CaseEq "shape", + CaseEq "list"] >> + res_tac >> fs []) >> + TOP_CASE_TAC >> + fs [assign_ret_def, nested_seq_def, assigned_vars_def] >> + ‘LENGTH (h'::t') = LENGTH (load_globals 0w (SUC (LENGTH t')))’ by + fs [GSYM length_load_globals_eq_read_size] >> + drule nested_seq_assigned_vars_eq >> + fs [] >> strip_tac >> + res_tac >> fs []) + >- ( + reverse conj_tac + >- ( + first_x_assum match_mp_tac >> + fs [] >> rw [] >> + res_tac >> fs []) >> + fs [exp_hdl_def] >> + TOP_CASE_TAC >> fs [] >> + fs [assigned_vars_def] >> + TOP_CASE_TAC >> fs [] >> + ‘LENGTH r = LENGTH (load_globals 0w (LENGTH r))’ by + fs [GSYM length_load_globals_eq_read_size] >> + drule nested_seq_assigned_vars_eq >> + fs [] >> strip_tac >> + res_tac >> fs []) >> + cases_on ‘q’ >> + fs [ret_var_def] >> + TRY (TOP_CASE_TAC) >> + fs [] >> + TRY ( + fs [ret_hdl_def] >> + cases_on ‘r’ >> + fs [assigned_vars_def, wrap_rt_def, + CaseEq "option", CaseEq "prod", CaseEq "shape", + CaseEq "list"] >> + res_tac >> fs []) >> + TRY TOP_CASE_TAC >> fs [] >> + fs [assign_ret_def, nested_seq_def, assigned_vars_def] >> + fs [exp_hdl_def] >> + rpt TOP_CASE_TAC >> fs [] >> + fs [assigned_vars_def] >> + TRY ( + ‘LENGTH r = LENGTH (load_globals 0w (LENGTH r))’ by + fs [GSYM length_load_globals_eq_read_size]) >> + TRY ( + ‘LENGTH (h'::t') = LENGTH (load_globals 0w (SUC (LENGTH t')))’ by + fs [GSYM length_load_globals_eq_read_size]) >> + imp_res_tac nested_seq_assigned_vars_eq >> + fs [] >> strip_tac >> + res_tac >> fs [] +QED + +Theorem rewritten_context_unassigned: + !p nctxt v ctxt ns nvars sh sh'. + nctxt = ctxt with + <|vars := ctxt.vars |+ (v,sh,nvars); + vmax := ctxt.vmax + size_of_shape sh|> /\ + FLOOKUP ctxt.vars v = SOME (sh',ns) /\ + no_overlap ctxt.vars /\ + ctxt_max ctxt.vmax ctxt.vars /\ + no_overlap nctxt.vars ∧ + ctxt_max nctxt.vmax nctxt.vars /\ + distinct_lists nvars ns ==> + distinct_lists ns (assigned_vars (compile nctxt p)) +Proof + rw [] >> fs [] >> + fs [distinct_lists_def] >> + rw [] >> + fs [EVERY_MEM] >> rw []>> + CCONTR_TAC >> fs [] >> + qmatch_asmsub_abbrev_tac ‘compile nctxt p’ >> + assume_tac not_mem_context_assigned_mem_gt >> + pop_assum (qspecl_then [‘nctxt’, ‘p’, ‘x’] mp_tac) >> + impl_tac + >- ( + unabbrev_all_tac >> fs[context_component_equality] >> + rw [FLOOKUP_UPDATE] >- metis_tac [] + >- ( + fs [no_overlap_def] >> + first_x_assum (qspecl_then [‘v’, ‘v'’] mp_tac) >> + fs [FLOOKUP_UPDATE] >> + metis_tac [IN_DISJOINT]) >> + fs [ctxt_max_def] >> + res_tac >> fs [] >> + DECIDE_TAC) >> + fs [] +QED + +Theorem ctxt_max_el_leq: + ctxt_max ctxt.vmax ctxt.vars /\ + FLOOKUP ctxt.vars v = SOME (sh,ns) /\ + n < LENGTH ns ==> EL n ns <= ctxt.vmax +Proof + rw [ctxt_max_def] >> + first_x_assum drule >> + disch_then (qspec_then ‘EL n ns’ assume_tac) >> + drule EL_MEM >> + fs [] +QED + + +Theorem compile_Dec: + ^(get_goal "compile _ (panLang$Dec _ _ _)") +Proof + rpt gen_tac >> + rpt strip_tac >> + fs [panSemTheory.evaluate_def] >> + fs [CaseEq "option"] >> + pairarg_tac >> fs [] >> + rveq >> + fs [compile_def] >> + pairarg_tac >> fs [] >> + rveq >> + drule compile_exp_val_rel >> + disch_then drule_all >> + strip_tac >> fs [] >> rveq >> + qmatch_goalsub_abbrev_tac ‘nested_decs nvars es _’ >> + ‘ALL_DISTINCT nvars ∧ LENGTH nvars = LENGTH es’ by ( + unabbrev_all_tac >> + fs [length_flatten_eq_size_of_shape, LENGTH_GENLIST, + ALL_DISTINCT_GENLIST]) >> + ‘distinct_lists nvars (FLAT (MAP var_cexp es))’ by ( + unabbrev_all_tac >> + ho_match_mp_tac genlist_distinct_max >> + rw [] >> + drule eval_var_cexp_present_ctxt >> + disch_then drule_all >> + rw [] >> fs [] >> + rfs [] >> + fs [locals_rel_def, ctxt_max_def] >> + first_x_assum drule >> + fs [] >> + first_x_assum drule >> + fs [EVERY_MEM] >> + res_tac >> fs []) >> + fs [] >> + qmatch_goalsub_abbrev_tac ‘evaluate (_ _ _ p, _)’ >> + assume_tac eval_nested_decs_seq_res_var_eq >> + pop_assum (qspecl_then [‘es’, ‘nvars’, ‘t’, + ‘flatten value’, ‘p’] mp_tac) >> + impl_tac >- fs [] >> + fs [] >> + pairarg_tac >> fs [] >> rveq >> + strip_tac >> + pop_assum kall_tac >> + last_x_assum (qspecl_then [‘t with locals := t.locals |++ ZIP (nvars,flatten value)’, + ‘ctxt with <|vars := ctxt.vars |+ (v,shape_of value,nvars); + vmax := ctxt.vmax + size_of_shape (shape_of value)|>’ ] + mp_tac) >> + impl_tac + >- ( + fs [state_rel_def] >> + conj_tac >- fs [code_rel_def] >> + fs [locals_rel_def] >> + conj_tac + >- ( + fs [no_overlap_def] >> + conj_tac + >- ( + rw [] >> + cases_on ‘x = v’ >> fs [FLOOKUP_UPDATE] >> + metis_tac []) >> + rw [] >> + cases_on ‘x = v’ >> cases_on ‘y = v’ >> fs [FLOOKUP_UPDATE] >> + rveq + >- ( + qsuff_tac ‘distinct_lists nvars ys’ + >- ( + fs [distinct_lists_def, IN_DISJOINT, EVERY_DEF, EVERY_MEM] >> + metis_tac []) >> + unabbrev_all_tac >> + ho_match_mp_tac genlist_distinct_max >> + rw [] >> + fs [ctxt_max_def] >> res_tac >> fs []) >> + qsuff_tac ‘distinct_lists nvars xs’ + >- ( + fs [distinct_lists_def, IN_DISJOINT, EVERY_DEF, EVERY_MEM] >> + metis_tac []) >> + unabbrev_all_tac >> + ho_match_mp_tac genlist_distinct_max >> + rw [] >> + fs [ctxt_max_def] >> res_tac >> fs []) >> + conj_tac + >- ( + fs [ctxt_max_def] >> rw [] >> + cases_on ‘v = v'’ >> fs [FLOOKUP_UPDATE] >> rveq + >- ( + unabbrev_all_tac >> + fs [MEM_GENLIST]) >> + res_tac >> fs [] >> DECIDE_TAC) >> + rw [] >> + cases_on ‘v = vname’ >> fs [FLOOKUP_UPDATE] >> rveq + >- ( + drule (INST_TYPE [``:'a``|->``:num``, + ``:'b``|->``:'a word_lab``] + opt_mmap_some_eq_zip_flookup) >> + disch_then (qspecl_then [‘t.locals’, ‘flatten v'’] mp_tac) >> + fs [length_flatten_eq_size_of_shape]) >> + res_tac >> fs [] >> + ‘distinct_lists nvars ns’ by ( + unabbrev_all_tac >> + ho_match_mp_tac genlist_distinct_max >> + rw [] >> + fs [ctxt_max_def] >> res_tac >> fs []) >> + drule (INST_TYPE [``:'a``|->``:num``, + ``:'b``|->``:'a word_lab``] + opt_mmap_disj_zip_flookup) >> + disch_then (qspecl_then [‘t.locals’, ‘flatten value’] mp_tac) >> + fs [length_flatten_eq_size_of_shape]) >> + strip_tac >> unabbrev_all_tac >> fs [] >> rveq >> + conj_tac >- fs [state_rel_def] >> + conj_tac >- fs [code_rel_def] >> + cases_on ‘res = NONE ∨ res = SOME Continue ∨ res = SOME Break’ >> + fs [] >> rveq >> rfs [] >> + TRY + (qmatch_goalsub_abbrev_tac ‘ZIP (nvars, _)’ >> + qmatch_asmsub_abbrev_tac ‘locals_rel nctxt st.locals r.locals’ >> + rewrite_tac [locals_rel_def] >> + conj_tac >- fs [locals_rel_def] >> + conj_tac >- fs [locals_rel_def] >> + rw [] >> + reverse (cases_on ‘v = vname’) >> fs [] >> rveq + >- ( + drule (INST_TYPE [``:'a``|->``:mlstring``, + ``:'b``|->``:'a v``] flookup_res_var_diff_eq_org) >> + disch_then (qspecl_then [‘FLOOKUP s.locals v’, ‘st.locals’] (mp_tac o GSYM)) >> + fs [] >> strip_tac >> + fs [locals_rel_def] >> rfs [] >> + first_x_assum drule_all >> strip_tac >> fs [] >> + fs [Abbr ‘nctxt’] >> + fs [FLOOKUP_UPDATE] >> rfs [] >> + fs [opt_mmap_eq_some] >> + ‘distinct_lists nvars ns’ by ( + fs [Abbr ‘nvars’] >> ho_match_mp_tac genlist_distinct_max >> + rw [] >> fs [ctxt_max_def] >> res_tac >> fs []) >> + drule (INST_TYPE [``:'a``|->``:num``, + ``:'b``|->``:'a word_lab``] flookup_res_var_distinct) >> + disch_then (qspecl_then [‘MAP (FLOOKUP t.locals) nvars’, + ‘r.locals’] mp_tac) >> + fs [LENGTH_MAP]) >> + drule flookup_res_var_some_eq_lookup >> + strip_tac >> + qpat_x_assum ‘locals_rel ctxt s.locals t.locals’ mp_tac >> + rewrite_tac [locals_rel_def] >> + strip_tac >> fs [] >> + pop_assum drule >> + strip_tac >> fs [] >> + ‘distinct_lists nvars ns’ by ( + unabbrev_all_tac >> + ho_match_mp_tac genlist_distinct_max >> + rw [] >> + fs [ctxt_max_def] >> res_tac >> fs []) >> + fs [opt_mmap_eq_some] >> + drule (INST_TYPE [``:'a``|->``:num``, + ``:'b``|->``:'a word_lab``] + flookup_res_var_distinct) >> + disch_then (qspecl_then [‘MAP (FLOOKUP t.locals) nvars’, + ‘r.locals’] mp_tac) >> + fs [LENGTH_MAP] >> + strip_tac >> + pop_assum kall_tac >> + assume_tac rewritten_context_unassigned >> + fs [] >> + first_x_assum drule >> + disch_then (qspecl_then [‘prog’, ‘nvars’, + ‘shape_of value’] mp_tac) >> + fs [] >> + impl_tac + >- ( + conj_tac + >- ( + fs [no_overlap_def] >> + rw [] + >- (cases_on ‘x = v’ >> fs [FLOOKUP_UPDATE] >> metis_tac []) >> + rw [] >> + cases_on ‘x = v’ >> cases_on ‘y = v’ >> fs [FLOOKUP_UPDATE] >> + rveq + >- ( + qsuff_tac ‘distinct_lists nvars ys’ + >- ( + fs [distinct_lists_def, IN_DISJOINT, EVERY_DEF, EVERY_MEM] >> + metis_tac []) >> + unabbrev_all_tac >> + ho_match_mp_tac genlist_distinct_max >> + rw [] >> + fs [ctxt_max_def] >> res_tac >> fs []) >> + qsuff_tac ‘distinct_lists nvars xs’ + >- ( + fs [distinct_lists_def, IN_DISJOINT, EVERY_DEF, EVERY_MEM] >> + metis_tac []) >> + unabbrev_all_tac >> + ho_match_mp_tac genlist_distinct_max >> + rw [] >> + fs [ctxt_max_def] >> res_tac >> fs []) >> + fs [ctxt_max_def] >> rw [] >> + cases_on ‘v = v''’ >> fs [FLOOKUP_UPDATE] >> rveq + >- ( + unabbrev_all_tac >> + fs [MEM_GENLIST]) >> + res_tac >> fs [] >> DECIDE_TAC) >> + rewrite_tac [distinct_lists_def] >> + strip_tac >> fs [EVERY_MEM] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + first_x_assum (qspec_then ‘EL n ns’ mp_tac) >> + fs [EL_MEM] >> + strip_tac >> + drule unassigned_vars_evaluate_same >> fs [] >> + disch_then drule >> + strip_tac >> fs [] >> + fs [] >> + ‘LENGTH nvars = LENGTH (flatten value)’ by ( + unabbrev_all_tac >> fs [LENGTH_GENLIST]) >> + drule flookup_fupdate_zip_not_mem >> + fs [Once distinct_lists_commutes] >> + disch_then (qspecl_then [‘t.locals’, ‘EL n ns’] mp_tac) >> + fs [distinct_lists_def, EVERY_MEM] >> + impl_tac >- metis_tac [EL_MEM] >> fs [] >> NO_TAC) >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + rw [] >> fs [globals_lookup_def] +QED + +Theorem compile_Store: + ^(get_goal "compile _ (panLang$Store _ _)") +Proof + rpt gen_tac >> rpt strip_tac >> + fs [panSemTheory.evaluate_def, CaseEq "option", CaseEq "v", CaseEq "word_lab"] >> + rveq >> + fs [compile_def] >> + TOP_CASE_TAC >> + qpat_x_assum ‘eval s src = _’ mp_tac >> + drule compile_exp_val_rel >> + disch_then drule_all >> + strip_tac >> fs [shape_of_def] >> rveq >> + fs [panLangTheory.size_of_shape_def] >> + TOP_CASE_TAC >> fs [flatten_def] >> rveq >> + strip_tac >> + pairarg_tac >> fs [] >> rveq >> + drule compile_exp_val_rel >> + disch_then drule_all >> + strip_tac >> fs [] >> + qmatch_goalsub_abbrev_tac ‘stores (Var ad) (MAP Var temps) _’ >> + ‘ALL_DISTINCT (ad::temps) ∧ LENGTH (ad::temps) = LENGTH (h::es)’ by ( + unabbrev_all_tac >> + fs [length_flatten_eq_size_of_shape, LENGTH_GENLIST, + ALL_DISTINCT_GENLIST, MEM_GENLIST]) >> + ‘distinct_lists (ad::temps) (FLAT (MAP var_cexp (h::es)))’ by ( + unabbrev_all_tac >> fs [MAP] >> + ‘ctxt.vmax + 1:: GENLIST (λx. SUC x + (ctxt.vmax + 1)) (LENGTH es) = + GENLIST (λx. SUC x + ctxt.vmax) (SUC(LENGTH es))’ by ( + fs [GENLIST_CONS, o_DEF] >> fs [GENLIST_FUN_EQ])>> + fs [] >> pop_assum kall_tac >> + ho_match_mp_tac genlist_distinct_max >> + rw [] + >- ( + qpat_x_assum ‘compile_exp _ src = (_,_)’ mp_tac >> + qpat_x_assum ‘eval _ src = _’ mp_tac >> + drule eval_var_cexp_present_ctxt >> + ntac 3 (disch_then drule) >> + fs [MAP] >> disch_then drule >> + rw [] >> fs [] >> + rfs [] >> + fs [locals_rel_def, ctxt_max_def] >> + first_x_assum drule >> fs []) >> + drule eval_var_cexp_present_ctxt >> + disch_then drule_all >> + rw [] >> fs [] >> + rfs [] >> + fs [locals_rel_def, ctxt_max_def] >> + first_x_assum drule >> + fs [] >> + first_x_assum drule >> + fs [EVERY_MEM] >> + res_tac >> fs []) >> + fs [] >> + qmatch_goalsub_abbrev_tac ‘evaluate (_ _ _ p, _)’ >> + assume_tac eval_nested_decs_seq_res_var_eq >> + pop_assum (qspecl_then [‘h::es’, ‘ad::temps’, ‘t’, + ‘Word addr::flatten value’, ‘p’] mp_tac) >> + impl_tac >- fs [] >> + fs [] >> + pairarg_tac >> fs [] >> rveq >> + strip_tac >> + pop_assum kall_tac >> + fs [state_rel_def] >> + fs [Abbr ‘p’] >> + assume_tac evaluate_seq_stores_mem_state_rel >> + pop_assum (qspecl_then [‘temps’, ‘flatten value’, ‘ad’ ,‘0w’, ‘t’, + ‘q’, ‘r’, ‘addr’, ‘m’] mp_tac) >> + fs [length_flatten_eq_size_of_shape] >> + strip_tac >> + drule evaluate_seq_stroes_locals_eq >> strip_tac >> fs [] >> + rfs [] >> + fs [GSYM length_flatten_eq_size_of_shape] >> + cases_on ‘FLOOKUP t.locals ad’ + >- ( + fs [res_var_def] >> + fs [FUPDATE_LIST_THM] >> + ‘~MEM ad (MAP FST (ZIP (temps,flatten value)))’ by ( + drule MAP_ZIP >> + strip_tac >> fs []) >> + drule FUPDATE_FUPDATE_LIST_COMMUTES >> + disch_then (qspecl_then [‘Word addr’, ‘t.locals’] assume_tac) >> + fs [] >> + qpat_x_assum ‘~MEM ad temps’ assume_tac >> + drule_all domsub_commutes_fupdate >> + disch_then (qspec_then ‘t.locals’ assume_tac) >> + fs [] >> pop_assum kall_tac >> + fs [flookup_thm] >> + drule DOMSUB_NOT_IN_DOM >> strip_tac >> fs [] >> + fs [locals_rel_def] >> rw [] >> + last_x_assum drule >> strip_tac >> fs [] >> + fs [opt_mmap_eq_some] >> + ‘distinct_lists temps ns’ by ( + unabbrev_all_tac >> + once_rewrite_tac [ADD_COMM] >> fs [] >> + ho_match_mp_tac genlist_distinct_max' >> + metis_tac [locals_rel_def, ctxt_max_def]) >> + drule (INST_TYPE [``:'a``|->``:num``, + ``:'b``|->``:'a word_lab``] + flookup_res_var_zip_distinct) >> + disch_then (qspecl_then [‘flatten value’, + ‘MAP (FLOOKUP t.locals) temps’, + ‘t.locals’] mp_tac) >> + impl_tac >- fs [] >> + strip_tac >> + fs []) >> + fs [res_var_def] >> + fs [FUPDATE_LIST_THM] >> + ‘~MEM ad (MAP FST (ZIP (temps,flatten value)))’ by ( + drule MAP_ZIP >> + strip_tac >> fs []) >> + drule FUPDATE_FUPDATE_LIST_COMMUTES >> + disch_then (qspecl_then [‘x’, ‘t.locals |+ (ad,Word addr)’] assume_tac o GSYM) >> + fs [flookup_thm] >> + drule_all FUPDATE_ELIM >> + strip_tac >> fs [] >> + fs [locals_rel_def] >> rw [] >> + last_x_assum drule >> strip_tac >> fs [] >> + fs [opt_mmap_eq_some] >> + ‘distinct_lists temps ns’ by ( + unabbrev_all_tac >> + once_rewrite_tac [ADD_COMM] >> fs [] >> + ho_match_mp_tac genlist_distinct_max' >> + metis_tac [locals_rel_def, ctxt_max_def]) >> + drule (INST_TYPE [``:'a``|->``:num``, + ``:'b``|->``:'a word_lab``] + flookup_res_var_zip_distinct) >> + disch_then (qspecl_then [‘flatten value’, + ‘MAP (FLOOKUP t.locals) temps’, + ‘t.locals’] mp_tac) >> + impl_tac >- fs [] >> + strip_tac >> + fs [] +QED + +Theorem compile_StoreByte: + ^(get_goal "compile _ (panLang$StoreByte _ _)") +Proof + rpt gen_tac >> rpt strip_tac >> + fs [panSemTheory.evaluate_def, CaseEq "option", CaseEq "v", CaseEq "word_lab"] >> + rveq >> + fs [compile_def] >> + TOP_CASE_TAC >> + qpat_x_assum ‘eval s src = _’ mp_tac >> + drule compile_exp_val_rel >> + disch_then drule_all >> + strip_tac >> fs [shape_of_def] >> rveq >> + fs [panLangTheory.size_of_shape_def] >> + TOP_CASE_TAC >> fs [flatten_def] >> rveq >> + strip_tac >> + TOP_CASE_TAC >> + drule compile_exp_val_rel >> + disch_then drule_all >> + strip_tac >> fs [shape_of_def] >> rveq >> + fs [panLangTheory.size_of_shape_def] >> + fs [flatten_def] >> rveq >> + fs [evaluate_def] >> TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + fs [state_rel_def] +QED + + +Theorem compile_exp_not_mem_load_glob: + ∀s e v (t :('a, 'b) state) ct es sh ad. + panSem$eval s e = SOME v ∧ + state_rel s t ∧ + code_rel ct s.code t.code ∧ + locals_rel ct s.locals t.locals ∧ + compile_exp ct e = (es, sh) ==> + ~MEM (LoadGlob ad) (FLAT (MAP exps es)) +Proof + ho_match_mp_tac panSemTheory.eval_ind >> + rpt conj_tac >> rpt gen_tac >> strip_tac + >- ( + rename [‘Const w’] >> + fs [panSemTheory.eval_def, compile_exp_def] >> rveq >> + fs [exps_def]) + >- ( + rename [‘eval s (Var vname)’] >> + fs [panSemTheory.eval_def] >> rveq >> + fs [compile_exp_def] >> + CCONTR_TAC >> fs [] >> + FULL_CASE_TAC >> fs [] >> rveq >> fs [exps_def] >> + FULL_CASE_TAC >> fs [] >> rveq >> + fs [MEM_FLAT, MEM_MAP] >> rveq >> fs [exps_def]) + >- ( + fs [compile_exp_def] >> + CCONTR_TAC >> fs [] >> + rveq >> fs [exps_def]) + >- ( + rpt strip_tac >> fs [] >> + fs [panSemTheory.eval_def, option_case_eq] >> rveq >> + fs [compile_exp_def] >> rveq >> + rpt (pop_assum mp_tac) >> + MAP_EVERY qid_spec_tac [‘vs’, ‘es’] >> + Induct >> rw [] >> + fs [OPT_MMAP_def] >> rveq + >- ( + CCONTR_TAC >> fs [] >> + cases_on ‘compile_exp ct h’ >> fs [] >> + first_x_assum (qspec_then ‘h’ assume_tac) >> fs [] >> + metis_tac []) >> + last_x_assum mp_tac >> + impl_tac >- metis_tac [] >> + strip_tac >> fs [] >> rfs [] >> rveq >> + last_x_assum (qspec_then ‘h’ mp_tac) >> fs [] >> rfs [] >> + disch_then drule >> disch_then drule >> + cases_on ‘FST (compile_exp ct h)’ >> fs [] >> rveq >> + cases_on ‘compile_exp ct h’ >> fs []) + >- ( + rpt gen_tac >> strip_tac >> fs [] >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq] >> rveq >> + fs [compile_exp_def] >> rveq >> + pairarg_tac >> fs [CaseEq "shape"] >> rveq >- fs [exps_def] >> + first_x_assum drule >> disch_then drule >> + disch_then drule >> disch_then drule >> + disch_then (qspec_then ‘ad’ mp_tac) >> + CCONTR_TAC >> fs [] >> + ‘!m. MEM m (FLAT (MAP exps es)) ==> MEM m (FLAT (MAP exps cexp))’ + suffices_by metis_tac [] >> + pop_assum kall_tac >> pop_assum kall_tac >> + rw [] >> fs [MEM_FLAT, MEM_MAP] >> rveq >> + drule mem_comp_field >> + disch_then (qspecl_then [‘shapes’, ‘cexp’, ‘sh’, ‘y’, ‘es’] mp_tac) >> + impl_tac + >- ( + drule compile_exp_val_rel >> disch_then drule_all >> fs [] >> + strip_tac >> rfs []) >> + strip_tac >> metis_tac []) + >- ( + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq, + CaseEq "word_lab"] >> rveq >> + fs [compile_exp_def] >> rveq >> + pairarg_tac >> fs [CaseEq "shape"] >> rveq >> + FULL_CASE_TAC >> fs [] >> rveq >- fs [exps_def] >> + first_x_assum drule >> disch_then drule >> + disch_then drule >> disch_then drule >> + disch_then (qspec_then ‘ad’ mp_tac) >> + CCONTR_TAC >> fs [] >> + metis_tac [load_glob_not_mem_load]) + >- ( + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq, + CaseEq "word_lab"] >> rveq >> + fs [compile_exp_def] >> rveq >> + pairarg_tac >> fs [CaseEq "shape"] >> rveq >> + every_case_tac >> fs [] >> rveq >> fs [exps_def] >> + drule compile_exp_val_rel >> disch_then drule_all >> fs [] >> + strip_tac >> fs [panLangTheory.size_of_shape_def] >> rveq >> + last_x_assum drule >> disch_then drule >> disch_then drule >> + disch_then drule >> + disch_then (qspec_then ‘ad’ mp_tac) >> fs []) + >- ( + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq, + CaseEq "word_lab"] >> rveq >> + fs [compile_exp_def] >> rveq >> + FULL_CASE_TAC >> fs [] >> rveq >- fs [exps_def] >> + fs [exps_def] >> + fs [cexp_heads_eq] >> + fs [cexp_heads_simp_def] >> + CCONTR_TAC >> fs [] >> + fs [MAP_MAP_o] >> + fs [EVERY_MEM] >> + ‘EVERY (\x. LENGTH x = 1) (MAP (FST ∘ compile_exp ct) es)’ by ( + fs [EVERY_MEM] >> + rw [] >> + fs [MEM_MAP] >> + cases_on ‘compile_exp ct y’ >> fs [] >> + rveq >> drule opt_mmap_mem_func >> + disch_then drule >> + strip_tac >> fs [] >> + drule compile_exp_val_rel >> disch_then drule_all >> strip_tac >> + drule opt_mmap_mem_defined >> disch_then drule >> fs [] >> strip_tac >> + first_x_assum drule >> + TOP_CASE_TAC >> fs [] >> TOP_CASE_TAC >> + fs [panLangTheory.size_of_shape_def, shape_of_def] >> rveq >> + fs [panLangTheory.size_of_shape_def]) >> + ntac 7 (pop_assum mp_tac) >> + ntac 2 (pop_assum kall_tac) >> + rpt (pop_assum mp_tac) >> + MAP_EVERY qid_spec_tac [‘x’ ,‘ws’, ‘es’] >> + Induct >> rpt gen_tac >> rpt strip_tac >> + fs [OPT_MMAP_def] >> rveq >> fs [] + >- ( + last_x_assum mp_tac >> + impl_tac >- metis_tac [] >> + strip_tac >> fs [] >> + last_x_assum (qspec_then ‘h’ mp_tac) >> + impl_tac >- fs [] >> + ntac 3 (disch_then drule) >> + cases_on ‘compile_exp ct h’ >> fs [] >> + cases_on ‘q’ >> fs [] >> metis_tac []) >> + last_x_assum mp_tac >> + impl_tac >- metis_tac [] >> + impl_tac >- fs [] >> + fs [EVERY_MEM]) + >- ( + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq, + CaseEq "word_lab"] >> rveq >> + fs [compile_exp_def] >> rveq >> + every_case_tac >> fs [] >> rveq >> fs [exps_def] >> + cases_on ‘compile_exp ct e'’ >> + cases_on ‘compile_exp ct e’ >> fs [] >> rveq >> + drule compile_exp_val_rel >> disch_then drule_all >> strip_tac >> + qpat_x_assum ‘eval s e = SOME (ValWord w1)’ assume_tac >> + drule compile_exp_val_rel >> disch_then drule_all >> strip_tac >> + fs [flatten_def] >> + rveq >> fs [panLangTheory.size_of_shape_def, shape_of_def] >> rveq >> + last_x_assum drule >> last_x_assum drule >> + rpt (disch_then drule) >> disch_then (qspec_then ‘ad’ mp_tac) >> + strip_tac >> + rpt (disch_then drule) >> disch_then (qspec_then ‘ad’ mp_tac) >> + fs []) >> + rpt gen_tac >> strip_tac >> + fs [panSemTheory.eval_def, option_case_eq, v_case_eq, + CaseEq "word_lab"] >> rveq >> + fs [compile_exp_def] >> rveq >> + every_case_tac >> fs [] >> rveq >> fs [exps_def] >> + cases_on ‘compile_exp ct e’ >> fs [] >> rveq >> + drule compile_exp_val_rel >> disch_then drule_all >> strip_tac >> + qpat_x_assum ‘eval s e = SOME (ValWord w)’ assume_tac >> + fs [flatten_def] >> + rveq >> fs [panLangTheory.size_of_shape_def, shape_of_def] >> rveq >> + last_x_assum drule >> + rpt (disch_then drule) >> disch_then (qspec_then ‘ad’ mp_tac) >> + fs [] +QED + + +Theorem compile_Return: + ^(get_goal "compile _ (panLang$Return _)") +Proof + rpt gen_tac >> rpt strip_tac >> + fs [panSemTheory.evaluate_def, CaseEq "option", CaseEq "bool"] >> + rveq >> fs [] >> + fs [compile_def] >> + pairarg_tac >> fs [] >> rveq >> + drule compile_exp_val_rel >> + disch_then drule_all >> + strip_tac >> rveq >> rfs [] >> + TOP_CASE_TAC >> fs [] >> rveq + >- ( + fs [evaluate_def, eval_def] >> + fs [state_rel_def,panSemTheory.empty_locals_def, + empty_locals_def, state_component_equality]) >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq + >- ( + fs [evaluate_def, eval_def] >> + fs [state_rel_def,panSemTheory.empty_locals_def, + empty_locals_def, state_component_equality]) >> + fs [evaluate_def] >> + pairarg_tac >> fs [] >> + fs [eval_def] >> + qmatch_asmsub_abbrev_tac ‘nested_decs temps es p’ >> + ‘distinct_lists temps (FLAT (MAP var_cexp es))’ by ( + fs [Abbr ‘temps’] >> + ho_match_mp_tac genlist_distinct_max >> + rw [] >> + drule eval_var_cexp_present_ctxt >> + disch_then drule_all >> + rw [] >> fs [] >> + rfs [] >> + fs [locals_rel_def, ctxt_max_def] >> + first_x_assum drule >> + fs [] >> + first_x_assum drule >> + fs [EVERY_MEM] >> + res_tac >> fs []) >> + ‘ALL_DISTINCT temps ∧ LENGTH es = LENGTH temps’ by ( + unabbrev_all_tac >> + fs [LENGTH_GENLIST, ALL_DISTINCT_GENLIST]) >> + fs [] >> + assume_tac eval_nested_decs_seq_res_var_eq >> + pop_assum (qspecl_then [‘es’, ‘temps’, ‘t’, ‘flatten value’, + ‘nested_seq (store_globals 0w (MAP Var temps))’] mp_tac) >> + impl_tac >- (unabbrev_all_tac >> fs []) >> + fs [] >> pairarg_tac >> fs [] >> rveq >> strip_tac >> rveq >> + fs [Abbr ‘p’] >> + drule evaluate_seq_store_globals_res >> + disch_then (qspecl_then [‘flatten value’, ‘t’, ‘0w’] mp_tac) >> + fs [Abbr ‘es’, length_flatten_eq_size_of_shape] >> + strip_tac >> fs [] >> + drule (INST_TYPE [``:'a``|->``:num``, + ``:'b``|->``:'a word_lab``] res_var_lookup_original_eq) >> + disch_then (qspecl_then [‘flatten value’, ‘t.locals’] assume_tac) >> + rfs [length_flatten_eq_size_of_shape] >> rveq >> + conj_tac + >- fs [state_rel_def,panSemTheory.empty_locals_def, + empty_locals_def, state_component_equality] >> + conj_tac >- fs [empty_locals_def, panSemTheory.empty_locals_def] >> + conj_tac + >- ( + fs [empty_locals_def, panSemTheory.empty_locals_def, excp_rel_def] >> + rw [] >> last_x_assum drule_all >> fs []) >> + fs [empty_locals_def] >> + qmatch_goalsub_abbrev_tac ‘t with <|locals := _; globals := g|>’ >> + cases_on ‘flatten value’ >> fs [] >> + fs [globals_lookup_def, Abbr ‘g’] >> + qpat_x_assum ‘LENGTH temps = _’ (assume_tac o GSYM) >> + fs [opt_mmap_eq_some] >> + fs [] >> + cases_on ‘temps = []’ >> fs [] >> + ‘GENLIST (λx. (n2w x):word5) (LENGTH temps) = MAP n2w (0 :: [1 .. (LENGTH temps)-1])’ by ( + fs [GENLIST_eq_MAP] >> + fs [listRangeINC_def] >> rw [] >> + cases_on ‘0 < x’ >> fs [NOT_LT_ZERO_EQ_ZERO] >> + drule (INST_TYPE [``:'a``|->``:num``] el_reduc_tl) >> + disch_then (qspec_then ‘0::GENLIST (λi. i + 1) (LENGTH temps - 1)’ assume_tac) >> fs []) >> + fs [] >> conj_tac + >- ( + fs [FUPDATE_LIST_THM] >> + ‘~MEM (0w:word5) (MAP FST (ZIP (MAP n2w [1 .. LENGTH temps - 1],t'')))’ by ( + once_rewrite_tac [listRangeINC_def] >> fs [] >> + ‘LENGTH temps - 1 = LENGTH t''’ by rfs [GSYM length_flatten_eq_size_of_shape] >> + fs [] >> + qmatch_goalsub_abbrev_tac ‘ZIP (gn,_)’ >> + ‘MAP FST (ZIP (gn,t'')) = gn’ by fs [Abbr ‘gn’, MAP_ZIP, LENGTH_GENLIST] >> + fs [] >> fs [Abbr ‘gn’] >> + match_mp_tac zero_not_mem_genlist_offset >> DECIDE_TAC) >> + drule FUPDATE_FUPDATE_LIST_COMMUTES >> + disch_then (qspecl_then [‘h'’, ‘t.globals’] assume_tac) >> + fs [FLOOKUP_DEF]) >> + fs [MAP_EQ_EVERY2] >> conj_tac >- fs [listRangeINC_def] >> + fs [LIST_REL_EL_EQN] >> conj_tac >- fs [listRangeINC_def] >> + fs [FUPDATE_LIST_THM] >> rw [] >> + match_mp_tac update_eq_zip_flookup >> + fs [] >> fs [listRangeINC_def] >> + match_mp_tac ALL_DISTINCT_MAP_INJ >> + rw [] >> fs [ALL_DISTINCT_GENLIST] >> + fs [MEM_GENLIST] >> rveq >> + ‘i < 32 ∧ i' < 32’ by fs [] >> + rfs [] +QED + +Theorem compile_Raise: + ^(get_goal "compile _ (panLang$Raise _ _)") +Proof + rpt gen_tac >> rpt strip_tac >> + fs [panSemTheory.evaluate_def, CaseEq "option", CaseEq "bool"] >> + rveq >> fs [] >> + fs [compile_def] >> + pairarg_tac >> fs [] >> rveq >> + drule compile_exp_val_rel >> + disch_then drule_all >> + strip_tac >> rveq >> rfs [] >> + TOP_CASE_TAC + >- ( + fs [excp_rel_def] >> + imp_res_tac fdoms_eq_flookup_some_none >> fs []) >> + fs [evaluate_def] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘nested_decs temps es p’ >> + ‘distinct_lists temps (FLAT (MAP var_cexp es))’ by ( + fs [Abbr ‘temps’] >> + ho_match_mp_tac genlist_distinct_max >> + rw [] >> + drule eval_var_cexp_present_ctxt >> + disch_then drule_all >> + rw [] >> fs [] >> + rfs [] >> + fs [locals_rel_def, ctxt_max_def] >> + first_x_assum drule >> + fs [] >> + first_x_assum drule >> + fs [EVERY_MEM] >> + res_tac >> fs []) >> + ‘ALL_DISTINCT temps ∧ LENGTH es = LENGTH temps’ by ( + unabbrev_all_tac >> + fs [LENGTH_GENLIST, ALL_DISTINCT_GENLIST]) >> + fs [] >> + assume_tac eval_nested_decs_seq_res_var_eq >> + pop_assum (qspecl_then [‘es’, ‘temps’, ‘t’, ‘flatten value’, + ‘nested_seq (store_globals 0w (MAP Var temps))’] mp_tac) >> + impl_tac >- (unabbrev_all_tac >> fs []) >> + fs [] >> pairarg_tac >> fs [] >> rveq >> strip_tac >> rveq >> + fs [Abbr ‘p’] >> + drule evaluate_seq_store_globals_res >> + disch_then (qspecl_then [‘flatten value’, ‘t’, ‘0w’] mp_tac) >> + fs [length_flatten_eq_size_of_shape] >> + strip_tac >> fs [] >> + drule (INST_TYPE [``:'a``|->``:num``, + ``:'b``|->``:'a word_lab``] res_var_lookup_original_eq) >> + disch_then (qspecl_then [‘flatten value’, ‘t.locals’] assume_tac) >> + rfs [length_flatten_eq_size_of_shape] >> rveq >> + conj_tac + >- fs [state_rel_def,panSemTheory.empty_locals_def, + empty_locals_def, state_component_equality] >> + conj_tac >- fs [empty_locals_def, panSemTheory.empty_locals_def] >> + conj_tac + >- ( + fs [empty_locals_def, panSemTheory.empty_locals_def, excp_rel_def] >> + rw [] >> last_x_assum drule_all >> fs []) >> + strip_tac >> + fs [empty_locals_def] >> + fs [globals_lookup_def] >> + fs [opt_mmap_eq_some] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + ‘ALL_DISTINCT (GENLIST (λx. (n2w x): word5) (LENGTH (flatten value)))’ by ( + fs [ALL_DISTINCT_GENLIST] >> + rw [] >> rfs []) >> + drule (INST_TYPE [``:'a``|->``:word5``, + ``:'b``|->``:'a word_lab``] update_eq_zip_flookup) >> + disch_then (qspecl_then [‘t.globals’, ‘flatten value’, ‘n’] mp_tac) >> + fs [] +QED + + +Theorem compile_Seq: + ^(get_goal "compile _ (panLang$Seq _ _)") +Proof + rpt gen_tac >> rpt strip_tac >> + fs [compile_def] >> + fs [panSemTheory.evaluate_def] >> + pairarg_tac >> fs [] >> rveq >> + cases_on ‘res' = NONE’ >> fs [] >> + rveq >> fs [] + >- ( + fs [evaluate_def] >> + pairarg_tac >> fs [] >> rveq >> + first_x_assum drule_all >> fs []) >> + fs [evaluate_def] >> + pairarg_tac >> fs [] >> rveq >> + first_x_assum drule_all >> strip_tac >> + fs [] >> rveq >> + + cases_on ‘res’ >> fs [] >> + cases_on ‘x’ >> fs [] >> + TRY (cases_on ‘FLOOKUP ctxt.eids m’ >> fs [] >> cases_on ‘x’ >> fs []) >> + cases_on ‘size_of_shape (shape_of v) = 0’ >> fs [] >> + cases_on ‘size_of_shape (shape_of v) = 1’ >> fs [] +QED + + +Theorem compile_If: + ^(get_goal "compile _ (panLang$If _ _ _)") +Proof + rpt gen_tac >> rpt strip_tac >> + fs [panSemTheory.evaluate_def] >> + fs [compile_def] >> + cases_on ‘eval s e’ >> fs [] >> + cases_on ‘x’ >> fs [] >> + cases_on ‘w’ >> fs [] >> + TOP_CASE_TAC >> fs [] >> + drule compile_exp_val_rel >> + disch_then drule_all >> + strip_tac >> fs [flatten_def] >> + rveq >> fs [] >> + fs [evaluate_def] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + last_x_assum drule_all >> + strip_tac >> fs [] >> + rfs [] >> + cases_on ‘res’ >> fs [] >> + rveq >> fs [] >> + cases_on ‘c = 0w’ >> fs [] +QED + +Theorem compile_While: + ^(get_goal "compile _ (panLang$While _ _)") +Proof + rpt gen_tac >> rpt strip_tac >> + qpat_x_assum ‘evaluate (While e c,s) = (res,s1)’ mp_tac >> + once_rewrite_tac [panSemTheory.evaluate_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + strip_tac >> + fs [compile_def] >> + TOP_CASE_TAC >> fs [] >> + drule_all compile_exp_val_rel >> + once_rewrite_tac [shape_of_def] >> + strip_tac >> + pop_assum (assume_tac o GSYM) >> + fs [] >> + TOP_CASE_TAC >> fs [panLangTheory.size_of_shape_def, flatten_def] >> + rveq >> fs [MAP] >> + reverse (cases_on ‘c' ≠ 0w’) >> fs [] >> rveq + >- fs [Once evaluate_def] >> + pairarg_tac >> fs [] >> + cases_on ‘s.clock = 0’ >> fs [] >> rveq >> fs [] + >- ( + fs [Once evaluate_def] >> + pairarg_tac >> fs [] >> + fs [state_rel_def] >> rveq >> + fs [empty_locals_def, panSemTheory.empty_locals_def]) >> + ‘t.clock <> 0’ by fs [state_rel_def] >> + reverse (cases_on ‘res'’) >> fs [] + >- ( + cases_on ‘x’ >> fs [] >> rveq >> + fs [Once evaluate_def] >> + pairarg_tac >> fs [] >> + last_x_assum (qspecl_then [‘dec_clock t’, ‘ctxt’] mp_tac) >> + impl_tac >> + TRY ( + fs [dec_clock_def, panSemTheory.dec_clock_def, state_rel_def] >> + NO_TAC) + >- ( + strip_tac >> fs [] >> rveq >> + fs [] >> + last_x_assum drule_all >> + strip_tac >> fs [] >> rfs []) + >- ( + strip_tac >> fs [] >> rveq >> + cases_on ‘size_of_shape (shape_of v) = 0’ >> fs [] >> + cases_on ‘size_of_shape (shape_of v) = 1’ >> fs []) >> + strip_tac >> fs [] >> rveq >> + cases_on ‘FLOOKUP ctxt.eids m’ >> fs [] >> + cases_on ‘x’ >> fs [] >> + cases_on ‘size_of_shape (shape_of v) = 0’ >> fs [] >> + cases_on ‘size_of_shape (shape_of v) = 1’ >> fs []) >> + fs [Once evaluate_def] >> + pairarg_tac >> fs [] >> + last_x_assum (qspecl_then [‘dec_clock t’, ‘ctxt’] mp_tac) >> + impl_tac + >- ( + fs [dec_clock_def, panSemTheory.dec_clock_def, state_rel_def]) >> + strip_tac >> fs [] >> rveq >> fs [] >> rfs [] >> + last_x_assum drule_all >> + fs [] >> + strip_tac >> fs [] >> rveq >> rfs [] +QED + + +Theorem eval_map_comp_exp_flat_eq: + !argexps args s t ctxt. MAP (eval s) argexps = MAP SOME args /\ + state_rel s t ∧ code_rel ctxt s.code t.code ∧ + locals_rel ctxt s.locals t.locals ==> + MAP (eval t) (FLAT (MAP FST (MAP (compile_exp ctxt) argexps))) = + MAP SOME (FLAT (MAP flatten args)) +Proof + Induct >> rpt gen_tac >> strip_tac + >- (cases_on ‘args’ >> fs []) >> + cases_on ‘args’ >> fs [] >> + fs [MAP_APPEND] >> + cases_on ‘compile_exp ctxt h’ >> fs [] >> + drule compile_exp_val_rel >> + disch_then drule_all >> + strip_tac >> fs [] >> + last_x_assum (qspecl_then [‘t'’] mp_tac) >> + fs [] >> + disch_then drule_all >> + fs [] +QED + + +Theorem local_rel_gt_vmax_preserved: + !ct l l' n v. + locals_rel ct l l' /\ ct.vmax < n ==> + locals_rel ct l (l' |+ (n,v)) +Proof + rw [] >> + fs [locals_rel_def] >> + rw [] >> + first_x_assum drule_all >> + strip_tac >> fs [] >> + fs [opt_mmap_eq_some] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + ‘EL n' ns <= ct.vmax’ by ( + drule ctxt_max_el_leq >> metis_tac []) >> + fs [FLOOKUP_UPDATE] +QED + +Theorem local_rel_le_zip_update_preserved: + !ct l l' x v sh ns v'. + locals_rel ct l l' /\ + FLOOKUP l x = SOME v /\ + FLOOKUP ct.vars x = SOME (sh,ns) /\ + shape_of v = shape_of v' ∧ ALL_DISTINCT ns ==> + locals_rel ct (l |+ (x,v')) (l' |++ ZIP (ns,flatten v')) +Proof + rw [] >> + drule_all locals_rel_lookup_ctxt >> + strip_tac >> fs [] >> + fs [locals_rel_def] >> + rw [] >> + fs [FLOOKUP_UPDATE] >> + FULL_CASE_TAC >> fs [] >> rveq >> + first_x_assum drule_all >> fs [] + >- ( + match_mp_tac opt_mmap_some_eq_zip_flookup >> + fs [opt_mmap_eq_some, MAP_EQ_EVERY2, + length_flatten_eq_size_of_shape]) >> + strip_tac >> fs [] >> + pop_assum (assume_tac o GSYM) >> + fs [] >> + match_mp_tac opt_mmap_disj_zip_flookup >> + fs [length_flatten_eq_size_of_shape] >> + fs [no_overlap_def] >> + first_x_assum (qspecl_then [‘x’, ‘vname’, ‘shape_of v’, + ‘shape_of v''’, ‘ns’, ‘ns''’] mp_tac) >> + fs [] >> fs [distinct_lists_def, IN_DISJOINT, EVERY_MEM] >> + metis_tac [] +QED + +Theorem ctxt_fc_funcs_eq: + (ctxt_fc cvs em vs shs ns).funcs = cvs +Proof + rw [ctxt_fc_def] +QED + +Theorem ctxt_fc_eids_eq: + (ctxt_fc cvs em vs shs ns).eids = em +Proof + rw [ctxt_fc_def] +QED + +Theorem ctxt_fc_vmax: + (ctxt_fc ctxt.funcs em vs shs ns).vmax = list_max ns +Proof + rw [ctxt_fc_def] +QED + +Definition slc_def: + slc vshs args = FEMPTY |++ ZIP (MAP FST vshs,args) +End + +Definition tlc_def: + tlc ns args = FEMPTY |++ ZIP (ns,FLAT (MAP flatten args)) +End + +Theorem slc_tlc_rw: + FEMPTY |++ ZIP (MAP FST vsh,args) = slc vsh args ∧ + FEMPTY |++ ZIP (ns,FLAT (MAP flatten args)) = tlc ns args +Proof + rw [slc_def, tlc_def] +QED + +Theorem call_preserve_state_code_locals_rel: + ALL_DISTINCT (MAP FST vshs) /\ + LIST_REL (λvshape arg. SND vshape = shape_of arg) vshs args /\ + state_rel s t /\ + code_rel ctxt s.code t.code /\ + excp_rel ctxt.eids s.eshapes /\ + locals_rel ctxt s.locals t.locals /\ + FLOOKUP s.code fname = SOME (vshs,prog) /\ + FLOOKUP ctxt.funcs fname = SOME vshs /\ + ALL_DISTINCT ns /\ + size_of_shape (Comb (MAP SND vshs)) = LENGTH (FLAT (MAP flatten args)) /\ + FLOOKUP t.code fname = SOME (ns, compile + (ctxt_fc ctxt.funcs ctxt.eids (MAP FST vshs) (MAP SND vshs) ns) prog) /\ + LENGTH ns = LENGTH (FLAT (MAP flatten args)) ==> + state_rel (dec_clock s with locals := slc vshs args) (dec_clock t with locals := tlc ns args) ∧ + code_rel (ctxt_fc ctxt.funcs ctxt.eids (MAP FST vshs) (MAP SND vshs) ns) + (dec_clock s).code (dec_clock t).code ∧ + excp_rel (ctxt_fc ctxt.funcs ctxt.eids (MAP FST vshs) (MAP SND vshs) ns).eids + (dec_clock s).eshapes ∧ + locals_rel (ctxt_fc ctxt.funcs ctxt.eids (MAP FST vshs) (MAP SND vshs) ns) (slc vshs args) (tlc ns args) +Proof + strip_tac >> fs [] >> + conj_tac >- fs [state_rel_def, dec_clock_def, panSemTheory.dec_clock_def] >> + conj_tac + >- ( + fs [code_rel_def, ctxt_fc_def] >> + rw [] >> + fs [panSemTheory.dec_clock_def] >> + last_x_assum drule_all >> + fs [dec_clock_def]) >> + conj_tac + >- fs [ctxt_fc_def, panSemTheory.dec_clock_def] >> + fs [locals_rel_def] >> + conj_tac (* replicating because needs to preserve fm in the third conjunct *) + >- ( + ‘(ctxt_fc ctxt.funcs ctxt.eids (MAP FST vshs) (MAP SND vshs) ns).vars = + alist_to_fmap (ZIP (MAP FST vshs,ZIP (MAP SND vshs,with_shape (MAP SND vshs) ns)))’ by ( + fs [ctxt_fc_def] >> + match_mp_tac fm_empty_zip_alist >> fs [length_with_shape_eq_shape]) >> fs [] >> + metis_tac [all_distinct_alist_no_overlap, LENGTH_MAP]) >> + conj_tac + >- ( + ‘(ctxt_fc ctxt.funcs ctxt.eids (MAP FST vshs) (MAP SND vshs) ns).vars = + alist_to_fmap (ZIP (MAP FST vshs,ZIP (MAP SND vshs,with_shape (MAP SND vshs) ns)))’ by ( + fs [ctxt_fc_def] >> + match_mp_tac fm_empty_zip_alist >> fs [length_with_shape_eq_shape]) >> fs [ctxt_fc_vmax] >> + match_mp_tac all_distinct_alist_ctxt_max >> fs []) >> + rw [] >> fs [locals_rel_def, ctxt_fc_def, slc_def, tlc_def] >> + ‘LENGTH (MAP FST vshs) = LENGTH args’ by (drule LIST_REL_LENGTH >> fs []) >> + drule fm_empty_zip_flookup >> fs [] >> + disch_then drule >> + strip_tac >> fs [] >> + qexists_tac ‘EL n (with_shape (MAP SND vshs) ns)’ >> + conj_tac + >- ( (* could be neater *) + ‘FLOOKUP (FEMPTY |++ ZIP (MAP FST vshs,ZIP (MAP SND vshs,with_shape (MAP SND vshs) ns))) vname = + SOME (EL n (MAP SND vshs),EL n (with_shape (MAP SND vshs) ns))’ by ( + match_mp_tac fm_empty_zip_flookup_el >> + fs [] >> ‘LENGTH ns = size_of_shape (Comb (MAP SND vshs))’ by fs [] >> + drule length_with_shape_eq_shape >> fs [] >> strip_tac >> + ‘LENGTH (MAP FST vshs) = LENGTH args’ by fs [] >> drule EL_ZIP >> + disch_then (qspec_then ‘n’ mp_tac) >> fs []) >> + fs [] >> + ‘n < LENGTH (MAP FST vshs)’ by fs [] >> + ‘LENGTH (MAP FST vshs) = LENGTH args’ by fs [] >> + drule EL_ZIP >> + disch_then (qspec_then ‘n’ assume_tac) >> + rfs [] >> rveq >> + fs [LIST_REL_EL_EQN] >> + last_x_assum drule >> fs [EL_MAP]) >> + fs [opt_mmap_eq_some] >> + fs [MAP_EQ_EVERY2] >> conj_tac + >- ( + match_mp_tac list_rel_flatten_with_shape_length >> + qexists_tac ‘args’ >> fs [] >> + ‘LENGTH (MAP FST vshs) = LENGTH args’ by fs [] >> drule EL_ZIP >> + disch_then (qspec_then ‘n’ mp_tac) >> fs [] >> + strip_tac >> fs [EVERY2_MAP]) >> + rewrite_tac [LIST_REL_EL_EQN] >> conj_tac + >- ( + match_mp_tac list_rel_flatten_with_shape_length >> + qexists_tac ‘args’ >> fs [] >> + ‘LENGTH (MAP FST vshs) = LENGTH args’ by fs [] >> drule EL_ZIP >> + disch_then (qspec_then ‘n’ mp_tac) >> fs [] >> + strip_tac >> fs [EVERY2_MAP]) >> + rw [] >> match_mp_tac list_rel_flatten_with_shape_flookup >> fs [] >> + ‘LENGTH (MAP FST vshs) = LENGTH args’ by fs [] >> drule EL_ZIP >> + disch_then (qspec_then ‘n’ mp_tac) >> fs [] >> strip_tac >> + fs [EVERY2_MAP] >> + match_mp_tac list_rel_flatten_with_shape_length >> + qexists_tac ‘args’ >> fs [] >> + fs [EVERY2_MAP] +QED + + +val clock_zero_tail_rt_tac = + fs [evaluate_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> + ‘OPT_MMAP (eval t) + (FLAT (MAP FST (MAP (compile_exp ctxt) argexps))) = SOME (FLAT (MAP flatten args))’ by ( + fs [opt_mmap_eq_some] >> metis_tac [eval_map_comp_exp_flat_eq]) >> + fs [] >> + fs [panSemTheory.lookup_code_def, CaseEq "option", CaseEq "prod"] >> rveq >> + drule code_rel_imp >> + disch_then drule >> + strip_tac >> fs [] >> + fs [lookup_code_def] >> + drule list_rel_length_shape_of_flatten >> + fs [] >> + strip_tac >> + fs [ALL_DISTINCT_GENLIST] >> + drule code_rel_empty_locals >> + fs [state_rel_def, panSemTheory.empty_locals_def, + empty_locals_def, ALL_DISTINCT_GENLIST] + +val clock_zero_nested_seq_rt_tac = + fs [nested_seq_def] >> + fs [evaluate_def] >> + pairarg_tac >> fs [] >> + cases_on ‘eval t x0’ >> fs [] >> + cases_on ‘x’ >> fs [] >> + ‘OPT_MMAP (eval t) + (FLAT (MAP FST (MAP (compile_exp ctxt) argexps))) = SOME (FLAT (MAP flatten args))’ by ( + fs [opt_mmap_eq_some] >> metis_tac [eval_map_comp_exp_flat_eq]) >> + fs [] >> rveq >> + fs [panSemTheory.lookup_code_def] >> + cases_on ‘FLOOKUP s.code fname’ >> fs [] >> + cases_on ‘x’ >> fs [] >> rveq >> + drule code_rel_imp >> + disch_then drule >> + strip_tac >> fs [] >> + fs [lookup_code_def] >> + drule list_rel_length_shape_of_flatten >> + fs [] >> + strip_tac >> + fs [ALL_DISTINCT_GENLIST] >> + strip_tac >> fs [] >> + fs [state_rel_def] >> rveq >> rfs [] >> + rveq >> fs [] >> + drule code_rel_empty_locals >> + fs [panSemTheory.empty_locals_def, + empty_locals_def, ALL_DISTINCT_GENLIST] + +val rels_empty_tac = + fs [Abbr ‘nctxt’, state_rel_def, ctxt_fc_funcs_eq, ctxt_fc_eids_eq, + excp_rel_def, empty_locals_def, panSemTheory.empty_locals_def, code_rel_def, + globals_lookup_def] + +val tail_call_tac = + fs [evaluate_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> + ‘OPT_MMAP (eval t) + (FLAT (MAP FST (MAP (compile_exp ctxt) argexps))) = SOME (FLAT (MAP flatten args))’ by ( + fs [opt_mmap_eq_some] >> metis_tac [eval_map_comp_exp_flat_eq]) >> + fs [] >> + fs [panSemTheory.lookup_code_def] >> + cases_on ‘FLOOKUP s.code fname’ >> fs [] >> + cases_on ‘x’ >> fs [] >> rveq >> + drule code_rel_imp >> + disch_then drule >> + strip_tac >> fs [] >> + fs [lookup_code_def] >> + drule list_rel_length_shape_of_flatten >> + fs [] >> + strip_tac >> + fs [ALL_DISTINCT_GENLIST] >> + TOP_CASE_TAC >- fs [state_rel_def] >> + cases_on ‘evaluate + (prog, + dec_clock s with locals := FEMPTY |++ ZIP (MAP FST q,args))’ >> + fs [] >> + cases_on ‘q'’ >> fs [] >> + cases_on ‘x’ >> fs [] >> rveq >> + qmatch_goalsub_abbrev_tac ‘compile nctxt _,nt’ >> + first_x_assum (qspecl_then [‘nt’, ‘nctxt’] mp_tac) >> + impl_tac >> + TRY ( + fs [Abbr ‘nctxt’, Abbr ‘nt’, slc_tlc_rw] >> + qmatch_goalsub_abbrev_tac ‘(dec_clock t with locals := tlc ns _)’ >> + match_mp_tac call_preserve_state_code_locals_rel >> + fs [Abbr ‘ns’, ALL_DISTINCT_GENLIST]) + >- (strip_tac >> fs [] >> rels_empty_tac) + >- ( + strip_tac >> fs [] >> + TOP_CASE_TAC >> fs [] >> TOP_CASE_TAC >> fs [] >> rels_empty_tac) + >- ( + strip_tac >> fs [] >> + cases_on ‘FLOOKUP nctxt.eids m’ >> fs [] >> + cases_on ‘x’ >> fs [] >> + TOP_CASE_TAC >> fs [] >> + rels_empty_tac) >> + strip_tac >> rels_empty_tac + + +val call_tail_ret_impl_tac = + fs [evaluate_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> + ‘OPT_MMAP (eval t) + (FLAT (MAP FST (MAP (compile_exp ctxt) argexps))) = SOME (FLAT (MAP flatten args))’ by ( + fs [opt_mmap_eq_some] >> metis_tac [eval_map_comp_exp_flat_eq]) >> + fs [] >> + fs [panSemTheory.lookup_code_def, CaseEq "option", CaseEq "prod"] >> rveq >> + drule code_rel_imp >> + disch_then drule >> + strip_tac >> fs [] >> + fs [lookup_code_def] >> + drule list_rel_length_shape_of_flatten >> + fs [] >> + strip_tac >> + fs [ALL_DISTINCT_GENLIST] >> + TOP_CASE_TAC >- fs [state_rel_def] >> + qmatch_goalsub_abbrev_tac ‘compile nctxt _,nt’ >> + first_x_assum (qspecl_then [‘nt’, ‘nctxt’] mp_tac) >> + impl_tac + >- ( + fs [Abbr ‘nctxt’, Abbr ‘nt’, slc_tlc_rw] >> + qmatch_goalsub_abbrev_tac ‘(dec_clock t with locals := tlc ns _)’ >> + match_mp_tac call_preserve_state_code_locals_rel >> + fs [Abbr ‘ns’, ALL_DISTINCT_GENLIST]) >> + strip_tac >> fs [] >> + fs [state_rel_def, Abbr ‘nctxt’, code_rel_def, ctxt_fc_funcs_eq, + panSemTheory.empty_locals_def, empty_locals_def, ctxt_fc_eids_eq, excp_rel_def] + +val ret_call_shape_retv_one_tac = + fs [evaluate_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + ‘OPT_MMAP (eval t) + (FLAT (MAP FST (MAP (compile_exp ctxt) argexps))) = SOME (FLAT (MAP flatten args))’ by ( + fs [opt_mmap_eq_some] >> metis_tac [eval_map_comp_exp_flat_eq]) >> + fs [] >> + fs [panSemTheory.lookup_code_def, CaseEq "option", CaseEq "prod"] >> rveq >> + drule code_rel_imp >> + disch_then drule >> + strip_tac >> fs [] >> + fs [lookup_code_def] >> + drule list_rel_length_shape_of_flatten >> + fs [] >> + strip_tac >> + fs [ALL_DISTINCT_GENLIST] >> + TOP_CASE_TAC >- fs [state_rel_def] >> + qmatch_goalsub_abbrev_tac ‘compile nctxt _,nt’ >> + first_x_assum (qspecl_then [‘nt’, ‘nctxt’] mp_tac) >> + impl_tac + >- ( + fs [Abbr ‘nctxt’, Abbr ‘nt’, slc_tlc_rw] >> + qmatch_goalsub_abbrev_tac ‘(dec_clock t with locals := tlc ns _)’ >> + match_mp_tac call_preserve_state_code_locals_rel >> + fs [Abbr ‘ns’, ALL_DISTINCT_GENLIST]) >> + strip_tac >> fs [] >> + ‘size_of_shape (shape_of x) = 1’ by ( + fs [locals_rel_def] >> + last_x_assum drule >> fs [shape_of_def] >> strip_tac >> + qpat_x_assum ‘One = shape_of x’ (assume_tac o GSYM) >> + fs [panLangTheory.size_of_shape_def]) >> + fs [shape_of_def] >> + drule locals_rel_lookup_ctxt >> + disch_then drule >> strip_tac >> fs [] >> + rveq >> fs [OPT_MMAP_def] >> rveq >> + fs [state_rel_def, panSemTheory.set_var_def,set_var_def, + Abbr ‘nctxt’, code_rel_def, ctxt_fc_funcs_eq,ctxt_fc_eids_eq, + panSemTheory.set_var_def,set_var_def] >> + fs [length_flatten_eq_size_of_shape] >> + rfs [panLangTheory.size_of_shape_def] >> + fs [locals_rel_def, panSemTheory.set_var_def,set_var_def] >> + rw [] >> rveq >> + fs [FLOOKUP_UPDATE] >> + FULL_CASE_TAC >> fs [] >> rveq + >- ( + fs [OPT_MMAP_def, FLOOKUP_UPDATE] >> rveq >> + fs [length_flatten_eq_size_of_shape, panLangTheory.size_of_shape_def]) >> + res_tac >> fs [] >> + match_mp_tac opt_mmap_flookup_update >> + fs [] >> + drule no_overlap_flookup_distinct >> + disch_then drule_all >> fs [distinct_lists_def] + + +val ret_call_shape_retv_comb_zero_tac = + fs [ret_var_def, ret_hdl_def] >> + fs [evaluate_def] >> + cases_on ‘eval t x0’ >> fs [] >> + cases_on ‘x'’ >> fs [] >> + ‘OPT_MMAP (eval t) + (FLAT (MAP FST (MAP (compile_exp ctxt) argexps))) = SOME (FLAT (MAP flatten args))’ by ( + fs [opt_mmap_eq_some] >> metis_tac [eval_map_comp_exp_flat_eq]) >> + fs [] >> + fs [panSemTheory.lookup_code_def, CaseEq "option", CaseEq "prod"] >> rveq >> + drule code_rel_imp >> + disch_then drule >> + strip_tac >> fs [] >> + fs [lookup_code_def] >> + drule list_rel_length_shape_of_flatten >> + fs [] >> + strip_tac >> + fs [ALL_DISTINCT_GENLIST] >> + cases_on ‘t.clock = 0’ >- fs [state_rel_def] >> + fs [] >> rveq >> + qmatch_goalsub_abbrev_tac ‘compile nctxt _,nt’ >> + first_x_assum (qspecl_then [‘nt’, ‘nctxt’] mp_tac) >> + impl_tac + >- ( + fs [Abbr ‘nctxt’, Abbr ‘nt’, slc_tlc_rw] >> + qmatch_goalsub_abbrev_tac ‘(dec_clock t with locals := tlc ns _)’ >> + match_mp_tac call_preserve_state_code_locals_rel >> + fs [Abbr ‘ns’, ALL_DISTINCT_GENLIST]) >> + strip_tac >> fs [] >> + cases_on ‘res1’ >> fs [] >> + cases_on ‘x'’ >> fs [] >> rveq >> fs [] >> + fs [shape_of_def, panLangTheory.size_of_shape_def, + panSemTheory.set_var_def, set_var_def] >> + conj_tac >- fs [state_rel_def] >> + conj_tac >- fs [Abbr ‘nctxt’, code_rel_def, ctxt_fc_funcs_eq, ctxt_fc_eids_eq] >> + conj_tac + >- ( + fs [Abbr ‘nctxt’, excp_rel_def, ctxt_fc_funcs_eq, ctxt_fc_eids_eq]) >> + fs [locals_rel_def] >> rw [] >> + fs [FLOOKUP_UPDATE] >> FULL_CASE_TAC >> fs [] >> rveq + >- ( + conj_asm1_tac + >- ( + fs [locals_rel_def] >> res_tac >> fs []) >> + ‘LENGTH (flatten v) = 0 /\ LENGTH r' = 0’ suffices_by fs [OPT_MMAP_def] >> + conj_asm1_tac + >- ( + rewrite_tac [length_flatten_eq_size_of_shape] >> + metis_tac [panLangTheory.size_of_shape_def]) >> + last_x_assum drule_all >> strip_tac >> fs [] >> rveq >> + ‘flatten v = flatten x’ by ( + ‘size_of_shape (shape_of v) = size_of_shape (shape_of x)’ by fs [] >> + fs [GSYM length_flatten_eq_size_of_shape] >> + cases_on ‘flatten v’ >> fs []) >> + fs [] >> cases_on ‘ns’ >> rfs [OPT_MMAP_def]) >> + first_x_assum drule >> strip_tac >> fs [] >> + fs [opt_mmap_eq_some, MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> fs [FLOOKUP_UPDATE] >> + TOP_CASE_TAC >> fs [] >> + drule ctxt_max_el_leq >> + qpat_x_assum ‘LENGTH _ = LENGTH (flatten _)’ (assume_tac o GSYM) >> + fs [] >> disch_then drule_all >> fs [] + +val ret_call_shape_retv_comb_one_tac = + fs [evaluate_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + ‘OPT_MMAP (eval t) + (FLAT (MAP FST (MAP (compile_exp ctxt) argexps))) = SOME (FLAT (MAP flatten args))’ by ( + fs [opt_mmap_eq_some] >> metis_tac [eval_map_comp_exp_flat_eq]) >> + fs [] >> + fs [panSemTheory.lookup_code_def, CaseEq "option", CaseEq "prod"] >> rveq >> + drule code_rel_imp >> + disch_then drule >> + strip_tac >> fs [] >> + fs [lookup_code_def] >> + drule list_rel_length_shape_of_flatten >> + fs [] >> + strip_tac >> + fs [ALL_DISTINCT_GENLIST] >> TOP_CASE_TAC >- fs [state_rel_def] >> + qmatch_goalsub_abbrev_tac ‘compile nctxt _,nt’ >> + first_x_assum (qspecl_then [‘nt’, ‘nctxt’] mp_tac) >> + impl_tac + >- ( + fs [Abbr ‘nctxt’, Abbr ‘nt’, slc_tlc_rw] >> + qmatch_goalsub_abbrev_tac ‘(dec_clock t with locals := tlc ns _)’ >> + match_mp_tac call_preserve_state_code_locals_rel >> + fs [Abbr ‘ns’, ALL_DISTINCT_GENLIST]) >> + strip_tac >> fs [] >> + ‘size_of_shape (shape_of x) = 1’ by ( + fs [locals_rel_def] >> + last_x_assum drule >> fs [shape_of_def] >> + strip_tac >> qpat_x_assum ‘Comb l = shape_of x’ (assume_tac o GSYM) >> + fs [panLangTheory.size_of_shape_def, shape_of_def]) >> fs [] >> + drule locals_rel_lookup_ctxt >> + disch_then drule >> strip_tac >> fs [] >> + rveq >> fs [OPT_MMAP_def] >> rveq >> + cases_on ‘ns’ >> fs [] + >- ( + fs [OPT_MMAP_def] >> + pop_assum (assume_tac o GSYM) >> + fs [GSYM length_flatten_eq_size_of_shape]) >> + fs [OPT_MMAP_def] >> rveq >> + fs [state_rel_def, panSemTheory.set_var_def,set_var_def, + Abbr ‘nctxt’, code_rel_def, ctxt_fc_funcs_eq,ctxt_fc_eids_eq, + panSemTheory.set_var_def,set_var_def] >> + ‘size_of_shape (shape_of v) = 1’ by fs [] >> + rveq >> fs [length_flatten_eq_size_of_shape] >> + rfs [panLangTheory.size_of_shape_def] >> + fs [OPT_MMAP_def] >> rveq >> + fs [locals_rel_def, panSemTheory.set_var_def,set_var_def] >> + rw [] >> rveq >> + fs [FLOOKUP_UPDATE] >> + FULL_CASE_TAC >> fs [] >> rveq + >- ( + fs [OPT_MMAP_def, FLOOKUP_UPDATE] >> + fs [length_flatten_eq_size_of_shape, + panLangTheory.size_of_shape_def, shape_of_def, + OPT_MMAP_def]) >> + res_tac >> fs [] >> + match_mp_tac opt_mmap_flookup_update >> + fs [OPT_MMAP_def] >> rveq >> + drule no_overlap_flookup_distinct >> + disch_then drule_all >> + cases_on ‘ns’ >> + fs [distinct_lists_def] + + +val ret_call_shape_retv_comb_gt_one_tac = + fs [ret_var_def, ret_hdl_def] >> + fs [evaluate_def, assign_ret_def] >> + cases_on ‘eval t x0’ >> fs [] >> + cases_on ‘x'’ >> fs [] >> + ‘OPT_MMAP (eval t) + (FLAT (MAP FST (MAP (compile_exp ctxt) argexps))) = SOME (FLAT (MAP flatten args))’ by ( + fs [opt_mmap_eq_some] >> metis_tac [eval_map_comp_exp_flat_eq]) >> + fs [] >> + fs [panSemTheory.lookup_code_def, CaseEq "option", CaseEq "prod"] >> rveq >> + drule code_rel_imp >> + disch_then drule >> + strip_tac >> fs [] >> + fs [lookup_code_def] >> + drule list_rel_length_shape_of_flatten >> + fs [] >> + strip_tac >> + fs [ALL_DISTINCT_GENLIST] >> + cases_on ‘t.clock = 0’ >- fs [state_rel_def] >> + fs [] >> rveq >> + qmatch_goalsub_abbrev_tac ‘compile nctxt _,nt’ >> + first_x_assum (qspecl_then [‘nt’, ‘nctxt’] mp_tac) >> + impl_tac + >- ( + fs [Abbr ‘nctxt’, Abbr ‘nt’, slc_tlc_rw] >> + qmatch_goalsub_abbrev_tac ‘(dec_clock t with locals := tlc ns _)’ >> + match_mp_tac call_preserve_state_code_locals_rel >> + fs [Abbr ‘ns’, ALL_DISTINCT_GENLIST]) >> + strip_tac >> fs [] >> + cases_on ‘res1’ >> fs [] >> + cases_on ‘x'’ >> fs [] >> rveq >> fs [] >> + fs [shape_of_def, panLangTheory.size_of_shape_def, + panSemTheory.set_var_def, set_var_def] >> + ‘1 < size_of_shape (shape_of x)’ by ( + drule locals_rel_lookup_ctxt >> + disch_then drule >> + strip_tac >> fs [] >> rfs [] >> + fs [panLangTheory.size_of_shape_def] >> + DECIDE_TAC) >> + fs [] >> + ‘ALL_DISTINCT r'’ by + (fs [locals_rel_def] >> imp_res_tac all_distinct_flookup_all_distinct) >> + fs [globals_lookup_def] >> + drule evaluate_seq_assign_load_globals >> + disch_then (qspecl_then [‘t1 with locals := + t.locals’, ‘0w’] mp_tac) >> + impl_tac + >- ( + conj_tac + >- ( + fs [word_0_n2w] >> + imp_res_tac locals_rel_lookup_ctxt >> rveq >> + fs [length_flatten_eq_size_of_shape] >> rfs []) >> + conj_tac + >- ( + rw [] >> CCONTR_TAC >> + drule locals_rel_lookup_ctxt >> + disch_then drule_all >> + strip_tac >> fs [] >> rveq >> + fs [opt_mmap_eq_some] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN, MEM_EL] >> + rveq >> fs [] >> rfs [] >> + res_tac >> rfs []) >> + rw [] >> rfs [] >> + drule locals_rel_lookup_ctxt >> + ‘size_of_shape (shape_of x) = LENGTH r'’ by ( + drule locals_rel_lookup_ctxt >> + disch_then drule >> + strip_tac >> fs [] >> rveq >> + fs [length_flatten_eq_size_of_shape] >> rfs []) >> + fs [] >> drule opt_mmap_mem_func >> + disch_then drule >> strip_tac >> fs []) >> + strip_tac >> fs [] >> + conj_tac >- fs [state_rel_def] >> + conj_tac >- fs [Abbr ‘nctxt’, code_rel_def, ctxt_fc_funcs_eq, ctxt_fc_eids_eq] >> + conj_tac + >- ( + fs [Abbr ‘nctxt’, excp_rel_def, ctxt_fc_funcs_eq, ctxt_fc_eids_eq]) >> + ‘MAP (λn. THE (FLOOKUP t1.globals n)) (GENLIST (λx. n2w x) (LENGTH r')) = + flatten v’ by ( + fs [opt_mmap_eq_some] >> + ‘size_of_shape (shape_of v) = LENGTH r'’ by ( + drule locals_rel_lookup_ctxt >> + disch_then drule >> + strip_tac >> fs [] >> rveq >> + fs [length_flatten_eq_size_of_shape] >> rfs []) >> + fs [] >> drule map_some_the_map >> fs []) >> + fs [] >> + match_mp_tac local_rel_le_zip_update_preserved >> fs [] >> + match_mp_tac local_rel_gt_vmax_preserved >> + fs [] + +val eval_call_impl_only_tac = + fs [evaluate_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + ‘OPT_MMAP (eval t) + (FLAT (MAP FST (MAP (compile_exp ctxt) argexps))) = SOME (FLAT (MAP flatten args))’ by ( + fs [opt_mmap_eq_some] >> metis_tac [eval_map_comp_exp_flat_eq]) >> + fs [] >> + fs [panSemTheory.lookup_code_def, CaseEq "option", CaseEq "prod"] >> rveq >> + drule code_rel_imp >> + disch_then drule >> + strip_tac >> fs [] >> + fs [lookup_code_def] >> + drule list_rel_length_shape_of_flatten >> + fs [] >> + strip_tac >> + fs [ALL_DISTINCT_GENLIST] >> + TOP_CASE_TAC >- fs [state_rel_def] >> + qmatch_goalsub_abbrev_tac ‘compile nctxt _,nt’ >> + last_x_assum (qspecl_then [‘nt’, ‘nctxt’] mp_tac) >> + impl_tac + >- ( + fs [Abbr ‘nctxt’, Abbr ‘nt’, slc_tlc_rw] >> + qmatch_goalsub_abbrev_tac ‘(dec_clock t with locals := tlc ns _)’ >> + match_mp_tac call_preserve_state_code_locals_rel >> + fs [Abbr ‘ns’, ALL_DISTINCT_GENLIST]) + + +val ret_call_excp_reult_handle_none_tac = + (* exception value with ret call *) + TOP_CASE_TAC >> fs [] >> + fs [CaseEq "option", CaseEq "prod", + CaseEq "shape", CaseEq "list"] >> + rveq >> fs [ret_var_def, ret_hdl_def] + >- ( + eval_call_impl_only_tac >> + strip_tac >> fs [] >> + ‘nctxt.eids = ctxt.eids’ by + fs [Abbr ‘nctxt’, ctxt_fc_eids_eq] >> + cases_on ‘FLOOKUP ctxt.eids m'’ >> fs [] >> + cases_on ‘x’ >> fs [] >> + cases_on ‘size_of_shape (shape_of v) = 0’ >> fs [] + >- rels_empty_tac >> + cases_on ‘size_of_shape (shape_of v) = 1’ >> fs [] + >- (fs [shape_of_def, panLangTheory.size_of_shape_def] >> rels_empty_tac) >> + rels_empty_tac) + >- ( + eval_call_impl_only_tac >> + strip_tac >> fs [] >> + ‘nctxt.eids = ctxt.eids’ by + fs [Abbr ‘nctxt’, ctxt_fc_eids_eq] >> + cases_on ‘FLOOKUP ctxt.eids m'’ >> fs [] >> + cases_on ‘x’ >> fs [] >> + cases_on ‘size_of_shape (shape_of v) = 0’ >> fs [] + >- rels_empty_tac >> + cases_on ‘size_of_shape (shape_of v) = 1’ >> fs [] + >- (fs [shape_of_def, panLangTheory.size_of_shape_def] >> rels_empty_tac) >> + rels_empty_tac) + >- ( + eval_call_impl_only_tac >> + strip_tac >> fs [] >> + ‘nctxt.eids = ctxt.eids’ by + fs [Abbr ‘nctxt’, ctxt_fc_eids_eq] >> + cases_on ‘FLOOKUP ctxt.eids m'’ >> fs [] >> + cases_on ‘x’ >> fs [] >> + cases_on ‘size_of_shape (shape_of v) = 0’ >> fs [] + >- rels_empty_tac >> + cases_on ‘size_of_shape (shape_of v) = 1’ >> fs [] + >- (fs [shape_of_def, panLangTheory.size_of_shape_def] >> rels_empty_tac) >> + rels_empty_tac) >> + eval_call_impl_only_tac >> + strip_tac >> fs [] >> + ‘nctxt.eids = ctxt.eids’ by + fs [Abbr ‘nctxt’, ctxt_fc_eids_eq] >> + cases_on ‘FLOOKUP ctxt.eids m'’ >> fs [] >> + cases_on ‘x’ >> fs [] >> + cases_on ‘res1’ >> fs [] >> rveq >> fs [] >> + TRY (cases_on ‘x’ >> fs [] >> rveq >> fs []) >> + cases_on ‘FLOOKUP ctxt.eids m'’ >> fs [] >> + cases_on ‘x’ >> fs [] >> + cases_on ‘size_of_shape (shape_of v) = 0’ >> fs [] + >- rels_empty_tac >> + cases_on ‘size_of_shape (shape_of v) = 1’ >> fs [] + >- ( + fs [shape_of_def, panLangTheory.size_of_shape_def] >> + rels_empty_tac) >> + rels_empty_tac + +val ret_call_excp_reult_handle_uneq_exp_tac = + rveq >> fs [] >> + cases_on ‘FLOOKUP ctxt.eids m0’ >> fs [] + >- ret_call_excp_reult_handle_none_tac >> + rename [‘geid <> eid’] >> + TOP_CASE_TAC >> fs [] >> + fs [CaseEq "option", CaseEq "prod", + CaseEq "shape", CaseEq "list"] >> + rveq >> fs [ret_var_def, ret_hdl_def] >> + eval_call_impl_only_tac >> + strip_tac >> fs [] >> + ‘nctxt.eids = ctxt.eids’ by + fs [Abbr ‘nctxt’, ctxt_fc_eids_eq] >> + cases_on ‘FLOOKUP ctxt.eids geid’ >> fs [] >> + rename [‘res1 = SOME (Exception er)’] >> + ‘er <> x’ by ( + CCONTR_TAC >> + fs [excp_rel_def]) >> + cases_on ‘size_of_shape (shape_of v) = 0’ >> fs [] >> rveq + >- rels_empty_tac >> + cases_on ‘size_of_shape (shape_of v) = 1’ >> fs [] + >- rels_empty_tac >> + rels_empty_tac + + +val ret_call_excp_handler_tac = + TRY ( + first_x_assum drule >> + strip_tac >> rfs []) >> + TOP_CASE_TAC >> fs [] >> + fs [CaseEq "option", CaseEq "prod", + CaseEq "shape", CaseEq "list"] >> + rveq >> fs [ret_var_def, ret_hdl_def] >> + ( + eval_call_impl_only_tac >> + strip_tac >> fs [] >> + ‘nctxt.eids = ctxt.eids’ by + fs [Abbr ‘nctxt’, ctxt_fc_eids_eq] >> + fs [] >> + cases_on ‘FLOOKUP ctxt.eids eid’ >> fs [] >> + rename [‘FLOOKUP ctxt.eids eid = SOME ed’] >> + fs [] >> rveq >> fs [] >> + fs [is_valid_value_def] >> + cases_on ‘FLOOKUP s.locals m''’ >> fs [] >> + drule locals_rel_lookup_ctxt >> + disch_then drule_all >> + strip_tac >> fs [] >> rveq >> + rename [‘OPT_MMAP (FLOOKUP t.locals) _ = SOME (flatten ex)’] >> + fs [exp_hdl_def] >> + pairarg_tac >> fs [] >> + ‘ALL_DISTINCT ns’ by + (fs [locals_rel_def] >> imp_res_tac all_distinct_flookup_all_distinct) >> + drule evaluate_seq_assign_load_globals >> + disch_then (qspecl_then [‘t1 with locals := + t.locals’, ‘0w’] mp_tac) >> + impl_tac + >- ( + conj_tac + >- ( + fs [word_0_n2w] >> + imp_res_tac locals_rel_lookup_ctxt >> rveq >> + fs [length_flatten_eq_size_of_shape] >> rfs [] >> + cases_on ‘size_of_shape (shape_of ex)’ >> fs []) >> + conj_tac + >- ( + rw [] >> CCONTR_TAC >> + drule locals_rel_lookup_ctxt >> + disch_then drule_all >> + strip_tac >> fs [] >> rveq >> + fs [opt_mmap_eq_some] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN, MEM_EL] >> + rveq >> fs [] >> rfs [] >> + res_tac >> rfs []) >> + rw [] >> rfs [] >> + CCONTR_TAC >> fs [] >> + reverse (cases_on ‘1 ≤ size_of_shape (shape_of ex)’) >> + fs [] + >- fs [MEM_GENLIST, length_flatten_eq_size_of_shape] >> + rfs [globals_lookup_def] >> + fs [GSYM length_flatten_eq_size_of_shape] >> + qpat_x_assum ‘OPT_MMAP (FLOOKUP t1.globals) _ = _’ assume_tac >> + drule opt_mmap_mem_func >> + disch_then drule >> strip_tac >> fs []) >> + strip_tac >> fs [] >> + rfs [] >> rveq >> + qmatch_goalsub_abbrev_tac ‘evaluate (compile ctxt p,tt)’ >> + first_x_assum (qspecl_then [‘tt’, ‘ctxt’] mp_tac) >> + impl_tac + >- ( + fs [Abbr ‘tt’, panSemTheory.set_var_def] >> + fs [state_rel_def, panSemTheory.set_var_def,set_var_def, + Abbr ‘nctxt’, code_rel_def, ctxt_fc_funcs_eq,ctxt_fc_eids_eq, + panSemTheory.set_var_def,set_var_def] >> + fs [locals_rel_def] >> + rw [] >> rveq >> + fs [FLOOKUP_UPDATE] >> + reverse FULL_CASE_TAC >> fs [] >> rveq + >- ( + res_tac >> fs [] >> + qpat_x_assum ‘OPT_MMAP _ ns' = _’ (assume_tac o GSYM) >> + fs [] >> + match_mp_tac opt_mmap_disj_zip_flookup >> + conj_tac + >- ( + pop_assum (assume_tac o GSYM) >> + fs [no_overlap_def] >> + res_tac >> fs [] >> rveq >> + fs [] >> fs [distinct_lists_def, IN_DISJOINT, EVERY_MEM] >> + metis_tac []) >> + res_tac >> fs []) >> + reverse (cases_on ‘1 ≤ size_of_shape (shape_of ex)’) >> + fs [] >> rveq >> + fs [length_flatten_eq_size_of_shape] + >- ( + qpat_x_assum ‘shape_of v = shape_of ex’ (assume_tac o GSYM) >> + fs [] >> + ‘size_of_shape (shape_of v) = 0’ by fs [] >> + fs [OPT_MMAP_def, GSYM length_flatten_eq_size_of_shape]) >> + fs [globals_lookup_def, opt_mmap_eq_some] >> + simp [Once (GSYM o_DEF),MAP_o] >> + rewrite_tac [ETA_AX] >> + rfs [ETA_AX] >> + fs [MAP_o, MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + fs [MAP_MAP_o] >> + ‘MAP (THE ∘ SOME) (flatten v) = flatten v’ by fs [map_the_some_cancel] >> + fs [] >> pop_assum kall_tac >> + match_mp_tac update_eq_zip_flookup >> + fs []) >> + strip_tac >> fs []) + + +Theorem compile_Call: + ^(get_goal "compile _ (panLang$Call _ _ _)") +Proof + rpt gen_tac >> rpt strip_tac >> + fs [panSemTheory.evaluate_def] >> + fs [compile_def] >> + fs [CaseEq "option", CaseEq "v", CaseEq "word_lab", CaseEq "prod"] >> + rveq >> fs [] >> + pairarg_tac >> fs [] >> + drule compile_exp_val_rel >> + disch_then drule_all >> + strip_tac >> fs [flatten_def] >> rveq >> + cases_on ‘s.clock = 0’ >> fs [] >> rveq + (* s = 0 case *) + >- ( + TRY (rpt TOP_CASE_TAC) >> fs [] >> clock_zero_tail_rt_tac) >> + (* s <> 0 case *) + TOP_CASE_TAC >> fs [] + (* Tail call *) + >- tail_call_tac >> + (* Return case *) + cases_on ‘evaluate (prog,dec_clock s with locals := newlocals)’ >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs [] >> rveq >> + TRY (cases_on ‘FLOOKUP s.locals m’ >> fs [] >> NO_TAC) + (* timed-out in Ret call *) + >- (TRY (rpt TOP_CASE_TAC) >> fs [] >> call_tail_ret_impl_tac) + (* return in Ret call *) + >- ( + cases_on ‘is_valid_value s.locals m v’ >> fs [] >> rveq >> + fs [is_valid_value_def] >> + cases_on ‘FLOOKUP s.locals m’ >> fs [] >> + fs [wrap_rt_def] >> + TOP_CASE_TAC >> fs [] + >- ( + fs [CaseEq "option"] + >- (fs [locals_rel_def] >> first_x_assum drule >> fs []) >> + fs [CaseEq "prod", CaseEq "shape", CaseEq "list"] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> + drule locals_rel_lookup_ctxt >> + disch_then drule >> strip_tac >> fs [] >> + rveq >> fs [OPT_MMAP_def] >> rveq >> + pop_assum (assume_tac o GSYM) >> + ‘size_of_shape (shape_of x) = 1’ by + fs [panLangTheory.size_of_shape_def] >> + rfs [GSYM length_flatten_eq_size_of_shape]) >> + fs [CaseEq "option"] >> + fs [CaseEq "prod", CaseEq "shape", CaseEq "list"] >> rveq >> + fs [ret_var_def, ret_hdl_def] + >- ( + (* shape-rtv: One *) + TRY (rpt TOP_CASE_TAC) >> fs [] >> ret_call_shape_retv_one_tac) >> + qmatch_asmsub_rename_tac ‘FLOOKUP ctxt.vars m = SOME (Comb l,r')’ >> + cases_on ‘size_of_shape (Comb l) = 0’ >> fs [] + >- (TRY (rpt TOP_CASE_TAC) >> fs [] >> ret_call_shape_retv_comb_zero_tac) >> + cases_on ‘size_of_shape (Comb l) = 1’ >> fs [] + (* size-shape-ret = 1 *) + >- (TRY (rpt TOP_CASE_TAC) >> fs [] >> ret_call_shape_retv_comb_one_tac) >> + (* 1 < size-shape-ret *) + TRY (rpt TOP_CASE_TAC) >> fs [] >> ret_call_shape_retv_comb_gt_one_tac) + >- ( + (* Exception result *) + fs [wrap_rt_def] >> + fs [] >> cases_on ‘o'’ >> fs [] + (* NONE exp-handler *) + >- ret_call_excp_reult_handle_none_tac >> + cases_on ‘x’ >> fs [] >> rveq >> + reverse (cases_on ‘m' = m0’) >> fs [] + (* eids mismatch *) + >- ret_call_excp_reult_handle_uneq_exp_tac >> + (* handling exception *) + rename [‘geid = eid’] >> + cases_on ‘FLOOKUP s.eshapes eid’ >> fs [] >> rveq >> + cases_on ‘shape_of v = x’ >> fs [] >> + cases_on ‘is_valid_value s.locals m'' v’ >> fs [] >> + cases_on ‘FLOOKUP ctxt.eids eid’ >> fs [] + >- ( + fs [excp_rel_def] >> + imp_res_tac fdoms_eq_flookup_some_none >> fs []) >> + cases_on ‘x'’ >> fs [] >> rveq >> + TOP_CASE_TAC >> fs [] + >- ret_call_excp_handler_tac >> + TOP_CASE_TAC >> fs [] >> + ret_call_excp_handler_tac) >> + (* FFI *) + cases_on ‘o'’ >> fs [] + >- (TRY (rpt TOP_CASE_TAC) >> fs [] >> call_tail_ret_impl_tac) >> + cases_on ‘x’ >> + TRY (rpt TOP_CASE_TAC) >> fs [] >> call_tail_ret_impl_tac +QED + + +Theorem compile_ExtCall: + ^(get_goal "compile _ (panLang$ExtCall _ _ _ _ _)") +Proof + rpt gen_tac >> rpt strip_tac >> + fs [panSemTheory.evaluate_def] >> + fs [compile_def] >> + fs [CaseEq "option", CaseEq "v", CaseEq "word_lab", CaseEq "prod"] >> + rveq >> fs [] >> + imp_res_tac locals_rel_lookup_ctxt >> fs [flatten_def] >> rveq >> + TOP_CASE_TAC >> fs [shape_of_def, OPT_MMAP_def] >> + TOP_CASE_TAC >> fs [shape_of_def, OPT_MMAP_def] >> + TOP_CASE_TAC >> fs [shape_of_def, OPT_MMAP_def] >> + TOP_CASE_TAC >> fs [shape_of_def, OPT_MMAP_def] >> rveq >> + fs [evaluate_def] >> + ‘t.memory = s.memory ∧ t.memaddrs = s.memaddrs ∧ t.be = s.be ∧ t.ffi = s.ffi’ by + fs [state_rel_def] >> + fs [] >> + TOP_CASE_TAC >> fs [] >> rveq + >- fs [state_rel_def, code_rel_def] >> + fs [state_rel_def, code_rel_def, excp_rel_def, panSemTheory.empty_locals_def] +QED + + +Theorem pc_compile_correct: + ^(compile_tm ()) +Proof + match_mp_tac (the_ind_thm()) >> + EVERY (map strip_assume_tac + [compile_Skip_Break_Continue, compile_Dec, + compile_Assign, compile_Store, compile_StoreByte, compile_Seq, + compile_If, compile_While, compile_Call, compile_ExtCall, + compile_Raise, compile_Return, compile_Tick]) >> + asm_rewrite_tac [] >> rw [] >> rpt (pop_assum kall_tac) +QED + +(* +Theorem compile_correct: + ^fgoal (p,s) +Proof + rw [] >> + ‘FST (evaluate (p,s)) <> SOME Error’ by fs [] >> + drule pan_simpProofTheory.compile_correct >> + fs [] >> strip_tac >> + fs [compile_def] >> + metis_tac [pc_compile_correct] +QED +*) + +Theorem first_compile_prog_all_distinct: + ALL_DISTINCT (MAP FST prog) ==> + ALL_DISTINCT (MAP FST (pan_to_crep$compile_prog prog)) +Proof + rw [] >> + fs [pan_to_crepTheory.compile_prog_def] >> + fs [MAP_MAP_o] >> + qmatch_goalsub_abbrev_tac ‘MAP ls _’ >> + ‘MAP ls prog = MAP FST prog’ suffices_by fs [] >> + fs [Abbr ‘ls’] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + cases_on ‘EL n prog’ >> + fs [] >> + cases_on ‘r’ >> + fs [] +QED + +Theorem alookup_compile_prog_code: + ALL_DISTINCT (MAP FST pan_code) ∧ + ALOOKUP pan_code start = SOME ([],prog) ==> + ALOOKUP (compile_prog pan_code) start = + SOME ([], + comp_func (make_funcs pan_code) (get_eids pan_code) [] prog) +Proof + rw [] >> + fs [compile_prog_def, ctxt_fc_def] >> + match_mp_tac ALOOKUP_ALL_DISTINCT_MEM >> + conj_tac + >- ( + fs [MAP_MAP_o] >> + qmatch_goalsub_abbrev_tac ‘MAP ff _’ >> + ‘MAP ff pan_code = MAP FST pan_code’ suffices_by fs [] >> + fs [Abbr ‘ff’, MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + fs [] >> + cases_on ‘EL n pan_code’ >> + cases_on ‘r’ >> fs []) >> + drule ALOOKUP_MEM >> + strip_tac >> + fs [MEM_EL] >> rveq >> + qexists_tac ‘n’ >> + fs [] >> + qmatch_goalsub_abbrev_tac ‘MAP ff pan_code’ >> + drule (INST_TYPE [“:'a”|->“:mlstring # (mlstring # shape) list # α panLang$prog”, + “:'b”|->“:mlstring # num list # α prog”] EL_MAP) >> + disch_then (qspec_then ‘ff’ mp_tac) >> + strip_tac >> fs [] >> + fs [Abbr ‘ff’] >> + qpat_x_assum ‘_ = EL n pan_code’ (assume_tac o GSYM) >> + fs [crep_vars_def, panLangTheory.size_of_shape_def] +QED + + +Theorem el_compile_prog_el_prog_eq: + !prog n start cprog p. + EL n (compile_prog prog) = (start,[],cprog) /\ + ALL_DISTINCT (MAP FST prog) /\ n < LENGTH prog /\ + ALOOKUP prog start = SOME ([],p) ==> + EL n prog = (start,[],p) +Proof + rw [] >> + fs [compile_prog_def] >> + qmatch_asmsub_abbrev_tac ‘EL _ (MAP ff _) = _’ >> + ‘EL n (MAP ff prog) = ff (EL n prog)’ by ( + match_mp_tac EL_MAP >> fs []) >> + cases_on ‘EL n prog’ >> + cases_on ‘r’ >> fs [] >> + fs [Abbr ‘ff’] >> rveq >> rfs [] >> + drule ALOOKUP_MEM >> + strip_tac >> + fs [MEM_EL] >> + pop_assum (assume_tac o GSYM) >> + fs [] >> + ‘n = n'’ by ( + drule pan_commonPropsTheory.all_distinct_el_fst_same_eq >> + disch_then (qspecl_then [‘n’, ‘n'’, ‘q’, ‘(q',r')’, ‘([],p)’] mp_tac) >> + fs []) >> + fs [] +QED + +Theorem mk_ctxt_code_imp_code_rel: + !pan_code start p. ALL_DISTINCT (MAP FST pan_code) /\ + ALOOKUP pan_code start = SOME ([],p) ==> + code_rel (mk_ctxt FEMPTY (make_funcs pan_code) 0 (get_eids pan_code)) + (alist_to_fmap pan_code) + (alist_to_fmap (pan_to_crep$compile_prog pan_code)) +Proof + rw [] >> + fs [code_rel_def, mk_ctxt_def] >> + rpt gen_tac >> + strip_tac >> + conj_tac + >- ( + fs [make_funcs_def] >> + match_mp_tac ALOOKUP_ALL_DISTINCT_MEM >> + conj_tac + >- ( + qmatch_goalsub_abbrev_tac ‘MAP FST ls’ >> + ‘MAP FST ls = MAP FST pan_code’ suffices_by fs [] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + conj_tac >- fs [Abbr ‘ls’] >> + conj_tac >- fs [Abbr ‘ls’] >> + rw [] >> + fs [Abbr ‘ls’] >> + qmatch_goalsub_abbrev_tac ‘MAP2 _ _ ps’ >> + ‘n < MIN (LENGTH (MAP FST pan_code)) (LENGTH ps)’ by fs [Abbr ‘ps’] >> + drule (INST_TYPE [“:'a”|->“:mlstring”, + “:'b”|->“:(mlstring # shape) list”, + “:'c”|-> “:mlstring # (mlstring # shape) list”] EL_MAP2) >> + disch_then (qspec_then ‘λx y. (x,y)’ mp_tac) >> + strip_tac >> fs [] >> + match_mp_tac EL_MAP >> + fs []) >> + drule ALOOKUP_MEM >> + strip_tac >> + fs [MEM_EL] >> rveq >> + qexists_tac ‘n’ >> + fs [] >> + qmatch_goalsub_abbrev_tac ‘MAP2 _ _ ps’ >> + ‘n < MIN (LENGTH (MAP FST pan_code)) (LENGTH ps)’ by fs [Abbr ‘ps’] >> + drule (INST_TYPE [“:'a”|->“:mlstring”, + “:'b”|->“:(mlstring # shape) list”, + “:'c”|-> “:mlstring # (mlstring # shape) list”] EL_MAP2) >> + disch_then (qspec_then ‘λx y. (x,y)’ mp_tac) >> + strip_tac >> fs [] >> + fs [Abbr ‘ps’] >> + conj_tac + >- ( + drule (INST_TYPE [“:'a”|->“:mlstring # (mlstring # shape) list # α panLang$prog”, + “:'b”|->“:mlstring”] EL_MAP) >> + disch_then (qspec_then ‘FST’ mp_tac) >> + strip_tac >> fs [] >> + qpat_x_assum ‘_ = EL n pan_code’ (assume_tac o GSYM) >> + fs []) >> + drule (INST_TYPE [“:'a”|->“:mlstring # (mlstring # shape) list # α panLang$prog”, + “:'b”|->“:(mlstring # shape) list”] EL_MAP) >> + disch_then (qspec_then ‘FST ∘ SND’ mp_tac) >> + strip_tac >> fs [] >> + qpat_x_assum ‘_ = EL n pan_code’ (assume_tac o GSYM) >> + fs []) >> + fs [compile_prog_def, ctxt_fc_def] >> + match_mp_tac ALOOKUP_ALL_DISTINCT_MEM >> + conj_tac + >- ( + fs [MAP_MAP_o] >> + qmatch_goalsub_abbrev_tac ‘MAP ff _’ >> + ‘MAP ff pan_code = MAP FST pan_code’ suffices_by fs [] >> + fs [Abbr ‘ff’, MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + fs [] >> + cases_on ‘EL n pan_code’ >> + cases_on ‘r’ >> fs []) >> + drule ALOOKUP_MEM >> + strip_tac >> + fs [MEM_EL] >> rveq >> + qexists_tac ‘n’ >> + fs [] >> + qmatch_goalsub_abbrev_tac ‘MAP ff pan_code’ >> + drule (INST_TYPE [“:'a”|->“:mlstring # (mlstring # shape) list # α panLang$prog”, + “:'b”|->“:mlstring # num list # α prog”] EL_MAP) >> + disch_then (qspec_then ‘ff’ mp_tac) >> + strip_tac >> fs [] >> + fs [Abbr ‘ff’] >> + qpat_x_assum ‘_ = EL n pan_code’ (assume_tac o GSYM) >> + fs [] >> + conj_tac + >- fs [crep_vars_def] >> + fs [comp_func_def, mk_ctxt_def] >> + fs [make_vmap_def, list_max_i_genlist] +QED + + +Theorem mod_eq_lt_eq: + !n x m. + (n:num) < x /\ m < x /\ n MOD x = m MOD x ==> + n = m +Proof + rw [] >> + rfs [arithmeticTheory.LESS_MOD] +QED + + +Theorem get_eids_imp_excp_rel: + !seids pc. + panLang$size_of_eids pc < dimword (:'a) /\ + FDOM seids = FDOM ((get_eids pc):mlstring |-> 'a word) ==> + excp_rel ((get_eids pc):mlstring |-> 'a word) seids +Proof + rw [] >> + fs [excp_rel_def] >> + rw [] >> + fs [get_eids_def] >> + qmatch_asmsub_abbrev_tac ‘ALOOKUP f e' = SOME n'’ >> + dxrule ALOOKUP_MEM >> + dxrule ALOOKUP_MEM >> + strip_tac >> + strip_tac >> + fs [MEM_EL] >> rveq >> + fs [Abbr ‘f’] >> + qmatch_asmsub_abbrev_tac ‘ EL n'' (MAP2 f xs ys)’ >> + ‘n < MIN (LENGTH xs) (LENGTH ys)’ by fs [Abbr ‘xs’, Abbr ‘ys’] >> + ‘n'' < MIN (LENGTH xs) (LENGTH ys)’ by fs [Abbr ‘xs’, Abbr ‘ys’] >> + dxrule (INST_TYPE [“:'a”|->“:mlstring”, + “:'b”|->“:'a word”, + “:'c”|-> “:mlstring # 'a word”] EL_MAP2) >> + dxrule (INST_TYPE [“:'a”|->“:mlstring”, + “:'b”|->“:'a word”, + “:'c”|-> “:mlstring # 'a word”] EL_MAP2) >> + disch_then (qspec_then ‘f’ assume_tac) >> + disch_then (qspec_then ‘f’ assume_tac) >> + fs [Abbr ‘f’, Abbr ‘xs’, Abbr ‘ys’] >> rveq >> fs [] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + qsuff_tac ‘n'' = n’ + >- fs [] >> + pop_assum mp_tac >> + + + drule (INST_TYPE [“:'a”|->“:'a word”] EL_GENLIST) >> + disch_then (qspec_then ‘λx. (n2w x):'a word’ assume_tac) >> + fs [] >> pop_assum kall_tac >> + strip_tac >> + fs [panLangTheory.size_of_eids_def] >> + assume_tac (GSYM n2w_11) >> + pop_assum (qspecl_then [‘n''’, ‘n’] assume_tac) >> + fs [] >> + ‘MOD_2EXP_EQ (dimindex (:α)) n'' n’ by + metis_tac [n2w_11, word_eq_n2w] >> + fs [bitTheory.MOD_2EXP_EQ_def] >> + fs [GSYM MOD_2EXP_DIMINDEX] >> + ‘n'' < dimword (:α) /\ n < dimword (:α)’ by rfs [] >> + fs [mod_eq_lt_eq] +QED + +Theorem mk_ctxt_imp_locals_rel: + !pc lcl. + locals_rel (mk_ctxt FEMPTY (make_funcs pc) 0 (get_eids pc)) FEMPTY lcl +Proof + rw [] >> fs [] >> + fs [locals_rel_def] >> + conj_tac + >- rw [no_overlap_def, mk_ctxt_def] >> + fs [ctxt_max_def, mk_ctxt_def] +QED + + +Theorem compile_prog_distinct_params: + ∀prog. + EVERY (λ(name,params,body). ALL_DISTINCT params) prog ⇒ + EVERY (λ(name,params,body). ALL_DISTINCT params) (compile_prog prog) +Proof + rw [] >> + fs [EVERY_MEM] >> + rw [] >> + PairCases_on ‘e’ >> fs [] >> + fs [compile_prog_def] >> + fs [MEM_EL] >> + qmatch_asmsub_abbrev_tac ‘MAP ff _’ >> + ‘EL n (MAP ff prog) = ff (EL n prog)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [] >> + pop_assum kall_tac >> + fs [Abbr ‘ff’] >> + cases_on ‘EL n prog’ >> + cases_on ‘r’ >> fs [] >> rveq >> + fs [crep_vars_def, ALL_DISTINCT_GENLIST] +QED + +Theorem state_rel_imp_semantics: + !(s:('a,'b) panSem$state) (t:('a,'b) crepSem$state) pan_code start prog. + state_rel s t ∧ + ALL_DISTINCT (MAP FST pan_code) ∧ + s.code = alist_to_fmap pan_code ∧ + t.code = alist_to_fmap (pan_to_crep$compile_prog pan_code) ∧ + s.locals = FEMPTY ∧ + panLang$size_of_eids pan_code < dimword (:'a) /\ + FDOM s.eshapes = FDOM ((get_eids pan_code):mlstring |-> 'a word) ∧ + ALOOKUP pan_code start = SOME ([],prog) ∧ + semantics s start <> Fail ==> + semantics t start = semantics s start +Proof + rw [] >> + fs [] >> + drule mk_ctxt_code_imp_code_rel >> + disch_then (qspecl_then [‘start’, ‘prog’] mp_tac) >> + fs [] >> strip_tac >> + ‘excp_rel ((get_eids pan_code):mlstring |-> 'a word) s.eshapes’ by ( + match_mp_tac get_eids_imp_excp_rel >> fs []) >> + ‘locals_rel (mk_ctxt FEMPTY (make_funcs pan_code) 0 + ((get_eids pan_code):mlstring |-> 'a word)) FEMPTY t.locals’ by ( + fs [locals_rel_def] >> + conj_tac + >- rw [no_overlap_def, mk_ctxt_def] >> + fs [ctxt_max_def, mk_ctxt_def]) >> + qmatch_asmsub_abbrev_tac ‘code_rel nctxt _ _’ >> + reverse (Cases_on ‘semantics s start’) >> fs [] + >- ( + (* Termination case of pan semantics *) + fs [panSemTheory.semantics_def] >> + pop_assum mp_tac >> + IF_CASES_TAC >> fs [] >> + DEEP_INTRO_TAC some_intro >> simp[] >> + rw [] >> + rw [crepSemTheory.semantics_def] + >- ( + (* the fail case of crep semantics *) + qhdtm_x_assum ‘panSem$evaluate’ kall_tac >> + pop_assum mp_tac >> + pop_assum kall_tac >> + strip_tac >> + last_x_assum(qspec_then ‘k'’ mp_tac) >> simp[] >> + (fn g => subterm (fn tm => Cases_on ‘^(assert(has_pair_type)tm)’) (#2 g) g) >> + CCONTR_TAC >> fs [] >> + drule pc_compile_correct >> fs [] >> + map_every qexists_tac [‘t with clock := k'’, ‘nctxt’] >> + fs [] >> + Ho_Rewrite.PURE_REWRITE_TAC[GSYM PULL_EXISTS] >> + conj_tac + >- ( + fs [state_rel_def, Abbr ‘nctxt’, mk_ctxt_def] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + CCONTR_TAC >> + fs [] >> + fs [compile_def] >> + fs [compile_exp_def] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs [] >> + cases_on ‘size_of_shape (shape_of v) = 0’ >> fs [] >> + cases_on ‘size_of_shape (shape_of v) = 1’ >> fs []) >> + (* the termination/diverging case of crep semantics *) + DEEP_INTRO_TAC some_intro >> simp[] >> + conj_tac + (* the termination case of crep semantics *) + >- ( + rw [] >> fs [] >> + drule pc_compile_correct >> fs [] >> + ‘r ≠ SOME Error ∧ + r ≠ SOME Break ∧ r ≠ SOME Continue ∧ r ≠ NONE’ by ( + cases_on ‘r’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + fs [] >> + disch_then (qspecl_then [‘t with clock := k’, ‘nctxt’] mp_tac) >> + impl_tac + >- fs [Abbr ‘nctxt’, mk_ctxt_def, state_rel_def] >> + strip_tac >> fs [] >> + fs [compile_def] >> + fs [compile_exp_def] >> + dxrule crepPropsTheory.evaluate_add_clock_eq >> + dxrule crepPropsTheory.evaluate_add_clock_eq >> + disch_then (qspec_then ‘k’ assume_tac) >> + disch_then (qspec_then ‘k'’ assume_tac) >> + fs [] >> + Cases_on ‘r’ >> fs[] >> + Cases_on ‘r'’ >> fs [] >> + Cases_on ‘x’ >> fs [] >> rveq >> fs [] >> + Cases_on ‘x'’ >> fs [] >> rveq >> fs [] >> + cases_on ‘size_of_shape (shape_of v) = 0’ >> fs [] >> rveq >> fs [] >> + cases_on ‘size_of_shape (shape_of v) = 1’ >> fs [] >> rveq >> fs [] >> + fs [state_rel_def] >> + fs [crepSemTheory.state_accfupds, crepSemTheory.state_component_equality]) >> + (* the diverging case of crep semantics *) + rw[] >> fs[] >> CCONTR_TAC >> fs [] >> + drule pc_compile_correct >> fs [] >> + ‘r ≠ SOME Error ∧ + r ≠ SOME Break ∧ r ≠ SOME Continue ∧ r ≠ NONE’ by ( + cases_on ‘r’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + fs [] >> + map_every qexists_tac [‘t with clock := k’, ‘nctxt’] >> + fs [] >> + Ho_Rewrite.PURE_REWRITE_TAC[GSYM PULL_EXISTS] >> + conj_tac + >- ( + fs [state_rel_def, Abbr ‘nctxt’, mk_ctxt_def] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + CCONTR_TAC >> fs [] >> + fs [compile_def] >> + fs [compile_exp_def] >> + first_x_assum (qspec_then ‘k’ mp_tac) >> simp[] >> + first_x_assum(qspec_then ‘k’ mp_tac) >> simp[] >> + every_case_tac >> fs[] >> rw[] >> rfs[]) >> + (* the diverging case of pan semantics *) + fs [panSemTheory.semantics_def] >> + pop_assum mp_tac >> + IF_CASES_TAC >> fs [] >> + DEEP_INTRO_TAC some_intro >> simp[] >> + rw [] >> + rw [crepSemTheory.semantics_def] + >- ( + (* the fail case of crep semantics *) + fs[] >> rveq >> fs[] >> + last_x_assum (qspec_then ‘k’ mp_tac) >> simp[] >> + (fn g => subterm (fn tm => Cases_on ‘^(assert(has_pair_type)tm)’) (#2 g) g) >> + CCONTR_TAC >> fs [] >> + drule pc_compile_correct >> fs [] >> + map_every qexists_tac [‘t with clock := k’, ‘nctxt’] >> + fs [] >> + Ho_Rewrite.PURE_REWRITE_TAC[GSYM PULL_EXISTS] >> + conj_tac + >- ( + fs [state_rel_def, Abbr ‘nctxt’, mk_ctxt_def] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + CCONTR_TAC >> + fs [] >> + fs [compile_def] >> + fs [compile_exp_def] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs [] >> + cases_on ‘size_of_shape (shape_of v) = 0’ >> fs [] >> rveq >> fs [] >> + cases_on ‘size_of_shape (shape_of v) = 1’ >> fs [] >> rveq >> fs []) >> + (* the termination/diverging case of crep semantics *) + DEEP_INTRO_TAC some_intro >> simp[] >> + conj_tac + (* the termination case of crep semantics *) + >- ( + rw [] >> fs[] >> + qpat_x_assum ‘∀x y. _’ (qspec_then ‘k’ mp_tac)>> + (fn g => subterm (fn tm => Cases_on ‘^(assert(has_pair_type)tm)’) (#2 g) g) >> + strip_tac >> + drule pc_compile_correct >> fs [] >> + map_every qexists_tac [‘t with clock := k’, ‘nctxt’] >> + fs [] >> + Ho_Rewrite.PURE_REWRITE_TAC[GSYM PULL_EXISTS] >> + conj_tac + >- ( + fs [state_rel_def, Abbr ‘nctxt’, mk_ctxt_def] >> + last_x_assum (qspec_then ‘k’ assume_tac) >> + rfs [] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + CCONTR_TAC >> + fs [] >> + fs [compile_def] >> + fs [compile_exp_def] >> + cases_on ‘q’ >> fs [] >> rveq >> fs [] >> + cases_on ‘x’ >> fs [] >> + every_case_tac >> fs []) >> + (* the diverging case of crep semantics *) + rw [] >> + qmatch_abbrev_tac ‘build_lprefix_lub l1 = build_lprefix_lub l2’ >> + ‘(lprefix_chain l1 ∧ lprefix_chain l2) ∧ equiv_lprefix_chain l1 l2’ + suffices_by metis_tac[build_lprefix_lub_thm,lprefix_lub_new_chain,unique_lprefix_lub] >> + conj_asm1_tac + >- ( + UNABBREV_ALL_TAC >> + conj_tac >> + Ho_Rewrite.ONCE_REWRITE_TAC[GSYM o_DEF] >> + REWRITE_TAC[IMAGE_COMPOSE] >> + match_mp_tac prefix_chain_lprefix_chain >> + simp[prefix_chain_def,PULL_EXISTS] >> + qx_genl_tac [‘k1’, ‘k2’] >> + qspecl_then [‘k1’, ‘k2’] mp_tac LESS_EQ_CASES >> + simp[LESS_EQ_EXISTS] >> + rw [] >> + assume_tac (INST_TYPE [``:'a``|->``:'a``, + ``:'b``|->``:'b``] + panPropsTheory.evaluate_add_clock_io_events_mono) >> + assume_tac (INST_TYPE [``:'a``|->``:'a``, + ``:'b``|->``:'b``] + crepPropsTheory.evaluate_add_clock_io_events_mono) >> + first_assum (qspecl_then + [‘Call Tail (Label start) []’, ‘t with clock := k1’, ‘p’] mp_tac) >> + first_assum (qspecl_then + [‘Call Tail (Label start) []’, ‘t with clock := k2’, ‘p’] mp_tac) >> + first_assum (qspecl_then + [‘TailCall (Label start) []’, ‘s with clock := k1’, ‘p’] mp_tac) >> + first_assum (qspecl_then + [‘TailCall (Label start) []’, ‘s with clock := k2’, ‘p’] mp_tac) >> + fs []) >> + simp [equiv_lprefix_chain_thm] >> + fs [Abbr ‘l1’, Abbr ‘l2’] >> simp[PULL_EXISTS] >> + pop_assum kall_tac >> + simp[LNTH_fromList,PULL_EXISTS] >> + simp[GSYM FORALL_AND_THM] >> + rpt gen_tac >> + reverse conj_tac >> strip_tac + >- ( + qmatch_assum_abbrev_tac`n < LENGTH (_ (_ (SND p)))` >> + Cases_on`p` >> pop_assum(assume_tac o SYM o REWRITE_RULE[markerTheory.Abbrev_def]) >> + drule pc_compile_correct >> fs [] >> + ‘q ≠ SOME Error ∧ + q ≠ SOME Break ∧ q ≠ SOME Continue ∧ q ≠ NONE’ by ( + last_x_assum (qspec_then ‘k’ assume_tac) >> rfs [] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + fs [] >> + disch_then (qspecl_then [‘t with clock := k’, ‘nctxt’] mp_tac) >> + impl_tac + >- fs [Abbr ‘nctxt’, mk_ctxt_def, state_rel_def] >> + strip_tac >> fs [] >> + qexists_tac ‘ck+k’ >> simp[] >> + fs [compile_def, compile_def] >> + fs [compile_exp_def] >> + first_x_assum (qspec_then ‘k’ kall_tac) >> + first_x_assum (qspec_then ‘k’ mp_tac) >> + fs [] >> + strip_tac >> + cases_on ‘q’ >> fs [] >> rveq >> fs [] >> + cases_on ‘x’ >> fs [] >> rveq >> fs [] >> + + assume_tac (INST_TYPE [``:'a``|->``:'a``, + ``:'b``|->``:'b``] + crepPropsTheory.evaluate_add_clock_io_events_mono) >> + first_x_assum (qspecl_then + [‘Call Tail (Label start) []’, + ‘t with clock := k’, ‘ck’] mp_tac) >> + strip_tac >> rfs [] >> + fs [state_rel_def, IS_PREFIX_THM]) >> + (fn g => subterm (fn tm => Cases_on`^(Term.subst[{redex = #1(dest_exists(#2 g)), residue = ``k:num``}] + (assert(has_pair_type)tm))`) (#2 g) g) >> + drule pc_compile_correct >> fs [] >> + ‘q ≠ SOME Error ∧ + q ≠ SOME Break ∧ q ≠ SOME Continue ∧ q ≠ NONE’ by ( + last_x_assum (qspec_then ‘k’ assume_tac) >> rfs [] >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs []) >> + fs [] >> + disch_then (qspecl_then [‘t with clock := k’, ‘nctxt’] mp_tac) >> + impl_tac + >- fs [Abbr ‘nctxt’, mk_ctxt_def, state_rel_def] >> + strip_tac >> fs [] >> + fs [compile_def] >> + fs [compile_exp_def] >> + assume_tac (INST_TYPE [``:'a``|->``:'a``, + ``:'b``|->``:'b``] + crepPropsTheory.evaluate_add_clock_io_events_mono) >> + first_x_assum (qspecl_then + [‘Call Tail (Label start) []’, + ‘t with clock := k’, ‘ck’] mp_tac) >> + strip_tac >> rfs [] >> + qexists_tac ‘k’ >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs [] >> rveq >> fs [] >> + fs [state_rel_def, IS_PREFIX_THM] +QED + + +val _ = export_theory(); diff --git a/pancake/proofs/pan_to_wordProofScript.sml b/pancake/proofs/pan_to_wordProofScript.sml new file mode 100644 index 0000000000..90cd449fd1 --- /dev/null +++ b/pancake/proofs/pan_to_wordProofScript.sml @@ -0,0 +1,724 @@ +(* + Correctness proof for -- +*) + +open preamble pan_to_wordTheory + pan_simpProofTheory pan_to_crepProofTheory + crep_to_loopProofTheory loop_to_wordProofTheory + +val _ = new_theory "pan_to_wordProof"; + + +Definition pan_simp_st_def: + pan_simp_st (s:('a,'ffi) panSem$state) (pan_code:(mlstring # (mlstring # shape) list # α prog) list) = + s with code := alist_to_fmap (pan_simp$compile_prog pan_code) +End + + +Definition crep_state_def: + crep_state (s:('a,'ffi) panSem$state) (pan_code:(mlstring # (mlstring # shape) list # α prog) list) = + <| locals := FEMPTY; + globals := FEMPTY; + code := alist_to_fmap (pan_to_crep$compile_prog pan_code); + memory := s.memory; + memaddrs := s.memaddrs; + clock := s.clock; + be := s.be; + ffi := s.ffi|> +End + +(* wlab_wloc should have taken only funcs of context *) +Definition mk_mem_def: + mk_mem funcs smem = + λad. wlab_wloc funcs (smem ad) +End + +Definition loop_state_def: + loop_state (s:('a,'ffi) crepSem$state) crep_code ck = + <| locals := LN; + globals := FEMPTY; + memory := mk_mem (make_funcs crep_code) s.memory; + mdomain := s.memaddrs; + code := fromAList (crep_to_loop$compile_prog crep_code); + clock := ck; + be := s.be; + ffi := s.ffi|> +End + + +Definition consistent_labels_def: + consistent_labels (mem:'a word -> 'a word_lab) + (pan_code:(mlstring # (mlstring # shape) list # α prog) list) <=> + ∀ad f. + mem ad = Label f ⇒ + ∃n m. FLOOKUP (make_funcs (compile_prog (pan_simp$compile_prog pan_code))) f = SOME (n,m) +End + +Definition distinct_params_def: + distinct_params prog <=> + EVERY (λ(name,params,body). ALL_DISTINCT params) prog +End + + +Theorem first_compile_prog_all_distinct: + !prog. ALL_DISTINCT (MAP FST prog) ==> + ALL_DISTINCT (MAP FST (pan_to_word$compile_prog prog)) +Proof + rw [] >> + fs [pan_to_wordTheory.compile_prog_def] >> + match_mp_tac loop_to_wordProofTheory.first_compile_all_distinct >> + metis_tac [crep_to_loopProofTheory.first_compile_prog_all_distinct] +QED + + +Theorem FDOM_get_eids_pan_simp_compile_eq: + !prog. FDOM ((get_eids prog): mlstring |-> α word) = + FDOM ((get_eids (pan_simp$compile_prog prog)):mlstring |-> α word) +Proof + rw [] >> + fs [pan_to_crepTheory.get_eids_def] >> + qmatch_goalsub_abbrev_tac ‘remove_dup (FLAT es)’ >> + qmatch_goalsub_abbrev_tac ‘_ = set (MAP FST (MAP2 (λx y. (x,y)) + (remove_dup (FLAT ces)) _ ))’ >> + qsuff_tac ‘es = ces’ + >- fs [] >> + fs [Abbr ‘es’, Abbr ‘ces’, pan_simpTheory.compile_prog_def] >> + fs [MAP_MAP_o] >> + fs [pan_simpProofTheory.map_snd_f_eq] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + ‘EL n (MAP (SND ∘ SND) prog) = + (SND ∘ SND) (EL n prog)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [] >> + fs [exp_ids_compile_eq] +QED + + +Theorem flookup_pan_simp_mk_funcs_none_eq: + !p f. + (FLOOKUP (make_funcs (compile_prog p)) f): (num#num) option = NONE ==> + FLOOKUP (crep_to_loop$make_funcs (pan_to_crep$compile_prog (compile_prog p))) f = NONE +Proof + rw [] >> + fs [flookup_thm] >> + qmatch_asmsub_abbrev_tac ‘_ ∉ xs’ >> + qmatch_goalsub_abbrev_tac ‘_ ∉ ys’ >> + qsuff_tac ‘xs = ys’ + >- (strip_tac >> fs []) >> + fs [Abbr ‘xs’, Abbr ‘ys’] >> + pop_assum kall_tac >> + fs [crep_to_loopTheory.make_funcs_def] >> + qmatch_goalsub_abbrev_tac ‘set xs = set ys’ >> + qsuff_tac ‘xs = ys’ + >- fs [] >> + fs [Abbr ‘xs’, Abbr ‘ys’] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + conj_asm1_tac + >- fs [pan_to_crepTheory.compile_prog_def, pan_simpTheory.compile_prog_def] >> + fs [] >> + rw [] >> + qmatch_goalsub_abbrev_tac ‘FST (EL n (MAP2 f ws xs)) = FST (EL n (MAP2 g ys zs))’ >> + ‘EL n (MAP2 f ws xs) = f (EL n ws) (EL n xs)’ by ( + match_mp_tac EL_MAP2 >> + unabbrev_all_tac >> fs []) >> + ‘EL n (MAP2 g ys zs) = g (EL n ys) (EL n zs)’ by ( + match_mp_tac EL_MAP2 >> + unabbrev_all_tac >> fs []) >> + fs [] >> + unabbrev_all_tac >> fs [] >> rveq >> rfs [] >> + fs [pan_to_crepTheory.compile_prog_def] >> + fs [MAP_MAP_o] >> + qmatch_goalsub_abbrev_tac ‘EL n (MAP f _) = EL n (MAP g _)’ >> + ‘EL n (MAP f p) = f (EL n p)’ by ( + match_mp_tac EL_MAP >> + unabbrev_all_tac >> fs []) >> + ‘EL n (MAP g (compile_prog p)) = g (EL n (compile_prog p))’ by ( + match_mp_tac EL_MAP >> + unabbrev_all_tac >> fs []) >> + fs [] >> + unabbrev_all_tac >> fs [] >> + ‘EL n (pan_simp$compile_prog p) = + (λ(name,params,body). (name,params,compile body)) (EL n p)’ by ( + fs [pan_simpTheory.compile_prog_def] >> + match_mp_tac EL_MAP >> + fs []) >> + fs [] >> + cases_on ‘EL n p’ >> fs [] >> + cases_on ‘r’ >> fs [] +QED + +Theorem flookup_pan_simp_mk_funcs_some_eq: + !p f x. ALL_DISTINCT (MAP FST p) ∧ + (FLOOKUP (make_funcs (compile_prog p)) f): (num#num) option = SOME x ==> + FLOOKUP (crep_to_loop$make_funcs (pan_to_crep$compile_prog (compile_prog p))) f = SOME x +Proof + rw [] >> + fs [crep_to_loopTheory.make_funcs_def] >> + dxrule ALOOKUP_MEM >> + strip_tac >> + match_mp_tac ALOOKUP_ALL_DISTINCT_MEM >> + reverse conj_tac + >- ( + fs [MEM_EL] >> + qexists_tac ‘n’ >> + reverse conj_asm1_tac + >- ( + qmatch_goalsub_abbrev_tac ‘EL n (MAP2 ff ws xs) = EL n (MAP2 gg ys zs)’ >> + ‘EL n (MAP2 ff ws xs) = ff (EL n ws) (EL n xs)’ by ( + match_mp_tac EL_MAP2 >> + unabbrev_all_tac >> fs []) >> + ‘EL n (MAP2 gg ys zs) = gg (EL n ys) (EL n zs)’ by ( + match_mp_tac EL_MAP2 >> + unabbrev_all_tac >> fs []) >> + fs [] >> + unabbrev_all_tac >> fs [] >> rveq >> rfs [] >> + conj_tac + >- ( + fs [pan_to_crepTheory.compile_prog_def] >> + fs [MAP_MAP_o] >> + qmatch_goalsub_abbrev_tac ‘EL n (MAP ff _) = EL n (MAP gg _)’ >> + ‘EL n (MAP ff p) = ff (EL n p)’ by ( + match_mp_tac EL_MAP >> + unabbrev_all_tac >> fs []) >> + ‘EL n (MAP gg (compile_prog p)) = gg (EL n (compile_prog p))’ by ( + match_mp_tac EL_MAP >> + unabbrev_all_tac >> fs []) >> + fs [] >> + unabbrev_all_tac >> fs [] >> + ‘EL n (pan_simp$compile_prog p) = + (λ(name,params,body). (name,params,compile body)) (EL n p)’ by ( + fs [pan_simpTheory.compile_prog_def] >> + match_mp_tac EL_MAP >> + fs []) >> + fs [] >> + cases_on ‘EL n p’ >> fs [] >> + cases_on ‘r’ >> fs []) >> + qmatch_goalsub_abbrev_tac ‘EL n (MAP2 ff ws xs) = EL n (MAP2 gg ys zs)’ >> + ‘EL n (MAP2 ff ws xs) = ff (EL n ws) (EL n xs)’ by ( + match_mp_tac EL_MAP2 >> + unabbrev_all_tac >> fs []) >> + ‘EL n (MAP2 gg ys zs) = gg (EL n ys) (EL n zs)’ by ( + match_mp_tac EL_MAP2 >> + unabbrev_all_tac >> fs []) >> + fs [] >> + unabbrev_all_tac >> fs [] >> rveq >> fs [] >> + qmatch_goalsub_abbrev_tac ‘EL n (MAP ff pp) = EL n (MAP gg qq)’ >> + ‘EL n (MAP ff pp) = ff (EL n pp)’ by ( + match_mp_tac EL_MAP >> + unabbrev_all_tac >> fs []) >> + ‘EL n (MAP gg qq) = gg (EL n qq)’ by ( + match_mp_tac EL_MAP >> + unabbrev_all_tac >> fs []) >> + fs [] >> + unabbrev_all_tac >> fs [] >> rveq >> + fs [pan_to_crepTheory.compile_prog_def] >> + qmatch_goalsub_abbrev_tac + ‘LENGTH (FST (SND (EL n (MAP ff _)))) = + LENGTH (FST (SND (EL n (MAP gg _))))’ >> + ‘EL n (MAP ff p) = ff (EL n p)’ by ( + match_mp_tac EL_MAP >> + unabbrev_all_tac >> fs []) >> + ‘EL n (MAP gg (compile_prog p)) = gg (EL n (compile_prog p))’ by ( + match_mp_tac EL_MAP >> + unabbrev_all_tac >> fs []) >> + fs [] >> + unabbrev_all_tac >> fs [] >> + ‘EL n (pan_simp$compile_prog p) = + (λ(name,params,body). (name,params,compile body)) (EL n p)’ by ( + fs [pan_simpTheory.compile_prog_def] >> + match_mp_tac EL_MAP >> + fs []) >> + fs [] >> + cases_on ‘EL n p’ >> fs [] >> + cases_on ‘r’ >> fs []) >> + fs [pan_to_crepTheory.compile_prog_def, + pan_simpTheory.compile_prog_def]) >> + qmatch_goalsub_abbrev_tac ‘MAP _ xs’ >> + ‘MAP FST xs = MAP FST (compile_prog (compile_prog p))’ by ( + unabbrev_all_tac >> fs [] >> + qmatch_goalsub_abbrev_tac ‘MAP _ xs = MAP _ ys’ >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + unabbrev_all_tac >> fs [] >> + rw [] >> + qmatch_goalsub_abbrev_tac ‘FST (EL n (MAP2 ff ws xs)) = _’ >> + ‘EL n (MAP2 ff ws xs) = ff (EL n ws) (EL n xs)’ by ( + match_mp_tac EL_MAP2 >> + unabbrev_all_tac >> fs []) >> + fs [] >> + unabbrev_all_tac >> fs [] >> + match_mp_tac EL_MAP >> + fs []) >> + fs [] >> + match_mp_tac pan_to_crepProofTheory.first_compile_prog_all_distinct >> + match_mp_tac pan_simpProofTheory.first_compile_prog_all_distinct >> + fs [] +QED + + +Theorem flookup_pan_simp_mk_funcs_eq: + !p f x. ALL_DISTINCT (MAP FST p) ==> + (FLOOKUP (make_funcs (compile_prog p)) f): (num#num) option = + FLOOKUP (crep_to_loop$make_funcs (pan_to_crep$compile_prog (compile_prog p))) f +Proof + rpt gen_tac >> + cases_on ‘(FLOOKUP (make_funcs (compile_prog p)) f): (num#num) option’ >> + metis_tac [flookup_pan_simp_mk_funcs_none_eq, flookup_pan_simp_mk_funcs_some_eq] +QED + + +Theorem crep_to_loop_intermediate_label: + ∀pan_code start prog. + ALOOKUP pan_code start = SOME ([],prog) ∧ + ALL_DISTINCT (MAP FST pan_code) ⇒ + ∃n. n < LENGTH pan_code ∧ EL n pan_code = (start,[],prog) ∧ + FLOOKUP (crep_to_loop$make_funcs + (pan_to_crep$compile_prog (pan_simp$compile_prog pan_code))) start = SOME (n,0) +Proof + rw [] >> + dxrule ALOOKUP_MEM >> + strip_tac >> + fs [crep_to_loopTheory.make_funcs_def] >> + fs [ALOOKUP_EXISTS_IFF] >> + fs [MEM_EL] >> + qexists_tac ‘n’ >> + fs [] >> + match_mp_tac ALOOKUP_ALL_DISTINCT_MEM >> + conj_tac + >- ( + qmatch_goalsub_abbrev_tac ‘MAP _ pp’ >> + qsuff_tac ‘MAP FST pp = MAP FST pan_code’ + >- fs [] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + fs [Abbr ‘pp’] >> + conj_asm1_tac + >- ( + fs [pan_to_crepTheory.compile_prog_def, + pan_simpTheory.compile_prog_def]) >> + fs [] >> + rw [] >> + qmatch_goalsub_abbrev_tac ‘EL n' (MAP2 f xs ys)’ >> + ‘EL n' (MAP2 f xs ys) = f (EL n' xs) (EL n' ys)’ by ( + match_mp_tac EL_MAP2 >> + unabbrev_all_tac >> fs []) >> + fs [] >> + unabbrev_all_tac >> fs [] >> + fs [pan_to_crepTheory.compile_prog_def, + pan_simpTheory.compile_prog_def] >> + fs [MAP_MAP_o] >> + qmatch_goalsub_abbrev_tac ‘EL n' (MAP ff _)’ >> + ‘EL n' (MAP ff pan_code) = ff (EL n' pan_code)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [] >> + unabbrev_all_tac >> fs [] >> + cases_on ‘EL n' pan_code’ >> + fs [] >> cases_on ‘r’ >> rfs []) >> + fs [MEM_EL] >> + qexists_tac ‘n’ >> + conj_asm1_tac + >- ( + fs [pan_to_crepTheory.compile_prog_def, + pan_simpTheory.compile_prog_def]) >> + qmatch_goalsub_abbrev_tac ‘_ = EL n (MAP2 f xs ys)’ >> + ‘EL n (MAP2 f xs ys) = f (EL n xs) (EL n ys)’ by ( + match_mp_tac EL_MAP2 >> + unabbrev_all_tac >> fs []) >> + fs [] >> + unabbrev_all_tac >> fs [] >> + conj_tac + >- ( + fs [pan_to_crepTheory.compile_prog_def, + pan_simpTheory.compile_prog_def] >> + fs [MAP_MAP_o] >> + qmatch_goalsub_abbrev_tac ‘_ = EL n (MAP ff _)’ >> + ‘EL n (MAP ff pan_code) = ff (EL n pan_code)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [] >> + unabbrev_all_tac >> fs [] >> + cases_on ‘EL n pan_code’ >> + fs [] >> cases_on ‘r’ >> rfs []) >> + qmatch_goalsub_abbrev_tac ‘_ = EL n (MAP2 f xs ys)’ >> + ‘EL n (MAP2 f xs ys) = f (EL n xs) (EL n ys)’ by ( + match_mp_tac EL_MAP2 >> + unabbrev_all_tac >> fs []) >> + fs [] >> + unabbrev_all_tac >> fs [] >> + qmatch_goalsub_abbrev_tac ‘EL n (MAP f pp) = _’ >> + ‘EL n (MAP f pp) = f (EL n pp)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [] >> + unabbrev_all_tac >> fs [] >> + fs [pan_to_crepTheory.compile_prog_def, + pan_simpTheory.compile_prog_def] >> + fs [MAP_MAP_o] >> + qmatch_goalsub_abbrev_tac ‘EL n (MAP ff _)’ >> + ‘EL n (MAP ff pan_code) = ff (EL n pan_code)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [] >> + unabbrev_all_tac >> fs [] >> + cases_on ‘EL n pan_code’ >> + fs [] >> cases_on ‘r’ >> + rfs [pan_to_crepTheory.crep_vars_def, panLangTheory.size_of_shape_def] +QED + + +Theorem state_rel_imp_semantics: + t.memory = mk_mem (make_funcs (compile_prog pan_code)) s.memory /\ + distinct_params pan_code ∧ + consistent_labels s.memory pan_code /\ + t.mdomain = s.memaddrs ∧ + t.be = s.be ∧ + t.ffi = s.ffi ∧ + ALL_DISTINCT (MAP FST pan_code) ∧ + ALOOKUP pan_code start = SOME ([],prog) ∧ + lc < LENGTH pan_code ∧ EL lc pan_code = (start,[],prog) ∧ + s.code = alist_to_fmap pan_code ∧ + t.code = fromAList (pan_to_word$compile_prog pan_code) ∧ + s.locals = FEMPTY ∧ size_of_eids pan_code < dimword (:α) ∧ + FDOM s.eshapes = FDOM ((get_eids pan_code):mlstring |-> 'a word) ∧ + lookup 0 t.locals = SOME (Loc 1 0) /\ + semantics s start <> Fail ==> + semantics (t:('a,'b, 'ffi) wordSem$state) lc = + semantics (s:('a,'ffi) panSem$state) start +Proof + rw [] >> + drule crep_to_loop_intermediate_label >> + rfs [] >> + strip_tac >> + ‘n = lc’ by ( + drule ALL_DISTINCT_EL_IMP >> + disch_then (qspecl_then [‘n’, ‘lc’] mp_tac) >> + fs [] >> + strip_tac >> + ‘EL n (MAP FST pan_code) = FST (EL n pan_code)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + ‘EL lc (MAP FST pan_code) = FST (EL lc pan_code)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + gs []) >> rveq >> + (* pan-simp pass *) + ‘state_rel s (pan_simp_st s pan_code) (pan_simp_st s pan_code).code’ by ( + fs [pan_simpProofTheory.state_rel_def, pan_simp_st_def] >> + conj_tac >> rw [] + >- ( + fs [pan_simpTheory.compile_prog_def] >> + fs [ALOOKUP_FAILS] >> + rw [] >> + fs [MEM_MAP] >> + rw [] >> + cases_on ‘y’ >> + cases_on ‘r’ >> fs [] >> + CCONTR_TAC >> fs [] >> + rveq >> fs [] >> metis_tac []) >> + fs [pan_simpTheory.compile_prog_def] >> + fs [ALOOKUP_EXISTS_IFF] >> + match_mp_tac ALOOKUP_ALL_DISTINCT_MEM >> + conj_tac + >- ( + fs [MAP_MAP_o] >> + qmatch_goalsub_abbrev_tac ‘MAP ff _’ >> + ‘MAP ff pan_code = MAP FST pan_code’ by ( + fs [Abbr ‘ff’, MAP_EQ_f] >> + rw [] >> + cases_on ‘e’ >> fs [] >> + cases_on ‘r’ >> fs []) >> + fs []) >> + fs [MEM_MAP] >> + qexists_tac ‘(f,vshs,prog')’ >> + fs [] >> + drule ALOOKUP_MEM >> fs []) >> + drule pan_simpProofTheory.state_rel_imp_semantics >> + disch_then (qspecl_then [‘pan_code’, ‘start’, ‘prog’] mp_tac) >> + fs [] >> + impl_tac >- fs [pan_simp_st_def] >> + strip_tac >> + pop_assum (assume_tac o GSYM) >> + fs [] >> + qmatch_goalsub_abbrev_tac ‘semantics pst start’ >> + (* pan_to_crep pass *) + qmatch_asmsub_abbrev_tac ‘make_funcs (_ pcode)’ >> + ‘ALOOKUP pcode start = SOME ([],compile prog)’ by ( + fs [Abbr ‘pcode’, pan_simpTheory.compile_prog_def] >> + match_mp_tac ALOOKUP_ALL_DISTINCT_MEM >> + conj_tac + >- ( + fs [MAP_MAP_o] >> + qmatch_goalsub_abbrev_tac ‘MAP ff _’ >> + ‘MAP ff pan_code = MAP FST pan_code’ by ( + fs [Abbr ‘ff’, MAP_EQ_f] >> + rw [] >> + cases_on ‘e’ >> fs [] >> + cases_on ‘r’ >> fs []) >> + fs []) >> + fs [MEM_MAP] >> + qexists_tac ‘(start,[],prog)’ >> + fs [] >> + drule ALOOKUP_MEM >> fs []) >> + ‘state_rel pst (crep_state pst pcode)’ by + fs [Abbr ‘pcode’, pan_to_crepProofTheory.state_rel_def, crep_state_def] >> + drule pan_to_crepProofTheory.state_rel_imp_semantics >> + disch_then (qspecl_then [‘pcode’, + ‘start’, ‘pan_simp$compile prog’] mp_tac) >> + fs [] >> + impl_tac + >- ( + fs [Abbr ‘pcode’, Abbr ‘pst’, pan_simp_st_def, crep_state_def] >> + conj_tac + >- ( + match_mp_tac pan_simpProofTheory.first_compile_prog_all_distinct >> + fs []) >> + fs [size_of_eids_compile_eq] >> + fs [Once FDOM_get_eids_pan_simp_compile_eq]) >> + strip_tac >> + pop_assum (assume_tac o GSYM) >> + fs [] >> + qmatch_goalsub_abbrev_tac ‘semantics cst start’ >> + (* crep_to_loop pass *) + qmatch_asmsub_abbrev_tac ‘make_funcs ccode’ >> + ‘ALOOKUP ccode start = + SOME ([],comp_func (make_funcs pcode) + (get_eids pcode) [] (compile prog))’ by ( + fs [Abbr ‘ccode’, Abbr ‘pcode’, Abbr ‘pst’, Abbr ‘cst’, + pan_simp_st_def, crep_state_def, loop_state_def] >> + match_mp_tac alookup_compile_prog_code >> + conj_tac + >- ( + match_mp_tac pan_simpProofTheory.first_compile_prog_all_distinct >> + fs []) >> + fs [pan_simpTheory.compile_prog_def]) >> + ‘cst.memaddrs = + (loop_state cst ccode t.clock).mdomain’ by + fs [Abbr ‘ccode’, Abbr ‘pcode’, Abbr ‘cst’, Abbr ‘pst’, crep_state_def, loop_state_def] >> + drule crep_to_loopProofTheory.state_rel_imp_semantics >> + disch_then (qspecl_then [‘ccode’, + ‘start’, ‘comp_func (make_funcs pcode) + (get_eids pcode) [] (compile prog)’, + ‘lc’] mp_tac) >> + impl_tac + >- ( + fs [Abbr ‘ccode’, Abbr ‘pcode’, Abbr ‘pst’, Abbr ‘cst’, + pan_simp_st_def, crep_state_def, loop_state_def] >> + conj_tac + >- ( + fs [crep_to_loopTheory.mk_ctxt_def, mk_mem_def, mem_rel_def, consistent_labels_def] >> + rw [] >> res_tac >> rfs []) >> + conj_tac >- fs [crep_to_loopProofTheory.globals_rel_def] >> + match_mp_tac pan_to_crepProofTheory.first_compile_prog_all_distinct >> + match_mp_tac pan_simpProofTheory.first_compile_prog_all_distinct >> + fs []) >> + strip_tac >> + pop_assum (assume_tac o GSYM) >> + fs [] >> + pop_assum kall_tac >> + qmatch_goalsub_abbrev_tac ‘_ = semantics lst _’ >> + + (* loop_to_word pass *) + qmatch_asmsub_abbrev_tac ‘_ = SOME ([],cprog)’ >> + drule pan_simpProofTheory.first_compile_prog_all_distinct >> + strip_tac >> + drule pan_to_crepProofTheory.first_compile_prog_all_distinct >> + strip_tac >> + ‘st_rel lst t (compile_prog ccode)’ by ( + fs [st_rel_def] >> + conj_tac + >- ( + fs [loop_removeProofTheory.state_rel_def] >> + qexists_tac ‘fromAList (comp_prog (compile_prog ccode))’ >> + fs [] >> rw [] + >- ( + fs [Abbr ‘lst’, loop_state_def] >> + fs [crep_to_loopTheory.compile_prog_def] >> + drule pan_commonPropsTheory.lookup_some_el >> + strip_tac >> + pop_assum mp_tac >> + qmatch_goalsub_abbrev_tac ‘EL m (MAP2 gg xs ys)’ >> + ‘EL m (MAP2 gg xs ys) = gg (EL m xs) (EL m ys)’ by ( + ho_match_mp_tac EL_MAP2 >> + fs [Abbr ‘xs’, Abbr ‘ys’]) >> + fs [Abbr ‘gg’, Abbr ‘xs’, Abbr ‘ys’] >> + pop_assum kall_tac >> + cases_on ‘EL m ccode’ >> fs [] >> + cases_on ‘r’ >> fs [] >> + strip_tac >> rveq >> gs [] >> + fs [loop_liveTheory.optimise_def] >> + fs [loop_liveTheory.comp_def] >> + fs [loop_liveProofTheory.mark_all_syntax_ok]) >> + (* has_code *) + match_mp_tac loop_removeProofTheory.comp_prog_has_code >> + reverse conj_tac + >- ( + fs [Abbr ‘lst’, loop_state_def] >> + fs [lookup_fromAList] >> + drule ALOOKUP_MEM >> + fs []) >> + fs [crep_to_loopProofTheory.first_compile_prog_all_distinct]) >> + conj_tac + >- ( + fs [loop_to_wordProofTheory.state_rel_def] >> + fs [Abbr ‘lst’, Abbr ‘cst’, Abbr ‘pst’, pan_simp_st_def, + loop_state_def, crep_state_def] >> + conj_tac + >- ( + fs [mk_mem_def, crep_to_loopTheory.mk_ctxt_def] >> + fs [FUN_EQ_THM] >> + rw [] >> + cases_on ‘s.memory ad’ >> fs [wlab_wloc_def, Once flookup_pan_simp_mk_funcs_eq]) >> + fs [globals_rel_def] >> + fs [loop_to_wordProofTheory.code_rel_def] >> + rw [] + >- ( + fs [lookup_fromAList] >> + dxrule ALOOKUP_MEM >> + strip_tac >> + match_mp_tac ALOOKUP_ALL_DISTINCT_MEM >> + conj_tac + >- ( + match_mp_tac first_compile_prog_all_distinct >> + fs []) >> + fs [pan_to_wordTheory.compile_prog_def] >> + fs [loop_to_wordTheory.compile_def] >> + drule mem_prog_mem_compile_prog >> fs []) >> + fs [lookup_fromAList] >> + drule ALOOKUP_MEM >> + strip_tac >> + rfs [] + >- (drule loop_removeProofTheory.comp_prog_no_loops >> fs []) >> + drule loop_removeProofTheory.compile_prog_distinct_params >> + impl_tac + >- ( + ho_match_mp_tac crep_to_loopProofTheory.compile_prog_distinct_params >> + fs [Abbr ‘ccode’] >> + ho_match_mp_tac pan_to_crepProofTheory.compile_prog_distinct_params >> + fs [Abbr ‘pcode’] >> + ho_match_mp_tac pan_simpProofTheory.compile_prog_distinct_params >> + fs [distinct_params_def]) >> + fs []) >> + fs [loop_to_wordProofTheory.code_rel_def] >> + rw [] + >- ( + fs [lookup_fromAList] >> + dxrule ALOOKUP_MEM >> + strip_tac >> + match_mp_tac ALOOKUP_ALL_DISTINCT_MEM >> + conj_tac + >- ( + match_mp_tac first_compile_prog_all_distinct >> + fs []) >> + fs [pan_to_wordTheory.compile_prog_def] >> + fs [loop_to_wordTheory.compile_def] >> + drule mem_prog_mem_compile_prog >> fs []) >> + drule pan_commonPropsTheory.lookup_some_el >> + strip_tac >> + drule EL_MEM >> + strip_tac >> + rfs [] + >- (drule loop_removeProofTheory.comp_prog_no_loops >> fs []) >> + drule loop_removeProofTheory.compile_prog_distinct_params >> + impl_tac + >- ( + ho_match_mp_tac crep_to_loopProofTheory.compile_prog_distinct_params >> + fs [Abbr ‘ccode’] >> + ho_match_mp_tac pan_to_crepProofTheory.compile_prog_distinct_params >> + fs [Abbr ‘pcode’] >> + ho_match_mp_tac pan_simpProofTheory.compile_prog_distinct_params >> + fs [distinct_params_def]) >> + fs []) >> + drule fstate_rel_imp_semantics >> + disch_then (qspecl_then [‘lc’, + ‘loop_live$optimise (comp_func (make_funcs ccode) [] cprog)’] mp_tac) >> + impl_tac + >- ( + fs [Abbr ‘lst’, loop_state_def, + Abbr ‘ccode’, Abbr ‘pcode’, + pan_to_wordTheory.compile_prog_def] >> + fs [lookup_fromAList] >> + fs [Abbr ‘cprog’] >> + match_mp_tac ALOOKUP_ALL_DISTINCT_MEM >> + conj_tac + >- fs [crep_to_loopProofTheory.first_compile_prog_all_distinct] >> + fs [crep_to_loopTheory.compile_prog_def] >> + qmatch_goalsub_abbrev_tac ‘MEM ff _’ >> + pop_assum mp_tac >> + qpat_x_assum ‘lc < _’ mp_tac >> + qpat_x_assum ‘EL lc pan_code = _’ mp_tac >> + qpat_x_assum ‘FLOOKUP _ _ = SOME _’ mp_tac >> + qpat_x_assum ‘ALOOKUP _ _ = SOME _’ mp_tac >> + qpat_x_assum ‘ALOOKUP _ _ = SOME _’ mp_tac >> + qpat_x_assum ‘ALOOKUP _ _ = SOME _’ mp_tac >> + rpt (pop_assum kall_tac) >> + rpt strip_tac >> + qmatch_asmsub_abbrev_tac + ‘ALOOKUP (_ (_ pan_code)) start = SOME ([],cprog)’ >> + ‘lc < LENGTH (pan_to_crep$compile_prog (pan_simp$compile_prog pan_code))’ by + fs [pan_to_crepTheory.compile_prog_def, pan_simpTheory.compile_prog_def] >> + fs [MEM_EL] >> + qexists_tac ‘lc’ >> + rfs [] >> + qmatch_goalsub_abbrev_tac ‘_ = EL lc (MAP2 gg xs ys)’ >> + ‘EL lc (MAP2 gg xs ys) = gg (EL lc xs) (EL lc ys)’ by ( + ho_match_mp_tac EL_MAP2 >> + fs [Abbr ‘xs’, Abbr ‘ys’]) >> + fs [Abbr ‘gg’, Abbr ‘xs’, Abbr ‘ys’] >> + pop_assum kall_tac >> + qmatch_goalsub_abbrev_tac ‘_ = hs x’ >> + cases_on ‘x’ >> fs [] >> + cases_on ‘r’ >> fs [] >> + fs [Abbr ‘hs’, Abbr ‘ff’] >> + conj_asm1_tac + >- ( + fs [pan_to_crepTheory.compile_prog_def] >> + pop_assum mp_tac >> + qmatch_goalsub_abbrev_tac ‘EL n (MAP ff xs)’ >> + ‘EL n (MAP ff xs) = ff (EL n xs)’ by ( + match_mp_tac EL_MAP >> + fs [Abbr ‘ff’, Abbr ‘xs’]) >> + fs [Abbr ‘ff’, Abbr ‘xs’] >> + pop_assum kall_tac >> + strip_tac >> + cases_on ‘EL n (pan_simp$compile_prog pan_code)’ >> + fs [] >> + cases_on ‘r’ >> fs [] >> + unabbrev_all_tac >> + fs [] >> rveq >> fs [] >> + pop_assum mp_tac >> + fs [pan_simpTheory.compile_prog_def] >> + qmatch_goalsub_abbrev_tac ‘EL n (MAP ff xs)’ >> + ‘EL n (MAP ff xs) = ff (EL n xs)’ by ( + match_mp_tac EL_MAP >> + fs [Abbr ‘ff’, Abbr ‘xs’]) >> + fs [Abbr ‘ff’, Abbr ‘xs’] >> rveq >> gs [] >> + fs [pan_to_crepTheory.crep_vars_def, panLangTheory.size_of_shape_def]) >> + cases_on ‘q'’ >> fs [GENLIST] >> + qsuff_tac ‘cprog = r'’ + >- fs [] >> + fs [Abbr ‘cprog’] >> + pop_assum kall_tac >> + fs [pan_to_crepTheory.compile_prog_def] >> + pop_assum mp_tac >> + qmatch_goalsub_abbrev_tac ‘EL n (MAP ff xs)’ >> + ‘EL n (MAP ff xs) = ff (EL n xs)’ by ( + match_mp_tac EL_MAP >> + fs [Abbr ‘ff’, Abbr ‘xs’]) >> + fs [Abbr ‘ff’, Abbr ‘xs’] >> + strip_tac >> + cases_on ‘EL n (pan_simp$compile_prog pan_code)’ >> + fs [] >> + cases_on ‘r’ >> fs [] >> rveq >> gs [] >> + pop_assum mp_tac >> + fs [pan_simpTheory.compile_prog_def] >> + qmatch_goalsub_abbrev_tac ‘EL n (MAP ff xs)’ >> + ‘EL n (MAP ff xs) = ff (EL n xs)’ by ( + match_mp_tac EL_MAP >> + fs [Abbr ‘ff’, Abbr ‘xs’]) >> + fs [Abbr ‘ff’, Abbr ‘xs’]) >> + fs [] +QED + + +val _ = export_theory(); diff --git a/pancake/proofs/readmePrefix b/pancake/proofs/readmePrefix new file mode 100644 index 0000000000..b31055578f --- /dev/null +++ b/pancake/proofs/readmePrefix @@ -0,0 +1 @@ +Proofs files for compiling Pancake. diff --git a/pancake/proofs/time_to_panProofScript.sml b/pancake/proofs/time_to_panProofScript.sml new file mode 100644 index 0000000000..2383bea7c7 --- /dev/null +++ b/pancake/proofs/time_to_panProofScript.sml @@ -0,0 +1,10931 @@ +(* + Correctness proof for -- +*) + +open preamble + timeSemTheory panSemTheory + timePropsTheory panPropsTheory + pan_commonPropsTheory time_to_panTheory + timeFunSemTheory + + +val _ = new_theory "time_to_panProof"; + +val _ = set_grammar_ancestry + ["timeSem", "panSem", + "pan_commonProps", "timeProps", + "time_to_pan"]; + +(* + FFI abstraction +*) + +Type time_input = ``:num -> num # num`` + +Type time_input_ffi = ``:time_input ffi_state`` + +Type pan_state = ``:('a, time_input) panSem$state`` + + +Definition get_bytes_def: + get_bytes be (w:'a word) = + let m = dimindex (:'a) DIV 8; + as = GENLIST (λm. (n2w m): 'a word) m + in + MAP (λa. get_byte a w be) as +End + + +Definition time_input_def: + time_input (:'a) be (f:num -> num # num) = + let + t = n2w (FST (f 1)):'a word; + b = n2w (SND (f 1)):'a word; + in + get_bytes be t ++ + get_bytes be b +End + + +Definition next_ffi_def: + next_ffi (f:num -> (num # num)) = + λn. f (n+1) +End + + +Definition string_to_word_def: + string_to_word = + n2w o THE o fromNatString o implode +End + + +Definition build_ffi_def: + build_ffi (:'a) be outs (seq:time_input) io = + <| oracle := + (λs f conf bytes. + if s = "get_time_input" + then Oracle_return (next_ffi f) (time_input (:'a) be f) + else if MEM s outs + then Oracle_return f bytes + else Oracle_final FFI_failed) + ; ffi_state := seq + ; io_events := io|> : time_input_ffi +End + +(* End of FFI abstraction *) + +Definition equiv_val_def: + equiv_val fm xs v <=> + v = MAP (ValWord o n2w o THE o (FLOOKUP fm)) xs +End + + +Definition valid_clks_def: + valid_clks clks tclks wt <=> + EVERY (λck. MEM ck clks) tclks ∧ + EVERY (λck. MEM ck clks) (MAP SND wt) +End + + +Definition resetClksVals_def: + resetClksVals fm xs ys = + MAP + (ValWord o n2w o THE o + (FLOOKUP (resetClocks fm ys))) xs +End + + +Definition retVal_def: + retVal s clks tclks wt dest = + Struct [ + Struct (resetClksVals s.clocks clks tclks); + ValWord (case wt of [] => 1w | _ => 0w); + ValWord (case wt of [] => 0w + | _ => n2w (THE (calculate_wtime s tclks wt))); + ValLabel (num_to_str dest)] +End + + +Definition maxClksSize_def: + maxClksSize clks ⇔ + SUM (MAP (size_of_shape o shape_of) clks) ≤ 29 +End + + +Definition defined_clocks_def: + defined_clocks fm clks ⇔ + EVERY + (λck. ∃n. FLOOKUP fm ck = SOME n) clks +End + + +Definition clock_bound_def: + clock_bound fm clks (m:num) ⇔ + EVERY + (λck. ∃n. FLOOKUP fm ck = SOME n ∧ + n < m) clks +End + +Definition restore_from_def: + (restore_from t lc [] = lc) ∧ + (restore_from t lc (v::vs) = + restore_from t (res_var lc (v, FLOOKUP t.locals v)) vs) +End + +Definition emptyVals_def: + emptyVals n = REPLICATE n (ValWord 0w) +End + +Definition constVals_def: + constVals n v = REPLICATE n v +End + + +Definition minOption_def: + (minOption (x:'a word) NONE = x) ∧ + (minOption x (SOME (y:num)) = + if x <₊ n2w y then x else n2w y) +End + + +Definition well_behaved_ffi_def: + well_behaved_ffi ffi_name (s:(α, β) panSem$state) n (m:num) <=> + explode ffi_name ≠ "" ∧ n < m ∧ + ∃bytes. + read_bytearray ffiBufferAddr n + (mem_load_byte s.memory s.memaddrs s.be) = + SOME bytes ∧ + s.ffi.oracle (explode ffi_name) s.ffi.ffi_state [] bytes = + Oracle_return s.ffi.ffi_state bytes +End + + +Definition ffi_return_state_def: + ffi_return_state s ffi_name bytes = + s with + <|memory := write_bytearray 4000w bytes s.memory s.memaddrs s.be; + ffi := + s.ffi with + <|io_events := + s.ffi.io_events ++ + [IO_event (explode ffi_name) [] (ZIP (bytes,bytes))]|> |> +End + + +Definition nffi_state_def: + nffi_state s (n:num) bytes = + s.ffi with + <|io_events := + s.ffi.io_events ++ + [IO_event (explode (num_to_str n)) [] (ZIP (bytes,bytes))]|> +End + +Definition code_installed_def: + code_installed code prog <=> + ∀loc tms. + MEM (loc,tms) prog ⇒ + let clks = clksOf prog; + n = LENGTH clks + in + FLOOKUP code (num_to_str loc) = + SOME ([(«clks», genShape n); + («event», One)], + compTerms clks «clks» «event» tms) +End + + +Definition ffi_vars_def: + ffi_vars fm ⇔ + FLOOKUP fm «ptr1» = SOME (ValWord 0w) ∧ + FLOOKUP fm «len1» = SOME (ValWord 0w) ∧ + FLOOKUP fm «ptr2» = SOME (ValWord ffiBufferAddr) ∧ + FLOOKUP fm «len2» = SOME (ValWord ffiBufferSize) +End + + +Definition time_vars_def: + time_vars fm ⇔ + (∃st. FLOOKUP fm «sysTime» = SOME (ValWord st)) ∧ + (∃wt. FLOOKUP fm «wakeUpAt» = SOME (ValWord wt)) ∧ + (∃io. FLOOKUP fm «event» = SOME (ValWord io)) ∧ + (∃i. FLOOKUP fm «isInput» = SOME (ValWord i)) ∧ + (∃w. FLOOKUP fm «waitSet» = SOME (ValWord w)) +End + + +(* for easier reasoning *) +Definition clkvals_rel_def: + clkvals_rel fm xs ys (n:num) ⇔ + MAP (λ(x,y). y + THE (FLOOKUP fm x)) (ZIP (xs,ys)) = + MAP (λx. n) ys ∧ + EVERY (\x. THE (FLOOKUP fm x) <= n) xs +End + + +Definition clocks_rel_def: + clocks_rel sclocks tlocals clks stime ⇔ + ∃ns. + FLOOKUP tlocals «clks» = + SOME (Struct (MAP (ValWord o n2w) ns)) ∧ + LENGTH clks = LENGTH ns ∧ + clkvals_rel sclocks clks ns stime +End + + +Definition active_low_def: + (active_low NONE = 1w) ∧ + (active_low (SOME _) = 0w) +End + + +Definition equivs_def: + equivs fm loc wt ⇔ + FLOOKUP fm «loc» = SOME (ValLabel (num_to_str loc)) ∧ + FLOOKUP fm «waitSet» = SOME (ValWord (active_low wt)) +End + +Definition time_seq_def: + time_seq (f:num -> num # num) m ⇔ + (∀n. ∃d. FST (f (SUC n)) = FST (f n) + d) ∧ + (∀n. FST (f n) < m) +End + + +Definition mem_config_def: + mem_config (mem:'a word -> 'a word_lab) (adrs:('a word) set) be ⇔ + (∃w. mem ffiBufferAddr = Word w) ∧ + (∃w. mem (ffiBufferAddr + bytes_in_word) = Word w) ∧ + ffiBufferAddr ∈ adrs ∧ + ffiBufferAddr + bytes_in_word ∈ adrs +End + + +Definition has_input_def: + has_input (n:num # num) ⇔ SND n ≠ 0 +End + + +Definition input_time_eq_def: + input_time_eq (n:num # num) m ⇔ + has_input m ⇒ FST m = FST n +End + + +Definition input_time_rel_def: + input_time_rel (f:num -> num # num) ⇔ + !n. input_time_eq (f n) (f (n+1)) +End + + +Definition state_rel_def: + state_rel clks outs s (t:('a,time_input) panSem$state) ⇔ + equivs t.locals s.location s.waitTime ∧ + ffi_vars t.locals ∧ time_vars t.locals ∧ + mem_config t.memory t.memaddrs t.be ∧ + LENGTH clks ≤ 29 ∧ + defined_clocks s.clocks clks ∧ + let + ffi = t.ffi.ffi_state; + io_events = t.ffi.io_events; + (tm,io_flg) = ffi 0 + in + t.ffi = build_ffi (:'a) t.be (MAP explode outs) ffi io_events ∧ + input_time_rel ffi ∧ + time_seq ffi (dimword (:'a)) ∧ + FLOOKUP t.locals «sysTime» = SOME (ValWord (n2w tm)) ∧ + clocks_rel s.clocks t.locals clks tm +End + +Definition nexts_ffi_def: + nexts_ffi m (f:num -> (num # num)) = + λn. f (n+m) +End + + +Definition delay_rep_def: + delay_rep (d:num) (seq:time_input) cycles ⇔ + FST (seq cycles) = d + FST (seq 0) ∧ + ∀i. i ≤ cycles ⇒ SND (seq i) = 0 +End + +Definition wakeup_rel_def: + (wakeup_rel fm NONE _ (seq:time_input) cycles = T) ∧ + (wakeup_rel fm (SOME wt) ist seq cycles = + let + st = FST (seq 0); + swt = ist + wt + in + FLOOKUP fm «sysTime» = SOME (ValWord (n2w st)) ∧ + ist ≤ st ∧ + FLOOKUP fm «wakeUpAt» = SOME (ValWord (n2w swt)) ∧ + (∀i. i ≤ cycles ⇒ + FST (seq i) < swt)) +End + + +Definition conds_clks_mem_clks_def: + conds_clks_mem_clks clks tms = + EVERY (λtm. + EVERY (λcnd. + EVERY (λck. MEM ck clks) (condClks cnd)) + (termConditions tm) + ) tms +End + +Definition terms_valid_clocks_def: + terms_valid_clocks clks tms = + EVERY (λtm. + valid_clks clks (termClks tm) (termWaitTimes tm) + ) tms +End + +Definition locs_in_code_def: + locs_in_code fm tms = + EVERY (λtm. + num_to_str (termDest tm) IN FDOM fm + ) tms +End + + +Definition out_signals_ffi_def: + out_signals_ffi (t :('a, 'b) panSem$state) tms = + EVERY (λout. + well_behaved_ffi (num_to_str out) t + (w2n (ffiBufferSize:'a word)) (dimword (:α))) + (terms_out_signals tms) +End + + +Definition mem_call_ffi_def: + mem_call_ffi (:α) mem adrs be (ffi: (num -> num # num)) = + write_bytearray + ffiBufferAddr + (get_bytes be ((n2w (FST (ffi 1))):'a word) ++ + get_bytes be ((n2w (SND (ffi 1))):'a word)) + mem adrs be +End + + +Definition ffi_call_ffi_def: + ffi_call_ffi (:α) be ffi bytes = + ffi with + <|ffi_state := next_ffi ffi.ffi_state; + io_events := ffi.io_events ++ + [IO_event "get_time_input" [] + (ZIP + (bytes, + get_bytes be ((n2w (FST (ffi.ffi_state (1:num)))):'a word) ++ + get_bytes be ((n2w (SND (ffi.ffi_state 1))):'a word)))]|> + +End + + +Datatype: + observed_io = ObsTime num + | ObsInput num + | ObsOutput num +End + + +Definition to_label_def: + (to_label (ObsTime n) = LDelay n) ∧ + (to_label (ObsInput n) = LAction (Input n)) ∧ + (to_label (ObsOutput n) = LAction (Output n)) +End + + +Definition to_delay_def: + (to_delay (ObsTime n) = SOME n) ∧ + (to_delay _ = NONE) +End + + +Definition to_input_def: + (to_input (ObsInput n) = SOME (Input (n - 1))) ∧ + (to_input _ = NONE) +End + +Definition mem_read_ffi_results_def: + mem_read_ffi_results (:'a) ffi (cycles:num) ⇔ + ∀i (t:('a,time_input) panSem$state) (t':('a,time_input) panSem$state). + i < cycles ∧ + t.ffi.ffi_state = nexts_ffi i ffi ∧ + evaluate + (ExtCall «get_time_input» «ptr1» «len1» «ptr2» «len2» , t) = + (NONE,t') ⇒ + t'.memory ffiBufferAddr = + Word (n2w (FST (nexts_ffi i ffi 1))) ∧ + t'.memory (bytes_in_word + ffiBufferAddr) = + Word (n2w (SND (nexts_ffi i ffi 1))) +End + +Definition io_event_dest_def: + io_event_dest (:'a) be (IO_event _ _ l) = + (MAP w2n o + (words_of_bytes: bool -> word8 list -> α word list) be o + MAP SND) l +End + +Definition io_events_dest_def: + io_events_dest (:'a) be ios = + MAP (io_event_dest (:'a) be) ios +End + + +Definition from_io_events_def: + from_io_events (:'a) be n ys = + io_events_dest (:'a) be (DROP n ys) +End + + +Definition decode_io_event_def: + decode_io_event (:'a) be (IO_event s conf l) = + if s ≠ "get_time_input" then (ObsOutput (toNum s)) + else ( + let + ti = io_event_dest (:'a) be (IO_event s conf l); + time = EL 0 ti; + input = EL 1 ti + in + if input = 0 then (ObsTime time) + else (ObsInput input)) +End + +Definition decode_io_events_def: + decode_io_events (:'a) be ios = + MAP (decode_io_event (:'a) be) ios +End + + +Definition io_events_eq_ffi_seq_def: + io_events_eq_ffi_seq seq cycles xs ⇔ + LENGTH xs = cycles ∧ + EVERY (λx. LENGTH x = 2) xs ∧ + (∀i. i < cycles ⇒ + (EL 0 (EL i xs), EL 1 (EL i xs)) = seq (i+1)) +End + + +Definition mk_ti_event_def: + mk_ti_event (:α) be bytes seq = + IO_event "get_time_input" [] + (ZIP (bytes, time_input (:α) be seq)) +End + + +Definition mk_ti_events_def: + mk_ti_events (:α) be (bytess:word8 list list) seqs = + MAP (λ(bytes,seq). mk_ti_event (:α) be bytes seq) + (ZIP (bytess, seqs)) +End + +Definition gen_ffi_states_def: + gen_ffi_states seq cycles = + MAP (λm. (λn. seq (n + m))) + (GENLIST I cycles) +End + +Definition delay_io_events_rel_def: + delay_io_events_rel (t:('a,time_input) panSem$state) (t':('a,time_input) panSem$state) cycles ⇔ + let + n = LENGTH t.ffi.io_events; + ios_to_nums = from_io_events (:'a) t.be n t'.ffi.io_events; + nios = DROP n t'.ffi.io_events; + obs_ios = decode_io_events (:'a) t'.be nios; + in + (∃bytess. + LENGTH bytess = cycles ∧ + EVERY (λbtyes. LENGTH btyes = 2 * dimindex (:α) DIV 8) bytess ∧ + t'.ffi.io_events = + t.ffi.io_events ++ + mk_ti_events (:α) t'.be bytess (gen_ffi_states t.ffi.ffi_state cycles)) ∧ + io_events_eq_ffi_seq t.ffi.ffi_state cycles ios_to_nums ∧ + (∀n. n < LENGTH obs_ios ⇒ + EL n obs_ios = ObsTime (FST (t.ffi.ffi_state (n+1)))) +End + +Definition delay_ios_mono_def: + delay_ios_mono obs_ios seq ⇔ + ∀i j. + i < LENGTH obs_ios ∧ j < LENGTH obs_ios ∧ i < j ⇒ + EL i obs_ios = ObsTime (FST (seq (i+1))) ∧ + EL j obs_ios = ObsTime (FST (seq (j+1))) ∧ + FST (seq (i+1)) ≤ FST (seq (j+1)) +End + + +(* to remove cycles dependency *) +Definition obs_ios_are_label_delay_def: + obs_ios_are_label_delay d (t:('a,time_input) panSem$state) (t':('a,time_input) panSem$state) ⇔ + let + n = LENGTH t.ffi.io_events; + nios = DROP n t'.ffi.io_events; + obs_ios = decode_io_events (:'a) t'.be nios; + in + delay_ios_mono obs_ios t.ffi.ffi_state ∧ + (obs_ios ≠ [] ⇒ + LDelay d = LDelay (THE (to_delay (EL (LENGTH obs_ios - 1) obs_ios)) - + EL 0 (io_event_dest (:α) t.be (LAST t.ffi.io_events)))) +End + + +Definition well_formed_terms_def: + well_formed_terms prog loc code <=> + ∀tms. + ALOOKUP prog loc = SOME tms ⇒ + conds_clks_mem_clks (clksOf prog) tms ∧ + terms_valid_clocks (clksOf prog) tms ∧ locs_in_code code tms +End + + +(* should stay as an invariant *) +Definition task_ret_defined_def: + task_ret_defined (fm: mlstring |-> 'a v) n ⇔ + ∃(vs:'a v list) v1 v2 v3. + FLOOKUP fm «taskRet» = SOME ( + Struct [ + Struct vs; + ValWord v1; + ValWord v2; + ValLabel v3 + ]) ∧ + EVERY (λv. ∃w. v = ValWord w) vs ∧ + LENGTH vs = n +End + +Definition input_rel_def: + input_rel fm n seq = + let + st = FST (seq (0:num)); + input = SND (seq 0) + in + FLOOKUP fm «sysTime» = SOME (ValWord (n2w st)) ∧ + FLOOKUP fm «event» = SOME (ValWord (n2w input)) ∧ + n = input - 1 ∧ input <> 0 +End + +Definition wakeup_rel_def: + (wakeup_rel fm NONE _ (seq:time_input) cycles = T) ∧ + (wakeup_rel fm (SOME wt) ist seq cycles = + let + st = FST (seq 0); + swt = ist + wt + in + FLOOKUP fm «sysTime» = SOME (ValWord (n2w st)) ∧ + ist ≤ st ∧ + FLOOKUP fm «wakeUpAt» = SOME (ValWord (n2w swt)) ∧ + (∀i. i ≤ cycles ⇒ + FST (seq i) < swt)) +End + +Definition wakeup_shape_def: + wakeup_shape (fm: mlstring |-> 'a v) wt ist ⇔ + ∃wt'. + FLOOKUP fm «wakeUpAt» = SOME (ValWord (n2w (ist + wt'))) ∧ + wt' < dimword (:α) - 1 ∧ + (case wt of + | NONE => T + | SOME wt => wt ≤ wt') +End + + +Definition wait_time_locals1_def: + wait_time_locals1 (:α) fm swt ist nst = + ∃wt. + FLOOKUP fm «wakeUpAt» = SOME (ValWord (n2w (wt + ist))) ∧ + wt < dimword (:α) - 1 ∧ + case swt of + | NONE => T + | SOME swt => + swt ≠ 0:num ⇒ + nst < wt + ist +End + + +Definition input_stime_rel_def: + (input_stime_rel NONE _ _ ⇔ T) ∧ + (input_stime_rel (SOME (wt:num)) ist st ⇔ + ist ≤ st ∧ + st < ist + wt) +End + + +Definition input_eq_ffi_seq_def: + input_eq_ffi_seq (seq:num -> num # num) xs ⇔ + LENGTH xs = 2 ∧ + (EL 0 xs, EL 1 xs) = seq 1 +End + + +Definition input_io_events_rel_def: + input_io_events_rel i (t:('a,time_input) panSem$state) (t':('a,time_input) panSem$state) ⇔ + let + n = LENGTH t.ffi.io_events; + nios = DROP n t'.ffi.io_events; + ios_to_nums = from_io_events (:'a) t.be n t'.ffi.io_events; + obs_ios = decode_io_events (:'a) t'.be nios + in + (∃bytes. + LENGTH bytes = 2 * dimindex (:α) DIV 8 ∧ + t'.ffi.io_events = + t.ffi.io_events ++ + [mk_ti_event (:α) t'.be bytes t.ffi.ffi_state]) ∧ + (∃ns. + ios_to_nums = [ns] ∧ + input_eq_ffi_seq t.ffi.ffi_state ns) ∧ + LENGTH obs_ios = 1 ∧ + EL 0 obs_ios = ObsInput (SND (t.ffi.ffi_state 1)) ∧ + LAction (Input i) = LAction (THE (to_input (EL 0 obs_ios))) +End + + +Definition output_rel_def: + output_rel fm (seq: num -> num # num) = + let + st = FST (seq 0) + in + ∃wt nt. + FLOOKUP fm «sysTime» = SOME (ValWord (n2w st)) ∧ + FLOOKUP fm «wakeUpAt» = SOME (ValWord (n2w (wt + nt))) ∧ + st = wt + nt ∧ + SND (seq 0) = 0 +End + +Definition output_io_events_rel_def: + output_io_events_rel os (t:('a,time_input) panSem$state) (t':('a,time_input) panSem$state) ⇔ + let + n = LENGTH t.ffi.io_events; + nios = DROP n t'.ffi.io_events; + obs_ios = decode_io_events (:'a) t'.be nios + in + (∃(bytes:word8 list). + t'.ffi.io_events = + t.ffi.io_events ++ + [IO_event (explode (num_to_str os)) [] (ZIP (bytes, bytes))]) ∧ + obs_ios = [ObsOutput os] +End + +Definition well_formed_code_def: + well_formed_code prog code <=> + ∀loc tms. + ALOOKUP prog loc = SOME tms ⇒ + well_formed_terms prog loc code +End + + +Definition event_inv_def: + event_inv fm ⇔ + FLOOKUP fm «isInput» = SOME (ValWord 1w) ∧ + FLOOKUP fm «event» = SOME (ValWord 0w) +End + +Definition assumptions_def: + assumptions prog n s (t:('a,time_input) panSem$state) ⇔ + state_rel (clksOf prog) (out_signals prog) s t ∧ + code_installed t.code prog ∧ + well_formed_code prog t.code ∧ + n = FST (t.ffi.ffi_state 0) ∧ + good_dimindex (:'a) ∧ + ~MEM "get_time_input" (MAP explode (out_signals prog)) ∧ + event_inv t.locals ∧ + task_ret_defined t.locals (nClks prog) ∧ + FLOOKUP t.eshapes «panic» = SOME One +End + + +Definition evaluations_def: + (evaluations prog [] [] ist s (t:('a,time_input) panSem$state) ⇔ T) ∧ + (evaluations prog (lbl::lbls) (st::sts) ist s t ⇔ + case lbl of + | LDelay d => + evaluate_delay prog d ist s st t lbls sts + | LAction act => + (case act of + | Input i => + evaluate_input prog i s st t lbls sts + | Output os => + evaluate_output prog os st t lbls sts) + | LPanic panic => + case panic of + | PanicTimeout => + (output_rel t.locals t.ffi.ffi_state ∧ + FST (t.ffi.ffi_state 0) < dimword (:α) - 2 ⇒ + ∃ck nt. + (∀ck_extra. + evaluate (time_to_pan$always (nClks prog), t with clock := t.clock + ck + ck_extra) = + (SOME (Exception «panic» (ValWord 0w)), nt with clock := nt.clock + ck_extra)) ∧ + nt.code = t.code ∧ + nt.be = t.be ∧ + nt.ffi.ffi_state = t.ffi.ffi_state ∧ + nt.ffi.io_events = t.ffi.io_events ∧ + nt.ffi.oracle = t.ffi.oracle ∧ + nt.eshapes = t.eshapes) + | PanicInput i => + (wakeup_shape t.locals s.waitTime (FST (t.ffi.ffi_state 0)) ∧ + input_stime_rel s.waitTime (FST (t.ffi.ffi_state 0)) (FST (t.ffi.ffi_state 0)) ∧ + input_rel t.locals i (next_ffi t.ffi.ffi_state) ∧ + mem_read_ffi_results (:α) t.ffi.ffi_state 1 ∧ + FST (t.ffi.ffi_state 1) < dimword (:α) - 2 ⇒ + ∃ck nt. + (∀ck_extra. + evaluate (time_to_pan$always (nClks prog), t with clock := t.clock + ck + ck_extra) = + (SOME (Exception «panic» (ValWord 0w)), nt with clock := nt.clock + ck_extra)) ∧ + ~MEM "get_time_input" (MAP explode (out_signals prog)) ∧ + nt.code = t.code ∧ + nt.be = t.be ∧ + nt.ffi.ffi_state = next_ffi t.ffi.ffi_state ∧ + nt.ffi.oracle = t.ffi.oracle ∧ + nt.eshapes = t.eshapes ∧ + nt.locals = FEMPTY ∧ + input_io_events_rel i t nt)) ∧ + + (evaluate_delay prog d ist s st (t:('a,time_input) panSem$state) lbls sts ⇔ + ∀cycles. + delay_rep d t.ffi.ffi_state cycles ∧ + wakeup_shape t.locals s.waitTime ist ∧ + wakeup_rel t.locals s.waitTime ist t.ffi.ffi_state cycles ∧ + mem_read_ffi_results (:α) t.ffi.ffi_state cycles ∧ + t.ffi.io_events ≠ [] ∧ + EL 0 (io_event_dest (:α) t.be (LAST t.ffi.io_events)) = FST (t.ffi.ffi_state 0) ⇒ + ∃ck nt. + (∀ck_extra. + evaluate (time_to_pan$always (nClks prog), t with clock := t.clock + ck + ck_extra) = + evaluate (time_to_pan$always (nClks prog), nt with clock := nt.clock + ck_extra)) ∧ + state_rel (clksOf prog) (out_signals prog) st nt ∧ + ~MEM "get_time_input" (MAP explode (out_signals prog)) ∧ + event_inv nt.locals ∧ + nt.code = t.code ∧ + nt.be = t.be ∧ + nt.ffi.ffi_state = nexts_ffi cycles t.ffi.ffi_state ∧ + nt.ffi.oracle = t.ffi.oracle ∧ + nt.eshapes = t.eshapes ∧ + FLOOKUP nt.locals «wakeUpAt» = FLOOKUP t.locals «wakeUpAt» ∧ + FLOOKUP nt.locals «waitSet» = FLOOKUP t.locals «waitSet» ∧ + FLOOKUP nt.locals «taskRet» = FLOOKUP t.locals «taskRet» ∧ + FLOOKUP nt.locals «sysTime» = + SOME (ValWord (n2w (FST (t.ffi.ffi_state cycles)))) ∧ + wait_time_locals1 (:α) nt.locals st.waitTime ist (FST (nt.ffi.ffi_state 0)) ∧ + delay_io_events_rel t nt cycles ∧ + obs_ios_are_label_delay d t nt ∧ + task_ret_defined nt.locals (nClks prog) ∧ + evaluations prog lbls sts ist st nt) ∧ + + (evaluate_input prog i s st (t:('a,time_input) panSem$state) lbls sts ⇔ + wakeup_shape t.locals s.waitTime (FST (t.ffi.ffi_state 0)) ∧ + input_stime_rel s.waitTime (FST (t.ffi.ffi_state 0)) (FST (t.ffi.ffi_state 0)) ∧ + input_rel t.locals i (next_ffi t.ffi.ffi_state) ∧ + mem_read_ffi_results (:α) t.ffi.ffi_state 1 ∧ + FST (t.ffi.ffi_state 1) < dimword (:α) - 2 ⇒ + ∃ck nt. + (∀ck_extra. + evaluate (time_to_pan$always (nClks prog), t with clock := t.clock + ck + ck_extra) = + evaluate (time_to_pan$always (nClks prog), nt with clock := nt.clock + ck_extra)) ∧ + state_rel (clksOf prog) (out_signals prog) st nt ∧ + ~MEM "get_time_input" (MAP explode (out_signals prog)) ∧ + event_inv nt.locals ∧ + nt.code = t.code ∧ + nt.be = t.be ∧ + nt.ffi.ffi_state = next_ffi t.ffi.ffi_state ∧ + nt.ffi.oracle = t.ffi.oracle ∧ + nt.eshapes = t.eshapes ∧ + FLOOKUP nt.locals «wakeUpAt» = + SOME (ValWord (n2w (FST (t.ffi.ffi_state 0) + + case st.waitTime of + | NONE => 0 + | SOME wt => wt))) ∧ + FLOOKUP nt.locals «waitSet» = + SOME (ValWord (n2w ( + case st.waitTime of + | NONE => 1 + | _ => 0))) ∧ + FLOOKUP nt.locals «sysTime» = FLOOKUP t.locals «sysTime» ∧ + wait_time_locals1 (:α) nt.locals st.waitTime (FST (t.ffi.ffi_state 0)) (FST (nt.ffi.ffi_state 0)) ∧ + input_io_events_rel i t nt ∧ + task_ret_defined nt.locals (nClks prog) ∧ + evaluations prog lbls sts (FST (t.ffi.ffi_state 0)) st nt) ∧ + + (evaluate_output prog os st (t:('a,time_input) panSem$state) lbls sts ⇔ + output_rel t.locals t.ffi.ffi_state ∧ + FST (t.ffi.ffi_state 0) < dimword (:α) - 2 ⇒ + ∃ck nt. + (∀ck_extra. + evaluate (time_to_pan$always (nClks prog), t with clock := t.clock + ck + ck_extra) = + evaluate (time_to_pan$always (nClks prog), nt with clock := nt.clock + ck_extra)) ∧ + state_rel (clksOf prog) (out_signals prog) st nt ∧ + ~MEM "get_time_input" (MAP explode (out_signals prog)) ∧ + event_inv nt.locals ∧ + nt.code = t.code ∧ + nt.be = t.be ∧ + nt.ffi.ffi_state = t.ffi.ffi_state ∧ + nt.ffi.oracle = t.ffi.oracle ∧ + nt.eshapes = t.eshapes ∧ + FLOOKUP nt.locals «wakeUpAt» = + SOME (ValWord (n2w (FST (t.ffi.ffi_state 0) + + case st.waitTime of + | NONE => 0 + | SOME wt => wt))) ∧ + FLOOKUP nt.locals «waitSet» = + SOME (ValWord (n2w ( + case st.waitTime of + | NONE => 1 + | _ => 0))) ∧ + FLOOKUP nt.locals «sysTime» = FLOOKUP t.locals «sysTime» ∧ + wait_time_locals1 (:α) nt.locals st.waitTime (FST (t.ffi.ffi_state 0)) (FST (nt.ffi.ffi_state 0)) ∧ + output_io_events_rel os t nt ∧ + task_ret_defined nt.locals (nClks prog) ∧ + evaluations prog lbls sts (FST (t.ffi.ffi_state 0)) st nt) +Termination + WF_REL_TAC ‘measure $ λx. case x of + | INL (_,lbls,_) => 2 * LENGTH lbls + | INR (INL (prog,d,ist,s,st,t,lbls,sts)) => 2 * LENGTH lbls + 1 + | INR (INR (INL (prog,i,s,st,t,lbls,sts))) => 2 * LENGTH lbls + 1 + | INR (INR (INR (prog,os,st,t,lbls,sts))) => 2 * LENGTH lbls + 1’ + \\ fs [] +End + + +Definition action_rel_def: + (action_rel (Input i) s (t:('a,time_input) panSem$state) ffi ⇔ + wakeup_shape t.locals s.waitTime (FST (t.ffi.ffi_state 0)) ∧ + input_stime_rel s.waitTime (FST (t.ffi.ffi_state 0)) (FST (t.ffi.ffi_state 0)) ∧ + input_rel t.locals i (next_ffi t.ffi.ffi_state) ∧ + mem_read_ffi_results (:α) t.ffi.ffi_state 1 ∧ + FST (t.ffi.ffi_state 1) < dimword (:α) − 2 ∧ + ffi = next_ffi t.ffi.ffi_state) ∧ + (action_rel (Output os) s t ffi ⇔ + output_rel t.locals t.ffi.ffi_state ∧ + FST (t.ffi.ffi_state 0) < dimword (:α) − 2 ∧ + ffi = t.ffi.ffi_state) +End + +Definition panic_rel_def: + (panic_rel PanicTimeout s (t:('a,time_input) panSem$state) ffi ⇔ + output_rel t.locals t.ffi.ffi_state ∧ + FST (t.ffi.ffi_state 0) < dimword (:α) - 2 ∧ + ffi = t.ffi.ffi_state) ∧ + (panic_rel (PanicInput i) s t ffi ⇔ + wakeup_shape t.locals s.waitTime (FST (t.ffi.ffi_state 0)) ∧ + input_stime_rel s.waitTime (FST (t.ffi.ffi_state 0)) (FST (t.ffi.ffi_state 0)) ∧ + input_rel t.locals i (next_ffi t.ffi.ffi_state) ∧ + mem_read_ffi_results (:α) t.ffi.ffi_state 1 ∧ + FST (t.ffi.ffi_state 1) < dimword (:α) − 2 ∧ + ffi = next_ffi t.ffi.ffi_state) +End + + +Definition ffi_rel_def: + (ffi_rel (LDelay d) s (t:('a,time_input) panSem$state) ist ffi = + ∃cycles. + delay_rep d t.ffi.ffi_state cycles ∧ + wakeup_shape t.locals s.waitTime ist ∧ + wakeup_rel t.locals s.waitTime ist t.ffi.ffi_state cycles ∧ + mem_read_ffi_results (:α) t.ffi.ffi_state cycles ∧ + ffi = nexts_ffi cycles t.ffi.ffi_state ∧ + t.ffi.io_events ≠ [] ∧ + EL 0 (io_event_dest (:α) t.be (LAST t.ffi.io_events)) = + FST (t.ffi.ffi_state 0)) ∧ + (ffi_rel (LAction act) s t ist ffi ⇔ + ist = FST (t.ffi.ffi_state 0) ∧ + action_rel act s t ffi) ∧ + (ffi_rel (LPanic p) s t ist ffi ⇔ + ist = FST (t.ffi.ffi_state 0) ∧ + panic_rel p s t ffi) +End + +Definition ffi_rels_def: + (ffi_rels prog [] s (t:('a,time_input) panSem$state) ist ⇔ + wait_time_locals1 (:α) t.locals s.waitTime ist (FST (t.ffi.ffi_state 0)) ∧ + ist < dimword (:α) − 1) ∧ + (ffi_rels prog (label::labels) s t ist ⇔ + ∃ffi. + ffi_rel label s t ist ffi ∧ + ∀s' (t':('a,time_input) panSem$state) m n. + step prog label m n s s' ∧ + t'.ffi.ffi_state = ffi ⇒ + ffi_rels prog labels s' t' ist) +End + +(* TODO: change - to + : + SUM (n::ns) + 1 = LENGTH ios *) +Definition decode_ios_def: + (decode_ios (:α) be [] [] ios ⇔ LENGTH ios = 1) ∧ + (decode_ios (:α) be (lbl::lbls) (n::ns) ios ⇔ + SUM (n::ns) = LENGTH ios - 1 ∧ + (case lbl of + | LDelay d => + (if n = 0 + then d = 0 ∧ decode_ios (:α) be lbls ns ios + else + let + m' = EL 0 (io_event_dest (:α) be (HD ios)); + nios = TAKE n (TL ios); + obs_ios = decode_io_events (:'a) be nios; + m = THE (to_delay (EL (LENGTH obs_ios - 1) obs_ios)) + in + d = m - m' ∧ + decode_ios (:α) be lbls ns (DROP n ios)) + | LAction act => + (n = 1 ∧ + decode_ios (:α) be lbls ns (DROP 1 ios) ∧ + (case act of + | Input i => + let + obs_io = decode_io_event (:α) be (EL 1 ios) + in + Input i = THE (to_input obs_io) + | Output os => + decode_io_event (:α) be (EL 1 ios) = ObsOutput os)) + | LPanic p => + case p of + | PanicInput i => + n = 1 ∧ + let + obs_io = decode_io_event (:α) be (EL 1 ios) + in + Input i = THE (to_input obs_io) + | _ => F)) ∧ + (decode_ios (:α) be _ _ ios ⇔ F) +End + + +Definition gen_max_times_def: + (gen_max_times [] n ns = ns) ∧ + (gen_max_times (lbl::lbls) n ns = + n :: + let m = + case lbl of + | LDelay d => d + n + | LAction _ => n + in + gen_max_times lbls m ns) +End + +Definition init_clocks_def: + init_clocks fm clks ⇔ + EVERY + (λck. FLOOKUP fm ck = SOME (0:num)) clks +End + +Definition init_ffi_def: + init_ffi (f:num -> num # num) ⇔ + f 0 = f 1 ∧ + SND (f 0) = 0 +End + + +Definition locals_before_start_ctrl_def: + locals_before_start_ctrl prog wt ffi = + FEMPTY |+ («loc» ,ValLabel (toString (FST (ohd prog)))) |+ + («waitSet» , + ValWord (case wt of NONE => 1w | SOME v => 0w)) |+ + («event» ,ValWord 0w) |+ («isInput» ,ValWord 1w) |+ + («wakeUpAt» ,ValWord 0w) |+ («sysTime» ,ValWord 0w) |+ + («ptr1» ,ValWord 0w) |+ («len1» ,ValWord 0w) |+ + («ptr2» ,ValWord ffiBufferAddr) |+ + («len2» ,ValWord ffiBufferSize) |+ + («taskRet» , + Struct + [Struct (emptyVals (nClks prog)); ValWord 0w; ValWord 0w; + ValLabel (toString (FST (ohd prog)))]) |+ + («clks» ,Struct (emptyVals (nClks prog))) |+ + («sysTime» ,ValWord (n2w (FST ffi))) |+ + («event» ,ValWord (n2w (SND ffi))) |+ + («isInput» ,ValWord 1w) |+ + («clks» , + Struct + (REPLICATE (nClks prog) + (ValWord (n2w (FST ffi))))) |+ + («wakeUpAt» , + ValWord + (n2w + (case wt of + NONE => FST ffi + | SOME n => n + FST ffi))) +End + +Definition ffi_rels_after_init_def: + ffi_rels_after_init prog labels st (t:('a,time_input) panSem$state) ⇔ + ∀bytes. + read_bytearray ffiBufferAddr (w2n (ffiBufferSize:'a word)) + (mem_load_byte t.memory t.memaddrs t.be) = SOME bytes ⇒ + ffi_rels prog labels st + (t with + <|locals := + locals_before_start_ctrl prog st.waitTime (t.ffi.ffi_state 0); + memory := + mem_call_ffi (:α) t.memory t.memaddrs t.be t.ffi.ffi_state; + ffi := ffi_call_ffi (:α) t.be t.ffi bytes|>) + (FST (t.ffi.ffi_state 0)) +End + + +Definition labels_of_def: + labels_of k prog m n or st = + FST (THE (timeFunSem$eval_steps k prog m n or st)) +End + + +Definition wf_prog_init_states_def: + wf_prog_init_states prog or k st (t:('a,time_input) panSem$state) ⇔ + timeFunSem$eval_steps + k prog (dimword (:α) - 1) (FST (t.ffi.ffi_state 0)) or st ≠ NONE ∧ + prog ≠ [] ∧ LENGTH (clksOf prog) ≤ 29 ∧ + st.location = FST (ohd prog) ∧ + init_clocks st.clocks (clksOf prog) ∧ + code_installed t.code prog ∧ + FLOOKUP t.code «start» = SOME ([],ta_controller (prog,st.waitTime)) ∧ + FLOOKUP t.code «start_controller» = + SOME ([],start_controller (prog,st.waitTime)) ∧ + FLOOKUP t.eshapes «panic» = SOME One ∧ + well_formed_code prog t.code ∧ + mem_config t.memory t.memaddrs t.be ∧ + mem_read_ffi_results (:α) t.ffi.ffi_state 1 ∧ + t.ffi = + build_ffi (:'a) t.be (MAP explode (out_signals prog)) + t.ffi.ffi_state t.ffi.io_events ∧ + init_ffi t.ffi.ffi_state ∧ + input_time_rel t.ffi.ffi_state ∧ + time_seq t.ffi.ffi_state (dimword (:α)) ∧ + FST (t.ffi.ffi_state 0) < dimword (:α) − 1 ∧ + t.ffi.io_events = [] ∧ + good_dimindex (:'a) ∧ + ~MEM "get_time_input" (MAP explode (out_signals prog)) +End + +Definition systime_at_def: + systime_at (t:('a,time_input) panSem$state) = + FST (t.ffi.ffi_state 0) +End + +Theorem length_get_bytes: + ∀w be. + LENGTH (get_bytes be (w:'a word)) = dimindex (:α) DIV 8 +Proof + rw [] >> + fs [get_bytes_def] +QED + +Theorem word_of_bytes_get_byte_eq_word_32: + ∀x be. + dimindex (:α) = 32 ⇒ + word_of_bytes + be 0w + [get_byte 0w x be; get_byte 1w x be; get_byte 2w x be; + get_byte 3w x be] = (x:'a word) +Proof + rw [] >> + gs [word_of_bytes_def] >> + cases_on ‘be’ >> gs [] >> ( + gvs [fcpTheory.CART_EQ] >> + rw [] >> + gs [set_byte_def, get_byte_def] >> + gs [byte_index_def, word_slice_alt_def] >> + gs [fcpTheory.FCP_BETA, word_or_def, dimword_def] >> + gs [word_lsl_def, word_lsr_def, fcpTheory.FCP_BETA, w2w] >> + srw_tac [CONJ_ss] + [word_lsl_def, word_lsr_def, fcpTheory.FCP_BETA, + w2w] >> + gs [word_0] >> + rw [] >> gs [] >> + cases_on ‘i < 8’ >> gs [] >> + cases_on ‘i < 16’ >> gs [] >> + cases_on ‘i < 24’ >> gs []) +QED + +Theorem word_of_bytes_get_byte_eq_word_64: + ∀x be. + dimindex (:α) = 64 ⇒ + word_of_bytes + be 0w + [get_byte 0w x be; get_byte 1w x be; get_byte 2w x be; + get_byte 3w x be; get_byte 4w x be; get_byte 5w x be; + get_byte 6w x be; get_byte 7w x be] = (x:'a word) +Proof + rw [] >> + gs [word_of_bytes_def] >> + cases_on ‘be’ >> gs [] >> ( + gvs [fcpTheory.CART_EQ] >> + rw [] >> + gs [set_byte_def, get_byte_def] >> + gs [byte_index_def] >> + gs [word_slice_alt_def, fcpTheory.FCP_BETA, word_or_def,dimword_def, + word_lsl_def, word_lsr_def, fcpTheory.FCP_BETA, w2w] >> + srw_tac [CONJ_ss] + [word_lsl_def, word_lsr_def, fcpTheory.FCP_BETA, + w2w] >> + gs [word_0] >> + rw [] >> gs [] >> + cases_on ‘i < 8’ >> gs [] >> + cases_on ‘i < 16’ >> gs [] >> + cases_on ‘i < 24’ >> gs [] >> + cases_on ‘i < 32’ >> gs [] >> + cases_on ‘i < 40’ >> gs [] >> + cases_on ‘i < 48’ >> gs [] >> + cases_on ‘i < 56’ >> gs []) +QED + +Theorem words_of_bytes_get_byte: + ∀xs x be. + good_dimindex (:α) ∧ + xs = get_bytes be (x:'a word) ⇒ + words_of_bytes be xs = [x] +Proof + Induct >> + rw [] + >- gs [words_of_bytes_def, get_bytes_def, good_dimindex_def] >> + pop_assum (assume_tac o GSYM) >> + gs [] >> + gs [words_of_bytes_def] >> + gs [good_dimindex_def, bytes_in_word_def, dimword_def] >> + gs [get_bytes_def] >> + pop_assum (mp_tac o GSYM) >> + pop_assum (mp_tac o GSYM) >> + strip_tac >> strip_tac >> + gs [words_of_bytes_def] >> + gvs [] + >- (match_mp_tac word_of_bytes_get_byte_eq_word_32 >> gs []) >> + match_mp_tac word_of_bytes_get_byte_eq_word_64 >> gs [] +QED + + +Theorem words_of_bytes_get_bytes: + ∀x y be. + good_dimindex (:α) ⇒ + words_of_bytes be + (get_bytes be (x:'a word) ++ + get_bytes be (y:'a word)) = [x;y] +Proof + rw [] >> + ‘0 < w2n (bytes_in_word:'a word)’ by + gs [good_dimindex_def, bytes_in_word_def, dimword_def] >> + drule words_of_bytes_append >> + disch_then (qspecl_then + [‘be’, ‘get_bytes be x’, ‘get_bytes be y’] mp_tac) >> + impl_tac + >- ( + gs [length_get_bytes] >> + gs [good_dimindex_def, bytes_in_word_def, dimword_def]) >> + strip_tac >> + gs [] >> + ‘words_of_bytes be (get_bytes be x) = [x]’ by ( + match_mp_tac words_of_bytes_get_byte >> + gs []) >> + ‘words_of_bytes be (get_bytes be y) = [y]’ by ( + match_mp_tac words_of_bytes_get_byte >> + gs []) >> + gs [] +QED + + +Theorem eval_empty_const_eq_empty_vals: + ∀s n. + OPT_MMAP (λe. eval s e) (emptyConsts n) = + SOME (emptyVals n) +Proof + rw [] >> + fs [opt_mmap_eq_some] >> + fs [MAP_EQ_EVERY2] >> + fs [emptyConsts_def, emptyVals_def] >> + fs [LIST_REL_EL_EQN] >> + rw [] >> + ‘EL n' (REPLICATE n ((Const 0w):'a panLang$exp)) = Const 0w’ by ( + match_mp_tac EL_REPLICATE >> + fs []) >> + ‘EL n' (REPLICATE n (ValWord 0w)) = ValWord 0w’ by ( + match_mp_tac EL_REPLICATE >> + fs []) >> + fs [eval_def] +QED + +Theorem opt_mmap_resetTermClocks_eq_resetClksVals: + ∀t clkvals s clks tclks. + EVERY (λck. ck IN FDOM s.clocks) clks ∧ + FLOOKUP t.locals «clks» = SOME (Struct clkvals) ∧ + equiv_val s.clocks clks clkvals ⇒ + OPT_MMAP (λa. eval t a) + (resetTermClocks «clks» clks tclks) = + SOME (resetClksVals s.clocks clks tclks) +Proof + rpt gen_tac >> + strip_tac >> + fs [opt_mmap_eq_some] >> + fs [MAP_EQ_EVERY2] >> + conj_tac + >- fs [resetTermClocks_def, resetClksVals_def] >> + fs [LIST_REL_EL_EQN] >> + conj_tac + >- fs [resetTermClocks_def, resetClksVals_def] >> + rw [] >> + fs [resetTermClocks_def] >> + TOP_CASE_TAC + >- ( + ‘EL n (resetClksVals s.clocks clks tclks) = ValWord 0w’ by ( + fs [resetClksVals_def] >> + qmatch_goalsub_abbrev_tac ‘MAP ff _’ >> + ‘EL n (MAP ff clks) = ff (EL n clks)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [Abbr ‘ff’] >> + drule reset_clks_mem_flookup_zero >> + disch_then (qspec_then ‘s.clocks’ mp_tac) >> + fs []) >> + fs [eval_def]) >> + fs [equiv_val_def] >> rveq >> fs [] >> + fs [EVERY_MEM] >> + last_x_assum (qspec_then ‘EL n clks’ mp_tac) >> + impl_tac + >- (match_mp_tac EL_MEM >> fs []) >> + strip_tac >> + fs [FDOM_FLOOKUP] >> + ‘EL n (resetClksVals s.clocks clks tclks) = ValWord (n2w v)’ by ( + fs [resetClksVals_def] >> + qmatch_goalsub_abbrev_tac ‘MAP ff _’ >> + ‘EL n (MAP ff clks) = ff (EL n clks)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [Abbr ‘ff’] >> + drule reset_clks_not_mem_flookup_same >> + fs []) >> + fs [] >> + fs [eval_def] >> + qmatch_goalsub_abbrev_tac ‘MAP ff _’ >> + ‘EL n (MAP ff clks) = ff (EL n clks)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [Abbr ‘ff’] +QED + + +Theorem maxClksSize_reset_clks_eq: + ∀s clks (clkvals:α v list) tclks. + EVERY (λck. ck IN FDOM s.clocks) clks ∧ + equiv_val s.clocks clks clkvals ∧ + maxClksSize clkvals ⇒ + maxClksSize ((resetClksVals s.clocks clks tclks):α v list) +Proof + rw [] >> + fs [resetClksVals_def] >> + fs [equiv_val_def] >> rveq >> fs [] >> + fs [maxClksSize_def] >> + fs [MAP_MAP_o] >> + fs [SUM_MAP_FOLDL] >> + qmatch_asmsub_abbrev_tac ‘FOLDL ff _ _’ >> + qmatch_goalsub_abbrev_tac ‘FOLDL gg _ _’ >> + ‘FOLDL ff 0 clks = FOLDL gg 0 clks ’ by ( + match_mp_tac FOLDL_CONG >> + fs [Abbr ‘ff’, Abbr ‘gg’] >> rw [shape_of_def]) >> + fs [] +QED + + +Theorem calculate_wait_times_eq: + ∀t vname clkvals s clks wt. + FLOOKUP t.locals vname = SOME (Struct clkvals) ∧ + EVERY (λck. ck IN FDOM s.clocks) clks ∧ + equiv_val s.clocks clks clkvals ∧ + EVERY (λck. MEM ck clks) (MAP SND wt) ∧ + EVERY (λ(t,c). ∃v. FLOOKUP s.clocks c = SOME v ∧ v ≤ t) wt ⇒ + OPT_MMAP (λe. eval t e) + (waitTimes (MAP FST wt) + (MAP (λn. Field n (Var vname)) (indicesOf clks (MAP SND wt)))) = + SOME (MAP (ValWord ∘ n2w ∘ THE ∘ evalDiff s) wt) +Proof + rw [] >> + fs [opt_mmap_eq_some] >> + fs [MAP_EQ_EVERY2] >> + rw [waitTimes_def, indicesOf_def, LIST_REL_EL_EQN] >> + ‘SND (EL n wt) ∈ FDOM s.clocks’ by ( + fs [EVERY_MEM] >> + first_x_assum (qspec_then ‘SND (EL n wt)’ mp_tac) >> + impl_tac + >- ( + drule EL_MEM >> + fs [MEM_MAP] >> + metis_tac []) >> + strip_tac >> + last_x_assum drule >> + fs []) >> + qmatch_goalsub_abbrev_tac ‘MAP2 ff xs ys’ >> + ‘EL n (MAP2 ff xs ys) = + ff (EL n xs) (EL n ys)’ by ( + match_mp_tac EL_MAP2 >> + fs [Abbr ‘xs’, Abbr ‘ys’]) >> + fs [] >> + pop_assum kall_tac >> + fs [Abbr ‘xs’] >> + ‘EL n (MAP FST wt) = FST (EL n wt)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [] >> + pop_assum kall_tac >> + fs [Abbr ‘ys’] >> + fs [MAP_MAP_o] >> + qmatch_goalsub_abbrev_tac ‘EL n (MAP gg _)’ >> + ‘EL n (MAP gg wt) = gg (EL n wt)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [] >> + pop_assum kall_tac >> + qmatch_goalsub_abbrev_tac ‘MAP hh _’ >> + ‘EL n (MAP hh wt) = hh (EL n wt)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [] >> + pop_assum kall_tac >> + fs [Abbr ‘gg’, Abbr ‘ff’, Abbr ‘hh’] >> + cases_on ‘EL n wt’ >> fs [] >> + fs [evalDiff_def, evalExpr_def, EVERY_EL] >> + fs [FDOM_FLOOKUP] >> + fs [minusT_def] >> + fs [eval_def, OPT_MMAP_def] >> + fs [eval_def] >> + ‘findi r clks < LENGTH clkvals’ by ( + fs [equiv_val_def] >> + match_mp_tac MEM_findi >> + res_tac >> fs [] >> + rfs [] >> + ‘EL n (MAP SND wt) = SND (EL n wt)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + rfs [] >> rveq >> fs []) >> + fs [] >> + rfs [equiv_val_def] >> + qmatch_goalsub_abbrev_tac ‘EL m (MAP ff _)’ >> + ‘EL m (MAP ff clks) = ff (EL m clks)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [Abbr ‘ff’, Abbr ‘m’] >> + pop_assum kall_tac >> + last_x_assum drule >> + strip_tac >> fs [] >> + ‘EL (findi r clks) clks = r’ by ( + match_mp_tac EL_findi >> + res_tac >> fs [] >> + rfs [] >> + ‘EL n (MAP SND wt) = SND (EL n wt)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + rfs [] >> rveq >> fs []) >> + fs [wordLangTheory.word_op_def] >> + first_x_assum drule >> + fs [] >> + strip_tac >> + ‘n2w (q − v):'a word = n2w q − n2w v’ suffices_by fs [] >> + match_mp_tac n2w_sub >> rveq >> fs [] >> rveq >> rfs [] >> + first_x_assum drule >> + fs [] +QED + + +Theorem eval_term_clkvals_equiv_reset_clkvals: + ∀s io io' cnds tclks dest wt s' clks. + evalTerm s io + (Tm io' cnds tclks dest wt) s' ⇒ + equiv_val s'.clocks clks (resetClksVals s.clocks clks tclks) +Proof + rw [] >> + fs [evalTerm_cases] >> + rveq >> fs [] >> + fs [equiv_val_def] >> + fs [resetClksVals_def] +QED + + +Theorem evaluate_minop_eq: + ∀es s vname n ns res t. + FLOOKUP s.locals vname = SOME (ValWord (n2w n)) ∧ + (∀n. n < LENGTH es ⇒ ~MEM vname (var_exp (EL n es))) ∧ + MAP (eval s) es = MAP (SOME ∘ ValWord ∘ (n2w:num -> α word)) ns ∧ + n < dimword (:α) ∧ + EVERY (λn. n < dimword (:α)) ns ∧ + evaluate (minOp vname es,s) = (res,t) ⇒ + res = NONE ∧ + t = s with locals:= s.locals |+ + (vname, + ValWord (minOption (n2w n) (list_min_option ns))) +Proof + Induct >> + rpt gen_tac >> + strip_tac >> fs [] + >- ( + fs [minOp_def, evaluate_def] >> rveq >> + fs [minOption_def, list_min_option_def] >> + cases_on ‘s’ >> + fs [state_fn_updates] >> + match_mp_tac EQ_SYM >> + match_mp_tac FUPDATE_ELIM >> + fs [FLOOKUP_DEF]) >> + cases_on ‘ns’ >> fs [] >> + fs [minOp_def] >> + fs [evaluate_def] >> + pairarg_tac >> fs [] >> + fs [eval_def] >> + rfs [] >> + fs [asmTheory.word_cmp_def] >> + cases_on ‘(n2w h'):'a word <₊ n2w n’ >> + fs [] + >- ( + fs [evaluate_def] >> + rfs [] >> + fs [is_valid_value_def] >> + rfs [] >> + fs [panSemTheory.shape_of_def] >> + rveq >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (_, stNew)’ >> + last_x_assum + (qspecl_then + [‘stNew’, ‘vname’, ‘h'’, ‘t'’, ‘res’, ‘t’] mp_tac) >> + fs [Abbr ‘stNew’] >> + fs [FLOOKUP_UPDATE] >> + impl_tac + >- ( + reverse conj_tac + >- ( + fs [MAP_EQ_EVERY2] >> + fs [LIST_REL_EL_EQN] >> + rw [] >> + match_mp_tac update_locals_not_vars_eval_eq >> + last_x_assum (qspec_then ‘SUC n'’ mp_tac) >> + fs []) >> + rw [] >> fs [] >> + last_x_assum (qspec_then ‘SUC n'’ mp_tac) >> + fs []) >> + strip_tac >> + fs [list_min_option_def] >> + cases_on ‘list_min_option t'’ >> fs [] + >- ( + fs [minOption_def] >> + ‘~(n2w n <₊ n2w h')’ by ( + fs [WORD_NOT_LOWER] >> + gs [WORD_LOWER_OR_EQ]) >> + fs []) >> + drule list_min_option_some_mem >> + strip_tac >> + fs [EVERY_MEM] >> + first_x_assum (qspec_then ‘x’ mp_tac) >> + fs [] >> + strip_tac >> + cases_on ‘h' < x’ >> fs [] + >- ( + fs [minOption_def] >> + ‘~(n2w n <₊ n2w h')’ by ( + fs [WORD_NOT_LOWER] >> + gs [WORD_LOWER_OR_EQ]) >> + fs [] >> + qsuff_tac ‘(n2w h'):'a word <₊ n2w x’ >- fs [] >> + fs [word_lo_n2w]) >> + fs [minOption_def] >> + ‘~((n2w h'):'a word <₊ n2w x)’ by ( + fs [WORD_NOT_LOWER, NOT_LESS, word_ls_n2w]) >> + fs [] >> + ‘~((n2w n):'a word <₊ n2w x)’ by ( + fs [WORD_NOT_LOWER] >> + fs [NOT_LESS] >> + ‘h' < n’ by gs [word_lo_n2w] >> + ‘x < n’ by gs [] >> + gs [word_ls_n2w]) >> + fs []) >> + fs [evaluate_def] >> + rfs [] >> rveq >> + last_x_assum + (qspecl_then + [‘s’, ‘vname’, ‘n’, ‘t'’, ‘res’, ‘t’] mp_tac) >> + fs [] >> + impl_tac + >- ( + rw [] >> + last_x_assum (qspec_then ‘SUC n'’ mp_tac) >> + fs []) >> + strip_tac >> + fs [] >> + fs [list_min_option_def] >> + cases_on ‘list_min_option t'’ >> fs [] + >- ( + fs [minOption_def] >> + fs [WORD_NOT_LOWER] >> + gs [WORD_LOWER_OR_EQ]) >> + fs [minOption_def] >> + every_case_tac >> fs [WORD_NOT_LOWER] + >- ( + qsuff_tac ‘h' = n’ >- fs [] >> + qsuff_tac ‘h' ≤ n ∧ n ≤ h'’ >- fs [] >> + gs [word_ls_n2w]) >> ( + drule list_min_option_some_mem >> + strip_tac >> + fs [EVERY_MEM] >> + first_x_assum (qspec_then ‘x’ mp_tac) >> + impl_tac >- fs [] >> + strip_tac >> + gs [word_ls_n2w]) +QED + + +Theorem evaluate_min_exp_eq: + ∀es s vname v ns res t. + FLOOKUP s.locals vname = SOME (ValWord v) ∧ + (∀n. n < LENGTH es ⇒ ~MEM vname (var_exp (EL n es))) ∧ + MAP (eval s) es = MAP (SOME ∘ ValWord ∘ (n2w:num -> α word)) ns ∧ + EVERY (λn. n < dimword (:α)) ns ∧ + evaluate (minExp vname es,s) = (res,t) ⇒ + res = NONE ∧ + (es = [] ⇒ t = s) ∧ + (es ≠ [] ⇒ + t = s with locals := + s.locals |+ + (vname, ValWord ((n2w:num -> α word) (THE (list_min_option ns))))) +Proof + rpt gen_tac >> + strip_tac >> + cases_on ‘es’ >> fs [] + >- ( + fs [minExp_def] >> + fs [evaluate_def]) >> + cases_on ‘ns’ >> fs [] >> + fs [minExp_def] >> + fs [evaluate_def] >> + pairarg_tac >> fs [] >> + rfs [] >> + fs [is_valid_value_def] >> + rfs [] >> + fs [panSemTheory.shape_of_def] >> rveq >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (_,stInit)’ >> + ‘FLOOKUP stInit.locals vname = SOME (ValWord (n2w h'))’ by ( + fs [Abbr ‘stInit’] >> + fs [FLOOKUP_UPDATE]) >> + last_x_assum mp_tac >> + drule evaluate_minop_eq >> + disch_then (qspecl_then [‘t'’, ‘t''’, ‘res’, ‘t’] mp_tac) >> + fs [] >> + impl_tac + >- ( + conj_tac + >- ( + rw [] >> + last_x_assum (qspec_then ‘SUC n’ mp_tac) >> + fs []) >> + fs [Abbr ‘stInit’] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + match_mp_tac update_locals_not_vars_eval_eq >> + last_x_assum (qspec_then ‘SUC n’ mp_tac) >> + fs []) >> + rpt strip_tac >> fs [] >> + fs [list_min_option_def] >> + cases_on ‘list_min_option t''’ >> fs [] >> + fs [Abbr ‘stInit’, minOption_def] >> + drule list_min_option_some_mem >> + strip_tac >> + fs [EVERY_MEM] >> + first_x_assum (qspec_then ‘x’ mp_tac) >> + fs [] >> + strip_tac >> + every_case_tac + >- ( + fs [NOT_LESS] >> + qsuff_tac ‘h' < x’ >- fs [] >> + gs [word_lo_n2w]) >> + fs [WORD_NOT_LOWER] >> + gs [word_ls_n2w] +QED + + +Theorem every_conj_spec: + ∀fm (m:num) xs w. + EVERY + (λck. ∃n. FLOOKUP fm ck = SOME n ∧ + n < m) xs ⇒ + EVERY (λck. ck IN FDOM fm) xs +Proof + rw [] >> + fs [EVERY_MEM] >> + rw [] >> + last_x_assum drule >> + strip_tac >> fs [FDOM_FLOOKUP] +QED + + +Theorem shape_of_resetClksVals_eq: + ∀fm (clks:mlstring list) (tclks:mlstring list) (clkvals:'a v list). + EVERY (λv. ∃w. v = ValWord w) clkvals /\ + LENGTH clks = LENGTH clkvals ⇒ + MAP ((λa. size_of_shape a) ∘ (λa. shape_of a)) + ((resetClksVals fm clks tclks):'a v list) = + MAP ((λa. size_of_shape a) ∘ (λa. shape_of a)) clkvals +Proof + rw [] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + fs [resetClksVals_def] >> + rw [] >> fs [] >> + qmatch_goalsub_abbrev_tac ‘MAP f _’ >> + ‘EL n (MAP f clks) = f (EL n clks)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [Abbr ‘f’] >> + pop_assum kall_tac >> + fs [EVERY_MEM] >> + drule EL_MEM >> + strip_tac >> + last_x_assum drule >> + strip_tac >> fs [] >> + fs [panSemTheory.shape_of_def] +QED + +Theorem comp_input_term_correct: + ∀s n cnds tclks dest wt s' t (clkvals:'a v list) clks (m:num). + evalTerm s (SOME n) + (Tm (Input n) cnds tclks dest wt) s' ∧ + m = dimword (:α) - 1 ∧ + FLOOKUP t.locals «clks» = SOME (Struct clkvals) ∧ + maxClksSize clkvals ∧ + clock_bound s.clocks clks m ∧ + time_range wt m ∧ + equiv_val s.clocks clks clkvals ∧ + valid_clks clks tclks wt ∧ + num_to_str dest IN FDOM t.code ⇒ + evaluate (compTerm clks (Tm (Input n) cnds tclks dest wt), t) = + (SOME (Return (retVal s clks tclks wt dest)), + t with locals := + restore_from t FEMPTY [«waitTimes»; «newClks»; «wakeUpAt»; «waitSet»]) +Proof + rpt gen_tac >> + strip_tac >> + fs [clock_bound_def, time_range_def] >> + drule every_conj_spec >> + strip_tac >> + drule eval_term_clkvals_equiv_reset_clkvals >> + disch_then (qspec_then ‘clks’ assume_tac) >> + fs [evalTerm_cases] >> + rveq >> fs [] >> + fs [compTerm_def] >> + cases_on ‘wt’ + >- ( (* wait set is disabled *) + fs [panLangTheory.decs_def] >> + fs [evaluate_def] >> + fs [eval_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> rveq >> + rfs [] >> fs [] >> + qmatch_asmsub_abbrev_tac ‘OPT_MMAP (λa. eval stInit a) _’ >> + ‘OPT_MMAP (λa. eval stInit a) + (resetTermClocks «clks» clks tclks) = + SOME (resetClksVals s.clocks clks tclks)’ by ( + match_mp_tac opt_mmap_resetTermClocks_eq_resetClksVals >> + qexists_tac ‘clkvals’ >> rfs [] >> + fs [Abbr ‘stInit’] >> + rfs [FLOOKUP_UPDATE]) >> + fs [] >> + pop_assum kall_tac >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [emptyConsts_def] >> + fs [OPT_MMAP_def] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [panLangTheory.nested_seq_def] >> + fs [evaluate_def] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [eval_def] >> + fs [indicesOf_def, waitTimes_def, minExp_def] >> + pop_assum mp_tac >> + rewrite_tac [OPT_MMAP_def] >> + strip_tac >> + fs [is_valid_value_def] >> + fs [FLOOKUP_UPDATE, FDOM_FLOOKUP] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [evaluate_def] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + qmatch_asmsub_abbrev_tac ‘OPT_MMAP (λa. eval stReset a) _’ >> + fs [OPT_MMAP_def] >> + fs [eval_def] >> + fs [Abbr ‘stReset’, FLOOKUP_UPDATE, FDOM_FLOOKUP] >> + rfs [] >> + fs [panSemTheory.shape_of_def, panLangTheory.size_of_shape_def] >> + fs [GSYM FDOM_FLOOKUP] >> + drule maxClksSize_reset_clks_eq >> + disch_then (qspecl_then [‘clkvals’, ‘tclks’] mp_tac) >> + fs [] >> strip_tac >> + fs [maxClksSize_def, MAP_MAP_o, ETA_AX] >> + pop_assum kall_tac >> + rveq >> fs [] >> rfs [] >> rveq >> fs [] >> + fs [empty_locals_def, retVal_def] >> + fs [restore_from_def]) >> + (* some maintenance to replace h::t' to wt *) + qmatch_goalsub_abbrev_tac ‘emptyConsts (LENGTH wt)’ >> + ‘(case wt of [] => Const 1w | v2::v3 => Const 0w) = + (Const 0w): 'a panLang$exp’ by fs [Abbr ‘wt’] >> + fs [] >> + pop_assum kall_tac >> + fs [panLangTheory.decs_def] >> + fs [evaluate_def] >> + fs [eval_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> rveq >> + rfs [] >> fs [] >> + qmatch_asmsub_abbrev_tac ‘OPT_MMAP (λa. eval stInit a) _’ >> + ‘OPT_MMAP (λa. eval stInit a) + (resetTermClocks «clks» clks tclks) = + SOME (resetClksVals s.clocks clks tclks)’ by ( + match_mp_tac opt_mmap_resetTermClocks_eq_resetClksVals >> + qexists_tac ‘clkvals’ >> rfs [] >> + fs [Abbr ‘stInit’] >> + rfs [FLOOKUP_UPDATE]) >> + fs [] >> + pop_assum kall_tac >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [eval_empty_const_eq_empty_vals] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [panLangTheory.nested_seq_def] >> + fs [evaluate_def] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + qmatch_asmsub_abbrev_tac ‘eval stReset _’ >> + fs [eval_def] >> + (* waitimes eq eval diffs *) + ‘OPT_MMAP (λa. eval stReset a) + (waitTimes (MAP FST wt) + (MAP (λn. Field n (Var «newClks» )) + (indicesOf clks (MAP SND wt)))) = + SOME (MAP ((λw. ValWord w) ∘ n2w ∘ THE ∘ evalDiff + (s with clocks := resetClocks s.clocks tclks)) wt)’ by ( + match_mp_tac calculate_wait_times_eq >> + qexists_tac ‘resetClksVals s.clocks clks tclks’ >> + rfs [Abbr ‘stReset’] >> + rewrite_tac [FLOOKUP_UPDATE] >> + fs [] >> + fs [equiv_val_def] >> + last_x_assum assume_tac >> + drule fdom_reset_clks_eq_clks >> + strip_tac >> + rfs [valid_clks_def] >> + fs [EVERY_MEM] >> + rw [] >> + last_x_assum (qspec_then ‘e’ mp_tac) >> + fs [] >> + cases_on ‘e’ >> fs [] >> + strip_tac >> + fs [] >> + match_mp_tac flookup_reset_clks_leq >> + fs []) >> + fs [] >> + pop_assum kall_tac >> + qmatch_asmsub_abbrev_tac ‘is_valid_value tt _ wtval’ >> + ‘is_valid_value tt «waitTimes» wtval’ by ( + fs [Abbr ‘tt’, Abbr ‘wtval’] >> + fs [is_valid_value_def] >> + fs [FLOOKUP_UPDATE] >> + fs [panSemTheory.shape_of_def] >> + fs [emptyVals_def, emptyConsts_def] >> + fs [MAP_MAP_o, GSYM MAP_K_REPLICATE, MAP_EQ_f] >> + rw [] >> + fs [shape_of_def]) >> + fs [] >> + pairarg_tac >> fs [] >> rveq >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (minExp _ es, stWait)’ >> + ‘FLOOKUP stWait.locals «wakeUpAt» = SOME (ValWord 0w)’ by + fs [Abbr ‘stWait’, FLOOKUP_UPDATE] >> + drule evaluate_min_exp_eq >> + disch_then ( + qspecl_then [ + ‘es’, + ‘MAP (THE o evalDiff (s with clocks := resetClocks s.clocks tclks)) wt’, + ‘res''’, ‘s1'’] mp_tac) >> + impl_tac + >- ( + rfs [] >> + conj_tac + >- ( + rw [] >> + fs [Abbr ‘es’] >> + fs [panLangTheory.var_exp_def]) >> + conj_tac + >- ( + fs [Abbr ‘stWait’, Abbr ‘es’] >> + fs [Abbr ‘wtval’] >> + fs [MAP_MAP_o] >> + fs [MAPi_enumerate_MAP] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + fs [LENGTH_enumerate] >> + rw [] >> + pairarg_tac >> fs [] >> + ‘EL n (enumerate 0 wt) = (n+0,EL n wt)’ by ( + match_mp_tac EL_enumerate >> + fs []) >> + fs [] >> + pop_assum kall_tac >> + fs [eval_def] >> + fs [FLOOKUP_UPDATE] >> + rveq >> rfs [] >> + qmatch_goalsub_abbrev_tac ‘MAP ff _’ >> + ‘EL i (MAP ff wt) = ff (EL i wt)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [Abbr ‘ff’]) >> + fs [EVERY_MAP, EVERY_MEM] >> + gen_tac >> + strip_tac >> + cases_on ‘x’ >> + fs [evalDiff_def, evalExpr_def] >> + cases_on ‘MEM r tclks’ + >- ( + drule reset_clks_mem_flookup_zero >> + disch_then (qspec_then ‘s.clocks’ assume_tac) >> + fs [] >> + fs [minusT_def] >> + first_x_assum (qspec_then ‘(q,r)’ mp_tac) >> + fs []) >> + rfs [valid_clks_def] >> + rfs [EVERY_MEM] >> + ‘MEM r clks’ by ( + ‘MEM r (MAP SND wt)’ by ( + fs [MEM_MAP] >> + qexists_tac ‘(q,r)’ >> fs []) >> + res_tac >> gs []) >> + res_tac >> rfs [] >> + drule reset_clks_not_mem_flookup_same >> + disch_then (qspec_then ‘tclks’ mp_tac) >> + rfs [] >> + strip_tac >> + fs [minusT_def] >> + last_x_assum (qspec_then ‘(q,r)’ mp_tac) >> + fs [] >> + strip_tac >> + last_x_assum (qspec_then ‘(q,r)’ mp_tac) >> + gs []) >> + strip_tac >> fs [] >> + ‘es ≠ []’ by fs [Abbr ‘wt’, Abbr ‘es’] >> + fs [] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + unabbrev_all_tac >> fs [] >> rveq >> rfs [] >> + fs [OPT_MMAP_def, eval_def, FLOOKUP_UPDATE] >> + rfs [FDOM_FLOOKUP] >> + rfs [] >> + fs [panLangTheory.size_of_shape_def, panSemTheory.shape_of_def] >> + fs [MAP_MAP_o] >> + qmatch_asmsub_abbrev_tac ‘SUM ss’ >> + ‘ss = + MAP ((λa. size_of_shape a) ∘ (λa. shape_of a)) clkvals’ by ( + fs [Abbr ‘ss’] >> + match_mp_tac shape_of_resetClksVals_eq >> + rfs [equiv_val_def] >> + fs [EVERY_MEM] >> + rw [] >> + fs [MEM_MAP]) >> + rfs [maxClksSize_def] >> + qmatch_asmsub_abbrev_tac ‘ss = tt’ >> + ‘SUM ss + 3 ≤ 32’ by fs [ETA_AX] >> + fs [] >> + pop_assum kall_tac >> + fs [empty_locals_def] >> + rveq >> fs [] >> rveq >> rfs [] >> + fs [restore_from_def] >> + fs [retVal_def] >> + fs [calculate_wtime_def] +QED + + +Theorem ffi_eval_state_thm: + !ffi_name s (res:'a result option) t nbytes. + evaluate + (ExtCall ffi_name «ptr1» «len1» «ptr2» «len2»,s) = (res,t)∧ + well_behaved_ffi ffi_name s + (w2n (ffiBufferSize:'a word)) (dimword (:α)) /\ + FLOOKUP s.locals «ptr1» = SOME (ValWord 0w) ∧ + FLOOKUP s.locals «len1» = SOME (ValWord 0w) ∧ + FLOOKUP s.locals «ptr2» = SOME (ValWord ffiBufferAddr) ∧ + FLOOKUP s.locals «len2» = SOME (ValWord ffiBufferSize) ==> + res = NONE ∧ + ∃bytes. + t = ffi_return_state s ffi_name bytes +Proof + rpt gen_tac >> + strip_tac >> + fs [well_behaved_ffi_def] >> + gs [evaluate_def] >> + gs [read_bytearray_def] >> + gs [read_bytearray_def, ffiBufferAddr_def] >> + dxrule LESS_MOD >> + strip_tac >> rfs [] >> + pop_assum kall_tac >> + rfs [ffiTheory.call_FFI_def] >> + rveq >> fs [] >> + gs [ffi_return_state_def] >> + rveq >> gs[] >> + qexists_tac ‘bytes’ >> + gs [state_component_equality, + ffiTheory.ffi_state_component_equality] +QED + +Theorem comp_output_term_correct: + ∀s out cnds tclks dest wt s' t (clkvals:'a v list) clks m. + evalTerm s NONE + (Tm (Output out) cnds tclks dest wt) s' ∧ + m = dimword (:'a) - 1 ∧ + FLOOKUP t.locals «clks» = SOME (Struct clkvals) ∧ + maxClksSize clkvals ∧ + clock_bound s.clocks clks m ∧ + time_range wt m ∧ + equiv_val s.clocks clks clkvals ∧ + valid_clks clks tclks wt ∧ + num_to_str dest IN FDOM t.code ∧ + well_behaved_ffi (num_to_str out) t + (w2n (ffiBufferSize:'a word)) (dimword (:α)) ⇒ + ∃bytes. + evaluate (compTerm clks (Tm (Output out) cnds tclks dest wt), t) = + (SOME (Return (retVal s clks tclks wt dest)), + t with + <|locals := + restore_from t FEMPTY [«len2»; «ptr2»; «len1»; «ptr1»; + «waitTimes»; «newClks»; «wakeUpAt»; «waitSet»]; + memory := write_bytearray 4000w bytes + t.memory t.memaddrs t.be; + ffi := nffi_state t out bytes|>) +Proof + rpt gen_tac >> + strip_tac >> + fs [clock_bound_def, time_range_def] >> + drule every_conj_spec >> + strip_tac >> + drule eval_term_clkvals_equiv_reset_clkvals >> + disch_then (qspec_then ‘clks’ assume_tac) >> + fs [evalTerm_cases] >> + rveq >> fs [] >> + fs [compTerm_def] >> + cases_on ‘wt’ + >- ( (* wait set is disabled *) + fs [panLangTheory.decs_def] >> + fs [evaluate_def, eval_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> rveq >> + rfs [] >> fs [] >> + qmatch_asmsub_abbrev_tac ‘OPT_MMAP (λa. eval stInit a) _’ >> + ‘OPT_MMAP (λa. eval stInit a) + (resetTermClocks «clks» clks tclks) = + SOME (resetClksVals s.clocks clks tclks)’ by ( + match_mp_tac opt_mmap_resetTermClocks_eq_resetClksVals >> + qexists_tac ‘clkvals’ >> rfs [] >> + fs [Abbr ‘stInit’] >> + rfs [FLOOKUP_UPDATE]) >> + fs [] >> + pop_assum kall_tac >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [emptyConsts_def] >> + fs [OPT_MMAP_def] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [panLangTheory.nested_seq_def] >> + fs [Once evaluate_def] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [Once evaluate_def] >> + fs [eval_def] >> + fs [indicesOf_def, waitTimes_def, minExp_def] >> + pop_assum mp_tac >> + rewrite_tac [OPT_MMAP_def] >> + strip_tac >> + fs [is_valid_value_def] >> + fs [FLOOKUP_UPDATE, FDOM_FLOOKUP] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [Once evaluate_def] >> rveq >> fs [] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [Once evaluate_def] >> rveq >> fs [] >> + fs [eval_def] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [Once evaluate_def] >> rveq >> fs [] >> + fs [eval_def] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [Once evaluate_def] >> rveq >> fs [] >> + fs [eval_def] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [Once evaluate_def] >> rveq >> fs [] >> + fs [eval_def] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [Once evaluate_def] >> rveq >> fs [] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + drule ffi_eval_state_thm >> + disch_then (qspec_then ‘nbytes’ mp_tac) >> + impl_tac + >- ( + fs [FLOOKUP_UPDATE] >> + fs [well_behaved_ffi_def]) >> + strip_tac >> fs [] >> rveq >> fs [] >> + fs [ffi_return_state_def] >> + fs [evaluate_def] >> + fs [eval_def] >> + qmatch_asmsub_abbrev_tac ‘OPT_MMAP (λa. eval stReset a) _’ >> + fs [OPT_MMAP_def] >> + fs [eval_def] >> + fs [Abbr ‘stReset’, FLOOKUP_UPDATE, FDOM_FLOOKUP] >> + rfs [] >> + fs [panSemTheory.shape_of_def, panLangTheory.size_of_shape_def] >> + fs [GSYM FDOM_FLOOKUP] >> + drule maxClksSize_reset_clks_eq >> + disch_then (qspecl_then [‘clkvals’, ‘tclks’] mp_tac) >> + fs [] >> strip_tac >> + fs [maxClksSize_def, MAP_MAP_o, ETA_AX] >> + pop_assum kall_tac >> + rveq >> fs [] >> rfs [] >> rveq >> fs [] >> + fs [empty_locals_def, retVal_def] >> + fs [nffi_state_def, restore_from_def] >> + qexists_tac ‘bytes’ >> + gs []) >> + (* some maintenance to replace h::t' to wt *) + qmatch_goalsub_abbrev_tac ‘emptyConsts (LENGTH wt)’ >> + ‘(case wt of [] => Const 1w | v2::v3 => Const 0w) = + (Const 0w): 'a panLang$exp’ by fs [Abbr ‘wt’] >> + fs [] >> + pop_assum kall_tac >> + fs [panLangTheory.decs_def] >> + fs [Once evaluate_def] >> rveq >> fs [] >> + fs [eval_def] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [Once evaluate_def] >> rveq >> fs [] >> + fs [eval_def] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [Once evaluate_def] >> rveq >> fs [] >> + fs [eval_def] >> + rfs [] >> fs [] >> + qmatch_asmsub_abbrev_tac ‘OPT_MMAP (λa. eval stInit a) _’ >> + ‘OPT_MMAP (λa. eval stInit a) + (resetTermClocks «clks» clks tclks) = + SOME (resetClksVals s.clocks clks tclks)’ by ( + match_mp_tac opt_mmap_resetTermClocks_eq_resetClksVals >> + qexists_tac ‘clkvals’ >> rfs [] >> + fs [Abbr ‘stInit’] >> + rfs [FLOOKUP_UPDATE]) >> + fs [] >> + pop_assum kall_tac >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [Once evaluate_def] >> rveq >> fs [] >> + fs [eval_def] >> + fs [eval_empty_const_eq_empty_vals] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [panLangTheory.nested_seq_def] >> + fs [Once evaluate_def] >> rveq >> fs [] >> + fs [eval_def] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [Once evaluate_def] >> rveq >> fs [] >> + qmatch_asmsub_abbrev_tac ‘eval stReset _’ >> + fs [eval_def] >> + (* waitimes eq eval diffs *) + ‘OPT_MMAP (λa. eval stReset a) + (waitTimes (MAP FST wt) + (MAP (λn. Field n (Var «newClks» )) + (indicesOf clks (MAP SND wt)))) = + SOME (MAP ((λw. ValWord w) ∘ n2w ∘ THE ∘ evalDiff + (s with clocks := resetClocks s.clocks tclks)) wt)’ by ( + match_mp_tac calculate_wait_times_eq >> + qexists_tac ‘resetClksVals s.clocks clks tclks’ >> + rfs [Abbr ‘stReset’] >> + rewrite_tac [FLOOKUP_UPDATE] >> + fs [] >> + fs [equiv_val_def] >> + last_x_assum assume_tac >> + drule fdom_reset_clks_eq_clks >> + strip_tac >> + rfs [valid_clks_def] >> + fs [EVERY_MEM] >> + rw [] >> + last_x_assum (qspec_then ‘e’ mp_tac) >> + fs [] >> + cases_on ‘e’ >> fs [] >> + strip_tac >> + fs [] >> + match_mp_tac flookup_reset_clks_leq >> + fs []) >> + fs [] >> + pop_assum kall_tac >> + qmatch_asmsub_abbrev_tac ‘is_valid_value tt _ wtval’ >> + ‘is_valid_value tt «waitTimes» wtval’ by ( + fs [Abbr ‘tt’, Abbr ‘wtval’] >> + fs [is_valid_value_def] >> + fs [FLOOKUP_UPDATE] >> + fs [panSemTheory.shape_of_def] >> + fs [emptyVals_def, emptyConsts_def] >> + fs [MAP_MAP_o, GSYM MAP_K_REPLICATE, MAP_EQ_f] >> + rw [] >> + fs [shape_of_def]) >> + fs [] >> + pairarg_tac >> fs [] >> rveq >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (minExp _ es, stWait)’ >> + ‘FLOOKUP stWait.locals «wakeUpAt» = SOME (ValWord 0w)’ by + fs [Abbr ‘stWait’, FLOOKUP_UPDATE] >> + drule evaluate_min_exp_eq >> + disch_then ( + qspecl_then [ + ‘es’, + ‘MAP (THE ∘ evalDiff (s with clocks := resetClocks s.clocks tclks)) wt’, + ‘res''’, ‘s1'’] mp_tac) >> + impl_tac + >- ( + rfs [] >> + conj_tac + >- ( + rw [] >> + fs [Abbr ‘es’] >> + fs [panLangTheory.var_exp_def]) >> + conj_tac + >- ( + fs [Abbr ‘stWait’, Abbr ‘es’] >> + fs [Abbr ‘wtval’] >> + fs [MAP_MAP_o] >> + fs [MAPi_enumerate_MAP] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + fs [LENGTH_enumerate] >> + rw [] >> + pairarg_tac >> fs [] >> + ‘EL n (enumerate 0 wt) = (n+0,EL n wt)’ by ( + match_mp_tac EL_enumerate >> + fs []) >> + fs [] >> + pop_assum kall_tac >> + fs [eval_def] >> + fs [FLOOKUP_UPDATE] >> + rveq >> rfs [] >> + qmatch_goalsub_abbrev_tac ‘MAP ff _’ >> + ‘EL i (MAP ff wt) = ff (EL i wt)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [Abbr ‘ff’]) >> + fs [EVERY_MAP, EVERY_MEM] >> + gen_tac >> + strip_tac >> + cases_on ‘x’ >> + fs [evalDiff_def, evalExpr_def] >> + cases_on ‘MEM r tclks’ + >- ( + drule reset_clks_mem_flookup_zero >> + disch_then (qspec_then ‘s.clocks’ assume_tac) >> + fs [] >> + fs [minusT_def] >> + first_x_assum (qspec_then ‘(q,r)’ mp_tac) >> + fs []) >> + rfs [valid_clks_def] >> + rfs [EVERY_MEM] >> + ‘MEM r clks’ by ( + ‘MEM r (MAP SND wt)’ by ( + fs [MEM_MAP] >> + qexists_tac ‘(q,r)’ >> fs []) >> + res_tac >> gs []) >> + res_tac >> rfs [] >> + drule reset_clks_not_mem_flookup_same >> + disch_then (qspec_then ‘tclks’ mp_tac) >> + rfs [] >> + strip_tac >> + fs [minusT_def] >> + last_x_assum (qspec_then ‘(q,r)’ mp_tac) >> + fs [] >> + strip_tac >> + last_x_assum (qspec_then ‘(q,r)’ mp_tac) >> + fs []) >> + strip_tac >> fs [] >> + ‘es ≠ []’ by fs [Abbr ‘wt’, Abbr ‘es’] >> + fs [] >> rveq >> rfs [] >> + fs [Once evaluate_def] >> rveq >> fs [] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [Once evaluate_def] >> rveq >> fs [] >> + fs [eval_def] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [Once evaluate_def] >> rveq >> fs [] >> + fs [eval_def] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [Once evaluate_def] >> rveq >> fs [] >> + fs [eval_def] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [Once evaluate_def] >> rveq >> fs [] >> + fs [eval_def] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + fs [Once evaluate_def] >> rveq >> fs [] >> + pairarg_tac >> fs [] >> rveq >> rfs [] >> + unabbrev_all_tac >> fs [] >> rveq >> rfs [] >> + drule ffi_eval_state_thm >> + disch_then (qspec_then ‘bytes’ mp_tac) >> + impl_tac + >- ( + fs [FLOOKUP_UPDATE] >> + fs [well_behaved_ffi_def]) >> + strip_tac >> fs [] >> rveq >> fs [] >> + fs [ffi_return_state_def] >> + fs [evaluate_def] >> + fs [eval_def] >> + qmatch_asmsub_abbrev_tac ‘OPT_MMAP (λa. eval stReset a) _’ >> + fs [OPT_MMAP_def] >> + fs [eval_def] >> + fs [Abbr ‘stReset’, FLOOKUP_UPDATE, FDOM_FLOOKUP] >> + rfs [] >> + fs [panLangTheory.size_of_shape_def, panSemTheory.shape_of_def] >> + fs [MAP_MAP_o] >> + qmatch_asmsub_abbrev_tac ‘SUM ss’ >> + ‘ss = + MAP ((λa. size_of_shape a) ∘ (λa. shape_of a)) clkvals’ by ( + fs [Abbr ‘ss’] >> + match_mp_tac shape_of_resetClksVals_eq >> + rfs [equiv_val_def] >> + fs [EVERY_MEM] >> + rw [] >> + fs [MEM_MAP]) >> + rfs [maxClksSize_def] >> + qmatch_asmsub_abbrev_tac ‘ss = tt’ >> + ‘SUM ss + 3 ≤ 32’ by fs [ETA_AX] >> + fs [] >> + pop_assum kall_tac >> + fs [empty_locals_def] >> + rveq >> fs [] >> rveq >> rfs [] >> + fs [restore_from_def] >> + fs [retVal_def] >> + fs [calculate_wtime_def] >> + fs [nffi_state_def] >> + qexists_tac ‘bytes’ >> + gs [] +QED + + +Theorem comp_term_correct: + ∀s io ioAct cnds tclks dest wt s' t (clkvals:'a v list) clks m. + evalTerm s io + (Tm ioAct cnds tclks dest wt) s' ∧ + m = dimword (:'a) - 1 ∧ + FLOOKUP t.locals «clks» = SOME (Struct clkvals) ∧ + maxClksSize clkvals ∧ + clock_bound s.clocks clks m ∧ + time_range wt m ∧ + equiv_val s.clocks clks clkvals ∧ + valid_clks clks tclks wt ∧ + num_to_str dest IN FDOM t.code ⇒ + case (io,ioAct) of + | (SOME _,Input n) => + evaluate (compTerm clks (Tm (Input n) cnds tclks dest wt), t) = + (SOME (Return (retVal s clks tclks wt dest)), + (* we can throw away the locals *) + t with locals := + restore_from t FEMPTY [«waitTimes»; «newClks»; «wakeUpAt»; «waitSet»]) + | (NONE, Output out) => + (well_behaved_ffi (num_to_str out) t + (w2n (ffiBufferSize:'a word)) (dimword (:α)) ⇒ + ∃bytes. + evaluate (compTerm clks (Tm (Output out) cnds tclks dest wt), t) = + (SOME (Return (retVal s clks tclks wt dest)), + t with + <|locals := + restore_from t FEMPTY [«len2»; «ptr2»; «len1»; «ptr1»; + «waitTimes»; «newClks»; «wakeUpAt»; «waitSet»]; + memory := write_bytearray 4000w bytes + t.memory t.memaddrs t.be; + ffi := nffi_state t out bytes|>)) + | (_,_) => F +Proof + rw [] >> + cases_on ‘ioAct’ >> + cases_on ‘io’ >> + fs [] >> + TRY (fs[evalTerm_cases] >> NO_TAC) + >- ( + drule eval_term_inpput_ios_same >> + strip_tac >> rveq >> + match_mp_tac comp_input_term_correct >> + gs [] >> + metis_tac []) >> + strip_tac >> + drule comp_output_term_correct >> + gs [] +QED + + +Theorem comp_exp_correct: + ∀s e n clks t:('a,'b)panSem$state clkvals. + evalExpr s e = SOME n ∧ + EVERY (λck. MEM ck clks) (exprClks [] e) ∧ + FLOOKUP t.locals «clks» = SOME (Struct clkvals) ∧ + equiv_val s.clocks clks clkvals ⇒ + eval t (compExp clks «clks» e) = SOME (ValWord (n2w n)) +Proof + ho_match_mp_tac evalExpr_ind >> + rpt gen_tac >> + strip_tac >> + rpt gen_tac >> + strip_tac >> + cases_on ‘e’ >> fs [] + >- ( + fs [evalExpr_def] >> + fs [compExp_def] >> + fs [eval_def]) + >- ( + fs [evalExpr_def, timeLangTheory.exprClks_def] >> + fs [compExp_def] >> + fs [equiv_val_def] >> rveq >> gs [] >> + fs [eval_def] >> + ‘findi m clks < LENGTH clks’ by ( + match_mp_tac MEM_findi >> + gs []) >> + fs [] >> + qmatch_goalsub_abbrev_tac ‘EL nn (MAP ff _)’ >> + ‘EL nn (MAP ff clks) = ff (EL nn clks)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [Abbr ‘ff’, Abbr ‘nn’] >> + pop_assum kall_tac >> + ‘EL (findi m clks) clks = m’ by ( + match_mp_tac EL_findi >> + gs []) >> + fs []) >> + qpat_x_assum ‘evalExpr _ _ = _’ mp_tac >> + rewrite_tac [Once evalExpr_def] >> + fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + strip_tac >> + qpat_x_assum ‘EVERY _ (exprClks [] _)’ mp_tac >> + once_rewrite_tac [timeLangTheory.exprClks_def] >> + fs [] >> + strip_tac >> + ‘EVERY (λck. MEM ck clks) (exprClks [] e0) ∧ + EVERY (λck. MEM ck clks) (exprClks [] e')’ by ( + drule exprClks_accumulates >> + fs [] >> + strip_tac >> + fs [EVERY_MEM] >> + rw [] >> + fs [] >> + drule exprClks_sublist_accum >> + fs []) >> + fs [] >> + last_x_assum drule >> + last_x_assum drule >> + fs [] >> + disch_then (qspecl_then [‘t’, ‘clkvals’] assume_tac) >> + disch_then (qspecl_then [‘t’, ‘clkvals’] assume_tac) >> + gs [] >> + rewrite_tac [compExp_def] >> + fs [eval_def] >> + gs [OPT_MMAP_def] >> + fs [wordLangTheory.word_op_def] >> + match_mp_tac EQ_SYM >> + rewrite_tac [Once evalExpr_def] >> + fs [minusT_def] >> + rveq >> gs [] >> + drule n2w_sub >> + fs [] +QED + + +Theorem comp_condition_true_correct: + ∀s cnd m (t:('a,'b) panSem$state) clks clkvals. + evalCond s cnd ∧ + m = dimword (:α) - 1 ∧ + EVERY (λe. case (evalExpr s e) of + | SOME n => n < m + | _ => F) (destCond cnd) ∧ + EVERY (λck. MEM ck clks) (condClks cnd) ∧ + FLOOKUP t.locals «clks» = SOME (Struct clkvals) ∧ + equiv_val s.clocks clks clkvals ⇒ + eval t (compCondition clks «clks» cnd) = SOME (ValWord 1w) +Proof + rw [] >> + cases_on ‘cnd’ >> + fs [evalCond_def, timeLangTheory.condClks_def, + timeLangTheory.destCond_def, timeLangTheory.clksOfExprs_def] >> + every_case_tac >> fs [] >> + ‘x MOD dimword (:α) = x’ by ( + match_mp_tac LESS_MOD >> + gs []) >> + ‘x' MOD dimword (:α) = x'’ by ( + match_mp_tac LESS_MOD >> + gs []) + >- ( + dxrule comp_exp_correct >> + disch_then + (qspecl_then [‘clks’, ‘t’, ‘clkvals’] mp_tac) >> + impl_tac + >- ( + fs [] >> + drule exprClks_accumulates >> + fs []) >> + strip_tac >> + dxrule comp_exp_correct >> + disch_then + (qspecl_then [‘clks’, ‘t’, ‘clkvals’] mp_tac) >> + impl_tac + >- ( + fs [EVERY_MEM] >> + rw [] >> + fs [] >> + drule exprClks_sublist_accum >> + fs []) >> + strip_tac >> + fs [compCondition_def] >> + fs [eval_def, OPT_MMAP_def] >> + gs [] >> + fs [asmTheory.word_cmp_def] >> + gs [word_lo_n2w] >> + gs [LESS_OR_EQ, wordLangTheory.word_op_def]) >> + dxrule comp_exp_correct >> + disch_then + (qspecl_then [‘clks’, ‘t’, ‘clkvals’] mp_tac) >> + impl_tac + >- ( + fs [] >> + drule exprClks_accumulates >> + fs []) >> + strip_tac >> + dxrule comp_exp_correct >> + disch_then + (qspecl_then [‘clks’, ‘t’, ‘clkvals’] mp_tac) >> + impl_tac + >- ( + fs [EVERY_MEM] >> + rw [] >> + fs [] >> + drule exprClks_sublist_accum >> + fs []) >> + strip_tac >> + fs [compCondition_def] >> + fs [eval_def, OPT_MMAP_def] >> + gs [] >> + fs [asmTheory.word_cmp_def] >> + gs [word_lo_n2w] +QED + + +Theorem map_comp_conditions_true_correct: + ∀cnds s m (t:('a,'b) panSem$state) clks clkvals. + EVERY (λcnd. evalCond s cnd) cnds ∧ + m = dimword (:α) - 1 ∧ + EVERY + (λcnd. + EVERY (λe. case (evalExpr s e) of + | SOME n => n < m + | _ => F) (destCond cnd)) cnds ∧ + EVERY + (λcnd. EVERY (λck. MEM ck clks) (condClks cnd)) cnds ∧ + FLOOKUP t.locals «clks» = SOME (Struct clkvals) ∧ + equiv_val s.clocks clks clkvals ⇒ + MAP (eval t o compCondition clks «clks») cnds = + MAP (SOME o (λx. ValWord 1w)) cnds +Proof + Induct + >- rw [] >> + rpt gen_tac >> + strip_tac >> + fs [] >> + drule comp_condition_true_correct >> + fs [] >> gvs [] >> + disch_then drule_all >> + strip_tac >> + gs [] >> + last_x_assum match_mp_tac >> + gs [] >> + qexists_tac ‘s’ >> + gs [] >> + metis_tac [] +QED + +Theorem and_ones_eq_one: + ∀n. word_op And (1w::REPLICATE n 1w) = SOME 1w +Proof + Induct >> + rw [] >> + fs [wordLangTheory.word_op_def] +QED + + +Theorem comp_conditions_true_correct: + ∀cnds s m (t:('a,'b) panSem$state) clks clkvals. + EVERY (λcnd. evalCond s cnd) cnds ∧ + m = dimword (:α) - 1 ∧ + EVERY + (λcnd. + EVERY (λe. case (evalExpr s e) of + | SOME n => n < m + | _ => F) (destCond cnd)) cnds ∧ + EVERY + (λcnd. EVERY (λck. MEM ck clks) (condClks cnd)) cnds ∧ + FLOOKUP t.locals «clks» = SOME (Struct clkvals) ∧ + equiv_val s.clocks clks clkvals ⇒ + eval t (compConditions clks «clks» cnds) = SOME (ValWord 1w) +Proof + rw [] >> + drule map_comp_conditions_true_correct >> + gs [] >> + disch_then drule_all >> + strip_tac >> + pop_assum mp_tac >> + rpt (pop_assum kall_tac) >> + MAP_EVERY qid_spec_tac [‘t’,‘clks’,‘cnds’] >> + Induct >> rw [] + >- ( + fs [compConditions_def] >> + fs [eval_def]) >> + fs [compConditions_def] >> + fs [eval_def, OPT_MMAP_def] >> + fs [GSYM MAP_MAP_o] >> + fs [GSYM opt_mmap_eq_some] >> + ‘MAP (λx. ValWord 1w) cnds = + REPLICATE (LENGTH cnds) (ValWord 1w)’ by ( + once_rewrite_tac [GSYM map_replicate] >> + once_rewrite_tac [GSYM map_replicate] >> + once_rewrite_tac [GSYM map_replicate] >> + rewrite_tac [MAP_MAP_o] >> + rewrite_tac [MAP_EQ_EVERY2] >> + fs [LIST_REL_EL_EQN] >> + rw [] >> fs [] >> + ‘EL n (REPLICATE (LENGTH cnds) (1:num)) = 1’ by ( + match_mp_tac EL_REPLICATE >> + fs []) >> + fs []) >> + fs [] >> + rewrite_tac [ETA_AX] >> + gs [] >> + metis_tac [and_ones_eq_one] +QED + + +Theorem pickTerm_output_cons_correct: + ∀s out cnds tclks dest wt s' t (clkvals:'a v list) clks tms m. + EVERY (λcnd. evalCond s cnd) cnds ∧ + m = dimword (:'a) - 1 ∧ + evalTerm s NONE (Tm (Output out) cnds tclks dest wt) s' ∧ + EVERY + (λcnd. + EVERY (λe. case (evalExpr s e) of + | SOME n => n < m + | _ => F) (destCond cnd)) cnds ∧ + EVERY + (λcnd. EVERY (λck. MEM ck clks) (condClks cnd)) cnds ∧ + FLOOKUP t.locals «clks» = SOME (Struct clkvals) ∧ + equiv_val s.clocks clks clkvals ∧ + maxClksSize clkvals ∧ + clock_bound s.clocks clks m ∧ + time_range wt m ∧ + valid_clks clks tclks wt ∧ + FLOOKUP t.locals «event» = SOME (ValWord 0w) ∧ + num_to_str dest IN FDOM t.code ∧ + well_behaved_ffi (num_to_str out) t + (w2n (ffiBufferSize:'a word)) (dimword (:α)) ⇒ + ∃bytes. + evaluate (compTerms clks «clks» «event» (Tm (Output out) cnds tclks dest wt::tms), t) = + (SOME (Return (retVal s clks tclks wt dest)), + t with + <|locals := + restore_from t FEMPTY [«len2»; «ptr2»; «len1»; «ptr1»; + «waitTimes»; «newClks»; «wakeUpAt»; «waitSet»]; + memory := write_bytearray 4000w bytes t.memory t.memaddrs t.be; + ffi := nffi_state t out bytes|>) +Proof + rpt gen_tac >> + rpt strip_tac >> + drule_all comp_conditions_true_correct >> + strip_tac >> + fs [compTerms_def] >> + fs [pick_term_def] >> + once_rewrite_tac [evaluate_def] >> + gs [timeLangTheory.termConditions_def, + eval_def,OPT_MMAP_def, ETA_AX, timeLangTheory.termAction_def] >> + gs [event_match_def,compAction_def, eval_def, asmTheory.word_cmp_def, + wordLangTheory.word_op_def] >> + drule comp_output_term_correct >> + gvs [] +QED + + +Theorem pickTerm_input_cons_correct: + ∀s n cnds tclks dest wt s' t (clkvals:'a v list) clks tms m. + EVERY (λcnd. evalCond s cnd) cnds ∧ + evalTerm s (SOME n) (Tm (Input n) cnds tclks dest wt) s' ∧ + m = dimword (:α) - 1 ∧ + EVERY + (λcnd. + EVERY (λe. case (evalExpr s e) of + | SOME n => n < m + | _ => F) (destCond cnd)) cnds ∧ + EVERY + (λcnd. EVERY (λck. MEM ck clks) (condClks cnd)) cnds ∧ + FLOOKUP t.locals «clks» = SOME (Struct clkvals) ∧ + equiv_val s.clocks clks clkvals ∧ + maxClksSize clkvals ∧ + clock_bound s.clocks clks m ∧ + time_range wt m ∧ + valid_clks clks tclks wt ∧ + FLOOKUP t.locals «event» = SOME (ValWord (n2w (n + 1))) ∧ + n + 1 < dimword (:α) ∧ + num_to_str dest IN FDOM t.code ⇒ + evaluate (compTerms clks «clks» «event» (Tm (Input n) cnds tclks dest wt::tms), t) = + (SOME (Return (retVal s clks tclks wt dest)), + t with locals := + restore_from t FEMPTY [«waitTimes»; «newClks»; «wakeUpAt»; «waitSet»]) +Proof + rpt gen_tac >> + rpt strip_tac >> + drule_all comp_conditions_true_correct >> + strip_tac >> + fs [compTerms_def] >> + fs [pick_term_def] >> + once_rewrite_tac [evaluate_def] >> + gs [timeLangTheory.termConditions_def, + eval_def,OPT_MMAP_def, ETA_AX, timeLangTheory.termAction_def] >> + gs [event_match_def,compAction_def, eval_def, asmTheory.word_cmp_def, + wordLangTheory.word_op_def] >> + drule comp_input_term_correct >> + gvs [] +QED + + +Theorem comp_condition_false_correct: + ∀s cnd m (t:('a,'b) panSem$state) clks clkvals. + ~(evalCond s cnd) ∧ + m = dimword (:α) - 1 ∧ + EVERY (λe. case (evalExpr s e) of + | SOME n => n < m + | _ => F) (destCond cnd) ∧ + EVERY (λck. MEM ck clks) (condClks cnd) ∧ + FLOOKUP t.locals «clks» = SOME (Struct clkvals) ∧ + equiv_val s.clocks clks clkvals ⇒ + eval t (compCondition clks «clks» cnd) = SOME (ValWord 0w) +Proof + rw [] >> + cases_on ‘cnd’ >> + fs [evalCond_def, timeLangTheory.condClks_def, + timeLangTheory.destCond_def, timeLangTheory.clksOfExprs_def] >> + every_case_tac >> fs [] + >- ( + dxrule comp_exp_correct >> + disch_then + (qspecl_then [‘clks’, ‘t’, ‘clkvals’] mp_tac) >> + impl_tac + >- ( + fs [] >> + drule exprClks_accumulates >> + fs []) >> + strip_tac >> + dxrule comp_exp_correct >> + disch_then + (qspecl_then [‘clks’, ‘t’, ‘clkvals’] mp_tac) >> + impl_tac + >- ( + fs [EVERY_MEM] >> + rw [] >> + fs [] >> + drule exprClks_sublist_accum >> + fs []) >> + strip_tac >> + fs [compCondition_def] >> + fs [eval_def, OPT_MMAP_def] >> + gs [] >> + fs [asmTheory.word_cmp_def] >> + gs [word_lo_n2w] >> + fs [wordLangTheory.word_op_def]) >> + dxrule comp_exp_correct >> + disch_then + (qspecl_then [‘clks’, ‘t’, ‘clkvals’] mp_tac) >> + impl_tac + >- ( + fs [] >> + drule exprClks_accumulates >> + fs []) >> + strip_tac >> + dxrule comp_exp_correct >> + disch_then + (qspecl_then [‘clks’, ‘t’, ‘clkvals’] mp_tac) >> + impl_tac + >- ( + fs [EVERY_MEM] >> + rw [] >> + fs [] >> + drule exprClks_sublist_accum >> + fs []) >> + strip_tac >> + fs [compCondition_def] >> + fs [eval_def, OPT_MMAP_def] >> + gs [] >> + fs [asmTheory.word_cmp_def] >> + gs [word_lo_n2w] +QED + + +Theorem comp_conditions_false_correct: + ∀cnds s m (t:('a,'b) panSem$state) clks clkvals. + ~EVERY (λcnd. evalCond s cnd) cnds ∧ + m = dimword (:α) - 1 ∧ + EVERY (λcnd. EVERY (λe. ∃t. evalExpr s e = SOME t) (destCond cnd)) cnds ∧ + EVERY + (λcnd. + EVERY (λe. case (evalExpr s e) of + | SOME n => n < m + | _ => F) (destCond cnd)) cnds ∧ + EVERY + (λcnd. EVERY (λck. MEM ck clks) (condClks cnd)) cnds ∧ + FLOOKUP t.locals «clks» = SOME (Struct clkvals) ∧ + equiv_val s.clocks clks clkvals ⇒ + eval t (compConditions clks «clks» cnds) = SOME (ValWord 0w) +Proof + Induct + >- ( + rw [] >> + fs []) >> + rpt gen_tac >> + strip_tac >> + fs [] + >- ( + imp_res_tac comp_condition_false_correct >> + cases_on ‘EVERY (λcnd. evalCond s cnd) cnds’ + >- ( + imp_res_tac comp_conditions_true_correct >> + fs [compConditions_def] >> + gs [eval_def, OPT_MMAP_def, ETA_AX] >> + pop_assum mp_tac >> + rpt (pop_assum kall_tac) >> + MAP_EVERY qid_spec_tac [‘t’,‘clks’,‘cnds’] >> + Induct >> rw [] + >- ( + fs [compConditions_def] >> + fs [OPT_MMAP_def, eval_def, wordLangTheory.word_op_def]) >> + gs [compConditions_def, eval_def, OPT_MMAP_def] >> + every_case_tac >> gs [] >> + rveq >> gs [] >> + every_case_tac >> gs [wordLangTheory.word_op_def] >> + rveq >> gs [] >> + metis_tac [EVERY_NOT_EXISTS]) >> + fs [] >> + gvs [] >> + last_x_assum drule_all >> + strip_tac >> + drule comp_condition_false_correct >> + gvs [] >> + disch_then drule_all >> + strip_tac >> + fs [compConditions_def] >> + fs [OPT_MMAP_def, eval_def, wordLangTheory.word_op_def] >> + pop_assum mp_tac >> + rpt (pop_assum kall_tac) >> + MAP_EVERY qid_spec_tac [‘t’,‘clks’,‘cnds’] >> + Induct >> rw [] + >- ( + fs [compConditions_def] >> + fs [OPT_MMAP_def, eval_def, wordLangTheory.word_op_def]) >> + gs [compConditions_def, eval_def, OPT_MMAP_def] >> + every_case_tac >> gs [] >> + rveq >> gs [] >> + every_case_tac >> gs [wordLangTheory.word_op_def] >> + rveq >> gs [] >> + metis_tac [EVERY_NOT_EXISTS]) >> + gvs [] >> + last_x_assum drule_all >> + strip_tac >> + cases_on ‘evalCond s h’ + >- ( + drule comp_condition_true_correct >> + gvs [] >> + disch_then drule_all >> + strip_tac >> + fs [compConditions_def] >> + fs [OPT_MMAP_def, eval_def, wordLangTheory.word_op_def] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + pop_assum mp_tac >> + rpt (pop_assum kall_tac) >> + MAP_EVERY qid_spec_tac [‘t’,‘clks’,‘cnds’] >> + Induct >> rw [] + >- ( + fs [compConditions_def] >> + fs [OPT_MMAP_def, eval_def, wordLangTheory.word_op_def]) >> + gs [compConditions_def, eval_def, OPT_MMAP_def] >> + every_case_tac >> gs [] >> + rveq >> gs [] >> + every_case_tac >> gs [wordLangTheory.word_op_def] >> + rveq >> gs [] >> + metis_tac [EVERY_NOT_EXISTS]) >> + drule comp_condition_false_correct >> + gvs [] >> + disch_then drule_all >> + strip_tac >> + fs [compConditions_def] >> + fs [OPT_MMAP_def, eval_def, wordLangTheory.word_op_def] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + pop_assum mp_tac >> + rpt (pop_assum kall_tac) >> + MAP_EVERY qid_spec_tac [‘t’,‘clks’,‘cnds’] >> + Induct >> rw [] + >- ( + fs [compConditions_def] >> + fs [OPT_MMAP_def, eval_def, wordLangTheory.word_op_def]) >> + gs [compConditions_def, eval_def, OPT_MMAP_def] >> + every_case_tac >> gs [] >> + rveq >> gs [] >> + every_case_tac >> gs [wordLangTheory.word_op_def] >> + rveq >> gs [] >> + metis_tac [EVERY_NOT_EXISTS] +QED + + +Theorem pickTerm_panic_correct: + ∀tms s t (clkvals:'a v list) clks m. + EVERY + (λtm. + EVERY + (λcnd. EVERY (λe. ∃t. evalExpr s e = SOME t) (destCond cnd)) + (termConditions tm)) tms ∧ + EVERY (λtm. EXISTS ($~ ∘ (λcnd. evalCond s cnd)) (termConditions tm)) + tms ∧ + m = dimword (:'a) - 1 ∧ + conds_eval_lt_dimword m s tms ∧ + conds_clks_mem_clks clks tms ∧ + FLOOKUP t.locals «clks» = SOME (Struct clkvals) ∧ + equiv_val s.clocks clks clkvals ∧ + (∃v. FLOOKUP t.eshapes «panic» = SOME One) ∧ + (∃v. FLOOKUP t.locals «event» = SOME (ValWord v)) ⇒ + evaluate (compTerms clks «clks» «event» tms, t) = + (SOME (Exception «panic» (ValWord 0w)), empty_locals t) +Proof + Induct >> rw [] + >- ( + gs [compTerms_def] >> + once_rewrite_tac [evaluate_def] >> + gs [eval_def, shape_of_def, panLangTheory.size_of_shape_def]) >> + cases_on ‘h’ >> + fs [compTerms_def] >> + once_rewrite_tac [evaluate_def] >> + fs [timeLangTheory.termConditions_def, timeLangTheory.termAction_def] >> + fs [pick_term_def] >> + ‘eval t (compConditions clks «clks» l) = SOME (ValWord 0w)’ by ( + match_mp_tac comp_conditions_false_correct >> + gs [] >> + qexists_tac ‘s’ >> + gs [conds_eval_lt_dimword_def, tm_conds_eval_limit_def, + timeLangTheory.termConditions_def, conds_clks_mem_clks_def]) >> + gs [eval_def, OPT_MMAP_def] >> + cases_on ‘i’ >> + fs [event_match_def] >> + gs [eval_def,compAction_def, asmTheory.word_cmp_def, wordLangTheory.word_op_def] >> + last_x_assum (qspecl_then [‘s’, ‘t’, ‘clkvals’, ‘clks’] mp_tac) >> + (impl_tac >- gs [conds_eval_lt_dimword_def, conds_clks_mem_clks_def] >> + gs []) +QED + +Theorem pick_term_thm: + ∀s m e tms s' lbl. + pickTerm s m e tms s' lbl ⇒ + (∀(t :('a, 'b) panSem$state) clks clkvals. + m = dimword (:α) - 1 ∧ + conds_clks_mem_clks clks tms ∧ + terms_valid_clocks clks tms ∧ + locs_in_code t.code tms ∧ + FLOOKUP t.locals «clks» = SOME (Struct clkvals) ∧ + EVERY (λck. ∃n. FLOOKUP s.clocks ck = SOME n) clks ∧ + equiv_val s.clocks clks clkvals ∧ + maxClksSize clkvals ∧ + out_signals_ffi t tms ⇒ + (e = NONE ∧ (∃os. lbl = LAction (Output os)) ∧ + FLOOKUP t.locals «event» = SOME (ValWord 0w) ⇒ + ∃out cnds tclks dest wt. + MEM (Tm (Output out) cnds tclks dest wt) tms ∧ + EVERY (λcnd. evalCond s cnd) cnds ∧ + evalTerm s NONE + (Tm (Output out) cnds tclks dest wt) s' ∧ + ∃bytes. + evaluate (compTerms clks «clks» «event» tms, t) = + (SOME (Return (retVal s clks tclks wt dest)), + t with + <|locals := + restore_from t FEMPTY [«len2»; «ptr2»; «len1»; «ptr1»; + «waitTimes»; «newClks»; «wakeUpAt»; «waitSet»]; + memory := write_bytearray 4000w bytes t.memory t.memaddrs t.be; + ffi := nffi_state t out bytes|>)) ∧ + (∀n. e = SOME n ∧ lbl = LAction (Input n) ∧ n+1 < dimword (:'a) ∧ + FLOOKUP t.locals «event» = SOME (ValWord (n2w (n+1))) ⇒ + ∃cnds tclks dest wt. + MEM (Tm (Input n) cnds tclks dest wt) tms ∧ + EVERY (λcnd. evalCond s cnd) cnds ∧ + evalTerm s (SOME n) + (Tm (Input n) cnds tclks dest wt) s' ∧ + evaluate (compTerms clks «clks» «event» tms, t) = + (SOME (Return (retVal s clks tclks wt dest)), + t with locals := + restore_from t FEMPTY [«waitTimes»; «newClks»; «wakeUpAt»; «waitSet»])) ∧ + (e = NONE ∧ lbl = LPanic PanicTimeout ∧ + FLOOKUP t.locals «event» = SOME (ValWord 0w) ∧ + FLOOKUP t.eshapes «panic» = SOME One ⇒ + evaluate (compTerms clks «clks» «event» tms, t) = + (SOME (Exception «panic» (ValWord 0w)),empty_locals t)) ∧ + (∀n. + e = SOME n ∧ lbl = LPanic (PanicInput n) ∧ n+1 < dimword (:'a) ∧ + FLOOKUP t.locals «event» = SOME (ValWord (n2w (n+1))) ∧ + FLOOKUP t.eshapes «panic» = SOME One ⇒ + evaluate (compTerms clks «clks» «event» tms, t) = + (SOME (Exception «panic» (ValWord 0w)),empty_locals t))) +Proof + ho_match_mp_tac pickTerm_ind >> + rpt gen_tac >> + strip_tac >> + rpt gen_tac + >- ( + strip_tac >> + fs [] >> + rw [] >> + MAP_EVERY qexists_tac + [‘cnds’, ‘clks’, ‘dest’, ‘diffs'’] >> + fs [] >> + match_mp_tac pickTerm_input_cons_correct >> + qexists_tac ‘s'’ >> + qexists_tac ‘clkvals’ >> + gvs [] >> + conj_tac + >- ( + gs [conds_eval_lt_dimword_def, tm_conds_eval_limit_def, + timeLangTheory.termConditions_def] >> + gs [EVERY_MEM] >> + rw [] >> + first_x_assum drule >> + gs [] >> + disch_then drule >> + TOP_CASE_TAC >> gs []) >> + conj_tac + >- gs [conds_clks_mem_clks_def, timeLangTheory.termConditions_def] >> + conj_tac + >- ( + gs [clock_bound_def, max_clocks_def, EVERY_MEM] >> + rw [] >> + first_x_assum drule >> + strip_tac >> gs [] >> + last_x_assum drule >> + gs []) >> + conj_tac + >- ( + gs [terms_time_range_def, term_time_range_def, time_range_def, + timeLangTheory.termWaitTimes_def] >> + gs [EVERY_MEM] >> + rw [] >> + first_x_assum drule >> + strip_tac >> + cases_on ‘e’ >> + gs []) >> + conj_tac + >- gs [terms_valid_clocks_def, timeLangTheory.termClks_def, + timeLangTheory.termWaitTimes_def] >> + gs [locs_in_code_def, timeLangTheory.termDest_def]) >> + strip_tac >> + rpt gen_tac + >- ( + strip_tac >> + fs [] >> + rw [] >> + MAP_EVERY qexists_tac + [‘out_signal’, ‘cnds’, ‘clks’, ‘dest’, ‘diffs'’] >> + fs [] >> + match_mp_tac pickTerm_output_cons_correct >> + qexists_tac ‘s'’ >> + qexists_tac ‘clkvals’ >> + gvs [] >> + conj_tac + >- gs [conds_eval_lt_dimword_def, tm_conds_eval_limit_def, + timeLangTheory.termConditions_def] >> + conj_tac + >- gs [conds_clks_mem_clks_def, timeLangTheory.termConditions_def] >> + conj_tac + >- ( + gs [clock_bound_def, max_clocks_def, EVERY_MEM] >> + rw [] >> + first_x_assum drule >> + strip_tac >> gs [] >> + last_x_assum drule >> + gs []) >> + conj_tac + >- gs [terms_time_range_def, term_time_range_def, + timeLangTheory.termWaitTimes_def] >> + conj_tac + >- gs [terms_valid_clocks_def, timeLangTheory.termClks_def, + timeLangTheory.termWaitTimes_def] >> + conj_tac + >- gs [locs_in_code_def, timeLangTheory.termDest_def] >> + gs [out_signals_ffi_def, timeLangTheory.terms_out_signals_def]) >> + strip_tac >> + rpt gen_tac + >- ( + strip_tac >> + fs [] >> + cases_on ‘e’ >> fs [] + >- ( + rw [] >> + fs [] + >- ( + last_x_assum (qspecl_then [‘t’, ‘clks'’, ‘clkvals’] mp_tac) >> + gs [] >> + impl_tac + >- ( + gs [conds_eval_lt_dimword_def, conds_clks_mem_clks_def, + terms_time_range_def, terms_valid_clocks_def, + locs_in_code_def, out_signals_ffi_def, input_terms_actions_def] >> + cases_on ‘ioAction’ >> + gs [timeLangTheory.terms_out_signals_def, + timeLangTheory.terms_in_signals_def]) >> + strip_tac >> + MAP_EVERY qexists_tac + [‘out’, ‘cnds'’, ‘tclks’, ‘dest'’, ‘wt’] >> + fs [] >> + qexists_tac ‘bytes’ >> + (* we can have a separate theorem *) + fs [compTerms_def] >> + fs [pick_term_def] >> + once_rewrite_tac [evaluate_def] >> + fs [timeLangTheory.termConditions_def] >> + ‘eval t (compConditions clks' «clks» cnds) = SOME (ValWord 0w)’ by ( + match_mp_tac comp_conditions_false_correct >> + gs [] >> + qexists_tac ‘s’ >> + gvs [conds_clks_mem_clks_def, conds_eval_lt_dimword_def, + tm_conds_eval_limit_def, + timeLangTheory.termConditions_def]) >> + gs [eval_def, OPT_MMAP_def] >> + fs [timeLangTheory.termAction_def] >> + cases_on ‘ioAction’ >> + fs [event_match_def] >> + gs [eval_def,compAction_def, + asmTheory.word_cmp_def, + wordLangTheory.word_op_def]) >> + last_x_assum (qspecl_then [‘t’, ‘clks'’, ‘clkvals’] mp_tac) >> + gs [] >> + impl_tac + >- ( + gs [conds_clks_mem_clks_def, terms_valid_clocks_def, locs_in_code_def, + out_signals_ffi_def] >> + cases_on ‘ioAction’ >> + gs [timeLangTheory.terms_out_signals_def]) >> + strip_tac >> + fs [compTerms_def] >> + once_rewrite_tac [evaluate_def] >> + fs [timeLangTheory.termConditions_def, timeLangTheory.termAction_def] >> + fs [pick_term_def] >> + ‘eval t (compConditions clks' «clks» cnds) = SOME (ValWord 0w)’ by ( + match_mp_tac comp_conditions_false_correct >> + gs [] >> + qexists_tac ‘s’ >> + gvs [conds_clks_mem_clks_def, conds_eval_lt_dimword_def, + tm_conds_eval_limit_def, + timeLangTheory.termConditions_def]) >> + gs [eval_def, OPT_MMAP_def] >> + cases_on ‘ioAction’ >> + fs [event_match_def] >> + gs [eval_def,compAction_def, + asmTheory.word_cmp_def, + wordLangTheory.word_op_def]) >> + rw [] >> + fs [] + >- ( + last_x_assum (qspecl_then [‘t’, ‘clks'’, ‘clkvals’] mp_tac) >> + gs [] >> + impl_tac + >- ( + gs [conds_eval_lt_dimword_def, conds_clks_mem_clks_def, + terms_time_range_def, terms_valid_clocks_def, + locs_in_code_def, out_signals_ffi_def, input_terms_actions_def] >> + cases_on ‘ioAction’ >> + gs [timeLangTheory.terms_out_signals_def, + timeLangTheory.terms_in_signals_def]) >> + strip_tac >> + MAP_EVERY qexists_tac + [‘cnds'’, ‘tclks’, ‘dest'’, ‘wt’] >> + fs [] >> + fs [compTerms_def] >> + fs [pick_term_def] >> + once_rewrite_tac [evaluate_def] >> + fs [timeLangTheory.termConditions_def] >> + ‘eval t (compConditions clks' «clks» cnds) = SOME (ValWord 0w)’ by ( + match_mp_tac comp_conditions_false_correct >> + gs [] >> + qexists_tac ‘s’ >> + gvs [conds_clks_mem_clks_def, conds_eval_lt_dimword_def, + tm_conds_eval_limit_def, + timeLangTheory.termConditions_def]) >> + gs [eval_def, OPT_MMAP_def] >> + fs [timeLangTheory.termAction_def] >> + cases_on ‘ioAction’ >> + fs [event_match_def] >> + gs [eval_def,compAction_def, asmTheory.word_cmp_def, wordLangTheory.word_op_def]) >> + last_x_assum (qspecl_then [‘t’, ‘clks'’, ‘clkvals’] mp_tac) >> + gs [] >> + impl_tac + >- ( + gs [conds_eval_lt_dimword_def, conds_clks_mem_clks_def, + terms_time_range_def, terms_valid_clocks_def, + locs_in_code_def, out_signals_ffi_def, input_terms_actions_def] >> + cases_on ‘ioAction’ >> + gs [timeLangTheory.terms_out_signals_def, + timeLangTheory.terms_in_signals_def]) >> + strip_tac >> + fs [compTerms_def] >> + once_rewrite_tac [evaluate_def] >> + fs [timeLangTheory.termConditions_def, timeLangTheory.termAction_def] >> + fs [pick_term_def] >> + ‘eval t (compConditions clks' «clks» cnds) = SOME (ValWord 0w)’ by ( + match_mp_tac comp_conditions_false_correct >> + gs [] >> + qexists_tac ‘s’ >> + gvs [conds_clks_mem_clks_def, conds_eval_lt_dimword_def, + tm_conds_eval_limit_def, + timeLangTheory.termConditions_def]) >> + gs [eval_def, OPT_MMAP_def] >> + cases_on ‘ioAction’ >> + fs [event_match_def] >> + gs [eval_def,compAction_def, + asmTheory.word_cmp_def, + wordLangTheory.word_op_def]) >> + strip_tac >> + rpt gen_tac + >- ( + strip_tac >> + rw [] >> + gs [] + >- ( + last_x_assum (qspecl_then [‘t’, ‘clks'’, ‘clkvals’] mp_tac) >> + gs [] >> + impl_tac + >- ( + gs [conds_eval_lt_dimword_def, conds_clks_mem_clks_def, + terms_time_range_def, terms_valid_clocks_def, + locs_in_code_def, out_signals_ffi_def, input_terms_actions_def] >> + gs [timeLangTheory.terms_out_signals_def, timeLangTheory.terms_in_signals_def]) >> + strip_tac >> + MAP_EVERY qexists_tac + [‘out’,‘cnds'’, ‘tclks’, ‘dest'’, ‘wt’] >> + fs [] >> + fs [compTerms_def] >> + fs [pick_term_def] >> + fs [timeLangTheory.termConditions_def, + timeLangTheory.termAction_def] >> + fs [event_match_def, compAction_def] >> + once_rewrite_tac [evaluate_def] >> + fs [eval_def, OPT_MMAP_def] >> + cases_on ‘EVERY (λcnd. evalCond s cnd) cnds’ + >- ( + drule comp_conditions_true_correct >> + disch_then (qspecl_then [‘dimword (:α) − 1 ’, ‘t’, ‘clks'’, ‘clkvals’] mp_tac) >> + impl_tac + >- ( + gvs [conds_clks_mem_clks_def, conds_eval_lt_dimword_def, + tm_conds_eval_limit_def, + timeLangTheory.termConditions_def]) >> + strip_tac >> fs [] >> + gs [asmTheory.word_cmp_def] >> + ‘(in_signal + 1) MOD dimword (:α) = in_signal + 1’ by ( + match_mp_tac LESS_MOD >> + gs [input_terms_actions_def, timeLangTheory.terms_in_signals_def]) >> + fs [] >> + fs [wordLangTheory.word_op_def] >> + metis_tac []) >> + drule comp_conditions_false_correct >> + disch_then (qspecl_then [‘dimword (:α) − 1 ’, ‘t’, ‘clks'’, ‘clkvals’] mp_tac) >> + impl_tac + >- ( + gvs [conds_clks_mem_clks_def, conds_eval_lt_dimword_def, + tm_conds_eval_limit_def, + timeLangTheory.termConditions_def] >> + gs [EVERY_MEM] >> + rw [] >> + res_tac >> gs [] >> + every_case_tac >> gs []) >> + strip_tac >> fs [] >> + gs [asmTheory.word_cmp_def] >> + ‘(in_signal + 1) MOD dimword (:α) = in_signal + 1’ by ( + match_mp_tac LESS_MOD >> + gs [input_terms_actions_def, timeLangTheory.terms_in_signals_def]) >> + fs [] >> + fs [wordLangTheory.word_op_def] >> + metis_tac []) + >- ( + last_x_assum (qspecl_then [‘t’, ‘clks'’, ‘clkvals’] mp_tac) >> + gs [] >> + impl_tac + >- ( + gs [conds_clks_mem_clks_def, terms_valid_clocks_def, locs_in_code_def, + out_signals_ffi_def] >> + gs [timeLangTheory.terms_out_signals_def]) >> + strip_tac >> + MAP_EVERY qexists_tac + [‘cnds'’, ‘tclks’, ‘dest'’, ‘wt’] >> + fs [] >> + fs [compTerms_def] >> + fs [pick_term_def] >> + fs [timeLangTheory.termConditions_def, + timeLangTheory.termAction_def] >> + fs [event_match_def, compAction_def] >> + once_rewrite_tac [evaluate_def] >> + fs [eval_def, OPT_MMAP_def] >> + cases_on ‘EVERY (λcnd. evalCond s cnd) cnds’ + >- ( + drule comp_conditions_true_correct >> + disch_then (qspecl_then [‘dimword (:α) − 1 ’, ‘t’, ‘clks'’, ‘clkvals’] mp_tac) >> + impl_tac + >- ( + gs [conds_clks_mem_clks_def, conds_eval_lt_dimword_def, + tm_conds_eval_limit_def, + timeLangTheory.termConditions_def]) >> + strip_tac >> fs [] >> + gs [asmTheory.word_cmp_def] >> + ‘(in_signal + 1) MOD dimword (:α) = in_signal + 1’ by ( + match_mp_tac LESS_MOD >> + gs [input_terms_actions_def, timeLangTheory.terms_in_signals_def]) >> + fs [] >> + fs [wordLangTheory.word_op_def] >> + metis_tac []) >> + drule comp_conditions_false_correct >> + disch_then (qspecl_then [‘dimword (:α) − 1 ’, ‘t’, ‘clks'’, ‘clkvals’] mp_tac) >> + impl_tac + >- ( + gs [conds_clks_mem_clks_def, conds_eval_lt_dimword_def, + tm_conds_eval_limit_def, + timeLangTheory.termConditions_def] >> + gs [EVERY_MEM] >> + rw [] >> + res_tac >> gs [] >> + every_case_tac >> gs []) >> + strip_tac >> fs [] >> + gs [asmTheory.word_cmp_def] >> + ‘(in_signal + 1) MOD dimword (:α) = in_signal + 1’ by ( + match_mp_tac LESS_MOD >> + gs [input_terms_actions_def, timeLangTheory.terms_in_signals_def]) >> + fs [] >> + fs [wordLangTheory.word_op_def] >> + metis_tac []) + >- ( + last_x_assum (qspecl_then [‘t’, ‘clks'’, ‘clkvals’] mp_tac) >> + gs [] >> + impl_tac + >- ( + gs [conds_clks_mem_clks_def, terms_valid_clocks_def, locs_in_code_def, + out_signals_ffi_def] >> + gs [timeLangTheory.terms_out_signals_def]) >> + strip_tac >> + fs [] >> + fs [compTerms_def] >> + fs [pick_term_def] >> + fs [timeLangTheory.termConditions_def, + timeLangTheory.termAction_def] >> + fs [event_match_def, compAction_def] >> + once_rewrite_tac [evaluate_def] >> + fs [eval_def, OPT_MMAP_def] >> + cases_on ‘EVERY (λcnd. evalCond s cnd) cnds’ + >- ( + drule comp_conditions_true_correct >> + disch_then (qspecl_then [‘dimword (:α) − 1 ’, ‘t’, ‘clks'’, ‘clkvals’] mp_tac) >> + impl_tac + >- ( + gs [conds_clks_mem_clks_def, conds_eval_lt_dimword_def, + tm_conds_eval_limit_def, + timeLangTheory.termConditions_def]) >> + strip_tac >> fs [] >> + gs [asmTheory.word_cmp_def] >> + ‘(in_signal + 1) MOD dimword (:α) = in_signal + 1’ by ( + match_mp_tac LESS_MOD >> + gs [input_terms_actions_def, timeLangTheory.terms_in_signals_def]) >> + fs [] >> + fs [wordLangTheory.word_op_def] >> + metis_tac []) >> + drule comp_conditions_false_correct >> + disch_then (qspecl_then [‘dimword (:α) − 1 ’, ‘t’, ‘clks'’, ‘clkvals’] mp_tac) >> + impl_tac + >- ( + gs [conds_clks_mem_clks_def, conds_eval_lt_dimword_def, + tm_conds_eval_limit_def, + timeLangTheory.termConditions_def] >> + gs [EVERY_MEM] >> + rw [] >> + res_tac >> gs [] >> + every_case_tac >> gs []) >> + strip_tac >> fs [] >> + gs [asmTheory.word_cmp_def] >> + ‘(in_signal + 1) MOD dimword (:α) = in_signal + 1’ by ( + match_mp_tac LESS_MOD >> + gs [input_terms_actions_def, timeLangTheory.terms_in_signals_def]) >> + fs [] >> + fs [wordLangTheory.word_op_def] >> + metis_tac []) >> + last_x_assum (qspecl_then [‘t’, ‘clks'’, ‘clkvals’] mp_tac) >> + gs [] >> + impl_tac + >- ( + gs [conds_clks_mem_clks_def, terms_valid_clocks_def, locs_in_code_def, + out_signals_ffi_def] >> + gs [timeLangTheory.terms_out_signals_def]) >> + strip_tac >> + fs [] >> + fs [compTerms_def] >> + fs [pick_term_def] >> + fs [timeLangTheory.termConditions_def, + timeLangTheory.termAction_def] >> + fs [event_match_def, compAction_def] >> + once_rewrite_tac [evaluate_def] >> + fs [eval_def, OPT_MMAP_def] >> + cases_on ‘EVERY (λcnd. evalCond s cnd) cnds’ + >- ( + drule comp_conditions_true_correct >> + disch_then (qspecl_then [‘dimword (:α) − 1 ’, ‘t’, ‘clks'’, ‘clkvals’] mp_tac) >> + impl_tac + >- ( + gs [conds_clks_mem_clks_def, conds_eval_lt_dimword_def, + tm_conds_eval_limit_def, + timeLangTheory.termConditions_def]) >> + strip_tac >> fs [] >> + gs [asmTheory.word_cmp_def] >> + ‘(in_signal + 1) MOD dimword (:α) = in_signal + 1’ by ( + match_mp_tac LESS_MOD >> + gs [input_terms_actions_def, timeLangTheory.terms_in_signals_def]) >> + fs [] >> + fs [wordLangTheory.word_op_def] >> + metis_tac []) >> + drule comp_conditions_false_correct >> + disch_then (qspecl_then [‘dimword (:α) − 1 ’, ‘t’, ‘clks'’, ‘clkvals’] mp_tac) >> + impl_tac + >- ( + gs [conds_clks_mem_clks_def, conds_eval_lt_dimword_def, + tm_conds_eval_limit_def, + timeLangTheory.termConditions_def] >> + gs [EVERY_MEM] >> + rw [] >> + res_tac >> gs [] >> + every_case_tac >> gs []) >> + strip_tac >> fs [] >> + gs [asmTheory.word_cmp_def] >> + ‘(in_signal + 1) MOD dimword (:α) = in_signal + 1’ by ( + match_mp_tac LESS_MOD >> + gs [input_terms_actions_def, timeLangTheory.terms_in_signals_def]) >> + fs [] >> + fs [wordLangTheory.word_op_def] >> + metis_tac []) >> + strip_tac >> + rpt gen_tac + >- ( + strip_tac >> + rw [] >> + gs [] + >- ( + last_x_assum (qspecl_then [‘t’, ‘clks'’, ‘clkvals’] mp_tac) >> + gs [] >> + impl_tac + >- ( + gs [conds_clks_mem_clks_def, terms_valid_clocks_def, locs_in_code_def, + out_signals_ffi_def] >> + gs [timeLangTheory.terms_out_signals_def]) >> + strip_tac >> + MAP_EVERY qexists_tac + [‘cnds'’, ‘tclks’, ‘dest'’, ‘wt’] >> + fs [] >> + fs [compTerms_def] >> + fs [pick_term_def] >> + fs [timeLangTheory.termConditions_def, + timeLangTheory.termAction_def] >> + fs [event_match_def, compAction_def] >> + once_rewrite_tac [evaluate_def] >> + fs [eval_def, OPT_MMAP_def] >> + cases_on ‘EVERY (λcnd. evalCond s cnd) cnds’ + >- ( + drule comp_conditions_true_correct >> + disch_then (qspecl_then [‘dimword (:α) − 1 ’, ‘t’, ‘clks'’, ‘clkvals’] mp_tac) >> + impl_tac + >- ( + gs [conds_clks_mem_clks_def, conds_eval_lt_dimword_def, + tm_conds_eval_limit_def, + timeLangTheory.termConditions_def]) >> + strip_tac >> fs [] >> + gs [asmTheory.word_cmp_def] >> + fs [wordLangTheory.word_op_def]) >> + drule comp_conditions_false_correct >> + disch_then (qspecl_then [‘dimword (:α) − 1 ’, ‘t’, ‘clks'’, ‘clkvals’] mp_tac) >> + impl_tac + >- ( + gs [conds_clks_mem_clks_def, conds_eval_lt_dimword_def, + tm_conds_eval_limit_def, + timeLangTheory.termConditions_def] >> + gs [EVERY_MEM] >> + rw [] >> + res_tac >> gs [] >> + every_case_tac >> gs []) >> + strip_tac >> fs [] >> + gs [asmTheory.word_cmp_def] >> + fs [wordLangTheory.word_op_def]) >> + last_x_assum (qspecl_then [‘t’, ‘clks'’, ‘clkvals’] mp_tac) >> + gs [] >> + impl_tac + >- ( + gs [conds_clks_mem_clks_def, terms_valid_clocks_def, locs_in_code_def, + out_signals_ffi_def] >> + gs [timeLangTheory.terms_out_signals_def]) >> + strip_tac >> + fs [] >> + fs [compTerms_def] >> + fs [pick_term_def] >> + fs [timeLangTheory.termConditions_def, + timeLangTheory.termAction_def] >> + fs [event_match_def, compAction_def] >> + once_rewrite_tac [evaluate_def] >> + fs [eval_def, OPT_MMAP_def] >> + cases_on ‘EVERY (λcnd. evalCond s cnd) cnds’ + >- ( + drule comp_conditions_true_correct >> + disch_then (qspecl_then [‘dimword (:α) − 1 ’, ‘t’, ‘clks'’, ‘clkvals’] mp_tac) >> + impl_tac + >- ( + gs [conds_clks_mem_clks_def, conds_eval_lt_dimword_def, + tm_conds_eval_limit_def, + timeLangTheory.termConditions_def]) >> + strip_tac >> fs [] >> + gs [asmTheory.word_cmp_def] >> + fs [wordLangTheory.word_op_def]) >> + drule comp_conditions_false_correct >> + disch_then (qspecl_then [‘dimword (:α) − 1 ’, ‘t’, ‘clks'’, ‘clkvals’] mp_tac) >> + impl_tac + >- ( + gs [conds_clks_mem_clks_def, conds_eval_lt_dimword_def, + tm_conds_eval_limit_def, + timeLangTheory.termConditions_def] >> + gs [EVERY_MEM] >> + rw [] >> + res_tac >> gs [] >> + every_case_tac >> gs []) >> + strip_tac >> fs [] >> + gs [asmTheory.word_cmp_def] >> + fs [wordLangTheory.word_op_def]) >> + strip_tac >> + rpt gen_tac + >- ( + strip_tac >> + rw [] >> + fs [compTerms_def, evaluate_def, eval_def, shape_of_def, panLangTheory.size_of_shape_def]) >> + strip_tac >> + rw [] >> + fs [compTerms_def, evaluate_def, eval_def, shape_of_def, panLangTheory.size_of_shape_def] +QED + + +Theorem pick_term_dest_eq: + ∀s m e tms s' lbl. + pickTerm s m e tms s' lbl ⇒ + (e = NONE ⇒ + ((∃out. + lbl = LAction (Output out)) ⇒ + (case s'.waitTime of + | NONE => T + | SOME x => x < m)) ∧ + (∀out cnds tclks dest wt. + MEM (Tm (Output out) cnds tclks dest wt) tms ∧ + EVERY (λcnd. evalCond s cnd) cnds ∧ + evalTerm s NONE (Tm (Output out) cnds tclks dest wt) s' ⇒ + dest = s'.location ∧ s'.ioAction = SOME (Output out) ∧ + (case wt of [] => s'.waitTime = NONE | _ => ∃nt. s'.waitTime = SOME nt))) ∧ + (∀n. + e = SOME n ⇒ + n+1 < m ∧ + (lbl = LAction (Input n) ⇒ + (case s'.waitTime of + | NONE => T + | SOME x => x < m)) ∧ + (∀cnds tclks dest wt. + MEM (Tm (Input n) cnds tclks dest wt) tms ∧ + EVERY (λcnd. evalCond s cnd) cnds ∧ + evalTerm s (SOME n) (Tm (Input n) cnds tclks dest wt) s' ⇒ + dest = s'.location ∧ + (case wt of [] => s'.waitTime = NONE | _ => ∃nt. s'.waitTime = SOME nt))) +Proof + ho_match_mp_tac pickTerm_ind >> + rpt gen_tac >> + strip_tac >> + rpt gen_tac + >- ( + strip_tac >> + fs [] >> + conj_tac + >- gs [input_terms_actions_def, timeLangTheory.terms_in_signals_def] >> + conj_tac + >- ( + gs [input_terms_actions_def, timeLangTheory.terms_in_signals_def] >> + TOP_CASE_TAC >> + gs [evalTerm_cases] >> + gs [terms_wtimes_ffi_bound_def, timeLangTheory.termClks_def, + timeLangTheory.termWaitTimes_def] >> + every_case_tac + >- (drule calculate_wtime_reset_output_eq >> gs []) >> + pop_assum mp_tac >> + pop_assum mp_tac >> + drule calculate_wtime_reset_output_eq >> gs []) >> + strip_tac >> + fs [] >> + rw [] >> + fs [evalTerm_cases] >> + every_case_tac >> + fs [calculate_wtime_def, list_min_option_def] >> + every_case_tac >> gs [] >> + metis_tac []) >> + strip_tac >> + rpt gen_tac + >- ( + strip_tac >> + fs [] >> + reverse conj_tac + >- ( + rw [] >> + fs [evalTerm_cases] >> + every_case_tac >> + gs [calculate_wtime_def, list_min_option_def] >> + every_case_tac >> gs [] >> + metis_tac []) >> + TOP_CASE_TAC >> + gs [evalTerm_cases] >> + gs [terms_wtimes_ffi_bound_def, timeLangTheory.termClks_def, + timeLangTheory.termWaitTimes_def] >> + every_case_tac + >- (drule calculate_wtime_reset_output_eq >> gs []) >> + pop_assum mp_tac >> + pop_assum mp_tac >> + drule calculate_wtime_reset_output_eq >> gs []) >> + strip_tac >> + rpt gen_tac + >- ( + strip_tac >> + cases_on ‘e’ >> fs [] >> + rw [] >> fs [] >> + metis_tac [EVERY_NOT_EXISTS]) >> + strip_tac >> + rpt gen_tac + >- ( + strip_tac >> + cases_on ‘e’ >> fs [] >> + rw [] >> fs [] >> + metis_tac [EVERY_NOT_EXISTS]) >> + strip_tac >> + rpt gen_tac + >- ( + strip_tac >> + cases_on ‘e’ >> fs [] >> + rw [] >> fs [] >> + metis_tac [EVERY_NOT_EXISTS]) >> + strip_tac >> + rpt gen_tac + >- ( + strip_tac >> + gs [max_clocks_def] >> + rw [] >> fs [] >> + metis_tac [EVERY_NOT_EXISTS]) >> + strip_tac >> + rw [] >> fs [] +QED + + +(* step theorems *) + +Theorem state_rel_imp_time_seq_ffi: + ∀cks outs s t. + state_rel cks outs s (t:('a,time_input) panSem$state) ⇒ + time_seq t.ffi.ffi_state (dimword (:'a)) +Proof + rw [state_rel_def] >> + pairarg_tac >> gs [] +QED + + +Theorem state_rel_imp_ffi_vars: + ∀cks outs s t. + state_rel cks outs s (t:('a,time_input) panSem$state) ⇒ + ffi_vars t.locals +Proof + rw [state_rel_def] +QED + + +Theorem state_rel_imp_equivs: + ∀cks outs s t. + state_rel cks outs s (t:('a,time_input) panSem$state) ⇒ + equivs t.locals s.location s.waitTime +Proof + rw [state_rel_def] +QED + +Theorem time_seq_mono: + ∀m n f a. + n ≤ m ∧ + time_seq f a ⇒ + FST (f n) ≤ FST (f m) +Proof + Induct >> + rw [] >> + fs [time_seq_def] >> + fs [LE] >> + last_x_assum (qspecl_then [‘n’, ‘f’, ‘a’] mp_tac) >> + impl_tac + >- gs [] >> + strip_tac >> + ‘FST (f m) ≤ FST (f (SUC m))’ suffices_by gs [] >> + last_x_assum (qspec_then ‘m’ mp_tac) >> + gs [] +QED + + + +Theorem step_delay_eval_wait_not_zero: + !t. + FLOOKUP t.locals «isInput» = SOME (ValWord 1w) ∧ + FLOOKUP t.locals «waitSet» = SOME (ValWord 1w) ∧ + (?tm. FLOOKUP t.locals «sysTime» = SOME (ValWord tm)) ∧ + (?tm. FLOOKUP t.locals «wakeUpAt» = SOME (ValWord tm)) ==> + ?w. + eval t wait = SOME (ValWord w) ∧ + w ≠ 0w +Proof + rw [] >> + fs [wait_def, eval_def, OPT_MMAP_def] >> + gs [wordLangTheory.word_op_def] >> + TOP_CASE_TAC >> + fs [] +QED + + +Theorem mod_greater_neq: + tm = (tm + wt) MOD (k:num) ∧ + tm < k ∧ wt < k ∧ + k < tm + wt ⇒ F +Proof + CCONTR_TAC >> gvs [] >> + ‘((tm + wt) - k) MOD k = (tm + wt) MOD k’ by + (irule SUB_MOD >> fs []) >> + pop_assum (fs o single o GSYM) >> + ‘tm + wt − k < k’ by gvs [] >> + fs [] +QED + + +Theorem step_wait_delay_eval_wait_not_zero: + !(t:('a,'b) panSem$state). + FLOOKUP t.locals «isInput» = SOME (ValWord 1w) ∧ + FLOOKUP t.locals «waitSet» = SOME (ValWord 0w) ∧ + (?tm. FLOOKUP t.locals «sysTime» = SOME (ValWord (n2w tm)) ∧ + ?wt. FLOOKUP t.locals «wakeUpAt» = SOME (ValWord (n2w (tm + wt))) ∧ + tm < tm + wt ∧ + wt < dimword (:α) ∧ + tm < dimword (:α)) ==> + ?w. + eval t wait = SOME (ValWord w) ∧ + w ≠ 0w +Proof + rw [] >> + fs [wait_def] >> + fs [eval_def, OPT_MMAP_def] >> + gs [active_low_def, + wordLangTheory.word_op_def] >> + TOP_CASE_TAC >> + fs [] >> + fs [asmTheory.word_cmp_def] >> + fs [addressTheory.WORD_CMP_NORMALISE] >> + fs [word_ls_n2w] >> + ‘wt MOD dimword (:α) = wt’ by ( + match_mp_tac LESS_MOD >> fs []) >> + ‘tm MOD dimword (:α) = tm’ by ( + match_mp_tac LESS_MOD >> fs []) >> + fs [] >> rveq >> gs [] >> + cases_on ‘tm + wt < dimword (:α)’ + >- ( + ‘(tm + wt) MOD dimword (:α) = tm + wt’ by ( + match_mp_tac LESS_MOD >> fs []) >> + gs []) >> + gs [NOT_LESS] >> + gs [LESS_OR_EQ] >> + metis_tac [mod_greater_neq] +QED + + +Theorem state_rel_imp_mem_config: + ∀clks outs io s t. + state_rel clks outs s t ==> + mem_config t.memory t.memaddrs t.be +Proof + rw [state_rel_def] +QED + + +Theorem state_rel_imp_systime_defined: + ∀clks outs io s t. + state_rel clks outs s t ==> + ∃tm. FLOOKUP t.locals «sysTime» = SOME (ValWord tm) +Proof + rw [state_rel_def, time_vars_def] >> + pairarg_tac >> fs [] +QED + +Theorem state_rel_imp_time_vars: + ∀clks outs s t. + state_rel clks outs s t ==> + time_vars t.locals +Proof + rw [state_rel_def] +QED + +Theorem evaluate_ext_call: + ∀(t :('a, time_input) panSem$state) res t' outs bytes. + evaluate (ExtCall «get_time_input» «ptr1» «len1» «ptr2» «len2» ,t) = (res,t') ∧ + read_bytearray ffiBufferAddr (w2n (ffiBufferSize:α word)) + (mem_load_byte t.memory t.memaddrs t.be) = SOME bytes ∧ + t.ffi = build_ffi (:'a) t.be outs t.ffi.ffi_state t.ffi.io_events ∧ + ffi_vars t.locals ∧ good_dimindex (:'a) ⇒ + res = NONE ∧ + t' = t with + <| memory := mem_call_ffi (:α) t.memory t.memaddrs t.be t.ffi.ffi_state + ; ffi := ffi_call_ffi (:α) t.be t.ffi bytes|> +Proof + rpt gen_tac >> + strip_tac >> + fs [good_dimindex_def] >> + (fs [evaluate_def, ffi_vars_def, read_bytearray_def] >> + gs [build_ffi_def, ffiTheory.call_FFI_def] >> + gs [ffiTheory.ffi_state_component_equality] >> + fs [time_input_def] >> + drule read_bytearray_LENGTH >> + strip_tac >> + fs [length_get_bytes] >> + fs [ffiBufferSize_def] >> + fs [bytes_in_word_def, dimword_def] >> + rveq >> + gs [mem_call_ffi_def, ffi_call_ffi_def]) +QED + +Theorem evaluate_assign_load: + ∀dst trgt (t :('a, time_input) panSem$state) res t' adr tm w. + evaluate (Assign dst (Load One (Var trgt)),t) = (res,t') ∧ + FLOOKUP t.locals trgt = SOME (ValWord adr) ∧ + FLOOKUP t.locals dst = SOME (ValWord tm) ∧ + t.memory adr = Word w ∧ + adr ∈ t.memaddrs ⇒ + res = NONE ∧ + t' = t with locals := + t.locals |+ + (dst, ValWord w) +Proof + rpt gen_tac >> + strip_tac >> + gs [evaluate_def, eval_def] >> + gs [mem_load_def] >> + gs [is_valid_value_def, shape_of_def] +QED + + +Theorem evaluate_assign_load_next_address: + ∀dst trgt (t :('a, time_input) panSem$state) res t' adr w. + evaluate (Assign dst + (Load One (Op Add [Var trgt ; Const bytes_in_word])),t) = (res,t') ∧ + FLOOKUP t.locals trgt = SOME (ValWord adr) ∧ + (∃tm. FLOOKUP t.locals dst = SOME (ValWord tm)) ∧ + t.memory (adr + bytes_in_word) = Word w ∧ + adr + bytes_in_word ∈ t.memaddrs ⇒ + res = NONE ∧ + t' = t with locals := + t.locals |+ + (dst, ValWord w) +Proof + rpt gen_tac >> + strip_tac >> + gs [evaluate_def, eval_def, OPT_MMAP_def] >> + gs [mem_load_def, wordLangTheory.word_op_def] >> + gs [is_valid_value_def, shape_of_def] +QED + + +Theorem evaluate_assign_compare_next_address: + ∀dst trgt (t :('a, time_input) panSem$state) res t' adr n. + evaluate (Assign dst + (Cmp Equal + (Load One (Op Add [Var trgt ; Const bytes_in_word])) + (Const n)),t) = (res,t') ∧ + FLOOKUP t.locals trgt = SOME (ValWord adr) ∧ + (∃tm. FLOOKUP t.locals dst = SOME (ValWord tm)) ∧ + t.memory (adr + bytes_in_word) = Word n ∧ + adr + bytes_in_word ∈ t.memaddrs ⇒ + res = NONE ∧ + t' = t with locals := + t.locals |+ + (dst, ValWord 1w) +Proof + rpt gen_tac >> + strip_tac >> + gs [evaluate_def, eval_def, OPT_MMAP_def] >> + gs [mem_load_def, wordLangTheory.word_op_def] >> + gs [is_valid_value_def, shape_of_def] >> + fs [asmTheory.word_cmp_def] +QED + + +Theorem evaluate_assign_compare_next_address_uneq: + ∀dst trgt (t :('a, time_input) panSem$state) res t' adr n n'. + evaluate (Assign dst + (Cmp Equal + (Load One (Op Add [Var trgt ; Const bytes_in_word])) + (Const n)),t) = (res,t') ∧ + FLOOKUP t.locals trgt = SOME (ValWord adr) ∧ + (∃tm. FLOOKUP t.locals dst = SOME (ValWord tm)) ∧ + t.memory (adr + bytes_in_word) = Word n' ∧ + n ≠ n' ∧ + adr + bytes_in_word ∈ t.memaddrs ⇒ + res = NONE ∧ + t' = t with locals := + t.locals |+ + (dst, ValWord 0w) +Proof + rpt gen_tac >> + strip_tac >> + gs [evaluate_def, eval_def, OPT_MMAP_def] >> + gs [mem_load_def, wordLangTheory.word_op_def] >> + gs [is_valid_value_def, shape_of_def] >> + fs [asmTheory.word_cmp_def] +QED + + +Theorem evaluate_if_compare_sys_time: + ∀v m n t res t'. + evaluate + (If (Cmp Equal (Var v) (Const (n2w m))) + (Return (Const 0w)) (Skip:'a panLang$prog),t) = (res,t') ∧ + FLOOKUP t.locals v = SOME (ValWord (n2w n)) ∧ + n < m ∧ + n < dimword (:α) ∧ m < dimword (:α) ⇒ + res = NONE ∧ + t' = t +Proof + rpt gen_tac >> + strip_tac >> + gs [evaluate_def, eval_def, asmTheory.word_cmp_def] >> + every_case_tac >> gs [eval_def, evaluate_def] >> + every_case_tac >> gs [shape_of_def, panLangTheory.size_of_shape_def] +QED + + +Theorem evaluate_if_compare_sys_time1: + ∀v m n t res t'. + evaluate + (If (Cmp Equal (Var v) (Const (n2w m))) + (Return (Const 0w)) (Skip:'a panLang$prog),t) = (res,t') ∧ + FLOOKUP t.locals v = SOME (ValWord (n2w n)) ∧ + n = m ∧ + n < dimword (:α) ∧ m < dimword (:α) ⇒ + res = SOME (Return (ValWord 0w)) ∧ + t' = empty_locals t +Proof + rpt gen_tac >> + strip_tac >> + gs [evaluate_def, eval_def, asmTheory.word_cmp_def] >> + every_case_tac >> gs [eval_def, evaluate_def] >> + every_case_tac >> gs [shape_of_def, panLangTheory.size_of_shape_def] +QED + + + +Theorem time_seq_add_holds: + ∀f m p. + time_seq f m ⇒ + time_seq (λn. f (p + n)) m +Proof + rw [time_seq_def] >> + fs [] >> + last_x_assum (qspec_then ‘p + n’ assume_tac) >> + fs [ADD_SUC] +QED + +(* good be more generic, but its a trivial theorem *) +Theorem read_bytearray_some_bytes_for_ffi: + ∀m adrs be. + good_dimindex (:'a) ∧ + ffiBufferAddr ∈ adrs ∧ + bytes_in_word + ffiBufferAddr ∈ adrs ∧ + (∃w. m ffiBufferAddr = Word w) ∧ + (∃w. m (bytes_in_word + ffiBufferAddr) = Word w) ⇒ + ∃bytes. + read_bytearray (ffiBufferAddr:'a word) (w2n (ffiBufferSize:'a word)) + (mem_load_byte m adrs be) = SOME bytes +Proof + rw [] >> + gs [good_dimindex_def] + >- ( + gs [ffiBufferSize_def, bytes_in_word_def] >> + ‘8 MOD dimword (:α) = 8’ by gs [dimword_def] >> + gs [] >> + pop_assum kall_tac >> + qmatch_goalsub_abbrev_tac ‘read_bytearray _ n _’ >> + pop_assum (mp_tac o SYM o REWRITE_RULE[markerTheory.Abbrev_def]) >> + rpt (pop_assum mp_tac) >> + MAP_EVERY qid_spec_tac [‘m’, ‘adrs’, ‘be’, ‘w’, ‘w'’, ‘n’] >> + Induct + >- (rw [] >> fs []) >> + rpt gen_tac >> + rpt strip_tac >> + rewrite_tac [read_bytearray_def] >> + cases_on ‘n’ >- fs [] >> + rewrite_tac [read_bytearray_def] >> + cases_on ‘n'’ >- fs [] >> + rewrite_tac [read_bytearray_def] >> + cases_on ‘n’ >- fs [] >> + rewrite_tac [read_bytearray_def] >> + cases_on ‘n'’ >- fs [] >> + rewrite_tac [read_bytearray_def] >> + cases_on ‘n’ >- fs [] >> + rewrite_tac [read_bytearray_def] >> + cases_on ‘n'’ >- fs [] >> + rewrite_tac [read_bytearray_def] >> + cases_on ‘n’ >- fs [] >> + rewrite_tac [read_bytearray_def] >> + fs [] >> + cases_on ‘n'’ >> fs [] >> + fs [ffiBufferAddr_def] >> + fs [mem_load_byte_def] >> + ‘byte_align (4000w:'a word) = 4000w ∧ + byte_align (4001w:'a word) = 4000w ∧ + byte_align (4002w:'a word) = 4000w ∧ + byte_align (4003w:'a word) = 4000w ∧ + byte_align (4004w:'a word) = 4004w ∧ + byte_align (4005w:'a word) = 4004w ∧ + byte_align (4006w:'a word) = 4004w ∧ + byte_align (4007w:'a word) = 4004w’ by ( + fs [byte_align_def] >> + fs [align_def] >> + EVAL_TAC >> + gs [dimword_def] >> + EVAL_TAC) >> + fs [read_bytearray_def]) >> + gs [ffiBufferSize_def, bytes_in_word_def] >> + ‘16 MOD dimword (:α) = 16’ by gs [dimword_def] >> + gs [] >> + pop_assum kall_tac >> + qmatch_goalsub_abbrev_tac ‘read_bytearray _ n _’ >> + pop_assum (mp_tac o SYM o REWRITE_RULE[markerTheory.Abbrev_def]) >> + rpt (pop_assum mp_tac) >> + MAP_EVERY qid_spec_tac [‘m’, ‘adrs’, ‘be’, ‘w’, ‘w'’, ‘n’] >> + Induct + >- (rw [] >> fs []) >> + rpt gen_tac >> + rpt strip_tac >> + rewrite_tac [read_bytearray_def] >> + cases_on ‘n’ >- fs [] >> + rewrite_tac [read_bytearray_def] >> + cases_on ‘n'’ >- fs [] >> + rewrite_tac [read_bytearray_def] >> + cases_on ‘n’ >- fs [] >> + rewrite_tac [read_bytearray_def] >> + cases_on ‘n'’ >- fs [] >> + rewrite_tac [read_bytearray_def] >> + cases_on ‘n’ >- fs [] >> + rewrite_tac [read_bytearray_def] >> + cases_on ‘n'’ >- fs [] >> + rewrite_tac [read_bytearray_def] >> + cases_on ‘n’ >- fs [] >> + rewrite_tac [read_bytearray_def] >> + cases_on ‘n'’ >- fs [] >> + rewrite_tac [read_bytearray_def] >> + cases_on ‘n’ >- fs [] >> + rewrite_tac [read_bytearray_def] >> + cases_on ‘n'’ >- fs [] >> + rewrite_tac [read_bytearray_def] >> + cases_on ‘n’ >- fs [] >> + rewrite_tac [read_bytearray_def] >> + cases_on ‘n'’ >- fs [] >> + rewrite_tac [read_bytearray_def] >> + cases_on ‘n’ >- fs [] >> + rewrite_tac [read_bytearray_def] >> + cases_on ‘n'’ >- fs [] >> + rewrite_tac [read_bytearray_def] >> + cases_on ‘n’ >- fs [] >> + rewrite_tac [read_bytearray_def] >> + fs [] >> + cases_on ‘n'’ >> fs [] >> + fs [ffiBufferAddr_def] >> + fs [mem_load_byte_def] >> + ‘byte_align (4000w:'a word) = 4000w ∧ + byte_align (4001w:'a word) = 4000w ∧ + byte_align (4002w:'a word) = 4000w ∧ + byte_align (4003w:'a word) = 4000w ∧ + byte_align (4004w:'a word) = 4000w ∧ + byte_align (4005w:'a word) = 4000w ∧ + byte_align (4006w:'a word) = 4000w ∧ + byte_align (4007w:'a word) = 4000w’ by ( + fs [byte_align_def] >> + fs [align_def] >> + EVAL_TAC >> + gs [dimword_def] >> + EVAL_TAC) >> + ‘byte_align (4008w:'a word) = 4008w ∧ + byte_align (4009w:'a word) = 4008w ∧ + byte_align (4010w:'a word) = 4008w ∧ + byte_align (4011w:'a word) = 4008w ∧ + byte_align (4012w:'a word) = 4008w ∧ + byte_align (4013w:'a word) = 4008w ∧ + byte_align (4014w:'a word) = 4008w ∧ + byte_align (4015w:'a word) = 4008w’ by ( + fs [byte_align_def] >> + fs [align_def] >> + EVAL_TAC >> + gs [dimword_def] >> + EVAL_TAC) >> + fs [read_bytearray_def] +QED + +Theorem ffi_abs_mono: + ∀j i (f:num -> num). + i < j ∧ + (∀n. + ∃d. + f (SUC n) = + d + f n) ⇒ + f i ≤ f j +Proof + Induct >> + rw [] >> + fs [] >> + cases_on ‘i < j’ + >- ( + last_x_assum drule >> + disch_then (qspec_then ‘f’ mp_tac) >> + impl_tac >- gs [] >> + strip_tac >> + last_x_assum (qspec_then ‘j’ mp_tac) >> + strip_tac >> gs []) >> + cases_on ‘i = j’ + >- ( + rveq >> + gs [] >> + first_x_assum (qspec_then ‘i’ assume_tac) >> + gs []) >> + gs [] +QED + + + +Theorem sum_mod_eq_lt_eq: + (a + b) MOD k = (a + c) MOD (k:num) ∧ + a < k ∧ + b < k ∧ + c < k ⇒ + b = c +Proof + once_rewrite_tac [ADD_COMM] >> + reverse (Cases_on ‘0 < k’) + >- fs [] >> + drule ADD_MOD >> + disch_then (fs o single) >> + rw [] >> fs [] +QED + + + +(* wakeup rel need to be updated *) +Theorem step_delay_loop: + !cycles prog d m n s s' (t:('a,time_input) panSem$state) ck0 ist. + step prog (LDelay d) m n s s' ∧ + m = dimword (:α) - 1 ∧ + n = FST (t.ffi.ffi_state 0) ∧ + state_rel (clksOf prog) (out_signals prog) s t ∧ + code_installed t.code prog ∧ + delay_rep d t.ffi.ffi_state cycles ∧ + wakeup_shape t.locals s.waitTime ist ∧ + wakeup_rel t.locals s.waitTime ist t.ffi.ffi_state cycles ∧ + mem_read_ffi_results (:α) t.ffi.ffi_state cycles ∧ + FLOOKUP t.locals «isInput» = SOME (ValWord 1w) ∧ + FLOOKUP t.locals «event» = SOME (ValWord 0w) ∧ + good_dimindex (:'a) ==> + ?ck t'. + (∀ck_extra. + evaluate (wait_input_time_limit, t with clock := t.clock + ck + ck_extra) = + evaluate (wait_input_time_limit, t' with clock := t'.clock + ck_extra + ck0)) ∧ + code_installed t'.code prog ∧ + state_rel (clksOf prog) (out_signals prog) s' t' ∧ + t'.ffi.ffi_state = nexts_ffi cycles t.ffi.ffi_state ∧ + t'.ffi.oracle = t.ffi.oracle ∧ + t'.code = t.code ∧ + t'.be = t.be ∧ + t'.eshapes = t.eshapes ∧ + FLOOKUP t'.locals «wakeUpAt» = FLOOKUP t.locals «wakeUpAt» ∧ + FLOOKUP t'.locals «waitSet» = FLOOKUP t.locals «waitSet» ∧ + FLOOKUP t'.locals «isInput» = SOME (ValWord 1w) ∧ + FLOOKUP t'.locals «event» = SOME (ValWord 0w) ∧ + FLOOKUP t'.locals «taskRet» = FLOOKUP t.locals «taskRet» ∧ + FLOOKUP t'.locals «sysTime» = + SOME (ValWord (n2w (FST (t.ffi.ffi_state cycles)))) ∧ + wait_time_locals1 (:α) t'.locals s'.waitTime + ist (FST (t.ffi.ffi_state cycles)) ∧ + (t.ffi.io_events ≠ [] ∧ + EL 0 (io_event_dest (:α) t.be (LAST t.ffi.io_events)) = FST (t.ffi.ffi_state 0) ⇒ + delay_io_events_rel t t' cycles ∧ + obs_ios_are_label_delay d t t') +Proof + Induct_on ‘cycles’ >> + fs [] + >- ( + rw [] >> + fs [delay_rep_def] >> + ‘d = 0’ by fs [] >> + fs [] >> + pop_assum kall_tac >> + fs [step_cases] >> + fs [delay_clocks_def, mkState_def] >> + rveq >> gs [] >> + fs [fmap_to_alist_eq_fm] >> + qexists_tac ‘ck0’ >> fs [] >> + qexists_tac ‘t’ >> fs [] >> + gs [state_rel_def, nexts_ffi_def, GSYM ETA_AX] >> + pairarg_tac >> gs [] >> + gs [delay_io_events_rel_def, mk_ti_events_def, gen_ffi_states_def, + io_events_eq_ffi_seq_def, from_io_events_def, io_events_dest_def, + io_event_dest_def, DROP_LENGTH_NIL] >> + gs [obs_ios_are_label_delay_def, DROP_LENGTH_NIL, + decode_io_events_def, delay_ios_mono_def] >> + gs [wait_time_locals1_def] + >- ( + gs [wakeup_shape_def] >> + qexists_tac ‘wt'’ >> + gs []) >> + gs [wakeup_shape_def] >> + qexists_tac ‘wt'’ >> + gs [] >> + strip_tac >> + gs [wakeup_rel_def]) >> + rw [] >> + ‘∃sd. sd ≤ d ∧ + delay_rep sd t.ffi.ffi_state cycles’ by ( + fs [delay_rep_def] >> + imp_res_tac state_rel_imp_time_seq_ffi >> + ‘FST (t.ffi.ffi_state 0) ≤ FST (t.ffi.ffi_state cycles)’ by ( + match_mp_tac time_seq_mono >> + qexists_tac ‘(dimword (:α))’ >> + fs []) >> + fs [time_seq_def] >> + first_x_assum (qspec_then ‘cycles’ mp_tac) >> + first_x_assum (qspec_then ‘cycles’ mp_tac) >> + strip_tac >> strip_tac >> + gs [] >> + qexists_tac ‘d - d'’ >> + gs [] >> + qexists_tac ‘st’ >> fs []) >> + qpat_x_assum ‘step _ _ _ _ _ _’ mp_tac >> + rewrite_tac [step_cases] >> + strip_tac >> + fs [] >> rveq + >- ( + ‘step prog (LDelay sd) (dimword (:α) - 1) (FST (t.ffi.ffi_state 0)) s + (mkState (delay_clocks s.clocks sd) s.location NONE NONE)’ by ( + gs [mkState_def] >> + fs [step_cases, mkState_def, max_clocks_def] >> + gs [delay_clocks_def] >> + rw [] >> + gs [flookup_update_list_some] >> + drule ALOOKUP_MEM >> + strip_tac >> + gs [GSYM MAP_REVERSE] >> + gs [MEM_MAP] >> + cases_on ‘y’ >> gs [] >> + rveq >> gs [] >> + first_x_assum (qspecl_then [‘ck’, + ‘r + (d + FST (t.ffi.ffi_state 0))’] mp_tac) >> + impl_tac + >- ( + match_mp_tac ALOOKUP_ALL_DISTINCT_MEM >> + gs [] >> + conj_tac + >- ( + gs [MAP_REVERSE] >> + ‘MAP FST (MAP (λ(x,y). (x,d + (y + FST (t.ffi.ffi_state 0)))) + (fmap_to_alist s.clocks)) = + MAP FST (fmap_to_alist s.clocks)’ by fs [map_fst] >> + gs []) >> + gs [MEM_MAP] >> + qexists_tac ‘(ck,r)’ >> + gs []) >> + strip_tac >> + gs []) >> + last_x_assum drule >> + (* ck0 *) + disch_then (qspecl_then [‘ck0 + 1’, ‘ist’] mp_tac) >> + impl_tac + >- ( + gs [mkState_def, wakeup_rel_def, mem_read_ffi_results_def] >> + rpt gen_tac >> + strip_tac >> + last_x_assum (qspecl_then [‘i’,‘t'’, ‘t''’] mp_tac) >> + gs []) >> + strip_tac >> fs [] >> + ‘(mkState (delay_clocks s.clocks d) s.location NONE NONE).ioAction = + NONE’ by fs [mkState_def] >> + fs [] >> + pop_assum kall_tac >> + ‘(mkState (delay_clocks s.clocks sd) s.location NONE NONE).ioAction = + NONE’ by fs [mkState_def] >> + fs [] >> + pop_assum kall_tac >> + qexists_tac ‘ck’ >> + fs [] >> + qpat_x_assum ‘∀ck_extra. _’ kall_tac >> + drule state_rel_imp_mem_config >> + rewrite_tac [Once mem_config_def] >> + strip_tac >> + fs [] >> + ‘∃bytes. + read_bytearray ffiBufferAddr (w2n (ffiBufferSize:'a word)) + (mem_load_byte t'.memory t'.memaddrs t'.be) = SOME bytes’ by ( + match_mp_tac read_bytearray_some_bytes_for_ffi >> + gs []) >> + gvs [] >> + qabbrev_tac + ‘new_t:('a,time_input) panSem$state = + t' with + <|locals := + t'.locals |+ + («sysTime» , + ValWord (n2w (FST (nexts_ffi cycles t.ffi.ffi_state 1)))) |+ + («event» , + ValWord (n2w (SND (nexts_ffi cycles t.ffi.ffi_state 1)))) |+ + («isInput» ,ValWord 1w); + memory := + mem_call_ffi (:α) t'.memory t'.memaddrs t.be + (nexts_ffi cycles t.ffi.ffi_state); + ffi := ffi_call_ffi (:α) t.be t'.ffi bytes|>’ >> + qexists_tac ‘new_t’ >> + fs [PULL_FORALL] >> + gen_tac >> gs [] >> + fs [wait_input_time_limit_def] >> + rewrite_tac [Once evaluate_def] >> + drule step_delay_eval_wait_not_zero >> + impl_tac + >- ( + gs [state_rel_def, mkState_def, equivs_def, time_vars_def, active_low_def] >> + pairarg_tac >> gs []) >> + strip_tac >> + gs [eval_upd_clock_eq] >> + gs [dec_clock_def] >> + (* evaluating the function *) + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + ‘state_rel (clksOf prog) (out_signals prog) + (mkState (delay_clocks s.clocks sd) s.location NONE NONE) + (t' with clock := ck_extra + t'.clock)’ by gs [state_rel_def] >> + qpat_x_assum ‘state_rel _ _ _ t'’ kall_tac >> + rewrite_tac [Once check_input_time_def] >> + fs [panLangTheory.nested_seq_def] >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + drule evaluate_ext_call >> + disch_then (qspecl_then [‘MAP explode (out_signals prog)’,‘bytes’] mp_tac) >> + impl_tac + >- ( + gs [state_rel_def] >> + pairarg_tac >> gs []) >> + strip_tac >> gvs [] >> + drule state_rel_imp_ffi_vars >> + strip_tac >> + pop_assum mp_tac >> + rewrite_tac [Once ffi_vars_def] >> + strip_tac >> + drule state_rel_imp_systime_defined >> + strip_tac >> + (* reading systime *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «sysTime» _, nt)’ >> + ‘nt.memory ffiBufferAddr = Word (n2w (FST(t'.ffi.ffi_state 1)))’ by ( + fs [Abbr ‘nt’] >> + qpat_x_assum ‘mem_read_ffi_results _ _ _’ assume_tac >> + gs [mem_read_ffi_results_def] >> + qmatch_asmsub_abbrev_tac ‘evaluate (ExtCall _ _ _ _ _, _) = (_, ft)’ >> + last_x_assum + (qspecl_then + [‘cycles’, + ‘t' with clock := ck0 + ck_extra + t'.clock’, + ‘ft’] mp_tac)>> + impl_tac + >- gs [Abbr ‘ft’] >> + strip_tac >> + gs [Abbr ‘ft’]) >> + drule evaluate_assign_load >> + gs [] >> + disch_then (qspecl_then + [‘ffiBufferAddr’, ‘tm’, + ‘n2w (FST (t'.ffi.ffi_state 1))’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nt’] >> + fs [state_rel_def]) >> + strip_tac >> fs [] >> + gvs [] >> + (* reading input to the variable event *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «event» _, nnt)’ >> + ‘nnt.memory (ffiBufferAddr + bytes_in_word) = + Word (n2w (SND(t'.ffi.ffi_state 1)))’ by ( + fs [Abbr ‘nnt’, Abbr ‘nt’] >> + qpat_x_assum ‘mem_read_ffi_results _ _ _’ assume_tac >> + gs [mem_read_ffi_results_def] >> + qmatch_asmsub_abbrev_tac ‘evaluate (ExtCall _ _ _ _ _, _) = (_, ft)’ >> + last_x_assum + (qspecl_then + [‘cycles’, + ‘t' with clock := ck0 + ck_extra + t'.clock’, + ‘ft’] mp_tac)>> + impl_tac + >- gs [Abbr ‘ft’] >> + strip_tac >> + gs [Abbr ‘ft’]) >> + gs [] >> + drule evaluate_assign_load_next_address >> + gs [] >> + disch_then (qspecl_then + [‘ffiBufferAddr’, + ‘n2w (SND (nexts_ffi cycles t.ffi.ffi_state 1))’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nnt’,Abbr ‘nt’, active_low_def] >> + gs [state_rel_def, time_vars_def, FLOOKUP_UPDATE] >> + gs [delay_rep_def, nexts_ffi_def]) >> + strip_tac >> gvs [] >> + (* isInput *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «isInput» _, nnnt)’ >> + ‘nnnt.memory (ffiBufferAddr + bytes_in_word) = + Word (n2w (SND(t'.ffi.ffi_state 1)))’ by fs [Abbr ‘nnnt’] >> + gs [] >> + ‘nnnt.memory (ffiBufferAddr + bytes_in_word) = Word 0w’ by ( + gs [delay_rep_def] >> + fs [nexts_ffi_def]) >> + fs [] >> + drule evaluate_assign_compare_next_address >> + gs [] >> + disch_then (qspecl_then [‘ffiBufferAddr’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nnnt’, Abbr ‘nnt’,Abbr ‘nt’, active_low_def] >> + gs [state_rel_def, time_vars_def, FLOOKUP_UPDATE] >> + gs [delay_rep_def, nexts_ffi_def]) >> + strip_tac >> gvs [] >> + (* If statement *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + drule evaluate_if_compare_sys_time >> + disch_then (qspec_then ‘FST (nexts_ffi cycles t.ffi.ffi_state 1)’ mp_tac) >> + impl_tac + >- ( + unabbrev_all_tac >> + gs [FLOOKUP_UPDATE, nexts_ffi_def] >> + gs [delay_rep_def, ADD1]) >> + strip_tac >> rveq >> gs [] >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + strip_tac >> fs [] >> + rveq >> gs [] >> + unabbrev_all_tac >> + gs [] >> gvs [] >> + reverse conj_tac + >- ( + fs [ffi_call_ffi_def] >> + fs [nexts_ffi_def, next_ffi_def, FLOOKUP_UPDATE] >> + fs [ADD1] >> + conj_asm1_tac + >- ( + gs [wait_time_locals1_def, FLOOKUP_UPDATE, mkState_def] >> + qexists_tac ‘wt’ >> gs []) >> + strip_tac >> gs [] >> + conj_asm1_tac + >- ( + fs [delay_io_events_rel_def] >> + conj_asm1_tac + >- ( + qexists_tac ‘bytess ++ [bytes]’ >> + gs [] >> + drule read_bytearray_LENGTH >> + strip_tac >> + conj_asm1_tac + >- ( + gs [ffiBufferSize_def, bytes_in_word_def] >> + gs [good_dimindex_def, dimword_def]) >> + gs [mk_ti_events_def] >> + ‘gen_ffi_states t.ffi.ffi_state (LENGTH bytess + 1) = + gen_ffi_states t.ffi.ffi_state (LENGTH bytess) ++ + [(λn. t.ffi.ffi_state (n + LENGTH bytess))]’ by ( + fs [gen_ffi_states_def] >> + gs [GSYM ADD1, GENLIST]) >> + gs [] >> + ‘LENGTH [bytes] = LENGTH [(λn. t.ffi.ffi_state (n + LENGTH bytess))] ∧ + LENGTH bytess = LENGTH (gen_ffi_states t.ffi.ffi_state (LENGTH bytess))’ by + gs [gen_ffi_states_def] >> + drule ZIP_APPEND >> + disch_then (qspecl_then [‘[bytes]’, + ‘[(λn. t.ffi.ffi_state (n + LENGTH bytess))]’] mp_tac) >> + impl_tac + >- gs [] >> + strip_tac >> + pop_assum (assume_tac o GSYM) >> + gs [mk_ti_event_def, time_input_def]) >> + (* proving io_events rel *) + gs [from_io_events_def] >> + rewrite_tac [GSYM APPEND_ASSOC] >> + gs [DROP_LENGTH_APPEND] >> + gs [mk_ti_events_def, io_events_dest_def] >> + gs [MAP_MAP_o] >> + gs [io_events_eq_ffi_seq_def] >> + gs [gen_ffi_states_def] >> + gs [EVERY_MEM] >> + rw [] >> gs [] + >- ( + gs [MEM_MAP] >> + drule MEM_ZIP2 >> + strip_tac >> gs [] >> + gs [mk_ti_event_def, io_event_dest_def] >> + qmatch_goalsub_abbrev_tac ‘ZIP (nn, mm)’ >> + ‘LENGTH nn = LENGTH mm’ by ( + fs [Abbr ‘nn’, Abbr ‘mm’] >> + first_x_assum (qspec_then ‘EL n bytess'’ mp_tac) >> + impl_tac + >- ( + gs [MEM_EL] >> + metis_tac []) >> + strip_tac >> gs [] >> + gs [time_input_def, length_get_bytes] >> + gs [good_dimindex_def]) >> + ‘MAP SND (ZIP (nn,mm)) = mm’ by ( + drule MAP_ZIP >> + gs []) >> + gs [] >> + gs [words_of_bytes_def] >> + ‘8 ≤ dimindex (:α)’ by gs [good_dimindex_def] >> + drule LENGTH_words_of_bytes >> + disch_then (qspecl_then [‘t.be’, ‘mm’] mp_tac) >> + strip_tac >> gs [] >> + gs [Abbr ‘mm’, time_input_def, length_get_bytes, bytes_in_word_def, + good_dimindex_def, dimword_def]) + >- ( + qpat_x_assum ‘MAP _ _ ++ _ = _’ (assume_tac o GSYM) >> + gs [GSYM MAP_MAP_o] >> + cases_on ‘i < LENGTH bytess’ + >- ( + last_x_assum (qspec_then ‘i’ mp_tac) >> + impl_tac >- gs [] >> + strip_tac >> + gs [EL_APPEND_EQN]) >> + gs [EL_APPEND_EQN] >> + ‘i − LENGTH bytess = 0’ by gs [] >> + simp [] >> + gs [io_event_dest_def] >> + qmatch_goalsub_abbrev_tac ‘ZIP (nn, mm)’ >> + ‘LENGTH nn = LENGTH mm’ by ( + fs [Abbr ‘nn’, Abbr ‘mm’] >> + drule read_bytearray_LENGTH >> + strip_tac >> + gs [length_get_bytes, ffiBufferSize_def, + good_dimindex_def, bytes_in_word_def, dimword_def]) >> + ‘MAP SND (ZIP (nn,mm)) = mm’ by ( + drule MAP_ZIP >> + gs []) >> + gs [Abbr ‘mm’] >> + qmatch_goalsub_abbrev_tac ‘get_bytes t.be aa ++ get_bytes t.be bb’ >> + ‘words_of_bytes t.be (get_bytes t.be aa ++ get_bytes t.be bb) = + [aa;bb]’ by ( + match_mp_tac words_of_bytes_get_bytes >> + gs []) >> + gs [Abbr ‘aa’, Abbr ‘bb’] >> + gs [delay_rep_def] >> + cases_on ‘t.ffi.ffi_state (i+1)’ >> gs [] >> + last_x_assum (qspec_then ‘i + 1’ mp_tac) >> + gs [] >> + strip_tac >> + qpat_x_assum ‘_ = d + FST (t.ffi.ffi_state 0)’ (mp_tac o GSYM) >> + gs [] >> + strip_tac >> + ‘LENGTH bytess = i’ by gs [] >> + simp []) >> + gs [decode_io_events_def] >> + gs [MAP_MAP_o] >> + qmatch_goalsub_abbrev_tac ‘EL n (MAP f l)’ >> + ‘EL n (MAP f l) = f (EL n l)’ by ( + match_mp_tac EL_MAP >> + gs [Abbr ‘f’, Abbr ‘l’]) >> + gs [Abbr ‘f’, Abbr ‘l’] >> + qmatch_goalsub_abbrev_tac ‘ZIP (l1, l2)’ >> + ‘EL n (ZIP (l1,l2)) = (EL n l1,EL n l2)’ by ( + match_mp_tac EL_ZIP >> + gs [Abbr ‘l1’, Abbr ‘l2’]) >> + gs [Abbr ‘l1’, Abbr ‘l2’] >> + qmatch_goalsub_abbrev_tac ‘EL n (MAP f l)’ >> + ‘EL n (MAP f l) = f (EL n l)’ by ( + match_mp_tac EL_MAP >> + gs [Abbr ‘f’, Abbr ‘l’]) >> + gs [Abbr ‘f’, Abbr ‘l’] >> + gs [mk_ti_event_def, decode_io_event_def] >> + qmatch_goalsub_abbrev_tac ‘EL 1 nio’ >> + ‘EL 1 nio = 0’ by ( + gs [Abbr ‘nio’, io_event_dest_def] >> + qmatch_goalsub_abbrev_tac ‘ZIP (nn, mm)’ >> + ‘LENGTH nn = LENGTH mm’ by ( + fs [Abbr ‘nn’, Abbr ‘mm’] >> + gs [time_input_def, length_get_bytes] >> + first_x_assum (qspec_then ‘EL n bytess'’ mp_tac) >> + impl_tac >- metis_tac [MEM_EL] >> + gs [good_dimindex_def]) >> + ‘MAP SND (ZIP (nn,mm)) = mm’ by ( + drule MAP_ZIP >> + gs []) >> + gs [Abbr ‘nn’, Abbr ‘mm’] >> + gs [time_input_def] >> + qmatch_goalsub_abbrev_tac ‘get_bytes t.be aa ++ get_bytes t.be bb’ >> + ‘words_of_bytes t.be (get_bytes t.be aa ++ get_bytes t.be bb) = + [aa;bb]’ by ( + match_mp_tac words_of_bytes_get_bytes >> + gs []) >> + gs [Abbr ‘aa’, Abbr ‘bb’] >> + gs [delay_rep_def]) >> + gs [Abbr ‘nio’] >> + gs [io_event_dest_def] >> + qmatch_goalsub_abbrev_tac ‘ZIP (nn, mm)’ >> + ‘LENGTH nn = LENGTH mm’ by ( + fs [Abbr ‘nn’, Abbr ‘mm’] >> + gs [time_input_def, length_get_bytes] >> + first_x_assum (qspec_then ‘EL n bytess'’ mp_tac) >> + impl_tac >- metis_tac [MEM_EL] >> + gs [good_dimindex_def]) >> + ‘MAP SND (ZIP (nn,mm)) = mm’ by ( + drule MAP_ZIP >> + gs []) >> + gs [Abbr ‘nn’, Abbr ‘mm’] >> + gs [time_input_def, length_get_bytes] >> + qmatch_goalsub_abbrev_tac ‘get_bytes t.be aa ++ get_bytes t.be bb’ >> + ‘words_of_bytes t.be (get_bytes t.be aa ++ get_bytes t.be bb) = + [aa;bb]’ by ( + match_mp_tac words_of_bytes_get_bytes >> + gs []) >> + gs [Abbr ‘aa’, Abbr ‘bb’] >> + last_x_assum assume_tac >> + gs [state_rel_def] >> + pairarg_tac >> gs [] >> + gs [time_seq_def]) >> + gs [obs_ios_are_label_delay_def] >> + reverse conj_tac + >- ( + pop_assum mp_tac >> + once_rewrite_tac [delay_io_events_rel_def] >> + fs [] >> + strip_tac >> + qmatch_goalsub_abbrev_tac ‘EL n ios’ >> + strip_tac >> + first_x_assum (qspec_then ‘n’ mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘ios’, Abbr ‘n’] >> + rewrite_tac [GSYM APPEND_ASSOC] >> + gs [DROP_LENGTH_APPEND] >> + gs [decode_io_events_def, mk_ti_events_def, gen_ffi_states_def]) >> + gs [] >> + strip_tac >> + gs [to_delay_def] >> + gs [Abbr ‘n’, Abbr ‘ios’, DROP_LENGTH_APPEND] >> + gs [decode_io_events_def, mk_ti_events_def, gen_ffi_states_def] >> + gs [delay_rep_def]) >> + pop_assum mp_tac >> + once_rewrite_tac [delay_io_events_rel_def] >> + fs [] >> + strip_tac >> + simp [delay_ios_mono_def] >> + rw [] >> + last_x_assum assume_tac >> + gs [state_rel_def] >> + pairarg_tac >> gs [] >> + gs [time_seq_def] >> + ‘(λx. FST (t.ffi.ffi_state x)) (i + 1) ≤ (λx. FST (t.ffi.ffi_state x)) (j + 1)’ by ( + match_mp_tac ffi_abs_mono >> + gs []) >> + gs []) >> + (* proving state rel *) + gs [state_rel_def, mkState_def] >> + conj_tac + (* equivs *) + >- gs [equivs_def, FLOOKUP_UPDATE, active_low_def] >> + conj_tac + >- gs [ffi_vars_def, FLOOKUP_UPDATE] >> + conj_tac + >- gs [time_vars_def, FLOOKUP_UPDATE] >> + conj_tac + >- gs [mem_config_def, mem_call_ffi_def] >> + conj_tac + >- ( + (* clock_bound *) + qpat_x_assum ‘defined_clocks s.clocks _’ assume_tac >> + gs [defined_clocks_def] >> + fs [EVERY_MEM] >> + rw [] >> + first_x_assum drule >> + strip_tac >> + fs [] >> + fs [delay_clocks_def] >> + qexists_tac ‘d+n’ >> + gs [] >> + match_mp_tac mem_to_flookup >> + ‘MAP FST (MAP (λ(x,y). (x,d + y)) (fmap_to_alist s.clocks)) = + MAP FST (fmap_to_alist s.clocks)’ by fs [map_fst] >> + fs [ALL_DISTINCT_fmap_to_alist_keys] >> + fs [MEM_MAP] >> + qexists_tac ‘(ck,n)’ >> + fs []) >> + pairarg_tac >> gs [] >> + conj_tac + >- ( + fs [ffi_call_ffi_def, build_ffi_def] >> + fs [ffiTheory.ffi_state_component_equality] >> + last_x_assum assume_tac >> + pairarg_tac >> + fs [] >> + pairarg_tac >> + fs []) >> + conj_tac + >- ( + (* input_time_rel *) + gs [input_time_rel_def] >> + rw [] >> + gs [input_time_eq_def, ffi_call_ffi_def, next_ffi_def, nexts_ffi_def, + has_input_def] >> + strip_tac >> + pairarg_tac >> gs [] >> + first_x_assum (qspec_then ‘n+1’ mp_tac) >> + impl_tac >- gs [] >> + gs []) >> + conj_tac + >- ( + (* time_seq holds *) + gs [ffi_call_ffi_def, + nexts_ffi_def, next_ffi_def] >> + qpat_x_assum ‘_ (t.ffi.ffi_state 0)’ mp_tac >> + pairarg_tac >> gs [] >> + strip_tac >> + drule time_seq_add_holds >> + disch_then (qspec_then ‘cycles + 1’ mp_tac) >> + fs []) >> + (* clocks_rel *) + qpat_x_assum ‘_ (nexts_ffi _ _ _)’ assume_tac >> + gs [clocks_rel_def, FLOOKUP_UPDATE, + nexts_ffi_def, ffi_call_ffi_def, next_ffi_def, time_seq_def] >> + pairarg_tac >> gs [] >> rveq >> gs [] >> + qexists_tac ‘ns’ >> + fs [] >> + fs [clkvals_rel_def] >> + conj_tac + >- ( + fs [MAP_EQ_EVERY2] >> + fs [LIST_REL_EL_EQN] >> + rw [] >> + pairarg_tac >> fs [] >> + last_x_assum drule >> + fs [] >> + strip_tac >> + (* shortcut *) + ‘∃xn. FLOOKUP s.clocks x = SOME xn’ by ( + drule EL_ZIP >> + disch_then (qspec_then ‘n’ mp_tac) >> + gs [] >> + strip_tac >> + gs [defined_clocks_def] >> + fs [EVERY_MEM] >> + fs [MEM_EL] >> + last_x_assum (qspec_then ‘x’ mp_tac) >> + fs [] >> + impl_tac >- metis_tac [] >> + gs [FDOM_FLOOKUP]) >> + fs [delay_clocks_def] >> + ‘FLOOKUP (FEMPTY |++ MAP (λ(x,y). (x,d + y)) (fmap_to_alist s.clocks)) + x = SOME (d + xn)’ by ( + match_mp_tac mem_to_flookup >> + ‘MAP FST (MAP (λ(x,y). (x,d + y)) (fmap_to_alist s.clocks)) = + MAP FST (fmap_to_alist s.clocks)’ by fs [map_fst] >> + fs [ALL_DISTINCT_fmap_to_alist_keys] >> + fs [MEM_MAP] >> + qexists_tac ‘(x,xn)’ >> + fs []) >> + fs [] >> + ‘FLOOKUP (FEMPTY |++ MAP (λ(x,y). (x,sd + y)) (fmap_to_alist s.clocks)) + x = SOME (sd + xn)’ by ( + match_mp_tac mem_to_flookup >> + ‘MAP FST (MAP (λ(x,y). (x,sd + y)) (fmap_to_alist s.clocks)) = + MAP FST (fmap_to_alist s.clocks)’ by fs [map_fst] >> + fs [ALL_DISTINCT_fmap_to_alist_keys] >> + fs [MEM_MAP] >> + qexists_tac ‘(x,xn)’ >> + fs []) >> + fs [] >> + fs [ffi_call_ffi_def, next_ffi_def] >> + qpat_x_assum ‘delay_rep d _ _’ assume_tac >> + qpat_x_assum ‘delay_rep sd _ _’ assume_tac >> + qpat_x_assum ‘sd ≤ d’ assume_tac >> + gs [delay_rep_def] >> + gs [ADD1]) >> + (* repetition *) + fs [EVERY_MEM] >> + rw [] >> + first_x_assum (qspec_then ‘x’ assume_tac) >> + gs [] >> + ‘∃xn. FLOOKUP s.clocks x = SOME xn’ by ( + gs [defined_clocks_def] >> + gs [EVERY_MEM]) >> + fs [delay_clocks_def] >> + ‘FLOOKUP (FEMPTY |++ MAP (λ(x,y). (x,d + y)) (fmap_to_alist s.clocks)) + x = SOME (d + xn)’ by ( + match_mp_tac mem_to_flookup >> + ‘MAP FST (MAP (λ(x,y). (x,d + y)) (fmap_to_alist s.clocks)) = + MAP FST (fmap_to_alist s.clocks)’ by fs [map_fst] >> + fs [ALL_DISTINCT_fmap_to_alist_keys] >> + fs [MEM_MAP] >> + qexists_tac ‘(x,xn)’ >> + fs []) >> + fs [] >> + ‘FLOOKUP (FEMPTY |++ MAP (λ(x,y). (x,sd + y)) (fmap_to_alist s.clocks)) + x = SOME (sd + xn)’ by ( + match_mp_tac mem_to_flookup >> + ‘MAP FST (MAP (λ(x,y). (x,sd + y)) (fmap_to_alist s.clocks)) = + MAP FST (fmap_to_alist s.clocks)’ by fs [map_fst] >> + fs [ALL_DISTINCT_fmap_to_alist_keys] >> + fs [MEM_MAP] >> + qexists_tac ‘(x,xn)’ >> + fs []) >> + fs [] >> + fs [ffi_call_ffi_def, next_ffi_def] >> + qpat_x_assum ‘delay_rep d _ _’ assume_tac >> + qpat_x_assum ‘delay_rep sd _ _’ assume_tac >> + qpat_x_assum ‘sd ≤ d’ assume_tac >> + gs [delay_rep_def] >> + gs [ADD1]) >> + ‘step prog (LDelay sd) (dimword (:α) - 1) (FST (t.ffi.ffi_state 0)) s + (mkState (delay_clocks s.clocks sd) s.location NONE (SOME (w - sd)))’ by ( + gs [mkState_def] >> + fs [step_cases, mkState_def, max_clocks_def] >> + gs [delay_clocks_def] >> + rw [] >> + gs [flookup_update_list_some] >> + drule ALOOKUP_MEM >> + strip_tac >> + gs [GSYM MAP_REVERSE] >> + gs [MEM_MAP] >> + cases_on ‘y’ >> gs [] >> + rveq >> gs [] >> + first_x_assum (qspecl_then [‘ck’, + ‘r + (d + FST (t.ffi.ffi_state 0))’] mp_tac) >> + impl_tac + >- ( + match_mp_tac ALOOKUP_ALL_DISTINCT_MEM >> + gs [] >> + conj_tac + >- ( + gs [MAP_REVERSE] >> + ‘MAP FST (MAP (λ(x,y). (x,d + (y + FST (t.ffi.ffi_state 0)))) + (fmap_to_alist s.clocks)) = + MAP FST (fmap_to_alist s.clocks)’ by fs [map_fst] >> + gs []) >> + gs [MEM_MAP] >> + qexists_tac ‘(ck,r)’ >> + gs []) >> + strip_tac >> + gs []) >> + last_x_assum drule >> + (* ck0 *) + disch_then (qspecl_then [‘ck0 + 1’, ‘ist’] mp_tac) >> + impl_tac + >- ( + gs [mkState_def, wakeup_rel_def] >> + gs [delay_rep_def] >> + gs [mem_read_ffi_results_def] >> + rpt gen_tac >> + strip_tac >> + last_x_assum (qspecl_then [‘i’,‘t'’, ‘t''’] mp_tac) >> + gs []) >> + strip_tac >> fs [] >> + ‘(mkState (delay_clocks s.clocks d) s.location NONE (SOME (w - d))).ioAction = + NONE’ by fs [mkState_def] >> + fs [] >> + pop_assum kall_tac >> + ‘(mkState (delay_clocks s.clocks sd) s.location NONE (SOME (w - sd))).ioAction = + NONE’ by fs [mkState_def] >> + fs [] >> + pop_assum kall_tac >> + (* cases on d ≤ w *) + cases_on ‘d < w’ >> gs [] + >- ( + qexists_tac ‘ck’ >> + fs [] >> + qpat_x_assum ‘∀ck_extra. _’ kall_tac >> + drule state_rel_imp_mem_config >> + rewrite_tac [Once mem_config_def] >> + strip_tac >> + fs [] >> + ‘∃bytes. + read_bytearray ffiBufferAddr (w2n (ffiBufferSize:'a word)) + (mem_load_byte t'.memory t'.memaddrs t'.be) = SOME bytes’ by ( + match_mp_tac read_bytearray_some_bytes_for_ffi >> + gs []) >> + gvs [] >> + qabbrev_tac + ‘new_t:('a,time_input) panSem$state = + t' with + <|locals := + t'.locals |+ + («sysTime» , + ValWord (n2w (FST (nexts_ffi cycles t.ffi.ffi_state 1)))) |+ + («event» , + ValWord (n2w (SND (nexts_ffi cycles t.ffi.ffi_state 1)))) |+ + («isInput» ,ValWord 1w); + memory := + mem_call_ffi (:α) t'.memory t'.memaddrs t.be + (nexts_ffi cycles t.ffi.ffi_state); + ffi := ffi_call_ffi (:α) t.be t'.ffi bytes|>’ >> + qexists_tac ‘new_t’ >> + fs [PULL_FORALL] >> + gen_tac >> gs [] >> + fs [wait_input_time_limit_def] >> + rewrite_tac [Once evaluate_def] >> + drule step_wait_delay_eval_wait_not_zero >> + impl_tac + >- ( + conj_tac + >- gs [state_rel_def, mkState_def, equivs_def, active_low_def] >> + gs [] >> + gs [wakeup_rel_def, delay_rep_def] >> + qexists_tac ‘sd + FST (t.ffi.ffi_state 0)’ >> + gs [] >> + qexists_tac ‘(ist + w) - (sd + FST (t.ffi.ffi_state 0))’ >> + gs [] >> + ‘ist + w − (sd + FST (t.ffi.ffi_state 0)) + FST (t.ffi.ffi_state 0) = + ist + w − sd’ by ( + once_rewrite_tac [SUB_PLUS] >> + ‘FST (t.ffi.ffi_state 0) ≤ ist + w − sd’ by ( + gs [] >> + first_x_assum (qspec_then ‘cycles’ mp_tac) >> + gs []) >> + drule SUB_ADD >> + gs []) >> + fs [] >> + first_x_assum (qspec_then ‘cycles’ mp_tac) >> + gs []) >> + strip_tac >> + gs [eval_upd_clock_eq] >> + (* evaluating the function *) + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + fs [dec_clock_def] >> + ‘state_rel (clksOf prog) (out_signals prog) + (mkState (delay_clocks s.clocks sd) s.location NONE (SOME (w − sd))) + (t' with clock := ck_extra + t'.clock)’ by gs [state_rel_def] >> + qpat_x_assum ‘state_rel _ _ _ t'’ kall_tac >> + rewrite_tac [Once check_input_time_def] >> + fs [panLangTheory.nested_seq_def] >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + drule evaluate_ext_call >> + disch_then (qspecl_then [‘MAP explode (out_signals prog)’,‘bytes’] mp_tac) >> + impl_tac + >- ( + gs [state_rel_def] >> + pairarg_tac >> gs []) >> + strip_tac >> gvs [] >> + drule state_rel_imp_ffi_vars >> + strip_tac >> + pop_assum mp_tac >> + rewrite_tac [Once ffi_vars_def] >> + strip_tac >> + drule state_rel_imp_systime_defined >> + strip_tac >> + (* reading systime *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «sysTime» _, nt)’ >> + ‘nt.memory ffiBufferAddr = Word (n2w (FST(t'.ffi.ffi_state 1)))’ by ( + fs [Abbr ‘nt’] >> + qpat_x_assum ‘mem_read_ffi_results _ _ _’ assume_tac >> + gs [mem_read_ffi_results_def] >> + qmatch_asmsub_abbrev_tac ‘evaluate (ExtCall _ _ _ _ _, _) = (_, ft)’ >> + last_x_assum + (qspecl_then + [‘cycles’, + ‘t' with clock := ck0 + ck_extra + t'.clock’, + ‘ft’] mp_tac)>> + impl_tac + >- gs [Abbr ‘ft’] >> + strip_tac >> + gs [Abbr ‘ft’]) >> + drule evaluate_assign_load >> + gs [] >> + disch_then (qspecl_then + [‘ffiBufferAddr’, ‘tm’, + ‘n2w (FST (t'.ffi.ffi_state 1))’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nt’] >> + fs [state_rel_def]) >> + strip_tac >> fs [] >> + gvs [] >> + (* reading input to the variable event *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «event» _, nnt)’ >> + ‘nnt.memory (ffiBufferAddr + bytes_in_word) = + Word (n2w (SND(t'.ffi.ffi_state 1)))’ by ( + fs [Abbr ‘nnt’, Abbr ‘nt’] >> + qpat_x_assum ‘mem_read_ffi_results _ _ _’ assume_tac >> + gs [mem_read_ffi_results_def] >> + qmatch_asmsub_abbrev_tac ‘evaluate (ExtCall _ _ _ _ _, _) = (_, ft)’ >> + last_x_assum + (qspecl_then + [‘cycles’, + ‘t' with clock := ck0 + ck_extra + t'.clock’, + ‘ft’] mp_tac)>> + impl_tac + >- gs [Abbr ‘ft’] >> + strip_tac >> + gs [Abbr ‘ft’]) >> + gs [] >> + drule evaluate_assign_load_next_address >> + gs [] >> + disch_then (qspecl_then + [‘ffiBufferAddr’, + ‘n2w (SND (nexts_ffi cycles t.ffi.ffi_state 1))’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nnt’,Abbr ‘nt’, active_low_def] >> + gs [state_rel_def, time_vars_def, FLOOKUP_UPDATE] >> + gs [delay_rep_def, nexts_ffi_def]) >> + strip_tac >> gvs [] >> + (* isInput *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «isInput» _, nnnt)’ >> + ‘nnnt.memory (ffiBufferAddr + bytes_in_word) = + Word (n2w (SND(t'.ffi.ffi_state 1)))’ by fs [Abbr ‘nnnt’] >> + gs [] >> + ‘nnnt.memory (ffiBufferAddr + bytes_in_word) = Word 0w’ by ( + gs [delay_rep_def] >> + fs [nexts_ffi_def]) >> + fs [] >> + drule evaluate_assign_compare_next_address >> + gs [] >> + disch_then (qspecl_then [‘ffiBufferAddr’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nnnt’, Abbr ‘nnt’,Abbr ‘nt’, active_low_def] >> + gs [state_rel_def, time_vars_def, FLOOKUP_UPDATE] >> + gs [delay_rep_def, nexts_ffi_def]) >> + strip_tac >> gvs [] >> + (* If statement *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + drule evaluate_if_compare_sys_time >> + disch_then (qspec_then ‘FST (nexts_ffi cycles t.ffi.ffi_state 1)’ mp_tac) >> + impl_tac + >- ( + unabbrev_all_tac >> + gs [FLOOKUP_UPDATE, nexts_ffi_def] >> + gs [delay_rep_def, ADD1]) >> + strip_tac >> rveq >> gs [] >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + strip_tac >> fs [] >> + rveq >> gs [] >> + unabbrev_all_tac >> + gs [] >> gvs [] >> + reverse conj_tac + >- ( + fs [ffi_call_ffi_def] >> + fs [nexts_ffi_def, next_ffi_def, FLOOKUP_UPDATE] >> + fs [ADD1] >> + conj_asm1_tac + >- ( + gs [wait_time_locals1_def, FLOOKUP_UPDATE, mkState_def] >> + qexists_tac ‘wt’ >> + gs [] >> + gvs [delay_rep_def] >> + qpat_x_assum ‘wakeup_rel _ _ _ _ _’ mp_tac >> + gs [wakeup_rel_def] >> + strip_tac >> + gvs [] >> + first_x_assum (qspec_then ‘cycles + 1’ mp_tac) >> + gs [] >> + strip_tac >> + ‘w ≤ wt’ suffices_by gvs [] >> + gs [wakeup_shape_def] >> + ‘wt' = wt’ suffices_by gvs [] >> + drule sum_mod_eq_lt_eq >> + gs []) >> + strip_tac >> gs [] >> + conj_asm1_tac + >- ( + fs [delay_io_events_rel_def] >> + conj_asm1_tac + >- ( + qexists_tac ‘bytess ++ [bytes]’ >> + gs [] >> + drule read_bytearray_LENGTH >> + strip_tac >> + conj_asm1_tac + >- ( + gs [ffiBufferSize_def, bytes_in_word_def] >> + gs [good_dimindex_def, dimword_def]) >> + gs [mk_ti_events_def] >> + ‘gen_ffi_states t.ffi.ffi_state (LENGTH bytess + 1) = + gen_ffi_states t.ffi.ffi_state (LENGTH bytess) ++ + [(λn. t.ffi.ffi_state (n + LENGTH bytess))]’ by ( + fs [gen_ffi_states_def] >> + gs [GSYM ADD1, GENLIST]) >> + gs [] >> + ‘LENGTH [bytes] = LENGTH [(λn. t.ffi.ffi_state (n + LENGTH bytess))] ∧ + LENGTH bytess = LENGTH (gen_ffi_states t.ffi.ffi_state (LENGTH bytess))’ by + gs [gen_ffi_states_def] >> + drule ZIP_APPEND >> + disch_then (qspecl_then [‘[bytes]’, + ‘[(λn. t.ffi.ffi_state (n + LENGTH bytess))]’] mp_tac) >> + impl_tac + >- gs [] >> + strip_tac >> + pop_assum (assume_tac o GSYM) >> + gs [mk_ti_event_def, time_input_def]) >> + (* proving io_events rel *) + gs [from_io_events_def] >> + rewrite_tac [GSYM APPEND_ASSOC] >> + gs [DROP_LENGTH_APPEND] >> + gs [mk_ti_events_def, io_events_dest_def] >> + gs [MAP_MAP_o] >> + gs [io_events_eq_ffi_seq_def] >> + gs [gen_ffi_states_def] >> + gs [EVERY_MEM] >> + rw [] >> gs [] + >- ( + gs [MEM_MAP] >> + drule MEM_ZIP2 >> + strip_tac >> gs [] >> + gs [mk_ti_event_def, io_event_dest_def] >> + qmatch_goalsub_abbrev_tac ‘ZIP (nn, mm)’ >> + ‘LENGTH nn = LENGTH mm’ by ( + fs [Abbr ‘nn’, Abbr ‘mm’] >> + first_x_assum (qspec_then ‘EL n bytess'’ mp_tac) >> + impl_tac + >- ( + gs [MEM_EL] >> + metis_tac []) >> + strip_tac >> gs [] >> + gs [time_input_def, length_get_bytes] >> + gs [good_dimindex_def]) >> + ‘MAP SND (ZIP (nn,mm)) = mm’ by ( + drule MAP_ZIP >> + gs []) >> + gs [] >> + gs [words_of_bytes_def] >> + ‘8 ≤ dimindex (:α)’ by gs [good_dimindex_def] >> + drule LENGTH_words_of_bytes >> + disch_then (qspecl_then [‘t.be’, ‘mm’] mp_tac) >> + strip_tac >> gs [] >> + gs [Abbr ‘mm’, time_input_def, length_get_bytes, bytes_in_word_def, + good_dimindex_def, dimword_def]) + >- ( + qpat_x_assum ‘MAP _ _ ++ _ = _’ (assume_tac o GSYM) >> + gs [GSYM MAP_MAP_o] >> + cases_on ‘i < LENGTH bytess’ + >- ( + last_x_assum (qspec_then ‘i’ mp_tac) >> + impl_tac >- gs [] >> + strip_tac >> + gs [EL_APPEND_EQN]) >> + gs [EL_APPEND_EQN] >> + ‘i − LENGTH bytess = 0’ by gs [] >> + simp [] >> + gs [io_event_dest_def] >> + qmatch_goalsub_abbrev_tac ‘ZIP (nn, mm)’ >> + ‘LENGTH nn = LENGTH mm’ by ( + fs [Abbr ‘nn’, Abbr ‘mm’] >> + drule read_bytearray_LENGTH >> + strip_tac >> + gs [length_get_bytes, ffiBufferSize_def, + good_dimindex_def, bytes_in_word_def, dimword_def]) >> + ‘MAP SND (ZIP (nn,mm)) = mm’ by ( + drule MAP_ZIP >> + gs []) >> + gs [Abbr ‘mm’] >> + qmatch_goalsub_abbrev_tac ‘get_bytes t.be aa ++ get_bytes t.be bb’ >> + ‘words_of_bytes t.be (get_bytes t.be aa ++ get_bytes t.be bb) = + [aa;bb]’ by ( + match_mp_tac words_of_bytes_get_bytes >> + gs []) >> + gs [Abbr ‘aa’, Abbr ‘bb’] >> + gs [delay_rep_def] >> + cases_on ‘t.ffi.ffi_state (i+1)’ >> gs [] >> + last_x_assum (qspec_then ‘i + 1’ mp_tac) >> + gs [] >> + strip_tac >> + qpat_x_assum ‘_ = d + FST (t.ffi.ffi_state 0)’ (mp_tac o GSYM) >> + gs [] >> + strip_tac >> + ‘LENGTH bytess = i’ by gs [] >> + simp []) >> + gs [decode_io_events_def] >> + gs [MAP_MAP_o] >> + qmatch_goalsub_abbrev_tac ‘EL n (MAP f l)’ >> + ‘EL n (MAP f l) = f (EL n l)’ by ( + match_mp_tac EL_MAP >> + gs [Abbr ‘f’, Abbr ‘l’]) >> + gs [Abbr ‘f’, Abbr ‘l’] >> + qmatch_goalsub_abbrev_tac ‘ZIP (l1, l2)’ >> + ‘EL n (ZIP (l1,l2)) = (EL n l1,EL n l2)’ by ( + match_mp_tac EL_ZIP >> + gs [Abbr ‘l1’, Abbr ‘l2’]) >> + gs [Abbr ‘l1’, Abbr ‘l2’] >> + qmatch_goalsub_abbrev_tac ‘EL n (MAP f l)’ >> + ‘EL n (MAP f l) = f (EL n l)’ by ( + match_mp_tac EL_MAP >> + gs [Abbr ‘f’, Abbr ‘l’]) >> + gs [Abbr ‘f’, Abbr ‘l’] >> + gs [mk_ti_event_def, decode_io_event_def] >> + qmatch_goalsub_abbrev_tac ‘EL 1 nio’ >> + ‘EL 1 nio = 0’ by ( + gs [Abbr ‘nio’, io_event_dest_def] >> + qmatch_goalsub_abbrev_tac ‘ZIP (nn, mm)’ >> + ‘LENGTH nn = LENGTH mm’ by ( + fs [Abbr ‘nn’, Abbr ‘mm’] >> + gs [time_input_def, length_get_bytes] >> + first_x_assum (qspec_then ‘EL n bytess'’ mp_tac) >> + impl_tac >- metis_tac [MEM_EL] >> + gs [good_dimindex_def]) >> + ‘MAP SND (ZIP (nn,mm)) = mm’ by ( + drule MAP_ZIP >> + gs []) >> + gs [Abbr ‘nn’, Abbr ‘mm’] >> + gs [time_input_def] >> + qmatch_goalsub_abbrev_tac ‘get_bytes t.be aa ++ get_bytes t.be bb’ >> + ‘words_of_bytes t.be (get_bytes t.be aa ++ get_bytes t.be bb) = + [aa;bb]’ by ( + match_mp_tac words_of_bytes_get_bytes >> + gs []) >> + gs [Abbr ‘aa’, Abbr ‘bb’] >> + gs [delay_rep_def]) >> + gs [Abbr ‘nio’] >> + gs [io_event_dest_def] >> + qmatch_goalsub_abbrev_tac ‘ZIP (nn, mm)’ >> + ‘LENGTH nn = LENGTH mm’ by ( + fs [Abbr ‘nn’, Abbr ‘mm’] >> + gs [time_input_def, length_get_bytes] >> + first_x_assum (qspec_then ‘EL n bytess'’ mp_tac) >> + impl_tac >- metis_tac [MEM_EL] >> + gs [good_dimindex_def]) >> + ‘MAP SND (ZIP (nn,mm)) = mm’ by ( + drule MAP_ZIP >> + gs []) >> + gs [Abbr ‘nn’, Abbr ‘mm’] >> + gs [time_input_def, length_get_bytes] >> + qmatch_goalsub_abbrev_tac ‘get_bytes t.be aa ++ get_bytes t.be bb’ >> + ‘words_of_bytes t.be (get_bytes t.be aa ++ get_bytes t.be bb) = + [aa;bb]’ by ( + match_mp_tac words_of_bytes_get_bytes >> + gs []) >> + gs [Abbr ‘aa’, Abbr ‘bb’] >> + last_x_assum assume_tac >> + gs [state_rel_def] >> + pairarg_tac >> gs [] >> + gs [time_seq_def]) >> + gs [obs_ios_are_label_delay_def] >> + reverse conj_tac + >- ( + pop_assum mp_tac >> + once_rewrite_tac [delay_io_events_rel_def] >> + fs [] >> + strip_tac >> + qmatch_goalsub_abbrev_tac ‘EL n ios’ >> + strip_tac >> + first_x_assum (qspec_then ‘n’ mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘ios’, Abbr ‘n’] >> + rewrite_tac [GSYM APPEND_ASSOC] >> + gs [DROP_LENGTH_APPEND] >> + gs [decode_io_events_def, mk_ti_events_def, gen_ffi_states_def]) >> + gs [] >> + strip_tac >> + gs [to_delay_def] >> + gs [Abbr ‘n’, Abbr ‘ios’, DROP_LENGTH_APPEND] >> + gs [decode_io_events_def, mk_ti_events_def, gen_ffi_states_def] >> + gs [delay_rep_def]) >> + pop_assum mp_tac >> + once_rewrite_tac [delay_io_events_rel_def] >> + fs [] >> + strip_tac >> + simp [delay_ios_mono_def] >> + rw [] >> + last_x_assum assume_tac >> + gs [state_rel_def] >> + pairarg_tac >> gs [] >> + gs [time_seq_def] >> + ‘(λx. FST (t.ffi.ffi_state x)) (i + 1) ≤ (λx. FST (t.ffi.ffi_state x)) (j + 1)’ by ( + match_mp_tac ffi_abs_mono >> + gs []) >> + gs []) >> + (* proving state rel *) + gs [state_rel_def, mkState_def] >> + conj_tac + (* equivs *) + >- gs [equivs_def, FLOOKUP_UPDATE, active_low_def] >> + conj_tac + >- gs [ffi_vars_def, FLOOKUP_UPDATE] >> + conj_tac + >- gs [time_vars_def, FLOOKUP_UPDATE] >> + conj_tac + >- gs [mem_config_def, mem_call_ffi_def] >> + conj_tac + >- ( + (* clock_bound *) + qpat_x_assum ‘defined_clocks s.clocks _’ assume_tac >> + gs [defined_clocks_def] >> + fs [EVERY_MEM] >> + rw [] >> + first_x_assum drule >> + strip_tac >> + fs [] >> + fs [delay_clocks_def] >> + qexists_tac ‘d+n’ >> + gs [] >> + match_mp_tac mem_to_flookup >> + ‘MAP FST (MAP (λ(x,y). (x,d + y)) (fmap_to_alist s.clocks)) = + MAP FST (fmap_to_alist s.clocks)’ by fs [map_fst] >> + fs [ALL_DISTINCT_fmap_to_alist_keys] >> + fs [MEM_MAP] >> + qexists_tac ‘(ck,n)’ >> + fs []) >> + pairarg_tac >> gs [] >> + conj_tac + >- ( + fs [ffi_call_ffi_def, build_ffi_def] >> + fs [ffiTheory.ffi_state_component_equality] >> + last_x_assum assume_tac >> + pairarg_tac >> + fs [] >> + pairarg_tac >> + fs []) >> + conj_tac + >- ( + (* input_time_rel *) + gs [input_time_rel_def] >> + rw [] >> + gs [input_time_eq_def, ffi_call_ffi_def, next_ffi_def, nexts_ffi_def, + has_input_def] >> + strip_tac >> + pairarg_tac >> gs [] >> + first_x_assum (qspec_then ‘n+1’ mp_tac) >> + impl_tac >- gs [] >> + gs []) >> + conj_tac + >- ( + (* time_seq holds *) + gs [ffi_call_ffi_def, + nexts_ffi_def, next_ffi_def] >> + last_x_assum mp_tac >> + pairarg_tac >> gs [] >> + strip_tac >> + drule time_seq_add_holds >> + disch_then (qspec_then ‘cycles + 1’ mp_tac) >> + fs []) >> + gs [clocks_rel_def, FLOOKUP_UPDATE, nexts_ffi_def, + ffi_call_ffi_def, next_ffi_def, time_seq_def] >> + pairarg_tac >> gs [] >> rveq >> gs [] >> + qexists_tac ‘ns’ >> + fs [] >> + fs [clkvals_rel_def] >> + conj_tac + >- ( + fs [MAP_EQ_EVERY2] >> + fs [LIST_REL_EL_EQN] >> + rw [] >> + pairarg_tac >> fs [] >> + last_x_assum drule >> + fs [] >> + strip_tac >> + (* shortcut *) + ‘∃xn. FLOOKUP s.clocks x = SOME xn’ by ( + drule EL_ZIP >> + disch_then (qspec_then ‘n’ mp_tac) >> + gs [] >> + strip_tac >> + gs [defined_clocks_def] >> + fs [EVERY_MEM] >> + fs [MEM_EL] >> + last_x_assum (qspec_then ‘x’ mp_tac) >> + fs [] >> + impl_tac >- metis_tac [] >> + gs [FDOM_FLOOKUP]) >> + fs [delay_clocks_def] >> + ‘FLOOKUP (FEMPTY |++ MAP (λ(x,y). (x,d + y)) (fmap_to_alist s.clocks)) + x = SOME (d + xn)’ by ( + match_mp_tac mem_to_flookup >> + ‘MAP FST (MAP (λ(x,y). (x,d + y)) (fmap_to_alist s.clocks)) = + MAP FST (fmap_to_alist s.clocks)’ by fs [map_fst] >> + fs [ALL_DISTINCT_fmap_to_alist_keys] >> + fs [MEM_MAP] >> + qexists_tac ‘(x,xn)’ >> + fs []) >> + fs [] >> + ‘FLOOKUP (FEMPTY |++ MAP (λ(x,y). (x,sd + y)) (fmap_to_alist s.clocks)) + x = SOME (sd + xn)’ by ( + match_mp_tac mem_to_flookup >> + ‘MAP FST (MAP (λ(x,y). (x,sd + y)) (fmap_to_alist s.clocks)) = + MAP FST (fmap_to_alist s.clocks)’ by fs [map_fst] >> + fs [ALL_DISTINCT_fmap_to_alist_keys] >> + fs [MEM_MAP] >> + qexists_tac ‘(x,xn)’ >> + fs []) >> + fs [] >> + fs [ffi_call_ffi_def, next_ffi_def] >> + qpat_x_assum ‘delay_rep d _ _’ assume_tac >> + qpat_x_assum ‘delay_rep sd _ _’ assume_tac >> + qpat_x_assum ‘sd ≤ d’ assume_tac >> + gs [delay_rep_def] >> + gs [ADD1]) >> + fs [EVERY_MEM] >> + rw [] >> + first_x_assum (qspec_then ‘x’ assume_tac) >> + gs [] >> + ‘∃xn. FLOOKUP s.clocks x = SOME xn’ by ( + gs [defined_clocks_def] >> + gs [EVERY_MEM]) >> + fs [delay_clocks_def] >> + ‘FLOOKUP (FEMPTY |++ MAP (λ(x,y). (x,d + y)) (fmap_to_alist s.clocks)) + x = SOME (d + xn)’ by ( + match_mp_tac mem_to_flookup >> + ‘MAP FST (MAP (λ(x,y). (x,d + y)) (fmap_to_alist s.clocks)) = + MAP FST (fmap_to_alist s.clocks)’ by fs [map_fst] >> + fs [ALL_DISTINCT_fmap_to_alist_keys] >> + fs [MEM_MAP] >> + qexists_tac ‘(x,xn)’ >> + fs []) >> + fs [] >> + ‘FLOOKUP (FEMPTY |++ MAP (λ(x,y). (x,sd + y)) (fmap_to_alist s.clocks)) + x = SOME (sd + xn)’ by ( + match_mp_tac mem_to_flookup >> + ‘MAP FST (MAP (λ(x,y). (x,sd + y)) (fmap_to_alist s.clocks)) = + MAP FST (fmap_to_alist s.clocks)’ by fs [map_fst] >> + fs [ALL_DISTINCT_fmap_to_alist_keys] >> + fs [MEM_MAP] >> + qexists_tac ‘(x,xn)’ >> + fs []) >> + fs [] >> + fs [ffi_call_ffi_def, next_ffi_def] >> + qpat_x_assum ‘delay_rep d _ _’ assume_tac >> + qpat_x_assum ‘delay_rep sd _ _’ assume_tac >> + qpat_x_assum ‘sd ≤ d’ assume_tac >> + gs [delay_rep_def] >> + gs [ADD1]) >> + ‘d = w’ by gs [] >> + pop_assum mp_tac >> + pop_assum kall_tac >> + qpat_x_assum ‘d ≤ w’ kall_tac >> + strip_tac >> + qexists_tac ‘ck’ >> + fs [] >> + qpat_x_assum ‘∀ck_extra. _’ kall_tac >> + drule state_rel_imp_mem_config >> + rewrite_tac [Once mem_config_def] >> + strip_tac >> + fs [] >> + ‘∃bytes. + read_bytearray ffiBufferAddr (w2n (ffiBufferSize:'a word)) + (mem_load_byte t'.memory t'.memaddrs t'.be) = SOME bytes’ by ( + match_mp_tac read_bytearray_some_bytes_for_ffi >> + gs []) >> + qabbrev_tac + ‘new_t:('a,time_input) panSem$state = + t' with + <|locals := + t'.locals |+ + («sysTime» , + ValWord (n2w (FST (nexts_ffi cycles t.ffi.ffi_state 1)))) |+ + («event» , + ValWord (n2w (SND (nexts_ffi cycles t.ffi.ffi_state 1)))) |+ + («isInput» ,ValWord 1w); + memory := + mem_call_ffi (:α) t'.memory t'.memaddrs t.be + (nexts_ffi cycles t.ffi.ffi_state); + ffi := ffi_call_ffi (:α) t.be t'.ffi bytes|>’ >> + qexists_tac ‘new_t’ >> + fs [PULL_FORALL] >> + gen_tac >> gs [] >> + fs [wait_input_time_limit_def] >> + rewrite_tac [Once evaluate_def] >> + drule step_wait_delay_eval_wait_not_zero >> + impl_tac + >- ( + conj_tac + >- gs [state_rel_def, mkState_def, equivs_def, active_low_def] >> + gs [] >> + gs [wakeup_rel_def, delay_rep_def] >> + qexists_tac ‘sd + FST (t.ffi.ffi_state 0)’ >> + gs [] >> + qexists_tac ‘(ist + w) - (sd + FST (t.ffi.ffi_state 0))’ >> + gs [] >> + ‘ist + w − (sd + FST (t.ffi.ffi_state 0)) + FST (t.ffi.ffi_state 0) = + ist + w − sd’ by ( + once_rewrite_tac [SUB_PLUS] >> + ‘FST (t.ffi.ffi_state 0) ≤ ist + w − sd’ by ( + gs [] >> + first_x_assum (qspec_then ‘cycles’ mp_tac) >> + gs []) >> + drule SUB_ADD >> + gs []) >> + fs [] >> + first_x_assum (qspec_then ‘cycles’ mp_tac) >> + gs []) >> + strip_tac >> + gs [eval_upd_clock_eq] >> + (* evaluating the function *) + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + fs [dec_clock_def] >> + rewrite_tac [Once check_input_time_def] >> + fs [panLangTheory.nested_seq_def] >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + drule evaluate_ext_call >> + disch_then (qspecl_then [‘MAP explode (out_signals prog)’,‘bytes’] mp_tac) >> + impl_tac + >- ( + gs [state_rel_def] >> + pairarg_tac >> gs []) >> + strip_tac >> gvs [] >> + drule state_rel_imp_ffi_vars >> + strip_tac >> + pop_assum mp_tac >> + rewrite_tac [Once ffi_vars_def] >> + strip_tac >> + drule state_rel_imp_systime_defined >> + strip_tac >> + (* reading systime *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «sysTime» _, nt)’ >> + ‘nt.memory ffiBufferAddr = Word (n2w (FST(t'.ffi.ffi_state 1)))’ by ( + fs [Abbr ‘nt’] >> + qpat_x_assum ‘mem_read_ffi_results _ _ _’ assume_tac >> + gs [mem_read_ffi_results_def] >> + qmatch_asmsub_abbrev_tac ‘evaluate (ExtCall _ _ _ _ _, _) = (_, ft)’ >> + last_x_assum + (qspecl_then + [‘cycles’, + ‘t' with clock := ck0 + ck_extra + t'.clock’, + ‘ft’] mp_tac)>> + impl_tac + >- gs [Abbr ‘ft’] >> + strip_tac >> + gs [Abbr ‘ft’]) >> + drule evaluate_assign_load >> + gs [] >> + disch_then (qspecl_then + [‘ffiBufferAddr’, ‘tm’, + ‘n2w (FST (t'.ffi.ffi_state 1))’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nt’] >> + fs [state_rel_def]) >> + strip_tac >> gvs [] >> + (* reading input to the variable event *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «event» _, nnt)’ >> + ‘nnt.memory (ffiBufferAddr + bytes_in_word) = + Word (n2w (SND(t'.ffi.ffi_state 1)))’ by ( + fs [Abbr ‘nnt’, Abbr ‘nt’] >> + qpat_x_assum ‘mem_read_ffi_results _ _ _’ assume_tac >> + gs [mem_read_ffi_results_def] >> + qmatch_asmsub_abbrev_tac ‘evaluate (ExtCall _ _ _ _ _, _) = (_, ft)’ >> + last_x_assum + (qspecl_then + [‘cycles’, + ‘t' with clock := ck0 + ck_extra + t'.clock’, + ‘ft’] mp_tac)>> + impl_tac + >- gs [Abbr ‘ft’] >> + strip_tac >> + gs [Abbr ‘ft’]) >> + gs [] >> + drule evaluate_assign_load_next_address >> + gs [] >> + disch_then (qspecl_then + [‘ffiBufferAddr’, + ‘n2w (SND (nexts_ffi cycles t.ffi.ffi_state 1))’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nnt’,Abbr ‘nt’, active_low_def] >> + gs [state_rel_def, time_vars_def, FLOOKUP_UPDATE] >> + gs [delay_rep_def, nexts_ffi_def]) >> + strip_tac >> gvs [] >> + (* isInput *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «isInput» _, nnnt)’ >> + ‘nnnt.memory (ffiBufferAddr + bytes_in_word) = + Word (n2w (SND(t'.ffi.ffi_state 1)))’ by fs [Abbr ‘nnnt’] >> + gs [] >> + ‘nnnt.memory (ffiBufferAddr + bytes_in_word) = Word 0w’ by ( + gs [delay_rep_def] >> + fs [nexts_ffi_def]) >> + fs [] >> + drule evaluate_assign_compare_next_address >> + gs [] >> + disch_then (qspecl_then [‘ffiBufferAddr’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nnnt’, Abbr ‘nnt’,Abbr ‘nt’, active_low_def] >> + gs [state_rel_def, time_vars_def, FLOOKUP_UPDATE] >> + gs [delay_rep_def, nexts_ffi_def]) >> + strip_tac >> gvs [] >> + (* If statement *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + drule evaluate_if_compare_sys_time >> + disch_then (qspec_then ‘FST (nexts_ffi cycles t.ffi.ffi_state 1)’ mp_tac) >> + impl_tac + >- ( + unabbrev_all_tac >> + gs [FLOOKUP_UPDATE, nexts_ffi_def] >> + gs [delay_rep_def, ADD1]) >> + strip_tac >> rveq >> gs [] >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + strip_tac >> fs [] >> + rveq >> gs [] >> + unabbrev_all_tac >> + gs [] >> gvs [] >> + reverse conj_tac + >- ( + fs [ffi_call_ffi_def] >> + fs [nexts_ffi_def, next_ffi_def, FLOOKUP_UPDATE] >> + fs [ADD1] >> + conj_asm1_tac + >- ( + gs [wait_time_locals1_def, FLOOKUP_UPDATE, mkState_def] >> + qexists_tac ‘wt’ >> + gs [] >> + gvs [delay_rep_def]) >> + strip_tac >> gs [] >> + conj_asm1_tac + >- ( + fs [delay_io_events_rel_def] >> + conj_asm1_tac + >- ( + qexists_tac ‘bytess ++ [bytes]’ >> + gs [] >> + drule read_bytearray_LENGTH >> + strip_tac >> + conj_asm1_tac + >- ( + gs [ffiBufferSize_def, bytes_in_word_def] >> + gs [good_dimindex_def, dimword_def]) >> + gs [mk_ti_events_def] >> + ‘gen_ffi_states t.ffi.ffi_state (LENGTH bytess + 1) = + gen_ffi_states t.ffi.ffi_state (LENGTH bytess) ++ + [(λn. t.ffi.ffi_state (n + LENGTH bytess))]’ by ( + fs [gen_ffi_states_def] >> + gs [GSYM ADD1, GENLIST]) >> + gs [] >> + ‘LENGTH [bytes] = LENGTH [(λn. t.ffi.ffi_state (n + LENGTH bytess))] ∧ + LENGTH bytess = LENGTH (gen_ffi_states t.ffi.ffi_state (LENGTH bytess))’ by + gs [gen_ffi_states_def] >> + drule ZIP_APPEND >> + disch_then (qspecl_then [‘[bytes]’, + ‘[(λn. t.ffi.ffi_state (n + LENGTH bytess))]’] mp_tac) >> + impl_tac + >- gs [] >> + strip_tac >> + pop_assum (assume_tac o GSYM) >> + gs [mk_ti_event_def, time_input_def]) >> + (* proving io_events rel *) + gs [from_io_events_def] >> + rewrite_tac [GSYM APPEND_ASSOC] >> + gs [DROP_LENGTH_APPEND] >> + gs [mk_ti_events_def, io_events_dest_def] >> + gs [MAP_MAP_o] >> + gs [io_events_eq_ffi_seq_def] >> + gs [gen_ffi_states_def] >> + gs [EVERY_MEM] >> + rw [] >> gs [] + >- ( + gs [MEM_MAP] >> + drule MEM_ZIP2 >> + strip_tac >> gs [] >> + gs [mk_ti_event_def, io_event_dest_def] >> + qmatch_goalsub_abbrev_tac ‘ZIP (nn, mm)’ >> + ‘LENGTH nn = LENGTH mm’ by ( + fs [Abbr ‘nn’, Abbr ‘mm’] >> + first_x_assum (qspec_then ‘EL n bytess'’ mp_tac) >> + impl_tac + >- ( + gs [MEM_EL] >> + metis_tac []) >> + strip_tac >> gs [] >> + gs [time_input_def, length_get_bytes] >> + gs [good_dimindex_def]) >> + ‘MAP SND (ZIP (nn,mm)) = mm’ by ( + drule MAP_ZIP >> + gs []) >> + gs [] >> + gs [words_of_bytes_def] >> + ‘8 ≤ dimindex (:α)’ by gs [good_dimindex_def] >> + drule LENGTH_words_of_bytes >> + disch_then (qspecl_then [‘t.be’, ‘mm’] mp_tac) >> + strip_tac >> gs [] >> + gs [Abbr ‘mm’, time_input_def, length_get_bytes, bytes_in_word_def, + good_dimindex_def, dimword_def]) + >- ( + qpat_x_assum ‘MAP _ _ ++ _ = _’ (assume_tac o GSYM) >> + gs [GSYM MAP_MAP_o] >> + cases_on ‘i < LENGTH bytess’ + >- ( + last_x_assum (qspec_then ‘i’ mp_tac) >> + impl_tac >- gs [] >> + strip_tac >> + gs [EL_APPEND_EQN]) >> + gs [EL_APPEND_EQN] >> + ‘i − LENGTH bytess = 0’ by gs [] >> + simp [] >> + gs [io_event_dest_def] >> + qmatch_goalsub_abbrev_tac ‘ZIP (nn, mm)’ >> + ‘LENGTH nn = LENGTH mm’ by ( + fs [Abbr ‘nn’, Abbr ‘mm’] >> + drule read_bytearray_LENGTH >> + strip_tac >> + gs [length_get_bytes, ffiBufferSize_def, + good_dimindex_def, bytes_in_word_def, dimword_def]) >> + ‘MAP SND (ZIP (nn,mm)) = mm’ by ( + drule MAP_ZIP >> + gs []) >> + gs [Abbr ‘mm’] >> + qmatch_goalsub_abbrev_tac ‘get_bytes t.be aa ++ get_bytes t.be bb’ >> + ‘words_of_bytes t.be (get_bytes t.be aa ++ get_bytes t.be bb) = + [aa;bb]’ by ( + match_mp_tac words_of_bytes_get_bytes >> + gs []) >> + gs [Abbr ‘aa’, Abbr ‘bb’] >> + gs [delay_rep_def] >> + cases_on ‘t.ffi.ffi_state (i+1)’ >> gs [] >> + last_x_assum (qspec_then ‘i + 1’ mp_tac) >> + gs [] >> + strip_tac >> + qpat_x_assum ‘_ = d + FST (t.ffi.ffi_state 0)’ (mp_tac o GSYM) >> + gs [] >> + strip_tac >> + ‘LENGTH bytess = i’ by gs [] >> + simp []) >> + gs [decode_io_events_def] >> + gs [MAP_MAP_o] >> + qmatch_goalsub_abbrev_tac ‘EL n (MAP f l)’ >> + ‘EL n (MAP f l) = f (EL n l)’ by ( + match_mp_tac EL_MAP >> + gs [Abbr ‘f’, Abbr ‘l’]) >> + gs [Abbr ‘f’, Abbr ‘l’] >> + qmatch_goalsub_abbrev_tac ‘ZIP (l1, l2)’ >> + ‘EL n (ZIP (l1,l2)) = (EL n l1,EL n l2)’ by ( + match_mp_tac EL_ZIP >> + gs [Abbr ‘l1’, Abbr ‘l2’]) >> + gs [Abbr ‘l1’, Abbr ‘l2’] >> + qmatch_goalsub_abbrev_tac ‘EL n (MAP f l)’ >> + ‘EL n (MAP f l) = f (EL n l)’ by ( + match_mp_tac EL_MAP >> + gs [Abbr ‘f’, Abbr ‘l’]) >> + gs [Abbr ‘f’, Abbr ‘l’] >> + gs [mk_ti_event_def, decode_io_event_def] >> + qmatch_goalsub_abbrev_tac ‘EL 1 nio’ >> + ‘EL 1 nio = 0’ by ( + gs [Abbr ‘nio’, io_event_dest_def] >> + qmatch_goalsub_abbrev_tac ‘ZIP (nn, mm)’ >> + ‘LENGTH nn = LENGTH mm’ by ( + fs [Abbr ‘nn’, Abbr ‘mm’] >> + gs [time_input_def, length_get_bytes] >> + first_x_assum (qspec_then ‘EL n bytess'’ mp_tac) >> + impl_tac >- metis_tac [MEM_EL] >> + gs [good_dimindex_def]) >> + ‘MAP SND (ZIP (nn,mm)) = mm’ by ( + drule MAP_ZIP >> + gs []) >> + gs [Abbr ‘nn’, Abbr ‘mm’] >> + gs [time_input_def] >> + qmatch_goalsub_abbrev_tac ‘get_bytes t.be aa ++ get_bytes t.be bb’ >> + ‘words_of_bytes t.be (get_bytes t.be aa ++ get_bytes t.be bb) = + [aa;bb]’ by ( + match_mp_tac words_of_bytes_get_bytes >> + gs []) >> + gs [Abbr ‘aa’, Abbr ‘bb’] >> + gs [delay_rep_def]) >> + gs [Abbr ‘nio’] >> + gs [io_event_dest_def] >> + qmatch_goalsub_abbrev_tac ‘ZIP (nn, mm)’ >> + ‘LENGTH nn = LENGTH mm’ by ( + fs [Abbr ‘nn’, Abbr ‘mm’] >> + gs [time_input_def, length_get_bytes] >> + first_x_assum (qspec_then ‘EL n bytess'’ mp_tac) >> + impl_tac >- metis_tac [MEM_EL] >> + gs [good_dimindex_def]) >> + ‘MAP SND (ZIP (nn,mm)) = mm’ by ( + drule MAP_ZIP >> + gs []) >> + gs [Abbr ‘nn’, Abbr ‘mm’] >> + gs [time_input_def, length_get_bytes] >> + qmatch_goalsub_abbrev_tac ‘get_bytes t.be aa ++ get_bytes t.be bb’ >> + ‘words_of_bytes t.be (get_bytes t.be aa ++ get_bytes t.be bb) = + [aa;bb]’ by ( + match_mp_tac words_of_bytes_get_bytes >> + gs []) >> + gs [Abbr ‘aa’, Abbr ‘bb’] >> + last_x_assum assume_tac >> + gs [state_rel_def] >> + pairarg_tac >> gs [] >> + gs [time_seq_def]) >> + gs [obs_ios_are_label_delay_def] >> + reverse conj_tac + >- ( + pop_assum mp_tac >> + once_rewrite_tac [delay_io_events_rel_def] >> + fs [] >> + strip_tac >> + qmatch_goalsub_abbrev_tac ‘EL n ios’ >> + strip_tac >> + first_x_assum (qspec_then ‘n’ mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘ios’, Abbr ‘n’] >> + rewrite_tac [GSYM APPEND_ASSOC] >> + gs [DROP_LENGTH_APPEND] >> + gs [decode_io_events_def, mk_ti_events_def, gen_ffi_states_def]) >> + gs [] >> + strip_tac >> + gs [to_delay_def] >> + gs [Abbr ‘n’, Abbr ‘ios’, DROP_LENGTH_APPEND] >> + gs [decode_io_events_def, mk_ti_events_def, gen_ffi_states_def] >> + gs [delay_rep_def]) >> + pop_assum mp_tac >> + once_rewrite_tac [delay_io_events_rel_def] >> + fs [] >> + strip_tac >> + simp [delay_ios_mono_def] >> + rw [] >> + last_x_assum assume_tac >> + gs [state_rel_def] >> + pairarg_tac >> gs [] >> + gs [time_seq_def] >> + ‘(λx. FST (t.ffi.ffi_state x)) (i + 1) ≤ (λx. FST (t.ffi.ffi_state x)) (j + 1)’ by ( + match_mp_tac ffi_abs_mono >> + gs []) >> + gs []) >> + (* proving state rel *) + gs [state_rel_def, mkState_def] >> + conj_tac + (* equivs *) + >- gs [equivs_def, FLOOKUP_UPDATE, active_low_def] >> + conj_tac + >- gs [ffi_vars_def, FLOOKUP_UPDATE] >> + conj_tac + >- gs [time_vars_def, FLOOKUP_UPDATE] >> + conj_tac + >- gs [mem_config_def, mem_call_ffi_def] >> + conj_tac + >- ( + (* clock_bound *) + qpat_x_assum ‘defined_clocks s.clocks _’ assume_tac >> + gs [defined_clocks_def] >> + fs [EVERY_MEM] >> + rw [] >> + first_x_assum drule >> + strip_tac >> + fs [] >> + fs [delay_clocks_def] >> + qexists_tac ‘d+n’ >> + gs [] >> + match_mp_tac mem_to_flookup >> + ‘MAP FST (MAP (λ(x,y). (x,d + y)) (fmap_to_alist s.clocks)) = + MAP FST (fmap_to_alist s.clocks)’ by fs [map_fst] >> + fs [ALL_DISTINCT_fmap_to_alist_keys] >> + fs [MEM_MAP] >> + qexists_tac ‘(ck,n)’ >> + fs []) >> + pairarg_tac >> gs [] >> + conj_tac + >- ( + fs [ffi_call_ffi_def, build_ffi_def] >> + fs [ffiTheory.ffi_state_component_equality] >> + last_x_assum assume_tac >> + pairarg_tac >> + fs [] >> + pairarg_tac >> + fs []) >> + conj_tac + >- ( + (* input_time_rel *) + gs [input_time_rel_def] >> + rw [] >> + gs [input_time_eq_def, ffi_call_ffi_def, next_ffi_def, nexts_ffi_def, + has_input_def] >> + strip_tac >> + pairarg_tac >> gs [] >> + first_x_assum (qspec_then ‘n+1’ mp_tac) >> + impl_tac >- gs [] >> + gs []) >> + conj_tac + >- ( + (* time_seq holds *) + gs [ffi_call_ffi_def, + nexts_ffi_def, next_ffi_def] >> + last_x_assum mp_tac >> + pairarg_tac >> gs [] >> + strip_tac >> + drule time_seq_add_holds >> + disch_then (qspec_then ‘cycles + 1’ mp_tac) >> + fs []) >> + gs [clocks_rel_def, FLOOKUP_UPDATE, nexts_ffi_def, + ffi_call_ffi_def, next_ffi_def, time_seq_def] >> + pairarg_tac >> gs [] >> rveq >> gs [] >> + qexists_tac ‘ns’ >> + fs [] >> + fs [clkvals_rel_def] >> + conj_tac + >- ( + fs [MAP_EQ_EVERY2] >> + fs [LIST_REL_EL_EQN] >> + rw [] >> + pairarg_tac >> fs [] >> + last_x_assum drule >> + fs [] >> + strip_tac >> + (* shortcut *) + ‘∃xn. FLOOKUP s.clocks x = SOME xn’ by ( + drule EL_ZIP >> + disch_then (qspec_then ‘n’ mp_tac) >> + gs [] >> + strip_tac >> + gs [defined_clocks_def] >> + fs [EVERY_MEM] >> + fs [MEM_EL] >> + last_x_assum (qspec_then ‘x’ mp_tac) >> + fs [] >> + impl_tac >- metis_tac [] >> + gs [FDOM_FLOOKUP]) >> + fs [delay_clocks_def] >> + ‘FLOOKUP (FEMPTY |++ MAP (λ(x,y). (x,d + y)) (fmap_to_alist s.clocks)) + x = SOME (d + xn)’ by ( + match_mp_tac mem_to_flookup >> + ‘MAP FST (MAP (λ(x,y). (x,d + y)) (fmap_to_alist s.clocks)) = + MAP FST (fmap_to_alist s.clocks)’ by fs [map_fst] >> + fs [ALL_DISTINCT_fmap_to_alist_keys] >> + fs [MEM_MAP] >> + qexists_tac ‘(x,xn)’ >> + fs []) >> + fs [] >> + ‘FLOOKUP (FEMPTY |++ MAP (λ(x,y). (x,sd + y)) (fmap_to_alist s.clocks)) + x = SOME (sd + xn)’ by ( + match_mp_tac mem_to_flookup >> + ‘MAP FST (MAP (λ(x,y). (x,sd + y)) (fmap_to_alist s.clocks)) = + MAP FST (fmap_to_alist s.clocks)’ by fs [map_fst] >> + fs [ALL_DISTINCT_fmap_to_alist_keys] >> + fs [MEM_MAP] >> + qexists_tac ‘(x,xn)’ >> + fs []) >> + fs [] >> + fs [ffi_call_ffi_def, next_ffi_def] >> + qpat_x_assum ‘delay_rep d _ _’ assume_tac >> + qpat_x_assum ‘delay_rep sd _ _’ assume_tac >> + qpat_x_assum ‘sd ≤ d’ assume_tac >> + gs [delay_rep_def] >> + gs [ADD1]) >> + fs [EVERY_MEM] >> + rw [] >> + first_x_assum (qspec_then ‘x’ assume_tac) >> + gs [] >> + ‘∃xn. FLOOKUP s.clocks x = SOME xn’ by ( + gs [defined_clocks_def] >> + gs [EVERY_MEM]) >> + fs [delay_clocks_def] >> + ‘FLOOKUP (FEMPTY |++ MAP (λ(x,y). (x,d + y)) (fmap_to_alist s.clocks)) + x = SOME (d + xn)’ by ( + match_mp_tac mem_to_flookup >> + ‘MAP FST (MAP (λ(x,y). (x,d + y)) (fmap_to_alist s.clocks)) = + MAP FST (fmap_to_alist s.clocks)’ by fs [map_fst] >> + fs [ALL_DISTINCT_fmap_to_alist_keys] >> + fs [MEM_MAP] >> + qexists_tac ‘(x,xn)’ >> + fs []) >> + fs [] >> + ‘FLOOKUP (FEMPTY |++ MAP (λ(x,y). (x,sd + y)) (fmap_to_alist s.clocks)) + x = SOME (sd + xn)’ by ( + match_mp_tac mem_to_flookup >> + ‘MAP FST (MAP (λ(x,y). (x,sd + y)) (fmap_to_alist s.clocks)) = + MAP FST (fmap_to_alist s.clocks)’ by fs [map_fst] >> + fs [ALL_DISTINCT_fmap_to_alist_keys] >> + fs [MEM_MAP] >> + qexists_tac ‘(x,xn)’ >> + fs []) >> + fs [] >> + fs [ffi_call_ffi_def, next_ffi_def] >> + qpat_x_assum ‘delay_rep d _ _’ assume_tac >> + qpat_x_assum ‘delay_rep sd _ _’ assume_tac >> + qpat_x_assum ‘sd ≤ d’ assume_tac >> + gs [delay_rep_def] >> + gs [ADD1] +QED + + +Theorem evaluate_seq_fst: + evaluate (p, t) = evaluate (p, t') ⇒ + evaluate (Seq p q, t) = evaluate (Seq p q, t') +Proof + rw [] >> + fs [evaluate_def] +QED + + +Theorem step_delay: + !cycles prog d m n s s' (t:('a,time_input) panSem$state) ck0 ist. + step prog (LDelay d) m n s s' ∧ + m = dimword (:α) - 1 ∧ n = FST (t.ffi.ffi_state 0) ∧ + state_rel (clksOf prog) (out_signals prog) s t ∧ + code_installed t.code prog ∧ + delay_rep d t.ffi.ffi_state cycles ∧ + wakeup_shape t.locals s.waitTime ist ∧ + wakeup_rel t.locals s.waitTime ist t.ffi.ffi_state cycles ∧ + mem_read_ffi_results (:α) t.ffi.ffi_state cycles ∧ + FLOOKUP t.locals «isInput» = SOME (ValWord 1w) ∧ + FLOOKUP t.locals «event» = SOME (ValWord 0w) ∧ + good_dimindex (:'a) ==> + ?ck t'. + (∀ck_extra. + evaluate (task_controller (nClks prog), t with clock := t.clock + ck + ck_extra) = + evaluate (task_controller (nClks prog), t' with clock := t'.clock + ck_extra + ck0)) ∧ + code_installed t'.code prog ∧ + state_rel (clksOf prog) (out_signals prog) s' t' ∧ + t'.ffi.ffi_state = nexts_ffi cycles t.ffi.ffi_state ∧ + t'.ffi.oracle = t.ffi.oracle ∧ + t'.code = t.code ∧ + t'.be = t.be ∧ + t'.eshapes = t.eshapes ∧ + FLOOKUP t'.locals «wakeUpAt» = FLOOKUP t.locals «wakeUpAt» ∧ + FLOOKUP t'.locals «waitSet» = FLOOKUP t.locals «waitSet» ∧ + FLOOKUP t'.locals «isInput» = SOME (ValWord 1w) ∧ + FLOOKUP t'.locals «event» = SOME (ValWord 0w) ∧ + FLOOKUP t'.locals «taskRet» = FLOOKUP t.locals «taskRet» ∧ + FLOOKUP t'.locals «sysTime» = + SOME (ValWord (n2w (FST (t.ffi.ffi_state cycles)))) ∧ + wait_time_locals1 (:α) t'.locals s'.waitTime ist + (FST (t.ffi.ffi_state cycles)) ∧ + (t.ffi.io_events ≠ [] ∧ + EL 0 (io_event_dest (:α) t.be (LAST t.ffi.io_events)) = FST (t.ffi.ffi_state 0) ⇒ + delay_io_events_rel t t' cycles ∧ + obs_ios_are_label_delay d t t') +Proof + rw [] >> + fs [task_controller_def] >> + fs [panLangTheory.nested_seq_def] >> + qmatch_goalsub_abbrev_tac ‘evaluate (Seq _ q, _)’ >> + drule step_delay_loop >> + disch_then (qspecl_then [‘cycles’, ‘t’, ‘ck0’, ‘ist’] mp_tac) >> + fs [] >> + strip_tac >> + qexists_tac ‘ck’ >> fs [] >> + qexists_tac ‘t'’ >> fs [] >> + rw [] >> + first_x_assum (qspec_then ‘ck_extra’ assume_tac) >> + drule evaluate_seq_fst >> + disch_then (qspec_then ‘q’ assume_tac) >> + gs [] +QED + + +Theorem step_input_eval_wait_zero: + !t. + FLOOKUP t.locals «isInput» = SOME (ValWord 0w) ∧ + (?tm. FLOOKUP t.locals «waitSet» = SOME (ValWord tm)) ∧ + (?st. FLOOKUP t.locals «sysTime» = SOME (ValWord st)) ∧ + (?wt. FLOOKUP t.locals «wakeUpAt» = SOME (ValWord wt)) ==> + ?w. + eval t wait = SOME (ValWord w) ∧ + w = 0w +Proof + rw [] >> + fs [wait_def, eval_def, OPT_MMAP_def] >> + gs [wordLangTheory.word_op_def] +QED + + +Theorem step_delay_eval_wait_zero: + !t st. + FLOOKUP t.locals «isInput» = SOME (ValWord 1w) ∧ + FLOOKUP t.locals «waitSet» = SOME (ValWord 0w) ∧ + FLOOKUP t.locals «sysTime» = SOME (ValWord st) ∧ + FLOOKUP t.locals «wakeUpAt» = SOME (ValWord st) ==> + ?w. + eval t wait = SOME (ValWord w) ∧ + w = 0w +Proof + rw [] >> + fs [wait_def, eval_def, OPT_MMAP_def] >> + gs [wordLangTheory.word_op_def] >> + fs [asmTheory.word_cmp_def] +QED + +Theorem eval_normalisedClks: + ∀t st ns. + FLOOKUP t.locals «sysTime» = SOME (ValWord (n2w st)) ∧ + FLOOKUP t.locals «clks» = SOME (Struct (MAP (ValWord o n2w) ns)) ∧ + EVERY (λn. n ≤ st) ns ⇒ + OPT_MMAP (eval t) (normalisedClks «sysTime» «clks» (LENGTH ns)) = + SOME (MAP (λ(x,y). ValWord (n2w (x-y))) (ZIP (REPLICATE (LENGTH ns) st,ns))) + (* MAP is better for reasoning than MAP2*) +Proof + rpt gen_tac >> + strip_tac >> + fs [normalisedClks_def] >> + fs [opt_mmap_eq_some] >> + fs [MAP_EQ_EVERY2] >> + conj_tac + >- fs [mkClks_def, fieldsOf_def] >> + fs [LIST_REL_EL_EQN] >> + conj_tac + >- fs [mkClks_def, fieldsOf_def] >> + rw [] >> + qmatch_goalsub_abbrev_tac ‘MAP2 ff xs ys’ >> + ‘EL n (MAP2 ff xs ys) = ff (EL n xs) (EL n ys)’ by ( + match_mp_tac EL_MAP2 >> + fs []) >> + unabbrev_all_tac >> + gs [] >> + qmatch_goalsub_abbrev_tac ‘MAP ff (ZIP (xs,ys))’ >> + ‘EL n (MAP ff (ZIP (xs,ys))) = ff (EL n (ZIP (xs,ys)))’ by ( + match_mp_tac EL_MAP >> + unabbrev_all_tac >> + gs [mkClks_def]) >> + unabbrev_all_tac >> + gs [] >> + fs [mkClks_def, fieldsOf_def] >> + ‘EL n (ZIP (REPLICATE (LENGTH ns) st,ns)) = + (EL n (REPLICATE (LENGTH ns) st),EL n ns)’ by ( + match_mp_tac EL_ZIP >> + fs []) >> + fs [] >> + qmatch_goalsub_abbrev_tac ‘MAP ff xs’ >> + ‘EL n (MAP ff xs) = ff (EL n xs)’ by ( + match_mp_tac EL_MAP >> + unabbrev_all_tac >> + gs [mkClks_def]) >> + fs [] >> + unabbrev_all_tac >> + ‘EL n (GENLIST I (LENGTH ns)) = I n’ by ( + match_mp_tac EL_GENLIST >> + gs []) >> + fs [] >> + ‘EL n (REPLICATE (LENGTH ns) (Var «sysTime»)) = Var «sysTime»’ by ( + match_mp_tac EL_REPLICATE >> + gs []) >> + fs [] >> + ‘EL n (REPLICATE (LENGTH ns) st) = st’ by ( + match_mp_tac EL_REPLICATE >> + gs []) >> + fs [] >> + gs [eval_def, OPT_MMAP_def] >> + qmatch_goalsub_abbrev_tac ‘MAP ff xs’ >> + ‘EL n (MAP ff xs) = ff (EL n xs)’ by ( + match_mp_tac EL_MAP >> + unabbrev_all_tac >> + gs []) >> + unabbrev_all_tac >> + gs [] >> + fs [wordLangTheory.word_op_def] >> + fs [EVERY_MEM] >> + first_x_assum (qspec_then ‘EL n ns’ mp_tac) >> + gs [MEM_EL] >> + impl_tac >- metis_tac [] >> + strip_tac >> + drule n2w_sub >> + strip_tac >> fs [] +QED + + +Theorem genshape_eq_shape_of: + ∀ys x zs. + LENGTH ys = LENGTH zs ⇒ + genShape (LENGTH ys) = + shape_of (Struct + (MAP (λ(x,y). ValWord (n2w (x − y))) + (ZIP (REPLICATE (LENGTH ys) x,zs)))) +Proof + rw [] >> + fs [genShape_def] >> + fs [shape_of_def] >> + ‘REPLICATE (LENGTH ys) One = MAP (λx. One) (GENLIST I (LENGTH ys))’ by ( + fs [MAP_GENLIST] >> + fs [REPLICATE_GENLIST] >> + fs [seqTheory.K_PARTIAL]) >> + gs [] >> + fs [MAP_EQ_EVERY2] >> + fs [LIST_REL_EL_EQN] >> + rw [] >> + qmatch_goalsub_abbrev_tac ‘MAP ff (ZIP (xs,_))’ >> + ‘EL n (MAP ff (ZIP (xs,zs))) = ff (EL n (ZIP (xs,zs)))’ by ( + match_mp_tac EL_MAP >> + unabbrev_all_tac >> + gs [mkClks_def]) >> + unabbrev_all_tac >> + fs [] >> + ‘EL n (ZIP (REPLICATE (LENGTH zs) x,zs)) = + (EL n (REPLICATE (LENGTH zs) x), EL n zs)’ by ( + match_mp_tac EL_ZIP >> + fs []) >> + gs [shape_of_def] +QED + + + +Theorem foldl_word_size_of: + ∀xs ys n. + LENGTH xs = LENGTH ys ⇒ + FOLDL + (λa e. a + + size_of_shape (shape_of ((λ(x,y). ValWord (n2w (x − y))) e))) + n (ZIP (xs,ys)) = n + LENGTH xs +Proof + Induct >> + rw [] >> + cases_on ‘ys’ >> fs [] >> + fs [panLangTheory.size_of_shape_def, shape_of_def] +QED + +Theorem state_rel_intro: + ∀clks outs s t. + state_rel clks outs s (t:('a,time_input) panSem$state) ⇒ + equivs t.locals s.location s.waitTime ∧ + ffi_vars t.locals ∧ time_vars t.locals ∧ + mem_config t.memory t.memaddrs t.be ∧ + LENGTH clks ≤ 29 ∧ + defined_clocks s.clocks clks ∧ + let + ffi = t.ffi.ffi_state; + io_events = t.ffi.io_events; + (tm,io_flg) = ffi 0 + in + t.ffi = build_ffi (:'a) t.be (MAP explode outs) ffi io_events ∧ + input_time_rel ffi ∧ + time_seq ffi (dimword (:'a)) ∧ + FLOOKUP t.locals «sysTime» = SOME (ValWord (n2w tm)) ∧ + clocks_rel s.clocks t.locals clks tm +Proof + rw [state_rel_def] +QED + +Theorem resetClksVals_eq_map: + ∀tclks fm clks. + EVERY (λck. MEM ck clks) tclks ∧ + EVERY (λck. ∃n. FLOOKUP fm ck = SOME n) clks ⇒ + resetClksVals fm clks tclks = + MAP (ValWord ∘ n2w) + (MAP (λck. if MEM ck tclks then 0 else (THE (FLOOKUP fm ck))) clks) +Proof + rw [] >> + fs [resetClksVals_def] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + fs [resetClocks_def] >> + qmatch_goalsub_abbrev_tac ‘EL _ (MAP ff _)’ >> + ‘EL n (MAP ff clks) = ff (EL n clks)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [Abbr ‘ff’] >> + cases_on ‘MEM (EL n clks) tclks’ >> + fs [] + >- ( + ‘FLOOKUP (fm |++ ZIP (tclks,MAP (λx. 0) tclks)) (EL n clks) = SOME 0’ by ( + fs [MEM_EL] >> + match_mp_tac update_eq_zip_map_flookup >> + gs []) >> + fs []) >> + ‘FLOOKUP (fm |++ ZIP (tclks,MAP (λx. 0) tclks)) (EL n clks) = + FLOOKUP fm (EL n clks) ’ by ( + match_mp_tac flookup_fupdate_zip_not_mem >> + fs []) >> + fs [] +QED + + +Triviality one_leq_suc: + ∀n. 1 ≤ SUC n +Proof + Induct >> + fs [] +QED + +Triviality lt_less_one: + n < m - 1 ⇒ n < (m:num) +Proof + rw [] >> + fs [] +QED + +Theorem mod_greater_neq1: + d + st = (st + wt) MOD (k:num) ∧ + wt < k ∧ d < wt ∧ + k < st + wt ⇒ F +Proof + CCONTR_TAC >> fs [] >> + ‘0 < k’ by fs [] >> + ‘d + st < k’ by metis_tac [MOD_LESS] >> + ‘((st + wt) - k) MOD k = (st + wt) MOD k’ by (irule SUB_MOD >> fs []) >> + pop_assum (fs o single o GSYM) +QED + + +Theorem eval_wait_not_zero': + !(t:('a,'b) panSem$state). + FLOOKUP t.locals «isInput» = SOME (ValWord 1w) ∧ + FLOOKUP t.locals «waitSet» = SOME (ValWord 0w) ∧ + (?tm. FLOOKUP t.locals «sysTime» = SOME (ValWord (n2w tm)) ∧ + ?wt st. + FLOOKUP t.locals «wakeUpAt» = SOME (ValWord (n2w (st + wt))) ∧ + tm < st + wt ∧ st ≤ tm ∧ + wt < dimword (:α) ∧ + tm < dimword (:α) ∧ + st < dimword (:α)) ==> + ?w. + eval t wait = SOME (ValWord w) ∧ + w ≠ 0w +Proof + rw [] >> + ‘∃d. tm = d + st’ by ( + gs [LESS_OR_EQ] + >- metis_tac [LESS_ADD] >> + qexists_tac ‘0’ >> gs []) >> + gvs [] >> + fs [wait_def] >> + fs [eval_def, OPT_MMAP_def] >> + gs [active_low_def, + wordLangTheory.word_op_def] >> + TOP_CASE_TAC >> + fs [] >> + fs [asmTheory.word_cmp_def] >> + fs [addressTheory.WORD_CMP_NORMALISE] >> + fs [word_ls_n2w] >> + ‘wt MOD dimword (:α) = wt’ by ( + match_mp_tac LESS_MOD >> fs []) >> + ‘st MOD dimword (:α) = st’ by ( + match_mp_tac LESS_MOD >> fs []) >> + fs [] >> rveq >> gs [] >> + cases_on ‘st + wt < dimword (:α)’ + >- ( + ‘(st + wt) MOD dimword (:α) = st + wt’ by ( + match_mp_tac LESS_MOD >> fs []) >> + gs []) >> + gs [NOT_LESS] >> + gs [LESS_OR_EQ] >> + metis_tac [mod_greater_neq1] +QED + +Theorem step_input: + !prog i m n s s' (t:('a,time_input) panSem$state) ist. + step prog (LAction (Input i)) m n s s' ∧ + m = dimword (:α) - 1 ∧ + n = FST (t.ffi.ffi_state 0) ∧ + FST (t.ffi.ffi_state 1) < dimword (:α) - 2 ∧ + ~MEM "get_time_input" (MAP explode (out_signals prog)) ∧ + state_rel (clksOf prog) (out_signals prog) s t ∧ + wakeup_shape t.locals s.waitTime ist ∧ + input_stime_rel s.waitTime ist (FST (t.ffi.ffi_state 0)) ∧ + (* wait_time_locals (:α) t.locals s.waitTime t.ffi.ffi_state ∧ *) + (* wait_time_locals (:α) t.locals s.waitTime t.ffi.ffi_state ∧ *) + well_formed_terms prog s.location t.code ∧ + code_installed t.code prog ∧ + (* we can update the input_rel to take t.ffi.ffi_state, but this + is also fine *) + input_rel t.locals i (next_ffi t.ffi.ffi_state) ∧ + FLOOKUP t.locals «isInput» = SOME (ValWord 1w) ∧ + mem_read_ffi_results (:α) t.ffi.ffi_state 1 ∧ + task_ret_defined t.locals (nClks prog) ∧ + good_dimindex (:'a) ⇒ + ?ck t'. + evaluate (task_controller (nClks prog), t with clock := t.clock + ck) = + (NONE, t') ∧ + code_installed t'.code prog ∧ + state_rel (clksOf prog) (out_signals prog) s' t' ∧ + t'.ffi.ffi_state = next_ffi t.ffi.ffi_state ∧ + t'.ffi.oracle = t.ffi.oracle ∧ + t'.code = t.code ∧ + t'.be = t.be ∧ + t'.eshapes = t.eshapes ∧ + FLOOKUP t'.locals «sysTime» = FLOOKUP t.locals «sysTime» ∧ + FLOOKUP t'.locals «event» = SOME (ValWord 0w) ∧ + FLOOKUP t'.locals «isInput» = SOME (ValWord 1w) ∧ + task_ret_defined t'.locals (nClks prog) ∧ + input_io_events_rel i t t' ∧ + FLOOKUP t'.locals «wakeUpAt» = + SOME (ValWord (n2w (FST (t.ffi.ffi_state 0) + + case s'.waitTime of + | NONE => 0 + | SOME wt => wt))) ∧ + FLOOKUP t'.locals «waitSet» = + SOME (ValWord (n2w ( + case s'.waitTime of + | NONE => 1 + | _ => 0))) ∧ + (case s'.waitTime of + | SOME wt => wt < dimword (:α) + | _ => T) + +Proof + rw [] >> + fs [task_controller_def] >> + fs [panLangTheory.nested_seq_def] >> + qmatch_goalsub_abbrev_tac ‘evaluate (Seq _ q, _)’ >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + qexists_tac ‘2’ >> + pairarg_tac >> gs [] >> + pop_assum mp_tac >> + fs [wait_input_time_limit_def] >> + rewrite_tac [Once evaluate_def] >> + ‘∃w. eval t wait = SOME (ValWord w) ∧ w ≠ 0w’ by ( + cases_on ‘s.waitTime’ + >- ( + gs [state_rel_def, equivs_def, active_low_def] >> + match_mp_tac step_delay_eval_wait_not_zero >> + gs [state_rel_def, equivs_def, time_vars_def, active_low_def]) >> + ‘x ≠ 0’ by gs [step_cases] >> + match_mp_tac eval_wait_not_zero' >> + gs [input_rel_def, next_ffi_def] >> + conj_tac + >- gs [state_rel_def, equivs_def, active_low_def, time_vars_def] >> + qexists_tac ‘FST (t.ffi.ffi_state 1)’ >> + gs [] >> + gvs [wakeup_shape_def, input_stime_rel_def] >> + qexists_tac ‘wt'’ >> + qexists_tac ‘ist’ >> + gs [input_rel_def, next_ffi_def] >> + gs [state_rel_def] >> + pairarg_tac >> gs [] >> gs [] >> + ‘FST (t.ffi.ffi_state 1) = FST (t.ffi.ffi_state 0)’ by ( + gs [input_time_rel_def] >> + last_x_assum (qspec_then ‘0’ mp_tac) >> + gs [input_time_eq_def, has_input_def]) >> + gvs [step_cases]) >> + gs [eval_upd_clock_eq] >> + gs [dec_clock_def] >> + (* evaluating the function *) + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once check_input_time_def] >> + fs [panLangTheory.nested_seq_def] >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + drule state_rel_imp_mem_config >> + rewrite_tac [Once mem_config_def] >> + strip_tac >> + fs [] >> + ‘∃bytes. + read_bytearray ffiBufferAddr (w2n (ffiBufferSize:'a word)) + (mem_load_byte t.memory t.memaddrs t.be) = SOME bytes’ by ( + match_mp_tac read_bytearray_some_bytes_for_ffi >> + gs []) >> + drule evaluate_ext_call >> + disch_then (qspecl_then [‘MAP explode (out_signals prog)’, ‘bytes’] mp_tac) >> + impl_tac + >- ( + gs [state_rel_def] >> + pairarg_tac >> gs []) >> + strip_tac >> gs [] >> + rveq >> gs [] >> + drule state_rel_imp_ffi_vars >> + strip_tac >> + pop_assum mp_tac >> + rewrite_tac [Once ffi_vars_def] >> + strip_tac >> + drule state_rel_imp_systime_defined >> + strip_tac >> + (* reading systime *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «sysTime» _, nt)’ >> + ‘nt.memory ffiBufferAddr = Word (n2w (FST(t.ffi.ffi_state 1)))’ by ( + fs [Abbr ‘nt’] >> + qpat_x_assum ‘mem_read_ffi_results _ _ _’ assume_tac >> + gs [mem_read_ffi_results_def] >> + qmatch_asmsub_abbrev_tac ‘evaluate (ExtCall _ _ _ _ _, _) = (_, ft)’ >> + last_x_assum + (qspecl_then + [‘t with clock := t.clock + 1’, + ‘ft’] mp_tac) >> + impl_tac + >- gs [Abbr ‘ft’, nexts_ffi_def, GSYM ETA_AX] >> + strip_tac >> + gs [Abbr ‘ft’, nexts_ffi_def]) >> + drule evaluate_assign_load >> + gs [] >> + disch_then (qspecl_then + [‘ffiBufferAddr’, ‘tm’, + ‘n2w (FST (t.ffi.ffi_state 1))’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nt’] >> + fs [state_rel_def]) >> + strip_tac >> fs [] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + (* reading input to the variable event *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «event» _, nnt)’ >> + ‘nnt.memory (ffiBufferAddr + bytes_in_word) = + Word (n2w (SND(t.ffi.ffi_state 1)))’ by ( + fs [Abbr ‘nnt’, Abbr ‘nt’] >> + qpat_x_assum ‘mem_read_ffi_results _ _ _’ assume_tac >> + gs [mem_read_ffi_results_def] >> + qmatch_asmsub_abbrev_tac ‘evaluate (ExtCall _ _ _ _ _, _) = (_, ft)’ >> + last_x_assum (qspecl_then [‘t with clock := t.clock + 1’, ‘ft’] mp_tac) >> + impl_tac + >- gs [Abbr ‘ft’, nexts_ffi_def, GSYM ETA_AX] >> + strip_tac >> + gs [Abbr ‘ft’, nexts_ffi_def, GSYM ETA_AX]) >> + gs [] >> + drule evaluate_assign_load_next_address >> + gs [] >> + disch_then (qspecl_then + [‘ffiBufferAddr’, + ‘n2w (SND (nexts_ffi 0 t.ffi.ffi_state 1))’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nnt’,Abbr ‘nt’, active_low_def] >> + gs [state_rel_def, time_vars_def, FLOOKUP_UPDATE, + nexts_ffi_def, mem_config_def]) >> + strip_tac >> + rveq >> gs [] >> + (* isInput *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «isInput» _, nnnt)’ >> + ‘nnnt.memory (ffiBufferAddr + bytes_in_word) = + Word (n2w (SND(t.ffi.ffi_state 1)))’ by fs [Abbr ‘nnnt’] >> + gs [] >> + ‘nnnt.memory (ffiBufferAddr + bytes_in_word) ≠ Word 0w’ by ( + gs [input_rel_def, nexts_ffi_def, next_ffi_def] >> + gs [step_cases] >> + drule pick_term_dest_eq >> + strip_tac >> + pop_assum mp_tac >> + disch_then (qspec_then ‘SND (t.ffi.ffi_state 1) − 1’ mp_tac) >> + impl_tac >- fs [] >> + strip_tac >> + ‘SND (t.ffi.ffi_state 1) − 1 + 1 = SND (t.ffi.ffi_state 1)’ by ( + match_mp_tac SUB_ADD >> + cases_on ‘SND (t.ffi.ffi_state 1)’ + >- metis_tac [] >> + metis_tac [one_leq_suc]) >> + ‘SND (t.ffi.ffi_state 1) MOD dimword (:α) = + SND (t.ffi.ffi_state 1)’ suffices_by metis_tac [] >> + match_mp_tac LESS_MOD >> + match_mp_tac lt_less_one >> + metis_tac []) >> + fs [] >> + drule evaluate_assign_compare_next_address_uneq >> + gs [] >> + disch_then (qspecl_then [‘ffiBufferAddr’, + ‘n2w (SND (t.ffi.ffi_state 1))’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nnnt’, Abbr ‘nnt’,Abbr ‘nt’, active_low_def] >> + gs [state_rel_def, time_vars_def, FLOOKUP_UPDATE] >> + gs [nexts_ffi_def, mem_config_def]) >> + strip_tac >> + gs [] >> rveq >> gs [] >> + (* If statement *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + drule evaluate_if_compare_sys_time >> + disch_then (qspec_then ‘FST (t.ffi.ffi_state 1)’ mp_tac) >> + impl_tac + >- ( + unabbrev_all_tac >> + gs [FLOOKUP_UPDATE, nexts_ffi_def] >> + gs [step_cases, ADD1, state_rel_def, input_time_rel_def] >> + pairarg_tac >> gs [] >> + last_x_assum (qspec_then ‘0’ mp_tac) >> + gs [input_time_eq_def, has_input_def, input_rel_def, next_ffi_def] >> + strip_tac >> + drule LESS_MOD >> + strip_tac >> gs []) >> + strip_tac >> rveq >> gs [] >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + strip_tac >> fs [] >> + rveq >> gs [] >> + strip_tac >> + (* loop should break now *) + fs [step_cases] >> + gs [input_rel_def] >> + pop_assum mp_tac >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + fs [wait_input_time_limit_def] >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + ‘FLOOKUP (nnnt with locals := nnnt.locals |+ («isInput» ,ValWord 0w)).locals + «isInput» = SOME (ValWord 0w)’ by fs [FLOOKUP_UPDATE] >> + drule step_input_eval_wait_zero >> + impl_tac + >- ( + unabbrev_all_tac >> gs [] >> + fs [FLOOKUP_UPDATE] >> + gs [state_rel_def, time_vars_def]) >> + gs [eval_upd_clock_eq] >> + strip_tac >> + strip_tac >> + unabbrev_all_tac >> + rveq >> gs [] >> + (* the new If statement *) + qmatch_goalsub_abbrev_tac ‘evaluate (Seq _ q, nnt)’ >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> gs [] >> + pop_assum mp_tac >> + rewrite_tac [Once evaluate_def] >> + unabbrev_all_tac >> + gvs [eval_def, FLOOKUP_UPDATE, asmTheory.word_cmp_def] >> + rewrite_tac [Once evaluate_def] >> + gvs [] >> + strip_tac >> gvs [] >> + (* until here *) + qmatch_goalsub_abbrev_tac ‘evaluate (Seq _ q, nnt)’ >> + ‘FLOOKUP nnt.locals «loc» = FLOOKUP t.locals «loc»’ by + fs [Abbr ‘nnt’, FLOOKUP_UPDATE] >> + ‘nnt.code = t.code’ by + fs [Abbr ‘nnt’, state_component_equality] >> + ‘FST (t.ffi.ffi_state 1) = FST (t.ffi.ffi_state 0)’ by ( + gs [state_rel_def] >> + pairarg_tac >> + gs [input_time_rel_def, input_time_eq_def] >> + last_x_assum (qspec_then ‘0’ mp_tac) >> + impl_tac + >- gs [has_input_def, next_ffi_def] >> + gs []) >> + ‘FLOOKUP nnt.locals «clks» = FLOOKUP t.locals «clks»’ by + fs [Abbr ‘nnt’, FLOOKUP_UPDATE] >> + (* calling the function *) + (* location will come from equivs: state_rel *) + imp_res_tac state_rel_imp_equivs >> + fs [equivs_def] >> + qmatch_asmsub_abbrev_tac + ‘FLOOKUP _ «loc» = SOME (ValLabel loc)’ >> + ‘FLOOKUP t.code loc = + SOME + ([(«clks» ,genShape (LENGTH (clksOf prog))); («event» ,One)], + compTerms (clksOf prog) «clks» «event» tms)’ by ( + fs [code_installed_def] >> + drule ALOOKUP_MEM >> + strip_tac >> + last_x_assum drule >> + strip_tac >> + fs [Abbr ‘loc’]) >> + (* evaluation *) + fs [Once evaluate_def] >> + pairarg_tac >> + fs [] >> + fs [Once evaluate_def, eval_upd_clock_eq] >> + gs [Once eval_def, eval_upd_clock_eq, FLOOKUP_UPDATE] >> + ‘FLOOKUP nnt.locals «sysTime» = SOME (ValWord (n2w (FST (t.ffi.ffi_state 0))))’ by + gs [Abbr ‘nnt’, FLOOKUP_UPDATE] >> + drule eval_normalisedClks >> + gs [Abbr ‘nnt’, FLOOKUP_UPDATE] >> + qpat_x_assum ‘state_rel (clksOf prog) (out_signals prog) s t’ assume_tac >> + drule state_rel_intro >> + strip_tac >> gs [] >> + pairarg_tac >> gs [] >> + gs [clocks_rel_def] >> + disch_then (qspec_then ‘ns’ mp_tac) >> + impl_tac + >- ( + conj_tac + >- gs [EVERY_MEM, time_seq_def] >> + fs [EVERY_MEM] >> + rw [] >> + gs [clkvals_rel_def] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + fs [MEM_EL] >> + first_x_assum (qspec_then ‘n'’ mp_tac) >> + fs [] >> + strip_tac >> + ‘(EL n' (ZIP (clksOf prog,ns))) = + (EL n' (clksOf prog),EL n' ns)’ by ( + match_mp_tac EL_ZIP >> + gs []) >> + fs []) >> + strip_tac >> + fs [] >> + fs [OPT_MMAP_def] >> + fs [Once eval_def] >> + qmatch_asmsub_abbrev_tac ‘(eval nnt)’ >> + ‘(λa. eval nnt a) = + eval nnt’ by metis_tac [ETA_AX] >> + fs [] >> + fs [timeLangTheory.nClks_def] >> + ‘LENGTH (clksOf prog) = LENGTH ns’ by gs [] >> + gs [] >> + (* event eval *) + gs [Abbr ‘nnt’, eval_def, FLOOKUP_UPDATE, nexts_ffi_def] >> + gs [lookup_code_def] >> + fs [timeLangTheory.nClks_def] >> + ‘LENGTH (clksOf prog) = LENGTH ns’ by gs [] >> + drule (INST_TYPE + [``:'a``|->``:'mlstring``, + ``:'b``|->``:'a``] genshape_eq_shape_of) >> + disch_then (qspec_then ‘tm’ assume_tac) >> + rfs [] >> + fs [] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + fs [shape_of_def] >> + fs [dec_clock_def] >> + pop_assum kall_tac >> + qmatch_asmsub_abbrev_tac ‘(«clks» ,Struct nclks)’ >> + qmatch_asmsub_abbrev_tac ‘evaluate (_, nnt)’ >> + gs [next_ffi_def] >> + drule (INST_TYPE [``:'a``|->``:'a``, + ``:'b``|->``:time_input``] pick_term_thm) >> + fs [] >> + disch_then (qspecl_then [‘nnt’, ‘clksOf prog’, + ‘nclks’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nnt’] >> + res_tac >> gs [] >> rveq >> + gs [well_formed_terms_def] >> + conj_tac + >- ( + match_mp_tac mem_to_flookup >> + fs []) >> + conj_tac + >- gs [resetOutput_def, defined_clocks_def] >> + conj_tac + >- ( + fs [resetOutput_def, Abbr ‘nclks’] >> + gs [clkvals_rel_def, equiv_val_def] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + first_x_assum (qspec_then ‘n’ mp_tac) >> + fs [] >> + strip_tac >> + qmatch_goalsub_abbrev_tac ‘EL _ (ZIP (xs,_))’ >> + ‘EL n (ZIP (xs,ns)) = (EL n xs, EL n ns)’ by ( + match_mp_tac EL_ZIP >> + unabbrev_all_tac >> + fs []) >> + fs [Abbr ‘xs’] >> + ‘EL n (REPLICATE (LENGTH ns) (FST (t.ffi.ffi_state 1))) = FST (t.ffi.ffi_state 1)’ by ( + match_mp_tac EL_REPLICATE >> + fs []) >> + fs [] >> + ‘EL n (ZIP (clksOf prog,ns)) = (EL n (clksOf prog), EL n ns)’ by ( + match_mp_tac EL_ZIP >> + unabbrev_all_tac >> + fs []) >> + fs []) >> + conj_tac + >- ( + gs [Abbr ‘nclks’, defined_clocks_def, maxClksSize_def] >> + fs [MAP_MAP_o] >> + fs [SUM_MAP_FOLDL] >> + ‘LENGTH (REPLICATE (LENGTH ns) (FST (t.ffi.ffi_state 1))) = LENGTH ns’ by fs [] >> + drule foldl_word_size_of >> + disch_then (qspec_then ‘0’ mp_tac) >> + fs []) >> + gs [resetOutput_def] >> + gs [out_signals_ffi_def, well_behaved_ffi_def] >> + gs [EVERY_MEM] >> + gen_tac >> + strip_tac >> + gs [] >> + conj_tac + >- gs [mlintTheory.num_to_str_thm] >> + conj_tac + >- gs [ffiBufferSize_def, bytes_in_word_def, + good_dimindex_def] >> + gs [mem_call_ffi_def, ffi_call_ffi_def] >> + qmatch_goalsub_abbrev_tac ‘mem_load_byte mm _ _’ >> + ‘∃bytes. + read_bytearray ffiBufferAddr (w2n (ffiBufferSize:'a word)) + (mem_load_byte mm t.memaddrs t.be) = SOME bytes’ by ( + match_mp_tac read_bytearray_some_bytes_for_ffi >> + gs [state_rel_def, mem_config_def]) >> + qexists_tac ‘bytes'’ >> gs [] >> + gs [next_ffi_def, build_ffi_def] >> + gs [ffiTheory.ffi_state_component_equality] >> + ‘MEM tms (MAP SND prog)’ by ( + drule ALOOKUP_MEM >> + gs [MEM_MAP] >> + strip_tac >> + qexists_tac ‘(s.location,tms)’ >> + gs []) >> + ‘MEM (explode (toString out)) (MAP explode (out_signals prog))’ by ( + gs [timeLangTheory.out_signals_def] >> + gs [MEM_MAP] >> + qexists_tac ‘out’ >> gs [] >> + match_mp_tac terms_out_signals_prog >> + qexists_tac ‘tms’ >> + gs [MEM_MAP] >> + metis_tac []) >> + cases_on ‘explode (num_to_str out) = "get_time_input"’ >> + gs []) >> + impl_tac + >- ( + fs [Abbr ‘nnt’] >> + conj_tac + >- ( + drule pick_term_dest_eq >> + strip_tac >> + pop_assum mp_tac >> + disch_then (qspec_then ‘SND (t.ffi.ffi_state 1) − 1’ mp_tac) >> + impl_tac >- fs [] >> + strip_tac >> + ‘SND (t.ffi.ffi_state 1) − 1 + 1 < dimword (:α)’ by ( + match_mp_tac lt_less_one >> + metis_tac []) >> + ‘1 ≤ SND (t.ffi.ffi_state 1)’ by ( + cases_on ‘SND (t.ffi.ffi_state 1)’ + >- metis_tac [] >> + metis_tac [one_leq_suc]) >> + drule SUB_ADD >> + strip_tac >> + metis_tac []) >> + (* from pick_term theorem *) + match_mp_tac mem_to_flookup >> + fs []) >> + strip_tac >> fs [] >> + qmatch_asmsub_abbrev_tac + ‘is_valid_value rt _ rtv’ >> + ‘is_valid_value rt «taskRet» rtv’ by ( + fs [Abbr ‘rt’, Abbr ‘rtv’] >> + fs [retVal_def] >> + fs [is_valid_value_def] >> + fs [FLOOKUP_UPDATE] >> + gs [task_ret_defined_def] >> + fs [shape_of_def] >> + gs [EVERY_MEM] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN, resetClksVals_def] >> + rw [] >> + fs [MEM_EL] >> + last_x_assum (qspec_then ‘EL n vs’ mp_tac) >> + fs [] >> + impl_tac + >- metis_tac [] >> + strip_tac >> + fs [] >> + qmatch_goalsub_abbrev_tac ‘MAP ff xs’ >> + ‘EL n (MAP ff xs) = ff (EL n xs)’ by ( + match_mp_tac EL_MAP >> + fs [Abbr ‘xs’]) >> + fs [Abbr ‘ff’, shape_of_def]) >> + fs [] >> + gs [panSemTheory.set_var_def] >> + rveq >> gs [] >> + (* from here *) + fs [Abbr ‘q’] >> + qmatch_goalsub_abbrev_tac ‘evaluate (Seq _ q, _)’ >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once evaluate_def] >> + fs [Abbr ‘rt’, Abbr ‘rtv’] >> + fs [retVal_def] >> + fs [eval_def, FLOOKUP_UPDATE] >> + fs [] >> + qmatch_goalsub_abbrev_tac + ‘is_valid_value rt _ rtv’ >> + ‘is_valid_value rt «clks» rtv’ by ( + fs [Abbr ‘rt’, Abbr ‘rtv’] >> + fs [retVal_def] >> + fs [is_valid_value_def] >> + fs [FLOOKUP_UPDATE] >> + fs [shape_of_def] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN, resetClksVals_def] >> + rw [] >> + gs [] >> + qmatch_goalsub_abbrev_tac ‘MAP ff xs’ >> + ‘EL n (MAP ff xs) = ff (EL n xs)’ by ( + match_mp_tac EL_MAP >> + fs [Abbr ‘xs’]) >> + fs [Abbr ‘ff’, shape_of_def] >> + ‘EL n (MAP ((λw. ValWord w) ∘ n2w) ns) = + ((λw. ValWord w) ∘ n2w) (EL n ns)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [shape_of_def]) >> + fs [] >> + strip_tac >> rveq >> gs [] >> + fs [Abbr ‘q’] >> + qmatch_goalsub_abbrev_tac ‘evaluate (Seq _ q, _)’ >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once evaluate_def] >> + fs [eval_def] >> + qmatch_goalsub_abbrev_tac ‘eval fnt’ >> + ‘FLOOKUP fnt.locals «sysTime» = SOME (ValWord (n2w (FST (t.ffi.ffi_state 1))))’ by ( + unabbrev_all_tac >> + fs [FLOOKUP_UPDATE]) >> + ‘(λa. eval fnt a) = + eval fnt’ by metis_tac [ETA_AX] >> + fs [] >> + pop_assum kall_tac >> + ‘FLOOKUP fnt.locals «clks» = + SOME (Struct (MAP ((λw. ValWord w) ∘ n2w) + (MAP (λck. + if MEM ck tclks then 0 else THE (FLOOKUP s.clocks ck)) (clksOf prog))))’ by ( + fs [Abbr ‘fnt’, FLOOKUP_UPDATE] >> + fs [Abbr ‘rtv’] >> + gs [resetOutput_def] >> + match_mp_tac resetClksVals_eq_map >> + conj_tac + >- ( + gs [well_formed_terms_def, EVERY_MEM, terms_valid_clocks_def] >> + rw [] >> + last_x_assum drule >> + gs [valid_clks_def, timeLangTheory.termClks_def, EVERY_MEM]) >> + gs [state_rel_def, defined_clocks_def, EVERY_MEM] >> + rw [] >> res_tac >> gs []) >> + ‘EVERY (λn. n ≤ FST (t.ffi.ffi_state 1)) + (MAP (λck. + if MEM ck tclks then 0 else THE (FLOOKUP s.clocks ck)) (clksOf prog))’ by ( + gs [EVERY_MAP, EVERY_MEM] >> + rw [] >> + gs [state_rel_def, clock_bound_def, EVERY_MEM] >> + rw [] >> res_tac >> gs [] >> + gs [clkvals_rel_def, MAP_EQ_EVERY2, LIST_REL_EL_EQN, EVERY_MEM] >> + first_x_assum (qspec_then ‘ck’ assume_tac) >> + gs []) >> + drule_all eval_normalisedClks >> + strip_tac >> + gs [] >> + pop_assum kall_tac >> + qmatch_goalsub_abbrev_tac + ‘is_valid_value rrt _ rrtv’ >> + ‘is_valid_value rrt «clks» rrtv’ by ( + fs [Abbr ‘rrt’,Abbr ‘rrtv’, Abbr ‘rt’, Abbr ‘rtv’] >> + fs [is_valid_value_def] >> + fs [FLOOKUP_UPDATE] >> + fs [shape_of_def] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN, resetClksVals_def] >> + rw [] >> + gs [] >> + qmatch_goalsub_abbrev_tac ‘MAP ff xs’ >> + ‘EL n (MAP ff xs) = ff (EL n xs)’ by ( + match_mp_tac EL_MAP >> + fs [Abbr ‘xs’]) >> + fs [Abbr ‘ff’, shape_of_def, Abbr ‘xs’] >> + qmatch_goalsub_abbrev_tac ‘ZIP (xs,ys)’ >> + ‘EL n (ZIP (xs,ys)) = + (EL n xs,EL n ys)’ by ( + match_mp_tac EL_ZIP >> + fs [Abbr ‘xs’, Abbr ‘ys’]) >> + fs [Abbr ‘xs’, Abbr ‘ys’] >> + fs [shape_of_def] >> + qmatch_goalsub_abbrev_tac ‘MAP ff xs’ >> + ‘EL n (MAP ff xs) = ff (EL n xs)’ by ( + match_mp_tac EL_MAP >> + fs [Abbr ‘xs’]) >> + fs [Abbr ‘ff’, Abbr ‘xs’, shape_of_def]) >> + fs [] >> + strip_tac >> gs [] >> rveq >> gs [] >> + fs [Abbr ‘q’] >> + qmatch_goalsub_abbrev_tac ‘evaluate (Seq _ q, _)’ >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once evaluate_def] >> + fs [Abbr ‘rt’, eval_def, FLOOKUP_UPDATE] >> + qmatch_goalsub_abbrev_tac + ‘is_valid_value wvt _ hm’ >> + ‘is_valid_value wvt «waitSet» hm’ by ( + fs [Abbr ‘wvt’,Abbr ‘hm’] >> + fs [is_valid_value_def] >> + fs [FLOOKUP_UPDATE] >> + fs [shape_of_def]) >> + fs [Abbr ‘wvt’,Abbr ‘hm’] >> + strip_tac >> + gs [] >> rveq >> gs [] >> + fs [Abbr ‘q’] >> + qmatch_goalsub_abbrev_tac ‘evaluate (Seq _ q, _)’ >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once evaluate_def] >> + fs [eval_def, FLOOKUP_UPDATE, OPT_MMAP_def, + wordLangTheory.word_op_def] >> + fs [is_valid_value_def, FLOOKUP_UPDATE, shape_of_def] >> + strip_tac >> + gs [] >> rveq >> gs [] >> + drule state_rel_imp_time_vars >> + gs [time_vars_def, shape_of_def] >> rveq >> gs [] >> + fs [Abbr ‘q’] >> + fs [evaluate_def] >> + fs [eval_def, FLOOKUP_UPDATE] >> + fs [is_valid_value_def, FLOOKUP_UPDATE, shape_of_def] >> + (* evaluation completed *) + conj_tac + >- (unabbrev_all_tac >> gs [] >> rveq >> gs []) >> + conj_tac + >- ( + rw [state_rel_def] + >- ( + gs [equivs_def, FLOOKUP_UPDATE] >> + drule pick_term_dest_eq >> + strip_tac >> + pop_assum mp_tac >> + disch_then (qspec_then ‘SND (t.ffi.ffi_state 1) − 1’ mp_tac) >> + impl_tac >- fs [] >> + strip_tac >> + pop_assum mp_tac >> + disch_then drule >> + gs [] >> + strip_tac >> + TOP_CASE_TAC >> gs [active_low_def]) + >- gs [ffi_vars_def, FLOOKUP_UPDATE] + >- gs [time_vars_def, FLOOKUP_UPDATE] + >- ( + unabbrev_all_tac >> + gs [mem_config_def] >> + fs[mem_call_ffi_def]) + >- ( + gs [defined_clocks_def] >> + fs [EVERY_MEM] >> + rw [] >> + gs [state_rel_def, defined_clocks_def] >> + last_x_assum drule >> + fs [] >> + strip_tac >> + imp_res_tac eval_term_clocks_reset >> + gs [resetOutput_def] >> + res_tac >> gs []) >> + pairarg_tac >> gs [] >> rveq >> gs [] >> + rw [] + >- ( + gs [nffi_state_def, build_ffi_def] >> + fs [Abbr ‘nnt’, ffi_call_ffi_def] >> + gs [ffiTheory.ffi_state_component_equality]) + >- ( + gs [Abbr ‘nnt’, input_time_rel_def, + ffi_call_ffi_def, next_ffi_def, input_time_eq_def] >> + rw [] >> + first_x_assum (qspec_then ‘n+1’ mp_tac) >> + gs []) + >- ( + gs [time_seq_def, nffi_state_def, ffi_call_ffi_def, + Abbr ‘nnt’, next_ffi_def] >> + rw [] >> + first_x_assum (qspec_then ‘n+1’ assume_tac) >> + metis_tac [ADD]) + >- ( + gs [Abbr ‘nnt’, FLOOKUP_UPDATE, nffi_state_def] >> + gs [ffi_call_ffi_def, next_ffi_def]) >> + gs [clocks_rel_def, FLOOKUP_UPDATE, nffi_state_def] >> + fs [Abbr ‘rrtv’] >> + fs [nffi_state_def, Abbr ‘nnt’, ffi_call_ffi_def, next_ffi_def] >> + qexists_tac ‘MAP (λck. tm - THE (FLOOKUP s'.clocks ck)) (clksOf prog)’ >> + gs [] >> + conj_tac + >- ( + gs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> gs [] >> + qmatch_goalsub_abbrev_tac ‘EL _ (ZIP (xs,ys))’ >> + ‘EL n (ZIP (xs,ys)) = (EL n xs, EL n ys)’ by ( + match_mp_tac EL_ZIP >> + unabbrev_all_tac >> + fs []) >> + fs [Abbr ‘xs’] >> + ‘EL n (REPLICATE (LENGTH ns) tm) = tm’ by ( + match_mp_tac EL_REPLICATE >> + fs []) >> + fs [] >> + fs [Abbr ‘ys’] >> + qmatch_goalsub_abbrev_tac ‘MAP ff xs’ >> + ‘EL n (MAP ff xs) = ff (EL n xs)’ by ( + match_mp_tac EL_MAP >> + fs [Abbr ‘xs’]) >> + fs [Abbr ‘ff’, Abbr ‘xs’] >> + qmatch_goalsub_abbrev_tac ‘MAP ff xs’ >> + ‘EL n (MAP ff xs) = ff (EL n xs)’ by ( + match_mp_tac EL_MAP >> + fs [Abbr ‘xs’]) >> + fs [Abbr ‘ff’, Abbr ‘xs’] >> + TOP_CASE_TAC >> gs [] + >- ( + ‘FLOOKUP s'.clocks (EL n (clksOf prog)) = SOME 0’ by ( + gs [evalTerm_cases, resetOutput_def, resetClocks_def, MEM_EL] >> + metis_tac [update_eq_zip_map_flookup]) >> + gs []) >> + ‘?x. FLOOKUP s.clocks (EL n (clksOf prog)) = SOME x ∧ + FLOOKUP s'.clocks (EL n (clksOf prog)) = SOME x’ by ( + gs [evalTerm_cases, resetOutput_def, resetClocks_def, MEM_EL] >> + gs [defined_clocks_def, EVERY_MEM] >> + last_x_assum (qspec_then ‘EL n (clksOf prog)’ mp_tac) >> + impl_tac + >- metis_tac [MEM_EL] >> + strip_tac >> + gs [] >> + qpat_x_assum ‘_ = SOME n''’ (assume_tac o GSYM) >> + fs [] >> + match_mp_tac flookup_fupdate_zip_not_mem >> + gs [MEM_EL]) >> + gs []) >> + gs [clkvals_rel_def] >> + conj_tac + >- ( + gs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> gs [] >> + qmatch_goalsub_abbrev_tac ‘EL _ (ZIP (xs,ys))’ >> + ‘EL n (ZIP (xs,ys)) = (EL n xs, EL n ys)’ by ( + match_mp_tac EL_ZIP >> + unabbrev_all_tac >> + fs []) >> + fs [Abbr ‘xs’, Abbr ‘ys’] >> + qmatch_goalsub_abbrev_tac ‘MAP ff xs’ >> + ‘EL n (MAP ff xs) = ff (EL n xs)’ by ( + match_mp_tac EL_MAP >> + fs [Abbr ‘xs’]) >> + fs [Abbr ‘ff’, Abbr ‘xs’] >> + ‘THE (FLOOKUP s'.clocks (EL n (clksOf prog))) <= tm’ by ( + gs [evalTerm_cases, resetOutput_def, resetClocks_def, MEM_EL] >> + cases_on ‘MEM (EL n (clksOf prog)) tclks’ + >- ( + fs [MEM_EL] >> + ‘FLOOKUP (s.clocks |++ ZIP (tclks,MAP (λx. 0) tclks)) + (EL n'' tclks) = SOME 0’ by + metis_tac [update_eq_zip_map_flookup]>> + fs []) >> + gs [defined_clocks_def, EVERY_MEM] >> + last_x_assum (qspec_then ‘EL n (clksOf prog)’ mp_tac) >> + impl_tac + >- metis_tac [MEM_EL] >> + strip_tac >> + gs [] >> + ‘FLOOKUP (s.clocks |++ ZIP (tclks,MAP (λx. 0) tclks)) + (EL n (clksOf prog)) = SOME n''’ by ( + qpat_x_assum ‘_ = SOME n''’ (assume_tac o GSYM) >> + fs [] >> + match_mp_tac flookup_fupdate_zip_not_mem >> + gs [MEM_EL]) >> + fs [] >> + last_x_assum (qspec_then ‘EL n (clksOf prog)’ mp_tac) >> + impl_tac >- metis_tac [MEM_EL] >> + gs []) >> + gs []) >> + fs [EVERY_MEM] >> + rw [] >> + gs [evalTerm_cases, resetOutput_def, resetClocks_def, MEM_EL] >> + cases_on ‘MEM (EL n (clksOf prog)) tclks’ + >- ( + fs [MEM_EL] >> + ‘FLOOKUP (s.clocks |++ ZIP (tclks,MAP (λx. 0) tclks)) + (EL n'' tclks) = SOME 0’ by + metis_tac [update_eq_zip_map_flookup]>> + fs []) >> + gs [defined_clocks_def, EVERY_MEM] >> + last_x_assum (qspec_then ‘EL n (clksOf prog)’ mp_tac) >> + impl_tac + >- metis_tac [MEM_EL] >> + strip_tac >> + gs [] >> + ‘FLOOKUP (s.clocks |++ ZIP (tclks,MAP (λx. 0) tclks)) + (EL n (clksOf prog)) = SOME n''’ by ( + qpat_x_assum ‘_ = SOME n''’ (assume_tac o GSYM) >> + fs [] >> + match_mp_tac flookup_fupdate_zip_not_mem >> + gs [MEM_EL]) >> + fs [] >> + last_x_assum (qspec_then ‘EL n (clksOf prog)’ mp_tac) >> + impl_tac >- metis_tac [MEM_EL] >> + gs []) >> + fs [nffi_state_def, Abbr ‘nnt’] >> + gs [task_ret_defined_def, FLOOKUP_UPDATE, Abbr ‘rtv’, resetOutput_def, + resetClksVals_def, ffi_call_ffi_def] >> + fs [next_ffi_def] >> + fs [EVERY_MAP] >> + ‘terms_wtimes_ffi_bound (dimword (:α) − 1) + (s with <|ioAction := NONE; waitTime := NONE|>) tms’ by + gs [Once pickTerm_cases] >> + gs [terms_wtimes_ffi_bound_def] >> + gs [EVERY_MEM] >> + last_x_assum (qspec_then ‘Tm (Input (SND (t.ffi.ffi_state 1) − 1)) cnds tclks dest wt’ mp_tac) >> + gs [timeLangTheory.termClks_def, timeLangTheory.termWaitTimes_def, resetOutput_def] >> + strip_tac >> + reverse conj_tac + >- ( + cases_on ‘wt’ >> gs [] + >- ( + ‘s'.waitTime = NONE’ by ( + gs [Once pickTerm_cases] >> + rveq >> gs [] >> + gs [evalTerm_cases] >> rveq >> + gs [calculate_wtime_def, list_min_option_def]) >> + gs []) >> + fs [] >> + qmatch_goalsub_abbrev_tac ‘n2w (THE (nwt))’ >> + ‘?t. nwt = SOME t’ by ( + gs [Abbr ‘nwt’] >> + gs [calculate_wtime_def, list_min_option_def] >> + TOP_CASE_TAC >> + gs []) >> + gs [] >> + ‘s'.waitTime = nwt’ by ( + gs [Abbr ‘nwt’, Once pickTerm_cases] >> + rveq >> gs [] >> + gs [evalTerm_cases]) >> + gs [word_add_n2w]) >> + gs [input_io_events_rel_def] >> + conj_asm1_tac + >- ( + qexists_tac ‘bytes’ >> + gs [mk_ti_event_def, time_input_def] >> + drule read_bytearray_LENGTH >> + strip_tac >> + gs [ffiBufferSize_def, good_dimindex_def, + bytes_in_word_def, dimword_def]) >> + conj_asm1_tac + >- ( + gs [from_io_events_def, DROP_LENGTH_APPEND, io_events_dest_def, + mk_ti_event_def, io_event_dest_def, time_input_def] >> + qmatch_goalsub_abbrev_tac ‘ZIP (_, nbytes)’ >> + ‘LENGTH bytes' = LENGTH nbytes’ by ( + fs [Abbr ‘nbytes’, length_get_bytes] >> + gs [good_dimindex_def]) >> + drule MAP_ZIP >> + gs [] >> + strip_tac >> + ‘words_of_bytes t.be nbytes = + [n2w(FST (t.ffi.ffi_state 1)); (n2w(SND (t.ffi.ffi_state 1))):'a word]’ by ( + fs [Abbr ‘nbytes’] >> + match_mp_tac words_of_bytes_get_bytes >> + gs []) >> + gs [input_eq_ffi_seq_def] >> + cases_on ‘t.ffi.ffi_state 1’ >> gs [] >> + gs [input_rel_def, step_cases, next_ffi_def] >> + drule pick_term_dest_eq >> + simp []) >> + gs [from_io_events_def, DROP_LENGTH_APPEND, input_eq_ffi_seq_def] >> + gs [DROP_LENGTH_APPEND, decode_io_events_def, io_events_dest_def, + mk_ti_event_def, decode_io_event_def] >> + cases_on ‘t.ffi.ffi_state 1’ >> gs [] >> + gs [to_input_def] +QED + + +Theorem step_output: + !prog os m it s s' (t:('a,time_input) panSem$state). + step prog (LAction (Output os)) m it s s' ∧ + m = dimword (:α) - 1 ∧ + ~MEM "get_time_input" (MAP explode (out_signals prog)) ∧ + it = FST (t.ffi.ffi_state 0) ∧ + FST (t.ffi.ffi_state 0) < dimword (:α) - 2 ∧ + state_rel (clksOf prog) (out_signals prog) s t ∧ + well_formed_terms prog s.location t.code ∧ + code_installed t.code prog ∧ + output_rel t.locals t.ffi.ffi_state ∧ + FLOOKUP t.locals «isInput» = SOME (ValWord 1w) ∧ + FLOOKUP t.locals «event» = SOME (ValWord 0w) ∧ + task_ret_defined t.locals (nClks prog) ∧ + good_dimindex (:'a) ⇒ + ?ck t'. + evaluate (task_controller (nClks prog), t with clock := t.clock + ck) = + (NONE, t') ∧ + code_installed t'.code prog ∧ + state_rel (clksOf prog) (out_signals prog) s' t' ∧ + t'.ffi.ffi_state = t.ffi.ffi_state ∧ + t'.ffi.oracle = t.ffi.oracle ∧ + t'.code = t.code ∧ + t'.be = t.be ∧ + t'.eshapes = t.eshapes ∧ + FLOOKUP t'.locals «sysTime» = FLOOKUP t.locals «sysTime» ∧ + FLOOKUP t'.locals «event» = SOME (ValWord 0w) ∧ + FLOOKUP t'.locals «isInput» = SOME (ValWord 1w) ∧ + task_ret_defined t'.locals (nClks prog) ∧ + output_io_events_rel os t t' ∧ + FLOOKUP t'.locals «wakeUpAt» = + SOME (ValWord (n2w (FST (t.ffi.ffi_state 0) + + case s'.waitTime of + | NONE => 0 + | SOME wt => wt))) ∧ + FLOOKUP t'.locals «waitSet» = + SOME (ValWord (n2w ( + case s'.waitTime of + | NONE => 1 + | _ => 0))) ∧ + (case s'.waitTime of + | SOME wt => wt < dimword (:α) + | _ => T) +Proof + rw [] >> + fs [] >> + fs [step_cases, task_controller_def, + panLangTheory.nested_seq_def] >> + ‘FLOOKUP t.locals «waitSet» = SOME (ValWord 0w)’ by + gs [state_rel_def, equivs_def, active_low_def] >> + qmatch_goalsub_abbrev_tac ‘evaluate (Seq _ q, _)’ >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + fs [wait_input_time_limit_def] >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + qexists_tac ‘1’ >> + fs [] >> + gs [output_rel_def] >> + drule step_delay_eval_wait_zero >> + disch_then (qspec_then ‘n2w (nt + wt)’ mp_tac) >> + gs [] >> + strip_tac >> + gs [eval_upd_clock_eq] >> + fs [Abbr ‘q’] >> + (* the new If statement *) + qmatch_goalsub_abbrev_tac ‘evaluate (Seq _ q, nnt)’ >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> gs [] >> + pop_assum mp_tac >> + rewrite_tac [Once evaluate_def] >> + unabbrev_all_tac >> + gvs [eval_def, FLOOKUP_UPDATE, asmTheory.word_cmp_def] >> + rewrite_tac [Once evaluate_def] >> + gvs [] >> + strip_tac >> gvs [] >> + (* until here *) + qmatch_goalsub_abbrev_tac ‘evaluate (Seq _ q, _)’ >> + (* calling the function *) + (* location will come from equivs: state_rel *) + imp_res_tac state_rel_imp_equivs >> + fs [equivs_def] >> + qmatch_asmsub_abbrev_tac + ‘FLOOKUP _ «loc» = SOME (ValLabel loc)’ >> + ‘FLOOKUP t.code loc = + SOME + ([(«clks» ,genShape (LENGTH (clksOf prog))); («event» ,One)], + compTerms (clksOf prog) «clks» «event» tms)’ by ( + fs [code_installed_def] >> + drule ALOOKUP_MEM >> + strip_tac >> + last_x_assum drule >> + strip_tac >> + fs [Abbr ‘loc’]) >> + (* evaluation *) + fs [Once evaluate_def] >> + pairarg_tac >> + fs [] >> + fs [Once evaluate_def, eval_upd_clock_eq] >> + gs [Once eval_def, eval_upd_clock_eq, FLOOKUP_UPDATE] >> + qmatch_asmsub_abbrev_tac ‘OPT_MMAP (eval nnt) [_ ; _]’ >> + ‘FLOOKUP nnt.locals «sysTime» = SOME (ValWord (n2w (FST (t.ffi.ffi_state 0))))’ by + fs [Abbr ‘nnt’, FLOOKUP_UPDATE] >> + drule eval_normalisedClks >> + gs [Abbr ‘nnt’, FLOOKUP_UPDATE] >> + qpat_x_assum ‘state_rel (clksOf prog) (out_signals prog) s t’ assume_tac >> + drule state_rel_intro >> + strip_tac >> gs [] >> + pairarg_tac >> gs [] >> + gs [clocks_rel_def] >> + disch_then (qspec_then ‘ns’ mp_tac) >> + impl_tac + >- ( + conj_tac + >- gs [EVERY_MEM, time_seq_def, output_rel_def] >> + fs [EVERY_MEM] >> + rw [] >> + gs [clkvals_rel_def] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + fs [MEM_EL] >> + first_x_assum (qspec_then ‘n'’ mp_tac) >> + fs [] >> + strip_tac >> + ‘(EL n' (ZIP (clksOf prog,ns))) = + (EL n' (clksOf prog),EL n' ns)’ by ( + match_mp_tac EL_ZIP >> + gs []) >> + fs []) >> + strip_tac >> + fs [] >> + fs [OPT_MMAP_def] >> + fs [Once eval_def] >> + qmatch_asmsub_abbrev_tac ‘(eval nnt)’ >> + ‘(λa. eval nnt a) = + eval nnt’ by metis_tac [ETA_AX] >> + fs [] >> + fs [timeLangTheory.nClks_def] >> + ‘LENGTH (clksOf prog) = LENGTH ns’ by gs [] >> + gs [] >> + (* event eval *) + gs [Abbr ‘nnt’, eval_def, FLOOKUP_UPDATE] >> + gs [lookup_code_def] >> + fs [timeLangTheory.nClks_def] >> + ‘LENGTH (clksOf prog) = LENGTH ns’ by gs [] >> + drule (INST_TYPE + [``:'a``|->``:'mlstring``, + ``:'b``|->``:'a``] genshape_eq_shape_of) >> + disch_then (qspec_then ‘nt + wt’ assume_tac) >> + rfs [] >> + fs [] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + fs [shape_of_def] >> + fs [dec_clock_def] >> + pop_assum kall_tac >> + qmatch_asmsub_abbrev_tac ‘(«clks» ,Struct nclks)’ >> + qmatch_asmsub_abbrev_tac ‘evaluate (_, nnt)’ >> + drule (INST_TYPE [``:'a``|->``:'a``, + ``:'b``|->``:time_input``] pick_term_thm) >> + fs [] >> + disch_then (qspecl_then [‘nnt’, ‘clksOf prog’, + ‘nclks’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nnt’] >> + res_tac >> gs [] >> rveq >> + gs [well_formed_terms_def] >> + conj_tac + >- ( + match_mp_tac mem_to_flookup >> + fs []) >> + conj_tac + >- gs [resetOutput_def, defined_clocks_def] >> + conj_tac + >- ( + fs [resetOutput_def, Abbr ‘nclks’] >> + gs [clkvals_rel_def, equiv_val_def] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + first_x_assum (qspec_then ‘n’ mp_tac) >> + fs [] >> + strip_tac >> + qmatch_goalsub_abbrev_tac ‘EL _ (ZIP (xs,_))’ >> + ‘EL n (ZIP (xs,ns)) = (EL n xs, EL n ns)’ by ( + match_mp_tac EL_ZIP >> + unabbrev_all_tac >> + fs []) >> + fs [Abbr ‘xs’] >> + ‘EL n (REPLICATE (LENGTH ns) (nt + wt)) = nt + wt’ by ( + match_mp_tac EL_REPLICATE >> + fs []) >> + fs [] >> + ‘EL n (ZIP (clksOf prog,ns)) = (EL n (clksOf prog), EL n ns)’ by ( + match_mp_tac EL_ZIP >> + unabbrev_all_tac >> + fs []) >> + fs []) >> + conj_tac + >- ( + gs [Abbr ‘nclks’, defined_clocks_def, maxClksSize_def] >> + fs [MAP_MAP_o] >> + fs [SUM_MAP_FOLDL] >> + ‘LENGTH (REPLICATE (LENGTH ns) (nt + wt)) = LENGTH ns’ by fs [] >> + drule foldl_word_size_of >> + disch_then (qspec_then ‘0’ mp_tac) >> + fs []) >> + gs [resetOutput_def] >> + gs [out_signals_ffi_def, well_behaved_ffi_def] >> + gs [EVERY_MEM] >> + gen_tac >> + strip_tac >> + gs [] >> + conj_tac + >- gs [mlintTheory.num_to_str_thm] >> + conj_tac + >- gs [ffiBufferSize_def, bytes_in_word_def, + good_dimindex_def] >> + gs [mem_call_ffi_def, ffi_call_ffi_def] >> + qmatch_goalsub_abbrev_tac ‘mem_load_byte mm _ _’ >> + ‘∃bytes. + read_bytearray ffiBufferAddr (w2n (ffiBufferSize:'a word)) + (mem_load_byte mm t.memaddrs t.be) = SOME bytes’ by ( + match_mp_tac read_bytearray_some_bytes_for_ffi >> + gs [state_rel_def, mem_config_def]) >> + qexists_tac ‘bytes’ >> gs [] >> + gs [next_ffi_def, build_ffi_def] >> + gs [ffiTheory.ffi_state_component_equality] >> + ‘MEM tms (MAP SND prog)’ by ( + drule ALOOKUP_MEM >> + gs [MEM_MAP] >> + strip_tac >> + qexists_tac ‘(s.location,tms)’ >> + gs []) >> + ‘MEM (explode (toString out)) (MAP explode (out_signals prog))’ by ( + gs [timeLangTheory.out_signals_def] >> + gs [MEM_MAP] >> + qexists_tac ‘out’ >> gs [] >> + match_mp_tac terms_out_signals_prog >> + qexists_tac ‘tms’ >> + gs [MEM_MAP] >> + metis_tac []) >> + cases_on ‘explode (num_to_str out) = "get_time_input"’ >> + gs []) >> + impl_tac + >- ( + fs [Abbr ‘nnt’] >> + match_mp_tac mem_to_flookup >> + fs []) >> + strip_tac >> fs [] >> + ‘out = os’ by ( + drule pick_term_dest_eq >> + gs [] >> + strip_tac >> + pop_assum mp_tac >> + disch_then drule >> + gs []) >> + rveq >> gs [] >> + qmatch_asmsub_abbrev_tac + ‘is_valid_value rt _ rtv’ >> + ‘is_valid_value rt «taskRet» rtv’ by ( + fs [Abbr ‘rt’, Abbr ‘rtv’] >> + fs [retVal_def] >> + fs [is_valid_value_def] >> + fs [FLOOKUP_UPDATE] >> + gs [task_ret_defined_def] >> + fs [shape_of_def] >> + gs [EVERY_MEM] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN, resetClksVals_def] >> + rw [] >> + fs [MEM_EL] >> + last_x_assum (qspec_then ‘EL n vs’ mp_tac) >> + fs [] >> + impl_tac + >- metis_tac [] >> + strip_tac >> + fs [] >> + qmatch_goalsub_abbrev_tac ‘MAP ff xs’ >> + ‘EL n (MAP ff xs) = ff (EL n xs)’ by ( + match_mp_tac EL_MAP >> + fs [Abbr ‘xs’]) >> + fs [Abbr ‘ff’, shape_of_def]) >> + fs [] >> + gs [panSemTheory.set_var_def] >> + rveq >> gs [] >> + (* from here *) + fs [Abbr ‘q’] >> + qmatch_goalsub_abbrev_tac ‘evaluate (Seq _ q, _)’ >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once evaluate_def] >> + fs [Abbr ‘rt’, Abbr ‘rtv’] >> + fs [retVal_def] >> + fs [eval_def, FLOOKUP_UPDATE] >> + fs [] >> + qmatch_goalsub_abbrev_tac + ‘is_valid_value rt _ rtv’ >> + ‘is_valid_value rt «clks» rtv’ by ( + fs [Abbr ‘rt’, Abbr ‘rtv’] >> + fs [retVal_def] >> + fs [is_valid_value_def] >> + fs [FLOOKUP_UPDATE] >> + fs [shape_of_def] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN, resetClksVals_def] >> + rw [] >> + gs [] >> + qmatch_goalsub_abbrev_tac ‘MAP ff xs’ >> + ‘EL n (MAP ff xs) = ff (EL n xs)’ by ( + match_mp_tac EL_MAP >> + fs [Abbr ‘xs’]) >> + fs [Abbr ‘ff’, shape_of_def] >> + ‘EL n (MAP ((λw. ValWord w) ∘ n2w) ns) = + ((λw. ValWord w) ∘ n2w) (EL n ns)’ by ( + match_mp_tac EL_MAP >> + fs []) >> + fs [shape_of_def]) >> + fs [] >> + strip_tac >> rveq >> gs [] >> + fs [Abbr ‘q’] >> + qmatch_goalsub_abbrev_tac ‘evaluate (Seq _ q, _)’ >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once evaluate_def] >> + fs [eval_def] >> + qmatch_goalsub_abbrev_tac ‘eval fnt’ >> + ‘FLOOKUP fnt.locals «sysTime» = SOME (ValWord (n2w (nt + wt)))’ by ( + unabbrev_all_tac >> + fs [FLOOKUP_UPDATE]) >> + ‘(λa. eval fnt a) = + eval fnt’ by metis_tac [ETA_AX] >> + fs [] >> + pop_assum kall_tac >> + ‘FLOOKUP fnt.locals «clks» = + SOME (Struct (MAP ((λw. ValWord w) ∘ n2w) + (MAP (λck. + if MEM ck tclks then 0 else THE (FLOOKUP s.clocks ck)) (clksOf prog))))’ by ( + fs [Abbr ‘fnt’, FLOOKUP_UPDATE] >> + fs [Abbr ‘rtv’] >> + gs [resetOutput_def] >> + match_mp_tac resetClksVals_eq_map >> + conj_tac + >- ( + gs [well_formed_terms_def, EVERY_MEM, terms_valid_clocks_def] >> + rw [] >> + last_x_assum drule >> + gs [valid_clks_def, timeLangTheory.termClks_def, EVERY_MEM]) >> + gs [state_rel_def, defined_clocks_def, EVERY_MEM]) >> + ‘EVERY (λn. n ≤ nt + wt) + (MAP (λck. + if MEM ck tclks then 0 else THE (FLOOKUP s.clocks ck)) (clksOf prog))’ by ( + gs [EVERY_MAP, EVERY_MEM] >> + rw [] >> + gs [state_rel_def, defined_clocks_def, EVERY_MEM] >> + rw [] >> res_tac >> gs [] >> + gs [clkvals_rel_def, MAP_EQ_EVERY2, LIST_REL_EL_EQN, EVERY_MEM] >> + first_x_assum (qspec_then ‘ck’ assume_tac) >> + gs []) >> + drule_all eval_normalisedClks >> + strip_tac >> + gs [] >> + pop_assum kall_tac >> + qmatch_goalsub_abbrev_tac + ‘is_valid_value rrt _ rrtv’ >> + ‘is_valid_value rrt «clks» rrtv’ by ( + fs [Abbr ‘rrt’,Abbr ‘rrtv’, Abbr ‘rt’, Abbr ‘rtv’] >> + fs [is_valid_value_def] >> + fs [FLOOKUP_UPDATE] >> + fs [shape_of_def] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN, resetClksVals_def] >> + rw [] >> + gs [] >> + qmatch_goalsub_abbrev_tac ‘MAP ff xs’ >> + ‘EL n (MAP ff xs) = ff (EL n xs)’ by ( + match_mp_tac EL_MAP >> + fs [Abbr ‘xs’]) >> + fs [Abbr ‘ff’, shape_of_def, Abbr ‘xs’] >> + qmatch_goalsub_abbrev_tac ‘ZIP (xs,ys)’ >> + ‘EL n (ZIP (xs,ys)) = + (EL n xs,EL n ys)’ by ( + match_mp_tac EL_ZIP >> + fs [Abbr ‘xs’, Abbr ‘ys’]) >> + fs [Abbr ‘xs’, Abbr ‘ys’] >> + fs [shape_of_def] >> + qmatch_goalsub_abbrev_tac ‘MAP ff xs’ >> + ‘EL n (MAP ff xs) = ff (EL n xs)’ by ( + match_mp_tac EL_MAP >> + fs [Abbr ‘xs’]) >> + fs [Abbr ‘ff’, Abbr ‘xs’, shape_of_def]) >> + fs [] >> + strip_tac >> gs [] >> rveq >> gs [] >> + fs [Abbr ‘q’] >> + qmatch_goalsub_abbrev_tac ‘evaluate (Seq _ q, _)’ >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once evaluate_def] >> + fs [Abbr ‘rt’, eval_def, FLOOKUP_UPDATE] >> + qmatch_goalsub_abbrev_tac + ‘is_valid_value wvt _ hm’ >> + ‘is_valid_value wvt «waitSet» hm’ by ( + fs [Abbr ‘wvt’,Abbr ‘hm’] >> + fs [is_valid_value_def] >> + fs [FLOOKUP_UPDATE] >> + fs [shape_of_def]) >> + fs [Abbr ‘wvt’,Abbr ‘hm’] >> + strip_tac >> + gs [] >> rveq >> gs [] >> + fs [Abbr ‘q’] >> + qmatch_goalsub_abbrev_tac ‘evaluate (Seq _ q, _)’ >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once evaluate_def] >> + fs [eval_def, FLOOKUP_UPDATE, OPT_MMAP_def, + wordLangTheory.word_op_def] >> + fs [is_valid_value_def, FLOOKUP_UPDATE, shape_of_def] >> + strip_tac >> + gs [] >> rveq >> gs [] >> + fs [Abbr ‘q’] >> + fs [evaluate_def] >> + fs [eval_def, FLOOKUP_UPDATE] >> + fs [is_valid_value_def, FLOOKUP_UPDATE, shape_of_def] >> + (* evaluation completed *) + conj_tac + >- (unabbrev_all_tac >> gs [] >> rveq >> gs []) >> + conj_tac + >- ( + rw [state_rel_def] + >- ( + gs [equivs_def, FLOOKUP_UPDATE] >> + drule pick_term_dest_eq >> + gs [] >> + strip_tac >> + pop_assum mp_tac >> + disch_then drule >> + gs [] >> + strip_tac >> + TOP_CASE_TAC >> gs [active_low_def]) + >- gs [ffi_vars_def, FLOOKUP_UPDATE] + >- gs [time_vars_def, FLOOKUP_UPDATE] + >- ( + unabbrev_all_tac >> + gs [mem_config_def] >> + fs[mem_call_ffi_def] >> + conj_tac >> ( + fs [ffiBufferAddr_def] >> + match_mp_tac write_bytearray_update_byte >> + gs [good_dimindex_def] >> + gs [byte_align_def, byte_aligned_def, align_def, aligned_def, bytes_in_word_def] >> + gs [dimword_def] >> + EVAL_TAC >> + rveq >> gs [] >> + EVAL_TAC)) + >- ( + gs [defined_clocks_def] >> + fs [EVERY_MEM] >> + rw [] >> + gs [state_rel_def, defined_clocks_def] >> + last_x_assum drule >> + fs [] >> + strip_tac >> + imp_res_tac eval_term_clocks_reset >> + gs [resetOutput_def] >> + res_tac >> gs []) >> + pairarg_tac >> gs [] >> rveq >> gs [] >> + rw [] + >- ( + gs [nffi_state_def, build_ffi_def] >> + fs [Abbr ‘nnt’, ffi_call_ffi_def] >> + gs [ffiTheory.ffi_state_component_equality]) + >- ( + gs [time_seq_def, nffi_state_def, ffi_call_ffi_def, + Abbr ‘nnt’, next_ffi_def] >> + rw [] >> + first_x_assum (qspec_then ‘n+1’ assume_tac) >> + metis_tac [ADD]) + >- gs [Abbr ‘nnt’, FLOOKUP_UPDATE, nffi_state_def] >> + gs [clocks_rel_def, FLOOKUP_UPDATE, nffi_state_def] >> + fs [Abbr ‘rrtv’] >> + fs [nffi_state_def, Abbr ‘nnt’, ffi_call_ffi_def, next_ffi_def] >> + qexists_tac ‘MAP (λck. (nt + wt) - THE (FLOOKUP s'.clocks ck)) (clksOf prog)’ >> + gs [] >> + conj_tac + >- ( + gs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> gs [] >> + qmatch_goalsub_abbrev_tac ‘EL _ (ZIP (xs,ys))’ >> + ‘EL n (ZIP (xs,ys)) = (EL n xs, EL n ys)’ by ( + match_mp_tac EL_ZIP >> + unabbrev_all_tac >> + fs []) >> + fs [Abbr ‘xs’] >> + ‘EL n (REPLICATE (LENGTH ns) tm) = tm’ by ( + match_mp_tac EL_REPLICATE >> + fs []) >> + fs [] >> + fs [Abbr ‘ys’] >> + qmatch_goalsub_abbrev_tac ‘MAP ff xs’ >> + ‘EL n (MAP ff xs) = ff (EL n xs)’ by ( + match_mp_tac EL_MAP >> + fs [Abbr ‘xs’]) >> + fs [Abbr ‘ff’, Abbr ‘xs’] >> + qmatch_goalsub_abbrev_tac ‘MAP ff xs’ >> + ‘EL n (MAP ff xs) = ff (EL n xs)’ by ( + match_mp_tac EL_MAP >> + fs [Abbr ‘xs’]) >> + fs [Abbr ‘ff’, Abbr ‘xs’] >> + TOP_CASE_TAC >> gs [] + >- ( + ‘FLOOKUP s'.clocks (EL n (clksOf prog)) = SOME 0’ by ( + gs [evalTerm_cases, resetOutput_def, resetClocks_def, MEM_EL] >> + metis_tac [update_eq_zip_map_flookup]) >> + gs [] >> + ‘EL n (REPLICATE (LENGTH ns) (nt + wt)) = nt + wt’ by ( + match_mp_tac EL_REPLICATE >> + gs []) >> + gs []) >> + ‘?x. FLOOKUP s.clocks (EL n (clksOf prog)) = SOME x ∧ + FLOOKUP s'.clocks (EL n (clksOf prog)) = SOME x’ by ( + gs [evalTerm_cases, resetOutput_def, resetClocks_def, MEM_EL] >> + gs [defined_clocks_def, EVERY_MEM] >> + last_x_assum (qspec_then ‘EL n (clksOf prog)’ mp_tac) >> + impl_tac + >- metis_tac [MEM_EL] >> + strip_tac >> + gs [] >> + qpat_x_assum ‘_ = SOME n''’ (assume_tac o GSYM) >> + fs [] >> + match_mp_tac flookup_fupdate_zip_not_mem >> + gs [MEM_EL]) >> + gs [] >> + ‘EL n (REPLICATE (LENGTH ns) (nt + wt)) = nt + wt’ by ( + match_mp_tac EL_REPLICATE >> + gs []) >> + gs []) >> + gs [clkvals_rel_def] >> + conj_tac + >- ( + gs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> gs [] >> + qmatch_goalsub_abbrev_tac ‘EL _ (ZIP (xs,ys))’ >> + ‘EL n (ZIP (xs,ys)) = (EL n xs, EL n ys)’ by ( + match_mp_tac EL_ZIP >> + unabbrev_all_tac >> + fs []) >> + fs [Abbr ‘xs’, Abbr ‘ys’] >> + qmatch_goalsub_abbrev_tac ‘MAP ff xs’ >> + ‘EL n (MAP ff xs) = ff (EL n xs)’ by ( + match_mp_tac EL_MAP >> + fs [Abbr ‘xs’]) >> + fs [Abbr ‘ff’, Abbr ‘xs’] >> + ‘THE (FLOOKUP s'.clocks (EL n (clksOf prog))) <= nt + wt’ by ( + gs [evalTerm_cases, resetOutput_def, resetClocks_def, MEM_EL] >> + cases_on ‘MEM (EL n (clksOf prog)) tclks’ + >- ( + fs [MEM_EL] >> + ‘FLOOKUP (s.clocks |++ ZIP (tclks,MAP (λx. 0) tclks)) + (EL n'' tclks) = SOME 0’ by + metis_tac [update_eq_zip_map_flookup]>> + fs []) >> + gs [defined_clocks_def, EVERY_MEM] >> + last_x_assum (qspec_then ‘EL n (clksOf prog)’ mp_tac) >> + impl_tac + >- metis_tac [MEM_EL] >> + strip_tac >> + gs [] >> + ‘FLOOKUP (s.clocks |++ ZIP (tclks,MAP (λx. 0) tclks)) + (EL n (clksOf prog)) = SOME n''’ by ( + qpat_x_assum ‘_ = SOME n''’ (assume_tac o GSYM) >> + fs [] >> + match_mp_tac flookup_fupdate_zip_not_mem >> + gs [MEM_EL]) >> + fs [] >> + last_x_assum (qspec_then ‘EL n (clksOf prog)’ mp_tac) >> + impl_tac >- metis_tac [MEM_EL] >> + gs [] >> + strip_tac >> + gs []) >> + gs []) >> + fs [EVERY_MEM] >> + rw [] >> + gs [evalTerm_cases, resetOutput_def, resetClocks_def, MEM_EL] >> + cases_on ‘MEM (EL n (clksOf prog)) tclks’ + >- ( + fs [MEM_EL] >> + ‘FLOOKUP (s.clocks |++ ZIP (tclks,MAP (λx. 0) tclks)) + (EL n'' tclks) = SOME 0’ by + metis_tac [update_eq_zip_map_flookup]>> + fs []) >> + gs [defined_clocks_def, EVERY_MEM] >> + last_x_assum (qspec_then ‘EL n (clksOf prog)’ mp_tac) >> + impl_tac + >- metis_tac [MEM_EL] >> + strip_tac >> + gs [] >> + ‘FLOOKUP (s.clocks |++ ZIP (tclks,MAP (λx. 0) tclks)) + (EL n (clksOf prog)) = SOME n''’ by ( + qpat_x_assum ‘_ = SOME n''’ (assume_tac o GSYM) >> + fs [] >> + match_mp_tac flookup_fupdate_zip_not_mem >> + gs [MEM_EL]) >> + fs [] >> + last_x_assum (qspec_then ‘EL n (clksOf prog)’ mp_tac) >> + impl_tac >- metis_tac [MEM_EL] >> + gs []) >> + fs [nffi_state_def, Abbr ‘nnt’] >> + gs [task_ret_defined_def, FLOOKUP_UPDATE, Abbr ‘rtv’, resetOutput_def, + resetClksVals_def] >> + fs [EVERY_MAP] >> + ‘terms_wtimes_ffi_bound (dimword (:α) − 1) + (s with <|ioAction := NONE; waitTime := NONE|>) tms’ by + gs [Once pickTerm_cases] >> + gs [terms_wtimes_ffi_bound_def] >> + gs [EVERY_MEM] >> + last_x_assum (qspec_then ‘Tm (Output os) cnds tclks dest wt'’ mp_tac) >> + gs [timeLangTheory.termClks_def, timeLangTheory.termWaitTimes_def, resetOutput_def] >> + strip_tac >> + reverse conj_tac + >- ( + cases_on ‘wt'’ >> gs [] + >- ( + ‘s'.waitTime = NONE’ by ( + gs [Once pickTerm_cases] >> + rveq >> gs [] >> + gs [evalTerm_cases] >> rveq >> + gs [calculate_wtime_def, list_min_option_def]) >> + gs []) >> + fs [] >> + qmatch_goalsub_abbrev_tac ‘n2w (THE (nwt))’ >> + ‘?t. nwt = SOME t’ by ( + gs [Abbr ‘nwt’] >> + gs [calculate_wtime_def, list_min_option_def] >> + TOP_CASE_TAC >> + gs []) >> + gs [] >> + ‘s'.waitTime = nwt’ by ( + gs [Abbr ‘nwt’, Once pickTerm_cases] >> + rveq >> gs [] >> + gs [evalTerm_cases]) >> + gs [word_add_n2w]) >> + gs [output_io_events_rel_def] >> + conj_tac + >- metis_tac [] >> + gs [DROP_LENGTH_APPEND] >> + gs [decode_io_events_def, decode_io_event_def] >> + ‘explode (toString os) ≠ "get_time_input"’ by ( + gs [mlintTheory.num_to_str_thm] >> + assume_tac EVERY_isDigit_num_to_dec_string >> + pop_assum (qspec_then ‘os’ mp_tac) >> + gs [EVERY_MEM] >> + strip_tac >> + CCONTR_TAC >> + gs [isDigit_def] >> + qpat_x_assum ‘∀e. _ ⇒ _’ mp_tac >> + rw [] >> + qexists_tac ‘#"g"’ >> gs []) >> + gs [mlintTheory.num_to_str_thm, toString_toNum_cancel] +QED + + +Theorem step_panic_timeout: + !prog m it s s' (t:('a,time_input) panSem$state). + step prog (LPanic PanicTimeout) m it s s' ∧ + m = dimword (:α) - 1 ∧ + ~MEM "get_time_input" (MAP explode (out_signals prog)) ∧ + it = FST (t.ffi.ffi_state 0) ∧ + FST (t.ffi.ffi_state 0) < dimword (:α) - 2 ∧ + state_rel (clksOf prog) (out_signals prog) s t ∧ + well_formed_terms prog s.location t.code ∧ + code_installed t.code prog ∧ + output_rel t.locals t.ffi.ffi_state ∧ + FLOOKUP t.locals «isInput» = SOME (ValWord 1w) ∧ + FLOOKUP t.locals «event» = SOME (ValWord 0w) ∧ + FLOOKUP t.eshapes «panic» = SOME One ∧ + good_dimindex (:'a) ⇒ + ?ck t'. + evaluate (task_controller (nClks prog), t with clock := t.clock + ck) = + (SOME (Exception «panic» (ValWord 0w)), t') ∧ + code_installed t'.code prog ∧ + t'.ffi.ffi_state = t.ffi.ffi_state ∧ + t'.ffi.io_events = t.ffi.io_events ∧ + t'.ffi.oracle = t.ffi.oracle ∧ + t'.code = t.code ∧ + t'.be = t.be ∧ + t'.eshapes = t.eshapes ∧ + t'.locals = FEMPTY +Proof + rw [] >> + fs [] >> + fs [step_cases, task_controller_def, + panLangTheory.nested_seq_def] >> + ‘FLOOKUP t.locals «waitSet» = SOME (ValWord 0w)’ by + gs [state_rel_def, equivs_def, active_low_def] >> + qmatch_goalsub_abbrev_tac ‘evaluate (Seq _ q, _)’ >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + fs [wait_input_time_limit_def] >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + qexists_tac ‘1’ >> + fs [] >> + gs [output_rel_def] >> + drule step_delay_eval_wait_zero >> + disch_then (qspec_then ‘n2w (nt + wt)’ mp_tac) >> + gs [] >> + strip_tac >> + gs [eval_upd_clock_eq] >> + fs [Abbr ‘q’] >> + qmatch_goalsub_abbrev_tac ‘evaluate (Seq _ q, nnt)’ >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once evaluate_def] >> + unabbrev_all_tac >> + gvs [eval_def, FLOOKUP_UPDATE, asmTheory.word_cmp_def] >> + rewrite_tac [Once evaluate_def] >> + gvs [] >> + strip_tac >> gvs [] >> + (* until here *) + qmatch_goalsub_abbrev_tac ‘evaluate (Seq _ q, _)’ >> + (* calling the function *) + (* location will come from equivs: state_rel *) + imp_res_tac state_rel_imp_equivs >> + fs [equivs_def] >> + qmatch_asmsub_abbrev_tac + ‘FLOOKUP _ «loc» = SOME (ValLabel loc)’ >> + ‘FLOOKUP t.code loc = + SOME + ([(«clks» ,genShape (LENGTH (clksOf prog))); («event» ,One)], + compTerms (clksOf prog) «clks» «event» tms)’ by ( + fs [code_installed_def] >> + drule ALOOKUP_MEM >> + strip_tac >> + last_x_assum drule >> + strip_tac >> + fs [Abbr ‘loc’]) >> + (* evaluation *) + fs [Once evaluate_def] >> + pairarg_tac >> + fs [] >> + fs [Once evaluate_def, eval_upd_clock_eq] >> + gs [Once eval_def, eval_upd_clock_eq, FLOOKUP_UPDATE] >> + qmatch_asmsub_abbrev_tac ‘OPT_MMAP (eval nnt) [_ ; _]’ >> + ‘FLOOKUP nnt.locals «sysTime» = SOME (ValWord (n2w (FST (t.ffi.ffi_state 0))))’ by + fs [Abbr ‘nnt’, FLOOKUP_UPDATE] >> + drule eval_normalisedClks >> + gs [Abbr ‘nnt’, FLOOKUP_UPDATE] >> + qpat_x_assum ‘state_rel (clksOf prog) (out_signals prog) s t’ assume_tac >> + drule state_rel_intro >> + strip_tac >> gs [] >> + pairarg_tac >> gs [] >> + gs [clocks_rel_def] >> + disch_then (qspec_then ‘ns’ mp_tac) >> + impl_tac + >- ( + conj_tac + >- gs [EVERY_MEM, time_seq_def, output_rel_def] >> + fs [EVERY_MEM] >> + rw [] >> + gs [clkvals_rel_def] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + fs [MEM_EL] >> + first_x_assum (qspec_then ‘n'’ mp_tac) >> + fs [] >> + strip_tac >> + ‘(EL n' (ZIP (clksOf prog,ns))) = + (EL n' (clksOf prog),EL n' ns)’ by ( + match_mp_tac EL_ZIP >> + gs []) >> + fs []) >> + strip_tac >> + fs [] >> + fs [OPT_MMAP_def] >> + fs [Once eval_def] >> + qmatch_asmsub_abbrev_tac ‘(eval nnt)’ >> + ‘(λa. eval nnt a) = + eval nnt’ by metis_tac [ETA_AX] >> + fs [] >> + fs [timeLangTheory.nClks_def] >> + ‘LENGTH (clksOf prog) = LENGTH ns’ by gs [] >> + gs [] >> + (* event eval *) + gs [Abbr ‘nnt’, eval_def, FLOOKUP_UPDATE] >> + gs [lookup_code_def] >> + fs [timeLangTheory.nClks_def] >> + ‘LENGTH (clksOf prog) = LENGTH ns’ by gs [] >> + drule (INST_TYPE + [``:'a``|->``:'mlstring``, + ``:'b``|->``:'a``] genshape_eq_shape_of) >> + disch_then (qspec_then ‘nt + wt’ assume_tac) >> + rfs [] >> + fs [] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + fs [shape_of_def] >> + fs [dec_clock_def] >> + pop_assum kall_tac >> + qmatch_asmsub_abbrev_tac ‘(«clks» ,Struct nclks)’ >> + qmatch_asmsub_abbrev_tac ‘evaluate (_, nnt)’ >> + drule (INST_TYPE [``:'a``|->``:'a``, + ``:'b``|->``:time_input``] pick_term_thm) >> + fs [] >> + disch_then (qspecl_then [‘nnt’, ‘clksOf prog’, + ‘nclks’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nnt’] >> + res_tac >> gs [] >> rveq >> + gs [well_formed_terms_def] >> + conj_tac + >- ( + match_mp_tac mem_to_flookup >> + fs []) >> + conj_tac + >- gs [resetOutput_def, defined_clocks_def] >> + conj_tac + >- ( + fs [resetOutput_def, Abbr ‘nclks’] >> + gs [clkvals_rel_def, equiv_val_def] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + first_x_assum (qspec_then ‘n’ mp_tac) >> + fs [] >> + strip_tac >> + qmatch_goalsub_abbrev_tac ‘EL _ (ZIP (xs,_))’ >> + ‘EL n (ZIP (xs,ns)) = (EL n xs, EL n ns)’ by ( + match_mp_tac EL_ZIP >> + unabbrev_all_tac >> + fs []) >> + fs [Abbr ‘xs’] >> + ‘EL n (REPLICATE (LENGTH ns) (nt + wt)) = nt + wt’ by ( + match_mp_tac EL_REPLICATE >> + fs []) >> + fs [] >> + ‘EL n (ZIP (clksOf prog,ns)) = (EL n (clksOf prog), EL n ns)’ by ( + match_mp_tac EL_ZIP >> + unabbrev_all_tac >> + fs []) >> + fs []) >> + conj_tac + >- ( + gs [Abbr ‘nclks’, defined_clocks_def, maxClksSize_def] >> + fs [MAP_MAP_o] >> + fs [SUM_MAP_FOLDL] >> + ‘LENGTH (REPLICATE (LENGTH ns) (nt + wt)) = LENGTH ns’ by fs [] >> + drule foldl_word_size_of >> + disch_then (qspec_then ‘0’ mp_tac) >> + fs []) >> + gs [resetOutput_def] >> + gs [out_signals_ffi_def, well_behaved_ffi_def] >> + gs [EVERY_MEM] >> + gen_tac >> + strip_tac >> + gs [] >> + conj_tac + >- gs [mlintTheory.num_to_str_thm] >> + conj_tac + >- gs [ffiBufferSize_def, bytes_in_word_def, + good_dimindex_def] >> + gs [mem_call_ffi_def, ffi_call_ffi_def] >> + qmatch_goalsub_abbrev_tac ‘mem_load_byte mm _ _’ >> + ‘∃bytes. + read_bytearray ffiBufferAddr (w2n (ffiBufferSize:'a word)) + (mem_load_byte mm t.memaddrs t.be) = SOME bytes’ by ( + match_mp_tac read_bytearray_some_bytes_for_ffi >> + gs [state_rel_def, mem_config_def]) >> + qexists_tac ‘bytes’ >> gs [] >> + gs [next_ffi_def, build_ffi_def] >> + gs [ffiTheory.ffi_state_component_equality] >> + ‘MEM tms (MAP SND prog)’ by ( + drule ALOOKUP_MEM >> + gs [MEM_MAP] >> + strip_tac >> + qexists_tac ‘(s.location,tms)’ >> + gs []) >> + ‘MEM (explode (toString out)) (MAP explode (out_signals prog))’ by ( + gs [timeLangTheory.out_signals_def] >> + gs [MEM_MAP] >> + qexists_tac ‘out’ >> gs [] >> + match_mp_tac terms_out_signals_prog >> + qexists_tac ‘tms’ >> + gs [MEM_MAP] >> + metis_tac []) >> + cases_on ‘explode (num_to_str out) = "get_time_input"’ >> + gs []) >> + impl_tac + >- ( + fs [Abbr ‘nnt’] >> + match_mp_tac mem_to_flookup >> + fs []) >> + strip_tac >> gvs [] >> + unabbrev_all_tac >> + gvs [empty_locals_def] +QED + + +Theorem step_panic_input: + !prog i m n s s' (t:('a,time_input) panSem$state) ist. + step prog (LPanic (PanicInput i)) m n s s' ∧ + m = dimword (:α) - 1 ∧ + n = FST (t.ffi.ffi_state 0) ∧ + FST (t.ffi.ffi_state 1) < dimword (:α) - 2 ∧ + ~MEM "get_time_input" (MAP explode (out_signals prog)) ∧ + state_rel (clksOf prog) (out_signals prog) s t ∧ + wakeup_shape t.locals s.waitTime ist ∧ + input_stime_rel s.waitTime ist (FST (t.ffi.ffi_state 0)) ∧ + well_formed_terms prog s.location t.code ∧ + code_installed t.code prog ∧ + input_rel t.locals i (next_ffi t.ffi.ffi_state) ∧ + FLOOKUP t.locals «isInput» = SOME (ValWord 1w) ∧ + FLOOKUP t.eshapes «panic» = SOME One ∧ + mem_read_ffi_results (:α) t.ffi.ffi_state 1 ∧ + good_dimindex (:'a) ⇒ + ?ck t'. + evaluate (task_controller (nClks prog), t with clock := t.clock + ck) = + (SOME (Exception «panic» (ValWord 0w)), t') ∧ + code_installed t'.code prog ∧ + t'.ffi.ffi_state = next_ffi t.ffi.ffi_state ∧ + t'.ffi.oracle = t.ffi.oracle ∧ + t'.code = t.code ∧ + t'.be = t.be ∧ + t'.eshapes = t.eshapes ∧ + t'.locals = FEMPTY ∧ + input_io_events_rel i t t' + +Proof + rw [] >> + fs [task_controller_def] >> + fs [panLangTheory.nested_seq_def] >> + qmatch_goalsub_abbrev_tac ‘evaluate (Seq _ q, _)’ >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + qexists_tac ‘2’ >> + pairarg_tac >> gs [] >> + pop_assum mp_tac >> + fs [wait_input_time_limit_def] >> + rewrite_tac [Once evaluate_def] >> + ‘∃w. eval t wait = SOME (ValWord w) ∧ w ≠ 0w’ by ( + cases_on ‘s.waitTime’ + >- ( + gs [state_rel_def, equivs_def, active_low_def] >> + match_mp_tac step_delay_eval_wait_not_zero >> + gs [state_rel_def, equivs_def, time_vars_def, active_low_def]) >> + ‘x ≠ 0’ by gs [step_cases] >> + match_mp_tac eval_wait_not_zero' >> + gs [input_rel_def, next_ffi_def] >> + conj_tac + >- gs [state_rel_def, equivs_def, active_low_def, time_vars_def] >> + qexists_tac ‘FST (t.ffi.ffi_state 1)’ >> + gs [] >> + gvs [wakeup_shape_def, input_stime_rel_def] >> + qexists_tac ‘wt'’ >> + qexists_tac ‘ist’ >> + gs [input_rel_def, next_ffi_def] >> + gs [state_rel_def] >> + pairarg_tac >> gs [] >> gs [] >> + ‘FST (t.ffi.ffi_state 1) = FST (t.ffi.ffi_state 0)’ by ( + gs [input_time_rel_def] >> + last_x_assum (qspec_then ‘0’ mp_tac) >> + gs [input_time_eq_def, has_input_def]) >> + gvs [step_cases]) >> + gs [eval_upd_clock_eq] >> + gs [dec_clock_def] >> + (* evaluating the function *) + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once check_input_time_def] >> + fs [panLangTheory.nested_seq_def] >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + drule state_rel_imp_mem_config >> + rewrite_tac [Once mem_config_def] >> + strip_tac >> + fs [] >> + ‘∃bytes. + read_bytearray ffiBufferAddr (w2n (ffiBufferSize:'a word)) + (mem_load_byte t.memory t.memaddrs t.be) = SOME bytes’ by ( + match_mp_tac read_bytearray_some_bytes_for_ffi >> + gs []) >> + drule evaluate_ext_call >> + disch_then (qspecl_then [‘MAP explode (out_signals prog)’, ‘bytes’] mp_tac) >> + impl_tac + >- ( + gs [state_rel_def] >> + pairarg_tac >> gs []) >> + strip_tac >> gs [] >> + rveq >> gs [] >> + drule state_rel_imp_ffi_vars >> + strip_tac >> + pop_assum mp_tac >> + rewrite_tac [Once ffi_vars_def] >> + strip_tac >> + drule state_rel_imp_systime_defined >> + strip_tac >> + (* reading systime *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «sysTime» _, nt)’ >> + ‘nt.memory ffiBufferAddr = Word (n2w (FST(t.ffi.ffi_state 1)))’ by ( + fs [Abbr ‘nt’] >> + qpat_x_assum ‘mem_read_ffi_results _ _ _’ assume_tac >> + gs [mem_read_ffi_results_def] >> + qmatch_asmsub_abbrev_tac ‘evaluate (ExtCall _ _ _ _ _, _) = (_, ft)’ >> + last_x_assum + (qspecl_then + [‘t with clock := t.clock + 1’, + ‘ft’] mp_tac) >> + impl_tac + >- gs [Abbr ‘ft’, nexts_ffi_def, GSYM ETA_AX] >> + strip_tac >> + gs [Abbr ‘ft’, nexts_ffi_def]) >> + drule evaluate_assign_load >> + gs [] >> + disch_then (qspecl_then + [‘ffiBufferAddr’, ‘tm’, + ‘n2w (FST (t.ffi.ffi_state 1))’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nt’] >> + fs [state_rel_def]) >> + strip_tac >> fs [] >> + (* reading input to the variable event *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «event» _, nnt)’ >> + ‘nnt.memory (ffiBufferAddr + bytes_in_word) = + Word (n2w (SND(t.ffi.ffi_state 1)))’ by ( + fs [Abbr ‘nnt’, Abbr ‘nt’] >> + qpat_x_assum ‘mem_read_ffi_results _ _ _’ assume_tac >> + gs [mem_read_ffi_results_def] >> + qmatch_asmsub_abbrev_tac ‘evaluate (ExtCall _ _ _ _ _, _) = (_, ft)’ >> + last_x_assum (qspecl_then [‘t with clock := t.clock + 1’, ‘ft’] mp_tac) >> + impl_tac + >- gs [Abbr ‘ft’, nexts_ffi_def, GSYM ETA_AX] >> + strip_tac >> + gs [Abbr ‘ft’, nexts_ffi_def, GSYM ETA_AX]) >> + gs [] >> + drule evaluate_assign_load_next_address >> + gs [] >> + disch_then (qspecl_then + [‘ffiBufferAddr’, + ‘n2w (SND (nexts_ffi 0 t.ffi.ffi_state 1))’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nnt’,Abbr ‘nt’, active_low_def] >> + gs [state_rel_def, time_vars_def, FLOOKUP_UPDATE, + nexts_ffi_def, mem_config_def]) >> + strip_tac >> + rveq >> gs [] >> + (* isInput *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «isInput» _, nnnt)’ >> + ‘nnnt.memory (ffiBufferAddr + bytes_in_word) = + Word (n2w (SND(t.ffi.ffi_state 1)))’ by fs [Abbr ‘nnnt’] >> + gs [] >> + ‘nnnt.memory (ffiBufferAddr + bytes_in_word) ≠ Word 0w’ by ( + gs [input_rel_def, nexts_ffi_def, next_ffi_def] >> + gs [step_cases] >> + drule pick_term_dest_eq >> + strip_tac >> + pop_assum mp_tac >> + disch_then (qspec_then ‘SND (t.ffi.ffi_state 1) − 1’ mp_tac) >> + impl_tac >- fs [] >> + strip_tac >> + ‘SND (t.ffi.ffi_state 1) − 1 + 1 = SND (t.ffi.ffi_state 1)’ by ( + match_mp_tac SUB_ADD >> + cases_on ‘SND (t.ffi.ffi_state 1)’ + >- metis_tac [] >> + metis_tac [one_leq_suc]) >> + ‘SND (t.ffi.ffi_state 1) MOD dimword (:α) = + SND (t.ffi.ffi_state 1)’ suffices_by metis_tac [] >> + match_mp_tac LESS_MOD >> + match_mp_tac lt_less_one >> + metis_tac []) >> + fs [] >> + drule evaluate_assign_compare_next_address_uneq >> + gs [] >> + disch_then (qspecl_then [‘ffiBufferAddr’, + ‘n2w (SND (t.ffi.ffi_state 1))’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nnnt’, Abbr ‘nnt’,Abbr ‘nt’, active_low_def] >> + gs [state_rel_def, time_vars_def, FLOOKUP_UPDATE] >> + gs [nexts_ffi_def, mem_config_def]) >> + strip_tac >> + gs [] >> rveq >> gs [] >> + (* If statement *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + drule evaluate_if_compare_sys_time >> + disch_then (qspec_then ‘FST (t.ffi.ffi_state 1)’ mp_tac) >> + impl_tac + >- ( + unabbrev_all_tac >> + gs [FLOOKUP_UPDATE, nexts_ffi_def] >> + gs [step_cases, ADD1, state_rel_def, input_time_rel_def] >> + pairarg_tac >> gs [] >> + last_x_assum (qspec_then ‘0’ mp_tac) >> + gs [input_time_eq_def, has_input_def, input_rel_def, next_ffi_def] >> + strip_tac >> + drule LESS_MOD >> + strip_tac >> gs []) >> + strip_tac >> rveq >> gs [] >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + strip_tac >> fs [] >> + rveq >> gs [] >> + strip_tac >> + (* loop should break now *) + fs [step_cases] >> + gs [input_rel_def] >> + pop_assum mp_tac >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + fs [wait_input_time_limit_def] >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + ‘FLOOKUP (nnnt with locals := nnnt.locals |+ («isInput» ,ValWord 0w)).locals + «isInput» = SOME (ValWord 0w)’ by fs [FLOOKUP_UPDATE] >> + drule step_input_eval_wait_zero >> + impl_tac + >- ( + unabbrev_all_tac >> gs [] >> + fs [FLOOKUP_UPDATE] >> + gs [state_rel_def, time_vars_def]) >> + gs [eval_upd_clock_eq] >> + strip_tac >> + strip_tac >> + unabbrev_all_tac >> + rveq >> gs [] >> + (* the new If statement *) + qmatch_goalsub_abbrev_tac ‘evaluate (Seq _ q, nnt)’ >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> gs [] >> + pop_assum mp_tac >> + rewrite_tac [Once evaluate_def] >> + unabbrev_all_tac >> + gvs [eval_def, FLOOKUP_UPDATE, asmTheory.word_cmp_def] >> + rewrite_tac [Once evaluate_def] >> + gvs [] >> + strip_tac >> gvs [] >> + (* until here *) + qmatch_goalsub_abbrev_tac ‘evaluate (Seq _ q, nnt)’ >> + ‘FLOOKUP nnt.locals «loc» = FLOOKUP t.locals «loc»’ by + fs [Abbr ‘nnt’, FLOOKUP_UPDATE] >> + ‘nnt.code = t.code’ by + fs [Abbr ‘nnt’, state_component_equality] >> + ‘FST (t.ffi.ffi_state 1) = FST (t.ffi.ffi_state 0)’ by ( + gs [state_rel_def] >> + pairarg_tac >> + gs [input_time_rel_def, input_time_eq_def] >> + last_x_assum (qspec_then ‘0’ mp_tac) >> + impl_tac + >- gs [has_input_def, next_ffi_def] >> + gs []) >> + ‘FLOOKUP nnt.locals «clks» = FLOOKUP t.locals «clks»’ by + fs [Abbr ‘nnt’, FLOOKUP_UPDATE] >> + (* calling the function *) + (* location will come from equivs: state_rel *) + imp_res_tac state_rel_imp_equivs >> + fs [equivs_def] >> + qmatch_asmsub_abbrev_tac + ‘FLOOKUP _ «loc» = SOME (ValLabel loc)’ >> + ‘FLOOKUP t.code loc = + SOME + ([(«clks» ,genShape (LENGTH (clksOf prog))); («event» ,One)], + compTerms (clksOf prog) «clks» «event» tms)’ by ( + fs [code_installed_def] >> + drule ALOOKUP_MEM >> + strip_tac >> + last_x_assum drule >> + strip_tac >> + fs [Abbr ‘loc’]) >> + (* evaluation *) + fs [Once evaluate_def] >> + pairarg_tac >> + fs [] >> + fs [Once evaluate_def, eval_upd_clock_eq] >> + gs [Once eval_def, eval_upd_clock_eq, FLOOKUP_UPDATE] >> + ‘FLOOKUP nnt.locals «sysTime» = SOME (ValWord (n2w (FST (t.ffi.ffi_state 0))))’ by + gs [Abbr ‘nnt’, FLOOKUP_UPDATE] >> + drule eval_normalisedClks >> + gs [Abbr ‘nnt’, FLOOKUP_UPDATE] >> + qpat_x_assum ‘state_rel (clksOf prog) (out_signals prog) s t’ assume_tac >> + drule state_rel_intro >> + strip_tac >> gs [] >> + pairarg_tac >> gs [] >> + gs [clocks_rel_def] >> + disch_then (qspec_then ‘ns’ mp_tac) >> + impl_tac + >- ( + conj_tac + >- gs [EVERY_MEM, time_seq_def] >> + fs [EVERY_MEM] >> + rw [] >> + gs [clkvals_rel_def] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + fs [MEM_EL] >> + first_x_assum (qspec_then ‘n'’ mp_tac) >> + fs [] >> + strip_tac >> + ‘(EL n' (ZIP (clksOf prog,ns))) = + (EL n' (clksOf prog),EL n' ns)’ by ( + match_mp_tac EL_ZIP >> + gs []) >> + fs []) >> + strip_tac >> + fs [] >> + fs [OPT_MMAP_def] >> + fs [Once eval_def] >> + qmatch_asmsub_abbrev_tac ‘(eval nnt)’ >> + ‘(λa. eval nnt a) = + eval nnt’ by metis_tac [ETA_AX] >> + fs [] >> + fs [timeLangTheory.nClks_def] >> + ‘LENGTH (clksOf prog) = LENGTH ns’ by gs [] >> + gs [] >> + (* event eval *) + gs [Abbr ‘nnt’, eval_def, FLOOKUP_UPDATE, nexts_ffi_def] >> + gs [lookup_code_def] >> + fs [timeLangTheory.nClks_def] >> + ‘LENGTH (clksOf prog) = LENGTH ns’ by gs [] >> + drule (INST_TYPE + [``:'a``|->``:'mlstring``, + ``:'b``|->``:'a``] genshape_eq_shape_of) >> + disch_then (qspec_then ‘tm’ assume_tac) >> + rfs [] >> + fs [] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + fs [shape_of_def] >> + fs [dec_clock_def] >> + pop_assum kall_tac >> + qmatch_asmsub_abbrev_tac ‘(«clks» ,Struct nclks)’ >> + qmatch_asmsub_abbrev_tac ‘evaluate (_, nnt)’ >> + gs [next_ffi_def] >> + drule (INST_TYPE [``:'a``|->``:'a``, + ``:'b``|->``:time_input``] pick_term_thm) >> + fs [] >> + disch_then (qspecl_then [‘nnt’, ‘clksOf prog’, + ‘nclks’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nnt’] >> + res_tac >> gs [] >> rveq >> + gs [well_formed_terms_def] >> + conj_tac + >- ( + match_mp_tac mem_to_flookup >> + fs []) >> + conj_tac + >- gs [resetOutput_def, defined_clocks_def] >> + conj_tac + >- ( + fs [resetOutput_def, Abbr ‘nclks’] >> + gs [clkvals_rel_def, equiv_val_def] >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + first_x_assum (qspec_then ‘n’ mp_tac) >> + fs [] >> + strip_tac >> + qmatch_goalsub_abbrev_tac ‘EL _ (ZIP (xs,_))’ >> + ‘EL n (ZIP (xs,ns)) = (EL n xs, EL n ns)’ by ( + match_mp_tac EL_ZIP >> + unabbrev_all_tac >> + fs []) >> + fs [Abbr ‘xs’] >> + ‘EL n (REPLICATE (LENGTH ns) (FST (t.ffi.ffi_state 1))) = FST (t.ffi.ffi_state 1)’ by ( + match_mp_tac EL_REPLICATE >> + fs []) >> + fs [] >> + ‘EL n (ZIP (clksOf prog,ns)) = (EL n (clksOf prog), EL n ns)’ by ( + match_mp_tac EL_ZIP >> + unabbrev_all_tac >> + fs []) >> + fs []) >> + conj_tac + >- ( + gs [Abbr ‘nclks’, defined_clocks_def, maxClksSize_def] >> + fs [MAP_MAP_o] >> + fs [SUM_MAP_FOLDL] >> + ‘LENGTH (REPLICATE (LENGTH ns) (FST (t.ffi.ffi_state 1))) = LENGTH ns’ by fs [] >> + drule foldl_word_size_of >> + disch_then (qspec_then ‘0’ mp_tac) >> + fs []) >> + gs [resetOutput_def] >> + gs [out_signals_ffi_def, well_behaved_ffi_def] >> + gs [EVERY_MEM] >> + gen_tac >> + strip_tac >> + gs [] >> + conj_tac + >- gs [mlintTheory.num_to_str_thm] >> + conj_tac + >- gs [ffiBufferSize_def, bytes_in_word_def, + good_dimindex_def] >> + gs [mem_call_ffi_def, ffi_call_ffi_def] >> + qmatch_goalsub_abbrev_tac ‘mem_load_byte mm _ _’ >> + ‘∃bytes. + read_bytearray ffiBufferAddr (w2n (ffiBufferSize:'a word)) + (mem_load_byte mm t.memaddrs t.be) = SOME bytes’ by ( + match_mp_tac read_bytearray_some_bytes_for_ffi >> + gs [state_rel_def, mem_config_def]) >> + qexists_tac ‘bytes'’ >> gs [] >> + gs [next_ffi_def, build_ffi_def] >> + gs [ffiTheory.ffi_state_component_equality] >> + ‘MEM tms (MAP SND prog)’ by ( + drule ALOOKUP_MEM >> + gs [MEM_MAP] >> + strip_tac >> + qexists_tac ‘(s.location,tms)’ >> + gs []) >> + ‘MEM (explode (toString out)) (MAP explode (out_signals prog))’ by ( + gs [timeLangTheory.out_signals_def] >> + gs [MEM_MAP] >> + qexists_tac ‘out’ >> gs [] >> + match_mp_tac terms_out_signals_prog >> + qexists_tac ‘tms’ >> + gs [MEM_MAP] >> + metis_tac []) >> + cases_on ‘explode (num_to_str out) = "get_time_input"’ >> + gs []) >> + impl_tac + >- ( + fs [Abbr ‘nnt’] >> + conj_tac + >- ( + drule pick_term_dest_eq >> + strip_tac >> + pop_assum mp_tac >> + disch_then (qspec_then ‘SND (t.ffi.ffi_state 1) − 1’ mp_tac) >> + impl_tac >- fs [] >> + strip_tac >> + ‘SND (t.ffi.ffi_state 1) − 1 + 1 < dimword (:α)’ by ( + match_mp_tac lt_less_one >> + metis_tac []) >> + ‘1 ≤ SND (t.ffi.ffi_state 1)’ by ( + cases_on ‘SND (t.ffi.ffi_state 1)’ + >- metis_tac [] >> + metis_tac [one_leq_suc]) >> + drule SUB_ADD >> + strip_tac >> + metis_tac []) >> + (* from pick_term theorem *) + match_mp_tac mem_to_flookup >> + fs []) >> + strip_tac >> gvs [] >> + unabbrev_all_tac >> + gvs [empty_locals_def, ffi_call_ffi_def, next_ffi_def] >> + gs [input_io_events_rel_def] >> + conj_asm1_tac + >- ( + qexists_tac ‘bytes’ >> + gs [mk_ti_event_def, time_input_def] >> + drule read_bytearray_LENGTH >> + strip_tac >> + gs [ffiBufferSize_def, good_dimindex_def, + bytes_in_word_def, dimword_def]) >> + conj_asm1_tac + >- ( + gs [from_io_events_def, DROP_LENGTH_APPEND, io_events_dest_def, + mk_ti_event_def, io_event_dest_def, time_input_def] >> + qmatch_goalsub_abbrev_tac ‘ZIP (_, nbytes)’ >> + ‘LENGTH bytes' = LENGTH nbytes’ by ( + fs [Abbr ‘nbytes’, length_get_bytes] >> + gs [good_dimindex_def]) >> + drule MAP_ZIP >> + gs [] >> + strip_tac >> + ‘words_of_bytes t.be nbytes = + [n2w(FST (t.ffi.ffi_state 1)); (n2w(SND (t.ffi.ffi_state 1))):'a word]’ by ( + fs [Abbr ‘nbytes’] >> + match_mp_tac words_of_bytes_get_bytes >> + gs []) >> + gs [input_eq_ffi_seq_def] >> + cases_on ‘t.ffi.ffi_state 1’ >> gs [] >> + gs [input_rel_def, step_cases, next_ffi_def] >> + drule pick_term_dest_eq >> + simp []) >> + gs [from_io_events_def, DROP_LENGTH_APPEND, input_eq_ffi_seq_def] >> + gs [DROP_LENGTH_APPEND, decode_io_events_def, io_events_dest_def, + mk_ti_event_def, decode_io_event_def] >> + cases_on ‘t.ffi.ffi_state 1’ >> gs [] >> + gs [to_input_def] +QED + + +Theorem steps_sts_length_eq_lbls: + ∀lbls prog m n st sts. + steps prog lbls m n st sts ⇒ + LENGTH sts = LENGTH lbls +Proof + Induct >> + rw [] >> + cases_on ‘sts’ >> + gs [steps_def] >> + res_tac >> gs [] +QED + + +Theorem steps_thm: + ∀labels prog n ist st sts (t:('a,time_input) panSem$state). + steps prog labels (dimword (:α) - 1) n st sts ∧ + assumptions prog n st t ⇒ + evaluations prog labels sts ist st t +Proof + Induct + >- ( + rpt gen_tac >> + strip_tac >> + cases_on ‘sts’ >> + fs [evaluations_def, steps_def]) >> + rpt gen_tac >> + strip_tac >> + ‘LENGTH sts = LENGTH (h::labels')’ by + metis_tac [steps_sts_length_eq_lbls] >> + cases_on ‘sts’ >> + fs [] >> + ‘n = FST (t.ffi.ffi_state 0)’ by + gs [assumptions_def] >> + rveq >> gs [] >> + cases_on ‘h’ >> gs [] + >- ((* delay step *) + gs [steps_def] >> + gs [assumptions_def, evaluations_def, event_inv_def] >> + rveq >> gs [] >> + rw [] >> + drule step_delay >> + gs [] >> + disch_then (qspecl_then [‘cycles’, ‘t’, ‘0’, ‘ist’] mp_tac) >> + impl_tac + >- gs [] >> + strip_tac >> + qexists_tac ‘ck+1’ >> + gs [always_def] >> + once_rewrite_tac [panSemTheory.evaluate_def] >> + gs [panSemTheory.eval_def] >> + gs [panSemTheory.dec_clock_def] >> + qexists_tac ‘t'' with clock := t''.clock + 1’ >> + conj_tac + >- rw [] >> + gs [] >> + conj_asm1_tac + >- gs [state_rel_def] >> + gs [] >> + conj_asm1_tac + >- ( + rewrite_tac [wait_time_locals1_def] >> + gs [step_cases, mkState_def] + >- ( + gs [wakeup_shape_def] >> + qexists_tac ‘wt'’ >> + gs []) >> + gs [wakeup_shape_def] >> + qexists_tac ‘wt'’ >> + gs [] >> + strip_tac >> + gs [wakeup_rel_def, nexts_ffi_def] >> + last_x_assum (qspec_then ‘cycles’ mp_tac) >> + gs []) >> + conj_asm1_tac + >- ( + gs [delay_io_events_rel_def] >> + metis_tac []) >> + conj_asm1_tac + >- ( + gs [obs_ios_are_label_delay_def] >> + metis_tac []) >> + conj_asm1_tac + >- gs [task_ret_defined_def] >> + last_x_assum match_mp_tac >> + gs [nexts_ffi_def, delay_rep_def]) + >- ( + cases_on ‘i’ >> + gs [] + >- ( + (* input step *) + gs [steps_def] >> + gs [assumptions_def, evaluations_def, event_inv_def] >> + rveq >> gs [] >> + rw [] >> + drule step_input >> + gs [] >> + disch_then (qspecl_then [‘t’,‘FST (t.ffi.ffi_state 0)’] mp_tac) >> + impl_tac + >- ( + gs [timeSemTheory.step_cases] >> + gs [well_formed_code_def]) >> + strip_tac >> + ‘FST (next_ffi t.ffi.ffi_state 0) = FST (t.ffi.ffi_state 0)’ by ( + gs [state_rel_def] >> + pairarg_tac >> gs [] >> + gs [input_time_rel_def] >> + pairarg_tac >> gs [] >> + gs [input_time_eq_def, has_input_def] >> + last_x_assum (qspec_then ‘0’ mp_tac) >> + impl_tac + >- ( + gs [] >> + gs [input_rel_def, next_ffi_def]) >> + gs [next_ffi_def]) >> + qexists_tac ‘ck+1’ >> + gs [always_def] >> + rewrite_tac [Once panSemTheory.evaluate_def] >> + gs [panSemTheory.eval_def] >> + gs [panSemTheory.dec_clock_def] >> + qexists_tac ‘t''’ >> + fs [] >> + conj_tac + >- ( + rw [] >> + drule evaluate_add_clock_eq >> + gs []) >> + cases_on ‘h'.waitTime’ >> + gs [wait_time_locals1_def] + >- ( + qexists_tac ‘0’ >> + gs [good_dimindex_def, dimword_def]) >> + qexists_tac ‘x’ >> + gs [step_cases] >> + drule pick_term_dest_eq >> + gs []) >> + (* output step *) + gs [steps_def] >> + gs [assumptions_def, event_inv_def, evaluations_def, event_inv_def] >> + rveq >> gs [] >> + rw [] >> + drule step_output >> + gs [] >> + disch_then (qspec_then ‘t’ mp_tac) >> + impl_tac + >- ( + gs [timeSemTheory.step_cases] >> + gs [well_formed_code_def]) >> + strip_tac >> + qexists_tac ‘ck+1’ >> + gs [always_def] >> + rewrite_tac [Once panSemTheory.evaluate_def] >> + gs [panSemTheory.eval_def] >> + gs [panSemTheory.dec_clock_def] >> + qexists_tac ‘t''’ >> + fs [] >> + conj_tac + >- ( + rw [] >> + drule evaluate_add_clock_eq >> + gs []) >> + cases_on ‘h'.waitTime’ >> + gs [wait_time_locals1_def] + >- ( + qexists_tac ‘0’ >> + gs [good_dimindex_def, dimword_def]) >> + qexists_tac ‘x’ >> + gs [] >> + gs [step_cases] >> + drule pick_term_dest_eq >> + gs []) >> + cases_on ‘p’ >> + gs [] + >- ( + gs [steps_def] >> + gs [assumptions_def, evaluations_def, event_inv_def] >> + rveq >> gs [] >> + rw [] >> + drule step_panic_timeout >> + gs [] >> + disch_then (qspec_then ‘t’ mp_tac) >> + impl_tac + >- ( + gs [timeSemTheory.step_cases] >> + gs [well_formed_code_def]) >> + strip_tac >> + qexists_tac ‘ck+1’ >> + gs [always_def] >> + rewrite_tac [Once panSemTheory.evaluate_def] >> + gs [panSemTheory.eval_def] >> + gs [panSemTheory.dec_clock_def] >> + qexists_tac ‘t''’ >> + fs [] >> + rw [] >> gvs [] >> + drule evaluate_add_clock_eq >> + gs []) >> + (* input step *) + gs [steps_def] >> + gs [assumptions_def, evaluations_def, event_inv_def] >> + rveq >> gs [] >> + rw [] >> + drule step_panic_input >> + gs [] >> + disch_then (qspecl_then [‘t’,‘FST (t.ffi.ffi_state 0)’] mp_tac) >> + impl_tac + >- ( + gs [timeSemTheory.step_cases] >> + gs [well_formed_code_def]) >> + strip_tac >> + qexists_tac ‘ck+1’ >> + gs [always_def] >> + rewrite_tac [Once panSemTheory.evaluate_def] >> + gs [panSemTheory.eval_def] >> + gs [panSemTheory.dec_clock_def] >> + qexists_tac ‘t''’ >> + fs [] >> + rw [] >> gvs [] >> + drule evaluate_add_clock_eq >> + gs [] +QED + + +Theorem decode_ios_length_eq_sum: + ∀labels ns ios be. + decode_ios (:α) be labels ns ios ∧ + LENGTH labels = LENGTH ns ⇒ + SUM ns = LENGTH ios - 1 +Proof + Induct >> + rw [] >> + gs [decode_ios_def] >> + cases_on ‘ns’ >> gs [decode_ios_def] +QED + +Theorem drop_length_eq_last: + ∀xs. + xs ≠ [] ⇒ + DROP (LENGTH xs − 1) xs = [LAST xs] +Proof + Induct >> + rw [] >> + cases_on ‘xs = []’ >> gs [LAST_CONS_cond] >> + ‘DROP (LENGTH xs) (h::xs) = DROP (LENGTH xs - 1) xs’ by ( + match_mp_tac DROP_cons >> + gs [] >> + cases_on ‘xs’ >> gs []) >> + gs [] +QED + +Definition sum_delays_def: + sum_delays (:α) lbls (ffi:time_input) ⇔ + SUM (MAP (λlbl. + case lbl of + | LDelay d => d + | _ => 0) lbls) + FST (ffi 0) = dimword (:α) − 2 ∧ + (∀n. + FST (ffi n) = dimword (:α) − 2 ⇒ + ffi (n+1) = (dimword (:α) − 1, 0) ∧ + SND (ffi n) = 0 ∧ + mem_read_ffi_results (:α) ffi (n+1)) +End + +Definition no_panic_def: + no_panic lbls ⇔ + ∀lbl. + MEM lbl lbls ⇒ + lbl ≠ LPanic (PanicTimeout) ∧ + (∀is. lbl ≠ LPanic is) +End + +Theorem steps_io_event_no_panic_thm: + ∀labels prog n st sts (t:('a,time_input) panSem$state) ist. + steps prog labels (dimword (:α) - 1) n st sts ∧ + no_panic labels ∧ + assumptions prog n st t ∧ + ffi_rels prog labels st t ist ∧ + sum_delays (:α) labels t.ffi.ffi_state ⇒ + ∃ck t' ns ios. + evaluate (time_to_pan$always (nClks prog), t with clock := t.clock + ck) = + (SOME (Return (ValWord 0w)),t') ∧ + t'.ffi.io_events = t.ffi.io_events ++ ios ∧ + LENGTH labels = LENGTH ns ∧ + SUM ns + 1 = LENGTH ios ∧ + t'.be = t.be ∧ + decode_ios (:α) t'.be labels ns + (LAST t.ffi.io_events::TAKE (SUM ns) ios) +Proof + rw [] >> + gs [no_panic_def] >> + drule_all steps_thm >> + disch_then (qspec_then ‘ist’ mp_tac) >> + strip_tac >> + rpt (pop_assum mp_tac) >> + MAP_EVERY qid_spec_tac [‘ist’, ‘t’, ‘sts’, ‘st’, ‘n’, ‘prog’, ‘labels'’] >> + Induct + >- ( + rw [] >> + cases_on ‘sts’ >> + fs [evaluations_def, steps_def] >> + gs [sum_delays_def] >> + qexists_tac ‘2’ >> + gs [always_def] >> + once_rewrite_tac [panSemTheory.evaluate_def] >> + gs [panSemTheory.eval_def] >> + gs [panSemTheory.dec_clock_def] >> + pairarg_tac >> gs [] >> + pop_assum mp_tac >> + fs [task_controller_def] >> + fs [panLangTheory.nested_seq_def] >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> gs [] >> + pop_assum mp_tac >> + fs [wait_input_time_limit_def] >> + rewrite_tac [Once evaluate_def] >> + ‘FLOOKUP t.locals «isInput» = SOME (ValWord 1w)’ by + gs [assumptions_def, event_inv_def] >> + ‘∃w. eval t wait = SOME (ValWord w)’ by ( + cases_on ‘st.waitTime’ + >- ( + ‘FLOOKUP t.locals «waitSet» = SOME (ValWord 1w)’ by + gs [assumptions_def, state_rel_def, equivs_def, active_low_def] >> + drule step_delay_eval_wait_not_zero >> + impl_tac + >- gs [assumptions_def, state_rel_def, mkState_def, + equivs_def, time_vars_def, active_low_def] >> + gs [] >> metis_tac []) >> + gs [] >> + ‘FLOOKUP t.locals «waitSet» = SOME (ValWord 0w)’ by + gs [assumptions_def, state_rel_def, equivs_def, active_low_def] >> + gvs [wait_def, eval_def, OPT_MMAP_def, assumptions_def, state_rel_def] >> + pairarg_tac >> gs [] >> + gs [ffi_rels_def] >> + gs [wait_time_locals1_def] >> + gs [asmTheory.word_cmp_def] >> + cases_on ‘(ist + wt) MOD dimword (:α) ≠ dimword (:α) − 2’ >> + gvs [wordLangTheory.word_op_def]) >> + reverse (cases_on ‘w = 0w’) >> gvs [] + >- ( + gs [eval_upd_clock_eq] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + fs [dec_clock_def] >> + rewrite_tac [Once check_input_time_def] >> + fs [panLangTheory.nested_seq_def] >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + gs [assumptions_def] >> + drule state_rel_imp_mem_config >> + rewrite_tac [Once mem_config_def] >> + strip_tac >> + fs [] >> + ‘∃bytes. + read_bytearray ffiBufferAddr (w2n (ffiBufferSize:'a word)) + (mem_load_byte t.memory t.memaddrs t.be) = SOME bytes’ by ( + match_mp_tac read_bytearray_some_bytes_for_ffi >> + gs []) >> + drule evaluate_ext_call >> + disch_then (qspecl_then [‘MAP explode (out_signals prog)’,‘bytes’] mp_tac) >> + impl_tac + >- ( + gs [state_rel_def] >> + pairarg_tac >> gs []) >> + strip_tac >> gs [] >> rveq >> gs [] >> + pop_assum kall_tac >> + drule state_rel_imp_ffi_vars >> + strip_tac >> + pop_assum mp_tac >> + rewrite_tac [Once ffi_vars_def] >> + strip_tac >> + drule state_rel_imp_systime_defined >> + strip_tac >> + (* reading systime *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «sysTime» _, nt)’ >> + ‘nt.memory ffiBufferAddr = Word (n2w (FST(t.ffi.ffi_state 1)))’ by ( + fs [Abbr ‘nt’] >> + last_x_assum (qspec_then ‘0’ mp_tac) >> + impl_tac >- gs [] >> + strip_tac >> + gs [mem_read_ffi_results_def] >> + qmatch_asmsub_abbrev_tac ‘evaluate (ExtCall _ _ _ _ _, _) = (_, ft)’ >> + last_x_assum + (qspecl_then + [‘t with clock := t.clock’, + ‘ft’] mp_tac) >> + impl_tac + >- gs [Abbr ‘ft’, nexts_ffi_def, GSYM ETA_AX] >> + strip_tac >> + gs [Abbr ‘ft’, nexts_ffi_def, GSYM ETA_AX]) >> + drule evaluate_assign_load >> + gs [] >> + disch_then (qspecl_then + [‘ffiBufferAddr’, ‘tm’, + ‘n2w (FST (t.ffi.ffi_state 1))’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nt’] >> + fs [state_rel_def]) >> + strip_tac >> fs [] >> rveq >> gs [] >> + pop_assum kall_tac >> + (* reading input to the variable event *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «event» _, nnt)’ >> + ‘nnt.memory (ffiBufferAddr + bytes_in_word) = + Word (n2w (SND(t.ffi.ffi_state 1)))’ by ( + fs [Abbr ‘nnt’, Abbr ‘nt’] >> + last_x_assum (qspec_then ‘0’ mp_tac) >> + impl_tac >- gs [] >> + strip_tac >> + gs [mem_read_ffi_results_def] >> + qmatch_asmsub_abbrev_tac ‘evaluate (ExtCall _ _ _ _ _, _) = (_, ft)’ >> + last_x_assum + (qspecl_then + [‘t with clock := t.clock’, + ‘ft’] mp_tac) >> + impl_tac + >- gs [Abbr ‘ft’, nexts_ffi_def, GSYM ETA_AX] >> + strip_tac >> + gs [Abbr ‘ft’, nexts_ffi_def, GSYM ETA_AX]) >> + gs [] >> + drule evaluate_assign_load_next_address >> + gs [] >> + disch_then (qspecl_then + [‘ffiBufferAddr’, + ‘n2w (SND (t.ffi.ffi_state 1))’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nnt’,Abbr ‘nt’, active_low_def] >> + gs [state_rel_def, time_vars_def, FLOOKUP_UPDATE]) >> + strip_tac >> + gs [] >> rveq >> gs [] >> + (* isInput *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «isInput» _, nnnt)’ >> + ‘nnnt.memory (ffiBufferAddr + bytes_in_word) = + Word (n2w (SND(t.ffi.ffi_state 1)))’ by fs [Abbr ‘nnnt’] >> + gs [] >> + drule evaluate_assign_compare_next_address >> + gs [] >> + disch_then (qspecl_then [‘ffiBufferAddr’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nnnt’, Abbr ‘nnt’,Abbr ‘nt’, active_low_def] >> + gs [state_rel_def, time_vars_def, FLOOKUP_UPDATE] >> + last_x_assum (qspec_then ‘0’ mp_tac) >> + impl_tac >- gs [] >> + gs []) >> + strip_tac >> + gs [] >> rveq >> gs [] >> + (* If statement *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + drule evaluate_if_compare_sys_time1 >> + disch_then (qspec_then ‘FST (t.ffi.ffi_state 1)’ mp_tac) >> + impl_tac + >- ( + unabbrev_all_tac >> + gs [FLOOKUP_UPDATE, ADD1] >> + last_x_assum (qspec_then ‘0’ mp_tac) >> + impl_tac >- gs [] >> + gs []) >> + unabbrev_all_tac >> gs [] >> + rpt strip_tac >> gs [empty_locals_def] >> rveq >> + gs [ffi_call_ffi_def, state_component_equality] >> + gs [decode_ios_def]) >> + gs [eval_upd_clock_eq] >> + strip_tac >> gvs [] >> + ‘FLOOKUP t.locals «sysTime» = SOME (ValWord (n2w (FST (t.ffi.ffi_state 0))))’ by ( + gvs [assumptions_def, state_rel_def] >> + pairarg_tac >> gvs []) >> + gvs [] >> + qmatch_goalsub_abbrev_tac ‘evaluate (Seq _ q, _)’ >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + pop_assum mp_tac >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + gs [eval_def, asmTheory.word_cmp_def] >> + rewrite_tac [Once check_input_time_def] >> + fs [panLangTheory.nested_seq_def] >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + gs [assumptions_def] >> + drule state_rel_imp_mem_config >> + rewrite_tac [Once mem_config_def] >> + strip_tac >> + fs [] >> + ‘∃bytes. + read_bytearray ffiBufferAddr (w2n (ffiBufferSize:'a word)) + (mem_load_byte t.memory t.memaddrs t.be) = SOME bytes’ by ( + match_mp_tac read_bytearray_some_bytes_for_ffi >> + gs []) >> + drule evaluate_ext_call >> + disch_then (qspecl_then [‘MAP explode (out_signals prog)’,‘bytes’] mp_tac) >> + impl_tac + >- ( + gs [state_rel_def] >> + pairarg_tac >> gs []) >> + strip_tac >> gs [] >> rveq >> gs [] >> + pop_assum kall_tac >> + drule state_rel_imp_ffi_vars >> + strip_tac >> + pop_assum mp_tac >> + rewrite_tac [Once ffi_vars_def] >> + strip_tac >> + drule state_rel_imp_systime_defined >> + strip_tac >> + (* reading systime *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «sysTime» _, nt)’ >> + ‘nt.memory ffiBufferAddr = Word (n2w (FST(t.ffi.ffi_state 1)))’ by ( + fs [Abbr ‘nt’] >> + last_x_assum (qspec_then ‘0’ mp_tac) >> + impl_tac >- gs [] >> + strip_tac >> + gs [mem_read_ffi_results_def] >> + qmatch_asmsub_abbrev_tac ‘evaluate (ExtCall _ _ _ _ _, _) = (_, ft)’ >> + last_x_assum + (qspecl_then + [‘t with clock := t.clock + 1’, + ‘ft’] mp_tac) >> + impl_tac + >- gs [Abbr ‘ft’, nexts_ffi_def, GSYM ETA_AX] >> + strip_tac >> + gs [Abbr ‘ft’, nexts_ffi_def, GSYM ETA_AX]) >> + drule evaluate_assign_load >> + gs [] >> + disch_then (qspecl_then + [‘ffiBufferAddr’, ‘tm’, + ‘n2w (FST (t.ffi.ffi_state 1))’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nt’] >> + fs [state_rel_def]) >> + strip_tac >> fs [] >> rveq >> gs [] >> + pop_assum kall_tac >> + (* reading input to the variable event *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «event» _, nnt)’ >> + ‘nnt.memory (ffiBufferAddr + bytes_in_word) = + Word (n2w (SND(t.ffi.ffi_state 1)))’ by ( + fs [Abbr ‘nnt’, Abbr ‘nt’] >> + last_x_assum (qspec_then ‘0’ mp_tac) >> + impl_tac >- gs [] >> + strip_tac >> + gs [mem_read_ffi_results_def] >> + qmatch_asmsub_abbrev_tac ‘evaluate (ExtCall _ _ _ _ _, _) = (_, ft)’ >> + last_x_assum + (qspecl_then + [‘t with clock := t.clock + 1’, + ‘ft’] mp_tac) >> + impl_tac + >- gs [Abbr ‘ft’, nexts_ffi_def, GSYM ETA_AX] >> + strip_tac >> + gs [Abbr ‘ft’, nexts_ffi_def, GSYM ETA_AX]) >> + gs [] >> + drule evaluate_assign_load_next_address >> + gs [] >> + disch_then (qspecl_then + [‘ffiBufferAddr’, + ‘n2w (SND (t.ffi.ffi_state 1))’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nnt’,Abbr ‘nt’, active_low_def] >> + gs [state_rel_def, time_vars_def, FLOOKUP_UPDATE]) >> + strip_tac >> + gs [] >> rveq >> gs [] >> + (* isInput *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «isInput» _, nnnt)’ >> + ‘nnnt.memory (ffiBufferAddr + bytes_in_word) = + Word (n2w (SND(t.ffi.ffi_state 1)))’ by fs [Abbr ‘nnnt’] >> + gs [] >> + drule evaluate_assign_compare_next_address >> + gs [] >> + disch_then (qspecl_then [‘ffiBufferAddr’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘nnnt’, Abbr ‘nnt’,Abbr ‘nt’, active_low_def] >> + gs [state_rel_def, time_vars_def, FLOOKUP_UPDATE] >> + last_x_assum (qspec_then ‘0’ mp_tac) >> + impl_tac >- gs [] >> + gs []) >> + strip_tac >> + gs [] >> rveq >> gs [] >> + (* If statement *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + drule evaluate_if_compare_sys_time1 >> + disch_then (qspec_then ‘FST (t.ffi.ffi_state 1)’ mp_tac) >> + impl_tac + >- ( + unabbrev_all_tac >> + gs [FLOOKUP_UPDATE, ADD1] >> + last_x_assum (qspec_then ‘0’ mp_tac) >> + impl_tac >- gs [] >> + gs []) >> + unabbrev_all_tac >> gs [] >> + rpt strip_tac >> gs [empty_locals_def] >> rveq >> + gs [ffi_call_ffi_def, state_component_equality] >> + gs [decode_ios_def]) >> + rw [] >> + ‘LENGTH sts = LENGTH (h::labels')’ by + metis_tac [steps_sts_length_eq_lbls] >> + cases_on ‘sts’ >> + fs [] >> + ‘n = FST (t.ffi.ffi_state 0)’ by + gs [assumptions_def] >> + rveq >> gs [] >> + gs [evaluations_def, steps_def] >> + cases_on ‘h’ >> gs [] >> + TRY ( + cases_on ‘p’ >> gvs [] + >- ( + first_x_assum (qspec_then ‘LPanic PanicTimeout’ mp_tac) >> + gvs []) >> + first_x_assum (qspec_then ‘LPanic (PanicInput n)’ mp_tac) >> + gvs []) + >- ( + gs [ffi_rels_def, ffi_rel_def] >> + first_x_assum drule >> + gs [] >> + strip_tac >> + last_x_assum drule >> + disch_then (qspecl_then [‘nt’, ‘ist’] mp_tac) >> + impl_tac + >- ( + gs [assumptions_def] >> + gs [nexts_ffi_def, delay_rep_def] >> + conj_tac + >- ( + first_x_assum match_mp_tac >> + metis_tac []) >> + once_rewrite_tac [sum_delays_def] >> + conj_tac >- gs [sum_delays_def] >> + gs [sum_delays_def] >> + gen_tac >> + strip_tac >> + first_x_assum (qspec_then ‘cycles + n'’ mp_tac) >> + first_x_assum (qspec_then ‘cycles + n'’ mp_tac) >> + gs [] >> + strip_tac >> + strip_tac >> + gs [mem_read_ffi_results_def] >> + rpt gen_tac >> + strip_tac >> + first_x_assum (qspec_then ‘i + cycles’ mp_tac) >> + gs [nexts_ffi_def] >> + disch_then + (qspec_then ‘t'' with ffi := + (t''.ffi with ffi_state := + (λn''. t.ffi.ffi_state (cycles + (i + n''))))’ mp_tac) >> + gs [] >> + disch_then (qspec_then ‘t'''’ mp_tac) >> + impl_tac + >- ( + gs [] >> + ‘t'' with + ffi := + t''.ffi with + ffi_state := (λn''. t.ffi.ffi_state (cycles + (i + n''))) = + t''’ by + gs [state_component_equality, ffiTheory.ffi_state_component_equality] >> + gs []) >> + gs []) >> + strip_tac >> + first_x_assum (qspec_then ‘ck'’ assume_tac) >> + qexists_tac ‘ck + ck'’ >> gs [] >> + gs [delay_io_events_rel_def] >> + qexists_tac ‘cycles::ns’ >> + rewrite_tac [decode_ios_def] >> + gs [] >> + TOP_CASE_TAC + >- ( + gs [mk_ti_events_def, gen_ffi_states_def] >> + gs [delay_rep_def] >> + drule decode_ios_length_eq_sum >> + gs []) >> + conj_asm1_tac + >- gs [mk_ti_events_def, gen_ffi_states_def] >> + (* + gs [] >> + cases_on ‘ios’ >> + gvs [FRONT_APPEND]*) + conj_asm1_tac + >- gs [TAKE_SUM] >> + qmatch_asmsub_abbrev_tac ‘decode_ios _ _ _ ns nios’ >> + qmatch_goalsub_abbrev_tac ‘decode_ios _ _ _ ns nios'’ >> + ‘nios = nios'’ by ( + gs [Abbr ‘nios’, Abbr ‘nios'’] >> + gs [TAKE_SUM] >> + qmatch_goalsub_abbrev_tac ‘TAKE _ (xs ++ _)’ >> + ‘cycles = LENGTH xs’ by + gs [Abbr ‘xs’, mk_ti_events_def, gen_ffi_states_def] >> + gs [TAKE_LENGTH_APPEND, DROP_LENGTH_APPEND] >> + gs [DROP_APPEND] >> + ‘LENGTH xs − 1 − LENGTH xs = 0’ by gs [] >> + simp [] >> + pop_assum kall_tac >> + ‘DROP (LENGTH xs − 1) xs = [LAST xs]’ by ( + match_mp_tac drop_length_eq_last >> + CCONTR_TAC >> + gvs []) >> + gs [] >> + ‘cycles = LENGTH xs’ by gvs [] >> + cases_on ‘xs’ >- gs [] >> + simp [LAST_APPEND_CONS] >> gvs [] >> + ‘LENGTH t'³' − SUC (LENGTH t'³') = 0’ by gs [] >> + simp [] >> + gs [DROP_LENGTH_NIL, TAKE_LENGTH_APPEND, LAST_CONS_cond] >> + cases_on ‘t'''’ >> gvs []) >> + qpat_x_assum ‘obs_ios_are_label_delay _ _ _’ mp_tac >> + gs [obs_ios_are_label_delay_def] >> + strip_tac >> + pop_assum mp_tac >> + impl_tac + >- ( + CCONTR_TAC >> + gs [DROP_LENGTH_APPEND, mk_ti_events_def, gen_ffi_states_def, decode_io_events_def] >> + gs [ZIP_EQ_NIL]) >> + strip_tac >> + gs [] >> + qmatch_goalsub_abbrev_tac ‘TAKE _ (TAKE _ (xs ++ _))’ >> + ‘TAKE cycles (TAKE (cycles + SUM ns) (xs ++ ios)) = + xs’ by ( + ‘cycles = LENGTH xs’ by + gs [Abbr ‘xs’, mk_ti_events_def, gen_ffi_states_def] >> + simp [] >> + gs [TAKE_SUM, TAKE_LENGTH_APPEND]) >> + gs [Abbr ‘xs’, DROP_LENGTH_APPEND]) >> + cases_on ‘i’ + >- ( + gs [ffi_rels_def, ffi_rel_def, action_rel_def] >> + first_x_assum drule >> + disch_then (qspec_then ‘nt’ mp_tac) >> + impl_tac >- gs [] >> + strip_tac >> + last_x_assum drule >> + disch_then (qspecl_then [‘nt’, ‘ist’] mp_tac) >> + impl_tac + >- ( + gvs [assumptions_def] >> + gs [nexts_ffi_def, input_rel_def] >> + qpat_x_assum ‘state_rel _ _ _ t’ assume_tac >> + gs [state_rel_def] >> + pairarg_tac >> gs [] >> + gs [input_time_rel_def] >> + gs [input_time_eq_def, has_input_def] >> + first_x_assum (qspec_then ‘0’ mp_tac) >> + impl_tac + >- ( + gs [] >> + gs [input_rel_def, next_ffi_def]) >> + gs [next_ffi_def] >> + strip_tac >> + cases_on ‘evaluate (always (nClks prog),t)’ >> + gs [] >> + drule evaluate_add_clock_eq >> + gs [] >> + disch_then (qspec_then ‘ck’ mp_tac) >> + gs [] >> + rpt strip_tac >> + gs [sum_delays_def] >> + gen_tac >> + strip_tac >> + first_x_assum (qspec_then ‘n' + 1’ mp_tac) >> + first_x_assum (qspec_then ‘n' + 1’ mp_tac) >> + gs [] >> + strip_tac >> + strip_tac >> + gs [mem_read_ffi_results_def] >> + rpt gen_tac >> + strip_tac >> + first_x_assum (qspec_then ‘i + 1’ mp_tac) >> + gs [nexts_ffi_def] >> + disch_then + (qspec_then ‘t'' with ffi := + (t''.ffi with ffi_state := + (λn''. t.ffi.ffi_state (1 + (i + n''))))’ mp_tac) >> + gs [] >> + disch_then (qspec_then ‘t'''’ mp_tac) >> + impl_tac + >- ( + gs [] >> + ‘t'' with + ffi := + t''.ffi with + ffi_state := (λn''. t.ffi.ffi_state (1 + (i + n''))) = + t''’ by + gs [state_component_equality, ffiTheory.ffi_state_component_equality] >> + gs []) >> + gs []) >> + strip_tac >> + first_x_assum (qspec_then ‘ck'’ assume_tac) >> + qexists_tac ‘ck + ck'’ >> gs [] >> + gs [input_io_events_rel_def] >> + qexists_tac ‘1::ns’ >> + rewrite_tac [decode_ios_def] >> + gs [] >> + gs [to_input_def, DROP_LENGTH_APPEND, decode_io_events_def] >> + ‘LENGTH ios − 1 = SUM ns’ by gs [] >> + simp []) >> + gs [ffi_rels_def, ffi_rel_def, action_rel_def] >> + first_x_assum drule >> + disch_then (qspec_then ‘nt’ mp_tac) >> + impl_tac >- gs [] >> + strip_tac >> + last_x_assum drule >> + disch_then (qspecl_then [‘nt’, ‘ist’] mp_tac) >> + impl_tac + >- ( + gs [assumptions_def] >> + cases_on ‘evaluate (always (nClks prog),t)’ >> + gs [] >> + drule evaluate_add_clock_eq >> + gs [] >> + disch_then (qspec_then ‘ck’ mp_tac) >> + gs [] >> + rpt strip_tac >> + gs[sum_delays_def]) >> + strip_tac >> + first_x_assum (qspec_then ‘ck'’ assume_tac) >> + qexists_tac ‘ck + ck'’ >> gs [] >> + gs [output_io_events_rel_def] >> + qexists_tac ‘1::ns’ >> + rewrite_tac [decode_ios_def] >> + gs [to_input_def, DROP_LENGTH_APPEND, decode_io_events_def] >> + ‘LENGTH ios − 1 = SUM ns’ by gs [] >> + simp [] +QED + +Theorem opt_mmap_empty_const: + ∀t prog v n. + FLOOKUP t.code (num_to_str (FST (ohd prog))) = SOME v ⇒ + OPT_MMAP (λa. eval t a) + [Struct (emptyConsts n); + Const 0w; Const 0w; Label (toString (FST (ohd prog)))] = + SOME ([Struct (emptyVals n); ValWord 0w; ValWord 0w; ValLabel (toString (FST (ohd prog)))]) +Proof + rw [] >> + gs [opt_mmap_eq_some] >> + gs [eval_def] >> + gs [eval_empty_const_eq_empty_vals, FDOM_FLOOKUP] +QED + +Theorem eval_mkClks: + ∀t st n. + FLOOKUP t.locals «sysTime» = SOME (ValWord (n2w st)) ⇒ + OPT_MMAP (λa. eval t a) (mkClks «sysTime» n) = + SOME (REPLICATE n (ValWord (n2w st))) +Proof + rpt gen_tac >> + strip_tac >> + fs [mkClks_def, opt_mmap_eq_some, eval_def] +QED + + +Theorem replicate_shape_one: + ∀n. + REPLICATE n One = + MAP (λa. shape_of a) (emptyVals n) +Proof + Induct >> + gs [emptyVals_def, shape_of_def] +QED + +Definition wf_prog_and_init_states_def: + wf_prog_and_init_states prog st (t:('a,time_input) panSem$state) ⇔ + prog ≠ [] ∧ LENGTH (clksOf prog) ≤ 29 ∧ + st.location = FST (ohd prog) ∧ + init_clocks st.clocks (clksOf prog) ∧ + code_installed t.code prog ∧ + FLOOKUP t.eshapes «panic» = SOME One ∧ + FLOOKUP t.code «start» = + SOME ([], ta_controller (prog,st.waitTime)) ∧ + FLOOKUP t.code «start_controller» = + SOME ([], start_controller (prog,st.waitTime)) ∧ + well_formed_code prog t.code ∧ + mem_config t.memory t.memaddrs t.be ∧ + mem_read_ffi_results (:α) t.ffi.ffi_state 1 ∧ + t.ffi = + build_ffi (:'a) t.be (MAP explode (out_signals prog)) + t.ffi.ffi_state t.ffi.io_events ∧ + init_ffi t.ffi.ffi_state ∧ + input_time_rel t.ffi.ffi_state ∧ + FST (t.ffi.ffi_state 0) < dimword (:α) − 1 ∧ + time_seq t.ffi.ffi_state (dimword (:α)) ∧ + t.ffi.io_events = [] ∧ + good_dimindex (:'a) ∧ + ~MEM "get_time_input" (MAP explode (out_signals prog)) +End + +Theorem timed_automata_no_panic_correct_main: + ∀prog labels st sts (t:('a,time_input) panSem$state). + steps prog labels + (dimword (:α) - 1) (FST (t.ffi.ffi_state 0)) st sts ∧ + no_panic labels ∧ + wf_prog_and_init_states prog st t ∧ + ffi_rels_after_init prog labels st t ∧ + sum_delays (:α) labels (next_ffi t.ffi.ffi_state) ⇒ + ∃io ios ns. + semantics t «start» = Terminate Success (io::ios) ∧ + LENGTH labels = LENGTH ns ∧ + SUM ns + 1 = LENGTH ios ∧ + decode_ios (:α) t.be labels ns + (io::TAKE (SUM ns) ios) +Proof + rw [wf_prog_and_init_states_def, no_panic_def] >> + ‘∃ck t' io ios ns. + evaluate + (TailCall (Label «start» ) [],t with clock := t.clock + ck) = + (SOME (Return (ValWord 0w)),t') ∧ + t'.ffi.io_events = t.ffi.io_events ++ io::ios ∧ + LENGTH labels' = LENGTH ns ∧ + SUM ns + 1 = LENGTH ios ∧ + decode_ios (:α) t.be labels' ns + (io::TAKE (SUM ns) ios)’ by ( + ‘∃bytes. + read_bytearray ffiBufferAddr (w2n (ffiBufferSize:'a word)) + (mem_load_byte t.memory t.memaddrs t.be) = SOME bytes’ by ( + match_mp_tac read_bytearray_some_bytes_for_ffi >> + gs [] >> + gs [mem_config_def]) >> + qabbrev_tac + ‘nt = + t with + <|locals := locals_before_start_ctrl prog st.waitTime (t.ffi.ffi_state 0); + memory := mem_call_ffi (:α) t.memory t.memaddrs t.be t.ffi.ffi_state; + clock := t.clock; ffi := ffi_call_ffi (:α) t.be t.ffi bytes|>’ >> + ‘∃ck t' ns ios. + evaluate (always (nClks prog),nt with clock := nt.clock + ck) = + (SOME (Return (ValWord 0w)),t') ∧ + t'.ffi.io_events = nt.ffi.io_events ++ ios ∧ + LENGTH labels' = LENGTH ns ∧ SUM ns + 1 = LENGTH ios ∧ + (t'.be ⇔ nt.be) ∧ + decode_ios (:α) t'.be labels' ns + (LAST nt.ffi.io_events::TAKE (SUM ns) ios)’ by ( + match_mp_tac steps_io_event_no_panic_thm >> + MAP_EVERY qexists_tac [‘FST (t.ffi.ffi_state 0)’, ‘st’, ‘sts’, + ‘(FST (t.ffi.ffi_state 0))’] >> + gs [no_panic_def] >> + conj_tac + >- ( + unabbrev_all_tac >> + gs [assumptions_def, locals_before_start_ctrl_def] >> rveq >> + conj_tac + (* state_rel *) + >- ( + gs [state_rel_def] >> + pairarg_tac >> gs [] >> + gs [FLOOKUP_UPDATE, ffi_call_ffi_def, next_ffi_def, init_ffi_def, + ffi_vars_def, time_vars_def] >> + conj_tac + >- ( + gs [equivs_def, FLOOKUP_UPDATE] >> + cases_on ‘st.waitTime’ >> gs [active_low_def]) >> + conj_tac + >- ( + gs [mem_call_ffi_def, mem_config_def] >> + conj_tac >> ( + fs [ffiBufferAddr_def] >> + match_mp_tac write_bytearray_update_byte >> + gs [good_dimindex_def] >> + gs [byte_align_def, byte_aligned_def, align_def, aligned_def, bytes_in_word_def] >> + gs [dimword_def] >> + EVAL_TAC >> + rveq >> gs [] >> + EVAL_TAC)) >> + conj_tac + >- ( + gs [defined_clocks_def, init_clocks_def] >> + gs [EVERY_MEM]) >> + conj_tac + >- gs [build_ffi_def, ffiTheory.ffi_state_component_equality] >> + conj_tac + >- ( + gs [input_time_rel_def] >> + rw [] >> + last_x_assum (qspec_then ‘n + 1’ mp_tac) >> + gs []) >> + conj_tac + >- ( + gs [time_seq_def] >> + rw [] >> + gs [] >> + cases_on ‘n’ >> gs [] + >- ( + first_x_assum (qspec_then ‘1’ mp_tac) >> + gs []) >> + first_x_assum (qspec_then ‘SUC (SUC n')’ mp_tac) >> + gs [ADD1]) >> + gs [clocks_rel_def, FLOOKUP_UPDATE] >> + qexists_tac ‘REPLICATE (nClks prog) tm’ >> + gs [map_replicate, timeLangTheory.nClks_def] >> + gs [clkvals_rel_def, EVERY_MEM, init_clocks_def] >> + gs [GSYM MAP_K_REPLICATE] >> + gs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + qmatch_goalsub_abbrev_tac ‘EL _ (ZIP (xs,ys))’ >> + ‘EL n (ZIP (xs,ys)) = (EL n xs, EL n ys)’ by ( + match_mp_tac EL_ZIP >> + unabbrev_all_tac >> + gs []) >> + unabbrev_all_tac >> + gs [] >> + gs [MEM_EL] >> + last_x_assum (qspec_then ‘EL n (clksOf prog)’ mp_tac) >> + impl_tac >- metis_tac [] >> + strip_tac >> + gs [EL_MAP]) >> + gs [init_ffi_def, ffi_call_ffi_def, next_ffi_def] >> + (* event_inv *) + conj_tac + >- gs [event_inv_def, FLOOKUP_UPDATE] >> + gs [task_ret_defined_def] >> + gs [FLOOKUP_UPDATE, emptyVals_def]) >> + unabbrev_all_tac >> + gs [ffi_rels_after_init_def] >> + qmatch_asmsub_abbrev_tac ‘ffi_rels _ _ _ tt'’ >> + qmatch_goalsub_abbrev_tac ‘ffi_rels _ _ _ tt’ >> + ‘tt' = tt’ by ( + unabbrev_all_tac >> + gs [state_component_equality]) >> + gs [ffi_call_ffi_def]) >> + qexists_tac ‘ck + 2’ >> + rw [] >> + once_rewrite_tac [evaluate_def] >> + gs [] >> + gs [eval_def, OPT_MMAP_def, lookup_code_def, dec_clock_def, FUPDATE_LIST] >> + (* qpat_x_assum ‘FLOOKUP t.code _ = _’ kall_tac >> *) + (* ta_controller *) + fs [ta_controller_def, panLangTheory.decs_def] >> + once_rewrite_tac [evaluate_def] >> + gs [eval_def] >> + once_rewrite_tac [evaluate_def] >> + gs [eval_def] >> + pairarg_tac >> gvs [] >> + pairarg_tac >> gvs [] >> + pop_assum mp_tac >> + gs [panLangTheory.nested_seq_def] >> + once_rewrite_tac [evaluate_def] >> + gs [] >> + pairarg_tac >> gvs [] >> + pop_assum mp_tac >> + once_rewrite_tac [evaluate_def] >> + gvs [eval_def] >> + gs [eval_def, OPT_MMAP_def, lookup_code_def, dec_clock_def, FUPDATE_LIST] >> + qpat_x_assum ‘FLOOKUP t.code _ = _’ kall_tac >> + qpat_x_assum ‘FLOOKUP t.code _ = _’ kall_tac >> + (* start contoller *) + fs [start_controller_def, panLangTheory.decs_def] >> + once_rewrite_tac [evaluate_def] >> + gs [eval_def] >> + ‘∃v1. FLOOKUP t.code (num_to_str (FST (ohd prog))) = SOME v1’ by ( + cases_on ‘prog’ >> + gs [ohd_def, code_installed_def] >> + cases_on ‘h’ >> gs [] >> metis_tac []) >> + gs [] >> + pairarg_tac >> gs [] >> + pop_assum mp_tac >> + once_rewrite_tac [evaluate_def] >> + qmatch_goalsub_abbrev_tac ‘eval tt q’ >> + ‘eval tt q = + SOME (ValWord ( + case st.waitTime of + | NONE => 1w + | SOME _ => (0w:'a word)))’ by ( + unabbrev_all_tac >> gs [] >> + TOP_CASE_TAC >> gs [eval_def]) >> + unabbrev_all_tac >> gs [] >> + gs [] >> + pairarg_tac >> gs [] >> + gs [evaluate_def, eval_def] >> + rpt (pairarg_tac >> gs []) >> + strip_tac >> rveq >> gs [] >> + qmatch_asmsub_abbrev_tac ‘eval tt _’ >> + ‘t.code = tt.code’ by ( + unabbrev_all_tac >> gs []) >> + fs [] >> + drule opt_mmap_empty_const >> + disch_then (qspec_then ‘nClks prog’ assume_tac) >> + gs [] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + pairarg_tac >> + unabbrev_all_tac >> gs [] >> + rveq >> gs [] >> + qmatch_asmsub_abbrev_tac ‘eval tt _’ >> + gs [eval_empty_const_eq_empty_vals] >> + pairarg_tac >> + unabbrev_all_tac >> gs [] >> + rveq >> gs [] >> + gs [FLOOKUP_UPDATE] >> + (* Decs are completed *) + gs [panLangTheory.nested_seq_def] >> + pop_assum mp_tac >> + once_rewrite_tac [evaluate_def] >> + gs [] >> + pairarg_tac >> rveq >> gs [] >> + fs [check_input_time_def] >> + fs [panLangTheory.nested_seq_def] >> + rewrite_tac [Once evaluate_def] >> + pop_assum mp_tac >> + once_rewrite_tac [evaluate_def] >> + gs [] >> + pairarg_tac >> rveq >> gs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (_, nt)’ >> + ‘∃bytes. + read_bytearray ffiBufferAddr (w2n (ffiBufferSize:'a word)) + (mem_load_byte nt.memory nt.memaddrs nt.be) = SOME bytes’ by ( + match_mp_tac read_bytearray_some_bytes_for_ffi >> + gs [] >> + unabbrev_all_tac >> gs [mem_config_def]) >> + drule evaluate_ext_call >> + disch_then (qspecl_then [‘MAP explode (out_signals prog)’,‘bytes’] mp_tac) >> + gs [] >> + impl_tac + >- ( + unabbrev_all_tac >> gs [ffi_vars_def, FLOOKUP_UPDATE]) >> + strip_tac >> rveq >> gs [] >> + pop_assum kall_tac >> + unabbrev_all_tac >> gs [] >> + (* reading systime *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «sysTime» _, nt)’ >> + ‘nt.memory ffiBufferAddr = Word (n2w (FST(t.ffi.ffi_state 0)))’ by ( + fs [Abbr ‘nt’] >> + gs [mem_call_ffi_def] >> + qpat_x_assum ‘mem_read_ffi_results _ _ _’ assume_tac >> + gs [mem_read_ffi_results_def] >> + qmatch_asmsub_abbrev_tac ‘evaluate (ExtCall _ _ _ _ _, nt) = (_, ft)’ >> + first_x_assum (qspecl_then [‘nt’, ‘ft’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘ft’, Abbr ‘nt’, nexts_ffi_def, ETA_AX] >> metis_tac []) >> + strip_tac >> + gs [Abbr ‘ft’, nexts_ffi_def, init_ffi_def]) >> + drule evaluate_assign_load >> + gs [] >> + disch_then (qspecl_then + [‘ffiBufferAddr’, ‘0w’, + ‘n2w (FST (t.ffi.ffi_state 0))’] mp_tac) >> + impl_tac + >- (unabbrev_all_tac >> gs [FLOOKUP_UPDATE, mem_config_def]) >> + strip_tac >> unabbrev_all_tac >> rveq >> gs [] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + (* reading input to the variable event *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «event» _, nnt)’ >> + ‘nnt.memory (ffiBufferAddr + bytes_in_word) = + Word (n2w (SND(t.ffi.ffi_state 0)))’ by ( + fs [Abbr ‘nnt’] >> + qpat_x_assum ‘mem_read_ffi_results _ _ _’ assume_tac >> + gs [mem_read_ffi_results_def] >> + qmatch_asmsub_abbrev_tac ‘evaluate (ExtCall _ _ _ _ _, nt) = (_, ft)’ >> + last_x_assum (qspecl_then [‘nt’, ‘ft’] mp_tac) >> + impl_tac + >- (gs [Abbr ‘ft’, Abbr ‘nt’, nexts_ffi_def, ETA_AX] >> metis_tac []) >> + strip_tac >> + gs [Abbr ‘ft’, nexts_ffi_def, init_ffi_def]) >> + gs [] >> + drule evaluate_assign_load_next_address >> + gs [] >> + disch_then (qspecl_then + [‘ffiBufferAddr’, + ‘n2w (SND (t.ffi.ffi_state 0))’] mp_tac) >> + impl_tac + >- (unabbrev_all_tac >> gs [FLOOKUP_UPDATE, mem_config_def]) >> + strip_tac >> + unabbrev_all_tac >> + gs [] >> rveq >> gs [] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + (* isInput *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + drule evaluate_assign_compare_next_address >> + gs [] >> + disch_then (qspecl_then [‘ffiBufferAddr’] mp_tac) >> + impl_tac + >- ( + gs [FLOOKUP_UPDATE, mem_call_ffi_def] >> + qpat_x_assum ‘mem_read_ffi_results _ _ _’ assume_tac >> + gs [mem_read_ffi_results_def] >> + qmatch_asmsub_abbrev_tac ‘evaluate (ExtCall _ _ _ _ _, nt) = (_, ft)’ >> + first_x_assum (qspecl_then [‘nt’, ‘ft’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘ft’, Abbr ‘nt’, nexts_ffi_def, ETA_AX] >> metis_tac []) >> + strip_tac >> + gs [Abbr ‘ft’, nexts_ffi_def, init_ffi_def, mem_config_def]) >> + strip_tac >> rveq >> gs [] >> + pop_assum kall_tac >> + (* If statement *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + drule evaluate_if_compare_sys_time >> + disch_then (qspec_then ‘FST (t.ffi.ffi_state 0)’ mp_tac) >> + impl_tac + >- ( + unabbrev_all_tac >> + gs [FLOOKUP_UPDATE]) >> + strip_tac >> rveq >> gs [] >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + strip_tac >> fs [] >> + rveq >> gs [] >> + pairarg_tac >> rveq >> gs [] >> + gs [eval_def, FLOOKUP_UPDATE] >> + qmatch_asmsub_abbrev_tac ‘eval nt _’ >> + ‘FLOOKUP nt.locals «sysTime» = SOME (ValWord (n2w (FST (t.ffi.ffi_state 0))))’ by + gs [Abbr ‘nt’,FLOOKUP_UPDATE] >> + drule eval_mkClks >> + disch_then (qspec_then ‘nClks prog’ assume_tac) >> + fs [] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + fs [is_valid_value_def, FLOOKUP_UPDATE] >> + fs [panSemTheory.shape_of_def] >> + gs [replicate_shape_one] >> + unabbrev_all_tac >> rveq >> gs[] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + pairarg_tac >> rveq >> gs [] >> + pop_assum mp_tac >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + qmatch_goalsub_abbrev_tac ‘eval tt q’ >> + ‘eval tt q = + SOME (ValWord (n2w ( + case st.waitTime of + | NONE => FST (t.ffi.ffi_state 0) + | SOME n => FST (t.ffi.ffi_state 0) + n)))’ by ( + cases_on ‘st.waitTime’ >> + unabbrev_all_tac >> + gs [eval_def, FLOOKUP_UPDATE, OPT_MMAP_def, + wordLangTheory.word_op_def, word_add_n2w]) >> + gs [is_valid_value_def, FLOOKUP_UPDATE, shape_of_def] >> + strip_tac >> rveq >> gs [] >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> rveq >> gs [] >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + (* until always *) + gs [locals_before_start_ctrl_def] >> + strip_tac >> + gvs [empty_locals_def] >> + gs [ffi_call_ffi_def] >> + gvs [shape_of_def, set_var_def] >> + strip_tac >> gvs [] >> + strip_tac >> gvs [panLangTheory.size_of_shape_def] >> + qexists_tac ‘ns’ >> gvs []) >> + gs [semantics_def] >> + DEEP_INTRO_TAC some_intro >> simp[] >> + rw [] + >- ( + cases_on + ‘evaluate (TailCall (Label «start» ) [],t with clock := k')’ >> + gs [] >> + cases_on ‘q = SOME TimeOut’ >> + gs [] >> + pop_assum mp_tac >> + pop_assum mp_tac >> + pop_assum mp_tac >> + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> + gs [] >> + disch_then (qspec_then ‘k'’ assume_tac) >> + gs [] >> + strip_tac >> + strip_tac >> + strip_tac >> + strip_tac >> + drule evaluate_add_clock_eq >> + gs [] >> + disch_then (qspec_then ‘ck + t.clock’ assume_tac) >> + gs []) + >- ( + gs [] >> + first_x_assum (qspec_then ‘ck + t.clock’ assume_tac) >> gs [] >> + cases_on ‘r = SOME TimeOut’ >> + gs [] >> + pop_assum mp_tac >> + pop_assum mp_tac >> + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> + gs [] >> + disch_then (qspec_then ‘k’ assume_tac) >> + gs [] >> + strip_tac >> + strip_tac >> + strip_tac >> + drule evaluate_add_clock_eq >> + gs [] >> + disch_then (qspec_then ‘ck + t.clock’ assume_tac) >> + gs [] >> gvs [] >> + MAP_EVERY qexists_tac [‘io’, ‘ios’, ‘ns’] >> + gvs [state_component_equality]) + >- ( + cases_on + ‘evaluate (TailCall (Label «start» ) [],t with clock := k)’ >> + gs [] >> + cases_on ‘q = SOME TimeOut’ >> + gs [] >> + pop_assum mp_tac >> + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> + gs [] >> + disch_then (qspec_then ‘k’ assume_tac) >> + gs [] >> + strip_tac >> + strip_tac >> + drule evaluate_add_clock_eq >> + gs [] >> + disch_then (qspec_then ‘ck + t.clock’ assume_tac) >> + gs []) >> + gs [] >> + qexists_tac ‘ck + t.clock’ >> + gs [] +QED + +Theorem take_one_less_length_eq_front: + ∀xs . + xs ≠ [] ⇒ + TAKE (LENGTH xs − 1) xs = FRONT xs +Proof + Induct >> + rw [] >> + gs [FRONT_DEF] >> + cases_on ‘xs’ >> gvs [] +QED + + +Theorem from_take_sum_to_front: + ∀xs ns. + SUM ns + 1 = LENGTH xs ⇒ + TAKE (SUM ns) xs = FRONT xs +Proof + Induct >> + rw [] >> + gs [ADD1] >> + cases_on ‘ns’ >> gs [] >> + gs [TAKE_def] >> + cases_on ‘xs’ + >- gvs [] >> + qmatch_goalsub_abbrev_tac ‘LENGTH xs’ >> + ‘TAKE (LENGTH xs − 1) xs = FRONT xs’ by ( + match_mp_tac take_one_less_length_eq_front >> + unabbrev_all_tac >> gs []) >> + unabbrev_all_tac >> gs [] +QED + +Theorem timed_automata_no_panic_correct: + ∀prog labels st sts (t:('a,time_input) panSem$state). + steps prog labels + (dimword (:α) - 1) (FST (t.ffi.ffi_state 0)) st sts ∧ + no_panic labels ∧ + wf_prog_and_init_states prog st t ∧ + ffi_rels_after_init prog labels st t ∧ + sum_delays (:α) labels (next_ffi t.ffi.ffi_state) ⇒ + ∃io ios ns. + semantics t «start» = Terminate Success (io::ios) ∧ + LENGTH labels = LENGTH ns ∧ + SUM ns + 1 = LENGTH ios ∧ + decode_ios (:α) t.be labels ns (io::FRONT ios) +Proof + rw [] >> + drule_all timed_automata_no_panic_correct_main >> + strip_tac >> + gs [] >> + qexists_tac ‘ns’ >> gs [from_take_sum_to_front] +QED + + +Theorem timed_automata_no_panic_functional_correct: + ∀k prog or st sts labels (t:('a,time_input) panSem$state). + timeFunSem$eval_steps k prog + (dimword (:α) - 1) (FST (t.ffi.ffi_state 0)) + or st = SOME (labels, sts) ∧ + no_panic labels ∧ + wf_prog_and_init_states prog st t ∧ + ffi_rels_after_init prog labels st t ∧ + sum_delays (:α) labels (next_ffi t.ffi.ffi_state) ⇒ + ∃io ios ns. + semantics t «start» = Terminate Success (io::ios) ∧ + LENGTH labels = LENGTH ns ∧ + SUM ns + 1 = LENGTH ios ∧ + decode_ios (:α) t.be labels ns (io::FRONT ios) +Proof + rw [] >> + dxrule eval_steps_imp_steps >> + strip_tac >> + metis_tac [timed_automata_no_panic_correct] +QED + + +Theorem io_trace_impl_eval_steps: + ∀prog st (t:('a,time_input) panSem$state) or k. + wf_prog_init_states prog or k st t ∧ + ffi_rels_after_init prog + (labels_of k prog (dimword (:α) - 1) (systime_at t) or st) st t ∧ + no_panic (labels_of k prog (dimword (:α) - 1) (systime_at t) or st) ∧ + sum_delays (:α) (labels_of k prog (dimword (:α) - 1) (systime_at t) or st) + (next_ffi t.ffi.ffi_state) ⇒ + ∃lbls sts io ios ns. + timeFunSem$eval_steps k prog (dimword (:α) - 1) (systime_at t) or st = + SOME (lbls, sts) ∧ + semantics t «start» = Terminate Success (io::ios) ∧ + LENGTH lbls = LENGTH ns ∧ SUM ns + 1 = LENGTH ios ∧ + decode_ios (:α) t.be lbls ns (io::FRONT ios) +Proof + rw [] >> + gs [wf_prog_init_states_def, systime_at_def] >> + ‘∃lbls sts. + timeFunSem$eval_steps k prog (dimword (:α) − 1) + (FST (t.ffi.ffi_state 0)) or st = SOME (lbls,sts)’ by ( + gs [GSYM quantHeuristicsTheory.IS_SOME_EQ_NOT_NONE] >> + cases_on ‘(timeFunSem$eval_steps k prog (dimword (:α) − 1) + (FST (t.ffi.ffi_state 0)) or st)’ >> + gs [IS_SOME_DEF] >> + cases_on ‘x’ >> gs []) >> + gs [labels_of_def] >> + metis_tac [timed_automata_no_panic_functional_correct, + wf_prog_and_init_states_def] +QED + + +Definition has_panic_def: + has_panic lbls ⇔ + ∃lbl. + MEM lbl lbls ∧ + (lbl = LPanic (PanicTimeout) ∨ + (∃is. lbl = LPanic is)) +End + +Definition panic_at_def: + (panic_at [] = NONE) ∧ + (panic_at (lbl::lbls) = + case lbl of + | LPanic p => SOME p + | _ => panic_at lbls) +End + + +Definition until_panic_def: + (until_panic [] = []) ∧ + (until_panic (lbl::lbls) = + case lbl of + | LPanic p => [] + | _ => lbl::until_panic lbls) +End + +Definition uptil_panic_def: + (uptil_panic [] = []) ∧ + (uptil_panic (lbl::lbls) = + case lbl of + | LPanic p => [LPanic p] + | _ => lbl::uptil_panic lbls) +End + +Definition slice_labels_def: + (slice_labels [] = []) ∧ + (slice_labels (lbl::lbls) = + case lbl of + | LPanic p => + (case p of + | PanicTimeout => [] + | _ => [LPanic p]) + | _ => lbl::slice_labels lbls) +End + + +Definition sum_delays_until_panic_def: + sum_delays_until_panic (:α) lbls (ffi:time_input) ⇔ + SUM (MAP (λlbl. + case lbl of + | LDelay d => d + | _ => 0) lbls) + FST (ffi 0) < dimword (:α) − 2 +End + + +Theorem steps_io_event_uptil_panic_thm: + ∀labels prog n st sts (t:('a,time_input) panSem$state) ist. + steps prog labels (dimword (:α) - 1) n st sts ∧ + has_panic labels ∧ + assumptions prog n st t ∧ + ffi_rels prog (uptil_panic labels) st t ist ∧ + sum_delays_until_panic (:α) (until_panic labels) t.ffi.ffi_state ⇒ + ∃ck t' ns ios. + evaluate (time_to_pan$always (nClks prog), t with clock := t.clock + ck) = + (SOME (Exception «panic» (ValWord 0w)),t') ∧ + t'.ffi.io_events = t.ffi.io_events ++ ios ∧ + LENGTH (slice_labels labels) = LENGTH ns ∧ + SUM ns = LENGTH ios ∧ + t'.be = t.be ∧ + decode_ios (:α) t'.be (slice_labels labels) ns (LAST t.ffi.io_events::ios) +Proof + rw [] >> + gs [] >> + drule_all steps_thm >> + disch_then (qspec_then ‘ist’ mp_tac) >> + strip_tac >> + rpt (pop_assum mp_tac) >> + MAP_EVERY qid_spec_tac [‘ist’, ‘t’, ‘sts’, ‘st’, ‘n’, ‘prog’, ‘labels'’] >> + Induct + >- ( + rw [] >> + gs [has_panic_def]) >> + rw [] >> + ‘LENGTH sts = LENGTH (h::labels')’ by + metis_tac [steps_sts_length_eq_lbls] >> + cases_on ‘sts’ >> + fs [] >> + ‘n = FST (t.ffi.ffi_state 0)’ by + gs [assumptions_def] >> + rveq >> gs [] >> + gs [evaluations_def, steps_def] >> + cases_on ‘h’ >> gs [] + >- ( + gs [uptil_panic_def, ffi_rels_def, ffi_rel_def, slice_labels_def, panic_at_def] >> + first_x_assum drule >> + gs [] >> + strip_tac >> + last_x_assum drule >> + disch_then (qspecl_then [‘nt’, ‘ist’] mp_tac) >> + impl_tac + >- ( + conj_tac + >- (gvs [has_panic_def] >> metis_tac []) >> + gs [assumptions_def] >> + gs [nexts_ffi_def, delay_rep_def] >> + conj_tac + >- ( + first_x_assum match_mp_tac >> + metis_tac []) >> + gvs [until_panic_def, sum_delays_until_panic_def]) >> + strip_tac >> + first_x_assum (qspec_then ‘ck'’ assume_tac) >> + qexists_tac ‘ck + ck'’ >> gs [] >> + gs [delay_io_events_rel_def] >> + qexists_tac ‘cycles::ns’ >> + rewrite_tac [decode_ios_def] >> + gs [] >> + TOP_CASE_TAC + >- ( + gs [mk_ti_events_def, gen_ffi_states_def] >> + gs [delay_rep_def] >> + drule decode_ios_length_eq_sum >> + gs []) >> + conj_asm1_tac + >- gs [mk_ti_events_def, gen_ffi_states_def] >> + conj_asm1_tac + >- gs [TAKE_SUM] >> + qmatch_asmsub_abbrev_tac ‘decode_ios _ _ _ ns nios’ >> + qmatch_goalsub_abbrev_tac ‘decode_ios _ _ _ ns nios'’ >> + ‘nios = nios'’ by ( + gs [Abbr ‘nios’, Abbr ‘nios'’] >> + qmatch_goalsub_abbrev_tac ‘DROP _ (xs ++ _)’ >> + ‘cycles = LENGTH xs’ by + gs [Abbr ‘xs’, mk_ti_events_def, gen_ffi_states_def] >> + gs [TAKE_LENGTH_APPEND, DROP_LENGTH_APPEND] >> + gs [DROP_APPEND] >> + ‘LENGTH xs − 1 − LENGTH xs = 0’ by gs [] >> + simp [] >> + pop_assum kall_tac >> + ‘DROP (LENGTH xs − 1) xs = [LAST xs]’ by ( + match_mp_tac drop_length_eq_last >> + CCONTR_TAC >> + gvs []) >> + gs [] >> + ‘cycles = LENGTH xs’ by gvs [] >> + cases_on ‘xs’ >- gs [] >> + simp [LAST_APPEND_CONS] >> gvs [] >> + ‘LENGTH t'³' − SUC (LENGTH t'³') = 0’ by gs [] >> + simp [] >> + conj_asm1_tac + >- ( + gs [DROP_LENGTH_NIL, TAKE_LENGTH_APPEND, LAST_CONS_cond] >> + cases_on ‘t'''’ >> gvs []) >> + ‘SUC (LENGTH t'³') − (SUC (LENGTH t'³') + 1)= 0’ by gs [] >> + simp []) >> + qpat_x_assum ‘obs_ios_are_label_delay _ _ _’ mp_tac >> + gs [obs_ios_are_label_delay_def] >> + strip_tac >> + pop_assum mp_tac >> + impl_tac + >- ( + CCONTR_TAC >> + gs [DROP_LENGTH_APPEND, mk_ti_events_def, gen_ffi_states_def, decode_io_events_def] >> + gs [ZIP_EQ_NIL]) >> + strip_tac >> + gs [] >> + qmatch_goalsub_abbrev_tac ‘TAKE _ (xs ++ _)’ >> + ‘TAKE cycles (xs ++ ios) = + xs’ by ( + ‘cycles = LENGTH xs’ by + gs [Abbr ‘xs’, mk_ti_events_def, gen_ffi_states_def] >> + simp [] >> + gs [TAKE_LENGTH_APPEND]) >> + gs [Abbr ‘xs’, DROP_LENGTH_APPEND]) + >- ( + cases_on ‘i’ + >- ( + gs [uptil_panic_def, ffi_rels_def, ffi_rel_def, action_rel_def, slice_labels_def, panic_at_def] >> + first_x_assum drule >> + disch_then (qspec_then ‘nt’ mp_tac) >> + impl_tac >- gs [] >> + strip_tac >> + last_x_assum drule >> + disch_then (qspecl_then [‘nt’, ‘ist’] mp_tac) >> + impl_tac + >- ( + conj_tac + >- (gvs [has_panic_def] >> metis_tac []) >> + gvs [assumptions_def] >> + gs [nexts_ffi_def, input_rel_def] >> + qpat_x_assum ‘state_rel _ _ _ t’ assume_tac >> + gs [state_rel_def] >> + pairarg_tac >> gs [] >> + gs [input_time_rel_def] >> + gs [input_time_eq_def, has_input_def] >> + first_x_assum (qspec_then ‘0’ mp_tac) >> + impl_tac + >- ( + gs [] >> + gs [input_rel_def, next_ffi_def]) >> + gs [next_ffi_def] >> + strip_tac >> + gvs [until_panic_def, sum_delays_until_panic_def]) >> + strip_tac >> + first_x_assum (qspec_then ‘ck'’ assume_tac) >> + qexists_tac ‘ck + ck'’ >> gs [] >> + gs [input_io_events_rel_def] >> + qexists_tac ‘1::ns’ >> + rewrite_tac [decode_ios_def] >> + gs [] >> + gs [to_input_def, DROP_LENGTH_APPEND, decode_io_events_def] >> + ‘LENGTH ios − 1 = SUM ns’ by gs [] >> + simp []) >> + gs [uptil_panic_def, ffi_rels_def, ffi_rel_def, action_rel_def, slice_labels_def, panic_at_def] >> + first_x_assum drule >> + disch_then (qspec_then ‘nt’ mp_tac) >> + impl_tac >- gs [] >> + strip_tac >> + last_x_assum drule >> + disch_then (qspecl_then [‘nt’, ‘ist’] mp_tac) >> + impl_tac + >- ( + conj_tac + >- (gvs [has_panic_def] >> metis_tac []) >> + gs [assumptions_def] >> + gvs [until_panic_def, sum_delays_until_panic_def]) >> + strip_tac >> + first_x_assum (qspec_then ‘ck'’ assume_tac) >> + qexists_tac ‘ck + ck'’ >> gs [] >> + gs [output_io_events_rel_def] >> + qexists_tac ‘1::ns’ >> + rewrite_tac [decode_ios_def] >> + gs [to_input_def, DROP_LENGTH_APPEND, decode_io_events_def] >> + ‘LENGTH ios − 1 = SUM ns’ by gs [] >> + simp []) >> + cases_on ‘p’ >> gvs [] + >- ( + gvs [slice_labels_def, until_panic_def, panic_at_def, + sum_delays_until_panic_def, uptil_panic_def] >> + pop_assum mp_tac >> + pop_assum mp_tac >> + impl_tac + >- gvs [ffi_rels_def, ffi_rel_def, panic_rel_def] >> + strip_tac >> gvs [] >> + strip_tac >> + first_x_assum (qspec_then ‘0’ assume_tac) >> + qexists_tac ‘ck’ >> + qexists_tac ‘nt’ >> + gs [state_component_equality, ffiTheory.ffi_state_component_equality] >> + (* cases_on ‘t.ffi.io_events’ >> *) + gvs [decode_ios_def]) >> + gvs [slice_labels_def, until_panic_def, panic_at_def, + sum_delays_until_panic_def, uptil_panic_def] >> + pop_assum mp_tac >> + pop_assum mp_tac >> + impl_tac + >- gvs [ffi_rels_def, ffi_rel_def, panic_rel_def] >> + strip_tac >> gvs [] >> + strip_tac >> + first_x_assum (qspec_then ‘0’ assume_tac) >> + qexists_tac ‘ck’ >> + qexists_tac ‘nt’ >> + gs [state_component_equality, ffiTheory.ffi_state_component_equality] >> + gvs [input_io_events_rel_def] >> + qexists_tac ‘[1]’ >> + gvs [] >> + rewrite_tac [decode_ios_def] >> + gs [] >> + gs [to_input_def, DROP_LENGTH_APPEND, decode_io_events_def] +QED + +Theorem timed_automata_until_panic_correct: + ∀prog labels st sts (t:('a,time_input) panSem$state). + steps prog labels + (dimword (:α) - 1) (FST (t.ffi.ffi_state 0)) st sts ∧ + has_panic labels ∧ + wf_prog_and_init_states prog st t ∧ + ffi_rels_after_init prog (uptil_panic labels) st t ∧ + sum_delays_until_panic (:α) (until_panic labels) (next_ffi t.ffi.ffi_state) ⇒ + ∃io ios ns. + semantics t «start» = Terminate Success (io::ios) ∧ + LENGTH (slice_labels labels) = LENGTH ns ∧ + SUM ns = LENGTH ios ∧ + decode_ios (:α) t.be (slice_labels labels) ns (io::ios) +Proof + rw [wf_prog_and_init_states_def] >> + ‘∃ck t' io ios ns. + evaluate + (TailCall (Label «start» ) [],t with clock := t.clock + ck) = + (SOME (Return (ValWord 1w)),t') ∧ + t'.ffi.io_events = t.ffi.io_events ++ io::ios ∧ + LENGTH (slice_labels labels') = LENGTH ns ∧ + SUM ns = LENGTH ios ∧ + decode_ios (:α) t.be (slice_labels labels') ns (io::ios)’ by ( + ‘∃bytes. + read_bytearray ffiBufferAddr (w2n (ffiBufferSize:'a word)) + (mem_load_byte t.memory t.memaddrs t.be) = SOME bytes’ by ( + match_mp_tac read_bytearray_some_bytes_for_ffi >> + gs [] >> + gs [mem_config_def]) >> + qabbrev_tac + ‘nt = + t with + <|locals := locals_before_start_ctrl prog st.waitTime (t.ffi.ffi_state 0); + memory := mem_call_ffi (:α) t.memory t.memaddrs t.be t.ffi.ffi_state; + clock := t.clock; ffi := ffi_call_ffi (:α) t.be t.ffi bytes|>’ >> + ‘∃ck t' ns ios. + evaluate (always (nClks prog),nt with clock := nt.clock + ck) = + (SOME (Exception «panic» (ValWord 0w)),t') ∧ + t'.ffi.io_events = nt.ffi.io_events ++ ios ∧ + LENGTH (slice_labels labels') = LENGTH ns ∧ + SUM ns = LENGTH ios ∧ + (t'.be ⇔ nt.be) ∧ + decode_ios (:α) t'.be (slice_labels labels') ns (LAST nt.ffi.io_events::ios)’ by ( + match_mp_tac steps_io_event_uptil_panic_thm >> + MAP_EVERY qexists_tac [‘FST (t.ffi.ffi_state 0)’, ‘st’, ‘sts’, + ‘(FST (t.ffi.ffi_state 0))’] >> + gs [] >> + conj_tac + >- ( + unabbrev_all_tac >> + gs [assumptions_def, locals_before_start_ctrl_def] >> rveq >> + conj_tac + (* state_rel *) + >- ( + gs [state_rel_def] >> + pairarg_tac >> gs [] >> + gs [FLOOKUP_UPDATE, ffi_call_ffi_def, next_ffi_def, init_ffi_def, + ffi_vars_def, time_vars_def] >> + conj_tac + >- ( + gs [equivs_def, FLOOKUP_UPDATE] >> + cases_on ‘st.waitTime’ >> gs [active_low_def]) >> + conj_tac + >- ( + gs [mem_call_ffi_def, mem_config_def] >> + conj_tac >> ( + fs [ffiBufferAddr_def] >> + match_mp_tac write_bytearray_update_byte >> + gs [good_dimindex_def] >> + gs [byte_align_def, byte_aligned_def, align_def, aligned_def, bytes_in_word_def] >> + gs [dimword_def] >> + EVAL_TAC >> + rveq >> gs [] >> + EVAL_TAC)) >> + conj_tac + >- ( + gs [defined_clocks_def, init_clocks_def] >> + gs [EVERY_MEM]) >> + conj_tac + >- gs [build_ffi_def, ffiTheory.ffi_state_component_equality] >> + conj_tac + >- ( + gs [input_time_rel_def] >> + rw [] >> + last_x_assum (qspec_then ‘n + 1’ mp_tac) >> + gs []) >> + conj_tac + >- ( + gs [time_seq_def] >> + rw [] >> + gs [] >> + cases_on ‘n’ >> gs [] + >- ( + first_x_assum (qspec_then ‘1’ mp_tac) >> + gs []) >> + first_x_assum (qspec_then ‘SUC (SUC n')’ mp_tac) >> + gs [ADD1]) >> + gs [clocks_rel_def, FLOOKUP_UPDATE] >> + qexists_tac ‘REPLICATE (nClks prog) tm’ >> + gs [map_replicate, timeLangTheory.nClks_def] >> + gs [clkvals_rel_def, EVERY_MEM, init_clocks_def] >> + gs [GSYM MAP_K_REPLICATE] >> + gs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + qmatch_goalsub_abbrev_tac ‘EL _ (ZIP (xs,ys))’ >> + ‘EL n (ZIP (xs,ys)) = (EL n xs, EL n ys)’ by ( + match_mp_tac EL_ZIP >> + unabbrev_all_tac >> + gs []) >> + unabbrev_all_tac >> + gs [] >> + gs [MEM_EL] >> + last_x_assum (qspec_then ‘EL n (clksOf prog)’ mp_tac) >> + impl_tac >- metis_tac [] >> + strip_tac >> + gs [EL_MAP]) >> + gs [init_ffi_def, ffi_call_ffi_def, next_ffi_def] >> + (* event_inv *) + conj_tac + >- gs [event_inv_def, FLOOKUP_UPDATE] >> + gs [task_ret_defined_def] >> + gs [FLOOKUP_UPDATE, emptyVals_def]) >> + unabbrev_all_tac >> + gs [ffi_rels_after_init_def] >> + qmatch_asmsub_abbrev_tac ‘ffi_rels _ _ _ tt'’ >> + qmatch_goalsub_abbrev_tac ‘ffi_rels _ _ _ tt’ >> + ‘tt' = tt’ by ( + unabbrev_all_tac >> + gs [state_component_equality]) >> + gs [ffi_call_ffi_def]) >> + qexists_tac ‘ck + 2’ >> + rw [] >> + once_rewrite_tac [evaluate_def] >> + gs [] >> + gs [eval_def, OPT_MMAP_def, lookup_code_def, dec_clock_def, FUPDATE_LIST] >> + + fs [ta_controller_def, panLangTheory.decs_def] >> + once_rewrite_tac [evaluate_def] >> + gs [eval_def] >> + once_rewrite_tac [evaluate_def] >> + gs [eval_def] >> + pairarg_tac >> gvs [] >> + pairarg_tac >> gvs [] >> + pop_assum mp_tac >> + gs [panLangTheory.nested_seq_def] >> + once_rewrite_tac [evaluate_def] >> + gs [] >> + pairarg_tac >> gvs [] >> + pop_assum mp_tac >> + once_rewrite_tac [evaluate_def] >> + gvs [eval_def] >> + gs [eval_def, OPT_MMAP_def, lookup_code_def, dec_clock_def, FUPDATE_LIST] >> + qpat_x_assum ‘FLOOKUP t.code _ = _’ kall_tac >> + qpat_x_assum ‘FLOOKUP t.code _ = _’ kall_tac >> + (* start contoller *) + fs [start_controller_def, panLangTheory.decs_def] >> + once_rewrite_tac [evaluate_def] >> + gs [eval_def] >> + ‘∃v1. FLOOKUP t.code (num_to_str (FST (ohd prog))) = SOME v1’ by ( + cases_on ‘prog’ >> + gs [ohd_def, code_installed_def] >> + cases_on ‘h’ >> gs [] >> metis_tac []) >> + gs [] >> + pairarg_tac >> gs [] >> + pop_assum mp_tac >> + once_rewrite_tac [evaluate_def] >> + qmatch_goalsub_abbrev_tac ‘eval tt q’ >> + ‘eval tt q = + SOME (ValWord ( + case st.waitTime of + | NONE => 1w + | SOME _ => (0w:'a word)))’ by ( + unabbrev_all_tac >> gs [] >> + TOP_CASE_TAC >> gs [eval_def]) >> + unabbrev_all_tac >> gs [] >> + gs [] >> + pairarg_tac >> gs [] >> + gs [evaluate_def, eval_def] >> + rpt (pairarg_tac >> gs []) >> + strip_tac >> rveq >> gs [] >> + qmatch_asmsub_abbrev_tac ‘eval tt _’ >> + ‘t.code = tt.code’ by ( + unabbrev_all_tac >> gs []) >> + fs [] >> + drule opt_mmap_empty_const >> + disch_then (qspec_then ‘nClks prog’ assume_tac) >> + gs [] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + pairarg_tac >> + unabbrev_all_tac >> gs [] >> + rveq >> gs [] >> + qmatch_asmsub_abbrev_tac ‘eval tt _’ >> + gs [eval_empty_const_eq_empty_vals] >> + pairarg_tac >> + unabbrev_all_tac >> gs [] >> + rveq >> gs [] >> + gs [FLOOKUP_UPDATE] >> + (* Decs are completed *) + gs [panLangTheory.nested_seq_def] >> + pop_assum mp_tac >> + once_rewrite_tac [evaluate_def] >> + gs [] >> + pairarg_tac >> rveq >> gs [] >> + fs [check_input_time_def] >> + fs [panLangTheory.nested_seq_def] >> + rewrite_tac [Once evaluate_def] >> + pop_assum mp_tac >> + once_rewrite_tac [evaluate_def] >> + gs [] >> + pairarg_tac >> rveq >> gs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (_, nt)’ >> + ‘∃bytes. + read_bytearray ffiBufferAddr (w2n (ffiBufferSize:'a word)) + (mem_load_byte nt.memory nt.memaddrs nt.be) = SOME bytes’ by ( + match_mp_tac read_bytearray_some_bytes_for_ffi >> + gs [] >> + unabbrev_all_tac >> gs [mem_config_def]) >> + drule evaluate_ext_call >> + disch_then (qspecl_then [‘MAP explode (out_signals prog)’,‘bytes’] mp_tac) >> + gs [] >> + impl_tac + >- ( + unabbrev_all_tac >> gs [ffi_vars_def, FLOOKUP_UPDATE]) >> + strip_tac >> rveq >> gs [] >> + pop_assum kall_tac >> + unabbrev_all_tac >> gs [] >> + (* reading systime *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «sysTime» _, nt)’ >> + ‘nt.memory ffiBufferAddr = Word (n2w (FST(t.ffi.ffi_state 0)))’ by ( + fs [Abbr ‘nt’] >> + gs [mem_call_ffi_def] >> + qpat_x_assum ‘mem_read_ffi_results _ _ _’ assume_tac >> + gs [mem_read_ffi_results_def] >> + qmatch_asmsub_abbrev_tac ‘evaluate (ExtCall _ _ _ _ _, nt) = (_, ft)’ >> + first_x_assum (qspecl_then [‘nt’, ‘ft’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘ft’, Abbr ‘nt’, nexts_ffi_def, ETA_AX] >> metis_tac []) >> + strip_tac >> + gs [Abbr ‘ft’, nexts_ffi_def, init_ffi_def]) >> + drule evaluate_assign_load >> + gs [] >> + disch_then (qspecl_then + [‘ffiBufferAddr’, ‘0w’, + ‘n2w (FST (t.ffi.ffi_state 0))’] mp_tac) >> + impl_tac + >- (unabbrev_all_tac >> gs [FLOOKUP_UPDATE, mem_config_def]) >> + strip_tac >> unabbrev_all_tac >> rveq >> gs [] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + (* reading input to the variable event *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + qmatch_asmsub_abbrev_tac ‘evaluate (Assign «event» _, nnt)’ >> + ‘nnt.memory (ffiBufferAddr + bytes_in_word) = + Word (n2w (SND(t.ffi.ffi_state 0)))’ by ( + fs [Abbr ‘nnt’] >> + qpat_x_assum ‘mem_read_ffi_results _ _ _’ assume_tac >> + gs [mem_read_ffi_results_def] >> + qmatch_asmsub_abbrev_tac ‘evaluate (ExtCall _ _ _ _ _, nt) = (_, ft)’ >> + last_x_assum (qspecl_then [‘nt’, ‘ft’] mp_tac) >> + impl_tac + >- (gs [Abbr ‘ft’, Abbr ‘nt’, nexts_ffi_def, ETA_AX] >> metis_tac []) >> + strip_tac >> + gs [Abbr ‘ft’, nexts_ffi_def, init_ffi_def]) >> + gs [] >> + drule evaluate_assign_load_next_address >> + gs [] >> + disch_then (qspecl_then + [‘ffiBufferAddr’, + ‘n2w (SND (t.ffi.ffi_state 0))’] mp_tac) >> + impl_tac + >- (unabbrev_all_tac >> gs [FLOOKUP_UPDATE, mem_config_def]) >> + strip_tac >> + unabbrev_all_tac >> + gs [] >> rveq >> gs [] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + (* isInput *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + drule evaluate_assign_compare_next_address >> + gs [] >> + disch_then (qspecl_then [‘ffiBufferAddr’] mp_tac) >> + impl_tac + >- ( + gs [FLOOKUP_UPDATE, mem_call_ffi_def] >> + qpat_x_assum ‘mem_read_ffi_results _ _ _’ assume_tac >> + gs [mem_read_ffi_results_def] >> + qmatch_asmsub_abbrev_tac ‘evaluate (ExtCall _ _ _ _ _, nt) = (_, ft)’ >> + first_x_assum (qspecl_then [‘nt’, ‘ft’] mp_tac) >> + impl_tac + >- ( + gs [Abbr ‘ft’, Abbr ‘nt’, nexts_ffi_def, ETA_AX] >> metis_tac []) >> + strip_tac >> + gs [Abbr ‘ft’, nexts_ffi_def, init_ffi_def, mem_config_def]) >> + strip_tac >> rveq >> gs [] >> + pop_assum kall_tac >> + (* If statement *) + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> fs [] >> + drule evaluate_if_compare_sys_time >> + disch_then (qspec_then ‘FST (t.ffi.ffi_state 0)’ mp_tac) >> + impl_tac + >- ( + unabbrev_all_tac >> + gs [FLOOKUP_UPDATE]) >> + strip_tac >> rveq >> gs [] >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + strip_tac >> fs [] >> + rveq >> gs [] >> + pairarg_tac >> rveq >> gs [] >> + gs [eval_def, FLOOKUP_UPDATE] >> + qmatch_asmsub_abbrev_tac ‘eval nt _’ >> + ‘FLOOKUP nt.locals «sysTime» = SOME (ValWord (n2w (FST (t.ffi.ffi_state 0))))’ by + gs [Abbr ‘nt’,FLOOKUP_UPDATE] >> + drule eval_mkClks >> + disch_then (qspec_then ‘nClks prog’ assume_tac) >> + fs [] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + fs [is_valid_value_def, FLOOKUP_UPDATE] >> + fs [panSemTheory.shape_of_def] >> + gs [replicate_shape_one] >> + unabbrev_all_tac >> rveq >> gs[] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + pairarg_tac >> rveq >> gs [] >> + pop_assum mp_tac >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + qmatch_goalsub_abbrev_tac ‘eval tt q’ >> + ‘eval tt q = + SOME (ValWord (n2w ( + case st.waitTime of + | NONE => FST (t.ffi.ffi_state 0) + | SOME n => FST (t.ffi.ffi_state 0) + n)))’ by ( + cases_on ‘st.waitTime’ >> + unabbrev_all_tac >> + gs [eval_def, FLOOKUP_UPDATE, OPT_MMAP_def, + wordLangTheory.word_op_def, word_add_n2w]) >> + gs [is_valid_value_def, FLOOKUP_UPDATE, shape_of_def] >> + strip_tac >> rveq >> gs [] >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + pairarg_tac >> rveq >> gs [] >> + rewrite_tac [Once evaluate_def] >> + fs [] >> + (* until always *) + gs [locals_before_start_ctrl_def] >> + strip_tac >> + gvs [empty_locals_def] >> + gs [ffi_call_ffi_def] >> + gvs [shape_of_def, set_var_def] >> + strip_tac >> gvs [] >> + strip_tac >> gvs [panLangTheory.size_of_shape_def] >> + qexists_tac ‘ns’ >> gvs []) >> + gs [semantics_def] >> + DEEP_INTRO_TAC some_intro >> simp[] >> + rw [] + >- ( + cases_on + ‘evaluate (TailCall (Label «start» ) [],t with clock := k')’ >> + gs [] >> + cases_on ‘q = SOME TimeOut’ >> + gs [] >> + pop_assum mp_tac >> + pop_assum mp_tac >> + pop_assum mp_tac >> + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> + gs [] >> + disch_then (qspec_then ‘k'’ assume_tac) >> + gs [] >> + strip_tac >> + strip_tac >> + strip_tac >> + strip_tac >> + drule evaluate_add_clock_eq >> + gs [] >> + disch_then (qspec_then ‘ck + t.clock’ assume_tac) >> + gs []) + >- ( + gs [] >> + first_x_assum (qspec_then ‘ck + t.clock’ assume_tac) >> gs [] >> + cases_on ‘r = SOME TimeOut’ >> + gs [] >> + pop_assum mp_tac >> + pop_assum mp_tac >> + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> + gs [] >> + disch_then (qspec_then ‘k’ assume_tac) >> + gs [] >> + strip_tac >> + strip_tac >> + strip_tac >> + drule evaluate_add_clock_eq >> + gs [] >> + disch_then (qspec_then ‘ck + t.clock’ assume_tac) >> + gs [] >> gvs [] >> + MAP_EVERY qexists_tac [‘io’, ‘ios’, ‘ns’] >> + gvs [state_component_equality]) + >- ( + cases_on + ‘evaluate (TailCall (Label «start» ) [],t with clock := k)’ >> + gs [] >> + cases_on ‘q = SOME TimeOut’ >> + gs [] >> + pop_assum mp_tac >> + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> + gs [] >> + disch_then (qspec_then ‘k’ assume_tac) >> + gs [] >> + strip_tac >> + strip_tac >> + drule evaluate_add_clock_eq >> + gs [] >> + disch_then (qspec_then ‘ck + t.clock’ assume_tac) >> + gs []) >> + gs [] >> + qexists_tac ‘ck + t.clock’ >> + gs [] +QED + +Theorem timed_automata_until_panic_functional_correct: + ∀k prog or st sts labels (t:('a,time_input) panSem$state). + timeFunSem$eval_steps k prog + (dimword (:α) - 1) (FST (t.ffi.ffi_state 0)) + or st = SOME (labels, sts) ∧ + has_panic labels ∧ + wf_prog_and_init_states prog st t ∧ + ffi_rels_after_init prog (uptil_panic labels) st t ∧ + sum_delays_until_panic (:α) (until_panic labels) (next_ffi t.ffi.ffi_state) ⇒ + ∃io ios ns. + semantics t «start» = Terminate Success (io::ios) ∧ + LENGTH (slice_labels labels) = LENGTH ns ∧ + SUM ns = LENGTH ios ∧ + decode_ios (:α) t.be (slice_labels labels) ns (io::ios) +Proof + rw [] >> + dxrule eval_steps_imp_steps >> + strip_tac >> + metis_tac [timed_automata_until_panic_correct] +QED + + +Theorem io_trace_impl_eval_steps_uptil_panic: + ∀prog st (t:('a,time_input) panSem$state) or k. + wf_prog_init_states prog or k st t ∧ + ffi_rels_after_init prog + (uptil_panic (labels_of k prog (dimword (:α) - 1) (systime_at t) or st)) + st t ∧ + has_panic (labels_of k prog (dimword (:α) - 1) (systime_at t) or st) ∧ + sum_delays_until_panic (:α) + (until_panic (labels_of k prog (dimword (:α) - 1) (systime_at t) or st)) + (next_ffi t.ffi.ffi_state) ⇒ + ∃lbls sts io ios ns. + timeFunSem$eval_steps k prog (dimword (:α) - 1) (systime_at t) or st = + SOME (lbls, sts) ∧ + semantics t «start» = Terminate Success (io::ios) ∧ + LENGTH (slice_labels lbls) = LENGTH ns ∧ + SUM ns = LENGTH ios ∧ + decode_ios (:α) t.be (slice_labels lbls) ns (io::ios) +Proof + rw [] >> + gs [wf_prog_init_states_def, systime_at_def] >> + ‘∃lbls sts. + timeFunSem$eval_steps k prog (dimword (:α) − 1) + (FST (t.ffi.ffi_state 0)) or st = SOME (lbls,sts)’ by ( + gs [GSYM quantHeuristicsTheory.IS_SOME_EQ_NOT_NONE] >> + cases_on ‘(timeFunSem$eval_steps k prog (dimword (:α) − 1) + (FST (t.ffi.ffi_state 0)) or st)’ >> + gs [IS_SOME_DEF] >> + cases_on ‘x’ >> gs []) >> + gs [labels_of_def] >> + metis_tac [timed_automata_until_panic_functional_correct, + wf_prog_and_init_states_def] +QED + +Definition labels_and_ffi_assumptions_def: + labels_and_ffi_assumptions (:α) prog lbls st t ⇔ + (no_panic lbls ∧ + sum_delays (:α) lbls (next_ffi t.ffi.ffi_state) ∧ + ffi_rels_after_init prog lbls st t) ∨ + (has_panic lbls ∧ + ffi_rels_after_init prog (uptil_panic lbls) st t ∧ + sum_delays_until_panic (:α) (until_panic lbls) (next_ffi t.ffi.ffi_state)) +End + +Theorem no_panic_imp_not_has_panic: + ∀lbls. + no_panic lbls ⇒ ~has_panic lbls +Proof + Induct >> + rw [no_panic_def, has_panic_def] >> + metis_tac [] +QED + +Theorem has_panic_imp_not_no_panic: + ∀lbls. + has_panic lbls ⇒ ~no_panic lbls +Proof + Induct >> + rw [no_panic_def, has_panic_def] >> + metis_tac [timed_automata_until_panic_functional_correct] +QED + + +Theorem steps_impl_io_trace: + ∀k prog or st sts labels (t:('a,time_input) panSem$state). + timeFunSem$eval_steps k prog + (dimword (:α) - 1) (FST (t.ffi.ffi_state 0)) + or st = SOME (labels, sts) ∧ + labels_and_ffi_assumptions (:α) prog labels st t ∧ + wf_prog_and_init_states prog st t ⇒ + ∃io ios ns. + semantics t «start» = Terminate Success (io::ios) ∧ + (no_panic labels ⇒ + LENGTH labels = LENGTH ns ∧ + SUM ns + 1 = LENGTH ios ∧ + decode_ios (:α) t.be labels ns (io::FRONT ios)) ∧ + (has_panic labels ⇒ + LENGTH (slice_labels labels) = LENGTH ns ∧ + SUM ns = LENGTH ios ∧ + decode_ios (:α) t.be (slice_labels labels) ns (io::ios)) +Proof + rw [] >> + gs [labels_and_ffi_assumptions_def, + no_panic_imp_not_has_panic, has_panic_imp_not_no_panic] >> + metis_tac [timed_automata_no_panic_functional_correct, + timed_automata_until_panic_functional_correct] +QED + +Definition io_events_and_ffi_assumptions_def: + io_events_and_ffi_assumptions (:α) k prog or st t ⇔ + (ffi_rels_after_init prog + (labels_of k prog (dimword (:α) - 1) (systime_at t) or st) st t ∧ + no_panic (labels_of k prog (dimword (:α) - 1) (systime_at t) or st) ∧ + sum_delays (:α) (labels_of k prog (dimword (:α) - 1) (systime_at t) or st) + (next_ffi t.ffi.ffi_state)) ∨ + (ffi_rels_after_init prog + (uptil_panic (labels_of k prog (dimword (:α) - 1) (systime_at t) or st)) + st t ∧ + has_panic (labels_of k prog (dimword (:α) - 1) (systime_at t) or st) ∧ + sum_delays_until_panic (:α) + (until_panic (labels_of k prog (dimword (:α) - 1) (systime_at t) or st)) + (next_ffi t.ffi.ffi_state)) +End + + +Theorem io_trace_impl_steps: + ∀prog st (t:('a,time_input) panSem$state) or k. + wf_prog_init_states prog or k st t ∧ + io_events_and_ffi_assumptions (:α) k prog or st t ⇒ + ∃lbls sts io ios ns. + timeFunSem$eval_steps k prog (dimword (:α) - 1) (systime_at t) or st = + SOME (lbls, sts) ∧ + semantics t «start» = Terminate Success (io::ios) ∧ + (no_panic (labels_of k prog (dimword (:α) - 1) (systime_at t) or st) ⇒ + LENGTH lbls = LENGTH ns ∧ SUM ns + 1 = LENGTH ios ∧ + decode_ios (:α) t.be lbls ns (io::FRONT ios)) ∧ + (has_panic (labels_of k prog (dimword (:α) - 1) (systime_at t) or st) ⇒ + LENGTH (slice_labels lbls) = LENGTH ns ∧ + SUM ns = LENGTH ios ∧ + decode_ios (:α) t.be (slice_labels lbls) ns (io::ios)) +Proof + rw [] >> + gs [io_events_and_ffi_assumptions_def, + no_panic_imp_not_has_panic, has_panic_imp_not_no_panic] >> + metis_tac [io_trace_impl_eval_steps, + io_trace_impl_eval_steps_uptil_panic] +QED + +(* +Definition ndecode_ios_def: + (ndecode_ios (:α) _ [] _ ios ⇔ LENGTH ios = 0) ∧ + (ndecode_ios (:α) be (lbl::lbls) e (io::ios) ⇔ + case lbl of + | LDelay d => + (if d = 0 then + ndecode_ios (:α) be lbls e (io::ios) + else + let + m' = EL 0 (io_event_dest (:α) be e); + obs_ios = decode_io_events (:'a) be io; + m = THE (to_delay (EL (LENGTH obs_ios - 1) obs_ios)) + in + d = m - m' ∧ + ndecode_ios (:α) be lbls (LAST io) ios) + | LAction act => + (ndecode_ios (:α) be lbls (LAST io) ios ∧ + (case act of + | Input i => + let + obs_io = decode_io_event (:α) be (EL 0 io) + in + Input i = THE (to_input obs_io) + | Output os => + decode_io_event (:α) be (EL 0 io) = ObsOutput os)) + | LPanic p => + case p of + | PanicInput i => + let + obs_io = decode_io_event (:α) be (EL 0 io) + in + Input i = THE (to_input obs_io) + | _ => F) ∧ + (ndecode_ios (:α) _ _ _ _ ⇔ F) +End +*) + +val _ = export_theory(); diff --git a/pancake/readmePrefix b/pancake/readmePrefix new file mode 100644 index 0000000000..e2cd44c833 --- /dev/null +++ b/pancake/readmePrefix @@ -0,0 +1 @@ +Abstract syntax and compiler for Pancake and its intermediate languages. \ No newline at end of file diff --git a/pancake/semantics/Holmakefile b/pancake/semantics/Holmakefile new file mode 100644 index 0000000000..5ee11b1d9e --- /dev/null +++ b/pancake/semantics/Holmakefile @@ -0,0 +1,14 @@ +INCLUDES = $(CAKEMLDIR)/misc\ + $(CAKEMLDIR)/pancake\ + $(CAKEMLDIR)/misc/\ + $(CAKEMLDIR)/compiler/backend/semantics\ + $(CAKEMLDIR)/compiler/encoders/asm\ + $(CAKEMLDIR)/semantics/ffi + +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) diff --git a/pancake/semantics/README.md b/pancake/semantics/README.md new file mode 100644 index 0000000000..a0465a1a3f --- /dev/null +++ b/pancake/semantics/README.md @@ -0,0 +1,37 @@ +Semantics for Pancake and its intermediate languages. + +[compactDSLSemScript.sml](compactDSLSemScript.sml): +semantics for timeLang + +[crepPropsScript.sml](crepPropsScript.sml): +crepLang Properties + +[crepSemScript.sml](crepSemScript.sml): +Semantics of crepLang + +[extra-files](extra-files): +Semantics for Pancake Language. + +[loopPropsScript.sml](loopPropsScript.sml): +Properties of loopLang and loopSem + +[loopSemScript.sml](loopSemScript.sml): +The formal semantics of loopLang + +[panPropsScript.sml](panPropsScript.sml): +panLang Properties + +[panSemScript.sml](panSemScript.sml): +Semantics of panLang + +[pan_commonPropsScript.sml](pan_commonPropsScript.sml): +Common Properties for Pancake ILS + +[timeFunSemScript.sml](timeFunSemScript.sml): +semantics for timeLang + +[timePropsScript.sml](timePropsScript.sml): +semantics for timeLang + +[timeSemScript.sml](timeSemScript.sml): +semantics for timeLang diff --git a/pancake/semantics/compactDSLSemScript.sml b/pancake/semantics/compactDSLSemScript.sml new file mode 100644 index 0000000000..d0ea65f292 --- /dev/null +++ b/pancake/semantics/compactDSLSemScript.sml @@ -0,0 +1,260 @@ +(* + semantics for timeLang +*) + +open preamble + timeLangTheory + +val _ = new_theory "compactDSLSem"; + + +Datatype: + label = LDelay time + | LAction ioAction +End + +Datatype: + state = + <| clocks : clock |-> time + ; location : loc + ; ioAction : ioAction option + ; waitTime : time option + |> +End + + +Definition mkState_def: + mkState cks loc io wt = + <| clocks := cks + ; location := loc + ; ioAction := io + ; waitTime := wt + |> +End + +Definition resetOutput_def: + resetOutput st = + st with + <| ioAction := NONE + ; waitTime := NONE + |> +End + +Definition resetClocks_def: + resetClocks fm xs = + fm |++ ZIP (xs,MAP (λx. 0:time) xs) +End + + +(* +Definition resetClocks_def: + resetClocks clks cvars_vals = + clks |++ MAP (λx. (x,0:time)) cvars_vals +End +*) + + +(* +Definition resetClocks_def: + resetClocks (st:state) cvs = + let reset_cvs = MAP (λx. (x,0:time)) cvs in + st with clocks := st.clocks |++ reset_cvs +End +*) + +(* TODO: rephrase this def *) + +Definition list_min_option_def: + (list_min_option ([]:num list) = NONE) /\ + (list_min_option (x::xs) = + case list_min_option xs of + | NONE => SOME x + | SOME y => SOME (if x < y then x else y)) +End + +Definition delay_clocks_def: + delay_clocks fm (d:num) = FEMPTY |++ + (MAP (λ(x,y). (x,y+d)) + (fmap_to_alist fm)) +End + + +Definition minusT_def: + minusT (t1:time) (t2:time) = t1 - t2 +End + + +Definition evalExpr_def: + evalExpr st e = + case e of + | ELit t => SOME t + | EClock c => FLOOKUP st.clocks c + | ESub e1 e2 => + case (evalExpr st e1, evalExpr st e2) of + | SOME t1,SOME t2 => + if t2 ≤ t1 then SOME (minusT t1 t2) + else NONE + | _=> NONE +End + +(* +Definition evalExpr_def: + (evalExpr st (ELit t) = t) ∧ + (evalExpr st (ESub e1 e2) = + minusT (evalExpr st e1) (evalExpr st e2)) ∧ + (evalExpr st (EClock c) = + case FLOOKUP st.clocks c of + | NONE => 0 + | SOME t => t) +End +*) + +(* +Definition evalCond_def: + (evalCond st (CndLe e1 e2) = (evalExpr st e1 <= evalExpr st e2)) /\ + (evalCond st (CndLt e1 e2) = (evalExpr st e1 < evalExpr st e2)) +End +*) + +Definition evalCond_def: + (evalCond st (CndLe e1 e2) = + case (evalExpr st e1,evalExpr st e2) of + | SOME t1,SOME t2 => t1 ≤ t2 + | _ => F) ∧ + (evalCond st (CndLt e1 e2) = + case (evalExpr st e1,evalExpr st e2) of + | SOME t1,SOME t2 => t1 < t2 + | _ => F) +End + + +Definition evalDiff_def: + evalDiff st ((t,c): time # clock) = + evalExpr st (ESub (ELit t) (EClock c)) +End + + +Definition calculate_wtime_def: + calculate_wtime st clks diffs = + let + st = st with clocks := resetClocks st.clocks clks + in + list_min_option (MAP (THE o evalDiff st) diffs) +End + + +Inductive evalTerm: + (∀st in_signal cnds clks dest diffs. + EVERY (λck. ck IN FDOM st.clocks) clks ∧ + EVERY (λ(t,c). + ∃v. FLOOKUP st.clocks c = SOME v ∧ + v ≤ t) diffs ==> + evalTerm st (SOME in_signal) + (Tm (Input in_signal) + cnds + clks + dest + diffs) + (st with <| clocks := resetClocks st.clocks clks + ; ioAction := SOME (Input in_signal) + ; location := dest + ; waitTime := calculate_wtime st clks diffs|>)) /\ + (∀st out_signal cnds clks dest diffs. + EVERY (λck. ck IN FDOM st.clocks) clks ∧ + EVERY (λ(t,c). + ∃v. FLOOKUP st.clocks c = SOME v ∧ + v ≤ t) diffs ==> + evalTerm st NONE + (Tm (Output out_signal) + cnds + clks + dest + diffs) + (st with <| clocks := resetClocks st.clocks clks + ; ioAction := SOME (Output out_signal) + ; location := dest + ; waitTime := calculate_wtime st clks diffs|>)) +End + + +Inductive pickTerm: + (* when each condition is true and input signals match with the first term *) + (!st cnds in_signal clks dest diffs tms st'. + EVERY (λcnd. evalCond st cnd) cnds ∧ + evalTerm st (SOME in_signal) (Tm (Input in_signal) cnds clks dest diffs) st' ==> + pickTerm st (SOME in_signal) (Tm (Input in_signal) cnds clks dest diffs :: tms) st') ∧ + + (* when each condition is true and output signals match with the first term *) + (!st cnds out_signal clks dest diffs tms st'. + EVERY (λcnd. evalCond st cnd) cnds ∧ + evalTerm st NONE (Tm (Output out_signal) cnds clks dest diffs) st' ==> + pickTerm st NONE (Tm (Output out_signal) cnds clks dest diffs :: tms) st') ∧ + + (* when any condition is false, but there is a matching term, then we can append the + list with the false term *) + (!st cnds event ioAction clks dest diffs tms st'. + (* new *) + EVERY (λcnd. EVERY (λe. ∃t. evalExpr st e = SOME t) (destCond cnd)) cnds ∧ + ~(EVERY (λcnd. evalCond st cnd) cnds) ∧ + pickTerm st event tms st' ==> + pickTerm st event (Tm ioAction cnds clks dest diffs :: tms) st') ∧ + + (* when the input event does not match, but there is a matching term, then we can append the + list with the false term *) + (!st cnds event in_signal clks dest diffs tms st'. + event <> SOME in_signal ∧ + pickTerm st event tms st' ==> + pickTerm st event (Tm (Input in_signal) cnds clks dest diffs :: tms) st') ∧ + + (* we can also append this in case of any SOME event with an output term *) + (!st cnds event out_signal clks dest diffs tms st'. + event <> NONE ∧ + pickTerm st event tms st' ==> + pickTerm st event (Tm (Output out_signal) cnds clks dest diffs :: tms) st') +End + + +Inductive step: + (!p st d. + st.waitTime = NONE ==> + step p (LDelay d) st + (mkState + (delay_clocks (st.clocks) d) + st.location + NONE + NONE)) /\ + + (!p st d w. + st.waitTime = SOME w ∧ + d ≤ w ==> + step p (LDelay d) st + (mkState + (delay_clocks (st.clocks) d) + st.location + NONE + (SOME (w - d)))) ∧ + + (!p st tms st' in_signal. + ALOOKUP p st.location = SOME tms /\ + pickTerm (resetOutput st) (SOME in_signal) tms st' /\ + st'.ioAction = SOME (Input in_signal) ==> + step p (LAction (Input in_signal)) st st') /\ +(* st has zero wakeup t *) + (!p st tms st' out_signal. + ALOOKUP p st.location = SOME tms /\ + pickTerm (resetOutput st) NONE tms st' /\ + st'.ioAction = SOME (Output out_signal) ==> + step p (LAction (Output out_signal)) st st') +End + + +Inductive stepTrace: + (!p st. + stepTrace p st st []) /\ + (!p lbl st st' st'' tr. + step p lbl st st' /\ + stepTrace p st' st'' tr ==> + stepTrace p st st'' (lbl::tr)) +End + +val _ = export_theory(); diff --git a/pancake/semantics/crepPropsScript.sml b/pancake/semantics/crepPropsScript.sml new file mode 100644 index 0000000000..3942de0350 --- /dev/null +++ b/pancake/semantics/crepPropsScript.sml @@ -0,0 +1,1105 @@ +(* + crepLang Properties +*) + +open preamble + panSemTheory panPropsTheory + crepLangTheory crepSemTheory + pan_commonTheory pan_commonPropsTheory; + +val _ = new_theory"crepProps"; + +val _ = set_grammar_ancestry ["panProps", "crepLang","crepSem", "pan_commonProps"]; + +Definition cexp_heads_simp_def: + cexp_heads_simp es = + if (MEM [] es) then NONE + else SOME (MAP HD es) +End + +Theorem lookup_locals_eq_map_vars: + ∀ns t. + OPT_MMAP (FLOOKUP t.locals) ns = + OPT_MMAP (eval t) (MAP Var ns) +Proof + rw [] >> + match_mp_tac IMP_OPT_MMAP_EQ >> + fs [MAP_MAP_o] >> + fs [MAP_EQ_f] >> rw [] >> + fs [crepSemTheory.eval_def] +QED + + +Theorem length_load_shape_eq_shape: + !n a e. + LENGTH (load_shape a n e) = n +Proof + Induct >> rw [] >> + once_rewrite_tac [load_shape_def] >> + fs [] >> + every_case_tac >> fs [] +QED + +Theorem eval_load_shape_el_rel: + !m n a t e. + n < m ==> + eval t (EL n (load_shape a m e)) = + eval t (Load (Op Add [e; Const (a + bytes_in_word * n2w n)])) +Proof + Induct >> rw [] >> + once_rewrite_tac [load_shape_def] >> + fs [ADD1] >> + cases_on ‘n’ >> fs [] + >- ( + TOP_CASE_TAC >> fs [] >> + fs [eval_def, OPT_MMAP_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + fs [wordLangTheory.word_op_def]) >> + rw [] >> + fs [ADD1] >> + fs [GSYM word_add_n2w, WORD_LEFT_ADD_DISTRIB] +QED + +Theorem mem_load_flat_rel: + ∀sh adr s v n. + mem_load sh adr s.memaddrs (s.memory: 'a word -> 'a word_lab) = SOME v ∧ + n < LENGTH (flatten v) ==> + crepSem$mem_load (adr + bytes_in_word * n2w (LENGTH (TAKE n (flatten v)))) s = + SOME (EL n (flatten v)) +Proof + rw [] >> + qmatch_asmsub_abbrev_tac `mem_load _ adr dm m = _` >> + ntac 2 (pop_assum(mp_tac o REWRITE_RULE [markerTheory.Abbrev_def])) >> + pop_assum mp_tac >> + pop_assum mp_tac >> + MAP_EVERY qid_spec_tac [‘n’,‘s’, `v`,`m`,`dm`,`adr`, `sh`] >> + Ho_Rewrite.PURE_REWRITE_TAC[GSYM PULL_FORALL] >> + qsuff_tac ‘(∀sh adr dm (m: 'a word -> 'a word_lab) v. + mem_load sh adr dm m = SOME v ⇒ + ∀(s :(α, β) state) n. + n < LENGTH (flatten v) ⇒ + dm = s.memaddrs ⇒ + m = s.memory ⇒ + mem_load (adr + bytes_in_word * n2w n) s = SOME (EL n (flatten v))) /\ + (∀sh adr dm (m: 'a word -> 'a word_lab) v. + mem_loads sh adr dm m = SOME v ⇒ + ∀(s :(α, β) state) n. + n < LENGTH (FLAT (MAP flatten v)) ⇒ + dm = s.memaddrs ⇒ + m = s.memory ⇒ + mem_load (adr + bytes_in_word * n2w n) s = SOME (EL n (FLAT (MAP flatten v))))’ + >- metis_tac [] >> + ho_match_mp_tac mem_load_ind >> + rpt strip_tac >> rveq + >- ( + fs [panSemTheory.mem_load_def] >> + cases_on ‘sh’ >> fs [option_case_eq] >> + rveq + >- (fs [flatten_def] >> rveq >> fs [mem_load_def]) >> + first_x_assum drule >> + disch_then (qspec_then ‘s’ mp_tac) >> + fs [flatten_def, ETA_AX]) + >- ( + fs [panSemTheory.mem_load_def] >> + rveq >> fs [flatten_def]) >> + fs [panSemTheory.mem_load_def] >> + cases_on ‘sh’ >> fs [option_case_eq] >> rveq + >- ( + fs [flatten_def] >> + cases_on ‘n’ >> fs [EL] >> + fs [panLangTheory.size_of_shape_def] >> + fs [n2w_SUC, WORD_LEFT_ADD_DISTRIB]) >> + first_x_assum drule >> + disch_then (qspec_then ‘s’ mp_tac) >> + fs [] >> + strip_tac >> + first_x_assum (qspec_then ‘s’ mp_tac) >> + strip_tac >> fs [] >> + fs [flatten_def, ETA_AX] >> + cases_on ‘0 <= n /\ n < LENGTH (FLAT (MAP flatten vs))’ >> + fs [] + >- fs [EL_APPEND_EQN] >> + fs [NOT_LESS] >> + ‘n - LENGTH (FLAT (MAP flatten vs)) < LENGTH (FLAT (MAP flatten vs'))’ by + DECIDE_TAC >> + last_x_assum drule >> + strip_tac >> fs [] >> + fs [EL_APPEND_EQN] >> + ‘size_of_shape (Comb l) = LENGTH (FLAT (MAP flatten vs))’ by ( + ‘mem_load (Comb l) adr s.memaddrs s.memory = SOME (Struct vs)’ by + rw [panSemTheory.mem_load_def] >> + drule mem_load_some_shape_eq >> + strip_tac >> pop_assum (assume_tac o GSYM) >> + fs [] >> + metis_tac [GSYM length_flatten_eq_size_of_shape, flatten_def]) >> + fs [] >> + drule n2w_sub >> + strip_tac >> fs [] >> + fs [WORD_LEFT_ADD_DISTRIB] >> + fs [GSYM WORD_NEG_RMUL] +QED + +Theorem update_locals_not_vars_eval_eq: + ∀s e v n w. + ~MEM n (var_cexp e) /\ + eval s e = SOME v ==> + eval (s with locals := s.locals |+ (n,w)) e = SOME v +Proof + ho_match_mp_tac eval_ind >> + rpt conj_tac >> rpt gen_tac >> strip_tac + >- (fs [eval_def]) + >- fs [eval_def, var_cexp_def, FLOOKUP_UPDATE] + >- fs [eval_def] + >- ( + rpt gen_tac >> + strip_tac >> fs [var_cexp_def] >> + fs [eval_def, CaseEq "option", CaseEq "word_lab"] >> + rveq >> fs [mem_load_def]) + >- ( + rpt gen_tac >> + strip_tac >> fs [var_cexp_def] >> + fs [eval_def, CaseEq "option", CaseEq "word_lab"] >> + rveq >> fs [mem_load_def]) + >- fs [var_cexp_def, eval_def, CaseEq "option"] + >- ( + rpt gen_tac >> + strip_tac >> fs [var_cexp_def, ETA_AX] >> + fs [eval_def, CaseEq "option", ETA_AX] >> + qexists_tac ‘ws’ >> + fs [opt_mmap_eq_some, ETA_AX, + MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + fs [MEM_FLAT, MEM_MAP] >> + metis_tac [EL_MEM]) >> + rpt gen_tac >> + strip_tac >> fs [var_cexp_def, ETA_AX] >> + fs [eval_def, CaseEq "option", CaseEq "word_lab"] >> + rveq >> metis_tac [] +QED + +Theorem var_exp_load_shape: + !i a e n. + MEM n (load_shape a i e) ==> + var_cexp n = var_cexp e +Proof + Induct >> + rw [load_shape_def] >> + fs [var_cexp_def] >> + metis_tac [] +QED + + +Theorem map_var_cexp_eq_var: + !vs. FLAT (MAP var_cexp (MAP Var vs)) = vs +Proof + Induct >> rw [var_cexp_def] >> + fs [var_cexp_def] +QED + +Theorem res_var_commutes: + n ≠ h ==> + res_var (res_var lc (h,FLOOKUP lc' h)) + (n,FLOOKUP lc' n) = + res_var (res_var lc (n,FLOOKUP lc' n)) + (h,FLOOKUP lc' h) +Proof + rw [] >> + cases_on ‘FLOOKUP lc' h’ >> + cases_on ‘FLOOKUP lc' n’ >> + fs[res_var_def] >> + fs [DOMSUB_COMMUTES, DOMSUB_FUPDATE_NEQ] >> + metis_tac [FUPDATE_COMMUTES] +QED + +Theorem flookup_res_var_diff_eq: + n <> m ==> + FLOOKUP (res_var l (m,v)) n = FLOOKUP l n +Proof + rw [] >> cases_on ‘v’ >> + fs [res_var_def, FLOOKUP_UPDATE, DOMSUB_FLOOKUP_NEQ] +QED + +Theorem unassigned_vars_evaluate_same: + !p s res t n. + evaluate (p,s) = (res,t) /\ + (res = NONE ∨ res = SOME Continue ∨ res = SOME Break) /\ + ~MEM n (assigned_vars p) ==> + FLOOKUP t.locals n = FLOOKUP s.locals n +Proof + recInduct evaluate_ind >> rw [] >> fs [] >> + TRY ( + rename1 ‘While _ _’ >> + qpat_x_assum ‘evaluate (While _ _,_) = (_,_)’ mp_tac >> + once_rewrite_tac [evaluate_def] >> + ntac 4 (TOP_CASE_TAC >> fs []) >> + pairarg_tac >> fs [] >> + fs [] >> + TOP_CASE_TAC >> fs [] >> + strip_tac + >- ( + first_x_assum drule >> + fs [] >> + disch_then drule >> + fs [assigned_vars_def] >> + first_x_assum drule >> + fs [dec_clock_def]) >> + FULL_CASE_TAC >> fs [] >> + fs [assigned_vars_def] >> + first_x_assum drule >> + fs [dec_clock_def] >> NO_TAC) >> + TRY + (fs [evaluate_def, assigned_vars_def, CaseEq "option", CaseEq "word_lab", + set_globals_def, state_component_equality] >> + TRY (pairarg_tac) >> rveq >> fs [] >> rveq >> + FULL_CASE_TAC >> metis_tac [] >> + NO_TAC) >> + TRY + (fs [evaluate_def, assigned_vars_def] >> fs [CaseEq "option"] >> + pairarg_tac >> fs [] >> rveq >> + first_x_assum drule >> + fs [state_component_equality, FLOOKUP_UPDATE] >> + metis_tac [flookup_res_var_diff_eq] >> NO_TAC) >> + TRY + (fs [evaluate_def, assigned_vars_def] >> fs [CaseEq "option", CaseEq "word_lab"] >> + rveq >> fs [state_component_equality, FLOOKUP_UPDATE] >> + fs [panSemTheory.mem_store_def, state_component_equality] >> NO_TAC) >> + TRY + (cases_on ‘caltyp’ >> + fs [evaluate_def, assigned_vars_def, CaseEq "option", CaseEq "ret", CaseEq "word_lab"] >> + rveq >> cases_on ‘v6’ >> fs[] >> + every_case_tac >> fs [set_var_def, state_component_equality, assigned_vars_def] >> + TRY (qpat_x_assum ‘s.locals |+ (_,_) = t.locals’ (mp_tac o GSYM) >> + fs [FLOOKUP_UPDATE] >> NO_TAC) >> + res_tac >> fs [FLOOKUP_UPDATE] >> NO_TAC) >> + TRY + (fs [evaluate_def, assigned_vars_def] >> fs [CaseEq "option"] >> + pairarg_tac >> fs [] >> rveq >> + FULL_CASE_TAC >> + metis_tac [] >> NO_TAC) >> + fs [evaluate_def, assigned_vars_def, dec_clock_def, CaseEq "option", + CaseEq "word_lab", CaseEq "ffi_result"] >> + rveq >> TRY (FULL_CASE_TAC) >>fs [state_component_equality] +QED + +Theorem assigned_vars_nested_decs_append: + !ns es p. + LENGTH ns = LENGTH es ==> + assigned_vars (nested_decs ns es p) = ns ++ assigned_vars p +Proof + Induct >> rw [] >> fs [nested_decs_def] >> + cases_on ‘es’ >> + fs [nested_decs_def, assigned_vars_def] +QED + + +Theorem nested_seq_assigned_vars_eq: + !ns vs. + LENGTH ns = LENGTH vs ==> + assigned_vars (nested_seq (MAP2 Assign ns vs)) = ns +Proof + Induct >> rw [] >- fs [nested_seq_def, assigned_vars_def] >> + cases_on ‘vs’ >> fs [nested_seq_def, assigned_vars_def] +QED + + +Theorem assigned_vars_seq_store_empty: + !es ad a. + assigned_vars (nested_seq (stores ad es a)) = [] +Proof + Induct >> rw [] >> + fs [stores_def, assigned_vars_def, nested_seq_def] >> + FULL_CASE_TAC >> fs [stores_def, assigned_vars_def, + nested_seq_def] +QED + +Theorem assigned_vars_store_globals_empty: + !es ad. + assigned_vars (nested_seq (store_globals ad es)) = [] +Proof + Induct >> rw [] >> + fs [store_globals_def, assigned_vars_def, nested_seq_def] >> + fs [store_globals_def, assigned_vars_def, nested_seq_def] +QED + +Theorem length_load_globals_eq_read_size: + !ads a. + LENGTH (load_globals a ads) = ads +Proof + Induct >> rw [] >> fs [load_globals_def] +QED + + +Theorem el_load_globals_elem: + !ads a n. + n < ads ==> + EL n (load_globals a ads) = LoadGlob (a + n2w n) +Proof + Induct >> rw [] >> fs [load_globals_def] >> + cases_on ‘n’ >> fs [] >> fs [n2w_SUC] +QED + +Theorem evaluate_seq_stroes_locals_eq: + !es ad a s res t. + evaluate (nested_seq (stores ad es a),s) = (res,t) ==> + t.locals = s.locals +Proof + Induct >> rw [] + >- fs [stores_def, nested_seq_def, evaluate_def] >> + fs [stores_def] >> FULL_CASE_TAC >> rveq >> fs [] >> + fs [nested_seq_def, evaluate_def] >> + pairarg_tac >> fs [] >> rveq >> + every_case_tac >> fs [] >> rveq >> + last_x_assum drule >> + fs [panSemTheory.mem_store_def,state_component_equality] +QED + +Theorem evaluate_seq_stores_mem_state_rel: + !es vs ad a s res t addr m. + LENGTH es = LENGTH vs /\ ~MEM ad es /\ ALL_DISTINCT es /\ + mem_stores (addr+a) vs s.memaddrs s.memory = SOME m /\ + evaluate (nested_seq (stores (Var ad) (MAP Var es) a), + s with locals := s.locals |++ + ((ad,Word addr)::ZIP (es,vs))) = (res,t) ==> + res = NONE ∧ t.memory = m ∧ + t.memaddrs = s.memaddrs ∧ (t.be ⇔ s.be) /\ + t.ffi = s.ffi ∧ t.code = s.code /\ t.clock = s.clock +Proof + Induct >> rpt gen_tac >> strip_tac >> rfs [] >> rveq + >- fs [stores_def, nested_seq_def, evaluate_def, + mem_stores_def, state_component_equality] >> + cases_on ‘vs’ >> fs [] >> + fs [mem_stores_def, CaseEq "option"] >> + qmatch_asmsub_abbrev_tac ‘s with locals := lc’ >> + ‘eval (s with locals := lc) (Var h) = SOME h'’ by ( + fs [Abbr ‘lc’, eval_def] >> + fs [FUPDATE_LIST_THM] >> + ‘~MEM h (MAP FST (ZIP (es,t')))’ by ( + drule MAP_ZIP >> + strip_tac >> fs []) >> + drule FUPDATE_FUPDATE_LIST_COMMUTES >> + disch_then (qspecl_then [‘h'’, ‘s.locals |+ (ad,Word addr)’] assume_tac) >> + fs [FLOOKUP_UPDATE]) >> + ‘lc |++ ((ad,Word addr)::ZIP (es,t')) = lc’ by ( + fs [Abbr ‘lc’] >> metis_tac [fm_multi_update]) >> + fs [stores_def] >> + FULL_CASE_TAC >> fs [] + >- ( + fs [nested_seq_def, evaluate_def] >> + pairarg_tac >> fs [] >> + ‘eval (s with locals := lc) (Var ad) = SOME (Word addr)’ by ( + fs [Abbr ‘lc’, eval_def] >> + fs [Once FUPDATE_LIST_THM] >> + ‘~MEM ad (MAP FST ((h,h')::ZIP (es,t')))’ by ( + drule MAP_ZIP >> + strip_tac >> fs []) >> + drule FUPDATE_FUPDATE_LIST_COMMUTES >> + disch_then (qspecl_then [‘Word addr’, ‘s.locals’] assume_tac) >> + fs [FLOOKUP_UPDATE]) >> fs [] >> + rfs [] >> rveq >> fs [] >> + last_x_assum (qspecl_then [‘t'’, ‘ad’, ‘bytes_in_word’] mp_tac) >> fs [] >> + disch_then (qspec_then ‘s with <|locals := lc; memory := m'|>’ mp_tac) >> fs [] >> + disch_then drule >> fs []) >> + fs [nested_seq_def, evaluate_def] >> + pairarg_tac >> fs [] >> + ‘eval (s with locals := lc) (Op Add [Var ad; Const a]) = SOME (Word (addr+a))’ by ( + fs [eval_def, OPT_MMAP_def, Abbr ‘lc’] >> + fs [Once FUPDATE_LIST_THM] >> + ‘~MEM ad (MAP FST ((h,h')::ZIP (es,t')))’ by ( + drule MAP_ZIP >> + strip_tac >> fs []) >> + drule FUPDATE_FUPDATE_LIST_COMMUTES >> + disch_then (qspecl_then [‘Word addr’, ‘s.locals’] assume_tac) >> + fs [FLOOKUP_UPDATE, wordLangTheory.word_op_def]) >> fs [] >> + rfs [] >> rveq >> fs [] >> + pop_assum kall_tac >> + pop_assum kall_tac >> + last_x_assum (qspecl_then [‘t'’, ‘ad’, ‘a + bytes_in_word’] mp_tac) >> fs [] >> + disch_then (qspec_then ‘s with <|locals := lc; memory := m'|>’ mp_tac) >> fs [] >> + disch_then drule >> fs [] +QED + +Theorem evaluate_seq_store_globals_res: + !vars vs t a. + ALL_DISTINCT vars ∧ LENGTH vars = LENGTH vs ∧ w2n a + LENGTH vs <= 32 ==> + evaluate (nested_seq (store_globals a (MAP Var vars)), + t with locals := t.locals |++ ZIP (vars,vs)) = + (NONE,t with <|locals := t.locals |++ ZIP (vars,vs); + globals := t.globals |++ ZIP (GENLIST (λx. a + n2w x) (LENGTH vs), vs)|>) +Proof + Induct >> rw [] + >- fs [store_globals_def, nested_seq_def, evaluate_def, + FUPDATE_LIST_THM, state_component_equality] >> + cases_on ‘vs’ >> fs [] >> + fs [store_globals_def, nested_seq_def, evaluate_def] >> + pairarg_tac >> fs [] >> + fs [eval_def, FUPDATE_LIST_THM] >> + ‘~MEM h (MAP FST (ZIP (vars, t')))’ by + metis_tac [MEM_MAP, MEM_ZIP,FST, MEM_EL] >> + drule FUPDATE_FUPDATE_LIST_COMMUTES >> + disch_then (qspecl_then [‘h'’, ‘t.locals’] assume_tac) >> + fs [FLOOKUP_UPDATE] >> rveq >> + fs [set_globals_def] >> + cases_on ‘t' = []’ + >- ( + rveq >> fs [] >> rveq >> + fs [store_globals_def, nested_seq_def, evaluate_def, + FUPDATE_LIST_THM, state_component_equality]) >> + qmatch_goalsub_abbrev_tac ‘nested_seq _, st’ >> + last_x_assum (qspecl_then [‘t'’, ‘st’, ‘a + 1w’] mp_tac) >> + fs [] >> impl_tac + >- ( + fs [ADD1] >> + qmatch_asmsub_abbrev_tac ‘m + (w2n a + 1) <= 32’ >> + ‘0 < m’ by (fs [Abbr ‘m’] >> cases_on ‘t'’ >> fs []) >> + ‘(w2n a + 1) <= 32 - m’ by DECIDE_TAC >> + fs [w2n_plus1] >> + FULL_CASE_TAC >> + fs []) >> + ‘st.locals |++ ZIP (vars,t') = st.locals’ by ( + fs [Abbr ‘st’] >> + drule FUPDATE_FUPDATE_LIST_COMMUTES >> + disch_then (qspecl_then [‘h'’, ‘t.locals |++ ZIP (vars,t')’] assume_tac) >> + fs [] >> metis_tac [FUPDATE_LIST_CANCEL, MEM_ZIP]) >> + fs [Abbr ‘st’] >> fs [] >> strip_tac >> fs [state_component_equality] >> + fs [GENLIST_CONS, FUPDATE_LIST_THM, o_DEF, n2w_SUC] +QED + + +Theorem res_var_lookup_original_eq: + !xs ys lc. ALL_DISTINCT xs ∧ LENGTH xs = LENGTH ys ==> + FOLDL res_var (lc |++ ZIP (xs,ys)) (ZIP (xs,MAP (FLOOKUP lc) xs)) = lc +Proof + Induct >> rw [] >- fs [FUPDATE_LIST_THM] >> + fs [] >> cases_on ‘ys’ >> fs [] >> + fs [FUPDATE_LIST_THM] >> + ‘~MEM h (MAP FST (ZIP (xs, t)))’ by + metis_tac [MEM_MAP, MEM_ZIP,FST, MEM_EL] >> + drule FUPDATE_FUPDATE_LIST_COMMUTES >> + disch_then (qspecl_then [‘h'’, ‘lc’] mp_tac) >> + fs [] >> strip_tac >> + cases_on ‘FLOOKUP lc h’ >> fs [] >> + fs [res_var_def] >> + qpat_x_assum ‘~MEM h xs’ assume_tac + >- ( + drule domsub_commutes_fupdate >> + disch_then (qspecl_then [‘t’, ‘lc’] mp_tac) >> + fs [] >> + metis_tac [flookup_thm, DOMSUB_NOT_IN_DOM]) >> + drule FUPDATE_FUPDATE_LIST_COMMUTES >> + disch_then (qspecl_then [‘x’, ‘lc’] assume_tac o GSYM) >> + fs [] >> + metis_tac [FUPDATE_ELIM, flookup_thm] +QED + +Theorem eval_exps_not_load_global_eq: + !s e v g. eval s e = SOME v ∧ + (!ad. ~MEM (LoadGlob ad) (exps e)) ==> + eval (s with globals := g) e = SOME v +Proof + ho_match_mp_tac eval_ind >> + rpt conj_tac >> rpt gen_tac >> strip_tac + >- fs [eval_def] + >- fs [eval_def] + >- fs [eval_def] + >- ( + rpt gen_tac >> + strip_tac >> fs [exps_def] >> + fs [eval_def, CaseEq "option", CaseEq "word_lab"] >> + rveq >> fs [mem_load_def] >> rveq >> metis_tac []) + >- ( + rpt gen_tac >> + strip_tac >> fs [exps_def] >> + fs [eval_def, CaseEq "option", CaseEq "word_lab"] >> + rveq >> metis_tac []) + >- fs [exps_def, eval_def, CaseEq "option"] + + >- ( + rpt gen_tac >> + strip_tac >> fs [exps_def, ETA_AX] >> + fs [eval_def, CaseEq "option", ETA_AX] >> + qexists_tac ‘ws’ >> + fs [opt_mmap_eq_some, ETA_AX, + MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + fs [MEM_FLAT, MEM_MAP] >> + metis_tac [EL_MEM]) >> + rpt gen_tac >> + strip_tac >> fs [exps_def, ETA_AX] >> + fs [eval_def, CaseEq "option", CaseEq "word_lab"] >> + rveq >> metis_tac [] +QED + +Theorem load_glob_not_mem_load: + !i a h ad. + ~MEM (LoadGlob ad) (exps h) ==> + ~MEM (LoadGlob ad) (FLAT (MAP exps (load_shape a i h))) +Proof + Induct >> rw [] >- fs [load_shape_def] >> + fs [load_shape_def] >> + TOP_CASE_TAC >> fs [MAP, load_shape_def, exps_def] +QED + +Theorem var_cexp_load_globals_empty: + !ads a. + FLAT (MAP var_cexp (load_globals a ads)) = [] +Proof + Induct >> rw [] >> + fs [var_cexp_def, load_globals_def] +QED + +Theorem evaluate_seq_assign_load_globals: + !ns t a. + ALL_DISTINCT ns /\ w2n a + LENGTH ns <= 32 /\ + (!n. MEM n ns ==> FLOOKUP t.locals n <> NONE) /\ + (!n. MEM n (GENLIST (λx. a + n2w x) (LENGTH ns)) ==> FLOOKUP t.globals n <> NONE) ==> + evaluate (nested_seq (MAP2 Assign ns (load_globals a (LENGTH ns))), t) = + (NONE, t with locals := t.locals |++ + ZIP (ns, MAP (\n. THE (FLOOKUP t.globals n)) (GENLIST (λx. a + n2w x) (LENGTH ns)))) +Proof + Induct >> rw [] + >- ( + fs [nested_seq_def, evaluate_def] >> + fs [FUPDATE_LIST_THM, state_component_equality]) >> + fs [nested_seq_def, GENLIST_CONS, load_globals_def] >> + fs [evaluate_def] >> pairarg_tac >> fs [] >> + fs [eval_def] >> + cases_on ‘FLOOKUP t.globals a’ + >- ( + first_assum (qspec_then ‘a’ mp_tac) >> + fs []) >> + fs [] >> + cases_on ‘FLOOKUP t.locals h’ + >- ( + first_assum (qspec_then ‘h’ mp_tac) >> + fs []) >> + fs [] >> rveq >> + fs [FUPDATE_LIST_THM] >> + last_x_assum (qspecl_then [‘t with locals := t.locals |+ (h,x)’, ‘a + 1w’] mp_tac) >> + impl_tac + >- ( + conj_tac + >- ( + ‘w2n a <= 31 - LENGTH ns’ by fs [] >> + cases_on ‘a = 31w:word5’ >> fs [] >> + ‘w2n (a + 1w) = w2n a + 1’ by ( + fs [w2n_plus1] >> + FULL_CASE_TAC >> fs []) >> + fs []) >> + conj_tac + >- ( + rw [] >> fs [FLOOKUP_UPDATE] >> + TOP_CASE_TAC >> fs []) >> + rw [] >> fs [MEM_GENLIST] >> + first_x_assum match_mp_tac >> + disj2_tac >> fs [] >> + qexists_tac ‘x''’ >> fs [] >> + fs [n2w_SUC]) >> + strip_tac >> fs [] >> + fs [state_component_equality] >> + ‘GENLIST (λx. a + n2w x + 1w) (LENGTH ns)= + GENLIST ((λx. a + n2w x) ∘ SUC) (LENGTH ns)’ + suffices_by fs [] >> + fs [GENLIST_FUN_EQ] >> + rw [] >> + fs [n2w_SUC] +QED + +Theorem flookup_res_var_distinct_eq: + !xs x fm. + ~MEM x (MAP FST xs) ==> + FLOOKUP (FOLDL res_var fm xs) x = + FLOOKUP fm x +Proof + Induct >> rw [] >> + cases_on ‘h’ >> fs [] >> + cases_on ‘r’ >> fs [res_var_def] >> + fs [MEM_MAP] >> + metis_tac [DOMSUB_FLOOKUP_NEQ, FLOOKUP_UPDATE] +QED + + +Theorem flookup_res_var_distinct_zip_eq: + LENGTH xs = LENGTH ys /\ + ~MEM x xs ==> + FLOOKUP (FOLDL res_var fm (ZIP (xs,ys))) x = + FLOOKUP fm x +Proof + rw [] >> + qmatch_goalsub_abbrev_tac `FOLDL res_var _ l` >> + pop_assum(mp_tac o REWRITE_RULE [markerTheory.Abbrev_def]) >> + rpt (pop_assum mp_tac) >> + MAP_EVERY qid_spec_tac [`x`,`ys`,`xs`,`fm`, `l`] >> + Induct >> rw [] >> rveq >> + cases_on ‘xs’ >> cases_on ‘ys’ >> fs [ZIP] >> + rveq >> + cases_on ‘h''’ >> fs [res_var_def] >> + fs [MEM_MAP] >> + metis_tac [DOMSUB_FLOOKUP_NEQ, FLOOKUP_UPDATE] +QED + +Theorem flookup_res_var_distinct: + !ys xs zs fm. + distinct_lists xs ys /\ + LENGTH xs = LENGTH zs ==> + MAP (FLOOKUP (FOLDL res_var fm (ZIP (xs,zs)))) ys = + MAP (FLOOKUP fm) ys +Proof + Induct + >- rw[MAP] >> rw [] + >- ( + fs [pan_commonTheory.distinct_lists_def, EVERY_MEM, FUPDATE_LIST_THM] >> + ‘~MEM h xs’ by metis_tac [] >> + drule flookup_res_var_distinct_zip_eq >> + disch_then (qspecl_then [‘h’,‘fm’] mp_tac) >> + fs [] >> + strip_tac >> fs [] >> + metis_tac [flookup_fupdate_zip_not_mem]) >> + fs [FUPDATE_LIST_THM] >> + drule distinct_lists_simp_cons >> + strip_tac >> + first_x_assum drule >> + disch_then (qspec_then ‘zs’ mp_tac) >> fs [] +QED + +Theorem flookup_res_var_zip_distinct: + !ys xs as cs fm. + distinct_lists xs ys /\ + LENGTH xs = LENGTH as /\ + LENGTH xs = LENGTH cs ==> + MAP (FLOOKUP (FOLDL res_var (fm |++ ZIP (xs,as)) (ZIP (xs,cs)))) ys = + MAP (FLOOKUP fm) ys +Proof + rw [] >> + drule flookup_res_var_distinct >> + disch_then (qspecl_then [‘cs’,‘fm |++ ZIP (xs,as)’] mp_tac) >> + fs [] >> + metis_tac [map_flookup_fupdate_zip_not_mem] +QED + +Theorem eval_some_var_cexp_local_lookup: + ∀s e v n. eval s e = SOME v /\ MEM n (var_cexp e) ==> + ?w. FLOOKUP s.locals n = SOME w +Proof + ho_match_mp_tac eval_ind >> rw [] >> + TRY (fs [eval_def, var_cexp_def] >> NO_TAC) >> + TRY ( + fs [eval_def, var_cexp_def] >> + FULL_CASE_TAC >> fs [] >> NO_TAC) + >- ( + fs [var_cexp_def, ETA_AX] >> + fs [eval_def] >> + FULL_CASE_TAC >> fs [ETA_AX] >> rveq >> + pop_assum kall_tac >> pop_assum kall_tac >> + rpt (pop_assum mp_tac) >> + MAP_EVERY qid_spec_tac [`n`,`x`,`s`, `es`] >> + Induct >- rw [] >> + rpt gen_tac >> + rpt strip_tac >> + fs [OPT_MMAP_def] >> rveq >> fs [] >> + last_x_assum (qspecl_then [‘s’, ‘t’, ‘n’] mp_tac) >> + fs [] >> + impl_tac >- metis_tac [] >> + fs []) >> + fs [var_cexp_def, eval_def] >> + every_case_tac >> fs [] +QED + + +Theorem eval_label_eq_state_contains_label: + !s e w f. eval s e = SOME w /\ w = Label f ==> + (?v. FLOOKUP s.locals v = SOME (Label f)) ∨ + (?n args. FLOOKUP s.code f = SOME (n,args)) ∨ + (?ad. s.memory ad = Label f) ∨ + (?gadr. FLOOKUP s.globals gadr = SOME (Label f)) +Proof + ho_match_mp_tac eval_ind >> rw [] >> + fs [eval_def, mem_load_def, AllCaseEqs ()] >> fs [] >> rveq >> + TRY (cases_on ‘v1’) >> + metis_tac [] +QED + + +Theorem eval_upd_clock_eq: + !t e ck. eval (t with clock := ck) e = eval t e +Proof + ho_match_mp_tac eval_ind >> rw [] >> + fs [eval_def] + >- ( + every_case_tac >> fs [] >> + fs [mem_load_def]) >> + qsuff_tac ‘OPT_MMAP (λa. eval (t with clock := ck) a) es = + OPT_MMAP (λa. eval t a) es’ >> + fs [] >> + pop_assum mp_tac >> + qid_spec_tac ‘es’ >> + Induct >> rw [] >> + fs [OPT_MMAP_def] +QED + +Theorem opt_mmap_eval_upd_clock_eq: + !es s ck. OPT_MMAP (eval (s with clock := ck + s.clock)) es = + OPT_MMAP (eval s) es +Proof + rw [] >> + match_mp_tac IMP_OPT_MMAP_EQ >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + metis_tac [eval_upd_clock_eq] +QED + +Theorem evaluate_add_clock_eq: + !p t res st ck. + evaluate (p,t) = (res,st) /\ res <> SOME TimeOut ==> + evaluate (p,t with clock := t.clock + ck) = (res,st with clock := st.clock + ck) +Proof + recInduct evaluate_ind >> rw [] >> + TRY (fs [Once evaluate_def] >> NO_TAC) >> + TRY ( + rename [‘Seq’] >> + fs [evaluate_def] >> pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> rveq >> + fs [AllCaseEqs ()] >> rveq >> fs [] >> + first_x_assum (qspec_then ‘ck’ mp_tac) >> + fs []) >> + TRY ( + rename [‘If’] >> + fs [evaluate_def, AllCaseEqs ()] >> rveq >> + fs [eval_upd_clock_eq]) >> + TRY ( + rename [‘ExtCall’] >> + fs [evaluate_def, AllCaseEqs ()] >> rveq >> fs []) >> + TRY ( + rename [‘While’] >> + qpat_x_assum ‘evaluate (While _ _,_) = _’ mp_tac >> + once_rewrite_tac [evaluate_def] >> + fs [eval_upd_clock_eq] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] + >- ( + strip_tac >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + fs [dec_clock_def] >> + last_x_assum (qspec_then ‘ck’ mp_tac) >> + fs []) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + strip_tac >> fs [] >> rveq >> fs [dec_clock_def] >> + first_x_assum (qspec_then ‘ck’ mp_tac) >> + fs []) >> + TRY ( + rename [‘Call’] >> + qpat_x_assum ‘evaluate (Call _ _ _,_) = _’ mp_tac >> + once_rewrite_tac [evaluate_def] >> + fs [dec_clock_def, eval_upd_clock_eq] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + ‘OPT_MMAP (eval (s with clock := ck + s.clock)) argexps = + OPT_MMAP (eval s) argexps’ by fs [opt_mmap_eval_upd_clock_eq] >> + fs [] >> + fs [AllCaseEqs(), empty_locals_def, dec_clock_def] >> rveq >> fs [] >> + strip_tac >> fs [] >> rveq >> fs []) >> + TRY ( + rename [‘Dec’] >> + fs [evaluate_def, eval_upd_clock_eq, AllCaseEqs () ] >> + pairarg_tac >> fs [] >> rveq >> fs [] >> + pairarg_tac >> fs [] >> rveq >> fs [] >> + last_x_assum (qspec_then ‘ck’ mp_tac) >> + fs []) >> + fs [evaluate_def, eval_upd_clock_eq, AllCaseEqs () , + set_var_def, mem_store_def, set_globals_def, + dec_clock_def, empty_locals_def] >> rveq >> + fs [state_component_equality] +QED + + +Theorem evaluate_io_events_mono: + !exps s1 res s2. + evaluate (exps,s1) = (res, s2) + ⇒ + s1.ffi.io_events ≼ s2.ffi.io_events +Proof + recInduct evaluate_ind >> + rw [] >> + TRY ( + rename [‘Seq’] >> + fs [evaluate_def] >> + pairarg_tac >> fs [] >> rveq >> + every_case_tac >> fs [] >> rveq >> + metis_tac [IS_PREFIX_TRANS]) >> + TRY ( + rename [‘ExtCall’] >> + fs [evaluate_def, AllCaseEqs(), empty_locals_def, + dec_clock_def, ffiTheory.call_FFI_def] >> + rveq >> fs []) >> + TRY ( + rename [‘If’] >> + fs [evaluate_def] >> + every_case_tac >> fs []) >> + TRY ( + rename [‘While’] >> + qpat_x_assum ‘evaluate (While _ _,_) = _’ mp_tac >> + once_rewrite_tac [evaluate_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [empty_locals_def] + >- (strip_tac >> rveq >> fs []) >> + pairarg_tac >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] + >- ( + strip_tac >> fs [] >> + fs [dec_clock_def] >> + metis_tac [IS_PREFIX_TRANS]) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + strip_tac >> fs [] >> rveq >> fs [dec_clock_def] >> + metis_tac [IS_PREFIX_TRANS]) >> + TRY ( + rename [‘Call’] >> + pop_assum mp_tac >> + once_rewrite_tac [evaluate_def, LET_THM] >> + fs [AllCaseEqs(), empty_locals_def, + dec_clock_def, set_var_def] >> + strip_tac >> fs [] >> rveq >> fs [] >> + metis_tac [IS_PREFIX_TRANS]) >> + TRY ( + rename [‘Dec’] >> + fs [evaluate_def, AllCaseEqs () ] >> + pairarg_tac >> fs [] >> rveq >> fs []) >> + fs [evaluate_def, eval_upd_clock_eq, AllCaseEqs () , + set_var_def, mem_store_def, set_globals_def, + dec_clock_def, empty_locals_def] >> rveq >> + fs [state_component_equality] +QED + +Theorem evaluate_add_clock_io_events_mono: + ∀exps s extra. + (SND(evaluate(exps,s))).ffi.io_events ≼ + (SND(evaluate(exps,s with clock := s.clock + extra))).ffi.io_events +Proof + recInduct evaluate_ind >> + rw [] >> + TRY ( + rename [‘Seq’] >> + fs [evaluate_def] >> + pairarg_tac >> fs [] >> rveq >> + pairarg_tac >> fs [] >> rveq >> + every_case_tac >> fs [] >> rveq >> fs [] + >- ( + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> + disch_then (qspec_then ‘extra’ mp_tac) >> + fs [] >> + strip_tac >> + strip_tac >> rveq >> fs []) + >- ( + pop_assum mp_tac >> + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> + disch_then (qspec_then ‘extra’ mp_tac) >> + fs []) + >- ( + first_x_assum (qspec_then ‘extra’ mp_tac) >> + strip_tac >> + ‘s1.ffi.io_events ≼ s1'.ffi.io_events’ by rfs [] >> + cases_on ‘evaluate (c2,s1')’ >> + fs [] >> + ‘s1'.ffi.io_events ≼ r.ffi.io_events’ by + metis_tac [evaluate_io_events_mono] >> + metis_tac [IS_PREFIX_TRANS]) >> + first_x_assum (qspec_then ‘extra’ mp_tac) >> + fs []) >> + TRY ( + rename [‘If’] >> + fs [evaluate_def, AllCaseEqs()] >> rveq >> fs [] >> + every_case_tac >> fs [eval_upd_clock_eq]) >> + TRY ( + rename [‘While’] >> + once_rewrite_tac [evaluate_def] >> + TOP_CASE_TAC >> fs [eval_upd_clock_eq] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [empty_locals_def] + >- ( + TOP_CASE_TAC >> fs [] >> rveq >> + fs [dec_clock_def] >> + pairarg_tac >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TRY (cases_on ‘x’) >> fs [] >> + TRY (cases_on ‘evaluate (While e c,s1)’) >> fs [] >> + imp_res_tac evaluate_io_events_mono >> fs [] >> + metis_tac [IS_PREFIX_TRANS]) >> + pairarg_tac >> fs [] >> rveq >> + pairarg_tac >> fs [] >> rveq >> + fs [dec_clock_def] >> + cases_on ‘res’ >> fs [] + >- ( + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘extra’ mp_tac) >> + fs [] >> + strip_tac >> strip_tac >> rveq >> fs []) >> + cases_on ‘x = Continue’ >> fs [] + >- ( + pop_assum mp_tac >> + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘extra’ mp_tac) >> + fs [] >> + strip_tac >> strip_tac >> strip_tac >> rveq >> fs []) >> + cases_on ‘x = TimeOut’ >> rveq >> fs [] + >- ( + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TRY (cases_on ‘x’) >> fs [] >> rveq >> fs [] >> + first_x_assum (qspec_then ‘extra’ mp_tac) >> + fs [] >> strip_tac >> + cases_on ‘evaluate (While e c,s1')’ >> fs [] >> + drule evaluate_io_events_mono >> + strip_tac >> + metis_tac [IS_PREFIX_TRANS]) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘extra’ mp_tac) >> + fs [] >> + strip_tac >> strip_tac >> strip_tac >> rveq >> fs []) >> + TRY ( + rename [‘Call’] >> + once_rewrite_tac [evaluate_def, LET_THM] >> + fs [eval_upd_clock_eq, opt_mmap_eval_upd_clock_eq] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [empty_locals_def] + >- ( + every_case_tac >> fs [dec_clock_def, empty_locals_def] >> + rveq >> fs [] >> + imp_res_tac evaluate_io_events_mono >> + fs [] >> + TRY (cases_on ‘evaluate (p,r' with locals := s.locals)’) >> fs [] >> + TRY (cases_on ‘evaluate (p',r' with locals := s.locals)’) >> fs [] >> + TRY (cases_on ‘evaluate (p,r' with locals := s.locals |+ (x',w))’) >> fs [] >> + imp_res_tac evaluate_io_events_mono >> + fs [] >> metis_tac [IS_PREFIX_TRANS]) >> + fs [dec_clock_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] + >- ( + first_x_assum (qspec_then ‘extra’ mp_tac) >> + strip_tac >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] + >- ( + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] + >- ( + cases_on ‘evaluate (p,r'' with locals := s.locals)’ >> + fs [] >> + imp_res_tac evaluate_io_events_mono >> + fs [] >> metis_tac [IS_PREFIX_TRANS]) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + cases_on ‘evaluate (p,r'' with locals := s.locals |+ (x',w))’ >> + fs [] >> + imp_res_tac evaluate_io_events_mono >> + fs [] >> metis_tac [IS_PREFIX_TRANS]) >> + every_case_tac >> fs [] >> rveq >> fs [] >> + cases_on ‘evaluate (p,r'' with locals := s.locals)’ >> + fs [] >> + imp_res_tac evaluate_io_events_mono >> + fs [] >> metis_tac [IS_PREFIX_TRANS]) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TRY (drule evaluate_add_clock_eq >> fs [] >> NO_TAC) + >- ( + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TRY (cases_on ‘x'’) >> fs [] >> rveq >> fs [] >> + TRY ( + first_x_assum (qspec_then ‘extra’ mp_tac) >> + strip_tac >> fs [] >> + cases_on ‘evaluate (q,s with <|locals := r; + clock := extra + s.clock - 1|>)’ >> + fs [] >> rveq >> fs [] >> NO_TAC) + >- ( + every_case_tac >> fs [] >> rveq >> fs [] >> + first_x_assum (qspec_then ‘extra’ mp_tac) >> + strip_tac >> fs [] >> rfs [] + >- ( + cases_on ‘evaluate (p,r'' with locals := s.locals)’ >> + imp_res_tac evaluate_io_events_mono >> + fs [] >> metis_tac [IS_PREFIX_TRANS]) >> + cases_on ‘evaluate (p,r'' with locals := s.locals |+ (x',w))’ >> + imp_res_tac evaluate_io_events_mono >> + fs [] >> metis_tac [IS_PREFIX_TRANS]) >> + every_case_tac >> fs [] >> rveq >> fs [] >> + first_x_assum (qspec_then ‘extra’ mp_tac) >> + strip_tac >> fs [] >> rfs [] >> + cases_on ‘evaluate (p,r'' with locals := s.locals)’ >> + imp_res_tac evaluate_io_events_mono >> + fs [] >> metis_tac [IS_PREFIX_TRANS]) + >- ( + TOP_CASE_TAC >> fs [] >> rveq >> fs [] + >- ( + first_x_assum (qspec_then ‘extra’ mp_tac) >> + strip_tac >> fs [] >> + cases_on ‘evaluate (q,s with <|locals := r; clock := extra + s.clock - 1|>)’ >> + fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs []) + >- ( + TOP_CASE_TAC >> fs [] >> rveq >> fs [] + >- (drule evaluate_add_clock_eq >> fs []) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + drule evaluate_add_clock_eq >> fs []) >> + drule evaluate_add_clock_eq >> fs []) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] + >- ( + first_x_assum (qspec_then ‘extra’ mp_tac) >> + strip_tac >> fs [] >> + cases_on ‘evaluate (q,s with <|locals := r; clock := extra + s.clock - 1|>)’ >> + fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs []) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] + >- ( + first_x_assum (qspec_then ‘extra’ mp_tac) >> + strip_tac >> fs [] >> + cases_on ‘evaluate (q,s with <|locals := r; clock := extra + s.clock - 1|>)’ >> + fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> fs []) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + drule evaluate_add_clock_eq >> fs []) >> + TRY ( + rename [‘Dec’] >> + fs [evaluate_def] >> + fs [eval_upd_clock_eq] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + pairarg_tac >> fs [] >> rveq >> fs [] >> + pairarg_tac >> fs [] >> rveq >> fs [] >> + last_x_assum (qspec_then ‘extra’ mp_tac) >> + fs []) >> + TRY ( + rename [‘ExtCall’] >> + fs [evaluate_def, eval_upd_clock_eq] >> + every_case_tac >> fs []) >> + fs [evaluate_def, eval_upd_clock_eq] >> + every_case_tac >> fs [] >> + fs [set_var_def, mem_store_def, set_globals_def, + dec_clock_def, empty_locals_def] >> rveq >> + fs [] +QED + + +val _ = export_theory(); diff --git a/pancake/semantics/crepSemScript.sml b/pancake/semantics/crepSemScript.sml new file mode 100644 index 0000000000..b59e976c15 --- /dev/null +++ b/pancake/semantics/crepSemScript.sml @@ -0,0 +1,326 @@ +(* + Semantics of crepLang +*) + +open preamble crepLangTheory; +local open alignmentTheory + miscTheory (* for read_bytearray *) + wordLangTheory (* for word_op and word_sh *) + panSemTheory (* for word_lab datatype *) + ffiTheory in end; + +val _ = new_theory"crepSem"; +val _ = set_grammar_ancestry [ + "crepLang", "alignment", + "finite_map", "misc", "wordLang", "panSem", "ffi", "lprefix_lub"] + +(* re-defining them again to avoid varname from panSem *) +Type varname = ``:num`` +Type funname = ``:mlstring`` + +Datatype: + state = + <| locals : varname |-> 'a word_lab + ; globals : 5 word |-> 'a word_lab + ; code : funname |-> (varname list # ('a crepLang$prog)) + ; memory : 'a word -> 'a word_lab + ; memaddrs : ('a word) set + ; clock : num + ; be : bool + ; ffi : 'ffi ffi_state |> +End + +val state_component_equality = theorem"state_component_equality"; + +Datatype: + result = Error + | TimeOut + | Break + | Continue + | Return ('a word_lab) + | Exception ('a word) + | FinalFFI final_event +End + +val s = ``(s:('a,'ffi) crepSem$state)`` + +Definition mem_load_def: + mem_load (addr:'a word) ^s = + if addr IN s.memaddrs + then SOME (s.memory addr) else NONE +End + + +Definition set_var_def: + set_var v w ^s = + (s with locals := s.locals |+ (v,w)) +End + +(* gv: global variable *) +Definition set_globals_def: + set_globals gv w ^s = + (s with globals := s.globals |+ (gv,w)) +End + +Definition upd_locals_def: + upd_locals varargs ^s = + s with <| locals := FEMPTY |++ varargs |> +End + +Definition empty_locals_def: + empty_locals ^s = + s with <| locals := FEMPTY |> +End + +Definition lookup_code_def: + lookup_code code fname args len = + case (FLOOKUP code fname) of + | SOME (ns, prog) => + if LENGTH ns = LENGTH args ∧ ALL_DISTINCT ns + then SOME (prog, FEMPTY |++ ZIP (ns,args)) else NONE + | _ => NONE +End + +Definition eval_def: + (eval (s:('a,'ffi) crepSem$state) ((Const w):'a crepLang$exp) = SOME (Word w)) ∧ + (eval s (Var v) = FLOOKUP s.locals v) ∧ + (eval s (Label fname) = + case FLOOKUP s.code fname of + | SOME _ => SOME (Label fname) + | _ => NONE) /\ + (eval s (Load addr) = + case eval s addr of + | SOME (Word w) => mem_load w s + | _ => NONE) /\ + (eval s (LoadByte addr) = + case eval s addr of + | SOME (Word w) => + (case mem_load_byte s.memory s.memaddrs s.be w of + | NONE => NONE + | SOME w => SOME (Word (w2w w))) + | _ => NONE) /\ + (eval s (LoadGlob gadr) = FLOOKUP (s.globals) gadr) ∧ + (eval s (Op op es) = + case (OPT_MMAP (eval s) es) of + | SOME ws => + if (EVERY (\w. case w of (Word _) => T | _ => F) ws) + then OPTION_MAP Word + (word_op op (MAP (\w. case w of Word n => n) ws)) else NONE + | _ => NONE) /\ + (eval s (Cmp cmp e1 e2) = + case (eval s e1, eval s e2) of + | (SOME (Word w1), SOME (Word w2)) => SOME (Word (v2w [word_cmp cmp w1 w2])) + | _ => NONE) /\ + (eval s (Shift sh e n) = + case eval s e of + | SOME (Word w) => OPTION_MAP Word (word_sh sh w n) + | _ => NONE) +Termination + wf_rel_tac `measure (exp_size ARB o SND)` + \\ rpt strip_tac \\ imp_res_tac MEM_IMP_exp_size + \\ TRY (first_x_assum (assume_tac o Q.SPEC `ARB`)) + \\ decide_tac +End + +Definition dec_clock_def: + dec_clock ^s = + s with clock := s.clock - 1 +End + +Definition fix_clock_def: + fix_clock old_s (res, new_s) = + (res, new_s with <|clock := if old_s.clock < new_s.clock then old_s.clock else new_s.clock |>) +End + +Theorem fix_clock_IMP_LESS_EQ: + !x. fix_clock ^s x = (res,s1) ==> s1.clock <= s.clock +Proof + full_simp_tac(srw_ss())[fix_clock_def,FORALL_PROD] >> + srw_tac[][] >> full_simp_tac(srw_ss())[] >> decide_tac +QED + + +Definition res_var_def: + (res_var lc (n, NONE) = lc \\ n) /\ + (res_var lc (n, SOME v) = lc |+ (n,v)) +End + +Definition evaluate_def: + (evaluate (Skip:'a crepLang$prog,^s) = (NONE,s)) /\ + (evaluate (Dec v e prog, s) = + case (eval s e) of + | SOME value => + let (res,st) = evaluate (prog,s with locals := s.locals |+ (v,value)) in + (res, st with locals := res_var st.locals (v, FLOOKUP s.locals v)) + | NONE => (SOME Error, s)) ∧ + (evaluate (Assign v src,s) = + case (eval s src) of + | NONE => (SOME Error, s) + | SOME w => + case FLOOKUP s.locals v of + | SOME _ => (NONE, s with locals := s.locals |+ (v,w)) + | _ => (SOME Error, s)) /\ + (evaluate (Store dst src,s) = + case (eval s dst, eval s src) of + | (SOME (Word adr), SOME w) => + (case mem_store adr w s.memaddrs s.memory of + | SOME m => (NONE, s with memory := m) + | NONE => (SOME Error, s)) + | _ => (SOME Error, s)) /\ + (evaluate (StoreByte dst src,s) = + case (eval s dst, eval s src) of + | (SOME (Word adr), SOME (Word w)) => + (case mem_store_byte s.memory s.memaddrs s.be adr (w2w w) of + | SOME m => (NONE, s with memory := m) + | NONE => (SOME Error, s)) + | _ => (SOME Error, s)) /\ + (evaluate (StoreGlob dst src,s) = + case eval s src of + | SOME w => (NONE, set_globals dst w s) + | _ => (SOME Error, s)) /\ + (evaluate (Seq c1 c2,s) = + let (res,s1) = fix_clock s (evaluate (c1,s)) in + if res = NONE then evaluate (c2,s1) else (res,s1)) /\ + (evaluate (If e c1 c2,s) = + case (eval s e) of + | SOME (Word w) => + evaluate (if w <> 0w then c1 else c2, s) (* False is 0, True is everything else *) + | _ => (SOME Error,s)) /\ + (evaluate (Break,s) = (SOME Break,s)) /\ + (evaluate (Continue,s) = (SOME Continue,s)) /\ + (evaluate (While e c,s) = + case (eval s e) of + | SOME (Word w) => + if (w <> 0w) then + (if s.clock = 0 then (SOME TimeOut,empty_locals s) else + let (res,s1) = fix_clock (dec_clock s) (evaluate (c,dec_clock s)) in + case res of + | SOME Continue => evaluate (While e c,s1) + | NONE => evaluate (While e c,s1) + | SOME Break => (NONE,s1) + | _ => (res,s1)) + else (NONE,s) + | _ => (SOME Error,s)) /\ + (evaluate (Return e,s) = + case (eval s e) of + | SOME w => (SOME (Return w),empty_locals s) + | _ => (SOME Error,s)) /\ + (evaluate (Raise eid,s) = (SOME (Exception eid), empty_locals s)) /\ + (evaluate (Tick,s) = + if s.clock = 0 then (SOME TimeOut,empty_locals s) + else (NONE,dec_clock s)) /\ + (evaluate (Call caltyp trgt argexps,s) = + case (eval s trgt, OPT_MMAP (eval s) argexps) of + | (SOME (Label fname), SOME args) => + (case lookup_code s.code fname args (LENGTH args) of + | SOME (prog, newlocals) => if s.clock = 0 then (SOME TimeOut,empty_locals s) else + let eval_prog = fix_clock ((dec_clock s) with locals:= newlocals) + (evaluate (prog, (dec_clock s) with locals:= newlocals)) in + (case eval_prog of + | (NONE,st) => (SOME Error,st) + | (SOME Break,st) => (SOME Error,st) + | (SOME Continue,st) => (SOME Error,st) + | (SOME (Return retv),st) => + (case caltyp of + | Tail => (SOME (Return retv),empty_locals st) + | Ret NONE p _ => evaluate (p, st with locals := s.locals) + | Ret (SOME rt) p _ => + (case FLOOKUP s.locals rt of + | SOME _ => evaluate (p, st with locals := s.locals |+ (rt,retv)) + | _ => (SOME Error, st))) + | (SOME (Exception eid),st) => + (case caltyp of + | Tail => (SOME (Exception eid),empty_locals st) + | Ret _ _ NONE => (SOME (Exception eid),empty_locals st) + | Ret _ _ (SOME (Handle eid' p)) => + if eid = eid' then + evaluate (p, st with locals := s.locals) + else (SOME (Exception eid), empty_locals st)) + | (res,st) => (res,empty_locals st)) + | _ => (SOME Error,s)) + | (_, _) => (SOME Error,s)) /\ + (evaluate (ExtCall ffi_index ptr1 len1 ptr2 len2,s) = + case (FLOOKUP s.locals len1, FLOOKUP s.locals ptr1, FLOOKUP s.locals len2, FLOOKUP s.locals ptr2) of + | SOME (Word w),SOME (Word w2),SOME (Word w3),SOME (Word w4) => + (case (read_bytearray w2 (w2n w) (mem_load_byte s.memory s.memaddrs s.be), + read_bytearray w4 (w2n w3) (mem_load_byte s.memory s.memaddrs s.be)) of + | SOME bytes,SOME bytes2 => + (case call_FFI s.ffi (explode ffi_index) bytes bytes2 of + | FFI_final outcome => (SOME (FinalFFI outcome),s) + | FFI_return new_ffi new_bytes => + let nmem = write_bytearray w4 new_bytes s.memory s.memaddrs s.be in + (NONE, s with <| memory := nmem; ffi := new_ffi |>)) + | _ => (SOME Error,s)) + | res => (SOME Error,s)) +Termination + wf_rel_tac `(inv_image (measure I LEX measure (prog_size (K 0))) + (\(xs,^s). (s.clock,xs)))` >> + rpt strip_tac >> TRY (full_simp_tac(srw_ss())[] >> DECIDE_TAC) >> + imp_res_tac fix_clock_IMP_LESS_EQ >> full_simp_tac(srw_ss())[] >> + imp_res_tac (GSYM fix_clock_IMP_LESS_EQ) >> + full_simp_tac(srw_ss())[set_var_def,set_globals_def,upd_locals_def,dec_clock_def, LET_THM] >> + rpt (pairarg_tac >> full_simp_tac(srw_ss())[]) >> + every_case_tac >> full_simp_tac(srw_ss())[] >> + decide_tac +End + + +Theorem evaluate_clock: + !prog s r s'. (evaluate (prog,s) = (r,s')) ==> + s'.clock <= s.clock +Proof + recInduct evaluate_ind >> REPEAT STRIP_TAC >> + POP_ASSUM MP_TAC >> ONCE_REWRITE_TAC [evaluate_def] >> + rw [] >> every_case_tac >> + fs [set_var_def, dec_clock_def, set_globals_def, empty_locals_def, LET_THM] >> + rveq >> fs [] >> + rpt (pairarg_tac >> fs []) >> + every_case_tac >> fs [] >> rveq >> + imp_res_tac fix_clock_IMP_LESS_EQ >> + imp_res_tac LESS_EQ_TRANS >> fs [] >> + rpt (res_tac >> fs []) +QED + +val fix_clock_evaluate = Q.prove( + `fix_clock s (evaluate (prog,s)) = evaluate (prog,s)`, + Cases_on `evaluate (prog,s)` \\ fs [fix_clock_def] + \\ imp_res_tac evaluate_clock \\ fs [GSYM NOT_LESS, state_component_equality]); + +val evaluate_ind = save_thm("evaluate_ind", + REWRITE_RULE [fix_clock_evaluate] evaluate_ind); + +val evaluate_def = save_thm("evaluate_def[compute]", + REWRITE_RULE [fix_clock_evaluate] evaluate_def); + +(* observational semantics *) + +Definition semantics_def: + semantics ^s start = + let prog = Call Tail (Label start) [] in + if ∃k. case FST (evaluate (prog,s with clock := k)) of + | SOME TimeOut => F + | SOME (FinalFFI _) => F + | SOME (Return _) => F + | _ => T + then Fail + else + case some res. + ∃k t r outcome. + evaluate (prog, s with clock := k) = (r,t) ∧ + (case r of + | (SOME (FinalFFI e)) => outcome = FFI_outcome e + | (SOME (Return _)) => outcome = Success + | _ => F) ∧ + res = Terminate outcome t.ffi.io_events + of + | SOME res => res + | NONE => + Diverge + (build_lprefix_lub + (IMAGE (λk. fromList + (SND (evaluate (prog,s with clock := k))).ffi.io_events) UNIV)) +End + +val _ = map delete_binding ["evaluate_AUX_def", "evaluate_primitive_def"]; + +val _ = export_theory(); diff --git a/pancake/semantics/loopPropsScript.sml b/pancake/semantics/loopPropsScript.sml new file mode 100644 index 0000000000..2564be2f61 --- /dev/null +++ b/pancake/semantics/loopPropsScript.sml @@ -0,0 +1,1321 @@ +(* + Properties of loopLang and loopSem +*) +open preamble + loopLangTheory loopSemTheory + pan_commonTheory pan_commonPropsTheory; + +local open wordSemTheory in end; + +val _ = new_theory"loopProps"; + +val _ = set_grammar_ancestry ["loopSem", "pan_commonProps"]; + + +Definition every_prog_def: + (every_prog p (Seq p1 p2) <=> + p (Seq p1 p2) /\ every_prog p p1 /\ every_prog p p2) /\ + (every_prog p (Loop l1 body l2) <=> + p (Loop l1 body l2) /\ every_prog p body) /\ + (every_prog p (If x1 x2 x3 p1 p2 l1) <=> + p (If x1 x2 x3 p1 p2 l1) /\ every_prog p p1 /\ every_prog p p2) /\ + (every_prog p (Mark p1) <=> + p (Mark p1) /\ every_prog p p1) /\ + (every_prog p (Call ret dest args handler) <=> + p (Call ret dest args handler) /\ + (case handler of SOME (n,q,r,l) => every_prog p q ∧ every_prog p r | NONE => T)) /\ + (every_prog p prog <=> p prog) +End +Definition no_Loop_def: + no_Loop = every_prog (\q. !l1 x l2. q <> Loop l1 x l2) +End + +Definition no_Loops_def: + no_Loops p ⇔ no_Loop p ∧ every_prog (\r. r ≠ Break ∧ r ≠ Continue) p +End + +Definition syntax_ok_def: (* syntax expected by loop_remove *) + (syntax_ok (Seq p1 p2) <=> + ~(no_Loop (Seq p1 p2)) ∧ syntax_ok p1 /\ syntax_ok p2) /\ + (syntax_ok (Loop l1 body l2) <=> + syntax_ok body) /\ + (syntax_ok (If x1 x2 x3 p1 p2 l1) <=> + ~(no_Loop (If x1 x2 x3 p1 p2 l1)) ∧ syntax_ok p1 /\ syntax_ok p2) /\ + (syntax_ok (Mark p1) <=> + no_Loop p1) /\ + (syntax_ok (Call ret dest args handler) <=> + ~(no_Loop (Call ret dest args handler)) ∧ + (case handler of SOME (n,q,r,l) => syntax_ok q ∧ syntax_ok r | NONE => F)) /\ + (syntax_ok prog <=> F) +End + +Definition survives_def: + (survives n (If c r ri p q cs) <=> + survives n p ∧ survives n q ∧ n ∈ domain cs) ∧ + (survives n (Loop il p ol) <=> + n ∈ domain il ∧ n ∈ domain ol ∧ survives n p) ∧ + (survives n (Call (SOME (m,cs)) trgt args NONE) <=> + n ∈ domain cs) ∧ + (survives n (Call (SOME (m,cs)) trgt args (SOME (r,p,q,ps))) <=> + n ∈ domain cs ∧ n ∈ domain ps ∧ survives n p ∧ survives n q) ∧ + (survives n (FFI fi ptr1 len1 ptr2 len2 cs) <=> n ∈ domain cs) ∧ + (survives n (Mark p) <=> survives n p) ∧ + (survives n (Seq p q) <=> survives n p ∧ survives n q) ∧ + (survives n p <=> T) +End + + +Definition cut_sets_def: + (cut_sets l Skip = l) ∧ + (cut_sets l (LocValue n m) = insert n () l) ∧ + (cut_sets l (Assign n e) = insert n () l) ∧ + (cut_sets l (LoadByte n m) = insert m () l) ∧ + (cut_sets l (Seq p q) = cut_sets (cut_sets l p) q) ∧ + (cut_sets l (If _ _ _ p q nl) = nl) ∧ + (cut_sets l _ = l) +End + +Definition comp_syntax_ok_def: + (comp_syntax_ok l loopLang$Skip = T) ∧ + (comp_syntax_ok l (Assign n e) = T) ∧ + (comp_syntax_ok l (LocValue n m) = T) ∧ + (comp_syntax_ok l (LoadByte n m) = T) ∧ + (comp_syntax_ok l (Seq p q) = (comp_syntax_ok l p ∧ comp_syntax_ok (cut_sets l p) q)) ∧ + (comp_syntax_ok l (If c n r p q nl) = + (∃m v v'. r = Reg m ∧ p = Assign n v ∧ q = Assign n v' ∧ nl = list_insert [n; m] l)) ∧ + (comp_syntax_ok _ _ = F) +End + +Theorem evaluate_tail_calls_eqs: + !f t lc x. find_code (SOME f) ([]:'a word_loc list) t.code = SOME x ==> + evaluate ((Call NONE (SOME f) [] NONE): 'a loopLang$prog, t) = + evaluate (Call NONE (SOME f) [] NONE, t with locals := lc) +Proof + rw [] >> + fs [evaluate_def] >> + TOP_CASE_TAC >> fs [get_vars_def] >> rveq >> + fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + fs [dec_clock_def] +QED + +Theorem acc_vars_acc: + ∀p l. + domain (acc_vars p l) = domain (acc_vars p LN) ∪ domain l +Proof + qsuff_tac ‘∀p (l:num_set) l. + domain (acc_vars p l) = domain (acc_vars p LN) UNION domain l’ + >- metis_tac [] >> + ho_match_mp_tac acc_vars_ind >> rw [] >> fs [] >> + ntac 4 (once_asm_rewrite_tac [acc_vars_def]) >> + simp_tac (srw_ss()) [domain_def,AC UNION_COMM UNION_ASSOC,domain_union, + domain_insert,LET_THM] >> + every_case_tac >> + simp_tac (srw_ss()) [domain_def,AC UNION_COMM UNION_ASSOC,domain_union, + domain_insert,LET_THM] >> + once_rewrite_tac [INSERT_SING_UNION] >> + simp_tac (srw_ss()) [domain_def,AC UNION_COMM UNION_ASSOC,domain_union, + domain_insert,LET_THM] >> + rpt (pop_assum (fn th => mp_tac (SIMP_RULE std_ss [] th))) >> + rewrite_tac [AND_IMP_INTRO] >> + disch_then (fn th => ntac 6 (once_rewrite_tac [th])) >> + simp_tac (srw_ss()) [domain_def,AC UNION_COMM UNION_ASSOC,domain_union, + domain_insert,LET_THM] >> fs [EXTENSION] >> metis_tac [] +QED + +Theorem evaluate_Loop_body_same: + (∀(s:('a,'b)state). evaluate (body,s) = evaluate (body',s)) ⇒ + ∀(s:('a,'b)state). evaluate (Loop l1 body l2,s) = evaluate (Loop l1 body' l2,s) +Proof + rw [] \\ completeInduct_on ‘s.clock’ + \\ rw [] \\ fs [PULL_EXISTS,PULL_FORALL] + \\ once_rewrite_tac [evaluate_def] + \\ TOP_CASE_TAC \\ fs [] + \\ TOP_CASE_TAC \\ fs [] + \\ TOP_CASE_TAC \\ fs [] + \\ TOP_CASE_TAC \\ fs [] + \\ TOP_CASE_TAC \\ fs [] + \\ first_x_assum match_mp_tac + \\ fs [cut_res_def,CaseEq"option",CaseEq"bool",cut_state_def] + \\ rveq \\ fs [dec_clock_def] + \\ imp_res_tac evaluate_clock \\ fs [dec_clock_def] +QED + +Theorem evaluate_no_Break_Continue: + ∀prog s res t. + evaluate (prog, s) = (res,t) ∧ + every_prog (\r. r ≠ Break ∧ r ≠ Continue) prog ⇒ + res ≠ SOME Break ∧ res ≠ SOME Continue +Proof + recInduct evaluate_ind \\ fs [] \\ rpt conj_tac \\ rpt gen_tac \\ strip_tac + \\ (rename [‘Loop’] ORELSE + (fs [evaluate_def,CaseEq"option",CaseEq"word_loc",CaseEq"bool",CaseEq"ffi_result"] + \\ rveq \\ fs [])) + \\ rpt gen_tac \\ TRY strip_tac + \\ rpt (pairarg_tac \\ fs []) + \\ fs [every_prog_def] + \\ fs [CaseEq"bool"] \\ rveq \\ fs [] + THEN1 + (Cases_on ‘word_cmp cmp x y’ \\ fs [] + \\ rename [‘evaluate (xx,s)’] \\ Cases_on ‘evaluate (xx,s)’ \\ fs [] + \\ Cases_on ‘x’ \\ fs [cut_res_def,CaseEq"option",CaseEq"bool"] \\ rveq \\ fs []) + THEN1 + (qpat_x_assum ‘evaluate _ = _’ mp_tac + \\ once_rewrite_tac [evaluate_def] + \\ TOP_CASE_TAC \\ fs [] + \\ reverse TOP_CASE_TAC \\ fs [] + \\ fs [cut_res_def,CaseEq"option",CaseEq"bool",cut_state_def] \\ rveq \\ fs [] + \\ rw [] \\ fs [CaseEq"option",CaseEq"bool",CaseEq"prod",CaseEq"result"] + \\ rveq \\ fs []) + \\ fs [CaseEq"prod",CaseEq"option"] \\ rveq \\ fs [] + THEN1 + (fs [CaseEq"bool"] \\ rveq \\ fs [] + \\ fs [CaseEq"bool",CaseEq"prod",CaseEq"result",CaseEq"option"] \\ rveq \\ fs []) + \\ fs [CaseEq"bool",CaseEq"prod",CaseEq"result",CaseEq"option",cut_res_def] + \\ rveq \\ fs [] \\ rename [‘cut_res _ xx’] \\ Cases_on ‘xx’ \\ fs [] + \\ fs [CaseEq"bool",CaseEq"prod",CaseEq"result",CaseEq"option",cut_res_def] + \\ rveq \\ fs [] +QED + + +Theorem locals_touched_eq_eval_eq: + !s e t. + s.globals = t.globals /\ s.memory = t.memory /\ s.mdomain = t.mdomain /\ + (!n. MEM n (locals_touched e) ==> lookup n s.locals = lookup n t.locals) ==> + eval t e = eval s e +Proof + ho_match_mp_tac eval_ind >> rw [] + >- fs [eval_def] + >- fs [eval_def, locals_touched_def] + >- fs [eval_def, locals_touched_def] + >- ( + fs [eval_def, locals_touched_def] >> + every_case_tac >> fs [mem_load_def]) + >- ( + fs [eval_def, locals_touched_def] >> + every_case_tac >> fs [] + >- ( + ‘the_words (MAP (λa. eval t a) wexps) = SOME x’ suffices_by fs [] >> + pop_assum mp_tac >> pop_assum kall_tac >> + rpt (pop_assum mp_tac) >> + MAP_EVERY qid_spec_tac [‘x’, ‘t’, ‘s’, ‘wexps’] >> + Induct >> rw [] >> + fs [wordSemTheory.the_words_def, + CaseEq "option", CaseEq "word_loc"] >> rveq >> fs [] >> + last_x_assum (qspecl_then [‘s’, ‘t’, ‘xs’] mp_tac) >> fs []) + >- ( + ‘the_words (MAP (λa. eval s a) wexps) = SOME x’ suffices_by fs [] >> + pop_assum kall_tac >> + rpt (pop_assum mp_tac) >> + MAP_EVERY qid_spec_tac [‘x’, ‘t’, ‘s’, ‘wexps’] >> + Induct >> rw [] >> + fs [wordSemTheory.the_words_def, + CaseEq "option", CaseEq "word_loc"] >> rveq >> fs [] >> + last_x_assum (qspecl_then [‘s’, ‘t’, ‘xs’] mp_tac) >> fs []) >> + ‘x = x'’ suffices_by fs [] >> + rpt (pop_assum mp_tac) >> + MAP_EVERY qid_spec_tac [‘x'’, ‘x’, ‘t’, ‘s’, ‘wexps’] >> + Induct >> rw [] >> + fs [wordSemTheory.the_words_def, + CaseEq "option", CaseEq "word_loc"] >> rveq >> fs [] >> + last_x_assum (qspecl_then [‘s’, ‘t’, ‘xs’] mp_tac) >> fs []) >> + fs [eval_def, locals_touched_def] +QED + +Theorem loop_eval_nested_assign_distinct_eq: + !es ns t ev. + MAP (eval t) es = MAP SOME ev /\ + distinct_lists ns (FLAT (MAP locals_touched es)) /\ + ALL_DISTINCT ns /\ + LENGTH ns = LENGTH es ==> + evaluate (nested_seq (MAP2 Assign ns es),t) = + (NONE, t with locals := (alist_insert ns ev t.locals)) +Proof + Induct + >- ( + rpt gen_tac >> strip_tac >> + cases_on ‘ns’ >> fs [] >> + fs [nested_seq_def, evaluate_def, + alist_insert_def, + state_component_equality]) >> + rpt gen_tac >> + strip_tac >> + cases_on ‘ns’ >> + fs [nested_seq_def] >> + fs [evaluate_def] >> + pairarg_tac >> fs [] >> + fs [MAP_EQ_CONS] >> + rveq >> rfs [] >> + fs [OPT_MMAP_def] >> + rveq >> rfs [] >> + rveq >> + rename [‘eval t e = SOME v’] >> + rename [‘MAP (eval t) es = MAP SOME ev’] >> + fs [alist_insert_def] >> + ‘MAP (eval (set_var h' v t)) es = MAP SOME ev’ by ( + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + first_x_assum (qspec_then ‘n’ assume_tac) >> + rfs [] >> + ‘eval (set_var h' v t) (EL n es) = eval t (EL n es)’ + suffices_by fs [] >> + match_mp_tac locals_touched_eq_eval_eq >> + fs [set_var_def] >> + rw [] >> + fs [distinct_lists_def, lookup_insert] >> + TOP_CASE_TAC >> fs [] >> rveq >> + metis_tac [MEM_FLAT, EL_MEM, MEM_MAP]) >> + fs [] >> + last_x_assum drule >> + disch_then (qspec_then ‘t'’ mp_tac) >> + fs [] >> + impl_tac + >- ( + ho_match_mp_tac (GEN_ALL distinct_lists_cons) >> + qexists_tac ‘locals_touched e’ >> + qexists_tac ‘[h']’ >> + fs []) >> + strip_tac >> + fs [set_var_def] >> + drule (INST_TYPE [``:'a``|->``:'a word_loc``] + alist_insert_pull_insert) >> + disch_then (qspecl_then [‘v’, ‘ev’, ‘t.locals’] mp_tac) >> + fs [] +QED + +Theorem get_var_imm_add_clk_eq: + get_var_imm ri (s with clock := ck) = + get_var_imm ri s +Proof + rw [] >> + cases_on ‘ri’ >> fs [get_var_imm_def] +QED + + +Theorem get_vars_local_clock_upd_eq: + !ns st l ck. + get_vars ns (st with <|locals := l; clock := ck|>) = + get_vars ns (st with locals := l) +Proof + Induct >> rw [] >> + fs [get_vars_def] +QED + +Theorem get_vars_clock_upd_eq: + !ns st l ck. + get_vars ns (st with clock := ck) = + get_vars ns st +Proof + Induct >> rw [] >> + fs [get_vars_def] +QED + + +Theorem get_vars_local_update_some_eq: + !ns vs st. + ALL_DISTINCT ns /\ LENGTH ns = LENGTH vs ==> + get_vars ns (st with locals := alist_insert ns vs st.locals) = SOME vs +Proof + Induct >> rw [] >> + fs [get_vars_def] >> + cases_on ‘vs’ >> + fs [alist_insert_def] >> + first_x_assum (qspecl_then + [‘t’, ‘st with locals := insert h h' st.locals’] mp_tac) >> + fs [] >> strip_tac >> + qsuff_tac ‘alist_insert ns t (insert h h' st.locals) = + insert h h' (alist_insert ns t st.locals)’ + >- (strip_tac >> fs []) >> + ho_match_mp_tac alist_insert_pull_insert >> + fs [] +QED + + +Theorem unassigned_vars_evaluate_same: + !p s res t n v. + evaluate (p,s) = (res,t) /\ + (res = NONE ∨ res = SOME Continue ∨ res = SOME Break) /\ + lookup n s.locals = SOME v /\ + ~MEM n (assigned_vars p) /\ survives n p ==> + lookup n t.locals = lookup n s.locals +Proof + recInduct evaluate_ind >> + rpt conj_tac >> rpt gen_tac >> + TRY ( + rename [‘Mark’] >> + rw [] >> + fs [Once evaluate_def, AllCaseEqs(), assigned_vars_def, + survives_def]) >> + TRY ( + rename [‘FFI’] >> + rw [] >> + fs [Once evaluate_def,AllCaseEqs(), assigned_vars_def, survives_def] >> + rveq >> fs [cut_state_def] >> rveq >> + fs [lookup_inter,AllCaseEqs(), domain_lookup]) >> + TRY ( + rename [‘Seq’] >> + rw [] >> + fs [Once evaluate_def,AllCaseEqs(), assigned_vars_def, + survives_def] >> + pairarg_tac >> fs [AllCaseEqs()] >> rveq >> + res_tac >> fs []) >> + TRY ( + rename [‘If’] >> + rw [] >> + fs [Once evaluate_def, AllCaseEqs(), assigned_vars_def, + survives_def] >> rveq >> + FULL_CASE_TAC >> fs [] >> + rename [‘cut_res _ (evaluate (c1,s))’] >> + cases_on ‘evaluate (c1,s)’ >> fs [] >> + cases_on ‘q’ >> fs [cut_res_def, AllCaseEqs(), dec_clock_def, cut_state_def] >> + rveq >> fs [lookup_inter, AllCaseEqs()] >> + res_tac >> rfs [domain_lookup]) >> + TRY ( + rename [‘Loop’] >> + rpt strip_tac >> + qpat_x_assum ‘evaluate (Loop _ _ _,_) = _’ mp_tac >> + once_rewrite_tac [evaluate_def] >> + rewrite_tac [cut_res_def, cut_state_def, dec_clock_def] >> + reverse (cases_on ‘domain live_in ⊆ domain s.locals’) + >- rw [] >> + rw [] >> + FULL_CASE_TAC >> + cases_on ‘q’ >> fs [] >> + fs [Once cut_res_def, cut_state_def] >> + fs [survives_def, assigned_vars_def, dec_clock_def] >> + fs [AllCaseEqs()] >> rveq >> fs [] >> + res_tac >> rfs [lookup_inter, AllCaseEqs(), domain_lookup]) >> + TRY ( + rename [‘Call’] >> + rpt strip_tac + >- ( + (* NONE result *) + qpat_x_assum ‘evaluate (Call _ _ _ _,_) = _’ mp_tac >> + once_rewrite_tac [evaluate_def] >> + rpt TOP_CASE_TAC + >- ( + strip_tac >> + rfs [] >> rveq >> + fs [assigned_vars_def, survives_def, set_var_def, cut_res_def, + dec_clock_def, cut_state_def, AllCaseEqs(), lookup_insert] >> + rveq >> fs [lookup_inter, AllCaseEqs(), domain_lookup]) + >- ( + pop_assum kall_tac >> + pop_assum mp_tac >> + pop_assum kall_tac >> + strip_tac >> + rfs [] >> rveq >> + fs [assigned_vars_def, survives_def, set_var_def, cut_res_def, + dec_clock_def, cut_state_def, AllCaseEqs(), lookup_insert] >> + rveq >> fs [lookup_inter, AllCaseEqs(), domain_lookup] >> + qmatch_goalsub_abbrev_tac ‘cut_res nr (evaluate (rq,ar)) = _’ >> + cases_on ‘evaluate (rq, ar)’ >> + qmatch_asmsub_rename_tac ‘ evaluate _ = (tq,tr)’ >> + strip_tac >> cases_on ‘tq’ >> + fs [cut_res_def, cut_state_def, dec_clock_def, + AllCaseEqs()] >> rveq >> + fs [] >> + unabbrev_all_tac >> fs [] >> + qsuff_tac ‘lookup n tr.locals = SOME v’ + >- (strip_tac >> fs [lookup_inter]) >> + first_x_assum match_mp_tac >> + fs []) >> + pop_assum mp_tac >> + pop_assum kall_tac >> + pop_assum kall_tac >> + strip_tac >> + rfs [] >> rveq >> + fs [assigned_vars_def, survives_def, set_var_def, cut_res_def, + dec_clock_def, cut_state_def, AllCaseEqs(), lookup_insert] >> + rveq >> fs [lookup_inter, AllCaseEqs(), domain_lookup] >> + qmatch_goalsub_abbrev_tac ‘cut_res nr (evaluate (rq,ar)) = _’ >> + cases_on ‘evaluate (rq, ar)’ >> + qmatch_asmsub_rename_tac ‘ evaluate _ = (tq,tr)’ >> + strip_tac >> cases_on ‘tq’ >> + fs [cut_res_def, cut_state_def, dec_clock_def, + AllCaseEqs()] >> rveq >> + fs [] >> + unabbrev_all_tac >> fs [] >> + qsuff_tac ‘lookup n tr.locals = SOME v’ + >- (strip_tac >> fs [lookup_inter]) >> + first_x_assum match_mp_tac >> + fs []) >> + (* non-NONE result *) + (qpat_x_assum ‘evaluate (Call _ _ _ _,_) = _’ mp_tac >> + once_rewrite_tac [evaluate_def] >> + rpt TOP_CASE_TAC + >- ( + pop_assum kall_tac >> + pop_assum mp_tac >> + pop_assum kall_tac >> + strip_tac >> + rfs [] >> rveq >> + fs [assigned_vars_def, survives_def, set_var_def, cut_res_def, + dec_clock_def, cut_state_def, AllCaseEqs(), lookup_insert] >> + rveq >> fs [lookup_inter, AllCaseEqs(), domain_lookup] >> + qmatch_goalsub_abbrev_tac ‘cut_res nr (evaluate (rq,ar)) = _’ >> + cases_on ‘evaluate (rq, ar)’ >> + qmatch_asmsub_rename_tac ‘ evaluate _ = (tq,tr)’ >> + strip_tac >> cases_on ‘tq’ >> + fs [cut_res_def, cut_state_def, dec_clock_def, + AllCaseEqs()]) >> + pop_assum mp_tac >> + pop_assum kall_tac >> + pop_assum kall_tac >> + strip_tac >> + rfs [] >> rveq >> + fs [assigned_vars_def, survives_def, set_var_def, cut_res_def, + dec_clock_def, cut_state_def, AllCaseEqs(), lookup_insert] >> + rveq >> fs [lookup_inter, AllCaseEqs(), domain_lookup] >> + qmatch_goalsub_abbrev_tac ‘cut_res nr (evaluate (rq,ar)) = _’ >> + cases_on ‘evaluate (rq, ar)’ >> + qmatch_asmsub_rename_tac ‘ evaluate _ = (tq,tr)’ >> + strip_tac >> cases_on ‘tq’ >> + fs [cut_res_def, cut_state_def, dec_clock_def, + AllCaseEqs()])) >> + rw [] >> + fs [Once evaluate_def,AllCaseEqs(), set_var_def, set_globals_def, + dec_clock_def, assigned_vars_def, survives_def] >> + rveq >> fs [lookup_insert, mem_store_def, AllCaseEqs()] >> + rveq >> fs [state_component_equality] +QED + + +Theorem evaluate_nested_seq_cases: + (!p q s st t. + evaluate (nested_seq (p ++ q), s) = (NONE, t) /\ + evaluate (nested_seq p,s) = (NONE,st) ==> + evaluate (nested_seq q,st) = (NONE,t)) /\ + (!p s st q. + evaluate (nested_seq p, s) = (NONE, st) ==> + evaluate (nested_seq (p ++ q), s) = evaluate (nested_seq q, st)) /\ + (!p s res st q. + evaluate (nested_seq p, s) = (res, st) /\ + res <> NONE ==> + evaluate (nested_seq (p ++ q), s) = evaluate (nested_seq p, s)) +Proof + rpt conj_tac >> + Induct >> rw [] + >- fs [nested_seq_def, evaluate_def] >> + fs [nested_seq_def, evaluate_def] >> + pairarg_tac >> fs [] >> + FULL_CASE_TAC >> fs [] >> + res_tac >> fs [] +QED + + +Theorem survives_nested_seq_intro: + !p q n. + survives n (nested_seq p) /\ + survives n (nested_seq q) ==> + survives n (nested_seq (p ++ q)) +Proof + Induct >> rw [] >> + fs [nested_seq_def, survives_def] +QED + +Theorem nested_assigns_survives: + !xs ys n. + LENGTH xs = LENGTH ys ==> + survives n (nested_seq (MAP2 Assign xs ys)) +Proof + Induct >> rw [] >> + TRY (cases_on ‘ys’) >> + fs [nested_seq_def, survives_def] +QED + + + +(* from here *) +Theorem comp_syn_ok_basic_cases: + (!l. comp_syntax_ok l Skip) /\ + (!l n m. comp_syntax_ok l (LocValue n m)) /\ + (!l n e. comp_syntax_ok l (Assign n e)) /\ + (!l n m. comp_syntax_ok l (LoadByte n m)) /\ + (!l c n m v v'. comp_syntax_ok l (If c n (Reg m) + (Assign n v) (Assign n v') (list_insert [n; m] l))) +Proof + rw [] >> + ntac 3 (fs [Once comp_syntax_ok_def]) +QED + + +Theorem comp_syn_ok_seq: + !l p q. comp_syntax_ok l (Seq p q) ==> + comp_syntax_ok l p /\ comp_syntax_ok (cut_sets l p) q +Proof + rw [] >> + fs [Once comp_syntax_ok_def] +QED + + +Theorem comp_syn_ok_if: + comp_syntax_ok l (If cmp n ri p q ns) ==> + ?v v' m. ri = Reg m /\ p = Assign n v /\ + q = Assign n v' /\ ns = list_insert [n; m] l +Proof + rw [] >> + fs [Once comp_syntax_ok_def] +QED + + +Theorem comp_syn_ok_seq2: + !l p q. comp_syntax_ok l p /\ comp_syntax_ok (cut_sets l p) q ==> + comp_syntax_ok l (Seq p q) +Proof + rw [] >> + once_rewrite_tac [comp_syntax_ok_def] >> + fs [] +QED + + +Theorem comp_syn_ok_nested_seq: + !p q l. comp_syntax_ok l (nested_seq p) ∧ + comp_syntax_ok (cut_sets l (nested_seq p)) (nested_seq q) ==> + comp_syntax_ok l (nested_seq (p ++ q)) +Proof + Induct >> rw [] >> + fs [nested_seq_def] >> + fs [cut_sets_def] >> + drule comp_syn_ok_seq >> + strip_tac >> res_tac >> fs [] >> + metis_tac [comp_syn_ok_seq2] +QED + +Theorem comp_syn_ok_nested_seq2: + !p q l. comp_syntax_ok l (nested_seq (p ++ q)) ==> + comp_syntax_ok l (nested_seq p) ∧ + comp_syntax_ok (cut_sets l (nested_seq p)) (nested_seq q) +Proof + Induct >> rw [] >> + fs [nested_seq_def, comp_syn_ok_basic_cases, cut_sets_def] >> + drule comp_syn_ok_seq >> strip_tac >> fs [] >> + metis_tac [comp_syn_ok_seq2] +QED + + +Theorem cut_sets_nested_seq: + !p q l. cut_sets l (nested_seq (p ++ q)) = + cut_sets (cut_sets l (nested_seq p)) (nested_seq q) +Proof + Induct >> rw [] >> + fs [nested_seq_def] + >- fs [cut_sets_def] >> + fs [cut_sets_def] +QED + + +Theorem cut_sets_union_accumulate: + !p l. comp_syntax_ok l p ==> (* need this assumption for the If case *) + ?(l' :sptree$num_set). cut_sets l p = union l l' +Proof + Induct >> rw [] >> + TRY (fs [Once comp_syntax_ok_def] >> NO_TAC) >> + fs [cut_sets_def] >> + TRY (qexists_tac ‘LN’ >> fs [] >> NO_TAC) >> + TRY ( + rename [‘insert vn () l’] >> + qexists_tac ‘insert vn () LN’ >> + fs [Once insert_union, union_num_set_sym] >> NO_TAC) + >- ( + drule comp_syn_ok_seq >> + strip_tac >> + last_x_assum drule >> + strip_tac >> fs [] >> + last_x_assum (qspec_then ‘union l l'’ mp_tac) >> + fs [] >> strip_tac >> + qexists_tac ‘union l' l''’ >> + fs [] >> metis_tac [union_assoc]) >> + drule comp_syn_ok_if >> + strip_tac >> rveq >> + qexists_tac ‘insert m () (insert n () LN)’ >> + fs [list_insert_def] >> + metis_tac [union_insert_LN, insert_union, union_num_set_sym, union_assoc] +QED + + +Theorem cut_sets_union_domain_subset: + !p l. comp_syntax_ok l p ==> + domain l ⊆ domain (cut_sets l p) +Proof + rw [] >> + drule cut_sets_union_accumulate >> + strip_tac >> fs [] >> + fs [domain_union] +QED + +Theorem cut_sets_union_domain_union: + !p l. comp_syntax_ok l p ==> + ?(l' :sptree$num_set). domain (cut_sets l p) = domain l ∪ domain l' +Proof + rw [] >> + drule cut_sets_union_accumulate >> + strip_tac >> fs [] >> + qexists_tac ‘l'’ >> + fs [domain_union] +QED + +Theorem comp_syn_impl_cut_sets_subspt: + !p l. comp_syntax_ok l p ==> + subspt l (cut_sets l p) +Proof + rw [] >> + drule cut_sets_union_accumulate >> + strip_tac >> + fs [subspt_union] +QED + +Theorem comp_syn_cut_sets_mem_domain: + !p l n . + comp_syntax_ok l p /\ n ∈ domain l ==> + n ∈ domain (cut_sets l p) +Proof + rw [] >> + drule cut_sets_union_domain_union >> + strip_tac >> fs [] +QED + + +Theorem comp_syn_ok_upd_local_clock: + !p s res t l. + evaluate (p,s) = (res,t) /\ + comp_syntax_ok l p ==> + t = s with <|locals := t.locals; clock := t.clock|> +Proof + recInduct evaluate_ind >> rw [] >> + TRY (fs [Once comp_syntax_ok_def, every_prog_def] >> NO_TAC) >> + TRY ( + fs [evaluate_def] >> rveq >> + TRY every_case_tac >> fs [set_var_def, state_component_equality] >> NO_TAC) + >- ( + drule comp_syn_ok_seq >> + strip_tac >> + fs [evaluate_def] >> + pairarg_tac >> fs [] >> + FULL_CASE_TAC >> fs [] >> rveq >> + res_tac >> fs [state_component_equality]) >> + drule comp_syn_ok_if >> + strip_tac >> rveq >> + fs [evaluate_def] >> + every_case_tac >> fs [] >> rveq >> + fs [state_component_equality, evaluate_def, comp_syn_ok_basic_cases] >> + every_case_tac >> + fs [cut_res_def, cut_state_def, dec_clock_def, set_var_def] >> + every_case_tac >> fs [] >> rveq >> fs [] +QED + + +Theorem assigned_vars_nested_seq_split: + !p q. + assigned_vars (nested_seq (p ++ q)) = + assigned_vars (nested_seq p) ++ assigned_vars (nested_seq q) +Proof + Induct >> rw [] >> + fs [nested_seq_def, assigned_vars_def] +QED + + +Theorem assigned_vars_seq_split: + !q p. assigned_vars (Seq p q) = + assigned_vars p ++ assigned_vars q +Proof + rw [] >> fs [assigned_vars_def, cut_sets_def] +QED + +Theorem assigned_vars_nested_assign: + !xs ys. + LENGTH xs = LENGTH ys ==> + assigned_vars (nested_seq (MAP2 Assign xs ys)) = xs +Proof + Induct >> rw [] >> + TRY (cases_on ‘ys’) >> + fs [nested_seq_def, assigned_vars_def] +QED + + +Theorem comp_syn_ok_lookup_locals_eq: + !p s res t l n. + evaluate (p,s) = (res,t) /\ res <> SOME TimeOut /\ + comp_syntax_ok l p /\ n ∈ domain l /\ + ~MEM n (assigned_vars p) ==> + lookup n t.locals = lookup n s.locals +Proof + recInduct evaluate_ind >> rw [] >> + TRY (fs [Once comp_syntax_ok_def, every_prog_def] >> NO_TAC) >> + TRY ( + fs [evaluate_def] >> + every_case_tac >> fs [] >> rveq >> + fs [set_var_def, assigned_vars_def, lookup_insert] >> NO_TAC) + >- ( + drule comp_syn_ok_seq >> + strip_tac >> + fs [evaluate_def, assigned_vars_def] >> + pairarg_tac >> fs [AllCaseEqs ()] >> rveq >> fs [] + >- ( + qpat_x_assum ‘evaluate (_,s1) = _’ assume_tac >> + drule evaluate_clock >> fs [] >> + strip_tac >> fs [] >> + dxrule comp_syn_ok_seq >> + strip_tac >> + first_x_assum drule >> + disch_then (qspec_then ‘n’ mp_tac) >> + fs [] >> + strip_tac >> + first_x_assum drule >> + disch_then (qspec_then ‘n’ mp_tac) >> + fs [] >> + impl_tac + >- ( + qpat_x_assum ‘comp_syntax_ok l c1’ assume_tac >> + drule cut_sets_union_domain_union >> + strip_tac >> fs []) >> + fs []) >> + drule comp_syn_ok_seq >> + strip_tac >> + res_tac >> fs []) >> + drule evaluate_clock >> fs [] >> + strip_tac >> fs [] >> + drule comp_syn_ok_if >> + strip_tac >> rveq >> fs [] >> + fs [evaluate_def, assigned_vars_def] >> + fs [AllCaseEqs()] >> rveq >> fs [domain_inter] >> + cases_on ‘word_cmp cmp x y’ >> fs [] >> + fs [evaluate_def, list_insert_def, AllCaseEqs()] >> + FULL_CASE_TAC >> fs [cut_res_def, set_var_def, dec_clock_def, cut_state_def] >> + FULL_CASE_TAC >> fs [] >> rveq >> + every_case_tac >> rfs [] >> rveq >> fs [] >> + fs [state_component_equality, lookup_inter, lookup_insert] >> + every_case_tac >> rfs [domain_lookup] +QED + +Theorem eval_upd_clock_eq: + !t e ck. eval (t with clock := ck) e = eval t e +Proof + ho_match_mp_tac eval_ind >> rw [] >> + fs [eval_def] + >- ( + every_case_tac >> fs [] >> + fs [mem_load_def]) >> + qsuff_tac ‘the_words (MAP (λa. eval (t with clock := ck) a) wexps) = + the_words (MAP (λa. eval t a) wexps)’ >> + fs [] >> + pop_assum mp_tac >> + qid_spec_tac ‘wexps’ >> + Induct >> rw [] >> + last_x_assum mp_tac >> + impl_tac >- metis_tac [] >> + strip_tac >> fs [wordSemTheory.the_words_def] +QED + +(* should be trivial, but record updates are annoying *) + +Theorem eval_upd_locals_clock_eq: + !t e l ck. eval (t with <|locals := l; clock := ck|>) e = eval (t with locals := l) e +Proof + ho_match_mp_tac eval_ind >> rw [] >> + fs [eval_def] + >- ( + every_case_tac >> fs [] >> + fs [mem_load_def]) >> + qsuff_tac ‘the_words (MAP (λa. eval (t with <|locals := l; clock := ck|>) a) wexps) = + the_words (MAP (λa. eval (t with locals := l) a) wexps)’ >> + fs [] >> + pop_assum mp_tac >> + qid_spec_tac ‘wexps’ >> + Induct >> rw [] >> + last_x_assum mp_tac >> + impl_tac >- metis_tac [] >> + strip_tac >> fs [wordSemTheory.the_words_def] +QED + +Theorem cut_res_add_clock: + cut_res l (res,s) = (q,r) /\ q <> SOME TimeOut ==> + cut_res l (res,s with clock := ck + s.clock) = + (q,r with clock := ck + r.clock) +Proof + rw [cut_res_def, cut_state_def] >> + ‘s.clock <> 0’ by fs [AllCaseEqs()] >> + fs [] >> rveq >> fs [dec_clock_def] +QED + +Theorem evaluate_add_clock_eq: + !p t res st ck. + evaluate (p,t) = (res,st) /\ res <> SOME TimeOut ==> + evaluate (p,t with clock := t.clock + ck) = (res,st with clock := st.clock + ck) +Proof + recInduct evaluate_ind >> rw [] >> + TRY (fs [Once evaluate_def] >> NO_TAC) >> + TRY ( + rename [‘Seq’] >> + fs [evaluate_def] >> pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> rveq >> + fs [AllCaseEqs ()] >> rveq >> fs [] >> + first_x_assum (qspec_then ‘ck’ mp_tac) >> + fs []) >> + TRY ( + rename [‘If’] >> + fs [evaluate_def, AllCaseEqs ()] >> + rveq >> cases_on ‘ri’ >> fs [get_var_imm_def] >> + TOP_CASE_TAC >> cases_on ‘evaluate (c1,s)’ >> cases_on ‘evaluate (c2,s)’ >> + fs [cut_res_def, cut_state_def, AllCaseEqs (), dec_clock_def] >> + rveq >> fs []) >> + TRY ( + rename [‘FFI’] >> + fs [evaluate_def, AllCaseEqs (), cut_state_def, call_env_def] >> + rveq >> fs []) >> + TRY ( + rename [‘Loop’] >> + fs [Once evaluate_def] >> + TOP_CASE_TAC >> fs [] >> + cases_on ‘cut_res live_in ((NONE:'a result option),s)’ >> + fs [] >> + ‘q' <> SOME TimeOut’ by ( + CCONTR_TAC >> + fs [cut_res_def, cut_state_def, AllCaseEqs(), dec_clock_def]) >> + drule cut_res_add_clock >> + disch_then (qspec_then ‘ck’ mp_tac) >> fs [] >> + strip_tac >> fs [] >> rveq >> + TOP_CASE_TAC >> fs [] >> + cases_on ‘evaluate (body,r')’ >> fs [] >> rveq >> + cases_on ‘q’ >> fs [] >> + cases_on ‘x’ >> fs [] >> rveq >> fs [] + >- (imp_res_tac cut_res_add_clock >> res_tac >> fs []) >> + first_x_assum match_mp_tac >> + TOP_CASE_TAC >> fs [] >> + reverse TOP_CASE_TAC >> fs [] + >- fs [Once evaluate_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + fs [Once evaluate_def]) >> + TRY ( + rename [‘Call’] >> + fs [evaluate_def, get_vars_clock_upd_eq, dec_clock_def] >> + ntac 4 (TOP_CASE_TAC >> fs []) + >- ( + fs [AllCaseEqs()] >> + ‘s.clock <> 0’ by ( + fs [AllCaseEqs()] >> rveq >> fs []) >> + rveq >> fs []) >> + TOP_CASE_TAC >> fs [] >> + cases_on ‘cut_res r' ((NONE:'a result option),s)’ >> + fs [] >> + ‘q'' <> SOME TimeOut’ by ( + CCONTR_TAC >> + fs [cut_res_def, cut_state_def, AllCaseEqs(), dec_clock_def]) >> + drule cut_res_add_clock >> + disch_then (qspec_then ‘ck’ mp_tac) >> fs [] >> + strip_tac >> fs [] >> + TOP_CASE_TAC >> fs [] >> + cases_on ‘evaluate (r,r'' with locals := q)’ >> fs [] >> rveq >> + cases_on ‘q''’ >> fs [] >> rveq >> + cases_on ‘x'’ >> fs [] >> rveq >> + TOP_CASE_TAC >> fs [] >> rveq >> + fs [set_var_def] >> + rpt (TOP_CASE_TAC >> fs []) >> + qmatch_goalsub_abbrev_tac ‘cut_res nr (evaluate (rq,ar)) = _’ >> + qmatch_asmsub_abbrev_tac ‘evaluate (rq, lr)’ >> + cases_on ‘evaluate (rq, lr)’ >> + qmatch_asmsub_rename_tac ‘ evaluate _ = (tq,tr)’ >> + ‘tq <> SOME TimeOut’ by ( + CCONTR_TAC >> + unabbrev_all_tac >> + fs [cut_res_def, cut_state_def, AllCaseEqs(), dec_clock_def]) >> + first_x_assum (qspecl_then [‘tq’, ‘tr’, ‘ck’] mp_tac) >> + fs [] >> strip_tac >> + imp_res_tac cut_res_add_clock >> + res_tac >> fs []) >> + fs [evaluate_def, eval_upd_clock_eq, AllCaseEqs () , + set_var_def, mem_store_def, set_globals_def, + call_env_def, dec_clock_def] >> rveq >> + fs [state_component_equality] +QED + +Theorem evaluate_nested_seq_comb_seq: + !p q t. + evaluate (Seq (nested_seq p) (nested_seq q), t) = + evaluate (nested_seq (p ++ q), t) +Proof + Induct >> rw [] >> + fs [nested_seq_def, evaluate_def] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> + cases_on ‘res' = NONE’ >> fs [] >> rveq >> fs [] >> + first_x_assum (qspecl_then [‘q’,‘s1'’] mp_tac) >> + fs [] +QED + + +Theorem nested_seq_pure_evaluation: + !p q t r st l m e v ck ck'. + evaluate (nested_seq p,t with clock := ck + t.clock) = (NONE,st) /\ + evaluate (nested_seq q,st with clock := ck' + st.clock) = (NONE,r) /\ + comp_syntax_ok l (nested_seq p) /\ + comp_syntax_ok (cut_sets l (nested_seq p)) (nested_seq q) /\ + (!n. MEM n (assigned_vars (nested_seq p)) ==> n < m) /\ + (!n. MEM n (assigned_vars (nested_seq q)) ==> m <= n) /\ + (!n. MEM n (locals_touched e) ==> n < m /\ n ∈ domain (cut_sets l (nested_seq p))) /\ + eval st e = SOME v ==> + eval r e = SOME v +Proof + rw [] >> + drule_all comp_syn_ok_upd_local_clock >> + fs [] >> strip_tac >> + ‘st.globals = r.globals /\ st.memory = r.memory /\ + st.mdomain = r.mdomain’ by fs [state_component_equality] >> + drule locals_touched_eq_eval_eq >> fs [] >> + disch_then (qspec_then ‘e’ mp_tac) >> fs [] >> + impl_tac + >- ( + rw [] >> + drule comp_syn_ok_lookup_locals_eq >> + disch_then (qspecl_then [‘cut_sets l (nested_seq p)’, ‘n’] mp_tac) >> + impl_tac + >- ( + fs [] >> + CCONTR_TAC >> fs [] >> + res_tac >> fs []) >> fs []) >> fs [] +QED + +Theorem evaluate_io_events_mono: + !exps s1 res s2. + evaluate (exps,s1) = (res, s2) + ⇒ + s1.ffi.io_events ≼ s2.ffi.io_events +Proof + recInduct evaluate_ind >> + rw [] >> + TRY ( + rename [‘Seq’] >> + fs [evaluate_def] >> + pairarg_tac >> fs [] >> rveq >> + every_case_tac >> fs [] >> rveq >> + metis_tac [IS_PREFIX_TRANS]) >> + TRY ( + rename [‘If’] >> + fs [evaluate_def] >> + every_case_tac >> fs [] >> rveq >> + fs [] >> + TRY (cases_on ‘evaluate (c1,s)’) >> + TRY (cases_on ‘evaluate (c2,s)’) >> + fs [cut_res_def] >> + every_case_tac >> fs [] >> rveq >> + fs [cut_state_def] >> rveq >> fs [dec_clock_def]) >> + TRY ( + rename [‘Loop’] >> + pop_assum mp_tac >> + once_rewrite_tac [evaluate_def, LET_THM] >> + fs [AllCaseEqs()] >> + fs [cut_res_def, cut_state_def, dec_clock_def] >> rveq >> + fs [AllCaseEqs()] >> + strip_tac >> fs [] >> rveq >> fs [] >> + metis_tac [IS_PREFIX_TRANS]) >> + TRY ( + rename [‘Call’] >> + pop_assum mp_tac >> + once_rewrite_tac [evaluate_def, LET_THM] >> + fs [AllCaseEqs(), cut_res_def, cut_state_def, + dec_clock_def, set_var_def] >> + strip_tac >> fs [] >> rveq >> fs [] + >- ( + cases_on ‘evaluate (r,st with locals := insert n retv (inter s.locals live))’ >> + fs [AllCaseEqs(), cut_res_def, cut_state_def, + dec_clock_def, set_var_def] >> rveq >> fs [] >> + metis_tac [IS_PREFIX_TRANS]) >> + cases_on ‘evaluate (h,st with locals := insert n' exn (inter s.locals live))’ >> + fs [AllCaseEqs(), cut_res_def, cut_state_def, + dec_clock_def, set_var_def] >> rveq >> fs [] >> + metis_tac [IS_PREFIX_TRANS]) >> + TRY ( + rename [‘FFI’] >> + fs [evaluate_def, AllCaseEqs(), cut_state_def, + dec_clock_def, ffiTheory.call_FFI_def, call_env_def] >> + rveq >> fs []) >> + fs [evaluate_def] >> + every_case_tac >> + fs [set_var_def, mem_store_def, set_globals_def, call_env_def, + dec_clock_def] >> rveq >> + fs [] +QED + +Theorem evaluate_add_clock_io_events_mono: + ∀exps s extra. + (SND(evaluate(exps,s))).ffi.io_events ≼ + (SND(evaluate(exps,s with clock := s.clock + extra))).ffi.io_events +Proof + recInduct evaluate_ind >> + rw [] >> + TRY ( + rename [‘Seq’] >> + fs [evaluate_def] >> + pairarg_tac >> fs [] >> rveq >> + pairarg_tac >> fs [] >> rveq >> + every_case_tac >> fs [] >> rveq >> fs [] + >- ( + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> + disch_then (qspec_then ‘extra’ mp_tac) >> + fs [] >> + strip_tac >> + strip_tac >> rveq >> fs []) + >- ( + pop_assum mp_tac >> + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> + disch_then (qspec_then ‘extra’ mp_tac) >> + fs []) + >- ( + first_x_assum (qspec_then ‘extra’ mp_tac) >> + strip_tac >> + ‘s1.ffi.io_events ≼ s1'.ffi.io_events’ by rfs [] >> + cases_on ‘evaluate (c2,s1')’ >> + fs [] >> + ‘s1'.ffi.io_events ≼ r.ffi.io_events’ by + metis_tac [evaluate_io_events_mono] >> + metis_tac [IS_PREFIX_TRANS]) >> + first_x_assum (qspec_then ‘extra’ mp_tac) >> + fs []) >> + TRY ( + rename [‘If’] >> + fs [evaluate_def, AllCaseEqs()] >> rveq >> fs [] >> + every_case_tac >> fs [get_var_imm_add_clk_eq] >> rveq >> + first_x_assum (qspec_then ‘extra’ assume_tac) >> + TRY (cases_on ‘evaluate (c1,s)’) >> + TRY (cases_on ‘evaluate (c1,s with clock := extra + s.clock)’) >> + TRY (cases_on ‘evaluate (c2,s)’) >> + TRY (cases_on ‘evaluate (c2,s with clock := extra + s.clock)’) >> + fs [cut_res_def, cut_state_def, dec_clock_def] >> + every_case_tac >> fs [] >> rveq >> fs []) >> + TRY ( + rename [‘Loop’] >> + once_rewrite_tac [evaluate_def, LET_THM] >> + TOP_CASE_TAC >> fs [] >> + reverse TOP_CASE_TAC + >- ( + fs [] >> + fs [cut_res_def, cut_state_def] >> + cases_on ‘domain live_in ⊆ domain s.locals’ >> fs [] >> + cases_on ‘s.clock = 0’ >> fs [] >> rveq >> fs [] >> + cases_on ‘extra = 0’ >> fs [] >> rveq >> fs [] >> + fs [dec_clock_def] >> + cases_on ‘evaluate (body, + s with <|locals := inter s.locals live_in; clock := extra - 1|>)’ >> + fs [] >> + TOP_CASE_TAC >> fs [] + >- (drule evaluate_io_events_mono >> fs []) >> + TOP_CASE_TAC >> fs [] >> + TRY (drule evaluate_io_events_mono >> fs [] >> NO_TAC) + >- ( + every_case_tac >> fs [] >> rveq >> fs [] >> + drule evaluate_io_events_mono >> fs []) >> + drule evaluate_io_events_mono >> fs [] >> + strip_tac >> + cases_on ‘evaluate (Loop live_in body live_out,r)’ >> + drule evaluate_io_events_mono >> fs [] >> + metis_tac [IS_PREFIX_TRANS]) >> + fs [cut_res_def, cut_state_def] >> + cases_on ‘domain live_in ⊆ domain s.locals’ >> fs [] >> + cases_on ‘s.clock = 0’ >> fs [] >> rveq >> fs [] >> + cases_on ‘extra = 0’ >> fs [] >> rveq >> fs [] >> + fs [dec_clock_def] >> + first_x_assum (qspec_then ‘extra’ assume_tac) >> + cases_on ‘evaluate + (body, + s with + <|locals := inter s.locals live_in; clock := s.clock - 1|>)’ >> + fs [] >> + cases_on ‘evaluate + (body, + s with + <|locals := inter s.locals live_in; + clock := extra + s.clock - 1|>)’ >> + cases_on ‘q’ >> fs [] >> rveq >> fs [] + >- ( + cases_on ‘q'’ >> fs [] >> + reverse (cases_on ‘x’) >> fs [] + >- ( + cases_on ‘evaluate (Loop live_in body live_out,r')’ >> + drule evaluate_io_events_mono >> fs [] >> + metis_tac [IS_PREFIX_TRANS]) >> + every_case_tac >> fs []) >> + cases_on ‘x’ >> fs [] >> rveq >> fs [] >> + TRY ( + cases_on ‘q'’ >> fs [] >> + reverse (cases_on ‘x’) >> fs [] + >- ( + cases_on ‘evaluate (Loop live_in body live_out,r')’ >> + drule evaluate_io_events_mono >> fs [] >> + metis_tac [IS_PREFIX_TRANS]) >> + every_case_tac >> fs [] >> NO_TAC) + >- ( + every_case_tac >> fs [] >> rveq >> fs [] >> + cases_on ‘evaluate (Loop live_in body live_out,r')’ >> + drule evaluate_io_events_mono >> fs [] >> + metis_tac [IS_PREFIX_TRANS]) >> + cases_on ‘q'’ >> fs [] + >- ( + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> fs []) >> + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> fs [] >> + strip_tac >> strip_tac >> fs [] >> rveq >> fs []) >> + TRY ( + rename [‘Call’] >> + once_rewrite_tac [evaluate_def, LET_THM] >> + TOP_CASE_TAC >> fs [get_vars_clock_upd_eq] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] + >- ( + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq + >- ( + TOP_CASE_TAC >> fs [] >> rveq >> fs [dec_clock_def] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] + >- ( + drule evaluate_io_events_mono >> + strip_tac >> fs [] >> rveq >> fs []) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + drule evaluate_io_events_mono >> + strip_tac >> fs [] >> rveq >> fs []) >> + fs [dec_clock_def] >> + first_x_assum (qspec_then ‘extra’ assume_tac) >> + cases_on ‘evaluate (r,s with <|locals := q; clock := s.clock - 1|>)’ >> + cases_on ‘evaluate (r,s with <|locals := q; clock := extra + s.clock - 1|>)’ >> + fs [] >> + every_case_tac >> fs [] >> rveq >> fs []) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + fs [cut_res_def, cut_state_def] >> + cases_on ‘domain r' ⊆ domain s.locals’ >> fs [] >> + rveq >> fs [] >> + cases_on ‘s.clock = 0’ >> fs [] >> rveq >> fs [] + >- ( + every_case_tac >> fs [] >> rveq >> fs [dec_clock_def, set_var_def] >> + TRY ( + drule evaluate_io_events_mono >> + strip_tac >> fs [] >> rveq >> fs [] >> NO_TAC) + >- ( + cases_on ‘(evaluate + (q'''',r''' with locals := insert q' w (inter s.locals r')))’ >> fs [] >> + fs [cut_res_def] >> + every_case_tac >> fs [] >> rveq >> fs [] >> rveq >> fs [cut_state_def, dec_clock_def] >> + rveq >> fs [] >> + imp_res_tac evaluate_io_events_mono >> + fs [] >> rveq >> metis_tac [IS_PREFIX_TRANS]) >> + cases_on ‘(evaluate + (q''',r''' with locals := insert q'' w (inter s.locals r')))’ >> fs [] >> + fs [cut_res_def] >> + every_case_tac >> fs [] >> rveq >> fs [] >> rveq >> fs [cut_state_def, dec_clock_def] >> + rveq >> fs [] >> + imp_res_tac evaluate_io_events_mono >> + fs [] >> rveq >> metis_tac [IS_PREFIX_TRANS]) >> + fs [dec_clock_def] >> + last_x_assum (qspec_then ‘extra’ assume_tac) >> + fs [set_var_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] + >- (drule evaluate_add_clock_eq >> fs []) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TRY (drule evaluate_add_clock_eq >> fs [] >> NO_TAC) + >- ( + TOP_CASE_TAC >> fs [] >> rveq >> fs [] + >- (drule evaluate_add_clock_eq >> fs []) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + first_x_assum (qspec_then ‘extra’ assume_tac) >> + drule evaluate_add_clock_eq >> fs [] >> + disch_then (qspec_then ‘extra’ assume_tac) >> + fs [] >> + cases_on ‘evaluate + (q'⁴',r'' with locals := insert q' w (inter s.locals r'))’ >> fs [] >> + cases_on ‘evaluate + (q'⁴', + r'' with + <|locals := insert q' w (inter s.locals r'); + clock := extra + r''.clock|>)’ >> fs [] >> + fs [cut_res_def] >> + reverse TOP_CASE_TAC >> fs [] + >- ( + pop_assum mp_tac >> + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> fs [] >> + disch_then (qspec_then ‘extra’ assume_tac) >> + strip_tac >> strip_tac >> rveq >> fs [] >> + fs [cut_state_def] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [dec_clock_def] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [dec_clock_def] >> rveq >> fs []) >> + TOP_CASE_TAC >> fs [dec_clock_def] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [dec_clock_def] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [dec_clock_def] >> rveq >> fs [] >> + fs [cut_state_def] >> rveq >> fs []) + >- ( + TOP_CASE_TAC >> fs [] >> rveq >> fs [] + >- (drule evaluate_add_clock_eq >> fs []) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + first_x_assum (qspec_then ‘extra’ assume_tac) >> + drule evaluate_add_clock_eq >> fs [] >> + disch_then (qspec_then ‘extra’ assume_tac) >> + fs [] >> + cases_on ‘evaluate + (q'³',r'' with locals := insert q'' w (inter s.locals r'))’ >> fs [] >> + cases_on ‘evaluate + (q'³', + r'' with + <|locals := insert q'' w (inter s.locals r'); + clock := extra + r''.clock|>)’ >> fs [] >> + fs [cut_res_def] >> + reverse TOP_CASE_TAC >> fs [] + >- ( + pop_assum mp_tac >> + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> fs [] >> + disch_then (qspec_then ‘extra’ assume_tac) >> + strip_tac >> strip_tac >> rveq >> fs [] >> + fs [cut_state_def] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [dec_clock_def] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [dec_clock_def] >> rveq >> fs []) >> + TOP_CASE_TAC >> fs [dec_clock_def] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [dec_clock_def] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [dec_clock_def] >> rveq >> fs [] >> + fs [cut_state_def] >> rveq >> fs []) >> + cases_on ‘evaluate + (r,s with <|locals := q; clock := extra + s.clock - 1|>)’ >> + fs [] >> + every_case_tac >> fs [] >> rveq >> fs [] + >- ( + cases_on ‘evaluate + (q'⁵',r'³' with locals := insert q' w (inter s.locals r'))’ >> + fs [cut_res_def] >> + every_case_tac >> fs [] >> rveq >> + fs [cut_state_def, dec_clock_def] >> rveq >> fs [] >> + imp_res_tac evaluate_io_events_mono >> + fs [] >> rveq >> metis_tac [IS_PREFIX_TRANS]) >> + cases_on ‘evaluate + (q'⁴',r'³' with locals := insert q'³' w (inter s.locals r'))’ >> + fs [cut_res_def] >> + every_case_tac >> fs [] >> rveq >> + fs [cut_state_def, dec_clock_def] >> rveq >> fs [] >> + imp_res_tac evaluate_io_events_mono >> + fs [] >> rveq >> metis_tac [IS_PREFIX_TRANS]) >> + TRY ( + rename [‘FFI’] >> + fs [evaluate_def] >> + every_case_tac >> + fs [cut_state_def, + dec_clock_def, ffiTheory.call_FFI_def, call_env_def] >> + rveq >> fs [] >> rveq >> fs []) >> + fs [evaluate_def] >> + every_case_tac >> + fs [set_var_def, mem_store_def, set_globals_def, call_env_def, + dec_clock_def] >> rveq >> + fs [] +QED + + +val _ = export_theory(); diff --git a/pancake/semantics/loopSemScript.sml b/pancake/semantics/loopSemScript.sml new file mode 100644 index 0000000000..073c9f5a32 --- /dev/null +++ b/pancake/semantics/loopSemScript.sml @@ -0,0 +1,375 @@ +(* + The formal semantics of loopLang +*) +open preamble loopLangTheory; +local open + alignmentTheory + wordSemTheory + ffiTheory in end; + +val _ = new_theory"loopSem"; +val _ = set_grammar_ancestry [ + "loopLang", "alignment", + "finite_map", "misc", "wordSem", + "ffi", "machine_ieee" (* for FP *) +] + +Datatype: + state = + <| locals : ('a word_loc) num_map + ; globals : 5 word |-> 'a word_loc + ; memory : 'a word -> 'a word_loc + ; mdomain : ('a word) set + ; clock : num + ; code : (num list # ('a loopLang$prog)) num_map + ; be : bool + ; ffi : 'ffi ffi_state |> +End + +val state_component_equality = theorem "state_component_equality"; + +Datatype: + result = Result ('w word_loc) + | Exception ('w word_loc) + | Break + | Continue + | TimeOut + | FinalFFI final_event + | Error +End + +val s = ``(s:('a,'ffi) loopSem$state)`` + +Definition dec_clock_def: + dec_clock ^s = s with clock := s.clock - 1 +End + +Definition fix_clock_def: + fix_clock old_s (res,new_s) = + (res,new_s with + <| clock := if old_s.clock < new_s.clock then old_s.clock else new_s.clock |>) +End + +Definition set_globals_def: + set_globals gv w ^s = + (s with globals := s.globals |+ (gv,w)) +End + +Definition mem_store_def: + mem_store (addr:'a word) (w:'a word_loc) ^s = + if addr IN s.mdomain then + SOME (s with memory := (addr =+ w) s.memory) + else NONE +End + +Definition mem_load_def: + mem_load (addr:'a word) ^s = + if addr IN s.mdomain then + SOME (s.memory addr) + else NONE +End + +Definition eval_def: + (eval ^s ((Const w):'a loopLang$exp) = SOME (Word w)) /\ + (eval s (Var v) = lookup v s.locals) /\ + (eval s (Lookup name) = FLOOKUP s.globals name) /\ + (eval s (Load addr) = + case eval s addr of + | SOME (Word w) => mem_load w s + | _ => NONE) /\ + (eval s (Op op wexps) = + case the_words (MAP (eval s) wexps) of + | SOME ws => (OPTION_MAP Word (word_op op ws)) + | _ => NONE) /\ + (eval s (Shift sh wexp n) = + case eval s wexp of + | SOME (Word w) => OPTION_MAP Word (word_sh sh w n) + | _ => NONE) +Termination + WF_REL_TAC `measure (exp_size ARB o SND)` + \\ REPEAT STRIP_TAC \\ IMP_RES_TAC MEM_IMP_exp_size + \\ TRY (FIRST_X_ASSUM (ASSUME_TAC o Q.SPEC `ARB`)) + \\ DECIDE_TAC +End + +Definition get_vars_def: + (get_vars [] ^s = SOME []) /\ + (get_vars (v::vs) s = + case sptree$lookup v s.locals of + | NONE => NONE + | SOME x => (case get_vars vs s of + | NONE => NONE + | SOME xs => SOME (x::xs))) +End + +Definition set_var_def: + set_var v x ^s = + (s with locals := (insert v x s.locals)) +End + +Definition set_vars_def: + set_vars vs xs ^s = + (s with locals := (alist_insert vs xs s.locals)) +End + +Definition find_code_def: + (find_code (SOME p) args code = + case sptree$lookup p code of + | NONE => NONE + | SOME (params,exp) => if LENGTH args = LENGTH params + then SOME (fromAList (ZIP (params, args)),exp) else NONE) /\ + (find_code NONE args code = + if args = [] then NONE else + case LAST args of + | Loc loc 0 => + (case lookup loc code of + | NONE => NONE + | SOME (params,exp) => if LENGTH args = LENGTH params + 1 + then SOME (fromAList (ZIP (params, FRONT args)),exp) + else NONE) + | other => NONE) +End + +Definition get_var_imm_def: + (get_var_imm ((Reg n):'a reg_imm) ^s = sptree$lookup n s.locals) ∧ + (get_var_imm (Imm w) s = SOME(Word w)) +End + +Theorem fix_clock_IMP_LESS_EQ: + !x. fix_clock ^s x = (res,s1) ==> s1.clock <= s.clock +Proof + full_simp_tac(srw_ss())[fix_clock_def,FORALL_PROD] \\ + srw_tac[][] \\ full_simp_tac(srw_ss())[] \\ decide_tac +QED + +Definition call_env_def: + call_env args ^s = + s with <| locals := fromList args |> +End + +Definition cut_state_def: + cut_state live s = + if domain live SUBSET domain s.locals then + SOME (s with locals := inter s.locals live) + else NONE +End + +Definition cut_res_def: + cut_res live (res,s) = + if res ≠ NONE then (res,s) else + case cut_state live s of + | NONE => (SOME Error,s) + | SOME s => if s.clock = 0 then (SOME TimeOut,s with locals := LN) + else (res,dec_clock s) +End + +Definition evaluate_def: + (evaluate (Skip:'a loopLang$prog,^s) = (NONE, s)) /\ + (evaluate (Fail:'a loopLang$prog,^s) = (SOME Error, s)) /\ + (evaluate (Assign v exp,s) = + case eval s exp of + | NONE => (SOME Error, s) + | SOME w => (NONE, set_var v w s)) /\ + (evaluate (Store exp v,s) = + case (eval s exp, lookup v s.locals) of + | (SOME (Word adr), SOME w) => + (case mem_store adr w s of + | SOME st => (NONE, st) + | NONE => (SOME Error, s)) + | _ => (SOME Error, s)) /\ + (evaluate (SetGlobal dst exp,s) = + case eval s exp of + | SOME w => (NONE, set_globals dst w s) + | _ => (SOME Error, s)) /\ + (evaluate (LoadByte a v,s) = + case lookup a s.locals of + | SOME (Word w) => + (case mem_load_byte_aux s.memory s.mdomain s.be w of + | SOME b => (NONE, set_var v (Word (w2w b)) s) + | _ => (SOME Error, s)) + | _ => (SOME Error, s)) /\ + (evaluate (StoreByte a w,s) = + case lookup a s.locals, lookup w s.locals of + | (SOME (Word w), SOME (Word b)) => + (case mem_store_byte_aux s.memory s.mdomain s.be w (w2w b) of + | SOME m => (NONE, s with memory := m) + | _ => (SOME Error, s)) + | _ => (SOME Error, s)) /\ + (evaluate (Seq c1 c2,s) = + let (res,s1) = fix_clock s (evaluate (c1,s)) in + if res = NONE then evaluate (c2,s1) else (res,s1)) /\ + (evaluate (If cmp r1 ri c1 c2 live_out,s) = + (case (lookup r1 s.locals,get_var_imm ri s)of + | SOME (Word x),SOME (Word y) => + let b = word_cmp cmp x y in + cut_res live_out (evaluate (if b then c1 else c2,s)) + | _ => (SOME Error,s))) /\ + (evaluate (Mark p,s) = evaluate (p,s)) /\ + (evaluate (Break,s) = (SOME Break,s)) /\ + (evaluate (Continue,s) = (SOME Continue,s)) /\ + (evaluate (Loop live_in body live_out,s) = + (case cut_res live_in (NONE,s) of + | (NONE,s) => + (case fix_clock s (evaluate (body,s)) of + | (SOME Continue,s) => evaluate (Loop live_in body live_out,s) + | (SOME Break,s) => cut_res live_out (NONE,s) + | (NONE,s) => (SOME Error,s) + | res => res) + | res => res)) /\ + (evaluate (Raise n,s) = + case lookup n s.locals of + | NONE => (SOME Error,s) + | SOME w => (SOME (Exception w),call_env [] s)) /\ + (evaluate (Return n,s) = + case lookup n s.locals of + | SOME v => (SOME (Result v),call_env [] s) + | _ => (SOME Error,s)) /\ + (evaluate (Tick,s) = + if s.clock = 0 then (SOME TimeOut,s with locals := LN) + else (NONE,dec_clock s)) /\ + (evaluate (LocValue r l1,s) = + if l1 ∈ domain s.code then + (NONE,set_var r (Loc l1 0) s) + else (SOME Error,s)) /\ + (evaluate (Call ret dest argvars handler,s) = + case get_vars argvars s of + | NONE => (SOME Error,s) + | SOME argvals => + (case find_code dest argvals s.code of + | NONE => (SOME Error,s) + | SOME (env,prog) => + (case ret of + | NONE (* tail call *) => + (if handler <> NONE then (SOME Error,s) else + if s.clock = 0 then (SOME TimeOut,s with locals := LN) + else (case evaluate (prog, dec_clock s with locals := env) of + | (NONE,s) => (SOME Error,s) + | (SOME Continue,s) => (SOME Error,s) + | (SOME Break,s) => (SOME Error,s) + | (SOME res,s) => (SOME res,s))) + | SOME (n,live) => + (case cut_res live (NONE,s) of + | (NONE,s) => + (case fix_clock (s with locals := env) + (evaluate (prog, s with locals := env)) + of (SOME (Result retv),st) => + (case handler of (* if handler is present, then finalise *) + | NONE => (NONE, set_var n retv (st with locals := s.locals)) + | SOME (_,_,r,live_out) => + cut_res live_out + (evaluate (r, set_var n retv (st with locals := s.locals)))) + | (SOME (Exception exn),st) => + (case handler of (* if handler is present, then handle exc *) + | NONE => (SOME (Exception exn),(st with locals := LN)) + | SOME (n,h,_,live_out) => + cut_res live_out + (evaluate (h, set_var n exn (st with locals := s.locals)))) + | (SOME Continue,st) => (SOME Error, st) + | (SOME Break,st) => (SOME Error, st) + | (NONE,st) => (SOME Error, st) + | res => res) + | res => res)))) /\ + (evaluate (FFI ffi_index ptr1 len1 ptr2 len2 cutset,s) = + case (lookup len1 s.locals, lookup ptr1 s.locals, lookup len2 s.locals, lookup ptr2 s.locals, cut_state cutset s) of + | SOME (Word w),SOME (Word w2),SOME (Word w3),SOME (Word w4),SOME s => + (case (read_bytearray w2 (w2n w) (mem_load_byte_aux s.memory s.mdomain s.be), + read_bytearray w4 (w2n w3) (mem_load_byte_aux s.memory s.mdomain s.be)) + of + | SOME bytes,SOME bytes2 => + (case call_FFI s.ffi ffi_index bytes bytes2 of + | FFI_final outcome => (SOME (FinalFFI outcome),call_env [] s) + | FFI_return new_ffi new_bytes => + let new_m = write_bytearray w4 new_bytes s.memory s.mdomain s.be in + (NONE, s with <| memory := new_m ; + ffi := new_ffi |>)) + | _ => (SOME Error,s)) + | res => (SOME Error,s)) +Termination + WF_REL_TAC `(inv_image (measure I LEX measure (prog_size (K 0))) + (\(xs,^s). (s.clock,xs)))` + \\ REPEAT STRIP_TAC \\ TRY (full_simp_tac(srw_ss())[] \\ DECIDE_TAC) + \\ imp_res_tac fix_clock_IMP_LESS_EQ \\ full_simp_tac(srw_ss())[] + \\ imp_res_tac (GSYM fix_clock_IMP_LESS_EQ) + \\ full_simp_tac(srw_ss())[set_var_def,call_env_def,dec_clock_def,set_globals_def, + LET_THM,cut_res_def,CaseEq"option",pair_case_eq,CaseEq"bool"] + \\ rveq \\ fs [] + \\ rpt (pairarg_tac \\ full_simp_tac(srw_ss())[]) + \\ fs [cut_state_def] + \\ every_case_tac \\ rveq \\ full_simp_tac(srw_ss())[] + \\ decide_tac +End + +(* We prove that the clock never increases *) + +Theorem evaluate_clock: + !xs s1 vs s2. (evaluate (xs,s1) = (vs,s2)) ==> s2.clock <= s1.clock +Proof + recInduct evaluate_ind \\ rpt strip_tac + \\ pop_assum mp_tac \\ once_rewrite_tac [evaluate_def] + \\ rpt (disch_then strip_assume_tac) + \\ fs [] \\ rveq \\ fs [] + \\ fs [CaseEq"option",pair_case_eq] \\ rveq \\ fs [] + \\ fs [cut_res_def] + \\ fs [CaseEq"option",pair_case_eq,CaseEq"bool"] \\ rveq \\ fs [] + \\ fs [CaseEq"option",CaseEq"word_loc",mem_store_def,CaseEq"bool",set_globals_def, + cut_state_def,pair_case_eq,CaseEq"ffi_result",cut_res_def,CaseEq"word_loc"] + \\ fs [] \\ rveq \\ fs [set_var_def,set_globals_def,dec_clock_def,call_env_def] + \\ rpt (pairarg_tac \\ fs []) + \\ fs [CaseEq"option",CaseEq"word_loc",mem_store_def,CaseEq"bool",CaseEq"result", + pair_case_eq,cut_res_def] + \\ fs [] \\ rveq \\ fs [set_var_def,set_globals_def] + \\ imp_res_tac fix_clock_IMP_LESS_EQ \\ fs [] + \\ rename [‘cut_res _ xx’] \\ PairCases_on ‘xx’ \\ fs [] + \\ fs [cut_res_def] + \\ every_case_tac \\ fs [] \\ rveq \\ fs [cut_state_def] + \\ rveq \\ fs [cut_state_def,dec_clock_def] +QED + +Theorem fix_clock_evaluate: + fix_clock s (evaluate (c1,s)) = evaluate (c1,s) +Proof + Cases_on ‘evaluate (c1,s)’ \\ rw [fix_clock_def] + \\ imp_res_tac evaluate_clock \\ fs [state_component_equality] +QED + +(* we store the theorems without fix_clock *) + +Theorem evaluate_ind = REWRITE_RULE [fix_clock_evaluate] evaluate_ind; +Theorem evaluate_def = REWRITE_RULE [fix_clock_evaluate] evaluate_def; + +(* observational semantics *) + + +(* keeping 0 as the initial parameter to be passed *) +(* if returned, it should always be to Loc 1 0 *) +(* we generate Fail for NONE because it means that the program + ran out of the code, and didn't exit properly *) + +Definition semantics_def: + semantics ^s start = + let prog = Call NONE (SOME start) [] NONE in + if ∃k. case FST(evaluate (prog,s with clock := k)) of + | SOME TimeOut => F + | SOME (FinalFFI _) => F + | SOME (Result _) => F + | _ => T + then Fail + else + case some res. + ∃k t r outcome. + evaluate (prog, s with clock := k) = (r,t) ∧ + (case r of + | (SOME (FinalFFI e)) => outcome = FFI_outcome e + | (SOME (Result _)) => outcome = Success + | _ => F) ∧ + res = Terminate outcome t.ffi.io_events + of + | SOME res => res + | NONE => + Diverge + (build_lprefix_lub + (IMAGE (λk. fromList + (SND (evaluate (prog,s with clock := k))).ffi.io_events) UNIV)) +End + +val _ = export_theory(); diff --git a/pancake/semantics/panPropsScript.sml b/pancake/semantics/panPropsScript.sml new file mode 100644 index 0000000000..053f9ca4c2 --- /dev/null +++ b/pancake/semantics/panPropsScript.sml @@ -0,0 +1,1302 @@ +(* + panLang Properties +*) + +open preamble + panLangTheory panSemTheory + pan_commonPropsTheory; + +val _ = new_theory"panProps"; + +val _ = set_grammar_ancestry ["panLang","panSem", "pan_commonProps"]; + + +Definition v2word_def: + v2word (ValWord v) = Word v +End + +Theorem length_flatten_eq_size_of_shape: + !v. + LENGTH (flatten v) = size_of_shape (shape_of v) +Proof + ho_match_mp_tac flatten_ind >> rw [] + >- (cases_on ‘w’ >> fs [shape_of_def, flatten_def, size_of_shape_def]) >> + fs [shape_of_def, flatten_def, size_of_shape_def] >> + fs [LENGTH_FLAT, MAP_MAP_o] >> fs[SUM_MAP_FOLDL] >> + match_mp_tac FOLDL_CONG >> fs [] +QED + +Theorem mem_load_some_shape_eq: + ∀sh adr dm (m: 'a word -> 'a word_lab) v. + mem_load sh adr dm m = SOME v ==> + shape_of v = sh +Proof + qsuff_tac ‘(∀sh adr dm (m: 'a word -> 'a word_lab) v. + mem_load sh adr dm m = SOME v ==> shape_of v = sh) /\ + (∀sh adr dm (m: 'a word -> 'a word_lab) v. + mem_loads sh adr dm m = SOME v ==> MAP shape_of v = sh)’ + >- metis_tac [] >> + ho_match_mp_tac mem_load_ind >> rw [mem_load_def] >> + cases_on ‘sh’ >> fs [option_case_eq] >> + rveq >> TRY (cases_on ‘m adr’) >> fs [shape_of_def] >> + metis_tac [] +QED + + +Theorem flookup_res_var_some_eq_lookup: + FLOOKUP (res_var lc (v,FLOOKUP lc' v)) v = SOME value ==> + FLOOKUP lc' v = SOME value +Proof + rw [] >> cases_on ‘FLOOKUP lc' v’ >> + fs [res_var_def, FLOOKUP_UPDATE] +QED + +Theorem flookup_res_var_diff_eq_org: + n <> m ==> + FLOOKUP (res_var lc (n,v)) m = FLOOKUP lc m +Proof + rw [] >> cases_on ‘v’ >> + fs [res_var_def, FLOOKUP_UPDATE, DOMSUB_FLOOKUP_NEQ] +QED + +Theorem list_rel_length_shape_of_flatten: + !vshs args. + LIST_REL (λvsh arg. SND vsh = shape_of arg) vshs args ==> + size_of_shape (Comb (MAP SND vshs)) = LENGTH (FLAT (MAP flatten args)) +Proof + Induct >> rpt gen_tac >> strip_tac + >- (cases_on ‘args’ >> fs [size_of_shape_def]) >> + cases_on ‘args’ >> fs [] >> rveq >> + fs [size_of_shape_def] >> + last_x_assum (qspecl_then [‘t’] mp_tac) >> + fs [] >> last_x_assum (assume_tac o GSYM) >> + fs [] >> + fs [length_flatten_eq_size_of_shape] +QED + + +Theorem length_with_shape_eq_shape: + !sh ns. + LENGTH ns = size_of_shape (Comb sh) ==> + LENGTH sh = LENGTH (with_shape sh ns) +Proof + Induct >> rw [] >> + fs [with_shape_def] >> + fs [size_of_shape_def] +QED + + +Theorem fdoms_eq_flookup_some_none: + !fm fm' n v v'. FDOM fm = FDOM fm' /\ + FLOOKUP fm n = SOME v ==> ?v. FLOOKUP fm' n = SOME v +Proof + rw [] >> + fs [flookup_thm] >> rveq >> fs [] >> + rfs [] +QED + + +Theorem all_distinct_with_shape: + !sh ns n. + ALL_DISTINCT ns /\ n < LENGTH sh /\ + LENGTH ns = size_of_shape (Comb sh) ==> + ALL_DISTINCT (EL n (with_shape sh ns)) +Proof + Induct >> rw [] >> + fs [with_shape_def] >> + cases_on ‘n’ >> fs [] + >- ( + fs [size_of_shape_def] >> + ‘size_of_shape h <= LENGTH ns’ by DECIDE_TAC >> + drule all_distinct_take >> fs []) >> + last_x_assum (qspecl_then [‘DROP (size_of_shape h) ns’, ‘n'’] mp_tac) >> + impl_tac + >- ( + fs [size_of_shape_def] >> + ‘size_of_shape h <= LENGTH ns’ by DECIDE_TAC >> + drule all_distinct_drop >> fs []) >> fs [] +QED + +Theorem el_mem_with_shape: + !sh ns n x. + n < LENGTH (with_shape sh ns) /\ + LENGTH ns = size_of_shape (Comb sh) /\ + MEM x (EL n (with_shape sh ns)) ==> + MEM x ns +Proof + Induct >> rw [] >> + fs [with_shape_def] >> + cases_on ‘n’ >> fs [] + >- ( + fs [size_of_shape_def] >> + ‘size_of_shape h <= LENGTH ns’ by DECIDE_TAC >> drule MEM_TAKE >> fs []) >> + fs [size_of_shape_def] >> + last_x_assum (qspecl_then [‘DROP (size_of_shape h) ns’, ‘n'’, ‘x’] mp_tac) >> + fs [] >> + strip_tac >> drule MEM_DROP_IMP >> + fs [] +QED + + +Theorem mem_with_shape_length: + !sh ns n. + LENGTH ns = size_of_shape (Comb sh) ∧ n < LENGTH sh ==> + MEM (EL n (with_shape sh ns)) (with_shape sh ns) +Proof + Induct >> rw [] >> + cases_on ‘n’ >> fs [] >> + fs [with_shape_def] >> + disj2_tac >> + first_x_assum match_mp_tac >> + fs [size_of_shape_def] +QED + +Theorem with_shape_el_take_drop_eq: + !sh ns n. + LENGTH ns = size_of_shape (Comb sh) ∧ + n < LENGTH sh ==> + EL n (with_shape sh ns) = + TAKE (size_of_shape (EL n sh)) (DROP (size_of_shape (Comb (TAKE n sh))) ns) +Proof + Induct >> rw [] >> + cases_on ‘n’ >> fs [] + >- fs [with_shape_def, size_of_shape_def] >> + fs [with_shape_def, size_of_shape_def] >> + last_x_assum (qspecl_then [‘DROP (size_of_shape h) ns’, ‘n'’] mp_tac) >> + impl_tac >- fs [] >> + strip_tac >> fs [DROP_DROP_T] +QED + +Theorem all_distinct_with_shape_distinct: + !sh ns x y. + ALL_DISTINCT ns ∧ LENGTH ns = size_of_shape (Comb sh) ∧ + MEM x (with_shape sh ns) ∧ MEM y (with_shape sh ns) ∧ x <> y ∧ + x <> [] ∧ y <> [] ==> + DISJOINT (set x) (set y) +Proof + Induct >> rw [] >> + fs [with_shape_def] + >- ( + cases_on ‘size_of_shape h = 0’ >> fs [] >> + ‘x = y’ suffices_by fs [] >> + ‘size_of_shape h <= LENGTH ns’ by + fs [size_of_shape_def] >> + qpat_x_assum ‘x ≠ y’ kall_tac >> + fs [TAKE]) + >- ( + fs [MEM_EL] >> + ‘EL n (with_shape sh (DROP (size_of_shape h) ns)) = + TAKE (size_of_shape (EL n sh)) (DROP (size_of_shape (Comb (TAKE n sh))) + (DROP (size_of_shape h) ns))’ by ( + match_mp_tac with_shape_el_take_drop_eq >> + fs [size_of_shape_def] >> + ‘LENGTH (DROP (size_of_shape h) ns) = size_of_shape (Comb sh)’ by + fs [size_of_shape_def] >> + drule length_with_shape_eq_shape >> fs []) >> + fs [] >> + fs [DROP_DROP_T, DROP_TAKE] >> + match_mp_tac disjoint_take_drop_sum >> + fs []) + >- ( + fs [MEM_EL] >> + ‘EL n (with_shape sh (DROP (size_of_shape h) ns)) = + TAKE (size_of_shape (EL n sh)) (DROP (size_of_shape (Comb (TAKE n sh))) + (DROP (size_of_shape h) ns))’ by ( + match_mp_tac with_shape_el_take_drop_eq >> + fs [size_of_shape_def] >> + ‘LENGTH (DROP (size_of_shape h) ns) = size_of_shape (Comb sh)’ by + fs [size_of_shape_def] >> + drule length_with_shape_eq_shape >> fs []) >> + fs [] >> + fs [DROP_DROP_T, DROP_TAKE] >> + match_mp_tac disjoint_drop_take_sum >> + fs []) >> + last_x_assum (qspec_then ‘DROP (size_of_shape h) ns’ mp_tac) >> + disch_then (qspecl_then [‘x’,‘y’] mp_tac) >> + impl_tac + >- fs [ALL_DISTINCT_DROP, size_of_shape_def] >> + fs [] +QED + + +Theorem all_distinct_disjoint_with_shape: + !sh ns n n'. + ALL_DISTINCT ns /\ n < LENGTH sh /\ n' < LENGTH sh /\ + n <> n' /\ + LENGTH ns = size_of_shape (Comb sh) ==> + DISJOINT (set (EL n (with_shape sh ns))) (set (EL n' (with_shape sh ns))) +Proof + Induct >> rw [] >> + fs [with_shape_def] >> + cases_on ‘n’ >> cases_on ‘n'’ >> fs [] + >- ( + fs [MEM_EL] >> + ‘EL n (with_shape sh (DROP (size_of_shape h) ns)) = + TAKE (size_of_shape (EL n sh)) (DROP (size_of_shape (Comb (TAKE n sh))) + (DROP (size_of_shape h) ns))’ by ( + match_mp_tac with_shape_el_take_drop_eq >> + fs [size_of_shape_def] >> + ‘LENGTH (DROP (size_of_shape h) ns) = size_of_shape (Comb sh)’ by + fs [size_of_shape_def] >> + drule length_with_shape_eq_shape >> fs []) >> + fs [] >> + fs [DROP_DROP_T, DROP_TAKE] >> + match_mp_tac disjoint_take_drop_sum >> + fs []) + >- ( + fs [MEM_EL] >> + ‘EL n'' (with_shape sh (DROP (size_of_shape h) ns)) = + TAKE (size_of_shape (EL n'' sh)) (DROP (size_of_shape (Comb (TAKE n'' sh))) + (DROP (size_of_shape h) ns))’ by ( + match_mp_tac with_shape_el_take_drop_eq >> + fs [size_of_shape_def] >> + ‘LENGTH (DROP (size_of_shape h) ns) = size_of_shape (Comb sh)’ by + fs [size_of_shape_def] >> + drule length_with_shape_eq_shape >> fs []) >> + fs [] >> + fs [DROP_DROP_T, DROP_TAKE] >> + match_mp_tac disjoint_drop_take_sum >> + fs []) >> + last_x_assum match_mp_tac >> + fs [size_of_shape_def, ALL_DISTINCT_DROP] +QED + + +Theorem all_distinct_mem_zip_disjoint_with_shape: + LENGTH l = LENGTH sh /\ LENGTH sh = LENGTH (with_shape sh ns) /\ + ALL_DISTINCT ns /\ LENGTH ns = size_of_shape (Comb sh) /\ + MEM (x,a,xs) (ZIP (l,ZIP (sh,with_shape sh ns))) /\ + MEM (y,b,ys) (ZIP (l,ZIP (sh,with_shape sh ns))) /\ + x ≠ y ==> + DISJOINT (set xs) (set ys) +Proof + rw [] >> + ‘LENGTH l = LENGTH (ZIP (sh,with_shape sh ns))’ by fs [] >> + drule MEM_ZIP >> + disch_then (qspec_then ‘(x,a,xs)’ assume_tac) >> + drule MEM_ZIP >> + disch_then (qspec_then ‘(y,b,ys)’ assume_tac) >> + fs [] >> rveq >> + cases_on ‘n = n'’ >> fs [] >> + drule EL_ZIP >> drule EL_ZIP >> + disch_then (qspec_then ‘n’ assume_tac) >> + disch_then (qspec_then ‘n'’ assume_tac) >> + rfs [] >> rveq >> fs [] >> + match_mp_tac all_distinct_disjoint_with_shape >> + fs [] +QED + +Theorem all_distinct_alist_no_overlap: + ALL_DISTINCT (ns:num list) /\ + LENGTH ns = size_of_shape (Comb sh) ∧ + LENGTH vs = LENGTH sh ⇒ + no_overlap (alist_to_fmap (ZIP (vs,ZIP (sh,with_shape sh ns)))) +Proof + rw [] >> + fs [no_overlap_def] >> + conj_tac + >- ( + rw [] >> + drule ALOOKUP_MEM >> + strip_tac >> fs [] >> + drule length_with_shape_eq_shape >> + strip_tac >> + drule LENGTH_ZIP >> + strip_tac >> fs [] >> + ‘LENGTH vs = LENGTH (ZIP (sh,with_shape sh ns))’ by fs [] >> + drule MEM_ZIP >> + disch_then (qspec_then ‘(x,a,xs)’ mp_tac) >> + strip_tac >> fs [] >> rveq >> + ‘LENGTH sh = LENGTH (with_shape sh ns)’ by fs [] >> + drule EL_ZIP >> + disch_then (qspec_then ‘n’ mp_tac) >> + impl_tac >- fs [] >> + strip_tac >> fs [] >> + match_mp_tac all_distinct_with_shape >> + fs []) >> + rw [] >> + CCONTR_TAC >> fs [] >> + dxrule ALOOKUP_MEM >> + dxrule ALOOKUP_MEM >> + rpt strip_tac >> + drule length_with_shape_eq_shape >> + strip_tac >> + drule length_with_shape_eq_shape >> + drule (INST_TYPE [``:'b``|->``:num``] all_distinct_mem_zip_disjoint_with_shape) >> + disch_then (qspecl_then [‘ys’, ‘y’, ‘xs’, ‘x’, ‘ns’, ‘b’, ‘a’] assume_tac) >> + rfs [] +QED + +Theorem all_distinct_alist_ctxt_max: + ALL_DISTINCT (ns:num list) /\ + LENGTH ns = size_of_shape (Comb sh) ∧ + LENGTH vs = LENGTH sh ⇒ + ctxt_max (list_max ns) + (alist_to_fmap (ZIP (vs,ZIP (sh,with_shape sh ns)))) +Proof + rw [] >> fs [ctxt_max_def] >> + rw [] >> + ‘MEM x ns’ suffices_by ( + assume_tac list_max_max >> + pop_assum (qspec_then ‘ns’ assume_tac) >> + fs [EVERY_MEM]) >> + drule ALOOKUP_MEM >> + strip_tac >> + drule length_with_shape_eq_shape >> + strip_tac >> + drule LENGTH_ZIP >> + strip_tac >> fs [] >> + ‘LENGTH vs = LENGTH (ZIP (sh,with_shape sh ns))’ by fs [] >> + drule MEM_ZIP >> + disch_then (qspec_then ‘(v,a,xs)’ mp_tac) >> + strip_tac >> fs [] >> + rveq >> ‘LENGTH sh = LENGTH (with_shape sh ns)’ by fs [] >> + drule EL_ZIP >> + disch_then (qspec_then ‘n’ mp_tac) >> + impl_tac >- fs [] >> + strip_tac >> fs [] >> rveq >> + drule el_mem_with_shape >> + fs [] +QED + +Theorem list_rel_flatten_with_shape_length: + !sh ns args v n. + LENGTH ns = LENGTH (FLAT (MAP flatten args))/\ + size_of_shape (Comb sh) = LENGTH (FLAT (MAP flatten args)) /\ + EL n args = v /\ n < LENGTH args /\ LENGTH args = LENGTH sh /\ + LIST_REL (λsh arg. sh = shape_of arg) sh args ==> + LENGTH (EL n (with_shape sh ns)) = LENGTH (flatten v) +Proof + Induct >> rw [] + >- fs [with_shape_def, size_of_shape_def] >> + fs [with_shape_def, size_of_shape_def] >> + cases_on ‘n’ >> fs [] + >- fs [length_flatten_eq_size_of_shape] >> + last_x_assum match_mp_tac >> + ‘LENGTH (flatten arg) = size_of_shape (shape_of arg)’ by + fs [length_flatten_eq_size_of_shape] >> + fs [] +QED + +Theorem list_rel_flatten_with_shape_flookup: + !sh ns args v n n'. + ALL_DISTINCT ns ∧ LENGTH ns = LENGTH (FLAT (MAP flatten args)) /\ + size_of_shape (Comb sh) = LENGTH (FLAT (MAP flatten args)) /\ + EL n args = v /\ n < LENGTH args /\ LENGTH args = LENGTH sh /\ + LIST_REL (λsh arg. sh = shape_of arg) sh args /\ + LENGTH (EL n (with_shape sh ns)) = LENGTH (flatten v) /\ + n' < LENGTH (EL n (with_shape sh ns)) ==> + FLOOKUP (FEMPTY |++ ZIP (ns,FLAT (MAP flatten args))) + (EL n' (EL n (with_shape sh ns))) = + SOME (EL n' (flatten v)) +Proof + Induct >> rw [] + >- fs [with_shape_def, size_of_shape_def] >> + fs [with_shape_def, size_of_shape_def] >> + cases_on ‘n’ >> fs [] + >- ( + ‘FLOOKUP (FEMPTY |++ ZIP (ns,flatten arg ++ FLAT (MAP flatten ys))) + (EL n' (TAKE (size_of_shape (shape_of arg)) ns)) = + SOME (EL n' (flatten arg ++ FLAT (MAP flatten ys)))’ by ( + ‘size_of_shape (shape_of arg) = LENGTH (flatten arg)’ by + fs [length_flatten_eq_size_of_shape] >> + fs [] >> + ‘EL n' (flatten arg ++ FLAT (MAP flatten ys)) = EL n' (flatten arg)’ by ( + match_mp_tac EL_APPEND1 >> fs []) >> + fs [] >> + ‘FEMPTY |++ ZIP (TAKE (LENGTH (flatten arg)) ns ++ DROP (LENGTH (flatten arg)) ns, + flatten arg ++ FLAT (MAP flatten ys)) = + FEMPTY |++ ZIP (TAKE (LENGTH (flatten arg)) ns,flatten arg) |++ + ZIP (DROP (LENGTH (flatten arg)) ns,FLAT (MAP flatten ys))’ by ( + drule ZIP_APPEND >> + disch_then (qspecl_then [‘DROP (LENGTH (flatten arg)) ns’, ‘FLAT (MAP flatten ys)’]mp_tac) >> + impl_tac >- fs [] >> + strip_tac >> pop_assum (assume_tac o GSYM) >> + fs [] >> + fs [FUPDATE_LIST_APPEND]) >> + fs [] >> pop_assum kall_tac >> + ‘FEMPTY |++ ZIP (TAKE (LENGTH (flatten arg)) ns,flatten arg) |++ + ZIP (DROP (LENGTH (flatten arg)) ns,FLAT (MAP flatten ys)) = + FEMPTY |++ + ZIP (DROP (LENGTH (flatten arg)) ns,FLAT (MAP flatten ys)) |++ + ZIP (TAKE (LENGTH (flatten arg)) ns,flatten arg)’ by ( + match_mp_tac FUPDATE_LIST_APPEND_COMMUTES >> + fs [MAP_ZIP] >> match_mp_tac all_distinct_take_frop_disjoint >> fs []) >> + fs [] >> pop_assum kall_tac >> + match_mp_tac update_eq_zip_flookup >> + fs [] >> + match_mp_tac all_distinct_take >> + fs []) >> + fs [] >> + pop_assum kall_tac >> + metis_tac [EL_APPEND1]) >> + ‘FLOOKUP (FEMPTY |++ ZIP (ns,flatten arg ++ FLAT (MAP flatten ys))) + (EL n' + (EL n'' (with_shape sh (DROP (size_of_shape (shape_of arg)) ns)))) = + FLOOKUP (FEMPTY |++ ZIP (DROP (size_of_shape (shape_of arg)) ns,FLAT (MAP flatten ys))) + (EL n' + (EL n'' (with_shape sh (DROP (size_of_shape (shape_of arg)) ns))))’ by ( + ‘FEMPTY |++ ZIP (ns,flatten arg ++ FLAT (MAP flatten ys)) = + FEMPTY |++ + ZIP (TAKE (LENGTH (flatten arg)) ns,flatten arg) |++ + ZIP (DROP (LENGTH (flatten arg)) ns,FLAT (MAP flatten ys))’ by ( + match_mp_tac fm_zip_append_take_drop >> + fs []) >> + fs [] >> pop_assum kall_tac >> + ‘FLOOKUP + (FEMPTY |++ ZIP (TAKE (LENGTH (flatten arg)) ns,flatten arg)) + (EL n' + (EL n'' (with_shape sh (DROP (size_of_shape (shape_of arg)) ns)))) = NONE’ by ( + match_mp_tac not_mem_fst_zip_flookup_empty >> + fs [] >> drule all_distinct_take >> disch_then (qspec_then ‘LENGTH (flatten arg)’ assume_tac) >> + fs [] >> + CCONTR_TAC >> fs [] >> + fs [GSYM length_flatten_eq_size_of_shape] >> + ‘TAKE (LENGTH (flatten arg)) ns = + EL 0 (with_shape (shape_of arg::sh) ns)’ by + fs [with_shape_def, length_flatten_eq_size_of_shape] >> + ‘EL n'' (with_shape sh (DROP (LENGTH (flatten arg)) ns)) = + EL (SUC n'') (with_shape (shape_of arg::sh) ns)’ by + fs [with_shape_def, length_flatten_eq_size_of_shape] >> + drule all_distinct_disjoint_with_shape >> + disch_then (qspecl_then [‘shape_of arg::sh’, ‘SUC n''’, ‘0’] mp_tac) >> + impl_tac >- fs [length_flatten_eq_size_of_shape, size_of_shape_def] >> + strip_tac >> fs [] >> drule disjoint_not_mem_el >> metis_tac []) >> + drule fupdate_flookup_zip_elim >> + disch_then (qspecl_then [‘DROP (LENGTH (flatten arg)) ns’, ‘FLAT (MAP flatten ys)’] mp_tac) >> + impl_tac >- (fs [] >> match_mp_tac all_distinct_take >> fs []) >> + fs [] >> strip_tac >> + fs [length_flatten_eq_size_of_shape]) >> + fs [] >> + pop_assum kall_tac >> + last_x_assum (qspecl_then [‘DROP (size_of_shape (shape_of arg)) ns’, + ‘ys’, ‘n''’, ‘n'’] mp_tac) >> + impl_tac >- fs [ALL_DISTINCT_DROP, GSYM length_flatten_eq_size_of_shape] >> fs [] +QED + +Theorem eval_upd_clock_eq: + !t e ck. eval (t with clock := ck) e = eval t e +Proof + ho_match_mp_tac eval_ind >> rw [] >> + fs [eval_def] >> + qsuff_tac ‘OPT_MMAP (λa. eval (t with clock := ck) a) es = + OPT_MMAP (λa. eval t a) es’ >> + fs [] >> + pop_assum mp_tac >> + qid_spec_tac ‘es’ >> + Induct >> rw [] >> + fs [OPT_MMAP_def] +QED + +Theorem opt_mmap_eval_upd_clock_eq: + !es s ck. OPT_MMAP (eval (s with clock := ck + s.clock)) es = + OPT_MMAP (eval s) es +Proof + rw [] >> + match_mp_tac IMP_OPT_MMAP_EQ >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + metis_tac [eval_upd_clock_eq] +QED + + +Theorem opt_mmap_eval_upd_clock_eq1: + !es s ck. OPT_MMAP (eval (s with clock := ck)) es = + OPT_MMAP (eval s) es +Proof + rw [] >> + match_mp_tac IMP_OPT_MMAP_EQ >> + fs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + metis_tac [eval_upd_clock_eq] +QED + + +Theorem evaluate_add_clock_eq: + !p t res st ck. + evaluate (p,t) = (res,st) /\ res <> SOME TimeOut ==> + evaluate (p,t with clock := t.clock + ck) = (res,st with clock := st.clock + ck) +Proof + recInduct evaluate_ind >> rw [] >> + TRY (fs [Once evaluate_def] >> NO_TAC) >> + TRY ( + rename [‘Seq’] >> + fs [evaluate_def] >> pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> rveq >> + fs [AllCaseEqs ()] >> rveq >> fs [] >> + first_x_assum (qspec_then ‘ck’ mp_tac) >> + fs []) >> + TRY ( + rename [‘If’] >> + fs [evaluate_def, AllCaseEqs ()] >> rveq >> + fs [eval_upd_clock_eq]) >> + TRY ( + rename [‘ExtCall’] >> + fs [evaluate_def, AllCaseEqs (), empty_locals_def] >> + rveq >> fs []) >> + TRY ( + rename [‘While’] >> + qpat_x_assum ‘evaluate (While _ _,_) = _’ mp_tac >> + once_rewrite_tac [evaluate_def] >> + fs [eval_upd_clock_eq] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] + >- ( + strip_tac >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + fs [dec_clock_def] >> + first_x_assum (qspec_then ‘ck’ mp_tac) >> + fs []) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [dec_clock_def] >> + first_x_assum (qspec_then ‘ck’ mp_tac) >> + fs [] >> + strip_tac >> strip_tac >> fs [] >> rveq >> fs []) >> + TRY ( + rename [‘Call’] >> + qpat_x_assum ‘evaluate (Call _ _ _,_) = _’ mp_tac >> + once_rewrite_tac [evaluate_def] >> + fs [dec_clock_def, eval_upd_clock_eq] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + ‘OPT_MMAP (eval (s with clock := ck + s.clock)) argexps = + OPT_MMAP (eval s) argexps’ by fs [opt_mmap_eval_upd_clock_eq] >> + fs [] >> + fs [AllCaseEqs(), empty_locals_def, dec_clock_def, set_var_def] >> rveq >> fs [] >> + strip_tac >> fs [] >> rveq >> fs []) >> + TRY ( + rename [‘Dec’] >> + fs [evaluate_def, eval_upd_clock_eq, AllCaseEqs () ] >> + pairarg_tac >> fs [] >> rveq >> fs [] >> + pairarg_tac >> fs [] >> rveq >> fs [] >> + last_x_assum (qspec_then ‘ck’ mp_tac) >> + fs []) >> + fs [evaluate_def, eval_upd_clock_eq, AllCaseEqs () , + set_var_def, mem_store_def, + dec_clock_def, empty_locals_def] >> rveq >> + fs [state_component_equality] +QED + +Theorem evaluate_clock_mono: + !p t res st. + evaluate (p,t) = (res,st) ⇒ + st.clock ≤ t.clock +Proof + recInduct evaluate_ind >> rw [] >> + TRY (fs [Once evaluate_def] >> NO_TAC) >> + TRY ( + rename [‘Seq’] >> + fs [evaluate_def] >> pairarg_tac >> fs [] >> + fs [AllCaseEqs ()] >> rveq >> fs []) >> + TRY ( + rename [‘ExtCall’] >> + fs [evaluate_def, AllCaseEqs (), empty_locals_def] >> + rveq >> fs []) >> + TRY ( + rename [‘While’] >> + qpat_x_assum ‘evaluate (While _ _,_) = _’ mp_tac >> + once_rewrite_tac [evaluate_def] >> + every_case_tac >> gs [dec_clock_def,empty_locals_def] >> + TRY (gs [state_component_equality]) >> + TRY (pairarg_tac >> fs [] >> rveq >> fs []) >> + every_case_tac >> gs [] >> + TRY strip_tac >> gs []) >> + TRY ( + rename [‘Dec’] >> + fs [evaluate_def, AllCaseEqs ()] >> + pairarg_tac >> fs [] >> rveq >> fs []) >> + fs [evaluate_def, AllCaseEqs () , + set_var_def, mem_store_def, + dec_clock_def, empty_locals_def] >> rveq >> + fs [] +QED + + +Theorem evaluate_clock_sub: + !p t res st ck. + evaluate (p,t) = (res,st with clock := st.clock + ck) ∧ + res <> SOME TimeOut ⇒ + evaluate (p,t with clock := t.clock - ck) = (res,st) +Proof + recInduct evaluate_ind >> rw [] >> + TRY ( + rename [‘Seq’] >> + fs [evaluate_def] >> pairarg_tac >> fs [] >> + pairarg_tac >> fs [] >> rveq >> + fs [AllCaseEqs ()] >> rveq >> fs [] + >- ( + first_x_assum (qspecl_then [‘s1' with clock := s1'.clock - ck’, ‘ck’] mp_tac) >> + impl_tac + >- ( + gs [state_component_equality] >> + qpat_x_assum ‘evaluate (c2,s1') = _’ assume_tac >> + drule evaluate_clock_mono >> + strip_tac >> gs []) >> + gs []) >> + last_x_assum (qspecl_then [‘st’, ‘ck’] mp_tac) >> + impl_tac >- gs [] >> + strip_tac >> gs []) >> + TRY ( + rename [‘Dec’] >> + fs [evaluate_def, eval_upd_clock_eq, AllCaseEqs ()] + >- gs [state_component_equality] >> + pairarg_tac >> fs [] >> rveq >> fs [] >> + pairarg_tac >> fs [] >> rveq >> fs [] >> + last_x_assum (qspecl_then [‘st'' with clock := st''.clock - ck’, ‘ck’] mp_tac) >> + impl_tac >- gs [state_component_equality] >> + gs [] >> strip_tac >> + rveq >> gs [state_component_equality]) >> + TRY ( + rename [‘While’] >> + qpat_x_assum ‘evaluate (While _ _,_) = _’ mp_tac >> + once_rewrite_tac [evaluate_def] >> + gs [AllCaseEqs(), eval_upd_clock_eq] >> + rw [] >> gs [state_component_equality] >> + rw [] >> gs [] + >- ( + CCONTR_TAC >> gs [] >> + pairarg_tac >> fs [] >> rveq >> fs [] >> + cases_on ‘res'’ >> gs [] + >- ( + imp_res_tac evaluate_clock_mono >> + gs [dec_clock_def]) >> + cases_on ‘x’ >> gs [] >> + imp_res_tac evaluate_clock_mono >> + gs [dec_clock_def]) >> + pairarg_tac >> fs [] >> rveq >> fs [] >> + pairarg_tac >> fs [] >> rveq >> fs [] >> + gs [] >> + cases_on ‘res''’ >> gs [dec_clock_def] + >- ( + first_x_assum (qspecl_then [‘s1' with clock := s1'.clock - ck’, ‘ck’] mp_tac) >> + impl_tac + >- ( + gs [state_component_equality] >> + imp_res_tac evaluate_clock_mono >> + gs []) >> + strip_tac >> gs []) >> + cases_on ‘x’ >> gs [dec_clock_def] >> ( + first_x_assum (qspecl_then [‘s1' with clock := s1'.clock - ck’, ‘ck’] mp_tac) >> + impl_tac + >- ( + gs [state_component_equality] >> + imp_res_tac evaluate_clock_mono >> + gs []) >> + strip_tac >> gs [] >> rveq >> gs [state_component_equality])) >> + TRY ( + rename [‘Call’] >> + qpat_x_assum ‘evaluate (Call _ _ _,_) = _’ mp_tac >> + once_rewrite_tac [evaluate_def] >> gs [] >> + TOP_CASE_TAC >> gs [] + >- ( + gs [AllCaseEqs(), eval_upd_clock_eq] >> + strip_tac >> gs [] >> rveq >> + gs [state_component_equality, eval_upd_clock_eq]) >> + reverse TOP_CASE_TAC >> gs [] + >- ( + gs [AllCaseEqs(), eval_upd_clock_eq] >> + strip_tac >> gs [] >> rveq >> + gs [state_component_equality, eval_upd_clock_eq]) >> + TOP_CASE_TAC >> gs [] + >- ( + gs [AllCaseEqs(), eval_upd_clock_eq] >> + strip_tac >> gs [] >> rveq >> + gs [state_component_equality, eval_upd_clock_eq]) >> + TOP_CASE_TAC >> gs [] + >- ( + gs [AllCaseEqs(), eval_upd_clock_eq] >> + strip_tac >> gs [] >> rveq >> + gs [eval_upd_clock_eq, opt_mmap_eval_upd_clock_eq1] >> + ‘st with clock := st.clock = st’ by gs [state_component_equality] >> + gs []) >> + TOP_CASE_TAC >> gs [] + >- ( + gs [AllCaseEqs(), eval_upd_clock_eq] >> + strip_tac >> gs [] >> rveq >> + gs [eval_upd_clock_eq, opt_mmap_eval_upd_clock_eq1] >> + ‘st with clock := st.clock = st’ by gs [state_component_equality] >> + gs []) >> + TOP_CASE_TAC >> gs [] >> + TOP_CASE_TAC >> gs [] >> + TOP_CASE_TAC >> gs [] >> + TOP_CASE_TAC >> gs [] + >- ( + strip_tac >> rveq >> gs [eval_upd_clock_eq, opt_mmap_eval_upd_clock_eq1] >> + imp_res_tac evaluate_clock_mono >> + gs [dec_clock_def] >> + first_x_assum (qspecl_then [‘st’, ‘ck’] mp_tac) >> + impl_tac >- gs [] >> + strip_tac >> gs []) >> + TOP_CASE_TAC >> gs [] + >- ( + strip_tac >> rveq >> + gs [eval_upd_clock_eq, opt_mmap_eval_upd_clock_eq1, empty_locals_def, dec_clock_def] >> + first_x_assum (qspecl_then [‘r' with clock := r'.clock - ck’, ‘ck’] mp_tac) >> + impl_tac + >- gs [state_component_equality] >> + strip_tac >> gs [] >> + imp_res_tac evaluate_clock_mono >> + gs [dec_clock_def, state_component_equality]) + >- ( + strip_tac >> rveq >> + gs [eval_upd_clock_eq, opt_mmap_eval_upd_clock_eq1, empty_locals_def, dec_clock_def] >> + first_x_assum (qspecl_then [‘st’, ‘ck’] mp_tac) >> + impl_tac + >- gs [state_component_equality] >> + strip_tac >> gs [] >> + imp_res_tac evaluate_clock_mono >> + gs [dec_clock_def, state_component_equality]) + >- ( + strip_tac >> rveq >> + gs [eval_upd_clock_eq, opt_mmap_eval_upd_clock_eq1, empty_locals_def, dec_clock_def] >> + first_x_assum (qspecl_then [‘st’, ‘ck’] mp_tac) >> + impl_tac + >- gs [state_component_equality] >> + strip_tac >> gs [] >> + imp_res_tac evaluate_clock_mono >> + gs [dec_clock_def, state_component_equality]) + >- ( + TOP_CASE_TAC >> gs [] + >- ( + strip_tac >> rveq >> + gs [eval_upd_clock_eq, opt_mmap_eval_upd_clock_eq1, empty_locals_def, dec_clock_def] >> + first_x_assum (qspecl_then [‘r' with clock := r'.clock - ck’, ‘ck’] mp_tac) >> + impl_tac + >- gs [state_component_equality] >> + strip_tac >> gs [] >> + imp_res_tac evaluate_clock_mono >> + gs [dec_clock_def, state_component_equality]) >> + TOP_CASE_TAC >> gs [] + >- ( + strip_tac >> rveq >> + gs [eval_upd_clock_eq, opt_mmap_eval_upd_clock_eq1, empty_locals_def, + dec_clock_def, set_var_def] >> + first_x_assum (qspecl_then [‘r' with clock := r'.clock - ck’, ‘ck’] mp_tac) >> + impl_tac + >- gs [state_component_equality] >> + strip_tac >> gs [] >> + imp_res_tac evaluate_clock_mono >> + gs [dec_clock_def, state_component_equality]) >> + strip_tac >> rveq >> + gs [eval_upd_clock_eq, opt_mmap_eval_upd_clock_eq1, empty_locals_def, + dec_clock_def, set_var_def] >> + first_x_assum (qspecl_then [‘st’, ‘ck’] mp_tac) >> + impl_tac + >- gs [state_component_equality] >> + strip_tac >> gs [] >> + imp_res_tac evaluate_clock_mono >> + gs [dec_clock_def, state_component_equality]) + >- ( + TOP_CASE_TAC >> gs [] + >- ( + strip_tac >> rveq >> + gs [eval_upd_clock_eq, opt_mmap_eval_upd_clock_eq1, empty_locals_def, dec_clock_def] >> + first_x_assum (qspecl_then [‘r' with clock := r'.clock - ck’, ‘ck’] mp_tac) >> + impl_tac + >- gs [state_component_equality] >> + strip_tac >> gs [] >> + imp_res_tac evaluate_clock_mono >> + gs [dec_clock_def, state_component_equality]) >> + TOP_CASE_TAC >> gs [] + >- ( + strip_tac >> rveq >> + gs [eval_upd_clock_eq, opt_mmap_eval_upd_clock_eq1, empty_locals_def, + dec_clock_def, set_var_def] >> + first_x_assum (qspecl_then [‘r' with clock := r'.clock - ck’, ‘ck’] mp_tac) >> + impl_tac + >- gs [state_component_equality] >> + strip_tac >> gs [] >> + imp_res_tac evaluate_clock_mono >> + gs [dec_clock_def, state_component_equality]) >> + TOP_CASE_TAC >> gs [] >> + TOP_CASE_TAC >> gs [] + >- ( + TOP_CASE_TAC >> gs [] + >- ( + strip_tac >> rveq >> + gs [eval_upd_clock_eq, opt_mmap_eval_upd_clock_eq1, empty_locals_def, + dec_clock_def, set_var_def] >> + first_x_assum (qspecl_then [‘st’, ‘ck’] mp_tac) >> + impl_tac + >- gs [state_component_equality] >> + strip_tac >> gs [] >> + imp_res_tac evaluate_clock_mono >> + gs [dec_clock_def, state_component_equality]) >> + reverse TOP_CASE_TAC >> gs [] + >- ( + strip_tac >> rveq >> + gs [eval_upd_clock_eq, opt_mmap_eval_upd_clock_eq1, empty_locals_def, + dec_clock_def, set_var_def] >> + first_x_assum (qspecl_then [‘st’, ‘ck’] mp_tac) >> + impl_tac + >- gs [state_component_equality] >> + strip_tac >> gs [] >> + imp_res_tac evaluate_clock_mono >> + gvs [dec_clock_def, state_component_equality] >> + TOP_CASE_TAC >> gvs []) >> + strip_tac >> rveq >> + gs [eval_upd_clock_eq, opt_mmap_eval_upd_clock_eq1, empty_locals_def, + dec_clock_def, set_var_def] >> + last_x_assum (qspecl_then [‘r' with clock := r'.clock - ck’, ‘ck’] mp_tac) >> + impl_tac + >- ( + gs [state_component_equality] >> + imp_res_tac evaluate_clock_mono >> + gs [dec_clock_def, state_component_equality]) >> + strip_tac >> gs [] >> + first_x_assum (qspecl_then [‘st’, ‘ck’] mp_tac) >> + impl_tac + >- gs [state_component_equality] >> + strip_tac >> gs [] >> + imp_res_tac evaluate_clock_mono >> + gs [dec_clock_def, state_component_equality]) >> + strip_tac >> rveq >> + gs [eval_upd_clock_eq, opt_mmap_eval_upd_clock_eq1, empty_locals_def, + dec_clock_def, set_var_def] >> + last_x_assum (qspecl_then [‘r' with clock := r'.clock - ck’, ‘ck’] mp_tac) >> + impl_tac + >- ( + gs [state_component_equality] >> + imp_res_tac evaluate_clock_mono >> + gs [dec_clock_def, state_component_equality]) >> + strip_tac >> gs [] >> + imp_res_tac evaluate_clock_mono >> + gs [dec_clock_def, state_component_equality]) >> + strip_tac >> rveq >> + gs [eval_upd_clock_eq, opt_mmap_eval_upd_clock_eq1, empty_locals_def, dec_clock_def] >> + last_x_assum (qspecl_then [‘r' with clock := r'.clock - ck’, ‘ck’] mp_tac) >> + impl_tac + >- ( + gs [state_component_equality] >> + imp_res_tac evaluate_clock_mono >> + gs [dec_clock_def, state_component_equality]) >> + strip_tac >> gs [] >> + imp_res_tac evaluate_clock_mono >> + gs [dec_clock_def, state_component_equality]) >> + gs [evaluate_def, AllCaseEqs ()] >> rveq >> + gs [eval_upd_clock_eq, state_component_equality, empty_locals_def, dec_clock_def] +QED + + +Theorem evaluate_io_events_mono: + !exps s1 res s2. + evaluate (exps,s1) = (res, s2) + ⇒ + s1.ffi.io_events ≼ s2.ffi.io_events +Proof + recInduct evaluate_ind >> + rw [] >> + TRY ( + rename [‘Seq’] >> + fs [evaluate_def] >> + pairarg_tac >> fs [] >> rveq >> + every_case_tac >> fs [] >> rveq >> + metis_tac [IS_PREFIX_TRANS]) >> + TRY ( + rename [‘ExtCall’] >> + fs [evaluate_def, AllCaseEqs(), empty_locals_def, + dec_clock_def, ffiTheory.call_FFI_def] >> + rveq >> fs []) >> + TRY ( + rename [‘If’] >> + fs [evaluate_def] >> + every_case_tac >> fs []) >> + TRY ( + rename [‘While’] >> + qpat_x_assum ‘evaluate (While _ _,_) = _’ mp_tac >> + once_rewrite_tac [evaluate_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [empty_locals_def] + >- (strip_tac >> rveq >> fs []) >> + pairarg_tac >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] + >- ( + strip_tac >> fs [] >> + fs [dec_clock_def] >> + metis_tac [IS_PREFIX_TRANS]) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + strip_tac >> fs [] >> rveq >> fs [dec_clock_def] >> + metis_tac [IS_PREFIX_TRANS]) >> + TRY ( + rename [‘Call’] >> + pop_assum mp_tac >> + once_rewrite_tac [evaluate_def, LET_THM] >> + fs [AllCaseEqs(), empty_locals_def, + dec_clock_def, set_var_def] >> + strip_tac >> fs [] >> rveq >> fs [] >> + metis_tac [IS_PREFIX_TRANS]) >> + TRY ( + rename [‘Dec’] >> + fs [evaluate_def, AllCaseEqs () ] >> + pairarg_tac >> fs [] >> rveq >> fs []) >> + fs [evaluate_def, eval_upd_clock_eq, AllCaseEqs () , + set_var_def, mem_store_def, + dec_clock_def, empty_locals_def] >> rveq >> + fs [state_component_equality] +QED + +Theorem evaluate_add_clock_io_events_mono: + ∀exps s extra. + (SND(evaluate(exps,s))).ffi.io_events ≼ + (SND(evaluate(exps,s with clock := s.clock + extra))).ffi.io_events +Proof + recInduct evaluate_ind >> + rw [] >> + TRY ( + rename [‘Seq’] >> + fs [evaluate_def] >> + pairarg_tac >> fs [] >> rveq >> + pairarg_tac >> fs [] >> rveq >> + every_case_tac >> fs [] >> rveq >> fs [] + >- ( + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> + disch_then (qspec_then ‘extra’ mp_tac) >> + fs [] >> + strip_tac >> + strip_tac >> rveq >> fs []) + >- ( + pop_assum mp_tac >> + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> + disch_then (qspec_then ‘extra’ mp_tac) >> + fs []) + >- ( + first_x_assum (qspec_then ‘extra’ mp_tac) >> + strip_tac >> + ‘s1.ffi.io_events ≼ s1'.ffi.io_events’ by rfs [] >> + cases_on ‘evaluate (c2,s1')’ >> + fs [] >> + ‘s1'.ffi.io_events ≼ r.ffi.io_events’ by + metis_tac [evaluate_io_events_mono] >> + metis_tac [IS_PREFIX_TRANS]) >> + first_x_assum (qspec_then ‘extra’ mp_tac) >> + fs []) >> + TRY ( + rename [‘If’] >> + fs [evaluate_def, AllCaseEqs()] >> rveq >> fs [] >> + every_case_tac >> fs [eval_upd_clock_eq]) >> + TRY ( + rename [‘While’] >> + once_rewrite_tac [evaluate_def] >> + TOP_CASE_TAC >> fs [eval_upd_clock_eq] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [empty_locals_def] + >- ( + TOP_CASE_TAC >> fs [] >> rveq >> + fs [dec_clock_def] >> + pairarg_tac >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TRY (cases_on ‘x’) >> fs [] >> + TRY (cases_on ‘evaluate (While e c,s1)’) >> fs [] >> + imp_res_tac evaluate_io_events_mono >> fs [] >> + metis_tac [IS_PREFIX_TRANS]) >> + pairarg_tac >> fs [] >> rveq >> + pairarg_tac >> fs [] >> rveq >> + fs [dec_clock_def] >> + cases_on ‘res’ >> fs [] + >- ( + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘extra’ mp_tac) >> + fs [] >> + strip_tac >> strip_tac >> rveq >> fs []) >> + cases_on ‘x = Continue’ >> fs [] + >- ( + pop_assum mp_tac >> + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘extra’ mp_tac) >> + fs [] >> + strip_tac >> strip_tac >> strip_tac >> rveq >> fs []) >> + cases_on ‘x = TimeOut’ >> rveq >> fs [] + >- ( + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TRY (cases_on ‘x’) >> fs [] >> rveq >> fs [] >> + first_x_assum (qspec_then ‘extra’ mp_tac) >> + fs [] >> strip_tac >> + cases_on ‘evaluate (While e c,s1')’ >> fs [] >> + drule evaluate_io_events_mono >> + strip_tac >> + metis_tac [IS_PREFIX_TRANS]) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + drule evaluate_add_clock_eq >> + fs [] >> + disch_then (qspec_then ‘extra’ mp_tac) >> + fs [] >> + strip_tac >> strip_tac >> strip_tac >> rveq >> fs []) >> + TRY ( + rename [‘Call’] >> + once_rewrite_tac [evaluate_def, LET_THM] >> + fs [eval_upd_clock_eq, opt_mmap_eval_upd_clock_eq] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [empty_locals_def] + >- ( + every_case_tac >> fs [dec_clock_def, empty_locals_def, set_var_def] >> + rveq >> fs [] >> + imp_res_tac evaluate_io_events_mono >> + fs [] >> + TRY (cases_on ‘evaluate (p,r' with locals := s.locals |+ (m'',v))’) >> fs [] >> + imp_res_tac evaluate_io_events_mono >> + fs [] >> metis_tac [IS_PREFIX_TRANS]) >> + fs [dec_clock_def] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] + >- ( + first_x_assum (qspec_then ‘extra’ mp_tac) >> + strip_tac >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] + >- ( + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [set_var_def]) >> + every_case_tac >> fs [] >> rveq >> fs [set_var_def] >> + cases_on ‘evaluate (p,r'' with locals := s.locals |+ (m'',v))’ >> + fs [] >> + imp_res_tac evaluate_io_events_mono >> + fs [] >> metis_tac [IS_PREFIX_TRANS]) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TRY (drule evaluate_add_clock_eq >> fs [] >> NO_TAC) + >- ( + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TRY (cases_on ‘x'’) >> fs [] >> rveq >> fs [] >> + TRY ( + first_x_assum (qspec_then ‘extra’ mp_tac) >> + strip_tac >> fs [] >> + cases_on ‘evaluate (q,s with <|locals := r; + clock := extra + s.clock - 1|>)’ >> + fs [] >> rveq >> fs [] >> NO_TAC) + >- ( + every_case_tac >> fs [] >> rveq >> fs [] >> + first_x_assum (qspec_then ‘extra’ mp_tac) >> + strip_tac >> fs [set_var_def] >> rfs []) >> + every_case_tac >> fs [] >> rveq >> fs [] >> + first_x_assum (qspec_then ‘extra’ mp_tac) >> + strip_tac >> fs [set_var_def] >> rfs [] >> + cases_on ‘evaluate (p,r'' with locals := s.locals |+ (m'',v))’ >> + imp_res_tac evaluate_io_events_mono >> + fs [] >> metis_tac [IS_PREFIX_TRANS]) + >- ( + TOP_CASE_TAC >> fs [] >> rveq >> fs [] + >- ( + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] + >- ( + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> fs []) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TRY ( + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> fs [] >> NO_TAC) >> + first_x_assum (qspec_then ‘extra’ mp_tac) >> + strip_tac >> fs [] >> rfs []) >> + TOP_CASE_TAC >> fs [set_var_def] >> rveq >> fs [] + >- ( + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] + >- ( + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> fs []) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TRY ( + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> fs [] >> NO_TAC) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> rfs [] >> + first_x_assum (qspec_then ‘extra’ mp_tac) >> + strip_tac >> fs [] >> rfs []) >> + drule evaluate_add_clock_eq >> fs []) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] + >- ( + first_x_assum (qspec_then ‘extra’ mp_tac) >> + strip_tac >> fs [] >> + cases_on ‘evaluate (q,s with <|locals := r; clock := extra + s.clock - 1|>)’ >> + fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs []) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] + >- ( + first_x_assum (qspec_then ‘extra’ mp_tac) >> + strip_tac >> fs [] >> + cases_on ‘evaluate (q,s with <|locals := r; clock := extra + s.clock - 1|>)’ >> + fs [] >> + TOP_CASE_TAC >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> fs []) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] + >- ( + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [set_var_def] >> + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> fs [] >> + disch_then (qspec_then ‘extra’ mp_tac) >> + fs [] >> strip_tac >> strip_tac >> + fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> gvs []) >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + pop_assum mp_tac >> + drule evaluate_add_clock_eq >> fs [] >> + disch_then (qspec_then ‘extra’ mp_tac) >> + fs [] >> + strip_tac >> strip_tac >> fs [] >> rveq >> fs []) >> + TRY ( + rename [‘Dec’] >> + fs [evaluate_def] >> + fs [eval_upd_clock_eq] >> + TOP_CASE_TAC >> fs [] >> rveq >> fs [] >> + pairarg_tac >> fs [] >> rveq >> fs [] >> + pairarg_tac >> fs [] >> rveq >> fs [] >> + last_x_assum (qspec_then ‘extra’ mp_tac) >> + fs []) >> + TRY ( + rename [‘ExtCall’] >> + fs [evaluate_def, eval_upd_clock_eq, + empty_locals_def] >> + every_case_tac >> fs []) >> + fs [evaluate_def, eval_upd_clock_eq] >> + every_case_tac >> fs [] >> + fs [set_var_def, mem_store_def, + dec_clock_def, empty_locals_def] >> rveq >> + fs [] +QED + + + +Theorem update_locals_not_vars_eval_eq: + ∀s e v n w. + ~MEM n (var_exp e) /\ + eval s e = SOME v ==> + eval (s with locals := s.locals |+ (n,w)) e = SOME v +Proof + ho_match_mp_tac eval_ind >> + rpt conj_tac >> rpt gen_tac >> strip_tac + >- fs [eval_def] + >- fs [eval_def, var_exp_def, FLOOKUP_UPDATE] + >- fs [eval_def] + >- ( + rpt gen_tac >> + fs [var_exp_def] >> + strip_tac >> + rpt (pop_assum mp_tac) >> + MAP_EVERY qid_spec_tac [‘s’, ‘n’, ‘v’, ‘es’] >> + Induct >> rw [] + >- gs [eval_def, OPT_MMAP_def] >> + gs [eval_def, OPT_MMAP_def] >> + every_case_tac >> gvs [] + >- ( + first_x_assum (qspec_then ‘h’ mp_tac) >> + impl_tac >- gs [] >> + strip_tac >> gs []) + >- ( + last_x_assum (qspecl_then [‘Struct t’, ‘n’, ‘s’] mp_tac) >> + impl_tac >- metis_tac [] >> + strip_tac >> gs []) >> + conj_asm1_tac + >- ( + first_x_assum (qspec_then ‘h’ mp_tac) >> + impl_tac >- gs [] >> + strip_tac >> gs []) >> + gvs [] >> + last_x_assum (qspecl_then [‘Struct t’, ‘n’, ‘s’] mp_tac) >> + impl_tac >- metis_tac [] >> + gs []) + >- ( + rpt gen_tac >> + strip_tac >> + fs [var_exp_def, eval_def] >> + cases_on ‘eval s e’ >> + fs []) + >- ( + rpt gen_tac >> + strip_tac >> fs [var_exp_def] >> + fs [eval_def, CaseEq "option", CaseEq "word_lab"] >> + rveq >> fs [mem_load_def]) + >- ( + rpt gen_tac >> + strip_tac >> fs [var_exp_def] >> + fs [eval_def, CaseEq "option", CaseEq "word_lab"] >> + rveq >> fs [mem_load_def]) + >- ( + rpt gen_tac >> + strip_tac >> fs [var_exp_def, ETA_AX] >> + fs [eval_def, CaseEq "option", ETA_AX] >> + qexists_tac ‘ws’ >> + fs [opt_mmap_eq_some, ETA_AX, + MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + fs [MEM_FLAT, MEM_MAP] >> + metis_tac [EL_MEM]) + >- ( + rw [] >> + gs [var_exp_def, eval_def] >> + every_case_tac >> gvs []) >> + rw [] >> + gs [var_exp_def, eval_def] >> + every_case_tac >> gvs [] +QED + + +Theorem write_bytearray_update_byte: + ∀bytes ad ad' m adrs be. + byte_aligned ad ∧ + (∃w. m ad = Word w) ⇒ + ∃w. + write_bytearray ad' bytes m adrs be + ad = Word w +Proof + Induct >> + rw [] >> + gs [panSemTheory.write_bytearray_def] >> + TOP_CASE_TAC >> gs [] >> + gs [mem_store_byte_def] >> + every_case_tac >> gs [] >> + rveq >> gs [] >> + gs [byte_align_aligned] >> + fs [APPLY_UPDATE_THM] >> + every_case_tac >> gs [] >> + fs [APPLY_UPDATE_THM] +QED + +Theorem evaluate_clock_sub1: + !p t res st t' ck. + evaluate (p,t) = (res,st) /\ res <> SOME TimeOut ∧ + evaluate (p,t with clock := ck + t.clock) = + evaluate (p,t') ⇒ + evaluate (p,t) = evaluate (p,t' with clock := t'.clock - ck) +Proof + rw [] >> gs [] >> + last_x_assum assume_tac >> + drule evaluate_add_clock_eq >> + disch_then (qspec_then ‘ck’ mp_tac) >> + gs [] >> + strip_tac >> + qpat_x_assum ‘_ = evaluate (p,t')’ kall_tac >> + once_rewrite_tac [EQ_SYM_EQ] >> + match_mp_tac evaluate_clock_sub >> + gs [] +QED + + +val _ = export_theory(); diff --git a/pancake/semantics/panSemScript.sml b/pancake/semantics/panSemScript.sml new file mode 100644 index 0000000000..0be06b5d47 --- /dev/null +++ b/pancake/semantics/panSemScript.sml @@ -0,0 +1,495 @@ +(* + Semantics of panLang +*) + +open preamble panLangTheory; +local open alignmentTheory + miscTheory (* for read_bytearray *) + wordLangTheory (* for word_op and word_sh *) + ffiTheory in end; + +val _ = new_theory"panSem"; +val _ = set_grammar_ancestry [ + "panLang", "alignment", + "finite_map", "misc", "wordLang", "ffi", "lprefix_lub"] + +Datatype: + word_lab = Word ('a word) + | Label funname +End + +Datatype: + v = Val ('a word_lab) + | Struct (v list) +End + +Overload ValWord = “\w. Val (Word w)” +Overload ValLabel = “\l. Val (Label l)” + +Datatype: + state = + <| locals : varname |-> 'a v + ; code : funname |-> ((varname # shape) list # ('a panLang$prog)) + (* arguments (with shape), body *) + ; eshapes : eid |-> shape + ; memory : 'a word -> 'a word_lab + ; memaddrs : ('a word) set + ; clock : num + ; be : bool + ; ffi : 'ffi ffi_state + (* ; gaddrs : decname |-> ('a word) (* num? *) *) + (* TODISC: this maps decname to its starting address in the memory and relative size *)|> +End + +val state_component_equality = theorem"state_component_equality"; + +Datatype: + result = Error + | TimeOut + | Break + | Continue + | Return ('a v) + | Exception mlstring ('a v) + | FinalFFI final_event +End + +val s = ``(s:('a,'ffi) panSem$state)`` + + +Theorem MEM_IMP_v_size: + !xs a. MEM a xs ==> (v_size l a < 1 + v1_size l xs) +Proof + Induct >> fs [] >> + rpt strip_tac >> rw [fetch "-" "v_size_def"] >> + res_tac >> decide_tac +QED + + +Definition shape_of_def: + shape_of (ValWord _) = One /\ + shape_of (ValLabel _) = One /\ + shape_of (Struct vs) = Comb (MAP shape_of vs) +Termination + wf_rel_tac `measure (\v. v_size ARB v)` >> + fs [MEM_IMP_v_size] +End + +Overload bytes_in_word = “byte$bytes_in_word” + +Definition mem_load_byte_def: + mem_load_byte m dm be w = + case m (byte_align w) of + | Label _ => NONE + | Word v => + if byte_align w IN dm + then SOME (get_byte w v be) else NONE +End + +Definition mem_load_def: + (mem_load sh addr dm (m: 'a word -> 'a word_lab) = + case sh of + | One => + if addr IN dm + then SOME (Val (m addr)) + else NONE + | Comb shapes => + case mem_loads shapes addr dm m of + | SOME vs => SOME (Struct vs) + | NONE => NONE) /\ + + (mem_loads [] addr dm m = SOME []) /\ + (mem_loads (shape::shapes) addr dm m = + case (mem_load shape addr dm m, + mem_loads shapes (addr + bytes_in_word * n2w (size_of_shape shape)) dm m) of + | SOME v, SOME vs => SOME (v :: vs) + | _ => NONE) +Termination + wf_rel_tac ‘measure (\x. case ISR x of + | T => list_size shape_size (FST (OUTR x)) + | F => shape_size (FST (OUTL x)))’ >> + rw [] + >- ( + qid_spec_tac ‘shapes’ >> + Induct >> rw [] >> fs [list_size_def, shape_size_def]) >> + fs [list_size_def, shape_size_def] >> + fs [list_size_def, shape_size_def] +End + +Definition eval_def: + (eval ^s (Const w) = SOME (ValWord w)) /\ + (eval s (Var v) = FLOOKUP s.locals v) /\ + (eval s (Label fname) = + case FLOOKUP s.code fname of + | SOME _ => SOME (ValLabel fname) + | _ => NONE) /\ +(* + (eval s (GetAddr dname) = + OPTION_MAP ValWord (FLOOKUP s.gaddrs dname)) /\ *) + + (eval s (Struct es) = + case (OPT_MMAP (eval s) es) of + | SOME vs => SOME (Struct vs) + | NONE => NONE) /\ + (eval s (Field index e) = + case eval s e of + | SOME (Struct vs) => + if index < LENGTH vs then SOME (EL index vs) + else NONE + | _ => NONE) /\ + (eval s (Load shape addr) = + case eval s addr of + | SOME (ValWord w) => mem_load shape w s.memaddrs s.memory + | _ => NONE) /\ + (eval s (LoadByte addr) = + case eval s addr of + | SOME (ValWord w) => + (case mem_load_byte s.memory s.memaddrs s.be w of + | NONE => NONE + | SOME w => SOME (ValWord (w2w w))) + | _ => NONE) /\ + (eval s (Op op es) = + case (OPT_MMAP (eval s) es) of + | SOME ws => + if (EVERY (\w. case w of (ValWord _) => T | _ => F) ws) + then OPTION_MAP ValWord + (word_op op (MAP (\w. case w of ValWord n => n) ws)) else NONE + | _ => NONE) /\ + (eval s (Cmp cmp e1 e2) = + case (eval s e1, eval s e2) of + | (SOME (ValWord w1), SOME (ValWord w2)) => + SOME (ValWord (if word_cmp cmp w1 w2 then 1w else 0w)) + | _ => NONE) /\ + (eval s (Shift sh e n) = + case eval s e of + | SOME (ValWord w) => OPTION_MAP ValWord (word_sh sh w n) + | _ => NONE) +Termination + wf_rel_tac `measure (exp_size ARB o SND)` + \\ rpt strip_tac \\ imp_res_tac MEM_IMP_exp_size + \\ TRY (first_x_assum (assume_tac o Q.SPEC `ARB`)) + \\ decide_tac +End + + +(* TODISC: why NONE is returned here on write failure *) +Definition mem_store_byte_def: + mem_store_byte m dm be w b = + case m (byte_align w) of + | Word v => + if byte_align w IN dm + then SOME ((byte_align w =+ Word (set_byte w b v be)) m) + else NONE + | Label _ => NONE +End + +Definition write_bytearray_def: + (write_bytearray a [] m dm be = m) /\ + (write_bytearray a (b::bs) m dm be = + case mem_store_byte (write_bytearray (a+1w) bs m dm be) dm be a b of + | SOME m => m + | NONE => m) + +End + +(* +Definition write_bytearray_def: + (write_bytearray a [] m dm be = SOME m) /\ + (write_bytearray a (b::bs) m dm be = + case mem_store_byte m dm be a b of + | SOME m => write_bytearray (a+1w) bs m dm be + | NONE => NONE) +End +*) + +Definition mem_store_def: + mem_store (addr:'a word) (w:'a word_lab) dm m = + if addr IN dm then + SOME ((addr =+ w) m) + else NONE +End + +Definition mem_stores_def: + (mem_stores a [] dm m = SOME m) /\ + (mem_stores a (w::ws) dm m = + case mem_store a w dm m of + | SOME m' => mem_stores (a + bytes_in_word) ws dm m' + | NONE => NONE) +End + +Definition flatten_def: + (flatten (Val w) = [w]) ∧ + (flatten (Struct vs) = FLAT (MAP flatten vs)) +Termination + wf_rel_tac `measure (\v. v_size ARB v)` >> + fs [MEM_IMP_v_size] +End + +Definition set_var_def: + set_var v value ^s = + (s with locals := s.locals |+ (v,value)) +End + +Definition upd_locals_def: + upd_locals varargs ^s = + s with <| locals := FEMPTY |++ varargs |> +End + +Definition empty_locals_def: + empty_locals ^s = + s with <| locals := FEMPTY |> +End + +Definition dec_clock_def: + dec_clock ^s = + s with clock := s.clock - 1 +End + +Definition fix_clock_def: + fix_clock old_s (res, new_s) = + (res, new_s with <|clock := if old_s.clock < new_s.clock then old_s.clock else new_s.clock |>) +End + +Theorem fix_clock_IMP_LESS_EQ: + !x. fix_clock ^s x = (res,s1) ==> s1.clock <= s.clock +Proof + full_simp_tac(srw_ss())[fix_clock_def,FORALL_PROD] >> + srw_tac[][] >> full_simp_tac(srw_ss())[] >> decide_tac +QED + +Definition lookup_code_def: + lookup_code code fname args = + case (FLOOKUP code fname) of + | SOME (vshapes, prog) => + if ALL_DISTINCT (MAP FST vshapes) ∧ + LIST_REL (\vshape arg. SND vshape = shape_of arg) vshapes args + then SOME (prog, FEMPTY |++ ZIP (MAP FST vshapes,args)) + else NONE + | _ => NONE +End + +Definition is_valid_value_def: + is_valid_value locals v value = + case FLOOKUP locals v of + | SOME w => shape_of value = shape_of w + | NONE => F +End + +Definition res_var_def: + (res_var lc (n, NONE) = lc \\ n) /\ + (res_var lc (n, SOME v) = lc |+ (n,v)) +End + +Definition evaluate_def: + (evaluate (Skip:'a panLang$prog,^s) = (NONE,s)) /\ + (evaluate (Dec v e prog, s) = + case (eval s e) of + | SOME value => + let (res,st) = evaluate (prog,s with locals := s.locals |+ (v,value)) in + (res, st with locals := res_var st.locals (v, FLOOKUP s.locals v)) + | NONE => (SOME Error, s)) /\ + (evaluate (Assign v src,s) = + case (eval s src) of + | SOME value => + if is_valid_value s.locals v value + then (NONE, s with locals := s.locals |+ (v,value)) + else (SOME Error, s) + | NONE => (SOME Error, s)) /\ + (evaluate (Store dst src,s) = + case (eval s dst, eval s src) of + | (SOME (ValWord addr), SOME value) => + (case mem_stores addr (flatten value) s.memaddrs s.memory of + | SOME m => (NONE, s with memory := m) + | NONE => (SOME Error, s)) + | _ => (SOME Error, s)) /\ + (evaluate (StoreByte dst src,s) = + case (eval s dst, eval s src) of + | (SOME (ValWord adr), SOME (ValWord w)) => + (case mem_store_byte s.memory s.memaddrs s.be adr (w2w w) of + | SOME m => (NONE, s with memory := m) + | NONE => (SOME Error, s)) + | _ => (SOME Error, s)) /\ + (evaluate (Seq c1 c2,s) = + let (res,s1) = fix_clock s (evaluate (c1,s)) in + if res = NONE then evaluate (c2,s1) else (res,s1)) /\ + (evaluate (If e c1 c2,s) = + case (eval s e) of + | SOME (ValWord w) => + evaluate (if w <> 0w then c1 else c2, s) (* False is 0, True is everything else *) + | _ => (SOME Error,s)) /\ + (evaluate (Break,s) = (SOME Break,s)) /\ + (evaluate (Continue,s) = (SOME Continue,s)) /\ + (evaluate (While e c,s) = + case (eval s e) of + | SOME (ValWord w) => + if (w <> 0w) then + (if s.clock = 0 then (SOME TimeOut,empty_locals s) else + let (res,s1) = fix_clock (dec_clock s) (evaluate (c,dec_clock s)) in + case res of + | SOME Continue => evaluate (While e c,s1) + | NONE => evaluate (While e c,s1) + | SOME Break => (NONE,s1) + | _ => (res,s1)) + else (NONE,s) + | _ => (SOME Error,s)) /\ + (evaluate (Return e,s) = + case (eval s e) of + | SOME value => + if size_of_shape (shape_of value) <= 32 + then (SOME (Return value),empty_locals s) + else (SOME Error,s) + | _ => (SOME Error,s)) /\ + (evaluate (Raise eid e,s) = + case (FLOOKUP s.eshapes eid, eval s e) of + | (SOME sh, SOME value) => + if shape_of value = sh ∧ + size_of_shape (shape_of value) <= 32 + then (SOME (Exception eid value),empty_locals s) + else (SOME Error,s) + | _ => (SOME Error,s)) /\ + (evaluate (Tick,s) = + if s.clock = 0 then (SOME TimeOut,empty_locals s) + else (NONE,dec_clock s)) /\ + (evaluate (Call caltyp trgt argexps,s) = + case (eval s trgt, OPT_MMAP (eval s) argexps) of + | (SOME (ValLabel fname), SOME args) => + (case lookup_code s.code fname args of + | SOME (prog, newlocals) => if s.clock = 0 then (SOME TimeOut,empty_locals s) + else + let eval_prog = fix_clock ((dec_clock s) with locals := newlocals) + (evaluate (prog, (dec_clock s) with locals:= newlocals)) in + (case eval_prog of + | (NONE,st) => (SOME Error,st) + | (SOME Break,st) => (SOME Error,st) + | (SOME Continue,st) => (SOME Error,st) + | (SOME (Return retv),st) => + (case caltyp of + | Tail => (SOME (Return retv),empty_locals st) + | Ret rt _ => + if is_valid_value s.locals rt retv + then (NONE, set_var rt retv (st with locals := s.locals)) + else (SOME Error,st)) + | (SOME (Exception eid exn),st) => + (case caltyp of + | Tail => (SOME (Exception eid exn),empty_locals st) + | Ret _ NONE => (SOME (Exception eid exn),empty_locals st) + | Ret _ (SOME (Handle eid' evar p)) => + if eid = eid' then + case FLOOKUP s.eshapes eid of + | SOME sh => + if shape_of exn = sh ∧ is_valid_value s.locals evar exn then + evaluate (p, set_var evar exn (st with locals := s.locals)) + else (SOME Error,st) + | NONE => (SOME Error,st) + else (SOME (Exception eid exn), empty_locals st)) + | (res,st) => (res,empty_locals st)) + | _ => (SOME Error,s)) + | (_, _) => (SOME Error,s)) /\ + (evaluate (ExtCall ffi_index ptr1 len1 ptr2 len2,s) = + case (FLOOKUP s.locals len1, FLOOKUP s.locals ptr1, FLOOKUP s.locals len2, FLOOKUP s.locals ptr2) of + | SOME (ValWord sz1),SOME (ValWord ad1),SOME (ValWord sz2),SOME (ValWord ad2) => + (case (read_bytearray ad1 (w2n sz1) (mem_load_byte s.memory s.memaddrs s.be), + read_bytearray ad2 (w2n sz2) (mem_load_byte s.memory s.memaddrs s.be)) of + | SOME bytes,SOME bytes2 => + (case call_FFI s.ffi (explode ffi_index) bytes bytes2 of + | FFI_final outcome => (SOME (FinalFFI outcome), empty_locals s) + | FFI_return new_ffi new_bytes => + let nmem = write_bytearray ad2 new_bytes s.memory s.memaddrs s.be in + (NONE, s with <| memory := nmem; ffi := new_ffi |>)) + | _ => (SOME Error,s)) + | res => (SOME Error,s)) +Termination + wf_rel_tac `(inv_image (measure I LEX measure (prog_size (K 0))) + (\(xs,^s). (s.clock,xs)))` >> + rpt strip_tac >> TRY (full_simp_tac(srw_ss())[] >> DECIDE_TAC) >> + imp_res_tac fix_clock_IMP_LESS_EQ >> full_simp_tac(srw_ss())[] >> + imp_res_tac (GSYM fix_clock_IMP_LESS_EQ) >> + full_simp_tac(srw_ss())[set_var_def,upd_locals_def,dec_clock_def, LET_THM] >> + rpt (pairarg_tac >> full_simp_tac(srw_ss())[]) >> + every_case_tac >> full_simp_tac(srw_ss())[] >> + decide_tac +End + +val evaluate_ind = theorem"evaluate_ind"; + + +Theorem vshapes_args_rel_imp_eq_len_MAP: + !vshapes args. + LIST_REL (\vshape arg. SND vshape = shape_of arg) vshapes args ==> + LENGTH vshapes = LENGTH args /\ MAP SND vshapes = MAP shape_of args +Proof + ho_match_mp_tac LIST_REL_ind >> rw [] +QED + +(* +Definition evaluate_main_def: + (evaluate_main (Decl dname str,^s) = ARB) /\ + (evaluate_main (Func fname rettyp partyp prog,s) = ARB) +End +*) + +Theorem evaluate_clock: + !prog s r s'. (evaluate (prog,s) = (r,s')) ==> + s'.clock <= s.clock +Proof + recInduct evaluate_ind >> + REPEAT STRIP_TAC >> + POP_ASSUM MP_TAC >> ONCE_REWRITE_TAC [evaluate_def] >> + rw [] >> every_case_tac >> + fs [set_var_def, upd_locals_def, empty_locals_def, dec_clock_def, LET_THM] >> + rveq >> fs [] >> + rpt (pairarg_tac >> fs []) >> + every_case_tac >> fs [] >> rveq >> + imp_res_tac fix_clock_IMP_LESS_EQ >> + imp_res_tac LESS_EQ_TRANS >> fs [] >> rfs [] >> + ‘s.clock <= s.clock + 1’ by DECIDE_TAC >> + res_tac >> fs [] +QED + +Theorem fix_clock_evaluate: + fix_clock s (evaluate (prog,s)) = evaluate (prog,s) +Proof + Cases_on `evaluate (prog,s)` >> fs [fix_clock_def] >> + imp_res_tac evaluate_clock >> + fs [GSYM NOT_LESS, state_component_equality] +QED + +(* we save evaluate theorems without fix_clock *) +val evaluate_ind = save_thm("evaluate_ind", + REWRITE_RULE [fix_clock_evaluate] evaluate_ind); + +val evaluate_def = save_thm("evaluate_def[compute]", + REWRITE_RULE [fix_clock_evaluate] evaluate_def); + +(* observational semantics *) + +Definition semantics_def: + semantics ^s start = + let prog = Call Tail (Label start) [] in + if ∃k. case FST (evaluate (prog,s with clock := k)) of + | SOME TimeOut => F + | SOME (FinalFFI _) => F + | SOME (Return _) => F + | _ => T + then Fail + else + case some res. + ∃k t r outcome. + evaluate (prog, s with clock := k) = (r,t) ∧ + (case r of + | (SOME (FinalFFI e)) => outcome = FFI_outcome e + | (SOME (Return _)) => outcome = Success + | _ => F) ∧ + res = Terminate outcome t.ffi.io_events + of + | SOME res => res + | NONE => + Diverge + (build_lprefix_lub + (IMAGE (λk. fromList + (SND (evaluate (prog,s with clock := k))).ffi.io_events) UNIV)) +End + + +val _ = map delete_binding ["evaluate_AUX_def", "evaluate_primitive_def"]; + +val _ = export_theory(); diff --git a/pancake/semantics/pan_commonPropsScript.sml b/pancake/semantics/pan_commonPropsScript.sml new file mode 100644 index 0000000000..5b678866e8 --- /dev/null +++ b/pancake/semantics/pan_commonPropsScript.sml @@ -0,0 +1,812 @@ +(* + Common Properties for Pancake ILS +*) + +open preamble pan_commonTheory; + +val _ = new_theory "pan_commonProps"; + + +Definition ctxt_max_def: + ctxt_max (n:num) fm <=> + 0 <= n ∧ + (!v a xs. + FLOOKUP fm v = SOME (a,xs) ==> !x. MEM x xs ==> x <= n) +End + +Definition no_overlap_def: + no_overlap fm <=> + (!x a xs. + FLOOKUP fm x = SOME (a,xs) ==> ALL_DISTINCT xs) /\ + (!x y a b xs ys. + FLOOKUP fm x = SOME (a,xs) /\ + FLOOKUP fm y = SOME (b,ys) /\ + ~DISJOINT (set xs) (set ys) ==> x = y) +End + +Theorem opt_mmap_eq_some: + ∀xs f ys. + OPT_MMAP f xs = SOME ys <=> + MAP f xs = MAP SOME ys +Proof + Induct >> rw [OPT_MMAP_def] >> + eq_tac >> rw [] >> fs [] >> + cases_on ‘ys’ >> fs [] +QED + + +Theorem map_append_eq_drop: + !xs ys zs f. + MAP f xs = ys ++ zs ==> + MAP f (DROP (LENGTH ys) xs) = zs +Proof + Induct >> rw [] >> + cases_on ‘ys’ >> fs [DROP] +QED + + +Theorem opt_mmap_mem_func: + ∀l f n g. + OPT_MMAP f l = SOME n ∧ MEM g l ==> + ?m. f g = SOME m +Proof + Induct >> + rw [OPT_MMAP_def] >> + res_tac >> fs [] +QED + +Theorem opt_mmap_mem_defined: + !l f m e n. + OPT_MMAP f l = SOME m ∧ + MEM e l ∧ f e = SOME n ==> + MEM n m +Proof + Induct >> rw [] >> + fs [OPT_MMAP_def] >> rveq + >- fs [MEM] >> + res_tac >> fs [] +QED + + +Theorem opt_mmap_el: + ∀l f x n. + OPT_MMAP f l = SOME x ∧ + n < LENGTH l ==> + f (EL n l) = SOME (EL n x) +Proof + Induct >> + rw [OPT_MMAP_def] >> + cases_on ‘n’ >> fs [] +QED + +Theorem opt_mmap_length_eq: + ∀l f n. + OPT_MMAP f l = SOME n ==> + LENGTH l = LENGTH n +Proof + Induct >> + rw [OPT_MMAP_def] >> + res_tac >> fs [] +QED + +Theorem opt_mmap_opt_map: + !l f n g. + OPT_MMAP f l = SOME n ==> + OPT_MMAP (λa. OPTION_MAP g (f a)) l = SOME (MAP g n) +Proof + Induct >> rw [] >> + fs [OPT_MMAP_def] >> rveq >> + res_tac >> fs [] +QED + +Theorem distinct_lists_append: + ALL_DISTINCT (xs ++ ys) ==> + distinct_lists xs ys +Proof + rw [] >> + fs [ALL_DISTINCT_APPEND, distinct_lists_def, EVERY_MEM] +QED + +Theorem distinct_lists_commutes: + distinct_lists xs ys = distinct_lists ys xs +Proof + EQ_TAC >> + rw [] >> + fs [distinct_lists_def, EVERY_MEM] >> + metis_tac [] +QED + +Theorem distinct_lists_cons: + distinct_lists (ns ++ xs) (ys ++ zs) ==> + distinct_lists xs zs +Proof + rw [] >> + fs [ALL_DISTINCT_APPEND, distinct_lists_def, EVERY_MEM] +QED + +Theorem distinct_lists_simp_cons: + distinct_lists xs (y :: ys) ==> + distinct_lists xs ys +Proof + rw [] >> + fs [ALL_DISTINCT_APPEND, distinct_lists_def, EVERY_MEM] +QED + +Theorem distinct_lists_append_intro: + distinct_lists xs ys /\ + distinct_lists xs zs ==> + distinct_lists xs (ys ++ zs) +Proof + rw [] >> + fs [ALL_DISTINCT_APPEND, distinct_lists_def, EVERY_MEM] +QED + +Theorem opt_mmap_flookup_update: + OPT_MMAP (FLOOKUP fm) xs = SOME ys /\ + ~MEM x xs ==> + OPT_MMAP (FLOOKUP (fm |+ (x,y))) xs = SOME ys +Proof + rw [] >> + fs [opt_mmap_eq_some, MAP_EQ_EVERY2, LIST_REL_EL_EQN] >> + rw [] >> + fs [FLOOKUP_UPDATE, MEM_EL] >> + metis_tac [] +QED + + + +Theorem opt_mmap_some_eq_zip_flookup: + ∀xs f ys. + ALL_DISTINCT xs /\ + LENGTH xs = LENGTH ys ⇒ + OPT_MMAP (FLOOKUP (f |++ ZIP (xs,ys))) xs = + SOME ys +Proof + Induct >> rw [OPT_MMAP_def] >> + fs [] >> + cases_on ‘ys’ >> fs [] >> + fs [FUPDATE_LIST_THM] >> + ‘~MEM h (MAP FST (ZIP (xs,t)))’ by + metis_tac [MEM_MAP, MEM_ZIP,FST, MEM_EL] >> + drule FUPDATE_FUPDATE_LIST_COMMUTES >> + disch_then (qspecl_then [‘h'’, ‘f’] assume_tac) >> + fs [FLOOKUP_DEF] +QED + +Theorem opt_mmap_disj_zip_flookup: + ∀xs f ys zs. + distinct_lists xs ys /\ + LENGTH xs = LENGTH zs ⇒ + OPT_MMAP (FLOOKUP (f |++ ZIP (xs,zs))) ys = + OPT_MMAP (FLOOKUP f) ys +Proof + Induct >> rw [] >> + fs [distinct_lists_def] + >- fs [FUPDATE_LIST_THM] >> + cases_on ‘zs’ >> fs [] >> + fs [FUPDATE_LIST_THM] >> + ho_match_mp_tac IMP_OPT_MMAP_EQ >> + ho_match_mp_tac MAP_CONG >> fs [] >> + rw [] >> + fs [FLOOKUP_UPDATE] >> + metis_tac [] +QED + + +Theorem genlist_distinct_max: + !n ys m. + (!y. MEM y ys ==> y <= m) ==> + distinct_lists (GENLIST (λx. SUC x + m) n) ys +Proof + rw [] >> + fs [distinct_lists_def, EVERY_GENLIST] >> + rw [] >> + CCONTR_TAC >> fs [] >> + first_x_assum drule >> + DECIDE_TAC +QED + +Theorem genlist_distinct_max': + !n ys m p. + (!y. MEM y ys ==> y <= m) ==> + distinct_lists (GENLIST (λx. SUC x + (m + p)) n) ys +Proof + rw [] >> + fs [distinct_lists_def, EVERY_GENLIST] >> + rw [] >> + CCONTR_TAC >> fs [] >> + first_x_assum drule >> + DECIDE_TAC +QED + +Theorem update_eq_zip_flookup: + ∀xs f ys n. + ALL_DISTINCT xs /\ + LENGTH xs = LENGTH ys /\ + n < LENGTH xs ⇒ + FLOOKUP (f |++ ZIP (xs,ys)) (EL n xs) = + SOME (EL n ys) +Proof + Induct >> rw [FUPDATE_LIST_THM] >> + cases_on ‘ys’ >> + fs [FUPDATE_LIST_THM] >> + ‘~MEM h (MAP FST (ZIP (xs,t)))’ by + metis_tac [MEM_MAP, MEM_ZIP,FST, MEM_EL] >> + cases_on ‘n’ >> fs [] >> + drule FUPDATE_FUPDATE_LIST_COMMUTES >> + disch_then (qspecl_then [‘h'’, ‘f’] assume_tac) >> + fs [FLOOKUP_DEF] +QED + +Theorem update_eq_zip_map_flookup: + ∀xs f n m. + n < LENGTH xs ⇒ + FLOOKUP (f |++ ZIP (xs,MAP (λx. m) xs)) (EL n xs) = + SOME m +Proof + Induct >> rw [FUPDATE_LIST_THM] >> + cases_on ‘n’ >> + fs [] >> + cases_on ‘~MEM h (MAP FST (ZIP (xs,MAP (λx. m) xs)))’ + >- ( + drule FUPDATE_FUPDATE_LIST_COMMUTES >> + disch_then (qspecl_then [‘m’, ‘f’] assume_tac) >> + fs [FLOOKUP_DEF]) >> + fs [] >> + fs [MEM_MAP] >> rveq >> fs [] >> + cases_on ‘y’ >> fs [] >> + ‘LENGTH xs = LENGTH (MAP (λx. m) xs)’ by fs [] >> + drule MEM_ZIP >> + disch_then (qspec_then ‘(q,r)’ mp_tac) >> + fs [] >> + strip_tac >> rveq >> fs [] +QED + + + +Theorem flookup_fupdate_zip_not_mem: + ∀xs ys f n. + LENGTH xs = LENGTH ys /\ + ~MEM n xs ⇒ + FLOOKUP (f |++ ZIP (xs,ys)) n = + FLOOKUP f n +Proof + Induct >> rw [FUPDATE_LIST_THM] >> + cases_on ‘ys’ >> + fs [FUPDATE_LIST_THM] >> + metis_tac [FLOOKUP_UPDATE] +QED + +Theorem map_flookup_fupdate_zip_not_mem: + ∀xs ys f n. + distinct_lists xs ys /\ + LENGTH xs = LENGTH zs ⇒ + MAP (FLOOKUP (f |++ ZIP (xs,zs))) ys = + MAP (FLOOKUP f) ys +Proof + rw [] >> + fs [MAP_EQ_EVERY2] >> + ho_match_mp_tac EVERY2_refl >> + rw [] >> + fs [distinct_lists_def, EVERY_MEM] >> + ho_match_mp_tac flookup_fupdate_zip_not_mem >> + metis_tac [] +QED + + +Theorem domsub_commutes_fupdate: + !xs ys fm x. + ~MEM x xs ∧ LENGTH xs = LENGTH ys ==> + (fm |++ ZIP (xs,ys)) \\ x = (fm \\ x) |++ ZIP (xs,ys) +Proof + Induct >> rw [] + >- fs [FUPDATE_LIST_THM] >> + cases_on ‘ys’ >> fs [] >> + fs [FUPDATE_LIST_THM] >> + metis_tac [DOMSUB_FUPDATE_NEQ] +QED + + +Theorem map_the_some_cancel: + !xs. MAP (THE ∘ SOME) xs = xs +Proof + Induct >> rw [] +QED + +Triviality FUPDATE_LIST_APPLY_NOT_MEM_ZIP: + ∀l1 l2 f k. + LENGTH l1 = LENGTH l2 ∧ ¬MEM k l1 ⇒ (f |++ ZIP (l1, l2)) ' k = f ' k +Proof + metis_tac [FUPDATE_LIST_APPLY_NOT_MEM, MAP_ZIP] +QED + +Theorem fm_multi_update: + !xs ys a b c d fm. + ~MEM a xs ∧ ~MEM c xs ∧ a ≠ c ∧ LENGTH xs = LENGTH ys ==> + fm |++ ((a,b)::(c,d)::ZIP (xs,ys)) |++ ((a,b)::ZIP (xs,ys)) = + fm |++ ((a,b)::(c,d)::ZIP (xs,ys)) +Proof + fs [FUPDATE_LIST_THM, GSYM fmap_EQ_THM, FDOM_FUPDATE, FDOM_FUPDATE_LIST] >> + rpt strip_tac + >- (fs [pred_setTheory.EXTENSION] >> metis_tac []) >> + fs [FUPDATE_LIST_APPLY_NOT_MEM_ZIP, FAPPLY_FUPDATE_THM] >> + (Cases_on ‘MEM x xs’ + >- (match_mp_tac FUPDATE_SAME_LIST_APPLY >> simp [MAP_ZIP]) + >- rw [FUPDATE_LIST_APPLY_NOT_MEM_ZIP, FAPPLY_FUPDATE_THM]) +QED + +Theorem el_reduc_tl: + !l n. 0 < n ∧ n < LENGTH l ==> EL n l = EL (n-1) (TL l) +Proof + Induct >> rw [] >> + cases_on ‘n’ >> fs [] +QED + +Theorem zero_not_mem_genlist_offset: + !t. LENGTH t <= 31 ==> + ~MEM 0w (MAP (n2w:num -> word5) (GENLIST (λi. i + 1) (LENGTH t))) +Proof + Induct >> rw [] >> + CCONTR_TAC >> fs [MEM_MAP, MEM_GENLIST] >> rveq >> + fs [ADD1] >> + ‘(i + 1) MOD 32 = i + 1’ by ( + match_mp_tac LESS_MOD >> DECIDE_TAC) >> + fs [] +QED + +Theorem all_distinct_take: + !ns n. + ALL_DISTINCT ns /\ n <= LENGTH ns ==> + ALL_DISTINCT (TAKE n ns) +Proof + Induct >> rw [] >> fs [] >> + cases_on ‘n’ >> fs [TAKE] >> + metis_tac [MEM_TAKE] +QED + +Theorem all_distinct_drop: + !ns n. + ALL_DISTINCT ns /\ n <= LENGTH ns ==> + ALL_DISTINCT (DROP n ns) +Proof + Induct >> rw [] >> fs [] >> + cases_on ‘n’ >> fs [DROP] >> + metis_tac [MEM_DROP] +QED + +Theorem disjoint_take_drop_sum: + !n m p ns. + ALL_DISTINCT ns ==> + DISJOINT (set (TAKE n ns)) (set (TAKE p (DROP (n + m) ns))) +Proof + Induct >> rw [] >> + cases_on ‘ns’ >> fs [LESS_EQ_ADD_SUB, SUC_SUB1] >> + CCONTR_TAC >> fs [] >> + drule MEM_TAKE >> + strip_tac >> + drule MEM_DROP_IMP >> fs [] +QED + + +Theorem disjoint_drop_take_sum: + !n m p ns. + ALL_DISTINCT ns ==> + DISJOINT (set (TAKE p (DROP (n + m) ns))) (set (TAKE n ns)) +Proof + Induct >> rw [] >> + cases_on ‘ns’ >> fs [LESS_EQ_ADD_SUB, SUC_SUB1] >> + CCONTR_TAC >> fs [] >> + drule MEM_TAKE >> + strip_tac >> + drule MEM_DROP_IMP >> fs [] +QED + +Theorem fm_empty_zip_alist: + !xs ys. LENGTH xs = LENGTH ys /\ + ALL_DISTINCT xs ==> + FEMPTY |++ ZIP (xs,ys) = + alist_to_fmap (ZIP (xs,ys)) +Proof + Induct >> rw [] + >- fs [FUPDATE_LIST_THM] >> + cases_on ‘ys’ >> fs [] >> + fs [FUPDATE_LIST_THM] >> + last_x_assum (qspecl_then [‘t’] assume_tac) >> + fs [] >> + pop_assum (assume_tac o GSYM) >> + fs [] >> + match_mp_tac FUPDATE_FUPDATE_LIST_COMMUTES >> + CCONTR_TAC >> fs [MEM_MAP] >> rveq >> + drule MEM_ZIP >> + disch_then (qspec_then ‘y’ mp_tac) >> + strip_tac >> fs [] >> rveq >> fs [FST] >> + fs [MEM_EL] >> metis_tac [] +QED + +Theorem fm_empty_zip_flookup: + !xs ys x y. + LENGTH xs = LENGTH ys /\ ALL_DISTINCT xs /\ + FLOOKUP (FEMPTY |++ ZIP (xs,ys)) x = SOME y ==> + ?n. n < LENGTH xs /\ EL n (ZIP (xs,ys)) = (x,y) +Proof + Induct >> rw [] + >- fs [FUPDATE_LIST_THM] >> + cases_on ‘ys’ >> fs [] >> + fs [FUPDATE_LIST_THM] >> + cases_on ‘x = h’ >> fs [] >> rveq + >- ( + qexists_tac ‘0’ >> fs [] >> + ‘~MEM h (MAP FST (ZIP (xs,t)))’ by + metis_tac [MEM_MAP, MEM_ZIP,FST, MEM_EL] >> + drule FUPDATE_FUPDATE_LIST_COMMUTES >> + disch_then (qspecl_then [‘h'’, ‘FEMPTY’] assume_tac) >> + fs [FLOOKUP_DEF]) >> + ‘~MEM h (MAP FST (ZIP (xs,t)))’ by + metis_tac [MEM_MAP, MEM_ZIP,FST, MEM_EL] >> + drule FUPDATE_FUPDATE_LIST_COMMUTES >> + disch_then (qspecl_then [‘h'’, ‘FEMPTY’] assume_tac) >> + fs [] >> + fs [FLOOKUP_UPDATE] >> + last_x_assum (qspec_then ‘t’ mp_tac) >> + fs [] >> + disch_then drule >> + strip_tac >> fs [] >> + qexists_tac ‘SUC n’ >> fs [] +QED + +Theorem fm_empty_zip_flookup_el: + !xs ys zs n x. + ALL_DISTINCT xs /\ LENGTH xs = LENGTH ys /\ LENGTH ys = LENGTH zs /\ + n < LENGTH xs /\ EL n xs = x ==> + FLOOKUP (FEMPTY |++ ZIP (xs,ZIP (ys,zs))) x = SOME (EL n ys,EL n zs) +Proof + Induct >> rw [] >> + cases_on ‘ys’ >> cases_on ‘zs’ >> fs [] >> + fs [FUPDATE_LIST_THM] >> + cases_on ‘n’ >> fs [] + >- ( + ‘~MEM h (MAP FST (ZIP (xs,ZIP (t,t'))))’ by ( + ‘LENGTH xs = LENGTH (ZIP (t,t'))’ by fs [] >> + metis_tac [MEM_MAP, MEM_ZIP,FST, MEM_EL]) >> + drule FUPDATE_FUPDATE_LIST_COMMUTES >> + disch_then (qspecl_then [‘(h', h'')’, ‘FEMPTY’] assume_tac) >> + fs [FLOOKUP_DEF]) >> + ‘~MEM h (MAP FST (ZIP (xs,ZIP (t,t'))))’ by ( + ‘LENGTH xs = LENGTH (ZIP (t,t'))’ by fs [] >> + metis_tac [MEM_MAP, MEM_ZIP,FST, MEM_EL]) >> + drule FUPDATE_FUPDATE_LIST_COMMUTES >> + disch_then (qspecl_then [‘(h', h'')’, ‘FEMPTY’] assume_tac) >> + fs [] >> + fs [FLOOKUP_UPDATE] >> + TOP_CASE_TAC >> fs [] >> + rveq >> drule EL_MEM >> fs [] +QED + + + + +Theorem all_distinct_flookup_all_distinct: + no_overlap fm /\ + FLOOKUP fm x = SOME (y,zs) ==> + ALL_DISTINCT zs +Proof + rw [] >> + fs [no_overlap_def] >> + metis_tac [] +QED + +Theorem no_overlap_flookup_distinct: + no_overlap fm /\ + x ≠ y /\ + FLOOKUP fm x = SOME (a,xs) /\ + FLOOKUP fm y = SOME (b,ys) ==> + distinct_lists xs ys +Proof + rw [] >> + match_mp_tac distinct_lists_append >> + fs [no_overlap_def, ALL_DISTINCT_APPEND, DISJOINT_ALT] >> + metis_tac [] +QED + + +Theorem all_distinct_take_frop_disjoint: + !ns n. + ALL_DISTINCT ns ∧ n <= LENGTH ns ==> + DISJOINT (set (TAKE n ns)) (set (DROP n ns)) +Proof + Induct >> rw [] >> + cases_on ‘n’ >> fs [] >> + CCONTR_TAC >> fs [] >> + fs[MEM_DROP, MEM_EL] >> + metis_tac [] +QED + +Theorem fupdate_flookup_zip_elim: + !xs ys zs as x. + FLOOKUP (FEMPTY |++ ZIP (xs, ys)) x = NONE ∧ + LENGTH zs = LENGTH as ∧ LENGTH xs = LENGTH ys /\ + ALL_DISTINCT xs ==> + FLOOKUP (FEMPTY |++ ZIP (xs, ys) |++ ZIP (zs, as)) x = FLOOKUP (FEMPTY |++ ZIP (zs, as)) x +Proof + Induct >> rw [] + >- (fs [FUPDATE_LIST_THM]) >> + cases_on ‘ys’ >> fs [] >> + fs [FUPDATE_LIST_THM] >> + ‘FLOOKUP (FEMPTY |++ ZIP (xs,t)) x = NONE’ by ( + ‘~MEM h (MAP FST (ZIP (xs,t)))’ by ( + CCONTR_TAC >> fs [MAP_ZIP, MEM_MAP] >> drule MEM_ZIP >> + disch_then (qspec_then ‘y’ assume_tac) >> fs [] >> rveq >> rfs [MEM_EL] >> + metis_tac []) >> + drule FUPDATE_FUPDATE_LIST_COMMUTES >> + disch_then (qspecl_then [‘h'’, ‘FEMPTY’] assume_tac) >> + fs [FLOOKUP_UPDATE] >> + FULL_CASE_TAC >> fs []) >> + ‘FLOOKUP (FEMPTY |+ (h,h') |++ ZIP (xs,t) |++ ZIP (zs,as)) x = + FLOOKUP (FEMPTY |++ ZIP (xs,t) |++ ZIP (zs,as)) x’ by ( + cases_on ‘FLOOKUP (FEMPTY |++ ZIP (xs,t) |++ ZIP (zs,as)) x’ >> fs [] + >- fs [flookup_update_list_none] >> + fs [flookup_update_list_some]) >> + fs [] >> + last_x_assum match_mp_tac >> fs [] +QED + +Theorem not_mem_fst_zip_flookup_empty: + !xs ys x. + ~MEM x xs ∧ ALL_DISTINCT xs ∧ + LENGTH xs = LENGTH ys ==> + FLOOKUP (FEMPTY |++ ZIP (xs, ys)) x = NONE +Proof + Induct >> rw [] + >- (fs [FUPDATE_LIST_THM]) >> + cases_on ‘ys’ >> fs [] >> + fs [FUPDATE_LIST_THM] >> + ‘~MEM h (MAP FST (ZIP (xs,t)))’ by ( + CCONTR_TAC >> fs [MAP_ZIP, MEM_MAP] >> drule MEM_ZIP >> + disch_then (qspec_then ‘y’ assume_tac) >> fs [] >> rveq >> rfs [MEM_EL] >> + metis_tac []) >> + drule FUPDATE_FUPDATE_LIST_COMMUTES >> + disch_then (qspecl_then [‘h'’, ‘FEMPTY’] assume_tac) >> + fs [FLOOKUP_UPDATE] +QED + + +Theorem fm_zip_append_take_drop: + !xs ys zs f. + ALL_DISTINCT xs ∧ LENGTH xs = LENGTH (ys ++ zs) ==> + f |++ ZIP (xs,ys ++ zs) = f |++ ZIP (TAKE (LENGTH ys) xs,ys) + |++ ZIP (DROP (LENGTH ys) xs,zs) +Proof + Induct >> rw [] + >- fs [FUPDATE_LIST_THM] >> + cases_on ‘ys’ >> fs [FUPDATE_LIST_THM] +QED + +Theorem disjoint_not_mem_el: + !xs ys n. + DISJOINT (set xs) (set ys) ∧ n < LENGTH xs ==> + ~MEM (EL n xs) ys +Proof + Induct >> rw [] >> + cases_on ‘n’ >> fs [] +QED + +Theorem map_some_the_map: + !xs ys f. + MAP f xs = MAP SOME ys ==> + MAP (λn. THE (f n)) xs = ys +Proof + Induct >> rw [] >> + cases_on ‘ys’ >> fs [] +QED + +Theorem set_eq_membership: + a = b ∧ x ∈ a ==> x ∈ b +Proof + rw [] >> fs [] +QED + + +Theorem max_set_list_max: + !xs. MAX_SET (set xs) = list_max xs +Proof + Induct >> rw [] >> fs [list_max_def] >> + ‘FINITE (set xs)’ by fs [] >> + drule (MAX_SET_THM |> CONJUNCT2) >> + disch_then (qspec_then ‘h’ assume_tac) >> + fs [] >> + TOP_CASE_TAC >>fs [MAX_DEF] +QED + +Theorem list_max_add_not_mem: + !xs. ~MEM (list_max xs + 1) xs +Proof + Induct >> rw [] >> fs [list_max_def] >> + CCONTR_TAC >> fs [] >> + every_case_tac >> fs [list_max_def] >> + ntac 2 (pop_assum mp_tac) >> pop_assum kall_tac >> + qid_spec_tac ‘xs’ >> + Induct >> rw [] >> fs [list_max_def] +QED + +Theorem subspt_same_insert_subspt: + !p q n. + subspt p q ==> + subspt (insert n () p) (insert n () q) +Proof + rw [] >> + fs [subspt_lookup] >> + rw [] >> + fs [lookup_insert] >> + FULL_CASE_TAC >> fs [] +QED + +Theorem subspt_insert: + !p n. subspt p (insert n () p) +Proof + rw [] >> + fs [subspt_lookup] >> + rw [] >> + fs [lookup_insert] +QED + +Theorem subspt_right_insert_subspt: + !p q n. + subspt p q ==> + subspt p (insert n () q) +Proof + rw [] >> + fs [subspt_lookup] >> + rw [] >> + fs [lookup_insert] +QED + +Theorem subspt_same_insert_cancel: + !p q n m. + subspt p q ==> + subspt (insert n () (insert m () (insert n () p))) + (insert m () (insert n () q)) +Proof + rw [] >> + fs [subspt_lookup] >> + rw [] >> + fs [lookup_insert] >> + every_case_tac >> fs [] +QED + + +Theorem max_set_count_length: + !n. MAX_SET (count n) = n − 1 +Proof + Induct >> rw [] >> + fs [COUNT_SUC] >> + ‘MAX_SET (n INSERT count n) = + MAX n (MAX_SET (count n))’ by ( + ‘FINITE (count n)’ by fs [] >> + metis_tac [MAX_SET_THM]) >> + fs [MAX_DEF] +QED + + +Theorem list_max_i_genlist: + !n. list_max (GENLIST I n) = n − 1 +Proof + rw [] >> + fs [GSYM COUNT_LIST_GENLIST] >> + fs [GSYM max_set_list_max] >> + fs [COUNT_LIST_COUNT] >> + metis_tac [max_set_count_length] +QED + +Theorem el_pair_map_fst_el: + !xs n x y z. + n < LENGTH xs /\ EL n xs = (x,y,z) ==> + x = EL n (MAP FST xs) +Proof + Induct >> rw [] >> + cases_on ‘n’ >> fs [] +QED + + +Theorem all_distinct_el_fst_same_eq: + !xs n n' x y y'. + ALL_DISTINCT (MAP FST xs) ∧ + n < LENGTH xs ∧ n' < LENGTH xs ∧ + EL n xs = (x,y) ∧ + EL n' xs = (x,y') ==> + n = n' +Proof + Induct >> rw [] >> + fs [] >> + cases_on ‘n’ >> cases_on ‘n'’ >> + fs [] >> rveq >> fs [] + >- ( + fs [MEM_MAP] >> + first_x_assum (qspec_then ‘(x,y')’ mp_tac) >> + fs [] >> + drule EL_MEM >> + strip_tac >> rfs []) >> + fs [MEM_MAP] >> + first_x_assum (qspec_then ‘(x,y)’ mp_tac) >> + fs [] >> + drule EL_MEM >> + strip_tac >> rfs [] +QED + + +Theorem lookup_some_el: + ∀xs n x. lookup n (fromAList xs) = SOME x ==> + ∃m. m < LENGTH xs ∧ EL m xs = (n,x) +Proof + Induct >> rw [] + >- fs [fromAList_def, lookup_def] >> + cases_on ‘h’ >> fs [] >> + fs [fromAList_def] >> + fs [lookup_insert] >> + every_case_tac >> fs [] >> rveq >> gs [] + >- ( + qexists_tac ‘0’ >> fs []) >> + res_tac >> fs [] >> rveq >> gs [] >> + qexists_tac ‘SUC m’ >> fs [] +QED + +Theorem max_foldr_lt: + !xs x n m. + MEM x xs ∧ n ≤ x ∧ 0 < m ⇒ + x < FOLDR MAX n xs + m +Proof + Induct >> rw [] >> fs [] + >- fs [MAX_DEF] >> + last_x_assum drule_all >> + strip_tac >> + fs [MAX_DEF] +QED + +Theorem fm_update_diff_vars: + a ≠ b ==> + fm + |+ (a ,a') + |+ (b ,b') + |+ (a ,a') + |+ (b ,b'') = + fm + |+ (a ,a') + |+ (b ,b'') +Proof + rw [] >> + ‘fm + |+ (a ,a') + |+ (b ,b') + |+ (a ,a') + |+ (b ,b'') = + fm + |+ (a ,a') + |+ (b ,b') + |+ (b ,b'') + |+ (a ,a')’ by ( + match_mp_tac FUPDATE_COMMUTES >> + fs []) >> + fs [] >> + ‘fm |+ (a,a') |+ (b,b'') |+ (a,a') = + fm |+ (a,a') |+ (a,a') |+ (b,b'')’ by ( + match_mp_tac FUPDATE_COMMUTES >> + fs []) >> + fs [] +QED + + +Theorem fmap_to_alist_eq_fm: + ∀fm. + FEMPTY |++ MAP (λ(x,y). (x,y)) (fmap_to_alist fm) = fm +Proof + rw [] >> + gs [MAP_values_fmap_to_alist] >> + gs [FUPDATE_LIST_EQ_APPEND_REVERSE] >> + ‘alist_to_fmap (REVERSE (fmap_to_alist fm)) = + alist_to_fmap (fmap_to_alist fm)’ by ( + match_mp_tac ALL_DISTINCT_alist_to_fmap_REVERSE >> + fs [ALL_DISTINCT_fmap_to_alist_keys]) >> + gs [] +QED + + +val _ = export_theory(); diff --git a/pancake/semantics/readmePrefix b/pancake/semantics/readmePrefix new file mode 100644 index 0000000000..8baacfd648 --- /dev/null +++ b/pancake/semantics/readmePrefix @@ -0,0 +1 @@ +Semantics for Pancake and its intermediate languages. diff --git a/pancake/semantics/timeFunSemScript.sml b/pancake/semantics/timeFunSemScript.sml new file mode 100644 index 0000000000..aed30bcbfc --- /dev/null +++ b/pancake/semantics/timeFunSemScript.sml @@ -0,0 +1,644 @@ +(* + semantics for timeLang +*) + +open preamble + timeLangTheory + timeSemTheory + +val _ = new_theory "timeFunSem"; + + +Datatype: + input_delay = Delay + | Input num +End + +(* a well-formed program will not produce NONE in eval_term *) +(* now returns (label, state) option *) +Definition eval_term_def: + (eval_term st (SOME i) + (Tm (Input in_signal) + cnds + clks + dest + difs) = + if i = in_signal ∧ + EVERY (λck. ck IN FDOM st.clocks) clks ∧ + EVERY (λ(t,c). + ∃v. FLOOKUP st.clocks c = SOME v ∧ + v ≤ t) difs + then SOME (LAction (Input in_signal), + st with <| clocks := resetClocks st.clocks clks + ; ioAction := SOME (Input in_signal) + ; location := dest + ; waitTime := calculate_wtime st clks difs|>) + else NONE) ∧ + + (eval_term st NONE + (Tm (Output out_signal) + cnds + clks + dest + difs) = + if EVERY (λck. ck IN FDOM st.clocks) clks ∧ + EVERY (λ(t,c). + ∃v. FLOOKUP st.clocks c = SOME v ∧ + v ≤ t) difs + then SOME (LAction (Output out_signal), + st with <| clocks := resetClocks st.clocks clks + ; ioAction := SOME (Output out_signal) + ; location := dest + ; waitTime := calculate_wtime st clks difs|>) + else NONE) ∧ + (eval_term st _ _ = NONE) +End + + +Definition machine_bounds_def: + machine_bounds st m tms ⇔ + tms_conds_eval st tms ∧ + conds_eval_lt_dimword m st tms ∧ + terms_time_range m tms ∧ + input_terms_actions m tms ∧ + terms_wtimes_ffi_bound m st tms ∧ + max_clocks st.clocks m +End + +(* now returns (label, state) option *) +Definition pick_eval_input_term_def: + (pick_eval_input_term st i m (tm::tms) = + case tm of + | Tm (Input in_signal) cnds clks dest difs => + if in_signal = i ∧ + EVERY (λcnd. evalCond st cnd) cnds + then eval_term st (SOME i) tm + else pick_eval_input_term st i m tms + | _ => pick_eval_input_term st i m tms) ∧ + (pick_eval_input_term st i m [] = + if i + 1 < m then SOME (LPanic (PanicInput i), st) + else NONE) +End + +Definition pick_eval_output_term_def: + (pick_eval_output_term st (tm::tms) = + case tm of + | Tm (Output out_signal) cnds clks dest difs => + if EVERY (λcnd. evalCond st cnd) cnds + then eval_term st NONE tm + else pick_eval_output_term st tms + | _ => pick_eval_output_term st tms) ∧ + (pick_eval_output_term st [] = SOME (LPanic PanicTimeout, st)) +End + + +Definition eval_input_def: + eval_input prog m n i st = + case ALOOKUP prog st.location of + | SOME tms => + if n < m ∧ machine_bounds (resetOutput st) m tms + then pick_eval_input_term (resetOutput st) i m tms + else NONE + | _ => NONE +End + +Definition eval_output_def: + eval_output prog m n st = + case ALOOKUP prog st.location of + | SOME tms => + if n < m ∧ machine_bounds (resetOutput st) m tms + then pick_eval_output_term (resetOutput st) tms + else NONE + | _ => NONE +End + + +Definition eval_delay_wtime_none_def: + eval_delay_wtime_none st m n = + if n + 1 < m ∧ + max_clocks (delay_clocks (st.clocks) (n + 1)) m + then SOME + (LDelay 1 , + st with + <|clocks := delay_clocks (st.clocks) 1; + ioAction := NONE|>) + else NONE +End + +Definition eval_delay_wtime_some_def: + eval_delay_wtime_some st m n w = + if 1 ≤ w ∧ w < m ∧ n + 1 < m ∧ + max_clocks (delay_clocks (st.clocks) (n + 1)) m + then SOME + (LDelay 1 , + st with + <|clocks := delay_clocks (st.clocks) 1; + waitTime := SOME (w - 1); + ioAction := NONE|>) + else NONE +End + +(* rearrange the check on system time *) +Definition eval_step_def: + eval_step prog m n (or:input_delay) st = + case st.waitTime of + | NONE => + (case or of + | Delay => eval_delay_wtime_none st m n + | Input i => eval_input prog m n i st) + | SOME w => + if w = 0 + then eval_output prog m n st + else + (case or of + | Delay => eval_delay_wtime_some st m n w + | Input i => + if w ≠ 0 ∧ w < m + then eval_input prog m n i st + else NONE) +End + + +Definition next_oracle_def: + next_oracle (f:num -> input_delay) = + λn. f (n+1) +End + +Definition set_oracle_def: + (set_oracle (Input _) (or:num -> input_delay) = next_oracle or) ∧ + (set_oracle (Output _) or = or) +End + +(* +Definition eval_steps_def: + (eval_steps 0 prog m n _ st = + if n < m ∧ + (case st.waitTime of + | SOME w => w < m + | NONE => T) + then SOME ([],[]) + else NONE) ∧ + (eval_steps (SUC k) prog m n or st = + case eval_step prog m n (or 0) st of + | SOME (lbl, st') => + let n' = + case lbl of + | LDelay d => d + n + | _ => n; + noracle = + case lbl of + | LDelay _ => next_oracle or + | LAction act => set_oracle act or + in + (case eval_steps k prog m n' noracle st' of + | NONE => NONE + | SOME (lbls', sts') => SOME (lbl::lbls', st'::sts')) + | NONE => NONE) +End +*) + + +Definition eval_steps_def: + (eval_steps 0 _ _ _ _ st = SOME ([],[])) ∧ + (eval_steps (SUC k) prog m n or st = + if m - 1 <= n then SOME ([], []) + else + (case eval_step prog m n (or 0) st of + | SOME (lbl, st') => + let n' = + case lbl of + | LDelay d => d + n + | _ => n; + noracle = + case lbl of + | LDelay _ => next_oracle or + | LAction act => set_oracle act or + in + (case eval_steps k prog m n' noracle st' of + | NONE => NONE + | SOME (lbls', sts') => SOME (lbl::lbls', st'::sts')) + | NONE => NONE)) +End + +(* +Definition eval_steps_def: + (eval_steps 0 _ _ _ _ st = SOME ([],[])) ∧ + (eval_steps (SUC k) prog m n or st = + case eval_step prog m n (or 0) st of + | SOME (lbl, st') => + let n' = + case lbl of + | LDelay d => d + n + | _ => n; + noracle = + case lbl of + | LDelay _ => next_oracle or + | LAction act => set_oracle act or + in + (case eval_steps k prog m n' noracle st' of + | NONE => NONE + | SOME (lbls', sts') => SOME (lbl::lbls', st'::sts')) + | NONE => NONE) +End +*) + +Theorem label_from_pick_eval_input_term: + ∀tms i st lbl st' m. + pick_eval_input_term st i m tms = SOME (lbl,st') ⇒ + lbl = LAction (Input i) ∨ + lbl = LPanic (PanicInput i) +Proof + Induct >> rw [] >> + gvs [pick_eval_input_term_def] >> + every_case_tac >> gvs [eval_term_def] >> + res_tac >> gvs [] +QED + +Theorem label_from_pick_eval_output_term: + ∀tms st lbl st'. + pick_eval_output_term st tms = SOME (lbl,st') ⇒ + (∃os. lbl = LAction (Output os)) ∨ + lbl = LPanic PanicTimeout +Proof + Induct >> rw [] >> + gvs [pick_eval_output_term_def] >> + every_case_tac >> gvs [eval_term_def] >> + res_tac >> gvs [] +QED + + +Theorem pick_eval_input_term_imp_pickTerm: + ∀tms st m i st'. + machine_bounds (resetOutput st) m tms ∧ + pick_eval_input_term (resetOutput st) i m tms = + SOME (LAction (Input i), st') ⇒ + pickTerm (resetOutput st) m (SOME i) tms st' (LAction (Input i)) ∧ + st'.ioAction = SOME (Input i) +Proof + Induct >> + rpt gen_tac >> + strip_tac >> + gs [] + >- gs [pick_eval_input_term_def] >> + gs [pick_eval_input_term_def] >> + cases_on ‘h’ >> gs [] >> + cases_on ‘i'’ >> gs [] + >- ( + FULL_CASE_TAC >> gvs [] + >- ( + rewrite_tac [Once pickTerm_cases] >> + gs [] >> + gs [machine_bounds_def] >> + gs [eval_term_def, evalTerm_cases] >> + rveq >> gs [state_component_equality]) >> + cases_on ‘ n' = i’ >> gvs [] + >- ( + rewrite_tac [Once pickTerm_cases] >> + gs [] >> + last_x_assum (qspecl_then [‘st’, ‘m’, ‘i’, ‘st'’] mp_tac) >> + impl_tac + >- ( + gs [] >> + gs [machine_bounds_def, tms_conds_eval_def, conds_eval_lt_dimword_def, + terms_time_range_def, input_terms_actions_def, terms_wtimes_ffi_bound_def, + terms_in_signals_def]) >> + strip_tac >> + gs [machine_bounds_def, terms_time_range_def, + conds_eval_lt_dimword_def, input_terms_actions_def, + terms_in_signals_def, tms_conds_eval_def] >> + disj2_tac >> + gs [tm_conds_eval_def, EVERY_MEM] >> + rw [] >> gvs [ timeLangTheory.termConditions_def] >> + res_tac >> gvs [] >> + FULL_CASE_TAC >> gvs []) >> + rewrite_tac [Once pickTerm_cases] >> + gs [] >> + last_x_assum (qspecl_then [‘st’, ‘m’, ‘i’, ‘st'’] mp_tac) >> + impl_tac + >- ( + gs [] >> + gs [machine_bounds_def, tms_conds_eval_def, conds_eval_lt_dimword_def, + terms_time_range_def, input_terms_actions_def, terms_wtimes_ffi_bound_def, + terms_in_signals_def]) >> + strip_tac >> + gs [machine_bounds_def, terms_time_range_def, + conds_eval_lt_dimword_def, input_terms_actions_def, + terms_in_signals_def, tms_conds_eval_def, tm_conds_eval_def, + timeLangTheory.termConditions_def] >> + gs [EVERY_MEM]) >> + rewrite_tac [Once pickTerm_cases] >> + gs [] >> + last_x_assum (qspecl_then [‘st’, ‘m’, ‘i’, ‘st'’] mp_tac) >> + impl_tac + >- ( + gs [] >> + gs [machine_bounds_def, tms_conds_eval_def, conds_eval_lt_dimword_def, + terms_time_range_def, input_terms_actions_def, terms_wtimes_ffi_bound_def, + terms_in_signals_def]) >> + strip_tac >> + gs [machine_bounds_def, terms_time_range_def, + conds_eval_lt_dimword_def, input_terms_actions_def, + terms_in_signals_def] +QED + + +Theorem pick_eval_output_term_imp_pickTerm: + ∀tms st m os st'. + machine_bounds (resetOutput st) m tms ∧ + pick_eval_output_term (resetOutput st) tms = + SOME (LAction (Output os),st') ⇒ + pickTerm (resetOutput st) m NONE tms st' (LAction (Output os)) ∧ + st'.ioAction = SOME (Output os) +Proof + Induct >> + rpt gen_tac >> + strip_tac >> + gs [] + >- gs [pick_eval_output_term_def] >> + gs [pick_eval_output_term_def] >> + cases_on ‘h’ >> gs [] >> + reverse (cases_on ‘i’) >> gs [] + >- ( + FULL_CASE_TAC >> gs [] >> rveq >> gs [] + >- ( + rewrite_tac [Once pickTerm_cases] >> + gs [] >> + gs [machine_bounds_def, terms_time_range_def, + conds_eval_lt_dimword_def, input_terms_actions_def, + terms_in_signals_def] >> + gs [eval_term_def, evalTerm_cases] >> + rveq >> gs [state_component_equality]) >> + rewrite_tac [Once pickTerm_cases] >> + gs [] >> + last_x_assum (qspecl_then [‘st’, ‘m’, ‘os’, ‘st'’] mp_tac) >> + impl_tac + >- ( + gs [] >> + gs [machine_bounds_def, tms_conds_eval_def, conds_eval_lt_dimword_def, + terms_time_range_def, input_terms_actions_def, terms_wtimes_ffi_bound_def, + terms_in_signals_def]) >> + strip_tac >> + gs [machine_bounds_def, terms_time_range_def, + conds_eval_lt_dimword_def, input_terms_actions_def, + terms_in_signals_def, tms_conds_eval_def, tm_conds_eval_def, + timeLangTheory.termConditions_def] >> + gs [EVERY_MEM] >> + disj2_tac >> + rw [] >> + res_tac >> gs [] >> + FULL_CASE_TAC >> gs []) >> + rewrite_tac [Once pickTerm_cases] >> + gs [] >> + last_x_assum (qspecl_then [‘st’, ‘m’, ‘os’, ‘st'’] mp_tac) >> + impl_tac + >- ( + gs [] >> + gs [machine_bounds_def, tms_conds_eval_def, conds_eval_lt_dimword_def, + terms_time_range_def, input_terms_actions_def, terms_wtimes_ffi_bound_def, + terms_in_signals_def]) >> + strip_tac >> + gs [machine_bounds_def, terms_time_range_def, + conds_eval_lt_dimword_def, input_terms_actions_def, + terms_in_signals_def, tms_conds_eval_def, tm_conds_eval_def, + timeLangTheory.termConditions_def] +QED + +Theorem pick_input_term_panic_sts_eq: + ∀tms st m i st'. + pick_eval_input_term st i m tms = + SOME (LPanic (PanicInput i), st') ⇒ + st = st' +Proof + Induct >> + rpt gen_tac >> + strip_tac >> + gs [pick_eval_input_term_def] >> + every_case_tac >> gvs [eval_term_def] >> + res_tac >> gvs [] +QED + +Theorem pick_eval_input_term_panic_imp_pickTerm: + ∀tms st m i st'. + machine_bounds (resetOutput st) m tms ∧ + pick_eval_input_term (resetOutput st) i m tms = + SOME (LPanic (PanicInput i), st') ⇒ + pickTerm (resetOutput st) m (SOME i) tms st' (LPanic (PanicInput i)) +Proof + Induct >> + rpt gen_tac >> + strip_tac >> + gs [] + >- ( + gs [pick_eval_input_term_def] >> + rewrite_tac [Once pickTerm_cases] >> + gs [machine_bounds_def]) >> + gs [pick_eval_input_term_def] >> + cases_on ‘h’ >> gs [] >> + cases_on ‘i'’ >> gs [] + >- ( + FULL_CASE_TAC >> gs [] + >- ( + rewrite_tac [Once pickTerm_cases] >> + gs [] >> + gvs [machine_bounds_def] >> + gs [eval_term_def, evalTerm_cases] >> + rveq >> gs [state_component_equality]) >> + cases_on ‘ n' = i’ >> gvs [] + >- ( + rewrite_tac [Once pickTerm_cases] >> + gs [] >> + last_x_assum (qspecl_then [‘st’, ‘m’, ‘i’, ‘st'’] mp_tac) >> + impl_tac + >- ( + gs [] >> + gs [machine_bounds_def, tms_conds_eval_def, conds_eval_lt_dimword_def, + terms_time_range_def, input_terms_actions_def, terms_wtimes_ffi_bound_def, + terms_in_signals_def]) >> + strip_tac >> + gs [machine_bounds_def, terms_time_range_def, + conds_eval_lt_dimword_def, input_terms_actions_def, + terms_in_signals_def] >> + gs [tms_conds_eval_def, tm_conds_eval_def, EVERY_MEM] >> + rw [] >> gvs [timeLangTheory.termConditions_def] >> + res_tac >> gvs [] >> + FULL_CASE_TAC >> gvs []) >> + rewrite_tac [Once pickTerm_cases] >> + gs [] >> + last_x_assum (qspecl_then [‘st’, ‘m’, ‘i’, ‘st'’] mp_tac) >> + impl_tac + >- ( + gs [] >> + gs [machine_bounds_def, tms_conds_eval_def, conds_eval_lt_dimword_def, + terms_time_range_def, input_terms_actions_def, terms_wtimes_ffi_bound_def, + terms_in_signals_def]) >> + strip_tac >> + gs [machine_bounds_def, terms_time_range_def, + conds_eval_lt_dimword_def, input_terms_actions_def, + terms_in_signals_def, tms_conds_eval_def, tm_conds_eval_def, + timeLangTheory.termConditions_def] >> + gs [EVERY_MEM]) >> + rewrite_tac [Once pickTerm_cases] >> + gs [] >> + last_x_assum (qspecl_then [‘st’, ‘m’, ‘i’, ‘st'’] mp_tac) >> + impl_tac + >- ( + gs [] >> + gs [machine_bounds_def, tms_conds_eval_def, conds_eval_lt_dimword_def, + terms_time_range_def, input_terms_actions_def, terms_wtimes_ffi_bound_def, + terms_in_signals_def]) >> + strip_tac >> + gs [machine_bounds_def, terms_time_range_def, + conds_eval_lt_dimword_def, input_terms_actions_def, + terms_in_signals_def] +QED + +Theorem pick_eval_output_term_panic_imp_pickTerm: + ∀tms st m st'. + machine_bounds (resetOutput st) m tms ∧ + pick_eval_output_term (resetOutput st) tms = + SOME (LPanic PanicTimeout, st') ⇒ + pickTerm (resetOutput st) m NONE tms st' (LPanic PanicTimeout) +Proof + Induct >> + rpt gen_tac >> + strip_tac >> + gs [] + >- ( + gs [pick_eval_output_term_def] >> + rewrite_tac [Once pickTerm_cases] >> + gs [machine_bounds_def]) >> + gs [pick_eval_output_term_def] >> + cases_on ‘h’ >> gs [] >> + reverse (cases_on ‘i’) >> gs [] + >- ( + FULL_CASE_TAC >> gs [] >> rveq >> gs [] + >- ( + rewrite_tac [Once pickTerm_cases] >> + gs [] >> + gs [machine_bounds_def, terms_time_range_def, + conds_eval_lt_dimword_def, input_terms_actions_def, + terms_in_signals_def] >> + gs [eval_term_def, evalTerm_cases] >> + rveq >> gs [state_component_equality]) >> + rewrite_tac [Once pickTerm_cases] >> + gs [] >> + last_x_assum (qspecl_then [‘st’, ‘m’, ‘st'’] mp_tac) >> + impl_tac + >- ( + gs [] >> + gs [machine_bounds_def, tms_conds_eval_def, conds_eval_lt_dimword_def, + terms_time_range_def, input_terms_actions_def, terms_wtimes_ffi_bound_def, + terms_in_signals_def]) >> + strip_tac >> + gs [machine_bounds_def, terms_time_range_def, + conds_eval_lt_dimword_def, input_terms_actions_def, + terms_in_signals_def, tms_conds_eval_def, tm_conds_eval_def, + timeLangTheory.termConditions_def] >> + gs [EVERY_MEM] >> + rw [] >> + res_tac >> gs [] >> + FULL_CASE_TAC >> gs []) >> + rewrite_tac [Once pickTerm_cases] >> + gs [] >> + last_x_assum (qspecl_then [‘st’, ‘m’, ‘st'’] mp_tac) >> + impl_tac + >- ( + gs [] >> + gs [machine_bounds_def, tms_conds_eval_def, conds_eval_lt_dimword_def, + terms_time_range_def, input_terms_actions_def, terms_wtimes_ffi_bound_def, + terms_in_signals_def]) >> + strip_tac >> + gs [machine_bounds_def, terms_time_range_def, + conds_eval_lt_dimword_def, input_terms_actions_def, + terms_in_signals_def, tms_conds_eval_def, tm_conds_eval_def, + timeLangTheory.termConditions_def] +QED + + +Theorem eval_step_imp_step: + eval_step prog m n or st = SOME (label, st') ⇒ + step prog label m n st st' +Proof + rw [] >> + fs [eval_step_def] >> + cases_on ‘st.waitTime’ >> gs [] >> + cases_on ‘or’ >> gs [] + >- ( + gs [eval_delay_wtime_none_def] >> + rveq >> + gs [step_cases, mkState_def] >> + gs [state_component_equality]) + >- ( + gs [eval_input_def] >> + FULL_CASE_TAC >> gvs [] >> + qmatch_asmsub_rename_tac ‘ALOOKUP _ _ = SOME tms’ >> + qmatch_asmsub_rename_tac ‘pick_eval_input_term _ i _ _ = _’ >> + drule label_from_pick_eval_input_term >> + strip_tac >> gvs [] + >- ( + imp_res_tac pick_eval_input_term_imp_pickTerm >> + gs [step_cases, mkState_def]) >> + drule_all pick_eval_input_term_panic_imp_pickTerm >> + gs [step_cases, mkState_def]) + >- ( + FULL_CASE_TAC >> gs [] + >- ( + gs [eval_output_def] >> + every_case_tac >> rveq >> gs [] >> + rveq >> gs [] >> + qmatch_asmsub_rename_tac ‘ALOOKUP _ _ = SOME tms’ >> + drule label_from_pick_eval_output_term >> + strip_tac >> gvs [] + >- ( + imp_res_tac pick_eval_output_term_imp_pickTerm >> + gs [step_cases, mkState_def]) >> + drule_all pick_eval_output_term_panic_imp_pickTerm >> + gs [step_cases, mkState_def]) >> + gs [eval_delay_wtime_some_def] >> + rveq >> + gs [step_cases, mkState_def] >> + gs [state_component_equality]) >> + cases_on ‘x = 0’ >> gs [] + >- ( + gs [eval_output_def] >> + every_case_tac >> rveq >> gs [] >> + rveq >> gs [] >> + qmatch_asmsub_rename_tac ‘ALOOKUP _ _ = SOME tms’ >> + drule label_from_pick_eval_output_term >> + strip_tac >> gvs [] + >- ( + imp_res_tac pick_eval_output_term_imp_pickTerm >> + gs [step_cases, mkState_def]) >> + drule_all pick_eval_output_term_panic_imp_pickTerm >> + gs [step_cases, mkState_def]) >> + gs [eval_input_def] >> + FULL_CASE_TAC >> gs [] >> rveq >> gs [] >> + qmatch_asmsub_rename_tac ‘ALOOKUP _ _ = SOME tms’ >> + qmatch_asmsub_rename_tac ‘pick_eval_input_term _ i _ _ = _’ >> + drule label_from_pick_eval_input_term >> + strip_tac >> gvs [] + >- ( + imp_res_tac pick_eval_input_term_imp_pickTerm >> + gs [step_cases, mkState_def]) >> + drule_all pick_eval_input_term_panic_imp_pickTerm >> + gs [step_cases, mkState_def] +QED + + +Theorem eval_steps_imp_steps: + ∀k prog m n or st labels sts. + eval_steps k prog m n or st = SOME (labels, sts) ⇒ + steps prog labels m n st sts +Proof + Induct >> rw [] + >- fs [eval_steps_def, steps_def] >> + gs [eval_steps_def] >> + every_case_tac >> gvs [] >> + TRY (cases_on ‘p’) >> gvs [] >> + gs [steps_def] >> + imp_res_tac eval_step_imp_step >> + gs [] >> + res_tac >> gs [] +QED + +val _ = export_theory(); diff --git a/pancake/semantics/timePropsScript.sml b/pancake/semantics/timePropsScript.sml new file mode 100644 index 0000000000..adbbce7a39 --- /dev/null +++ b/pancake/semantics/timePropsScript.sml @@ -0,0 +1,264 @@ +(* + semantics for timeLang +*) + +open preamble + timeLangTheory timeSemTheory + pan_commonPropsTheory + +val _ = new_theory "timeProps"; + +val _ = set_grammar_ancestry + ["timeLang","timeSem", + "pan_commonProps"]; + + + +Definition good_dimindex_def: + good_dimindex (:'a) ⇔ + dimindex (:'a) = 32 ∨ dimindex (:'a) = 64 +End + +Theorem eval_term_inpput_ios_same: + ∀s m n cnds tclks dest wt s'. + evalTerm s (SOME m) (Tm (Input n) cnds tclks dest wt) s' ⇒ + m = n +Proof + rw [] >> + fs [evalTerm_cases] +QED + + +Theorem eval_term_clocks_reset: + ∀s io n cnds tclks dest wt s' ck t. + FLOOKUP s.clocks ck = SOME t ∧ + evalTerm s io (Tm n cnds tclks dest wt) s' ⇒ + (FLOOKUP s'.clocks ck = SOME t ∨ FLOOKUP s'.clocks ck = SOME 0) +Proof + rw [] >> + fs [evalTerm_cases, resetClocks_def] >> + rveq >> gs [] >>( + cases_on ‘MEM ck tclks’ + >- ( + gs [MEM_EL] >> + metis_tac [update_eq_zip_map_flookup]) >> + last_x_assum (assume_tac o GSYM) >> + gs [] >> + disj1_tac >> + match_mp_tac flookup_fupdate_zip_not_mem >> + gs []) +QED + + +Theorem list_min_option_some_mem: + ∀xs x. + list_min_option xs = SOME x ⇒ + MEM x xs +Proof + Induct >> rw [] >> + fs [list_min_option_def] >> + every_case_tac >> fs [] >> rveq >> rfs [] +QED + + +Theorem fdom_reset_clks_eq_clks: + ∀fm clks. + EVERY (λck. ck IN FDOM fm) clks ⇒ + FDOM (resetClocks fm clks) = FDOM fm +Proof + rw [] >> + fs [resetClocks_def] >> + fs [FDOM_FUPDATE_LIST] >> + ‘LENGTH clks = LENGTH (MAP (λx. 0:num) clks)’ by fs [] >> + drule MAP_ZIP >> + fs [] >> + strip_tac >> pop_assum kall_tac >> + ‘set clks ⊆ FDOM fm’ by ( + fs [SUBSET_DEF] >> + rw [] >> + fs [EVERY_MEM]) >> + fs [SUBSET_UNION_ABSORPTION] >> + fs [UNION_COMM] +QED + + +Theorem reset_clks_mem_flookup_zero: + ∀clks ck fm. + MEM ck clks ⇒ + FLOOKUP (resetClocks fm clks) ck = SOME 0 +Proof + rw [] >> + fs [timeSemTheory.resetClocks_def] >> + fs [MEM_EL] >> rveq >> + match_mp_tac update_eq_zip_map_flookup >> fs [] +QED + + + +Theorem reset_clks_not_mem_flookup_same: + ∀clks ck fm v. + FLOOKUP fm ck = SOME v ∧ + ~MEM ck clks ⇒ + FLOOKUP (resetClocks fm clks) ck = SOME v +Proof + rw [] >> + fs [timeSemTheory.resetClocks_def] >> + last_x_assum (mp_tac o GSYM) >> + fs [] >> + strip_tac >> + match_mp_tac flookup_fupdate_zip_not_mem >> + fs [] +QED + + +Theorem flookup_reset_clks_leq: + ∀fm ck v tclks q. + FLOOKUP fm ck = SOME v ∧ v ≤ q ⇒ + ∃v. FLOOKUP (resetClocks fm tclks) ck = SOME v ∧ v ≤ q +Proof + rw [] >> + cases_on ‘MEM ck tclks’ + >- ( + drule reset_clks_mem_flookup_zero >> + fs []) >> + drule reset_clks_not_mem_flookup_same >> + fs [] +QED + + +Theorem exprClks_accumulates: + ∀xs e ys. + EVERY (λck. MEM ck ys) (exprClks xs e) ⇒ + EVERY (λck. MEM ck ys) xs +Proof + ho_match_mp_tac exprClks_ind >> + rw [] >> + cases_on ‘e’ + >- fs [Once exprClks_def] + >- ( + gs [] >> + fs [exprClks_def] >> + every_case_tac >> fs []) >> + gs [] >> + pop_assum mp_tac >> + once_rewrite_tac [exprClks_def] >> + fs [] +QED + + +Theorem exprClks_sublist_accum: + ∀xs e ck ys. + MEM ck (exprClks xs e) ∧ + EVERY (λx. MEM x ys) xs ⇒ + MEM ck (exprClks ys e) +Proof + ho_match_mp_tac exprClks_ind >> + rw [] >> + gs [] >> + cases_on ‘e’ + >- fs [Once exprClks_def, EVERY_MEM] + >- ( + gs [] >> + fs [exprClks_def] >> + every_case_tac >> gs [EVERY_MEM]) >> + gs [] >> + once_rewrite_tac [exprClks_def] >> + fs [] >> + first_x_assum match_mp_tac >> + conj_tac + >- ( + qpat_x_assum ‘MEM ck _’ mp_tac >> + rewrite_tac [Once exprClks_def] >> + fs []) >> + fs [EVERY_MEM] +QED + + +Theorem terms_out_signals_append: + ∀xs ys. + terms_out_signals (xs ++ ys) = + terms_out_signals xs ++ terms_out_signals ys +Proof + Induct >> rw [] >> + gs [timeLangTheory.terms_out_signals_def] >> + cases_on ‘h’ >> gs [] >> + cases_on ‘i’ >> gs [timeLangTheory.terms_out_signals_def] +QED + + +Theorem terms_out_signals_prog: + ∀xs x out. + MEM x xs ∧ + MEM out (terms_out_signals x) ⇒ + MEM out (terms_out_signals (FLAT xs)) +Proof + Induct >> rw [] >> + gs [timeLangTheory.terms_out_signals_def] >> + gs [terms_out_signals_append] >> + metis_tac [] +QED + +Theorem calculate_wtime_reset_output_eq: + calculate_wtime s clks difs = SOME wt ⇒ + calculate_wtime (resetOutput s) clks difs = SOME wt +Proof + rw [calculate_wtime_def, resetOutput_def] >> + gs [] >> + qmatch_asmsub_abbrev_tac ‘list_min_option xs’ >> + qmatch_goalsub_abbrev_tac ‘list_min_option ys’ >> + ‘xs = ys’ by ( + unabbrev_all_tac >> + gs [MAP_EQ_f] >> + rw [] >> gs [] >> + cases_on ‘e’ >> + gs [evalDiff_def, evalExpr_def]) >> + gs [] +QED + + +Theorem step_ffi_bounded: + ∀p lbl m n st st'. + step p lbl m n st st' ⇒ + n < m +Proof + rw [] >> + gs [step_cases] +QED + +Theorem steps_ffi_bounded: + ∀lbls sts p m n st. + steps p lbls m n st sts ∧ + lbls ≠ [] ⇒ + n < m +Proof + Induct >> + rw [] >> + cases_on ‘sts’ >> + gs [steps_def, step_cases] +QED + +Theorem steps_lbls_sts_len_eq: + ∀lbls sts p m n st. + steps p lbls m n st sts ⇒ + LENGTH lbls = LENGTH sts +Proof + Induct >> + rw [] >> + cases_on ‘sts’ >> + gs [steps_def, step_cases] >> + res_tac >> gs [] +QED + +Theorem pickTerm_panic_st_eq: + ∀tms st m i st st'. + pickTerm st m (SOME i) tms st' (LPanic (PanicInput i)) ⇒ + st' = st +Proof + Induct >> rw [] >> + gs [Once pickTerm_cases] >> + gvs [] >> + res_tac >> gs [] +QED + + +val _ = export_theory(); diff --git a/pancake/semantics/timeSemScript.sml b/pancake/semantics/timeSemScript.sml new file mode 100644 index 0000000000..55fe981746 --- /dev/null +++ b/pancake/semantics/timeSemScript.sml @@ -0,0 +1,390 @@ +(* + semantics for timeLang +*) + +open preamble + timeLangTheory + +val _ = new_theory "timeSem"; + +Datatype: + panic = PanicTimeout + | PanicInput in_signal +End + +Datatype: + label = LDelay time + | LAction ioAction + | LPanic panic +End + +Datatype: + state = + <| clocks : clock |-> time + ; location : loc + ; ioAction : ioAction option + ; waitTime : time option + |> +End + + +Definition mkState_def: + mkState cks loc io wt = + <| clocks := cks + ; location := loc + ; ioAction := io + ; waitTime := wt + |> +End + +Definition resetOutput_def: + resetOutput st = + st with + <| ioAction := NONE + ; waitTime := NONE + |> +End + +Definition resetClocks_def: + resetClocks fm xs = + fm |++ ZIP (xs,MAP (λx. 0:time) xs) +End + +(* TODO: rephrase this def *) + +Definition list_min_option_def: + (list_min_option ([]:num list) = NONE) /\ + (list_min_option (x::xs) = + case list_min_option xs of + | NONE => SOME x + | SOME y => SOME (if x < y then x else y)) +End + +Definition delay_clocks_def: + delay_clocks fm (d:num) = FEMPTY |++ + (MAP (λ(x,y). (x,y+d)) + (fmap_to_alist fm)) +End + + +Definition minusT_def: + minusT (t1:time) (t2:time) = t1 - t2 +End + +(* inner case for generating induction theorem *) + +Definition evalExpr_def: + evalExpr st e = + case e of + | ELit t => SOME t + | EClock c => FLOOKUP st.clocks c + | ESub e1 e2 => + case (evalExpr st e1, evalExpr st e2) of + | SOME t1,SOME t2 => + if t2 ≤ t1 then SOME (minusT t1 t2) + else NONE + | _=> NONE +End + + +Definition evalCond_def: + (evalCond st (CndLe e1 e2) = + case (evalExpr st e1,evalExpr st e2) of + | SOME t1,SOME t2 => t1 ≤ t2 + | _ => F) ∧ + (evalCond st (CndLt e1 e2) = + case (evalExpr st e1,evalExpr st e2) of + | SOME t1,SOME t2 => t1 < t2 + | _ => F) +End + + +Definition evalDiff_def: + evalDiff st ((t,c): time # clock) = + evalExpr st (ESub (ELit t) (EClock c)) +End + + +Definition calculate_wtime_def: + calculate_wtime st clks diffs = + let + st = st with clocks := resetClocks st.clocks clks + in + list_min_option (MAP (THE o evalDiff st) diffs) +End + + +Inductive evalTerm: + (∀st in_signal cnds clks dest diffs. + EVERY (λck. ck IN FDOM st.clocks) clks ∧ + EVERY (λ(t,c). + ∃v. FLOOKUP st.clocks c = SOME v ∧ + v ≤ t) diffs ==> + evalTerm st (SOME in_signal) + (Tm (Input in_signal) + cnds + clks + dest + diffs) + (st with <| clocks := resetClocks st.clocks clks + ; ioAction := SOME (Input in_signal) + ; location := dest + ; waitTime := calculate_wtime st clks diffs|>)) /\ + (∀st out_signal cnds clks dest diffs. + EVERY (λck. ck IN FDOM st.clocks) clks ∧ + EVERY (λ(t,c). + ∃v. FLOOKUP st.clocks c = SOME v ∧ + v ≤ t) diffs ==> + evalTerm st NONE + (Tm (Output out_signal) + cnds + clks + dest + diffs) + (st with <| clocks := resetClocks st.clocks clks + ; ioAction := SOME (Output out_signal) + ; location := dest + ; waitTime := calculate_wtime st clks diffs|>)) +End + +Definition max_clocks_def: + max_clocks fm (m:num) ⇔ + ∀ck n. + FLOOKUP fm ck = SOME n ⇒ + n < m +End + + +Definition tm_conds_eval_def: + tm_conds_eval s tm = + EVERY (λcnd. + EVERY (λe. case (evalExpr s e) of + | SOME n => T + | _ => F) (destCond cnd)) + (termConditions tm) +End + + +Definition tms_conds_eval_def: + tms_conds_eval s tms = + EVERY (tm_conds_eval s) tms +End + +Definition tm_conds_eval_limit_def: + tm_conds_eval_limit m s tm = + EVERY (λcnd. + EVERY (λe. case (evalExpr s e) of + | SOME n => n < m + | _ => F) (destCond cnd)) + (termConditions tm) +End + + +Definition conds_eval_lt_dimword_def: + conds_eval_lt_dimword m s tms = + EVERY (tm_conds_eval_limit m s) tms +End + + +Definition time_range_def: + time_range wt (m:num) ⇔ + EVERY (λ(t,c). t < m) wt +End + + +Definition term_time_range_def: + term_time_range m tm = + time_range (termWaitTimes tm) m +End + +Definition terms_time_range_def: + terms_time_range m tms = + EVERY (term_time_range m) tms +End + +Definition input_terms_actions_def: + input_terms_actions m tms = + EVERY (λn. n+1 < m) + (terms_in_signals tms) +End + +Definition terms_wtimes_ffi_bound_def: + terms_wtimes_ffi_bound m s tms = + EVERY (λtm. + case calculate_wtime (resetOutput s) (termClks tm) (termWaitTimes tm) of + | NONE => T + | SOME wt => wt < m + ) tms +End + +(* max is dimword *) +(* m is m+n *) +Inductive pickTerm: + (!st m cnds in_signal clks dest diffs tms st'. + EVERY (λcnd. evalCond st cnd) cnds ∧ + conds_eval_lt_dimword m st (Tm (Input in_signal) cnds clks dest diffs::tms) ∧ + max_clocks st.clocks m ∧ + terms_time_range m (Tm (Input in_signal) cnds clks dest diffs::tms) ∧ + input_terms_actions m (Tm (Input in_signal) cnds clks dest diffs::tms) ∧ + terms_wtimes_ffi_bound m st (Tm (Input in_signal) cnds clks dest diffs::tms) ∧ + evalTerm st (SOME in_signal) (Tm (Input in_signal) cnds clks dest diffs) st' ⇒ + pickTerm st m (SOME in_signal) (Tm (Input in_signal) cnds clks dest diffs::tms) st' + (LAction (Input in_signal))) ∧ + + (!st m cnds out_signal clks dest diffs tms st'. + EVERY (λcnd. evalCond st cnd) cnds ∧ + conds_eval_lt_dimword m st (Tm (Output out_signal) cnds clks dest diffs::tms) ∧ + max_clocks st.clocks m ∧ + terms_time_range m (Tm (Output out_signal) cnds clks dest diffs::tms) ∧ + input_terms_actions m tms ∧ + terms_wtimes_ffi_bound m st (Tm (Output out_signal) cnds clks dest diffs::tms) ∧ + evalTerm st NONE (Tm (Output out_signal) cnds clks dest diffs) st' ⇒ + pickTerm st m NONE (Tm (Output out_signal) cnds clks dest diffs::tms) st' + (LAction (Output out_signal))) ∧ + + (!st m cnds event ioAction clks dest diffs tms st' lbl. + EVERY (λcnd. EVERY (λe. ∃t. evalExpr st e = SOME t) (destCond cnd)) cnds ∧ + ~(EVERY (λcnd. evalCond st cnd) cnds) ∧ + tm_conds_eval_limit m st (Tm ioAction cnds clks dest diffs) ∧ + term_time_range m (Tm ioAction cnds clks dest diffs) ∧ + input_terms_actions m [(Tm ioAction cnds clks dest diffs)] ∧ + terms_wtimes_ffi_bound m st (Tm ioAction cnds clks dest diffs :: tms) ∧ + pickTerm st m event tms st' lbl ⇒ + pickTerm st m event (Tm ioAction cnds clks dest diffs :: tms) st' lbl) ∧ + + (!st m cnds event in_signal clks dest diffs tms st' lbl. + event <> SOME in_signal ∧ + tm_conds_eval_limit m st (Tm (Input in_signal) cnds clks dest diffs) ∧ + term_time_range m (Tm (Input in_signal) cnds clks dest diffs) ∧ + terms_wtimes_ffi_bound m st (Tm (Input in_signal) cnds clks dest diffs :: tms) ∧ + in_signal + 1 < m ∧ + pickTerm st m event tms st' lbl ⇒ + pickTerm st m event (Tm (Input in_signal) cnds clks dest diffs :: tms) st' lbl) ∧ + + (!st m cnds event out_signal clks dest diffs tms st' lbl. + event <> NONE ∧ + tm_conds_eval_limit m st (Tm (Output out_signal) cnds clks dest diffs) ∧ + term_time_range m (Tm (Output out_signal) cnds clks dest diffs) ∧ + terms_wtimes_ffi_bound m st (Tm (Output out_signal) cnds clks dest diffs :: tms) ∧ + pickTerm st m event tms st' lbl ⇒ + pickTerm st m event (Tm (Output out_signal) cnds clks dest diffs :: tms) st' lbl) ∧ + + (!st m. + max_clocks st.clocks m ⇒ + pickTerm st m NONE [] st (LPanic PanicTimeout)) ∧ + + (!st m in_signal. + max_clocks st.clocks m ∧ + in_signal + 1 < m ⇒ + pickTerm st m (SOME in_signal) [] st (LPanic (PanicInput in_signal))) +End + +(* d + n ≤ m ∧ *) + +(* m ≤ w + n *) +(* n would be FST (seq 0), or may be systime time *) +Inductive step: + (!p m n st d. + st.waitTime = NONE ∧ + d + n < m ∧ + max_clocks (delay_clocks (st.clocks) (d + n)) m ⇒ + step p (LDelay d) m n st + (mkState + (delay_clocks (st.clocks) d) + st.location + NONE + NONE)) ∧ + + (!p m n st d w. + st.waitTime = SOME w ∧ + d ≤ w ∧ w < m ∧ d + n < m ∧ + max_clocks (delay_clocks (st.clocks) (d + n)) m ⇒ + step p (LDelay d) m n st + (mkState + (delay_clocks (st.clocks) d) + st.location + NONE + (SOME (w - d)))) ∧ + + (!p m n st tms st' in_signal. + n < m ∧ + ALOOKUP p st.location = SOME tms ∧ + (case st.waitTime of + | NONE => T + | SOME wt => wt ≠ 0 ∧ wt < m) ∧ + pickTerm (resetOutput st) m (SOME in_signal) tms st' (LAction (Input in_signal)) ∧ + st'.ioAction = SOME (Input in_signal) ⇒ + step p (LAction (Input in_signal)) m n st st') ∧ + + (!p m n st tms st' out_signal. + n < m ∧ + ALOOKUP p st.location = SOME tms ∧ + st.waitTime = SOME 0 ∧ + pickTerm (resetOutput st) m NONE tms st' (LAction (Output out_signal)) ∧ + st'.ioAction = SOME (Output out_signal) ⇒ + step p (LAction (Output out_signal)) m n st st') ∧ + + (!p m n st tms st'. + n < m ∧ + ALOOKUP p st.location = SOME tms ∧ + st.waitTime = SOME 0 ∧ + pickTerm (resetOutput st) m NONE tms st' (LPanic PanicTimeout) ⇒ + step p (LPanic PanicTimeout) m n st st') ∧ + + (!p m n st tms st' in_signal. + n < m ∧ + ALOOKUP p st.location = SOME tms ∧ + (case st.waitTime of + | NONE => T + | SOME wt => wt ≠ 0 ∧ wt < m) ∧ + pickTerm (resetOutput st) m (SOME in_signal) tms st' (LPanic (PanicInput in_signal)) ⇒ + step p (LPanic (PanicInput in_signal)) m n st st') +End + + +Definition steps_def: + (steps prog [] m n s [] ⇔ T) ∧ + (steps prog (lbl::lbls) m n s (st::sts) ⇔ + step prog lbl m n s st ∧ + let n' = + case lbl of + | LDelay d => d + n + | _ => n + in + steps prog lbls m n' st sts) ∧ + (steps prog _ m _ s _ ⇔ F) +End + +(* +Definition steps_def: + (steps prog [] m n s [] ⇔ + n < m ∧ + (case s.waitTime of + | SOME w => (* w ≠ 0 ∧ *) w < m + | NONE => T)) ∧ + (steps prog (lbl::lbls) m n s (st::sts) ⇔ + step prog lbl m n s st ∧ + let n' = + case lbl of + | LDelay d => d + n + | _ => n + in + steps prog lbls m n' st sts) ∧ + (steps prog _ m _ s _ ⇔ F) +End +*) +Inductive stepTrace: + (!p m n st. + stepTrace p m n st st []) ∧ + + (!p lbl m n st st' st'' tr. + step p lbl m n st st' ∧ + stepTrace p m (case lbl of + | LDelay d => d + n + | LAction _ => n) + st' st'' tr ⇒ + stepTrace p m n st st'' (lbl::tr)) +End + + +val _ = export_theory(); diff --git a/pancake/sketch.txt b/pancake/sketch.txt new file mode 100644 index 0000000000..d3ae3f550c --- /dev/null +++ b/pancake/sketch.txt @@ -0,0 +1,53 @@ +REPRESENTATION: + + state s state t + + the global system clock as 'a word + + store_clocks --> global vars in Pancake, each as 'a word + + wait NONE --> as 0w in wait_set var -- never wake me up (unless there is an input) + wait SOME c --> wait_set is 1w -- some wake up time is present + --> wake_up_at is c as 'a word + + location --> Lab funname (where the code for location is implemented in funname) + + +state_rel: + + s.clocks A = t.sys_time - t.locals "A_time" + + IS_SOME (s.wait) <=> t.locals "wait_set" = 1w + + s.wait = SOME c ==> + c = t.locals "wake_up_at" - t.sys_time + + +IMPLEMENTATION: + + sketch: + + input_received = false; + input = null; + sys_time = get_time_now(); + while ((wait_set ==> sys_time < wake_up_at) && !input_received) { + input_received = check_for_input(); // updates input is received + sys_time = get_time_now(); + } + Call (Ret (Var "location") NONE) (Var "location") [Var "sys_time"] + + +timeLang: + Type program = (location # (term list)) list + + timeLang program turns into the list of Pancake functions + + one should think: location -> term list + + compile ([]:term list) = Skip /\ + compile (x::xs) = compile_single x (compile xs) + + compiler_single (Term io cond next_loc clocks_to_reset wait) otherwise = + panLang$If (compile_cond cond) + (compile_body io next_loc clocks_to_reset wait) + otherwise diff --git a/pancake/taParserScript.sml b/pancake/taParserScript.sml new file mode 100644 index 0000000000..bb8cc843a7 --- /dev/null +++ b/pancake/taParserScript.sml @@ -0,0 +1,47 @@ +(* + Parser for compactDSL programs +*) + +open preamble + timeLangTheory + +val _ = new_theory "taParser"; + +Overload CVar = “strlit”; + +local + fun has_nat_prefix (#"%" :: #"n" :: #"a" :: #"t" :: _) = true + | has_nat_prefix _ = false + + fun replace_nat_chars [] = [] + | replace_nat_chars xs = + if has_nat_prefix xs + then #"n" :: replace_nat_chars (List.drop(xs,4)) + else hd xs :: replace_nat_chars (tl xs) + + val replace_nat = implode o replace_nat_chars o explode +in + fun parseFile fname filename = + let + val fd = TextIO.openIn filename + val content = TextIO.inputAll fd handle e => (TextIO.closeIn fd; raise e) + val _ = TextIO.closeIn fd + val content = replace_nat content + in + Define [QUOTE (fname ^ " " ^ content)] + end +end + +val flashing_led_def = + parseFile "flashing_led" + "ta_progs/flashing_led.out"; + +val flashing_led_with_button_def = + parseFile "flashing_led_with_button" + "ta_progs/flashing_led_with_button.out"; + +val flashing_led_with_invariant_def = + parseFile "flashing_led_with_invariant" + "ta_progs/flashing_led_with_invariant.out"; + +val _ = export_theory(); diff --git a/pancake/ta_progs/README.md b/pancake/ta_progs/README.md new file mode 100644 index 0000000000..271145552a --- /dev/null +++ b/pancake/ta_progs/README.md @@ -0,0 +1 @@ +Same TA programs diff --git a/pancake/ta_progs/flashing_led.out b/pancake/ta_progs/flashing_led.out new file mode 100644 index 0000000000..b46f489bd1 --- /dev/null +++ b/pancake/ta_progs/flashing_led.out @@ -0,0 +1,13 @@ + = ([(0%nat, + [Tm (Output 1%nat) + [CndLe (EClock (CVar "x")) (ELit 1); + CndLe (ELit 1) (EClock (CVar "x")); + CndLe (EClock (CVar "x")) (ELit 2)] [] 1%nat + [(2, CVar "x")]]); + (1%nat, + [Tm (Output 0%nat) + [CndLe (EClock (CVar "x")) (ELit 2); + CndLe (ELit 2) (EClock (CVar "x")); + CndLe (ELit 0) (ELit 1)] + [CVar "x"] 0%nat [(1, CVar "x")]])], NONE) + : program diff --git a/pancake/ta_progs/flashing_led_with_button.out b/pancake/ta_progs/flashing_led_with_button.out new file mode 100644 index 0000000000..1f82fa1552 --- /dev/null +++ b/pancake/ta_progs/flashing_led_with_button.out @@ -0,0 +1,23 @@ + = ([(0%nat, + [Tm (Output 1%nat) + [CndLe (EClock (CVar "x")) (ELit 1); + CndLe (ELit 1) (EClock (CVar "x")); + CndLe (EClock (CVar "x")) (ELit 2)] [] 2%nat [(2, CVar "x")]; + Tm (Input 0%nat) [] [] 1%nat []]); + (1%nat, + [Tm (Input 1%nat) [CndLe (ELit 0) (ELit 1)] [CVar "x"] 0%nat + [(1, CVar "x")]]); + (2%nat, + [Tm (Output 0%nat) + [CndLe (EClock (CVar "x")) (ELit 2); + CndLe (ELit 2) (EClock (CVar "x")); CndLe (ELit 0) (ELit 1)] + [CVar "x"] 0%nat [(1, CVar "x")]; + Tm (Input 0%nat) [CndLe (EClock (CVar "x")) (ELit 2)] [] 3%nat + [(2, CVar "x")]]); + (3%nat, + [Tm (Input 1%nat) [CndLe (EClock (CVar "x")) (ELit 2)] [] 2%nat + [(2, CVar "x")]; + Tm (Output 2%nat) + [CndLe (EClock (CVar "x")) (ELit 2); + CndLe (ELit 2) (EClock (CVar "x"))] [] 1%nat []])], SOME 10) + : program diff --git a/pancake/ta_progs/flashing_led_with_invariant.out b/pancake/ta_progs/flashing_led_with_invariant.out new file mode 100644 index 0000000000..cbf4d89772 --- /dev/null +++ b/pancake/ta_progs/flashing_led_with_invariant.out @@ -0,0 +1,25 @@ + = ([(0%nat, + [Tm (Output 1%nat) + [CndLe (EClock (CVar "x")) (ELit 1); + CndLe (ELit 1) (EClock (CVar "x")); + CndLe (EClock (CVar "x")) (ELit 2)] [] 2%nat [(2, CVar "x")]; + Tm (Input 0%nat) [CndLt (ELit 0) (ELit 5)] [CVar "y"] 1%nat + [(5, CVar "y")]]); + (1%nat, + [Tm (Input 1%nat) [CndLe (ELit 0) (ELit 1)] [CVar "x"] 0%nat + [(1, CVar "x")]]); + (2%nat, + [Tm (Output 0%nat) + [CndLe (EClock (CVar "x")) (ELit 2); + CndLe (ELit 2) (EClock (CVar "x")); CndLe (ELit 0) (ELit 1)] + [CVar "x"] 0%nat [(1, CVar "x")]; + Tm (Input 0%nat) [CndLe (EClock (CVar "x")) (ELit 2)] [CVar "y"] 3%nat + [(2, CVar "x")]]); + (3%nat, + [Tm (Input 1%nat) [CndLe (EClock (CVar "x")) (ELit 2)] [] 2%nat + [(2, CVar "x")]; + Tm (Output 2%nat) + [CndLe (EClock (CVar "x")) (ELit 2); + CndLe (ELit 2) (EClock (CVar "x")); + CndLt (EClock (CVar "y")) (ELit 5)] [] 1%nat [(5, CVar "y")]])], SOME 1) + : program diff --git a/pancake/timeLangScript.sml b/pancake/timeLangScript.sml new file mode 100644 index 0000000000..5c8895ca83 --- /dev/null +++ b/pancake/timeLangScript.sml @@ -0,0 +1,189 @@ +(* + Abstract syntax for timeLang +*) + +open preamble + stringTheory mlstringTheory mlintTheory + +val _ = new_theory "timeLang"; + +Overload CVar[inferior] = “strlit” + +val _ = set_grammar_ancestry + ["mlint"]; + +(* location identifies TA-states *) +Type loc = ``:num`` + +(* state specific input and output *) +Type in_signal = ``:num`` +Type out_signal = ``:num`` + +Datatype: + ioAction = Input in_signal + | Output out_signal +End + +(* + IMP: + time:rat in the Coq formalism, + Pancake has discrete time:num *) +Type time = ``:num`` + +(* clock variables *) +Type clock = ``:mlstring`` +Type clocks = ``:clock list`` + +(* time expression *) +Datatype: + expr = ELit time + | EClock clock + | ESub expr expr +End + +(* relational time expression *) +Datatype: + cond = CndLe expr expr (* e <= e *) + | CndLt expr expr (* e < e *) +End + +Datatype: + term = Tm ioAction + (cond list) + clocks + loc + ((time # clock) list) (* to calculate wait time *) +End + +(* +Type program = ``:(loc # term list) list`` +*) + +Type program = ``:(loc # term list) list # time option`` + +(* functions for compiler *) +Definition termConditions_def: + (termConditions (Tm _ cs _ _ _) = cs) +End + +Definition termWaitTimes_def: + (termWaitTimes (Tm _ _ _ _ wt) = wt) +End + +Definition termDest_def: + (termDest (Tm _ _ _ loc _) = loc) +End + +Definition termAction_def: + (termAction (Tm io _ _ _ _) = io) +End + + +Definition terms_out_signals_def: + (terms_out_signals [] = []) ∧ + (terms_out_signals (Tm (Output out) _ _ _ _::tms) = + out :: terms_out_signals tms) ∧ + (terms_out_signals (Tm (Input _) _ _ _ _::tms) = + terms_out_signals tms) +End + + +Definition terms_in_signals_def: + (terms_in_signals [] = []) ∧ + (terms_in_signals (Tm (Input i) _ _ _ _::tms) = + i :: terms_in_signals tms) ∧ + (terms_in_signals (Tm (Output _) _ _ _ _::tms) = + terms_in_signals tms) +End + +Definition accumClks_def: + (accumClks ac [] = ac) ∧ + (accumClks ac (clk::clks) = + if MEM clk ac + then accumClks ac clks + else accumClks (clk::ac) clks) +End + + +Definition exprClks_def: + exprClks clks e = + case e of + | ELit t => clks + | EClock clk => + if MEM clk clks then clks else clk::clks + | ESub e1 e2 => + exprClks (exprClks clks e1) e2 +End + + +Definition clksOfExprs_def: + clksOfExprs es = FOLDL exprClks [] es +End + + +Definition destCond_def: + (destCond (CndLe e1 e2) = [e1; e2]) ∧ + (destCond (CndLt e1 e2) = [e1; e2]) +End + + +Definition condClks_def: + condClks cd = clksOfExprs (destCond cd) +End + + +Definition condsClks_def: + condsClks cds = clksOfExprs (FLAT (MAP destCond cds)) +End + + +Definition termClks_def: + termClks (Tm _ _ clks _ _) = clks +End + + +Definition clksOf_def: + clksOf prog = + let tms = FLAT (MAP SND prog) in + accumClks [] (FLAT (MAP termClks tms)) +End + +Definition nClks_def: + nClks prog = LENGTH (clksOf prog) +End + + +Definition termInvs_def: + termInvs (Tm _ _ _ _ tes) = MAP FST tes +End + +Definition initTerm_def: + (initTerm (t::ts) = t) ∧ + (initTerm [] = []) +End + + +Definition initLoc_def: + initLoc = 0:num +End + +Definition waitSet_def: + (waitSet (Tm _ _ _ _ []) = 0:num) ∧ + (waitSet _ = 1:num) +End + +Definition inputSet_def: + (inputSet (Tm _ _ _ _ []) = 1:num) ∧ + (inputSet _ = 0:num) +End + + +Definition out_signals_def: + out_signals prog = + let + tms = FLAT (MAP SND prog) + in + MAP num_to_str (terms_out_signals tms) +End + +val _ = export_theory(); diff --git a/pancake/time_to_panScript.sml b/pancake/time_to_panScript.sml new file mode 100644 index 0000000000..acf9f22f4c --- /dev/null +++ b/pancake/time_to_panScript.sml @@ -0,0 +1,330 @@ +(* + Compilation from timeLang to panLang +*) + +open preamble pan_commonTheory mlintTheory + timeLangTheory panLangTheory + +val _ = new_theory "time_to_pan" + +val _ = set_grammar_ancestry + ["pan_common", "mlint", "timeLang", "panLang"]; + + +Definition ohd_def: + (ohd [] = (0:num,[])) ∧ + (ohd (x::xs) = x) +End + + +Definition ffiBufferAddr_def: + ffiBufferAddr = 4000w:'a word +End + + +Definition ffiBufferSize_def: + ffiBufferSize = (bytes_in_word + bytes_in_word): 'a word +End + + +Definition genShape_def: + genShape n = Comb (REPLICATE n One) +End + + +Definition mkClks_def: + mkClks vname n = REPLICATE n (Var vname) +End + + +Definition emptyConsts_def: + emptyConsts n = REPLICATE n (Const 0w) +End + + +Definition indicesOf_def: + indicesOf xs ys = MAP (λn. findi n xs) ys +End + + +Definition resetTermClocks_def: + resetTermClocks v clks tclks = + MAPi (λn e. + if (MEM e tclks) + then (Const 0w) + else Field n (Var v)) + clks +End + + +Definition waitTimes_def: + waitTimes = + list$MAP2 (λt e. Op Sub [Const (n2w t); e]) +End + + +Definition minOp_def: + (minOp v [] = Skip) ∧ + (minOp v (e::es) = + Seq (If (Cmp Lower e (Var v)) (Assign v e) Skip) + (minOp v es)) +End + + +Definition minExp_def: + (minExp v [] = Skip) ∧ + (minExp v (e::es) = Seq (Assign v e) (minOp v es)) +End + + +Definition compTerm_def: + (compTerm (clks:mlstring list) (Tm io cnds tclks loc wt)) : 'a prog = + let waitClks = indicesOf clks (MAP SND wt); + return = Return + (Struct + [Var «newClks»; Var «waitSet»; + Var «wakeUpAt»; Label (num_to_str loc)]) + in + decs [ + («waitSet», case wt of [] => Const 1w | wt => Const 0w); (* not waitSet *) + («wakeUpAt», Const 0w); + («newClks», Struct (resetTermClocks «clks» clks tclks)); + («waitTimes», Struct (emptyConsts (LENGTH wt))) + ] + (nested_seq + [Assign «waitTimes» + (Struct ( + waitTimes + (MAP FST wt) + (MAP (λn. Field n (Var «newClks»)) waitClks))); + minExp «wakeUpAt» (MAPi (λn wt. Field n (Var «waitTimes»)) wt); + case io of + | (Input insig) => return + | (Output outsig) => + decs + [(«ptr1»,Const 0w); + («len1»,Const 0w); + («ptr2»,Const ffiBufferAddr); + («len2»,Const ffiBufferSize) + ] (Seq + (ExtCall (num_to_str outsig) «ptr1» «len1» «ptr2» «len2») + return) + ]) +End + + +Definition compExp_def: + (compExp _ _ (ELit t) = Const (n2w t)) ∧ + (compExp clks vname (EClock clk) = + Field (findi clk clks) (Var vname)) ∧ + (compExp clks vname (ESub e1 e2) = + Op Sub [compExp clks vname e1; + compExp clks vname e2]) +End + +Definition compCondition_def: + (compCondition clks vname (CndLt e1 e2) = + Cmp Lower + (compExp clks vname e1) + (compExp clks vname e2)) ∧ + (compCondition clks vname (CndLe e1 e2) = + Op Or [Cmp Lower + (compExp clks vname e1) + (compExp clks vname e2); + Cmp Equal + (compExp clks vname e1) + (compExp clks vname e2)]) +End + +Definition compConditions_def: + (compConditions clks vname [] = Const 1w) ∧ + (compConditions clks vname cs = + Op And (MAP (compCondition clks vname) cs)) +End + + +Definition compAction_def: + (compAction (Output _) = Const 0w) ∧ + (compAction (Input n) = Const (n2w (n + 1))) +End + + +Definition event_match_def: + event_match vname act = Cmp Equal (Var vname) (compAction act) +End + + +Definition pick_term_def: + pick_term clks cname ename cds act = + Op And + [compConditions clks cname cds; + event_match ename act] +End + +Definition compTerms_def: + (compTerms clks cname ename [] = Raise «panic» (Const 0w)) ∧ + (compTerms clks cname ename (t::ts) = + let + cds = termConditions t; + act = termAction t + in + If (pick_term clks cname ename cds act) + (compTerm clks t) + (compTerms clks cname ename ts)) +End + +Definition compLocation_def: + compLocation clks (loc,ts) = + let n = LENGTH clks in + (num_to_str loc, + [(«clks», genShape n); + («event», One)], + compTerms clks «clks» «event» ts) +End + +Definition compProg_def: + (compProg clks [] = []) ∧ + (compProg clks (p::ps) = + compLocation clks p :: compProg clks ps) +End + +Definition comp_def: + comp prog = + compProg (clksOf prog) prog +End + + +Definition fieldsOf_def: + fieldsOf e n = + MAP (λn. Field n e) (GENLIST I n) +End + + +Definition normalisedClks_def: + normalisedClks v1 v2 n = + MAP2 (λx y. Op Sub [x;y]) + (mkClks v1 n) + (fieldsOf (Var v2) n) +End + + +Definition check_input_time_def: + check_input_time = + let time = Load One (Var «ptr2»); + input = Load One + (Op Add [Var «ptr2»; + Const bytes_in_word]) + in + nested_seq [ + ExtCall «get_time_input» «ptr1» «len1» «ptr2» «len2» ; + Assign «sysTime» time ; + Assign «event» input; + Assign «isInput» (Cmp Equal input (Const 0w)); + If (Cmp Equal (Var «sysTime») (Const (n2w (dimword (:α) - 1)))) + (Return (Const 0w)) (Skip:'a prog) + ] +End + +Definition wait_def: + wait = + Op And [Var «isInput»; (* Not *) + Op Or + [Var «waitSet»; (* Not *) + Cmp NotEqual (Var «sysTime») (Var «wakeUpAt»)]] +End + +Definition wait_input_time_limit_def: + wait_input_time_limit = + While wait check_input_time +End + +Definition task_controller_def: + task_controller clksLength = + let + rt = Var «taskRet» ; + nClks = Field 0 rt; + nWaitSet = Field 1 rt; + nwakeUpAt = Field 2 rt; + nloc = Field 3 rt + in + (nested_seq [ + wait_input_time_limit; + If (Cmp Equal (Var «sysTime») (Const (n2w (dimword (:α) - 2)))) + check_input_time (Skip:'a prog); + Call (Ret «taskRet» NONE) (Var «loc») + [Struct (normalisedClks «sysTime» «clks» clksLength); + Var «event»]; + Assign «clks» nClks; + Assign «clks» (Struct (normalisedClks «sysTime» «clks» clksLength)); + Assign «waitSet» nWaitSet ; + Assign «wakeUpAt» (Op Add [Var «sysTime»; nwakeUpAt]); + Assign «loc» nloc; + Assign «isInput» (Const 1w); + Assign «event» (Const 0w)]) +End + + +Definition always_def: + always clksLength = + While (Const 1w) + (task_controller clksLength) +End + +Definition start_controller_def: + start_controller (ta_prog:program) = + let + prog = FST ta_prog; + initLoc = FST (ohd prog); + initWakeUp = SND ta_prog; + clksLength = nClks prog + in + decs + [(«loc», Label (num_to_str initLoc)); + («waitSet», + case initWakeUp of NONE => Const 1w | _ => Const 0w); (* not waitSet *) + («event», Const 0w); + («isInput», Const 1w); (* not isInput, active low *) + («wakeUpAt», Const 0w); + («sysTime», Const 0w); + («ptr1», Const 0w); + («len1», Const 0w); + («ptr2», Const ffiBufferAddr); + («len2», Const ffiBufferSize); + («taskRet», + Struct [Struct (emptyConsts clksLength); + Const 0w; Const 0w; Label (num_to_str initLoc)]); + («clks»,Struct (emptyConsts clksLength)) + ] + (nested_seq + [ + check_input_time; + Assign «clks» (Struct (mkClks «sysTime» clksLength)); + Assign «wakeUpAt» + (case initWakeUp of + | NONE => Var «sysTime» + | SOME n => Op Add [Var «sysTime»; Const (n2w n)]); + always clksLength + ]) +End + + +Definition ta_controller_def: + ta_controller (ta_prog:program) = + decs + [ + («retvar», Const 0w); + («excpvar», Const 0w) + ] + (nested_seq + [ + Call (Ret «retvar» + (SOME (Handle «panic» «excpvar» (Return (Const 1w))))) + (Label «start_controller») + []; + Return (Const 0w) + ]) +End + + + +val _ = export_theory();