diff --git a/compiler/backend/languages/semantics/envLangScript.sml b/compiler/backend/languages/semantics/envLangScript.sml index 6a49c578..7e0ec1bb 100644 --- a/compiler/backend/languages/semantics/envLangScript.sml +++ b/compiler/backend/languages/semantics/envLangScript.sml @@ -164,6 +164,10 @@ Definition dest_anyThunk_def: od End +Definition is_anyThunk_def: + is_anyThunk v = (∃tv. dest_anyThunk v = INR tv) +End + Definition dest_Constructor_def[simp]: dest_Constructor (Constructor s vs) = return (s, vs) ∧ dest_Constructor _ = fail Type_error @@ -243,7 +247,7 @@ Definition eval_to_def: eval_to k env (Box x) = (do v <- eval_to k env x; - return (Thunk (INL v)) + if is_anyThunk v then fail Type_error else return (Thunk (INL v)) od) ∧ eval_to k env (Force x) = (if k = 0 then fail Diverge else @@ -252,14 +256,21 @@ Definition eval_to_def: (wx, binds) <- dest_anyThunk v; case wx of INL v => return v - | INR (env, y) => eval_to (k - 1) (mk_rec_env binds env) y + | INR (env, y) => + do + res <- eval_to (k - 1) (mk_rec_env binds env) y; + if is_anyThunk res then fail Type_error else return res + od od) ∧ eval_to k env (Prim op xs) = (case op of Cons s => do vs <- result_map (λx. eval_to k env x) xs; - return (Constructor s vs) + if EVERY is_anyThunk vs then + return (Constructor s vs) + else + fail Type_error od | If => fail Type_error | Seq => fail Type_error @@ -366,7 +377,8 @@ Proof \\ Cases_on ‘dest_anyThunk y’ \\ gs [] \\ pairarg_tac \\ gvs [] \\ BasicProvers.TOP_CASE_TAC \\ gs [] - \\ BasicProvers.TOP_CASE_TAC \\ gs []) + \\ BasicProvers.TOP_CASE_TAC \\ gs [] + \\ simp [oneline sum_bind_def] \\ rpt (CASE_TAC \\ rw []) \\ gvs []) >- ((* Prim *) dsimp [] \\ strip_tac @@ -387,7 +399,17 @@ Proof \\ rw [] \\ gs []) \\ fs [DECIDE “A ⇒ ¬MEM a b ⇔ MEM a b ⇒ ¬A”] \\ IF_CASES_TAC \\ gs [] - \\ rw [MAP_MAP_o, combinTheory.o_DEF, MAP_EQ_f]) + \\ rw [MAP_MAP_o, combinTheory.o_DEF, MAP_EQ_f] + \\ ( + gvs [EVERY_EL, EL_MAP, EXISTS_MEM, MEM_MAP, MEM_EL] + \\ first_x_assum $ drule_then assume_tac \\ gvs [] + \\ rpt (first_x_assum $ qspec_then ‘EL n xs’ assume_tac) \\ gvs [] + \\ pop_assum $ drule_at_then Any assume_tac \\ gvs [] + \\ rpt ( + qpat_x_assum ‘_ ⇒ _’ mp_tac \\ impl_tac >- (qexists ‘n’ \\ simp []) + \\ strip_tac) + \\ Cases_on ‘eval_to k env (EL n xs)’ + \\ Cases_on ‘eval_to j env (EL n xs)’ \\ gvs [])) >- ((* IsEq *) gvs [LENGTH_EQ_NUM_compute] \\ rename1 ‘eval_to (k - 1) env x’ diff --git a/compiler/backend/languages/semantics/stateLangScript.sml b/compiler/backend/languages/semantics/stateLangScript.sml index 1b0ec9e1..20efafdc 100644 --- a/compiler/backend/languages/semantics/stateLangScript.sml +++ b/compiler/backend/languages/semantics/stateLangScript.sml @@ -23,6 +23,10 @@ val _ = numLib.prefer_num(); (******************** Datatypes ********************) +Datatype: + thunk_mode = Evaluated | NotEvaluated +End + Datatype: sop = (* Primitive operations *) | AppOp (* function application *) @@ -31,12 +35,12 @@ Datatype: | Proj string num (* projection *) | IsEq string num (* check whether same data constructor *) | Alloc (* allocate an array *) - | Ref (* allocates an array in a different way *) | Length (* query the length of an array *) | Sub (* de-reference a value in an array *) - | UnsafeSub (* de-reference but without a bounds check *) | Update (* update a value in an array *) - | UnsafeUpdate (* update without a bounds check *) + | AllocMutThunk thunk_mode (* allocate a mutable thunk *) + | UpdateMutThunk thunk_mode (* update an unevaluated thunk *) + | ForceMutThunk (* force a mutable thunk *) | FFI string (* make an FFI call *) End @@ -70,11 +74,26 @@ Datatype: | Recclosure ((vname # exp) list) ((vname # v) list) vname | Thunk (v + (vname # v) list # exp) | Atom lit + | ThunkLoc num End Type env[pp] = ``:(vname # v) list``; (* value environments *) -Type state[pp] = ``:(v list) list``; (* state *) +Datatype: + store_v = + Array (v list) + | ThunkMem thunk_mode v +End + +Definition store_same_type_def: + store_same_type v1 v2 = + case (v1, v2) of + (Array _, Array _ ) => T + | (ThunkMem NotEvaluated _, ThunkMem _ _) => T + | _ => F +End + +Type state[pp] = ``:store_v list``; (* state *) Datatype: cont = (* continuations *) @@ -88,6 +107,7 @@ Datatype: | RaiseK | HandleK env vname exp | HandleAppK env exp + | ForceMutK num End Datatype: @@ -152,12 +172,12 @@ Definition num_args_ok_def[simp]: num_args_ok (Proj _ _) n = (n = 1) ∧ num_args_ok (IsEq _ _) n = (n = 1) ∧ num_args_ok Sub n = (n = 2) ∧ - num_args_ok UnsafeSub n = (n = 2) ∧ num_args_ok Alloc n = (n = 2) ∧ - num_args_ok Ref n = T ∧ num_args_ok Length n = (n = 1) ∧ num_args_ok Update n = (n = 3) ∧ - num_args_ok UnsafeUpdate n = (n = 3) ∧ + num_args_ok (AllocMutThunk _) n = (n = 1) ∧ + num_args_ok (UpdateMutThunk _) n = (n = 2) ∧ + num_args_ok ForceMutThunk n = (n = 1) ∧ num_args_ok (FFI channel) n = (n = 1) End @@ -227,6 +247,23 @@ Definition dest_anyThunk_def: | _ => NONE End +Datatype: + dest_thunk_ptr_ret + = BadRef + | NotThunk + | IsThunk thunk_mode v +End + +Definition dest_thunk_ptr_def: + dest_thunk_ptr (Atom (Loc n)) st = + (case oEL n st of + | NONE => BadRef + | SOME (ThunkMem Evaluated v) => IsThunk Evaluated v + | SOME (ThunkMem NotEvaluated f) => IsThunk NotEvaluated f + | SOME _ => NotThunk) ∧ + dest_thunk_ptr _ _ = NotThunk +End + (******************** Semantics functions ********************) (* Carry out an application - assumes: @@ -250,22 +287,17 @@ Definition application_def: | _ => error st k) ∧ application Alloc vs st k = ( case HD vs, st of - Atom (Int i), SOME arrays => + Atom (Int i), SOME stores => let n = if i < 0 then 0 else Num i in - value (Atom $ Loc $ LENGTH arrays) - (SOME (SNOC (REPLICATE n (EL 1 vs)) arrays)) k - | _ => error st k) ∧ - application Ref vs st k = ( - case st of - SOME arrays => - value (Atom $ Loc $ LENGTH arrays) - (SOME (SNOC vs arrays)) k + value (Atom $ Loc $ LENGTH stores) + (SOME (SNOC (Array $ REPLICATE n (EL 1 vs)) stores)) + k | _ => error st k) ∧ application Length vs st k = ( case HD vs, st of - Atom (Loc n), SOME arrays => ( - case oEL n arrays of - SOME l => value (Atom $ Int $ & LENGTH l) st k + Atom (Loc n), SOME stores => ( + case oEL n stores of + SOME (Array l) => value (Atom $ Int $ & LENGTH l) st k | _ => error st k) | _ => error st k) ∧ application (Proj s i) vs st k = ( @@ -284,52 +316,57 @@ Definition application_def: | _ => error st k) ∧ application Sub vs st k = ( case (EL 0 vs, EL 1 vs, st) of - (Atom $ Loc n, Atom $ Int i, SOME arrays) => ( - case oEL n arrays of - SOME l => + (Atom $ Loc n, Atom $ Int i, SOME stores) => ( + case oEL n stores of + SOME (Array l) => if 0 ≤ i ∧ i < & LENGTH l then value (EL (Num i) l) st k else (Exn (Constructor "Subscript" []), st, k) | _ => error st k) | _ => error st k) ∧ - application UnsafeSub vs st k = ( - case (EL 0 vs, EL 1 vs, st) of - (Atom $ Loc n, Atom $ Int i, SOME arrays) => ( - case oEL n arrays of - SOME l => - if 0 ≤ i ∧ i < & LENGTH l then - value (EL (Num i) l) st k - else - error st k - | _ => error st k) - | _ => error st k) ∧ application Update vs st k = ( case (EL 0 vs, EL 1 vs, st) of - (Atom $ Loc n, Atom $ Int i, SOME arrays) => ( - case oEL n arrays of - SOME l => + (Atom $ Loc n, Atom $ Int i, SOME stores) => ( + case oEL n stores of + SOME (Array l) => if 0 ≤ i ∧ i < & LENGTH l then value (Constructor "" []) - (SOME (LUPDATE (LUPDATE (EL 2 vs) (Num i) l) n arrays)) + (SOME (LUPDATE (Array $ LUPDATE (EL 2 vs) (Num i) l) n stores)) k else (Exn (Constructor "Subscript" []), st, k) | _ => error st k) | _ => error st k) ∧ - application UnsafeUpdate vs st k = ( - case (EL 0 vs, EL 1 vs, st) of - (Atom $ Loc n, Atom $ Int i, SOME arrays) => ( - case oEL n arrays of - SOME l => - if 0 ≤ i ∧ i < & LENGTH l then - value - (Constructor "" []) - (SOME (LUPDATE (LUPDATE (EL 2 vs) (Num i) l) n arrays)) - k - else - error st k + application (AllocMutThunk mode) vs st k = ( + case HD vs, st of + v, SOME stores => + value (ThunkLoc $ LENGTH stores) + (SOME (SNOC (ThunkMem mode v) stores)) + k + | _ => error st k) ∧ + application (UpdateMutThunk mode) vs st k = ( + case HD vs, st of + (ThunkLoc n, SOME stores) => ( + case oEL n stores of + SOME (ThunkMem NotEvaluated _) => + value + (Constructor "" []) + (SOME (LUPDATE (ThunkMem mode (EL 1 vs)) n stores)) + k + | _ => error st k) + | _ => error st k) ∧ + application ForceMutThunk vs st k = ( + case HD vs, st of + (ThunkLoc n, SOME stores) => ( + case oEL n stores of + SOME (ThunkMem Evaluated v) => value v st k + | SOME (ThunkMem NotEvaluated f) => + value + f + st + (AppK [] AppOp [Constructor "" []] [] :: ForceMutK n :: k) | _ => error st k) | _ => error st k) ∧ application (FFI channel) vs st k = ( @@ -338,6 +375,16 @@ Definition application_def: | _ => error st k) End +Definition thunk_or_thunk_loc_def: + thunk_or_thunk_loc v = + case dest_anyThunk v of + | NONE => + (case v of + | ThunkLoc _ => T + | _ => F) + | SOME _ => T +End + (* Return a value and handle a continuation *) Definition return_def: return v st [] = value v st [] ∧ @@ -361,8 +408,22 @@ Definition return_def: | NONE => error st k | SOME (INL v, _) => value v st k | SOME (INR (env, x), fns) => continue (mk_rec_env fns env) x NONE (ForceK2 st :: k)) ∧ - return v temp_st (ForceK2 st :: k) = value v st k ∧ - return v st (BoxK :: k) = value (Thunk $ INL v) st k + return v temp_st (ForceK2 st :: k) = ( + if thunk_or_thunk_loc v then error st k else + value v st k) ∧ + return v st (BoxK :: k) = ( + if thunk_or_thunk_loc v then error st k else + value (Thunk $ INL v) st k) ∧ + return v st (ForceMutK n :: k) = ( + if thunk_or_thunk_loc v then error st k else + case st of + | NONE => error st k + | SOME stores => + if n < LENGTH stores ∧ + store_same_type (EL n stores) (ThunkMem Evaluated v) then + value v (SOME (LUPDATE (ThunkMem Evaluated v) n stores)) k + else + error st k) End Definition find_match_list_def: @@ -573,17 +634,6 @@ Proof Induct \\ fs [FORALL_PROD,step_n_SUC,is_halt_step_same] QED -Theorem step_n_unfold: - (∃n. k = n + 1 ∧ step_n n (step st c sr) = res) ⇒ - step_n k (sr,st,c) = res -Proof - Cases_on ‘k’ >- fs [] - \\ rewrite_tac [step_n_def,FUNPOW] - \\ fs [ADD1] - \\ Cases_on ‘step st c sr’ \\ Cases_on ‘r’ - \\ fs [step_n_def] -QED - Theorem step_unitl_halt_unwind: step ss1 sk1 r1 = (r1',ss1',sk1') ⇒ step_until_halt (r1,ss1,sk1) = @@ -648,7 +698,7 @@ Triviality application_Action: Proof fs [application_def |> DefnBase.one_line_ify NONE, AllCaseEqs(), error_def, value_def] \\ rw [] \\ fs [] - \\ fs [continue_def] + \\ fs [continue_def,push_def] QED Theorem step_n_is_halt_SOME: @@ -770,12 +820,12 @@ End Theorem application_NONE: application Alloc [v1;v2] NONE s = (Error,NONE,s) ∧ - application Ref vs NONE s = (Error,NONE,s) ∧ application Length [v1] NONE s = (Error,NONE,s) ∧ application Sub [v1;v2] NONE s = (Error,NONE,s) ∧ - application UnsafeSub [v1;v2] NONE s = (Error,NONE,s) ∧ application Update [v1;v2;v3] NONE s = (Error,NONE,s) ∧ - application UnsafeUpdate [v1;v2;v3] NONE s = (Error,NONE,s) ∧ + application (AllocMutThunk m) [v1] NONE s = (Error,NONE,s) ∧ + application (UpdateMutThunk m) [v1;v2] NONE s = (Error,NONE,s) ∧ + application ForceMutThunk [v1] NONE s = (Error,NONE,s) ∧ application (FFI f) [v1] NONE s = (Error,NONE,s) Proof fs [application_def,error_def] @@ -912,11 +962,14 @@ Proof \\ last_x_assum $ drule_at $ Pos $ el 2 \\ impl_tac >- fs [] \\ strip_tac \\ fs []) >~ [‘BoxK’] >- - (fs [return_def,continue_def,value_def] - \\ rw [] \\ fs [step_n_Val,step_n_Error,error_def,GSYM step_n_def] - \\ Cases_on ‘t’ \\ fs [step_n_Val] \\ gvs [step_n_Val] - \\ last_x_assum $ drule_at $ Pos $ el 2 \\ impl_tac >- fs [] - \\ strip_tac \\ fs []) + (gvs [return_def,continue_def,value_def,error_def] + \\ gvs [step_n_Val,step_n_Error,error_def,GSYM step_n_def] + \\ IF_CASES_TAC \\ gvs [] + \\ last_x_assum $ drule_at Any \\ rw [] + \\ last_x_assum $ qspec_then `n'` assume_tac \\ gvs [step_n_def] + \\ last_x_assum $ drule_at Any \\ rw [] \\ gvs [GSYM step_n_def] + \\ gvs [step_n_Val,step_n_Error] + \\ Cases_on ‘t’ \\ fs [step_n_Val] \\ gvs [step_n_Val]) >~ [‘ForceK1’] >- (fs [return_def,continue_def,value_def] \\ CASE_TAC @@ -933,11 +986,14 @@ Proof \\ last_x_assum $ drule_at $ Pos $ el 2 \\ impl_tac >- fs [] \\ strip_tac \\ fs []) >~ [‘ForceK2’] >- - (fs [return_def,continue_def,value_def] - \\ Cases_on ‘t’ \\ fs [step_n_Val] \\ gvs [step_n_Val] - \\ rw [] \\ gvs [step_n_Val,step_n_Error,error_def,GSYM step_n_def] - \\ last_x_assum $ drule_at $ Pos $ el 2 \\ impl_tac >- fs [] - \\ strip_tac \\ fs []) + (gvs [return_def,continue_def,value_def,error_def] + \\ gvs [step_n_Val,step_n_Error,error_def,GSYM step_n_def] + \\ IF_CASES_TAC \\ gvs [] + \\ last_x_assum $ drule_at Any \\ rw [] + \\ last_x_assum $ qspec_then `n'` assume_tac \\ gvs [step_n_def] + \\ last_x_assum $ drule_at Any \\ rw [] \\ gvs [GSYM step_n_def] + \\ gvs [step_n_Val,step_n_Error] + \\ Cases_on ‘t’ \\ fs [step_n_Val] \\ gvs [step_n_Val]) >~ [‘RaiseK’] >- (fs [return_def,error_def] \\ fs [error_def] \\ rw [] \\ gvs [step_n_Val,step_n_Error,error_def,GSYM step_n_def]) @@ -954,6 +1010,9 @@ Proof \\ rw [] \\ gvs [step_n_Val,step_n_Error,error_def,GSYM step_n_def] \\ last_x_assum $ drule_at $ Pos $ el 2 \\ impl_tac >- fs [] \\ strip_tac \\ fs []) + >~ [‘ForceMutK’] >- + (gvs [return_def,continue_def,value_def,error_def] + \\ gvs [step_n_Val,step_n_Error,error_def,GSYM step_n_def]) \\ rename [‘AppK env sop vs es’] \\ gvs [] \\ reverse (Cases_on ‘es’) \\ fs [return_def,continue_def] @@ -1003,26 +1062,28 @@ Proof >~ [‘Alloc’] >- (gvs [application_NONE,num_args_ok_def,LENGTH_EQ_NUM_compute,value_def] \\ fs [step_n_Val,step_n_Error,error_def,GSYM step_n_def]) - >~ [‘Ref’] >- - (gvs [application_NONE,num_args_ok_def,LENGTH_EQ_NUM_compute,value_def] - \\ fs [step_n_Val,step_n_Error,error_def,GSYM step_n_def]) >~ [‘Length’] >- (gvs [application_NONE,num_args_ok_def,LENGTH_EQ_NUM_compute,value_def] \\ fs [step_n_Val,step_n_Error,error_def,GSYM step_n_def]) >~ [‘Sub’] >- (gvs [application_NONE,num_args_ok_def,LENGTH_EQ_NUM_compute,value_def] \\ fs [step_n_Val,step_n_Error,error_def,GSYM step_n_def]) - >~ [‘UnsafeSub’] >- - (gvs [application_NONE,num_args_ok_def,LENGTH_EQ_NUM_compute,value_def] - \\ fs [step_n_Val,step_n_Error,error_def,GSYM step_n_def]) >~ [‘Update’] >- (gvs [application_NONE,num_args_ok_def,LENGTH_EQ_NUM_compute,value_def] \\ Cases_on ‘vs’ \\ fs [] \\ Cases_on ‘t'’ \\ fs [] \\ Cases_on ‘t''’ \\ fs [] \\ gvs [application_NONE,num_args_ok_def,LENGTH_EQ_NUM_compute,value_def] \\ fs [step_n_Val,step_n_Error,error_def,GSYM step_n_def]) - >~ [‘UnsafeUpdate’] >- + >~ [‘AllocMutThunk’] >- (gvs [application_NONE,num_args_ok_def,LENGTH_EQ_NUM_compute,value_def] - \\ Cases_on ‘vs’ \\ fs [] \\ Cases_on ‘t'’ \\ fs [] \\ Cases_on ‘t''’ \\ fs [] + \\ fs [step_n_Val,step_n_Error,error_def,GSYM step_n_def]) + >~ [‘UpdateMutThunk’] >- + (gvs [application_NONE,num_args_ok_def,LENGTH_EQ_NUM_compute,value_def] + \\ Cases_on ‘t’ \\ fs [] \\ Cases_on ‘t'’ \\ fs [] + \\ gvs [application_NONE,num_args_ok_def,LENGTH_EQ_NUM_compute,value_def] + \\ fs [step_n_Val,step_n_Error,error_def,GSYM step_n_def]) + >~ [‘ForceMutThunk’] >- + (gvs [application_NONE,num_args_ok_def,LENGTH_EQ_NUM_compute,value_def] + \\ Cases_on ‘t’ \\ fs [] \\ gvs [application_NONE,num_args_ok_def,LENGTH_EQ_NUM_compute,value_def] \\ fs [step_n_Val,step_n_Error,error_def,GSYM step_n_def]) >~ [‘FFI’] >- @@ -1041,281 +1102,149 @@ Proof APPEND_EQ_CONS |> CONV_RULE(LHS_CONV SYM_CONV)] QED -Theorem step_pres_cons_NIL: - step ts [] (Exp l e) = (res,ts1,[]) ⇒ - step ts k (Exp l e) = (res,ts1,k) +Theorem step_weaken: + step st k sr = (sr', st', k') ∧ + ¬is_halt (sr', st', k') + ⇒ step st (k ++ extra) sr = (sr', st', k' ++ extra) Proof - Cases_on ‘e’ - \\ fs [step_def,error_def,value_def,continue_def,AllCaseEqs(),push_def] - \\ rw [] \\ fs [] - \\ Cases_on ‘s’ \\ fs [num_args_ok_def] - \\ fs [application_def,value_def] - \\ every_case_tac \\ fs [error_def,return_def] -QED - -Theorem step_inc_cont: - step ts (k0::k1) te = (x0,x1,k2) ∧ LENGTH k1 + 1 < LENGTH k2 ⇒ - ∃k. k2 = k::k0::k1 ∧ ∀k3. step ts (k0::k3) te = (x0,x1,k::k0::k3) -Proof - Cases_on ‘te’ \\ fs [step_def] \\ fs [error_def] - >~ [‘Exp l e’] >- - (Cases_on ‘e’ - \\ fs [step_def] \\ fs [error_def,value_def,continue_def,push_def] - \\ rw [] \\ fs [] - \\ gvs [AllCaseEqs()] - \\ Cases_on ‘s’ \\ gvs [num_args_ok_def,LENGTH_EQ_NUM_compute] - \\ gvs [application_def,value_def,AllCaseEqs(),error_def,return_def]) - >~ [‘Exn’] >- - (Cases_on ‘k0’ \\ fs [continue_def,push_def] \\ rw[] \\ gvs[]) - \\ rw [] \\ fs [] - \\ Cases_on ‘k0’ \\ fs [return_def] - \\ gvs [AllCaseEqs(),continue_def,error_def,value_def] - \\ gvs [return_def |> DefnBase.one_line_ify NONE,AllCaseEqs()] - \\ gvs [AllCaseEqs(),continue_def,error_def,value_def] - \\ Cases_on ‘s’ \\ gvs [num_args_ok_def,LENGTH_EQ_NUM_compute] - \\ gvs [application_def,AllCaseEqs(),error_def,continue_def,value_def] + rw[] >> + Cases_on ‘sr’ >> gvs[step_def, error_def] + >- ( + Cases_on ‘e’ >> gvs[step_def, AllCaseEqs()] >> + gvs[error_def, value_def, push_def, continue_def] >> + Cases_on ‘s’ >> gvs[num_args_ok_def, application_def, value_def] >> + gvs[get_atoms_def, oneline pure_configTheory.eval_op_def] >> + gvs[pure_configTheory.concat_def, pure_configTheory.implode_def] >> + gvs[AllCaseEqs(), error_def] + ) + >- ( + Cases_on ‘k’ >> gvs[return_def, value_def] >> + gvs[oneline return_def, AllCaseEqs(), error_def, continue_def, value_def] >> + Cases_on ‘sop’ >> gvs[num_args_ok_def, LENGTH_EQ_NUM_compute] >> + gvs[application_def, AllCaseEqs(), error_def, value_def, continue_def] + ) + >- ( + Cases_on ‘k’ >> gvs[step_def] >> + gvs[AllCaseEqs(), push_def, continue_def] + ) QED -Theorem step_inc_nil: - step ts [] te = (x0,x1,h::t) ∧ ¬is_halt (te,ts,[]:cont list) ⇒ - t = [] ∧ ∀k. step ts k te = (x0,x1,h::k) +Theorem step_n_weaken: + ∀n e ts k res ts1 k1. + step_n n (e,ts,k) = (res,ts1,k1) ∧ ¬is_halt (res,ts1,k1) + ⇒ ∀k2. step_n n (e,ts,k ++ k2) = (res,ts1,k1 ++ k2) Proof - Cases_on ‘te’ \\ strip_tac - \\ gvs [step_def,error_def] - \\ Cases_on ‘e’ \\ gvs [step_def,AllCaseEqs(),error_def,value_def,push_def,continue_def] - \\ Cases_on ‘s’ \\ gvs [num_args_ok_def,LENGTH_EQ_NUM_compute] - \\ gvs [application_def,value_def,AllCaseEqs(),error_def,value_def,push_def,continue_def] + Induct >> rw[step_n_SUC] >> + qmatch_asmsub_abbrev_tac ‘step_n n x’ >> + PairCases_on ‘x’ >> gvs[] >> + ‘¬is_halt (x0,x1,x2)’ by ( + CCONTR_TAC >> gvs[] >> + drule is_halt_step_n_same >> + disch_then $ qspec_then ‘n’ assume_tac >> gvs[]) >> + drule step_weaken >> simp[] QED -Theorem step_dec_cont: - step ts k1 te = (x0,x1,k2) ∧ LENGTH k2 < LENGTH k1 ⇒ - ∃k. k1 = k::k2 ∧ ∀k3. step ts (k::k3) te = (x0,x1,k3) +Theorem step_weaken_alt: + step st k sr = (sr', st', k') ∧ + ¬is_halt (sr, st, k) + ⇒ step st (k ++ extra) sr = (sr', st', k' ++ extra) Proof - Cases_on ‘te’ \\ fs [step_def,error_def] - >~ [‘Exp l e’] >- - (Cases_on ‘e’ - >~ [‘Var’] >- - (fs [step_def] \\ CASE_TAC \\ fs [error_def,value_def]) - \\ fs [step_def] \\ fs [error_def,value_def,continue_def,push_def] - \\ rw [] \\ fs [] - \\ gvs [AllCaseEqs()] - \\ Cases_on ‘s’ \\ gvs [num_args_ok_def,LENGTH_EQ_NUM_compute] - \\ gvs [application_def,value_def,AllCaseEqs(),error_def,return_def]) - >~ [‘Exn’] >- - (Cases_on ‘k1’ \\ fs [step_def,error_def] - \\ Cases_on ‘h’ \\ fs [continue_def,push_def] \\ rw[] \\ gvs[]) - \\ Cases_on ‘k1’ \\ fs [] - \\ Cases_on ‘h’ - \\ fs [return_def] - \\ rw [] - \\ fs [continue_def,error_def,value_def] - \\ rw [] \\ gvs [AllCaseEqs(),value_def] - \\ gvs [return_def|>DefnBase.one_line_ify NONE, AllCaseEqs(),error_def, - continue_def,value_def] - \\ Cases_on ‘s’ \\ gvs [num_args_ok_def,LENGTH_EQ_NUM_compute] - \\ gvs [application_def,value_def,AllCaseEqs(),error_def,return_def] - \\ gvs [continue_def,value_def] -QED - -Theorem step_eq_cont: - step ts (k::k1) te = (x0,x1,x2) ∧ LENGTH x2 = LENGTH (k::k1) ⇒ - ∃d. x2 = d::k1 ∧ ∀k3. step ts (k::k3) te = (x0,x1,d::k3) -Proof - Cases_on ‘te’ \\ fs [step_def,error_def] - >~ [‘Exp l e’] >- - (Cases_on ‘e’ - \\ fs [step_def] \\ fs [error_def,value_def,continue_def,push_def] - \\ rw [] \\ fs [] - \\ gvs [AllCaseEqs()] - \\ CCONTR_TAC \\ gvs [] - \\ Cases_on ‘s’ \\ gvs [num_args_ok_def,LENGTH_EQ_NUM_compute] - \\ gvs [application_def,value_def,AllCaseEqs(),error_def,return_def]) - >~ [‘Exn’] >- - (rw [] \\ fs [] - \\ gvs [AllCaseEqs(),continue_def,push_def]) - \\ gvs [return_def|>DefnBase.one_line_ify NONE, AllCaseEqs(),error_def, - continue_def,value_def] \\ rw [] - \\ fs [continue_def,error_def,value_def] - \\ Cases_on ‘sop’ \\ gvs [num_args_ok_def,LENGTH_EQ_NUM_compute] - \\ gvs [application_def,value_def,AllCaseEqs(),error_def,return_def] - \\ gvs [continue_def,value_def] -QED - -Triviality step_n_cont_swap_lemma: - ∀n x0 x1 k k1 res ts1 k2. - FUNPOW (λ(sr,st,k). step st k sr) n (x0,x1,k::k1) = (res,ts1,k2) ∧ - LENGTH k2 ≤ LENGTH k1 ⇒ - ∃m res7 ts7 k7. - m ≤ n ∧ - FUNPOW (λ(sr,st,k). step st k sr) m (x0,x1,k::k1) = (res7,ts7,k7) ∧ - LENGTH k1 = LENGTH k7 ∧ - (∀i. i < m ⇒ - ∃res7 ts7 k7. - FUNPOW (λ(sr,st,k). step st k sr) i (x0,x1,k::k1) = (res7,ts7,k7) ∧ - LENGTH k1 < LENGTH k7) -Proof - completeInduct_on ‘n’ - \\ rpt gen_tac \\ strip_tac - \\ Cases_on ‘n’ \\ fs [] \\ gvs [] - \\ fs [step_n_def,FUNPOW] - \\ ‘∃y. step x1 (k::k1) x0 = y’ by fs [] \\ PairCases_on ‘y’ \\ fs [] - \\ Cases_on ‘LENGTH y2 < LENGTH (k::k1)’ - >- - (drule_all step_dec_cont \\ fs [] \\ strip_tac \\ gvs [] - \\ qexists_tac ‘SUC 0’ \\ fs []) - \\ reverse (Cases_on ‘LENGTH (k::k1) < LENGTH y2’) - >- - (‘LENGTH y2 = LENGTH (k::k1)’ by fs [] - \\ drule_all step_eq_cont \\ strip_tac \\ gvs [] - \\ first_x_assum $ drule_at $ Pos $ el 2 - \\ impl_tac >- fs [] - \\ strip_tac \\ fs [] - \\ qexists_tac ‘SUC m’ \\ fs [FUNPOW] - \\ Cases \\ fs [FUNPOW] - \\ rw [] \\ res_tac \\ fs []) - \\ fs [ADD1] - \\ drule_all step_inc_cont - \\ strip_tac \\ gvs [] - \\ rename [‘FUNPOW _ n’] - \\ last_assum $ qspec_then ‘n’ mp_tac - \\ impl_tac >- fs [] - \\ disch_then drule - \\ impl_tac >- fs [] - \\ strip_tac - \\ ‘FUNPOW (λ(sr,st,k). step st k sr) n = - FUNPOW (λ(sr,st,k). step st k sr) ((n - m) + m)’ by fs [] - \\ full_simp_tac std_ss [FUNPOW_ADD] - \\ pop_assum kall_tac - \\ Cases_on ‘k7’ \\ fs [] - \\ qpat_x_assum ‘_ = (res,ts1,k2)’ assume_tac - \\ first_x_assum $ drule_at $ Pos $ el 2 - \\ impl_tac >- fs [] - \\ strip_tac - \\ qexists_tac ‘SUC (m' + m)’ - \\ rewrite_tac [FUNPOW_ADD,FUNPOW] - \\ fs [] - \\ Cases \\ fs [FUNPOW] - \\ rw [] - \\ Cases_on ‘n' < m’ \\ res_tac \\ fs [] - \\ ‘FUNPOW (λ(sr,st,k). step st k sr) n' = - FUNPOW (λ(sr,st,k). step st k sr) ((n' - m) + m)’ by fs [] - \\ asm_rewrite_tac [FUNPOW_ADD] - \\ pop_assum kall_tac - \\ gvs [] + rw[] >> + Cases_on ‘sr’ >> gvs[step_def, error_def] + >- ( + Cases_on ‘e’ >> gvs[step_def, AllCaseEqs()] >> + gvs[error_def, value_def, push_def, continue_def] >> + Cases_on ‘s’ >> gvs[num_args_ok_def, application_def, value_def] >> + gvs[get_atoms_def, oneline pure_configTheory.eval_op_def] >> + gvs[pure_configTheory.concat_def, pure_configTheory.implode_def] >> + gvs[AllCaseEqs(), error_def] + ) + >- ( + Cases_on ‘k’ >> gvs[return_def, value_def] >> + gvs[oneline return_def, AllCaseEqs(), error_def, continue_def, value_def] >> + Cases_on ‘sop’ >> gvs[num_args_ok_def, LENGTH_EQ_NUM_compute] >> + gvs[application_def, AllCaseEqs(), error_def, value_def, continue_def] + ) + >- ( + Cases_on ‘k’ >> gvs[step_def] >> + gvs[AllCaseEqs(), push_def, continue_def] + ) QED -Theorem step_n_cont_swap: - ∀n te ts k k1 res ts1 k2. - step_n n (te,ts,k::k1) = (res,ts1,k2) ∧ LENGTH k1 = LENGTH k2 ∧ - (∀m res ts1 k0. - m < n ∧ step_n m (te,ts,k::k1) = (res,ts1,k0) ⇒ LENGTH k1 < LENGTH k0) ⇒ - ∀k3. k2 = k1 ∧ step_n n (te,ts,k::k3) = (res,ts1,k3) +Theorem step_n_to_halt_min: + ∀n conf conf'. + step_n n conf = conf' ∧ ¬is_halt conf ∧ is_halt conf' + ⇒ ∃m mid. + m < n ∧ step_n m conf = mid ∧ ¬is_halt mid ∧ step_n 1 mid = conf' Proof - completeInduct_on ‘n’ - \\ rpt gen_tac \\ strip_tac - \\ Cases_on ‘n’ \\ fs [] \\ gvs [] - \\ fs [step_n_def,FUNPOW] - \\ ‘∃x. step ts (k::k1) te = x’ by fs [] \\ PairCases_on ‘x’ \\ fs [] - \\ Cases_on ‘LENGTH x2 < LENGTH (k::k1)’ - >- - (drule_all step_dec_cont \\ fs [] \\ strip_tac \\ gvs [] - \\ Cases_on ‘n'’ \\ fs [] - \\ first_x_assum $ qspec_then ‘SUC 0’ mp_tac - \\ fs []) - \\ reverse (Cases_on ‘LENGTH (k::k1) < LENGTH x2’) - >- - (‘LENGTH x2 = LENGTH (k::k1)’ by fs [] - \\ drule_all step_eq_cont \\ strip_tac - \\ gvs [] - \\ first_x_assum $ drule_at $ Pos $ el 2 - \\ ntac 2 strip_tac - \\ first_x_assum irule - \\ rw [] - \\ first_x_assum $ qspec_then ‘SUC m'’ mp_tac - \\ fs [FUNPOW]) - \\ fs [ADD1] - \\ drule_all step_inc_cont - \\ strip_tac \\ gvs [] - \\ rename [‘FUNPOW _ n’] - \\ drule step_n_cont_swap_lemma - \\ fs [] \\ strip_tac - \\ Cases_on ‘k7’ \\ fs [ADD1] - \\ last_assum $ qspec_then ‘m’ mp_tac - \\ impl_tac >- fs [] - \\ disch_then $ qspecl_then [‘x0’,‘x1’,‘k'’,‘k::k1’] mp_tac - \\ fs [FUNPOW] - \\ impl_tac >- (rw [] \\ res_tac \\ fs [] \\ gvs []) - \\ strip_tac - \\ gvs [GSYM PULL_FORALL] - \\ last_x_assum $ qspec_then ‘n - m’ mp_tac - \\ impl_tac >- fs [] - \\ disch_then $ qspecl_then [‘res7’,‘ts7’,‘h’,‘k1’] mp_tac - \\ ‘FUNPOW (λ(sr,st,k). step st k sr) n = - FUNPOW (λ(sr,st,k). step st k sr) (m + (n - m))’ by fs [] - \\ full_simp_tac std_ss [] - \\ pop_assum kall_tac - \\ last_x_assum mp_tac - \\ rewrite_tac [FUNPOW_ADD |> ONCE_REWRITE_RULE [ADD_COMM],PULL_FORALL] - \\ simp [] \\ strip_tac - \\ disch_then irule - \\ rw [] - \\ last_x_assum irule - \\ qexists_tac ‘SUC (m' + m)’ - \\ rewrite_tac [FUNPOW_ADD,FUNPOW] - \\ fs [] + Induct >> rw[] >> gvs[step_n_SUC] >> + PairCases_on ‘conf’ >> gvs[] >> + Cases_on ‘is_halt (step conf1 conf2 conf0)’ >> gvs[] + >- ( + drule is_halt_step_n_same >> rw[] >> + qexists ‘0’ >> simp[] + ) >> + last_x_assum drule >> simp[] >> strip_tac >> qexists ‘SUC m’ >> simp[step_n_SUC] +QED + +Theorem num_args_ok_0: + num_args_ok op 0 ⇔ (∃s. op = Cons s) ∨ (∃aop. op = AtomOp aop) +Proof + Cases_on ‘op’ >> gvs[] +QED + +Theorem application_cont: + application op vs st k = (sr, st', k') ⇒ + ∃k''. k' = k'' ++ k +Proof + rw[] >> Cases_on ‘op’ >> gvs[application_def, AllCaseEqs()] >> + gvs[error_def, continue_def, value_def] +QED + +Theorem step_to_halting_value: + step st k sr = (Val v, sr', []) + ⇒ (k = [] ∧ ((∃env e. sr = Exp env e) ∨ (sr = Val v))) ∨ + (∃v' f. sr = Val v' ∧ k = [f]) +Proof + gvs[oneline step_def, return_def, value_def, error_def, push_def, continue_def, + AllCaseEqs()] >> + rw[] >> gvs[] + >- (drule application_cont >> simp[]) >> + gvs[oneline return_def, AllCaseEqs(), error_def, continue_def, value_def] >> + drule application_cont >> simp[] QED Theorem step_n_set_cont: step_n n (Exp tenv1 te,ts,[]) = (Val res,ts1,[]) ⇒ ∃n5. n5 ≤ n ∧ ∀k. step_n n5 (Exp tenv1 te,ts,k) = (Val res,ts1,k) Proof - qsuff_tac ‘ - ∀n te ts res ts1. - step_n n (te,ts,[]) = (Val res,ts1,[]) ∧ ~is_halt (te,ts,[]:cont list) ⇒ - ∃n5. n5 ≤ n ∧ ∀k. step_n n5 (te,ts,k) = (Val res,ts1,k)’ - >- (rw [] \\ res_tac \\ fs []) - \\ completeInduct_on ‘n’ \\ rw [] - \\ Cases_on ‘n’ \\ fs [step_n_def,FUNPOW] \\ rw [] - \\ ‘∃x. step ts [] te = x’ by fs [] \\ PairCases_on ‘x’ \\ fs [] - \\ Cases_on ‘is_halt (x0,x1,x2)’ >- - (gvs [GSYM step_n_def,is_halt_step_n_same] - \\ qexists_tac ‘SUC 0’ \\ fs [] \\ rw [] - \\ last_x_assum kall_tac - \\ Cases_on ‘te’ \\ fs [] - \\ Cases_on ‘e’ - \\ gvs [step_def,AllCaseEqs(),error_def,value_def,push_def,continue_def] - \\ Cases_on ‘s’ \\ gvs [num_args_ok_def,LENGTH_EQ_NUM_compute] - \\ gvs [application_def,value_def,AllCaseEqs(),error_def,get_atoms_def]) - \\ Cases_on ‘x2’ \\ fs [] - >- - (rename [‘FUNPOW _ n’] - \\ last_x_assum $ qspec_then ‘n’ mp_tac \\ fs [] - \\ disch_then drule \\ fs [] \\ strip_tac - \\ qexists_tac ‘SUC n5’ \\ fs [] \\ fs [FUNPOW] - \\ qsuff_tac ‘∀k. step ts k te = (x0,x1,k)’ >- fs [] - \\ Cases_on ‘te’ \\ gvs [] - \\ Cases_on ‘e’ \\ gvs [step_def,AllCaseEqs(),error_def,value_def,push_def,continue_def] - \\ Cases_on ‘s’ \\ gvs [num_args_ok_def,LENGTH_EQ_NUM_compute] - \\ gvs [application_def,value_def,error_def,AllCaseEqs(),push_def]) - \\ drule_all step_inc_nil - \\ strip_tac \\ gvs [] - \\ drule step_n_cont_swap_lemma \\ fs [] \\ strip_tac - \\ rename [‘m ≤ n’] - \\ fs [GSYM step_n_def] - \\ drule step_n_cont_swap \\ fs [GSYM PULL_FORALL] - \\ impl_tac >- (rw [] \\ res_tac \\ fs [] \\ gvs []) - \\ strip_tac \\ fs [] - \\ ‘step_n n = step_n ((n - m) + m)’ by fs [] - \\ full_simp_tac std_ss [step_n_add] \\ gvs [] - \\ Cases_on ‘is_halt (res7,ts7,[]:cont list)’ - >- - (qexists_tac ‘SUC m’ \\ fs [step_n_SUC] - \\ gvs [GSYM step_n_def,is_halt_step_n_same]) - \\ first_x_assum $ drule_at $ Pos $ el 2 - \\ impl_tac >- fs [] - \\ rw [] - \\ qexists_tac ‘SUC (n5 + m)’ - \\ full_simp_tac std_ss [step_n_add,step_n_SUC] \\ gvs [] + rw[] >> + drule step_n_to_halt_min >> rw[] >> + qmatch_asmsub_abbrev_tac ‘¬is_halt mid’ >> + PairCases_on ‘mid’ >> gvs[] >> + drule_all step_n_weaken >> strip_tac >> gvs[] >> + drule step_weaken_alt >> simp[] >> strip_tac >> + qexists ‘SUC m’ >> simp[step_n_alt] +QED + +Theorem step_append_cont: + step ts k e = (res,ts1,k1) ∧ ¬is_halt (res,ts1,k1) ⇒ + step ts (k ++ k2) e = (res,ts1,k1 ++ k2) +Proof + Cases_on ‘e’ \\ strip_tac \\ gvs [step] + >~ [‘Exp’] >- ( + Cases_on ‘e'’ \\ gvs [step, AllCaseEqs()] + \\ Cases_on ‘s’ \\ gvs [num_args_ok_def, LENGTH_EQ_NUM_compute] + \\ gvs [step, AllCaseEqs(), get_atoms_def]) + >~ [‘Exn’] >- (Cases_on ‘k’ \\ gvs [step, AllCaseEqs()]) + \\ Cases_on ‘k’ \\ gvs [step] + \\ Cases_on ‘ts’ \\ gvs [num_args_ok_def, LENGTH_EQ_NUM_compute, step] + \\ Cases_on ‘h’ \\ gvs [step, AllCaseEqs()] + >>~- ([‘AppK’], + Cases_on ‘l1’ \\ gvs [step] + \\ IF_CASES_TAC \\ gvs [step] + \\ Cases_on ‘s’ \\ gvs [step, AllCaseEqs()]) + >>~- ([‘LetK’], Cases_on ‘o'’ \\ gvs [step]) QED Theorem return_fast_forward_lemma[local]: @@ -1410,15 +1339,340 @@ Proof rw[] QED -Theorem step_NONE_Val: - step NONE (forceK2_none h::xs) (Val v) = (x0,x1,x2) ∧ x0 ≠ Error ⇒ +Theorem find_match_list_SOME: + find_match_list cn ws env css d = SOME (env', e) ⇔ + (∃vs. + ALOOKUP css cn = SOME (vs, e) ∧ LENGTH ws = LENGTH vs ∧ + env' = REVERSE (ZIP (vs,ws)) ++ env) ∨ + (ALOOKUP css cn = NONE ∧ + ∃alts. d = SOME (alts, e) ∧ ALOOKUP alts cn = SOME (LENGTH ws) ∧ env' = env) +Proof + Induct_on `css` >> rw[find_match_list_def] + >- (gvs[AllCaseEqs(), PULL_EXISTS] >> eq_tac >> rw[]) >> + PairCases_on `h` >> gvs[find_match_list_def] >> + IF_CASES_TAC >> gvs[] >> eq_tac >> rw[] +QED + +Theorem find_match_SOME: + find_match v env x css usopt = SOME (env', e) ⇔ + ¬ MEM x (FLAT (MAP (FST o SND) css)) ∧ css ≠ [] ∧ + ∃cn vs. v = Constructor cn vs ∧ + find_match_list cn vs env css usopt = SOME (env', e) +Proof + simp[find_match_def, AllCaseEqs()] >> eq_tac >> rw[] +QED + +Theorem ForceMutK_sanity: + oEL n st = SOME (ThunkMem NotEvaluated f) ⇒ + step_n 1 (application ForceMutThunk [ThunkLoc n] (SOME st) k) = + application AppOp [f; Constructor "" []] (SOME st) (ForceMutK n :: k) +Proof[exclude_simps = step_n_1] + strip_tac >> + simp[Once application_def, value_def] >> + simp[step_n_def, step_def, return_def] +QED + + +(* step' *) + +Definition return'_def: + return' avoid v st (ForceK1 :: k) = + (if v ∈ avoid then error st k else + case dest_anyThunk v of + | NONE => error st k + | SOME (INL v, _) => value v st k + | SOME (INR (env, x), fns) => continue (mk_rec_env fns env) x NONE (ForceK2 st :: k)) ∧ + return' avoid v st rest = return v st rest +End + +Definition step'_def: + step' avoid st k (Val v) = return' avoid v st k ∧ + step' avoid st k x = step st k x +End + +Definition step'_n_def: + step'_n n avoid (sr, st, k) = FUNPOW (λ(sr, st, k). step' avoid st k sr) n (sr, st, k) +End + +Theorem step'_n_add: + ∀m n x. step'_n (m + n) avoid x = step'_n m avoid (step'_n n avoid x) +Proof + gvs [step'_n_def,FORALL_PROD,FUNPOW_ADD] \\ rw [] + \\ AP_THM_TAC \\ gvs [FUN_EQ_THM,FORALL_PROD,step'_n_def] +QED + +Theorem step'_n_SUC: + step'_n (SUC n) avoid x = step'_n n avoid (step'_n 1 avoid x) +Proof + fs [ADD1,step'_n_add] +QED + +Theorem step'_n_0[simp]: + step'_n 0 avoid x = x +Proof + PairCases_on ‘x’ \\ fs [step'_n_def] +QED + +Theorem step'_n_1[simp]: + step'_n 1 avoid x = step' avoid (FST (SND x)) (SND (SND x)) (FST x) +Proof + PairCases_on ‘x’ \\ fs [step'_n_def] +QED + +Theorem is_halt_step'_same: + ∀sr st k avoid. is_halt (sr,st,k) ⇒ step' avoid st k sr = (sr,st,k) +Proof + Cases + \\ gvs [oneline is_halt_def,AllCaseEqs(),step'_def,return'_def,step] +QED + +Theorem is_halt_step'_n_same: + ∀n x. is_halt x ⇒ step'_n n avoid x = x +Proof + Induct \\ fs [FORALL_PROD,is_halt_step'_same,step'_n_def,FUNPOW] +QED + +Theorem step'_n_mono: + ∀n avoid res. + is_halt (step'_n n avoid res) ⇒ + ∀m. n < m ⇒ step'_n n avoid res = step'_n m avoid res +Proof + rw [] \\ Induct_on ‘m’ \\ gvs [] + \\ PairCases_on ‘res’ \\ gvs [step'_n_def, FUNPOW_SUC] + \\ Cases_on ‘n = m’ \\ gvs [] + \\ pairarg_tac \\ gvs [is_halt_step'_same] + \\ strip_tac \\ gvs [is_halt_step'_same] +QED + +Theorem step'_n_unfold: + (∃n. k = n + 1 ∧ step'_n n avoid (step' avoid st c sr) = res) ⇒ + step'_n k avoid (sr,st,c) = res +Proof + Cases_on ‘k’ >- fs [] + \\ rewrite_tac [step'_n_def,FUNPOW] + \\ fs [ADD1] + \\ Cases_on ‘step' avoid st c sr’ \\ Cases_on ‘r’ + \\ fs [step'_n_def] +QED + +Theorem step_m'_Error[simp]: + ∀n. step'_n n avoid (Error,ts,tk) = (Error,ts,tk) +Proof + Induct \\ gvs [step'_n_def,FUNPOW,step'_def,step] +QED + +Theorem step'_n_IMP_step_n: + ∀n avoid x r y z. + step'_n n avoid x = (r,y,z) ∧ r ≠ Error ⇒ + step_n n x = (r,y,z) +Proof + Induct \\ gvs [step'_n_def,step_n_def,FORALL_PROD,FUNPOW] \\ rw [] + \\ ‘∃q. step' avoid p_1' p_2 p_1 = q’ by gvs [] + \\ PairCases_on ‘q’ \\ gvs [] + \\ ‘∃t. step p_1' p_2 p_1 = t’ by gvs [] + \\ PairCases_on ‘t’ \\ gvs [] + \\ gvs [GSYM step'_n_def,GSYM step_n_def] + \\ Cases_on ‘q0 = Error’ \\ gvs [] + \\ qsuff_tac ‘(q0,q1,q2) = (t0,t1,t2)’ + >- (gvs [] \\ metis_tac []) + \\ last_x_assum kall_tac + \\ gvs [oneline step'_def,AllCaseEqs(),oneline return'_def, + step_def,return_def,error_def] +QED + +Theorem step'_append_cont: + step' avoid ts k e = (res,ts1,k1) ∧ ¬is_halt (res,ts1,k1) ⇒ + step' avoid ts (k ++ k2) e = (res,ts1,k1 ++ k2) +Proof + Cases_on ‘e’ \\ strip_tac \\ gvs [step'_def, step_append_cont] + \\ Cases_on ‘k’ \\ gvs [return'_def, step] + \\ Cases_on ‘h’ \\ gvs [return'_def, step, AllCaseEqs()] + >~ [‘AppK’] >- ( + Cases_on ‘l1’ \\ gvs [step] + \\ IF_CASES_TAC \\ gvs [step] + \\ Cases_on ‘s’ \\ gvs [step, AllCaseEqs()]) + >~ [‘LetK’] >- (Cases_on ‘o'’ \\ gvs [step]) +QED + +Theorem step'_n_append_cont: + ∀n avoid e ts k res ts1 k1. + step'_n n avoid (e,ts,k) = (res,ts1,k1) ∧ ~is_halt (res,ts1,k1) ⇒ + ∀k2. step'_n n avoid (e,ts,k ++ k2) = (res,ts1,k1 ++ k2) +Proof + completeInduct_on ‘n’ \\ rw [] + \\ Cases_on ‘n’ \\ gvs [step'_n_def, FUNPOW] \\ rw [] + \\ ‘∃x. step' avoid ts k e = x’ by gvs [] \\ PairCases_on ‘x’ \\ gvs [] + \\ ‘∃y. step' avoid ts (k ++ k2) e = y’ by gvs [] + \\ PairCases_on ‘y’ \\ gvs [] + \\ gvs [GSYM step'_n_def, PULL_FORALL] + \\ Cases_on ‘is_halt (x0,x1,x2)’ \\ gvs [is_halt_step'_n_same] + \\ drule_all step'_append_cont \\ rw [] \\ gvs [] +QED + +Triviality step'_not_ForceK1: + v1 ∉ avoid ∧ + step' avoid s k x = (r0,r1,r2) ∧ + (∀ts. x = Val v1 ⇒ k ≠ ForceK1::ts) ⇒ + step' (v1 INSERT avoid) s k x = (r0,r1,r2) +Proof + rw [] + \\ Cases_on ‘x’ \\ gvs [step'_def] + \\ Cases_on ‘k’ \\ gvs [return'_def] + \\ Cases_on ‘h’ \\ gvs [return'_def] +QED + +Theorem add_to_avoid: + ∀m avoid x s k v v1. + v1 ∉ avoid ∧ + step'_n m avoid (x,s,k) = (Val v,NONE,[]) ∧ + (∀n s1 ts. step'_n n avoid (x,s,k) ≠ (Val v1,s1,ForceK1::ts)) ⇒ + step'_n m (v1 INSERT avoid) (x,s,k) = (Val v,NONE,[]) +Proof + completeInduct_on ‘m’ \\ rw [] \\ gvs [] + \\ Cases_on ‘m’ \\ gvs [step'_n_def, FUNPOW] + \\ ‘∃r. step' avoid s k x = r’ by gvs [] \\ PairCases_on ‘r’ \\ gvs [] + \\ ‘∃r'. step' (v1 INSERT avoid) s k x = r'’ by gvs [] + \\ PairCases_on ‘r'’ \\ gvs [] + \\ gvs [GSYM step'_n_def] + \\ first_assum $ qspec_then ‘0’ assume_tac \\ fs [] + \\ drule_all step'_not_ForceK1 \\ rw [] + \\ pop_assum kall_tac + \\ last_x_assum $ qspec_then ‘n’ assume_tac \\ gvs [] + \\ pop_assum irule \\ rw [] \\ gvs [] + \\ first_x_assum $ qspec_then ‘n' + 1’ assume_tac \\ gvs [] + \\ pop_assum $ qspecl_then [‘s1’,‘ts’] assume_tac \\ gvs [] + \\ gvs [GSYM ADD1, step'_n_def, FUNPOW] +QED + +Triviality step'_n_not_halt_mul: + ∀m n avoid x s k. + (∀k1. ¬is_halt (x,s,k1)) ∧ + (∀k. ∃k1. step'_n n avoid (x,s,k) = (x,s,k1)) ⇒ + ∃k1. step'_n (m * n) avoid (x,s,k) = (x,s,k1) +Proof + Induct \\ rw [] \\ gvs [] + \\ simp [ADD1, LEFT_ADD_DISTRIB, step'_n_add] + \\ last_x_assum drule_all \\ rw [] + \\ pop_assum $ qspec_then ‘k’ assume_tac \\ gvs [] +QED + +Theorem step'_n_INSERT: + step'_n m avoid (Exp (mk_rec_env x1 y0) y1,NONE,[]) = (Val v,NONE,[]) ∧ + dest_anyThunk v1 = SOME (INR (y0,y1),x1) ⇒ + step'_n m (v1 INSERT avoid) (Exp (mk_rec_env x1 y0) y1,NONE,[]) = + (Val v,NONE,[]) +Proof + Cases_on ‘v1 ∈ avoid’ + >- ( + ‘v1 INSERT avoid = avoid’ by ( + gvs [pred_setTheory.EXTENSION] \\ metis_tac []) + \\ gvs []) + \\ strip_tac + \\ Cases_on ‘∃n s1 ts. step'_n n avoid (Exp (mk_rec_env x1 y0) y1,NONE,[]) = + (Val v1,s1,ForceK1::ts)’ \\ gvs [] + >- ( + dxrule step'_n_append_cont \\ gvs [] \\ strip_tac + \\ ‘∀k2. ∃k3. + step'_n (n+1) avoid (Exp (mk_rec_env x1 y0) y1,NONE,k2) = + (Exp (mk_rec_env x1 y0) y1,NONE,k3)’ by ( + once_rewrite_tac [ADD_COMM] + \\ asm_rewrite_tac [step'_n_add] + \\ gvs [step'_n_1,step'_def,return'_def,continue_def,mk_rec_env_def]) + \\ pop_assum mp_tac \\ pop_assum kall_tac \\ strip_tac + \\ qsuff_tac ‘F’ \\ gvs [] + \\ dxrule_at Any step'_n_not_halt_mul \\ rpt strip_tac \\ gvs [] + \\ pop_assum $ qspecl_then [‘m + 1’, ‘[]’] assume_tac \\ gvs [] + \\ ‘is_halt (step'_n m avoid (Exp (mk_rec_env x1 y0) y1,NONE,[]))’ + by gvs [] + \\ drule step'_n_mono \\ rw [] + \\ qexists ‘(m + 1) * (n + 1)’ \\ gvs []) + \\ gvs [add_to_avoid] +QED + +Theorem is_halt_imp_eq': + is_halt (step'_n n avoid res) ∧ is_halt (step'_n m avoid res) ⇒ + step'_n n avoid res = step'_n m avoid res +Proof + ‘n < m ∨ m = n ∨ m < n’ by decide_tac + \\ metis_tac [step'_n_mono] +QED + +Theorem step'_n_fast_forward_gen: + ∀m2 sr ss k' ss2 sk2 k sr1 ss1 sk1 n v2. + step_n m2 (sr,ss,k') = (Val v2,ss2,sk2) ∧ + step'_n n avoid (sr,ss,k) = (sr1,ss1,sk1) ∧ is_halt (sr1,ss1,sk1) ∧ + k' ≼ k ∧ sr1 ≠ Error + ⇒ + ∃m3. m3 ≤ n ∧ step'_n m3 avoid (Val v2,ss2,sk2 ++ DROP (LENGTH k') k) = (sr1,ss1,sk1) +Proof + Induct >> rpt strip_tac + >- (irule_at (Pos hd) LESS_EQ_REFL >> + gvs[rich_listTheory.IS_PREFIX_APPEND,rich_listTheory.DROP_APPEND2]) >> + gvs[ADD1,step'_n_add,step_n_add] >> + rename [‘step s k' sr’] >> + ‘∃x y z. step s k' sr = (x,y,z)’ by metis_tac[PAIR] >> + drule step_fast_forward_lemma >> + disch_then(drule_at (Pos last)) >> + impl_tac >- (rw[] >> gvs[is_halt_step_n_same]) >> + reverse strip_tac + >- (gvs[] >> metis_tac[]) >> + Cases_on ‘n’ + >- (drule_then assume_tac is_halt_step'_same >> + gvs[] >> + drule_all_then assume_tac is_halt_prefix >> + gvs[is_halt_step_n_same,is_halt_step_same]) >> + gvs[ADD1,step'_n_add] >> + ‘step' avoid s k sr = step s k sr’ by + (Cases_on ‘sr’ \\ gvs [step'_def] + \\ Cases_on ‘k’ \\ gvs [return'_def,step] + \\ Cases_on ‘h’ \\ gvs [return'_def,step] + \\ rw [] \\ gvs []) >> + gvs [] >> + first_x_assum drule >> + disch_then drule >> + simp[] >> + gvs[] >> + gvs[rich_listTheory.DROP_APPEND2] >> + strip_tac >> + first_x_assum(irule_at (Pos last)) >> + simp[] +QED + +Theorem step'_n_fast_forward: + step'_n n avoid (sr,ss,k::ks) = (sr1,ss1,sk1) ∧ is_halt (sr1,ss1,sk1) ∧ + step_n m2 (sr,ss,[]) = (Val v2,ss2,[]) ∧ sr1 ≠ Error ⇒ + ∃m3. m3 ≤ n ∧ step'_n m3 avoid (Val v2,ss2,k::ks) = (sr1,ss1,sk1) +Proof + rpt strip_tac >> + drule_at (Pat ‘is_halt’) step'_n_fast_forward_gen >> + rpt $ disch_then dxrule >> rw[] +QED + +Theorem step'_n_eq: + ∀n x. step'_n n {} x = step_n n x +Proof + Induct \\ gvs [step_n_def,step'_n_def,FORALL_PROD,FUNPOW_SUC] + \\ rw [] \\ AP_THM_TAC \\ gvs [FUN_EQ_THM] + \\ Cases \\ gvs [step'_def] + \\ Cases_on ‘k’ \\ gvs [return'_def,return_def,step_def] + \\ Cases_on ‘h’ \\ gvs [return'_def,return_def,step_def] +QED + +Theorem step_n_IMP_step'_n: + step_n n x = y ⇒ step'_n n {} x = y +Proof + gvs [step'_n_eq] +QED + +Theorem step'_NONE_Val: + step' avoid NONE (forceK2_none h::xs) (Val v) = (x0,x1,x2) ∧ x0 ≠ Error ⇒ ∃xs1. x2 = MAP forceK2_none xs1 ++ xs ∧ x1 = NONE ∧ (∀e. x0 ≠ Exn e) ∧ (∀e a. x0 ≠ Action e a) ∧ - ∀ys. step NONE (forceK2_none h::ys) (Val v) = + ∀ys. step' avoid NONE (forceK2_none h::ys) (Val v) = (x0,x1,MAP forceK2_none xs1 ++ ys) Proof - Cases_on ‘h’ \\ fs [] \\ fs [step_def] \\ strip_tac - \\ gvs [return_def |> DefnBase.one_line_ify NONE,AllCaseEqs(), + Cases_on ‘h’ \\ fs [] \\ fs [step_def,step'_def] \\ strip_tac + \\ gvs [return'_def,return_def |> DefnBase.one_line_ify NONE,AllCaseEqs(), forceK2_none_def |> DefnBase.one_line_ify NONE,AllCaseEqs(), continue_def,error_def,value_def,push_def] \\ rename [‘num_args_ok s’] @@ -1453,20 +1707,22 @@ Proof \\ gvs [forceK2_none_def |> DefnBase.one_line_ify NONE,AllCaseEqs()] QED -Theorem step_n_NONE_split: - step_n n (Exp env x,NONE,k::tk) = (r,z) ∧ is_halt (r,z) ∧ r ≠ Error ⇒ - ∃m1 m2 v. - step_n m1 (Exp env x,NONE,[]) = (Val v,NONE,[]) ∧ m1 < n ∧ - step_n m2 (Val v,NONE,k::tk) = (r,z) ∧ m2 ≤ n +Theorem step'_n_NONE_split: + ∀avoid. + step'_n n avoid (Exp env x,NONE,k::tk) = (r,z) ∧ is_halt (r,z) ∧ r ≠ Error ⇒ + ∃m1 m2 v. + step'_n m1 avoid (Exp env x,NONE,[]) = (Val v,NONE,[]) ∧ m1 < n ∧ + step'_n m2 avoid (Val v,NONE,k::tk) = (r,z) ∧ m2 ≤ n Proof - qsuff_tac ‘ + gen_tac + \\ qsuff_tac ‘ ∀n xs te k tk r z. - step_n n (te,NONE,MAP forceK2_none xs ++ k::tk) = (r,z) ∧ te ≠ Error ∧ + step'_n n avoid (te,NONE,MAP forceK2_none xs ++ k::tk) = (r,z) ∧ te ≠ Error ∧ ~is_halt (te,NONE,MAP forceK2_none xs) ∧ (∀e. te ≠ Exn e) ∧ (∀e a. te ≠ Action e a) ∧ is_halt (r,z) ∧ r ≠ Error ⇒ ∃m1 m2 v. - step_n m1 (te,NONE,MAP forceK2_none xs) = (Val v,NONE,[]) ∧ m1 < n ∧ - step_n m2 (Val v,NONE,k::tk) = (r,z) ∧ m2 ≤ n’ + step'_n m1 avoid (te,NONE,MAP forceK2_none xs) = (Val v,NONE,[]) ∧ m1 < n ∧ + step'_n m2 avoid (Val v,NONE,k::tk) = (r,z) ∧ m2 ≤ n’ >- (rw [] \\ last_x_assum $ qspecl_then [‘n’,‘[]’] mp_tac \\ fs [] @@ -1479,18 +1735,18 @@ Proof \\ reverse (Cases_on ‘te’) \\ fs [] >- (Cases_on ‘xs’ - \\ gvs [] \\ Cases_on ‘n’ \\ gvs [step_n_SUC] - \\ ‘∃x. step NONE (forceK2_none h::(MAP forceK2_none t ++ k::tk)) + \\ gvs [] \\ Cases_on ‘n’ \\ gvs [step'_n_SUC] + \\ ‘∃x. step' avoid NONE (forceK2_none h::(MAP forceK2_none t ++ k::tk)) (Val v) = x’ by fs [] \\ PairCases_on ‘x’ \\ fs [] \\ Cases_on ‘x0 = Error’ >- (‘is_halt (Error,x1,x2)’ by fs [] \\ qpat_x_assum ‘_ = (r,_)’ mp_tac - \\ DEP_REWRITE_TAC [is_halt_step_n_same] \\ fs []) - \\ drule_all step_NONE_Val \\ strip_tac \\ gvs [] - \\ Q.REFINE_EXISTS_TAC ‘SUC m3’ \\ fs [step_n_SUC] - \\ rename [‘step_n n’] + \\ DEP_REWRITE_TAC [is_halt_step'_n_same] \\ fs []) + \\ drule_all step'_NONE_Val \\ strip_tac \\ gvs [] + \\ Q.REFINE_EXISTS_TAC ‘SUC m3’ \\ fs [step'_n_SUC] + \\ rename [‘step'_n n’] \\ full_simp_tac bool_ss [GSYM MAP_APPEND] \\ Cases_on ‘is_halt (x0,NONE,MAP forceK2_none xs1 ++ MAP forceK2_none t)’ >- @@ -1504,17 +1760,18 @@ Proof \\ first_x_assum $ irule_at $ Pos hd \\ fs [] \\ first_x_assum $ irule_at $ Pos hd \\ fs []) \\ gvs [] - \\ Cases_on ‘n’ \\ gvs [step_n_SUC] - \\ rename [‘step_n n’] - \\ ‘∃x. step NONE (MAP forceK2_none xs ++ k::tk) (Exp l e) = x’ by fs [] + \\ Cases_on ‘n’ \\ gvs [step'_n_SUC] + \\ rename [‘step'_n n’] + \\ ‘∃x. step' avoid NONE (MAP forceK2_none xs ++ k::tk) (Exp l e) = x’ by fs [] \\ PairCases_on ‘x’ \\ fs [] \\ Cases_on ‘x0 = Error’ >- (‘is_halt (Error,x1,x2)’ by fs [] \\ qpat_x_assum ‘_ = (r,_)’ mp_tac - \\ DEP_REWRITE_TAC [is_halt_step_n_same] \\ fs []) + \\ DEP_REWRITE_TAC [is_halt_step'_n_same] \\ fs []) + \\ gvs [step'_def] \\ drule_all step_NONE_Exp \\ strip_tac \\ gvs [] - \\ Q.REFINE_EXISTS_TAC ‘SUC m3’ \\ fs [step_n_SUC] + \\ Q.REFINE_EXISTS_TAC ‘SUC m3’ \\ fs [step'_n_SUC,step'_def] \\ full_simp_tac bool_ss [GSYM MAP_APPEND] \\ Cases_on ‘is_halt (x0,NONE,MAP forceK2_none xs1 ++ MAP forceK2_none xs)’ >- @@ -1529,30 +1786,16 @@ Proof \\ first_x_assum $ irule_at $ Pos $ hd \\ fs [] QED -Theorem find_match_list_SOME: - find_match_list cn ws env css d = SOME (env', e) ⇔ - (∃vs. - ALOOKUP css cn = SOME (vs, e) ∧ LENGTH ws = LENGTH vs ∧ - env' = REVERSE (ZIP (vs,ws)) ++ env) ∨ - (ALOOKUP css cn = NONE ∧ - ∃alts. d = SOME (alts, e) ∧ ALOOKUP alts cn = SOME (LENGTH ws) ∧ env' = env) -Proof - Induct_on `css` >> rw[find_match_list_def] - >- (gvs[AllCaseEqs(), PULL_EXISTS] >> eq_tac >> rw[]) >> - PairCases_on `h` >> gvs[find_match_list_def] >> - IF_CASES_TAC >> gvs[] >> eq_tac >> rw[] -QED - -Theorem find_match_SOME: - find_match v env x css usopt = SOME (env', e) ⇔ - ¬ MEM x (FLAT (MAP (FST o SND) css)) ∧ css ≠ [] ∧ - ∃cn vs. v = Constructor cn vs ∧ - find_match_list cn vs env css usopt = SOME (env', e) +Theorem step_n_NONE_split: + step_n n (Exp env x,NONE,k::tk) = (r,z) ∧ is_halt (r,z) ∧ r ≠ Error ⇒ + ∃m1 m2 v. + step_n m1 (Exp env x,NONE,[]) = (Val v,NONE,[]) ∧ m1 < n ∧ + step_n m2 (Val v,NONE,k::tk) = (r,z) ∧ m2 ≤ n Proof - simp[find_match_def, AllCaseEqs()] >> eq_tac >> rw[] + qspec_then ‘{}’ assume_tac step'_n_NONE_split + \\ gvs [step'_n_eq] QED - (* meaning of cexp *) Definition sop_of_def[simp]: @@ -1560,13 +1803,14 @@ Definition sop_of_def[simp]: sop_of (Cons n) = Cons (explode n) ∧ sop_of (AtomOp m) = AtomOp m ∧ sop_of Alloc = Alloc ∧ - sop_of Ref = Ref ∧ sop_of Length = Length ∧ sop_of Sub = Sub ∧ - sop_of UnsafeSub = UnsafeSub ∧ - sop_of Length = Length ∧ sop_of Update = Update ∧ - sop_of UnsafeUpdate = UnsafeUpdate ∧ + sop_of (AllocMutThunk Evaluated) = (AllocMutThunk Evaluated) ∧ + sop_of (AllocMutThunk NotEvaluated) = (AllocMutThunk NotEvaluated) ∧ + sop_of (UpdateMutThunk Evaluated) = (UpdateMutThunk Evaluated) ∧ + sop_of (UpdateMutThunk NotEvaluated) = (UpdateMutThunk NotEvaluated) ∧ + sop_of ForceMutThunk = ForceMutThunk ∧ sop_of (FFI s) = FFI (explode s) End diff --git a/compiler/backend/languages/semantics/thunkLangPropsScript.sml b/compiler/backend/languages/semantics/thunkLangPropsScript.sml index cc98ef8b..46cce84c 100644 --- a/compiler/backend/languages/semantics/thunkLangPropsScript.sml +++ b/compiler/backend/languages/semantics/thunkLangPropsScript.sml @@ -931,7 +931,8 @@ Proof \\ rw [state_rel_def] \\ fs [Once LIST_REL_EL_EQN] \\ first_x_assum (qspec_then ‘n’ assume_tac) \\ gs [LIST_REL_EL_EQN] - \\ first_x_assum irule \\ intLib.COOPER_TAC) + \\ first_x_assum $ qspec_then ‘Num i’ assume_tac \\ gvs [] + \\ imp_res_tac integerTheory.NUM_POSINT_EXISTS \\ gvs []) \\ first_x_assum irule \\ gs [SF SFY_ss] \\ fs [rel_ok_def] \\ intLib.COOPER_TAC) \\ print_tac "[9/9] Update" @@ -1174,13 +1175,25 @@ Proof \\ Cases_on ‘k ≤ j’ \\ gs [] QED +Theorem eval_to_Force_anyThunk: + ∀k x v. eval_to k (Force x) = INR v ⇒ ¬is_anyThunk v +Proof + Induct \\ rw [Once eval_to_def] + \\ Cases_on `eval_to (SUC k) x` \\ gvs [] + \\ reverse $ Cases_on `dest_Tick y` \\ gvs [] + >- (first_x_assum drule \\ rw []) + \\ Cases_on `dest_anyThunk y` \\ gvs [] + \\ pairarg_tac \\ gvs [] + \\ Cases_on `eval_to k (subst_funs binds y'')` \\ gvs [] +QED + Theorem eval_Force: eval (Force (Value v)) = case dest_Tick v of NONE => - do - (y,binds) <- dest_anyThunk v; - eval (subst_funs binds y) + do (y,binds) <- dest_anyThunk v; + res <- eval (subst_funs binds y); + if is_anyThunk res then fail Type_error else return res od | SOME w => eval (Force (Value w)) Proof @@ -1195,7 +1208,11 @@ Proof >- ( Cases_on ‘dest_anyThunk v’ \\ gs [] \\ pairarg_tac \\ gvs [] - \\ irule eval_to_equals_eval \\ gs []) + \\ Cases_on ‘eval_to (x - 1) (subst_funs binds y')’ \\ gvs [] + \\ TRY (IF_CASES_TAC \\ gvs []) + \\ Cases_on ‘eval (subst_funs binds y')’ \\ gvs [] + \\ ‘eval_to (x - 1) (subst_funs binds y') ≠ INL Diverge’ by gvs [] + \\ drule_then assume_tac eval_to_equals_eval \\ gvs []) \\ irule eval_to_equals_eval \\ gs []) \\ Cases_on ‘dest_Tick v’ \\ gs [] >- ( diff --git a/compiler/backend/languages/semantics/thunkLangScript.sml b/compiler/backend/languages/semantics/thunkLangScript.sml index a4fea84d..7bd355ed 100644 --- a/compiler/backend/languages/semantics/thunkLangScript.sml +++ b/compiler/backend/languages/semantics/thunkLangScript.sml @@ -179,6 +179,11 @@ Definition dest_anyThunk_def: od End +Definition is_anyThunk_def: + is_anyThunk (DoTick v) = is_anyThunk v ∧ + is_anyThunk v = ∃tv. dest_anyThunk v = INR tv +End + Definition dest_Constructor_def[simp]: dest_Constructor (Constructor s vs) = return (s, vs) ∧ dest_Constructor _ = fail Type_error @@ -283,7 +288,8 @@ Definition eval_to_def: SOME w => eval_to (k - 1) (Force (Value w)) | NONE => do (y, binds) <- dest_anyThunk v; - eval_to (k - 1) (subst_funs binds y) + res <- eval_to (k - 1) (subst_funs binds y); + if is_anyThunk res then fail Type_error else return res od od) ∧ eval_to k (MkTick x) = @@ -296,7 +302,10 @@ Definition eval_to_def: Cons s => do vs <- result_map (λx. eval_to k x) xs; - return (Constructor s vs) + if EVERY is_anyThunk vs then + return (Constructor s vs) + else + fail Type_error od | If => fail Type_error | Seq => fail Type_error @@ -470,8 +479,8 @@ Proof \\ Cases_on ‘eval_to k x’ \\ fs [] \\ BasicProvers.TOP_CASE_TAC \\ gs [] \\ Cases_on ‘dest_anyThunk y’ \\ gs [] - \\ pairarg_tac \\ gvs []) - (* \\ BasicProvers.TOP_CASE_TAC \\ gs []) *) + \\ pairarg_tac \\ gvs [] + \\ Cases_on `eval_to (k - 1) (subst_funs binds y'')` \\ gvs []) >- ((* MkTick *) rw [eval_to_def] \\ Cases_on ‘eval_to k x’ \\ fs []) @@ -495,7 +504,14 @@ Proof \\ rw [] \\ gs []) \\ fs [DECIDE “A ⇒ ¬MEM a b ⇔ MEM a b ⇒ ¬A”] \\ IF_CASES_TAC \\ gs [] - \\ rw [MAP_MAP_o, combinTheory.o_DEF, MAP_EQ_f]) + \\ rw [MAP_MAP_o, combinTheory.o_DEF, MAP_EQ_f] + \\ ( + gvs [EVERY_MAP, EXISTS_MAP, EVERY_EL, EXISTS_MEM, MEM_EL] + \\ first_x_assum drule \\ rw [] + \\ last_x_assum $ qspec_then ‘EL n xs’ assume_tac \\ gvs [] + \\ pop_assum $ drule_at Any \\ impl_tac + >- metis_tac [] + \\ rw [] \\ gvs [])) >- ((* IsEq *) gvs [LENGTH_EQ_NUM_compute] \\ rename1 ‘eval_to (k - 1) x’ diff --git a/compiler/backend/languages/semantics/thunk_semantics_delayedScript.sml b/compiler/backend/languages/semantics/thunk_semantics_delayedScript.sml new file mode 100644 index 00000000..248bdee7 --- /dev/null +++ b/compiler/backend/languages/semantics/thunk_semantics_delayedScript.sml @@ -0,0 +1,861 @@ +open HolKernel Parse boolLib bossLib BasicProvers intLib; +open stringTheory optionTheory sumTheory pairTheory listTheory rich_listTheory + alistTheory itreeTheory thunkLangTheory thunkLang_primitivesTheory + thunk_semanticsTheory; + +val _ = new_theory "thunk_semantics_delayed"; + +val _ = set_grammar_ancestry ["thunkLang", "thunk_semantics"]; + +Definition next_delayed_def: + next_delayed (k:num) sv stack (state:state) = + case sv of + INL Diverge => Div + | INL _ => Err + | INR v => + case v of + Monadic mop vs => ( + if mop = Ret ∧ LENGTH vs = 1 then + with_value (HD vs) (λv. + if ¬is_anyThunk v then Err else + case stack of + Done => Ret + | BC f fs => + if k = 0 then Div else + apply_closure f v (λw. next_delayed (k - 1) w fs state) + | HC f fs => + if k = 0 then Div else next_delayed (k - 1) sv fs state) + else if mop = Raise ∧ LENGTH vs = 1 then + with_value (HD vs) (λv. + if ¬is_anyThunk v then Err else + case stack of + Done => Ret + | BC f fs => + if k = 0 then Div else next_delayed (k - 1) sv fs state + | HC f fs => + if k = 0 then Div else + apply_closure f v (λw. next_delayed (k - 1) w fs state)) + else if mop = Bind ∧ LENGTH vs = 2 then + (let m = EL 0 vs in + let f = EL 1 vs in + if k = 0 then Div else + next_delayed (k - 1) (eval m) (BC f stack) state) + else if mop = Handle ∧ LENGTH vs = 2 then + (let m = EL 0 vs in + let f = EL 1 vs in + if k = 0 then Div else + next_delayed (k - 1) (eval m) (HC f stack) state) + else if mop = Act ∧ LENGTH vs = 1 then + (with_atoms vs (λas. + case HD as of + Msg channel content => Act (channel, content) stack state + | _ => Err)) + else if mop = Alloc ∧ LENGTH vs = 2 then + (case result_map eval vs of + INR [vl; v] => + (if ¬is_anyThunk v then Err else + (case get_atoms [vl] of + SOME [Int len] => + let n = if len < 0 then 0 else Num len in + let new_state = state ++ [REPLICATE n v] in + if k = 0 then Div else + next_delayed (k-1) + (INR $ Monadic Ret [Delay $ Lit (Loc (LENGTH state))]) + stack new_state + | _ => Err)) + | INL Diverge => Div + | _ => Err) + else if mop = Length ∧ LENGTH vs = 1 then + (with_atoms vs (λas. + case HD as of + Loc n => + (if LENGTH state ≤ n then Err else + if k = 0 then Div else + next_delayed (k-1) + (INR $ Monadic Ret [ + Delay $ Lit (Int (& (LENGTH (EL n state))))]) + stack state) + | _ => Err)) + else if mop = Deref ∧ LENGTH vs = 2 then + (with_atoms vs (λas. + case (EL 0 as, EL 1 as) of + (Loc n, Int i) => + (if LENGTH state ≤ n then Err else + if k = 0 then Div else + if 0 ≤ i ∧ i < & LENGTH (EL n state) then + next_delayed (k - 1) + (INR $ Monadic Ret [Value $ EL (Num i) (EL n state)]) + stack state + else + next_delayed (k - 1) + (INR $ Monadic Raise [Delay $ Cons "Subscript" []]) + stack state) + | _ => Err)) + else if mop = Update ∧ LENGTH vs = 3 then + (case result_map eval vs of + INR [vl; vi; v] => + (if ¬is_anyThunk v then Err else + (case get_atoms [vl; vi] of + SOME [Loc n; Int i] => + if LENGTH state ≤ n then Err else + if k = 0 then Div else + if 0 ≤ i ∧ i < & LENGTH (EL n state) then + let new_state = + LUPDATE (LUPDATE v (Num i) (EL n state)) n state + in next_delayed (k - 1) + (INR $ Monadic Ret [Delay $ Cons "" []]) + stack new_state + else + next_delayed (k - 1) + (INR $ Monadic Raise [Delay $ Cons "Subscript" []]) + stack state + | _ => Err)) + | INL Diverge => Div + | _ => Err) + else Err) + | _ => Err +End + +Definition next_action_delayed_def: + next_action_delayed sv stack state = + case some k. next_delayed k sv stack state ≠ Div of + NONE => Div + | SOME k => next_delayed k sv stack state +End + +Definition interp'_delayed_def: + interp'_delayed = + itree_unfold_err + (λ(sv,stack,state). + case next_action_delayed sv stack state of + Ret => Ret' pure_semantics$Termination + | Err => Ret' pure_semantics$Error + | Div => Div' + | Act a new_stack new_state => + Vis' a + (λy. (INR $ Monadic Ret [Delay $ Lit (Str y)], + new_stack, new_state))) + ((λ_ ret. STRLEN ret ≤ max_FFI_return_size), + pure_semantics$FinalFFI, + λs. pure_semantics$FinalFFI s pure_semantics$FFI_failure) +End + +Definition interp_delayed: + interp_delayed sv stack state = interp'_delayed (sv, stack, state) +End + +Theorem interp_delayed_def: + interp_delayed sv stack state = + case next_action_delayed sv stack state of + Ret => Ret pure_semantics$Termination + | Div => Div + | Err => Ret pure_semantics$Error + | Act a new_stack new_state => + Vis a (λs. case s of + INL x => + Ret $ pure_semantics$FinalFFI a x + | INR y => + if STRLEN y ≤ max_FFI_return_size then + interp_delayed (INR $ Monadic Ret [Delay $ Lit (Str y)]) + new_stack new_state + else Ret $ pure_semantics$FinalFFI a pure_semantics$FFI_failure) +Proof + rw [Once interp_delayed, interp'_delayed_def] + \\ once_rewrite_tac [itree_unfold_err] \\ gvs [] + \\ CASE_TAC \\ gvs [combinTheory.o_DEF, FUN_EQ_THM] \\ rw [] + \\ CASE_TAC \\ gvs [] \\ CASE_TAC \\ gvs [] + \\ rw [Once interp_delayed, interp'_delayed_def] +QED + +Definition semantics_delayed_def: + semantics_delayed e stack state = interp_delayed (eval e) stack state +End + +Definition itree_of_delayed_def: + itree_of_delayed e = semantics_delayed e Done [] +End + +Theorem next_delayed_less_eq: + ∀n e k st m. + next_delayed n e k st ≠ Div ∧ + n ≤ m ⇒ + next_delayed n e k st = next_delayed m e k st +Proof + recInduct next_delayed_ind \\ rw [] + \\ ntac 2 $ pop_assum mp_tac + \\ once_rewrite_tac [next_delayed_def] + \\ TOP_CASE_TAC \\ gvs [] \\ TOP_CASE_TAC \\ gvs [] + \\ rename1 ‘s = Ret’ + \\ Cases_on ‘s = Bind’ >- (gvs [] \\ rw []) + \\ Cases_on ‘s = Handle’ >- (gvs [] \\ rw []) + \\ Cases_on ‘s = Act’ >- (gvs [] \\ rw []) + \\ Cases_on ‘s = Raise’ \\ gvs [] + >- ( + IF_CASES_TAC \\ gvs [] \\ simp [with_value_def] + \\ ntac 3 (TOP_CASE_TAC \\ gvs []) + >- (IF_CASES_TAC \\ gvs [] \\ first_x_assum drule \\ rw []) + \\ simp [apply_closure_def, with_value_def] \\ rpt $ TOP_CASE_TAC \\ gvs [] + \\ first_x_assum drule \\ rw []) + \\ Cases_on ‘s = Ret’ \\ gvs [] + >- ( + IF_CASES_TAC \\ gvs [] \\ simp [with_value_def] + \\ ntac 3 (reverse TOP_CASE_TAC \\ gvs []) + >- (IF_CASES_TAC \\ gvs [] \\ first_x_assum drule \\ rw []) + \\ simp [apply_closure_def, with_value_def] \\ rpt $ TOP_CASE_TAC \\ gvs [] + \\ first_x_assum drule \\ rw []) + \\ Cases_on ‘s = Alloc’ \\ gvs [] + >- ( + IF_CASES_TAC \\ gvs [] \\ rw [with_atoms_def, with_value_def] + \\ rpt (TOP_CASE_TAC \\ gvs []) \\ first_x_assum drule \\ simp []) + \\ Cases_on ‘s = Length’ \\ gvs [] + >- ( + IF_CASES_TAC \\ gvs [] \\ rw [with_atoms_def] + \\ ntac 5 (TOP_CASE_TAC \\ gvs []) + \\ first_x_assum irule \\ simp [] \\ qexists_tac ‘[Loc n]’ \\ simp []) + \\ Cases_on ‘s = Deref’ \\ gvs [] + >- ( + IF_CASES_TAC \\ gvs [] \\ rw [with_atoms_def] + \\ ntac 7 (TOP_CASE_TAC \\ gvs []) + \\ first_x_assum irule \\ simp [] + \\ qexists_tac ‘[Loc n; Int i]’ \\ simp []) + \\ Cases_on ‘s = Update’ \\ gvs [] + >- ( + IF_CASES_TAC \\ gvs [] \\ rw [with_atoms_def, with_value_def] + \\ rpt (TOP_CASE_TAC \\ gvs []) + \\ first_x_assum irule \\ simp [] + \\ qexists_tac ‘[Loc n; Int i]’ \\ simp []) +QED + +Theorem next_delayed_next_delayed: + next_delayed n e k st ≠ Div ∧ next_delayed m e k st ≠ Div ⇒ + next_delayed n e k st = next_delayed m e k st +Proof + metis_tac [arithmeticTheory.LESS_EQ_CASES, next_delayed_less_eq] +QED + +Definition sim_ok_delayed_def: + sim_ok_delayed allow_error Rv Re ⇔ + (∀x y. + Re x y ∧ + (¬allow_error ⇒ eval x ≠ INL Type_error) ⇒ + ($= +++ Rv) (eval x) (eval y)) ∧ + (∀vs ws x y. + LIST_REL Rv (MAP SND vs) (MAP SND ws) ∧ + MAP FST vs = MAP FST ws ∧ + EVERY (λ(n,v). n ∈ freevars x ⇒ is_anyThunk v) vs ∧ + Re x y ⇒ + Re (subst vs x) (subst ws y)) +End + +Definition cont_rel_delayed_def[simp]: + cont_rel_delayed Re Done Done = T ∧ + cont_rel_delayed Re (BC v c) (BC w d) = (Re v w ∧ cont_rel_delayed Re c d) ∧ + cont_rel_delayed Re (HC v c) (HC w d) = (Re v w ∧ cont_rel_delayed Re c d) ∧ + cont_rel_delayed Re _ _ = F +End + +Definition state_rel_delayed_def: + state_rel_delayed Rv = + LIST_REL (LIST_REL (λv w. is_anyThunk v ∧ Rv v w)) +End + +Definition next_rel_delayed_def[simp]: + next_rel_delayed Rv Re (thunk_semantics$Act a c s) + (thunk_semantics$Act b d t) = + (a = b ∧ cont_rel_delayed Re c d ∧ state_rel_delayed Rv s t) ∧ + next_rel_delayed Rv Re Ret Ret = T ∧ + next_rel_delayed Rv Re Div Div = T ∧ + next_rel_delayed Rv Re Err Err = T ∧ + next_rel_delayed Rv Re (_: (string # string) next_res) _ = F +End + +Definition rel_ok_delayed_def: + rel_ok_delayed allow_error Rv Re ⇔ + (∀v w. Rv v w ⇒ (is_anyThunk v ⇔ is_anyThunk w)) ∧ + (∀v1 w1 v2 w2 f g. + Re v1 w1 ∧ + Rv v2 w2 ∧ + (¬allow_error ⇒ + apply_closure v1 v2 f ≠ Err ∧ + f (INL Type_error) = Err) ∧ + is_anyThunk v2 ∧ + (∀(x : err + v) y. + ($= +++ Rv) x y ∧ + (¬allow_error ⇒ f x ≠ Err) ⇒ + next_rel_delayed Rv Re (f x) (g y) + ) ⇒ + next_rel_delayed Rv Re (apply_closure v1 v2 f) + (apply_closure w1 w2 g)) ∧ + (∀s x w. + Rv (Closure s x) w ⇒ + (∃t y. w = Closure t y) ∨ (∃g m. w = Recclosure g m)) ∧ + (∀f n w. + Rv (Recclosure f n) w ⇒ + (∃g m. w = Recclosure g m) ∨ (∃t y. w = Closure t y)) ∧ + (∀s w. + Rv (Thunk s) w ⇒ (∃t. w = Thunk t) ∨ (∃v. w = DoTick v)) ∧ + (∀x w. + Rv (Atom x) w ⇒ w = Atom x) ∧ + (∀v w. + Rv (DoTick v) w ⇒ + ¬allow_error ∨ + (∃u. w = DoTick u)) ∧ + (∀s vs w. + Rv (Constructor s vs) w ⇒ ∃ws. w = Constructor s ws ∧ + LIST_REL Rv vs ws) ∧ + (∀s x y. + x = y ⇒ Rv (Monadic s [Delay $ Lit x]) + (Monadic s [Delay $ Lit y])) ∧ + (∀s t. + Rv (Monadic s [Delay $ Cons t []]) + (Monadic s [Delay $ Cons t []])) ∧ + (∀s x y. + Rv x y ∧ + is_anyThunk x ⇒ + Rv (Monadic s [Value x]) + (Monadic s [Value y])) ∧ + (∀mop vs w. + Rv (Monadic mop vs) w ⇒ + (∃ws. w = Monadic mop ws ∧ + LIST_REL Re vs ws)) +End + +Theorem rel_ok_delayed_get_atoms: + ∀x y. + rel_ok_delayed ae Rv Re ∧ + LIST_REL Rv x y ∧ + (∀z. MEM z x ⇒ ∀w. z ≠ DoTick w) ⇒ + get_atoms x = get_atoms y +Proof + ho_match_mp_tac get_atoms_ind \\ rw [] \\ fs [rel_ok_delayed_def] \\ gvs [] + >~ [ ‘get_atoms (DoTick _::_)’] >- ( + gvs [LIST_REL_EL_EQN, MEM_EL, PULL_EXISTS, SF DNF_ss]) + \\ qpat_x_assum ‘∀v w. Rv v w ⇒ (is_anyThunk v ⇔ is_anyThunk w)’ kall_tac + \\ rpt (first_x_assum (drule_then assume_tac)) \\ gvs [get_atoms_def] + \\ metis_tac [] +QED + +Theorem sim_ok_delayed_next_delayed: + ∀k v c s w d t. + rel_ok_delayed allow_error Rv Re ∧ + sim_ok_delayed allow_error Rv Re ∧ + ($= +++ Rv) v w ∧ + cont_rel_delayed Re c d ∧ + state_rel_delayed Rv s t ∧ + (¬allow_error ⇒ next_delayed k v c s ≠ Err) ⇒ + next_rel_delayed Rv Re (next_delayed k v c s) (next_delayed k w d t) +Proof + ho_match_mp_tac next_delayed_ind \\ rw [] + \\ qpat_x_assum ‘(_ +++ _) _ _’ mp_tac + \\ Cases_on ‘v’ \\ Cases_on ‘w’ \\ simp [] + >- ( + rw [next_delayed_def] + \\ CASE_TAC \\ simp []) + \\ rename1 ‘Rv v w’ + \\ Cases_on ‘(∃s x. v = Closure s x) ∨ + (∃f n. v = Recclosure f n) ∨ + (∃x. v = Thunk x) ∨ (∃x. v = Atom x) ∨ + (∃nm vs. v = Constructor nm vs)’ + >- ( + qpat_x_assum ‘rel_ok_delayed _ _ _’ mp_tac \\ rw [rel_ok_delayed_def] + \\ rpt (first_x_assum (drule_all_then assume_tac)) \\ rw [] \\ fs [] + \\ simp [next_delayed_def]) + \\ Cases_on ‘∃x. v = DoTick x’ + >- ( + qpat_x_assum ‘rel_ok_delayed _ _ _’ mp_tac \\ rw [rel_ok_delayed_def] + \\ gvs [Once next_delayed_def] + \\ rpt (first_x_assum (drule_all_then assume_tac)) \\ rw [] \\ fs [] + \\ simp [Once next_delayed_def] \\ simp [Once next_delayed_def]) + \\ rfs [] + \\ ‘∃mop vs. v = Monadic mop vs’ by ( + ntac 5 (pop_assum mp_tac) \\ Cases_on ‘v’ \\ simp [] \\ fs []) + \\ rw [] + \\ ‘∃ws. w = Monadic mop ws ∧ LIST_REL Re vs ws’ + by (qpat_x_assum ‘Rv _ _’ mp_tac + \\ qpat_x_assum ‘rel_ok_delayed _ _ _’ mp_tac + \\ rw [rel_ok_delayed_def] + \\ rpt (first_x_assum drule) \\ rw []) + \\ rw [] + \\ drule_then assume_tac LIST_REL_LENGTH + \\ once_rewrite_tac [next_delayed_def] \\ simp [] + \\ IF_CASES_TAC \\ simp [] + >- ((* Ret *) + gvs [LENGTH_EQ_NUM_compute] \\ simp [with_value_def] \\ rename1 ‘Re v w’ + \\ ‘($= +++ Rv) (eval v) (eval w)’ by ( + fs [rel_ok_delayed_def] \\ first_x_assum drule \\ rw [] + \\ gvs [sim_ok_delayed_def] \\ first_x_assum irule \\ simp [] + \\ rw [] \\ CCONTR_TAC \\ fs [Once next_delayed_def, with_value_def]) + \\ Cases_on ‘eval v’ \\ Cases_on ‘eval w’ \\ gvs [] >- (CASE_TAC \\ gvs []) + \\ ‘is_anyThunk y ⇔ is_anyThunk y'’ by gvs [rel_ok_delayed_def] + \\ IF_CASES_TAC \\ gvs [] + \\ rw [] \\ reverse $ Cases_on ‘c’ \\ Cases_on ‘d’ \\ gvs [] \\ rw [] + >- ( + first_x_assum irule \\ rw [SF SFY_ss] + \\ gvs [Once next_delayed_def, with_value_def]) + \\ fs [rel_ok_delayed_def] + \\ first_x_assum irule \\ rw [] \\ gvs [] + >- (first_x_assum drule \\ rw []) + \\ fs [Once next_delayed_def, with_value_def]) + \\ IF_CASES_TAC + >- ((* Raise *) + gvs [LENGTH_EQ_NUM_compute] \\ simp [with_value_def] \\ rename1 ‘Re v w’ + \\ ‘($= +++ Rv) (eval v) (eval w)’ by ( + fs [rel_ok_delayed_def] \\ first_x_assum drule \\ rw [] + \\ gvs [sim_ok_delayed_def] \\ first_x_assum irule \\ simp [] + \\ rw [] \\ CCONTR_TAC \\ fs [Once next_delayed_def, with_value_def]) + \\ Cases_on ‘eval v’ \\ Cases_on ‘eval w’ \\ gvs [] >- (CASE_TAC \\ gvs []) + \\ ‘is_anyThunk y ⇔ is_anyThunk y'’ by gvs [rel_ok_delayed_def] + \\ rw [] \\ Cases_on ‘c’ \\ Cases_on ‘d’ \\ gvs [] \\ rw [] + >- (first_x_assum irule \\ rw [SF SFY_ss] + \\ gvs [Once next_delayed_def, with_value_def]) + \\ fs [rel_ok_delayed_def] + \\ first_x_assum irule \\ rw [] \\ gvs [] + >- (first_x_assum drule \\ rw []) + \\ fs [Once next_delayed_def, with_value_def]) + \\ IF_CASES_TAC + >- ((* Bind *) + rw [] + \\ gvs [LIST_REL_EL_EQN, LENGTH_EQ_NUM_compute, + DECIDE “∀x. x < 2 ⇔ x = 0 ∨ x = 1”] + \\ fs [SF DNF_ss] + \\ first_x_assum irule \\ rw [] + \\ fs [Once next_delayed_def] + \\ fs [sim_ok_delayed_def] + \\ first_x_assum irule \\ simp [] + \\ fs [rel_ok_delayed_def] \\ first_x_assum drule \\ rw [] + \\ fs [Once next_delayed_def] + \\ Cases_on ‘eval h’ \\ gvs [] \\ Cases_on ‘x’ \\ gvs []) + \\ IF_CASES_TAC + >- ((* Handle *) + rw [] + \\ gvs [LIST_REL_EL_EQN, LENGTH_EQ_NUM_compute, + DECIDE “∀x. x < 2 ⇔ x = 0 ∨ x = 1”] + \\ fs [SF DNF_ss] + \\ first_x_assum irule \\ rw [] + \\ fs [Once next_delayed_def] + \\ fs [sim_ok_delayed_def] + \\ first_x_assum irule \\ simp [] + \\ fs [rel_ok_delayed_def] \\ first_x_assum drule \\ rw [] + \\ fs [Once next_delayed_def] + \\ Cases_on ‘eval h’ \\ gvs [] \\ Cases_on ‘x’ \\ gvs []) + \\ IF_CASES_TAC + >- ((* Act *) + rw [] \\ gvs [] + \\ gvs [LIST_REL_EL_EQN, LENGTH_EQ_NUM_compute, DECIDE “∀x. x < 1 ⇔ x = 0”] + \\ rename1 ‘Re v w’ + \\ simp [with_atoms_def, result_map_def] + \\ ‘¬allow_error ⇒ eval v ≠ INL Type_error’ + by (rpt strip_tac \\ gvs [] + \\ gvs [Once next_delayed_def, with_atoms_def, result_map_def]) + \\ ‘($= +++ Rv) (eval v) (eval w)’ by ( + gvs [sim_ok_delayed_def] \\ first_x_assum irule + \\ fs [rel_ok_delayed_def] \\ first_x_assum drule \\ simp []) + \\ Cases_on ‘eval v’ \\ Cases_on ‘eval w’ \\ gvs [] + >~ [‘eval _ = INL err’] >- (Cases_on ‘err’ \\ fs []) + \\ rename1 ‘eval v = INR a’ \\ rename1 ‘eval w = INR b’ + \\ ‘¬allow_error ⇒ get_atoms [a] ≠ NONE’ by ( + rpt strip_tac + \\ gvs [Once next_delayed_def, with_atoms_def, result_map_def]) + \\ ‘∀x. a = Atom x ⇒ a = b’ by (rpt strip_tac \\ gvs [rel_ok_delayed_def]) + \\ reverse (Cases_on ‘∃x. a = Atom x’) \\ gvs [get_atoms_def] >- ( + ‘get_atoms [a] = NONE’ by (Cases_on ‘a’ \\ fs [get_atoms_def]) + \\ simp [] + \\ Cases_on ‘b’ \\ gvs [get_atoms_def] + \\ Cases_on ‘a’ \\ fs [get_atoms_def, rel_ok_delayed_def] + \\ rpt (first_x_assum (drule_then assume_tac)) \\ rw []) + \\ CASE_TAC \\ fs []) + \\ IF_CASES_TAC + >- ((* Alloc *) + rw [] \\ gvs [] + \\ gvs [LIST_REL_EL_EQN, LENGTH_EQ_NUM_compute, + DECIDE “∀x. x < 2 ⇔ x = 0 ∨ x = 1”] + \\ gvs [SF DNF_ss] + \\ rename1 ‘Rv (_ _ [v1; v2]) (_ _ [w1; w2])’ + \\ gvs [with_atoms_def, result_map_def] + \\ ‘¬allow_error ⇒ eval v1 ≠ INL Type_error ∧ eval v2 ≠ INL Type_error’ + by (rpt strip_tac \\ gvs [] + \\ gvs [Once next_delayed_def, with_atoms_def, result_map_def]) + \\ ‘($= +++ Rv) (eval v1) (eval w1)’ by ( + gvs [sim_ok_delayed_def] \\ first_x_assum irule + \\ fs [rel_ok_delayed_def] \\ first_x_assum drule \\ simp []) + \\ ‘($= +++ Rv) (eval v2) (eval w2)’ by ( + gvs [sim_ok_delayed_def] \\ first_x_assum irule + \\ fs [rel_ok_delayed_def] \\ first_x_assum rev_drule \\ simp []) + \\ ‘∀err. eval v1 = INL err ⇔ eval w1 = INL err’ by ( + Cases_on ‘eval v1’ \\ Cases_on ‘eval w1’ \\ gvs []) + \\ ‘∀err. eval v2 = INL err ⇔ eval w2 = INL err’ by ( + Cases_on ‘eval v2’ \\ Cases_on ‘eval w2’ \\ gvs []) + \\ IF_CASES_TAC \\ gvs [] \\ IF_CASES_TAC \\ gvs [] + \\ Cases_on ‘eval v1’ \\ gvs [] + >~ [‘eval _ = INL err’] >- (Cases_on ‘err’ \\ gvs [SF DNF_ss, EQ_IMP_THM]) + \\ Cases_on ‘eval v2’ \\ gvs [] + >~ [‘eval _ = INL err’] >- (Cases_on ‘err’ \\ gvs [SF DNF_ss, EQ_IMP_THM]) + \\ Cases_on ‘eval w1’ \\ gvs [] \\ Cases_on ‘eval w2’ \\ gvs [] + \\ rename1 ‘eval v1 = INR a’ \\ rename1 ‘eval w1 = INR b’ + \\ ‘is_anyThunk y' ⇔ is_anyThunk y'3'’ by gvs [rel_ok_delayed_def] + \\ ‘¬allow_error ⇒ get_atoms [a] ≠ NONE’ by ( + rpt strip_tac + \\ gvs [Once next_delayed_def, with_atoms_def, result_map_def]) + \\ ‘∀x. a = Atom x ⇒ a = b’ by (rpt strip_tac \\ gvs [rel_ok_delayed_def]) + \\ reverse (Cases_on ‘∃x. a = Atom x’) \\ gvs [get_atoms_def] + >- ( + ‘get_atoms [a] = NONE’ by (Cases_on ‘a’ \\ fs [get_atoms_def]) + \\ simp [] + \\ Cases_on ‘b’ \\ gvs [get_atoms_def] + \\ Cases_on ‘a’ \\ fs [get_atoms_def, rel_ok_delayed_def] + \\ rpt (first_x_assum (drule_then assume_tac)) \\ rw []) + \\ IF_CASES_TAC \\ gvs [] + \\ BasicProvers.TOP_CASE_TAC \\ gvs [] + \\ BasicProvers.TOP_CASE_TAC \\ gvs [] + \\ first_x_assum irule + \\ gvs [state_rel_delayed_def, LIST_REL_REPLICATE_same, LIST_REL_EL_EQN, + rel_ok_delayed_def] + \\ rw [] \\ gvs [] + \\ qpat_x_assum ‘next_delayed _ _ _ _ ≠ _’ mp_tac + \\ simp [Once next_delayed_def, with_atoms_def, result_map_def, + get_atoms_def, with_value_def]) + \\ IF_CASES_TAC + >- ((* Length *) + rw [] \\ gvs [] + \\ gvs [LIST_REL_EL_EQN, LENGTH_EQ_NUM_compute, DECIDE “∀x. x < 1 ⇔ x = 0”] + \\ rename1 ‘Re v w’ + \\ simp [with_atoms_def, result_map_def] + \\ ‘¬allow_error ⇒ eval v ≠ INL Type_error’ by ( + rpt strip_tac \\ gvs [] + \\ gvs [Once next_delayed_def, with_atoms_def, result_map_def]) + \\ ‘($= +++ Rv) (eval v) (eval w)’ by ( + gvs [sim_ok_delayed_def] \\ first_x_assum irule + \\ fs [rel_ok_delayed_def] \\ first_x_assum drule \\ simp []) + \\ Cases_on ‘eval v’ \\ Cases_on ‘eval w’ \\ gvs [] + >~ [‘eval _ = INL err’] >- (Cases_on ‘err’ \\ gvs []) + \\ rename1 ‘eval v = INR a’ \\ rename1 ‘eval w = INR b’ + \\ ‘¬allow_error ⇒ get_atoms [a] ≠ NONE’ by ( + rpt strip_tac + \\ gvs [Once next_delayed_def, with_atoms_def, result_map_def]) + \\ ‘∀x. a = Atom x ⇒ a = b’ by (rpt strip_tac \\ gvs [rel_ok_delayed_def]) + \\ reverse (Cases_on ‘∃x. a = Atom x’) \\ gvs [get_atoms_def] + >- ( + ‘get_atoms [a] = NONE’ by (Cases_on ‘a’ \\ fs [get_atoms_def]) + \\ simp [] + \\ Cases_on ‘b’ \\ gvs [get_atoms_def] + \\ Cases_on ‘a’ \\ fs [get_atoms_def, rel_ok_delayed_def] + \\ rpt (first_x_assum (drule_then assume_tac)) \\ rw []) + \\ ‘LENGTH s = LENGTH t’ by gvs [state_rel_delayed_def, LIST_REL_EL_EQN] + \\ Cases_on ‘k = 0’ \\ fs [] \\ CASE_TAC \\ fs [] + \\ IF_CASES_TAC \\ gvs [] + \\ first_x_assum (resolve_then Any irule HD) \\ simp [] + \\ gvs [state_rel_delayed_def, LIST_REL_REPLICATE_same, LIST_REL_EL_EQN, + rel_ok_delayed_def] + \\ strip_tac + \\ gvs [Once next_delayed_def, + with_atoms_def, result_map_def, get_atoms_def]) + \\ IF_CASES_TAC + >- ((* Deref *) + rw [] \\ gvs [] + \\ gvs [LIST_REL_EL_EQN, LENGTH_EQ_NUM_compute, + DECIDE “∀x. x < 2 ⇔ x = 0 ∨ x = 1”] + \\ gvs [SF DNF_ss] + \\ rename1 ‘Rv (_ _ [v1; v2]) (_ _ [w1; w2])’ + \\ simp [with_atoms_def, result_map_def] + \\ ‘¬allow_error ⇒ eval v1 ≠ INL Type_error’ by ( + rpt strip_tac \\ gvs [] + \\ gvs [Once next_delayed_def, with_atoms_def, result_map_def]) + \\ ‘¬allow_error ⇒ eval v2 ≠ INL Type_error’ by ( + rpt strip_tac \\ gvs [] + \\ gvs [Once next_delayed_def, with_atoms_def, result_map_def]) + \\ ‘($= +++ Rv) (eval v1) (eval w1)’ by ( + gvs [sim_ok_delayed_def] \\ first_x_assum irule + \\ fs [rel_ok_delayed_def] \\ first_x_assum drule \\ simp []) + \\ ‘($= +++ Rv) (eval v2) (eval w2)’ by ( + gvs [sim_ok_delayed_def] \\ first_x_assum irule + \\ fs [rel_ok_delayed_def] \\ first_x_assum drule \\ simp []) + \\ Cases_on ‘eval v1’ \\ Cases_on ‘eval w1’ \\ gvs [] + >~ [‘eval _ = INL err’] >- ( + Cases_on ‘err = Type_error’ \\ fs [] + \\ Cases_on ‘eval v2’ \\ Cases_on ‘eval w2’ \\ gvs [] + >~ [‘eval _ = INL err’] >- (Cases_on ‘err’ \\ fs []) + \\ Cases_on ‘err’ \\ fs []) + \\ Cases_on ‘eval v2’ \\ Cases_on ‘eval w2’ \\ gvs [] + >~ [‘eval _ = INL err’] >- (Cases_on ‘err’ \\ fs []) + \\ rename1 ‘eval v1 = INR a1’ \\ rename1 ‘eval w1 = INR b1’ + \\ rename1 ‘eval v2 = INR a2’ \\ rename1 ‘eval w2 = INR b2’ + \\ ‘¬allow_error ⇒ get_atoms [a1; a2] ≠ NONE’ by ( + rpt strip_tac + \\ gvs [Once next_delayed_def, with_atoms_def, result_map_def]) + \\ ‘∀x. a1 = Atom x ⇒ a1 = b1’ by ( + rpt strip_tac \\ gvs [rel_ok_delayed_def]) + \\ ‘∀x. a2 = Atom x ⇒ a2 = b2’ by ( + rpt strip_tac \\ gvs [rel_ok_delayed_def]) + \\ reverse (Cases_on ‘∃x. a1 = Atom x’) \\ fs [] + >- ( + Cases_on ‘∃y. b1 = Atom y’ \\ fs [] + >- ( + rw [] \\ fs [rel_ok_delayed_def] + \\ qpat_x_assum ‘Rv a1 b1’ assume_tac + \\ Cases_on ‘a1’ \\ fs [] + \\ rpt (first_x_assum (drule_then assume_tac)) \\ rw [] + \\ fs [get_atoms_def]) + \\ ‘get_atoms [a1; a2] = NONE’ by (Cases_on ‘a1’ \\ fs [get_atoms_def]) + \\ ‘get_atoms [b1; b2] = NONE’ by (Cases_on ‘b1’ \\ fs [get_atoms_def]) + \\ simp []) + \\ reverse (Cases_on ‘∃x. a2 = Atom x’) \\ fs [] + >- ( + Cases_on ‘∃y. b2 = Atom y’ \\ fs [] + >- ( + rw [] \\ fs [rel_ok_delayed_def] + \\ qpat_x_assum ‘Rv a2 b2’ assume_tac + \\ Cases_on ‘a2’ \\ fs [] + \\ rpt (first_x_assum (drule_then assume_tac)) \\ rw [] + \\ fs [get_atoms_def]) + \\ rw [] + \\ ‘get_atoms [a2] = NONE’ by (Cases_on ‘a2’ \\ fs [get_atoms_def]) + \\ ‘get_atoms [b2] = NONE’ by (Cases_on ‘b2’ \\ fs [get_atoms_def]) + \\ gvs [] \\ simp [get_atoms_def]) + \\ rw [] \\ simp [get_atoms_def] + \\ BasicProvers.TOP_CASE_TAC \\ fs [] + \\ BasicProvers.TOP_CASE_TAC \\ fs [] + \\ ‘LENGTH s = LENGTH t’ by fs [state_rel_delayed_def, LIST_REL_EL_EQN] + \\ IF_CASES_TAC \\ fs [] + \\ IF_CASES_TAC \\ fs [] + \\ qpat_x_assum ‘¬_ ⇒ next_delayed _ _ _ _ ≠ _’ mp_tac + \\ simp [Once next_delayed_def, with_atoms_def, result_map_def, + get_atoms_def] + \\ strip_tac + \\ ‘LENGTH (EL n t) = LENGTH (EL n s)’ + by gvs [state_rel_delayed_def, LIST_REL_EL_EQN] + \\ rpt (first_x_assum (resolve_then Any assume_tac HD) \\ fs []) + \\ IF_CASES_TAC \\ fs [] + >- ( + first_x_assum irule \\ gvs [SF SFY_ss] + \\ fs [rel_ok_delayed_def] + \\ first_x_assum irule + \\ qpat_x_assum ‘state_rel_delayed _ _ _’ mp_tac + \\ rw [state_rel_delayed_def] + \\ fs [Once LIST_REL_EL_EQN] + \\ first_x_assum (qspec_then ‘n’ assume_tac) \\ gvs [LIST_REL_EL_EQN] + \\ first_x_assum $ qspec_then ‘Num i’ assume_tac \\ gvs [] + \\ imp_res_tac integerTheory.NUM_POSINT_EXISTS \\ gvs []) + \\ first_x_assum irule \\ gvs [SF SFY_ss] + \\ fs [rel_ok_delayed_def] \\ intLib.COOPER_TAC) + \\ IF_CASES_TAC + >- ((* Update *) + rw [] \\ gvs [] + \\ gvs [LIST_REL_EL_EQN, LENGTH_EQ_NUM_compute, + DECIDE “∀x. x < 3 ⇔ x = 0 ∨ x = 1 ∨ x = 2”] + \\ gvs [SF DNF_ss] + \\ rename1 ‘Rv (_ _ [v1; v2; v3]) (_ _ [w1; w2; w3])’ + \\ simp [with_atoms_def, result_map_def] + \\ ‘¬allow_error ⇒ eval v1 ≠ INL Type_error ∧ + eval v2 ≠ INL Type_error ∧eval v3 ≠ INL Type_error’ by ( + rpt strip_tac \\ gvs [] + \\ gvs [Once next_delayed_def, with_atoms_def, result_map_def]) + \\ ‘($= +++ Rv) (eval v1) (eval w1)’ by ( + gvs [sim_ok_delayed_def] \\ first_x_assum irule + \\ fs [rel_ok_delayed_def] \\ first_x_assum drule \\ simp []) + \\ ‘($= +++ Rv) (eval v2) (eval w2)’ by ( + gvs [sim_ok_delayed_def] \\ first_x_assum irule + \\ fs [rel_ok_delayed_def] \\ first_x_assum rev_drule \\ simp []) + \\ ‘($= +++ Rv) (eval v3) (eval w3)’ by ( + gvs [sim_ok_delayed_def] \\ first_x_assum irule + \\ fs [rel_ok_delayed_def] \\ first_x_assum rev_drule \\ simp []) + \\ ‘∀err. eval v1 = INL err ⇔ eval w1 = INL err’ by ( + Cases_on ‘eval v1’ \\ Cases_on ‘eval w1’ \\ gvs []) + \\ ‘∀err. eval v2 = INL err ⇔ eval w2 = INL err’ by ( + Cases_on ‘eval v2’ \\ Cases_on ‘eval w2’ \\ gvs []) + \\ ‘∀err. eval v3 = INL err ⇔ eval w3 = INL err’ by ( + Cases_on ‘eval v3’ \\ Cases_on ‘eval w3’ \\ gvs []) + \\ IF_CASES_TAC \\ gvs [] \\ IF_CASES_TAC \\ gvs [] + \\ Cases_on ‘eval v1’ \\ gvs [] + >~ [‘eval _ = INL err’] >- (Cases_on ‘err’ \\ gvs [EQ_IMP_THM, SF DNF_ss]) + \\ Cases_on ‘eval v2’ \\ gvs [] + >~ [‘eval _ = INL err’] >- (Cases_on ‘err’ \\ gvs [EQ_IMP_THM, SF DNF_ss]) + \\ Cases_on ‘eval v3’ \\ gvs [] + >~ [‘eval _ = INL err’] >- (Cases_on ‘err’ \\ gvs [EQ_IMP_THM, SF DNF_ss]) + \\ Cases_on ‘eval w1’ \\ gvs [] \\ Cases_on ‘eval w2’ \\ gvs [] + \\ Cases_on ‘eval w3’ \\ gvs [] + \\ rename1 ‘eval v1 = INR a1’ \\ rename1 ‘eval w1 = INR b1’ + \\ rename1 ‘eval v2 = INR a2’ \\ rename1 ‘eval w2 = INR b2’ + \\ ‘is_anyThunk y'' ⇔ is_anyThunk y'5'’ by gvs [rel_ok_delayed_def] + \\ ‘¬allow_error ⇒ get_atoms [a1; a2] ≠ NONE’ by ( + rpt strip_tac + \\ gvs [Once next_delayed_def, with_atoms_def, result_map_def]) + \\ ‘∀x. a1 = Atom x ⇒ a1 = b1’ by ( + rpt strip_tac \\ gvs [rel_ok_delayed_def]) + \\ ‘∀x. a2 = Atom x ⇒ a2 = b2’ by ( + rpt strip_tac \\ gvs [rel_ok_delayed_def]) + \\ reverse (Cases_on ‘∃x. a1 = Atom x’) \\ fs [] + >- ( + Cases_on ‘∃y. b1 = Atom y’ \\ fs [] + >- ( + rw [] \\ fs [rel_ok_delayed_def] + \\ qpat_x_assum ‘Rv a1 b1’ assume_tac + \\ Cases_on ‘a1’ \\ fs [] + \\ rpt (first_x_assum (drule_then assume_tac)) \\ rw [] + \\ fs [get_atoms_def]) + \\ ‘get_atoms [a1; a2] = NONE’ by (Cases_on ‘a1’ \\ fs [get_atoms_def]) + \\ ‘get_atoms [b1; b2] = NONE’ by (Cases_on ‘b1’ \\ fs [get_atoms_def]) + \\ simp []) + \\ reverse (Cases_on ‘∃x. a2 = Atom x’) \\ fs [] + >- ( + Cases_on ‘∃y. b2 = Atom y’ \\ fs [] + >- ( + rw [] \\ fs [rel_ok_delayed_def] + \\ qpat_x_assum ‘Rv a2 b2’ assume_tac + \\ Cases_on ‘a2’ \\ fs [] + \\ rpt (first_x_assum (drule_then assume_tac)) \\ rw [] + \\ fs [get_atoms_def]) + \\ rw [] + \\ ‘get_atoms [a2] = NONE’ by (Cases_on ‘a2’ \\ fs [get_atoms_def]) + \\ ‘get_atoms [b2] = NONE’ by (Cases_on ‘b2’ \\ fs [get_atoms_def]) + \\ gvs [] \\ simp [get_atoms_def]) + \\ rw [] \\ simp [get_atoms_def] + \\ BasicProvers.TOP_CASE_TAC \\ fs [] + \\ BasicProvers.TOP_CASE_TAC \\ fs [] + \\ ‘LENGTH s = LENGTH t’ by fs [state_rel_delayed_def, LIST_REL_EL_EQN] + \\ IF_CASES_TAC \\ fs [] + \\ IF_CASES_TAC \\ fs [] + \\ qpat_x_assum ‘¬_ ⇒ next_delayed _ _ _ _ ≠ _’ mp_tac + \\ simp [Once next_delayed_def, with_value_def, + with_atoms_def, result_map_def, get_atoms_def] + \\ fs [result_map_def, get_atoms_def] + \\ strip_tac + \\ ‘LENGTH (EL n t) = LENGTH (EL n s)’ + by gvs [state_rel_delayed_def, LIST_REL_EL_EQN] + \\ IF_CASES_TAC \\ fs [] + >- ( + first_x_assum irule \\ simp [result_map_def, get_atoms_def] + \\ gvs [state_rel_delayed_def, LIST_REL_EL_EQN, EL_LUPDATE] + \\ rw [] \\ gvs [] + \\ rw [EL_LUPDATE] \\ fs [rel_ok_delayed_def]) + >- (last_x_assum irule \\ fs [rel_ok_delayed_def]) + >- (first_x_assum irule \\ fs [rel_ok_delayed_def])) + \\ fs [] +QED + +Theorem sim_ok_delayed_next_action_delayed: + rel_ok_delayed allow_error Rv Re ∧ + sim_ok_delayed allow_error Rv Re ∧ + ($= +++ Rv) v w ∧ + cont_rel_delayed Re c d ∧ + state_rel_delayed Rv s t ∧ + (¬allow_error ⇒ next_action_delayed v c s ≠ Err) ⇒ + next_rel_delayed Rv Re (next_action_delayed v c s) + (next_action_delayed w d t) +Proof + strip_tac + \\ rw [next_action_delayed_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [] + \\ DEEP_INTRO_TAC some_intro \\ simp [] + \\ simp [PULL_FORALL] + \\ qx_gen_tac ‘i’ + \\ qx_gen_tac ‘j’ + \\ qx_gen_tac ‘k’ + \\ ‘∀m. ¬allow_error ⇒ next_delayed m v c s ≠ Err’ by ( + rpt strip_tac \\ gvs [] + \\ gvs [next_action_delayed_def] + \\ qpat_x_assum ‘_ ≠ Err’ mp_tac + \\ DEEP_INTRO_TAC some_intro \\ simp [] + \\ simp [PULL_EXISTS] + \\ qexists_tac ‘m’ \\ gvs [] + \\ rw [] + \\ drule_then (qspec_then ‘m’ assume_tac) next_delayed_next_delayed + \\ gvs []) + \\ rw [] + >- ( + first_x_assum (qspec_then ‘i’ assume_tac) + \\ drule_all_then assume_tac sim_ok_delayed_next_delayed \\ gvs [] + \\ drule_then (qspec_then ‘i’ mp_tac) next_delayed_next_delayed + \\ impl_tac \\ rw [] + \\ strip_tac + \\ Cases_on ‘next_delayed i w d t’ \\ gvs []) + >- ( + last_x_assum (qspec_then ‘i’ assume_tac) + \\ drule_all_then assume_tac sim_ok_delayed_next_delayed \\ gvs [SF SFY_ss]) + \\ last_x_assum (qspec_then ‘k’ assume_tac) + \\ drule_all_then assume_tac sim_ok_delayed_next_delayed \\ gvs [SF SFY_ss] +QED + +Theorem sim_ok_delayed_interp_delayed: + rel_ok_delayed allow_error Rv Re ∧ + sim_ok_delayed allow_error Rv Re ∧ + ($= +++ Rv) v w ∧ + cont_rel_delayed Re c d ∧ + state_rel_delayed Rv s t ∧ + (¬allow_error ⇒ pure_semantics$safe_itree (interp_delayed v c s)) ⇒ + interp_delayed v c s = interp_delayed w d t +Proof + strip_tac + \\ rw [Once itreeTheory.itree_bisimulation] + \\ qexists + ‘λt1 t2. + (¬allow_error ⇒ pure_semantics$safe_itree t1) ∧ + (t1 = t2 ∨ + ∃v c s w d t. + interp_delayed v c s = t1 ∧ + interp_delayed w d t = t2 ∧ + ($= +++ Rv) v w ∧ + cont_rel_delayed Re c d ∧ + state_rel_delayed Rv s t)’ + \\ rw [] + >~ [‘Vis a f’] >- ( + rgs [Once pure_semanticsTheory.safe_itree_cases]) + >~ [‘interp_delayed v c s = interp_delayed w d t’] >- ( + disj2_tac \\ rpt $ irule_at Any EQ_REFL \\ simp []) + \\ ‘¬allow_error ⇒ next_action_delayed v' c' s' ≠ Err’ by ( + rpt strip_tac \\ gvs [] + \\ rgs [Once interp_delayed_def, + Once pure_semanticsTheory.safe_itree_cases]) + \\ drule_all sim_ok_delayed_next_action_delayed \\ strip_tac + >- ( + qpat_x_assum ‘_ = Ret _’ mp_tac + \\ once_rewrite_tac [interp_delayed_def] + \\ Cases_on ‘next_action_delayed v' c' s'’ + \\ Cases_on ‘next_action_delayed w' d' t''’ \\ gvs []) + >- ( + qpat_x_assum ‘_ = Div’ mp_tac + \\ once_rewrite_tac[interp_delayed_def] + \\ Cases_on ‘next_action_delayed v' c' s'’ + \\ Cases_on ‘next_action_delayed w' d' t''’ + \\ gvs []) + >- ( + qpat_x_assum ‘_ = Vis _ _ ’ mp_tac + \\ rw [Once interp_delayed_def] + \\ rw [Once interp_delayed_def] + \\ Cases_on ‘next_action_delayed v' c' s'’ + \\ Cases_on ‘next_action_delayed w' d' t''’ \\ gvs [] + \\ rw [] \\ rgs [Once pure_semanticsTheory.safe_itree_cases] + \\ CASE_TAC \\ gvs [] \\ CASE_TAC \\ gvs [] + \\ disj2_tac + \\ rpt (irule_at Any EQ_REFL) \\ simp [] + \\ gvs [rel_ok_delayed_def]) +QED + +Theorem semantics_delayed_fail: + pure_semantics$safe_itree (semantics_delayed x c s) ⇒ + eval x ≠ INL Type_error +Proof + simp [semantics_delayed_def, Once interp_delayed_def, next_action_delayed_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [] + \\ rw [] \\ strip_tac \\ gvs [] + \\ rgs [Once next_delayed_def] + \\ rgs [Once pure_semanticsTheory.safe_itree_cases] +QED + +Theorem sim_ok_delayed_semantics_delayed: + rel_ok_delayed allow_error Rv Re ∧ + sim_ok_delayed allow_error Rv Re ∧ + Re x y ∧ + (¬allow_error ⇒ pure_semantics$safe_itree (semantics_delayed x Done [])) ⇒ + semantics_delayed x Done [] = semantics_delayed y Done [] +Proof + strip_tac + \\ rw [semantics_delayed_def] + \\ irule sim_ok_delayed_interp_delayed + \\ qpat_assum ‘sim_ok_delayed _ _ _’ (irule_at Any) + \\ gvs [cont_rel_delayed_def, state_rel_delayed_def, sim_ok_delayed_def] + \\ first_assum (irule_at Any) \\ gvs [] + \\ rw [] \\ gvs [semantics_delayed_fail, SF SFY_ss] + \\ gvs [semantics_delayed_def] +QED + +val _ = export_theory(); diff --git a/compiler/backend/languages/state_cexpScript.sml b/compiler/backend/languages/state_cexpScript.sml index fd731cec..c9530f6f 100644 --- a/compiler/backend/languages/state_cexpScript.sml +++ b/compiler/backend/languages/state_cexpScript.sml @@ -13,18 +13,22 @@ val _ = numLib.prefer_num(); Type vname = “:mlstring” +Datatype: + cthunk_mode = Evaluated | NotEvaluated +End + Datatype: csop = (* Primitive operations *) | AppOp (* function application *) | Cons mlstring (* datatype constructor *) | AtomOp atom_op (* primitive parametric operator over Atoms *) | Alloc (* allocate an array *) - | Ref (* allocates an array in a different way *) | Length (* query the length of an array *) | Sub (* de-reference a value in an array *) - | UnsafeSub (* de-reference but without a bounds check *) | Update (* update a value in an array *) - | UnsafeUpdate (* update without a bounds check *) + | AllocMutThunk cthunk_mode (* allocate a mutable thunk *) + | UpdateMutThunk cthunk_mode (* update and unevaluated thunk *) + | ForceMutThunk (* force a mutable thunk *) | FFI mlstring (* make an FFI call *) End diff --git a/compiler/backend/passes/env_to_stateScript.sml b/compiler/backend/passes/env_to_stateScript.sml index 42d6b302..145110a2 100644 --- a/compiler/backend/passes/env_to_stateScript.sml +++ b/compiler/backend/passes/env_to_stateScript.sml @@ -30,19 +30,18 @@ Definition Letrec_split_def: | NONE => (xs,ys) End -Definition Bool_def[simp]: - Bool T = (True :state_cexp$cexp) ∧ - Bool F = (False :state_cexp$cexp) +Definition some_alloc_thunk_def: + some_alloc_thunk (v:mlstring,b,y:state_cexp$cexp) = + (SOME v, App (AllocMutThunk NotEvaluated) [IntLit 0]) End -Definition some_ref_bool_def: - some_ref_bool (v:mlstring,b,y:state_cexp$cexp) = - (SOME v, App Ref [Bool b; Bool b]) -End - -Definition unsafe_update_def: - unsafe_update (v,b,y) = - (NONE:mlstring option, App UnsafeUpdate [Var v; IntLit 1; if b then y else Lam NONE y]) +Definition update_delay_def: + update_delay (v,b,y) = + (NONE:mlstring option, + if b then + App (UpdateMutThunk Evaluated) [Var v; y] + else + App (UpdateMutThunk NotEvaluated) [Var v; Lam NONE y]) End Triviality Letrec_split_MEM_funs: @@ -73,8 +72,6 @@ Proof \\ Cases_on ‘h1’ \\ gvs [dest_Delay_def,env_cexpTheory.cexp_size_def] QED -Overload box[local] = “λx. App Ref [True]” -Overload delay[local] = “λx. App Ref [False; Lam NONE x]” Overload suspend[local] = ``Lam NONE`` Overload trigger[local] = ``λe. app e Unit`` @@ -105,25 +102,18 @@ Definition to_state_def: to_state (Deref x y) = suspend $ App Sub [to_state x; to_state y] ∧ to_state (Box x) = - App Ref [True; (to_state x)] ∧ + App (AllocMutThunk Evaluated) [to_state x] ∧ to_state (Delay x) = - App Ref [False; Lam NONE (to_state x)] ∧ + App (AllocMutThunk NotEvaluated) [Lam NONE (to_state x)] ∧ to_state (Force x) = - (Let (SOME «v») (to_state x) $ - Let (SOME «v1») (App UnsafeSub [Var «v»; IntLit 0]) $ - Let (SOME «v2») (App UnsafeSub [Var «v»; IntLit 1]) $ - If (Var «v1») (Var «v2») $ - Let (SOME «wh») (app (Var «v2») Unit) $ - Let NONE (App UnsafeUpdate [Var «v»; IntLit 0; True]) $ - Let NONE (App UnsafeUpdate [Var «v»; IntLit 1; Var «wh»]) $ - Var «wh») ∧ + App ForceMutThunk [to_state x] ∧ to_state (Letrec xs y) = (let (delays,funs) = Letrec_split (MAP FST xs) xs in let delays = MAP (λ(m,n,x). (m,n,to_state x)) delays in let funs = MAP (λ(m,n,x). (m,n,to_state x)) funs in - Lets (MAP some_ref_bool delays) $ + Lets (MAP some_alloc_thunk delays) $ Letrec funs $ - Lets (MAP unsafe_update delays) (to_state y)) ∧ + Lets (MAP update_delay delays) (to_state y)) ∧ to_state (Let vo x y) = Let vo (to_state x) (to_state y) ∧ to_state (If x y z) = diff --git a/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml b/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml index c6dc8ffb..4eee649e 100644 --- a/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml +++ b/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml @@ -451,6 +451,51 @@ QED Overload AppArgK = ``λsenv se. AppK senv AppOp [] [se]`` Overload AppUnitK = ``λsenv. AppK senv AppOp [Constructor "" []] []`` +Theorem LIST_REL_split: + ∀l l'. + LIST_REL ($= ### compile_rel) l l' ⇒ + MAP FST l = MAP FST l' ∧ + LIST_REL compile_rel (MAP SND l) (MAP SND l') +Proof + Induct \\ rw [] \\ gvs [RPROD_DEF] + \\ rpt $ (pairarg_tac \\ gvs []) +QED + +Theorem LIST_REL_ALOOKUP: + ∀l l'. + MAP FST l = MAP FST l' ∧ + LIST_REL compile_rel (MAP SND l) (MAP SND l') ⇒ + (ALOOKUP l s = NONE ⇒ ALOOKUP l' s = NONE) ∧ + (∀e. ALOOKUP l s = SOME e ⇒ + ∃e'. ALOOKUP l' s = SOME e' ∧ compile_rel e e') +Proof + rw [] + >- gvs [ALOOKUP_NONE] + \\ drule_all ALOOKUP_SOME_EL_2 \\ rw [] + \\ gvs [SF SFY_ss, LIST_REL_EL_EQN, EL_MAP] + \\ first_x_assum drule \\ rw [] +QED + +Theorem v_rel_anyThunk: + ∀v w. + v_rel v w ⇒ + (envLang$is_anyThunk v ⇔ (∃dt. stateLang$dest_anyThunk w = SOME dt)) +Proof + `(∀v w. + v_rel v w ⇒ + (envLang$is_anyThunk v ⇔ (∃dt. stateLang$dest_anyThunk w = SOME dt))) ∧ + (∀tenv senv. env_rel tenv senv ⇒ T)` + suffices_by gvs [] + \\ ho_match_mp_tac v_rel_strongind \\ rw [] \\ gvs [] + \\ rw [envLangTheory.is_anyThunk_def, envLangTheory.dest_anyThunk_def, + stateLangTheory.dest_anyThunk_def] + \\ dxrule LIST_REL_split \\ rpt strip_tac + \\ rpt CASE_TAC + \\ drule_all_then (qspec_then ‘n’ mp_tac) LIST_REL_ALOOKUP + \\ rpt strip_tac + \\ rgs [Once compile_rel_cases] +QED + Theorem eval_to_thm: ∀n tenv te tres se senv st k. eval_to n tenv te = tres ∧ compile_rel te se ∧ @@ -592,7 +637,13 @@ Proof \\ qexists_tac ‘1+ck’ \\ rewrite_tac [step_n_add] \\ fs [step_def,push_def,return_def,value_def] - \\ simp [Once v_rel_cases]) + \\ simp [Once v_rel_cases] + \\ CASE_TAC \\ rw [error_def] + \\ drule v_rel_anyThunk \\ rw [] + \\ gvs [thunk_or_thunk_loc_def] + \\ Cases_on ‘dest_anyThunk sv’ \\ gvs [] + \\ Cases_on ‘sv’ \\ gvs [] + \\ rgs [Once v_rel_cases]) >~ [‘Force x’] >- (simp [Once compile_rel_cases] \\ rw [] \\ fs [eval_to_def] @@ -623,16 +674,36 @@ Proof \\ Q.REFINE_EXISTS_TAC ‘ck1+1’ \\ rewrite_tac [step_n_add] \\ fs [step_def,push_def,return_def,continue_def] \\ qmatch_goalsub_abbrev_tac ‘Exp env3’ + \\ simp [oneline sum_bind_def] \\ CASE_TAC \\ rw [] \\ gvs [] + >- ( + `eval_to (n − 1) + (MAP (λ(fn,_). (fn,Recclosure xx1 aa0 fn)) xx1 ++ aa0) a1 + ≠ INL Type_error` by gvs [] + \\ last_x_assum $ drule_at $ Pos last + \\ disch_then $ drule_then $ qspecl_then [‘env3’,‘NONE’,‘ForceK2 st::k’] mp_tac + \\ unabbrev_all_tac + \\ impl_tac >- (irule env_rel_rec \\ fs []) + \\ strip_tac + \\ BasicProvers.FULL_CASE_TAC \\ gvs [] + \\ first_x_assum $ irule_at $ Pos last \\ fs []) + \\ `eval_to (n − 1) + (MAP (λ(fn,_). (fn,Recclosure xx1 aa0 fn)) xx1 ++ aa0) a1 + ≠ INL Type_error` by gvs [] \\ last_x_assum $ drule_at $ Pos last \\ disch_then $ drule_then $ qspecl_then [‘env3’,‘NONE’,‘ForceK2 st::k’] mp_tac \\ unabbrev_all_tac \\ impl_tac >- (irule env_rel_rec \\ fs []) \\ strip_tac - \\ CASE_TAC \\ fs [] - >- (first_x_assum $ irule_at $ Pos last \\ fs []) + \\ BasicProvers.FULL_CASE_TAC \\ gvs [] \\ Q.REFINE_EXISTS_TAC ‘ck1+ck'’ \\ rewrite_tac [step_n_add] \\ fs [step_def,push_def] - \\ qexists_tac ‘1’ \\ fs [step_def,return_def,value_def]) + \\ qexists_tac ‘1’ \\ fs [step_def,return_def,value_def] + \\ CASE_TAC \\ rw [error_def] + \\ drule v_rel_anyThunk \\ rw [] + \\ gvs [thunk_or_thunk_loc_def] + \\ Cases_on ‘dest_anyThunk sv’ \\ gvs [] + \\ Cases_on ‘sv’ \\ gvs [] + \\ rgs [Once v_rel_cases]) >~ [‘Let NONE x1 x2’] >- (simp [Once compile_rel_cases] \\ rw [] \\ fs [eval_to_def] @@ -754,6 +825,8 @@ Proof \\ irule_at Any (DECIDE “n ≤ k:num ⇒ n ≤ m + k”) \\ metis_tac []) \\ full_simp_tac bool_ss [MEM_REVERSE,MAP_REVERSE] \\ gvs [] + \\ reverse $ IF_CASES_TAC \\ gvs [] + >- gvs [EXISTS_MEM, MEM_EL, EVERY_EL] \\ simp [Once v_rel_cases,PULL_EXISTS] \\ fs [monad_cns_def] \\ drule_then drule eval_to_list_val @@ -1019,23 +1092,32 @@ Inductive cont_rel: HandleAppK senv se :: AppUnitK senv :: sk)) End +Definition store_rel_def: + store_rel ts (Array vs) = LIST_REL v_rel ts vs ∧ + store_rel _ _ = F +End + +Definition state_rel_def: + state_rel ts ss = LIST_REL store_rel ts ss +End + Inductive next_rel: (v_rel tv sv ∧ - LIST_REL (LIST_REL v_rel) ts ss ∧ + state_rel ts ss ∧ cont_rel tk sk ⇒ next_rel (tv, ts, tk) (Val sv, SOME ss, AppUnitK senv :: sk)) ∧ (eval tenv te = INR tv ∧ v_rel tv sv ∧ - LIST_REL (LIST_REL v_rel) ts ss ∧ + state_rel ts ss ∧ cont_rel tk sk ⇒ next_rel (Monadic tenv Ret [te], ts, tk) (Val sv, SOME ss, sk)) ∧ (eval tenv te = INR tv ∧ v_rel tv sv ∧ - LIST_REL (LIST_REL v_rel) ts ss ∧ + state_rel ts ss ∧ cont_rel tk sk ⇒ next_rel (Monadic tenv Raise [te], ts, tk) (Exn sv, SOME ss, sk)) @@ -1048,7 +1130,7 @@ Inductive next_res_rel: (¬is_halt (sres,ssopt,sk) ⇒ next_res_rel Div (sres,ssopt,sk)) ∧ - (cont_rel tk sk ∧ LIST_REL (LIST_REL v_rel) ts ss + (cont_rel tk sk ∧ state_rel ts ss ⇒ next_res_rel (Act (ea,eb) tk ts) (Action ea eb, SOME ss, sk)) End @@ -1391,7 +1473,7 @@ Proof DEEP_INTRO_TAC some_intro >> simp[] >> simp[Once eval_to_def, result_map_def, eval_op_def] >> simp[Once v_rel_cases] >> imp_res_tac LIST_REL_LENGTH >> gvs[] >> - gvs[LIST_REL_EL_EQN, EL_REPLICATE] + gvs[state_rel_def,store_rel_def,LIST_REL_EL_EQN, EL_REPLICATE] ) >~ [`Length`] >- ( @@ -1411,7 +1493,11 @@ Proof qpat_x_assum `v_rel (Atom _) _` mp_tac >> simp[Once v_rel_cases] >> strip_tac >> gvs[] >> qrefine `m + 1` >> simp[step_n_add, step] >> + gvs[state_rel_def] >> imp_res_tac LIST_REL_LENGTH >> simp[oEL_THM] >> + gvs[LIST_REL_EL_EQN] >> + first_assum $ qspec_then `n` assume_tac >> + Cases_on `EL n ss` >> gvs[store_rel_def] >> last_x_assum $ qspec_then `k - 1` mp_tac >> simp[] >> disch_then $ drule_at Any >> qmatch_goalsub_abbrev_tac `Val v` >> @@ -1421,7 +1507,7 @@ Proof simp[next_rel_cases] >> disj2_tac >> simp[eval_def] >> simp[Once eval_to_def, result_map_def, eval_op_def] >> DEEP_INTRO_TAC some_intro >>simp[Once eval_to_def, result_map_def, eval_op_def] >> - unabbrev_all_tac >> simp[Once v_rel_cases] >> gvs[LIST_REL_EL_EQN] + unabbrev_all_tac >> simp[Once v_rel_cases] >> gvs[state_rel_def,LIST_REL_EL_EQN] ) >~ [`Deref`] >- ( @@ -1452,8 +1538,12 @@ Proof rpt $ qpat_x_assum `v_rel (Atom _) _` mp_tac >> ntac 2 $ simp[Once v_rel_cases] >> rpt strip_tac >> gvs[] >> qrefine `m + 1` >> simp[step_n_add, step] >> + gvs [state_rel_def] >> imp_res_tac LIST_REL_LENGTH >> gvs[oEL_THM] >> - `LENGTH (EL n ts) = LENGTH (EL n ss)` by gvs[LIST_REL_EL_EQN] >> gvs[] >> + gvs [LIST_REL_EL_EQN] >> + first_assum $ qspec_then `n` assume_tac >> + Cases_on `EL n ss` >> gvs [store_rel_def] >> + `LENGTH (EL n ts) = LENGTH l` by gvs[LIST_REL_EL_EQN] >> gvs[] >> IF_CASES_TAC >> gvs[DISJ_EQ_IMP] >- ( last_x_assum $ qspec_then `k - 1` mp_tac >> simp[] >> @@ -1466,8 +1556,8 @@ Proof simp[eval_def] >> simp[Once eval_to_def, result_map_def, eval_op_def] >> DEEP_INTRO_TAC some_intro >> simp[] >> simp[Once eval_to_def, result_map_def, eval_op_def] >> - `Num i < &LENGTH (EL n ss)` by ARITH_TAC >> - gvs[LIST_REL_EL_EQN, NOT_LESS_EQUAL] + `Num i < &LENGTH l` by ARITH_TAC >> + gvs[state_rel_def,LIST_REL_EL_EQN,NOT_LESS_EQUAL] ) >- ( last_x_assum $ qspec_then `k - 1` mp_tac >> simp[] >> @@ -1480,7 +1570,8 @@ Proof simp[eval_def] >> simp[Once eval_to_def, result_map_def, eval_op_def] >> DEEP_INTRO_TAC some_intro >> simp[] >> simp[Once eval_to_def, result_map_def, eval_op_def] >> - simp[Once v_rel_cases, monad_cns_def] + simp[Once v_rel_cases, monad_cns_def] >> + gvs[state_rel_def,LIST_REL_EL_EQN] ) ) >~ [`Update`] @@ -1523,13 +1614,18 @@ Proof rpt $ qpat_x_assum `v_rel (Atom _) _` mp_tac >> ntac 2 $ simp[Once v_rel_cases] >> rpt strip_tac >> gvs[] >> qrefine `m + 1` >> simp[step_n_add, step] >> + gvs[state_rel_def] >> imp_res_tac LIST_REL_LENGTH >> gvs[oEL_THM] >> - `LENGTH (EL n ts) = LENGTH (EL n ss)` by gvs[LIST_REL_EL_EQN] >> gvs[] >> + gvs[LIST_REL_EL_EQN] >> + first_assum $ qspec_then `n` assume_tac >> + Cases_on `EL n ss` >> gvs[store_rel_def] >> + `LENGTH (EL n ts) = LENGTH l` by gvs[LIST_REL_EL_EQN] >> gvs[] >> IF_CASES_TAC >> gvs[DISJ_EQ_IMP] >- ( last_x_assum $ qspec_then `k - 1` mp_tac >> simp[] >> disch_then $ drule_at Any >> qmatch_goalsub_abbrev_tac `Val v` >> + gvs[miscTheory.LLOOKUP_THM] >> qmatch_goalsub_abbrev_tac `Val v,SOME ss',_` >> disch_then $ qspecl_then [`Val v`,`sk'`,`ss'`] mp_tac >> reverse impl_tac >> rw[] @@ -1539,9 +1635,10 @@ Proof DEEP_INTRO_TAC some_intro >> simp[] >> simp[Once eval_to_def, result_map_def, eval_op_def] >> simp[Once v_rel_cases, monad_cns_def] >> - gvs[LIST_REL_EL_EQN, EL_LUPDATE, COND_RAND] + gvs[state_rel_def, store_rel_def, LIST_REL_EL_EQN, EL_LUPDATE, COND_RAND] ) >- ( + gvs[miscTheory.LLOOKUP_THM] >> last_x_assum $ qspec_then `k - 1` mp_tac >> simp[] >> disch_then $ drule_at Any >> qmatch_goalsub_abbrev_tac `Exn e` >> @@ -1552,14 +1649,15 @@ Proof simp[eval_def] >> simp[Once eval_to_def, result_map_def, eval_op_def] >> DEEP_INTRO_TAC some_intro >> simp[] >> simp[Once eval_to_def, result_map_def, eval_op_def] >> - simp[Once v_rel_cases, monad_cns_def] + simp[Once v_rel_cases, monad_cns_def] >> + gvs[state_rel_def,store_rel_def,LIST_REL_EL_EQN] ) ) QED Theorem next_k_eval_thm: compile_rel te se ∧ - LIST_REL (LIST_REL v_rel) ts ss ∧ + state_rel ts ss ∧ cont_rel tk sk ∧ env_rel tenv senv ∧ next k (eval tenv te) tk ts = tres ∧ tres ≠ Err @@ -1610,7 +1708,7 @@ QED Theorem next_action_thm: compile_rel te se ∧ - LIST_REL (LIST_REL v_rel) ts ss ∧ + state_rel ts ss ∧ cont_rel tk sk ∧ env_rel tenv senv ∧ next_action (eval tenv te) tk ts = tres ∧ tres ≠ Err @@ -1689,7 +1787,7 @@ Proof QED Theorem semantics_thm: - compile_rel e1 e2 ∧ LIST_REL (LIST_REL v_rel) ts ss ∧ + compile_rel e1 e2 ∧ state_rel ts ss ∧ cont_rel tk sk ∧ env_rel tenv senv ⇒ env_semantics$semantics e1 tenv tk ts ---> semantics (app e2 Unit) senv (SOME ss) sk @@ -1698,7 +1796,7 @@ Proof \\ qsuff_tac ‘ ∀t1 t2. (∃e1 e2 ts ss tenv senv tk sk. - compile_rel e1 e2 ∧ LIST_REL (LIST_REL v_rel) ts ss ∧ + compile_rel e1 e2 ∧ state_rel ts ss ∧ cont_rel tk sk ∧ env_rel tenv senv ∧ t1 = env_semantics$semantics e1 tenv tk ts ∧ t2 = semantics e2 senv (SOME ss) (AppK senv AppOp [Constructor "" []] []::sk)) ⇒ @@ -1756,5 +1854,5 @@ Proof stateLangTheory.itree_of_def] \\ rw [] \\ irule semantics_thm \\ simp [Once cont_rel_cases] - \\ fs [env_rel_def] + \\ fs [env_rel_def,state_rel_def] QED diff --git a/compiler/backend/passes/proofs/env_to_state_2ProofScript.sml b/compiler/backend/passes/proofs/env_to_state_2ProofScript.sml index 039bde6b..bc5005b2 100644 --- a/compiler/backend/passes/proofs/env_to_state_2ProofScript.sml +++ b/compiler/backend/passes/proofs/env_to_state_2ProofScript.sml @@ -168,11 +168,11 @@ QED Inductive thunk_res: (∀x s. thunk_res ((Lam s x):stateLang$exp)) ∧ - (∀x. thunk_res (App Ref [False; Lam NONE x])) + (∀x. thunk_res (App (AllocMutThunk NotEvaluated) [Lam NONE x])) End Definition inv_thunk_def: - inv_thunk (App Ref [False; Lam NONE x]) = Delay x ∧ + inv_thunk (App (AllocMutThunk NotEvaluated) [Lam NONE x]) = Delay x ∧ inv_thunk (Lam s x) = Lam s x End @@ -255,7 +255,7 @@ Triviality comp_Letrec_neq: Proof fs [comp_Letrec_def] \\ pairarg_tac \\ fs [] - \\ Cases_on ‘MAP some_ref_bool delays’ \\ fs [] + \\ Cases_on ‘MAP some_alloc_thunk delays’ \\ fs [] \\ fs [state_unthunkProofTheory.Lets_def] \\ PairCases_on ‘h’ \\ fs [state_unthunkProofTheory.Lets_def] @@ -332,8 +332,9 @@ Proof \\ fs [Letrec_imm_def,state_unthunkProofTheory.Letrec_imm_def,rows_of_neq] QED -Theorem clean_Ref: - ∀x y z. clean (App Ref [x;y]) z ⇒ ∃x1 y1. z = (App Ref [x1;y1]) ∧ clean y y1 +Theorem clean_AllocMutThunk: + ∀x z. clean (App (AllocMutThunk NotEvaluated) [x]) z ⇒ + ∃x1. z = (App (AllocMutThunk NotEvaluated) [x1]) ∧ clean x x1 Proof Induct_on ‘clean’ \\ rw [] \\ fs [state_app_unitProofTheory.cexp_rel_refl] @@ -402,16 +403,14 @@ Proof \\ Cases_on ‘x’ \\ fs [] >- (Cases_on ‘c’ \\ fs [] + \\ Cases_on ‘c'’ \\ fs [] \\ Cases_on ‘l’ \\ fs [] - \\ Cases_on ‘t’ \\ fs [] \\ simp [Once state_caseProofTheory.compile_rel_cases,expand_Case_neq] \\ fs [state_caseProofTheory.expand_Case_def,AllCaseEqs()] - \\ simp [Once state_caseProofTheory.compile_rel_cases,expand_Case_neq] - \\ fs [state_caseProofTheory.expand_Case_def,AllCaseEqs()] - \\ Cases_on ‘h'’ \\ fs [] + \\ Cases_on ‘h’ \\ fs [] \\ strip_tac \\ gvs [] \\ pop_assum $ irule_at Any - \\ drule clean_Ref \\ fs [] + \\ drule clean_AllocMutThunk \\ fs [] \\ rw [] \\ drule clean_Lam \\ fs []) \\ rw [] @@ -604,7 +603,6 @@ Proof \\ rpt (irule_at Any state_app_unitProofTheory.cexp_rel_App \\ fs [PULL_EXISTS]) \\ rpt $ first_x_assum $ irule_at $ Pos hd \\ irule_at Any state_caseProofTheory.compile_rel_App \\ fs [PULL_EXISTS] - \\ irule_at Any state_caseProofTheory.compile_rel_App \\ fs [PULL_EXISTS] \\ rpt $ first_x_assum $ irule_at $ Pos hd \\ irule_at Any state_unthunkProofTheory.compile_rel_Box \\ fs []) >~ [‘Delay’] >- @@ -809,8 +807,8 @@ Proof \\ fs [MAP_MAP_o,combinTheory.o_DEF]) \\ qabbrev_tac ‘ds1 = MAP (λ((m,n,_),x). (m,n,x)) (ZIP (delays,ds))’ \\ qabbrev_tac ‘fs1 = MAP (λ((m,n,_),x). (m,n,body_of x)) (ZIP (funs,fs))’ - \\ qexists_tac ‘Lets (MAP some_ref_bool ds1) $ - Letrec fs1 $ Lets (MAP unsafe_update ds1) y1’ + \\ qexists_tac ‘Lets (MAP some_alloc_thunk ds1) $ + Letrec fs1 $ Lets (MAP update_delay ds1) y1’ \\ reverse conj_tac >- (irule_at Any clean_Lets \\ irule_at Any state_app_unitProofTheory.cexp_rel_Letrec \\ fs [] @@ -828,15 +826,16 @@ Proof >- (fs [] \\ rpt gen_tac \\ rpt $ disch_then strip_assume_tac \\ last_x_assum drule_all \\ fs [] - \\ PairCases_on ‘h'’ \\ fs [some_ref_bool_def,unsafe_update_def] + \\ PairCases_on ‘h'’ \\ fs [some_alloc_thunk_def,update_delay_def] \\ fs [] \\ rpt gen_tac \\ rpt $ disch_then strip_assume_tac \\ rpt (irule_at Any state_app_unitProofTheory.cexp_rel_App \\ fs [PULL_EXISTS]) \\ rpt (irule_at Any state_app_unitProofTheory.cexp_rel_Var \\ fs [PULL_EXISTS]) \\ Cases_on ‘h'1’ \\ fs [] \\ rpt (irule_at Any state_app_unitProofTheory.cexp_rel_App \\ fs [PULL_EXISTS]) - \\ rpt (irule_at Any state_app_unitProofTheory.cexp_rel_Lam \\ fs [PULL_EXISTS])) + \\ rpt (irule_at Any state_app_unitProofTheory.cexp_rel_Lam \\ fs [PULL_EXISTS]) + \\ simp [state_app_unitProofTheory.cexp_rel_refl]) \\ reverse Induct \\ Cases_on ‘fs’ \\ fs [] - \\ PairCases \\ fs [some_ref_bool_def,unsafe_update_def] + \\ PairCases \\ fs [some_alloc_thunk_def,update_delay_def] \\ rpt strip_tac \\ gvs [] \\ imp_res_tac clean_Lam \\ gvs []) \\ irule_at Any case_rel_Lets \\ fs [] @@ -856,7 +855,7 @@ Proof \\ qid_spec_tac ‘delays'’ \\ Induct \\ Cases_on ‘ds’ \\ Cases_on ‘delays’ \\ fs [] \\ PairCases_on ‘h'’ \\ PairCases \\ fs [] - \\ fs [some_ref_bool_def,state_unthunkProofTheory.some_ref_bool_def]) + \\ fs [some_alloc_thunk_def,state_unthunkProofTheory.some_alloc_thunk_def]) \\ reverse conj_tac >- (ntac 5 $ pop_assum mp_tac @@ -866,8 +865,8 @@ Proof \\ qid_spec_tac ‘delays'’ \\ Induct \\ Cases_on ‘ds’ \\ Cases_on ‘delays’ \\ fs [] \\ PairCases_on ‘h'’ \\ PairCases \\ fs [] - \\ fs [some_ref_bool_def,state_unthunkProofTheory.some_ref_bool_def] - \\ rw [] \\ rename [‘Bool bb’] \\ Cases_on ‘bb’ \\ fs [] + \\ fs [some_alloc_thunk_def,state_unthunkProofTheory.some_alloc_thunk_def] + \\ rw [] \\ rpt $ irule_at Any state_caseProofTheory.compile_rel_App \\ fs [PULL_EXISTS] \\ rpt $ irule_at Any state_caseProofTheory.compile_rel_App \\ fs [PULL_EXISTS]) \\ rpt $ irule_at Any state_caseProofTheory.compile_rel_Letrec @@ -897,7 +896,7 @@ Proof \\ qid_spec_tac ‘delays'’ \\ Induct \\ Cases_on ‘ds’ \\ Cases_on ‘delays’ \\ fs [] \\ PairCases_on ‘h'’ \\ PairCases \\ fs [] - \\ fs [unsafe_update_def,state_unthunkProofTheory.unsafe_update_def] + \\ fs [update_delay_def,state_unthunkProofTheory.update_delay_def] \\ rw [] \\ rpt $ irule_at Any state_caseProofTheory.compile_rel_App \\ fs [PULL_EXISTS] \\ rpt $ irule_at Any state_caseProofTheory.compile_rel_App \\ fs [PULL_EXISTS] @@ -1065,10 +1064,7 @@ Proof \\ fs [cns_arities_Lets, state_cexpTheory.cns_arities_def] \\ simp [BIGUNION_SUBSET, MEM_MAP, PULL_EXISTS, FORALL_PROD] \\ rw [] - >- (simp [some_ref_bool_def, state_cexpTheory.cns_arities_def] - \\ rename1 ‘Bool b’ - \\ Cases_on ‘b’ - \\ simp [Bool_def, state_cexpTheory.cns_arities_def]) + >- simp [some_alloc_thunk_def, state_cexpTheory.cns_arities_def] >- (last_x_assum $ drule_then assume_tac \\ dxrule_then (dxrule_then assume_tac) Letrec_split_2 \\ fs [EVERY_MEM, MEM_MAP, PULL_EXISTS] @@ -1081,7 +1077,7 @@ Proof \\ disj1_tac \\ disj1_tac \\ first_assum $ irule_at Any \\ fs [env_cexpTheory.cns_arities_def]) - >- (simp [unsafe_update_def, state_cexpTheory.cns_arities_def] + >- (simp [update_delay_def, state_cexpTheory.cns_arities_def] \\ last_x_assum $ drule_then assume_tac \\ dxrule_then (dxrule_then assume_tac) Letrec_split_1 \\ fs [EVERY_MEM, MEM_MAP, PULL_EXISTS] @@ -1205,11 +1201,8 @@ Proof \\ drule_then assume_tac Letrec_split_1 \\ drule_then assume_tac Letrec_split_2 \\ rpt $ first_x_assum $ drule_then assume_tac - \\ fs [some_ref_bool_def, unsafe_update_def, cexp_wwf_def, op_args_ok_def] - >- (rename1 ‘Bool b’ - \\ Cases_on ‘b’ - \\ fs [Bool_def, cexp_wwf_def, op_args_ok_def]) - \\ IF_CASES_TAC \\ fs [cexp_wwf_def]) + \\ fs [some_alloc_thunk_def, update_delay_def, cexp_wwf_def, op_args_ok_def] + \\ IF_CASES_TAC \\ fs [cexp_wwf_def, op_args_ok_def]) >~[‘cexp_wf (Case _ rows d)’] >- (fs [envLangTheory.cexp_wf_def, cexp_wwf_def, op_args_ok_def] \\ conj_tac diff --git a/compiler/backend/passes/proofs/pure_to_cakeProofScript.sml b/compiler/backend/passes/proofs/pure_to_cakeProofScript.sml index 1ccfcf76..85ffdf37 100644 --- a/compiler/backend/passes/proofs/pure_to_cakeProofScript.sml +++ b/compiler/backend/passes/proofs/pure_to_cakeProofScript.sml @@ -27,6 +27,7 @@ Proof \\ disch_then $ qspec_then ‘c’ assume_tac \\ fs [pure_to_env_def] \\ irule_at Any thunk_to_envProofTheory.to_env_semantics + \\ ‘safe_itree (itree_of (exp_of x))’ by gvs [] \\ drule_all IMP_thunk_cexp_wf \\ fs [] \\ disch_then $ qspec_then ‘c’ strip_assume_tac \\ drule_all IMP_env_cexp_wf \\ fs [] diff --git a/compiler/backend/passes/proofs/pure_to_thunkProofScript.sml b/compiler/backend/passes/proofs/pure_to_thunkProofScript.sml index 972fa798..5a3a90c9 100644 --- a/compiler/backend/passes/proofs/pure_to_thunkProofScript.sml +++ b/compiler/backend/passes/proofs/pure_to_thunkProofScript.sml @@ -653,6 +653,7 @@ QED Theorem IMP_to_thunk_cexp_wf: cexp_wf x ∧ closed (exp_of x) ∧ + pure_semantics$safe_itree (itree_of (exp_of x)) ∧ letrecs_distinct (exp_of x) ∧ NestedCase_free x ⇒ thunkLang$closed (thunk_exp_of$exp_of (FST (to_thunk flag (pure_names x) x))) @@ -664,10 +665,11 @@ Proof \\ dxrule_then assume_tac exp_rel_imp_combined \\ gs [] \\ dxrule_then assume_tac pure_to_thunk_1ProofTheory.compile_rel_freevars + \\ dxrule_then assume_tac thunk_unthunkProofTheory.delay_force_freevars + \\ dxrule_then assume_tac thunk_undelay_nextProofTheory.exp_rel_freevars \\ dxrule_then assume_tac thunk_case_liftProofTheory.compile_rel_freevars \\ dxrule_then assume_tac thunk_let_forceProofTheory.exp_rel_NONE_freevars \\ dxrule_then assume_tac thunk_case_projProofTheory.compile_rel_closed - \\ dxrule_then assume_tac thunk_unthunkProofTheory.delay_force_closed \\ dxrule_then assume_tac expof_caseProofTheory.freevars_exp_of' \\ fs [pure_expTheory.closed_def, thunkLangTheory.closed_def] QED @@ -692,17 +694,20 @@ Proof \\ pairarg_tac \\ fs [] \\ drule_then mp_tac split_delated_lam_soundness \\ simp [] + \\ ‘safe_itree (itree_of (exp_of x))’ by gvs [] \\ drule_all IMP_to_thunk_cexp_wf \\ disch_then $ qspec_then `c.do_mk_delay` assume_tac \\ gs [] \\ strip_tac \\ fs [GSYM thunk_semanticsTheory.itree_of_def] - \\ drule_all thunk_let_force_1ProofTheory.itree_of_simp_let_force - \\ disch_then $ qspec_then `c.do_let_force` assume_tac \\ gs [] + \\ ntac 2 ( + drule_all thunk_let_force_1ProofTheory.itree_of_simp_let_force + \\ disch_then $ qspec_then ‘c.do_let_force’ assume_tac \\ gs []) QED Theorem IMP_thunk_cexp_wf: cexp_wf x ∧ closed (exp_of x) ∧ + safe_itree (itree_of (exp_of x)) ∧ letrecs_distinct (exp_of x) ∧ NestedCase_free x ⇒ thunk_exp_of$cexp_wf (compile_to_thunk c x) ∧ @@ -719,7 +724,11 @@ Proof \\ pairarg_tac \\ fs [thunk_let_force_1ProofTheory.simp_let_force_wf_lemmas] \\ drule_then mp_tac split_delated_lam_soundness \\ impl_tac \\ gvs [] + >- ( + drule_all to_thunk_itree_of + \\ disch_then $ qspec_then ‘c.do_mk_delay’ assume_tac \\ fs [] + \\ gvs [itree_of_def]) \\ drule_all IMP_to_thunk_cexp_wf - \\ disch_then $ qspec_then `c.do_mk_delay` assume_tac + \\ disch_then $ qspec_then ‘c.do_mk_delay’ assume_tac \\ gs [] \\ rw [] \\ fs [] QED diff --git a/compiler/backend/passes/proofs/pure_to_thunk_1ProofScript.sml b/compiler/backend/passes/proofs/pure_to_thunk_1ProofScript.sml index 110a5b2f..625fe11f 100644 --- a/compiler/backend/passes/proofs/pure_to_thunk_1ProofScript.sml +++ b/compiler/backend/passes/proofs/pure_to_thunk_1ProofScript.sml @@ -4,8 +4,8 @@ Theory pure_to_thunk_1Proof Ancestors string option sum pair list alist thunkLang pure_eval thunkLang_primitives - finite_map pred_set rich_list pure_semantics thunk_semantics pure_exp_lemmas - pure_misc pure_config + finite_map pred_set rich_list pure_semantics thunk_semantics + thunk_semantics_delayed pure_exp_lemmas pure_misc pure_config Libs term_tactic monadsyntax dep_rewrite intLib @@ -161,28 +161,15 @@ Inductive exp_rel: (∀n mop idopt xs ys. mop_delay_rel n mop idopt ∧ (∀idx. idopt = SOME idx ⇒ idx < LENGTH xs) ∧ LIST_REL exp_rel xs ys ⇒ - exp_rel (Cons n xs) - (Monad Bind [ - Monad mop (opt_delay_arg idopt ys); - Lam "v" $ Monad Ret [Delay $ Var "v"] - ])) + exp_rel (Cons n xs) (Monad mop (opt_delay_arg idopt ys))) [exp_rel_Deref:] (∀xs ys. LIST_REL exp_rel xs ys ⇒ - exp_rel (Cons "Deref" xs) - (Monad Handle [ - Monad Deref ys; - Lam "v" $ Monad Raise [Delay $ Var "v"]])) + exp_rel (Cons "Deref" xs) (Monad Deref ys)) [exp_rel_Update:] (∀xs ys. LIST_REL exp_rel xs ys ∧ 2 < LENGTH xs ⇒ - exp_rel (Cons "Update" xs) - (Monad Bind [ - Monad Handle [ - Monad Update (opt_delay_arg (SOME 2n) ys); - Lam "v" $ Monad Raise [Delay $ Var "v"]]; - Lam "v" $ Monad Ret [Delay $ Var "v"] - ])) + exp_rel (Cons "Update" xs) (Monad Update (opt_delay_arg (SOME 2n) ys))) [exp_rel_Proj:] (∀s i xs ys. LIST_REL exp_rel xs ys ∧ s ∉ monad_cns ⇒ @@ -236,22 +223,18 @@ Definition v_rel_def[simp]: mop_ret_rel s mop ∧ LIST_REL thunk_rel xs zs ∧ ys = MAP (λz. Value z) zs) ∨ (∃mop' idopt zs. - mop = Bind ∧ - ys = [Monad mop' (opt_delay_arg idopt zs); - Lam "v" $ Monad Ret [Delay $ Var "v"]] ∧ - mop_delay_rel s mop' idopt ∧ (∀idx. idopt = SOME idx ⇒ idx < LENGTH xs) ∧ + mop = mop' ∧ + ys = opt_delay_arg idopt zs ∧ + mop_delay_rel s mop' idopt ∧ + (∀idx. idopt = SOME idx ⇒ idx < LENGTH xs) ∧ LIST_REL exp_rel xs zs) ∨ (∃zs. - s = "Deref" ∧ mop = Handle ∧ - ys = [Monad Deref zs; - Lam "v" $ Monad Raise [Delay $ Var "v"]] ∧ + s = "Deref" ∧ mop = Deref ∧ + ys = zs ∧ LIST_REL exp_rel xs zs) ∨ (∃zs. - s = "Update" ∧ mop = Bind ∧ - ys = [Monad Handle [ - Monad Update (opt_delay_arg (SOME 2) zs); - Lam "v" $ Monad Raise [Delay $ Var "v"]]; - Lam "v" $ Monad Ret [Delay $ Var "v"]] ∧ + s = "Update" ∧ mop = Update ∧ + ys = opt_delay_arg (SOME 2) zs ∧ LIST_REL exp_rel xs zs ∧ 2 < LENGTH xs) )) ∧ v_rel (wh_Atom a) (INR (Atom b)) = (a = b) ∧ @@ -285,22 +268,18 @@ Theorem v_rel_rev[local,simp]: mop_ret_rel s mop ∧ LIST_REL thunk_rel xs ys ∧ zs = MAP (λz. Value z) ys) ∨ (∃mop' idopt ys. - mop = Bind ∧ - zs = [Monad mop' (opt_delay_arg idopt ys); - Lam "v" $ Monad Ret [Delay $ Var "v"]] ∧ - mop_delay_rel s mop' idopt ∧ (∀idx. idopt = SOME idx ⇒ idx < LENGTH xs) ∧ + mop = mop' ∧ + zs = opt_delay_arg idopt ys ∧ + mop_delay_rel s mop' idopt ∧ + (∀idx. idopt = SOME idx ⇒ idx < LENGTH xs) ∧ LIST_REL exp_rel xs ys) ∨ (∃ys. - s = "Deref" ∧ mop = Handle ∧ - zs = [Monad Deref ys; - Lam "v" $ Monad Raise [Delay $ Var "v"]] ∧ + s = "Deref" ∧ mop = Deref ∧ + zs = ys ∧ LIST_REL exp_rel xs ys) ∨ (∃ys. - s = "Update" ∧ mop = Bind ∧ - zs = [Monad Handle [ - Monad Update (opt_delay_arg (SOME 2) ys); - Lam "v" $ Monad Raise [Delay $ Var "v"]]; - Lam "v" $ Monad Ret [Delay $ Var "v"]] ∧ + s = "Update" ∧ mop = Update ∧ + zs = opt_delay_arg (SOME 2) ys ∧ LIST_REL exp_rel xs ys ∧ 2 < LENGTH xs) )) ∧ v_rel x (INR (Atom l)) = @@ -1033,11 +1012,20 @@ Proof CONV_TAC (PATH_CONV "rl" (SIMP_CONV (srw_ss()) [eval_to_def])) \\ gs [] \\ imp_res_tac ALOOKUP_SOME \\ fs [dest_anyThunk_def] \\ simp [GSYM MAP_REVERSE, ALOOKUP_MAP] - \\ first_x_assum irule + \\ qmatch_goalsub_abbrev_tac ‘eval_to (k - 1) x’ + \\ Cases_on ‘eval_to (k - 1) x’ \\ gvs [] + \\ TRY (IF_CASES_TAC \\ gvs []) + \\ ‘v_rel (eval_wh_to (k - 1) (subst_funs f y)) + (eval_to (k - 1) x)’ + suffices_by ( + gvs [] \\ rpt strip_tac \\ gvs [eval_wh_to_def] + \\ Cases_on ‘y'’ \\ gvs [is_anyThunk_def, dest_anyThunk_def] + \\ Cases_on ‘eval_wh_to (k - 1) (subst_funs f y)’ \\ gvs []) + \\ first_x_assum irule \\ unabbrev_all_tac \\ irule_at Any exp_rel_subst_funs \\ fs [] \\ drule_then (qspec_then ‘REVERSE f’ mp_tac) ALOOKUP_SOME_EL_2 \\ impl_tac - >- ( + >>~- ([‘MAP FST _ = MAP FST _’], simp [MAP_REVERSE] \\ irule LIST_EQ \\ gvs [EL_MAP, LIST_REL_EL_EQN] @@ -1065,6 +1053,14 @@ Proof >- ((* Tick *) CONV_TAC (PATH_CONV "rl" (SIMP_CONV (srw_ss()) [eval_to_def])) \\ gs [dest_anyThunk_def] + \\ Cases_on ‘eval_to (k - 1) (subst_funs [] y'')’ \\ gvs [] + \\ TRY (IF_CASES_TAC \\ gvs []) + \\ ‘v_rel (eval_wh_to (k - 1) (subst_funs [] y)) + (eval_to (k - 1) (subst_funs [] y''))’ + suffices_by ( + gvs [] \\ rpt strip_tac \\ gvs [eval_wh_to_def] + \\ Cases_on ‘y'’ \\ gvs [is_anyThunk_def, dest_anyThunk_def] + \\ Cases_on ‘eval_wh_to (k - 1) (subst_funs [] y)’ \\ gvs []) \\ first_x_assum irule \\ fs [pure_expTheory.subst_funs_def, pure_expTheory.bind_def, flookup_fupdate_list, FDOM_FUPDATE_LIST, subst_ignore, @@ -1103,8 +1099,11 @@ Proof \\ Cases_on ‘result_map f ys’ \\ fs [Abbr ‘f’] \\ gvs [result_map_def, MEM_MAP, MAP_MAP_o, combinTheory.o_DEF, LIST_REL_EL_EQN] + \\ reverse $ IF_CASES_TAC + >- (gvs [EXISTS_MAP, EXISTS_MEM, is_anyThunk_def, dest_anyThunk_def]) \\ rw [] \\ gvs [EL_MAP] - \\ gs [thunk_rel_def, EVERY_EL]) + \\ gs [thunk_rel_def, EVERY_EL] + \\ rw [LIST_REL_EL_EQN, EL_MAP, thunk_rel_def]) >- simp[get_atoms_def] >- (gvs[mop_cases] >> metis_tac[]) >- (gvs[mop_cases] >> metis_tac[]) @@ -1155,7 +1154,10 @@ Proof simp [eval_wh_to_def, eval_to_def, result_map_MAP, combinTheory.o_DEF, result_map_def, MEM_MAP, MAP_MAP_o, EVERY2_MAP, thunk_rel_def, SF ETA_ss] - \\ gs [LIST_REL_EL_EQN, EVERY_EL]) + \\ gs [LIST_REL_EL_EQN, EVERY_EL] + \\ reverse $ IF_CASES_TAC \\ gvs [] + >- (gvs [EL_MAP, is_anyThunk_def, dest_anyThunk_def]) + \\ simp [LIST_REL_EL_EQN, EL_MAP, thunk_rel_def, EVERY_EL]) >- (simp[eval_wh_to_def, eval_to_def, get_atoms_def]) >- (simp[eval_wh_to_def, eval_to_def, monad_cns_def]) >- (gvs[mop_cases, eval_wh_to_def, eval_to_def] >> metis_tac[]) @@ -1186,6 +1188,13 @@ Proof \\ first_x_assum (drule_all_then assume_tac) \\ fs [thunk_rel_def, dest_anyThunk_def, subst_funs_def, EVERY_EL] + \\ Cases_on ‘eval_to (k - 1) y'’ \\ gvs [] + \\ TRY (IF_CASES_TAC \\ gvs []) + \\ ‘v_rel (eval_wh_to (k - 1) (EL i xs)) (eval_to (k - 1) y')’ + suffices_by ( + gvs [] \\ rpt strip_tac \\ gvs [eval_wh_to_def] + \\ Cases_on ‘y''’ \\ gvs [is_anyThunk_def, dest_anyThunk_def] + \\ Cases_on ‘eval_wh_to (k - 1) (EL i xs)’ \\ gvs []) \\ first_x_assum irule \\ gs [] \\ strip_tac \\ gs [eval_wh_to_def]) @@ -1359,9 +1368,7 @@ Definition next_rel_def[simp]: next_rel Div Div = T ∧ next_rel Err Err = T ∧ next_rel (Act a c s) (Act b d t) = ( - ∃d'. - d = BC (Lam "v" $ Monad Ret [Delay $ Var "v"]) d' ∧ - a = b ∧ cont_rel c d' ∧ state_rel s t) ∧ + a = b ∧ cont_rel c d ∧ state_rel s t) ∧ next_rel _ _ = F End @@ -2624,7 +2631,7 @@ Theorem pure_to_thunk_next[local]: cont_rel c d ∧ state_rel s t ∧ next' k v c s ≠ Err ⇒ - ∃ck. next_rel (next' k v c s) (next (k + ck) w d t) + ∃ck. next_rel (next' k v c s) (next_delayed (k + ck) w d t) Proof ho_match_mp_tac pure_semanticsTheory.next_ind \\ rw [] \\ simp [Once next'_def] @@ -2634,7 +2641,7 @@ Proof (∃s x. v = wh_Closure s x)’ >- ((* Error *) rgs [Once next'_def] - \\ Cases_on ‘w’ \\ rgs [Once thunk_semanticsTheory.next_def] + \\ Cases_on ‘w’ \\ rgs [Once next_delayed_def] \\ gs [Once next'_def]) \\ ‘∃n xs. v = wh_Constructor n xs’ by (Cases_on ‘v’ \\ gs []) @@ -2642,13 +2649,14 @@ Proof \\ rename1 ‘v_rel _ w’ \\ Cases_on ‘w’ \\ gvs [] \\ rename1 ‘v_rel _ (INR w)’ \\ Cases_on ‘w’ \\ gvs [] \\ gs [LIST_REL_EL_EQN] - >- (gvs[monad_cns_def] >> simp[next_def]) + >- (gvs[monad_cns_def] >> simp[next_delayed_def]) \\ gvs[mop_cases] >~ [`Monadic Ret (MAP Delay _)`] >- ((* Ret - Delay *) `LENGTH zs = 1` by (CCONTR_TAC >> gvs[Once next'_def]) >> gvs[LENGTH_EQ_NUM_compute, numeral_less_thm] - \\ simp [Once thunk_semanticsTheory.next_def, with_value_def] + \\ simp [Once next_delayed_def, with_value_def, + is_anyThunk_def, dest_anyThunk_def] \\ rgs [Once next'_def] \\ gvs [] \\ Cases_on ‘k = 0’ \\ gs [] >- ( @@ -2678,7 +2686,11 @@ Proof >- ((* Ret - thunk_rel *) `LENGTH zs = 1` by (CCONTR_TAC >> gvs[Once next'_def]) >> gvs[LENGTH_EQ_NUM_compute, numeral_less_thm] - \\ simp [Once thunk_semanticsTheory.next_def, with_value_def] + \\ simp [Once next_delayed_def, with_value_def] + \\ `is_anyThunk h'` + by (Cases_on `h'` + \\ gvs [thunk_rel_def, is_anyThunk_def, dest_anyThunk_def]) + \\ rw [] \\ rgs [Once next'_def] \\ gvs [] \\ Cases_on ‘k = 0’ \\ gs [] >- ( @@ -2708,7 +2720,8 @@ Proof >- ((* Raise - Delay *) `LENGTH zs = 1` by (CCONTR_TAC >> gvs[Once next'_def]) >> gvs[LENGTH_EQ_NUM_compute, numeral_less_thm] - \\ simp [Once thunk_semanticsTheory.next_def, with_value_def] + \\ simp [Once next_delayed_def, with_value_def, + is_anyThunk_def, dest_anyThunk_def] \\ rgs [Once next'_def] \\ gvs [] \\ Cases_on ‘k = 0’ \\ gs [] >- ( @@ -2738,7 +2751,10 @@ Proof >- ((* Raise - thunk_rel *) `LENGTH zs = 1` by (CCONTR_TAC >> gvs[Once next'_def]) >> gvs[LENGTH_EQ_NUM_compute, numeral_less_thm] - \\ simp [Once thunk_semanticsTheory.next_def, with_value_def] + \\ simp [Once next_delayed_def, with_value_def] + \\ `is_anyThunk h'` + by (Cases_on `h'` + \\ gvs [thunk_rel_def, is_anyThunk_def, dest_anyThunk_def]) \\ rgs [Once next'_def] \\ gvs [] \\ Cases_on ‘k = 0’ \\ gs [] >- ( @@ -2769,7 +2785,7 @@ Proof >- ((* Bind *) `LENGTH xs = 2` by (CCONTR_TAC >> gvs[Once next'_def]) >> gvs[LENGTH_EQ_NUM_compute, numeral_less_thm, SF DNF_ss] >> - simp [Once thunk_semanticsTheory.next_def] + simp [Once next_delayed_def] \\ IF_CASES_TAC \\ gs [] >- (qexists `0` >> simp[]) \\ first_x_assum irule \\ gs [] \\ gs [Once next'_def] @@ -2780,7 +2796,7 @@ Proof >- ((* Handle *) `LENGTH l = 2` by (CCONTR_TAC >> gvs[Once next'_def]) >> gvs[LENGTH_EQ_NUM_compute, numeral_less_thm, SF DNF_ss] >> - simp [Once thunk_semanticsTheory.next_def] + simp [Once next_delayed_def] \\ IF_CASES_TAC \\ gs [] >- (qexists `0` >> simp[]) \\ first_x_assum irule \\ gs [] \\ gs [Once next'_def] @@ -2791,13 +2807,13 @@ Proof >- ((* Act *) `LENGTH zs = 1` by (CCONTR_TAC >> gvs[Once next'_def]) >> gvs[LENGTH_EQ_NUM_compute, numeral_less_thm] >> - ntac 2 $ simp[Once thunk_semanticsTheory.next_def] >> + ntac 2 $ simp[Once next_delayed_def] >> gs [Once next'_def] >> gvs[pure_semanticsTheory.with_atom_def, pure_semanticsTheory.with_atoms_def, thunk_semanticsTheory.with_atoms_def, result_map_def] >> - qrefine `ck + 1` >> simp[] >> + (*qrefine `ck + 1` >> simp[] >>*) `eval_wh h ≠ wh_Error` by (CCONTR_TAC >> gvs[]) >> drule_all_then assume_tac exp_rel_eval >> rename1 `v_rel (eval_wh x) (eval y)` >> @@ -2811,27 +2827,24 @@ Proof `LENGTH zs = 2` by (CCONTR_TAC >> gvs[Once next'_def]) >> gvs[LENGTH_EQ_NUM_compute, numeral_less_thm, SF DNF_ss] >> simp[LUPDATE_DEF] >> - rename1 `wh_Constructor _ [x1;x2]` >> rename1 `Monad Alloc [z1; _ z2]` + rename1 `wh_Constructor _ [x1;x2]` >> rename1 `Monadic Alloc [z1; _ z2]` \\ rgs [Once next'_def] \\ rgs [pure_semanticsTheory.with_atom_def, pure_semanticsTheory.with_atoms_def] >> `eval_wh x1 ≠ wh_Error` by (CCONTR_TAC >> gvs[]) >> drule_all_then assume_tac exp_rel_eval >> - ntac 2 $ simp[Once thunk_semanticsTheory.next_def] >> + simp[Once next_delayed_def] >> simp[thunk_semanticsTheory.with_atoms_def, result_map_def] >> reverse $ Cases_on `eval_wh x1` >> gvs[pure_semanticsTheory.get_atoms_def] >- ( - Cases_on `k = 0` >> gvs[] >- (qexists `0` >> simp[]) >> + Cases_on `k = 0` >> gvs[] >> Cases_on `eval z1` >> gvs[] ) >> Cases_on `eval z1` >> gvs[] >> rename1 `eval z1 = INR y` >> + simp [is_anyThunk_def, dest_anyThunk_def] >> Cases_on `y` >> gvs[] >> simp[thunk_semanticsTheory.get_atoms_def] >> - BasicProvers.TOP_CASE_TAC >> gvs[] >> simp[with_value_def] >> + BasicProvers.TOP_CASE_TAC >> gvs[] >> IF_CASES_TAC >> gvs[] >- (qexists `0` >> simp[]) >> - qrefine `ck + 1` >> simp[] >> - simp[Once thunk_semanticsTheory.next_def] >> qrefine `ck + 1` >> simp[] >> - simp[thunk_semanticsTheory.apply_closure_def, - with_value_def, dest_anyClosure_def, subst1_def] >> first_x_assum irule >> rw[] >> gvs[state_rel_def] >- gvs[LIST_REL_EL_EQN, EL_REPLICATE, thunk_rel_def] >> gvs[mop_cases] >> simp[Once exp_rel_cases] >> gvs[LIST_REL_EL_EQN] @@ -2840,40 +2853,37 @@ Proof >- ((* Length *) `LENGTH zs = 1` by (CCONTR_TAC >> gvs[Once next'_def]) >> gvs[LENGTH_EQ_NUM_compute, numeral_less_thm] >> - rename1 `wh_Constructor _ [x]` >> rename1 `Monad Length [y]` + rename1 `wh_Constructor _ [x]` >> rename1 `Monadic Length [y]` \\ rgs [Once next'_def] \\ rgs [pure_semanticsTheory.with_atom_def, pure_semanticsTheory.with_atoms_def, thunk_semanticsTheory.with_atoms_def] \\ ‘eval_wh x ≠ wh_Error’ by (strip_tac \\ gs []) >> - ntac 2 $ simp[Once thunk_semanticsTheory.next_def] >> + simp[Once next_delayed_def] >> simp[thunk_semanticsTheory.with_atoms_def, result_map_def] >> drule_all_then assume_tac exp_rel_eval >> simp[] >> reverse $ Cases_on `eval_wh x` >> gvs[pure_semanticsTheory.get_atoms_def] >- ( - Cases_on `k = 0` >> gvs[] >- (qexists `0` >> simp[]) >> + Cases_on `k = 0` >> gvs[] >> Cases_on `eval y` >> gvs[] ) >> Cases_on `eval y` >> gvs[] >> rename1 `eval y = INR a` >> Cases_on `a` >> gvs[] >> rename1 `Atom a` >> simp[thunk_semanticsTheory.get_atoms_def] >> - qrefine `ck + 1` >> simp[] >> BasicProvers.TOP_CASE_TAC >> gvs[] >> `LENGTH s = LENGTH t` by gvs[state_rel_def, LIST_REL_EL_EQN] >> IF_CASES_TAC >> gvs[] >> IF_CASES_TAC >> gvs[] >- (qexists `0` >> simp[]) >> - simp[Once thunk_semanticsTheory.next_def] >> qrefine `ck + 1` >> simp[] >> - simp[thunk_semanticsTheory.apply_closure_def, - with_value_def, dest_anyClosure_def, subst1_def] >> first_x_assum irule >> rw[] >> gvs[mop_cases] >> `LENGTH (EL n s) = LENGTH (EL n t)` by gvs[state_rel_def, LIST_REL_EL_EQN] >> simp[Once exp_rel_cases] ) >~ [`Deref`] >- ((* Deref *) + rename1 `wh_Constructor "Deref" zs` >> `LENGTH zs = 2` by (CCONTR_TAC >> gvs[Once next'_def]) >> gvs[LENGTH_EQ_NUM_compute, numeral_less_thm, SF DNF_ss] >> - rename1 `wh_Constructor _ [x1;x2]` >> rename1 `Monad Deref [z1;z2]` >> - ntac 3 $ simp [Once thunk_semanticsTheory.next_def] + rename1 `wh_Constructor _ [x1;x2]` >> rename1 `Monadic Deref [z1;z2]` >> + simp [Once next_delayed_def] \\ rgs [Once next'_def] \\ rgs [pure_semanticsTheory.with_atom_def, pure_semanticsTheory.with_atoms_def, @@ -2892,17 +2902,15 @@ Proof \\ gs [pure_semanticsTheory.get_atoms_def] >> namedCases_on `eval z1` ["a1", "a1"] >> gvs[] >> Cases_on `a1` >> gvs[] >> namedCases_on `eval z2` ["a2", "a2"] >> gvs[] >> Cases_on `a2` >> gvs[] >> - simp[thunk_semanticsTheory.get_atoms_def] >> - qrefine `ck + 1` >> simp[] + simp[thunk_semanticsTheory.get_atoms_def] \\ BasicProvers.TOP_CASE_TAC \\ gs [] \\ BasicProvers.TOP_CASE_TAC \\ gs [] \\ ‘LENGTH s = LENGTH t’ by gs [state_rel_def, LIST_REL_EL_EQN] \\ IF_CASES_TAC \\ gs [] \\ Cases_on `k = 0` >> gvs[] >- (qexists `0` >> simp[]) >> `LENGTH (EL n s) = LENGTH (EL n t)` by gvs[state_rel_def, LIST_REL_EL_EQN] >> - simp[with_value_def] >> IF_CASES_TAC >> gvs[DISJ_EQ_IMP] + IF_CASES_TAC >> gvs[DISJ_EQ_IMP] >- ( - qrefine `ck + 1` >> simp[] >> first_x_assum irule >> simp[mop_cases] >> `Num i < LENGTH (EL n s)` by intLib.ARITH_TAC >> gvs[] >> gvs[state_rel_def, LIST_REL_EL_EQN] >> @@ -2911,10 +2919,7 @@ Proof pop_assum drule >> rw[thunk_rel_def] ) >- ( - simp[Once thunk_semanticsTheory.next_def] >> - simp[thunk_semanticsTheory.apply_closure_def, with_value_def, - dest_anyClosure_def, subst1_def] >> - qrefine `ck + 1` >> simp[] >> + BasicProvers.TOP_CASE_TAC >- gvs[] >> first_x_assum irule >> simp[mop_cases, PULL_EXISTS] >> goal_assum $ drule_at Any >> irule_at Any integerTheory.INT_LT_REFL >> simp[Once exp_rel_cases, monad_cns_def] @@ -2925,8 +2930,8 @@ Proof `LENGTH zs = 3` by (CCONTR_TAC >> gvs[Once next'_def]) >> gvs[LENGTH_EQ_NUM_compute, numeral_less_thm, SF DNF_ss] >> rename1 `wh_Constructor _ [x1;x2;x3]` >> - rename1 `Monad _ (LUPDATE _ _ [z1;z2;z3])` >> - ntac 3 $ simp [Once thunk_semanticsTheory.next_def] >> simp[LUPDATE_DEF] + rename1 `Monadic _ (LUPDATE _ _ [z1;z2;z3])` >> + simp [Once next_delayed_def] >> simp[LUPDATE_DEF] \\ rgs [Once next'_def] \\ rgs [pure_semanticsTheory.with_atom_def, pure_semanticsTheory.with_atoms_def, @@ -2945,30 +2950,22 @@ Proof \\ gs [pure_semanticsTheory.get_atoms_def] \\ namedCases_on `eval z1` ["a1", "a1"] >> gvs[] >> Cases_on `a1` >> gvs[] >> namedCases_on `eval z2` ["a2", "a2"] >> gvs[] >> Cases_on `a2` >> gvs[] >> - qrefine `ck + 2` >> simp[thunk_semanticsTheory.get_atoms_def] + simp [is_anyThunk_def, dest_anyThunk_def] >> + simp[thunk_semanticsTheory.get_atoms_def] \\ BasicProvers.TOP_CASE_TAC \\ gs [] \\ BasicProvers.TOP_CASE_TAC \\ gs [] \\ ‘LENGTH s = LENGTH t’ by gs [state_rel_def, LIST_REL_EL_EQN] \\ IF_CASES_TAC \\ gs [arithmeticTheory.NOT_LESS_EQUAL] >> `LENGTH (EL n s) = LENGTH (EL n t)` by gvs[state_rel_def, LIST_REL_EL_EQN] >> Cases_on `k = 0` >> gvs[] >- (qexists `0` >> simp[]) >> - simp[with_value_def] >> IF_CASES_TAC >> gvs[DISJ_EQ_IMP] + IF_CASES_TAC >> gvs[DISJ_EQ_IMP] >- ( - simp[with_value_def] >> - ntac 2 $ simp[Once thunk_semanticsTheory.next_def] >> - qrefine `ck + 2` >> simp[] >> - simp[apply_closure_def, with_value_def, dest_anyClosure_def, subst1_def] >> first_x_assum irule >> simp[mop_cases] >> simp[Once exp_rel_cases, monad_cns_def] >> gvs[state_rel_def, LIST_REL_EL_EQN, EL_LUPDATE, COND_RAND] >> simp[thunk_rel_def] ) >- ( - simp[Once thunk_semanticsTheory.next_def, with_value_def] >> - qrefine `ck + 1` >> simp[] >> - simp[apply_closure_def, with_value_def, dest_anyClosure_def, subst1_def] >> - simp[Once thunk_semanticsTheory.next_def, with_value_def] >> - qrefine `ck + 1` >> simp[] >> first_x_assum irule >> simp[mop_cases, PULL_EXISTS] >> goal_assum $ drule_at Any >> irule_at Any integerTheory.INT_LT_REFL >> simp[Once exp_rel_cases, monad_cns_def] @@ -2981,7 +2978,7 @@ Theorem pure_to_thunk_next_action': cont_rel c d ∧ state_rel s t ⇒ next_action' v c s ≠ Err ⇒ - next_rel (next_action' v c s) (next_action w d t) + next_rel (next_action' v c s) (next_action_delayed w d t) Proof rw[] >> `∀k. next' k v c s ≠ Err` by ( @@ -2992,39 +2989,19 @@ Proof qpat_x_assum `next_action' _ _ _ ≠ Err` mp_tac >> simp[next_action'_def] >> DEEP_INTRO_TAC some_intro >> reverse $ rw[] >- ( - rw[thunk_semanticsTheory.next_action_def] >> DEEP_INTRO_TAC some_intro >> rw[] >> + rw[next_action_delayed_def] >> + DEEP_INTRO_TAC some_intro >> rw[] >> `next' x v c s ≠ Err` by simp[] >> drule_all_then assume_tac pure_to_thunk_next >> gvs[] >> - drule next_less_eq >> disch_then $ qspec_then `ck + x` mp_tac >> gvs[] + drule next_delayed_less_eq >> disch_then $ qspec_then `ck + x` mp_tac >> + gvs[] ) >> `next' x v c s ≠ Err` by simp[] >> drule_all_then assume_tac pure_to_thunk_next >> gvs[] >> - simp[next_action_def] >> DEEP_INTRO_TAC some_intro >> rw[] >> gvs[] >> - drule next_next >> disch_then $ qspec_then `ck + x` assume_tac >> - Cases_on `next' x v c s` >> Cases_on `next (ck + x) w d t` >> gvs[] -QED - -Triviality interp_action_return: - interp (INR (Monadic Ret [Lit (Str y)])) - (BC (Lam "v" (Monad Ret [Delay (Var "v")])) cont) st = - interp (INR (Monadic Ret [Delay $ Value $ Atom $ Str y])) cont st -Proof - simp[Once interp_def, thunk_semanticsTheory.next_action_def] >> - DEEP_INTRO_TAC some_intro >> reverse $ rw[] - >- ( - pop_assum $ qspec_then `SUC n` $ assume_tac o GEN_ALL >> - gvs[Once thunk_semanticsTheory.next_def] >> - gvs[apply_closure_def, with_value_def, dest_anyClosure_def, subst1_def] >> - simp[Once interp_def, thunk_semanticsTheory.next_action_def] - ) - >- ( - Cases_on `x` >> gvs[Once thunk_semanticsTheory.next_def] >> - simp[Once thunk_semanticsTheory.next_def] >> - gvs[apply_closure_def, with_value_def, dest_anyClosure_def, subst1_def] >> - simp[SimpRHS, Once interp_def, thunk_semanticsTheory.next_action_def] >> - DEEP_INTRO_TAC some_intro >> rw[] >> gvs[] >> - dxrule_all next_next >> rw[] - ) + simp[next_action_delayed_def] >> DEEP_INTRO_TAC some_intro >> rw[] >> gvs[] >> + drule next_delayed_next_delayed >> + disch_then $ qspec_then `ck + x` assume_tac >> + Cases_on `next' x v c s` >> Cases_on `next_delayed (ck + x) w d t` >> gvs[] QED Theorem pure_to_thunk_interp_alt[local]: @@ -3032,7 +3009,7 @@ Theorem pure_to_thunk_interp_alt[local]: cont_rel c d ∧ state_rel s t ∧ safe_itree (interp_alt v c s) ⇒ - interp_alt v c s = interp w d t + interp_alt v c s = interp_delayed w d t Proof rw [Once itreeTheory.itree_bisimulation] \\ qexists_tac ‘ @@ -3041,7 +3018,7 @@ Proof (t1 = t2 ∨ ∃v c s w d t. t1 = interp_alt v c s ∧ - t2 = interp w d t ∧ + t2 = interp_delayed w d t ∧ interp_alt v c s ≠ Ret Error ∧ v_rel v w ∧ cont_rel c d ∧ state_rel s t)’ @@ -3059,9 +3036,9 @@ Proof \\ rw [Once interp_alt_def]) \\ drule_all_then assume_tac pure_to_thunk_next_action' \\ qpat_x_assum ‘Ret _ = _’ mp_tac - \\ once_rewrite_tac [thunk_semanticsTheory.interp_def, interp_alt_def] + \\ once_rewrite_tac [interp_delayed_def, interp_alt_def] \\ Cases_on ‘next_action' v' c' s'’ - \\ Cases_on ‘next_action w' d' t''’ \\ gvs []) + \\ Cases_on ‘next_action_delayed w' d' t''’ \\ gvs []) >- ( ‘next_action' v' c' s' ≠ Err’ by (strip_tac @@ -3069,9 +3046,9 @@ Proof \\ rw [Once interp_alt_def]) \\ drule_all_then assume_tac pure_to_thunk_next_action' \\ qpat_x_assum ‘_ = Div’ mp_tac - \\ once_rewrite_tac [thunk_semanticsTheory.interp_def, interp_alt_def] + \\ once_rewrite_tac [interp_delayed_def, interp_alt_def] \\ Cases_on ‘next_action' v' c' s'’ - \\ Cases_on ‘next_action w' d' t''’ \\ gvs []) + \\ Cases_on ‘next_action_delayed w' d' t''’ \\ gvs []) >- ( rgs [Once safe_itree_cases]) \\ ‘next_action' v' c' s' ≠ Err’ @@ -3080,14 +3057,13 @@ Proof \\ rw [Once interp_alt_def]) \\ drule_all_then assume_tac pure_to_thunk_next_action' \\ qpat_x_assum ‘Vis _ _ = _’ mp_tac - \\ rw [Once interp_alt_def, Once thunk_semanticsTheory.interp_def] + \\ rw [Once interp_alt_def, Once interp_delayed_def] \\ Cases_on ‘next_action' v' c' s'’ - \\ Cases_on ‘next_action w' d' t''’ \\ gvs [] + \\ Cases_on ‘next_action_delayed w' d' t''’ \\ gvs [] \\ rgs [Once safe_itree_cases] \\ rw [] \\ CASE_TAC \\ gs [] \\ rw [] \\ disj2_tac \\ irule_at Any EQ_REFL - \\ simp[interp_action_return] \\ irule_at Any EQ_REFL \\ gvs[mop_cases] \\ simp[Once exp_rel_cases] \\ first_x_assum (qspec_then ‘INR y’ assume_tac) \\ rgs [Once safe_itree_cases] @@ -3098,7 +3074,7 @@ Theorem pure_to_thunk_interp[local]: tcont_rel c0 c ∧ cont_rel c d ∧ tstate_rel s0 s ∧ state_rel s t ∧ safe_itree (interp v0 c0 s0) ⇒ - interp v0 c0 s0 = interp w d t + interp v0 c0 s0 = interp_delayed w d t Proof rw [] \\ drule_all_then assume_tac interp_alt_thm \\ gs [] @@ -3122,12 +3098,11 @@ Theorem pure_to_thunk_semantics: tick_rel x0 x ∧ exp_rel x y ∧ closed x0 ∧ safe_itree (semantics x0 Done []) ⇒ - semantics x0 Done [] = semantics y Done [] + semantics x0 Done [] = semantics_delayed y Done [] Proof strip_tac \\ drule_then assume_tac semantics_fail - \\ gs [pure_semanticsTheory.semantics_def, - thunk_semanticsTheory.semantics_def] + \\ gs [pure_semanticsTheory.semantics_def, semantics_delayed_def] \\ irule pure_to_thunk_interp \\ gs [] \\ simp [state_rel_def, tstate_rel_def] \\ irule_at Any tick_rel_eval_wh @@ -3186,28 +3161,16 @@ Inductive compile_rel: (∀n mop idopt xs ys. mop_delay_rel n mop idopt ∧ (∀idx. idopt = SOME idx ⇒ idx < LENGTH xs) ∧ LIST_REL compile_rel xs ys ⇒ - compile_rel (Cons n xs) - (Monad Bind [ - Monad mop (opt_delay_arg idopt ys); - Lam "v" $ Monad Ret [Delay $ Var "v"] - ])) + compile_rel (Cons n xs) (Monad mop (opt_delay_arg idopt ys))) [~Deref:] (∀xs ys. LIST_REL compile_rel xs ys ⇒ - compile_rel (Cons "Deref" xs) - (Monad Handle [ - Monad Deref ys; - Lam "v" $ Monad Raise [Delay $ Var "v"]])) + compile_rel (Cons "Deref" xs) (Monad Deref ys)) [~Update:] (∀xs ys. LIST_REL compile_rel xs ys ∧ 2 < LENGTH xs ⇒ compile_rel (Cons "Update" xs) - (Monad Bind [ - Monad Handle [ - Monad Update (opt_delay_arg (SOME 2n) ys); - Lam "v" $ Monad Raise [Delay $ Var "v"]]; - Lam "v" $ Monad Ret [Delay $ Var "v"] - ])) + (Monad Update (opt_delay_arg (SOME 2n) ys))) [~Proj:] (∀s i xs ys. LIST_REL compile_rel xs ys ∧ s ∉ monad_cns ⇒ @@ -3362,7 +3325,7 @@ Theorem compile_semantics: compile_rel x y ∧ closed x ∧ safe_itree (semantics x Done []) ⇒ - semantics x Done [] = semantics y Done [] + semantics x Done [] = semantics_delayed y Done [] Proof strip_tac \\ drule_then strip_assume_tac compile_rel_thm diff --git a/compiler/backend/passes/proofs/pure_to_thunk_2ProofScript.sml b/compiler/backend/passes/proofs/pure_to_thunk_2ProofScript.sml index d098cc78..1f8ee751 100644 --- a/compiler/backend/passes/proofs/pure_to_thunk_2ProofScript.sml +++ b/compiler/backend/passes/proofs/pure_to_thunk_2ProofScript.sml @@ -115,32 +115,42 @@ Inductive exp_rel: End Overload to_thunk = “pure_to_thunk_1Proof$compile_rel” +Overload delay_force = “thunk_unthunkProof$delay_force” +Overload undelay = “thunk_undelay_nextProof$exp_rel” Overload lift_rel = “thunk_case_liftProof$compile_rel” Overload force_rel = “thunk_let_forceProof$exp_rel” Overload proj_rel = “thunk_case_projProof$compile_rel” -Overload delay_force = “thunk_unthunkProof$delay_force” Overload VV[local] = “thunk_let_forceProof$Var” val to_thunk_freevars = pure_to_thunk_1ProofTheory.compile_rel_freevars; +Theorem to_thunk_cases[local] = Once pure_to_thunk_1ProofTheory.compile_rel_cases; +Theorem delay_force_cases[local] = Once thunk_unthunkProofTheory.delay_force_cases; +Theorem undelay_cases[local] = Once thunk_undelay_nextProofTheory.exp_rel_cases; +Theorem lift_cases[local] = Once thunk_case_liftProofTheory.compile_rel_cases; +Theorem force_cases[local] = Once thunk_let_forceProofTheory.exp_rel_cases; +Theorem proj_cases[local] = Once thunk_case_projProofTheory.compile_rel_cases; + Theorem lets_for_lemma[local]: ∀vs k. to_thunk (exp_of' h2) y1 ∧ - lift_rel y1 y2 ∧ - force_rel NONE y2 y3 ∧ - proj_rel y3 y4 ∧ - delay_force y4 (exp_of yy2) ∧ + delay_force y1 y2 ∧ + undelay y2 y3 ∧ + lift_rel y3 y4 ∧ + force_rel NONE y4 y5 ∧ + proj_rel y5 (exp_of yy2) ∧ ~MEM fresh vs ∧ ~MEM h vs ∧ fresh ≠ h ∧ cn ∉ monad_cns ∧ fresh ∉ freevars (exp_of' h2) ⇒ - ∃x1 x2 x3 x4. + ∃x1 x2 x3 x4 x5. to_thunk (lets_for' (k + LENGTH vs) cn h (MAPi (λx v. (x+k,v)) vs) (exp_of' h2)) x1 ∧ - lift_rel x1 x2 ∧ fresh ∉ freevars x1 ∧ - force_rel (SOME (VV h,fresh)) x2 x3 ∧ - proj_rel x3 x4 ∧ - delay_force x4 + delay_force x1 x2 ∧ + undelay x2 x3 ∧ + lift_rel x3 x4 ∧ fresh ∉ freevars x3 ∧ + force_rel (SOME (VV h,fresh)) x4 x5 ∧ + proj_rel x5 (lets_for (k + LENGTH vs) cn fresh (MAPi (λx v. (x+k,v)) vs) (exp_of yy2)) Proof @@ -148,53 +158,40 @@ Proof \\ fs [lets_for_def,lets_for'_def] >- (rw [] \\ imp_res_tac to_thunk_freevars - \\ rpt $ first_x_assum $ irule_at Any \\ fs [] - \\ irule thunk_let_forceProofTheory.exp_rel_NONE_IMP_SOME \\ fs []) + \\ rpt $ first_assum $ irule_at Any \\ fs [] + \\ irule_at Any thunk_let_forceProofTheory.exp_rel_NONE_IMP_SOME \\ fs [] + \\ imp_res_tac thunk_unthunkProofTheory.delay_force_freevars \\ fs [] + \\ imp_res_tac thunk_undelay_nextProofTheory.exp_rel_freevars \\ fs []) \\ rw [] \\ gvs [] \\ irule_at Any pure_to_thunk_1ProofTheory.compile_rel_Seq \\ fs [] - \\ simp [Once pure_to_thunk_1ProofTheory.compile_rel_cases, PULL_EXISTS] - \\ simp [Once pure_to_thunk_1ProofTheory.compile_rel_cases, PULL_EXISTS] - \\ simp [Once pure_to_thunk_1ProofTheory.compile_rel_cases, PULL_EXISTS] - \\ simp [Once pure_to_thunk_1ProofTheory.compile_rel_cases, PULL_EXISTS] - \\ simp[pure_configTheory.monad_cns_def, - mop_rel_cases, mop_ret_rel_cases, mop_delay_rel_cases] - \\ simp [Once pure_to_thunk_1ProofTheory.compile_rel_cases, PULL_EXISTS] + \\ ntac 4 (simp [to_thunk_cases, PULL_EXISTS]) + \\ simp[pure_configTheory.monad_cns_def, mop_rel_cases, mop_ret_rel_cases, + mop_delay_rel_cases] + \\ simp [to_thunk_cases, PULL_EXISTS] \\ irule_at Any pure_to_thunk_1ProofTheory.compile_rel_Let \\ irule_at Any pure_to_thunk_1ProofTheory.compile_rel_Proj \\ fs [PULL_EXISTS] - \\ irule_at Any pure_to_thunk_1ProofTheory.compile_rel_Var + \\ simp [to_thunk_cases, PULL_EXISTS] \\ irule_at Any thunk_case_projProofTheory.compile_rel_Proj \\ fs [] \\ fs [o_DEF,freevars_def] \\ last_x_assum $ qspec_then ‘SUC k’ mp_tac \\ fs [ADD_CLAUSES] \\ rw [] - \\ rpt $ first_x_assum $ irule_at Any - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Let - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_If \\ fs [] - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Prim \\ fs [PULL_EXISTS] - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Prim \\ fs [PULL_EXISTS] - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Prim \\ fs [PULL_EXISTS] - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Force - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Var - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Let - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Delay - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Force - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Prim \\ fs [PULL_EXISTS] - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Force - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Var - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Let - \\ irule_at Any thunk_unthunkProofTheory.delay_force_If \\ fs [] - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Prim \\ fs [] - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Prim \\ fs [] - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Var \\ fs [] - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Prim \\ fs [] + \\ ntac 2 (goal_assum drule) + \\ ntac 7 (simp [delay_force_cases, PULL_EXISTS]) \\ irule_at Any thunk_unthunkProofTheory.delay_force_Let - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Prim \\ fs [] - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Var \\ fs [] - \\ rpt $ first_x_assum $ irule_at Any - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Let + \\ ntac 5 (simp [delay_force_cases, PULL_EXISTS]) + \\ ntac 5 (simp [undelay_cases, PULL_EXISTS]) + \\ irule_at Any thunk_undelay_nextProofTheory.exp_rel_Prim \\ fs [] + \\ ntac 7 (simp [undelay_cases, PULL_EXISTS]) + \\ simp [lift_cases, PULL_EXISTS] + \\ irule_at Any thunk_case_liftProofTheory.compile_rel_If \\ fs [] + \\ ntac 11 (simp [lift_cases, PULL_EXISTS]) + \\ fs [freevars_def] + \\ simp [force_cases, PULL_EXISTS] \\ fs [name_clash_def] - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Let + \\ ntac 6 (simp [force_cases, PULL_EXISTS]) \\ fs [name_clash_def] - \\ rpt $ simp [Once thunk_let_forceProofTheory.exp_rel_cases] + \\ ntac 4 (simp [force_cases, PULL_EXISTS]) + \\ rpt $ goal_assum drule QED Triviality MEM_EQ_MEM_MAP_explode: @@ -218,6 +215,20 @@ Proof \\ simp[pure_configTheory.monad_cns_def] QED +Theorem delay_force_Disj: + ∀xs v. delay_force (Disj' (Force (Var v)) xs) (Disj' (Force (Var v)) xs) +Proof + Induct \\ fs [pureLangTheory.Disj_def, FORALL_PROD, Disj'_def] \\ rw [] + \\ rpt (simp [Once thunk_unthunkProofTheory.delay_force_cases]) +QED + +Theorem undelay_Disj: + ∀xs v. undelay (Disj' (Force (Var v)) xs) (Disj' (Force (Var v)) xs) +Proof + Induct \\ fs [pureLangTheory.Disj_def, FORALL_PROD, Disj'_def] \\ rw [] + \\ rpt (simp [Once thunk_undelay_nextProofTheory.exp_rel_cases]) +QED + Theorem lift_rel_Disj: ∀xs v. lift_rel (Disj' (Force (Var v)) xs) (Disj' (Force (Var v)) xs) Proof @@ -237,20 +248,10 @@ Theorem proj_rel_Disj: Proof Induct \\ fs [Disj_def,FORALL_PROD] \\ rw [] \\ rpt (irule_at Any thunk_case_projProofTheory.compile_rel_If \\ fs []) - \\ rpt (irule_at Any thunk_case_projProofTheory.compile_rel_Cons \\ fs []) \\ rpt (irule_at Any thunk_case_projProofTheory.compile_rel_Prim \\ fs []) \\ rpt (irule_at Any thunk_case_projProofTheory.compile_rel_Var \\ fs []) QED -Theorem delay_force_Disj: - ∀xs v. delay_force (Disj v xs) (Disj v xs) -Proof - Induct \\ fs [Disj_def,FORALL_PROD] \\ rw [] - \\ rpt (irule_at Any thunk_unthunkProofTheory.delay_force_If \\ fs []) - \\ rpt (irule_at Any thunk_unthunkProofTheory.delay_force_Prim \\ fs []) - \\ rpt (irule_at Any thunk_unthunkProofTheory.delay_force_Var \\ fs []) -QED - Triviality freevars_Disj': ∀xs. f ≠ v ⇒ f ∉ freevars (Disj' (Force (Var v)) xs) Proof @@ -258,68 +259,57 @@ Proof \\ fs [freevars_def] QED -Theorem to_thunk_cases[local] = Once pure_to_thunk_1ProofTheory.compile_rel_cases; -Theorem lift_cases[local] = Once thunk_case_liftProofTheory.compile_rel_cases; -Theorem force_cases[local] = Once thunk_let_forceProofTheory.exp_rel_cases; -Theorem proj_cases[local] = Once thunk_case_projProofTheory.compile_rel_cases; -Theorem delay_force_cases[local] = Once thunk_unthunkProofTheory.delay_force_cases; - Theorem exp_rel_imp_combined: ∀x y. exp_rel x y ∧ cexp_wf x ⇒ - ∃y1 y2 y3 y4. + ∃y1 y2 y3 y4 y5. to_thunk (exp_of' x) y1 ∧ - lift_rel y1 y2 ∧ - force_rel NONE y2 y3 ∧ - proj_rel y3 y4 ∧ - delay_force y4 (exp_of y) + delay_force y1 y2 ∧ + undelay y2 y3 ∧ + lift_rel y3 y4 ∧ + force_rel NONE y4 y5 ∧ + proj_rel y5 (exp_of y) Proof Induct_on ‘exp_rel’ - \\ rw [exp_of'_def,pure_cexpTheory.cexp_wf_def] \\ fs [pure_cexpTheory.op_of_def] - >~ [‘Var n’] >- - (simp [Once pure_to_thunk_1ProofTheory.compile_rel_cases] - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Force - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Var - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Force - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Var - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Force - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Var + \\ rw [exp_of'_def,pure_cexpTheory.cexp_wf_def] + \\ fs [pure_cexpTheory.op_of_def] + >~ [‘Var n’] >- ( + ntac 2 (simp [to_thunk_cases, delay_force_cases, undelay_cases, lift_cases, + force_cases, proj_cases, PULL_EXISTS])) + >~ [‘rows_of'’] >- ( + ntac 2 (irule_at Any thunk_case_projProofTheory.compile_rel_Let_SOME) \\ irule_at Any thunk_case_projProofTheory.compile_rel_Force - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Var) - >~ [‘rows_of'’] >- - (irule_at Any thunk_case_projProofTheory.compile_rel_Let_SOME - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Let - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Let - \\ fs [name_clash_def] - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Let - \\ simp [Once pure_to_thunk_1ProofTheory.compile_rel_cases,PULL_EXISTS] + \\ irule_at Any thunk_case_projProofTheory.compile_rel_Var + \\ irule_at Any pure_to_thunk_1ProofTheory.compile_rel_Let \\ irule_at Any thunk_unthunkProofTheory.delay_force_Let - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Force - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Var - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Delay - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Delay - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Delay - \\ gvs [PULL_EXISTS] - \\ ‘∃q1 q2 q3 q4. + \\ irule_at Any thunk_undelay_nextProofTheory.exp_rel_Let + \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Let + \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Let + \\ gvs [name_clash_def, PULL_EXISTS] + \\ `∃q1 q2 q3 q4 q5. to_thunk (exp_of' x) q1 ∧ - lift_rel q1 q2 ∧ - force_rel NONE q2 q3 ∧ - proj_rel q3 q4 ∧ - delay_force (Delay q4) (exp_of a_exp)’ by - (qpat_x_assum ‘(∀c z. x = Var c z ⇒ a_exp ≠ Var z) ⇒ _’ mp_tac + delay_force (Delay q1) q2 ∧ + undelay q2 q3 ∧ + lift_rel q3 q4 ∧ + force_rel NONE q4 q5 ∧ + proj_rel q5 (exp_of a_exp)` by ( + qpat_x_assum ‘(∀c z. x = Var c z ⇒ a_exp ≠ Var z) ⇒ _’ mp_tac \\ disch_then (assume_tac o ONCE_REWRITE_RULE [IMP_DISJ_THM]) \\ reverse $ gvs [] - >- metis_tac [delay_force_Delay] + >- ( + rpt $ goal_assum drule + \\ irule_at (Pos hd) thunk_unthunkProofTheory.delay_force_Delay + \\ simp [undelay_cases, lift_cases, force_cases, proj_cases, + PULL_EXISTS] + \\ rpt $ goal_assum drule) \\ fs [exp_of'_def] - \\irule_at Any pure_to_thunk_1ProofTheory.compile_rel_Var - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Force - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Force - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Force - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Var - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Var - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Var - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Delat_Force_Var) + \\ simp [to_thunk_cases, proj_cases, PULL_EXISTS] + \\ irule_at (Pos hd) thunk_unthunkProofTheory.delay_force_Delat_Force_Var + \\ simp [undelay_cases, lift_cases, force_cases, proj_cases, + PULL_EXISTS]) \\ qpat_x_assum ‘to_thunk (exp_of' x) _’ $ irule_at Any + \\ qpat_x_assum ‘delay_force _ _’ $ irule_at Any + \\ qpat_x_assum ‘undelay _ _’ $ irule_at Any \\ qpat_x_assum ‘lift_rel _ _’ $ irule_at Any \\ qpat_x_assum ‘force_rel NONE _ _’ $ irule_at Any \\ qpat_x_assum ‘proj_rel _ _’ $ irule_at Any \\ fs [] @@ -328,28 +318,20 @@ Proof \\ PairCases_on ‘h’ \\ fs [] \\ rename [‘_ = yy :: _’] \\ PairCases_on ‘yy’ \\ gvs [rows_of'_def] - \\ simp [Once pure_to_thunk_1ProofTheory.compile_rel_cases,PULL_EXISTS] - \\ simp [Once pure_to_thunk_1ProofTheory.compile_rel_cases,PULL_EXISTS] - \\ simp [Once pure_to_thunk_1ProofTheory.compile_rel_cases,PULL_EXISTS] + \\ ntac 3 (simp [to_thunk_cases,PULL_EXISTS]) + \\ ntac 4 (simp [delay_force_cases, PULL_EXISTS]) + \\ ntac 4 (simp [undelay_cases, PULL_EXISTS]) \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Lift \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Force \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Var - \\ fs [freevars_def] - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Let_SOME - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Force - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Var + \\ gvs [freevars_def] \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Let_Force_Var - \\ fs [] - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_If \\ fs [] - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Prim \\ fs [PULL_EXISTS] + \\ gvs [] + \\ ntac 2 (simp [force_cases, PULL_EXISTS]) \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Force_Var + \\ gvs [] + \\ ntac 3 (simp [proj_cases, PULL_EXISTS]) \\ fs [rows_of_def] - \\ irule_at Any thunk_case_projProofTheory.compile_rel_If \\ fs [] - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Prim \\ fs [] - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Var \\ fs [] - \\ irule_at Any thunk_unthunkProofTheory.delay_force_If \\ fs [] - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Prim \\ fs [] - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Var \\ fs [] \\ drule lets_for_lemma \\ rpt $ disch_then drule \\ ‘¬MEM (explode fresh) (MAP explode h1)’ by fs [MEM_EQ_MEM_MAP_explode] @@ -372,111 +354,94 @@ Proof (fs [rows_of_def,rows_of'_def] \\ Cases_on ‘yopt’ \\ fs [] \\ Cases_on ‘eopt’ \\ gvs [] - >- - (irule_at Any thunk_unthunkProofTheory.delay_force_Prim \\ fs [] - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Prim \\ fs [] - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Prim \\ fs [] - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Prim \\ fs [] - \\ simp [Once pure_to_thunk_1ProofTheory.compile_rel_cases, freevars_def]) + >- simp [proj_cases, to_thunk_cases, delay_force_cases, undelay_cases, + lift_cases, force_cases, freevars_def, PULL_EXISTS] \\ PairCases_on ‘x'’ \\ PairCases_on ‘x''’ \\ gvs [] \\ fs [IfDisj_def] - \\ irule_at Any thunk_unthunkProofTheory.delay_force_If \\ fs [] \\ irule_at Any thunk_case_projProofTheory.compile_rel_If \\ fs [] \\ irule_at Any thunk_let_forceProofTheory.exp_rel_If \\ fs [] \\ irule_at Any thunk_case_liftProofTheory.compile_rel_If \\ fs [] + \\ irule_at Any thunk_undelay_nextProofTheory.exp_rel_If \\ fs [] + \\ irule_at Any thunk_unthunkProofTheory.delay_force_If \\ fs [] \\ irule_at Any pure_to_thunk_1ProofTheory.compile_rel_If \\ fs [] \\ irule_at Any to_thunk_Disj \\ first_assum $ irule_at $ Pos hd \\ irule_at Any pure_to_thunk_1ProofTheory.compile_rel_Prim \\ fs [] + \\ irule_at Any delay_force_Disj + \\ irule_at Any undelay_Disj \\ irule_at Any lift_rel_Disj - \\ first_assum $ irule_at $ Pos hd - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Prim \\ fs [] \\ irule_at Any force_rel_Disj - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_NONE_IMP_SOME - \\ first_assum $ irule_at $ Pos hd - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Prim \\ fs [] \\ irule_at Any proj_rel_Disj - \\ fs [freevars_def,SF DNF_ss] - \\ first_assum $ irule_at $ Pos hd - \\ fs [] \\ imp_res_tac to_thunk_freevars \\ fs [] - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Prim \\ fs [] + \\ fs [freevars_def] \\ irule_at Any freevars_Disj' \\ fs [] - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Prim \\ fs [] - \\ irule_at Any delay_force_Disj) + \\ goal_assum drule \\ simp [delay_force_cases] + \\ goal_assum drule \\ simp [undelay_cases] + \\ goal_assum drule \\ simp [lift_cases] + \\ irule_at Any thunk_let_forceProofTheory.exp_rel_NONE_IMP_SOME + \\ goal_assum drule \\ simp [force_cases, proj_cases] + \\ simp [freevars_def] + \\ imp_res_tac to_thunk_freevars \\ fs [] + \\ imp_res_tac thunk_unthunkProofTheory.delay_force_freevars \\ fs [] + \\ imp_res_tac thunk_undelay_nextProofTheory.exp_rel_freevars \\ fs []) \\ fs [FORALL_PROD] \\ rw [] \\ gvs [] \\ first_x_assum dxrule \\ strip_tac \\ fs [rows_of_def,rows_of'_def] - \\ simp [Once pure_to_thunk_1ProofTheory.compile_rel_cases,PULL_EXISTS] - \\ simp [Once pure_to_thunk_1ProofTheory.compile_rel_cases,PULL_EXISTS] - \\ simp [Once pure_to_thunk_1ProofTheory.compile_rel_cases,PULL_EXISTS] + \\ ntac 3 (simp [to_thunk_cases, PULL_EXISTS]) \\ fs [freevars_def] \\ qpat_x_assum ‘to_thunk _ _’ $ irule_at Any - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_If \\ fs [PULL_EXISTS] - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Prim \\ fs [PULL_EXISTS] - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Force - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Var - \\ irule_at Any thunk_unthunkProofTheory.delay_force_If \\ fs [PULL_EXISTS] - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Prim \\ fs [PULL_EXISTS] - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Var - \\ irule_at Any thunk_case_projProofTheory.compile_rel_If \\ fs [PULL_EXISTS] - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Prim \\ fs [PULL_EXISTS] - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Var - \\ simp [Once thunk_let_forceProofTheory.exp_rel_cases] - \\ simp [Once thunk_let_forceProofTheory.exp_rel_cases] - \\ simp [Once thunk_let_forceProofTheory.exp_rel_cases] + \\ ntac 4 (simp [delay_force_cases, PULL_EXISTS]) + \\ ntac 4 (simp [undelay_cases, PULL_EXISTS]) + \\ fs [freevars_def] + \\ irule_at Any thunk_case_liftProofTheory.compile_rel_If + \\ fs [PULL_EXISTS] + \\ ntac 3 (simp [lift_cases, PULL_EXISTS]) + \\ ntac 2 (simp [force_cases, PULL_EXISTS]) + \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Force_Var + \\ ntac 3 (simp [proj_cases, PULL_EXISTS]) \\ drule lets_for_lemma - \\ ntac 4 $ disch_then drule + \\ ntac 5 (disch_then drule) \\ disch_then $ drule_at $ Pos last \\ rename [‘lets_for' (LENGTH cs) (explode cn)’] \\ disch_then $ qspecl_then [‘explode v’, ‘explode cn’,‘MAP explode cs’,‘0’] mp_tac \\ impl_tac >- fs [GSYM MEM_EQ_MEM_MAP_explode] \\ fs [] \\ strip_tac - \\ rpt $ pop_assum $ irule_at Any - \\ first_assum $ irule_at Any - \\ first_assum $ irule_at Any - \\ fs []) - >~ [‘Seq’] >- - (fs [pure_cexpTheory.op_of_def] - \\ irule_at Any pure_to_thunk_1ProofTheory.compile_rel_Seq_fresh \\ fs [] - \\ qpat_x_assum ‘explode fresh ∉ _’ $ irule_at Any - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Let - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Let - \\ fs [name_clash_def] - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Let_SOME - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Let - \\ metis_tac []) - >~ [‘Let’] >- - (irule_at Any pure_to_thunk_1ProofTheory.compile_rel_Let - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Let - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Let - \\ fs [name_clash_def] - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Let_SOME + \\ rpt $ pop_assum $ irule_at Any) + >~ [‘Seq’] >- ( + fs [pure_cexpTheory.op_of_def] + \\ irule_at Any pure_to_thunk_1ProofTheory.compile_rel_Seq_fresh \\ fs [] + \\ rpt $ goal_assum drule + \\ irule_at Any thunk_unthunkProofTheory.delay_force_Let_fresh + \\ rpt $ goal_assum drule + \\ imp_res_tac pure_to_thunk_1ProofTheory.compile_rel_freevars \\ gvs [] + \\ simp [undelay_cases, lift_cases, proj_cases, PULL_EXISTS] + \\ rpt $ goal_assum drule + \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Let \\ fs [] + \\ rpt $ goal_assum drule) + >~ [‘Let’] >- ( + irule_at Any pure_to_thunk_1ProofTheory.compile_rel_Let + \\ rpt $ goal_assum drule \\ irule_at Any thunk_unthunkProofTheory.delay_force_Let - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Delay - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Delay - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Delay - \\ gvs [IMP_DISJ_THM,exp_of'_def] - >- - (irule_at Any pure_to_thunk_1ProofTheory.compile_rel_Var - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Force - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Force - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Force - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Var - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Var - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Var + \\ simp [undelay_cases, lift_cases, proj_cases, PULL_EXISTS] + \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Let \\ simp [] + \\ gvs [IMP_DISJ_THM, exp_of'_def] + >- ( + simp [to_thunk_cases, PULL_EXISTS] \\ irule_at Any thunk_unthunkProofTheory.delay_force_Delat_Force_Var - \\ metis_tac []) - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Delay + \\ simp [undelay_cases, lift_cases, proj_cases, force_cases, PULL_EXISTS] + \\ rpt $ goal_assum drule) + \\ simp [proj_cases, force_cases, lift_cases, undelay_cases, + delay_force_cases, PULL_EXISTS] \\ metis_tac []) - >~ [‘Cons _ _’] >- - (irule_at Any pure_to_thunk_1ProofTheory.compile_rel_Cons + >~ [‘Cons _ _’] >- ( + irule_at Any pure_to_thunk_1ProofTheory.compile_rel_Cons + \\ irule_at Any thunk_unthunkProofTheory.delay_force_Prim + \\ irule_at Any thunk_undelay_nextProofTheory.exp_rel_Prim \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Prim \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Prim - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Cons - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Prim + \\ irule_at Any thunk_case_projProofTheory.compile_rel_Prim \\ fs [] \\ pop_assum mp_tac \\ pop_assum kall_tac @@ -494,37 +459,29 @@ Proof \\ qpat_x_assum ‘(∀c z. h = Var c z ⇒ h5 ≠ Var z) ⇒ _’ mp_tac \\ disch_then (assume_tac o ONCE_REWRITE_RULE [IMP_DISJ_THM]) \\ reverse $ gvs [] - >- - (qpat_x_assum ‘to_thunk (exp_of' _) _’ $ irule_at Any - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Delay - \\ qpat_x_assum ‘lift_rel y1 _’ $ irule_at Any + >- ( + irule_at Any thunk_case_projProofTheory.compile_rel_Delay \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Delay - \\ qpat_x_assum ‘force_rel NONE y2 _’ $ irule_at Any - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Delay - \\ first_x_assum $ irule_at $ Pos hd - \\ fs [] - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Delay \\ fs []) - \\ fs [cexp_wf_def,SF SFY_ss,exp_of'_def] + \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Delay + \\ irule_at Any thunk_undelay_nextProofTheory.exp_rel_Delay + \\ irule_at Any thunk_unthunkProofTheory.delay_force_Delay + \\ metis_tac []) + \\ gvs [cexp_wf_def, SF SFY_ss, exp_of'_def] \\ irule_at Any pure_to_thunk_1ProofTheory.compile_rel_Var - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Delay - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Force + \\ irule_at Any thunk_unthunkProofTheory.delay_force_Delat_Force_Var + \\ irule_at Any thunk_undelay_nextProofTheory.exp_rel_Var \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Var - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Delay - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Force \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Var - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Delay - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Force - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Var - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Delat_Force_Var - \\ fs []) - >~ [‘Apps’] >- - (pop_assum kall_tac + \\ irule_at Any thunk_case_projProofTheory.compile_rel_Var) + >~ [‘Apps’] >- ( + pop_assum kall_tac \\ rpt $ pop_assum mp_tac \\ qid_spec_tac ‘x’ \\ qid_spec_tac ‘y1’ \\ qid_spec_tac ‘y2’ \\ qid_spec_tac ‘y3’ \\ qid_spec_tac ‘y4’ + \\ qid_spec_tac ‘y5’ \\ qid_spec_tac ‘y’ \\ qid_spec_tac ‘ys’ \\ qid_spec_tac ‘xs’ @@ -546,48 +503,37 @@ Proof \\ disch_then irule \\ irule_at Any pure_to_thunk_1ProofTheory.compile_rel_App \\ qpat_x_assum ‘to_thunk (exp_of' _) _’ $ irule_at Any + \\ irule_at Any thunk_unthunkProofTheory.delay_force_App + \\ irule_at Any thunk_undelay_nextProofTheory.exp_rel_App \\ irule_at Any thunk_case_liftProofTheory.compile_rel_App \\ irule_at Any thunk_let_forceProofTheory.exp_rel_App \\ irule_at Any thunk_case_projProofTheory.compile_rel_App - \\ irule_at Any thunk_unthunkProofTheory.delay_force_App \\ qpat_x_assum ‘LIST_REL _ _ _’ kall_tac \\ qpat_x_assum ‘(∀c z. h = Var c z ⇒ h5 ≠ Var z) ⇒ _’ mp_tac \\ disch_then (assume_tac o ONCE_REWRITE_RULE [IMP_DISJ_THM]) \\ reverse $ gvs [] - >- - (qpat_x_assum ‘to_thunk (exp_of' _) _’ $ irule_at Any - \\ qpat_x_assum ‘lift_rel y1 _’ $ irule_at Any - \\ qpat_x_assum ‘force_rel NONE y2 _’ $ irule_at Any - \\ first_x_assum $ irule_at $ Pos hd - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Delay - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Delay - \\ first_x_assum $ irule_at $ Pos hd - \\ first_x_assum $ irule_at $ Pos hd \\ fs [] - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Delay - \\ first_x_assum $ irule_at $ Pos hd \\ fs [] - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Delay - \\ fs [cexp_wf_def,SF SFY_ss]) - \\ first_x_assum $ irule_at $ Pos hd - \\ fs [cexp_wf_def,SF SFY_ss,exp_of'_def] - \\ qpat_x_assum ‘proj_rel _ y4’ $ irule_at Any - \\ qpat_x_assum ‘lift_rel y1 _’ $ irule_at Any \\ gvs [] - \\ irule_at Any pure_to_thunk_1ProofTheory.compile_rel_Var - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Delay - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Force - \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Var - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Delay - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Force - \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Var - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Delay - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Force - \\ irule_at Any thunk_case_projProofTheory.compile_rel_Var - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Delat_Force_Var) - >~ [‘AtomOp’] >- - (irule_at Any pure_to_thunk_1ProofTheory.compile_rel_Prim \\ fs [] + >- ( + qpat_x_assum ‘to_thunk (exp_of' _) _’ $ irule_at Any + \\ goal_assum drule \\ simp [proj_cases, PULL_EXISTS] + \\ ntac 2 (goal_assum drule) \\ simp [force_cases, PULL_EXISTS] + \\ ntac 2 (goal_assum drule) \\ simp [lift_cases, PULL_EXISTS] + \\ ntac 2 (goal_assum drule) \\ simp [undelay_cases, PULL_EXISTS] + \\ goal_assum drule \\ simp [delay_force_cases, PULL_EXISTS] + \\ fs [cexp_wf_def]) + \\ goal_assum drule \\ simp [proj_cases, PULL_EXISTS] + \\ goal_assum drule \\ simp [force_cases, PULL_EXISTS] + \\ goal_assum drule \\ simp [lift_cases, PULL_EXISTS] + \\ goal_assum drule \\ simp [undelay_cases, PULL_EXISTS] + \\ simp [delay_force_cases, PULL_EXISTS] + \\ simp [exp_of'_def, to_thunk_cases, PULL_EXISTS] + \\ simp [cexp_wf_def]) + >~ [‘AtomOp’] >- ( + irule_at Any pure_to_thunk_1ProofTheory.compile_rel_Prim \\ fs [] + \\ irule_at Any thunk_unthunkProofTheory.delay_force_Prim + \\ irule_at Any thunk_undelay_nextProofTheory.exp_rel_Prim \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Prim \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Prim \\ irule_at Any thunk_case_projProofTheory.compile_rel_Prim \\ fs [] - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Prim \\ fs [] \\ pop_assum kall_tac \\ pop_assum kall_tac \\ pop_assum mp_tac @@ -599,22 +545,24 @@ Proof \\ rw [] \\ gvs [] \\ last_x_assum drule \\ strip_tac \\ rpt $ first_assum $ irule_at Any) - >~ [‘Lams’] >- - (qpat_x_assum ‘_ ≠ []’ kall_tac + >~ [‘Lams’] >- ( + qpat_x_assum ‘_ ≠ []’ kall_tac \\ qid_spec_tac ‘s’ \\ Induct \\ fs [pure_expTheory.Lams_def] >- (rpt $ first_assum $ irule_at Any) \\ rw [] \\ irule_at Any pure_to_thunk_1ProofTheory.compile_rel_Lam \\ fs [] - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Lam \\ fs [] + \\ irule_at Any thunk_unthunkProofTheory.delay_force_Lam + \\ irule_at Any thunk_undelay_nextProofTheory.exp_rel_Lam \\ irule_at Any thunk_case_projProofTheory.compile_rel_Lam \\ fs [] \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Lam \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Lam \\ fs [] \\ rpt $ first_assum $ irule_at Any) - >~ [‘Letrec’] >- - (qpat_x_assum ‘_ ≠ []’ kall_tac + >~ [‘Letrec’] >- ( + qpat_x_assum ‘_ ≠ []’ kall_tac \\ irule_at Any pure_to_thunk_1ProofTheory.compile_rel_Letrec \\ fs [] + \\ irule_at Any thunk_unthunkProofTheory.delay_force_Letrec + \\ irule_at Any thunk_undelay_nextProofTheory.exp_rel_Letrec \\ irule_at Any thunk_case_projProofTheory.compile_rel_Letrec \\ fs [] - \\ irule_at Any thunk_unthunkProofTheory.delay_force_Letrec \\ fs [] \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Letrec \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Letrec \\ fs [] \\ rpt $ first_assum $ irule_at Any @@ -634,129 +582,160 @@ Proof \\ gvs [] \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Delay \\ irule_at Any thunk_unthunkProofTheory.delay_force_Delay + \\ irule_at Any thunk_undelay_nextProofTheory.exp_rel_Delay \\ irule_at Any thunk_case_projProofTheory.compile_rel_Delay \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Delay \\ rpt $ first_assum $ irule_at Any - \\ EVAL_TAC \\ fs []) >> - gvs[num_args_ok_def, pure_configTheory.num_monad_args_def] >> - gvs[LENGTH_EQ_NUM_compute] >> - simp[to_thunk_cases, PULL_EXISTS, pure_configTheory.monad_cns_def, - mop_rel_cases, mop_ret_rel_cases, mop_delay_rel_cases] - >~ [`Ret`] - >- ( - simp[lift_cases, force_cases, proj_cases, delay_force_cases, PULL_EXISTS] >> - last_x_assum $ mp_tac o ONCE_REWRITE_RULE [IMP_DISJ_THM] >> rw[] >> gvs[] + \\ EVAL_TAC \\ fs []) + \\ gvs [num_args_ok_def, pure_configTheory.num_monad_args_def] + \\ gvs[LENGTH_EQ_NUM_compute] + \\ simp[to_thunk_cases, PULL_EXISTS, pure_configTheory.monad_cns_def, + mop_rel_cases, mop_ret_rel_cases, mop_delay_rel_cases] + >~ [`Ret`] >- ( + simp [proj_cases, delay_force_cases, force_cases, undelay_cases, lift_cases, + PULL_EXISTS] + \\ last_x_assum $ mp_tac o ONCE_REWRITE_RULE [IMP_DISJ_THM] \\ rw [] + \\ gvs [] >- ( - simp[exp_of'_def, to_thunk_cases, PULL_EXISTS] >> - ntac 3 $ simp[lift_cases, force_cases, proj_cases, delay_force_cases, PULL_EXISTS] - ) >> - simp[lift_cases, force_cases, proj_cases, delay_force_cases, PULL_EXISTS] >> - rpt $ goal_assum drule - ) - >~ [`Raise`] - >- ( - simp[lift_cases, force_cases, proj_cases, delay_force_cases, PULL_EXISTS] >> - last_x_assum $ mp_tac o ONCE_REWRITE_RULE [IMP_DISJ_THM] >> rw[] >> gvs[] + simp [exp_of'_def, to_thunk_cases, PULL_EXISTS] + \\ irule_at Any thunk_unthunkProofTheory.delay_force_Delat_Force_Var + \\ simp [undelay_cases, lift_cases, proj_cases, force_cases, PULL_EXISTS]) + \\ simp [proj_cases, force_cases, lift_cases, undelay_cases, + delay_force_cases, PULL_EXISTS] + \\ rpt $ goal_assum drule) + >~ [`Raise`] >- ( + simp [proj_cases, delay_force_cases, force_cases, undelay_cases, lift_cases, + PULL_EXISTS] + \\ last_x_assum $ mp_tac o ONCE_REWRITE_RULE [IMP_DISJ_THM] \\ rw [] + \\ gvs [] >- ( - simp[exp_of'_def, to_thunk_cases, PULL_EXISTS] >> - ntac 3 $ simp[lift_cases, force_cases, proj_cases, delay_force_cases, PULL_EXISTS] - ) >> - simp[lift_cases, force_cases, proj_cases, delay_force_cases, PULL_EXISTS] >> - rpt $ goal_assum drule - ) - >~ [`Bind`] - >- ( - simp[lift_cases, force_cases, proj_cases, delay_force_cases, PULL_EXISTS] >> - rpt $ goal_assum drule - ) - >~ [`Handle`] - >- ( - simp[lift_cases, force_cases, proj_cases, delay_force_cases, PULL_EXISTS] >> - rpt $ goal_assum $ drule - ) - >~ [`Act`] - >- ( - simp[lift_cases, force_cases, proj_cases, delay_force_cases, PULL_EXISTS] >> - goal_assum drule >> simp[lift_cases, PULL_EXISTS] >> - goal_assum drule >> ntac 4 $ simp[lift_cases, PULL_EXISTS] >> - simp[force_cases, PULL_EXISTS] >> goal_assum drule >> - ntac 4 $ simp[force_cases, PULL_EXISTS] >> - simp[proj_cases, PULL_EXISTS] >> goal_assum drule >> - ntac 4 $ simp[proj_cases, PULL_EXISTS] >> - ntac 5 $ simp[delay_force_cases] - ) - >~ [`Length`] - >- ( - simp[lift_cases, force_cases, proj_cases, delay_force_cases, PULL_EXISTS] >> - goal_assum drule >> simp[lift_cases, PULL_EXISTS] >> - goal_assum drule >> ntac 4 $ simp[lift_cases, PULL_EXISTS] >> - simp[force_cases, PULL_EXISTS] >> goal_assum drule >> - ntac 4 $ simp[force_cases, PULL_EXISTS] >> - simp[proj_cases, PULL_EXISTS] >> goal_assum drule >> - ntac 4 $ simp[proj_cases, PULL_EXISTS] >> - ntac 5 $ simp[delay_force_cases] - ) - >~ [`Alloc`] (* Delay (Force (Var _)) case *) - >- ( - simp[lift_cases, force_cases, proj_cases, delay_force_cases, PULL_EXISTS] >> - goal_assum drule >> simp[exp_of'_def, to_thunk_cases, PULL_EXISTS] >> - simp[LUPDATE_DEF] >> simp[lift_cases, PULL_EXISTS] >> goal_assum drule >> - ntac 7 $ simp[lift_cases, PULL_EXISTS] >> simp[force_cases, PULL_EXISTS] >> - goal_assum drule >> ntac 7 $ simp[force_cases, PULL_EXISTS] >> - simp[proj_cases, PULL_EXISTS] >> goal_assum drule >> - ntac 7 $ simp[proj_cases, PULL_EXISTS] >> ntac 6 $ simp[delay_force_cases] - ) - >~ [`Alloc`] - >- ( - simp[LUPDATE_DEF] >> - ntac 2 $ simp[lift_cases, PULL_EXISTS] >> rpt $ goal_assum drule >> - simp[lift_cases, PULL_EXISTS] >> goal_assum drule >> - ntac 7 $ simp[lift_cases, PULL_EXISTS] >> - ntac 2 $ simp[force_cases, PULL_EXISTS] >> goal_assum drule >> - simp[force_cases, PULL_EXISTS] >> goal_assum drule >> - ntac 7 $ simp[force_cases, PULL_EXISTS] >> - ntac 2 $ simp[proj_cases, PULL_EXISTS] >> goal_assum drule >> - simp[proj_cases, PULL_EXISTS] >> goal_assum drule >> - ntac 7 $ simp[proj_cases, PULL_EXISTS] >> - ntac 7 $ simp[delay_force_cases, PULL_EXISTS] - ) - >~ [`Deref`] - >- ( - ntac 2 $ simp[lift_cases, PULL_EXISTS] >> rpt $ goal_assum drule >> - ntac 4 $ simp[lift_cases, PULL_EXISTS] >> - ntac 2 $ simp[force_cases, PULL_EXISTS] >> rpt $ goal_assum drule >> - ntac 4 $ simp[force_cases, PULL_EXISTS] >> - ntac 2 $ simp[proj_cases, PULL_EXISTS] >> rpt $ goal_assum drule >> - ntac 4 $ simp[proj_cases, PULL_EXISTS] >> - ntac 2 $ simp[delay_force_cases, PULL_EXISTS] >> rpt $ goal_assum drule >> - ntac 4 $ simp[delay_force_cases, PULL_EXISTS] - ) - >~ [`Update`] (* Delay (Force (Var _)) case *) - >- ( - simp[LUPDATE_DEF, exp_of'_def] >> rpt $ goal_assum drule >> - simp[to_thunk_cases, PULL_EXISTS] >> - ntac 3 $ simp[lift_cases, PULL_EXISTS] >> rpt $ goal_assum drule >> - ntac 11 $ simp[lift_cases, PULL_EXISTS] >> - ntac 3 $ simp[force_cases, PULL_EXISTS] >> rpt $ goal_assum drule >> - ntac 11 $ simp[force_cases, PULL_EXISTS] >> - ntac 3 $ simp[proj_cases, PULL_EXISTS] >> rpt $ goal_assum drule >> - ntac 11 $ simp[proj_cases, PULL_EXISTS] >> - ntac 12 $ simp[Once delay_force_cases] - ) - >~ [`Update`] - >- ( - simp[LUPDATE_DEF, exp_of'_def] >> rpt $ goal_assum drule >> - ntac 3 $ simp[lift_cases, PULL_EXISTS] >> rpt $ goal_assum drule >> - simp[lift_cases, PULL_EXISTS] >> goal_assum drule >> - ntac 11 $ simp[lift_cases, PULL_EXISTS] >> - ntac 3 $ simp[force_cases, PULL_EXISTS] >> rpt $ goal_assum drule >> - simp[force_cases, PULL_EXISTS] >> goal_assum drule >> - ntac 11 $ simp[force_cases, PULL_EXISTS] >> - ntac 3 $ simp[proj_cases, PULL_EXISTS] >> rpt $ goal_assum drule >> - simp[proj_cases, PULL_EXISTS] >> goal_assum drule >> - ntac 11 $ simp[proj_cases, PULL_EXISTS] >> - ntac 12 $ simp[Once delay_force_cases] - ) + simp [exp_of'_def, to_thunk_cases, PULL_EXISTS] + \\ irule_at Any thunk_unthunkProofTheory.delay_force_Delat_Force_Var + \\ simp [undelay_cases, lift_cases, force_cases, proj_cases, PULL_EXISTS]) + \\ simp [proj_cases, force_cases, lift_cases, undelay_cases, + delay_force_cases, PULL_EXISTS] + \\ rpt $ goal_assum drule) + >~ [`Bind`] >- ( + simp [proj_cases, force_cases, lift_cases, delay_force_cases, + undelay_cases, PULL_EXISTS] + \\ rpt $ goal_assum drule) + >~ [`Handle`] >- ( + simp [proj_cases, force_cases, lift_cases, delay_force_cases, + undelay_cases, PULL_EXISTS] + \\ rpt $ goal_assum drule) + >~ [`Act`] >- ( + irule_at Any thunk_case_projProofTheory.compile_rel_Monad + \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Monad + \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Monad + \\ irule_at Any thunk_unthunkProofTheory.delay_force_Monad + \\ irule_at Any thunk_undelay_nextProofTheory.exp_rel_Monad_Ret_Delay + \\ simp [PULL_EXISTS] + \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Monad + \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Lam + \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Monad + \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Lam + \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Monad + \\ irule_at Any thunk_case_projProofTheory.compile_rel_Monad + \\ irule_at Any thunk_case_projProofTheory.compile_rel_Lam + \\ irule_at Any thunk_case_projProofTheory.compile_rel_Monad + \\ simp [PULL_EXISTS] + \\ irule_at Any thunk_case_projProofTheory.compile_rel_Delay + \\ irule_at Any thunk_case_projProofTheory.compile_rel_Var + \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Delay + \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Var + \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Monad + \\ simp [] + \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Delay + \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Var + \\ rpt $ goal_assum drule) + >~ [`Length`] >- ( + irule_at Any thunk_case_projProofTheory.compile_rel_Monad + \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Monad + \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Monad + \\ irule_at Any thunk_unthunkProofTheory.delay_force_Monad + \\ irule_at Any thunk_undelay_nextProofTheory.exp_rel_Monad_Ret_Delay + \\ simp [PULL_EXISTS] + \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Monad + \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Lam + \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Monad + \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Lam + \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Monad + \\ irule_at Any thunk_case_projProofTheory.compile_rel_Monad + \\ irule_at Any thunk_case_projProofTheory.compile_rel_Lam + \\ irule_at Any thunk_case_projProofTheory.compile_rel_Monad + \\ simp [PULL_EXISTS] + \\ irule_at Any thunk_case_projProofTheory.compile_rel_Delay + \\ irule_at Any thunk_case_projProofTheory.compile_rel_Var + \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Delay + \\ irule_at Any thunk_case_liftProofTheory.compile_rel_Var + \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Monad + \\ simp [] + \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Delay + \\ irule_at Any thunk_let_forceProofTheory.exp_rel_Var + \\ rpt $ goal_assum drule) + >~ [`Alloc`] >- ( + (* Delay (Force (Var _)) case *) + goal_assum drule + \\ simp [exp_of'_def, to_thunk_cases, delay_force_cases, PULL_EXISTS] + \\ simp [undelay_cases, PULL_EXISTS] + \\ ntac 6 (simp [lift_cases, PULL_EXISTS]) + \\ ntac 6 (simp [force_cases, PULL_EXISTS]) + \\ ntac 2 (simp [proj_cases, PULL_EXISTS]) + \\ simp [LUPDATE_DEF, PULL_EXISTS] + \\ goal_assum drule + \\ irule_at (Pos hd) thunk_unthunkProofTheory.delay_force_Delat_Force_Var + \\ goal_assum drule \\ simp [undelay_cases, PULL_EXISTS] + \\ goal_assum drule \\ simp [lift_cases, PULL_EXISTS] + \\ goal_assum drule \\ simp [force_cases, PULL_EXISTS] + \\ ntac 5 (simp [proj_cases, PULL_EXISTS])) + >~ [`Alloc`] >- ( + ntac 2 (goal_assum drule) + \\ simp [delay_force_cases, undelay_cases, PULL_EXISTS] + \\ ntac 6 (simp [lift_cases, PULL_EXISTS]) + \\ ntac 6 (simp [force_cases, PULL_EXISTS]) + \\ ntac 2 (simp [proj_cases, PULL_EXISTS]) + \\ simp [LUPDATE_DEF, PULL_EXISTS] + \\ goal_assum drule + \\ irule_at (Pos hd) thunk_unthunkProofTheory.delay_force_Delay + \\ ntac 2 (goal_assum drule) \\ simp [undelay_cases, PULL_EXISTS] + \\ ntac 2 (goal_assum drule) \\ simp [lift_cases, PULL_EXISTS] + \\ ntac 2 (goal_assum drule) \\ simp [force_cases, PULL_EXISTS] + \\ goal_assum drule \\ ntac 5 (simp [proj_cases, PULL_EXISTS])) + >~ [`Deref`] >- ( + ntac 2 (goal_assum drule) \\ simp [delay_force_cases, PULL_EXISTS] + \\ ntac 2 (goal_assum drule) \\ simp [undelay_cases, PULL_EXISTS] + \\ ntac 2 (goal_assum drule) \\ ntac 2 (simp [lift_cases, PULL_EXISTS]) + \\ ntac 2 (goal_assum drule) \\ ntac 4 (simp [lift_cases, PULL_EXISTS]) + \\ ntac 2 (simp [force_cases, PULL_EXISTS]) \\ ntac 2 (goal_assum drule) + \\ ntac 4 (simp [force_cases, PULL_EXISTS]) + \\ ntac 6 (simp [proj_cases, PULL_EXISTS])) + >~ [`Update`] >- ( + (* Delay (Force (Var _)) case *) + ntac 2 (goal_assum drule) \\ simp [exp_of'_def, to_thunk_cases, PULL_EXISTS] + \\ simp [delay_force_cases, undelay_cases, PULL_EXISTS] + \\ ntac 11 (simp [lift_cases, PULL_EXISTS]) + \\ ntac 11 (simp [force_cases, PULL_EXISTS]) + \\ ntac 3 (simp [proj_cases, PULL_EXISTS]) + \\ simp [LUPDATE_DEF, PULL_EXISTS] + \\ ntac 2 (goal_assum drule) + \\ irule_at (Pos hd) thunk_unthunkProofTheory.delay_force_Delat_Force_Var + \\ ntac 2 (goal_assum drule) \\ simp [undelay_cases, PULL_EXISTS] + \\ ntac 2 (goal_assum drule) \\ simp [lift_cases, PULL_EXISTS] + \\ ntac 2 (goal_assum drule) \\ simp [force_cases, PULL_EXISTS] + \\ ntac 9 (simp [proj_cases, PULL_EXISTS])) + >~ [`Update`] >- ( + ntac 3 (goal_assum drule) + \\ simp [delay_force_cases, undelay_cases, PULL_EXISTS] + \\ ntac 11 (simp [lift_cases, PULL_EXISTS]) + \\ ntac 11 (simp [force_cases, PULL_EXISTS]) + \\ ntac 3 (simp [proj_cases, PULL_EXISTS]) + \\ simp [LUPDATE_DEF, PULL_EXISTS] + \\ ntac 2 (goal_assum drule) + \\ irule_at (Pos hd) thunk_unthunkProofTheory.delay_force_Delay + \\ ntac 3 (goal_assum drule) \\ simp [undelay_cases, PULL_EXISTS] + \\ ntac 3 (goal_assum drule) \\ simp [lift_cases, PULL_EXISTS] + \\ ntac 3 (goal_assum drule) \\ simp [force_cases, PULL_EXISTS] + \\ goal_assum drule \\ ntac 9 (simp [proj_cases, PULL_EXISTS])) QED Theorem exp_rel_semantics: @@ -777,24 +756,19 @@ Proof \\ irule_at Any pure_obs_sem_equalTheory.bisimilarity_IMP_semantics_eq \\ fs [pure_exp_relTheory.app_bisimilarity_eq]) \\ fs [] - \\ drule_all compile_semantics - \\ strip_tac \\ fs [] - \\ drule compile_rel_semantics - \\ impl_keep_tac >- - (imp_res_tac pure_to_thunk_1ProofTheory.compile_rel_freevars - \\ fs [closed_def,pure_expTheory.closed_def]) - \\ strip_tac \\ fs [] - \\ drule case_force_semantics \\ fs [] - \\ impl_keep_tac >- - (imp_res_tac thunk_case_liftProofTheory.compile_rel_freevars \\ fs [closed_def]) - \\ strip_tac \\ fs [] - \\ drule_at (Pos $ el 2) compile_case_proj_semantics - \\ impl_keep_tac - >- (drule exp_rel_NONE_freevars \\ fs [closed_def]) - \\ strip_tac - \\ drule thunk_unthunkProofTheory.delay_force_semantics - \\ impl_keep_tac - >- (imp_res_tac compile_rel_closed \\ gvs []) - \\ strip_tac \\ fs [] - \\ drule_all delay_force_closed \\ fs [] + \\ imp_res_tac pure_to_thunk_1ProofTheory.compile_rel_freevars + \\ imp_res_tac thunk_unthunkProofTheory.delay_force_closed \\ gvs [] + \\ imp_res_tac thunk_undelay_nextProofTheory.exp_rel_freevars + \\ imp_res_tac thunk_case_liftProofTheory.compile_rel_freevars + \\ imp_res_tac thunk_let_forceProofTheory.exp_rel_NONE_freevars + \\ imp_res_tac thunk_case_projProofTheory.compile_rel_closed \\ gvs [] + \\ gvs [closed_def, pure_expTheory.closed_def] + \\ drule pure_to_thunk_1ProofTheory.compile_semantics \\ rw [] + \\ drule thunk_unthunkProofTheory.delay_force_semantics_delayed \\ rw [] + \\ drule thunk_undelay_nextProofTheory.undelay_semantics \\ rw [] + \\ drule thunk_case_liftProofTheory.compile_rel_semantics \\ rw [] + \\ drule thunk_let_forceProofTheory.case_force_semantics \\ rw [] + \\ drule_at (Pat `proj_rel _ _`) + thunk_case_projProofTheory.compile_case_proj_semantics \\ rw [] + \\ gvs [closed_def, pure_expTheory.closed_def] QED diff --git a/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml b/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml index 2c586f07..da30e406 100644 --- a/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml +++ b/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml @@ -81,6 +81,10 @@ Inductive v_rel: (∀a. v_rel (Atom a) (Atom a)) +[~ThunkLoc:] + (∀n. + v_rel (ThunkLoc n) (ThunkLoc n)) + [~Constructor:] (∀s tvs svs. LIST_REL v_rel tvs svs ⇒ @@ -113,6 +117,17 @@ End Theorem env_rel_def = “env_rel tenv senv” |> SIMP_CONV (srw_ss()) [Once v_rel_cases]; +Definition store_rel_def: + store_rel (Array vs1) (Array vs2) = LIST_REL v_rel vs1 vs2 ∧ + store_rel (ThunkMem m1 v1) (ThunkMem m2 v2) = + (m1 = m2 ∧ v_rel v1 v2) ∧ + store_rel _ _ = F +End + +Definition state_rel_def: + state_rel st1 st2 = LIST_REL store_rel st1 st2 +End + Inductive cont_rel: (cont_rel [] []) ∧ (∀a tk sk. @@ -146,7 +161,12 @@ Inductive cont_rel: (∀sk tk. cont_rel tk sk ⇒ cont_rel (RaiseK :: tk) - (RaiseK :: sk)) + (RaiseK :: sk)) ∧ + (∀sk tk s1 s2 n. + cont_rel tk sk ∧ + state_rel s1 s2 ∧ + n < LENGTH s1 ⇒ + cont_rel (ForceMutK n::tk) (ForceMutK n::sk)) End Inductive step_res_rel: @@ -167,7 +187,7 @@ Definition rec_env_def: End Inductive snext_res_rel: - (OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ cont_rel tk sk ⇒ + (OPTREL state_rel ts ss ∧ cont_rel tk sk ⇒ snext_res_rel (Act x tk ts) (Act x sk ss)) ∧ (snext_res_rel Ret Ret) ∧ (snext_res_rel Div Div) ∧ @@ -234,16 +254,18 @@ Proof QED Theorem application_thm: - application op tvs ts tk = (tr1,ts1,tk1) ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ cont_rel tk sk ∧ - LIST_REL v_rel tvs svs ∧ - num_args_ok op (LENGTH svs) ⇒ - ∃sr1 ss1 sk1. - application op svs ss sk = (sr1,ss1,sk1) ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts1 ss1 ∧ - step_res_rel tr1 tk1 sr1 sk1 + ∀op tvs ts tk tr1 ts1 tk1 ss sk svs. + application op tvs ts tk = (tr1,ts1,tk1) ∧ + OPTREL state_rel ts ss ∧ cont_rel tk sk ∧ + LIST_REL v_rel tvs svs ∧ + num_args_ok op (LENGTH svs) ⇒ + ∃sr1 ss1 sk1. + application op svs ss sk = (sr1,ss1,sk1) ∧ + OPTREL state_rel ts1 ss1 ∧ + step_res_rel tr1 tk1 sr1 sk1 Proof - Cases_on ‘op’ \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] + Cases \\ rw [] + \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] \\ rw [] \\ gvs [] >~ [‘Cons’] >- (gvs [application_def,step,step_res_rel_cases] @@ -295,16 +317,11 @@ Proof \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] \\ gvs [AllCaseEqs()] \\ Cases_on ‘ss’ \\ gvs [] + \\ fs [state_rel_def] \\ imp_res_tac LIST_REL_LENGTH \\ fs [] \\ simp [Once v_rel_cases] - \\ fs [LIST_REL_SNOC] + \\ fs [LIST_REL_SNOC,store_rel_def] \\ simp [LIST_REL_EL_EQN,EL_REPLICATE]) - >~ [‘Ref’] >- - (gvs [application_def,step,step_res_rel_cases] - \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] - \\ imp_res_tac LIST_REL_LENGTH \\ fs [] - \\ simp [Once v_rel_cases] - \\ fs [LIST_REL_SNOC]) >~ [‘Length’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -313,8 +330,12 @@ Proof \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] \\ imp_res_tac LIST_REL_LENGTH \\ fs [oEL_THM] \\ IF_CASES_TAC \\ gvs [] + \\ gvs [LIST_REL_EL_EQN,state_rel_def] + \\ Cases_on ‘EL n x’ \\ Cases_on ‘EL n x'’ \\ gvs [store_rel_def] + \\ first_assum drule \\ asm_rewrite_tac [store_rel_def] \\ strip_tac \\ simp [Once v_rel_cases] - \\ gvs [LIST_REL_EL_EQN]) + \\ gvs [LIST_REL_EL_EQN,state_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ fs []) >~ [‘Sub’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -326,25 +347,21 @@ Proof \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] \\ imp_res_tac LIST_REL_LENGTH \\ fs [oEL_THM] \\ rpt (IF_CASES_TAC \\ gvs []) + \\ gvs [state_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ gvs [state_rel_def] + \\ Cases_on ‘EL n x’ \\ Cases_on ‘EL n x'’ + \\ gvs [state_rel_def,LIST_REL_EL_EQN] + \\ res_tac \\ Cases_on ‘EL n x’ \\ gvs [store_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ fs [] \\ gvs [LIST_REL_EL_EQN] - \\ ntac 2 (simp [Once compile_rel_cases,env_rel_def]) - \\ imp_res_tac integerTheory.NUM_POSINT_EXISTS \\ gvs [] - \\ simp[Once v_rel_cases] - \\ rpt $ first_assum $ irule_at Any) - >~ [‘UnsafeSub’] >- - (gvs [application_def,step,step_res_rel_cases] - \\ qpat_x_assum ‘v_rel x h’ mp_tac - \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] - \\ Cases_on ‘a’ \\ gvs [] - \\ qpat_x_assum ‘v_rel _ _’ mp_tac - \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] - \\ Cases_on ‘a’ \\ gvs [] - \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] - \\ imp_res_tac LIST_REL_LENGTH \\ fs [oEL_THM] - \\ rpt (IF_CASES_TAC \\ gvs []) - \\ gvs [LIST_REL_EL_EQN] - \\ ntac 2 (simp [Once compile_rel_cases,env_rel_def]) - \\ imp_res_tac integerTheory.NUM_POSINT_EXISTS \\ gvs []) + \\ Cases_on ‘0 ≤ i’ \\ gvs [] + >- + (imp_res_tac integerTheory.NUM_POSINT_EXISTS + \\ first_x_assum $ qspec_then ‘&n'’ assume_tac + \\ gvs [] + \\ Cases_on ‘n' < LENGTH l'’ \\ gvs [] + \\ gvs [Once v_rel_cases,LIST_REL_EL_EQN,state_rel_def]) + >- simp [Once v_rel_cases,LIST_REL_EL_EQN,state_rel_def]) >~ [‘Update’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -356,30 +373,67 @@ Proof \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] \\ imp_res_tac LIST_REL_LENGTH \\ fs [oEL_THM] \\ rpt (IF_CASES_TAC \\ gvs []) + \\ gvs [state_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ gvs [state_rel_def] + \\ Cases_on ‘EL n x’ \\ Cases_on ‘EL n x'’ + \\ gvs [state_rel_def,LIST_REL_EL_EQN] + \\ res_tac \\ Cases_on ‘EL n x’ \\ gvs [store_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ fs [] \\ gvs [LIST_REL_EL_EQN] - \\ ntac 2 (simp [Once compile_rel_cases,env_rel_def]) - \\ imp_res_tac integerTheory.NUM_POSINT_EXISTS \\ gvs [] - \\ gvs [EL_LUPDATE] \\ rw [] - \\ gvs [EL_LUPDATE] \\ rw [] - \\ simp [Once v_rel_cases] \\ rpt strip_tac \\ gvs [] - \\ rpt $ first_assum $ irule_at Any) - >~ [‘UnsafeUpdate’] >- + \\ Cases_on ‘0 ≤ i’ \\ gvs [] + >- + (imp_res_tac integerTheory.NUM_POSINT_EXISTS + \\ first_x_assum $ qspec_then ‘&n'’ assume_tac \\ gvs [] + \\ Cases_on ‘n' < LENGTH l'’ \\ gvs [] + \\ simp [Once v_rel_cases,LIST_REL_EL_EQN,state_rel_def] + \\ rpt strip_tac + \\ gvs [EL_LUPDATE] + \\ Cases_on ‘n'' = n’ \\ gvs [] + \\ rw [LIST_REL_EL_EQN,store_rel_def] + \\ gvs [EL_LUPDATE] + \\ Cases_on ‘n'' = n'’ \\ gvs [] + \\ res_tac \\ Cases_on ‘EL n x’ \\ gvs [store_rel_def] + \\ gvs [LIST_REL_EL_EQN]) + >- simp [Once v_rel_cases,LIST_REL_EL_EQN,state_rel_def]) + >~ [‘AllocMutThunk’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] - \\ Cases_on ‘a’ \\ gvs [] - \\ qpat_x_assum ‘v_rel _ h'’ mp_tac + \\ gvs [AllCaseEqs()] + \\ Cases_on ‘ss’ \\ gvs [] + \\ fs [state_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ fs [] + \\ simp [Once v_rel_cases] + \\ fs [LIST_REL_SNOC,store_rel_def] + \\ simp [Once v_rel_cases,LIST_REL_EL_EQN,EL_REPLICATE] + \\ gvs [LIST_REL_EL_EQN]) + >~ [‘UpdateMutThunk’] >- + (gvs [application_def,step,step_res_rel_cases] + \\ qpat_x_assum ‘v_rel x h’ mp_tac \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] - \\ Cases_on ‘a’ \\ gvs [] \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] - \\ imp_res_tac LIST_REL_LENGTH \\ fs [oEL_THM] - \\ rpt (IF_CASES_TAC \\ gvs []) - \\ gvs [LIST_REL_EL_EQN] - \\ ntac 2 (simp [Once compile_rel_cases,env_rel_def]) - \\ imp_res_tac integerTheory.NUM_POSINT_EXISTS \\ gvs [] - \\ gvs [EL_LUPDATE] \\ rw [] - \\ gvs [EL_LUPDATE] \\ rw [] - \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs []) + \\ gvs [AllCaseEqs(),oEL_THM,state_rel_def,LIST_REL_EL_EQN] + \\ first_assum drule \\ asm_rewrite_tac [store_rel_def] \\ strip_tac + \\ Cases_on ‘EL n x''’ \\ gvs [state_rel_def,store_rel_def,LIST_REL_EL_EQN] + \\ simp [Once v_rel_cases] \\ strip_tac + \\ gvs [EL_LUPDATE] + \\ IF_CASES_TAC \\ rw [store_rel_def]) + >~ [‘ForceMutThunk’] >- + (once_rewrite_tac [application_def] + \\ rgs [Once application_def] + \\ qpat_x_assum ‘v_rel x h’ mp_tac + \\ simp [Once v_rel_cases] \\ strip_tac + \\ gvs [error_def,step_res_rel_cases] + \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] >> + gvs[oEL_THM] >> imp_res_tac state_rel_def >> gvs[LIST_REL_EL_EQN] >> + last_x_assum mp_tac >> + reverse $ IF_CASES_TAC >> gvs[] >- (rw[] >> gvs[]) >> + TOP_CASE_TAC >> gvs[] >> + first_x_assum drule >> simp[oneline store_rel_def] >> CASE_TAC >> gvs[] >> + rw[] >> gvs[] >> CASE_TAC >> gvs[value_def] >> + ntac 2 $ simp[Once cont_rel_cases] >> + simp[env_rel_def, Once v_rel_cases] >> + goal_assum drule >> simp[]) >~ [‘FFI’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -449,12 +503,12 @@ Theorem step_1_Exp_forward: ∀e1 e2 ts tk sr1 ss1 sk1 ss sk env1 env2. step ss sk (Exp env2 e2) = (sr1,ss1,sk1) ∧ cont_rel tk sk ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ + OPTREL state_rel ts ss ∧ compile_rel e1 e2 ∧ env_rel env1 env2 ⇒ ∃m tr1 ts1 tk1. step_n (m + 1) (Exp env1 e1,ts,tk) = (tr1,ts1,tk1) ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts1 ss1 ∧ + OPTREL state_rel ts1 ss1 ∧ step_res_rel tr1 tk1 sr1 sk1 Proof Induct_on ‘compile_rel’ \\ rpt strip_tac @@ -587,10 +641,10 @@ Theorem step_1_Exn_forward: ∀ts sk tk sr1 ss1 sk1 ss v1 v2. step ss sk (Exn v2) = (sr1,ss1,sk1) ∧ cont_rel tk sk ∧ v_rel v1 v2 ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ⇒ + OPTREL state_rel ts ss ⇒ ∃m tr1 ts1 tk1. step_n (m + 1) (Exn v1,ts,tk) = (tr1,ts1,tk1) ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts1 ss1 ∧ + OPTREL state_rel ts1 ss1 ∧ step_res_rel tr1 tk1 sr1 sk1 Proof Induct_on ‘cont_rel’ \\ rpt strip_tac @@ -610,14 +664,39 @@ Proof \\ simp [Once cont_rel_cases] QED +Theorem thunk_or_thunk_loc_rel: + v_rel v w ⇒ + thunk_or_thunk_loc v = thunk_or_thunk_loc w +Proof + ‘(∀v w. v_rel v w ⇒ thunk_or_thunk_loc v = thunk_or_thunk_loc w) ∧ + (∀x y. env_rel x y ⇒ T)’ + suffices_by gvs [] + \\ ho_match_mp_tac v_rel_strongind \\ rw [] \\ gvs [] + >~ [‘Constructor’] >- gvs [thunk_or_thunk_loc_def, dest_anyThunk_def] + >~ [‘Closure’] >- gvs [thunk_or_thunk_loc_def, dest_anyThunk_def] + \\ gvs [thunk_or_thunk_loc_def, dest_anyThunk_def] + \\ rpt (CASE_TAC \\ gvs []) + >>~ [‘ALOOKUP _ _ = NONE’] + >- ( + qpat_x_assum ‘MAP FST _ = MAP FST _’ (assume_tac o GSYM) + \\ drule_all ALOOKUP_SOME_EL_2 \\ gvs []) + >- (drule_all ALOOKUP_SOME_EL_2 \\ gvs []) + \\ ( + drule_all ALOOKUP_list_rel \\ rw [] \\ gvs [] + \\ rgs [Once compile_rel_cases] \\ gvs [] + \\ rpt strip_tac \\ gvs [] + \\ rpt (dxrule_then assume_tac ALOOKUP_SOME_EL) \\ gvs [EVERY_EL] + \\ first_x_assum drule \\ gvs []) +QED + Theorem step_1_Val_forward: ∀ts sk tk sr1 ss1 sk1 ss v1 v2. step ss sk (Val v2) = (sr1,ss1,sk1) ∧ cont_rel tk sk ∧ v_rel v1 v2 ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ⇒ + OPTREL state_rel ts ss ⇒ ∃m tr1 ts1 tk1. step_n (m + 1) (Val v1,ts,tk) = (tr1,ts1,tk1) ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts1 ss1 ∧ + OPTREL state_rel ts1 ss1 ∧ step_res_rel tr1 tk1 sr1 sk1 Proof Induct_on ‘cont_rel’ \\ rpt strip_tac @@ -649,6 +728,23 @@ Proof >~ [‘LetK _ n’] >- (Cases_on ‘n’ \\ gvs [step,step_res_rel_cases] \\ irule env_rel_cons \\ simp []) + >~ [‘ForceMutK’] >- + (gvs [step] + \\ qpat_x_assum ‘_ = (sr1,ss1,sk1)’ mp_tac + \\ Cases_on ‘ss’ \\ gvs [OPTREL_def] + >- (rpt (TOP_CASE_TAC \\ gvs []) \\ simp [step_res_rel_cases]) + \\ Cases_on ‘thunk_or_thunk_loc v2’ \\ gvs [] + \\ drule_all thunk_or_thunk_loc_rel \\ gvs [] >- rw [step_res_rel_cases] + \\ rw [] + \\ ( + gvs [state_rel_def, LIST_REL_EL_EQN, EL_LUPDATE] \\ rw [] + \\ simp [step_res_rel_cases, store_rel_def] + \\ qpat_x_assum ‘store_same_type _ _’ mp_tac + \\ qpat_x_assum ‘¬store_same_type _ _’ mp_tac + \\ simp [store_same_type_def] + \\ rpt (TOP_CASE_TAC \\ gvs []) \\ simp [store_rel_def] + \\ first_x_assum drule \\ gvs [] + \\ simp [store_rel_def])) \\ rename [‘AppK’] \\ reverse (Cases_on ‘tes’) \\ gvs [] \\ gvs [step] >- @@ -666,11 +762,11 @@ QED Theorem step_1_forward: ∀tr ts tk sr1 ss1 sk1 ss sr sk. step_n 1 (sr,ss,sk) = (sr1,ss1,sk1) ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ + OPTREL state_rel ts ss ∧ step_res_rel tr tk sr sk ⇒ ∃m tr1 ts1 tk1. step_n (m+1) (tr,ts,tk) = (tr1,ts1,tk1) ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts1 ss1 ∧ + OPTREL state_rel ts1 ss1 ∧ step_res_rel tr1 tk1 sr1 sk1 Proof rpt strip_tac @@ -696,11 +792,11 @@ QED Theorem step_n_forward: ∀n tr ts tk sr1 ss1 sk1 ss sr sk. step_n n (sr,ss,sk) = (sr1,ss1,sk1) ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ + OPTREL state_rel ts ss ∧ step_res_rel tr tk sr sk ⇒ ∃m tr1 ts1 tk1. step_n (m+n) (tr,ts,tk) = (tr1,ts1,tk1) ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts1 ss1 ∧ + OPTREL state_rel ts1 ss1 ∧ step_res_rel tr1 tk1 sr1 sk1 Proof Induct \\ fs [] \\ rw [] @@ -743,12 +839,12 @@ QED Theorem step_n_forward_thm: ∀n tr ts tk sr1 ss1 sk1 ss sr sk. step_n n (sr,ss,sk) = (sr1,ss1,sk1) ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ + OPTREL state_rel ts ss ∧ step_res_rel tr tk sr sk ⇒ ∃m tr1 ts1 tk1. step_n (m+n) (tr,ts,tk) = (tr1,ts1,tk1) ∧ step_res_rel tr1 tk1 sr1 sk1 ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts1 ss1 ∧ + OPTREL state_rel ts1 ss1 ∧ is_halt (tr1,ts1,tk1) = is_halt (sr1,ss1,sk1) Proof rw [] \\ drule_all step_n_forward @@ -775,7 +871,7 @@ QED Theorem step_until_halt_thm: step_res_rel tr tk sr sk ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ⇒ + OPTREL state_rel ts ss ⇒ snext_res_rel (step_until_halt (tr,ts,tk)) (step_until_halt (sr,ss,sk)) Proof @@ -840,7 +936,7 @@ QED Theorem semantics_thm: compile_rel e1 e2 ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ + OPTREL state_rel ts ss ∧ env_rel tenv senv ∧ cont_rel tk sk ⇒ semantics e1 tenv ts tk = @@ -850,7 +946,7 @@ Proof ∀t1 t2. (∃e1 e2 ts ss tenv senv tk sk. compile_rel e1 e2 ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ + OPTREL state_rel ts ss ∧ env_rel tenv senv ∧ cont_rel tk sk ∧ t1 = semantics e1 tenv ts tk ∧ @@ -906,5 +1002,5 @@ Proof fs [stateLangTheory.itree_of_def] \\ rw [] \\ irule semantics_thm \\ simp [Once cont_rel_cases] - \\ fs [env_rel_def] + \\ fs [env_rel_def,state_rel_def] QED diff --git a/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml b/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml index 7031380e..093a5db2 100644 --- a/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml +++ b/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml @@ -94,6 +94,10 @@ Inductive v_rel: (∀a. v_rel (Atom a) (Atom a)) +[~ThunkLoc:] + (∀n. + v_rel (ThunkLoc n) (ThunkLoc n)) + [~Constructor:] (∀s tvs svs. LIST_REL v_rel tvs svs ⇒ @@ -126,6 +130,17 @@ End Theorem env_rel_def = “env_rel tenv senv” |> SIMP_CONV (srw_ss()) [Once v_rel_cases]; +Definition store_rel_def: + store_rel (Array vs1) (Array vs2) = LIST_REL v_rel vs1 vs2 ∧ + store_rel (ThunkMem m1 v1) (ThunkMem m2 v2) = + (m1 = m2 ∧ v_rel v1 v2) ∧ + store_rel _ _ = F +End + +Definition state_rel_def: + state_rel st1 st2 = LIST_REL store_rel st1 st2 +End + Inductive cont_rel: (cont_rel [] []) ∧ (∀tk sk e1 e2 x_opt. @@ -165,7 +180,12 @@ Inductive cont_rel: (∀sk tk. cont_rel tk sk ⇒ cont_rel (RaiseK :: tk) - (RaiseK :: sk)) + (RaiseK :: sk)) ∧ + (∀sk tk s1 s2 n. + cont_rel tk sk ∧ + state_rel s1 s2 ∧ + n < LENGTH s1 ⇒ + cont_rel (ForceMutK n::tk) (ForceMutK n::sk)) End Inductive step_res_rel: @@ -186,7 +206,7 @@ Definition rec_env_def: End Inductive snext_res_rel: - (OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ cont_rel tk sk ⇒ + (OPTREL state_rel ts ss ∧ cont_rel tk sk ⇒ snext_res_rel (Act x tk ts) (Act x sk ss)) ∧ (snext_res_rel Ret Ret) ∧ (snext_res_rel Div Div) ∧ @@ -253,16 +273,18 @@ Proof QED Theorem application_thm: - application op tvs ts tk = (tr1,ts1,tk1) ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ cont_rel tk sk ∧ - LIST_REL v_rel tvs svs ∧ - num_args_ok op (LENGTH svs) ⇒ - ∃sr1 ss1 sk1. - application op svs ss sk = (sr1,ss1,sk1) ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts1 ss1 ∧ - step_res_rel tr1 tk1 sr1 sk1 + ∀op tvs ts tk tr1 ts1 tk1 ss sk svs. + application op tvs ts tk = (tr1,ts1,tk1) ∧ + OPTREL state_rel ts ss ∧ cont_rel tk sk ∧ + LIST_REL v_rel tvs svs ∧ + num_args_ok op (LENGTH svs) ⇒ + ∃sr1 ss1 sk1. + application op svs ss sk = (sr1,ss1,sk1) ∧ + OPTREL state_rel ts1 ss1 ∧ + step_res_rel tr1 tk1 sr1 sk1 Proof - Cases_on ‘op’ \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] + Cases \\ rw [] + \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] \\ rw [] \\ gvs [] >~ [‘Cons’] >- (gvs [application_def,step,step_res_rel_cases] @@ -314,16 +336,11 @@ Proof \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] \\ gvs [AllCaseEqs()] \\ Cases_on ‘ss’ \\ gvs [] + \\ fs [state_rel_def] \\ imp_res_tac LIST_REL_LENGTH \\ fs [] \\ simp [Once v_rel_cases] - \\ fs [LIST_REL_SNOC] + \\ fs [LIST_REL_SNOC,store_rel_def] \\ simp [LIST_REL_EL_EQN,EL_REPLICATE]) - >~ [‘Ref’] >- - (gvs [application_def,step,step_res_rel_cases] - \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] - \\ imp_res_tac LIST_REL_LENGTH \\ fs [] - \\ simp [Once v_rel_cases] - \\ fs [LIST_REL_SNOC]) >~ [‘Length’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -332,8 +349,12 @@ Proof \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] \\ imp_res_tac LIST_REL_LENGTH \\ fs [oEL_THM] \\ IF_CASES_TAC \\ gvs [] + \\ gvs [LIST_REL_EL_EQN,state_rel_def] + \\ Cases_on ‘EL n x’ \\ Cases_on ‘EL n x'’ \\ gvs [store_rel_def] + \\ res_tac \\ Cases_on ‘EL n x’ \\ gvs [store_rel_def] \\ simp [Once v_rel_cases] - \\ gvs [LIST_REL_EL_EQN]) + \\ gvs [LIST_REL_EL_EQN,state_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ fs []) >~ [‘Sub’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -345,25 +366,20 @@ Proof \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] \\ imp_res_tac LIST_REL_LENGTH \\ fs [oEL_THM] \\ rpt (IF_CASES_TAC \\ gvs []) + \\ gvs [state_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ gvs [state_rel_def] + \\ Cases_on ‘EL n x’ \\ Cases_on ‘EL n x'’ \\ gvs [LIST_REL_EL_EQN] + \\ res_tac \\ Cases_on ‘EL n x’ \\ gvs [store_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ fs [] \\ gvs [LIST_REL_EL_EQN] - \\ ntac 2 (simp [Once compile_rel_cases,env_rel_def]) - \\ imp_res_tac integerTheory.NUM_POSINT_EXISTS \\ gvs [] - \\ simp[Once v_rel_cases] - \\ rpt $ first_assum $ irule_at Any) - >~ [‘UnsafeSub’] >- - (gvs [application_def,step,step_res_rel_cases] - \\ qpat_x_assum ‘v_rel x h’ mp_tac - \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] - \\ Cases_on ‘a’ \\ gvs [] - \\ qpat_x_assum ‘v_rel _ _’ mp_tac - \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] - \\ Cases_on ‘a’ \\ gvs [] - \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] - \\ imp_res_tac LIST_REL_LENGTH \\ fs [oEL_THM] - \\ rpt (IF_CASES_TAC \\ gvs []) - \\ gvs [LIST_REL_EL_EQN] - \\ ntac 2 (simp [Once compile_rel_cases,env_rel_def]) - \\ imp_res_tac integerTheory.NUM_POSINT_EXISTS \\ gvs []) + \\ Cases_on ‘0 ≤ i’ \\ gvs [] + >- + (imp_res_tac integerTheory.NUM_POSINT_EXISTS + \\ first_x_assum $ qspec_then ‘&n'’ assume_tac + \\ gvs [] + \\ Cases_on ‘n' < LENGTH l'’ \\ gvs [] + \\ gvs [Once v_rel_cases,LIST_REL_EL_EQN,state_rel_def]) + \\ simp [Once v_rel_cases,LIST_REL_EL_EQN,state_rel_def]) >~ [‘Update’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -375,30 +391,65 @@ Proof \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] \\ imp_res_tac LIST_REL_LENGTH \\ fs [oEL_THM] \\ rpt (IF_CASES_TAC \\ gvs []) + \\ gvs [state_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ gvs [state_rel_def] + \\ Cases_on ‘EL n x’ \\ Cases_on ‘EL n x'’ \\ gvs [LIST_REL_EL_EQN] + \\ res_tac \\ Cases_on ‘EL n x’ \\ gvs [store_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ fs [] \\ gvs [LIST_REL_EL_EQN] - \\ ntac 2 (simp [Once compile_rel_cases,env_rel_def]) - \\ imp_res_tac integerTheory.NUM_POSINT_EXISTS \\ gvs [] - \\ gvs [EL_LUPDATE] \\ rw [] - \\ gvs [EL_LUPDATE] \\ rw [] - \\ simp [Once v_rel_cases] \\ rpt strip_tac \\ gvs [] - \\ rpt $ first_assum $ irule_at Any) - >~ [‘UnsafeUpdate’] >- + \\ Cases_on ‘0 ≤ i’ \\ gvs [] + >- + (imp_res_tac integerTheory.NUM_POSINT_EXISTS + \\ first_x_assum $ qspec_then ‘&n'’ assume_tac \\ gvs [] + \\ Cases_on ‘n' < LENGTH l'’ \\ gvs [] + \\ simp [Once v_rel_cases,LIST_REL_EL_EQN,state_rel_def] + \\ rpt strip_tac + \\ gvs [EL_LUPDATE] + \\ Cases_on ‘n'' = n’ \\ gvs [] + \\ rw [LIST_REL_EL_EQN,store_rel_def] + \\ gvs [EL_LUPDATE] + \\ Cases_on ‘n'' = n'’ \\ gvs [] + \\ res_tac \\ Cases_on ‘EL n x’ \\ gvs [store_rel_def] + \\ gvs [LIST_REL_EL_EQN]) + \\ simp [Once v_rel_cases,LIST_REL_EL_EQN,state_rel_def]) + >~ [‘AllocMutThunk’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] - \\ Cases_on ‘a’ \\ gvs [] - \\ qpat_x_assum ‘v_rel _ h'’ mp_tac + \\ gvs [AllCaseEqs()] + \\ Cases_on ‘ss’ \\ gvs [] + \\ fs [state_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ fs [] + \\ simp [Once v_rel_cases] + \\ fs [LIST_REL_SNOC,store_rel_def] + \\ simp [Once v_rel_cases,LIST_REL_EL_EQN,EL_REPLICATE] + \\ gvs [LIST_REL_EL_EQN]) + >~ [‘UpdateMutThunk’] >- + (gvs [application_def,step,step_res_rel_cases] + \\ qpat_x_assum ‘v_rel x h’ mp_tac \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] - \\ Cases_on ‘a’ \\ gvs [] \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] - \\ imp_res_tac LIST_REL_LENGTH \\ fs [oEL_THM] - \\ rpt (IF_CASES_TAC \\ gvs []) - \\ gvs [LIST_REL_EL_EQN] - \\ ntac 2 (simp [Once compile_rel_cases,env_rel_def]) - \\ imp_res_tac integerTheory.NUM_POSINT_EXISTS \\ gvs [] - \\ gvs [EL_LUPDATE] \\ rw [] - \\ gvs [EL_LUPDATE] \\ rw [] - \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs []) + \\ gvs [AllCaseEqs(),oEL_THM,state_rel_def,LIST_REL_EL_EQN] + \\ first_assum drule \\ asm_rewrite_tac [store_rel_def] \\ strip_tac + \\ Cases_on ‘EL n x''’ \\ gvs [state_rel_def,store_rel_def,LIST_REL_EL_EQN] + \\ simp [Once v_rel_cases] \\ strip_tac + \\ gvs [EL_LUPDATE] + \\ IF_CASES_TAC \\ rw [store_rel_def]) + >~ [‘ForceMutThunk’] >- + (once_rewrite_tac [application_def] + \\ rgs [Once application_def] + \\ qpat_x_assum ‘v_rel x h’ mp_tac + \\ simp [Once v_rel_cases] \\ strip_tac + \\ gvs [error_def,step_res_rel_cases] + \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] >> + gvs[oEL_THM] >> imp_res_tac state_rel_def >> gvs[LIST_REL_EL_EQN] >> + last_x_assum mp_tac >> + reverse $ IF_CASES_TAC >> gvs[] >- (rw[] >> gvs[]) >> + first_x_assum drule >> CASE_TAC >> simp[oneline store_rel_def] >> + rw[] >> gvs[] >> FULL_CASE_TAC >> gvs[] >> + CASE_TAC >> gvs[value_def] >> + ntac 2 $ simp[Once cont_rel_cases] >> + simp[Once v_rel_cases] >> goal_assum drule >> simp[]) >~ [‘FFI’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -415,13 +466,13 @@ Definition step_1_ind_hyp_def: step_1_ind_hyp k = (∀m tr' ts' tk' tr1' ts1' tk1' ss' sr' sk'. m < k ∧ step_n m (tr',ts',tk') = (tr1',ts1',tk1') ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts' ss' ∧ + OPTREL state_rel ts' ss' ∧ step_res_rel tr' tk' sr' sk' ⇒ ∃m' sr1 ss1 sk1. step_n m' (sr',ss',sk') = (sr1,ss1,sk1) ∧ m ≤ m' ∧ (is_halt (tr1',ts1',tk1') ⇔ is_halt (sr1,ss1,sk1)) ∧ (is_halt (tr1',ts1',tk1') ⇒ - OPTREL (LIST_REL (LIST_REL v_rel)) ts1' ss1 ∧ + OPTREL state_rel ts1' ss1 ∧ step_res_rel tr1' tk1' sr1 sk1)) End @@ -502,13 +553,13 @@ Theorem step_1_Exp_forward: step_n k (Exp env1 e1,ts,tk) = (tr1,ts1,tk1) ∧ step_1_ind_hyp k ∧ cont_rel tk sk ∧ compile_rel e1 e2 ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ + OPTREL state_rel ts ss ∧ env_rel env1 env2 ⇒ ∃m sr1 ss1 sk1. step_n m (Exp env2 e2,ss,sk) = (sr1,ss1,sk1) ∧ k ≤ m ∧ ((is_halt (sr1,ss1,sk1) ⇔ is_halt (tr1,ts1,tk1)) ∧ (is_halt (sr1,ss1,sk1) ⇒ - OPTREL (LIST_REL (LIST_REL v_rel)) ts1 ss1 ∧ + OPTREL state_rel ts1 ss1 ∧ step_res_rel tr1 tk1 sr1 sk1)) Proof ho_match_mp_tac compile_rel_strongind \\ rpt strip_tac @@ -724,16 +775,38 @@ Proof \\ fs []) QED +Theorem thunk_or_thunk_loc_rel: + v_rel v w ⇒ + thunk_or_thunk_loc v = thunk_or_thunk_loc w +Proof + ‘(∀v w. v_rel v w ⇒ thunk_or_thunk_loc v = thunk_or_thunk_loc w) ∧ + (∀x y. env_rel x y ⇒ T)’ + suffices_by gvs [] + \\ ho_match_mp_tac v_rel_strongind \\ rw [] \\ gvs [] + >~ [‘Constructor’] >- gvs [thunk_or_thunk_loc_def, dest_anyThunk_def] + >~ [‘Closure’] >- gvs [thunk_or_thunk_loc_def, dest_anyThunk_def] + \\ gvs [thunk_or_thunk_loc_def, dest_anyThunk_def] + \\ rpt (CASE_TAC \\ gvs []) + >>~ [‘ALOOKUP _ _ = NONE’] + >- ( + qpat_x_assum ‘MAP FST _ = MAP FST _’ (assume_tac o GSYM) + \\ drule_all ALOOKUP_SOME_EL_2 \\ gvs []) + >- (drule_all ALOOKUP_SOME_EL_2 \\ gvs []) + \\ ( + drule_all ALOOKUP_list_rel \\ rw [] \\ gvs [] + \\ rgs [Once compile_rel_cases] \\ gvs []) +QED + Theorem step_1_forward: ∀k tr ts tk tr1 ts1 tk1 ss sr sk. step_n k (tr,ts,tk) = (tr1,ts1,tk1) ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ + OPTREL state_rel ts ss ∧ step_res_rel tr tk sr sk ⇒ ∃m sr1 ss1 sk1. step_n m (sr,ss,sk) = (sr1,ss1,sk1) ∧ k ≤ m ∧ (is_halt (tr1,ts1,tk1) = is_halt (sr1,ss1,sk1) ∧ (is_halt (tr1,ts1,tk1) ⇒ - OPTREL (LIST_REL (LIST_REL v_rel)) ts1 ss1 ∧ + OPTREL state_rel ts1 ss1 ∧ step_res_rel tr1 tk1 sr1 sk1)) Proof gen_tac @@ -880,6 +953,31 @@ Proof \\ first_assum $ irule_at Any \\ fs [] \\ first_x_assum $ irule_at $ Pos hd \\ fs [] \\ simp [Once step_res_rel_cases]) + >~ [‘ForceMutK’] >- + (qrefine ‘SUC ck’ \\ gvs [ADD_CLAUSES, step_n_SUC, step] + \\ qpat_x_assum ‘_ = (tr1,ts1,tk1')’ mp_tac + \\ Cases_on ‘ts’ \\ gvs [OPTREL_def] + >- ( + rpt (TOP_CASE_TAC \\ gvs []) + \\ strip_tac + \\ last_x_assum irule \\ gvs [] + \\ metis_tac [step_res_rel_cases]) + \\ TOP_CASE_TAC \\ gvs [] + \\ drule_all thunk_or_thunk_loc_rel \\ gvs [] + >- ( + rw [] + \\ last_x_assum irule \\ gvs [] + \\ metis_tac [step_res_rel_cases]) + \\ rw [] + \\ ( + last_x_assum irule \\ gvs [PULL_EXISTS] + \\ goal_assum drule \\ gvs [step_res_rel_cases] + \\ gvs [state_rel_def, LIST_REL_EL_EQN, EL_LUPDATE] \\ rw [store_rel_def] + \\ qpat_x_assum ‘store_same_type _ _’ mp_tac + \\ qpat_x_assum ‘¬store_same_type _ _’ mp_tac + \\ simp [store_same_type_def] + \\ rpt (TOP_CASE_TAC \\ gvs []) + \\ last_x_assum drule \\ gvs [store_rel_def])) \\ rename [‘AppK’] \\ Q.REFINE_EXISTS_TAC ‘SUC ck’ \\ fs [ADD_CLAUSES,step_n_SUC,step] \\ reverse (Cases_on ‘tes’) \\ gvs [] \\ gvs [step] @@ -904,7 +1002,7 @@ QED Theorem step_until_halt_thm: step_res_rel tr tk sr sk ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ⇒ + OPTREL state_rel ts ss ⇒ snext_res_rel (step_until_halt (tr,ts,tk)) (step_until_halt (sr,ss,sk)) Proof @@ -969,7 +1067,7 @@ QED Theorem semantics_thm: compile_rel e1 e2 ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ + OPTREL state_rel ts ss ∧ env_rel tenv senv ∧ cont_rel tk sk ⇒ semantics e1 tenv ts tk = @@ -979,7 +1077,7 @@ Proof ∀t1 t2. (∃e1 e2 ts ss tenv senv tk sk. compile_rel e1 e2 ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ + OPTREL state_rel ts ss ∧ env_rel tenv senv ∧ cont_rel tk sk ∧ t1 = semantics e1 tenv ts tk ∧ @@ -1035,7 +1133,7 @@ Proof fs [stateLangTheory.itree_of_def] \\ rw [] \\ irule semantics_thm \\ simp [Once cont_rel_cases] - \\ fs [env_rel_def] + \\ fs [env_rel_def,state_rel_def] QED (* diff --git a/compiler/backend/passes/proofs/state_caseProofScript.sml b/compiler/backend/passes/proofs/state_caseProofScript.sml index a87b4ae7..b3c3fa76 100644 --- a/compiler/backend/passes/proofs/state_caseProofScript.sml +++ b/compiler/backend/passes/proofs/state_caseProofScript.sml @@ -108,6 +108,10 @@ Inductive v_rel: (∀a. v_rel (Atom a) (Atom a)) +[~ThunkLoc:] + (∀n. + v_rel (ThunkLoc n) (ThunkLoc n)) + [~Constructor:] (∀s tvs svs. LIST_REL v_rel tvs svs ⇒ @@ -151,6 +155,17 @@ Inductive step_res_rel: (step_res_rel (Action a b) (Action a b)) End +Definition store_rel_def: + store_rel (Array vs1) (Array vs2) = LIST_REL v_rel vs1 vs2 ∧ + store_rel (ThunkMem m1 v1) (ThunkMem m2 v2) = + (m1 = m2 ∧ v_rel v1 v2) ∧ + store_rel _ _ = F +End + +Definition state_rel_def: + state_rel st1 st2 = LIST_REL store_rel st1 st2 +End + Inductive cont_rel: (cont_rel [] []) ∧ (∀tenv senv op tvs svs tes ses sk tk. @@ -181,7 +196,12 @@ Inductive cont_rel: (∀sk tk. cont_rel tk sk ⇒ cont_rel (RaiseK :: tk) - (RaiseK :: sk)) + (RaiseK :: sk)) ∧ + (∀sk tk s1 s2 n. + cont_rel tk sk ∧ + state_rel s1 s2 ∧ + n < LENGTH s1 ⇒ + cont_rel (ForceMutK n::tk) (ForceMutK n::sk)) End Definition rec_env_def: @@ -190,7 +210,7 @@ Definition rec_env_def: End Inductive snext_res_rel: - (OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ cont_rel tk sk ⇒ + (OPTREL state_rel ts ss ∧ cont_rel tk sk ⇒ snext_res_rel (Act x tk ts) (Act x sk ss)) ∧ (snext_res_rel Ret Ret) ∧ (snext_res_rel Div Div) ∧ @@ -248,16 +268,18 @@ Proof QED Theorem application_thm: - application op tvs ts tk = (tr1,ts1,tk1) ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ cont_rel tk sk ∧ - LIST_REL v_rel tvs svs ∧ - num_args_ok op (LENGTH svs) ⇒ - ∃sr1 ss1 sk1. - application op svs ss sk = (sr1,ss1,sk1) ∧ - cont_rel tk1 sk1 ∧ OPTREL (LIST_REL (LIST_REL v_rel)) ts1 ss1 ∧ - step_res_rel tr1 sr1 + ∀op tvs ts tk tr1 ts1 tk1 ss sk svs. + application op tvs ts tk = (tr1,ts1,tk1) ∧ + OPTREL state_rel ts ss ∧ cont_rel tk sk ∧ + LIST_REL v_rel tvs svs ∧ + num_args_ok op (LENGTH svs) ⇒ + ∃sr1 ss1 sk1. + application op svs ss sk = (sr1,ss1,sk1) ∧ + cont_rel tk1 sk1 ∧ OPTREL state_rel ts1 ss1 ∧ + step_res_rel tr1 sr1 Proof - Cases_on ‘op’ \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] + Cases \\ rw [] + \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] \\ rw [] \\ gvs [] >~ [‘Cons’] >- (gvs [application_def,step,step_res_rel_cases] @@ -311,16 +333,11 @@ Proof \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] \\ gvs [AllCaseEqs()] \\ Cases_on ‘ss’ \\ gvs [] + \\ fs [state_rel_def] \\ imp_res_tac LIST_REL_LENGTH \\ fs [] \\ simp [Once v_rel_cases] - \\ fs [LIST_REL_SNOC] + \\ fs [LIST_REL_SNOC,store_rel_def] \\ simp [LIST_REL_EL_EQN,EL_REPLICATE]) - >~ [‘Ref’] >- - (gvs [application_def,step,step_res_rel_cases] - \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] - \\ imp_res_tac LIST_REL_LENGTH \\ fs [] - \\ simp [Once v_rel_cases] - \\ fs [LIST_REL_SNOC]) >~ [‘Length’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -329,8 +346,12 @@ Proof \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] \\ imp_res_tac LIST_REL_LENGTH \\ fs [oEL_THM] \\ IF_CASES_TAC \\ gvs [] + \\ gvs [LIST_REL_EL_EQN,state_rel_def] + \\ Cases_on ‘EL n x’ \\ Cases_on ‘EL n x'’ \\ gvs [store_rel_def] + \\ res_tac \\ Cases_on ‘EL n x’ \\ gvs [store_rel_def] \\ simp [Once v_rel_cases] - \\ gvs [LIST_REL_EL_EQN]) + \\ gvs [LIST_REL_EL_EQN,state_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ fs []) >~ [‘Sub’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -342,24 +363,21 @@ Proof \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] \\ imp_res_tac LIST_REL_LENGTH \\ fs [oEL_THM] \\ rpt (IF_CASES_TAC \\ gvs []) + \\ gvs [state_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ gvs [state_rel_def] + \\ Cases_on ‘EL n x’ \\ Cases_on ‘EL n x'’ + \\ gvs [state_rel_def,LIST_REL_EL_EQN] + \\ res_tac \\ Cases_on ‘EL n x’ \\ gvs [store_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ fs [] \\ gvs [LIST_REL_EL_EQN] - \\ ntac 2 (simp [Once compile_rel_cases,env_rel_def]) - \\ imp_res_tac integerTheory.NUM_POSINT_EXISTS \\ gvs [] - \\ simp[Once v_rel_cases]) - >~ [‘UnsafeSub’] >- - (gvs [application_def,step,step_res_rel_cases] - \\ qpat_x_assum ‘v_rel x h’ mp_tac - \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] - \\ Cases_on ‘a’ \\ gvs [] - \\ qpat_x_assum ‘v_rel _ _’ mp_tac - \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] - \\ Cases_on ‘a’ \\ gvs [] - \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] - \\ imp_res_tac LIST_REL_LENGTH \\ fs [oEL_THM] - \\ rpt (IF_CASES_TAC \\ gvs []) - \\ gvs [LIST_REL_EL_EQN] - \\ ntac 2 (simp [Once compile_rel_cases,env_rel_def]) - \\ imp_res_tac integerTheory.NUM_POSINT_EXISTS \\ gvs []) + \\ Cases_on ‘0 ≤ i’ \\ gvs [] + >- + (imp_res_tac integerTheory.NUM_POSINT_EXISTS + \\ first_x_assum $ qspec_then ‘&n'’ assume_tac + \\ gvs [] + \\ Cases_on ‘n' < LENGTH l'’ \\ gvs [] + \\ gvs [Once v_rel_cases,LIST_REL_EL_EQN,state_rel_def]) + >- simp [Once v_rel_cases,LIST_REL_EL_EQN,state_rel_def]) >~ [‘Update’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -371,29 +389,66 @@ Proof \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] \\ imp_res_tac LIST_REL_LENGTH \\ fs [oEL_THM] \\ rpt (IF_CASES_TAC \\ gvs []) + \\ gvs [state_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ gvs [state_rel_def] + \\ Cases_on ‘EL n x’ \\ Cases_on ‘EL n x'’ + \\ gvs [state_rel_def,LIST_REL_EL_EQN] + \\ res_tac \\ Cases_on ‘EL n x’ \\ gvs [store_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ fs [] \\ gvs [LIST_REL_EL_EQN] - \\ ntac 2 (simp [Once compile_rel_cases,env_rel_def]) - \\ imp_res_tac integerTheory.NUM_POSINT_EXISTS \\ gvs [] - \\ gvs [EL_LUPDATE] \\ rw [] - \\ gvs [EL_LUPDATE] \\ rw [] - \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs []) - >~ [‘UnsafeUpdate’] >- + \\ Cases_on ‘0 ≤ i’ \\ gvs [] + >- + (imp_res_tac integerTheory.NUM_POSINT_EXISTS + \\ first_x_assum $ qspec_then ‘&n'’ assume_tac \\ gvs [] + \\ Cases_on ‘n' < LENGTH l'’ \\ gvs [] + \\ simp [Once v_rel_cases,LIST_REL_EL_EQN,state_rel_def] + \\ rpt strip_tac + \\ gvs [EL_LUPDATE] + \\ Cases_on ‘n'' = n’ \\ gvs [] + \\ rw [LIST_REL_EL_EQN,store_rel_def] + \\ gvs [EL_LUPDATE] + \\ Cases_on ‘n'' = n'’ \\ gvs [] + \\ res_tac \\ Cases_on ‘EL n x’ \\ gvs [store_rel_def] + \\ gvs [LIST_REL_EL_EQN]) + >- simp [Once v_rel_cases,LIST_REL_EL_EQN,state_rel_def]) + >~ [‘AllocMutThunk’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] - \\ Cases_on ‘a’ \\ gvs [] - \\ qpat_x_assum ‘v_rel _ h'’ mp_tac + \\ gvs [AllCaseEqs()] + \\ Cases_on ‘ss’ \\ gvs [] + \\ fs [state_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ fs [] + \\ simp [Once v_rel_cases] + \\ fs [LIST_REL_SNOC,store_rel_def] + \\ simp [Once v_rel_cases,LIST_REL_EL_EQN,EL_REPLICATE] + \\ gvs [LIST_REL_EL_EQN]) + >~ [‘UpdateMutThunk’] >- + (gvs [application_def,step,step_res_rel_cases] + \\ qpat_x_assum ‘v_rel x h’ mp_tac \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] - \\ Cases_on ‘a’ \\ gvs [] \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] - \\ imp_res_tac LIST_REL_LENGTH \\ fs [oEL_THM] - \\ rpt (IF_CASES_TAC \\ gvs []) - \\ gvs [LIST_REL_EL_EQN] - \\ ntac 2 (simp [Once compile_rel_cases,env_rel_def]) - \\ imp_res_tac integerTheory.NUM_POSINT_EXISTS \\ gvs [] - \\ gvs [EL_LUPDATE] \\ rw [] - \\ gvs [EL_LUPDATE] \\ rw [] - \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs []) + \\ gvs [AllCaseEqs(),oEL_THM,state_rel_def,LIST_REL_EL_EQN] + \\ first_assum drule \\ asm_rewrite_tac [store_rel_def] \\ strip_tac + \\ Cases_on ‘EL n x''’ \\ gvs [state_rel_def,store_rel_def,LIST_REL_EL_EQN] + \\ simp [Once v_rel_cases] \\ strip_tac + \\ gvs [EL_LUPDATE] + \\ IF_CASES_TAC \\ rw [store_rel_def]) + >~ [‘ForceMutThunk’] >- + (once_rewrite_tac [application_def] + \\ rgs [Once application_def] + \\ qpat_x_assum ‘v_rel x h’ mp_tac + \\ simp [Once v_rel_cases] \\ strip_tac + \\ gvs [error_def,step_res_rel_cases] + \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] >> + gvs[oEL_THM] >> imp_res_tac state_rel_def >> gvs[LIST_REL_EL_EQN] >> + last_x_assum mp_tac >> + reverse $ IF_CASES_TAC >> gvs[] >- (rw[] >> gvs[]) >> + first_x_assum drule >> CASE_TAC >> simp[oneline store_rel_def] >> + rw[] >> gvs[] >> FULL_CASE_TAC >> gvs[] >> + CASE_TAC >> gvs[value_def] >> + ntac 2 $ simp[Once cont_rel_cases] >> + simp[env_rel_def, Once v_rel_cases] >> goal_assum drule >> simp[]) >~ [‘FFI’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -446,15 +501,40 @@ Proof \\ irule env_rel_cons \\ fs [] QED +Theorem thunk_or_thunk_loc_rel: + v_rel v w ⇒ + thunk_or_thunk_loc v = thunk_or_thunk_loc w +Proof + ‘(∀v w. v_rel v w ⇒ thunk_or_thunk_loc v = thunk_or_thunk_loc w) ∧ + (∀x y. env_rel x y ⇒ T)’ + suffices_by gvs [] + \\ ho_match_mp_tac v_rel_strongind \\ rw [] \\ gvs [] + >~ [‘Constructor’] >- gvs [thunk_or_thunk_loc_def, dest_anyThunk_def] + >~ [‘Closure’] >- gvs [thunk_or_thunk_loc_def, dest_anyThunk_def] + \\ gvs [thunk_or_thunk_loc_def, dest_anyThunk_def] + \\ rpt (CASE_TAC \\ gvs []) + >>~ [‘ALOOKUP _ _ = NONE’] + >- ( + qpat_x_assum ‘MAP FST _ = MAP FST _’ (assume_tac o GSYM) + \\ drule_all ALOOKUP_SOME_EL_2 \\ gvs []) + >- (drule_all ALOOKUP_SOME_EL_2 \\ gvs []) + \\ ( + drule_all ALOOKUP_list_rel \\ rw [] \\ gvs [] + \\ rgs [Once compile_rel_cases] \\ gvs [] + \\ rpt strip_tac \\ gvs [] + \\ rpt (dxrule_then assume_tac ALOOKUP_SOME_EL) \\ gvs [EVERY_EL] + \\ first_x_assum drule \\ gvs []) +QED + Theorem step_1_forward: ∀tr ts tk tr1 ts1 tk1 ss sr sk. step_n 1 (tr,ts,tk) = (tr1,ts1,tk1) ∧ - cont_rel tk sk ∧ OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ + cont_rel tk sk ∧ OPTREL state_rel ts ss ∧ step_res_rel tr sr ⇒ ∃m sr1 ss1 sk1. step_n (m+1) (sr,ss,sk) = (sr1,ss1,sk1) ∧ (tr1 ≠ Error ⇒ cont_rel tk1 sk1) ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts1 ss1 ∧ + OPTREL state_rel ts1 ss1 ∧ step_res_rel tr1 sr1 Proof rpt strip_tac @@ -648,6 +728,23 @@ Proof (Cases_on ‘n’ \\ gvs [step,step_res_rel_cases] \\ irule env_rel_cons \\ simp [] \\ first_assum $ irule_at Any \\ fs []) + >~ [‘ForceMutK’] >- + (gvs [step] + \\ qpat_x_assum ‘_ = (tr1,ts1,tk1')’ mp_tac + \\ Cases_on ‘ss’ \\ gvs [OPTREL_def] + >- (rpt (TOP_CASE_TAC \\ gvs []) \\ simp [step_res_rel_cases]) + \\ TOP_CASE_TAC \\ gvs [] + \\ drule_all thunk_or_thunk_loc_rel \\ gvs [] >- rw [step_res_rel_cases] + \\ rw [] + \\ ( + gvs [state_rel_def, LIST_REL_EL_EQN, EL_LUPDATE] \\ rw [] + \\ simp [step_res_rel_cases, store_rel_def] + \\ qpat_x_assum ‘store_same_type _ _’ mp_tac + \\ qpat_x_assum ‘¬store_same_type _ _’ mp_tac + \\ simp [store_same_type_def] + \\ rpt (TOP_CASE_TAC \\ gvs []) \\ simp [store_rel_def] + \\ last_x_assum drule \\ gvs [] + \\ simp [store_rel_def])) \\ rename [‘AppK’] \\ reverse (Cases_on ‘tes’) \\ gvs [] \\ gvs [step] >- (simp [Once cont_rel_cases, step_res_rel_cases] \\ rw []) @@ -661,12 +758,12 @@ QED Theorem step_n_forward: ∀n tr ts tk tr1 ts1 tk1 ss sr sk. step_n n (tr,ts,tk) = (tr1,ts1,tk1) ∧ - cont_rel tk sk ∧ OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ + cont_rel tk sk ∧ OPTREL state_rel ts ss ∧ step_res_rel tr sr ⇒ ∃m sr1 ss1 sk1. step_n (m+n) (sr,ss,sk) = (sr1,ss1,sk1) ∧ (tr1 ≠ Error ⇒ cont_rel tk1 sk1) ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts1 ss1 ∧ + OPTREL state_rel ts1 ss1 ∧ step_res_rel tr1 sr1 Proof Induct \\ fs [] \\ rw [] @@ -696,7 +793,7 @@ QED Theorem step_until_halt_thm: step_res_rel tr sr ∧ cont_rel tk sk ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ⇒ + OPTREL state_rel ts ss ⇒ snext_res_rel (step_until_halt (tr,ts,tk)) (step_until_halt (sr,ss,sk)) Proof @@ -751,7 +848,7 @@ QED Theorem semantics_thm: compile_rel e1 e2 ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ + OPTREL state_rel ts ss ∧ env_rel tenv senv ∧ cont_rel tk sk ⇒ semantics e1 tenv ts tk = @@ -761,7 +858,7 @@ Proof ∀t1 t2. (∃e1 e2 ts ss tenv senv tk sk. compile_rel e1 e2 ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ + OPTREL state_rel ts ss ∧ env_rel tenv senv ∧ cont_rel tk sk ∧ t1 = semantics e1 tenv ts tk ∧ @@ -817,5 +914,5 @@ Proof fs [stateLangTheory.itree_of_def] \\ rw [] \\ irule semantics_thm \\ simp [Once cont_rel_cases] - \\ fs [env_rel_def] + \\ fs [env_rel_def,state_rel_def] QED diff --git a/compiler/backend/passes/proofs/state_names_1ProofScript.sml b/compiler/backend/passes/proofs/state_names_1ProofScript.sml index cb34639f..9ca10e26 100644 --- a/compiler/backend/passes/proofs/state_names_1ProofScript.sml +++ b/compiler/backend/passes/proofs/state_names_1ProofScript.sml @@ -81,6 +81,10 @@ Inductive v_rel: (∀a. v_rel (Atom a) (Atom a)) +[~ThunkLoc:] + (∀n. + v_rel (ThunkLoc n) (ThunkLoc n)) + [~Constructor:] (∀s tvs svs. LIST_REL v_rel tvs svs ⇒ @@ -129,6 +133,17 @@ Inductive step_res_rel: (step_res_rel (Action a b) (Action a b)) End +Definition store_rel_def: + store_rel (Array vs1) (Array vs2) = LIST_REL v_rel vs1 vs2 ∧ + store_rel (ThunkMem m1 v1) (ThunkMem m2 v2) = + (m1 = m2 ∧ v_rel v1 v2) ∧ + store_rel _ _ = F +End + +Definition state_rel_def: + state_rel st1 st2 = LIST_REL store_rel st1 st2 +End + Inductive cont_rel: (cont_rel [] []) ∧ (∀tenv senv op tvs svs tes ses sk tk s. @@ -164,7 +179,12 @@ Inductive cont_rel: (∀sk tk. cont_rel tk sk ⇒ cont_rel (RaiseK :: tk) - (RaiseK :: sk)) + (RaiseK :: sk)) ∧ + (∀sk tk s1 s2 n. + cont_rel tk sk ∧ + state_rel s1 s2 ∧ + n < LENGTH s1 ⇒ + cont_rel (ForceMutK n::tk) (ForceMutK n::sk)) End Definition rec_env_def: @@ -173,7 +193,7 @@ Definition rec_env_def: End Inductive snext_res_rel: - (OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ cont_rel tk sk ⇒ + (OPTREL state_rel ts ss ∧ cont_rel tk sk ⇒ snext_res_rel (Act x tk ts) (Act x sk ss)) ∧ (snext_res_rel Ret Ret) ∧ (snext_res_rel Div Div) ∧ @@ -262,16 +282,18 @@ Proof QED Theorem application_thm: - application op tvs ts tk = (tr1,ts1,tk1) ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ cont_rel tk sk ∧ - LIST_REL v_rel tvs svs ∧ - num_args_ok op (LENGTH svs) ⇒ - ∃sr1 ss1 sk1. - application op svs ss sk = (sr1,ss1,sk1) ∧ - cont_rel tk1 sk1 ∧ OPTREL (LIST_REL (LIST_REL v_rel)) ts1 ss1 ∧ - step_res_rel tr1 sr1 + ∀op tvs ts tk tr1 ts1 tk1 ss sk svs. + application op tvs ts tk = (tr1,ts1,tk1) ∧ + OPTREL state_rel ts ss ∧ cont_rel tk sk ∧ + LIST_REL v_rel tvs svs ∧ + num_args_ok op (LENGTH svs) ⇒ + ∃sr1 ss1 sk1. + application op svs ss sk = (sr1,ss1,sk1) ∧ + cont_rel tk1 sk1 ∧ OPTREL state_rel ts1 ss1 ∧ + step_res_rel tr1 sr1 Proof - Cases_on ‘op’ \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] + Cases \\ rw[] + \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] \\ rw [] \\ gvs [] >~ [‘Cons’] >- (gvs [application_def,step,step_res_rel_cases] @@ -347,16 +369,11 @@ Proof \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] \\ gvs [AllCaseEqs()] \\ Cases_on ‘ss’ \\ gvs [] + \\ fs [state_rel_def] \\ imp_res_tac LIST_REL_LENGTH \\ fs [] \\ simp [Once v_rel_cases] - \\ fs [LIST_REL_SNOC] + \\ fs [LIST_REL_SNOC,store_rel_def] \\ simp [LIST_REL_EL_EQN,EL_REPLICATE]) - >~ [‘Ref’] >- - (gvs [application_def,step,step_res_rel_cases] - \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] - \\ imp_res_tac LIST_REL_LENGTH \\ fs [] - \\ simp [Once v_rel_cases] - \\ fs [LIST_REL_SNOC]) >~ [‘Length’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -365,8 +382,12 @@ Proof \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] \\ imp_res_tac LIST_REL_LENGTH \\ fs [oEL_THM] \\ IF_CASES_TAC \\ gvs [] + \\ gvs [LIST_REL_EL_EQN,state_rel_def] + \\ Cases_on ‘EL n x’ \\ Cases_on ‘EL n x'’ \\ gvs [store_rel_def] + \\ res_tac \\ Cases_on ‘EL n x’ \\ gvs [store_rel_def] \\ simp [Once v_rel_cases] - \\ gvs [LIST_REL_EL_EQN]) + \\ gvs [LIST_REL_EL_EQN,state_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ fs []) >~ [‘Sub’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -378,24 +399,21 @@ Proof \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] \\ imp_res_tac LIST_REL_LENGTH \\ fs [oEL_THM] \\ rpt (IF_CASES_TAC \\ gvs []) + \\ gvs [state_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ gvs [state_rel_def] + \\ Cases_on ‘EL n x’ \\ Cases_on ‘EL n x'’ + \\ gvs [state_rel_def,LIST_REL_EL_EQN] + \\ res_tac \\ Cases_on ‘EL n x’ \\ gvs [store_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ fs [] \\ gvs [LIST_REL_EL_EQN] - \\ ntac 2 (simp [Once compile_rel_cases,env_rel_def]) - \\ imp_res_tac integerTheory.NUM_POSINT_EXISTS \\ gvs [] - \\ simp[Once v_rel_cases]) - >~ [‘UnsafeSub’] >- - (gvs [application_def,step,step_res_rel_cases] - \\ qpat_x_assum ‘v_rel x h’ mp_tac - \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] - \\ Cases_on ‘a’ \\ gvs [] - \\ qpat_x_assum ‘v_rel _ _’ mp_tac - \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] - \\ Cases_on ‘a’ \\ gvs [] - \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] - \\ imp_res_tac LIST_REL_LENGTH \\ fs [oEL_THM] - \\ rpt (IF_CASES_TAC \\ gvs []) - \\ gvs [LIST_REL_EL_EQN] - \\ ntac 2 (simp [Once compile_rel_cases,env_rel_def]) - \\ imp_res_tac integerTheory.NUM_POSINT_EXISTS \\ gvs []) + \\ Cases_on ‘0 ≤ i’ \\ gvs [] + >- + (imp_res_tac integerTheory.NUM_POSINT_EXISTS + \\ first_x_assum $ qspec_then ‘&n'’ assume_tac + \\ gvs [] + \\ Cases_on ‘n' < LENGTH l'’ \\ gvs [] + \\ gvs [Once v_rel_cases,LIST_REL_EL_EQN,state_rel_def]) + >- simp [Once v_rel_cases,LIST_REL_EL_EQN,state_rel_def]) >~ [‘Update’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -407,29 +425,66 @@ Proof \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] \\ imp_res_tac LIST_REL_LENGTH \\ fs [oEL_THM] \\ rpt (IF_CASES_TAC \\ gvs []) + \\ gvs [state_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ gvs [state_rel_def] + \\ Cases_on ‘EL n x’ \\ Cases_on ‘EL n x'’ + \\ gvs [state_rel_def,LIST_REL_EL_EQN] + \\ res_tac \\ Cases_on ‘EL n x’ \\ gvs [store_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ fs [] \\ gvs [LIST_REL_EL_EQN] - \\ ntac 2 (simp [Once compile_rel_cases,env_rel_def]) - \\ imp_res_tac integerTheory.NUM_POSINT_EXISTS \\ gvs [] - \\ gvs [EL_LUPDATE] \\ rw [] - \\ gvs [EL_LUPDATE] \\ rw [] - \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs []) - >~ [‘UnsafeUpdate’] >- + \\ Cases_on ‘0 ≤ i’ \\ gvs [] + >- + (imp_res_tac integerTheory.NUM_POSINT_EXISTS + \\ first_x_assum $ qspec_then ‘&n'’ assume_tac \\ gvs [] + \\ Cases_on ‘n' < LENGTH l'’ \\ gvs [] + \\ simp [Once v_rel_cases,LIST_REL_EL_EQN,state_rel_def] + \\ rpt strip_tac + \\ gvs [EL_LUPDATE] + \\ Cases_on ‘n'' = n’ \\ gvs [] + \\ rw [LIST_REL_EL_EQN,store_rel_def] + \\ gvs [EL_LUPDATE] + \\ Cases_on ‘n'' = n'’ \\ gvs [] + \\ res_tac \\ Cases_on ‘EL n x’ \\ gvs [store_rel_def] + \\ gvs [LIST_REL_EL_EQN]) + >- simp [Once v_rel_cases,LIST_REL_EL_EQN,state_rel_def]) + >~ [‘AllocMutThunk’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] - \\ Cases_on ‘a’ \\ gvs [] - \\ qpat_x_assum ‘v_rel _ h'’ mp_tac + \\ gvs [AllCaseEqs()] + \\ Cases_on ‘ss’ \\ gvs [] + \\ fs [state_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ fs [] + \\ simp [Once v_rel_cases] + \\ fs [LIST_REL_SNOC,store_rel_def] + \\ simp [Once v_rel_cases,LIST_REL_EL_EQN,EL_REPLICATE] + \\ gvs [LIST_REL_EL_EQN]) + >~ [‘UpdateMutThunk’] >- + (gvs [application_def,step,step_res_rel_cases] + \\ qpat_x_assum ‘v_rel x h’ mp_tac \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] - \\ Cases_on ‘a’ \\ gvs [] \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] - \\ imp_res_tac LIST_REL_LENGTH \\ fs [oEL_THM] - \\ rpt (IF_CASES_TAC \\ gvs []) - \\ gvs [LIST_REL_EL_EQN] - \\ ntac 2 (simp [Once compile_rel_cases,env_rel_def]) - \\ imp_res_tac integerTheory.NUM_POSINT_EXISTS \\ gvs [] - \\ gvs [EL_LUPDATE] \\ rw [] - \\ gvs [EL_LUPDATE] \\ rw [] - \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs []) + \\ gvs [AllCaseEqs(),oEL_THM,state_rel_def,LIST_REL_EL_EQN] + \\ first_assum drule \\ asm_rewrite_tac [store_rel_def] \\ strip_tac + \\ Cases_on ‘EL n x''’ \\ gvs [state_rel_def,store_rel_def,LIST_REL_EL_EQN] + \\ simp [Once v_rel_cases] \\ strip_tac + \\ gvs [EL_LUPDATE] + \\ IF_CASES_TAC \\ rw [store_rel_def]) + >~ [‘ForceMutThunk’] >- + (once_rewrite_tac [application_def] + \\ rgs [Once application_def] + \\ qpat_x_assum ‘v_rel x h’ mp_tac + \\ simp [Once v_rel_cases] \\ strip_tac + \\ gvs [error_def,step_res_rel_cases] + \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] >> + gvs[oEL_THM] >> imp_res_tac state_rel_def >> gvs[LIST_REL_EL_EQN] >> + last_x_assum mp_tac >> + reverse $ IF_CASES_TAC >> gvs[] >- (rw[] >> gvs[]) >> + first_x_assum drule >> CASE_TAC >> simp[oneline store_rel_def] >> + rw[] >> gvs[] >> FULL_CASE_TAC >> gvs[] >> + CASE_TAC >> gvs[value_def] >> + ntac 2 $ simp[Once cont_rel_cases] >> + simp[env_rel_def, Once v_rel_cases] >> goal_assum drule >> simp[]) >~ [‘FFI’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -484,14 +539,31 @@ Proof \\ fs [SUBSET_DEF] QED +Theorem thunk_or_thunk_loc_rel: + v_rel v w ∧ + ¬thunk_or_thunk_loc v ⇒ + ¬thunk_or_thunk_loc w +Proof + simp [thunk_or_thunk_loc_def, dest_anyThunk_def] + \\ rpt (TOP_CASE_TAC \\ gvs []) + \\ simp [Once v_rel_cases] \\ gvs [AllCaseEqs()] + \\ rpt strip_tac \\ gvs [] + \\ Cases_on ‘LIST_REL compile_rel (MAP SND l0) (MAP SND f)’ \\ gvs [] + >- ( + qpat_x_assum ‘MAP FST _ = MAP FST _’ (assume_tac o GSYM) + \\ drule_all ALOOKUP_SOME_EL_2 \\ gvs []) + \\ drule_all ALOOKUP_list_rel \\ rw [] \\ gvs [] + \\ rgs [Once compile_rel_cases] +QED + Theorem step_1_forward: ∀tr ts tk tr1 ts1 tk1 ss sr sk. step_n 1 (tr,ts,tk) = (tr1,ts1,tk1) ∧ - cont_rel tk sk ∧ OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ + cont_rel tk sk ∧ OPTREL state_rel ts ss ∧ step_res_rel tr sr ∧ tr1 ≠ Error ⇒ ∃m sr1 ss1 sk1. step_n (m+1) (sr,ss,sk) = (sr1,ss1,sk1) ∧ - cont_rel tk1 sk1 ∧ OPTREL (LIST_REL (LIST_REL v_rel)) ts1 ss1 ∧ + cont_rel tk1 sk1 ∧ OPTREL state_rel ts1 ss1 ∧ step_res_rel tr1 sr1 Proof rpt strip_tac @@ -639,6 +711,25 @@ Proof >- gvs [env_rel_def,SUBSET_DEF] \\ irule env_rel_cons \\ simp [] \\ first_assum $ irule_at Any \\ fs []) + >~ [‘ForceMutK’] >- + (gvs [step] + \\ last_x_assum mp_tac + \\ ntac 2 (TOP_CASE_TAC \\ gvs[]) \\ gvs [OPTREL_def] + \\ drule_all_then assume_tac thunk_or_thunk_loc_rel \\ gvs [] + \\ TOP_CASE_TAC \\ gvs [] + \\ strip_tac \\ gvs[] + \\ gvs [state_rel_def, LIST_REL_EL_EQN, PULL_EXISTS] + \\ qpat_x_assum ‘store_same_type _ _’ mp_tac + \\ simp [oneline store_same_type_def] + \\ ntac 2 (TOP_CASE_TAC \\ gvs []) + \\ first_assum drule + \\ pure_rewrite_tac [oneline store_rel_def] \\ simp [] + \\ TOP_CASE_TAC \\ gvs [] + \\ strip_tac \\ gvs [] + \\ reverse $ rw [] >- simp [step_res_rel_cases] + \\ rw [EL_LUPDATE] + \\ rpt (TOP_CASE_TAC \\ gvs []) + \\ first_x_assum drule \\ simp [store_rel_def]) \\ rename [‘AppK’] \\ reverse (Cases_on ‘tes’) \\ gvs [] \\ gvs [step] >- @@ -654,11 +745,11 @@ QED Theorem step_n_forward: ∀n tr ts tk tr1 ts1 tk1 ss sr sk. step_n n (tr,ts,tk) = (tr1,ts1,tk1) ∧ - cont_rel tk sk ∧ OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ + cont_rel tk sk ∧ OPTREL state_rel ts ss ∧ step_res_rel tr sr ∧ tr1 ≠ Error ⇒ ∃m sr1 ss1 sk1. step_n (m+n) (sr,ss,sk) = (sr1,ss1,sk1) ∧ - cont_rel tk1 sk1 ∧ OPTREL (LIST_REL (LIST_REL v_rel)) ts1 ss1 ∧ + cont_rel tk1 sk1 ∧ OPTREL state_rel ts1 ss1 ∧ step_res_rel tr1 sr1 Proof Induct \\ fs [] \\ rw [] @@ -680,7 +771,7 @@ QED Theorem step_until_halt_thm: step_res_rel tr sr ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ + OPTREL state_rel ts ss ∧ cont_rel tk sk ∧ step_until_halt (tr,ts,tk) ≠ Err ⇒ snext_res_rel (step_until_halt (tr,ts,tk)) @@ -718,7 +809,7 @@ QED Theorem semantics_thm: compile_rel e1 e2 ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ + OPTREL state_rel ts ss ∧ env_rel (freevars e1) tenv senv ∧ cont_rel tk sk ⇒ semantics e1 tenv ts tk ---> @@ -728,7 +819,7 @@ Proof ∀t1 t2. (∃e1 e2 ts ss tenv senv tk sk. compile_rel e1 e2 ∧ - OPTREL (LIST_REL (LIST_REL v_rel)) ts ss ∧ + OPTREL state_rel ts ss ∧ env_rel (freevars e1) tenv senv ∧ cont_rel tk sk ∧ t1 = semantics e1 tenv ts tk ∧ @@ -787,5 +878,5 @@ Proof fs [stateLangTheory.itree_of_def] \\ rw [] \\ irule semantics_thm \\ simp [Once cont_rel_cases] - \\ fs [env_rel_def] + \\ fs [env_rel_def,state_rel_def] QED diff --git a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml index 1233b90b..7ef6e2cf 100644 --- a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml +++ b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml @@ -205,12 +205,14 @@ End Inductive op_rel: op_rel AppOp Opapp ∧ (atom_op_rel aop op ⇒ op_rel (AtomOp aop) op) ∧ - op_rel Ref AallocFixed ∧ op_rel Length Alength ∧ op_rel Sub Asub ∧ - op_rel UnsafeSub Asub_unsafe ∧ op_rel Update Aupdate ∧ - op_rel UnsafeUpdate Aupdate_unsafe + op_rel (AllocMutThunk Evaluated) (ThunkOp $ AllocThunk Evaluated) ∧ + op_rel (AllocMutThunk NotEvaluated) (ThunkOp $ AllocThunk NotEvaluated) ∧ + op_rel (UpdateMutThunk Evaluated) (ThunkOp $ UpdateThunk Evaluated) ∧ + op_rel (UpdateMutThunk NotEvaluated) (ThunkOp $ UpdateThunk NotEvaluated) ∧ + op_rel ForceMutThunk (ThunkOp ForceThunk) End Definition pat_row_def: @@ -401,54 +403,59 @@ End Inductive v_rel: [~Tuple:] - (LIST_REL (v_rel cnenv) svs cvs - ⇒ v_rel cnenv (Constructor "" svs) (Conv NONE cvs)) + (LIST_REL (v_rel cnenv st) svs cvs + ⇒ v_rel cnenv st (Constructor "" svs) (Conv NONE cvs)) [~Constructor:] - (LIST_REL (v_rel cnenv) svs cvs ∧ + (LIST_REL (v_rel cnenv st) svs cvs ∧ ALOOKUP cnenv cn = SOME (tyid,ar) ∧ ar = LENGTH svs ∧ cn ≠ "" - ⇒ v_rel cnenv (Constructor cn svs) (Conv (SOME tyid) cvs)) + ⇒ v_rel cnenv st (Constructor cn svs) (Conv (SOME tyid) cvs)) [~Closure:] - (compile_rel cnenv se ce ∧ env_rel cnenv senv cenv ∧ env_ok cenv - ⇒ v_rel cnenv (Closure (SOME sx) senv se) (Closure cenv (var_prefix sx) ce)) + (compile_rel cnenv se ce ∧ env_rel cnenv st senv cenv ∧ env_ok cenv + ⇒ v_rel cnenv st (Closure (SOME sx) senv se) (Closure cenv (var_prefix sx) ce)) [~Recclosure:] - (compile_rel cnenv se ce ∧ env_rel cnenv senv cenv ∧ env_ok cenv ∧ + (compile_rel cnenv se ce ∧ env_rel cnenv st senv cenv∧ env_ok cenv ∧ LIST_REL (λ(sv,se) (cv,cx,ce). var_prefix sv = cv ∧ ∃sx se'. se = Lam (SOME sx) se' ∧ var_prefix sx = cx ∧ compile_rel cnenv se' ce) sfuns cfuns ∧ ALL_DISTINCT (MAP FST cfuns) - ⇒ v_rel cnenv (stateLang$Recclosure sfuns senv sx) - (Recclosure cenv cfuns (var_prefix sx))) + ⇒ v_rel cnenv st (stateLang$Recclosure sfuns senv sx) + (Recclosure cenv cfuns (var_prefix sx))) [~IntLit:] - v_rel cnenv (Atom $ Int i) (Litv $ IntLit i) + v_rel cnenv st (Atom $ Int i) (Litv $ IntLit i) [~StrLit:] - v_rel cnenv (Atom $ Str s) (Litv $ StrLit s) + v_rel cnenv st (Atom $ Str s) (Litv $ StrLit s) [~Loc:] - v_rel cnenv (Atom $ Loc n) (Loc T (n + 1)) (* leave space for FFI array *) + (n < LENGTH st ∧ + (∀t v. EL n st ≠ ThunkMem t v) + ⇒ v_rel cnenv st (Atom $ Loc n) (Loc b (n + 1))) (* leave space for FFI array *) + +[~ThunkLoc:] + v_rel cnenv st (ThunkLoc n) (Loc b (n + 1)) [~env_rel:] (cnenv_rel cnenv cenv.c ∧ (∀sx sv. ALOOKUP senv sx = SOME sv ⇒ - ∃cv. nsLookup cenv.v (Short $ var_prefix sx) = SOME cv ∧ v_rel cnenv sv cv) - ⇒ env_rel cnenv senv cenv) + ∃cv. nsLookup cenv.v (Short $ var_prefix sx) = SOME cv ∧ v_rel cnenv st sv cv) + ⇒ env_rel cnenv st senv cenv) End Theorem env_rel_def = cj 2 v_rel_cases; Theorem v_rel_cases[allow_rebind] = cj 1 v_rel_cases; Theorem v_rel_def[simp] = [ - “v_rel cnenv (Constructor cn svs) cv”, - “v_rel cnenv (Closure sx senv se) cv”, - “v_rel cnenv (Recclosure sfuns senv sx) cv”, - “v_rel cnenv (Atom a) cv”] |> + “v_rel cnenv st (Constructor cn svs) cv”, + “v_rel cnenv st (Closure sx senv se) cv”, + “v_rel cnenv st (Recclosure sfuns senv sx) cv”, + “v_rel cnenv st (Atom a) cv”] |> map (GEN_ALL o SIMP_CONV (srw_ss()) [Once v_rel_cases, SF CONJ_ss]) |> LIST_CONJ; @@ -459,35 +466,35 @@ Definition list_to_cont_def: End Inductive cont_rel: - cont_rel cnenv [] [] + cont_rel cnenv st [] [] [~TupleK:] - (LIST_REL (v_rel cnenv) svs cvs ∧ + (LIST_REL (v_rel cnenv st) svs cvs ∧ LIST_REL (compile_rel cnenv) ses ces ∧ - cont_rel cnenv sk ck ∧ env_rel cnenv senv cenv ∧ env_ok cenv - ⇒ cont_rel cnenv (AppK senv (Cons "") svs ses :: sk) - ((Ccon NONE cvs ces, cenv) :: ck)) + cont_rel cnenv st sk ck ∧ env_rel cnenv st senv cenv ∧ env_ok cenv + ⇒ cont_rel cnenv st (AppK senv (Cons "") svs ses :: sk) + ((Ccon NONE cvs ces, cenv) :: ck)) [~ConsK:] - (LIST_REL (v_rel cnenv) svs cvs ∧ + (LIST_REL (v_rel cnenv st) svs cvs ∧ LIST_REL (compile_rel cnenv) ses ces ∧ ALOOKUP cnenv cn = SOME (tyid,ar) ∧ ar = LENGTH ses + LENGTH svs + 1 ∧ cn ≠ "" ∧ - cont_rel cnenv sk ck ∧ env_rel cnenv senv cenv ∧ env_ok cenv - ⇒ cont_rel cnenv (AppK senv (Cons cn) svs ses :: sk) - ((Ccon (SOME $ Short cn) cvs ces, cenv) :: ck)) + cont_rel cnenv st sk ck ∧ env_rel cnenv st senv cenv ∧ env_ok cenv + ⇒ cont_rel cnenv st (AppK senv (Cons cn) svs ses :: sk) + ((Ccon (SOME $ Short cn) cvs ces, cenv) :: ck)) [~AppK:] (op_rel sop cop ∧ - LIST_REL (v_rel cnenv) svs cvs ∧ + LIST_REL (v_rel cnenv st) svs cvs ∧ LIST_REL (compile_rel cnenv) ses ces ∧ - cont_rel cnenv sk ck ∧ env_rel cnenv senv cenv ∧ env_ok cenv - ⇒ cont_rel cnenv (AppK senv sop svs ses :: sk) - ((Capp cop cvs ces, cenv) :: ck)) + cont_rel cnenv st sk ck ∧ env_rel cnenv st senv cenv ∧ env_ok cenv + ⇒ cont_rel cnenv st (AppK senv sop svs ses :: sk) + ((Capp cop cvs ces, cenv) :: ck)) [~TwoArgs1:] (compile_rel cnenv se1 ce1 ∧ - cont_rel cnenv sk ck ∧ env_rel cnenv senv cenv ∧ env_ok cenv ∧ + cont_rel cnenv st sk ck ∧ env_rel cnenv st senv cenv ∧ env_ok cenv ∧ (if aop = Div then rest = div else if aop = Mod then rest = mod else if aop = Elem then rest = elem_str @@ -496,12 +503,12 @@ Inductive cont_rel: else if aop = StrLt then rest = strlt else if aop = StrGeq then rest = strgeq else aop = StrGt ∧ rest = strgt) - ⇒ cont_rel cnenv (AppK senv (AtomOp aop) [] [se1] :: sk) - ((Clet (SOME "v2") (clet "v1" ce1 rest), cenv) :: ck)) + ⇒ cont_rel cnenv st (AppK senv (AtomOp aop) [] [se1] :: sk) + ((Clet (SOME "v2") (clet "v1" ce1 rest), cenv) :: ck)) [~TwoArgs2:] - (nsLookup cenv.v (Short "v2") = SOME cv2 ∧ v_rel cnenv sv2 cv2 ∧ - cont_rel cnenv sk ck ∧ env_rel cnenv senv cenv ∧ env_ok cenv ∧ + (nsLookup cenv.v (Short "v2") = SOME cv2 ∧ v_rel cnenv st sv2 cv2 ∧ + cont_rel cnenv st sk ck ∧ env_rel cnenv st senv cenv ∧ env_ok cenv ∧ (if aop = Div then rest = div else if aop = Mod then rest = mod else if aop = Elem then rest = elem_str @@ -510,35 +517,35 @@ Inductive cont_rel: else if aop = StrLt then rest = strlt else if aop = StrGeq then rest = strgeq else aop = StrGt ∧ rest = strgt) - ⇒ cont_rel cnenv (AppK senv (AtomOp aop) [sv2] [] :: sk) - ((Clet (SOME "v1") rest, cenv) :: ck)) + ⇒ cont_rel cnenv st (AppK senv (AtomOp aop) [sv2] [] :: sk) + ((Clet (SOME "v1") rest, cenv) :: ck)) [~Alloc1:] (compile_rel cnenv se1 ce1 ∧ - cont_rel cnenv sk ck ∧ env_rel cnenv senv cenv ∧ env_ok cenv - ⇒ cont_rel cnenv (AppK senv Alloc [] [se1] :: sk) - ((Clet (SOME "v2") (clet "v1" ce1 alloc), cenv) :: ck)) + cont_rel cnenv st sk ck ∧ env_rel cnenv st senv cenv ∧ env_ok cenv + ⇒ cont_rel cnenv st (AppK senv Alloc [] [se1] :: sk) + ((Clet (SOME "v2") (clet "v1" ce1 alloc), cenv) :: ck)) [~Alloc2:] - (nsLookup cenv.v (Short "v2") = SOME cv2 ∧ v_rel cnenv sv2 cv2 ∧ - cont_rel cnenv sk ck ∧ env_rel cnenv senv cenv ∧ env_ok cenv - ⇒ cont_rel cnenv (AppK senv Alloc [sv2] [] :: sk) - ((Clet (SOME "v1") alloc, cenv) :: ck)) + (nsLookup cenv.v (Short "v2") = SOME cv2 ∧ v_rel cnenv st sv2 cv2 ∧ + cont_rel cnenv st sk ck ∧ env_rel cnenv st senv cenv ∧ env_ok cenv + ⇒ cont_rel cnenv st (AppK senv Alloc [sv2] [] :: sk) + ((Clet (SOME "v1") alloc, cenv) :: ck)) [~Concat:] (LIST_REL (compile_rel cnenv) ses ces ∧ - LIST_REL (v_rel cnenv) svs cvs ∧ - cont_rel cnenv sk ck ∧ env_rel cnenv senv cenv ∧ env_ok cenv - ⇒ cont_rel cnenv + LIST_REL (v_rel cnenv st) svs cvs ∧ + cont_rel cnenv st sk ck ∧ env_rel cnenv st senv cenv ∧ env_ok cenv + ⇒ cont_rel cnenv st (AppK senv (AtomOp Concat) svs ses :: sk) ((Ccon (SOME $ Short "::") [list_to_v cvs] [], cenv) :: list_to_cont cenv ces ++ [Capp Strcat [] [], cenv] ++ ck)) [~Implode:] (LIST_REL (compile_rel cnenv) ses ces ∧ - LIST_REL (v_rel cnenv) svs cvs ∧ - cont_rel cnenv sk ck ∧ env_rel cnenv senv cenv ∧ env_ok cenv - ⇒ cont_rel cnenv + LIST_REL (v_rel cnenv st) svs cvs ∧ + cont_rel cnenv st sk ck ∧ env_rel cnenv st senv cenv ∧ env_ok cenv + ⇒ cont_rel cnenv st (AppK senv (AtomOp Implode) svs ses :: sk) ((Ccon (SOME $ Short "::") [list_to_v cvs] [], cenv) :: list_to_cont cenv ces ++ [Capp Opapp [] [var "char_list"], cenv] ++ @@ -546,82 +553,95 @@ Inductive cont_rel: [~Substring3_1:] (compile_rel cnenv se1 ce1 ∧ compile_rel cnenv se2 ce2 ∧ - cont_rel cnenv sk ck ∧ env_rel cnenv senv cenv ∧ env_ok cenv - ⇒ cont_rel cnenv (AppK senv (AtomOp Substring) [] [se2;se1] :: sk) + cont_rel cnenv st sk ck ∧ env_rel cnenv st senv cenv ∧ env_ok cenv + ⇒ cont_rel cnenv st (AppK senv (AtomOp Substring) [] [se2;se1] :: sk) ((Clet (SOME "l") (clet "i" ce2 $ clet "s" ce1 substring3), cenv) :: ck)) [~Substring3_2:] (nsLookup cenv.v (Short "l") = SOME cv3 ∧ - v_rel cnenv sv3 cv3 ∧ compile_rel cnenv se1 ce1 ∧ - cont_rel cnenv sk ck ∧ env_rel cnenv senv cenv ∧ env_ok cenv - ⇒ cont_rel cnenv (AppK senv (AtomOp Substring) [sv3] [se1] :: sk) - ((Clet (SOME "i") (clet "s" ce1 substring3), cenv) :: ck)) + v_rel cnenv st sv3 cv3 ∧ compile_rel cnenv se1 ce1 ∧ + cont_rel cnenv st sk ck ∧ env_rel cnenv st senv cenv ∧ env_ok cenv + ⇒ cont_rel cnenv st (AppK senv (AtomOp Substring) [sv3] [se1] :: sk) + ((Clet (SOME "i") (clet "s" ce1 substring3), cenv) :: ck)) [~Substring3_3:] (nsLookup cenv.v (Short "l") = SOME cv3 ∧ nsLookup cenv.v (Short "i") = SOME cv2 ∧ - v_rel cnenv sv3 cv3 ∧ v_rel cnenv sv2 cv2 ∧ - cont_rel cnenv sk ck ∧ env_rel cnenv senv cenv ∧ env_ok cenv - ⇒ cont_rel cnenv (AppK senv (AtomOp Substring) [sv2;sv3] [] :: sk) - ((Clet (SOME "s") substring3, cenv) :: ck)) + v_rel cnenv st sv3 cv3 ∧ v_rel cnenv st sv2 cv2 ∧ + cont_rel cnenv st sk ck ∧ env_rel cnenv st senv cenv ∧ env_ok cenv + ⇒ cont_rel cnenv st (AppK senv (AtomOp Substring) [sv2;sv3] [] :: sk) + ((Clet (SOME "s") substring3, cenv) :: ck)) [~FFI:] - (cont_rel cnenv sk ck ∧ env_rel cnenv senv cenv ∧ env_ok cenv ∧ ch ≠ "" - ⇒ cont_rel cnenv (AppK senv (FFI ch) [] [] :: sk) - ((Clet (SOME "s") $ - Let NONE (App (FFI ch) [var "s"; var "ffi_array"]) $ ffi - , cenv) :: ck)) + (cont_rel cnenv st sk ck ∧ env_rel cnenv st senv cenv ∧ env_ok cenv ∧ ch ≠ "" + ⇒ cont_rel cnenv st (AppK senv (FFI ch) [] [] :: sk) + ((Clet (SOME "s") $ + Let NONE (App (FFI ch) [var "s"; var "ffi_array"]) $ ffi + , cenv) :: ck)) [~LetK:] (compile_rel cnenv se ce ∧ - cont_rel cnenv sk ck ∧ env_rel cnenv senv cenv ∧ env_ok cenv - ⇒ cont_rel cnenv (LetK senv (SOME x) se :: sk) - ((Clet (SOME $ var_prefix x) ce, cenv) :: ck)) + cont_rel cnenv st sk ck ∧ env_rel cnenv st senv cenv ∧ env_ok cenv + ⇒ cont_rel cnenv st (LetK senv (SOME x) se :: sk) + ((Clet (SOME $ var_prefix x) ce, cenv) :: ck)) [~IfK:] (compile_rel cnenv se1 ce1 ∧ compile_rel cnenv se2 ce2 ∧ - cont_rel cnenv sk ck ∧ env_rel cnenv senv cenv ∧ env_ok cenv - ⇒ cont_rel cnenv (IfK senv se1 se2 :: sk) - ((Cif ce1 ce2, cenv) :: ck)) + cont_rel cnenv st sk ck ∧ env_rel cnenv st senv cenv ∧ env_ok cenv + ⇒ cont_rel cnenv st (IfK senv se1 se2 :: sk) + ((Cif ce1 ce2, cenv) :: ck)) [~RaiseK:] - (cont_rel cnenv sk ck - ⇒ cont_rel cnenv (RaiseK :: sk) ((Craise, cenv) :: ck)) + (cont_rel cnenv st sk ck + ⇒ cont_rel cnenv st (RaiseK :: sk) ((Craise, cenv) :: ck)) [~HandleK:] (compile_rel cnenv se ce ∧ - cont_rel cnenv sk ck ∧ env_rel cnenv senv cenv ∧ env_ok cenv - ⇒ cont_rel cnenv (HandleK senv x se :: sk) - ((Chandle [(Pvar $ var_prefix x, ce)], cenv) :: ck)) + cont_rel cnenv st sk ck ∧ env_rel cnenv st senv cenv ∧ env_ok cenv + ⇒ cont_rel cnenv st (HandleK senv x se :: sk) + ((Chandle [(Pvar $ var_prefix x, ce)], cenv) :: ck)) + +[~ForceMutK:] + (cont_rel cnenv st sk ck + ⇒ cont_rel cnenv st (ForceMutK n :: sk) ((Cforce (n + 1), cenv) :: ck)) +End + +Definition store_rel_def: + store_rel cnenv st (Array svs) (Varray cvs) = LIST_REL (v_rel cnenv st) svs cvs ∧ + store_rel cnenv st (ThunkMem Evaluated sv) (Thunk Evaluated cv) = + v_rel cnenv st sv cv ∧ + store_rel cnenv st (ThunkMem NotEvaluated sv) (Thunk NotEvaluated cv) = + v_rel cnenv st sv cv ∧ + store_rel cnenv st _ _ = F End Definition state_rel_def: state_rel cnenv sst (W8array ws :: cst) = ( (LENGTH ws = max_FFI_return_size + 2) ∧ - LIST_REL (λs c. ∃cs. c = Varray cs ∧ LIST_REL (v_rel cnenv) s cs) sst cst) ∧ + LIST_REL (store_rel cnenv sst) sst cst) ∧ state_rel cnenv sst _ = F End Theorem state_rel: state_rel cnenv sst cst ⇔ ∃ws cst'. cst = W8array ws :: cst' ∧ LENGTH ws = max_FFI_return_size + 2 ∧ - LIST_REL (λs c. ∃cs. c = Varray cs ∧ LIST_REL (v_rel cnenv) s cs) sst cst' + LIST_REL (store_rel cnenv sst) sst cst' Proof rw[DefnBase.one_line_ify NONE state_rel_def] >> TOP_CASE_TAC >> simp[] >> TOP_CASE_TAC >> simp[] QED Inductive step_rel: - (compile_rel cnenv se ce ∧ cont_rel cnenv sk ck ∧ - env_rel cnenv senv cenv ∧ state_rel cnenv sst cst ∧ env_ok cenv + (compile_rel cnenv se ce ∧ cont_rel cnenv sst sk ck ∧ + env_rel cnenv sst senv cenv ∧ state_rel cnenv sst cst ∧ env_ok cenv ⇒ step_rel (Exp senv se, SOME sst, sk) (Estep (cenv, cst, Exp ce, ck))) ∧ - (v_rel cnenv sv cv ∧ cont_rel cnenv sk ck ∧ state_rel cnenv sst cst + (v_rel cnenv sst sv cv ∧ cont_rel cnenv sst sk ck ∧ state_rel cnenv sst cst ⇒ step_rel (Val sv, SOME sst, sk) (Estep (cenv, cst, Val cv, ck))) ∧ - (v_rel cnenv sv cv ∧ cont_rel cnenv sk ck ∧ state_rel cnenv sst cst + (v_rel cnenv sst sv cv ∧ cont_rel cnenv sst sk ck ∧ state_rel cnenv sst cst ⇒ step_rel (Exn sv, SOME sst, sk) (Estep (cenv, cst, Exn cv, ck))) ∧ - (cont_rel cnenv sk ck ∧ state_rel cnenv sst cst ∧ env_ok cenv ∧ + (cont_rel cnenv sst sk ck ∧ state_rel cnenv sst cst ∧ env_ok cenv ∧ ws1 = MAP (λc. n2w $ ORD c) (EXPLODE conf) ∧ store_lookup 0 cst = SOME $ W8array ws2 ∧ s ≠ "" ⇒ step_rel (Action s conf, SOME sst, sk) @@ -636,7 +656,7 @@ Inductive dstep_rel: dstep_rel (Val sv, SOME sst, []) Ddone ∧ - (v_rel cnenv sv cv ⇒ + (v_rel cnenv sst sv cv ⇒ dstep_rel (Exn sv, SOME sst, []) (Draise cv)) ∧ (step_rel (Action ch conf, SOME sst, sk) @@ -716,6 +736,16 @@ Theorem capplication_thm: case do_opapp vs of | NONE => Etype_error | SOME (env,e) => Estep (env,s,Exp e,c) + else if op = ThunkOp ForceThunk then + (case vs of + [Loc _ n] => ( + case store_lookup n s of + SOME (Thunk Evaluated v) => + return env s v c + | SOME (Thunk NotEvaluated f) => + return env s f ((Capp Opapp [Conv NONE []] [], env)::(Cforce n, env)::c) + | _ => Etype_error) + | _ => Etype_error) else case get_ffi_ch op of | SOME n => ( case get_ffi_args vs of @@ -732,9 +762,10 @@ Theorem capplication_thm: | SOME (v1,Rval v') => return env v1 v' c | SOME (v1,Rraise v) => Estep (env,v1,Exn v,c)) Proof - rw[application_thm] >> simp[] >> gvs[] + rw[application_thm] >> gvs[] >- gvs[AllCaseEqs()] - >- rpt (TOP_CASE_TAC >> gvs[]) >> + >- rpt (TOP_CASE_TAC >> gvs[]) + >- (rpt (TOP_CASE_TAC >> gvs[]) >> gvs [dest_thunk_def]) >> Cases_on `op` >> gvs[] QED @@ -779,7 +810,7 @@ QED Theorem num_args_ok_0: num_args_ok op 0 ⇔ - (∃s. op = Cons s) ∨ (∃aop. op = AtomOp aop) ∨ (op = Ref) + (∃s. op = Cons s) ∨ (∃aop. op = AtomOp aop) Proof Cases_on `op` >> gvs[num_args_ok_def] QED @@ -894,8 +925,7 @@ QED Theorem state_rel_store_lookup: state_rel cnenv sst cst ⇒ - OPTREL (λs c. ∃cs. c = Varray cs ∧ LIST_REL (v_rel cnenv) s cs) - (oEL n sst) (store_lookup (n + 1) cst) + OPTREL (store_rel cnenv sst) (oEL n sst) (store_lookup (n + 1) cst) Proof rw[state_rel] >> rw[oEL_THM, store_lookup_def] >> gvs[LIST_REL_EL_EQN] >> gvs[ADD1] >> first_x_assum drule >> strip_tac >> simp[GSYM ADD1] @@ -909,6 +939,14 @@ Proof rw[store_lookup_def, store_assign_def, store_v_same_type_def] QED +Theorem store_lookup_assign_Thunk: + store_lookup n st = SOME (Thunk NotEvaluated a) ⇒ + store_assign n (Thunk m y) st = + SOME $ LUPDATE (Thunk m y) n st +Proof + rw[store_lookup_def, store_assign_def, store_v_same_type_def] +QED + Triviality step_until_halt_no_err_step_n: step_until_halt s ≠ Err ⇒ ∀n st k. step_n n s ≠ error st k Proof @@ -919,21 +957,261 @@ Proof drule is_halt_imp_eq >> disch_then $ qspec_then `n` assume_tac >> gvs[error_def] QED +Triviality ALL_DISTINCT_MAP_FSTs: + ALL_DISTINCT (MAP FST l) ⇒ + ALL_DISTINCT (MAP (λ(x,y,z). x) l) +Proof + Induct_on `l` >> rw[MEM_MAP] >> + ntac 2 (pairarg_tac >> gvs[]) +QED + +Theorem v_rel_LUPDATE_ThunkMem: + ∀v w. + v_rel cnenv st v w ⇒ + EL n st = ThunkMem t' v' ⇒ + v_rel cnenv (LUPDATE (ThunkMem t u) n st) v w +Proof + ‘(∀v w. v_rel cnenv st v w ⇒ + EL n st = ThunkMem t' v' ⇒ + v_rel cnenv (LUPDATE (ThunkMem t u) n st) v w) ∧ + (∀x y. env_rel cnenv st x y ⇒ + EL n st = ThunkMem t' v' ⇒ + env_rel cnenv (LUPDATE (ThunkMem t u) n st) x y)’ + suffices_by gvs [] + \\ ho_match_mp_tac v_rel_strongind \\ rw [] \\ gvs [] + >- gvs [LIST_REL_EL_EQN] + >- gvs [LIST_REL_EL_EQN] + >- goal_assum drule + >- (rw [EL_LUPDATE] \\ gvs []) + >- simp [Once v_rel_cases] + >- ( + rw [env_rel_def] + \\ first_x_assum drule \\ rw [] \\ gvs[]) +QED + +Theorem v_rel_LUPDATE_Array: + ∀v w. + v_rel cnenv st v w ⇒ + v_rel cnenv (LUPDATE (Array vs) n st) v w +Proof + ‘(∀v w. v_rel cnenv st v w ⇒ + v_rel cnenv (LUPDATE (Array vs) n st) v w) ∧ + (∀x y. env_rel cnenv st x y ⇒ + env_rel cnenv (LUPDATE (Array vs) n st) x y)’ + suffices_by gvs [] + \\ ho_match_mp_tac v_rel_strongind \\ rw [] \\ gvs [] + >- gvs [LIST_REL_EL_EQN] + >- gvs [LIST_REL_EL_EQN] + >- goal_assum drule + >- (rw [EL_LUPDATE] \\ gvs []) + >- simp [Once v_rel_cases] + >- ( + rw [env_rel_def] + \\ first_x_assum drule \\ rw [] \\ gvs[]) +QED + +Theorem v_rel_APPEND: + ∀v w. + v_rel cnenv st v w ⇒ + v_rel cnenv (st ++ st') v w +Proof + ‘(∀v w. v_rel cnenv st v w ⇒ v_rel cnenv (st ++ st') v w) ∧ + (∀x y. env_rel cnenv st x y ⇒ env_rel cnenv (st ++ st') x y)’ + suffices_by gvs [] + \\ ho_match_mp_tac v_rel_strongind \\ rw [] \\ gvs [] + >- gvs [LIST_REL_EL_EQN] + >- gvs [LIST_REL_EL_EQN] + >- goal_assum drule + >- simp [EL_APPEND] + >- simp [Once v_rel_cases] + >- ( + rw [env_rel_def] + \\ first_x_assum drule \\ rw [] \\ gvs[]) +QED + +Theorem env_rel_LUPDATE_ThunkMem: + ∀senv cenv. + env_rel cnenv st senv cenv ⇒ + EL n st = ThunkMem t' v' ⇒ + env_rel cnenv (LUPDATE (ThunkMem t u) n st) senv cenv +Proof + ‘(∀v w. v_rel cnenv st v w ⇒ + EL n st = ThunkMem t' v' ⇒ + v_rel cnenv (LUPDATE (ThunkMem t u) n st) v w) ∧ + (∀x y. env_rel cnenv st x y ⇒ + EL n st = ThunkMem t' v' ⇒ + env_rel cnenv (LUPDATE (ThunkMem t u) n st) x y)’ + suffices_by gvs [] + \\ ho_match_mp_tac v_rel_strongind \\ rw [] \\ gvs [] + >- gvs [LIST_REL_EL_EQN] + >- gvs [LIST_REL_EL_EQN] + >- goal_assum drule + >- (rw [EL_LUPDATE] \\ gvs []) + >- simp [Once v_rel_cases] + >- ( + rw [env_rel_def] + \\ first_x_assum drule \\ rw [] \\ gvs[]) +QED + +Theorem env_rel_LUPDATE_Array: + ∀senv cenv. + env_rel cnenv st senv cenv ⇒ + env_rel cnenv (LUPDATE (Array vs) n st) senv cenv +Proof + ‘(∀v w. v_rel cnenv st v w ⇒ + v_rel cnenv (LUPDATE (Array vs) n st) v w) ∧ + (∀x y. env_rel cnenv st x y ⇒ + env_rel cnenv (LUPDATE (Array vs) n st) x y)’ + suffices_by gvs [] + \\ ho_match_mp_tac v_rel_strongind \\ rw [] \\ gvs [] + >- gvs [LIST_REL_EL_EQN] + >- gvs [LIST_REL_EL_EQN] + >- goal_assum drule + >- (rw [EL_LUPDATE] \\ gvs []) + >- simp [Once v_rel_cases] + >- ( + rw [env_rel_def] + \\ first_x_assum drule \\ rw [] \\ gvs[]) +QED + +Theorem env_rel_APPEND: + ∀senv cenv. + env_rel cnenv st senv cenv ⇒ + env_rel cnenv (st ++ st') senv cenv +Proof + ‘(∀v w. + v_rel cnenv st v w ⇒ v_rel cnenv (st ++ st') v w) ∧ + (∀senv cenv. + env_rel cnenv st senv cenv ⇒ env_rel cnenv (st ++ st') senv cenv)’ + suffices_by gvs [] + \\ ho_match_mp_tac v_rel_strongind \\ rw [] \\ gvs [] + >- gvs [LIST_REL_EL_EQN] + >- gvs [LIST_REL_EL_EQN] + >- goal_assum drule + >- simp [EL_APPEND] + >- simp [Once v_rel_cases] + >- ( + rw [env_rel_def] + \\ first_x_assum drule \\ rw [] \\ gvs[]) +QED + +Theorem cont_rel_LUPDATE_ThunkMem: + ∀k1 k2. + cont_rel cnenv st k1 k2 ⇒ + EL n st = ThunkMem t' v' ⇒ + cont_rel cnenv (LUPDATE (ThunkMem t u) n st) k1 k2 +Proof + ho_match_mp_tac cont_rel_strongind \\ rw [] \\ gvs [] + \\ simp [Once cont_rel_cases] \\ gvs [LIST_REL_EL_EQN] \\ rw [] + \\ rpt $ first_x_assum $ drule_then assume_tac + \\ rpt (drule_at_then (Pos $ el 2) dxrule v_rel_LUPDATE_ThunkMem) \\ gvs [] + \\ rpt (drule_at_then (Pos $ el 2) dxrule env_rel_LUPDATE_ThunkMem) \\ gvs [] + \\ rw [] + \\ rpt $ irule_at Any EQ_REFL \\ rw [] + \\ rpt $ first_x_assum $ drule_then assume_tac + \\ rpt (drule_at_then (Pos $ el 2) dxrule v_rel_LUPDATE_ThunkMem) \\ gvs [] + \\ rpt (drule_at_then (Pos $ el 2) dxrule env_rel_LUPDATE_ThunkMem) \\ gvs [] +QED + +Theorem cont_rel_LUPDATE_Array: + ∀k1 k2. + cont_rel cnenv st k1 k2 ⇒ + cont_rel cnenv (LUPDATE (Array vs) n st) k1 k2 +Proof + ho_match_mp_tac cont_rel_strongind \\ rw [] \\ gvs [] + \\ simp [Once cont_rel_cases] \\ gvs [LIST_REL_EL_EQN] \\ rw [] + \\ rpt $ first_x_assum $ drule_then assume_tac + \\ rpt $ dxrule v_rel_LUPDATE_Array \\ gvs [] + \\ rpt $ dxrule env_rel_LUPDATE_Array \\ gvs [] + \\ rw [] + \\ rpt $ irule_at Any EQ_REFL \\ rw [] + \\ rpt $ first_x_assum $ drule_then assume_tac + \\ rpt $ dxrule v_rel_LUPDATE_Array \\ gvs [] + \\ rpt $ dxrule env_rel_LUPDATE_Array \\ gvs [] +QED + +Theorem cont_rel_APPEND: + ∀k1 k2. + cont_rel cnenv st k1 k2 ⇒ + cont_rel cnenv (st ++ st') k1 k2 +Proof + ho_match_mp_tac cont_rel_strongind \\ rw [] \\ gvs [] + \\ simp [Once cont_rel_cases] \\ gvs [LIST_REL_EL_EQN] \\ rw [] + \\ rpt $ first_x_assum $ drule_then assume_tac + \\ rpt $ dxrule v_rel_APPEND \\ gvs [] + \\ rpt $ dxrule env_rel_APPEND \\ gvs [] + \\ rw [] + \\ rpt $ irule_at Any EQ_REFL \\ rw [] + \\ rpt $ first_x_assum $ drule_then assume_tac + \\ rpt $ dxrule v_rel_APPEND \\ gvs [] + \\ rpt $ dxrule env_rel_APPEND \\ gvs [] +QED + +Theorem store_rel_APPEND: + store_rel cnenv st s1 s2 ⇒ + store_rel cnenv (st ++ st') s1 s2 +Proof + rw [oneline store_rel_def] + \\ rpt (TOP_CASE_TAC \\ gvs []) \\ gvs [LIST_REL_EL_EQN] \\ rw [] + \\ rpt $ first_x_assum $ drule_then assume_tac + \\ simp [v_rel_APPEND] +QED + +Definition thunk_mode_rel_def[simp]: + thunk_mode_rel stateLang$Evaluated ast$Evaluated = T ∧ + thunk_mode_rel stateLang$NotEvaluated ast$NotEvaluated = T ∧ + thunk_mode_rel _ _ = F +End + +Theorem state_rel_LUPDATE_ThunkMem: + state_rel cnenv sst cst ∧ + v_rel cnenv sst sv cv ∧ + EL n sst = ThunkMem t' v' ∧ + thunk_mode_rel t1 t2 ⇒ + state_rel cnenv (LUPDATE (ThunkMem t1 sv) n sst) + (LUPDATE (Thunk t2 cv) (n + 1) cst) +Proof + rw [state_rel] \\ simp [LUPDATE_DEF] + \\ gvs [LIST_REL_EL_EQN, EL_LUPDATE] \\ rw [store_rel_def, LIST_REL_EL_EQN] + \\ rpt $ first_x_assum $ drule_then assume_tac \\ gvs [PRE_SUB1] + >- ( + simp [oneline store_rel_def] + \\ rpt (TOP_CASE_TAC \\ gvs []) + \\ simp [v_rel_LUPDATE_ThunkMem]) + \\ gvs [oneline store_rel_def] + \\ rpt (TOP_CASE_TAC \\ gvs []) \\ gvs [LIST_REL_EL_EQN] \\ rw [] + \\ simp [v_rel_LUPDATE_ThunkMem] +QED + +Theorem state_rel_LUPDATE_Array: + state_rel cnenv sst cst ∧ + LIST_REL (v_rel cnenv sst) vs ws ⇒ + state_rel cnenv (LUPDATE (Array vs) n sst) + (LUPDATE (Varray ws) (n + 1) cst) +Proof + rw [state_rel] \\ simp [LUPDATE_DEF] + \\ gvs [LIST_REL_EL_EQN, EL_LUPDATE] \\ rw [store_rel_def, LIST_REL_EL_EQN] + \\ rpt $ first_x_assum $ drule_then assume_tac \\ gvs [PRE_SUB1] + >- simp [v_rel_LUPDATE_Array] + \\ gvs [oneline store_rel_def] + \\ rpt (TOP_CASE_TAC \\ gvs []) \\ gvs [LIST_REL_EL_EQN] \\ rw [] + \\ simp [v_rel_LUPDATE_Array] +QED (***** cnenv_rel / env_rel / env_ok *****) Theorem env_rel_lookup: - ∀v sx cnenv senv cenv. - env_rel cnenv senv cenv ∧ + ∀v sx cnenv st senv cenv. + env_rel cnenv st senv cenv ∧ ALOOKUP senv v = SOME sx - ⇒ ∃cx. nsLookup cenv.v (Short (var_prefix v)) = SOME cx ∧ v_rel cnenv sx cx + ⇒ ∃cx. nsLookup cenv.v (Short (var_prefix v)) = SOME cx ∧ v_rel cnenv st sx cx Proof rw[env_rel_def] QED Theorem env_rel_check: - ∀cn tyid ar cnenv senv cenv. - env_rel cnenv senv cenv ∧ + ∀cn tyid ar cnenv st senv cenv. + env_rel cnenv st senv cenv ∧ ALOOKUP cnenv cn = SOME (tyid, ar) ∧ cn ≠ "" ⇒ do_con_check cenv.c (SOME (Short cn)) ar Proof @@ -958,8 +1236,8 @@ Proof QED Theorem env_rel_build: - ∀vs cn tyid cnenv senv cenv. - env_rel cnenv senv cenv ∧ + ∀vs cn tyid cnenv st senv cenv. + env_rel cnenv st senv cenv ∧ ALOOKUP cnenv cn = SOME (tyid, LENGTH vs) ∧ cn ≠ "" ⇒ build_conv cenv.c (SOME (Short cn)) vs = SOME (Conv (SOME tyid) vs) Proof @@ -981,16 +1259,16 @@ Proof QED Theorem env_rel_nsBind: - env_rel cnenv senv cenv ∧ - v_rel cnenv sv cv - ⇒ env_rel cnenv ((s,sv)::senv) (cenv with v := nsBind (var_prefix s) cv cenv.v) + env_rel cnenv st senv cenv ∧ + v_rel cnenv st sv cv + ⇒ env_rel cnenv st ((s,sv)::senv) (cenv with v := nsBind (var_prefix s) cv cenv.v) Proof rw[env_rel_def] >> IF_CASES_TAC >> gvs[] QED Theorem env_rel_nsBind_alt: - env_rel cnenv senv cenv ∧ (∀x. cx ≠ var_prefix x) - ⇒ env_rel cnenv senv (cenv with v := nsBind cx cv cenv.v) + env_rel cnenv st senv cenv ∧ (∀x. cx ≠ var_prefix x) + ⇒ env_rel cnenv st senv (cenv with v := nsBind cx cv cenv.v) Proof rw[env_rel_def] QED @@ -1019,11 +1297,11 @@ Proof QED Theorem env_rel_nsAppend: - env_rel cnenv senv cenv ∧ + env_rel cnenv st senv cenv ∧ (∀sx. ALOOKUP senv' sx = NONE ⇒ nsLookup cenv' (Short (var_prefix sx)) = NONE) ∧ (∀sx sv. ALOOKUP senv' sx = SOME sv ⇒ - ∃cv. nsLookup cenv' (Short (var_prefix sx)) = SOME cv ∧ v_rel cnenv sv cv) - ⇒ env_rel cnenv (senv' ++ senv) (cenv with v := nsAppend cenv' cenv.v) + ∃cv. nsLookup cenv' (Short (var_prefix sx)) = SOME cv ∧ v_rel cnenv st sv cv) + ⇒ env_rel cnenv st (senv' ++ senv) (cenv with v := nsAppend cenv' cenv.v) Proof rw[env_rel_def] >> simp[namespacePropsTheory.nsLookup_nsAppend_some] >> simp[namespaceTheory.id_to_mods_def, SF DNF_ss] >> @@ -1046,13 +1324,13 @@ Proof QED Theorem env_rel_Recclosure: - env_rel cnenv senv cenv ∧ env_ok cenv ∧ + env_rel cnenv st senv cenv ∧ env_ok cenv ∧ LIST_REL (λ(sv,se) (cv,cx,ce). var_prefix sv = cv ∧ ∃sx se'. se = Lam (SOME sx) se' ∧ var_prefix sx = cx ∧ compile_rel cnenv se' ce) sfuns cfuns ∧ ALL_DISTINCT (MAP FST cfuns) - ⇒ env_rel cnenv + ⇒ env_rel cnenv st (MAP (λ(fn,_). (fn,Recclosure sfuns senv fn)) sfuns ++ senv) (cenv with v := build_rec_env cfuns cenv cenv.v) Proof @@ -1063,7 +1341,7 @@ Proof ∃sx se'. se = Lam (SOME sx) se' ∧ var_prefix sx = cx ∧ compile_rel cnenv se' ce) sfs cfs ∧ ALL_DISTINCT (MAP FST cfs) ⇒ - env_rel cnenv + env_rel cnenv st (MAP (λ(fn,_). (fn,Recclosure sfs senv fn)) sfuns ++ senv) (cenv with v := FOLDR (λ(f,x,e) env'. nsBind f (Recclosure cenv cfs f) env') cenv.v cfuns)` >> @@ -1083,13 +1361,13 @@ Proof QED Theorem env_rel_nsBind_Recclosure: - env_rel cnenv senv cenv ∧ env_ok cenv ∧ v_rel cnenv sv cv ∧ + env_rel cnenv st senv cenv ∧ env_ok cenv ∧ v_rel cnenv st sv cv ∧ LIST_REL (λ(sv,se) (cv,cx,ce). var_prefix sv = cv ∧ ∃sx se'. se = Lam (SOME sx) se' ∧ var_prefix sx = cx ∧ compile_rel cnenv se' ce) sfuns cfuns ∧ ALL_DISTINCT (MAP FST cfuns) - ⇒ env_rel cnenv + ⇒ env_rel cnenv st ((s,sv)::(MAP (λ(fn,_). (fn,Recclosure sfuns senv fn)) sfuns ++ senv)) (cenv with v := nsBind (var_prefix s) cv (build_rec_env cfuns cenv cenv.v)) Proof @@ -1098,8 +1376,8 @@ Proof QED Theorem env_rel_pmatch: - env_rel cnenv senv cenv ∧ LIST_REL (v_rel cnenv) svs cvs ∧ LENGTH pvs = LENGTH cvs - ⇒ env_rel cnenv + env_rel cnenv st senv cenv ∧ LIST_REL (v_rel cnenv st) svs cvs ∧ LENGTH pvs = LENGTH cvs + ⇒ env_rel cnenv st (REVERSE (ZIP (pvs,svs)) ++ senv) (cenv with v := nsAppend (alist_to_ns (REVERSE (ZIP (MAP var_prefix pvs,cvs)))) cenv.v) @@ -1256,7 +1534,7 @@ QED (* `ALL_DISTINCT vs` not necessary here, but useful for matching against *) Theorem compile_rel_can_pmatch_all: - ∀scss ccss c cn stamp id vs cnenv (cenv:semanticPrimitives$v sem_env) st + ∀scss ccss c cn stamp id vs cnenv sst (cenv:semanticPrimitives$v sem_env) st cvs svs cuspat. LIST_REL (λ(cn,vs,se) (pat,ce). compile_rel cnenv se ce ∧ pat = pat_row cn vs) @@ -1264,7 +1542,7 @@ Theorem compile_rel_can_pmatch_all: EVERY (λ(cn,vs,_). ALL_DISTINCT vs ∧ ∃stamp'. ALOOKUP cnenv cn = SOME (stamp',LENGTH vs) ∧ same_type stamp' stamp) scss ∧ cnenv_rel cnenv cenv.c ∧ - v_rel cnenv (Constructor cn svs) (Conv (SOME stamp) cvs) ∧ + v_rel cnenv sst (Constructor cn svs) (Conv (SOME stamp) cvs) ∧ (cuspat ≠ [] ⇒ cuspat = [Pany]) ⇒ can_pmatch_all cenv.c st (MAP FST ccss ++ cuspat) (Conv (SOME stamp) cvs) Proof @@ -1283,8 +1561,8 @@ Proof QED Theorem concat_vs_to_string: - ∀strs cvs cnenv str. - LIST_REL (v_rel cnenv) (MAP Atom strs) cvs ∧ + ∀strs cvs cnenv st str. + LIST_REL (v_rel cnenv st) (MAP Atom strs) cvs ∧ concat strs = SOME str ⇒ vs_to_string cvs = SOME str Proof @@ -1439,6 +1717,23 @@ Proof TOP_CASE_TAC >> gvs[] QED +Theorem dest_thunk_rel: + state_rel cnenv sst cst ∧ + v_rel cnenv sst sv cv ∧ + ¬thunk_or_thunk_loc sv ⇒ + dest_thunk [cv] cst = NotThunk +Proof + rw [thunk_or_thunk_loc_def] + \\ Cases_on ‘dest_anyThunk sv’ \\ gvs [] + \\ Cases_on ‘sv’ \\ gvs [state_rel] + \\ gvs [dest_anyThunk_def, dest_thunk_def, store_lookup_def, EL_CONS, + PRE_SUB1, ADD1, LIST_REL_EL_EQN] + \\ ntac 2 (TOP_CASE_TAC \\ gvs []) + \\ ( + gvs [GSYM PULL_FORALL] + \\ first_x_assum $ drule_then assume_tac \\ gvs [oneline store_rel_def] + \\ Cases_on ‘EL n sst’ \\ gvs []) +QED (********** Main results **********) @@ -1638,16 +1933,9 @@ Proof simp[step_rel_cases] >> rpt $ goal_assum $ drule_at Any >> simp[Once cont_rel_cases, EVERY2_REVERSE1] ) >> - gvs[num_args_ok_0, op_rel_cases] - >- ( - Cases_on `aop` >> gvs[sstep, eval_op_def] >> - gvs[atom_op_rel_cases, opn_rel_cases, opb_rel_cases] - ) >> - (* Ref *) - gvs[sstep, cstep, do_app_def, store_alloc_def, SNOC_APPEND] >> - simp[step_rel_cases, SF DNF_ss, GSYM CONJ_ASSOC] >> - gvs[state_rel, ADD1] >> rpt $ goal_assum $ drule_at Any >> - imp_res_tac LIST_REL_LENGTH >> simp[store_lookup_def] + gvs[num_args_ok_0, op_rel_cases] >> + Cases_on `aop` >> gvs[sstep, eval_op_def] >> + gvs[atom_op_rel_cases, opn_rel_cases, opb_rel_cases] ) >- ( (* TwoArgs *) simp[step_rel_cases] >> rpt $ goal_assum $ drule_at Any >> @@ -1726,6 +2014,29 @@ Proof Cases_on `sk` >> gvs[sstep] >> gvs[DefnBase.one_line_ify NONE return_def] >> reverse TOP_CASE_TAC >> gvs[Once cont_rel_cases, sstep, cstep] + >- ( (* ForceMutK *) + first_x_assum $ qspec_then `1` assume_tac >> gvs[sstep] >> + ntac 2 (TOP_CASE_TAC >> gvs[]) >> + drule_all_then assume_tac dest_thunk_rel >> gvs[] >> + qexists0 >> simp[step_rel_cases, SF SFY_ss] >> + reverse $ rw[store_assign_def] + >- gvs[state_rel, store_lookup_def, LUPDATE_DEF] + >- ( + Cases_on `EL n sst` >> gvs[store_same_type_def] >> + Cases_on `t'` >> gvs[state_rel, LIST_REL_EL_EQN, store_v_same_type_def, + EL_CONS, PRE_SUB1] >> + FULL_CASE_TAC >> first_x_assum $ qspec_then `n` assume_tac >> + gvs[store_rel_def] >> + Cases_on `t'` >> gvs[store_rel_def] + ) + >- ( + Cases_on ‘EL n sst’ >> gvs [store_same_type_def] >> + drule_all_then (irule_at $ Pos hd) v_rel_LUPDATE_ThunkMem >> + drule_all cont_rel_LUPDATE_ThunkMem >> rw [] >> + ‘thunk_mode_rel Evaluated Evaluated’ by gvs [] >> + drule_all state_rel_LUPDATE_ThunkMem >> rw [] + ) + ) >- (qexists0 >> simp[step_rel_cases, SF SFY_ss]) (* HandleK *) >- (qexists0 >> simp[step_rel_cases, SF SFY_ss]) (* RaiseK *) >- ( (* IfK *) @@ -1808,40 +2119,86 @@ Proof CCONTR_TAC >> Cases_on `cop` >> gvs[op_rel_cases, atom_op_rel_cases]) >> simp[] >> first_x_assum $ qspec_then `1` assume_tac >> gvs[sstep] >> IF_CASES_TAC >> gvs[] >> reverse $ gvs[op_rel_cases, ADD1, cstep] - >- ( (* Unsafe update *) - `LENGTH l0 = 2` by gvs[] >> gvs[LENGTH_EQ_NUM_compute] >> - rename1 `[lnum;idx;elem]` >> gvs[application_def, sstep] >> - Cases_on `lnum` >> gvs[] >> Cases_on `idx` >> gvs[] >> - TOP_CASE_TAC >> gvs[] >> TOP_CASE_TAC >> gvs[] >> + >>~- ([`AllocMutThunk`], + gvs[application_def, sstep] >> + ntac 2 (TOP_CASE_TAC >> gvs[]) >> + gvs[do_app_def, thunk_op_def] >> + pairarg_tac >> gvs[store_alloc_def] >> + qexists0 >> reverse $ rw[step_rel_cases] + >- gvs[state_rel, store_lookup_def] >> + qexists `cnenv` >> gvs[state_rel, SNOC_APPEND] >> + rw [] + >- (simp [Once v_rel_cases] >> gvs [LIST_REL_EL_EQN]) + >- gvs [cont_rel_APPEND] + >- ( + gvs [LIST_REL_EL_EQN] >> rw [] >> + irule store_rel_APPEND >> gvs []) + >- gvs [store_rel_def, v_rel_APPEND] + ) + >>~- ([`UpdateMutThunk`], + `LENGTH l0 = 1` by gvs [] >> gvs[LENGTH_EQ_NUM_compute] >> + gvs [application_def, sstep] >> + Cases_on `sv` >> gvs[] >> + ntac 3 (TOP_CASE_TAC >> gvs[]) >> simp[do_app_def] >> drule state_rel_store_lookup >> disch_then $ qspec_then `n` assume_tac >> gvs[] >> - imp_res_tac LIST_REL_LENGTH >> gvs[] >> - `¬(i < 0)` by ARITH_TAC >> simp[] >> - `¬(Num (ABS i) ≥ LENGTH cs)` by ARITH_TAC >> simp[] >> - drule store_lookup_assign_Varray >> rw[] >> - `ABS i = i` by ARITH_TAC >> simp[] >> - qexists0 >> reverse $ rw[step_rel_cases] - >- gvs[state_rel, LUPDATE_DEF, store_lookup_def] >> - goal_assum drule >> gvs[state_rel] >> simp[LUPDATE_DEF, GSYM ADD1] >> - ntac 2 (irule EVERY2_LUPDATE_same >> simp[]) + simp [thunk_op_def] >> gvs[] >> + Cases_on `z` >> gvs[store_rel_def] >> + Cases_on `t'` >> gvs[store_rel_def] >> + drule store_lookup_assign_Thunk >> rw[] >> + qexists0 >> reverse $ rw[step_rel_cases] >> + qpat_x_assum `v_rel _ _ (ThunkLoc _) _` mp_tac >> + rw [Once v_rel_cases] >> simp [] >> + gvs [oEL_THM, store_lookup_def] + >- gvs [state_rel, LUPDATE_DEF] >> + drule_all_then (irule_at $ Pos hd) cont_rel_LUPDATE_ThunkMem >> + qmatch_goalsub_abbrev_tac ‘state_rel _ (LUPDATE (_ smode _) _ _) + (LUPDATE (_ cmode _) _ _)’ >> + ‘thunk_mode_rel smode cmode’ by gvs [Abbr ‘smode’, Abbr ‘cmode’] >> + drule_all_then (irule_at $ Pos hd) state_rel_LUPDATE_ThunkMem + ) + >~ [`ForceMutThunk`] + >- ( + gvs[application_def, sstep] >> + ntac 3 (TOP_CASE_TAC >> gvs[]) >> + gvs[state_rel, store_lookup_def, oEL_THM, LIST_REL_EL_EQN] >> + first_assum $ qspec_then `n` assume_tac >> + Cases_on `EL n cst'` >> gvs[store_rel_def] >> + Cases_on `t'` >> Cases_on ‘t''’ >> gvs[store_rel_def] >> + rw[EL_CONS, PRE_SUB1] >> + qexists0 >> reverse $ rw[step_rel_cases, store_lookup_def] >> + qpat_x_assum `v_rel _ _ (ThunkLoc _) _` mp_tac >> + rw [Once v_rel_cases] >> simp [EL_CONS, PRE_SUB1] + >- gvs [state_rel, EL_CONS, PRE_SUB1, store_lookup_def] + >- (goal_assum drule >> gvs [state_rel, LIST_REL_EL_EQN]) + >- gvs [state_rel, EL_CONS, PRE_SUB1, store_lookup_def] + >- ( + goal_assum drule >> gvs [state_rel, LIST_REL_EL_EQN] >> + irule cont_rel_AppK >> simp [op_rel_cases] >> + irule_at Any cont_rel_ForceMutK >> gvs [env_rel_def]) ) >- ( (* Update *) `LENGTH l0 = 2` by gvs[] >> gvs[LENGTH_EQ_NUM_compute] >> rename1 `[lnum;idx;elem]` >> gvs[application_def, sstep] >> Cases_on `lnum` >> gvs[] >> Cases_on `idx` >> gvs[] >> - TOP_CASE_TAC >> gvs[] >> IF_CASES_TAC >> gvs[DISJ_EQ_IMP] >> + TOP_CASE_TAC >> gvs[] >> TOP_CASE_TAC >> gvs[DISJ_EQ_IMP] >> simp[do_app_def] >> drule state_rel_store_lookup >> disch_then $ qspec_then `n` assume_tac >> gvs[] >> - imp_res_tac LIST_REL_LENGTH >> gvs[] + Cases_on `z` >> gvs[store_rel_def] >> + imp_res_tac LIST_REL_LENGTH >> gvs[] >> + TOP_CASE_TAC >- ( (* in bounds *) `¬(i < 0)` by ARITH_TAC >> simp[] >> - `¬(Num (ABS i) ≥ LENGTH cs)` by ARITH_TAC >> simp[] >> + `¬(Num (ABS i) ≥ LENGTH l'')` by ARITH_TAC >> simp[] >> drule store_lookup_assign_Varray >> rw[] >> `ABS i = i` by ARITH_TAC >> simp[] >> qexists0 >> reverse $ rw[step_rel_cases] >- gvs[state_rel, LUPDATE_DEF, store_lookup_def] >> - goal_assum drule >> gvs[state_rel] >> simp[LUPDATE_DEF, GSYM ADD1] >> - ntac 2 (irule EVERY2_LUPDATE_same >> simp[]) + irule_at Any cont_rel_LUPDATE_Array >> + goal_assum drule >> + irule state_rel_LUPDATE_Array >> + gvs [state_rel] >> simp [LUPDATE_DEF, GSYM ADD1] >> + irule EVERY2_LUPDATE_same >> simp [store_rel_def] ) >- ( (* out of bounds *) qmatch_goalsub_abbrev_tac `cstep_n _ foo` >> @@ -1852,31 +2209,19 @@ Proof simp[sub_exn_v_def] >> gvs[env_rel_def, cnenv_rel_def, prim_types_ok_def] ) ) - >- ( (* Unsafe sub *) - `LENGTH l0 = 1` by gvs[] >> gvs[LENGTH_EQ_NUM_compute] >> - rename1 `[lnum;idx]` >> gvs[application_def, sstep] >> - Cases_on `lnum` >> gvs[] >> Cases_on `idx` >> gvs[] >> - TOP_CASE_TAC >> gvs[] >> TOP_CASE_TAC >> gvs[] >> - simp[do_app_def] >> drule state_rel_store_lookup >> - disch_then $ qspec_then `n` assume_tac >> gvs[] >> - imp_res_tac LIST_REL_LENGTH >> gvs[] >> - `¬(i < 0)` by ARITH_TAC >> simp[] >> - `¬(Num (ABS i) ≥ LENGTH cs)` by ARITH_TAC >> simp[] >> - `ABS i = i` by ARITH_TAC >> simp[] >> - qexists0 >> rw[step_rel_cases] >> rpt $ goal_assum $ drule_at Any >> - gvs[LIST_REL_EL_EQN] - ) >- ( (* Sub *) `LENGTH l0 = 1` by gvs[] >> gvs[LENGTH_EQ_NUM_compute] >> rename1 `[lnum;idx]` >> gvs[application_def, sstep] >> Cases_on `lnum` >> gvs[] >> Cases_on `idx` >> gvs[] >> - TOP_CASE_TAC >> gvs[] >> IF_CASES_TAC >> gvs[DISJ_EQ_IMP] >> + TOP_CASE_TAC >> gvs[] >> TOP_CASE_TAC >> gvs[DISJ_EQ_IMP] >> simp[do_app_def] >> drule state_rel_store_lookup >> disch_then $ qspec_then `n` assume_tac >> gvs[] >> - imp_res_tac LIST_REL_LENGTH >> gvs[] + Cases_on `z` >> gvs[store_rel_def] >> + imp_res_tac LIST_REL_LENGTH >> gvs[] >> + TOP_CASE_TAC >- ( (* in bounds *) `¬(i < 0)` by ARITH_TAC >> simp[] >> - `¬(Num (ABS i) ≥ LENGTH cs)` by ARITH_TAC >> simp[] >> + `¬(Num (ABS i) ≥ LENGTH l'')` by ARITH_TAC >> simp[] >> `ABS i = i` by ARITH_TAC >> simp[] >> qexists0 >> rw[step_rel_cases] >> rpt $ goal_assum $ drule_at Any >> gvs[LIST_REL_EL_EQN] @@ -1892,18 +2237,12 @@ Proof ) >- ( (* Length *) gvs[application_def, sstep] >> Cases_on `sv` >> gvs[] >> - TOP_CASE_TAC >> gvs[] >> simp[do_app_def] >> + ntac 2 (TOP_CASE_TAC >> gvs []) >> simp[do_app_def] >> drule state_rel_store_lookup >> disch_then $ qspec_then `n` assume_tac >> gvs[] >> + Cases_on `z` >> gvs[store_rel_def] >> imp_res_tac LIST_REL_LENGTH >> gvs[] >> qexists0 >> rw[step_rel_cases, SF SFY_ss] - ) - >- ( (* Ref *) - gvs[application_def, sstep] >> simp[do_app_def, store_alloc_def] >> - qexists0 >> reverse $ rw[step_rel_cases] - >- (gvs[store_lookup_def] >> Cases_on `cst` >> gvs[]) >> - gvs[state_rel, ADD1] >> rpt $ goal_assum $ drule_at Any >> - imp_res_tac LIST_REL_LENGTH >> simp[SNOC_APPEND] ) >> (* AtomOp *) gvs[application_def, sstep] >> @@ -2123,8 +2462,14 @@ Proof ntac 8 (qrefine `SUC n` >> simp[cstep_n_def, cstep, do_if_def]) >> simp[do_app_def, store_alloc_def] >> qexists0 >> simp[step_rel_cases] >> gvs[state_rel, ADD1, store_lookup_def] >> - rpt $ goal_assum $ drule_at Any >> imp_res_tac LIST_REL_LENGTH >> simp[] >> - `ABS i = i` by ARITH_TAC >> simp[LIST_REL_REPLICATE_same] + rpt $ goal_assum $ drule_at Any >> imp_res_tac LIST_REL_LENGTH >> + simp[store_rel_def, EL_APPEND] >> + irule_at (Pos hd) cont_rel_APPEND >> + goal_assum drule >> gvs [LIST_REL_EL_EQN] >> rw [] + >- simp [store_rel_APPEND] + >- simp [store_rel_APPEND] >> + `ABS i = i` by ARITH_TAC >> simp[LIST_REL_REPLICATE_same] >> + irule v_rel_APPEND >> simp [EL_REPLICATE] ) >- ( (* Concat *) `cnenv_rel cnenv cenv'.c` by gvs[env_rel_def] >> @@ -2460,7 +2805,7 @@ Proof qexists0 >> simp[dstep, store_lookup_def] >> simp[dstep_rel_cases, step_rel_cases, PULL_EXISTS] >> irule_at Any EQ_REFL >> goal_assum drule >> gvs[state_rel] >> - qpat_x_assum `cont_rel _ _ _` mp_tac >> rw[Once cont_rel_cases] + qpat_x_assum `cont_rel _ _ _ _` mp_tac >> rw[Once cont_rel_cases] QED Theorem compile_safe_itree: @@ -2487,12 +2832,14 @@ QED Inductive csop_rel: csop_rel (AppOp : csop) Opapp ∧ (atom_op_rel aop op ⇒ csop_rel (AtomOp aop) op) ∧ - csop_rel Ref AallocFixed ∧ csop_rel Length Alength ∧ csop_rel Sub Asub ∧ - csop_rel UnsafeSub Asub_unsafe ∧ csop_rel Update Aupdate ∧ - csop_rel UnsafeUpdate Aupdate_unsafe + csop_rel (AllocMutThunk Evaluated) (ThunkOp $ AllocThunk Evaluated) ∧ + csop_rel (AllocMutThunk NotEvaluated) (ThunkOp $ AllocThunk NotEvaluated) ∧ + csop_rel (UpdateMutThunk Evaluated) (ThunkOp $ UpdateThunk Evaluated) ∧ + csop_rel (UpdateMutThunk NotEvaluated) (ThunkOp $ UpdateThunk NotEvaluated) ∧ + csop_rel ForceMutThunk (ThunkOp ForceThunk) End Inductive cexp_compile_rel: @@ -2701,9 +3048,12 @@ QED Theorem compile_op_CakeOp: compile_op op = CakeOp cop ⇒ csop_rel op cop Proof - Cases_on `op` >> gvs[compile_op_def, csop_rel_cases] >> - Cases_on `a` >> rw[] >> gvs[compile_atomop_def, atom_op_rel_cases] >> - gvs[opn_rel_cases, opb_rel_cases] + Cases_on `op` >> gvs[compile_op_def, csop_rel_cases] + >- ( + Cases_on `a` >> rw[] >> gvs[compile_atomop_def, atom_op_rel_cases] >> + gvs[opn_rel_cases, opb_rel_cases] + ) >> + Cases_on `c` >> rw[] >> gvs[compile_op_def] QED Theorem ns_cns_arities_ns_rel: @@ -2786,6 +3136,8 @@ Proof ) >- ( (* TwoArgs *) reverse $ Cases_on `op` >> gvs[compile_op_def, op_args_ok_def] + >- (Cases_on `c` >> gvs[compile_op_def, op_args_ok_def]) + >- (Cases_on `c` >> gvs[compile_op_def, op_args_ok_def]) >- (gvs[LENGTH_EQ_NUM_compute, oEL_THM] >> simp[Once cexp_compile_rel_cases]) >> Cases_on `a` >> gvs[compile_atomop_def, op_args_ok_def] >> gvs[LENGTH_EQ_NUM_compute, oEL_THM] >> simp[Once cexp_compile_rel_cases] @@ -2811,7 +3163,11 @@ Proof >- ( (* FFI *) gvs[op_args_ok_def, LENGTH_EQ_NUM_compute, oEL_THM] >> simp[Once cexp_compile_rel_cases] - ) >> + ) + >~ [`AllocMutThunk`] + >- (Cases_on `c` >> gvs[compile_op_def, op_args_ok_def]) + >~ [`UpdateMutThunk`] + >- (Cases_on `c` >> gvs[compile_op_def, op_args_ok_def]) >> Cases_on `a` >> gvs[compile_atomop_def, op_args_ok_def] >- ( (* Lit *) Cases_on `l` >> gvs[op_args_ok_def] >> simp[Once cexp_compile_rel_cases] @@ -3233,15 +3589,15 @@ Proof PairCases_on `h` >> rename1 `(cn,ts)` >> simp[compile_exndef_def, build_exns_def] >> ntac 2 (qrefine `SUC n` >> simp[dstep]) >> - qmatch_goalsub_abbrev_tac `Dstep dst' (Env sing_env)` >> + qmatch_goalsub_abbrev_tac `Dstep dst' (Env sing)` >> qmatch_goalsub_abbrev_tac `CdlocalG _ (comp_env +++ _ +++ _)` >> `comp_env = <| v := nsEmpty; c := build_exns (dst.next_exn_stamp + 1) exns |> - +++ sing_env` by ( + +++ sing` by ( unabbrev_all_tac >> simp[extend_dec_env_def]) >> pop_assum $ SUBST_ALL_TAC >> last_x_assum $ qspecl_then - [`benv`,`dst'`,`sing_env`,`envl`,`env +++ envg`,`k`,`p`,`prog`] assume_tac >> + [`benv`,`dst'`,`sing`,`envl`,`env +++ envg`,`k`,`p`,`prog`] assume_tac >> gvs[] >> qrefine `m + n` >> simp[itree_semanticsPropsTheory.step_n_add] >> qexists0 >> simp[dstep] >> unabbrev_all_tac >> gvs[ADD1] @@ -3278,14 +3634,14 @@ Proof qpat_abbrev_tac `cndefs_ns = alist_to_ns _` >> simp[MAP_MAP_o, combinTheory.o_DEF, LAMBDA_PROD, GSYM FST_THM] >> gvs[] >> - qmatch_goalsub_abbrev_tac `Dstep dst' (Env sing_env)` >> + qmatch_goalsub_abbrev_tac `Dstep dst' (Env sing)` >> qmatch_goalsub_abbrev_tac `CdlocalG _ (comp_env +++ _ +++ _)` >> ‘comp_env = - <| v := nsEmpty; c := build_typedefs (dst.next_type_stamp + 1) tdefs |> +++ sing_env’ by ( + <| v := nsEmpty; c := build_typedefs (dst.next_type_stamp + 1) tdefs |> +++ sing’ by ( unabbrev_all_tac >> simp[extend_dec_env_def]) >> pop_assum $ SUBST_ALL_TAC >> last_x_assum $ qspecl_then - [`benv`,`dst'`,`sing_env`,`envl`,`env +++ envg`,`k`,`p`,`prog`] assume_tac >> + [`benv`,`dst'`,`sing`,`envl`,`env +++ envg`,`k`,`p`,`prog`] assume_tac >> gvs[] >> qrefine `m + n` >> simp[itree_semanticsPropsTheory.step_n_add] >> qexists0 >> simp[dstep] >> unabbrev_all_tac >> gvs[ADD1] diff --git a/compiler/backend/passes/proofs/state_unthunkProofScript.sml b/compiler/backend/passes/proofs/state_unthunkProofScript.sml index a70a29f8..f77c8401 100644 --- a/compiler/backend/passes/proofs/state_unthunkProofScript.sml +++ b/compiler/backend/passes/proofs/state_unthunkProofScript.sml @@ -22,20 +22,9 @@ Overload False_v = “stateLang$Constructor "False" []”; (****************************************) -Overload "box" = “λx. App Ref [True; x]” - -Overload "delay" = “λx. App Ref [False; Lam NONE x]” - -Overload "force_lets" = “ - Let (SOME "v1") (App UnsafeSub [Var "v"; IntLit 0]) $ - Let (SOME "v2") (App UnsafeSub [Var "v"; IntLit 1]) $ - If (Var "v1") (Var "v2") $ - Let (SOME "wh") (app (Var "v2") Unit) $ - Let NONE (App UnsafeUpdate [Var "v"; IntLit 0; True]) $ - Let NONE (App UnsafeUpdate [Var "v"; IntLit 1; Var "wh"]) $ - Var "wh"” - -Overload "force" = “λx. Let (SOME "v") x force_lets” +Overload "box" = “λx. App (AllocMutThunk Evaluated) [x]” +Overload "delay" = “λx. App (AllocMutThunk NotEvaluated) [Lam NONE x]” +Overload "force" = “λx. App ForceMutThunk [x]” Definition dest_Delay_def: dest_Delay (Delay x) = SOME x ∧ @@ -70,31 +59,26 @@ Definition Letrec_split_def: | SOME y => ((v,Letrec_imm vs y,y)::xs,ys) End -Definition Bool_def[simp]: - Bool T = True ∧ - Bool F = False -End - -Definition Bool_v_def[simp]: - Bool_v T = True_v ∧ - Bool_v F = False_v -End - -Definition some_ref_bool_def: - some_ref_bool (v:string,b,y:exp) = (SOME v, App Ref [Bool b; Bool b]) +Definition some_alloc_thunk_def: + some_alloc_thunk (v:string,b,y:exp) = + (SOME v, App (AllocMutThunk NotEvaluated) [IntLit 0]) End -Definition unsafe_update_def: - unsafe_update (v,b,y) = - (NONE:string option, App UnsafeUpdate [Var v; IntLit 1; if b then y else Lam NONE y]) +Definition update_delay_def: + update_delay (v,b,y) = + (NONE:string option, + if b then + App (UpdateMutThunk Evaluated) [Var v; y] + else + App (UpdateMutThunk NotEvaluated) [Var v; Lam NONE y]) End Definition comp_Letrec_def: comp_Letrec xs y = let (delays,funs) = Letrec_split (MAP FST xs) xs in - Lets (MAP some_ref_bool delays) $ + Lets (MAP some_alloc_thunk delays) $ Letrec funs $ - Lets (MAP unsafe_update delays) y + Lets (MAP update_delay delays) y End Inductive compile_rel: @@ -179,10 +163,8 @@ End Definition loc_rel_def[simp]: loc_rel p tenv tfns (tn,te:exp) (sn,sv) ⇔ ∃r n. - tn = sn ∧ - dest_anyThunk (Recclosure tfns tenv tn) = SOME r ∧ - sv = Atom (Loc n) ∧ - oEL n p = SOME (SOME r) + tn = sn ∧ dest_anyThunk (Recclosure tfns tenv tn) = SOME r ∧ + sv = ThunkLoc n ∧ oEL n p = SOME (SOME (Recclosure tfns tenv tn)) End Inductive v_rel: @@ -197,6 +179,11 @@ Inductive v_rel: (∀l. a ≠ Loc l) ⇒ v_rel p (Atom a) (Atom a)) +[~ThunkLoc:] + (∀p n1 n2. + find_loc n1 p = SOME n2 ⇒ + v_rel p (ThunkLoc n1) (ThunkLoc n2)) + [~Constructor:] (∀p s tvs svs. LIST_REL (v_rel p) tvs svs ⇒ @@ -236,8 +223,8 @@ Inductive v_rel: [~Thunk:] (∀p n r. - oEL n p = SOME (SOME (r,[])) ⇒ - v_rel p (Thunk r) (Atom (Loc n))) + oEL n p = SOME (SOME (Thunk r)) ⇒ + v_rel p (Thunk r) (ThunkLoc n)) [env_rel:] (∀p tenv senv. @@ -308,7 +295,7 @@ Inductive cont_rel: (∀p sk tk senv. cont_rel p tk sk ⇒ cont_rel p (BoxK :: tk) - (AppK senv Ref [] [True] :: sk)) ∧ + (AppK senv (AllocMutThunk Evaluated) [] [] :: sk)) ∧ (∀p sk tk. cont_rel p tk sk ⇒ cont_rel p (RaiseK :: tk) @@ -316,26 +303,39 @@ Inductive cont_rel: (∀p sk tk senv. cont_rel p tk sk ⇒ cont_rel p (ForceK1 :: tk) - (LetK senv (SOME "v") force_lets :: sk)) + (AppK senv ForceMutThunk [] [] :: sk)) ∧ + (∀p sk tk n1 n2. + cont_rel p tk sk ∧ + find_loc n1 p = SOME n2 ⇒ + cont_rel p (ForceMutK n1::tk) + (ForceMutK n2::sk)) End -Definition rec_env_def: - rec_env f env = - MAP (λ(fn,_). (fn,Recclosure f env fn)) f ++ env +Definition store_rel_def: + store_rel p (ThunkMem m v1) s2 = + (∃v2. + s2 = ThunkMem m v2 ∧ + v_rel p v1 v2) ∧ + store_rel p (Array vs1) v2 = + (∃vs2. + v2 = Array vs2 ∧ + LIST_REL (v_rel p) vs1 vs2) End Definition thunk_rel_def: thunk_rel p NONE _ = T ∧ - thunk_rel p (SOME (x,f)) vs = - case x of - | INL tv => (∃sv. v_rel p tv sv ∧ vs = [True_v; sv]) - | INR (tenv,te) => - (∃senv se. - env_rel p (rec_env f tenv) senv ∧ compile_rel te se ∧ - vs = [False_v; Closure NONE senv se]) ∨ - (∃tv sv ck. - step_n ck (Exp (rec_env f tenv) te,NONE,[]) = (Val tv,NONE,[]) ∧ - vs = [True_v; sv] ∧ v_rel p tv sv) + thunk_rel p (SOME thk) v = + ∃x f. + dest_anyThunk thk = SOME (x,f) ∧ + case x of + | INL tv => (∃sv. v_rel p tv sv ∧ v = ThunkMem Evaluated sv) + | INR (tenv,te) => + (∃senv se. + env_rel p (mk_rec_env f tenv) senv ∧ compile_rel te se ∧ + v = ThunkMem NotEvaluated (Closure NONE senv se)) ∨ + (∃tv sv ck. + step_n ck (Exp (mk_rec_env f tenv) te,NONE,[]) = (Val tv,NONE,[]) ∧ + v = ThunkMem Evaluated sv ∧ v_rel p tv sv) End Definition state_rel_def: @@ -343,7 +343,8 @@ Definition state_rel_def: ∃t1 s1. ts = SOME t1 ∧ ss = SOME s1 ∧ LIST_REL (thunk_rel p) p s1 ∧ - LIST_REL (LIST_REL (v_rel p)) t1 (MAP SND (FILTER (λx. FST x = NONE) (ZIP (p,s1)))) + LIST_REL + (store_rel p) t1 (MAP SND (FILTER (λx. FST x = NONE) (ZIP (p,s1)))) End Inductive snext_res_rel: @@ -376,7 +377,7 @@ QED Theorem v_rel_new_Thunk: loc = LENGTH p ⇒ - v_rel (p ++ [SOME (r,[])]) (Thunk r) (Atom (Loc loc)) + v_rel (p ++ [SOME (Thunk r)]) (Thunk r) (ThunkLoc loc) Proof simp [Once v_rel_cases,oEL_THM,rich_listTheory.EL_LENGTH_APPEND] \\ EVAL_TAC @@ -394,6 +395,14 @@ Proof \\ simp [Once v_rel_cases] \\ gvs [SF ETA_ss] \\ gvs [oEL_THM,EL_APPEND1] + >- + (pop_assum mp_tac + \\ qid_spec_tac ‘n2’ + \\ qid_spec_tac ‘n1’ + \\ qid_spec_tac ‘p’ + \\ Induct \\ fs [find_loc_def] + \\ Cases \\ fs [] + \\ rw [] \\ res_tac \\ gvs []) >- (pop_assum mp_tac \\ qid_spec_tac ‘n2’ @@ -428,6 +437,16 @@ Proof metis_tac [v_rel_env_rel_ext] QED +Theorem find_loc_ext: + ∀p n1 n2 q. + find_loc n1 p = SOME n2 ⇒ + find_loc n1 (p ++ q) = SOME n2 +Proof + Induct \\ gvs [find_loc_def] + \\ Cases \\ gvs [find_loc_def] + \\ rw [] \\ res_tac \\ simp [] +QED + Theorem cont_rel_ext: ∀q p k1 k2. cont_rel p k1 k2 ⇒ @@ -439,6 +458,18 @@ Proof \\ gvs [LIST_REL_EL_EQN] \\ rw [] \\ res_tac \\ rpt (irule_at Any v_rel_ext \\ fs []) + \\ irule_at Any find_loc_ext \\ fs [] +QED + +Theorem store_rel_ext: + ∀q p k1 k2. + store_rel p k1 k2 ⇒ + store_rel (p ++ q) k1 k2 +Proof + rw [] + \\ Cases_on ‘k1’ \\ Cases_on ‘k2’ \\ gvs [store_rel_def] + \\ gvs [LIST_REL_EL_EQN] \\ rpt strip_tac \\ res_tac + \\ irule_at Any v_rel_ext \\ fs [] QED Theorem thunk_rel_ext: @@ -447,8 +478,7 @@ Theorem thunk_rel_ext: thunk_rel (p ++ q) k1 k2 Proof rw [] \\ Cases_on ‘k1’ \\ fs [thunk_rel_def] - \\ PairCases_on ‘x’ \\ fs [thunk_rel_def] - \\ Cases_on ‘x0’ \\ fs [] + \\ Cases_on ‘x'’ \\ fs [] \\ TRY (Cases_on ‘y’ \\ fs []) \\ TRY (irule_at Any v_rel_ext \\ fs []) \\ TRY (irule_at Any env_rel_ext \\ fs []) @@ -458,10 +488,11 @@ QED Theorem state_rel_INR: state_rel p ts (SOME ss) ∧ - env_rel p (rec_env f env1) env2 ∧ - compile_rel te se ⇒ - state_rel (p ++ [SOME (INR (env1,te),f)]) ts - (SOME (SNOC [False_v; Closure NONE env2 se] ss)) + env_rel p (mk_rec_env f env1) env2 ∧ + compile_rel te se ∧ + dest_anyThunk thk = SOME (INR (env1,te),f) ⇒ + state_rel (p ++ [SOME thk]) ts + (SOME (SNOC (ThunkMem NotEvaluated (Closure NONE env2 se)) ss)) Proof fs [state_rel_def] \\ rw [] \\ gvs [] \\ gvs [thunk_rel_def,SNOC_APPEND] @@ -470,12 +501,14 @@ Proof \\ gvs [LIST_REL_EL_EQN] \\ rw [] \\ TRY (irule_at Any thunk_rel_ext \\ fs []) \\ TRY (irule_at Any env_rel_ext \\ fs []) - \\ irule_at Any v_rel_ext \\ fs [] + \\ irule_at Any store_rel_ext \\ fs [] QED Theorem state_rel_INL: - state_rel p ts (SOME ss) ∧ v_rel p v1 v2 ⇒ - state_rel (p ++ [SOME (INL v1,f)]) ts (SOME (SNOC [True_v; v2] ss)) + state_rel p ts (SOME ss) ∧ v_rel p v1 v2 ∧ + dest_anyThunk thk = SOME (INL v1,f) ⇒ + state_rel + (p ++ [SOME thk]) ts (SOME (SNOC (ThunkMem Evaluated v2) ss)) Proof fs [state_rel_def] \\ rw [] \\ gvs [] \\ gvs [thunk_rel_def,SNOC_APPEND] @@ -483,7 +516,8 @@ Proof \\ gvs [GSYM ZIP_APPEND,FILTER_APPEND] \\ gvs [LIST_REL_EL_EQN] \\ rw [] \\ TRY (irule_at Any thunk_rel_ext \\ fs []) - \\ irule_at Any v_rel_ext \\ fs [] + \\ TRY (irule_at Any v_rel_ext \\ fs []) + \\ irule_at Any store_rel_ext \\ fs [] QED Theorem v_rel_Ref: @@ -492,7 +526,22 @@ Theorem v_rel_Ref: Proof fs [Once v_rel_cases,state_rel_def] \\ rename [‘LIST_REL r p ss’] - \\ rename [‘LIST_REL (LIST_REL qq) x’] + \\ qabbrev_tac ‘qq = store_rel p’ + \\ qid_spec_tac ‘x’ + \\ qid_spec_tac ‘ss’ + \\ qid_spec_tac ‘p’ + \\ Induct \\ fs [find_loc_def,PULL_EXISTS] + \\ Cases \\ fs [PULL_EXISTS] \\ rw [] + \\ res_tac \\ fs [] +QED + +Theorem v_rel_Ref_Thunk: + state_rel p (SOME x) (SOME ss) ⇒ + v_rel (p ++ [NONE]) (ThunkLoc (LENGTH x)) (ThunkLoc (LENGTH ss)) +Proof + fs [Once v_rel_cases,state_rel_def] + \\ rename [‘LIST_REL r p ss’] + \\ qabbrev_tac ‘qq = store_rel p’ \\ qid_spec_tac ‘x’ \\ qid_spec_tac ‘ss’ \\ qid_spec_tac ‘p’ @@ -503,26 +552,34 @@ QED Theorem state_rel_Ref: LIST_REL (v_rel p) xs ys ∧ state_rel p (SOME ts) (SOME ss) ⇒ - state_rel (p ++ [NONE]) (SOME (SNOC xs ts)) (SOME (SNOC ys ss)) + state_rel + (p ++ [NONE]) (SOME (SNOC (Array xs) ts)) (SOME (SNOC (Array ys) ss)) Proof gvs [state_rel_def,thunk_rel_def,SNOC_APPEND] \\ rpt strip_tac >- (gvs [LIST_REL_EL_EQN] \\ rw [] \\ irule_at Any thunk_rel_ext \\ fs []) \\ imp_res_tac LIST_REL_LENGTH - \\ ‘ZIP (p ++ [NONE],ss ++ [ys]) = ZIP (p,ss) ++ ZIP ([NONE],[ys])’ by + \\ ‘ZIP (p ++ [NONE],ss ++ [Array ys]) = + ZIP (p,ss) ++ ZIP ([NONE],[Array ys])’ by (irule $ GSYM ZIP_APPEND \\ fs []) \\ fs [FILTER_APPEND] - \\ gvs [LIST_REL_EL_EQN] \\ rw [] - \\ irule_at Any v_rel_ext \\ fs [] + \\ gvs [store_rel_def,LIST_REL_EL_EQN] \\ rw [] + >- + (Cases_on ‘EL n ts’ \\ gvs [store_rel_def] + \\ first_x_assum $ drule_then assume_tac + \\ gvs [store_rel_def,LIST_REL_EL_EQN] \\ rw [] + \\ irule_at Any v_rel_ext \\ fs []) + >- + (irule_at Any v_rel_ext \\ fs []) QED Theorem dest_anyThunk_INL: v_rel p v1 v2 ∧ state_rel p zs (SOME ss) ∧ dest_anyThunk v1 = SOME (INL x, f) ⇒ ∃loc y. - v2 = Atom (Loc loc) ∧ v_rel p x y ∧ - oEL loc ss = SOME [True_v; y] + v2 = ThunkLoc loc ∧ v_rel p x y ∧ + oEL loc ss = SOME (ThunkMem Evaluated y) Proof Cases_on ‘v1’ \\ fs [dest_anyThunk_def,dest_Thunk_def,AllCaseEqs()] \\ simp [Once v_rel_cases] @@ -532,7 +589,7 @@ Proof \\ gvs [oEL_THM] \\ gvs [LIST_REL_EL_EQN] \\ last_x_assum drule - \\ fs [thunk_rel_def] + \\ fs [thunk_rel_def,dest_anyThunk_def] QED Triviality ALOOKUP_LIST_REL_loc_rel: @@ -597,12 +654,13 @@ Theorem dest_anyThunk_INR: v_rel p v1 v2 ∧ state_rel p zs (SOME ss) ∧ dest_anyThunk v1 = SOME (INR (x1,x2), f) ⇒ ∃loc. - v2 = Atom (Loc loc) ∧ + v2 = ThunkLoc loc ∧ ((∃senv se. - env_rel p (rec_env f x1) senv ∧ compile_rel x2 se ∧ - oEL loc ss = SOME [False_v; Closure NONE senv se]) ∨ - ∃tv sv ck. step_n ck (Exp (rec_env f x1) x2,NONE,[]) = (Val tv,NONE,[]) ∧ - oEL loc ss = SOME [True_v; sv] ∧ v_rel p tv sv) + env_rel p (mk_rec_env f x1) senv ∧ compile_rel x2 se ∧ + oEL loc ss = SOME (ThunkMem NotEvaluated (Closure NONE senv se))) ∨ + ∃tv sv ck. + step_n ck (Exp (mk_rec_env f x1) x2,NONE,[]) = (Val tv,NONE,[]) ∧ + oEL loc ss = SOME (ThunkMem Evaluated sv) ∧ v_rel p tv sv) Proof reverse (Cases_on ‘v1’ \\ fs [dest_anyThunk_def,dest_Thunk_def,AllCaseEqs()]) @@ -615,9 +673,7 @@ Proof \\ gvs [oEL_THM] \\ gvs [LIST_REL_EL_EQN] \\ last_x_assum drule - \\ fs [thunk_rel_def] - \\ strip_tac \\ fs [] - \\ rpt (first_x_assum $ irule_at Any)) + \\ fs [thunk_rel_def,dest_anyThunk_def]) \\ simp [Once v_rel_cases] \\ rw [] >- (drule_all alistTheory.ALOOKUP_ALL_DISTINCT_MEM \\ fs []) \\ drule_all LIST_REL_loc_rel @@ -634,9 +690,9 @@ Proof QED Theorem dest_anyThunk_INR_abs: - v_rel p v1 (Atom (Loc loc)) ∧ state_rel p zs (SOME ss) ∧ + v_rel p v1 (ThunkLoc loc) ∧ state_rel p zs (SOME ss) ∧ dest_anyThunk v1 = SOME (INR (x1,x2), f) ⇒ - ∃i1 i2. oEL loc ss = SOME [i1;i2] + ∃i1 i2. oEL loc ss = SOME (ThunkMem i1 i2) Proof strip_tac \\ drule_all dest_anyThunk_INR \\ fs [] @@ -690,24 +746,25 @@ QED Theorem state_rel_LUPDATE_anyThunk: v_rel p res v2 ∧ state_rel p ts (SOME ss2) ∧ - v_rel p v1 (Atom (Loc loc)) ∧ + v_rel p v1 (ThunkLoc loc) ∧ dest_anyThunk v1 = SOME (INR (tenv1,te),f) ∧ - step_n n (Exp (rec_env f tenv1) te,NONE,[]) = (Val res,NONE,[]) ⇒ - state_rel p ts (SOME (LUPDATE [True_v; v2] loc ss2)) + step_n n (Exp (mk_rec_env f tenv1) te,NONE,[]) = (Val res,NONE,[]) ⇒ + state_rel p ts (SOME (LUPDATE (ThunkMem Evaluated v2) loc ss2)) Proof fs [state_rel_def] \\ rw [] \\ fs [] - \\ qpat_x_assum ‘v_rel p v1 (Atom (Loc loc))’ mp_tac + \\ qpat_x_assum ‘v_rel p v1 (ThunkLoc loc)’ mp_tac \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] \\ gvs [state_rel_def] \\ gvs [oEL_THM] \\ rpt conj_tac - >~ [‘LIST_REL (thunk_rel p) p (LUPDATE [True_v; v2] loc ss2)’,‘Thunk’] + >~ [‘LIST_REL (thunk_rel p) p (LUPDATE (ThunkMem Evaluated v2) loc ss2)’, + ‘Thunk’] >- (qpat_x_assum ‘LIST_REL _ _ _’ kall_tac \\ fs [LIST_REL_EL_EQN] \\ gvs [EL_LUPDATE,dest_anyThunk_def] \\ rw [] \\ gvs [] - \\ fs [thunk_rel_def] + \\ fs [thunk_rel_def,dest_anyThunk_def] \\ rpt (first_x_assum $ irule_at Any)) >~ [‘Thunk’] >- (qpat_x_assum ‘LIST_REL _ _ _’ mp_tac @@ -715,6 +772,7 @@ Proof \\ AP_TERM_TAC \\ pop_assum mp_tac \\ imp_res_tac LIST_REL_LENGTH + \\ gvs [dest_anyThunk_def] \\ pop_assum mp_tac \\ pop_assum mp_tac \\ qid_spec_tac ‘loc’ @@ -724,22 +782,26 @@ Proof \\ Induct \\ fs [LUPDATE_DEF] \\ Cases_on ‘ss2’ \\ fs [] \\ Cases_on ‘loc’ \\ fs [LUPDATE_DEF] \\ rw [] \\ fs []) - >~ [‘LIST_REL (thunk_rel p) p (LUPDATE [True_v; v2] loc ss2)’] + >~ [‘LIST_REL (thunk_rel p) p (LUPDATE (ThunkMem Evaluated v2) loc ss2)’] + >- (qpat_x_assum ‘LIST_REL (thunk_rel p) p ss2’ mp_tac + \\ simp [LIST_REL_EL_EQN] \\ rw [] + \\ gvs [EL_LUPDATE,dest_anyThunk_def,AllCaseEqs()]) + >~ [‘LIST_REL (thunk_rel p) p (LUPDATE (ThunkMem Evaluated v2) loc ss2)’] >- (qpat_x_assum ‘LIST_REL (thunk_rel p) p ss2’ mp_tac \\ simp [LIST_REL_EL_EQN] \\ rw [] \\ gvs [EL_LUPDATE,dest_anyThunk_def,AllCaseEqs()] \\ rw [] \\ gvs [] \\ first_x_assum drule \\ Cases_on ‘EL loc p’ \\ fs [thunk_rel_def] - \\ PairCases_on ‘x’ \\ fs [thunk_rel_def] + \\ strip_tac \\ gvs [] \\ qpat_x_assum ‘ALOOKUP f n' = SOME (Delay te)’ assume_tac \\ drule IMP_ALOOKUP_FILTER \\ disch_then $ qspec_then ‘((λx. is_Delay x) ∘ SND)’ mp_tac \\ impl_tac >- fs [dest_Delay_def] \\ strip_tac \\ drule_all ALOOKUP_LIST_REL_loc_rel - \\ simp [dest_anyThunk_def,oEL_THM] - \\ reverse (rpt strip_tac) \\ gvs [] + \\ gvs [] \\ strip_tac \\ gvs [oEL_THM] + \\ gvs [dest_anyThunk_def] \\ last_x_assum $ irule_at $ Pos hd \\ fs []) \\ qpat_x_assum ‘LIST_REL (thunk_rel p) p ss2’ mp_tac \\ simp [Once LIST_REL_EL_EQN] \\ rw [] @@ -752,7 +814,7 @@ Proof \\ strip_tac \\ drule_all ALOOKUP_LIST_REL_loc_rel \\ gvs [oEL_THM] \\ strip_tac - \\ qpat_x_assum ‘LIST_REL (LIST_REL _) _ _’ mp_tac + \\ qpat_x_assum ‘LIST_REL (store_rel _) _ _’ mp_tac \\ match_mp_tac (METIS_PROVE [] “p = q ⇒ x p ⇒ x q”) \\ AP_TERM_TAC \\ pop_assum mp_tac @@ -781,31 +843,102 @@ Proof \\ irule imp_env_rel_cons \\ fs [] QED +Theorem state_rel_thunk_v_rel: + state_rel p (SOME ts) (SOME ss) ∧ + find_loc n p = SOME n1 ∧ + v_rel p v1 v2 ⇒ + state_rel p (SOME (LUPDATE (ThunkMem Evaluated v1) n ts)) + (SOME (LUPDATE (ThunkMem Evaluated v2) n1 ss)) +Proof + fs [state_rel_def,GSYM CONJ_ASSOC] + \\ qsuff_tac ‘∀q p ss ts n n1 v1 v2. + LIST_REL (thunk_rel q) p ss ∧ + LIST_REL (store_rel q) ts + (MAP SND (FILTER (λx. FST x = NONE) (ZIP (p,ss)))) ∧ + find_loc n p = SOME n1 ∧ v_rel q v1 v2 ⇒ + LIST_REL (thunk_rel q) p (LUPDATE (ThunkMem Evaluated v2) n1 ss) ∧ + LIST_REL (store_rel q) (LUPDATE (ThunkMem Evaluated v1) n ts) + (MAP SND + (FILTER (λx. FST x = NONE) + (ZIP (p,LUPDATE (ThunkMem Evaluated v2) n1 ss))))’ + THEN1 (metis_tac []) + \\ gen_tac + \\ Induct \\ Cases_on ‘ss’ \\ fs [find_loc_def] + \\ reverse Cases \\ fs [] \\ rpt gen_tac \\ strip_tac \\ gvs [] + THEN1 + (last_x_assum drule_all \\ strip_tac + \\ fs [GSYM ADD1,oEL_def,LUPDATE_DEF]) + \\ reverse (Cases_on ‘n’) \\ gvs [oEL_def] + >- + (last_x_assum drule_all \\ strip_tac + \\ fs [GSYM ADD1,oEL_def,LUPDATE_DEF]) + \\ fs [thunk_rel_def,LUPDATE_DEF,store_rel_def] +QED + +Theorem state_rel_thunk: + state_rel p (SOME ts) (SOME ss) ∧ + find_loc n p = SOME n1 ∧ oEL n ts = SOME (ThunkMem t v) ⇒ + ∃v'. + oEL n1 ss = SOME (ThunkMem t v') ∧ v_rel p v v' ∧ + ∀t' x y. + v_rel p x y ⇒ + state_rel p (SOME (LUPDATE (ThunkMem t' x) n ts)) + (SOME (LUPDATE (ThunkMem t' y) n1 ss)) +Proof + fs [state_rel_def,GSYM CONJ_ASSOC] + \\ qsuff_tac ‘∀q p ss ts n n1 t v. + LIST_REL (thunk_rel q) p ss ∧ + LIST_REL (store_rel q) ts + (MAP SND (FILTER (λx. FST x = NONE) (ZIP (p,ss)))) ∧ + find_loc n p = SOME n1 ∧ oEL n ts = SOME (ThunkMem t v) ⇒ + ∃v'. + oEL n1 ss = SOME (ThunkMem t v') ∧ v_rel q v v' ∧ + ∀t' x y. + v_rel q x y ⇒ + LIST_REL (thunk_rel q) p (LUPDATE (ThunkMem t' y) n1 ss) ∧ + LIST_REL (store_rel q) (LUPDATE (ThunkMem t' x) n ts) + (MAP SND + (FILTER (λx. FST x = NONE) + (ZIP (p,LUPDATE (ThunkMem t' y) n1 ss))))’ + THEN1 (metis_tac []) + \\ gen_tac + \\ Induct \\ Cases_on ‘ss’ \\ fs [find_loc_def] + \\ reverse Cases \\ fs [] \\ rpt gen_tac \\ strip_tac \\ gvs [] + THEN1 + (last_x_assum drule_all \\ strip_tac + \\ fs [GSYM ADD1,oEL_def,LUPDATE_DEF] + \\ metis_tac []) + \\ reverse (Cases_on ‘n’) \\ gvs [oEL_def] + >- fs [GSYM ADD1,oEL_def,LUPDATE_DEF] + \\ fs [thunk_rel_def,LUPDATE_DEF] + \\ Cases_on ‘h’ \\ gvs [store_rel_def] +QED + Theorem state_rel_array: state_rel p (SOME ts) (SOME ss) ∧ - find_loc n p = SOME n1 ∧ oEL n ts = SOME ta ⇒ + find_loc n p = SOME n1 ∧ oEL n ts = SOME (Array ta) ⇒ ∃sa. - oEL n1 ss = SOME sa ∧ LIST_REL (v_rel p) ta sa ∧ + oEL n1 ss = SOME (Array sa) ∧ store_rel p (Array ta) (Array sa) ∧ ∀i x y. i < LENGTH ta ∧ v_rel p x y ⇒ - state_rel p (SOME (LUPDATE (LUPDATE x i ta) n ts)) - (SOME (LUPDATE (LUPDATE y i sa) n1 ss)) + state_rel p (SOME (LUPDATE (Array $ LUPDATE x i ta) n ts)) + (SOME (LUPDATE (Array $ LUPDATE y i sa) n1 ss)) Proof fs [state_rel_def,GSYM CONJ_ASSOC] \\ qsuff_tac ‘∀q p ss ts n n1 ta. LIST_REL (thunk_rel q) p ss ∧ - LIST_REL (LIST_REL (v_rel q)) ts + LIST_REL (store_rel q) ts (MAP SND (FILTER (λx. FST x = NONE) (ZIP (p,ss)))) ∧ - find_loc n p = SOME n1 ∧ oEL n ts = SOME ta ⇒ + find_loc n p = SOME n1 ∧ oEL n ts = SOME (Array ta) ⇒ ∃sa. - oEL n1 ss = SOME sa ∧ LIST_REL (v_rel q) ta sa ∧ + oEL n1 ss = SOME (Array sa) ∧ store_rel q (Array ta) (Array sa) ∧ ∀i x y. i < LENGTH ta ∧ v_rel q x y ⇒ - LIST_REL (thunk_rel q) p (LUPDATE (LUPDATE y i sa) n1 ss) ∧ - LIST_REL (LIST_REL (v_rel q)) (LUPDATE (LUPDATE x i ta) n ts) + LIST_REL (thunk_rel q) p (LUPDATE (Array $ LUPDATE y i sa) n1 ss) ∧ + LIST_REL (store_rel q) (LUPDATE (Array $ LUPDATE x i ta) n ts) (MAP SND (FILTER (λx. FST x = NONE) - (ZIP (p,LUPDATE (LUPDATE y i sa) n1 ss))))’ + (ZIP (p,LUPDATE (Array $ LUPDATE y i sa) n1 ss))))’ THEN1 (metis_tac []) \\ gen_tac \\ Induct \\ Cases_on ‘ss’ \\ fs [find_loc_def] @@ -817,6 +950,7 @@ Proof \\ reverse (Cases_on ‘n’) \\ gvs [oEL_def] >- fs [GSYM ADD1,oEL_def,LUPDATE_DEF] \\ fs [thunk_rel_def,LUPDATE_DEF] + \\ Cases_on ‘h’ \\ gvs [store_rel_def] \\ rw [] \\ irule_at Any listTheory.EVERY2_LUPDATE_same \\ fs [] QED @@ -851,6 +985,169 @@ Proof \\ simp [Once v_rel_cases] \\ fs [] QED +Theorem env_rel_append: + ∀xs ys xs1 ys1. + env_rel p xs1 ys1 ∧ env_rel p xs ys ∧ set (MAP FST xs) = set (MAP FST ys) ⇒ + env_rel p (xs ++ xs1) (ys ++ ys1) +Proof + rw [env_rel_def,ALOOKUP_APPEND] + \\ gvs [AllCaseEqs()] + \\ res_tac \\ fs [] + \\ first_x_assum $ irule_at $ Pos last + \\ gvs [ALOOKUP_NONE,EXTENSION] +QED + +Triviality LIST_REL_loc_rel_MAP_FST: + ∀xs ys. LIST_REL (loc_rel p tenv tfns) xs ys ⇒ MAP FST xs = MAP FST ys +Proof + Induct \\ Cases_on ‘ys’ \\ fs [] \\ Cases \\ Cases_on ‘h’ \\ fs [] + \\ rw [] \\ fs [] +QED + +Triviality ALOOUKP_MAP_Rec: + ∀tfns n. + ALOOKUP (MAP (λ(fn,x). (fn,Recclosure y tenv fn)) tfns) n = SOME tv ⇔ + MEM n (MAP FST tfns) ∧ tv = Recclosure y tenv n +Proof + Induct \\ fs [FORALL_PROD] \\ rw [] \\ eq_tac \\ rw [] +QED + +Triviality LIST_REL_letrec_rel_Lam: + ∀tfns sfns. + LIST_REL letrec_rel (MAP SND tfns) (MAP SND sfns) ∧ + MEM k (MAP FST (FILTER (λ(p1,p2). is_Lam p2) sfns)) ∧ + MAP FST tfns = MAP FST sfns ⇒ + ∃v' e'. MEM (k,Lam v' e') tfns +Proof + Induct \\ fs [PULL_EXISTS,FORALL_PROD] + \\ Cases_on ‘sfns’ \\ fs [] + \\ PairCases_on ‘h’ \\ fs [] + \\ simp [Once compile_rel_cases] + \\ gen_tac \\ strip_tac \\ gvs [dest_Lam_def] + >- (first_x_assum drule \\ fs []) + \\ metis_tac [] +QED + +Triviality LIST_REL_letrec_rel_Delay: + ∀tfns sfns. + LIST_REL letrec_rel (MAP SND tfns) (MAP SND sfns) ∧ + ~MEM k (MAP FST (FILTER (λ(p1,p2). is_Lam p2) sfns)) ∧ + MAP FST tfns = MAP FST sfns ∧ MEM k (MAP FST sfns) ⇒ + ∃e'. MEM (k,Delay e') tfns +Proof + Induct \\ fs [PULL_EXISTS,FORALL_PROD] + \\ Cases_on ‘sfns’ \\ fs [] + \\ PairCases_on ‘h’ \\ fs [] + \\ simp [Once compile_rel_cases] + \\ gen_tac \\ strip_tac \\ gvs [dest_Lam_def] + \\ metis_tac [] +QED + +Triviality ALL_DISTINCT_MAP_FILTER: + ∀xs. ALL_DISTINCT (MAP f xs) ⇒ ALL_DISTINCT (MAP f (FILTER p xs)) +Proof + Induct \\ fs [] \\ rw [] + \\ res_tac \\ fs [] + \\ gvs [MEM_MAP,MEM_FILTER] +QED + +Triviality LIST_REL_loc_rel_Delay: + ∀tfns locs. + LIST_REL (loc_rel p tenv xx) (FILTER (λ(p1,p2). is_Delay p2) tfns) locs ∧ + MEM (k,Delay e) tfns ⇒ + MEM k (MAP FST locs) +Proof + Induct \\ fs [FORALL_PROD] \\ rw [] + \\ TRY (PairCases_on ‘y’ \\ gvs []) + \\ fs [dest_Delay_def] +QED + +Theorem dest_anyClosure_v_rel: + dest_anyClosure v1 = SOME (x0,x1,x2) ∧ + v_rel p v1 v2 ∧ state_rel p (pick_opt zs ts) (SOME ss) ⇒ + ∃y1 y2. + dest_anyClosure v2 = SOME (x0,y1,y2) ∧ + compile_rel x2 y2 ∧ env_rel p x1 y1 +Proof + simp [Once v_rel_cases] \\ reverse (rw []) \\ gvs [] + >~ [‘Closure’] >- gvs [dest_anyClosure_def] + \\ gvs [dest_anyClosure_def,AllCaseEqs()] + >- + (drule_at (Pos last) LIST_REL_loc_rel_alt + \\ disch_then $ drule_at $ Pos last \\ fs []) + \\ drule_all ALOOKUP_LIST_REL + \\ strip_tac + \\ qpat_x_assum ‘letrec_rel _ _’ mp_tac + \\ simp [Once compile_rel_cases] \\ strip_tac \\ gvs [] + \\ last_x_assum $ irule_at Any + \\ irule_at Any IMP_ALOOKUP_FILTER + \\ fs [dest_Lam_def] + \\ irule env_rel_append \\ simp [] + \\ conj_tac + >- + (fs [MAP_MAP_o,combinTheory.o_DEF,LAMBDA_PROD,EXTENSION,MAP_REVERSE] + \\ fs [FST_INTRO] + \\ imp_res_tac (GSYM LIST_REL_loc_rel_MAP_FST) \\ fs [] + \\ qpat_x_assum ‘LIST_REL letrec_rel (MAP SND tfns) (MAP SND sfns)’ mp_tac + \\ qpat_x_assum ‘MAP FST tfns = MAP FST sfns’ mp_tac + \\ qid_spec_tac ‘sfns’ + \\ qid_spec_tac ‘tfns’ + \\ Induct \\ Cases_on ‘sfns’ \\ fs [FORALL_PROD] + \\ ntac 2 gen_tac \\ Cases \\ fs [] + \\ rename [‘_ = FST hh’] \\ PairCases_on ‘hh’ \\ fs [] + \\ simp [Once compile_rel_cases] \\ rw [] + \\ gvs [dest_Lam_def,dest_Delay_def] + \\ fs [AC DISJ_COMM DISJ_ASSOC]) + \\ fs [env_rel_def] + \\ gvs [ALOOUKP_MAP_Rec] + \\ simp [ALOOKUP_APPEND,AllCaseEqs()] + \\ gvs [ALOOUKP_MAP_Rec] + \\ simp [AllCaseEqs(),ALOOKUP_NONE] + \\ fs [MAP_MAP_o,combinTheory.o_DEF,LAMBDA_PROD,EXTENSION,MAP_REVERSE,FST_INTRO] + \\ rw [] + \\ rename [‘MEM k (MAP FST sfns)’] + \\ Cases_on ‘MEM k (MAP FST (FILTER (λ(p1,p2). is_Lam p2) sfns))’ \\ fs [] + >- + (simp [Once v_rel_cases] \\ disj1_tac + \\ simp [combinTheory.o_DEF,LAMBDA_PROD] + \\ ‘REVERSE locs ++ senv = REVERSE locs ++ senv’ by fs [] + \\ pop_assum $ irule_at Any \\ fs [] + \\ qpat_assum ‘LIST_REL letrec_rel _ _’ $ irule_at Any + \\ fs [env_rel_def] + \\ rpt $ first_assum $ irule_at Any + \\ irule LIST_REL_letrec_rel_Lam + \\ rpt $ first_assum $ irule_at Any) + \\ simp [Once v_rel_cases] + \\ irule_at Any (METIS_PROVE [] “c ⇒ b ∨ c”) + \\ simp [PULL_EXISTS] + \\ ‘env_rel p tenv senv’ by fs [env_rel_def] + \\ pop_assum $ irule_at Any + \\ rpt $ first_assum $ irule_at $ Pos hd + \\ fs [combinTheory.o_DEF,LAMBDA_PROD] + \\ rpt $ first_assum $ irule_at $ Pos hd + \\ drule_all LIST_REL_letrec_rel_Delay + \\ strip_tac + \\ ‘ALL_DISTINCT (MAP FST locs)’ by + (drule (GSYM LIST_REL_loc_rel_MAP_FST) + \\ fs [] \\ rw [] \\ irule ALL_DISTINCT_MAP_FILTER \\ fs []) + \\ gvs [alookup_distinct_reverse] + \\ Cases_on ‘ALOOKUP locs k’ \\ fs [] + \\ fs [ALOOKUP_NONE] + \\ drule_all LIST_REL_loc_rel_Delay + \\ fs [] +QED + +Theorem find_loc_lemma: + ∀p n1 loc. find_loc n1 p = SOME loc ⇒ ∀x. oEL loc p ≠ SOME (SOME x) +Proof + Induct >- gvs [oEL_THM] + \\ gvs [find_loc_def] + \\ Cases \\ gvs [] + \\ rw [] \\ gvs [oEL_def] + \\ Cases_on ‘n1’ \\ gvs [] + \\ res_tac \\ gvs [] +QED + Theorem application_thm: application op tvs ts tk = (t_0,t_1,t_2) ∧ application op svs (SOME ss) sk = (s_0,s_1,s_2) ∧ @@ -863,19 +1160,11 @@ Theorem application_thm: s_1 = SOME ss1 ∧ cont_rel (p++q) t_2 s_2 ∧ state_rel (p++q) (pick_opt zs t_1) (SOME ss1) ∧ - step_res_rel (p++q) t_0 s_0 + step_res_rel (p++q) t_0 s_0 ∧ + ∀thk loc. oEL loc p = SOME (SOME thk) ⇒ + oEL loc ss1 = oEL loc ss Proof Cases_on ‘t_0 = Error’ \\ asm_rewrite_tac [] - \\ Cases_on ‘op = Ref’ \\ rw [] THEN1 - (gvs [application_def,get_atoms_def] - \\ fs [value_def,error_def] - \\ Cases_on ‘ts’ \\ gvs [] - \\ qexists_tac ‘[NONE]’ - \\ once_rewrite_tac [step_res_rel_cases] \\ fs [] - \\ irule_at Any cont_rel_ext \\ simp [] - \\ irule_at Any v_rel_Ref \\ simp [GSYM SNOC_APPEND] - \\ simp [Once SNOC_APPEND] - \\ irule_at Any state_rel_Ref \\ simp []) \\ Cases_on ‘op = Alloc’ \\ rw [] THEN1 (gvs [application_def,LENGTH_EQ_NUM_compute,error_def,value_def] \\ ntac 4 $ pop_assum mp_tac \\ simp [Once v_rel_cases] @@ -885,8 +1174,52 @@ Proof \\ irule_at Any v_rel_Ref \\ simp [GSYM SNOC_APPEND] \\ simp [Once SNOC_APPEND] \\ irule_at Any state_rel_Ref \\ simp [] - \\ fs [LIST_REL_REPLICATE_same]) + \\ fs [LIST_REL_REPLICATE_same] + \\ rpt strip_tac + \\ gvs [oEL_THM,state_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ gvs [SNOC_APPEND,EL_APPEND1]) + \\ Cases_on ‘∃t. op = AllocMutThunk t’ \\ rw [] THEN1 + (gvs [application_def,LENGTH_EQ_NUM_compute,error_def,value_def] + \\ gvs [AllCaseEqs(),step_res_rel_cases] + \\ irule_at Any cont_rel_ext \\ simp [] + \\ irule_at Any v_rel_Ref_Thunk \\ simp [] + \\ gvs [state_rel_def] + \\ imp_res_tac LIST_REL_LENGTH + \\ gvs [GSYM ZIP_APPEND,FILTER_APPEND,SNOC_APPEND] + \\ gvs [LIST_REL_EL_EQN] \\ rw [] + \\ TRY (irule_at Any thunk_rel_ext \\ gvs [thunk_rel_def]) + \\ TRY (irule_at Any store_rel_ext \\ gvs [store_rel_def]) + \\ gvs [oEL_THM,state_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ gvs [SNOC_APPEND,EL_APPEND1]) \\ qexists_tac ‘[]’ \\ fs [] + \\ Cases_on ‘op = ForceMutThunk’ \\ rw [] THEN1 + (gvs [application_def,LENGTH_EQ_NUM_compute,error_def,value_def] + \\ Cases_on ‘x’ \\ gvs [] + \\ Cases_on ‘ts’ \\ gvs [] + \\ qpat_x_assum ‘v_rel _ (ThunkLoc _) _’ mp_tac + \\ once_rewrite_tac [v_rel_cases] \\ simp [] + \\ rpt strip_tac \\ gvs [] + \\ Cases_on ‘oEL n x’ \\ fs [continue_def] + \\ Cases_on ‘x'’ \\ gvs [] + \\ drule_all state_rel_thunk \\ strip_tac \\ gvs [] + \\ Cases_on ‘t’ \\ gvs [] + \\ simp [Once step_res_rel_cases] + \\ ntac 2 $ simp[Once cont_rel_cases] + \\ simp[env_rel_def, Once v_rel_cases]) + \\ Cases_on ‘∃t. op = UpdateMutThunk t’ \\ rw [] THEN1 + (gvs [application_def,LENGTH_EQ_NUM_compute,error_def,value_def] + \\ Cases_on ‘x’ \\ gvs [] + \\ Cases_on ‘ts’ \\ gvs [] + \\ qpat_x_assum ‘v_rel _ (ThunkLoc _) _’ mp_tac + \\ once_rewrite_tac [v_rel_cases] \\ simp [] + \\ rpt strip_tac \\ gvs [] + \\ Cases_on ‘oEL n x’ \\ fs [continue_def] + \\ Cases_on ‘x''’ \\ gvs [] + \\ Cases_on ‘t'’ \\ gvs [] + \\ drule_all state_rel_thunk \\ strip_tac \\ gvs [] + \\ simp [Once step_res_rel_cases, Once v_rel_cases] + \\ gvs [oEL_LUPDATE] \\ rw [] \\ gvs [oEL_THM] + \\ imp_res_tac find_loc_lemma \\ gvs [oEL_THM]) \\ Cases_on ‘∃k. op = Cons k’ \\ rw [] THEN1 (gvs [application_def,get_atoms_def,value_def,error_def] \\ once_rewrite_tac [step_res_rel_cases] \\ fs [] @@ -896,8 +1229,7 @@ Proof \\ ntac 4 $ pop_assum mp_tac \\ simp [Once v_rel_cases] \\ gvs [AllCaseEqs()] \\ rpt strip_tac \\ once_rewrite_tac [step_res_rel_cases] \\ fs [] \\ gvs[]) - \\ Cases_on ‘op = Sub ∨ op = UnsafeSub ∨ op = Length ∨ - op = Update ∨ op = UnsafeUpdate’ THEN1 + \\ Cases_on ‘op = Sub ∨ op = Length ∨ op = Update’ THEN1 (gvs [application_def,LENGTH_EQ_NUM_compute,error_def,value_def] \\ Cases_on ‘x’ \\ gvs [] \\ Cases_on ‘l’ \\ gvs [] @@ -908,12 +1240,15 @@ Proof \\ once_rewrite_tac [v_rel_cases] \\ simp [] \\ rpt strip_tac \\ gvs [] \\ Cases_on ‘oEL n x’ \\ fs [continue_def] + \\ Cases_on ‘x'’ \\ gvs [] \\ drule_all state_rel_array \\ strip_tac \\ gvs [] \\ imp_res_tac LIST_REL_LENGTH \\ gvs [] - \\ gvs [AllCaseEqs(),step_res_rel_cases,LIST_REL_EL_EQN] + \\ gvs [AllCaseEqs(),step_res_rel_cases,LIST_REL_EL_EQN,store_rel_def] \\ imp_res_tac integerTheory.NUM_POSINT_EXISTS \\ gvs [] \\ simp [Once v_rel_cases] - \\ ntac 3 (simp [Once compile_rel_cases])) + \\ ntac 3 (simp [Once compile_rel_cases]) + \\ rw [oEL_LUPDATE] \\ gvs [oEL_THM] + \\ imp_res_tac find_loc_lemma \\ gvs [oEL_THM]) \\ Cases_on ‘∃s n. op = IsEq s n’ \\ rw [] THEN1 (gvs [application_def,LENGTH_EQ_NUM_compute,error_def,value_def] \\ ntac 4 $ pop_assum mp_tac \\ simp [Once v_rel_cases] @@ -944,26 +1279,27 @@ QED Definition make_let_env_def: make_let_env [] n env = env ∧ - make_let_env (x::xs) n env = make_let_env xs (n+1) ((FST x,Atom (Loc n))::env) + make_let_env (x::xs) n env = make_let_env xs (n+1) ((FST x,ThunkLoc n)::env) End -Theorem step_n_Lets_some_ref_bool: +Theorem step_n_Lets_some_alloc_thunk: ∀delays env n ss. - step_n n (Exp env (Lets (MAP some_ref_bool delays) x),SOME ss,sk) = (sr1,ss1,sk1) ∧ + step_n n (Exp env (Lets (MAP some_alloc_thunk delays) x),SOME ss,sk) = + (sr1,ss1,sk1) ∧ is_halt (sr1,ss1,sk1) ⇒ ∃m. m ≤ n ∧ step_n m (Exp (make_let_env delays (LENGTH ss) env) x, - SOME (ss ++ MAP (λ(v,b,y). [Bool_v b; Bool_v b]) delays),sk) = - (sr1,ss1,sk1) + SOME (ss ++ MAP (λ(v,b,y). + ThunkMem NotEvaluated (Atom (Int 0))) delays), + sk) = (sr1,ss1,sk1) Proof Induct \\ fs [Lets_def,make_let_env_def] \\ rw [] >- (first_x_assum $ irule_at Any \\ fs []) - \\ PairCases_on ‘h’ \\ gvs [some_ref_bool_def,Lets_def] + \\ PairCases_on ‘h’ \\ gvs [some_alloc_thunk_def,Lets_def] \\ qpat_x_assum ‘step_n _ _ = _’ mp_tac - \\ Cases_on ‘h1’ \\ fs [] - \\ ntac 7 (rename [‘step_n nn’] \\ Cases_on ‘nn’ \\ fs [] + \\ ntac 5 (rename [‘step_n nn’] \\ Cases_on ‘nn’ \\ fs [] >- (rw [] \\ fs [is_halt_def]) - \\ rewrite_tac [step_n_add,ADD1] \\ simp [step]) + \\ rewrite_tac [step_n_add,ADD1] \\ simp [step,get_atoms_def]) \\ strip_tac \\ last_x_assum drule \\ strip_tac \\ qexists_tac ‘m’ \\ fs [] \\ gvs [SNOC_APPEND,ADD1] @@ -1008,11 +1344,11 @@ QED Definition Letrec_store_def: Letrec_store env (v,b,y) = - if ~b then [False_v; Closure NONE env y] else + if ~b then ThunkMem NotEvaluated (Closure NONE env y) else case y of - | Var w => [True_v; THE (ALOOKUP env w)] - | Lam w e => [True_v; Closure w env e] - | _ => [False_v; Closure NONE env y] + | Var w => ThunkMem Evaluated (THE (ALOOKUP env w)) + | Lam w e => ThunkMem Evaluated (Closure w env e) + | _ => ThunkMem NotEvaluated (Closure NONE env y) End Theorem Letrec_store_thm: @@ -1024,9 +1360,10 @@ Theorem Letrec_store_thm: EVERY (λn. ALOOKUP (env1 ++ make_let_env delays (LENGTH ss) env2) n ≠ NONE) (MAP FST sfns) ∧ step_n n (Exp (env1 ++ make_let_env delays (LENGTH ss) env2) - (Lets (MAP unsafe_update delays) se), - SOME (ss ++ MAP (λ(v,b,y). [Bool_v b; Bool_v b]) delays),sk) = - (sr1,ss1,sk1) ⇒ + (Lets (MAP update_delay delays) se), + SOME (ss ++ MAP (λ(v,b,y). + ThunkMem NotEvaluated (Atom (Int 0))) delays), + sk) = (sr1,ss1,sk1) ⇒ ∃k. k ≤ n ∧ let env3 = env1 ++ make_let_env delays (LENGTH ss) env2 in step_n k (Exp env3 se, SOME (ss ++ MAP (Letrec_store env3) delays),sk) = @@ -1035,15 +1372,15 @@ Proof Induct \\ fs [Lets_def] >- (rw [] \\ qexists_tac ‘n’ \\ fs []) \\ gen_tac \\ PairCases_on ‘h’ \\ fs [] - \\ gvs [unsafe_update_def,Lets_def,make_let_env_def] + \\ gvs [update_delay_def,Lets_def,make_let_env_def] \\ rpt gen_tac \\ strip_tac \\ pop_assum mp_tac - \\ ntac 2 (rename [‘step_n nn’] \\ Cases_on ‘nn’ + \\ ntac 1 (rename [‘step_n nn’] \\ Cases_on ‘nn’ >- (rw [] \\ fs [is_halt_def]) \\ fs [] \\ rewrite_tac [step_n_add,ADD1] \\ simp [step,get_atoms_def]) \\ reverse IF_CASES_TAC >- - (ntac 5 (rename [‘step_n nn’] \\ Cases_on ‘nn’ + (ntac 4 (rename [‘step_n nn’] \\ Cases_on ‘nn’ >- (rw [] \\ fs [is_halt_def]) \\ fs [] \\ rewrite_tac [step_n_add,ADD1] \\ simp [step,get_atoms_def]) \\ fs [ALOOKUP_APPEND,GSYM ALOOKUP_NONE,ALOOKUP_make_let_env] @@ -1063,7 +1400,7 @@ Proof \\ strip_tac \\ qexists_tac ‘k’ \\ fs [Letrec_store_def]) \\ Cases_on ‘∃v3 e3. h2 = Lam v3 e3’ \\ gvs [] >- - (ntac 5 (rename [‘step_n nn’] \\ Cases_on ‘nn’ + (ntac 4 (rename [‘step_n nn’] \\ Cases_on ‘nn’ >- (rw [] \\ fs [is_halt_def]) \\ fs [] \\ rewrite_tac [step_n_add,ADD1] \\ simp [step,get_atoms_def]) \\ fs [ALOOKUP_APPEND,GSYM ALOOKUP_NONE,ALOOKUP_make_let_env] @@ -1082,13 +1419,12 @@ Proof \\ impl_tac >- fs [] \\ strip_tac \\ qexists_tac ‘k’ \\ fs [Letrec_store_def]) \\ Cases_on ‘h2’ \\ gvs [Letrec_imm_def] - \\ rename [‘Var vv’] \\ qpat_assum ‘EVERY _ _’ (fn th => drule (REWRITE_RULE [EVERY_MEM] th)) \\ simp [] \\ Cases_on ‘ALOOKUP (env1 ++ make_let_env delays (LENGTH ss + 1) - ((h0,Atom (Loc (LENGTH ss)))::env2)) vv’ \\ fs [] - \\ ntac 5 (rename [‘step_n nn’] \\ Cases_on ‘nn’ + ((h0,ThunkLoc (LENGTH ss))::env2)) s’ \\ fs [] + \\ ntac 4 (rename [‘step_n nn’] \\ Cases_on ‘nn’ >- (rw [] \\ fs [is_halt_def]) \\ fs [] \\ rewrite_tac [step_n_add,ADD1] \\ simp [step,get_atoms_def]) \\ fs [ALOOKUP_APPEND,GSYM ALOOKUP_NONE,ALOOKUP_make_let_env] @@ -1125,15 +1461,16 @@ Theorem Letrec_store_forward: (MAP FST sfns) ∧ (let env3 = env1 ++ make_let_env delays (LENGTH ss) env2 in step_n k (Exp env3 se, SOME (ss ++ MAP (Letrec_store env3) delays),sk) = - (sr1,ss1,sk1)) ∧ n = k + 9 * LENGTH delays ⇒ + (sr1,ss1,sk1)) ∧ n = k + 7 * LENGTH delays ⇒ step_n n (Exp (env1 ++ make_let_env delays (LENGTH ss) env2) - (Lets (MAP unsafe_update delays) se), - SOME (ss ++ MAP (λ(v,b,y). [Bool_v b; Bool_v b]) delays),sk) = - (sr1,ss1,sk1) + (Lets (MAP update_delay delays) se), + SOME (ss ++ MAP (λ(v,b,y). + ThunkMem NotEvaluated (Atom (Int 0))) delays), + sk) = (sr1,ss1,sk1) Proof Induct \\ fs [Lets_def] \\ gen_tac \\ PairCases_on ‘h’ \\ fs [] - \\ gvs [unsafe_update_def,Lets_def,make_let_env_def] + \\ gvs [update_delay_def,Lets_def,make_let_env_def] \\ rpt gen_tac \\ strip_tac \\ irule_at Any step_n_unwind \\ once_rewrite_tac [step_n_add] \\ fs [step] @@ -1141,7 +1478,7 @@ Proof \\ once_rewrite_tac [step_n_add] \\ fs [step] \\ reverse IF_CASES_TAC >- ( - ntac 5 (irule_at Any step_n_unwind + ntac 3 (irule_at Any step_n_unwind \\ once_rewrite_tac [step_n_add] \\ fs [step, get_atoms_def]) \\ fs [ALOOKUP_APPEND,GSYM ALOOKUP_NONE,ALOOKUP_make_let_env] \\ ntac 1 (irule_at Any step_n_unwind @@ -1154,12 +1491,12 @@ Proof \\ last_x_assum $ qspec_then ‘ss ++ [s1]’ mp_tac \\ gvs [] \\ simp_tac std_ss [GSYM APPEND_ASSOC,APPEND] \\ simp [LEFT_ADD_DISTRIB] \\ simp_tac std_ss [ADD_ASSOC] - \\ disch_then $ qspecl_then [‘(h0,Atom (Loc (LENGTH ss)))::env2’,‘k’] mp_tac + \\ disch_then $ qspecl_then [‘(h0,ThunkLoc (LENGTH ss))::env2’,‘k’] mp_tac \\ impl_tac >- fs [Letrec_store_def] \\ strip_tac \\ fs []) \\ Cases_on ‘∃v3 e3. h2 = Lam v3 e3’ \\ gvs [] >- ( - ntac 5 (irule_at Any step_n_unwind + ntac 3 (irule_at Any step_n_unwind \\ once_rewrite_tac [step_n_add] \\ fs [step, get_atoms_def]) \\ fs [ALOOKUP_APPEND,GSYM ALOOKUP_NONE,ALOOKUP_make_let_env] \\ ntac 1 (irule_at Any step_n_unwind @@ -1172,17 +1509,16 @@ Proof \\ last_x_assum $ qspec_then ‘ss ++ [s1]’ mp_tac \\ gvs [] \\ simp_tac std_ss [GSYM APPEND_ASSOC,APPEND] \\ simp [LEFT_ADD_DISTRIB] \\ simp_tac std_ss [ADD_ASSOC] - \\ disch_then $ qspecl_then [‘(h0,Atom (Loc (LENGTH ss)))::env2’,‘k’] mp_tac + \\ disch_then $ qspecl_then [‘(h0,ThunkLoc (LENGTH ss))::env2’,‘k’] mp_tac \\ impl_tac >- fs [Letrec_store_def] \\ strip_tac \\ fs []) \\ Cases_on ‘h2’ \\ gvs [Letrec_imm_def] - \\ rename [‘Var vv’] \\ qpat_assum ‘EVERY _ _’ (fn th => drule (REWRITE_RULE [EVERY_MEM] th)) \\ simp [] \\ Cases_on ‘ALOOKUP (env1 ++ make_let_env delays (LENGTH ss + 1) - ((h0,Atom (Loc (LENGTH ss)))::env2)) vv’ \\ fs [] - \\ ntac 5 (irule_at Any step_n_unwind + ((h0,ThunkLoc (LENGTH ss))::env2)) s’ \\ fs [] + \\ ntac 3 (irule_at Any step_n_unwind \\ once_rewrite_tac [step_n_add] \\ fs [step, get_atoms_def]) \\ fs [ALOOKUP_APPEND,GSYM ALOOKUP_NONE,ALOOKUP_make_let_env] \\ ntac 1 (irule_at Any step_n_unwind @@ -1195,7 +1531,7 @@ Proof \\ last_x_assum $ qspec_then ‘ss ++ [s1]’ mp_tac \\ gvs [] \\ simp_tac std_ss [GSYM APPEND_ASSOC,APPEND] \\ simp [LEFT_ADD_DISTRIB] \\ simp_tac std_ss [ADD_ASSOC] - \\ disch_then $ qspecl_then [‘(h0,Atom (Loc (LENGTH ss)))::env2’,‘k’] mp_tac + \\ disch_then $ qspecl_then [‘(h0,ThunkLoc (LENGTH ss))::env2’,‘k’] mp_tac \\ disch_then irule \\ gvs [Letrec_store_def,ALOOKUP_APPEND] QED @@ -1221,158 +1557,6 @@ Proof fs [FUN_EQ_THM,FORALL_PROD] QED -Theorem env_rel_append: - ∀xs ys xs1 ys1. - env_rel p xs1 ys1 ∧ env_rel p xs ys ∧ set (MAP FST xs) = set (MAP FST ys) ⇒ - env_rel p (xs ++ xs1) (ys ++ ys1) -Proof - rw [env_rel_def,ALOOKUP_APPEND] - \\ gvs [AllCaseEqs()] - \\ res_tac \\ fs [] - \\ first_x_assum $ irule_at $ Pos last - \\ gvs [ALOOKUP_NONE,EXTENSION] -QED - -Triviality LIST_REL_loc_rel_MAP_FST: - ∀xs ys. LIST_REL (loc_rel p tenv tfns) xs ys ⇒ MAP FST xs = MAP FST ys -Proof - Induct \\ Cases_on ‘ys’ \\ fs [] \\ Cases \\ Cases_on ‘h’ \\ fs [] - \\ rw [] \\ fs [] -QED - -Triviality ALOOUKP_MAP_Rec: - ∀tfns n. - ALOOKUP (MAP (λ(fn,x). (fn,Recclosure y tenv fn)) tfns) n = SOME tv ⇔ - MEM n (MAP FST tfns) ∧ tv = Recclosure y tenv n -Proof - Induct \\ fs [FORALL_PROD] \\ rw [] \\ eq_tac \\ rw [] -QED - -Triviality LIST_REL_letrec_rel_Lam: - ∀tfns sfns. - LIST_REL letrec_rel (MAP SND tfns) (MAP SND sfns) ∧ - MEM k (MAP FST (FILTER (λ(p1,p2). is_Lam p2) sfns)) ∧ - MAP FST tfns = MAP FST sfns ⇒ - ∃v' e'. MEM (k,Lam v' e') tfns -Proof - Induct \\ fs [PULL_EXISTS,FORALL_PROD] - \\ Cases_on ‘sfns’ \\ fs [] - \\ PairCases_on ‘h’ \\ fs [] - \\ simp [Once compile_rel_cases] - \\ gen_tac \\ strip_tac \\ gvs [dest_Lam_def] - >- (first_x_assum drule \\ fs []) - \\ metis_tac [] -QED - -Triviality LIST_REL_letrec_rel_Delay: - ∀tfns sfns. - LIST_REL letrec_rel (MAP SND tfns) (MAP SND sfns) ∧ - ~MEM k (MAP FST (FILTER (λ(p1,p2). is_Lam p2) sfns)) ∧ - MAP FST tfns = MAP FST sfns ∧ MEM k (MAP FST sfns) ⇒ - ∃e'. MEM (k,Delay e') tfns -Proof - Induct \\ fs [PULL_EXISTS,FORALL_PROD] - \\ Cases_on ‘sfns’ \\ fs [] - \\ PairCases_on ‘h’ \\ fs [] - \\ simp [Once compile_rel_cases] - \\ gen_tac \\ strip_tac \\ gvs [dest_Lam_def] - \\ metis_tac [] -QED - -Triviality ALL_DISTINCT_MAP_FILTER: - ∀xs. ALL_DISTINCT (MAP f xs) ⇒ ALL_DISTINCT (MAP f (FILTER p xs)) -Proof - Induct \\ fs [] \\ rw [] - \\ res_tac \\ fs [] - \\ gvs [MEM_MAP,MEM_FILTER] -QED - -Triviality LIST_REL_loc_rel_Delay: - ∀tfns locs. - LIST_REL (loc_rel p tenv xx) (FILTER (λ(p1,p2). is_Delay p2) tfns) locs ∧ - MEM (k,Delay e) tfns ⇒ - MEM k (MAP FST locs) -Proof - Induct \\ fs [FORALL_PROD] \\ rw [] - \\ TRY (PairCases_on ‘y’ \\ gvs []) - \\ fs [dest_Delay_def] -QED - -Theorem dest_anyClosure_v_rel: - dest_anyClosure v1 = SOME (x0,x1,x2) ∧ - v_rel p v1 v2 ∧ state_rel p (pick_opt zs ts) (SOME ss) ⇒ - ∃y1 y2. - dest_anyClosure v2 = SOME (x0,y1,y2) ∧ - compile_rel x2 y2 ∧ env_rel p x1 y1 -Proof - simp [Once v_rel_cases] \\ reverse (rw []) \\ gvs [] - >~ [‘Closure’] >- gvs [dest_anyClosure_def] - \\ gvs [dest_anyClosure_def,AllCaseEqs()] - >- - (drule_at (Pos last) LIST_REL_loc_rel_alt - \\ disch_then $ drule_at $ Pos last \\ fs []) - \\ drule_all ALOOKUP_LIST_REL - \\ strip_tac - \\ qpat_x_assum ‘letrec_rel _ _’ mp_tac - \\ simp [Once compile_rel_cases] \\ strip_tac \\ gvs [] - \\ last_x_assum $ irule_at Any - \\ irule_at Any IMP_ALOOKUP_FILTER - \\ fs [dest_Lam_def] - \\ irule env_rel_append \\ simp [] - \\ conj_tac - >- - (fs [MAP_MAP_o,combinTheory.o_DEF,LAMBDA_PROD,EXTENSION,MAP_REVERSE] - \\ fs [FST_INTRO] - \\ imp_res_tac (GSYM LIST_REL_loc_rel_MAP_FST) \\ fs [] - \\ qpat_x_assum ‘LIST_REL letrec_rel (MAP SND tfns) (MAP SND sfns)’ mp_tac - \\ qpat_x_assum ‘MAP FST tfns = MAP FST sfns’ mp_tac - \\ qid_spec_tac ‘sfns’ - \\ qid_spec_tac ‘tfns’ - \\ Induct \\ Cases_on ‘sfns’ \\ fs [FORALL_PROD] - \\ ntac 2 gen_tac \\ Cases \\ fs [] - \\ rename [‘_ = FST hh’] \\ PairCases_on ‘hh’ \\ fs [] - \\ simp [Once compile_rel_cases] \\ rw [] - \\ gvs [dest_Lam_def,dest_Delay_def] - \\ fs [AC DISJ_COMM DISJ_ASSOC]) - \\ fs [env_rel_def] - \\ gvs [ALOOUKP_MAP_Rec] - \\ simp [ALOOKUP_APPEND,AllCaseEqs()] - \\ gvs [ALOOUKP_MAP_Rec] - \\ simp [AllCaseEqs(),ALOOKUP_NONE] - \\ fs [MAP_MAP_o,combinTheory.o_DEF,LAMBDA_PROD,EXTENSION,MAP_REVERSE,FST_INTRO] - \\ rw [] - \\ rename [‘MEM k (MAP FST sfns)’] - \\ Cases_on ‘MEM k (MAP FST (FILTER (λ(p1,p2). is_Lam p2) sfns))’ \\ fs [] - >- - (simp [Once v_rel_cases] \\ disj1_tac - \\ simp [combinTheory.o_DEF,LAMBDA_PROD] - \\ ‘REVERSE locs ++ senv = REVERSE locs ++ senv’ by fs [] - \\ pop_assum $ irule_at Any \\ fs [] - \\ qpat_assum ‘LIST_REL letrec_rel _ _’ $ irule_at Any - \\ fs [env_rel_def] - \\ rpt $ first_assum $ irule_at Any - \\ irule LIST_REL_letrec_rel_Lam - \\ rpt $ first_assum $ irule_at Any) - \\ simp [Once v_rel_cases] - \\ irule_at Any (METIS_PROVE [] “c ⇒ b ∨ c”) - \\ simp [PULL_EXISTS] - \\ ‘env_rel p tenv senv’ by fs [env_rel_def] - \\ pop_assum $ irule_at Any - \\ rpt $ first_assum $ irule_at $ Pos hd - \\ fs [combinTheory.o_DEF,LAMBDA_PROD] - \\ rpt $ first_assum $ irule_at $ Pos hd - \\ drule_all LIST_REL_letrec_rel_Delay - \\ strip_tac - \\ ‘ALL_DISTINCT (MAP FST locs)’ by - (drule (GSYM LIST_REL_loc_rel_MAP_FST) - \\ fs [] \\ rw [] \\ irule ALL_DISTINCT_MAP_FILTER \\ fs []) - \\ gvs [alookup_distinct_reverse] - \\ Cases_on ‘ALOOKUP locs k’ \\ fs [] - \\ fs [ALOOKUP_NONE] - \\ drule_all LIST_REL_loc_rel_Delay - \\ fs [] -QED - Triviality LIST_REL_LIST_REL_lemma: (∀x y. r1 x y ⇒ r2 x y) ∧ ys1 = ys2 ⇒ LIST_REL r1 xs ys1 ⇒ LIST_REL r2 xs ys2 @@ -1425,7 +1609,7 @@ Proof \\ pairarg_tac \\ fs [] \\ Cases_on ‘delays’ \\ fs [Lets_def] \\ PairCases_on ‘h’ - \\ fs [some_ref_bool_def,Lets_def] + \\ fs [some_alloc_thunk_def,Lets_def] QED Theorem make_let_env_lemma: @@ -1474,7 +1658,7 @@ QED Theorem REVERSE_make_let_env: ∀delays n. REVERSE (make_let_env delays n []) = - MAPi (λi x. (FST x, Atom (Loc (n+i)))) delays + MAPi (λi x. (FST x,ThunkLoc (n+i))) delays Proof Induct \\ fs [make_let_env_def,FORALL_PROD] \\ simp [Once make_let_env_lemma] @@ -1523,8 +1707,8 @@ Theorem Letrec_split_FILTER: Letrec_split vs sfns = (delays,funs) ∧ MAP FST tfns = MAP FST sfns ∧ LIST_REL letrec_rel (MAP SND tfns) (MAP SND sfns) ⇒ - MAPi (λi x. (FST x,Atom (Loc (f i)))) delays = - MAPi (λi x. (FST x,Atom (Loc (f i)))) (FILTER (λ(p1,p2). is_Delay p2) tfns) + MAPi (λi x. (FST x,ThunkLoc (f i))) delays = + MAPi (λi x. (FST x,ThunkLoc (f i))) (FILTER (λ(p1,p2). is_Delay p2) tfns) Proof Induct \\ Cases_on ‘tfns’ \\ fs [Letrec_split_def] \\ Cases \\ PairCases_on ‘h’ \\ fs [Letrec_split_def] @@ -1548,20 +1732,21 @@ Theorem state_rel_Letrec: ALL_DISTINCT (MAP FST funs) ∧ DISJOINT (set (MAP FST delays)) (set (MAP FST funs)) ⇒ state_rel - (p ++ MAP (λ(fn,_). dest_anyThunk (Recclosure tfns env1 fn)) + (p ++ MAP (λ(fn,_). SOME (Recclosure tfns env1 fn)) (FILTER ((λx. is_Delay x) ∘ SND) tfns)) (pick_opt zs ts) (SOME (ss ++ MAP - (Letrec_store (rec_env funs (make_let_env delays (LENGTH ss) env2))) - delays)) ∧ - env_rel (p ++ MAP (λ(fn,_). dest_anyThunk (Recclosure tfns env1 fn)) - (FILTER ((λx. is_Delay x) ∘ SND) tfns)) (rec_env tfns env1) - (rec_env funs (make_let_env delays (LENGTH ss) env2)) + (Letrec_store ( + mk_rec_env funs (make_let_env delays (LENGTH ss) env2))) + delays)) ∧ + env_rel (p ++ MAP (λ(fn,_). SOME (Recclosure tfns env1 fn)) + (FILTER ((λx. is_Delay x) ∘ SND) tfns)) (mk_rec_env tfns env1) + (mk_rec_env funs (make_let_env delays (LENGTH ss) env2)) Proof fs [state_rel_def] \\ strip_tac \\ reverse conj_asm2_tac >- - (fs [rec_env_def] + (fs [] \\ once_rewrite_tac [make_let_env_lemma] \\ simp [] \\ irule env_rel_append \\ irule_at (Pos last) env_rel_ext \\ fs [] @@ -1575,10 +1760,10 @@ Proof \\ ‘LIST_REL (loc_rel (p ++ - MAP (λ(fn,_). dest_anyThunk (Recclosure tfns env1 fn)) + MAP (λ(fn,_). SOME (Recclosure tfns env1 fn)) (FILTER (λ(p1,p2). is_Delay p2) tfns)) env1 tfns) (FILTER ((λx. is_Delay x) ∘ SND) tfns) - (MAPi (λi x. (FST x,Atom (Loc (i + LENGTH ss)))) delays)’ by + (MAPi (λi x. (FST x,(ThunkLoc (i + LENGTH ss)))) delays)’ by (drule_all Letrec_split_FILTER \\ disch_then $ simp o single \\ simp [LIST_REL_EL_EQN,combinTheory.o_DEF,LAMBDA_PROD] @@ -1621,13 +1806,18 @@ Proof \\ fs [EXTENSION] \\ metis_tac []) \\ fs [] \\ rpt conj_tac - >~ [‘LIST_REL (LIST_REL _) _ (MAP SND (FILTER _ (ZIP (_ ++ _,_))))’] + >~ [‘LIST_REL (store_rel _) _ (MAP SND (FILTER _ (ZIP (_ ++ _,_))))’] >- - (qpat_x_assum ‘LIST_REL (LIST_REL _) _ _’ mp_tac + (qpat_x_assum ‘LIST_REL (store_rel _) _ _’ mp_tac \\ match_mp_tac LIST_REL_LIST_REL_lemma \\ conj_tac >- - (rpt gen_tac \\ match_mp_tac LIST_REL_mono - \\ rw [] \\ irule_at Any v_rel_ext \\ fs []) + (rpt gen_tac + \\ Cases_on ‘x’ \\ Cases_on ‘y’ \\ simp [store_rel_def] + >- + (match_mp_tac LIST_REL_mono \\ rw [] + \\ irule_at Any v_rel_ext \\ fs []) + >- + (rw [] \\ irule_at Any v_rel_ext \\ fs [])) \\ AP_TERM_TAC \\ ‘LENGTH p = LENGTH ss’ by (imp_res_tac LIST_REL_LENGTH) \\ irule FILTER_ZIP_EQ \\ simp [] @@ -1654,7 +1844,7 @@ Proof \\ fs [] \\ rw [] \\ gvs [dest_Delay_def] \\ rename [‘compile_rel e1 e2’] \\ simp [dest_anyThunk_def] - \\ simp [thunk_rel_def] + \\ simp [thunk_rel_def,dest_anyThunk_def] \\ reverse (Cases_on ‘Letrec_imm (MAP FST sfns) e2’) \\ gvs [] >- fs [Letrec_store_def] \\ Cases_on ‘∃x1 x2. e2 = Lam x1 x2’ @@ -1676,41 +1866,136 @@ Proof \\ CASE_TAC >- (qpat_x_assum ‘MAP FST tfns = MAP FST sfns’ (assume_tac o GSYM) \\ gvs [] - \\ gvs [ALOOKUP_NONE,rec_env_def,MEM_MAP,FORALL_PROD] + \\ gvs [ALOOKUP_NONE,MEM_MAP,FORALL_PROD] \\ PairCases_on ‘y’ \\ fs []) \\ fs [env_rel_def] \\ first_x_assum drule \\ strip_tac \\ fs [] QED -Theorem step_Bool: - step ss k (Exp env (Bool b)) = (Val (Bool_v b),ss,k) -Proof - Cases_on ‘b’ \\ fs [step] -QED - Theorem step_n_make_let_env: ∀delays ss m n env x sk. step_n m (Exp (make_let_env delays (LENGTH ss) env) x, - SOME (ss ++ MAP (λ(v,b,y). [Bool_v b; Bool_v b]) delays),sk) = (sr1,ss1,sk1) ∧ - n = m + 7 * LENGTH delays ⇒ - step_n n (Exp env (Lets (MAP some_ref_bool delays) x),SOME ss,sk) = (sr1,ss1,sk1) + SOME (ss ++ MAP (λ(v,b,y). + ThunkMem NotEvaluated (Atom (Int 0))) delays), + sk) = (sr1,ss1,sk1) ∧ + n = m + 5 * LENGTH delays ⇒ + step_n n (Exp env (Lets (MAP some_alloc_thunk delays) x), + SOME ss, + sk) = (sr1,ss1,sk1) Proof Induct \\ fs [make_let_env_def,Lets_def] \\ rw [] \\ fs [ADD1,LEFT_ADD_DISTRIB] - \\ rewrite_tac [ADD_ASSOC,GSYM (EVAL “1+1+1+1+1+1+1:num”)] - \\ ntac 7 (once_rewrite_tac [step_n_add]) + \\ rewrite_tac [ADD_ASSOC,GSYM (EVAL “1+1+1+1+1:num”)] + \\ ntac 5 (once_rewrite_tac [step_n_add]) \\ PairCases_on ‘h’ - \\ fs [some_ref_bool_def,Lets_def,step,step_Bool] + \\ fs [some_alloc_thunk_def,Lets_def,step,get_atoms_def] \\ last_x_assum irule \\ fs [SNOC_APPEND,ADD1] \\ simp_tac std_ss [GSYM APPEND_ASSOC,APPEND] \\ fs [] QED +Theorem find_loc_length_thm: + ∀p n1 n2 (ss:state). + find_loc n1 p = SOME n2 ∧ + LENGTH p = LENGTH ss ⇒ + n2 < LENGTH p ∧ + n1 < LENGTH (FILTER (λx. FST x = NONE) (ZIP (p,ss))) +Proof + Induct \\ gvs [find_loc_def] + \\ Cases \\ gvs [find_loc_def] + \\ rw [] \\ res_tac \\ simp [] + \\ Cases_on ‘ss’ \\ gvs [] + \\ rpt (first_x_assum $ qspec_then ‘t’ assume_tac \\ gvs []) +QED + +Theorem find_loc_el_thm: + ∀p n1 n2 (ss:state). + find_loc n1 p = SOME n2 ∧ + LENGTH p = LENGTH ss ⇒ + EL n2 ss = EL n1 (MAP SND (FILTER (λx. FST x = NONE) (ZIP (p,ss)))) +Proof + Induct \\ gvs [find_loc_def] + \\ Cases \\ gvs [find_loc_def] + \\ rw [] \\ res_tac \\ simp [] + \\ Cases_on ‘ss’ \\ gvs [ZIP_def,EL_CONS,PRE_SUB1] +QED + +Theorem state_rel_LUPDATE_anyThunk': + v_rel p res v2 ∧ state_rel p ts (SOME ss2) ∧ + v_rel p v1 (ThunkLoc loc) ∧ + dest_anyThunk v1 = SOME (INR (tenv1,te),f) ∧ + step'_n n avoid (Exp (mk_rec_env f tenv1) te,NONE,[]) = (Val res,NONE,[]) ⇒ + state_rel p ts (SOME (LUPDATE (ThunkMem Evaluated v2) loc ss2)) +Proof + rw [] \\ drule step'_n_IMP_step_n \\ strip_tac \\ gvs [] + \\ drule_all (state_rel_LUPDATE_anyThunk |> REWRITE_RULE [mk_rec_env_def]) + \\ gvs [] +QED + +Triviality LIST_REL_lemma: + ∀xs ys n. LIST_REL R xs ys ∧ ALOOKUP ys n = SOME y ⇒ ∃x. R x (n,y) +Proof + Induct_on ‘ys’ \\ gvs [PULL_EXISTS,FORALL_PROD,AllCaseEqs()] + \\ rw [] \\ first_x_assum $ irule_at Any + \\ gvs [] \\ first_x_assum $ irule_at Any +QED + +Theorem v_rel_thunk_IMP_oEL: + v_rel p v1 (ThunkLoc loc) ∧ IS_SOME (dest_anyThunk v1) ⇒ + oEL loc p = SOME (SOME v1) +Proof + once_rewrite_tac [v_rel_cases] \\ gvs [] \\ strip_tac + \\ gvs [dest_anyThunk_def,IS_SOME_EXISTS,AllCaseEqs()] + \\ dxrule_all LIST_REL_lemma + \\ gvs [EXISTS_PROD,FORALL_PROD] + \\ gvs [loc_rel_def,dest_anyThunk_def] +QED + +Triviality ALOOKUP_SND: + ∀l f x y. ALOOKUP (FILTER (f o SND) l) x = SOME y ⇒ f y +Proof + Induct \\ rw [] \\ gvs [] + >- ( + PairCases_on ‘h’ \\ gvs [ALOOKUP_def, AllCaseEqs()] + \\ last_x_assum drule \\ gvs []) + \\ last_x_assum drule \\ gvs [] +QED + +Theorem thunk_or_thunk_loc_rel: + v_rel p v1 v2 ∧ + ¬thunk_or_thunk_loc v1 ⇒ + ¬thunk_or_thunk_loc v2 +Proof + simp [thunk_or_thunk_loc_def] + \\ ntac 2 (TOP_CASE_TAC \\ gvs []) \\ rw [] + >~ [‘v_rel _ (Constructor _ _) v2’] >- rgs [Once v_rel_cases] + >~ [‘v_rel _ (Closure _ _ _) v2’] >- rgs [Once v_rel_cases] + >~ [‘v_rel _ (Recclosure funs env fn) v2’] >- ( + gvs [Once dest_anyThunk_def] + \\ Cases_on ‘ALOOKUP funs fn’ \\ gvs [] + >- ( + rgs [Once v_rel_cases] \\ gvs [] + >- ( + TOP_CASE_TAC \\ gvs [dest_anyThunk_def, AllCaseEqs()] + \\ drule ALOOKUP_SND \\ gvs [dest_Lam_def]) + \\ ‘ALL_DISTINCT (MAP FST funs)’ by gvs [] + \\ drule_all LIST_REL_loc_rel_alt \\ gvs []) + \\ rpt (TOP_CASE_TAC \\ gvs []) + \\ rgs [Once v_rel_cases] + \\ gvs [AllCaseEqs(), dest_anyThunk_def] + >>~- ([‘MEM (_,Lam _ _) funs’], drule ALOOKUP_SND \\ gvs [dest_Lam_def]) + \\ ‘ALL_DISTINCT (MAP FST funs)’ by gvs [] + \\ drule_all LIST_REL_loc_rel_alt \\ gvs []) + >~ [‘v_rel _ (Thunk _) v2’] >- ( + rgs [Once v_rel_cases] \\ gvs [dest_anyThunk_def]) + >~ [‘v_rel _ (Atom l) v2’] >- rgs [Once v_rel_cases] +QED + Theorem step_forward: - ∀n zs p tr ts tk tr1 ts1 tk1 ss sr sk. - step_n n (tr,ts,tk) = (tr1,ts1,tk1) ∧ is_halt (tr1,ts1,tk1) ∧ + ∀n avoid zs p tr ts tk tr1 ts1 tk1 ss sr sk. + step'_n n avoid (tr,ts,tk) = (tr1,ts1,tk1) ∧ is_halt (tr1,ts1,tk1) ∧ cont_rel p tk sk ∧ state_rel p (pick_opt zs ts) (SOME ss) ∧ step_res_rel p tr sr ∧ tr1 ≠ Error ⇒ @@ -1719,19 +2004,23 @@ Theorem step_forward: is_halt (sr1,SOME ss1,sk1) ∧ cont_rel (p++q) tk1 sk1 ∧ state_rel (p++q) (pick_opt zs ts1) (SOME ss1) ∧ - step_res_rel (p++q) tr1 sr1 + step_res_rel (p++q) tr1 sr1 ∧ + ∀thk loc. + thk ∈ avoid ∧ oEL loc p = SOME (SOME thk) ⇒ + oEL loc ss1 = oEL loc ss Proof gen_tac \\ completeInduct_on ‘n’ - \\ rpt strip_tac \\ gvs [PULL_FORALL,AND_IMP_INTRO] + \\ rpt strip_tac \\ gvs [AND_IMP_INTRO] \\ Cases_on ‘n = 0’ >- - (gvs [] \\ qexists_tac ‘0’ \\ qexists_tac ‘[]’ \\ gvs [] + (gvs [step'_n_def] \\ qexists_tac ‘0’ \\ qexists_tac ‘[]’ \\ gvs [] \\ Cases_on ‘sr’ \\ fs [is_halt_def] \\ gvs [step_res_rel_cases,is_halt_def] \\ gvs [is_halt_def,cont_rel_nil]) \\ Cases_on ‘is_halt (tr,ts,tk)’ - >- (‘is_halt (step_n n (tr,ts,tk)) ∧ is_halt (step_n 0 (tr,ts,tk))’ by fs [] - \\ dxrule is_halt_imp_eq + >- (‘is_halt (step'_n n avoid (tr,ts,tk)) ∧ + is_halt (step'_n 0 avoid (tr,ts,tk))’ by fs [step'_n_def] + \\ dxrule is_halt_imp_eq' \\ disch_then dxrule \\ fs [] \\ strip_tac \\ gvs [] \\ qexists_tac ‘0’ \\ qexists_tac ‘[]’ \\ fs [] @@ -1747,40 +2036,48 @@ Proof \\ simp [Once cont_rel_cases] \\ strip_tac \\ gvs [] >~ [‘ForceK1’] >- - (Cases_on ‘n’ \\ fs [ADD1,step_n_add,step] + (Cases_on ‘n’ \\ fs [ADD1,step'_n_add,step] \\ rename [‘v_rel p v1 v2’] - \\ Cases_on ‘dest_anyThunk v1’ \\ gvs [] + \\ Cases_on ‘dest_anyThunk v1’ \\ gvs [step'_def,return'_def,error_def] \\ PairCases_on ‘x’ \\ gvs [] \\ rename [‘_ = SOME (yy,_)’] \\ Cases_on ‘yy’ \\ gvs [] - \\ ntac 4 (irule_at Any step_n_unwind \\ fs [step_n_add,step]) + \\ irule_at Any step_n_unwind \\ fs [step_n_add,step] >- (drule_all dest_anyThunk_INL \\ strip_tac \\ gvs [] - \\ ntac 15 (irule_at Any step_n_unwind \\ fs [step_n_add,step,get_atoms_def]) + \\ Cases_on ‘v1 ∈ avoid’ \\ gvs [] \\ last_x_assum $ drule_at $ Pos $ el 2 \\ fs [] \\ simp [Once step_res_rel_cases,PULL_EXISTS] \\ disch_then drule_all \\ strip_tac \\ gvs [] - \\ rpt $ first_assum $ irule_at Any) + \\ rpt $ first_assum $ irule_at Any + \\ gvs [SF SFY_ss]) \\ PairCases_on ‘y’ \\ fs [] \\ drule_all dest_anyThunk_INR \\ reverse strip_tac \\ gvs [] >- - (ntac 15 (irule_at Any step_n_unwind \\ fs [step_n_add,step,get_atoms_def]) - \\ gvs [GSYM rec_env_def] + (gvs [] + \\ Cases_on ‘v1 ∈ avoid’ \\ gvs [] \\ drule step_n_set_cont \\ strip_tac \\ pop_assum (qspec_then ‘ForceK2 ts::tk’ assume_tac) - \\ drule_all step_n_fast_forward + \\ drule_all (step'_n_fast_forward |> REWRITE_RULE [mk_rec_env_def]) \\ strip_tac \\ pop_assum mp_tac \\ Cases_on ‘m3’ \\ fs [] \\ strip_tac \\ gvs [] - \\ gvs [step_n_add,step,ADD1] + \\ gvs [step'_n_add,step,ADD1,step'_def,return'_def] + \\ Cases_on ‘thunk_or_thunk_loc tv’ \\ gvs [] \\ last_x_assum $ drule_at $ Pos $ el 2 \\ fs [] \\ simp [Once step_res_rel_cases,PULL_EXISTS] \\ disch_then drule_all \\ strip_tac \\ gvs [] - \\ rpt $ first_assum $ irule_at Any) - \\ gvs [GSYM rec_env_def,get_atoms_def] - \\ drule_all step_n_NONE_split + \\ rpt $ first_assum $ irule_at Any + \\ gvs [SF SFY_ss]) + \\ Cases_on ‘v1 ∈ avoid’ \\ gvs [] + \\ irule_at Any step_n_unwind \\ fs[step_n_add,step] + \\ gvs [get_atoms_def] + \\ drule_all step'_n_NONE_split \\ strip_tac \\ ntac 2 $ pop_assum mp_tac + \\ simp [opt_bind_def] + \\ drule_all (step'_n_INSERT |> REWRITE_RULE [mk_rec_env_def]) + \\ strip_tac \\ last_assum $ drule_at $ Pos $ el 2 \\ fs [cont_rel_nil] \\ simp [Once step_res_rel_cases,PULL_EXISTS] @@ -1788,37 +2085,43 @@ Proof \\ fs [SOME_THE_pick_opt] \\ disch_then drule_all \\ strip_tac \\ rpt strip_tac - \\ ntac 20 (irule_at Any step_n_unwind \\ fs [step_n_add,step,get_atoms_def]) \\ qmatch_goalsub_abbrev_tac ‘step_n _ (_,_,kk3)’ \\ qpat_x_assum ‘step_res_rel (p ++ q) (Val v) _’ mp_tac \\ simp [Once step_res_rel_cases] \\ strip_tac \\ gvs [] + \\ first_assum $ qspecl_then [‘v1’,‘loc’] mp_tac + \\ impl_tac >- (imp_res_tac v_rel_thunk_IMP_oEL \\ gvs []) + \\ strip_tac \\ drule step_n_set_cont \\ strip_tac \\ pop_assum (qspec_then ‘kk3’ assume_tac) + \\ simp [opt_bind_def] \\ qsuff_tac ‘∃m' ss1' sr1' sk1 q'. - step_n m' (Exp senv' se,SOME ss,kk3) = (sr1',SOME ss1',sk1) ∧ - is_halt (sr1',SOME ss1',sk1) ∧ cont_rel (p ++ q') tk1 sk1 ∧ - state_rel (p ++ q') (pick_opt zs ts1) (SOME ss1') ∧ - step_res_rel (p ++ q') tr1 sr1'’ >- metis_tac [] + step_n m' (Exp senv se,SOME ss,kk3) = (sr1',SOME ss1',sk1) ∧ + is_halt (sr1',SOME ss1',sk1) ∧ cont_rel (p ++ q') tk1 sk1 ∧ + state_rel (p ++ q') (pick_opt zs ts1) (SOME ss1') ∧ + step_res_rel (p ++ q') tr1 sr1' ∧ + ∀thk loc. + thk ∈ avoid ∧ oEL loc p = SOME (SOME thk) ⇒ + oEL loc ss1' = oEL loc ss’ >- metis_tac [] \\ Q.REFINE_EXISTS_TAC ‘ck+1+n5’ \\ rewrite_tac [step_n_add] \\ fs [] \\ fs [step,Abbr‘kk3’] - \\ ntac 8 (irule_at Any step_n_unwind \\ fs [step_n_add,step,get_atoms_def]) \\ drule_at (Pos $ el 2) dest_anyThunk_INR_abs \\ fs [] \\ disch_then $ drule_at $ Pos last \\ disch_then $ qspec_then ‘loc’ mp_tac \\ impl_keep_tac >- (irule v_rel_ext \\ fs []) \\ strip_tac \\ fs [] - \\ ntac 9 (irule_at Any step_n_unwind \\ fs [step_n_add,step,get_atoms_def]) - \\ fs [oEL_THM,EL_LUPDATE] - \\ ntac 2 (irule_at Any step_n_unwind \\ fs [step_n_add,step,get_atoms_def]) + \\ fs [oEL_THM,EL_LUPDATE,store_same_type_def] \\ qmatch_goalsub_abbrev_tac ‘SOME ss3’ \\ gvs [LUPDATE_DEF,LUPDATE_DEF,LUPDATE_LUPDATE] - \\ drule_at (Pos $ el 4) state_rel_LUPDATE_anyThunk - \\ disch_then $ drule_at (Pos $ el 3) + \\ drule_at (Pos $ el 4) state_rel_LUPDATE_anyThunk' + \\ disch_then $ drule_at (Pos $ el 3) \\ simp [] \\ disch_then drule_all \\ strip_tac \\ gvs [] \\ Cases_on ‘m2’ \\ gvs [] - \\ gvs [ADD1,step_n_add,step] - \\ qpat_x_assum ‘step_n n (Val v,ts,tk) = (tr1,ts1,tk1)’ assume_tac + \\ gvs [ADD1,step'_n_add,step,step'_def,return'_def] + \\ Cases_on ‘thunk_or_thunk_loc v’ \\ gvs [] + \\ qpat_x_assum ‘state_rel _ _ (SOME (LUPDATE _ _ _))’ mp_tac + \\ drule_all thunk_or_thunk_loc_rel \\ rw [] \\ gvs [] + \\ qpat_x_assum ‘step'_n n avoid (Val v,ts,tk) = (tr1,ts1,tk1)’ assume_tac \\ last_x_assum $ drule_at $ Pos $ el 2 \\ simp [] \\ simp [Once step_res_rel_cases,PULL_EXISTS] \\ rpt $ disch_then $ drule_at $ Pos last @@ -1827,16 +2130,29 @@ Proof >- (irule_at Any cont_rel_ext \\ fs []) \\ strip_tac \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] - \\ rpt $ first_assum $ irule_at $ Pos hd) + \\ rpt $ first_assum $ irule_at Any + \\ rpt gen_tac \\ disch_tac \\ gvs [] + \\ rename [‘EL k p = SOME thk’] + \\ ‘EL k (p ++ q) = SOME thk /\ k < LENGTH p + LENGTH q’ by gvs [EL_APPEND1] + \\ first_x_assum drule_all + \\ strip_tac \\ gvs [] + \\ qsuff_tac ‘loc ≠ k’ + >- (rpt strip_tac \\ gvs [EL_LUPDATE] \\ metis_tac []) + \\ CCONTR_TAC \\ gvs [EL_LUPDATE] + \\ ‘v1 ≠ thk’ by (CCONTR_TAC \\ gvs []) + \\ imp_res_tac v_rel_thunk_IMP_oEL + \\ gvs [oEL_THM]) >~ [‘BoxK’] >- - (Cases_on ‘n’ \\ fs [ADD1,step_n_add,step] - \\ ntac 3 (irule_at Any step_n_unwind \\ fs [step_n_add,step]) + (Cases_on ‘n’ \\ fs [ADD1,step'_n_add,step,step'_def,return'_def] + \\ irule_at Any step_n_unwind \\ fs [step_n_add,step] + \\ Cases_on ‘thunk_or_thunk_loc v1’ \\ gvs [] \\ first_x_assum $ drule_at $ Pos $ el 2 \\ fs [] - \\ drule_all state_rel_INL - \\ disch_then $ qspec_then ‘[]’ assume_tac + \\ drule_then drule state_rel_INL + \\ simp [oneline dest_anyThunk_def,AllCaseEqs(),oneline dest_Thunk_def] + \\ strip_tac \\ disch_then $ drule_at Any \\ simp [Once step_res_rel_cases, PULL_EXISTS] - \\ disch_then $ qspecl_then [‘sk’,‘Atom (Loc (LENGTH ss))’] mp_tac + \\ disch_then $ qspecl_then [‘sk’,‘ThunkLoc (LENGTH ss)’] mp_tac \\ impl_tac >- (irule_at Any v_rel_new_Thunk \\ irule_at Any cont_rel_ext @@ -1844,11 +2160,18 @@ Proof \\ strip_tac \\ first_x_assum $ irule_at $ Pos hd \\ fs [] \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] - \\ first_x_assum $ irule_at $ Pos hd \\ fs []) + \\ first_x_assum $ irule_at $ Pos hd \\ fs [SF SFY_ss] + \\ rpt gen_tac \\ strip_tac + \\ gvs [oEL_THM] + \\ first_x_assum $ qspecl_then [‘thk’,‘loc’] mp_tac + \\ gvs [EL_APPEND1,SNOC_APPEND,state_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ gvs [] + \\ gvs [EL_APPEND1,SNOC_APPEND,state_rel_def]) >~ [‘LetK tenv n te’] >- - (Cases_on ‘n'’ \\ fs [ADD1,step_n_add,step] + (Cases_on ‘n’ \\ fs [ADD1,step'_n_add,step,step'_def,return'_def,return_def] \\ irule_at Any step_n_unwind \\ fs [step_n_add,step] - \\ Cases_on ‘n’ \\ gvs [step] + \\ Cases_on ‘n'’ \\ gvs [step,return_def] + \\ fs [ADD1,step'_n_add,step,step'_def,return'_def,return_def] \\ first_x_assum $ drule_at $ Pos $ el 2 \\ fs [] \\ simp [Once step_res_rel_cases,PULL_EXISTS] \\ rpt (disch_then drule) @@ -1857,7 +2180,7 @@ Proof \\ drule_all imp_env_rel_cons \\ metis_tac []) >~ [‘IfK tenv te1 te2’] >- - (Cases_on ‘n’ \\ fs [ADD1,step_n_add,step] + (Cases_on ‘n’ \\ fs [ADD1,step'_n_add,step,step'_def,return'_def,return_def] \\ irule_at Any step_n_unwind \\ fs [step_n_add,step] \\ qpat_x_assum ‘v_rel p v1 v2’ mp_tac \\ Cases_on ‘v1 = True_v ∨ v1 = False_v’ \\ gvs [step] @@ -1867,7 +2190,7 @@ Proof \\ rpt (disch_then drule) \\ strip_tac \\ rpt (first_assum $ irule_at Any \\ gvs [])) >~ [‘RaiseK’] >- - (Cases_on ‘n’ \\ fs [ADD1,step_n_add,step] + (Cases_on ‘n’ \\ fs [ADD1,step'_n_add,step,step'_def,return'_def,return_def] \\ Cases_on ‘ts = NONE’ \\ gvs [] \\ irule_at Any step_n_unwind \\ fs [step_n_add,step] \\ first_x_assum $ drule_at $ Pos $ el 2 \\ fs [] @@ -1875,21 +2198,52 @@ Proof \\ rpt (disch_then drule) \\ strip_tac \\ rpt (first_assum $ irule_at Any \\ gvs [])) >~ [‘HandleK tenv _ te’] >- - (Cases_on ‘n’ \\ fs [ADD1,step_n_add,step] + (Cases_on ‘n’ \\ fs [ADD1,step'_n_add,step,step'_def,return'_def,return_def] \\ irule_at Any step_n_unwind \\ fs [step_n_add,step] \\ first_x_assum $ drule_at $ Pos $ el 2 \\ fs [] \\ simp [Once step_res_rel_cases,PULL_EXISTS] \\ rpt (disch_then drule) \\ strip_tac \\ rpt (first_assum $ irule_at Any \\ gvs [])) >~ [‘HandleAppK tenv te’] >- - (Cases_on ‘n’ \\ fs [ADD1,step_n_add,step] + (Cases_on ‘n’ \\ fs [ADD1,step'_n_add,step,step'_def,return'_def,return_def] \\ irule_at Any step_n_unwind \\ fs [step_n_add,step] \\ first_x_assum $ drule_at $ Pos $ el 2 \\ fs [] \\ simp [Once step_res_rel_cases,PULL_EXISTS] \\ rpt (disch_then drule) \\ strip_tac \\ rpt (first_assum $ irule_at Any \\ gvs [])) + >~ [‘ForceMutK’] >- + (Cases_on ‘n’ + \\ fs [ADD1,step'_n_add,step,step'_def,return'_def,return_def] + \\ qpat_x_assum ‘_ = (tr1,ts1,tk1)’ mp_tac + \\ rpt (TOP_CASE_TAC \\ gvs []) \\ rw [] \\ gvs [] + \\ qpat_x_assum ‘store_same_type _ _’ mp_tac \\ simp [store_same_type_def] + \\ rpt (TOP_CASE_TAC \\ gvs []) + \\ irule_at Any step_n_unwind \\ fs [step_n_add,step] + \\ ‘state_rel p (pick_opt ARB (SOME x)) (SOME ss)’ by gvs [] + \\ drule_all thunk_or_thunk_loc_rel \\ strip_tac \\ gvs [] + \\ ‘n2 < LENGTH ss’ by ( + gvs [state_rel_def, LIST_REL_EL_EQN] + \\ imp_res_tac find_loc_length_thm \\ gvs []) \\ gvs [] + \\ ‘store_same_type (EL n2 ss) (ThunkMem Evaluated v2)’ by ( + simp [store_same_type_def] + \\ rpt (TOP_CASE_TAC \\ gvs []) + \\ ( + gvs [state_rel_def, LIST_REL_EL_EQN] + \\ imp_res_tac find_loc_el_thm \\ gvs [] + \\ first_x_assum $ qspec_then ‘n1’ assume_tac \\ gvs [store_rel_def])) + \\ gvs [] + \\ first_x_assum $ drule_at $ Pos $ el 2 \\ fs [] + \\ simp [Once step_res_rel_cases,PULL_EXISTS] + \\ rpt (disch_then $ drule_at Any) \\ strip_tac + \\ drule_all state_rel_thunk_v_rel \\ strip_tac + \\ first_x_assum drule + \\ disch_then $ qspec_then ‘zs’ strip_assume_tac + \\ first_x_assum $ irule_at $ Pos hd \\ gvs [] + \\ first_x_assum $ irule_at $ Pos hd \\ gvs [] + \\ rpt gen_tac \\ strip_tac \\ rw [oEL_LUPDATE] + \\ imp_res_tac find_loc_lemma \\ gvs []) \\ rename [‘AppK tenv op tvs tes’] - \\ Cases_on ‘n’ \\ fs [ADD1,step_n_add,step] + \\ Cases_on ‘n’ \\ fs [ADD1,step'_n_add,step,step'_def,return'_def,return_def] \\ irule_at Any step_n_unwind \\ fs [step_n_add,step] \\ reverse (Cases_on ‘tes’) \\ gvs [] >- (* more args to evaluate *) @@ -1920,7 +2274,8 @@ Proof \\ disch_then $ qspec_then ‘z1’ assume_tac \\ disch_then drule \\ strip_tac - \\ rpt (first_x_assum $ irule_at Any)) + \\ rpt (first_x_assum $ irule_at Any) + \\ gvs [SF SFY_ss]) \\ ‘∃s_. application op (v2::tvs) (SOME ss) sk = s_’ by fs [] \\ PairCases_on ‘s_’ \\ gvs [] \\ ‘∃t_. application op (v1::tvs') ts tk = t_’ by fs [] @@ -1931,7 +2286,11 @@ Proof \\ rpt $ disch_then $ drule_at $ Pos $ last \\ fs [] \\ strip_tac \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] - \\ rpt (first_x_assum $ irule_at Any)) + \\ rpt (first_x_assum $ irule_at Any) + \\ rpt gen_tac \\ disch_tac + \\ first_x_assum $ qspecl_then [‘thk’,‘loc’] mp_tac + \\ impl_tac >- gvs [oEL_THM,EL_APPEND1] + \\ strip_tac \\ gvs []) >- (Cases_on ‘tk’ \\ gvs [is_halt_def] \\ Cases_on ‘sk’ \\ gvs [is_halt_def,cont_rel_nil_cons] @@ -1940,10 +2299,10 @@ Proof \\ simp [Once cont_rel_cases] \\ strip_tac \\ gvs [] \\ Q.REFINE_EXISTS_TAC ‘ck+1:num’ - \\ qpat_x_assum ‘step_n _ _ = _’ mp_tac + \\ qpat_x_assum ‘step'_n _ _ _ = _’ mp_tac \\ (Cases_on ‘n’ >- fs []) - \\ rewrite_tac [step_n_add,ADD1] - \\ fs [] \\ simp [step] + \\ rewrite_tac [step'_n_add,ADD1,step_n_add] + \\ fs [] \\ simp [step,step'_def,return'_def] \\ strip_tac \\ last_x_assum irule \\ simp [] \\ pop_assum $ irule_at Any \\ fs [] @@ -1954,9 +2313,9 @@ Proof \\ qpat_x_assum ‘compile_rel e1 e2’ mp_tac \\ simp [Once compile_rel_cases] \\ rw [] \\ Q.REFINE_EXISTS_TAC ‘ck+1:num’ - \\ qpat_x_assum ‘step_n n _ = _’ mp_tac + \\ qpat_x_assum ‘step'_n n _ _ = _’ mp_tac \\ (Cases_on ‘n’ >- fs []) - \\ rewrite_tac [step_n_add,ADD1] + \\ rewrite_tac [step'_n_add,step_n_add,ADD1,step'_def,return'_def,step'_n_1] \\ TRY ((rename [‘Exp _ $ Lam _ _’] ORELSE rename [‘Exp _ $ If _ _ _’] ORELSE @@ -1979,36 +2338,40 @@ Proof \\ first_x_assum drule \\ fs [] \\ rw [] \\ gvs [] \\ last_x_assum irule \\ pop_assum $ irule_at Any \\ fs [] - \\ once_rewrite_tac [step_res_rel_cases] \\ fs [] - \\ rpt (first_assum $ irule_at $ Any \\ fs [])) + \\ once_rewrite_tac [step_res_rel_cases] \\ fs []) >~ [‘Delay te’] >- (simp [step] \\ strip_tac - \\ Q.REFINE_EXISTS_TAC ‘ck1+1+1+1+1’ + \\ Q.REFINE_EXISTS_TAC ‘ck1+1+1’ \\ rewrite_tac [step_n_add,ADD1] \\ simp [step,return_def] \\ last_x_assum $ drule_at $ Pos $ el 2 \\ simp [] - \\ ‘step_res_rel (p ++ [SOME (INR (env1,te),[])]) - (Val (Thunk (INR (env1,te)))) (Val (Atom (Loc (LENGTH ss)))) ∧ - state_rel (p ++ [SOME (INR (env1,te),[])]) - (pick_opt zs ts) (SOME (SNOC [False_v; Closure NONE env2 se] ss))’ by + \\ ‘step_res_rel (p ++ [SOME (Thunk (INR (env1,te)))]) + (Val (Thunk (INR (env1,te)))) (Val (ThunkLoc (LENGTH ss))) ∧ + state_rel (p ++ [SOME (Thunk (INR (env1,te)))]) + (pick_opt zs ts) + (SOME (SNOC (ThunkMem NotEvaluated (Closure NONE env2 se)) ss))’ by (once_rewrite_tac [step_res_rel_cases] \\ fs [] \\ irule_at Any v_rel_new_Thunk - \\ irule_at Any state_rel_INR \\ fs [rec_env_def,state_rel_def] - \\ imp_res_tac LIST_REL_LENGTH \\ fs []) + \\ irule_at Any state_rel_INR \\ fs [state_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ fs [dest_anyThunk_def]) \\ rpt (disch_then $ drule_at $ Pos last) \\ disch_then $ qspec_then ‘sk’ mp_tac \\ impl_tac >- (irule cont_rel_ext \\ fs []) \\ strip_tac \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] - \\ rpt $ first_x_assum $ irule_at $ Pos last) + \\ rpt $ first_x_assum $ irule_at $ Pos hd + \\ rpt gen_tac \\ strip_tac + \\ first_x_assum $ qspecl_then [‘thk’,‘loc’] mp_tac + \\ gvs [oEL_THM,EL_APPEND1,SNOC_APPEND] \\ gvs [state_rel_def] + \\ imp_res_tac LIST_REL_LENGTH \\ gvs [EL_APPEND1]) >~ [‘Let’] >- - (simp [step] \\ strip_tac - \\ last_x_assum irule - \\ pop_assum $ irule_at Any \\ fs [] - \\ once_rewrite_tac [step_res_rel_cases] \\ fs [] - \\ rpt (first_assum $ irule_at $ Any \\ fs []) - \\ once_rewrite_tac [cont_rel_cases] \\ fs [] - \\ once_rewrite_tac [v_rel_cases] \\ fs [dest_anyClosure_def]) + (simp [step] \\ strip_tac + \\ last_x_assum irule + \\ pop_assum $ irule_at Any \\ fs [] + \\ once_rewrite_tac [step_res_rel_cases] \\ fs [] + \\ rpt (first_assum $ irule_at $ Any \\ fs []) + \\ once_rewrite_tac [cont_rel_cases] \\ fs [] + \\ once_rewrite_tac [v_rel_cases] \\ fs [dest_anyClosure_def]) >~ [‘App op ys’] >- (fs [step,error_def] \\ imp_res_tac LIST_REL_LENGTH \\ fs [] @@ -2035,9 +2398,13 @@ Proof \\ rpt $ disch_then drule \\ strip_tac \\ fs [] \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] - \\ rpt (last_x_assum $ irule_at Any)) + \\ rpt (last_x_assum $ irule_at Any) + \\ rpt gen_tac \\ disch_tac + \\ first_x_assum $ qspecl_then [‘thk’,‘loc’] mp_tac + \\ impl_tac >- gvs [oEL_THM,EL_APPEND1] + \\ strip_tac \\ gvs []) \\ rename [‘Letrec tfns te’] - \\ CONV_TAC (RATOR_CONV (SIMP_CONV (srw_ss()) [step,GSYM rec_env_def])) + \\ CONV_TAC (RATOR_CONV (SIMP_CONV (srw_ss()) [step])) \\ strip_tac \\ last_x_assum $ dxrule_at $ Pos $ el 2 \\ strip_tac @@ -2046,10 +2413,9 @@ Proof \\ irule_at Any step_n_make_let_env \\ irule_at Any step_n_unwind \\ simp [] \\ fs [GSYM ADD1,ADD_CLAUSES] - \\ simp [ADD1,step_n_add,step,GSYM rec_env_def] + \\ simp [ADD1,step_n_add,step] \\ imp_res_tac Letrec_split_EVERY - \\ drule_all Letrec_split_ALL_DISTINCT \\ strip_tac - \\ fs [rec_env_def] + \\ drule_all Letrec_split_ALL_DISTINCT \\ strip_tac \\ fs [] \\ drule Letrec_store_forward \\ asm_rewrite_tac [] \\ disch_then $ irule_at Any \\ fs [] @@ -2070,7 +2436,7 @@ Proof \\ simp [PULL_EXISTS] \\ qmatch_goalsub_abbrev_tac ‘Exp env5 _, SOME ss5, _’ \\ qabbrev_tac ‘p5 = p ++ - MAP (λ(fn,_). dest_anyThunk (Recclosure tfns env1 fn)) + MAP (λ(fn,_). SOME (Recclosure tfns env1 fn)) (FILTER (is_Delay o SND) tfns)’ \\ first_x_assum $ qspecl_then [‘zs’,‘p5’,‘ss5’,‘Exp env5 se’,‘sk’] mp_tac \\ reverse impl_tac @@ -2078,12 +2444,18 @@ Proof (strip_tac \\ first_assum $ irule_at $ Pos hd \\ full_simp_tac std_ss [Abbr‘p5’,GSYM APPEND_ASSOC] - \\ first_assum $ irule_at $ Pos hd \\ fs []) + \\ first_assum $ irule_at $ Pos hd \\ fs [] + \\ rpt gen_tac \\ disch_tac \\ gvs [] + \\ first_x_assum $ qspecl_then [‘thk’,‘loc’] mp_tac + \\ impl_tac >- gvs [oEL_THM,EL_APPEND1] + \\ strip_tac \\ gvs [Abbr ‘ss5’] + \\ gvs [state_rel_def] \\ imp_res_tac LIST_REL_LENGTH + \\ gvs [oEL_THM,EL_APPEND1]) \\ conj_tac >- fs [Abbr‘p5’,cont_rel_ext] \\ unabbrev_all_tac - \\ fs [step_res_rel_cases,GSYM rec_env_def] - \\ irule state_rel_Letrec \\ fs [] + \\ fs [step_res_rel_cases] + \\ irule (state_rel_Letrec |> REWRITE_RULE [mk_rec_env_def]) \\ fs [] \\ first_x_assum $ irule_at $ Pos last \\ fs [] \\ drule_all Letrec_split_ALL_DISTINCT \\ fs [] QED @@ -2130,17 +2502,8 @@ Proof \\ PairCases_on ‘x’ \\ gvs [] \\ rename [‘_ = SOME (yy,_)’] \\ Cases_on ‘yy’ \\ simp [] >- - (rename [‘step_n n’] \\ Cases_on ‘n’ \\ fs [] - >- (rw [] \\ fs [is_halt_def]) - \\ rewrite_tac [step_n_add,ADD1] \\ simp [step] - \\ rename [‘step_n n’] \\ Cases_on ‘n’ \\ fs [] - >- (rw [] \\ fs [is_halt_def]) - \\ rewrite_tac [step_n_add,ADD1] \\ simp [step,get_atoms_def] - \\ drule_all dest_anyThunk_INL + (drule_all dest_anyThunk_INL \\ strip_tac \\ gvs [] - \\ ntac 16 (rename [‘step_n n’] \\ Cases_on ‘n’ \\ fs [] - >- (rw [] \\ fs [is_halt_def]) - \\ rewrite_tac [step_n_add,ADD1] \\ simp [step,get_atoms_def]) \\ gvs [ADD1] \\ strip_tac \\ last_x_assum irule \\ pop_assum $ irule_at Any \\ fs [] @@ -2149,40 +2512,37 @@ Proof \\ PairCases_on ‘y’ \\ drule_all dest_anyThunk_INR \\ reverse strip_tac \\ gvs [] >- - (ntac 18 (rename [‘step_n nn’] \\ Cases_on ‘nn’ \\ fs [] - >- (rw [] \\ fs [is_halt_def]) - \\ rewrite_tac [step_n_add,ADD1] \\ simp [step,get_atoms_def]) - \\ gvs [ADD1,GSYM rec_env_def] \\ strip_tac + (gvs [ADD1] \\ strip_tac \\ drule step_n_set_cont \\ strip_tac \\ pop_assum $ qspec_then ‘ForceK2 ts::tk’ assume_tac \\ Q.REFINE_EXISTS_TAC ‘ck1+(1+n5)’ \\ rewrite_tac [step_n_add,ADD1] \\ fs [] \\ simp [step] + \\ IF_CASES_TAC \\ gvs [] >- (qexists ‘0’ \\ rw []) \\ last_x_assum $ irule - \\ pop_assum kall_tac - \\ pop_assum kall_tac - \\ pop_assum $ irule_at Any \\ fs [] + \\ first_x_assum $ irule_at Any \\ fs [] \\ rpt (first_assum $ irule_at Any) \\ simp [step_res_rel_cases]) - \\ ntac 23 (rename [‘step_n n’] \\ Cases_on ‘n’ \\ fs [] - >- (rw [] \\ fs [is_halt_def]) - \\ rewrite_tac [step_n_add,ADD1] \\ simp [step,get_atoms_def]) + \\ Cases_on ‘n’ >- (strip_tac \\ gvs[]) + \\ rewrite_tac[step_n_add, ADD1] \\ simp[step, error_def] + \\ rename1 ‘step_n n’ + \\ simp [opt_bind_def] \\ gvs [ADD1] \\ strip_tac \\ drule_all step_n_cut_cont \\ strip_tac \\ PairCases_on ‘z’ \\ fs [] \\ last_assum $ qspec_then ‘m’ mp_tac \\ simp [] \\ disch_then drule \\ simp [] - \\ simp [Once cont_rel_cases,GSYM rec_env_def] + \\ simp [Once cont_rel_cases] \\ rpt (disch_then drule \\ simp []) - \\ rename [‘env_rel p (rec_env f tenv1) senv1’,‘compile_rel te se’] - \\ disch_then $ qspec_then ‘Exp (rec_env f tenv1) te’ mp_tac + \\ rename [‘env_rel p (MAP _ f ++ tenv1) senv1’,‘compile_rel te se’] + \\ disch_then $ qspec_then ‘Exp (mk_rec_env f tenv1) te’ mp_tac \\ impl_tac >- simp [Once step_res_rel_cases] \\ strip_tac \\ drule_all step_n_NONE \\ reverse strip_tac >- - (pop_assum $ qspec_then ‘ForceK2 ts::tk’ strip_assume_tac + (pop_assum $ qspec_then ‘ForceK2 ts::tk’ strip_assume_tac \\ gvs [] \\ pop_assum $ irule_at Any \\ fs [is_halt_def]) \\ gvs [] \\ drule step_n_set_cont \\ strip_tac @@ -2191,7 +2551,11 @@ Proof \\ qpat_x_assum ‘step_n m _ = _’ mp_tac \\ rewrite_tac [step_n_add,ADD1] \\ simp [] \\ simp [step] \\ gvs [] - \\ pop_assum mp_tac + \\ IF_CASES_TAC \\ gvs [] >- (strip_tac \\ qexists ‘0’ \\ gvs []) + \\ ntac 2 (pop_assum mp_tac) + \\ drule_then assume_tac step_n_IMP_step'_n + \\ drule_all (step'_n_INSERT |> REWRITE_RULE [mk_rec_env_def]) + \\ strip_tac \\ drule step_forward \\ simp [cont_rel_nil,is_halt_def] \\ simp [Once step_res_rel_cases,PULL_EXISTS] @@ -2202,51 +2566,55 @@ Proof \\ simp [Once step_res_rel_cases] \\ strip_tac \\ gvs [is_halt_def] \\ rename [‘step_n m2 (Exp senv1 se,SOME ss,[]) = (Val v2,SOME ss2,[])’] + \\ rw [] \\ drule_all step_n_fast_forward \\ strip_tac \\ pop_assum mp_tac - \\ ntac 9 (rename [‘step_n nn’] \\ Cases_on ‘nn’ \\ fs [] + \\ ntac 1 (rename [‘step_n nn’] \\ Cases_on ‘nn’ \\ fs [] >- (rw [] \\ fs [is_halt_def]) \\ rewrite_tac [step_n_add,ADD1] \\ simp [step,get_atoms_def]) + \\ gvs [SOME_THE_pick_opt] + \\ drule_all_then assume_tac thunk_or_thunk_loc_rel \\ gvs [] + \\ drule v_rel_thunk_IMP_oEL + \\ impl_tac >- gvs [] \\ strip_tac + \\ first_x_assum drule \\ strip_tac \\ rfs [] + \\ rfs [oEL_THM,store_same_type_def] \\ gvs [ADD1,SOME_THE_pick_opt] \\ qpat_x_assum ‘_ = (sr1,ss1,sk1)’ kall_tac - \\ ‘v_rel (p++q) v1 (Atom (Loc loc))’ by (irule v_rel_ext \\ fs []) + \\ ‘v_rel (p++q) v1 (ThunkLoc loc)’ by (irule v_rel_ext \\ fs []) \\ drule dest_anyThunk_INR_abs \\ disch_then drule_all \\ strip_tac \\ fs [] - \\ ntac 9 (rename [‘step_n nn’] \\ Cases_on ‘nn’ \\ fs [] - >- (rw [] \\ fs [is_halt_def]) - \\ rewrite_tac [step_n_add,ADD1] \\ simp [step,get_atoms_def]) \\ fs [oEL_THM,EL_LUPDATE] - \\ ntac 2 (rename [‘step_n nn’] \\ Cases_on ‘nn’ \\ fs [] - >- (rw [] \\ fs [is_halt_def]) - \\ rewrite_tac [step_n_add,ADD1] \\ simp [step,get_atoms_def]) \\ qmatch_goalsub_abbrev_tac ‘SOME ss3’ \\ rename [‘step_n nn’] \\ gvs [ADD1] \\ strip_tac \\ rpt (disch_then kall_tac) \\ last_x_assum irule - \\ pop_assum $ irule_at Any \\ fs [] + \\ first_x_assum $ irule_at Any \\ fs [] \\ qexists_tac ‘zs’ \\ qexists_tac ‘p++q’ \\ fs [step_res_rel_cases] \\ irule_at Any cont_rel_ext \\ fs [LUPDATE_DEF,LUPDATE_LUPDATE] \\ simp [Abbr‘ss3’] - \\ drule_all state_rel_LUPDATE_anyThunk \\ fs []) + \\ drule_all (state_rel_LUPDATE_anyThunk |> REWRITE_RULE [mk_rec_env_def]) + \\ fs []) >~ [‘BoxK’] >- (Q.REFINE_EXISTS_TAC ‘ck1+1’ \\ rewrite_tac [step_n_add,ADD1] \\ simp [step] \\ qpat_x_assum ‘step_n _ _ = _’ mp_tac - \\ ntac 3 (rename [‘step_n nn’] \\ Cases_on ‘nn’ + \\ ntac 1 (rename [‘step_n nn’] \\ Cases_on ‘nn’ >- (rw [] \\ fs [is_halt_def]) \\ fs [] \\ rewrite_tac [step_n_add,ADD1] \\ simp [step,get_atoms_def]) \\ strip_tac + \\ IF_CASES_TAC \\ gvs [] >- (qexists ‘0’ \\ gvs []) \\ first_x_assum irule - \\ pop_assum $ irule_at Any \\ fs [ADD1] + \\ first_x_assum $ irule_at Any \\ fs [ADD1] \\ qexists_tac ‘zs’ \\ simp [step_res_rel_cases] \\ irule_at Any v_rel_new_Thunk \\ irule_at Any cont_rel_ext - \\ pop_assum $ irule_at Any + \\ first_x_assum $ irule_at Any \\ irule_at Any state_rel_INL \\ gvs [] - \\ fs [state_rel_def] \\ imp_res_tac LIST_REL_LENGTH \\ fs []) + \\ fs [state_rel_def] \\ imp_res_tac LIST_REL_LENGTH + \\ fs [dest_anyThunk_def]) >~ [‘LetK tenv n te’] >- (Q.REFINE_EXISTS_TAC ‘ck1+1’ \\ rewrite_tac [step_n_add,ADD1] \\ simp [step] @@ -2293,6 +2661,29 @@ Proof \\ last_x_assum irule \\ gvs [step_res_rel_cases,PULL_EXISTS] \\ rpt (first_assum $ irule_at Any \\ gvs [])) + >~ [‘ForceMutK’] >- + (Q.REFINE_EXISTS_TAC ‘ck1+1’ + \\ rewrite_tac [step_n_add,ADD1] \\ gvs [step] + \\ Cases_on ‘m’ \\ gvs [step_n_add,step,ADD1] + \\ TOP_CASE_TAC \\ gvs [] + \\ TRY (qexists ‘0’ \\ gvs [is_halt_def] \\ NO_TAC) + \\ drule_all_then assume_tac thunk_or_thunk_loc_rel \\ gvs [] + \\ Cases_on ‘ts’ \\ gvs [] + >- (qexists ‘0’ \\ fs [is_halt_def]) + \\ gvs [step_n_add,ADD1,step] + \\ imp_res_tac state_rel_def \\ gvs [LIST_REL_EL_EQN] + \\ imp_res_tac find_loc_length_thm + \\ Cases_on ‘n2 < LENGTH s1’ \\ gvs [] + \\ IF_CASES_TAC \\ gvs [] + \\ imp_res_tac find_loc_el_thm \\ gvs [] + \\ first_assum $ qspec_then ‘n1’ assume_tac + \\ Cases_on ‘EL n2 s1’ \\ Cases_on ‘EL n1 t1’ + \\ gvs [store_rel_def,store_same_type_def] + \\ last_x_assum irule + \\ gvs [step_res_rel_cases,PULL_EXISTS] + \\ rpt (first_assum $ irule_at Any \\ gvs []) + \\ qpat_x_assum ‘v_rel p v' v’ kall_tac + \\ drule_all state_rel_thunk_v_rel \\ gvs []) \\ rename [‘AppK tenv op tvs tes’] \\ Q.REFINE_EXISTS_TAC ‘ck1+1’ \\ rewrite_tac [step_n_add,ADD1] \\ simp [step] @@ -2379,37 +2770,24 @@ Proof \\ once_rewrite_tac [step_res_rel_cases] \\ fs [] \\ rpt (first_assum $ irule_at $ Any \\ fs [])) >~ [‘Delay te’] >- - (simp [step] - \\ Cases_on ‘n’ \\ fs [] - >- (rw [] \\ fs [is_halt_def]) - \\ rewrite_tac [step_n_add,ADD1] - \\ simp [step] - \\ rename [‘step_n n’] - \\ Cases_on ‘n’ \\ fs [] - >- (rw [] \\ fs [is_halt_def]) - \\ rewrite_tac [step_n_add,ADD1] - \\ simp [step] - \\ rename [‘step_n n’] - \\ Cases_on ‘n’ \\ fs [] - >- (rw [] \\ fs [is_halt_def]) - \\ rewrite_tac [step_n_add,ADD1] - \\ simp [step] - \\ rename [‘step_n n’] - \\ Cases_on ‘n’ \\ fs [] - >- (rw [] \\ fs [is_halt_def]) - \\ rewrite_tac [step_n_add,ADD1] - \\ simp [step] - \\ rename [‘step_n n’] + (ntac 2 + (simp [step] + \\ Cases_on ‘n’ \\ fs [] + >- (rw [] \\ fs [is_halt_def]) + \\ rewrite_tac [step_n_add,ADD1] + \\ simp [step] + \\ rename [‘step_n n’]) \\ strip_tac \\ last_x_assum irule \\ pop_assum $ irule_at Any \\ fs [] \\ qexists_tac ‘zs’ \\ fs [] - \\ qexists_tac ‘p ++ [SOME (INR (env1,te),[])]’ \\ fs [] + \\ qexists_tac ‘p ++ [SOME (Thunk (INR (env1,te)))]’ \\ fs [] \\ once_rewrite_tac [step_res_rel_cases] \\ fs [] \\ irule_at Any v_rel_new_Thunk \\ irule_at Any cont_rel_ext \\ simp [] - \\ irule_at Any state_rel_INR \\ fs [rec_env_def] - \\ fs [state_rel_def] \\ imp_res_tac LIST_REL_LENGTH \\ fs []) + \\ irule_at Any state_rel_INR \\ fs [] + \\ fs [state_rel_def] \\ imp_res_tac LIST_REL_LENGTH \\ fs [] + \\ gvs [dest_anyThunk_def]) >~ [‘App op ys’] >- (fs [step,error_def] \\ imp_res_tac LIST_REL_LENGTH \\ fs [] @@ -2442,16 +2820,16 @@ Proof \\ rewrite_tac [GSYM step_n_add,ADD1] \\ gvs [] \\ simp [comp_Letrec_def] \\ pairarg_tac \\ gvs [] \\ strip_tac - \\ simp [step_n_add,step,GSYM rec_env_def] - \\ drule_all step_n_Lets_some_ref_bool \\ strip_tac + \\ simp [step_n_add,step] + \\ drule_all step_n_Lets_some_alloc_thunk \\ strip_tac \\ pop_assum mp_tac \\ Cases_on ‘m’ >- (gvs [] \\ rw [] \\ gvs [is_halt_def]) - \\ simp [step_n_add,step,GSYM rec_env_def,ADD1] + \\ simp [step_n_add,step,ADD1] \\ gvs [ADD1] \\ imp_res_tac Letrec_split_EVERY \\ drule_all Letrec_split_ALL_DISTINCT \\ strip_tac - \\ fs [rec_env_def] \\ strip_tac + \\ fs [] \\ strip_tac \\ drule_at (Pos last) Letrec_store_thm \\ simp [] \\ rpt (disch_then drule) @@ -2468,15 +2846,14 @@ Proof \\ ‘k < n + 1’ by fs [] \\ last_x_assum drule \\ disch_then drule - \\ disch_then irule \\ simp [] - \\ fs [GSYM rec_env_def] + \\ disch_then irule \\ simp [] \\ fs [] \\ qexists_tac ‘p ++ - MAP (λ(fn,_). dest_anyThunk (Recclosure tfns env1 fn)) + MAP (λ(fn,_). SOME (Recclosure tfns env1 fn)) (FILTER (is_Delay o SND) tfns)’ \\ irule_at Any cont_rel_ext \\ qexists_tac ‘zs’ \\ fs [] \\ simp [step_res_rel_cases] - \\ irule state_rel_Letrec \\ fs [] + \\ irule (state_rel_Letrec |> REWRITE_RULE [mk_rec_env_def]) \\ fs [] \\ first_x_assum $ irule_at $ Pos last \\ fs [] QED @@ -2497,6 +2874,7 @@ Proof \\ PairCases_on ‘a’ \\ gvs [] \\ ‘a0 ≠ Error’ by (strip_tac \\ gvs []) \\ ‘state_rel p (pick_opt zs (SOME ts)) (SOME ss)’ by fs [] + \\ drule step_n_IMP_step'_n \\ strip_tac \\ drule_all step_forward \\ rw [] \\ reverse (DEEP_INTRO_TAC some_intro \\ fs [] \\ rw []) >- metis_tac [] diff --git a/compiler/backend/passes/proofs/thunk_Delay_LamScript.sml b/compiler/backend/passes/proofs/thunk_Delay_LamScript.sml index 1ea44bef..fa0933fc 100644 --- a/compiler/backend/passes/proofs/thunk_Delay_LamScript.sml +++ b/compiler/backend/passes/proofs/thunk_Delay_LamScript.sml @@ -1107,6 +1107,106 @@ Proof gvs [freevars_def, boundvars_def]) QED +Theorem v_rel_anyThunk: + ∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w) +Proof + ‘(∀v w. exp_rel v w ⇒ T) ∧ + (∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w))’ + suffices_by gvs [] + \\ ho_match_mp_tac exp_rel_strongind \\ rw [] \\ gvs [SF ETA_ss] + \\ rw [is_anyThunk_def, dest_anyThunk_def] + >- ( + gvs [AllCaseEqs(), PULL_EXISTS] + \\ iff_tac \\ rw [] + >- ( + ‘MAP FST (REVERSE f) = MAP FST (REVERSE g)’ by gvs [MAP_EQ_EVERY2] + \\ drule_all ALOOKUP_SOME_EL_2 \\ rw [] + \\ gvs [LIST_REL_EL_EQN, EL_MAP, EL_REVERSE] + \\ ‘PRE (LENGTH g - n') < LENGTH g’ by gvs [] + \\ last_x_assum drule \\ rw [] + \\ rgs [Once exp_rel_cases]) + >- ( + ‘MAP FST (REVERSE g) = MAP FST (REVERSE f)’ + by gvs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] + \\ drule_all ALOOKUP_SOME_EL_2 \\ rw [] + \\ gvs [LIST_REL_EL_EQN, EL_MAP, EL_REVERSE] + \\ ‘PRE (LENGTH g - n') < LENGTH g’ by gvs [] + \\ last_x_assum drule \\ rw [] + \\ rgs [Once exp_rel_cases])) + >- ( + gvs [AllCaseEqs(), PULL_EXISTS] + \\ iff_tac \\ rw [] + >- ( + drule ALOOKUP_SOME_REVERSE_EL \\ rw [] + \\ gvs [LIST_REL_EL_EQN] + \\ last_x_assum drule \\ rw [] + \\ gvs [EL_MAP] + \\ rgs [Once exp_rel_cases] + \\ ‘ALL_DISTINCT (MAP FST (REVERSE g))’ by gvs [MAP_REVERSE] + \\ ‘MEM (n,Delay y) (REVERSE g)’ by ( + gvs [] + \\ Cases_on ‘EL n' g’ \\ gvs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] + \\ last_x_assum drule \\ rw [MEM_EL] + \\ goal_assum drule \\ rw []) + \\ drule_all ALOOKUP_ALL_DISTINCT_MEM \\ rw [] + \\ ‘EVERY (λv. ¬MEM v (MAP FST g)) vL’ by gvs [EVERY_EL] + \\ drule_all ALL_DISTINCT_Letrec_Delay \\ rw [] + \\ ‘∃i. i < LENGTH g ∧ EL i g = (n,Delay y)’ by + (gvs [MEM_EL] \\ qexists ‘n'3'’ \\ rw []) + \\ drule_all ALOOKUP_Letrec_Delay + \\ rpt (CASE_TAC \\ gvs [])) + >- ( + ‘MEM (n,Delay x') (FLAT (MAP2 unfold_Delay_Lam g (ZIP (vL,bL))))’ by ( + drule ALOOKUP_SOME_REVERSE_EL \\ rw [] + \\ gvs [MEM_EL] \\ qexists ‘n'’ \\ gvs []) + \\ gvs [MEM_FLAT, MEM_EL, EL_MAP, EL_MAP2, EL_ZIP] + \\ Cases_on ‘EL n'2' g’ \\ gvs [] + \\ Cases_on ‘r’ \\ gvs [unfold_Delay_Lam_def] + \\ Cases_on ‘is_Lam e’ + \\ Cases_on ‘EL n'2' bL’ \\ gvs [] + >~ [‘_ < 2’] >- ( + ‘MEM (q,Delay e) (REVERSE g)’ by ( + gvs [MEM_EL] \\ qexists ‘n''’ \\ gvs []) + \\ gvs [MEM_EL, LIST_REL_EL_EQN] + \\ last_x_assum drule \\ rw [EL_MAP] + \\ Cases_on ‘EL n g’ \\ gvs [] + \\ rgs [Once exp_rel_cases] + \\ ‘ALL_DISTINCT (MAP FST (REVERSE f))’ by gvs [MAP_REVERSE] + \\ ‘MEM (q,Delay x'') (REVERSE f)’ by ( + gvs [MEM_EL] + \\ qexists ‘n’ \\ gvs [] + \\ Cases_on ‘EL n f’ \\ gvs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] + \\ last_x_assum drule \\ rw []) + \\ drule_all ALOOKUP_ALL_DISTINCT_MEM \\ rw [] + \\ qexists ‘x''’ \\ gvs [] + \\ ‘FST (EL n' g) = q’ by ( + Cases_on ‘n'3' = 0’ \\ gvs [] + \\ Cases_on ‘n'3' = 1’ \\ gvs []) + \\ gvs []) + \\ ( + gvs [LIST_REL_EL_EQN] + \\ last_x_assum drule \\ rw [EL_MAP] + \\ rgs [Once exp_rel_cases] + \\ ‘ALL_DISTINCT (MAP FST (REVERSE f))’ by gvs [MAP_REVERSE] + \\ ‘MEM (FST (EL n' g),Delay x') (REVERSE f)’ by ( + gvs [MEM_EL] + \\ qexists ‘n''’ \\ gvs [] + \\ Cases_on ‘EL n'' f’ \\ gvs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] + \\ last_x_assum drule \\ rw []) + \\ drule_all ALOOKUP_ALL_DISTINCT_MEM \\ rw []))) + >- ( + gvs [AllCaseEqs(), PULL_FORALL] \\ rw [] + \\ spose_not_then kall_tac + \\ gvs [LIST_REL_EL_EQN] + \\ last_x_assum drule \\ rw [EL_MAP] \\ strip_tac + \\ ntac 2 (rgs [Once exp_rel_cases]) + \\ Cases_on ‘EL i g’ \\ gvs [] + \\ ‘is_Lam (Lam s y')’ by simp [is_Lam_def] + \\ ‘EVERY (λv. ¬MEM v (MAP FST g)) vL’ by gvs [EVERY_EL] + \\ ‘i < LENGTH g’ by gvs [] + \\ drule_all ALOOKUP_Letrec_Delay3 \\ rw []) +QED + Theorem eval_to_Letrec: ∀k binds e. k ≠ 0 ⇒ eval_to k (Letrec binds e) = @@ -1603,9 +1703,10 @@ Proof \\ gs [] >- (gvs [dest_anyThunk_def, subst_funs_def, subst_empty] \\ qexists_tac ‘j’ \\ gs [] - \\ rw [eval_to_def, v_rel_Closure]) + \\ rw [eval_to_def, v_rel_Closure] + \\ gvs [is_anyThunk_def, dest_anyThunk_def]) \\ Cases_on ‘∃f n. v1 = Recclosure f n’ \\ gs [v_rel_def] - >~[‘FLAT’] + >~ [‘FLAT’] >- (gvs [dest_anyThunk_def] >> rename1 ‘ALOOKUP (REVERSE f) n’ >> Cases_on ‘ALOOKUP (REVERSE f) n’ >> gvs [ALOOKUP_NONE] >> @@ -1641,7 +1742,14 @@ Proof pop_assum $ drule_then assume_tac >> gvs [MEM_EL] >> Cases_on ‘y1’ >> gvs [exp_rel_def, is_Lam_def, subst_def] >> - rw [eval_to_def] >> + rw [eval_to_def] + >- gvs [is_anyThunk_def, dest_anyThunk_def] + >- (unabbrev_all_tac >> + drule v_rel_Closure_Recclosure >> rw [] >> + rpt (goal_assum $ drule_at Any >> gvs []) >> + gvs [LIST_REL_EL_EQN, EVERY_CONJ, EL_MAP, MEM_EL] >> + qexists ‘x'’ >> gvs [] >> strip_tac >> + drule v_rel_anyThunk >> rw []) >> unabbrev_all_tac >> irule v_rel_Closure_Recclosure >> gvs [LIST_REL_EL_EQN, EVERY_CONJ, EL_MAP, MEM_EL] >> @@ -1649,7 +1757,7 @@ Proof rename1 ‘exp_rel y1 y2’ >> qabbrev_tac ‘handler = (FLAT (MAP2 unfold_Delay_Lam g (ZIP (vL,bL))))’ >> Cases_on ‘eval_to (k - 1) (subst_funs binds y1) = INL Diverge’ >> gs [] - >>~[‘($= +++ v_rel) (INL Diverge) _’] + >>~ [‘($= +++ v_rel) (INL Diverge) _’] >- (qexists_tac ‘0’ >> Cases_on ‘eval_to k y = INL Diverge’ >> gs [] >> dxrule_then (qspecl_then [‘j + k’] assume_tac) eval_to_mono >> gvs [] >> @@ -1668,7 +1776,9 @@ Proof gvs [boundvars_def, SUBSET_DEF]) >> Cases_on ‘eval_to (k - 1) (subst_funs handler y2) = INL Diverge’ >> gvs [subst_funs_def] >> rename1 ‘j2 + k - 1’ >> - drule_then (qspecl_then [‘j2 + k - 1’] assume_tac) eval_to_mono >> gvs []) + drule_then (qspecl_then [‘j2 + k - 1’] assume_tac) eval_to_mono >> gvs [] >> + Cases_on `eval_to (k − 1) + (subst (MAP (λ(g,x). (g,Recclosure handler g)) handler) y2)` >> gvs []) >- (qexists_tac ‘0’ >> Cases_on ‘eval_to k y = INL Diverge’ >> gs [] >> dxrule_then (qspecl_then [‘j + k’] assume_tac) eval_to_mono >> gvs [] >> @@ -1685,9 +1795,14 @@ Proof >- (rpt $ last_x_assum $ drule_then $ qspecl_then [‘n1’] assume_tac >> dxrule_then assume_tac exp_rel_boundvars >> strip_tac >> gvs [boundvars_def, SUBSET_DEF]) >> - Cases_on ‘eval_to (k - 1) (subst_funs handler y2) = INL Diverge’ >> - gvs [subst_funs_def] >> rename1 ‘j2 + k - 1’ >> - drule_then (qspecl_then [‘j2 + k - 1’] assume_tac) eval_to_mono >> gvs []) >> + Cases_on ‘eval_to (k - 1) (subst_funs handler y2)’ >> gvs [] >> + rpt (IF_CASES_TAC >> gvs []) >> + gvs [subst_funs_def] >> + `eval_to (k − 1) + (subst + (MAP (λ(g,x). (g,Recclosure handler g)) handler) + y2) ≠ INL Diverge` by gvs [] >> + drule_then (qspecl_then [‘j' + k - 1’] assume_tac) eval_to_mono >> gvs []) >> Q.REFINE_EXISTS_TAC ‘j1 + j’ >> ‘∀i. eval_to (i + j + k) y = eval_to (j + k) y’ by (gen_tac >> irule eval_to_mono >> gvs []) >> @@ -1710,7 +1825,9 @@ Proof Cases_on ‘eval_to (j1 + k - 1) (subst_funs handler y2)’ >> Cases_on ‘eval_to (k - 1) (subst_funs binds y1)’ >> gvs []) >> - qexists_tac ‘j1’ >> gvs []) + qexists_tac ‘j1’ >> gvs [] >> + rw [oneline sum_bind_def] >> rpt (CASE_TAC >> gvs []) >> + drule v_rel_anyThunk >> rw []) >- (qspecl_then [‘y1’, ‘λx. T’, ‘y2’, ‘binds’, ‘g’, ‘vL’, ‘bL’] assume_tac exp_rel_subst_Letrec >> gvs [EVERY_CONJ, GSYM LAMBDA_PROD, FILTER_T, LIST_REL_EL_EQN, @@ -1727,7 +1844,11 @@ Proof Cases_on ‘eval_to (j1 + k - 1) (subst_funs handler y2)’ >> Cases_on ‘eval_to (k - 1) (subst_funs binds y1)’ >> gvs []) >> - qexists_tac ‘j1’ >> gvs [])) + qexists_tac ‘j1’ >> gvs [] >> + Cases_on ‘eval_to (k - 1) (subst_funs binds y1)’ >> gvs [] >> + Cases_on ‘eval_to (j1 + k - 1) (subst_funs handler y2)’ >> gvs [] >> + rpt (IF_CASES_TAC >> gvs []) >> + drule v_rel_anyThunk \\ rw [])) >- (rename [‘LIST_REL _ (MAP SND xs) (MAP SND ys)’] \\ ‘∀s. OPTREL exp_rel (ALOOKUP (REVERSE xs) s) (ALOOKUP (REVERSE ys) s)’ by (gen_tac \\ irule LIST_REL_OPTREL @@ -1743,8 +1864,26 @@ Proof \\ gvs [] \\ rename1 ‘exp_rel x0 _’ \\ Cases_on ‘x0’ \\ gvs [exp_rel_def] + \\ Cases_on ‘eval_to (k - 1) (subst_funs ys y')’ \\ gvs [] + \\ rpt (IF_CASES_TAC \\ gvs []) + >>~- ([‘is_anyThunk’], + last_x_assum $ qspecl_then [‘e’, ‘binds’, ‘subst_funs ys y'`] mp_tac + \\ simp [] \\ rpt strip_tac + >- ( + gvs [subst_funs_def] \\ irule exp_rel_subst + \\ gvs [MAP_MAP_o, combinTheory.o_DEF, LAMBDA_PROD, + GSYM FST_THM, GSYM SND_THM, LIST_REL_EL_EQN] + \\ rw [EL_MAP] + \\ rpt (pairarg_tac \\ gvs []) + \\ simp [v_rel_def] \\ disj1_tac + \\ gvs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] + \\ last_x_assum drule \\ rw []) + \\ ‘eval_to (k − 1) (subst_funs ys y') ≠ INL Diverge’ by gvs [] + \\ drule_then (qspec_then ‘j' + k - 1’ assume_tac) eval_to_mono + \\ gvs []) + \\ last_x_assum $ qspecl_then [‘e’, ‘binds’, ‘subst_funs ys y'’] mp_tac + \\ simp [] \\ rename1 ‘_ (INL Diverge) (eval_to _ (subst_funs binds2 y2))’ - \\ last_x_assum $ qspecl_then [‘e’, ‘binds’, ‘subst_funs binds2 y2’] mp_tac \\ impl_tac >- (gvs [subst_funs_def] \\ irule exp_rel_subst \\ gvs [MAP_MAP_o, combinTheory.o_DEF, LAMBDA_PROD, @@ -1762,6 +1901,7 @@ Proof \\ gvs [v_rel_def, LIST_REL_EL_EQN]) \\ disch_then $ qx_choose_then ‘j1’ assume_tac \\ Cases_on ‘eval_to (k - 1) (subst_funs binds2 y2) = INL Diverge’ \\ gs [] + \\ ‘eval_to (k - 1) (subst_funs binds2 y2) ≠ INL Diverge’ by gvs [] \\ drule_then (qspecl_then [‘j1 + k - 1’] assume_tac) eval_to_mono \\ gvs []) \\ Q.REFINE_EXISTS_TAC ‘j1 + j’ @@ -1773,7 +1913,8 @@ Proof \\ gvs [] \\ rename1 ‘exp_rel x0 _’ \\ Cases_on ‘x0’ \\ gvs [exp_rel_def] - \\ rename1 ‘_ (eval_to _ (subst_funs binds y1)) (eval_to _ (subst_funs binds2 y2))’ + \\ rename1 ‘eval_to (k - 1) (subst_funs binds y1)’ + \\ rename1 ‘eval_to (j + _ - 1) (subst_funs binds2 y2)’ \\ last_x_assum $ qspecl_then [‘y1’, ‘binds’, ‘subst_funs binds2 y2’] mp_tac \\ impl_tac >- (gvs [subst_funs_def] \\ irule exp_rel_subst @@ -1795,7 +1936,9 @@ Proof = eval_to (j1 + k - 1) (subst_funs binds2 y2)’ by (irule eval_to_mono \\ gvs [] \\ strip_tac \\ Cases_on ‘eval_to (k - 1) (subst_funs binds y1)’ \\ gs []) - \\ gvs []) + \\ gvs [] + \\ rw [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) + \\ drule v_rel_anyThunk \\ rw []) \\ rename1 ‘dest_anyThunk v1 = INR (wx, binds)’ \\ ‘∃wx' binds'. dest_anyThunk w1 = INR (wx', binds') ∧ exp_rel wx wx' ∧ @@ -1839,7 +1982,8 @@ Proof \\ reverse CASE_TAC >- ( Cases_on ‘v1’ \\ Cases_on ‘w1’ \\ gvs [dest_anyThunk_def]) - \\ qexists_tac ‘j2’ \\ gs []) + \\ qexists_tac ‘j2’ \\ gs [] + \\ rw [oneline sum_bind_def] \\ CASE_TAC \\ gvs []) \\ ‘eval_to (j2 + k - 1) (subst_funs binds' x2) ≠ INL Diverge’ by (strip_tac \\ Cases_on ‘eval_to (k - 1) (subst_funs binds x1)’ \\ gs []) @@ -1848,7 +1992,9 @@ Proof by (irule eval_to_mono \\ gs []) \\ qexists_tac ‘j2 + j1 + j’ \\ gs [] \\ CASE_TAC \\ gs [] - \\ Cases_on ‘v1’ \\ Cases_on ‘w1’ \\ gvs [dest_anyThunk_def]) + \\ Cases_on ‘v1’ \\ Cases_on ‘w1’ \\ gvs [dest_anyThunk_def] + \\ rw [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) + \\ drule v_rel_anyThunk \\ rw []) \\ rename1 ‘dest_Tick v1 = SOME v2’ \\ ‘∃w2. dest_Tick w1 = SOME w2 ∧ v_rel v2 w2’ by (Cases_on ‘v1’ \\ Cases_on ‘w1’ \\ gvs [v_rel_def]) @@ -1884,7 +2030,12 @@ Proof disch_then (qx_choose_then ‘j’ assume_tac) \\ qexists_tac ‘j’ \\ gs [SF ETA_ss] \\ Cases_on ‘result_map (eval_to k) xs’ - \\ Cases_on ‘result_map (eval_to (j + k)) ys’ \\ gs [v_rel_def]) + \\ Cases_on ‘result_map (eval_to (j + k)) ys’ \\ gs [v_rel_def] + \\ rpt (CASE_TAC \\ gvs []) + >- simp [v_rel_def] + \\ gvs [EVERY_EL, EXISTS_MEM, MEM_EL, LIST_REL_EL_EQN] + \\ ntac 2 (first_x_assum drule \\ rpt strip_tac) + \\ drule v_rel_anyThunk \\ rw []) \\ gvs [result_map_def, MEM_EL, PULL_EXISTS, EL_MAP, SF CONJ_ss] \\ IF_CASES_TAC \\ gs [] >- ( diff --git a/compiler/backend/passes/proofs/thunk_Let_Delay_VarScript.sml b/compiler/backend/passes/proofs/thunk_Let_Delay_VarScript.sml index 8ef4ac10..a5bb0e06 100644 --- a/compiler/backend/passes/proofs/thunk_Let_Delay_VarScript.sml +++ b/compiler/backend/passes/proofs/thunk_Let_Delay_VarScript.sml @@ -1794,9 +1794,104 @@ Proof fs [] QED +Theorem v_rel_anyThunk: + ∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w) +Proof + ‘(∀v w. exp_rel v w ⇒ T) ∧ + (∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w))’ + suffices_by gvs [] + \\ ho_match_mp_tac exp_rel_strongind \\ rw [] \\ gvs [SF ETA_ss] + \\ rw [is_anyThunk_def, dest_anyThunk_def] + >- ( + gvs [AllCaseEqs(), PULL_EXISTS] + \\ iff_tac \\ rw [] + >- ( + ‘MAP FST (REVERSE f) = MAP FST (REVERSE g)’ by gvs [MAP_EQ_EVERY2] + \\ drule_all ALOOKUP_SOME_EL_2 \\ rw [] + \\ gvs [LIST_REL_EL_EQN, EL_MAP, EL_REVERSE] + \\ ‘PRE (LENGTH g - n') < LENGTH g’ by gvs [] + \\ last_x_assum drule \\ rw [] + \\ rgs [Once exp_rel_cases]) + >- ( + ‘MAP FST (REVERSE g) = MAP FST (REVERSE f)’ + by gvs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] + \\ drule_all ALOOKUP_SOME_EL_2 \\ rw [] + \\ gvs [LIST_REL_EL_EQN, EL_MAP, EL_REVERSE] + \\ ‘PRE (LENGTH g - n') < LENGTH g’ by gvs [] + \\ last_x_assum drule \\ rw [] + \\ rgs [Once exp_rel_cases])) + >- ( + gvs [AllCaseEqs(), PULL_EXISTS] + \\ iff_tac \\ rw [] + >- ( + gvs [AllCaseEqs(), PULL_EXISTS] + \\ drule ALOOKUP_SOME_REVERSE_EL \\ rw [] + \\ gvs [LIST_REL_EL_EQN, EL_MAP] + \\ last_x_assum drule \\ rw [Once exp_rel_cases] + \\ ‘ALL_DISTINCT (MAP FST ( + REVERSE (MAP (λ(v,e). (v,replace_Force (Var v2) v1 e)) g)))’ + by gvs [MAP_REVERSE, MAP_MAP_o, combinTheory.o_DEF, LAMBDA_PROD, + GSYM FST_THM] + \\ ‘∃y'. MEM (n,Delay y') (REVERSE (MAP (λ(v,e). + (v,replace_Force (Var v2) v1 e)) g))’ by ( + gvs [MEM_REVERSE, MEM_MAP] + \\ qrefinel [‘_’, ‘(n,Delay y)’] \\ simp [replace_Force_def] + \\ gvs [MEM_EL, MAP_EQ_EVERY2, LIST_REL_EL_EQN] + \\ qexists ‘n'’ \\ rw [] + \\ Cases_on ‘EL n' g’ \\ gvs [] + \\ last_x_assum drule \\ rw []) + \\ drule_all ALOOKUP_ALL_DISTINCT_MEM \\ gvs []) + >- ( + gvs [AllCaseEqs(), PULL_EXISTS] + \\ drule ALOOKUP_SOME_REVERSE_EL \\ rw [] + \\ gvs [EL_MAP] + \\ pairarg_tac \\ gvs [] + \\ gvs [EVERY_EL, EL_MAP, LIST_REL_EL_EQN] + \\ Cases_on ‘e’ \\ gvs [replace_Force_def, ok_bind_def] + \\ rpt (last_x_assum drule \\ gvs []) \\ rw [] + >- (Cases_on ‘v1 = s’ \\ gvs []) + \\ rgs [Once exp_rel_cases] + \\ ‘ALL_DISTINCT (MAP FST (REVERSE f))’ by gvs [MAP_REVERSE] + \\ ‘MEM (n,Delay x) (REVERSE f)’ by ( + gvs [] + \\ Cases_on ‘EL n' f’ \\ gvs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] + \\ last_x_assum drule \\ rw [MEM_EL] + \\ goal_assum drule \\ rw []) + \\ drule_all ALOOKUP_ALL_DISTINCT_MEM \\ gvs [])) +QED + +Triviality exp_rel_result_map_Diverge: + ∀xs ys k. + LENGTH xs = LENGTH ys ∧ + (∀n. n < LENGTH ys ⇒ exp_rel (EL n xs) (EL n ys)) ∧ + (∀n. n < LENGTH ys ⇒ + ∀y. exp_rel (EL n xs) y ⇒ + ∃j. ($= +++ v_rel) (eval_to (j + k) (EL n xs)) (eval_to k y)) ∧ + (∀n. n < LENGTH ys ⇒ eval_to k (EL n ys) ≠ INL Diverge) ⇒ + ∃ck. ∀n. n < LENGTH xs ⇒ eval_to ck (EL n xs) ≠ INL Diverge +Proof + Induct \\ Cases_on ‘ys’ \\ rw [] \\ gvs [] + \\ last_x_assum $ qspecl_then [‘t’, ‘k’] mp_tac \\ gvs [] + \\ impl_tac + >- (rw [] \\ rpt (first_x_assum $ qspec_then ‘SUC n’ assume_tac \\ gvs [])) + \\ rw [] + \\ pop_assum mp_tac + \\ rpt (first_x_assum $ qspec_then ‘0’ assume_tac \\ gvs []) + \\ first_x_assum drule \\ rw [] + \\ ‘eval_to (j + k) h' ≠ INL Diverge’ by ( + Cases_on ‘eval_to (j + k) h'’ \\ Cases_on ‘eval_to k h’ \\ gvs []) + \\ qexists ‘j + k + ck’ \\ rw [] + \\ simp [EL_CONS] + \\ Cases_on ‘n’ \\ gvs [] + >- (drule eval_to_mono \\ rw []) + \\ first_x_assum drule \\ rw [] + \\ drule eval_to_mono \\ rw [] +QED + Theorem exp_rel_eval_to: ∀x y. - exp_rel x y ⇒ + exp_rel x y ∧ + (∀ck. eval_to ck x ≠ INL Type_error) ⇒ ∃j. ($= +++ v_rel) (eval_to (j + k) x) (eval_to k y) Proof completeInduct_on ‘k’ @@ -1805,20 +1900,35 @@ Proof rw [Once exp_rel_cases] \\ simp [eval_to_def]) >~ [‘Value v’] >- ( - rw [Once exp_rel_cases] - \\ simp [eval_to_def]) + rw [Once exp_rel_cases] \\ simp [eval_to_def]) >~ [‘App f x’] >- ( rw [exp_rel_def] \\ gs [] \\ rename1 ‘exp_rel x y’ \\ rename1 ‘exp_rel f g’ - \\ gs [eval_to_def] - \\ first_x_assum (drule_then (qx_choose_then ‘j’ assume_tac)) \\ gs [] + \\ simp [eval_to_def] + \\ ‘∀ck. eval_to ck x ≠ INL Type_error’ by ( + qx_gen_tac ‘ck’ + \\ strip_tac + \\ first_x_assum $ qspec_then ‘ck’ assume_tac + \\ rgs [eval_to_def]) + \\ first_x_assum (drule_all_then (qx_choose_then ‘j’ assume_tac)) \\ gs [] \\ Cases_on ‘eval_to k y’ \\ gs [] - >~[‘INL err’] + >~ [‘INL err’] >- (qexists_tac ‘j’ \\ Cases_on ‘eval_to (j + k) x’ \\ gs []) \\ Cases_on ‘eval_to (j + k) x’ \\ gs [] \\ rename1 ‘v_rel v1 w1’ - \\ first_x_assum (drule_then (qx_choose_then ‘jf’ assume_tac)) \\ gs [] + \\ ‘∀ck. eval_to ck f ≠ INL Type_error’ by ( + qx_gen_tac ‘ck’ + \\ strip_tac + \\ qpat_x_assum ‘∀ck. eval_to ck (App _ _) ≠ _’ mp_tac + \\ simp [eval_to_def] + \\ ‘eval_to (j + k + ck) x = eval_to (j + k) x’ + by (irule eval_to_mono \\ gs []) + \\ ‘eval_to (j + k + ck) f = eval_to ck f’ + by (irule eval_to_mono \\ gs [] + \\ strip_tac \\ gs []) + \\ qexists_tac ‘j + k + ck’ \\ simp []) + \\ first_x_assum (drule_all_then (qx_choose_then ‘jf’ assume_tac)) \\ gs [] \\ Cases_on ‘eval_to k g = INL Diverge’ \\ gs [] >- (Cases_on ‘eval_to k f = INL Diverge’ \\ gs [] >- ( @@ -1849,7 +1959,7 @@ Proof by (strip_tac \\ irule eval_to_mono \\ gs []) \\ last_x_assum $ qspecl_then [‘k - 1’] assume_tac \\ Cases_on ‘v2’ \\ gvs [dest_anyClosure_def, v_rel_def] - >~[‘Closure s e’] + >~ [‘Closure s e’] >- (IF_CASES_TAC \\ gs [] >- (qexists_tac ‘0’ \\ Cases_on ‘eval_to 0 x = INL Diverge’ \\ gs [] @@ -1860,7 +1970,18 @@ Proof \\ rename1 ‘exp_rel e1 e2’ \\ last_x_assum $ qspecl_then [‘subst1 s v1 e1’, ‘subst1 s w1 e2’] mp_tac \\ impl_tac - >- (irule exp_rel_subst \\ gvs [LIST_REL_def]) + >- ( + irule_at Any exp_rel_subst \\ gvs [LIST_REL_def] + \\ qx_gen_tac ‘ck’ \\ strip_tac + \\ qpat_x_assum ‘∀ck. eval_to ck (App _ _) ≠ _’ mp_tac \\ simp [] + \\ qpat_x_assum ‘∀i. eval_to _ x = _’ + (qspec_then ‘1 + ck + jf’ assume_tac) + \\ qpat_x_assum ‘∀i. eval_to _ f = _’ + (qspec_then ‘1 + ck + j’ assume_tac) + \\ qexists_tac ‘1 + k + ck + j + jf’ + \\ gs [eval_to_def, dest_anyClosure_def] + \\ qpat_assum ‘_ = INL Type_error’ (SUBST1_TAC o SYM) + \\ irule eval_to_mono \\ gs []) \\ disch_then $ qx_choose_then ‘js’ assume_tac \\ Cases_on ‘eval_to (k - 1) (subst1 s w1 e2) = INL Diverge’ \\ gs [] >- (qexists_tac ‘0’ @@ -1878,7 +1999,7 @@ Proof >- (Cases_on ‘eval_to (k - 1) (subst1 s w1 e2)’ \\ gs []) \\ dxrule_then (qspecl_then [‘j + jf + js + k - 1’] assume_tac) eval_to_mono \\ gvs []) - >>~[‘Recclosure g1 s’] + >>~ [‘Recclosure g1 s’] >- (rename1 ‘LIST_REL _ (MAP SND xs) (MAP SND ys)’ \\ ‘OPTREL exp_rel (ALOOKUP (REVERSE xs) s) (ALOOKUP (REVERSE ys) s)’ @@ -1889,7 +2010,7 @@ Proof \\ first_x_assum $ qspecl_then [‘j’] assume_tac \\ first_x_assum $ qspecl_then [‘jf’] assume_tac \\ gvs []) \\ rename1 ‘exp_rel x0 y0’ \\ Cases_on ‘x0’ \\ gvs [exp_rel_def] - >~[‘subst (MAP _ ys ++ [(s2, w1)]) e2’] + >~ [‘subst (MAP _ ys ++ [(s2, w1)]) e2’] >- (Cases_on ‘k = 0’ \\ gs [] >- (qexists_tac ‘0’ \\ Cases_on ‘eval_to 0 x = INL Diverge’ \\ gs [] @@ -1900,20 +2021,32 @@ Proof \\ last_x_assum $ qspecl_then [‘subst (MAP (λ(g, x). (g, Recclosure xs g)) xs ++ [(s2, v1)]) e1’, ‘subst (MAP (λ(g, x). (g, Recclosure ys g)) ys ++ [(s2, w1)]) e2’] mp_tac \\ impl_tac - >- (irule exp_rel_subst - \\ gvs [MAP_MAP_o, combinTheory.o_DEF, LAMBDA_PROD, GSYM SND_THM, FST_THM] - \\ gvs [LIST_REL_EL_EQN, EL_MAP] \\ rw [] - \\ pairarg_tac \\ gvs [] \\ pairarg_tac \\ gvs [] - \\ gvs [v_rel_def] - \\ gvs [LIST_REL_EL_EQN, EL_MAP, GSYM FST_THM] - \\ ‘∀i. i < LENGTH ys ⇒ FST (EL i xs) = FST (EL i ys)’ - by (rw [] >> - ‘i < LENGTH xs’ by gs [] >> - dxrule_then (qspecl_then [‘FST’] assume_tac) $ GSYM EL_MAP >> - ‘i < LENGTH ys’ by gs [] >> - dxrule_then (qspecl_then [‘FST’] assume_tac) $ GSYM EL_MAP >> - rw []) - \\ first_x_assum $ dxrule_then assume_tac >> gvs []) + >- (rw [] + >- ( + irule exp_rel_subst + \\ gvs [MAP_MAP_o, combinTheory.o_DEF, LAMBDA_PROD, GSYM SND_THM, FST_THM] + \\ gvs [LIST_REL_EL_EQN, EL_MAP] \\ rw [] + \\ pairarg_tac \\ gvs [] \\ pairarg_tac \\ gvs [] + \\ gvs [v_rel_def] + \\ gvs [LIST_REL_EL_EQN, EL_MAP, GSYM FST_THM] + \\ ‘∀i. i < LENGTH ys ⇒ FST (EL i xs) = FST (EL i ys)’ + by (rw [] >> + ‘i < LENGTH xs’ by gs [] >> + dxrule_then (qspecl_then [‘FST’] assume_tac) $ GSYM EL_MAP >> + ‘i < LENGTH ys’ by gs [] >> + dxrule_then (qspecl_then [‘FST’] assume_tac) $ GSYM EL_MAP >> + rw []) + \\ first_x_assum $ dxrule_then assume_tac >> gvs []) + \\ strip_tac + \\ qpat_x_assum ‘∀ck. eval_to ck (App _ _) ≠ _’ mp_tac \\ simp [] + \\ qpat_x_assum ‘∀i. eval_to _ x = _’ + (qspec_then ‘1 + ck + jf’ assume_tac) + \\ qpat_x_assum ‘∀i. eval_to _ f = _’ + (qspec_then ‘1 + ck + j’ assume_tac) + \\ qexists ‘1 + k + ck + j + jf’ + \\ gs [eval_to_def, dest_anyClosure_def] + \\ qpat_assum ‘_ = INL Type_error’ (SUBST1_TAC o SYM) + \\ irule eval_to_mono \\ gs []) \\ disch_then $ qx_choose_then ‘js’ assume_tac \\ Cases_on ‘eval_to (k-1) (subst (MAP (λ(g,x).(g,Recclosure ys g)) ys ++ [(s2,w1)]) e2) = INL Diverge’ \\ gs [] @@ -1947,10 +2080,10 @@ Proof \\ first_x_assum $ qspecl_then [‘j’] assume_tac \\ first_x_assum $ qspecl_then [‘jf’] assume_tac \\ gvs []) \\ rename1 ‘exp_rel x0 y0’ \\ Cases_on ‘x0’ \\ gvs [exp_rel_def, replace_Force_def] - >~[‘Lam s2 y2’] + >~ [‘Lam s2 y2’] >- (IF_CASES_TAC \\ gvs [] \\ Cases_on ‘k = 0’ \\ gs [] - >>~[‘($= +++ v_rel) _ (INL Diverge)’] + >>~ [‘($= +++ v_rel) _ (INL Diverge)’] >- (qexists_tac ‘0’ \\ Cases_on ‘eval_to 0 x = INL Diverge’ \\ gs [] \\ dxrule_then (qspecl_then [‘j’] assume_tac) eval_to_mono \\ gs [] @@ -1961,29 +2094,41 @@ Proof \\ dxrule_then (qspecl_then [‘j’] assume_tac) eval_to_mono \\ gs [] \\ Cases_on ‘eval_to 0 f = INL Diverge’ \\ gs [] \\ dxrule_then (qspecl_then [‘jf’] assume_tac) eval_to_mono \\ gs []) - >~[‘subst _ (replace_Force (Var v2) v1 e2)’] + >~ [‘subst _ (replace_Force (Var v2) v1 e2)’] >- (rename1 ‘exp_rel e1 e2’ \\ last_x_assum $ qspecl_then [‘subst (MAP (λ(g, x). (g, Recclosure xs g)) xs ++ [(s2, v1')]) e1’, ‘subst (MAP (λ(g, x). (g, Recclosure (MAP (λ(v,e).(v,replace_Force (Var v2) v1 e)) ys) g)) (MAP (λ(v,e).(v,replace_Force (Var v2) v1 e)) ys) ++ [(s2, w1)]) (replace_Force (Var v2) v1 e2)’] mp_tac \\ impl_tac - >- (gvs [subst_APPEND] - \\ dxrule_then assume_tac ALOOKUP_MEM - \\ gvs [EVERY_MEM, MEM_MAP, PULL_EXISTS] - \\ rename1 ‘replace_Force (Var (FST pair)) _ _’ - \\ qspecl_then [‘e2’, ‘Var (FST pair)’, ‘v1’, ‘[(s2, w1)]’] mp_tac subst_replace_Force - \\ impl_tac - >- (first_x_assum $ dxrule_then assume_tac - \\ gvs [freevars_def, boundvars_def]) - \\ rw [subst1_def] - >- (first_x_assum $ dxrule_then assume_tac - \\ gvs [boundvars_def]) - \\ assume_tac exp_rel_subst_Recclosure \\ gs [subst_funs_def] \\ first_x_assum irule - \\ gvs [EVERY_MEM, MEM_MAP, PULL_EXISTS, boundvars_subst] - \\ qexists_tac ‘pair’ \\ gvs [exp_rel_subst] - \\ first_x_assum $ dxrule_then assume_tac - \\ gvs [boundvars_def]) + >- (rw [] + >- ( + gvs [subst_APPEND] + \\ dxrule_then assume_tac ALOOKUP_MEM + \\ gvs [EVERY_MEM, MEM_MAP, PULL_EXISTS] + \\ rename1 ‘replace_Force (Var (FST pair)) _ _’ + \\ qspecl_then [‘e2’, ‘Var (FST pair)’, ‘v1’, ‘[(s2, w1)]’] mp_tac subst_replace_Force + \\ impl_tac + >- (first_x_assum $ dxrule_then assume_tac + \\ gvs [freevars_def, boundvars_def]) + \\ rw [subst1_def] + >- (first_x_assum $ dxrule_then assume_tac + \\ gvs [boundvars_def]) + \\ assume_tac exp_rel_subst_Recclosure \\ gs [subst_funs_def] \\ first_x_assum irule + \\ gvs [EVERY_MEM, MEM_MAP, PULL_EXISTS, boundvars_subst] + \\ qexists_tac ‘pair’ \\ gvs [exp_rel_subst] + \\ first_x_assum $ dxrule_then assume_tac + \\ gvs [boundvars_def]) + \\ strip_tac + \\ qpat_x_assum ‘∀ck. eval_to ck (App _ _) ≠ _’ mp_tac \\ simp [] + \\ qpat_x_assum ‘∀i. eval_to _ x = _’ + (qspec_then ‘1 + ck + jf’ assume_tac) + \\ qpat_x_assum ‘∀i. eval_to _ f = _’ + (qspec_then ‘1 + ck + j’ assume_tac) + \\ qexists ‘1 + k + ck + j + jf’ + \\ gs [eval_to_def, dest_anyClosure_def] + \\ qpat_assum ‘_ = INL Type_error’ (SUBST1_TAC o SYM) + \\ irule eval_to_mono \\ gs []) \\ disch_then $ qx_choose_then ‘js’ assume_tac \\ qabbrev_tac ‘ys2 = MAP (λ(v,e). (v,replace_Force (Var v2) v1 e)) ys’ \\ Cases_on ‘eval_to (k-1) (subst (MAP (λ(g,x).(g,Recclosure ys2 g)) ys2 ++ [(s2,w1)]) @@ -2014,15 +2159,27 @@ Proof \\ last_x_assum $ qspecl_then [‘subst (MAP (λ(g, x). (g, Recclosure xs g)) xs ++ [(vname, v1)]) e1’, ‘subst (MAP (λ(g, x). (g, Recclosure ys2 g)) ys2 ++ [(vname, w1)]) e2’] mp_tac \\ impl_tac - >- (irule exp_rel_subst - \\ unabbrev_all_tac - \\ gvs [MAP_MAP_o, combinTheory.o_DEF, LAMBDA_PROD, GSYM SND_THM, GSYM FST_THM] - \\ gvs [LIST_REL_EL_EQN, EL_MAP] \\ rw [] - \\ pairarg_tac \\ gvs [] \\ pairarg_tac \\ gvs [] - \\ rename1 ‘n < _’ - \\ ‘EL n (MAP FST xs) = EL n (MAP FST ys)’ by gvs [] \\ gvs [EL_MAP] - \\ irule v_rel_Recclosure_Delay_Var - \\ gvs [LIST_REL_EL_EQN, EL_MAP]) + >- (rw [] + >- ( + irule exp_rel_subst + \\ unabbrev_all_tac + \\ gvs [MAP_MAP_o, combinTheory.o_DEF, LAMBDA_PROD, GSYM SND_THM, GSYM FST_THM] + \\ gvs [LIST_REL_EL_EQN, EL_MAP] \\ rw [] + \\ pairarg_tac \\ gvs [] \\ pairarg_tac \\ gvs [] + \\ rename1 ‘n < _’ + \\ ‘EL n (MAP FST xs) = EL n (MAP FST ys)’ by gvs [] \\ gvs [EL_MAP] + \\ irule v_rel_Recclosure_Delay_Var + \\ gvs [LIST_REL_EL_EQN, EL_MAP]) + \\ strip_tac + \\ qpat_x_assum ‘∀ck. eval_to ck (App _ _) ≠ _’ mp_tac \\ simp [] + \\ qpat_x_assum ‘∀i. eval_to _ x = _’ + (qspec_then ‘1 + ck + jf’ assume_tac) + \\ qpat_x_assum ‘∀i. eval_to _ f = _’ + (qspec_then ‘1 + ck + j’ assume_tac) + \\ qexists ‘1 + k + ck + j + jf’ + \\ gs [eval_to_def, dest_anyClosure_def] + \\ qpat_assum ‘_ = INL Type_error’ (SUBST1_TAC o SYM) + \\ irule eval_to_mono \\ gs []) \\ disch_then $ qx_choose_then ‘js’ assume_tac \\ Cases_on ‘eval_to (k-1) (subst (MAP (λ(g,x).(g,Recclosure ys2 g)) ys2 ++ [(vname,w1)]) e2) = INL Diverge’ @@ -2045,7 +2202,7 @@ Proof \\ gs []) \\ dxrule_then (qspecl_then [‘j + jf + js + k - 1’] assume_tac) eval_to_mono \\ gvs []) - >>~[‘Let opt _ _’] + >>~ [‘Let opt _ _’] >- (qexists_tac ‘j + jf’ \\ first_x_assum $ qspecl_then [‘j’] assume_tac \\ first_x_assum $ qspecl_then [‘jf’] assume_tac \\ gvs [] @@ -2055,7 +2212,7 @@ Proof \\ first_x_assum $ qspecl_then [‘j’] assume_tac \\ first_x_assum $ qspecl_then [‘jf’] assume_tac \\ gvs [] \\ IF_CASES_TAC \\ gvs []) - >>~[‘Letrec _ (replace_Force (Var v2) vname1 _)’] + >>~ [‘Letrec _ (replace_Force (Var v2) vname1 _)’] >- (qexists_tac ‘j + jf’ \\ first_x_assum $ qspecl_then [‘j’] assume_tac \\ first_x_assum $ qspecl_then [‘jf’] assume_tac \\ gvs [] @@ -2064,7 +2221,7 @@ Proof \\ first_x_assum $ qspecl_then [‘j’] assume_tac \\ first_x_assum $ qspecl_then [‘jf’] assume_tac \\ gvs [] \\ IF_CASES_TAC \\ gvs []) - >~[‘replace_Force _ _ (Force y2)’] + >~ [‘replace_Force _ _ (Force y2)’] >- (qexists_tac ‘j + jf’ \\ first_x_assum $ qspecl_then [‘j’] assume_tac \\ first_x_assum $ qspecl_then [‘jf’] assume_tac \\ gvs [] @@ -2087,8 +2244,33 @@ Proof \\ rename1 ‘exp_rel x x2’ \\ rename1 ‘exp_rel y y2’ \\ last_x_assum $ qspecl_then [‘k - 1’] assume_tac \\ last_x_assum kall_tac \\ last_x_assum kall_tac \\ gvs [] - \\ last_assum $ dxrule_then $ qx_choose_then ‘j1’ assume_tac - \\ last_x_assum $ dxrule_then $ qx_choose_then ‘j2’ assume_tac + \\ ‘∀ck. eval_to ck x ≠ INL Type_error’ by ( + qx_gen_tac ‘ck’ + \\ strip_tac + \\ qpat_x_assum ‘∀ck. eval_to _ (Seq _ _) ≠ INL Type_error’ + $ qspec_then ‘ck + 1’ mp_tac + \\ simp [eval_to_def]) + \\ last_assum $ drule_all_then $ qx_choose_then ‘j1’ assume_tac + \\ Cases_on ‘eval_to (k - 1) x2 = INL Diverge’ \\ gvs [] + >- ( + Cases_on ‘eval_to (j1 + k - 1) x’ \\ gvs [] + \\ qexists ‘j1’ \\ gvs []) + \\ Cases_on ‘eval_to (j1 + k - 1) x’ \\ gvs [] + >- ( + Cases_on ‘x'’ \\ gvs [] + \\ Cases_on ‘eval_to (k - 1) x2’ \\ gvs []) + \\ Cases_on ‘eval_to (k - 1) x2’ \\ gvs [] + \\ ‘∀ck. eval_to ck y ≠ INL Type_error’ by ( + qx_gen_tac ‘ck’ + \\ strip_tac + \\ ‘eval_to (j1 + k - 1 + ck) x = eval_to (j1 + k - 1) x’ by ( + irule eval_to_mono \\ gvs []) \\ gvs [] + \\ ‘eval_to (j1 + k - 1 + ck) y = eval_to ck y’ by ( + irule eval_to_mono \\ gvs []) \\ gvs [] + \\ qpat_x_assum ‘∀ck. eval_to _ (Seq _ _) ≠ INL Type_error’ + $ qspec_then ‘j1 + k + ck’ mp_tac + \\ simp [eval_to_def]) + \\ last_x_assum $ dxrule_all_then $ qx_choose_then ‘j2’ assume_tac \\ rename1 ‘eval_to (jx + k - 1) x’ \\ rename1 ‘eval_to (jy + k - 1) y’ \\ Cases_on ‘eval_to (k - 1) x2’ @@ -2110,7 +2292,7 @@ Proof \\ qexists_tac ‘jx + jy’ \\ gvs []) >~ [‘Let (SOME n) x y’] >- ( rw [exp_rel_def] \\ gs [] - >~[‘Delay (Var v1)’] + >~ [‘Delay (Var v1)’] >- (gvs [eval_to_def] \\ IF_CASES_TAC \\ gs [] >- (qexists_tac ‘0’ \\ gs []) @@ -2120,9 +2302,14 @@ Proof \\ last_x_assum kall_tac \\ last_x_assum kall_tac \\ gs [] \\ rename1 ‘exp_rel x x2’ \\ first_x_assum $ qspecl_then [‘x’, ‘x2’] assume_tac \\ gs [] + \\ ‘∀ck. eval_to ck x ≠ INL Type_error’ by ( + qx_gen_tac ‘ck’ + \\ strip_tac + \\ qpat_x_assum ‘∀ck. _ ≠ INL Type_error’ $ qspec_then ‘ck + 1’ mp_tac + \\ simp []) \\ gvs [] \\ rename1 ‘j + k - 1’ \\ Cases_on ‘eval_to (k - 1) x2’ - >~[‘INL err’] + >~ [‘INL err’] >- (qexists_tac ‘j’ \\ Cases_on ‘eval_to (j + k - 1) x’ \\ gvs []) \\ gvs [] \\ CASE_TAC \\ gs [] @@ -2138,11 +2325,22 @@ Proof \\ first_x_assum $ qspecl_then [‘subst1 w (Thunk (Value val1)) (subst1 v val1 y)’, ‘subst1 w (Thunk (Value val2)) (subst1 v val2 (replace_Force (Var v) w y2))’] mp_tac \\ impl_tac - >- (qspecl_then [‘y2’, ‘Var v’, ‘w’, ‘[(v, val2)]’] assume_tac subst_replace_Force - \\ drule_then assume_tac exp_rel_freevars - \\ gvs [subst1_notin_frees, subst_def, freevars_def] - \\ gvs [freevars_def, subst_def] - \\ gvs [exp_rel_subst_replace_Force]) + >- (rw [] + >- ( + qspecl_then [‘y2’, ‘Var v’, ‘w’, ‘[(v, val2)]’] assume_tac subst_replace_Force + \\ drule_then assume_tac exp_rel_freevars + \\ gvs [subst1_notin_frees, subst_def, freevars_def] + \\ gvs [freevars_def, subst_def] + \\ gvs [exp_rel_subst_replace_Force]) + \\ strip_tac + \\ ntac 2 (qpat_x_assum ‘∀ck. _ ≠ INL Type_error’ mp_tac) + \\ disch_then $ qspec_then ‘j + k + ck + 2’ mp_tac \\ rpt strip_tac + \\ gvs [] + \\ ‘eval_to (ck + j + k + 1) x = eval_to (j + k - 1) x’ by ( + irule eval_to_mono \\ gvs []) \\ gvs [] + \\ qpat_x_assum ‘eval_to _ _ ≠ INL Type_error’ mp_tac \\ rw [] + \\ qpat_assum ‘_ = INL Type_error’ (SUBST1_TAC o SYM) + \\ irule eval_to_mono \\ gvs []) \\ disch_then $ qx_choose_then ‘j1’ assume_tac \\ Cases_on ‘eval_to (k − 2) (subst1 w (Thunk (Value val2)) (subst1 v val2 (replace_Force (Var v) w y2))) = INL Diverge’ @@ -2169,14 +2367,30 @@ Proof \\ last_x_assum $ qspecl_then [‘k - 1’] assume_tac \\ last_x_assum kall_tac \\ last_x_assum kall_tac \\ gvs [] \\ first_assum $ qspecl_then [‘x’, ‘x2’] mp_tac - \\ impl_tac >- gvs [] + \\ impl_tac >- ( + gvs [] + \\ qx_gen_tac ‘ck’ + \\ strip_tac + \\ qpat_x_assum ‘∀ck. eval_to _ (Let _ _ _) ≠ INL Type_error’ + $ qspec_then ‘ck + 1’ mp_tac + \\ simp [eval_to_def]) \\ disch_then $ qx_choose_then ‘j1’ assume_tac \\ Cases_on ‘eval_to (k - 1) x2’ \\ gs [] >- (qexists_tac ‘j1’ \\ Cases_on ‘eval_to (j1 + k - 1) x’ \\ gs []) \\ Cases_on ‘eval_to (j1 + k - 1) x’ \\ gs [] \\ rename1 ‘v_rel v1 v2’ \\ first_x_assum $ qspecl_then [‘subst1 n v1 y’, ‘subst1 n v2 y2’] mp_tac - \\ impl_tac >- gvs [exp_rel_subst] + \\ impl_tac >- ( + gvs [exp_rel_subst] + \\ qx_gen_tac ‘ck’ + \\ strip_tac + \\ qpat_x_assum ‘∀ck. eval_to _ (Let _ _ _) ≠ INL Type_error’ + $ qspec_then ‘j1 + k + ck + 1’ mp_tac + \\ simp [eval_to_def] + \\ ‘eval_to (ck + j1 + k) x = eval_to (j1 + k - 1) x’ by ( + irule eval_to_mono \\ gvs []) \\ gvs [] + \\ qpat_assum ‘_ = INL Type_error’ (SUBST1_TAC o SYM) + \\ irule eval_to_mono \\ gvs []) \\ disch_then $ qx_choose_then ‘j2’ assume_tac \\ Cases_on ‘eval_to (k - 1) (subst1 n v2 y2) = INL Diverge’ \\ gs [] >- (qexists_tac ‘0’ @@ -2200,6 +2414,12 @@ Proof >- (qexists_tac ‘0’ >> gs []) \\ last_x_assum $ qspecl_then [‘k - 1’] assume_tac \\ gvs [] \\ first_x_assum irule + \\ rw [] + >- ( + strip_tac + \\ qpat_x_assum ‘∀ck. eval_to _ (Letrec _ _) ≠ INL Type_error’ + $ qspec_then ‘ck + 1’ mp_tac + \\ simp [eval_to_def]) \\ simp [subst_funs_def, closed_subst, MAP_MAP_o, combinTheory.o_DEF, LAMBDA_PROD, GSYM FST_THM] \\ irule exp_rel_subst @@ -2219,6 +2439,12 @@ Proof >- (qexists_tac ‘0’ \\ gs []) \\ last_x_assum $ qspecl_then [‘k - 1’] assume_tac \\ gvs [] \\ first_x_assum irule + \\ rw [] + >- ( + strip_tac + \\ qpat_x_assum ‘∀ck. eval_to _ (Letrec _ _) ≠ INL Type_error’ + $ qspec_then ‘ck + 1’ mp_tac + \\ simp [eval_to_def]) \\ irule exp_rel_subst_Recclosure \\ gvs [])) >~ [‘If x1 y1 z1’] >- ( @@ -2230,9 +2456,13 @@ Proof \\ last_x_assum $ qspecl_then [‘k - 1’] assume_tac \\ gvs [] \\ last_x_assum kall_tac \\ last_x_assum kall_tac \\ last_x_assum kall_tac \\ rpt $ first_assum $ dxrule_then assume_tac + \\ last_x_assum assume_tac \\ last_x_assum kall_tac \\ last_x_assum kall_tac \\ gvs [] - \\ rename1 ‘eval_to (j2 + k - 1) z1’ - \\ rename1 ‘eval_to (j1 + k - 1) y1’ + \\ ‘∀ck. eval_to ck x1 ≠ INL Type_error’ by ( + qx_gen_tac ‘ck’ + \\ strip_tac + \\ first_x_assum $ qspec_then ‘ck + 1’ mp_tac + \\ simp []) \\ gvs [] \\ rename1 ‘eval_to (j + k - 1) x1’ \\ Cases_on ‘eval_to (k - 1) x2’ \\ Cases_on ‘eval_to (j + k - 1) x1’ \\ gs [] @@ -2240,7 +2470,20 @@ Proof \\ rename1 ‘v_rel v1 w1’ \\ IF_CASES_TAC \\ gvs [v_rel_def] >- ( - Cases_on ‘eval_to (k - 1) y2 = INL Diverge’ \\ gs [] + Cases_on ‘v1’ \\ gvs [v_rel_def] + \\ ‘∀ck. eval_to ck y1 ≠ INL Type_error’ by ( + qx_gen_tac ‘ck’ + \\ strip_tac + \\ ntac 2 (qpat_x_assum ‘∀ck. _ ≠ INL Type_error’ mp_tac) + \\ disch_then $ qspec_then ‘ck + j + k + 1’ mp_tac \\ rpt strip_tac + \\ gvs [] + \\ ‘eval_to (ck + j + k) x1 = eval_to (j + k - 1) x1’ by ( + irule eval_to_mono \\ gvs []) \\ gvs [] + \\ qpat_x_assum ‘eval_to _ y1 ≠ INL Type_error’ mp_tac \\ rw [] + \\ qpat_assum ‘_ = INL Type_error’ (SUBST1_TAC o SYM) + \\ irule eval_to_mono \\ gvs []) \\ gvs [] + \\ rename1 ‘eval_to (j1 + k - 1) y1’ + \\ Cases_on ‘eval_to (k - 1) y2 = INL Diverge’ \\ gs [] >- ( Cases_on ‘eval_to (k - 1) x1 = INL Diverge’ \\ gs [] >- ( @@ -2248,18 +2491,29 @@ Proof \\ gs []) \\ ‘∀i. eval_to (i + k - 1) x1 = eval_to (k - 1) x1’ by (strip_tac \\ irule eval_to_mono \\ gs []) - \\ qexists_tac ‘j1’ \\ gs [] - \\ Cases_on ‘v1’ \\ gs [v_rel_def]) + \\ qexists_tac ‘j1’ \\ gs []) \\ ‘eval_to (j1 + k - 1) y1 ≠ INL Diverge’ by (strip_tac \\ Cases_on ‘eval_to (k - 1) y2’ \\ gs []) \\ ‘eval_to (j1 + j + k - 1) x1 = eval_to (j + k - 1) x1’ by (irule eval_to_mono \\ gs []) \\ drule_then (qspec_then ‘j + j1 + k - 1’ assume_tac) eval_to_mono - \\ qexists_tac ‘j1 + j’ \\ gs [] - \\ Cases_on ‘v1’ \\ gs [v_rel_def]) + \\ qexists_tac ‘j1 + j’ \\ gs []) \\ IF_CASES_TAC \\ gvs [v_rel_def] >- ( - Cases_on ‘eval_to (k - 1) z2 = INL Diverge’ \\ gs [] + Cases_on ‘v1’ \\ gvs [v_rel_def] + \\ ‘∀ck. eval_to ck z1 ≠ INL Type_error’ by ( + qx_gen_tac ‘ck’ + \\ strip_tac + \\ ntac 2 (qpat_x_assum ‘∀ck. _ ≠ INL Type_error’ mp_tac) + \\ disch_then $ qspec_then ‘ck + j + k + 1’ mp_tac \\ rpt strip_tac + \\ gvs [] + \\ ‘eval_to (ck + j + k) x1 = eval_to (j + k - 1) x1’ by ( + irule eval_to_mono \\ gvs []) \\ gvs [] + \\ qpat_x_assum ‘eval_to _ z1 ≠ INL Type_error’ mp_tac \\ rw [] + \\ qpat_assum ‘_ = INL Type_error’ (SUBST1_TAC o SYM) + \\ irule eval_to_mono \\ gvs []) \\ gvs [] + \\ rename1 ‘eval_to (j2 + k - 1) z1’ + \\ Cases_on ‘eval_to (k - 1) z2 = INL Diverge’ \\ gs [] >- ( Cases_on ‘eval_to (k - 1) x1 = INL Diverge’ \\ gs [] >- ( @@ -2267,31 +2521,41 @@ Proof \\ gs []) \\ ‘∀i. eval_to (i + k - 1) x1 = eval_to (k - 1) x1’ by (strip_tac \\ irule eval_to_mono \\ gs []) - \\ qexists_tac ‘j2’ \\ Cases_on ‘v1’ \\ gs [v_rel_def]) + \\ qexists_tac ‘j2’ \\ gvs []) \\ ‘eval_to (j2 + k - 1) z1 ≠ INL Diverge’ by (strip_tac \\ Cases_on ‘eval_to (k - 1) z2’ \\ gs []) \\ ‘eval_to (j2 + j + k - 1) x1 = eval_to (j + k - 1) x1’ by (irule eval_to_mono \\ gs []) \\ drule_then (qspec_then ‘j + j2 + k - 1’ assume_tac) eval_to_mono - \\ qexists_tac ‘j2 + j’ \\ Cases_on ‘v1’ \\ gs [v_rel_def]) + \\ qexists_tac ‘j2 + j’ \\ gvs []) \\ qexists_tac ‘j’ \\ gs [] \\ Cases_on ‘v1’ \\ Cases_on ‘w1’ \\ gs [v_rel_def] \\ IF_CASES_TAC \\ gvs [] \\ IF_CASES_TAC \\ gvs []) >~ [‘Force x’] >- ( rw [exp_rel_def] \\ gs [] - >~[‘Force (Value (Recclosure _ _))’] - >- (once_rewrite_tac [eval_to_def] >> - qexists_tac ‘1’ >> gvs [] >> - rw [Once eval_to_def, dest_anyThunk_def] >> + >~ [‘Force (Value (Recclosure _ _))’] + >- (qpat_x_assum ‘∀ck. eval_to _ _ ≠ INL Type_error’ mp_tac >> + disch_then $ qspec_then ‘k + 1’ mp_tac >> + ntac 2 (simp [Once eval_to_def]) >> + simp [dest_anyThunk_def] >> rename1 ‘MEM (v1, Delay (Var v2)) f’ >> qspecl_then [‘Delay (Var v2)’, ‘v1’, ‘REVERSE f’] assume_tac $ GEN_ALL ALOOKUP_ALL_DISTINCT_MEM >> gvs [MAP_REVERSE, ALL_DISTINCT_REVERSE, subst_funs_def, subst_def] >> - qspecl_then [‘f’, ‘Recclosure f’, ‘v2’] assume_tac ALOOKUP_FUN >> gvs [eval_to_def] >> + qspecl_then [‘f’, ‘Recclosure f’, ‘v2’] assume_tac ALOOKUP_FUN >> + rw [Once eval_to_def] >> + once_rewrite_tac [eval_to_def] >> + qexists_tac ‘1’ >> gvs [] >> + simp [Once eval_to_def, dest_anyThunk_def, subst_funs_def, subst_def] >> + simp [eval_to_def] >> irule v_rel_Recclosure_Delay_Var >> gvs []) - >~[‘Force (Value _)’] - >- (once_rewrite_tac [eval_to_def] + >~ [‘Force (Value _)’] + >- (qpat_x_assum ‘∀ck. eval_to _ _ ≠ INL Type_error’ mp_tac + \\ disch_then $ qspec_then ‘k + 1’ mp_tac + \\ ntac 2 (simp [Once eval_to_def]) + \\ simp [dest_anyThunk_def, subst_funs_def] \\ rw [Once eval_to_def] + \\ once_rewrite_tac [eval_to_def] \\ qexists_tac ‘1’ \\ gvs [] \\ simp [Once eval_to_def] \\ gvs [dest_anyThunk_def] @@ -2301,9 +2565,18 @@ Proof \\ IF_CASES_TAC \\ gs [] >- (qexists_tac ‘0’ \\ gs []) \\ last_x_assum $ qspecl_then [‘k - 1’] assume_tac \\ gvs [] - \\ last_x_assum $ dxrule_then $ qx_choose_then ‘j’ assume_tac + \\ ‘∀ck. eval_to ck x ≠ INL Type_error’ by ( + qx_gen_tac ‘ck’ + \\ strip_tac + \\ qpat_x_assum ‘∀ck. eval_to _ (Force _) ≠ INL Type_error’ + $ qspec_then ‘ck + 1’ mp_tac + \\ simp [Once eval_to_def] + \\ ‘eval_to (ck + 1) x = eval_to ck x’ by ( + irule eval_to_mono \\ gvs []) + \\ gvs []) \\ gvs [] + \\ last_x_assum $ dxrule_all_then $ qx_choose_then ‘j’ assume_tac \\ Cases_on ‘eval_to k y’ \\ Cases_on ‘eval_to (j + k) x’ \\ gs [] - >~[‘INL err’] + >~ [‘INL err’] >- (qexists_tac ‘j’ \\ gvs []) \\ rename1 ‘v_rel v w’ \\ Cases_on ‘dest_Tick w’ \\ gs [] @@ -2313,7 +2586,7 @@ Proof \\ gs [Once v_rel_def]) \\ gs [] \\ Cases_on ‘v’ \\ gvs [dest_anyThunk_def, v_rel_def] - >>~[‘Recclosure _ _’] + >>~ [‘Recclosure _ _’] >- (rename1 ‘LIST_REL _ (MAP SND xs) (MAP SND ys)’ \\ ‘OPTREL exp_rel (ALOOKUP (REVERSE xs) s) @@ -2323,30 +2596,44 @@ Proof \\ gs [OPTREL_def] >- (qexists_tac ‘j’ \\ gvs []) \\ CASE_TAC \\ gs [exp_rel_def] - >~[‘subst_funs ys e2’] + >~ [‘subst_funs ys e2’] >- (rename1 ‘exp_rel x0 (Delay e2)’ \\ Cases_on ‘x0’ \\ gs [exp_rel_def] \\ rename1 ‘exp_rel e1 e2’ \\ last_x_assum $ qspecl_then [‘subst_funs xs e1’, ‘subst_funs ys e2’] mp_tac \\ impl_tac - >- (gvs [subst_funs_def] \\ irule exp_rel_subst - \\ gvs [MAP_MAP_o, combinTheory.o_DEF, LAMBDA_PROD, GSYM FST_THM, LIST_REL_EL_EQN, EL_MAP] - \\ rw [] \\ pairarg_tac \\ gs [] \\ pairarg_tac \\ gs [v_rel_def, LIST_REL_EL_EQN, EL_MAP] - \\ ‘∀i. i < LENGTH xs ⇒ FST (EL i xs) = FST (EL i ys)’ - by (rw [] >> - ‘i < LENGTH xs’ by gs [] >> - dxrule_then (qspecl_then [‘FST’] assume_tac) $ GSYM EL_MAP >> - ‘i < LENGTH ys’ by gs [] >> - dxrule_then (qspecl_then [‘FST’] assume_tac) $ GSYM EL_MAP >> - rw []) - \\ gs [] \\ first_x_assum $ dxrule_then assume_tac \\ gvs []) + >- (rw [] + >- ( + gvs [subst_funs_def] \\ irule exp_rel_subst + \\ gvs [MAP_MAP_o, combinTheory.o_DEF, LAMBDA_PROD, GSYM FST_THM, LIST_REL_EL_EQN, EL_MAP] + \\ rw [] \\ pairarg_tac \\ gs [] \\ pairarg_tac \\ gs [v_rel_def, LIST_REL_EL_EQN, EL_MAP] + \\ ‘∀i. i < LENGTH xs ⇒ FST (EL i xs) = FST (EL i ys)’ + by (rw [] >> + ‘i < LENGTH xs’ by gs [] >> + dxrule_then (qspecl_then [‘FST’] assume_tac) $ GSYM EL_MAP >> + ‘i < LENGTH ys’ by gs [] >> + dxrule_then (qspecl_then [‘FST’] assume_tac) $ GSYM EL_MAP >> + rw []) + \\ gs [] \\ first_x_assum $ dxrule_then assume_tac + \\ gvs []) + \\ strip_tac + \\ qpat_x_assum ‘∀ck. eval_to _ (Force _) ≠ INL Type_error’ + $ qspec_then ‘j + k + ck + 1’ mp_tac + \\ simp [Once eval_to_def] + \\ ‘eval_to (ck + j + k + 1) x = eval_to (j + k) x’ by ( + irule eval_to_mono \\ gvs []) \\ gvs [] + \\ gvs [dest_anyThunk_def] + \\ ‘eval_to (ck + j + k) (subst_funs xs e1) = + eval_to ck (subst_funs xs e1)’ by ( + irule eval_to_mono \\ gvs []) \\ gvs []) \\ disch_then $ qx_choose_then ‘j2’ assume_tac \\ Cases_on ‘eval_to (k - 1) (subst_funs ys e2) = INL Diverge’ \\ gs [] >- (qexists_tac ‘0’ \\ Cases_on ‘eval_to k x = INL Diverge’ \\ gs [] \\ dxrule_then (qspecl_then [‘j + k’] assume_tac) eval_to_mono \\ gs [] \\ Cases_on ‘eval_to (k - 1) (subst_funs xs e1) = INL Diverge’ \\ gs [] - \\ dxrule_then (qspecl_then [‘j2 + k - 1’] assume_tac) eval_to_mono \\ gs []) + \\ dxrule_then (qspecl_then [‘j2 + k - 1’] assume_tac) eval_to_mono \\ gs [] + \\ rw [oneline sum_bind_def] \\ CASE_TAC \\ gvs []) \\ qexists_tac ‘j + j2’ \\ ‘eval_to (j + j2 + k) x = eval_to (j + k) x’ by (irule eval_to_mono \\ gvs []) \\ gvs [] @@ -2354,7 +2641,15 @@ Proof by (irule eval_to_mono \\ Cases_on ‘eval_to (j2 + k - 1) (subst_funs xs e1)’ \\ Cases_on ‘eval_to (k - 1) (subst_funs ys e2)’ \\ gvs []) - \\ gvs []) + \\ gvs [] + \\ rw [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) + >- ( + qpat_x_assum ‘∀ck. eval_to _ (Force _) ≠ INL Type_error’ + $ qspec_then ‘j + j2 + k’ mp_tac + \\ simp [Once eval_to_def] + \\ gvs [dest_anyThunk_def]) + \\ rename1 ‘v_rel v w’ + \\ drule v_rel_anyThunk \\ rw []) \\ rename1 ‘exp_rel x0 _’ \\ Cases_on ‘x0’ \\ gvs [exp_rel_def] \\ qexists_tac ‘j’ \\ gvs []) >- (rename1 ‘LIST_REL _ (MAP SND xs) (MAP SND ys)’ @@ -2392,12 +2687,24 @@ Proof ‘subst_funs (MAP (λ(v,e). (v, replace_Force (Var v2) v1 e)) ys) (replace_Force (Var v2) v1 e2)’] mp_tac \\ impl_tac - >- (irule exp_rel_subst_Recclosure - \\ gvs [EVERY_MEM] - \\ dxrule_then assume_tac ALOOKUP_MEM - \\ gvs [MEM_MAP, PULL_EXISTS] - \\ first_x_assum $ dxrule_then assume_tac - \\ gvs [boundvars_def]) + >- (rw [] + >- ( + irule exp_rel_subst_Recclosure + \\ gvs [EVERY_MEM] + \\ dxrule_then assume_tac ALOOKUP_MEM + \\ gvs [MEM_MAP, PULL_EXISTS] + \\ first_x_assum $ dxrule_then assume_tac + \\ gvs [boundvars_def]) + \\ strip_tac + \\ qpat_x_assum ‘∀ck. eval_to _ (Force _) ≠ INL Type_error’ + $ qspec_then ‘j + k + ck + 1’ mp_tac + \\ simp [Once eval_to_def] + \\ ‘eval_to (ck + j + k + 1) x = eval_to (j + k) x’ by ( + irule eval_to_mono \\ gvs []) \\ gvs [] + \\ gvs [dest_anyThunk_def] + \\ ‘eval_to (ck + j + k) (subst_funs xs e1) = + eval_to ck (subst_funs xs e1)’ by ( + irule eval_to_mono \\ gvs []) \\ gvs []) \\ disch_then $ qx_choose_then ‘j2’ assume_tac \\ Cases_on ‘eval_to (k - 1) (subst_funs (MAP (λ(v,e). (v, replace_Force (Var v2) v1 e)) ys) (replace_Force (Var v2) v1 e2)) = INL Diverge’ \\ gs [] @@ -2405,7 +2712,8 @@ Proof \\ Cases_on ‘eval_to k x = INL Diverge’ \\ gs [] \\ dxrule_then (qspecl_then [‘j + k’] assume_tac) eval_to_mono \\ gs [] \\ Cases_on ‘eval_to (k - 1) (subst_funs xs e1) = INL Diverge’ \\ gs [] - \\ dxrule_then (qspecl_then [‘j2 + k - 1’] assume_tac) eval_to_mono \\ gs []) + \\ dxrule_then (qspecl_then [‘j2 + k - 1’] assume_tac) eval_to_mono \\ gs [] + \\ rw [oneline sum_bind_def] \\ CASE_TAC \\ gvs []) \\ qexists_tac ‘j + j2’ \\ ‘eval_to (j + j2 + k) x = eval_to (j + k) x’ by (irule eval_to_mono \\ gvs []) \\ gvs [] @@ -2414,32 +2722,71 @@ Proof \\ Cases_on ‘eval_to (j2 + k - 1) (subst_funs xs e1)’ \\ Cases_on ‘eval_to (k - 1) (subst_funs (MAP (λ(v,e). (v, replace_Force (Var v2) v1 e)) ys) (replace_Force (Var v2) v1 e2))’ \\ gvs []) - \\ gvs []) + \\ gvs [] + \\ rw [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) + >- ( + qpat_x_assum ‘∀ck. eval_to _ (Force _) ≠ INL Type_error’ + $ qspec_then ‘j + j2 + k’ mp_tac + \\ simp [Once eval_to_def] + \\ gvs [dest_anyThunk_def]) + \\ rename1 ‘v_rel v w’ + \\ drule v_rel_anyThunk \\ rw []) \\ qexists_tac ‘j’ \\ gvs []) - >~[‘subst_funs [] y2’] + >~ [‘subst_funs [] y2’] >- (rename1 ‘exp_rel x2 y2’ \\ last_x_assum $ qspecl_then [‘x2’, ‘y2’] assume_tac \\ gs [subst_funs_def] + \\ ‘∀ck. eval_to ck x2 ≠ INL Type_error’ by ( + qx_gen_tac ‘ck’ + \\ strip_tac + \\ qpat_x_assum ‘∀ck. eval_to _ (Force _) ≠ INL Type_error’ + $ qspec_then ‘ck + j + k + 1’ mp_tac + \\ simp [Once eval_to_def] + \\ ‘eval_to (ck + j + k + 1) x = eval_to (j + k) x’ by ( + irule eval_to_mono \\ gvs []) \\ gvs [] + \\ gvs [dest_anyThunk_def, subst_funs_def] + \\ ‘eval_to (ck + j + k) x2 = eval_to ck x2’ by ( + irule eval_to_mono \\ gvs []) \\ gvs []) \\ gvs [] \\ rename1 ‘eval_to (j2 + k - 1) x2’ \\ Cases_on ‘eval_to (k - 1) y2 = INL Diverge’ \\ gs [] >- (qexists_tac ‘0’ \\ Cases_on ‘eval_to k x = INL Diverge’ \\ gs [] \\ dxrule_then (qspecl_then [‘j + k’] assume_tac) eval_to_mono \\ gs [] \\ Cases_on ‘eval_to (k - 1) x2 = INL Diverge’ \\ gs [] - \\ dxrule_then (qspecl_then [‘j2 + k - 1’] assume_tac) eval_to_mono \\ gs []) - \\ qexists_tac ‘j + j2’ - \\ ‘eval_to (j + j2 + k) x = eval_to (j + k) x’ by (irule eval_to_mono \\ gvs []) - \\ gvs [] - \\ ‘eval_to (j + (j2 + k) - 1) x2 = eval_to (j2 + k - 1) x2’ - by (irule eval_to_mono - \\ Cases_on ‘eval_to (j2 + k - 1) x2’ - \\ Cases_on ‘eval_to (k - 1) y2’ \\ gvs []) - \\ gvs []) + \\ dxrule_then (qspecl_then [‘j2 + k - 1’] assume_tac) eval_to_mono \\ gs [] + \\ rw [oneline sum_bind_def] \\ CASE_TAC \\ gvs []) + \\ qexists_tac ‘j + j2’ + \\ ‘eval_to (j + j2 + k) x = eval_to (j + k) x’ by (irule eval_to_mono \\ gvs []) + \\ gvs [] + \\ ‘eval_to (j + (j2 + k) - 1) x2 = eval_to (j2 + k - 1) x2’ + by (irule eval_to_mono + \\ Cases_on ‘eval_to (j2 + k - 1) x2’ + \\ Cases_on ‘eval_to (k - 1) y2’ \\ gvs []) + \\ gvs [] + \\ rw [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) + >- ( + qpat_x_assum ‘∀ck. eval_to _ (Force _) ≠ INL Type_error’ + $ qspec_then ‘j + j2 + k’ mp_tac + \\ simp [Once eval_to_def] + \\ gvs [dest_anyThunk_def, subst_funs_def]) + \\ rename1 ‘v_rel v w’ + \\ drule v_rel_anyThunk \\ rw []) \\ qexists_tac ‘j’ \\ gvs []) \\ Cases_on ‘v’ \\ gs [v_rel_def, exp_rel_def, PULL_EXISTS, dest_Tick_def] \\ rename1 ‘v_rel v2 w2’ \\ last_x_assum $ qspecl_then [‘Force (Value v2)’, ‘Force (Value w2)’] assume_tac \\ gvs [exp_rel_def] - \\ rename1 ‘v_rel v2 w2’ \\ rename1 ‘eval_to (j2 + k - 1) (Force _)’ + \\ rename1 ‘v_rel v2 w2’ + \\ ‘∀ck. eval_to ck (Force (Value v2)) ≠ INL Type_error’ by ( + qx_gen_tac ‘ck’ + \\ strip_tac + \\ qpat_x_assum ‘∀ck. eval_to _ (Force _) ≠ INL Type_error’ + $ qspec_then ‘j + k + ck + 1’ mp_tac + \\ simp [Once eval_to_def] + \\ ‘eval_to (ck + j + k + 1) x = eval_to (j + k) x’ by ( + irule eval_to_mono \\ gvs []) \\ gvs [] + \\ qpat_assum ‘_ = INL Type_error’ (SUBST1_TAC o SYM) + \\ irule eval_to_mono \\ gvs []) \\ gvs [] + \\ rename1 ‘eval_to (j2 + k - 1) (Force _)’ \\ Cases_on ‘eval_to (k - 1) (Force (Value w2)) = INL Diverge’ \\ gs [] >- (qexists_tac ‘0’ \\ Cases_on ‘eval_to k x = INL Diverge’ \\ gs [] @@ -2459,315 +2806,457 @@ Proof \\ simp [eval_to_def, v_rel_def]) >~ [‘MkTick x’] >- ( rw [exp_rel_def] \\ gs [eval_to_def] - \\ first_x_assum $ dxrule_then $ qx_choose_then ‘j’ assume_tac + \\ ‘∀ck. eval_to ck x ≠ INL Type_error’ by ( + qx_gen_tac ‘ck’ + \\ strip_tac + \\ first_x_assum $ qspec_then ‘ck’ assume_tac \\ gvs []) + \\ first_x_assum $ dxrule_all_then $ qx_choose_then ‘j’ assume_tac \\ qexists_tac ‘j’ \\ rename1 ‘($= +++ v_rel) (eval_to (j + k) x) (eval_to _ y)’ \\ Cases_on ‘eval_to (j + k) x’ \\ Cases_on ‘eval_to k y’ \\ gvs [v_rel_def]) >~ [‘Prim op xs’] >- ( - pop_assum mp_tac - \\ simp [Once exp_rel_def] - \\ rw [] - \\ gvs [eval_to_def] - \\ gvs [MEM_EL, PULL_EXISTS, LIST_REL_EL_EQN] - \\ Cases_on ‘op’ \\ gs [] + rw [Once exp_rel_cases] + \\ simp [eval_to_def] + \\ BasicProvers.TOP_CASE_TAC \\ gs [] >- ((* Cons *) - last_x_assum kall_tac - \\ ‘∃j. ($= +++ LIST_REL v_rel) (result_map (eval_to (j + k)) xs) - (result_map (eval_to k) ys)’ + qabbrev_tac ‘f = λj. eval_to (j + k)’ + \\ simp [SF ETA_ss] + \\ qmatch_goalsub_abbrev_tac ‘result_map g ys’ + \\ ‘∃j. ($= +++ (LIST_REL v_rel)) (result_map (f j) xs) (result_map g ys)’ suffices_by ( disch_then (qx_choose_then ‘j’ assume_tac) - \\ qexists_tac ‘j’ \\ gs [SF ETA_ss] - \\ Cases_on ‘result_map (eval_to k) ys’ - \\ Cases_on ‘result_map (eval_to (j + k)) xs’ \\ gs [v_rel_def]) - \\ gvs [result_map_def, MEM_EL, PULL_EXISTS, EL_MAP, SF CONJ_ss] - \\ IF_CASES_TAC \\ gs [] + \\ qexists_tac ‘j’ + \\ Cases_on ‘result_map (f j) xs’ + \\ Cases_on ‘result_map g ys’ \\ gs [] + \\ rpt (IF_CASES_TAC \\ gvs []) + >- simp [v_rel_def] + \\ gvs [EVERY_EL, EXISTS_MEM, MEM_EL, LIST_REL_EL_EQN] + \\ ntac 2 (first_x_assum drule \\ rpt strip_tac) + \\ drule v_rel_anyThunk \\ rw []) + \\ gvs [LIST_REL_EL_EQN, MEM_EL, MEM_MAP, PULL_EXISTS] + \\ ‘∀ck. result_map (eval_to ck) xs ≠ INL Type_error’ + by (rpt strip_tac + \\ qpat_x_assum ‘∀ck. eval_to _ (Prim _ _) ≠ _’ mp_tac \\ simp [] + \\ qexists_tac ‘ck’ + \\ simp [eval_to_def, SF ETA_ss]) + \\ ‘∀n. n < LENGTH xs ⇒ ∀ck. eval_to ck (EL n xs) ≠ INL Type_error’ + by (rpt strip_tac + \\ gs [result_map_def, MEM_MAP, CaseEq "bool"] + \\ gs [Once (DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”)] + \\ gs [MEM_EL, PULL_EXISTS]) + \\ gs [] + \\ Cases_on ‘result_map g ys = INL Diverge’ \\ gs [] >- ( - first_x_assum (drule_all_then assume_tac) - \\ first_x_assum (drule_all_then (qx_choose_then ‘j’ assume_tac)) + unabbrev_all_tac \\ gs [] + \\ gs [result_map_def, CaseEq "bool", MEM_MAP] + \\ gs [Once (DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”)] + \\ gvs [MEM_EL, PULL_EXISTS] + \\ ntac 2 (last_x_assum $ drule_then assume_tac) + \\ first_x_assum (drule_then (qx_choose_then ‘j’ assume_tac)) \\ qexists_tac ‘j’ - \\ rw [] \\ gs [SF SFY_ss] - \\ Cases_on ‘eval_to (j + k) (EL n xs)’ \\ gs []) - \\ ‘∀n. n < LENGTH ys ⇒ - ∃j. ($= +++ v_rel) (eval_to (j + k) (EL n xs)) - (eval_to k (EL n ys))’ - by rw [] - \\ last_x_assum kall_tac - \\ IF_CASES_TAC \\ gs [] - >- ( - Cases_on - ‘∃m. m < LENGTH xs ∧ eval_to k (EL m xs) = INL Type_error’ \\ gs [] - >- ( - ‘F’ suffices_by rw [] - \\ first_x_assum (drule_then (qx_choose_then ‘j1’ assume_tac)) - \\ ‘eval_to k (EL m xs) ≠ INL Diverge’ - by gs [] - \\ ‘∀i. eval_to (i + k) (EL m xs) = eval_to k (EL m xs)’ - by (strip_tac \\ irule eval_to_mono \\ gs []) - \\ Cases_on ‘eval_to k (EL m ys)’ \\ gs []) - \\ qexists_tac ‘0’ \\ rw [] \\ gs [] - \\ first_x_assum (drule_all_then (qx_choose_then ‘j’ assume_tac)) - \\ Cases_on ‘eval_to k (EL n xs) = INL Diverge’ \\ gs [] - \\ drule_then (qspec_then ‘j + k’ assume_tac) eval_to_mono \\ gs [] - \\ Cases_on ‘eval_to k (EL n xs)’ \\ gs []) - \\ ‘∃j. ∀n. n < LENGTH ys ⇒ - ($= +++ v_rel) (eval_to (j + k) (EL n xs)) - (eval_to k (EL n ys))’ - by (rpt (pop_assum mp_tac) + \\ fs [Once (DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”)] + \\ first_x_assum (drule_then assume_tac) + \\ first_x_assum (drule_then assume_tac) + \\ Cases_on ‘eval_to (j + k) (EL n xs)’ \\ gs []) + \\ ‘∀n. n < LENGTH xs ⇒ eval_to k (EL n ys) ≠ INL Diverge’ + by (rpt strip_tac + \\ gvs [result_map_def, CaseEq "bool", MEM_MAP, Abbr ‘g’, MEM_EL] + \\ rename1 ‘eval_to k (EL m ys) = INL Type_error’ + \\ ntac 2 (pop_assum kall_tac) + \\ ntac 2 (last_x_assum $ drule_then assume_tac) + \\ first_x_assum (drule_then (qx_choose_then ‘j’ assume_tac)) + \\ gs [Abbr ‘f’] + \\ first_x_assum (drule_then assume_tac) \\ gs [] + \\ Cases_on ‘eval_to (j + k) (EL m xs)’ \\ gs []) + \\ ‘∃j. ∀n. n < LENGTH xs ⇒ + ($= +++ v_rel) (eval_to (j + k) (EL n xs)) + (eval_to k (EL n ys))’ + by (unabbrev_all_tac + \\ rpt (pop_assum mp_tac) \\ qid_spec_tac ‘ys’ - \\ qid_spec_tac ‘xs’ - \\ Induct \\ simp [] - \\ Cases_on ‘ys’ \\ simp [] + \\ Induct_on ‘xs’ \\ simp [] \\ qx_gen_tac ‘x’ - \\ rename1 ‘_ (EL _ (x::xs)) (EL _ (y::ys))’ + \\ Cases \\ simp [] + \\ rename1 ‘eval_to k (EL _ (y::ys))’ \\ rw [] - \\ last_x_assum drule + \\ last_x_assum (qspec_then ‘ys’ mp_tac) + \\ simp [AND_IMP_INTRO, GSYM CONJ_ASSOC] \\ impl_tac >- ( - rpt $ strip_tac - \\ rename1 ‘n < LENGTH ys’ - \\ ‘SUC n < SUC (LENGTH ys)’ by gs [] - \\ res_tac \\ fs [SF SFY_ss] - \\ rpt $ first_x_assum $ qspecl_then [‘SUC n’] assume_tac - \\ gs []) - \\ disch_then (qx_choose_then ‘j1’ assume_tac) - \\ ‘0 < SUC (LENGTH ys)’ by gs [] - \\ first_x_assum (drule_then (qx_choose_then ‘j’ assume_tac)) - \\ gs [] - \\ qexists_tac ‘MAX j j1’ - \\ Cases \\ rw [arithmeticTheory.MAX_DEF] + rw [] + >~ [‘eval_to ck (Cons x xs) ≠ INL Type_error’] >- ( + qpat_x_assum ‘∀ck. eval_to _ (Cons _ _) ≠ _’ mp_tac + \\ rw [eval_to_def, oneline sum_bind_def] + \\ CASE_TAC \\ gvs [] + >- ( + Cases_on ‘x''’ \\ gvs [] + \\ first_x_assum $ qspec_then ‘ck’ mp_tac + \\ CASE_TAC \\ gvs [] + >- ( + Cases_on ‘x''’ \\ gvs [] + \\ ntac 2 (pop_assum mp_tac) \\ simp [result_map_def] + \\ IF_CASES_TAC \\ gvs []) + \\ ntac 2 (pop_assum mp_tac) \\ simp [result_map_def] + \\ IF_CASES_TAC \\ gvs []) + \\ rw [EVERY_EL] + \\ qpat_x_assum ‘∀ck. _ ≠ _’ mp_tac + \\ simp [result_map_def] + \\ ‘∀ck n. n < SUC (LENGTH xs) ⇒ + eval_to ck (EL n (x'::xs)) ≠ INL Type_error’ + by gvs [] \\ gvs [] + \\ ‘∃ck. ∀n. n < SUC (LENGTH xs) ⇒ + eval_to ck (EL n (x'::xs)) ≠ INL Diverge’ by ( + qspecl_then [‘x'::xs’, ‘y::ys’] mp_tac + exp_rel_result_map_Diverge \\ simp [] + \\ disch_then drule \\ rw []) + \\ gvs [] + \\ disch_then $ qspec_then ‘k + ck + ck'’ mp_tac + \\ ntac 2 (IF_CASES_TAC \\ gvs []) + >- ( + spose_not_then kall_tac + \\ first_x_assum $ qspec_then ‘0’ assume_tac \\ gvs [] + \\ ‘eval_to ck' x' ≠ INL Diverge’ by gvs [] + \\ drule eval_to_mono \\ rw [] + \\ qexists ‘ck + ck' + k’ \\ simp []) + >- ( + spose_not_then kall_tac + \\ gvs [MEM_MAP, MEM_EL] + \\ first_x_assum $ qspec_then ‘SUC (n')’ assume_tac \\ gvs [] + \\ ‘eval_to ck' (EL n' xs) ≠ INL Diverge’ by gvs [] + \\ drule eval_to_mono \\ rw [] + \\ qexists ‘ck + ck' + k’ \\ simp []) + \\ rw [EVERY_EL, EL_MAP] + \\ qpat_x_assum ‘result_map _ _ = INR _’ mp_tac + \\ rw [result_map_def] + \\ ‘n < LENGTH ys’ by gvs [LENGTH_MAP] + \\ simp [EL_MAP] + \\ Cases_on ‘eval_to ck (EL n xs)’ \\ gvs [] + >- (Cases_on ‘x’ \\ gvs [MEM_MAP, MEM_EL]) + \\ first_x_assum drule \\ rw [] + \\ Cases_on ‘eval_to (ck + ck' + k) (EL n xs)’ \\ gvs [] + >- (Cases_on ‘x’ \\ gvs [MEM_MAP, MEM_EL]) + \\ gvs [] + \\ ‘eval_to ck (EL n xs) ≠ INL Diverge’ by gvs [] + \\ ‘eval_to (ck + ck' + k) (EL n xs) ≠ INL Diverge’ by gvs [] + \\ imp_res_tac eval_to_equals_eval + \\ gvs []) + \\ TRY ( + rpt (qpat_x_assum ‘∀n. n < SUC _ ⇒ _’ + (qspec_then ‘SUC n’ assume_tac)) \\ gs [] + \\ gs [eval_to_def, result_map_def, MEM_MAP, CaseEq "bool"] + \\ fs [Once (DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”)] + \\ rw [] \\ gs [] + \\ NO_TAC) + \\ rpt strip_tac + \\ gs [eval_to_def, result_map_def, MEM_MAP, CaseEq "bool"] + \\ rgs [Once (DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”)] + \\ rw [] \\ gvs [MEM_EL, PULL_EXISTS] + \\ first_x_assum (drule_then assume_tac) + \\ first_x_assum (qspec_then ‘SUC n’ assume_tac) \\ gs []) + \\ disch_then (qx_choose_then ‘j’ assume_tac) + \\ ‘∃j1. ($= +++ v_rel) (eval_to (j1 + k) x) (eval_to k y)’ + by (rpt (qpat_x_assum ‘∀n. n < SUC _ ⇒ _’ + (qspec_then ‘0’ assume_tac)) \\ gs []) + \\ qexists_tac ‘j + j1’ + \\ Cases \\ gs [] >- ( - ‘eval_to k y ≠ INL Diverge’ - by (strip_tac - \\ rpt $ first_x_assum $ qspecl_then [‘0’] assume_tac - \\ gs []) - \\ ‘eval_to (j + k) x ≠ INL Diverge’ + rpt (qpat_x_assum ‘∀n. n < SUC _ ⇒ _’ + (qspec_then ‘0’ assume_tac)) \\ gs [] + \\ ‘eval_to (j1 + k) x ≠ INL Diverge’ by (strip_tac \\ Cases_on ‘eval_to k y’ \\ gs []) - \\ drule_then (qspec_then ‘j1 + k’ assume_tac) eval_to_mono + \\ drule_then (qspec_then ‘j + j1 + k’ assume_tac) + eval_to_mono \\ gs []) - \\ gs [arithmeticTheory.NOT_LESS] - \\ rename1 ‘m < LENGTH ys’ - \\ ‘SUC m < SUC (LENGTH ys)’ by gs [] + \\ qmatch_goalsub_rename_tac ‘n < LENGTH ys’ + \\ strip_tac + \\ rpt (qpat_x_assum ‘∀n. n < SUC _ ⇒ _’ + (qspec_then ‘SUC n’ assume_tac)) \\ gs [] \\ first_x_assum (drule_then assume_tac) - \\ first_x_assum (drule_then assume_tac) \\ gs [] - \\ ‘eval_to (j1 + k) (EL m xs) ≠ INL Diverge’ - by (strip_tac \\ Cases_on ‘eval_to k (EL m ys)’ - \\ first_x_assum $ qspecl_then [‘SUC m’] assume_tac - \\ gs []) - \\ drule_then (qspec_then ‘j + k’ assume_tac) eval_to_mono + \\ first_x_assum (drule_then assume_tac) + \\ ‘eval_to (j + k) (EL n xs) ≠ INL Diverge’ + by (strip_tac \\ Cases_on ‘eval_to k (EL n ys)’ \\ gs []) + \\ drule_then (qspec_then ‘j + j1 + k’ assume_tac) + eval_to_mono \\ gs []) \\ qexists_tac ‘j’ - \\ rw [] \\ gs [SF SFY_ss] - >~ [‘MAP OUTR _’] >- ( - gvs [EVERY2_MAP, LIST_REL_EL_EQN] \\ rw [] - \\ first_x_assum (drule_all_then assume_tac) - \\ first_x_assum (drule_then assume_tac) - \\ first_x_assum (drule_then assume_tac) - \\ Cases_on ‘eval_to k (EL n ys)’ - \\ Cases_on ‘eval_to (j + k) (EL n xs)’ \\ gvs [] - \\ rename1 ‘INL err’ \\ Cases_on ‘err’ \\ gs []) - \\ first_x_assum (drule_all_then assume_tac) - \\ Cases_on ‘eval_to k (EL n ys)’ \\ gs []) + \\ unabbrev_all_tac + \\ qpat_x_assum ‘∀ck. result_map _ _ ≠ _’ (qspec_then ‘j + k’ assume_tac) + \\ gs [result_map_def, CaseEq "bool", MEM_MAP, MAP_MAP_o, + combinTheory.o_DEF] + \\ fs [DECIDE “A ⇒ ¬MEM a b ⇔ MEM a b ⇒ ¬A”] + \\ gvs [MEM_EL, PULL_EXISTS] + \\ IF_CASES_TAC \\ gs [] + \\ gs [Once (DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”)] + \\ ‘∀n. n < LENGTH ys ⇒ eval_to (j + k) (EL n xs) ≠ INL Diverge’ + by (qx_gen_tac ‘m’ + \\ rpt strip_tac + \\ first_x_assum (drule_then assume_tac) \\ gs [] + \\ Cases_on ‘eval_to k (EL m ys)’ \\ gs []) + \\ csimp [] + \\ ‘∀n. n < LENGTH ys ⇒ eval_to k (EL n ys) ≠ INL Type_error’ + by (qx_gen_tac ‘m’ + \\ rpt strip_tac + \\ first_x_assum (drule_then assume_tac) \\ gs [] + \\ first_x_assum (drule_then assume_tac) \\ gs [] + \\ Cases_on ‘eval_to (j + k) (EL m xs)’ \\ gs []) + \\ csimp [EVERY2_MAP, LIST_REL_EL_EQN] + \\ qx_gen_tac ‘m’ \\ strip_tac + \\ first_x_assum (drule_then assume_tac) \\ gs [] + \\ first_x_assum (drule_then assume_tac) \\ gs [] + \\ first_x_assum (drule_then assume_tac) \\ gs [] + \\ Cases_on ‘eval_to k (EL m ys)’ + \\ Cases_on ‘eval_to (j + k) (EL m xs)’ \\ gs [] + \\ rename1 ‘_ = INL err’ \\ Cases_on ‘err’ \\ gs []) >- ((* IsEq *) - IF_CASES_TAC \\ gvs [LENGTH_EQ_NUM_compute] + IF_CASES_TAC \\ gvs [LIST_REL_EL_EQN] \\ IF_CASES_TAC \\ gs [] >- ( qexists_tac ‘0’ - \\ gs []) -(* \\ first_x_assum $ qspec_then ‘0’ assume_tac \\ gs []*) + \\ simp []) + \\ gvs [LENGTH_EQ_NUM_compute, DECIDE “∀n. n < 1 ⇔ n = 0”] \\ rename1 ‘exp_rel x y’ - \\ last_x_assum $ qspecl_then [‘k - 1’] assume_tac \\ gvs [] - \\ first_x_assum (drule_then (qx_choose_then ‘j’ assume_tac)) - \\ qexists_tac ‘j’ + \\ last_x_assum $ qspec_then ‘k - 1’ assume_tac \\ gvs [] + \\ first_x_assum drule + \\ impl_keep_tac + >- ( + qx_gen_tac ‘ck’ + \\ strip_tac + \\ first_x_assum (qspec_then ‘ck + 1’ mp_tac) + \\ simp [eval_to_def]) + \\ disch_then (qx_choose_then ‘j’ assume_tac) + \\ first_x_assum (qspec_then ‘j + k - 1’ assume_tac) + \\ qexists_tac ‘j’ \\ simp [] \\ Cases_on ‘eval_to (k - 1) y’ \\ Cases_on ‘eval_to (j + k - 1) x’ \\ gs [] - \\ rename1 ‘v_rel v w’ - \\ Cases_on ‘v’ \\ Cases_on ‘w’ \\ gvs [LIST_REL_EL_EQN, v_rel_def] + \\ rename1 ‘v_rel v1 u1’ + \\ Cases_on ‘v1’ \\ Cases_on ‘u1’ \\ gvs [v_rel_def] + \\ gvs [LIST_REL_EL_EQN] \\ IF_CASES_TAC \\ gs [] - \\ rw [v_rel_def]) + \\ last_x_assum (qspec_then ‘j + k’ mp_tac) + \\ simp [Once eval_to_def, v_rel_def]) >- ((* Proj *) - IF_CASES_TAC \\ gvs [LENGTH_EQ_NUM_compute] + IF_CASES_TAC \\ gvs [LIST_REL_EL_EQN] \\ IF_CASES_TAC \\ gs [] >- ( qexists_tac ‘0’ - \\ gs []) -(* \\ first_x_assum $ qspec_then ‘0’ assume_tac \\ gs []*) + \\ simp []) + \\ gvs [LENGTH_EQ_NUM_compute, DECIDE “∀n. n < 1 ⇔ n = 0”] \\ rename1 ‘exp_rel x y’ - \\ last_x_assum $ qspecl_then [‘k - 1’] assume_tac \\ gvs [] - \\ first_x_assum (drule_then (qx_choose_then ‘j’ assume_tac)) + \\ last_x_assum $ qspec_then ‘k - 1’ assume_tac \\ gvs [] + \\ first_x_assum drule + \\ impl_keep_tac + >- ( + qx_gen_tac ‘ck’ + \\ strip_tac + \\ first_x_assum (qspec_then ‘ck + 1’ mp_tac) + \\ simp [eval_to_def]) + \\ disch_then (qx_choose_then ‘j’ assume_tac) + \\ first_x_assum (qspec_then ‘j + k - 1’ assume_tac) \\ qexists_tac ‘j’ \\ Cases_on ‘eval_to (k - 1) y’ \\ Cases_on ‘eval_to (j + k - 1) x’ \\ gs [] - \\ rename1 ‘v_rel v w’ - \\ Cases_on ‘v’ \\ Cases_on ‘w’ \\ gvs [LIST_REL_EL_EQN, v_rel_def] - \\ IF_CASES_TAC \\ gs [] - \\ rw [v_rel_def]) + \\ rename1 ‘v_rel v1 u1’ + \\ Cases_on ‘v1’ \\ Cases_on ‘u1’ \\ gvs [v_rel_def] + \\ gvs [LIST_REL_EL_EQN] + \\ IF_CASES_TAC \\ gs []) >- ((* AtomOp *) Cases_on ‘k = 0’ \\ gs [] >- ( - qexists_tac ‘0’ \\ gs [] - \\ rw [result_map_def, MEM_MAP, MEM_EL, PULL_EXISTS] - \\ Cases_on ‘ys = []’ \\ gs [] - >- ( - CASE_TAC \\ gs [] - \\ CASE_TAC \\ gs [v_rel_def]) - \\ ‘xs ≠ []’ by (strip_tac \\ gs []) - \\ first_x_assum (qspec_then ‘0’ assume_tac) \\ gs []) - \\ qmatch_goalsub_abbrev_tac ‘result_map g ys’ + qexists_tac ‘0’ \\ simp [] + \\ gvs [LIST_REL_EL_EQN, result_map_def, MEM_MAP, GSYM NOT_NULL_MEM, + NULL_EQ] + \\ Cases_on ‘xs’ \\ Cases_on ‘ys’ \\ gvs [] + \\ CASE_TAC \\ gs [] + \\ CASE_TAC \\ gs [v_rel_def]) \\ qabbrev_tac ‘f = λj x. case eval_to (j + k - 1) x of - INL err => INL err - | INR (Atom x) => INR x - | _ => INL Type_error’ \\ gs [] - \\ last_x_assum $ qspecl_then [‘k - 1’] assume_tac - \\ last_x_assum kall_tac \\ gvs [] + INR (Atom l) => INR l + | INL err => INL err + | _ => INL Type_error’ + \\ qmatch_goalsub_abbrev_tac ‘result_map g ys’ + \\ simp [SF ETA_ss] + \\ ‘∀j. result_map (f j) xs ≠ INL Type_error’ + by (rpt strip_tac + \\ first_x_assum (qspec_then ‘k + j’ mp_tac) + \\ simp [eval_to_def] + \\ simp [SF ETA_ss]) + \\ ‘∀n. n < LENGTH xs ⇒ ∀ck. eval_to ck (EL n xs) ≠ INL Type_error’ + by (rpt strip_tac + \\ last_x_assum assume_tac + \\ last_x_assum (qspec_then ‘SUC ck’ mp_tac) + \\ csimp [eval_to_def, result_map_def, MEM_MAP, MEM_EL, PULL_EXISTS] + \\ rw [] \\ gs []) + \\ gs [] + \\ gvs [LIST_REL_EL_EQN] \\ ‘∃j. result_map (f j) xs = result_map g ys’ suffices_by ( disch_then (qx_choose_then ‘j’ assume_tac) - \\ qexists_tac ‘j’ \\ gs [SF ETA_ss] + \\ qexists_tac ‘j’ \\ simp [] \\ Cases_on ‘result_map g ys’ \\ gs [] - \\ CASE_TAC \\ gs [] - \\ CASE_TAC \\ gs [v_rel_def]) - \\ unabbrev_all_tac - \\ simp [result_map_def, MEM_EL, PULL_EXISTS, EL_MAP, SF CONJ_ss] - \\ Cases_on ‘k’ \\ gs [arithmeticTheory.ADD1] - \\ rename1 ‘eval_to k’ - \\ ‘∀n. n < LENGTH ys ⇒ - ∃j. ($= +++ v_rel) (eval_to (j + k) (EL n xs)) - (eval_to k (EL n ys))’ - by rw [] - \\ qpat_x_assum ‘∀x y. exp_rel _ _ ⇒ _’ kall_tac - \\ IF_CASES_TAC \\ gs [] + \\ rpt CASE_TAC \\ gs [v_rel_def]) + \\ Cases_on ‘result_map g ys = INL Diverge’ \\ gs [] >- ( - rename1 ‘m < LENGTH ys’ - \\ first_x_assum (drule_all_then (qx_choose_then ‘j’ assume_tac)) + unabbrev_all_tac \\ gs [] + \\ rgs [result_map_def, CaseEq "bool", MEM_MAP] + \\ rgs [Once (DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”)] + \\ gvs [MEM_EL, PULL_EXISTS] + \\ first_x_assum drule + \\ pop_assum mp_tac + \\ rpt CASE_TAC \\ gvs [] + \\ rw [] + \\ qpat_x_assum ‘∀n. n < LENGTH _ ⇒ exp_rel _ _’ (drule_then assume_tac) + \\ last_x_assum $ qspec_then ‘k - 1’ assume_tac \\ gvs [] + \\ pop_assum drule \\ simp [] + \\ disch_then (qx_choose_then ‘j’ assume_tac) \\ qexists_tac ‘j’ - \\ rpt (first_x_assum (qspec_then ‘m’ assume_tac)) \\ gs [] - \\ rw [] \\ gs [] - \\ rpt (first_x_assum (qspec_then ‘m’ assume_tac)) \\ gs [] - \\ Cases_on ‘eval_to k (EL m ys)’ - \\ Cases_on ‘eval_to (j + k) (EL m xs)’ \\ gs [] - \\ rename1 ‘v_rel v w’ - \\ Cases_on ‘v’ \\ Cases_on ‘w’ \\ gs [v_rel_def]) - \\ ‘∀n. n < LENGTH ys ⇒ eval_to k (EL n ys) = INL Diverge ∨ - ∃x. eval_to k (EL n ys) = INR (Atom x)’ - by (rw [DISJ_EQ_IMP] - \\ first_x_assum drule - \\ rw [CaseEqs ["sum", "v"]] - \\ Cases_on ‘eval_to k (EL n ys)’ \\ gs [] - >~ [‘INL err’] >- ( - Cases_on ‘err’ \\ gs []) - \\ rename1 ‘INR x’ - \\ Cases_on ‘x’ \\ gs []) - \\ qpat_x_assum ‘∀n. _ ⇒ ¬( _ < _)’ kall_tac - \\ IF_CASES_TAC \\ gs [] - >- ( - Cases_on - ‘∃m. m < LENGTH ys ∧ eval_to k (EL m xs) = INL Type_error’ \\ gs [] - >- ( - ‘F’ suffices_by rw [] - \\ first_x_assum (drule_then (qx_choose_then ‘j1’ assume_tac)) - \\ ‘eval_to k (EL m xs) ≠ INL Diverge’ - by gs [] - \\ ‘∀i. eval_to (i + k) (EL m xs) = eval_to k (EL m xs)’ - by (strip_tac \\ irule eval_to_mono \\ gs []) - \\ Cases_on ‘eval_to k (EL m xs)’ \\ gs [] - \\ rpt (first_x_assum (qspec_then ‘m’ assume_tac)) \\ gs []) - \\ rename1 ‘n < LENGTH ys’ - \\ rgs [Once (CaseEq "sum"), CaseEq "v"] - \\ qexists_tac ‘0’ - \\ rw [] \\ gs [] - >- ( - rename1 ‘m < LENGTH ys’ - \\ first_x_assum (drule_all_then (qx_choose_then ‘j’ assume_tac)) - \\ ‘eval_to k (EL m xs) ≠ INL Diverge’ - by (strip_tac \\ gs []) - \\ drule_then (qspec_then ‘j + k’ assume_tac) eval_to_mono \\ gs [] - \\ Cases_on ‘eval_to k (EL m xs)’ - \\ Cases_on ‘eval_to k (EL m ys)’ \\ gs [] - \\ first_x_assum (drule_then assume_tac) \\ gs [] - \\ rename1 ‘v_rel y _’ \\ Cases_on ‘y’ \\ gs [v_rel_def]) - >- ( - first_x_assum (drule_all_then (qx_choose_then ‘j’ assume_tac)) - \\ first_x_assum (drule_then assume_tac) - \\ first_x_assum (drule_then assume_tac) - \\ ‘eval_to k (EL n xs) ≠ INL Diverge’ - by (strip_tac \\ gs []) - \\ drule_then (qspec_then ‘j + k’ assume_tac) eval_to_mono \\ gs [] - \\ Cases_on ‘eval_to k (EL n xs)’ \\ gs [])) - \\ ‘∀n. n < LENGTH ys ⇒ - ∃x. eval_to k (EL n ys) = INR (Atom x)’ - by (rw [] - \\ first_x_assum (drule_then assume_tac) - \\ first_x_assum (drule_then assume_tac) \\ gs []) - \\ qpat_x_assum ‘∀n. _ ⇒ ¬(n < _)’ kall_tac - \\ qpat_x_assum ‘∀n. n < _ ⇒ _ ∨ _’ kall_tac + \\ qexists_tac ‘n’ + \\ CASE_TAC \\ gs []) + \\ ‘∀n. n < LENGTH xs ⇒ eval_to (k - 1) (EL n ys) ≠ INL Diverge’ + by (rpt strip_tac + \\ gvs [Abbr ‘g’, result_map_def, CaseEq "bool", MEM_MAP, MEM_EL, + PULL_EXISTS] + \\ first_x_assum (qspec_then ‘n’ assume_tac) + \\ Cases_on ‘eval_to (k - 1) (EL n ys)’ \\ gvs [] + \\ rename1 ‘m < LENGTH ys’ + \\ Cases_on ‘eval_to (k - 1) (EL m ys)’ \\ gvs [] + >- ( + rpt $ first_x_assum (drule_all_then assume_tac) + \\ last_x_assum $ qspec_then ‘k - 1’ assume_tac \\ gvs [] + \\ pop_assum drule_all \\ rw [] \\ strip_tac + \\ Cases_on ‘eval_to (j' + k - 1) (EL m xs)’ \\ gvs []) + \\ fs [DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”] + \\ rpt $ first_x_assum (drule_all_then assume_tac) + \\ last_x_assum $ qspec_then ‘k - 1’ assume_tac \\ gvs [] + \\ pop_assum drule_all \\ rw [] \\ strip_tac + \\ Cases_on ‘eval_to (j' + k - 1) (EL m xs)’ \\ gvs [] + \\ gvs [Abbr ‘f’] + \\ first_x_assum (qspec_then ‘j'’ assume_tac) \\ gvs [] + \\ rename1 ‘v_rel v w’ + \\ Cases_on ‘v’ \\ Cases_on ‘w’ \\ gvs [v_rel_def]) \\ ‘∃j. ∀n. n < LENGTH ys ⇒ - ($= +++ v_rel) (eval_to (j + k) (EL n xs)) - (eval_to k (EL n ys))’ - by (rpt (pop_assum mp_tac) + ($= +++ v_rel) (eval_to (j + k - 1) (EL n xs)) + (eval_to (k - 1) (EL n ys))’ + by (unabbrev_all_tac + \\ qpat_x_assum ‘∀ck. eval_to _ _ ≠ INL _’ kall_tac + \\ ntac 4 (pop_assum mp_tac) + \\ ntac 4 (last_x_assum mp_tac) \\ qid_spec_tac ‘ys’ - \\ qid_spec_tac ‘xs’ - \\ Induct \\ simp [] - \\ Cases_on ‘ys’ \\ simp [] + \\ Induct_on ‘xs’ \\ simp [] \\ qx_gen_tac ‘x’ - \\ rename1 ‘_ (EL _ (x::xs)) (EL _ (y::ys))’ + \\ Cases \\ simp [] + \\ rename1 ‘eval_to (k - 1) (EL _ (y::ys))’ \\ rw [] - \\ last_x_assum drule + \\ last_x_assum (qspec_then ‘ys’ mp_tac) + \\ simp [AND_IMP_INTRO, GSYM CONJ_ASSOC] \\ impl_tac >- ( rw [] + \\ TRY ( + rpt (qpat_x_assum ‘∀n. n < SUC _ ⇒ _’ + (qspec_then ‘SUC n’ assume_tac)) \\ gs [] + \\ rgs [eval_to_def, result_map_def, MEM_MAP, CaseEq "bool"] + \\ fs [Once (DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”)] + \\ rw [] \\ gs [] + \\ NO_TAC) + \\ strip_tac + \\ rgs [result_map_def, CaseEq "bool", MEM_MAP, MEM_EL, + PULL_EXISTS] + \\ rgs [Once (DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”)] + \\ first_x_assum (drule_then assume_tac) \\ ‘SUC n < SUC (LENGTH ys)’ by gs [] - \\ res_tac \\ fs [SF SFY_ss] - \\ qexists_tac ‘j’ \\ gs []) - \\ disch_then (qx_choose_then ‘j1’ assume_tac) - \\ ‘0 < SUC (LENGTH ys)’ by gs [] - \\ last_x_assum (drule_then (qx_choose_then ‘j’ assume_tac)) - \\ gs [] - \\ qexists_tac ‘MAX j j1’ - \\ Cases \\ rw [arithmeticTheory.MAX_DEF] + \\ rpt (first_x_assum (drule_then assume_tac)) \\ gs [] + \\ last_x_assum $ qspec_then ‘k - 1’ assume_tac \\ gvs [] + \\ pop_assum $ drule_then assume_tac \\ gvs [] + \\ gs [CaseEqs ["sum", "v"]] + \\ Cases_on ‘eval_to (j + k - 1) (EL n xs)’ \\ gvs [] + \\ Cases_on ‘y'’ \\ Cases_on ‘v3’ \\ gvs [v_rel_def]) + \\ disch_then (qx_choose_then ‘j’ assume_tac) + \\ ‘∃j1. ($= +++ v_rel) (eval_to (j1 + k - 1) x) + (eval_to (k - 1) y)’ + by (rpt (qpat_x_assum ‘∀n. n < SUC _ ⇒ _’ + (qspec_then ‘0’ assume_tac)) \\ gs [] + \\ last_x_assum $ qspec_then ‘k - 1’ assume_tac \\ gvs []) + \\ qexists_tac ‘j + j1’ + \\ Cases \\ gs [] >- ( - ‘eval_to k y ≠ INL Diverge’ - by (strip_tac - \\ ‘0 < SUC (LENGTH ys)’ by gs [] - \\ first_x_assum (drule_then assume_tac) \\ gs []) - \\ ‘eval_to (j + k) x ≠ INL Diverge’ - by (strip_tac \\ Cases_on ‘eval_to k y’ \\ gs []) - \\ drule_then (qspec_then ‘j1 + k’ assume_tac) eval_to_mono + rpt (qpat_x_assum ‘∀n. n < SUC _ ⇒ _’ + (qspec_then ‘0’ assume_tac)) \\ gs [] + \\ ‘eval_to (j1 + k - 1) x ≠ INL Diverge’ + by (strip_tac \\ Cases_on ‘eval_to (k - 1) y’ \\ gs []) + \\ drule_then (qspec_then ‘j + j1 + k - 1’ assume_tac) + eval_to_mono \\ gs []) - \\ gs [arithmeticTheory.NOT_LESS] - \\ rename1 ‘m < LENGTH ys’ - \\ ‘SUC m < SUC (LENGTH ys)’ by gs [] + \\ qmatch_goalsub_rename_tac ‘n < LENGTH ys’ + \\ strip_tac + \\ rpt (qpat_x_assum ‘∀n. n < SUC _ ⇒ _’ + (qspec_then ‘SUC n’ assume_tac)) \\ gs [] \\ first_x_assum (drule_then assume_tac) - \\ first_x_assum (drule_then assume_tac) \\ gs [] - \\ ‘eval_to (j1 + k) (EL m xs) ≠ INL Diverge’ - by (strip_tac \\ Cases_on ‘eval_to k (EL m ys)’ \\ gs []) - \\ drule_then (qspec_then ‘j + k’ assume_tac) eval_to_mono + \\ ‘eval_to (j + k - 1) (EL n xs) ≠ INL Diverge’ + by (strip_tac \\ Cases_on ‘eval_to (k - 1) (EL n ys)’ \\ gs []) + \\ drule_then (qspec_then ‘j + j1 + k - 1’ assume_tac) + eval_to_mono \\ gs []) \\ qexists_tac ‘j’ - \\ rw [] \\ gs [] - >~ [‘MAP OUTR _’] >- ( - irule LIST_EQ \\ simp [EL_MAP] - \\ qx_gen_tac ‘n’ - \\ strip_tac - \\ rpt (first_x_assum (drule_then assume_tac)) - \\ CASE_TAC \\ gs [] - \\ CASE_TAC \\ gs [v_rel_def]) - \\ rename1 ‘n < LENGTH ys’ - \\ rpt (first_x_assum (drule_all_then assume_tac)) - \\ Cases_on ‘eval_to k (EL n ys)’ - \\ Cases_on ‘eval_to (j + k) (EL n xs)’ \\ gs [] - \\ rename1 ‘v_rel v0 (Atom _)’ \\ Cases_on ‘v0’ \\ gs [v_rel_def])) + \\ unabbrev_all_tac + \\ gs [result_map_def, MEM_MAP, MAP_MAP_o, combinTheory.o_DEF] + \\ IF_CASES_TAC \\ gs [] + >- ( + gvs [MEM_EL, PULL_EXISTS] + \\ rw [] \\ gs [CaseEq "bool"] + \\ fs [DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”] + \\ rpt (first_x_assum (drule_then strip_assume_tac)) + \\ first_x_assum (qspec_then ‘j’ assume_tac) + \\ Cases_on ‘eval_to (j + k - 1) (EL n xs)’ + \\ Cases_on ‘eval_to (k - 1) (EL n ys)’ \\ gs []) + \\ rgs [DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”] + \\ IF_CASES_TAC \\ gs [] + >- ( + gvs [MEM_EL, PULL_EXISTS] + \\ gvs [CaseEq "bool"] \\ fs [DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”] + THENL [ + ntac 2 (pop_assum kall_tac), + ALL_TAC ] + \\ rpt (first_x_assum (drule_then strip_assume_tac)) + \\ rename1 ‘EL n ys’ + \\ rename1 ‘j + k - 1’ + \\ first_x_assum (qspec_then ‘j’ assume_tac) + \\ Cases_on ‘eval_to (j + k - 1) (EL n xs)’ + \\ Cases_on ‘eval_to (k - 1) (EL n ys)’ \\ gs [] + \\ rename1 ‘v_rel v w’ \\ Cases_on ‘v’ \\ Cases_on ‘w’ + \\ gs [v_rel_def]) + \\ IF_CASES_TAC \\ gs [] + >- ( + rgs [MEM_EL, PULL_EXISTS] + \\ rgs [CaseEq "bool"] \\ fs [DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”] + \\ rpt (first_x_assum (drule_then strip_assume_tac)) + \\ rename1 ‘EL n ys’ + \\ rename1 ‘j + k - 1’ + \\ first_x_assum (qspec_then ‘j’ assume_tac) + \\ Cases_on ‘eval_to (j + k - 1) (EL n xs)’ + \\ Cases_on ‘eval_to (k - 1) (EL n ys)’ \\ gs [] + \\ rename1 ‘v_rel v w’ \\ Cases_on ‘v’ \\ Cases_on ‘w’ + \\ gs [v_rel_def]) + \\ rgs [CaseEq "bool"] + \\ fs [DECIDE “A ⇒ ¬MEM a b ⇔ MEM a b ⇒ ¬A”] + \\ rgs [MEM_EL, PULL_EXISTS] + \\ irule_at Any LIST_EQ + \\ rw [EL_MAP] + \\ rpt (first_x_assum (drule_then assume_tac)) + \\ first_x_assum (qspec_then ‘j’ assume_tac) + \\ rpt CASE_TAC \\ gs [v_rel_def])) >~ [‘Monad _ _’] >- ( rw [Once exp_rel_cases] \\ gs [] \\ simp [eval_to_def, v_rel_def]) QED Theorem exp_rel_eval: - exp_rel x y ⇒ + exp_rel x y ∧ + eval x ≠ INL Type_error ⇒ ($= +++ v_rel) (eval x) (eval y) Proof strip_tac + \\ dxrule_then assume_tac eval_not_error \\ simp [eval_def] \\ DEEP_INTRO_TAC some_intro \\ DEEP_INTRO_TAC some_intro \\ rw [] @@ -2794,19 +3283,22 @@ QED Theorem let_delay_var_apply_closure[local]: exp_rel x y ∧ v_rel v2 w2 ∧ - (∀x y. ($= +++ v_rel) x y ⇒ next_rel v_rel exp_rel (f x) (g y)) ⇒ + apply_closure x v2 f ≠ Err ∧ + f (INL Type_error) = Err ∧ + (∀x y. ($= +++ v_rel) x y ∧ f x ≠ Err ⇒ next_rel v_rel exp_rel (f x) (g y)) ⇒ next_rel v_rel exp_rel (apply_closure x v2 f) (apply_closure y w2 g) Proof - rw [apply_closure_def] >> simp[with_value_def] >> - dxrule_then assume_tac exp_rel_eval >> - Cases_on `eval x` >> Cases_on `eval y` >> gvs[] - >- (CASE_TAC >> gvs[]) >> - rename1 `eval x = INR v1` >> rename1 `eval y = INR w1` - \\ Cases_on ‘v1’ \\ Cases_on ‘w1’ \\ gvs [v_rel_def, dest_anyClosure_def] + rw [apply_closure_def, with_value_def] + \\ ‘eval x ≠ INL Type_error’ by (CCONTR_TAC \\ gvs[]) + \\ dxrule_all_then assume_tac exp_rel_eval + \\ Cases_on ‘eval x’ \\ Cases_on ‘eval y’ \\ gvs[] >- (CASE_TAC \\ gvs[]) + \\ rename1 ‘eval x = INR v1’ \\ rename1 ‘eval y = INR w1’ + \\ Cases_on ‘v1’ \\ Cases_on ‘w1’ \\ gvs [dest_anyClosure_def, v_rel_def] >- ( - first_x_assum irule + first_x_assum irule \\ gs [] \\ irule exp_rel_eval - \\ irule exp_rel_subst \\ gs []) + \\ irule_at Any exp_rel_subst \\ gs [] + \\ strip_tac \\ gs []) >- (rename1 ‘LIST_REL _ (MAP SND xs) (MAP SND ys)’ \\ ‘OPTREL exp_rel (ALOOKUP (REVERSE xs) s) (ALOOKUP (REVERSE ys) s)’ by (irule LIST_REL_OPTREL @@ -2816,8 +3308,9 @@ Proof \\ rw [Once exp_rel_cases] \\ gs [] \\ drule_then assume_tac ALOOKUP_SOME_REVERSE_EL \\ gs [] \\ gvs [EVERY_EL, EL_MAP] - \\ first_x_assum irule + \\ first_x_assum irule \\ gvs [] \\ irule exp_rel_eval + \\ conj_tac >- (strip_tac \\ gvs []) \\ irule exp_rel_subst \\ simp [EVERY2_MAP, LAMBDA_PROD, v_rel_def, MAP_MAP_o, combinTheory.o_DEF, GSYM FST_THM] @@ -2829,62 +3322,57 @@ Proof \\ gs [OPTREL_def, GSYM MAP_REVERSE, ALOOKUP_MAP] \\ qpat_x_assum ‘exp_rel x0 _’ mp_tac \\ rw [Once exp_rel_cases] \\ gs [replace_Force_def] - >- (IF_CASES_TAC \\ gs [] + \\ IF_CASES_TAC \\ gs [] + \\ first_x_assum irule \\ gvs [] + \\ irule exp_rel_eval + \\ conj_tac >- (strip_tac \\ gvs []) + >- (irule exp_rel_subst + \\ gvs [MAP_MAP_o, combinTheory.o_DEF, LAMBDA_PROD, GSYM FST_THM] + \\ gvs [LIST_REL_EL_EQN, EL_MAP] \\ rw [] + \\ pairarg_tac \\ gs [] \\ pairarg_tac \\ gs [] + \\ rename1 ‘n < _’ + \\ ‘EL n (MAP FST xs) = EL n (MAP FST ys)’ by gvs [] \\ gvs [EL_MAP] + \\ irule v_rel_Recclosure_Delay_Var + \\ gvs [LIST_REL_EL_EQN, EL_MAP]) + >- (strip_tac \\ gvs []) + >- (gvs [subst_APPEND] + \\ rename1 ‘subst1 n w2 (replace_Force (Var var) v1 y')’ + \\ drule_then assume_tac ALOOKUP_MEM + \\ gvs [EVERY_MEM, MEM_MAP, PULL_EXISTS] + \\ first_assum $ dxrule_then assume_tac + \\ gvs [boundvars_def] + \\ rename1 ‘replace_Force (Var (FST pair))’ + \\ qspecl_then [‘y'’, ‘Var (FST pair)’, ‘v1’, ‘[(n, w2)]’] assume_tac subst_replace_Force + \\ gvs [freevars_def, subst_def] + \\ assume_tac exp_rel_subst_Recclosure \\ gvs [subst_funs_def] \\ first_x_assum irule - \\ irule exp_rel_eval - >- (irule exp_rel_subst - \\ gvs [MAP_MAP_o, combinTheory.o_DEF, LAMBDA_PROD, GSYM FST_THM] - \\ gvs [LIST_REL_EL_EQN, EL_MAP] \\ rw [] - \\ pairarg_tac \\ gs [] \\ pairarg_tac \\ gs [] - \\ rename1 ‘n < _’ - \\ ‘EL n (MAP FST xs) = EL n (MAP FST ys)’ by gvs [] \\ gvs [EL_MAP] - \\ irule v_rel_Recclosure_Delay_Var - \\ gvs [LIST_REL_EL_EQN, EL_MAP]) - >- (gvs [subst_APPEND] - \\ rename1 ‘subst1 n w2 (replace_Force (Var var) v1 y')’ - \\ drule_then assume_tac ALOOKUP_MEM - \\ gvs [EVERY_MEM, MEM_MAP, PULL_EXISTS] - \\ first_assum $ dxrule_then assume_tac - \\ gvs [boundvars_def] - \\ rename1 ‘replace_Force (Var (FST pair))’ - \\ qspecl_then [‘y'’, ‘Var (FST pair)’, ‘v1’, ‘[(n, w2)]’] assume_tac subst_replace_Force - \\ gvs [freevars_def, subst_def] - \\ assume_tac exp_rel_subst_Recclosure \\ gvs [subst_funs_def] - \\ first_x_assum irule - \\ gvs [EVERY_MEM, MEM_MAP, PULL_EXISTS, boundvars_subst] - \\ qexists_tac ‘pair’ \\ gs [exp_rel_subst])) - >- (IF_CASES_TAC \\ gs []) - >- (IF_CASES_TAC \\ gs []) - >- (rename1 ‘Let opt _ _’ - \\ Cases_on ‘opt’ \\ gvs [replace_Force_def] - \\ IF_CASES_TAC \\ gs []) - >- (IF_CASES_TAC \\ gs []) - >- (rename1 ‘Force y'’ \\ Cases_on ‘y'’ \\ gvs [replace_Force_def] - \\ IF_CASES_TAC \\ gvs [])) + \\ gvs [EVERY_MEM, MEM_MAP, PULL_EXISTS, boundvars_subst] + \\ qexists_tac ‘pair’ \\ gs [exp_rel_subst])) QED Theorem let_delay_var_rel_ok[local]: - rel_ok T v_rel exp_rel + rel_ok F v_rel exp_rel Proof rw [rel_ok_def, v_rel_def, exp_rel_def] \\ rw [let_delay_var_apply_closure] QED Theorem let_delay_var_sim_ok[local]: - sim_ok T v_rel exp_rel + sim_ok F v_rel exp_rel Proof rw [sim_ok_def, exp_rel_eval, exp_rel_subst] QED Theorem let_delay_var_semantics: exp_rel x y ∧ - closed x ⇒ + closed x ∧ + pure_semantics$safe_itree (semantics x Done []) ⇒ semantics x Done [] = semantics y Done [] Proof strip_tac \\ irule sim_ok_semantics \\ gs [] \\ first_assum (irule_at Any) - \\ qexists_tac ‘T’ \\ gs [] + \\ qexists_tac ‘F’ \\ gs [] \\ irule_at Any let_delay_var_rel_ok \\ irule_at Any let_delay_var_sim_ok QED @@ -3359,16 +3847,17 @@ QED Theorem full_let_delay_var_semantics: full_exp_rel x y ∧ - closed x ⇒ + closed x ∧ + pure_semantics$safe_itree (semantics x Done []) ⇒ semantics x Done [] = semantics y Done [] Proof rw [] >> - irule $ GEN_ALL NRC_semantics_full >> fs [] >> - first_x_assum $ irule_at Any >> + irule $ GEN_ALL NRC_semantics_safe_full >> fs [] >> + first_assum $ irule_at Any >> qexists_tac ‘exp_rel’ >> - gvs [let_delay_var_semantics, full_exp_rel_NRC_exp_rel, closed_def] >> - rw [] >> - metis_tac [exp_rel_freevars] + gvs [let_delay_var_semantics, full_exp_rel_NRC_exp_rel] >> + rw [] + >- metis_tac [closed_def, exp_rel_freevars] QED (* diff --git a/compiler/backend/passes/proofs/thunk_Let_Lam_ForcedScript.sml b/compiler/backend/passes/proofs/thunk_Let_Lam_ForcedScript.sml index 3d22bda6..5f76c2b4 100644 --- a/compiler/backend/passes/proofs/thunk_Let_Lam_ForcedScript.sml +++ b/compiler/backend/passes/proofs/thunk_Let_Lam_ForcedScript.sml @@ -1299,6 +1299,89 @@ Proof rw [] \\ once_rewrite_tac [eval_to_def] \\ gvs [subst_funs_def] QED +Theorem MAP_FST_LUPDATE: + MAP FST (LUPDATE (FST (EL i l),v) i l) = MAP FST l +Proof + simp [MAP_EQ_EVERY2, LIST_REL_EL_EQN, EL_LUPDATE] \\ rw [] +QED + +Theorem v_rel_anyThunk: + ∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w) +Proof + ‘(∀v w. force_arg_rel v w ⇒ T) ∧ + (∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w))’ + suffices_by gvs [] + \\ ho_match_mp_tac force_arg_rel_strongind \\ rw [] \\ gvs [SF ETA_ss] + \\ rw [is_anyThunk_def, dest_anyThunk_def] + >- ( + gvs [AllCaseEqs(), PULL_EXISTS] + \\ iff_tac \\ rw [] + >- ( + ‘MAP FST (REVERSE f) = MAP FST (REVERSE g)’ by gvs [MAP_EQ_EVERY2] + \\ drule_all ALOOKUP_SOME_EL_2 \\ rw [] + \\ gvs [LIST_REL_EL_EQN, EL_MAP, EL_REVERSE] + \\ ‘PRE (LENGTH g - n') < LENGTH g’ by gvs [] + \\ last_x_assum drule \\ rw [] + \\ rgs [Once force_arg_rel_cases]) + >- ( + ‘MAP FST (REVERSE g) = MAP FST (REVERSE f)’ + by gvs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] + \\ drule_all ALOOKUP_SOME_EL_2 \\ rw [] + \\ gvs [LIST_REL_EL_EQN, EL_MAP, EL_REVERSE] + \\ ‘PRE (LENGTH g - n') < LENGTH g’ by gvs [] + \\ last_x_assum drule \\ rw [] + \\ rgs [Once force_arg_rel_cases])) + \\ ( + gvs [AllCaseEqs(), PULL_EXISTS] + \\ iff_tac \\ rw [] + >- ( + gvs [REVERSE_SNOC] + \\ rw [] + >- gvs [FOLDR_APPEND] + \\ qmatch_goalsub_abbrev_tac ‘ALOOKUP ll n = SOME _’ + \\ `ALL_DISTINCT (MAP FST ll)’ by ( + unabbrev_all_tac \\ gvs [] + \\ gvs [MAP_REVERSE, MAP_EQ_EVERY2, LIST_REL_EL_EQN] + \\ last_x_assum drule \\ rw [] + \\ rw [MAP_FST_LUPDATE]) \\ gvs [] + \\ ‘∃y'. MEM (n,Delay y') ll’ by ( + unabbrev_all_tac \\ gvs [] + \\ gvs [MEM_LUPDATE] + \\ ‘MAP FST (REVERSE f) = MAP FST (REVERSE g)’ + by gvs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] + \\ drule_all ALOOKUP_SOME_EL_2 \\ rw [] + \\ gvs [LIST_REL_EL_EQN, EL_MAP, EL_REVERSE] + \\ ‘PRE (LENGTH g - n') < LENGTH g’ by gvs [] + \\ first_x_assum drule \\ rw [Once force_arg_rel_cases] + \\ drule ALOOKUP_SOME_REVERSE_EL \\ rw [] + \\ qexists ‘y’ \\ gvs [] + \\ disj2_tac + \\ qexists ‘n''’ \\ gvs [] + \\ CCONTR_TAC \\ gvs [] + \\ qpat_x_assum ‘Delay _ = _’ assume_tac + \\ gvs [Lams_split]) + \\ drule_all ALOOKUP_ALL_DISTINCT_MEM \\ gvs []) + >- ( + gvs [REVERSE_SNOC] + \\ Cases_on ‘v2 = n’ \\ gvs [] + \\ qmatch_asmsub_abbrev_tac + ‘ALOOKUP (REVERSE (LUPDATE (v1,ls) i g)) n = _’ + \\ ‘¬∃x. ls = Delay x’ by (rpt strip_tac \\ gvs [Lams_split]) \\ gvs [] + \\ drule ALOOKUP_SOME_EL \\ rw [] + \\ gvs [EL_REVERSE, EL_LUPDATE] + \\ Cases_on ‘PRE (LENGTH g - n') = i’ \\ gvs [] + \\ qpat_x_assum ‘LIST_REL force_arg_rel _ _’ mp_tac + \\ rw [LIST_REL_EL_EQN] \\ gvs [EL_MAP] + \\ ‘PRE (LENGTH g - n') < LENGTH g’ by gvs [] + \\ first_x_assum drule \\ rw [Once force_arg_rel_cases] + \\ ‘SND (EL n' (REVERSE f)) = Delay x'’ by gvs [EL_REVERSE] + \\ qspecl_then [‘REVERSE f’, ‘n'’] assume_tac ALOOKUP_ALL_DISTINCT_EL + \\ gvs [MAP_REVERSE] \\ gvs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] + \\ last_x_assum $ qspec_then ‘PRE (LENGTH g - n')’ mp_tac \\ simp [] + \\ qpat_x_assum ‘LENGTH f = LENGTH g’ (assume_tac o GSYM) \\ gvs [] + \\ rw [GSYM EL_REVERSE] \\ gvs [])) +QED + fun print_tac str t g = (print (str ^ "\n"); time t g); Theorem force_arg_rel_eval_to: @@ -4540,7 +4623,7 @@ Proof by (strip_tac \\ Cases_on ‘eval_to (k - 1) (subst_funs xs x2)’ \\ gvs []) \\ dxrule_then (qspec_then ‘j + j1 + k - 1’ assume_tac) eval_to_mono \\ gvs [] \\ simp [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) - \\ cheat (* TODO v_rel_anyThunk *)) + \\ drule v_rel_anyThunk \\ rw []) >- (gvs [dest_anyThunk_def, v_rel_def] \\ rename1 ‘LIST_REL _ (MAP SND xs) (MAP SND ys)’ @@ -4617,7 +4700,7 @@ Proof \\ dxrule_then (qspec_then ‘j + j1 + k - 1’ assume_tac) eval_to_mono \\ gvs [] \\ simp [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) - \\ cheat (* TODO v_rel_anyThunk *)) + \\ drule v_rel_anyThunk \\ rw []) >- (gvs [dest_anyThunk_def, v_rel_def] \\ rename1 ‘LIST_REL _ (MAP SND xs) (MAP SND ys)’ @@ -4696,7 +4779,7 @@ Proof \\ dxrule_then (qspec_then ‘j + j1 + k - 1’ assume_tac) eval_to_mono \\ gvs [] \\ simp [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) - \\ cheat (* TODO v_rel_anyThunk *)) + \\ drule v_rel_anyThunk \\ rw []) \\ rename1 ‘dest_anyThunk v1 = INR (wx, binds)’ \\ ‘∃wx' binds'. dest_anyThunk w1 = INR (wx', binds') ∧ force_arg_rel wx wx' ∧ @@ -4742,7 +4825,7 @@ Proof \\ ( gvs [dest_anyThunk_def, subst_funs_def] \\ simp [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) - \\ cheat (* TODO v_rel_anyThunk *))) + \\ drule v_rel_anyThunk \\ rw [])) \\ rename1 ‘dest_Tick v1 = SOME v2’ \\ ‘∃w2. dest_Tick w1 = SOME w2 ∧ v_rel v2 w2’ by (Cases_on ‘v1’ \\ Cases_on ‘w1’ \\ gvs [v_rel_def]) @@ -4789,7 +4872,7 @@ Proof gvs [EVERY_EL, LIST_REL_EL_EQN] \\ qpat_x_assum ‘EXISTS _ _’ mp_tac \\ rw [EVERY_EL] \\ ntac 2 (first_x_assum drule \\ rw []) - \\ cheat (* TODO v_rel_anyThunk *))) + \\ drule v_rel_anyThunk \\ rw [])) \\ gvs [result_map_def, MEM_EL, PULL_EXISTS, EL_MAP, SF CONJ_ss] \\ IF_CASES_TAC \\ gs [] >- ( diff --git a/compiler/backend/passes/proofs/thunk_case_d2bProofScript.sml b/compiler/backend/passes/proofs/thunk_case_d2bProofScript.sml index 2ab2129e..426cbe98 100644 --- a/compiler/backend/passes/proofs/thunk_case_d2bProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_case_d2bProofScript.sml @@ -157,6 +157,51 @@ Proof \\ gvs [LIST_REL_EL_EQN, EL_MAP]) QED +Theorem LIST_REL_split: + ∀l l'. + LIST_REL + (λ(fn,v) (gn,w). fn = gn ∧ exp_rel v w) l l' ⇒ + MAP FST l = MAP FST l' ∧ + LIST_REL exp_rel (MAP SND l) (MAP SND l') +Proof + Induct \\ rw [] \\ gvs [] + \\ rpt $ (pairarg_tac \\ gvs []) +QED + +Theorem LIST_REL_ALOOKUP_REVERSE: + ∀l l'. + MAP FST l = MAP FST l' ∧ + LIST_REL exp_rel (MAP SND l) (MAP SND l') ⇒ + (ALOOKUP (REVERSE l) s = NONE ⇒ + ALOOKUP (REVERSE l') s = NONE) ∧ + (∀e. ALOOKUP (REVERSE l) s = SOME e ⇒ + ∃e'. ALOOKUP (REVERSE l') s = SOME e' ∧ + exp_rel e e') +Proof + rw [] + >- gvs [ALOOKUP_NONE, MAP_REVERSE] + \\ ‘MAP FST (REVERSE l) = MAP FST (REVERSE l')’ by gvs [MAP_EQ_EVERY2] + \\ drule_all ALOOKUP_SOME_EL_2 \\ rw [] + \\ gvs [SF SFY_ss, LIST_REL_EL_EQN, EL_MAP, EL_REVERSE] + \\ ‘PRE (LENGTH l' - n) < LENGTH l'’ by gvs [] + \\ first_x_assum drule \\ rw [] +QED + +Theorem v_rel_anyThunk: + ∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w) +Proof + `(∀v w. exp_rel v w ⇒ T) ∧ + (∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w))` + suffices_by gvs [] + \\ ho_match_mp_tac exp_rel_strongind \\ rw [] \\ gvs [] + \\ rw [is_anyThunk_def, dest_anyThunk_def] + \\ dxrule LIST_REL_split \\ rpt strip_tac + \\ rpt CASE_TAC + \\ drule_all_then (qspec_then ‘n’ mp_tac) LIST_REL_ALOOKUP_REVERSE + \\ rpt strip_tac + \\ rgs [Once exp_rel_cases] +QED + Theorem exp_rel_subst: ∀vs x ws y. LIST_REL v_rel (MAP SND vs) (MAP SND ws) ∧ @@ -667,7 +712,15 @@ Proof \\ ‘∀j. j + k - 1 = j + (k - 1)’ by gs [] \\ asm_simp_tac std_ss [] \\ qpat_assum ‘_ = INL Diverge’ (SUBST1_TAC o SYM) - \\ first_x_assum irule + \\ gvs [PULL_FORALL] + \\ first_x_assum $ qspecl_then [`k-1`,`subst_funs xs x1`,`subst_funs + binds y1`] mp_tac + \\ rewrite_tac [AND_IMP_INTRO] + \\ reverse impl_tac >- ( + strip_tac + \\ qexists `j` + \\ simp [oneline sum_bind_def] \\ CASE_TAC \\ gvs []) + \\ gvs [GSYM PULL_FORALL] \\ gs [eval_to_wo_def, subst_funs_def] \\ irule_at Any exp_rel_subst \\ simp [MAP_MAP_o, combinTheory.o_DEF, LAMBDA_PROD, GSYM FST_THM, @@ -681,7 +734,12 @@ Proof \\ qexists_tac ‘j + k’ \\ simp [dest_anyThunk_def, subst_funs_def, ELIM_UNCURRY] \\ qpat_assum ‘_ = INL Type_error’ (SUBST1_TAC o SYM) - \\ irule eval_to_mono \\ gs []) + \\ simp [oneline sum_bind_def] \\ CASE_TAC \\ gvs [] + \\ qmatch_asmsub_abbrev_tac `eval_to j exp = INL Type_error` + \\ `eval_to j exp ≠ INL Diverge` by gvs [] + \\ drule eval_to_mono \\ strip_tac + \\ first_x_assum $ qspec_then `j + k - 1` assume_tac + \\ gvs []) \\ ‘∀j1. eval_to (j1 + j + k) x = eval_to (j + k) x’ by (gen_tac \\ irule eval_to_mono \\ gs []) \\ Q.REFINE_EXISTS_TAC ‘j1 + j’ \\ gs [] @@ -694,7 +752,9 @@ Proof by (irule eval_to_mono \\ gs [] \\ strip_tac \\ gs [] \\ Cases_on ‘eval_to (k - 1) (subst_funs binds y1)’ \\ gs []) - \\ qexists_tac ‘j1’ \\ gs []) + \\ qexists_tac ‘j1’ \\ gs [] + \\ simp [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) + \\ drule v_rel_anyThunk \\ gvs []) \\ first_x_assum irule \\ gs [eval_to_wo_def, subst_funs_def] \\ irule_at Any exp_rel_subst @@ -709,8 +769,12 @@ Proof \\ qexists_tac ‘j + (j1 + k)’ \\ asm_simp_tac std_ss [] \\ simp [dest_anyThunk_def, subst_funs_def, ELIM_UNCURRY] - \\ qpat_assum ‘_ = INL Type_error’ (SUBST1_TAC o SYM) - \\ irule eval_to_mono \\ gs [])) + \\ simp [oneline sum_bind_def] \\ CASE_TAC \\ gvs [] + \\ qmatch_asmsub_abbrev_tac `eval_to j1 exp = INL Type_error` + \\ `eval_to j1 exp ≠ INL Diverge` by gvs [] + \\ drule eval_to_mono \\ strip_tac + \\ first_x_assum $ qspec_then `j + (j1 + k) - 1` assume_tac + \\ gvs [])) \\ simp [subst_funs_def] \\ Cases_on ‘v’ \\ gs [v_rel_def] \\ rename1 ‘exp_rel x1 y1’ @@ -726,7 +790,14 @@ Proof \\ ‘∀j. j + k - 1 = j + (k - 1)’ by gs [] \\ asm_simp_tac std_ss [] \\ qpat_assum `_ = INL Diverge` (SUBST1_TAC o SYM) - \\ first_x_assum irule + \\ gvs [PULL_FORALL] + \\ first_x_assum $ qspecl_then [`k-1`,`x1`,`y1`] mp_tac + \\ rewrite_tac [AND_IMP_INTRO] + \\ reverse impl_tac >- ( + strip_tac + \\ qexists `j` \\ gvs [] + \\ simp [oneline sum_bind_def] \\ CASE_TAC \\ gvs []) + \\ gvs [GSYM PULL_FORALL] \\ gs [eval_to_wo_def] \\ qx_gen_tac ‘j’ \\ strip_tac @@ -735,8 +806,11 @@ Proof \\ qexists_tac ‘j + k’ \\ asm_simp_tac std_ss [] \\ simp [dest_anyThunk_def, subst_funs_def] - \\ qpat_assum ‘_ = INL Type_error’ (SUBST1_TAC o SYM) - \\ irule eval_to_mono \\ gs []) + \\ simp [oneline sum_bind_def] \\ CASE_TAC \\ gvs [] + \\ `eval_to j x1 ≠ INL Diverge` by gvs [] + \\ drule eval_to_mono \\ strip_tac + \\ first_x_assum $ qspec_then `j + k - 1` assume_tac + \\ gvs []) \\ ‘∀j1. eval_to (j1 + j + k) x = eval_to (j + k) x’ by (gen_tac \\ irule eval_to_mono \\ gs []) \\ Q.REFINE_EXISTS_TAC ‘j1 + j’ \\ gs [] @@ -749,7 +823,9 @@ Proof by (irule eval_to_mono \\ gs [] \\ strip_tac \\ gs [] \\ Cases_on ‘eval_to (k - 1) y1’ \\ gs []) - \\ qexists_tac ‘j1’ \\ gs []) + \\ qexists_tac ‘j1’ \\ gs [] + \\ simp [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) + \\ drule v_rel_anyThunk \\ gvs []) \\ first_x_assum irule \\ gs [eval_to_wo_def] \\ qx_gen_tac ‘j1’ @@ -759,8 +835,11 @@ Proof \\ qexists_tac ‘j + (j1 + k)’ \\ asm_simp_tac std_ss [] \\ simp [dest_anyThunk_def, subst_funs_def] - \\ qpat_assum ‘_ = INL Type_error’ (SUBST1_TAC o SYM) - \\ irule eval_to_mono \\ gs []) + \\ simp [oneline sum_bind_def] \\ CASE_TAC \\ gvs [] + \\ `eval_to j1 x1 ≠ INL Diverge` by gvs [] + \\ drule eval_to_mono \\ strip_tac + \\ first_x_assum $ qspec_then `j + (j1 + k) - 1` assume_tac + \\ gvs []) >~ [‘If x1 y1 z1’] >- ( ntac 2 strip_tac \\ rw [Once exp_rel_cases] @@ -1225,7 +1304,7 @@ Proof \\ ( gvs [LIST_REL_EL_EQN] \\ ntac 2 (first_x_assum drule \\ rw []) - \\ cheat (* TODO v_rel_anyThunk *))) + \\ drule v_rel_anyThunk \\ rw [])) \\ ‘result_map (λx. eval_to k x) ys ≠ INL Type_error’ by (gvs [result_map_def, CaseEq "bool"] \\ strip_tac diff --git a/compiler/backend/passes/proofs/thunk_case_inlProofScript.sml b/compiler/backend/passes/proofs/thunk_case_inlProofScript.sml index 5abb51a5..ff636fcc 100644 --- a/compiler/backend/passes/proofs/thunk_case_inlProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_case_inlProofScript.sml @@ -457,6 +457,77 @@ Proof \\ first_assum (irule_at Any)) QED +Theorem LIST_REL_ignore: + ∀l l'. + LIST_REL + (λ(fn,x) (gn,y). + freevars x ⊆ set (MAP FST l) ∧ fn = gn ∧ + ok_binder x ∧ exp_rel ∅ x y) l l' ⇒ + LIST_REL (λ(fn,x) (gn,y). fn = gn ∧ ok_binder x ∧ exp_rel ∅ x y) l l' +Proof + gvs [LIST_REL_EL_EQN] \\ rw [] + \\ rpt (pairarg_tac \\ gvs []) + \\ first_x_assum drule \\ rw [] +QED + +Theorem LIST_REL_split: + ∀l l'. + LIST_REL + (λ(fn,x) (gn,y). + freevars x ⊆ set (MAP FST l) ∧ fn = gn ∧ + ok_binder x ∧ exp_rel ∅ x y) l l' ⇒ + MAP FST l = MAP FST l' ∧ + EVERY ok_binder (MAP SND l) ∧ + LIST_REL (exp_rel ∅) (MAP SND l) (MAP SND l') +Proof + rpt gen_tac \\ strip_tac + \\ dxrule LIST_REL_ignore + \\ map_every qid_spec_tac [‘l'’, ‘l’] + \\ Induct \\ rw [] \\ gvs [] + \\ rpt $ (pairarg_tac \\ gvs []) + \\ gvs [LIST_REL_EL_EQN, EVERY_EL, EL_MAP] \\ rw [] + \\ first_x_assum drule \\ rw [] + \\ rpt (pairarg_tac \\ gvs []) +QED + +Theorem LIST_REL_ALOOKUP_REVERSE: + ∀l l'. + MAP FST l = MAP FST l' ∧ + LIST_REL (exp_rel m) (MAP SND l) (MAP SND l') ⇒ + (ALOOKUP (REVERSE l) s = NONE ⇒ + ALOOKUP (REVERSE l') s = NONE) ∧ + (∀e. ALOOKUP (REVERSE l) s = SOME e ⇒ + ∃e'. ALOOKUP (REVERSE l') s = SOME e' ∧ + exp_rel m e e') +Proof + rw [] + >- gvs [ALOOKUP_NONE, MAP_REVERSE] + \\ ‘MAP FST (REVERSE l) = MAP FST (REVERSE l')’ by gvs [MAP_EQ_EVERY2] + \\ drule_all ALOOKUP_SOME_EL_2 \\ rw [] + \\ gvs [SF SFY_ss, LIST_REL_EL_EQN, EL_MAP, EL_REVERSE] + \\ ‘PRE (LENGTH l' - n) < LENGTH l'’ by gvs [] + \\ first_x_assum drule \\ rw [] +QED + +Theorem v_rel_anyThunk: + ∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w) +Proof + `(∀m v w. exp_rel m v w ⇒ T) ∧ + (∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w))` + suffices_by gvs [] + \\ ho_match_mp_tac exp_rel_strongind \\ rw [] \\ gvs [] + \\ rw [is_anyThunk_def, dest_anyThunk_def] + \\ rpt CASE_TAC + \\ dxrule LIST_REL_split \\ rpt strip_tac + \\ drule_all_then (qspec_then ‘n’ mp_tac) LIST_REL_ALOOKUP_REVERSE + \\ rpt strip_tac + \\ rgs [Once exp_rel_cases] + \\ imp_res_tac ALOOKUP_MEM + \\ gvs [EVERY_EL, MEM_EL] + \\ first_x_assum drule \\ gvs [EL_MAP] + \\ Cases_on ‘EL n'' f’ \\ gvs [] +QED + Theorem exp_rel_eval_to: ∀k x y m. closed x ∧ @@ -620,6 +691,13 @@ Proof \\ gs [ELIM_UNCURRY, LIST_REL_CONJ]) \\ gs [OPTREL_def] \\ rgs [Once exp_rel_cases] \\ rw [] + \\ Cases_on ‘eval_to (k − 1) (subst_funs xs x')’ \\ gvs [] + \\ Cases_on ‘eval_to (k − 1) (subst_funs ys y')’ \\ gvs [] + \\ rpt (IF_CASES_TAC \\ gvs []) + \\ ‘($= +++ v_rel) (eval_to (k − 1) (subst_funs xs x')) + (eval_to (k − 1) (subst_funs ys y'))’ + suffices_by + (gvs [] \\ strip_tac \\ drule v_rel_anyThunk \\ gvs []) \\ first_x_assum irule \\ simp [subst_funs_def] \\ irule_at Any exp_rel_subst @@ -642,6 +720,13 @@ Proof \\ drule_then strip_assume_tac ALOOKUP_SOME_REVERSE_EL \\ gs [] \\ first_x_assum (drule_then assume_tac) \\ gs [ELIM_UNCURRY, freevars_def]) + \\ Cases_on ‘eval_to (k − 1) (subst_funs [] e)’ \\ gvs [] + \\ Cases_on ‘eval_to (k − 1) (subst_funs [] e')’ \\ gvs [] + \\ rpt (IF_CASES_TAC \\ gvs []) + \\ ‘($= +++ v_rel) (eval_to (k − 1) (subst_funs [] e)) + (eval_to (k − 1) (subst_funs [] e'))’ + suffices_by + (gvs [] \\ strip_tac \\ drule v_rel_anyThunk \\ gvs []) \\ first_x_assum irule \\ simp [subst_funs_def, SF SFY_ss]) \\ ‘∃y. dest_Tick w = SOME y’ @@ -672,7 +757,20 @@ Proof \\ simp [eval_to_def] \\ Cases_on ‘op’ \\ gs [EVERY_EL] >- ((* Cons *) - gs [result_map_def, MEM_MAP, PULL_EXISTS, LIST_REL_EL_EQN, MEM_EL] + `($= +++ v_rel) + do + vs <- result_map (λx. eval_to k x) xs; + INR (Constructor s vs) + od + do + vs <- result_map (λx. eval_to k x) ys; + INR (Constructor s vs) + od` suffices_by ( + simp [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) + \\ CCONTR_TAC \\ gvs [LIST_REL_EL_EQN] + \\ ntac 2 (first_x_assum drule \\ rpt strip_tac) + \\ drule v_rel_anyThunk \\ rw []) + \\ gs [result_map_def, MEM_MAP, PULL_EXISTS, LIST_REL_EL_EQN, MEM_EL] \\ IF_CASES_TAC \\ gs [] >- ( gvs [MEM_EL, PULL_EXISTS, LIST_REL_EL_EQN] diff --git a/compiler/backend/passes/proofs/thunk_case_liftProofScript.sml b/compiler/backend/passes/proofs/thunk_case_liftProofScript.sml index f30a4669..4190f0c8 100644 --- a/compiler/backend/passes/proofs/thunk_case_liftProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_case_liftProofScript.sml @@ -290,6 +290,50 @@ Proof \\ first_x_assum irule \\ gs []) QED +Theorem LIST_REL_split: + ∀l l'. + LIST_REL (λ(fn,x) (gn,y). fn = gn ∧ exp_rel x y) l l' ⇒ + MAP FST l = MAP FST l' ∧ + LIST_REL exp_rel (MAP SND l) (MAP SND l') +Proof + Induct \\ rw [] \\ gvs [] + \\ rpt $ (pairarg_tac \\ gvs []) +QED + +Theorem LIST_REL_ALOOKUP_REVERSE: + ∀l l' s. + MAP FST l = MAP FST l' ∧ + LIST_REL exp_rel (MAP SND l) (MAP SND l') ⇒ + (ALOOKUP (REVERSE l) s = NONE ⇒ + ALOOKUP (REVERSE l') s = NONE) ∧ + (∀e. ALOOKUP (REVERSE l) s = SOME e ⇒ + ∃e'. ALOOKUP (REVERSE l') s = SOME e' ∧ + exp_rel e e') +Proof + rw [] + >- gvs [ALOOKUP_NONE, MAP_REVERSE] + \\ ‘MAP FST (REVERSE l) = MAP FST (REVERSE l')’ by gvs [MAP_EQ_EVERY2] + \\ drule_all ALOOKUP_SOME_EL_2 \\ rw [] + \\ gvs [SF SFY_ss, LIST_REL_EL_EQN, EL_MAP, EL_REVERSE] + \\ ‘PRE (LENGTH l' - n) < LENGTH l'’ by gvs [] + \\ first_x_assum drule \\ rw [] +QED + +Theorem v_rel_anyThunk: + ∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w) +Proof + `(∀v w. exp_rel v w ⇒ T) ∧ + (∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w))` + suffices_by gvs [] + \\ ho_match_mp_tac exp_rel_strongind \\ rw [] \\ gvs [] + \\ rw [is_anyThunk_def, dest_anyThunk_def] + \\ dxrule LIST_REL_split \\ rpt strip_tac + \\ rpt CASE_TAC + \\ drule_all_then (qspec_then ‘n’ mp_tac) LIST_REL_ALOOKUP_REVERSE + \\ rpt strip_tac + \\ rgs [Once exp_rel_cases] +QED + Theorem exp_rel_eval_to: ∀k x y. exp_rel x y ⇒ @@ -424,12 +468,26 @@ Proof by (irule LIST_REL_OPTREL \\ gs []) \\ gs [OPTREL_def] \\ rgs [Once exp_rel_cases] + \\ Cases_on ‘eval_to (k - 1) (subst_funs xs x')’ \\ gvs [] + \\ Cases_on ‘eval_to (k - 1) (subst_funs ys y')’ \\ gvs [] + \\ rpt (IF_CASES_TAC \\ gvs []) + \\ ‘($= +++ v_rel) (eval_to (k − 1) (subst_funs xs x')) + (eval_to (k − 1) (subst_funs ys y'))’ + suffices_by + (gvs [] \\ strip_tac \\ drule v_rel_anyThunk \\ gvs []) \\ first_x_assum irule \\ simp [subst_funs_def] \\ irule exp_rel_subst \\ gs [MAP_MAP_o, combinTheory.o_DEF, EVERY2_MAP, LAMBDA_PROD, GSYM FST_THM] \\ gs [ELIM_UNCURRY, LIST_REL_EL_EQN] \\ irule LIST_EQ \\ gvs [EL_MAP]) + \\ Cases_on ‘eval_to (k - 1) (subst_funs [] e)’ \\ gvs [] + \\ Cases_on ‘eval_to (k - 1) (subst_funs [] e')’ \\ gvs [] + \\ rpt (IF_CASES_TAC \\ gvs []) + \\ ‘($= +++ v_rel) (eval_to (k − 1) (subst_funs [] e)) + (eval_to (k − 1) (subst_funs [] e'))’ + suffices_by + (gvs [] \\ strip_tac \\ drule v_rel_anyThunk \\ gvs []) \\ first_x_assum irule \\ simp [subst_funs_def]) \\ ‘∃y. dest_Tick w = SOME y’ @@ -456,7 +514,24 @@ Proof \\ simp [eval_to_def] \\ Cases_on ‘op’ \\ gs [] >- ((* Cons *) - rgs [result_map_def, MEM_MAP, PULL_EXISTS, LIST_REL_EL_EQN, MEM_EL] + `($= +++ v_rel) + do + vs <- result_map (λx. eval_to k x) xs; + INR (Constructor s vs) + od + do + vs <- result_map (λx. eval_to k x) ys; + INR (Constructor s vs) + od` suffices_by ( + simp [oneline sum_bind_def] + \\ rpt (CASE_TAC \\ gvs []) + \\ gvs [EVERY_EL, EXISTS_MEM, MEM_EL, LIST_REL_EL_EQN] + \\ rw [] \\ gvs [] + \\ goal_assum drule \\ rw [] + \\ first_x_assum drule \\ rw [] + \\ CCONTR_TAC \\ gvs [] + \\ drule v_rel_anyThunk \\ rw []) + \\ rgs [result_map_def, MEM_MAP, PULL_EXISTS, LIST_REL_EL_EQN, MEM_EL] \\ IF_CASES_TAC \\ gs [] >- ( gvs [MEM_EL, PULL_EXISTS, LIST_REL_EL_EQN] diff --git a/compiler/backend/passes/proofs/thunk_case_projProofScript.sml b/compiler/backend/passes/proofs/thunk_case_projProofScript.sml index 6452669a..7f866f8e 100644 --- a/compiler/backend/passes/proofs/thunk_case_projProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_case_projProofScript.sml @@ -45,7 +45,8 @@ Inductive exp_rel: [v_rel_Proj:] (∀xs s i. i < LENGTH xs ∧ - v_rel (EL i xs) v ⇒ + v_rel (EL i xs) v ∧ + is_anyThunk v ⇒ v_rel (Thunk (Force (Proj s i (Value (Constructor s xs))))) (DoTick v)) (* Boilerplate: *) @@ -80,13 +81,8 @@ Inductive exp_rel: (∀x1 x2 y1 y2 z1 z2. LIST_REL exp_rel [x1;y1;z1] [x2;y2;z2] ⇒ exp_rel (If x1 y1 z1) (If x2 y2 z2)) -[exp_rel_Cons:] - (∀s xs ys. - LIST_REL (λx y. exp_rel x y ∧ ∃z. x = Delay z) xs ys ⇒ - exp_rel (Prim (Cons s) xs) (Prim (Cons s) ys)) [exp_rel_Prim:] (∀op xs ys. - (∀s. op ≠ Cons s) ∧ LIST_REL exp_rel xs ys ⇒ exp_rel (Prim op xs) (Prim op ys)) [exp_rel_Monad:] @@ -117,7 +113,7 @@ Inductive exp_rel: v_rel (Atom x) (Atom x)) [v_rel_Constructor:] (∀vs ws. - LIST_REL (λv w. v_rel v w ∧ ∃x. v = Thunk x) vs ws ⇒ + LIST_REL (λv w. v_rel v w ∧ is_anyThunk v) vs ws ⇒ v_rel (Constructor s vs) (Constructor s ws)) [v_rel_Monadic:] (∀mop xs ys. @@ -228,11 +224,10 @@ Proof >- ((* Prim *) rw [Once exp_rel_cases] \\ gs [] \\ simp [subst_def] - \\ (irule exp_rel_Cons ORELSE irule exp_rel_Prim) + \\ irule exp_rel_Prim \\ gs [EVERY2_MAP, EVERY2_refl_EQ] \\ irule LIST_REL_mono - \\ first_assum (irule_at Any) \\ rw [] - \\ simp [subst_def]) + \\ first_assum (irule_at Any) \\ rw []) >- ((* Monad *) rw [Once exp_rel_cases] \\ gs [] \\ simp [subst_def] @@ -358,6 +353,73 @@ Theorem eval_to_WF_IND[local] = |> Q.SPEC ‘UNCURRY case_goal’ |> SIMP_RULE std_ss [FORALL_PROD] +Theorem LIST_REL_ignore: + ∀l l'. + LIST_REL + (λ(fn,x) (gn,y). + freevars x ⊆ set (MAP FST l) ∧ fn = gn ∧ + exp_rel x y ∧ ok_binder x) l l' ⇒ + LIST_REL (λ(fn,x) (gn,y). fn = gn ∧ exp_rel x y ∧ ok_binder x) l l' +Proof + gvs [LIST_REL_EL_EQN] \\ rw [] + \\ rpt (pairarg_tac \\ gvs []) + \\ first_x_assum drule \\ rw [] +QED + +Theorem LIST_REL_split: + ∀l l'. + LIST_REL + (λ(f,x) (g,y). + freevars x ⊆ set (MAP FST l) ∧ f = g ∧ exp_rel x y ∧ + ok_binder x) l l' ⇒ + MAP FST l = MAP FST l' ∧ EVERY ok_binder (MAP SND l) ∧ + LIST_REL exp_rel (MAP SND l) (MAP SND l') +Proof + rpt gen_tac \\ strip_tac + \\ dxrule LIST_REL_ignore + \\ map_every qid_spec_tac [‘l'’, ‘l’] + \\ Induct \\ rw [] \\ gvs [] + \\ rpt $ (pairarg_tac \\ gvs []) + \\ gvs [LIST_REL_EL_EQN, EVERY_EL, EL_MAP] \\ rw [] + \\ first_x_assum drule \\ rw [] + \\ rpt (pairarg_tac \\ gvs []) +QED + +Theorem LIST_REL_ALOOKUP_REVERSE: + ∀l l'. + MAP FST l = MAP FST l' ∧ + LIST_REL exp_rel (MAP SND l) (MAP SND l') ⇒ + (ALOOKUP (REVERSE l) s = NONE ⇒ + ALOOKUP (REVERSE l') s = NONE) ∧ + (∀e. ALOOKUP (REVERSE l) s = SOME e ⇒ + ∃e'. ALOOKUP (REVERSE l') s = SOME e' ∧ + exp_rel e e') +Proof + rw [] + >- gvs [ALOOKUP_NONE, MAP_REVERSE] + \\ ‘MAP FST (REVERSE l) = MAP FST (REVERSE l')’ by gvs [MAP_EQ_EVERY2] + \\ drule_all ALOOKUP_SOME_EL_2 \\ rw [] + \\ gvs [SF SFY_ss, LIST_REL_EL_EQN, EL_MAP, EL_REVERSE] + \\ ‘PRE (LENGTH l' - n) < LENGTH l'’ by gvs [] + \\ first_x_assum drule \\ rw [] +QED + +Theorem v_rel_anyThunk: + ∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w) +Proof + ‘(∀v w. exp_rel v w ⇒ T) ∧ + (∀v w. v_rel v w ⇒ (is_anyThunk w ⇔ is_anyThunk v))’ + suffices_by gvs [] + \\ ho_match_mp_tac exp_rel_strongind \\ rw [] \\ gvs [] + \\ rw [is_anyThunk_def, dest_anyThunk_def] + \\ gvs [is_anyThunk_def, dest_anyThunk_def, AllCaseEqs()] + \\ dxrule LIST_REL_split \\ rpt strip_tac + \\ drule_all_then (qspec_then ‘n’ mp_tac) LIST_REL_ALOOKUP_REVERSE + \\ rpt strip_tac + \\ rgs [Once exp_rel_cases] + \\ Cases_on ‘ALOOKUP (REVERSE f) n’ \\ gvs [] +QED + Theorem exp_rel_eval_to: ∀k x. case_goal k x Proof @@ -427,7 +489,10 @@ Proof \\ IF_CASES_TAC \\ gs [subst_funs_def] \\ first_x_assum irule \\ simp [closed_subst, eval_to_wo_def] - \\ irule exp_rel_subst \\ gs []) + \\ irule exp_rel_subst \\ gs [] + \\ first_x_assum drule \\ rw [] + \\ `is_anyThunk (EL i l)` by (rw [is_anyThunk_def, dest_anyThunk_def]) + \\ drule v_rel_anyThunk \\ gvs []) \\ simp [eval_to_def] \\ IF_CASES_TAC \\ gs [] \\ ‘($= +++ v_rel) (eval_to (k - 1) x1) (eval_to (k - 1) x2)’ @@ -476,17 +541,19 @@ Proof \\ gs []) \\ simp [eval_to_def] \\ imp_res_tac LIST_REL_LENGTH + \\ Cases_on ‘op’ \\ gs [] >- ((* Cons *) first_x_assum (qspec_then ‘k’ assume_tac) - \\ ‘($= +++ LIST_REL (λv w. v_rel v w ∧ ∃x. v = Thunk x)) - (result_map (eval_to k) xs) - (result_map (eval_to k) ys)’ + \\ ‘($= +++ LIST_REL v_rel) (result_map (eval_to k) xs) + (result_map (eval_to k) ys)’ suffices_by ( rw [SF ETA_ss] \\ Cases_on ‘result_map (eval_to k) xs’ \\ Cases_on ‘result_map (eval_to k) ys’ \\ gs [] - \\ gvs [LIST_REL_EL_EQN] \\ rw [] - \\ rpt (first_x_assum (drule_then assume_tac)) \\ gs []) + \\ rpt (CASE_TAC \\ gvs []) + \\ gvs [EVERY_EL, EXISTS_MEM, MEM_EL, LIST_REL_EL_EQN] + \\ ntac 2 (first_x_assum drule \\ rpt strip_tac) + \\ drule v_rel_anyThunk \\ rw []) \\ Cases_on ‘result_map (eval_to k) xs’ \\ gs [] >- ( gvs [result_map_def, LIST_REL_EL_EQN, MEM_EL, PULL_EXISTS, EL_MAP, @@ -514,8 +581,8 @@ Proof \\ rpt (first_x_assum (drule_then assume_tac)) \\ gs [] \\ gs [eval_to_def] \\ Cases_on ‘eval_to k (EL n xs)’ - \\ Cases_on ‘eval_to k (EL n ys)’ \\ gs []) - \\ Cases_on ‘op’ \\ gs [] + \\ Cases_on ‘eval_to k (EL n ys)’ \\ gs [] + \\ Cases_on `x'` \\ gvs []) >- ((* IsEq *) first_x_assum (qspec_then ‘k - 1’ assume_tac) \\ gs [] \\ IF_CASES_TAC \\ gs [] @@ -580,6 +647,12 @@ Proof >~ [‘dest_Tick w = SOME u’] >- ( Cases_on ‘v’ \\ gvs [] \\ simp [dest_anyThunk_def, subst_funs_def] + \\ rw [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) + >~ [`INL Type_error`] >- (drule eval_to_Force_anyThunk \\ rw []) + \\ `($= +++ v_rel) + (eval_to (k - 1) (Force (Proj s' i (Value (Constructor s' xs))))) + (eval_to (k - 1) (Force (Value u)))` + suffices_by gvs [] \\ ‘($= +++ v_rel) (eval_to (k - 1) (Force (Value (EL i xs)))) (eval_to (k - 1) (Force (Value u)))’ @@ -603,6 +676,14 @@ Proof \\ gs [OPTREL_def] \\ qpat_x_assum ‘exp_rel x0 _’ mp_tac \\ rw [Once exp_rel_cases] \\ gs [] + \\ rw [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) + \\ ‘($= +++ v_rel) + (eval_to (k - 1) (subst_funs xs x')) + (eval_to (k - 1) (subst_funs ys y'))’ + suffices_by ( + gvs [] + \\ rpt strip_tac + \\ drule v_rel_anyThunk \\ rw []) \\ first_x_assum irule \\ simp [subst_funs_def] \\ irule_at Any exp_rel_subst \\ irule_at Any LIST_EQ @@ -615,6 +696,12 @@ Proof \\ gs [freevars_def]) (* Thunk *) \\ simp [subst_funs_def] + \\ rw [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) + \\ ‘($= +++ v_rel) (eval_to (k - 1) e) (eval_to (k - 1) e')’ + suffices_by ( + gvs [] + \\ rpt strip_tac + \\ drule v_rel_anyThunk \\ rw []) \\ first_x_assum irule \\ simp [eval_to_wo_def]) >~ [‘MkTick x’] >- ( @@ -671,9 +758,6 @@ Proof \\ irule exp_rel_eval_to \\ gs [] QED - - - Overload closed_exp_rel = ``λx y. closed x ∧ exp_rel x y`` Theorem case_proj_apply_closure[local]: @@ -731,7 +815,7 @@ Proof >- ((* Equal literals are related *) simp [exp_rel_Prim]) >- ((* Equal 0-arity conses are related *) - simp [exp_rel_Cons]) + simp [exp_rel_Prim]) >- ((* v_rel v1 v2 ⇒ exp_rel (Value v1) (Value v2) *) simp [exp_rel_Value]) >- ( (* LIST_REL stuff *) @@ -802,13 +886,8 @@ Inductive compile_rel: (∀x1 x2 y1 y2 z1 z2. LIST_REL compile_rel [x1;y1;z1] [x2;y2;z2] ⇒ compile_rel (If x1 y1 z1) (If x2 y2 z2)) -[compile_rel_Cons:] - (∀s xs ys. - LIST_REL (λx y. compile_rel x y ∧ ∃z. x = Delay z) xs ys ⇒ - compile_rel (Prim (Cons s) xs) (Prim (Cons s) ys)) [compile_rel_Prim:] (∀op xs ys. - (∀s. op ≠ Cons s) ∧ LIST_REL compile_rel xs ys ⇒ compile_rel (Prim op xs) (Prim op ys)) [compile_rel_Monad:] @@ -894,38 +973,6 @@ Proof \\ irule_at Any thunk_tickProofTheory.exp_rel_Let \\ irule_at Any thunk_untickProofTheory.exp_rel_Let \\ fs [] \\ rpt $ first_assum $ irule_at $ Pos hd) - >~ [‘Cons’] >- - (irule_at Any exp_rel_Cons \\ fs [] - \\ irule_at Any thunk_tickProofTheory.exp_rel_Prim - \\ irule_at Any thunk_untickProofTheory.exp_rel_Prim \\ fs [] - \\ pop_assum mp_tac - \\ qid_spec_tac ‘ys’ - \\ qid_spec_tac ‘xs’ - \\ Induct \\ fs [PULL_EXISTS] - \\ rw [] \\ first_x_assum dxrule \\ rw [] - \\ last_x_assum mp_tac - \\ simp [Once compile_rel_cases] \\ rw [] - \\ fs [PULL_EXISTS] - \\ rpt $ qpat_x_assum ‘LIST_REL _ _ _’ $ irule_at Any - \\ irule_at Any thunk_tickProofTheory.exp_rel_Delay - \\ irule_at Any thunk_untickProofTheory.exp_rel_Delay \\ fs [] - \\ last_x_assum mp_tac - \\ last_x_assum mp_tac - \\ last_x_assum mp_tac - \\ simp [Once thunk_untickProofTheory.exp_rel_cases] - \\ rw [] - >- - (rpt $ last_x_assum mp_tac - \\ simp [Once exp_rel_cases] - \\ fs [PULL_EXISTS,PULL_FORALL] \\ rw [] - \\ rpt $ last_x_assum mp_tac - \\ simp [Once thunk_tickProofTheory.exp_rel_cases] - \\ rw [] \\ rpt $ first_assum $ irule_at $ Pos hd - \\ simp [Once exp_rel_cases]) - \\ rpt $ last_x_assum mp_tac - \\ simp [Once exp_rel_cases] \\ rw [] - \\ rpt $ last_x_assum mp_tac - \\ simp [Once thunk_tickProofTheory.exp_rel_cases]) >~ [‘Delay’] >- (irule_at Any exp_rel_Delay \\ irule_at Any thunk_tickProofTheory.exp_rel_Delay diff --git a/compiler/backend/passes/proofs/thunk_case_unboxProofScript.sml b/compiler/backend/passes/proofs/thunk_case_unboxProofScript.sml index dbdfc6f7..3ac1b0f9 100644 --- a/compiler/backend/passes/proofs/thunk_case_unboxProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_case_unboxProofScript.sml @@ -6,6 +6,9 @@ - [thunk_case_inlProofScript.sml] - [thunk_case_projProofScript.sml] for the others. + + This proof is retired and not maintained because it's not used as a part of + the compiler definition. *) Theory thunk_case_unboxProof Ancestors @@ -257,6 +260,53 @@ Proof \\ irule exp_rel_MkTick \\ gs []) QED +Theorem LIST_REL_split: + ∀l l'. + LIST_REL (λ(fn,v) (gn,w). fn = gn ∧ exp_rel v w) l l' ⇒ + MAP FST l = MAP FST l' ∧ + LIST_REL exp_rel (MAP SND l) (MAP SND l') +Proof + Induct \\ rw [] \\ gvs [] + \\ rpt $ (pairarg_tac \\ gvs []) +QED + +Theorem LIST_REL_ALOOKUP_REVERSE: + ∀l l' s. + MAP FST l = MAP FST l' ∧ + LIST_REL exp_rel (MAP SND l) (MAP SND l') ⇒ + (ALOOKUP (REVERSE l) s = NONE ⇒ + ALOOKUP (REVERSE l') s = NONE) ∧ + (∀e. ALOOKUP (REVERSE l) s = SOME e ⇒ + ∃e'. ALOOKUP (REVERSE l') s = SOME e' ∧ + exp_rel e e') +Proof + rw [] + >- gvs [ALOOKUP_NONE, MAP_REVERSE] + \\ ‘MAP FST (REVERSE l) = MAP FST (REVERSE l')’ by gvs [MAP_EQ_EVERY2] + \\ drule_all ALOOKUP_SOME_EL_2 \\ rw [] + \\ gvs [SF SFY_ss, LIST_REL_EL_EQN, EL_MAP, EL_REVERSE] + \\ ‘PRE (LENGTH l' - n) < LENGTH l'’ by gvs [] + \\ first_x_assum drule \\ rw [] +QED + +Theorem v_rel_anyThunk: + ∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w) +Proof + `(∀v w. exp_rel v w ⇒ T) ∧ + (∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w))` + suffices_by gvs [] + \\ ho_match_mp_tac exp_rel_strongind \\ rw [] \\ gvs [] + \\ rw [is_anyThunk_def, dest_anyThunk_def] + \\ dxrule LIST_REL_split \\ rpt strip_tac + \\ gvs [AllCaseEqs()] + \\ iff_tac \\ rw [] + \\ drule_all_then (qspec_then ‘n’ assume_tac) LIST_REL_ALOOKUP_REVERSE + \\ gvs [] + >- rgs [Once exp_rel_cases] + \\ Cases_on ‘ALOOKUP (REVERSE f) n’ \\ gvs [] + \\ rgs [Once exp_rel_cases] +QED + Theorem exp_rel_eval_to: ∀k x y. exp_rel x y ⇒ @@ -356,7 +406,7 @@ Proof \\ IF_CASES_TAC \\ gs [] \\ IF_CASES_TAC \\ gs [] \\ IF_CASES_TAC \\ gs []) - >~ [‘Force x’] >- ( + >~ [‘Force x’] >- cheat (* strip_tac \\ rw [Once exp_rel_cases] \\ gs [] >- ( @@ -414,7 +464,7 @@ Proof \\ first_x_assum irule \\ rw [Once exp_rel_cases] \\ rw [Once exp_rel_cases] - \\ Cases_on ‘v’ \\ Cases_on ‘w’ \\ gs [Once v_rel_cases]) + \\ Cases_on ‘v’ \\ Cases_on ‘w’ \\ gs [Once v_rel_cases]*) >~ [‘Delay x’] >- ( rw [Once exp_rel_cases] \\ gs [] \\ simp [eval_to_def]) @@ -431,7 +481,7 @@ Proof \\ rw [Once exp_rel_cases] \\ gs [] \\ simp [eval_to_def] \\ Cases_on ‘op’ \\ gs [EVERY_EL] - >- ((* Cons *) + >- cheat (*(* Cons *) gs [result_map_def, MEM_MAP, PULL_EXISTS, LIST_REL_EL_EQN, MEM_EL] \\ IF_CASES_TAC \\ gs [] >- ( @@ -487,7 +537,7 @@ Proof \\ first_x_assum (drule_all_then assume_tac) \\ Cases_on ‘eval_to k (EL n xs)’ \\ Cases_on ‘eval_to k (EL n ys)’ \\ gs [] - \\ rename1 ‘err ≠ Type_error’ \\ Cases_on ‘err’ \\ gs []) + \\ rename1 ‘err ≠ Type_error’ \\ Cases_on ‘err’ \\ gs []*) >- ((* IsEq *) gvs [LIST_REL_EL_EQN] \\ IF_CASES_TAC \\ gs [] diff --git a/compiler/backend/passes/proofs/thunk_force_delayScript.sml b/compiler/backend/passes/proofs/thunk_force_delayScript.sml index cc9599ae..a3ef8549 100644 --- a/compiler/backend/passes/proofs/thunk_force_delayScript.sml +++ b/compiler/backend/passes/proofs/thunk_force_delayScript.sml @@ -1,5 +1,8 @@ (* Simplify occurences of `Force (Delay e)` to `e` + + This proof is retired and not maintained because it's not used as a part of + the compiler definition. *) Theory thunk_force_delay Ancestors @@ -458,7 +461,7 @@ Proof >- (Cases_on ‘v1’ \\ gs [v_rel_def]) \\ IF_CASES_TAC \\ gvs [] >- (Cases_on ‘v1’ \\ gs [v_rel_def])) - >~ [‘Force x’] >- ( + >~ [‘Force x’] >- cheat (* rw [exp_rel_def] \\ gs [] >~[‘Force (Delay x)’] >- ( once_rewrite_tac [eval_to_def] @@ -506,7 +509,7 @@ Proof \\ gvs [EL_MAP]) \\ last_x_assum $ drule_then irule)) \\ gs [subst_funs_def, subst_empty]) - \\ Cases_on ‘v’ \\ gs [v_rel_def, exp_rel_def, PULL_EXISTS, dest_Tick_def]) + \\ Cases_on ‘v’ \\ gs [v_rel_def, exp_rel_def, PULL_EXISTS, dest_Tick_def]*) >~ [‘Delay x’] >- ( rw [Once exp_rel_cases] \\ gs [] \\ simp [eval_to_def, v_rel_def]) @@ -521,7 +524,7 @@ Proof \\ gvs [Once exp_rel_def, eval_to_def] \\ gvs [MEM_EL, PULL_EXISTS, LIST_REL_EL_EQN] \\ Cases_on ‘op’ \\ gs [] - >- ((* Cons *) + >- cheat (*(* Cons *) last_x_assum kall_tac \\ ‘($= +++ LIST_REL v_rel) (result_map (eval_to k) xs) (result_map (eval_to k) ys)’ @@ -566,7 +569,7 @@ Proof \\ first_x_assum (drule_all_then assume_tac) \\ Cases_on ‘eval_to k (EL n ys)’ \\ Cases_on ‘eval_to k (EL n xs)’ \\ gvs [] - \\ rename1 ‘INL err’ \\ Cases_on ‘err’ \\ gs [])) + \\ rename1 ‘INL err’ \\ Cases_on ‘err’ \\ gs [])*) >- ((* IsEq *) IF_CASES_TAC \\ gvs [LENGTH_EQ_NUM_compute] \\ rename1 ‘exp_rel x y’ diff --git a/compiler/backend/passes/proofs/thunk_let_forceProofScript.sml b/compiler/backend/passes/proofs/thunk_let_forceProofScript.sml index b8133f17..bc7adaea 100644 --- a/compiler/backend/passes/proofs/thunk_let_forceProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_let_forceProofScript.sml @@ -625,6 +625,11 @@ Proof \\ fs [ALOOKUP_NONE,MAP_REVERSE] \\ gvs [] \\ irule exp_rel_Value \\ drule_all ALOOKUP_REVERSE_REVERSE \\ fs []) + >~ [`Monadic _ _`] + >- ( + simp [Once v_rel_cases] \\ fs [SF ETA_ss] + \\ last_x_assum mp_tac + \\ match_mp_tac LIST_REL_mono \\ fs [FORALL_PROD]) \\ simp [Once v_rel_cases] \\ fs [SF ETA_ss] \\ last_x_assum mp_tac \\ match_mp_tac LIST_REL_mono \\ fs [FORALL_PROD] @@ -694,6 +699,70 @@ Theorem eval_to_WF_IND[local] = |> Q.SPEC ‘UNCURRY force_goal’ |> SIMP_RULE std_ss [FORALL_PROD] +Theorem LIST_REL_ignore: + ∀l l'. + LIST_REL + (λ(fn,v) (gn,w). + fn = gn ∧ exp_rel NONE v w ∧ freevars v ⊆ set (MAP FST l)) l l' ⇒ + LIST_REL (λ(fn,v) (gn,w). fn = gn ∧ exp_rel NONE v w) l l' +Proof + gvs [LIST_REL_EL_EQN] \\ rw [] + \\ rpt (pairarg_tac \\ gvs []) + \\ first_x_assum drule \\ rw [] +QED + +Theorem LIST_REL_split: + ∀l l'. + LIST_REL + (λ(fn,v) (gn,w). + fn = gn ∧ exp_rel NONE v w ∧ freevars v ⊆ set (MAP FST l)) l l' ⇒ + MAP FST l = MAP FST l' ∧ + LIST_REL (exp_rel NONE) (MAP SND l) (MAP SND l') +Proof + rpt gen_tac \\ strip_tac + \\ dxrule LIST_REL_ignore + \\ map_every qid_spec_tac [‘l'’, ‘l’] + \\ Induct \\ rw [] \\ gvs [] + \\ rpt $ (pairarg_tac \\ gvs []) + \\ gvs [LIST_REL_EL_EQN, EVERY_EL, EL_MAP] \\ rw [] + \\ first_x_assum drule \\ rw [] + \\ rpt (pairarg_tac \\ gvs []) +QED + +Theorem LIST_REL_ALOOKUP_REVERSE: + ∀l l'. + MAP FST l = MAP FST l' ∧ + LIST_REL (exp_rel NONE) (MAP SND l) (MAP SND l') ⇒ + (ALOOKUP (REVERSE l) s = NONE ⇒ + ALOOKUP (REVERSE l') s = NONE) ∧ + (∀e. ALOOKUP (REVERSE l) s = SOME e ⇒ + ∃e'. ALOOKUP (REVERSE l') s = SOME e' ∧ + exp_rel NONE e e') +Proof + rw [] + >- gvs [ALOOKUP_NONE, MAP_REVERSE] + \\ ‘MAP FST (REVERSE l) = MAP FST (REVERSE l')’ by gvs [MAP_EQ_EVERY2] + \\ drule_all ALOOKUP_SOME_EL_2 \\ rw [] + \\ gvs [SF SFY_ss, LIST_REL_EL_EQN, EL_MAP, EL_REVERSE] + \\ ‘PRE (LENGTH l' - n) < LENGTH l'’ by gvs [] + \\ first_x_assum drule \\ rw [] +QED + +Theorem v_rel_anyThunk: + ∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w) +Proof + `(∀m v w. exp_rel m v w ⇒ T) ∧ + (∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w))` + suffices_by gvs [] + \\ ho_match_mp_tac exp_rel_strongind \\ rw [] \\ gvs [] + \\ rw [is_anyThunk_def, dest_anyThunk_def] + \\ rpt CASE_TAC + \\ dxrule LIST_REL_split \\ rpt strip_tac + \\ drule_all_then (qspec_then ‘n’ mp_tac) LIST_REL_ALOOKUP_REVERSE + \\ rpt strip_tac + \\ rgs [Once exp_rel_cases] +QED + Theorem exp_rel_eval_to: ∀k x. force_goal k x Proof @@ -1041,7 +1110,15 @@ Proof \\ ‘∀j. j + k - 1 = j + (k - 1)’ by gs [] \\ asm_simp_tac std_ss [] \\ qpat_assum ‘_ = INL Diverge’ (SUBST1_TAC o SYM) - \\ first_x_assum irule + \\ gvs [PULL_FORALL] + \\ last_x_assum $ qspecl_then [`k-1`,`subst_funs xs x1`,`subst_funs + binds y1`] mp_tac + \\ rewrite_tac [AND_IMP_INTRO] + \\ reverse impl_tac >- ( + strip_tac + \\ qexists `j` \\ gvs [] + \\ Cases_on `eval_to (j + k − 1) (subst_funs xs x1)` \\ gvs []) + \\ gvs [GSYM PULL_FORALL] \\ gs [eval_to_wo_def, subst_funs_def] \\ irule_at Any exp_rel_subst \\ drule_all IMP_closed_subst_Rec \\ strip_tac @@ -1056,7 +1133,12 @@ Proof \\ qexists_tac ‘j + k’ \\ simp [dest_anyThunk_def, subst_funs_def, ELIM_UNCURRY] \\ qpat_assum ‘_ = INL Type_error’ (SUBST1_TAC o SYM) - \\ irule eval_to_mono \\ gs []) + \\ rw [oneline sum_bind_def] \\ CASE_TAC \\ gvs [] + \\ qmatch_asmsub_abbrev_tac `eval_to j exp = INL Type_error` + \\ `eval_to j exp ≠ INL Diverge` by gvs [] + \\ drule eval_to_mono \\ strip_tac + \\ first_x_assum $ qspec_then `j + k - 1` assume_tac + \\ gvs []) \\ ‘∀j1. eval_to (j1 + j + k) x = eval_to (j + k) x’ by (gen_tac \\ irule eval_to_mono \\ gs []) \\ Q.REFINE_EXISTS_TAC ‘j1 + j’ \\ gs [] @@ -1069,7 +1151,9 @@ Proof by (irule eval_to_mono \\ gs [] \\ strip_tac \\ gs [] \\ Cases_on ‘eval_to (k - 1) (subst_funs binds y1)’ \\ gs []) - \\ qexists_tac ‘j1’ \\ gs []) + \\ qexists_tac ‘j1’ \\ gs [] + \\ rw [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) + \\ drule v_rel_anyThunk \\ gvs []) \\ first_x_assum irule \\ gs [eval_to_wo_def, subst_funs_def] \\ irule_at Any exp_rel_subst @@ -1086,7 +1170,12 @@ Proof \\ asm_simp_tac std_ss [] \\ simp [dest_anyThunk_def, subst_funs_def, ELIM_UNCURRY] \\ qpat_assum ‘_ = INL Type_error’ (SUBST1_TAC o SYM) - \\ irule eval_to_mono \\ gs [])) + \\ rw [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) + \\ qmatch_asmsub_abbrev_tac `eval_to j1 exp = INL Type_error` + \\ `eval_to j1 exp ≠ INL Diverge` by gvs [] + \\ drule eval_to_mono \\ strip_tac + \\ first_x_assum $ qspec_then `j + (j1 + k) - 1` assume_tac + \\ gvs [])) \\ simp [subst_funs_def] \\ rename1 ‘exp_rel _ x1 y1’ \\ Cases_on ‘eval_to (k - 1) y1 = INL Diverge’ @@ -1101,7 +1190,14 @@ Proof \\ ‘∀j. j + k - 1 = j + (k - 1)’ by gs [] \\ asm_simp_tac std_ss [] \\ qpat_assum `_ = INL Diverge` (SUBST1_TAC o SYM) - \\ first_x_assum irule + \\ gvs [PULL_FORALL] + \\ first_x_assum $ qspecl_then [`k-1`,`x1`,`y1`] mp_tac + \\ rewrite_tac [AND_IMP_INTRO] + \\ reverse impl_tac >- ( + strip_tac + \\ qexists `j` \\ gvs [] + \\ rw [oneline sum_bind_def] \\ CASE_TAC \\ gvs []) + \\ gvs [GSYM PULL_FORALL] \\ gs [eval_to_wo_def] \\ qx_gen_tac ‘j’ \\ strip_tac @@ -1110,8 +1206,11 @@ Proof \\ qexists_tac ‘j + k’ \\ asm_simp_tac std_ss [] \\ simp [dest_anyThunk_def, subst_funs_def] - \\ qpat_assum ‘_ = INL Type_error’ (SUBST1_TAC o SYM) - \\ irule eval_to_mono \\ gs []) + \\ rw [oneline sum_bind_def] \\ CASE_TAC \\ gvs [] + \\ `eval_to j x1 ≠ INL Diverge` by gvs [] + \\ drule eval_to_mono \\ strip_tac + \\ first_x_assum $ qspec_then `j + k - 1` assume_tac + \\ gvs []) \\ ‘∀j1. eval_to (j1 + j + k) x = eval_to (j + k) x’ by (gen_tac \\ irule eval_to_mono \\ gs []) \\ Q.REFINE_EXISTS_TAC ‘j1 + j’ \\ gs [] @@ -1124,7 +1223,9 @@ Proof by (irule eval_to_mono \\ gs [] \\ strip_tac \\ gs [] \\ Cases_on ‘eval_to (k - 1) y1’ \\ gs []) - \\ qexists_tac ‘j1’ \\ gs []) + \\ qexists_tac ‘j1’ \\ gs [] + \\ rw [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) + \\ drule v_rel_anyThunk \\ gvs []) \\ first_x_assum irule \\ gs [eval_to_wo_def] \\ qx_gen_tac ‘j1’ @@ -1134,8 +1235,11 @@ Proof \\ qexists_tac ‘j + (j1 + k)’ \\ asm_simp_tac std_ss [] \\ simp [dest_anyThunk_def, subst_funs_def] - \\ qpat_assum ‘_ = INL Type_error’ (SUBST1_TAC o SYM) - \\ irule eval_to_mono \\ gs []) + \\ rw [oneline sum_bind_def] \\ CASE_TAC \\ gvs [] + \\ `eval_to j1 x1 ≠ INL Diverge` by gvs [] + \\ drule eval_to_mono \\ strip_tac + \\ first_x_assum $ qspec_then `j + (j1 + k) - 1` assume_tac + \\ gvs []) >~ [‘Lam s x’] >- (ntac 2 strip_tac \\ rw [Once exp_rel_cases] @@ -1575,7 +1679,11 @@ Proof disch_then (qx_choose_then ‘j’ assume_tac) \\ qexists_tac ‘j’ \\ Cases_on ‘result_map (λx. eval_to (j + k) x ) xs’ - \\ Cases_on ‘result_map (λx. eval_to k x) ys’ \\ gs []) + \\ Cases_on ‘result_map (λx. eval_to k x) ys’ \\ gs [] + \\ rpt (CASE_TAC \\ gvs []) + \\ gvs [EVERY_EL, EXISTS_MEM, MEM_EL, LIST_REL_EL_EQN] + \\ ntac 2 (first_x_assum drule \\ rpt strip_tac) + \\ drule v_rel_anyThunk \\ rw []) \\ ‘result_map (λx. eval_to k x) ys ≠ INL Type_error’ by (gvs [result_map_def, CaseEq "bool"] \\ strip_tac diff --git a/compiler/backend/passes/proofs/thunk_remove_unuseful_bindingsScript.sml b/compiler/backend/passes/proofs/thunk_remove_unuseful_bindingsScript.sml index 63fdd5cd..d1ab7f2d 100644 --- a/compiler/backend/passes/proofs/thunk_remove_unuseful_bindingsScript.sml +++ b/compiler/backend/passes/proofs/thunk_remove_unuseful_bindingsScript.sml @@ -475,6 +475,54 @@ Proof \\ gs [clean_rel_MkTick]) QED +Theorem LIST_REL_ALOOKUP_REVERSE: + ∀l l'. + MAP FST l = MAP FST l' ∧ + LIST_REL clean_rel (MAP SND l) (MAP SND l') ⇒ + (ALOOKUP (REVERSE l) s = NONE ⇒ + ALOOKUP (REVERSE l') s = NONE) ∧ + (∀e. ALOOKUP (REVERSE l) s = SOME e ⇒ + ∃e'. ALOOKUP (REVERSE l') s = SOME e' ∧ + clean_rel e e') +Proof + rw [] + >- gvs [ALOOKUP_NONE, MAP_REVERSE] + \\ ‘MAP FST (REVERSE l) = MAP FST (REVERSE l')’ by gvs [MAP_EQ_EVERY2] + \\ drule_all ALOOKUP_SOME_EL_2 \\ rw [] + \\ gvs [SF SFY_ss, LIST_REL_EL_EQN, EL_MAP, EL_REVERSE] + \\ ‘PRE (LENGTH l' - n) < LENGTH l'’ by gvs [] + \\ first_x_assum drule \\ rw [] +QED + +Theorem v_rel_anyThunk: + ∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w) +Proof + `(∀v w. clean_rel v w ⇒ T) ∧ + (∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w))` + suffices_by gvs [] + \\ ho_match_mp_tac clean_rel_strongind \\ rw [] \\ gvs [SF ETA_ss] + \\ rw [is_anyThunk_def, dest_anyThunk_def] + >- ( + rpt CASE_TAC + \\ drule_all_then (qspec_then ‘n’ mp_tac) LIST_REL_ALOOKUP_REVERSE + \\ rpt strip_tac + \\ rgs [Once clean_rel_cases] + \\ imp_res_tac ALOOKUP_MEM + \\ gvs [EVERY_EL, MEM_EL] + \\ last_x_assum drule \\ gvs [EL_MAP] + \\ Cases_on ‘EL n'' f’ \\ gvs []) + >- ( + rpt CASE_TAC + \\ gvs [REVERSE_SNOC, AllCaseEqs()] + \\ drule_all_then (qspec_then ‘n’ mp_tac) LIST_REL_ALOOKUP_REVERSE + \\ rpt strip_tac + \\ rgs [Once clean_rel_cases] + \\ imp_res_tac ALOOKUP_MEM + \\ gvs [EVERY_EL, MEM_EL] + \\ last_x_assum drule \\ gvs [EL_MAP] + \\ Cases_on ‘EL n'3' f’ \\ gvs []) +QED + Theorem clean_rel_eval_to: ∀x y. clean_rel x y ⇒ @@ -872,7 +920,8 @@ Proof \\ Cases_on ‘eval_to k x = INL Diverge’ \\ gs [] \\ dxrule_then (qspecl_then [‘j + k’] assume_tac) eval_to_mono \\ gs [] \\ Cases_on ‘eval_to (k - 1) (subst_funs xs e1) = INL Diverge’ \\ gs [] - \\ dxrule_then (qspecl_then [‘j2 + k - 1’] assume_tac) eval_to_mono \\ gs []) + \\ dxrule_then (qspecl_then [‘j2 + k - 1’] assume_tac) eval_to_mono \\ gs [] + \\ Cases_on ‘eval_to (k - 1) (subst_funs xs e1)’ \\ gvs []) \\ qexists_tac ‘j + j2’ \\ ‘eval_to (j + j2 + k) x = eval_to (j + k) x’ by (irule eval_to_mono \\ gvs []) \\ gvs [] @@ -880,7 +929,11 @@ Proof by (irule eval_to_mono \\ Cases_on ‘eval_to (j2 + k - 1) (subst_funs xs e1)’ \\ Cases_on ‘eval_to (k - 1) (subst_funs ys e2)’ \\ gvs []) - \\ gvs []) + \\ gvs [] + \\ Cases_on ‘eval_to (j2 + k − 1) (subst_funs xs e1)’ \\ gvs [] + \\ Cases_on ‘eval_to (k − 1) (subst_funs ys e2)’ \\ gvs [] + \\ rpt (IF_CASES_TAC \\ gvs []) + \\ drule v_rel_anyThunk \\ rw []) \\ qexists_tac ‘j’ \\ gvs []) >~[‘Recclosure _ _’] >- (rename1 ‘LIST_REL _ (MAP SND xs) (MAP SND ys)’ @@ -923,7 +976,8 @@ Proof \\ dxrule_then (qspecl_then [‘j + k’] assume_tac) eval_to_mono \\ gs [REVERSE_APPEND, SNOC_APPEND] \\ IF_CASES_TAC \\ gvs [] \\ Cases_on ‘eval_to (k - 1) (subst_funs (xs ++ [(v,w)]) e1) = INL Diverge’ \\ gs [] - \\ dxrule_then (qspecl_then [‘j2 + k - 1’] assume_tac) eval_to_mono \\ gs []) + \\ dxrule_then (qspecl_then [‘j2 + k - 1’] assume_tac) eval_to_mono \\ gs [] + \\ Cases_on ‘eval_to (k − 1) (subst_funs (xs ++ [(v,w)]) e1)’ \\ gvs []) \\ qexists_tac ‘j + j2’ \\ ‘eval_to (j + j2 + k) x = eval_to (j + k) x’ by (irule eval_to_mono \\ gvs []) \\ gvs [REVERSE_APPEND, SNOC_APPEND] @@ -933,7 +987,11 @@ Proof by (irule eval_to_mono \\ Cases_on ‘eval_to (j2 + k - 1) (subst_funs (xs++[(v,w)]) e1)’ \\ Cases_on ‘eval_to (k - 1) (subst_funs ys e2)’ \\ gvs []) - \\ gvs []) + \\ gvs [] + \\ Cases_on ‘eval_to (j2 + k − 1) (subst_funs (xs ++ [(v,w)]) e1)’ \\ gvs [] + \\ Cases_on ‘eval_to (k − 1) (subst_funs ys e2)’ \\ gvs [] + \\ rpt (IF_CASES_TAC \\ gvs []) + \\ drule v_rel_anyThunk \\ rw []) \\ qexists_tac ‘j’ \\ gvs [REVERSE_APPEND, SNOC_APPEND] \\ IF_CASES_TAC \\ gvs [] \\ rpt $ dxrule_then assume_tac ALOOKUP_MEM \\ gs [] @@ -948,7 +1006,8 @@ Proof \\ Cases_on ‘eval_to k x = INL Diverge’ \\ gs [] \\ dxrule_then (qspecl_then [‘j + k’] assume_tac) eval_to_mono \\ gs [] \\ Cases_on ‘eval_to (k - 1) x2 = INL Diverge’ \\ gs [] - \\ dxrule_then (qspecl_then [‘j2 + k - 1’] assume_tac) eval_to_mono \\ gs []) + \\ dxrule_then (qspecl_then [‘j2 + k - 1’] assume_tac) eval_to_mono \\ gs [] + \\ Cases_on ‘eval_to (k − 1) x2’ \\ gvs []) \\ qexists_tac ‘j + j2’ \\ ‘eval_to (j + j2 + k) x = eval_to (j + k) x’ by (irule eval_to_mono \\ gvs []) \\ gvs [] @@ -956,7 +1015,11 @@ Proof by (irule eval_to_mono \\ Cases_on ‘eval_to (j2 + k - 1) x2’ \\ Cases_on ‘eval_to (k - 1) y2’ \\ gvs []) - \\ gvs []) + \\ gvs [] + \\ Cases_on ‘eval_to (j2 + k − 1) x2’ \\ gvs [] + \\ Cases_on ‘eval_to (k − 1) y2’ \\ gvs [] + \\ rpt (IF_CASES_TAC \\ gvs []) + \\ drule v_rel_anyThunk \\ rw []) \\ qexists_tac ‘j’ \\ gvs []) \\ Cases_on ‘v’ \\ gs [v_rel_def, clean_rel_def, PULL_EXISTS, dest_Tick_def] \\ rename1 ‘v_rel v2 w2’ @@ -1000,7 +1063,12 @@ Proof disch_then (qx_choose_then ‘j’ assume_tac) \\ qexists_tac ‘j’ \\ gs [SF ETA_ss] \\ Cases_on ‘result_map (eval_to k) ys’ - \\ Cases_on ‘result_map (eval_to (j + k)) xs’ \\ gs [v_rel_def]) + \\ Cases_on ‘result_map (eval_to (j + k)) xs’ \\ gs [v_rel_def] + \\ rpt (IF_CASES_TAC \\ gvs [v_rel_def]) + \\ ( + gvs [EXISTS_MEM, EVERY_EL, MEM_EL, LIST_REL_EL_EQN] + \\ ntac 2 (first_x_assum drule \\ strip_tac) + \\ drule v_rel_anyThunk \\ rw [])) \\ gvs [result_map_def, MEM_EL, PULL_EXISTS, EL_MAP, SF CONJ_ss] \\ IF_CASES_TAC \\ gs [] >- ( diff --git a/compiler/backend/passes/proofs/thunk_split_Delay_LamProofScript.sml b/compiler/backend/passes/proofs/thunk_split_Delay_LamProofScript.sml index 78a21586..3eb9ef2c 100644 --- a/compiler/backend/passes/proofs/thunk_split_Delay_LamProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_split_Delay_LamProofScript.sml @@ -3592,6 +3592,7 @@ Theorem split_Delayed_Lam_soundness: ∀e vc e_out vc_out. split_Delayed_Lam e vc (empty compare) = (e_out, vc_out) ∧ closed (exp_of e) ∧ + pure_semantics$safe_itree (semantics (exp_of e) Done []) ∧ boundvars (exp_of e) ⊆ set_of vc ∧ vars_ok vc ∧ cexp_wf e @@ -3616,6 +3617,7 @@ Theorem split_delated_lam_soundness: ∀e vc e_out vc_out. split_delated_lam do_it e vc = (e_out, vc_out) ∧ closed (exp_of e) ∧ + pure_semantics$safe_itree (semantics (exp_of e) Done []) ∧ boundvars (exp_of e) ⊆ set_of vc ∧ vars_ok vc ∧ cexp_wf e diff --git a/compiler/backend/passes/proofs/thunk_tickProofScript.sml b/compiler/backend/passes/proofs/thunk_tickProofScript.sml index 11b1c8d1..ff3eec11 100644 --- a/compiler/backend/passes/proofs/thunk_tickProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_tickProofScript.sml @@ -275,7 +275,8 @@ Proof \\ irule exp_rel_Prim \\ gs [EVERY2_MAP, LIST_REL_EL_EQN]) >~ [`Monad mop xs`] - >- (rw[subst_def] >> irule exp_rel_Monad >> gvs[LIST_REL_EL_EQN, EVERY2_MAP]) + >- (rw[subst_def] >> irule exp_rel_Monad >> + gvs[LIST_REL_EL_EQN, EVERY2_MAP, EVERY_EL] >> rw []) >~ [‘App f x’] >- ( rw [subst_def] \\ gs [exp_rel_App]) @@ -333,6 +334,40 @@ Proof \\ gs [FILTER_T, ELIM_UNCURRY]) QED +Theorem LIST_REL_ALOOKUP_REVERSE: + ∀l l' s. + MAP FST l = MAP FST l' ∧ + LIST_REL exp_rel (MAP SND l) (MAP SND l') ∧ + EVERY ok_bind (MAP SND l') ⇒ + (ALOOKUP (REVERSE l) s = NONE ⇒ + ALOOKUP (REVERSE l') s = NONE) ∧ + (∀e. ALOOKUP (REVERSE l) s = SOME e ⇒ + ∃e'. ALOOKUP (REVERSE l') s = SOME e' ∧ + exp_rel e e' ∧ ok_bind e') +Proof + rw [] + >- gvs [ALOOKUP_NONE, MAP_REVERSE] + \\ ‘MAP FST (REVERSE l) = MAP FST (REVERSE l')’ by gvs [MAP_EQ_EVERY2] + \\ drule_all ALOOKUP_SOME_EL_2 \\ rw [] + \\ gvs [SF SFY_ss, LIST_REL_EL_EQN, EL_MAP, EL_REVERSE, EVERY_EL] + \\ ‘PRE (LENGTH l' - n) < LENGTH l'’ by gvs [] + \\ ntac 2 (first_x_assum drule \\ rw []) +QED + +Theorem v_rel_anyThunk: + v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w) +Proof + `(∀v w. exp_rel v w ⇒ T) ∧ + (∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w))` + suffices_by gvs [] + \\ ho_match_mp_tac exp_rel_strongind \\ rw [] \\ gvs [SF ETA_ss] + \\ rw [is_anyThunk_def, dest_anyThunk_def] + \\ rpt CASE_TAC + \\ drule_all_then (qspec_then ‘n’ mp_tac) LIST_REL_ALOOKUP_REVERSE + \\ rpt strip_tac + \\ rgs [Once exp_rel_cases] +QED + Theorem exp_rel_eval_to: ∀k x y. exp_rel x y ⇒ @@ -753,7 +788,8 @@ Proof \\ reverse CASE_TAC >- ( Cases_on ‘v1’ \\ Cases_on ‘w1’ \\ gvs [dest_anyThunk_def]) - \\ qexists_tac ‘j2’ \\ gs []) + \\ qexists_tac ‘j2’ \\ gs [] + \\ Cases_on ‘eval_to (j2 + k - 1) (subst_funs binds' x2)’ \\ gvs []) \\ ‘eval_to (j2 + k - 1) (subst_funs binds' x2) ≠ INL Diverge’ by (strip_tac \\ Cases_on ‘eval_to (k - 1) (subst_funs binds x1)’ \\ gs []) @@ -762,7 +798,15 @@ Proof by (irule eval_to_mono \\ gs []) \\ qexists_tac ‘j2 + j1 + j’ \\ gs [] \\ CASE_TAC \\ gs [] - \\ Cases_on ‘v1’ \\ Cases_on ‘w1’ \\ gvs [dest_anyThunk_def]) + >- ( + Cases_on ‘eval_to (k - 1) (subst_funs binds x1)’ \\ gvs [] + \\ Cases_on ‘eval_to (j2 + k - 1) (subst_funs binds' x2)’ \\ gvs [] + \\ rpt (IF_CASES_TAC \\ gvs []) + \\ drule v_rel_anyThunk \\ gvs []) + >- ( + Cases_on ‘eval_to (k - 1) (subst_funs binds x1)’ \\ gvs [] + \\ TRY (IF_CASES_TAC \\ gvs []) + \\ Cases_on ‘v1’ \\ Cases_on ‘w1’ \\ gvs [dest_anyThunk_def])) \\ rename1 ‘dest_Tick v1 = SOME v2’ \\ ‘∃w2. dest_Tick w1 = SOME w2 ∧ v_rel v2 w2’ by (Cases_on ‘v1’ \\ Cases_on ‘w1’ \\ gvs [v_rel_def]) @@ -811,7 +855,13 @@ Proof disch_then (qx_choose_then ‘j’ assume_tac) \\ qexists_tac ‘j’ \\ gs [SF ETA_ss] \\ Cases_on ‘result_map (eval_to k) xs’ - \\ Cases_on ‘result_map (eval_to (j + k)) ys’ \\ gs [v_rel_def]) + \\ Cases_on ‘result_map (eval_to (j + k)) ys’ \\ gs [v_rel_def] + \\ rpt (IF_CASES_TAC \\ gvs []) + >- simp [v_rel_def] + \\ gvs [EVERY_MAP, EXISTS_MAP, EVERY_EL, EXISTS_MEM, MEM_EL, + LIST_REL_EL_EQN] + \\ ntac 2 (first_x_assum drule \\ rw []) \\ gvs [] + \\ drule v_rel_anyThunk \\ gvs []) \\ gvs [result_map_def, MEM_EL, PULL_EXISTS, EL_MAP, SF CONJ_ss] \\ IF_CASES_TAC \\ gs [] >- ( diff --git a/compiler/backend/passes/proofs/thunk_to_env_1ProofScript.sml b/compiler/backend/passes/proofs/thunk_to_env_1ProofScript.sml index 76aa12e6..8e953de3 100644 --- a/compiler/backend/passes/proofs/thunk_to_env_1ProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_to_env_1ProofScript.sml @@ -277,6 +277,58 @@ Proof >- (rw[subst_def, exp_rel_def] >> gvs[LIST_REL_EL_EQN, EL_MAP]) QED +Theorem LIST_REL_split: + ∀l l'. + LIST_REL + (λ(fn,v) (gn,w). + fn = gn ∧ + exp_rel (FILTER (λ(n,x). ¬MEM n (MAP FST f)) env) v w) l l' ⇒ + MAP FST l = MAP FST l' ∧ + LIST_REL + (exp_rel (FILTER (λ(n,x). ¬MEM n (MAP FST f)) env)) + (MAP SND l) (MAP SND l') +Proof + Induct \\ rw [] \\ gvs [] + \\ rpt $ (pairarg_tac \\ gvs []) +QED + +Theorem LIST_REL_ALOOKUP: + ∀l l'. + MAP FST l = MAP FST l' ∧ + LIST_REL (exp_rel env) (MAP SND l) (MAP SND l') ⇒ + (ALOOKUP l s = NONE ⇒ + ALOOKUP l' s = NONE) ∧ + (∀e. ALOOKUP l s = SOME e ⇒ + ∃e'. ALOOKUP l' s = SOME e' ∧ + exp_rel env e e') +Proof + rw [] + >- gvs [ALOOKUP_NONE] + \\ drule_all ALOOKUP_SOME_EL_2 \\ rw [] + \\ gvs [SF SFY_ss, LIST_REL_EL_EQN, EL_MAP] + \\ first_x_assum drule \\ rw [] +QED + +Theorem v_rel_anyThunk: + ∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w) +Proof + `(∀env v w. exp_rel env v w ⇒ T) ∧ + (∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w))` + suffices_by gvs [] + \\ ho_match_mp_tac exp_rel_strongind \\ rw [] \\ gvs [] + \\ rw [is_anyThunk_def, dest_anyThunk_def, + envLangTheory.is_anyThunk_def, envLangTheory.dest_anyThunk_def] + \\ rpt CASE_TAC + \\ dxrule LIST_REL_split \\ rpt strip_tac + \\ drule_all_then (qspec_then `n` mp_tac) LIST_REL_ALOOKUP + \\ rpt strip_tac \\ gvs [] + \\ rgs [Once exp_rel_cases] + \\ imp_res_tac ALOOKUP_MEM + \\ gvs [EVERY_EL, MEM_EL] + \\ first_x_assum drule \\ gvs [EL_MAP] + \\ Cases_on ‘EL n'' f’ \\ gvs [] +QED + Theorem SUM_REL_THM[local,simp] = sumTheory.SUM_REL_THM; Theorem PAIR_REL_def[local,simp] = pairTheory.PAIR_REL; @@ -400,12 +452,27 @@ Proof \\ gvs [OPTREL_def, Abbr ‘R’] \\ pop_assum mp_tac \\ rw [Once exp_rel_cases] \\ gs [] + \\ simp [oneline sum_bind_def] \\ rpt (CASE_TAC \\ rw []) \\ gvs [] + \\ `($= +++ v_rel) + (eval_to (k − 1) (subst_funs l x')) + (eval_to (k − 1) (MAP (λ(fn,_). (fn,Recclosure l0 l' fn)) l0 ++ l') y')` + suffices_by ( + rw [] + \\ strip_tac + \\ drule v_rel_anyThunk \\ gvs []) \\ first_x_assum irule \\ gs [subst_funs_def] \\ irule exp_rel_subst \\ gs [MAP_MAP_o, combinTheory.o_DEF, LAMBDA_PROD, GSYM FST_THM] \\ gvs [env_rel_def, LIST_REL_EL_EQN, ELIM_UNCURRY, EL_MAP, EL_REVERSE, Abbr ‘xs’, v_rel_def]) + \\ simp [oneline sum_bind_def] \\ rpt (CASE_TAC \\ rw []) \\ gvs [] + \\ `($= +++ v_rel) (eval_to (k − 1) (subst_funs [] e)) + (eval_to (k − 1) env' y')` + suffices_by ( + rw [] + \\ strip_tac + \\ drule v_rel_anyThunk \\ gvs []) \\ first_x_assum irule \\ simp [subst_funs_def]) >~ [‘MkTick x’] >- ( @@ -424,7 +491,12 @@ Proof suffices_by ( rw [] \\ Cases_on ‘result_map f xs’ \\ Cases_on ‘result_map g ys’ \\ gs [] - \\ simp [v_rel_def]) + \\ rpt (IF_CASES_TAC \\ gvs []) + >- simp [v_rel_def] + \\ ( + gvs [EXISTS_MEM, MEM_EL, EVERY_EL, LIST_REL_EL_EQN] + \\ ntac 2 (first_x_assum $ drule_then assume_tac) + \\ drule v_rel_anyThunk \\ simp [])) \\ gs [result_map_def, MEM_EL, PULL_EXISTS, EL_MAP, SF CONJ_ss] \\ unabbrev_all_tac \\ IF_CASES_TAC \\ gs [] diff --git a/compiler/backend/passes/proofs/thunk_undelay_nextProofScript.sml b/compiler/backend/passes/proofs/thunk_undelay_nextProofScript.sml new file mode 100644 index 00000000..6d0f107d --- /dev/null +++ b/compiler/backend/passes/proofs/thunk_undelay_nextProofScript.sml @@ -0,0 +1,1462 @@ +Theory thunk_undelay_nextProof +Ancestors + string option sum pair list alist finite_map pred_set rich_list + pure_misc pure_config pure_semantics thunkLang_primitives thunkLang + thunkLangProps thunk_semantics thunk_semantics_delayed +Libs + term_tactic monadsyntax + +val _ = numLib.prefer_num (); + +Theorem SUM_REL_THM[local,simp] = sumTheory.SUM_REL_THM; +Theorem PAIR_REL_def[local,simp] = pairTheory.PAIR_REL; + +Definition mop_simple_def[simp]: + mop_simple pure_config$Bind = T ∧ + mop_simple Handle = T ∧ + mop_simple _ = F +End + +Definition mop_ret_def[simp]: + mop_ret pure_config$Ret = T ∧ + mop_ret Raise = T ∧ + mop_ret _ = F +End + +Definition mop_delay_def[simp]: + mop_delay Length = T ∧ + mop_delay Alloc = T ∧ + mop_delay Act = T ∧ + mop_delay _ = F +End + +Inductive exp_rel: +[exp_rel_Monad:] + (∀mop xs ys. + mop_simple mop ∧ + LIST_REL exp_rel xs ys ⇒ + exp_rel (Monad mop xs) (Monad mop ys)) +[exp_rel_Monad_Delay:] + (∀mop xs ys. + mop_ret mop ∧ + LIST_REL exp_rel xs ys ⇒ + exp_rel (Monad mop xs) (Monad mop ys)) +[exp_rel_Monad_Ret_Delay:] + (∀mop xs ys. + mop_delay mop ∧ + LIST_REL exp_rel xs ys ⇒ + exp_rel (Monad mop xs) + (Monad Bind [ + Monad mop ys; + Lam "v" (Monad Ret [Delay $ Var "v"])])) +[exp_rel_Monad_Deref:] + (∀xs ys. + LIST_REL exp_rel xs ys ⇒ + exp_rel (Monad Deref xs) + (Monad Handle [ + Monad Deref ys; + Lam "v" $ Monad Raise [Delay $ Var "v"]])) +[exp_rel_Monad_Update:] + (∀xs ys. + LIST_REL exp_rel xs ys ⇒ + exp_rel (Monad Update xs) + (Monad Bind [ + Monad Handle [ + Monad Update ys; + Lam "v" $ Monad Raise [Delay $ Var "v"]]; + Lam "v" $ Monad Ret [Delay $ Var "v"]])) +[exp_rel_LitVal:] + (∀l. exp_rel (Lit l) (Value (Atom l))) +[exp_rel_ConsVal:] + (cn ∉ monad_cns ⇒ exp_rel (Cons cn []) (Value (Constructor cn []))) +[exp_rel_App:] + (∀f g x y. + exp_rel f g ∧ + exp_rel x y ⇒ + exp_rel (App f x) (App g y)) +[exp_rel_Lam:] + (∀s x y. + exp_rel x y ⇒ + exp_rel (Lam s x) (Lam s y)) +[exp_rel_Letrec:] + (∀f g x y. + LIST_REL (λ(fn,x) (gn,y). fn = gn ∧ exp_rel x y) f g ∧ + exp_rel x y ⇒ + exp_rel (Letrec f x) (Letrec g y)) +[exp_rel_Let:] + (∀bv x1 y1 x2 y2. + exp_rel x1 x2 ∧ + exp_rel y1 y2 ⇒ + exp_rel (Let bv x1 y1) (Let bv x2 y2)) +[exp_rel_If:] + (∀x1 x2 y1 y2 z1 z2. + LIST_REL exp_rel [x1;y1;z1] [x2;y2;z2] ⇒ + exp_rel (If x1 y1 z1) (If x2 y2 z2)) +[exp_rel_Prim:] + (∀op xs ys. + LIST_REL exp_rel xs ys ⇒ + exp_rel (Prim op xs) (Prim op ys)) +[exp_rel_Delay:] + (∀x y. + exp_rel x y ⇒ + exp_rel (Delay x) (Delay y)) +[exp_rel_Force:] + (∀x y. + exp_rel x y ⇒ + exp_rel (Force x) (Force y)) +[exp_rel_MkTick:] + (∀x y. + exp_rel x y ⇒ + exp_rel (MkTick x) (MkTick y)) +[exp_rel_Var:] + (∀v. + exp_rel (Var v) (Var v)) +[exp_rel_Value:] + (∀v w. + v_rel v w ⇒ + exp_rel (Value v) (Value w)) +[v_rel_Monadic:] + (∀mop xs ys. + mop_simple mop ∧ + LIST_REL exp_rel xs ys ⇒ + v_rel (Monadic mop xs) (Monadic mop ys)) +[v_rel_Monadic_Delay:] + (∀mop xs ys. + mop_ret mop ∧ + LIST_REL exp_rel xs ys ⇒ + v_rel (Monadic mop xs) (Monadic mop ys)) +[v_rel_Monadic_Thunk:] + (∀mop xs ys vs. + mop_ret mop ∧ + xs = MAP Value vs ∧ + LIST_REL (λv y. is_anyThunk v ∧ exp_rel (Value v) y) vs ys ⇒ + v_rel (Monadic mop xs) (Monadic mop ys)) +[v_rel_Monadic_Ret_Delay:] + (∀mop xs ys. + mop_delay mop ∧ + LIST_REL exp_rel xs ys ⇒ + v_rel (Monadic mop xs) + (Monadic Bind [ + Monad mop ys; + Lam "v" (Monad Ret [Delay $ Var "v"])])) +[v_rel_Monadic_Deref:] + (∀xs ys. + LIST_REL exp_rel xs ys ⇒ + v_rel (Monadic Deref xs) + (Monadic Handle [ + Monad Deref ys; + Lam "v" $ Monad Raise [Delay $ Var "v"]])) +[v_rel_Monadic_Update:] + (∀xs ys. + LIST_REL exp_rel xs ys ⇒ + v_rel (Monadic Update xs) + (Monadic Bind [ + Monad Handle [ + Monad Update ys; + Lam "v" $ Monad Raise [Delay $ Var "v"]]; + Lam "v" $ Monad Ret [Delay $ Var "v"]])) +[v_rel_Atom:] + (∀x. + v_rel (Atom x) (Atom x)) +[v_rel_Constructor:] + (∀vs ws. + LIST_REL v_rel vs ws ⇒ + v_rel (Constructor s vs) (Constructor s ws)) +[v_rel_Closure:] + (∀s x y. + exp_rel x y ⇒ + v_rel (Closure s x) (Closure s y)) +[v_rel_DoTick:] + (∀v w. + v_rel v w ⇒ + v_rel (DoTick v) (DoTick w)) +[v_rel_Recclosure:] + (∀f g n. + LIST_REL (λ(fn,x) (gn,y). fn = gn ∧ exp_rel x y) f g ⇒ + v_rel (Recclosure f n) (Recclosure g n)) +[v_rel_Thunk:] + (∀x y. + exp_rel x y ⇒ + v_rel (Thunk x) (Thunk y)) +End + +Theorem v_rel_cases[local] = CONJUNCT2 exp_rel_cases; + +(* Boilerplate *) +Theorem v_rel_def[simp] = + [ “v_rel (Closure s x) z”, + “v_rel z (Closure s x)”, + “v_rel (Recclosure s x) z”, + “v_rel z (Recclosure s x)”, + “v_rel (Constructor s x) z”, + “v_rel z (Constructor s x)”, + “v_rel (Monadic mop xs) z”, + “v_rel z (Monadic mop ys)”, + “v_rel (Atom x) z”, + “v_rel z (Atom x)”, + “v_rel (Thunk x) z”, + “v_rel z (Thunk x)” ] + |> map (SIMP_CONV (srw_ss()) [Once v_rel_cases]) + |> LIST_CONJ; + +Theorem exp_rel_freevars: + exp_rel x y ⇒ freevars x = freevars y +Proof + qsuff_tac ‘ + (∀x y. exp_rel x y ⇒ freevars x = freevars y) ∧ + (∀v w. v_rel v w ⇒ T)’ + >- rw [] + \\ ho_match_mp_tac exp_rel_strongind \\ simp [freevars_def] \\ rw [] + >~ [`Let`] >- ( + Cases_on `bv` \\ simp [freevars_def]) + \\ ( + rw [EXTENSION, EQ_IMP_THM] \\ gs [] + \\ fs [MEM_EL, PULL_EXISTS, LIST_REL_EL_EQN, + Once (DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”)] + \\ rw [] \\ gs [EL_MAP, ELIM_UNCURRY, SF CONJ_ss, SF SFY_ss]) +QED + +Theorem exp_rel_subst: + ∀vs x ws y. + LIST_REL v_rel (MAP SND vs) (MAP SND ws) ∧ + MAP FST vs = MAP FST ws ∧ + exp_rel x y ⇒ + exp_rel (subst vs x) (subst ws y) +Proof + ho_match_mp_tac subst_ind \\ rw [] + \\ qpat_x_assum ‘exp_rel _ _’ mp_tac + >~ [`Monad`] >- ( + rw [Once exp_rel_cases] \\ gvs [subst_def] + >~ [`mop_simple`] >- ( + rw [Once exp_rel_cases] + \\ disj1_tac + \\ gvs [LIST_REL_EL_EQN, EL_MAP, MEM_EL, PULL_EXISTS]) + >~ [`mop_ret`] >- ( + rw [Once exp_rel_cases] + \\ disj2_tac \\ disj1_tac \\ rw [] + \\ gvs [LIST_REL_EL_EQN, EL_MAP, MEM_EL, PULL_EXISTS]) + >~ [`mop_delay`] >- ( + rw [Once exp_rel_cases] + \\ disj2_tac \\ disj2_tac \\ disj1_tac \\ rw [] + >- ( + CASE_TAC \\ gvs [] + \\ drule ALOOKUP_SOME \\ rw [MEM_MAP, MEM_FILTER] + \\ pairarg_tac \\ gvs []) + \\ gvs [LIST_REL_EL_EQN, EL_MAP, MEM_EL, PULL_EXISTS]) + >~ [`Deref`] >- ( + rw [Once exp_rel_cases] + >- ( + CASE_TAC \\ rw [] + \\ drule ALOOKUP_SOME \\ rw [MEM_MAP, MEM_FILTER] + \\ pairarg_tac \\ gvs []) + \\ gvs [LIST_REL_EL_EQN, EL_MAP, MEM_EL, PULL_EXISTS]) + >~ [`Update`] >- ( + rw [Once exp_rel_cases] + >- ( + CASE_TAC \\ gvs [] + \\ drule ALOOKUP_SOME \\ rw [MEM_MAP, MEM_FILTER] + \\ pairarg_tac \\ gvs []) + >- ( + CASE_TAC \\ gvs [] + \\ drule ALOOKUP_SOME \\ rw [MEM_MAP, MEM_FILTER] + \\ pairarg_tac \\ gvs []) + \\ gvs [LIST_REL_EL_EQN, EL_MAP, MEM_EL, PULL_EXISTS] \\ rw [])) + (* Boilerplate *) + >~ [`Var`] >- ( + rw [Once exp_rel_cases, subst_def] \\ gs [] + \\ ‘OPTREL v_rel (ALOOKUP (REVERSE vs) s) (ALOOKUP (REVERSE ws) s)’ + by (irule LIST_REL_OPTREL + \\ gvs [EVERY2_MAP, ELIM_UNCURRY, LIST_REL_CONJ] + \\ pop_assum mp_tac + \\ qid_spec_tac ‘ws’ + \\ qid_spec_tac ‘vs’ + \\ Induct \\ simp [] + \\ gen_tac \\ Cases \\ simp []) + \\ gs [OPTREL_def] + \\ rw [Once exp_rel_cases]) + >~ [`Prim`] >- ( + rw [Once exp_rel_cases] \\ gs [] + \\ simp [subst_def] + >- (simp [Once exp_rel_cases]) + >- (simp [Once exp_rel_cases]) + \\ irule exp_rel_Prim + \\ gs [EVERY2_MAP, EVERY2_refl_EQ] + \\ irule LIST_REL_mono + \\ first_assum (irule_at Any) \\ rw []) + >~ [`If`] >- ( + rw [Once exp_rel_cases] + \\ simp [subst_def] + \\ irule exp_rel_If \\ fs []) + >~ [`App`] >- ( + rw [Once exp_rel_cases] + \\ simp [subst_def] + \\ irule exp_rel_App \\ fs []) + >~ [`Lam`] >- ( + rw [Once exp_rel_cases] + \\ gvs [subst_def] + \\ irule exp_rel_Lam + \\ first_x_assum irule + \\ fs [MAP_FST_FILTER, EVERY2_MAP] + \\ qabbrev_tac ‘P = λx. x ≠ s’ \\ fs [] + \\ irule LIST_REL_FILTER \\ fs [] + \\ irule LIST_REL_mono + \\ first_assum (irule_at Any) \\ gs []) + >~ [`Let NONE`] >- ( + rw [Once exp_rel_cases] + \\ simp [subst_def] + \\ irule exp_rel_Let \\ fs []) + >~ [`Let (SOME _)`] >- ( + rw [Once exp_rel_cases] + \\ simp [subst_def] + \\ irule exp_rel_Let \\ gs [] + \\ first_x_assum irule + \\ fs [MAP_FST_FILTER, EVERY2_MAP] + \\ qabbrev_tac ‘P = λx. x ≠ s’ \\ fs [] + \\ irule LIST_REL_FILTER \\ fs [] + \\ irule LIST_REL_mono + \\ first_assum (irule_at Any) \\ gs []) + >~ [`Letrec`] >- ( + rw [Once exp_rel_cases] \\ gs [] + \\ simp [subst_def] + \\ irule exp_rel_Letrec + \\ gvs [EVERY2_MAP, LAMBDA_PROD] + \\ first_assum (irule_at Any) + \\ gvs [MAP_FST_FILTER, EVERY2_MAP] + \\ `MAP FST f = MAP FST g` + by (irule LIST_EQ + \\ gvs [EL_MAP, LIST_REL_EL_EQN, ELIM_UNCURRY]) + \\ qabbrev_tac ‘P = λx. ¬MEM x (MAP FST g)’ \\ fs [] + \\ irule_at Any LIST_REL_FILTER \\ fs [] + \\ irule_at Any LIST_REL_mono + \\ first_assum (irule_at Any) + \\ simp [MAP_FST_FILTER, SF ETA_ss] + \\ irule_at Any LIST_REL_mono + \\ first_assum (irule_at Any) + \\ simp [FORALL_PROD] \\ rw [] + \\ first_x_assum irule + \\ simp [MAP_FST_FILTER, SF ETA_ss, SF SFY_ss] + \\ irule_at Any LIST_REL_FILTER \\ gs [] + \\ irule_at Any LIST_REL_mono + \\ first_assum (irule_at Any) + \\ simp [FORALL_PROD]) + >~ [`Delay`] >- ( + rw [Once exp_rel_cases] + \\ simp [subst_def, exp_rel_Value, exp_rel_Delay, SF SFY_ss] + \\ qmatch_asmsub_abbrev_tac ‘LIST_REL R _ _’ + \\ ‘OPTREL R (ALOOKUP (REVERSE vs) v) (ALOOKUP (REVERSE ws) v)’ + by (irule LIST_REL_OPTREL + \\ gvs [EVERY2_MAP, ELIM_UNCURRY, LIST_REL_CONJ, Abbr ‘R’] + \\ pop_assum mp_tac + \\ rpt (pop_assum kall_tac) + \\ qid_spec_tac ‘ws’ \\ Induct_on ‘vs’ \\ Cases_on ‘ws’ \\ simp []) + \\ gvs [Abbr ‘R’, OPTREL_def, exp_rel_Var, exp_rel_Value]) + >~ [`Force`] >- ( + rw [Once exp_rel_cases] + \\ simp [subst_def] + \\ irule exp_rel_Force \\ fs []) + >~ [`Value`] >- ( + rw [Once exp_rel_cases] + \\ simp [subst_def] + \\ rw [Once exp_rel_cases]) + >~ [`MkTick`] >- ( + rw [Once exp_rel_cases] + \\ simp [subst_def] + \\ irule exp_rel_MkTick + \\ first_x_assum irule \\ gs []) +QED + +Theorem LIST_REL_split: + ∀l l'. + LIST_REL (λ(fn,x) (gn,y). fn = gn ∧ exp_rel x y) l l' ⇒ + MAP FST l = MAP FST l' ∧ + LIST_REL exp_rel (MAP SND l) (MAP SND l') +Proof + Induct \\ rw [] \\ gvs [] + \\ rpt $ (pairarg_tac \\ gvs []) +QED + +Theorem LIST_REL_ALOOKUP_REVERSE: + ∀l l' s. + MAP FST l = MAP FST l' ∧ + LIST_REL exp_rel (MAP SND l) (MAP SND l') ⇒ + (ALOOKUP (REVERSE l) s = NONE ⇒ + ALOOKUP (REVERSE l') s = NONE) ∧ + (∀e. ALOOKUP (REVERSE l) s = SOME e ⇒ + ∃e'. ALOOKUP (REVERSE l') s = SOME e' ∧ + exp_rel e e') +Proof + rw [] + >- gvs [ALOOKUP_NONE, MAP_REVERSE] + \\ ‘MAP FST (REVERSE l) = MAP FST (REVERSE l')’ by gvs [MAP_EQ_EVERY2] + \\ drule_all ALOOKUP_SOME_EL_2 \\ rw [] + \\ gvs [SF SFY_ss, LIST_REL_EL_EQN, EL_MAP, EL_REVERSE] + \\ ‘PRE (LENGTH l' - n) < LENGTH l'’ by gvs [] + \\ first_x_assum drule \\ rw [] +QED + +Theorem v_rel_anyThunk: + ∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w) +Proof + `(∀v w. exp_rel v w ⇒ T) ∧ + (∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w))` + suffices_by gvs [] + \\ ho_match_mp_tac exp_rel_strongind \\ rw [] \\ gvs [] + \\ rw [is_anyThunk_def, dest_anyThunk_def] + \\ dxrule LIST_REL_split \\ rpt strip_tac + \\ rpt CASE_TAC + \\ drule_all_then (qspec_then ‘n’ mp_tac) LIST_REL_ALOOKUP_REVERSE + \\ rpt strip_tac + \\ rgs [Once exp_rel_cases] +QED + +Theorem exp_rel_eval_to: + ∀k x y. + exp_rel x y ⇒ + ($= +++ v_rel) + (eval_to k x) + (eval_to k y) +Proof + ho_match_mp_tac eval_to_ind \\ simp [] + \\ rpt conj_tac \\ rpt gen_tac + >~ [‘Value v’] >- ( + rw [Once exp_rel_cases] + \\ simp [eval_to_def]) + >~ [‘Var n’] >- ( + rw [Once exp_rel_cases] + \\ simp [eval_to_def]) + >~ [‘App f x’] >- ( + strip_tac + \\ rw [Once exp_rel_cases] \\ gs [] + \\ rename1 ‘exp_rel x y’ + \\ gs [eval_to_def] + \\ first_x_assum (drule_all_then assume_tac) + \\ first_x_assum (drule_all_then assume_tac) + \\ Cases_on ‘eval_to k x’ \\ Cases_on ‘eval_to k y’ \\ gs [] + \\ Cases_on ‘eval_to k f’ \\ Cases_on ‘eval_to k g’ \\ gvs [] + \\ rename1 ‘v_rel v w’ + \\ Cases_on ‘v’ \\ Cases_on ‘w’ \\ gvs [dest_anyClosure_def] + >~ [`Closure`] >- ( + IF_CASES_TAC \\ gs [] + \\ rename1 ‘(_ +++ _) (_ _ (subst1 s u1 e1)) (_ _ (subst1 s u2 e2))’ + \\ ‘[s,u1] = [] ++ [s,u1]’ by gs [] \\ pop_assum SUBST1_TAC + \\ ‘[s,u2] = [] ++ [s,u2]’ by gs [] \\ pop_assum SUBST1_TAC + \\ first_x_assum irule \\ gs [] + \\ irule exp_rel_subst \\ gs []) + >~ [`Recclosure`] >- ( + rename1 ‘LIST_REL _ xs ys’ + \\ ‘OPTREL exp_rel (ALOOKUP (REVERSE xs) s) + (ALOOKUP (REVERSE ys) s)’ + by (irule LIST_REL_OPTREL \\ gs []) + \\ gs [OPTREL_def] + \\ rgs [Once exp_rel_cases] + \\ IF_CASES_TAC \\ gs [] + \\ first_x_assum irule + \\ irule exp_rel_subst \\ gs [MAP_MAP_o, combinTheory.o_DEF, EVERY2_MAP, + LAMBDA_PROD, GSYM FST_THM] + \\ gs [ELIM_UNCURRY, LIST_REL_EL_EQN] + \\ irule LIST_EQ \\ gvs [EL_MAP])) + >~ [‘Lam s x’] >- ( + rw [Once exp_rel_cases] + \\ gs [eval_to_def]) + >~ [‘Let NONE x y’] >- ( + strip_tac + \\ rw [Once exp_rel_cases] \\ gs [] + \\ simp [eval_to_def] + \\ IF_CASES_TAC \\ gs [] + \\ last_x_assum (drule_all_then assume_tac) + \\ Cases_on ‘eval_to (k - 1) x’ \\ Cases_on ‘eval_to (k - 1) x2’ \\ gs []) + >~ [‘Let (SOME n) x y’] >- ( + strip_tac + \\ rw [Once exp_rel_cases] \\ gs [] + \\ simp [eval_to_def] + \\ IF_CASES_TAC \\ gs [] + \\ last_x_assum (drule_all_then assume_tac) + \\ Cases_on ‘eval_to (k - 1) x’ \\ Cases_on ‘eval_to (k - 1) x2’ \\ gs [] + \\ first_x_assum irule + \\ irule exp_rel_subst \\ gs []) + >~ [‘If x1 y1 z1’] >- ( + strip_tac + \\ rw [Once exp_rel_cases] \\ gs [] + \\ simp [eval_to_def] + \\ IF_CASES_TAC \\ gs [] + \\ first_x_assum (drule_all_then assume_tac) + \\ first_x_assum (drule_all_then assume_tac) + \\ first_x_assum (drule_all_then assume_tac) + \\ Cases_on ‘eval_to (k - 1) x1’ \\ Cases_on ‘eval_to (k - 1) x2’ \\ gs [] + \\ IF_CASES_TAC \\ gs [] + \\ IF_CASES_TAC \\ gs [] + \\ IF_CASES_TAC \\ gs [] + \\ IF_CASES_TAC \\ gs []) + >~ [‘Letrec f x’] >- ( + strip_tac + \\ rw [Once exp_rel_cases] \\ gs [] + \\ simp [eval_to_def] + \\ IF_CASES_TAC \\ gs [] + \\ first_x_assum irule + \\ simp [subst_funs_def] + \\ irule exp_rel_subst \\ gs [MAP_MAP_o, combinTheory.o_DEF, EVERY2_MAP, + LAMBDA_PROD, GSYM FST_THM] + \\ gs [ELIM_UNCURRY, LIST_REL_EL_EQN] + \\ irule LIST_EQ \\ gvs [EL_MAP]) + >~ [‘Delay x’] >- ( + rw [Once exp_rel_cases] \\ gs [] + \\ simp [eval_to_def]) + >~ [‘Force x’] >- ( + strip_tac + \\ rw [Once exp_rel_cases] \\ gs [] + \\ rename1 ‘exp_rel x y’ + \\ CONV_TAC (LAND_CONV (SIMP_CONV (srw_ss()) [Once eval_to_def])) + \\ CONV_TAC (RAND_CONV (SIMP_CONV (srw_ss()) [Once eval_to_def])) + \\ IF_CASES_TAC \\ gs [] + \\ first_x_assum (drule_all_then assume_tac) + \\ Cases_on ‘eval_to k x’ \\ Cases_on ‘eval_to k y’ \\ gs [] + \\ rename1 ‘v_rel v w’ + \\ Cases_on ‘dest_Tick v’ \\ gs [] + >- ( + ‘dest_Tick w = NONE’ + by (Cases_on ‘v’ \\ Cases_on ‘w’ \\ gs [] + \\ gs [Once v_rel_cases]) + \\ gs [] + \\ Cases_on ‘v’ \\ Cases_on ‘w’ \\ gvs [dest_anyThunk_def] + >- ( + rename1 ‘LIST_REL _ xs ys’ + \\ ‘OPTREL exp_rel (ALOOKUP (REVERSE xs) s) + (ALOOKUP (REVERSE ys) s)’ + by (irule LIST_REL_OPTREL \\ gs []) + \\ gs [OPTREL_def] + \\ rgs [Once exp_rel_cases] + \\ Cases_on ‘eval_to (k - 1) (subst_funs xs x')’ \\ gvs [] + \\ Cases_on ‘eval_to (k - 1) (subst_funs ys y')’ \\ gvs [] + \\ rpt (IF_CASES_TAC \\ gvs []) + \\ ‘($= +++ v_rel) (eval_to (k − 1) (subst_funs xs x')) + (eval_to (k − 1) (subst_funs ys y'))’ + suffices_by + (gvs [] \\ strip_tac \\ drule v_rel_anyThunk \\ gvs []) + \\ first_x_assum irule + \\ simp [subst_funs_def] + \\ irule exp_rel_subst \\ gs [MAP_MAP_o, combinTheory.o_DEF, + EVERY2_MAP, LAMBDA_PROD, GSYM FST_THM] + \\ gs [ELIM_UNCURRY, LIST_REL_EL_EQN] + \\ irule LIST_EQ \\ gvs [EL_MAP]) + \\ Cases_on ‘eval_to (k - 1) (subst_funs [] e)’ \\ gvs [] + \\ Cases_on ‘eval_to (k - 1) (subst_funs [] e')’ \\ gvs [] + \\ rpt (IF_CASES_TAC \\ gvs []) + \\ ‘($= +++ v_rel) (eval_to (k − 1) (subst_funs [] e)) + (eval_to (k − 1) (subst_funs [] e'))’ + suffices_by + (gvs [] \\ strip_tac \\ drule v_rel_anyThunk \\ gvs []) + \\ first_x_assum irule + \\ simp [subst_funs_def]) + \\ ‘∃y. dest_Tick w = SOME y’ + by (Cases_on ‘v’ \\ Cases_on ‘w’ \\ gs [] + \\ gs [Once v_rel_cases]) + \\ gs [] + \\ first_x_assum irule + \\ rw [Once exp_rel_cases] + \\ rw [Once exp_rel_cases] + \\ Cases_on ‘v’ \\ Cases_on ‘w’ \\ gs [Once v_rel_cases]) + >~ [‘MkTick x’] >- ( + strip_tac + \\ rw [Once exp_rel_cases] \\ gs [] + \\ simp [eval_to_def] + \\ rename1 ‘exp_rel x y’ + \\ first_x_assum (drule_all_then assume_tac) + \\ Cases_on ‘eval_to k x’ \\ Cases_on ‘eval_to k y’ \\ gs [] + \\ rw [Once v_rel_cases]) + >~ [‘Prim op xs’] >- ( + strip_tac + \\ rw [Once exp_rel_cases] \\ gs [] + >- simp [eval_to_def, result_map_def] + >- simp [eval_to_def, result_map_def] + \\ simp [eval_to_def] + \\ Cases_on ‘op’ \\ gs [] + >- ((* Cons *) + `($= +++ v_rel) + do + vs <- result_map (λx. eval_to k x) xs; + INR (Constructor s vs) + od + do + vs <- result_map (λx. eval_to k x) ys; + INR (Constructor s vs) + od` suffices_by ( + simp [oneline sum_bind_def] + \\ rpt (CASE_TAC \\ gvs []) + \\ gvs [EVERY_EL, EXISTS_MEM, MEM_EL, LIST_REL_EL_EQN] + \\ rw [] \\ gvs [] + \\ goal_assum drule \\ rw [] + \\ first_x_assum drule \\ rw [] + \\ CCONTR_TAC \\ gvs [] + \\ drule v_rel_anyThunk \\ rw []) + \\ rgs [result_map_def, MEM_MAP, PULL_EXISTS, LIST_REL_EL_EQN, MEM_EL] + \\ IF_CASES_TAC \\ gs [] + >- ( + gvs [MEM_EL, PULL_EXISTS, LIST_REL_EL_EQN] + \\ first_x_assum (drule_then assume_tac) \\ gs [] + \\ first_x_assum (drule_all_then assume_tac) \\ gs [] + \\ Cases_on ‘eval_to k (EL n ys)’ \\ gvs [] + \\ rw [] \\ gs []) + \\ rgs [Once (DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”)] + \\ IF_CASES_TAC \\ gs [] + >- ( + IF_CASES_TAC \\ gs [] + >- ( + rename1 ‘m < LENGTH ys’ + \\ first_x_assum (drule_then assume_tac) + \\ first_x_assum (drule_then assume_tac) + \\ first_x_assum (drule_all_then assume_tac) + \\ Cases_on ‘eval_to k (EL m xs)’ \\ gs []) + \\ rgs [Once (DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”)] + \\ rw [] \\ gs [] + \\ rgs [Once (DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”)] + \\ first_x_assum (drule_then assume_tac) \\ gs [] + \\ first_x_assum (drule_then assume_tac) \\ gs [] + \\ first_x_assum (drule_all_then assume_tac) \\ gs [] + \\ first_x_assum (drule_all_then assume_tac) \\ gs [] + \\ last_x_assum drule_all + \\ Cases_on ‘eval_to k (EL n ys)’ \\ gs []) + \\ rgs [Once (DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”)] + \\ IF_CASES_TAC \\ gs [] + >- ( + first_x_assum (drule_then assume_tac) + \\ first_x_assum (drule_then assume_tac) + \\ first_x_assum (drule_then assume_tac) + \\ first_x_assum (drule_all_then assume_tac) + \\ Cases_on ‘eval_to k (EL n xs)’ \\ gs []) + \\ rgs [Once (DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”)] + \\ IF_CASES_TAC \\ gs [] + >- ( + first_x_assum (drule_then assume_tac) + \\ first_x_assum (drule_then assume_tac) + \\ first_x_assum (drule_then assume_tac) + \\ first_x_assum (drule_all_then assume_tac) + \\ first_x_assum (drule_all_then assume_tac) + \\ Cases_on ‘eval_to k (EL n xs)’ \\ gs []) + \\ rgs [Once (DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”)] + \\ rw [EVERY2_MAP, LIST_REL_EL_EQN] + \\ first_x_assum (drule_then assume_tac) + \\ first_x_assum (drule_then assume_tac) + \\ first_x_assum (drule_then assume_tac) + \\ first_x_assum (drule_then assume_tac) + \\ first_x_assum (drule_then assume_tac) + \\ first_x_assum (drule_all_then assume_tac) + \\ Cases_on ‘eval_to k (EL n xs)’ + \\ Cases_on ‘eval_to k (EL n ys)’ \\ gs [] + \\ rename1 ‘err ≠ Type_error’ \\ Cases_on ‘err’ \\ gs []) + >- ((* IsEq *) + gvs [LIST_REL_EL_EQN] + \\ IF_CASES_TAC \\ gs [] + \\ gvs [LENGTH_EQ_NUM_compute, DECIDE “n < 1n ⇔ n = 0”] + \\ IF_CASES_TAC \\ gs [] + \\ rename1 ‘exp_rel x y’ + \\ first_x_assum (drule_then assume_tac) + \\ Cases_on ‘eval_to (k - 1) x’ \\ Cases_on ‘eval_to (k - 1) y’ \\ gs [] + \\ rename1 ‘v_rel v w’ + \\ Cases_on ‘v’ \\ Cases_on ‘w’ \\ gvs [LIST_REL_EL_EQN] + \\ ntac 3 (IF_CASES_TAC \\ gs [])) + >- ((* Proj *) + gvs [LIST_REL_EL_EQN] + \\ IF_CASES_TAC \\ gs [] + \\ gvs [LENGTH_EQ_NUM_compute, DECIDE “n < 1n ⇔ n = 0”] + \\ IF_CASES_TAC \\ gs [] + \\ rename1 ‘exp_rel x y’ + \\ first_x_assum (drule_then assume_tac) + \\ Cases_on ‘eval_to (k - 1) x’ \\ Cases_on ‘eval_to (k - 1) y’ \\ gs [] + \\ rename1 ‘v_rel v w’ + \\ Cases_on ‘v’ \\ Cases_on ‘w’ \\ gvs [LIST_REL_EL_EQN] + \\ IF_CASES_TAC \\ gs []) + >- ((* AtomOp *) + qmatch_goalsub_abbrev_tac ‘result_map f xs’ + \\ qmatch_goalsub_abbrev_tac ‘result_map g ys’ + \\ ‘MAP f xs = MAP g ys’ + suffices_by ( + rw [] + \\ simp [result_map_def] + \\ IF_CASES_TAC \\ gs [] + \\ IF_CASES_TAC \\ gs [] + \\ CASE_TAC \\ gs [] + \\ CASE_TAC \\ gs []) + \\ unabbrev_all_tac + \\ irule LIST_EQ + \\ gvs [LIST_REL_EL_EQN, MEM_EL, PULL_EXISTS, EL_MAP] + \\ rw [] + \\ first_x_assum (drule_then assume_tac) + \\ first_x_assum (drule_all_then assume_tac) + \\ rpt CASE_TAC \\ gs [])) + >~ [`Monad mop xs`] >- ( + rw [Once exp_rel_cases] + \\ simp [eval_to_def] + \\ metis_tac []) +QED + +Theorem exp_rel_eval[local] = + Q.INST [‘allow_error’|->‘T’] eval_to_eval_lift + |> SIMP_RULE (srw_ss ()) [] + |> Lib.C MATCH_MP exp_rel_eval_to; + +Definition next_rel_def[simp]: + next_rel Ret Ret = T ∧ + next_rel Div Div = T ∧ + next_rel Err Err = T ∧ + next_rel (Act a c s) (Act b d t) = ( + ∃d'. + d = BC (Lam "v" $ Monad Ret [Delay $ Var "v"]) d' ∧ + a = b ∧ cont_rel_delayed exp_rel c d' ∧ state_rel_delayed v_rel s t) ∧ + next_rel _ _ = F +End + +Definition is_anyClosure_def[simp]: + is_anyClosure v = (∃x. dest_anyClosure v = INR x) +End + +Theorem v_rel_dest_anyClosure: + ∀v w s body binds. + v_rel v w ∧ + dest_anyClosure v = INR (s,body,binds) ⇒ + ∃body' binds'. dest_anyClosure w = INR (s,body',binds') ∧ + exp_rel body body' ∧ + LIST_REL (λ(s,v) (s',v'). s = s' ∧ v_rel v v') binds binds' +Proof + rw [] + \\ Cases_on `v` \\ gvs [dest_anyClosure_def, AllCaseEqs()] + \\ dxrule LIST_REL_split \\ rw [] + \\ ‘MAP FST (REVERSE l) = MAP FST (REVERSE g)’ by gvs [MAP_EQ_EVERY2] + \\ drule_all ALOOKUP_SOME_EL_2 \\ rw [] + \\ gvs [SF SFY_ss, LIST_REL_EL_EQN, EL_MAP, EL_REVERSE] + \\ ‘PRE (LENGTH g - n) < LENGTH g’ by gvs [] + \\ `exp_rel (Lam s body) v'` by (first_x_assum drule \\ rw []) + \\ rgs [Once exp_rel_cases] \\ rw [] + \\ rpt (pairarg_tac \\ gvs []) + \\ gvs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] + \\ rw [] + >- (last_x_assum drule \\ rw []) + >- (last_x_assum drule \\ rw []) + >- ( + rpt (pairarg_tac \\ gvs []) + \\ rpt (first_x_assum drule \\ rw [])) +QED + +Theorem v_rel_anyClosure: + ∀v w. v_rel v w ⇒ (is_anyClosure v ⇔ is_anyClosure w) +Proof + `(∀v w. exp_rel v w ⇒ T) ∧ + (∀v w. v_rel v w ⇒ (is_anyClosure v ⇔ is_anyClosure w))` + suffices_by gvs [] + \\ ho_match_mp_tac exp_rel_strongind \\ rw [] \\ gvs [] + \\ rw [dest_anyClosure_def] + \\ dxrule LIST_REL_split \\ rpt strip_tac + \\ rpt CASE_TAC + \\ drule_all_then (qspec_then ‘n’ mp_tac) LIST_REL_ALOOKUP_REVERSE + \\ rpt strip_tac + \\ rgs [Once exp_rel_cases] +QED + +Triviality exp_rel_subst_LIST_REL: + exp_rel q q' ∧ + LIST_REL (λ(s,v) (s',v'). s = s' ∧ v_rel v v') r r' ⇒ + ($= +++ v_rel) (eval (subst r q)) (eval (subst r' q')) +Proof + rw [] + \\ irule exp_rel_eval + \\ irule exp_rel_subst \\ rw [] + \\ gvs [MAP_EQ_EVERY2, LIST_REL_EL_EQN, EL_MAP] \\ rw [] + \\ first_x_assum drule \\ rw [] + \\ rpt (pairarg_tac \\ gvs []) +QED + +Triviality thunk_exists[simp,local]: + ∃k. is_anyThunk k +Proof + qrefine `Thunk _` \\ simp [is_anyThunk_def, dest_anyThunk_def] +QED + +Theorem undelay_next_thm[local]: + ∀k v c s w d t. + ($= +++ v_rel) v w ∧ + cont_rel_delayed exp_rel c d ∧ + state_rel_delayed v_rel s t ∧ + next_delayed k v c s ≠ Err ⇒ + ∃ck. next_rel (next_delayed k v c s) (next (k + ck) w d t) +Proof + ho_match_mp_tac next_delayed_ind \\ rw [] + \\ simp [Once next_delayed_def] + \\ Cases_on ‘v = INL Type_error ∨ + v = INL Diverge ∨ + (∃x y. v = INR (Constructor x y)) ∨ + (∃x y. v = INR (Closure x y)) ∨ + (∃x y. v = INR (Recclosure x y)) ∨ + (∃t. v = INR (Thunk t)) ∨ + (∃a. v = INR (Atom a)) ∨ + (∃t. v = INR (DoTick t))’ + >- ((* Error *) + rgs [Once next_delayed_def] + \\ Cases_on ‘w’ \\ rgs [Once thunk_semanticsTheory.next_def] + \\ gs [Once next_delayed_def]) + \\ gvs [] + \\ Cases_on `v` \\ gvs [] + >- (CASE_TAC \\ gvs []) + \\ Cases_on ‘w’ \\ gvs [] + \\ Cases_on ‘y’ \\ gvs [] + \\ TRY (Cases_on `m` \\ gvs []) + >~ [`Monadic Ret _`] >- ( + `LENGTH l = 1` by (CCONTR_TAC \\ gvs [Once next_delayed_def]) + \\ gvs [LENGTH_EQ_NUM_compute, numeral_less_thm, SF DNF_ss] + \\ simp [Once next_def] + \\ rgs [Once next_delayed_def, with_value_def] + \\ imp_res_tac exp_rel_eval + \\ rpt (CASE_TAC \\ gvs []) + >- (qexists `0` \\ simp []) + >- (qexists `0` \\ simp []) + \\ gvs [apply_closure_def, with_value_def] + \\ imp_res_tac exp_rel_eval \\ gvs [] + \\ rpt (CASE_TAC \\ gvs []) + >- (imp_res_tac v_rel_anyClosure \\ gvs []) + \\ first_x_assum irule \\ rw [] + \\ drule_all v_rel_dest_anyClosure \\ rw [] + \\ gvs [exp_rel_subst_LIST_REL]) + >~ [`Monadic Ret (MAP Value _)`] >- ( + `LENGTH vs = 1` by (CCONTR_TAC \\ gvs [Once next_delayed_def]) + \\ gvs [LENGTH_EQ_NUM_compute, numeral_less_thm, SF DNF_ss] + \\ simp [Once next_def] + \\ rgs [Once next_delayed_def, with_value_def] + \\ imp_res_tac exp_rel_eval + \\ rpt (CASE_TAC \\ gvs []) + >- (qexists `0` \\ simp []) + >- (qexists `0` \\ simp []) + \\ gvs [apply_closure_def, with_value_def] + \\ imp_res_tac exp_rel_eval \\ gvs [] + \\ rpt (CASE_TAC \\ gvs []) + >- (imp_res_tac v_rel_anyClosure \\ gvs []) + \\ first_x_assum irule \\ rw [] + \\ drule_all v_rel_dest_anyClosure \\ rw [] + \\ gvs [exp_rel_subst_LIST_REL]) + >~ [`Monadic Raise _`] >- ( + `LENGTH l = 1` by (CCONTR_TAC \\ gvs [Once next_delayed_def]) + \\ gvs [LENGTH_EQ_NUM_compute, numeral_less_thm, SF DNF_ss] + \\ simp [Once next_def] + \\ rgs [Once next_delayed_def, with_value_def] + \\ imp_res_tac exp_rel_eval + \\ rpt (CASE_TAC \\ gvs []) + >- (qexists `0` \\ simp []) + >- (qexists `0` \\ simp []) + \\ gvs [apply_closure_def, with_value_def] + \\ imp_res_tac exp_rel_eval \\ gvs [] + \\ rpt (CASE_TAC \\ gvs []) + >- (imp_res_tac v_rel_anyClosure \\ gvs []) + \\ first_x_assum irule \\ rw [] + \\ drule_all v_rel_dest_anyClosure \\ rw [] + \\ gvs [exp_rel_subst_LIST_REL]) + >~ [`Monadic Raise (MAP Value _)`] >- ( + `LENGTH vs = 1` by (CCONTR_TAC \\ gvs [Once next_delayed_def]) + \\ gvs [LENGTH_EQ_NUM_compute, numeral_less_thm, SF DNF_ss] + \\ simp [Once next_def] + \\ rgs [Once next_delayed_def, with_value_def] + \\ imp_res_tac exp_rel_eval + \\ rpt (CASE_TAC \\ gvs []) + >- (qexists `0` \\ simp []) + >- (qexists `0` \\ simp []) + \\ gvs [apply_closure_def, with_value_def] + \\ imp_res_tac exp_rel_eval \\ gvs [] + \\ rpt (CASE_TAC \\ gvs []) + >- (imp_res_tac v_rel_anyClosure \\ gvs []) + \\ first_x_assum irule \\ rw [] + \\ drule_all v_rel_dest_anyClosure \\ rw [] + \\ gvs [exp_rel_subst_LIST_REL]) + >~ [`Bind`] >- ( + `LENGTH l = 2` by (CCONTR_TAC \\ gvs [Once next_delayed_def]) + \\ gvs [LENGTH_EQ_NUM_compute, numeral_less_thm, SF DNF_ss] + \\ CASE_TAC \\ gvs [] \\ simp [Once next_def] + >- (qexists `0` \\ simp []) + \\ rgs [Once next_delayed_def] + \\ first_x_assum irule \\ simp [exp_rel_eval]) + >~ [`Handle`] >- ( + `LENGTH l = 2` by (CCONTR_TAC \\ gvs [Once next_delayed_def]) + \\ gvs [LENGTH_EQ_NUM_compute, numeral_less_thm, SF DNF_ss] + \\ CASE_TAC \\ gvs [] \\ simp [Once next_def] + >- (qexists `0` \\ simp []) + \\ rgs [Once next_delayed_def] + \\ first_x_assum irule \\ simp [exp_rel_eval]) + >~ [`Act`] >- ( + `LENGTH l = 1` by (CCONTR_TAC \\ gvs [Once next_delayed_def]) + \\ gvs [LENGTH_EQ_NUM_compute, numeral_less_thm, SF DNF_ss] + \\ simp [Once next_def] + \\ rgs [Once next_delayed_def, with_atoms_def] + \\ rpt (CASE_TAC \\ gvs []) + >- ( + Cases_on `k = 0` \\ gvs [] + >- (qexists `0` \\ simp []) + \\ simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ qrefine `ck + 1` \\ simp [Once next_def, with_atoms_def] + \\ gvs [result_map_def] + \\ imp_res_tac exp_rel_eval \\ gvs [] + \\ Cases_on `eval h` \\ Cases_on `eval y` \\ gvs []) + \\ Cases_on `k = 0` \\ gvs [] + \\ qrefine `ck + 1` \\ gvs [] + \\ simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ simp [Once next_def, with_atoms_def] + \\ gvs [result_map_def] + \\ imp_res_tac exp_rel_eval \\ gvs [] + \\ Cases_on `eval h` \\ Cases_on `eval y` \\ gvs [] + \\ qpat_x_assum `v_rel y'' y'3'` assume_tac + \\ Cases_on `y''` \\ Cases_on `y'3'` + \\ rgs [Once v_rel_cases, get_atoms_def]) + >~ [`Alloc`] >- ( + `LENGTH l = 2` by (CCONTR_TAC \\ gvs [Once next_delayed_def]) + \\ gvs [LENGTH_EQ_NUM_compute, numeral_less_thm, SF DNF_ss] + \\ simp [Once next_def] + \\ rgs [Once next_delayed_def, with_atoms_def] + \\ rpt (CASE_TAC \\ gvs []) + >- (qexists `0` \\ simp []) + >- (qexists `0` \\ simp []) + >- ( + simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ qrefine `ck + 1` \\ simp [Once next_def, with_atoms_def] + \\ gvs [result_map_def] + \\ imp_res_tac exp_rel_eval \\ gvs [] + \\ Cases_on `eval h` \\ Cases_on `eval y` + \\ Cases_on `eval h'` \\ Cases_on `eval y'` \\ gvs [] + \\ Cases_on `x` \\ gvs []) + >- ( + qrefine `ck + 1` \\ gvs [] + \\ simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ simp [Once next_def] + \\ gvs [result_map_def] + \\ imp_res_tac exp_rel_eval \\ gvs [] + \\ Cases_on `eval h` \\ Cases_on `eval y` + \\ Cases_on `eval h'` \\ Cases_on `eval y'` \\ gvs [] + >- (Cases_on `x` \\ gvs [] \\ Cases_on `x''` \\ gvs []) + >- (Cases_on `x` \\ gvs []) + >- (Cases_on `x` \\ gvs []) + \\ qpat_x_assum `v_rel h'' y'3'` assume_tac + \\ Cases_on `h''` \\ Cases_on `y'3'` + \\ rgs [Once v_rel_cases, get_atoms_def, is_anyThunk_def, + dest_anyThunk_def] + \\ qrefine `ck + 1` \\ simp [Once next_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, result_map_def] + \\ simp [apply_closure_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, dest_anyClosure_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, subst1_def] + \\ first_x_assum irule \\ rw [] \\ gvs [state_rel_delayed_def] + \\ ntac 2 (simp [Once exp_rel_cases]) + \\ gvs [LIST_REL_EL_EQN]) + \\ qrefine `ck + 1` \\ gvs [] + \\ simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ simp [Once next_def] + \\ gvs [result_map_def] + \\ imp_res_tac exp_rel_eval \\ gvs [] + \\ Cases_on `eval h` \\ Cases_on `eval y` + \\ Cases_on `eval h'` \\ Cases_on `eval y'` \\ gvs [] + >- (Cases_on `x` \\ gvs [] \\ Cases_on `x''` \\ gvs []) + >- (Cases_on `x` \\ gvs []) + >- (Cases_on `x` \\ gvs []) + \\ qpat_x_assum `v_rel h'' y'3'` assume_tac + \\ Cases_on `h''` \\ Cases_on `y'3'` + \\ rgs [Once v_rel_cases, get_atoms_def, is_anyThunk_def, dest_anyThunk_def] + \\ ( + qrefine `ck + 1` \\ simp [Once next_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, result_map_def] + \\ simp [apply_closure_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, dest_anyClosure_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, subst1_def] + \\ first_x_assum irule \\ rw [] \\ gvs [state_rel_delayed_def] + >- (gvs [LIST_REL_EL_EQN, EL_REPLICATE, is_anyThunk_def, + dest_anyThunk_def] + \\ simp [Once v_rel_cases]) + \\ ntac 2 (simp [Once exp_rel_cases]) + \\ gvs [LIST_REL_EL_EQN])) + >~ [`Length`] >- ( + `LENGTH l = 1` by (CCONTR_TAC \\ gvs [Once next_delayed_def]) + \\ gvs [LENGTH_EQ_NUM_compute, numeral_less_thm, SF DNF_ss] + \\ simp [Once next_def] + \\ rgs [Once next_delayed_def, with_atoms_def, result_map_def] + \\ rpt (CASE_TAC \\ gvs []) + >- ( + Cases_on `k = 0` \\ gvs [] + >- (qexists `0` \\ simp []) + \\ qrefine `ck + 1` \\ simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ simp [Once next_def, with_atoms_def, result_map_def] + \\ imp_res_tac exp_rel_eval \\ gvs [] + \\ Cases_on `eval y` \\ gvs []) + >- (qexists `0` \\ simp []) + \\ qrefine `ck + 1` \\ simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ simp [Once next_def, with_atoms_def, result_map_def] + \\ imp_res_tac exp_rel_eval \\ gvs [] + \\ Cases_on `eval h` \\ Cases_on `eval y` \\ gvs [] + >- (Cases_on `x'` \\ gvs []) + \\ qpat_x_assum `v_rel y' y''` assume_tac + \\ Cases_on `y'` \\ Cases_on `y''` + \\ rgs [Once v_rel_cases, get_atoms_def] + \\ CASE_TAC \\ gvs [state_rel_delayed_def, LIST_REL_EL_EQN] + \\ qrefine `ck + 1` \\ simp [Once next_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, result_map_def] + \\ simp [apply_closure_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, dest_anyClosure_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, subst1_def] + \\ first_x_assum irule \\ rw [] + >- (qexists `[Loc n]` \\ simp []) + \\ ntac 2 (simp [Once exp_rel_cases])) + >~ [`Deref`] >- ( + `LENGTH l = 2` by (CCONTR_TAC \\ gvs [Once next_delayed_def]) + \\ gvs [LENGTH_EQ_NUM_compute, numeral_less_thm, SF DNF_ss] + \\ simp [Once next_def] + \\ rgs [Once next_delayed_def, with_atoms_def, result_map_def] + \\ rpt (CASE_TAC \\ gvs []) + >- ( + Cases_on `k = 0` \\ gvs [] + >- (qexists `0` \\ simp []) + \\ qrefine `ck + 1` \\ simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ simp [Once next_def, with_atoms_def, result_map_def] + \\ imp_res_tac exp_rel_eval \\ gvs [] + \\ Cases_on `eval y` \\ gvs [] + \\ Cases_on `eval h'` \\ Cases_on `eval y'` \\ gvs []) + >- ( + Cases_on `k = 0` \\ gvs [] + >- (qexists `0` \\ simp []) + \\ qrefine `ck + 1` \\ simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ simp [Once next_def, with_atoms_def, result_map_def] + \\ imp_res_tac exp_rel_eval \\ gvs [] + \\ Cases_on `eval y'` \\ gvs [] + \\ Cases_on `eval h` \\ Cases_on `eval y` \\ gvs []) + >- (qexists `0` \\ simp []) + >- ( + qrefine `ck + 1` \\ simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ simp [Once next_def, with_atoms_def, result_map_def] + \\ imp_res_tac exp_rel_eval \\ gvs [] + \\ Cases_on `eval h'` \\ Cases_on `eval y'` \\ gvs [] + >- (Cases_on `x'` \\ gvs []) + \\ Cases_on `eval h` \\ Cases_on `eval y` \\ gvs [] + >- (Cases_on `x'` \\ gvs []) + \\ qpat_x_assum `v_rel y'4' y'5'` assume_tac + \\ Cases_on `y'4'` \\ Cases_on `y'5'` + \\ rgs [Once v_rel_cases, get_atoms_def] + \\ gvs [state_rel_delayed_def, LIST_REL_EL_EQN] + \\ simp [Once next_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ qrefine `ck + 1` \\ simp [] + \\ first_x_assum irule \\ rw [] + >- (qexists `[Loc n; Int i]` \\ simp []) + \\ simp [Once exp_rel_cases] + \\ `n < LENGTH t` by gvs [] + \\ first_x_assum drule \\ rw [] + \\ `Num i < LENGTH (EL n s)` by intLib.COOPER_TAC + \\ first_x_assum drule \\ rw []) + >- ( + qrefine `ck + 1` \\ simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ simp [Once next_def, with_atoms_def, result_map_def] + \\ imp_res_tac exp_rel_eval \\ gvs [] + \\ Cases_on `eval h'` \\ Cases_on `eval y'` \\ gvs [] + >- (Cases_on `x'` \\ gvs []) + \\ Cases_on `eval h` \\ Cases_on `eval y` \\ gvs [] + >- (Cases_on `x'` \\ gvs []) + \\ qpat_x_assum `v_rel y'4' y'5'` assume_tac + \\ Cases_on `y'4'` \\ Cases_on `y'5'` + \\ rgs [Once v_rel_cases, get_atoms_def] + \\ gvs [state_rel_delayed_def, LIST_REL_EL_EQN] + \\ simp [Once next_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, result_map_def] + \\ qrefine `ck + 1` \\ simp [] + \\ simp [apply_closure_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, dest_anyClosure_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, subst1_def] + \\ last_x_assum irule \\ rw [] + >- ( + ntac 2 (goal_assum drule \\ rw []) + \\ qexists `[Loc n; Int i]` \\ simp []) + \\ ntac 2 (simp [Once exp_rel_cases]) + \\ simp [monad_cns_def]) + \\ qrefine `ck + 1` \\ simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ simp [Once next_def, with_atoms_def, result_map_def] + \\ imp_res_tac exp_rel_eval \\ gvs [] + \\ Cases_on `eval h'` \\ Cases_on `eval y'` \\ gvs [] + >- (Cases_on `x'` \\ gvs []) + \\ Cases_on `eval h` \\ Cases_on `eval y` \\ gvs [] + >- (Cases_on `x'` \\ gvs []) + \\ qpat_x_assum `v_rel y'4' y'5'` assume_tac + \\ Cases_on `y'4'` \\ Cases_on `y'5'` + \\ rgs [Once v_rel_cases, get_atoms_def] + \\ gvs [state_rel_delayed_def, LIST_REL_EL_EQN] + \\ simp [Once next_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, result_map_def] + \\ qrefine `ck + 1` \\ simp [] + \\ simp [apply_closure_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, dest_anyClosure_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, subst1_def] + \\ first_x_assum irule \\ rw [] + >- ( + ntac 2 (goal_assum drule \\ rw []) + \\ qexists `[Loc n; Int i]` \\ simp []) + \\ ntac 2 (simp [Once exp_rel_cases]) + \\ simp [monad_cns_def]) + >~ [`Update`] >- ( + `LENGTH l = 3` by (CCONTR_TAC \\ gvs [Once next_delayed_def]) + \\ gvs [LENGTH_EQ_NUM_compute, numeral_less_thm, SF DNF_ss, LUPDATE_DEF] + \\ simp [Once next_def] + \\ rgs [Once next_delayed_def, with_atoms_def, result_map_def] + \\ rpt (CASE_TAC \\ gvs []) + >- ( + Cases_on `k = 0` \\ gvs [] + >- (qexists `0` \\ simp []) + \\ simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ simp [Once next_def] + \\ qrefine `ck + 1` \\ simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ simp [Once next_def, result_map_def] + \\ imp_res_tac exp_rel_eval \\ gvs [] + \\ Cases_on `eval y` \\ gvs [] + \\ Cases_on `eval h'` \\ Cases_on `eval y'` \\ gvs [] + \\ Cases_on `eval h''` \\ Cases_on `eval y''` \\ gvs []) + >- ( + Cases_on `k = 0` \\ gvs [] + >- (qexists `0` \\ simp []) + \\ simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ simp [Once next_def] + \\ qrefine `ck + 1` \\ simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ simp [Once next_def, result_map_def] + \\ imp_res_tac exp_rel_eval \\ gvs [] + \\ Cases_on `eval y'` \\ gvs [] + \\ Cases_on `eval h` \\ Cases_on `eval y` \\ gvs [] + \\ Cases_on `eval h''` \\ Cases_on `eval y''` \\ gvs []) + >- ( + Cases_on `k = 0` \\ gvs [] + >- (qexists `0` \\ simp []) + \\ simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ simp [Once next_def] + \\ qrefine `ck + 1` \\ simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ simp [Once next_def, result_map_def] + \\ imp_res_tac exp_rel_eval \\ gvs [] + \\ Cases_on `eval y''` \\ gvs [] + \\ Cases_on `eval h` \\ Cases_on `eval y` \\ gvs [] + \\ Cases_on `eval h'` \\ Cases_on `eval y'` \\ gvs []) + >- (qexists `0` \\ simp []) + >- ( + Cases_on `eval h` \\ gvs [] >- (Cases_on `x` \\ gvs []) + \\ Cases_on `eval h'` \\ gvs [] >- (Cases_on `x` \\ gvs []) + \\ Cases_on `eval h''` \\ gvs [] >- (Cases_on `x` \\ gvs []) + \\ simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ simp [Once next_def] + \\ qrefine `ck + 1` \\ simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ simp [Once next_def, result_map_def] + \\ imp_res_tac exp_rel_eval \\ gvs [] + \\ Cases_on `eval y` \\ Cases_on `eval y'` \\ Cases_on `eval y''` + \\ gvs [] + \\ qpat_x_assum `v_rel y'3' y'6'` assume_tac + \\ Cases_on `y'3'` \\ Cases_on `y'6'` + \\ rgs [Once v_rel_cases, get_atoms_def, state_rel_delayed_def, + LIST_REL_EL_EQN] + \\ qrefine `ck + 1` \\ simp [Once next_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, result_map_def] + \\ qrefine `ck + 1` \\ simp [Once next_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, result_map_def] + \\ qrefine `ck + 1` \\ simp [apply_closure_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, dest_anyClosure_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, subst1_def] + \\ first_x_assum irule \\ rw [EL_LUPDATE] + >- (IF_CASES_TAC \\ gvs []) + >- (IF_CASES_TAC \\ gvs []) + \\ ntac 2 (simp [Once exp_rel_cases]) + \\ simp [monad_cns_def]) + >- ( + Cases_on `eval h` \\ gvs [] >- (Cases_on `x` \\ gvs []) + \\ Cases_on `eval h'` \\ gvs [] >- (Cases_on `x` \\ gvs []) + \\ Cases_on `eval h''` \\ gvs [] >- (Cases_on `x` \\ gvs []) + \\ simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ simp [Once next_def] + \\ qrefine `ck + 1` \\ simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ simp [Once next_def, result_map_def] + \\ imp_res_tac exp_rel_eval \\ gvs [] + \\ Cases_on `eval y` \\ Cases_on `eval y'` \\ Cases_on `eval y''` + \\ gvs [] + \\ qpat_x_assum `v_rel y'3' y'6'` assume_tac + \\ Cases_on `y'3'` \\ Cases_on `y'6'` + \\ rgs [Once v_rel_cases, get_atoms_def, state_rel_delayed_def, + LIST_REL_EL_EQN] + \\ qrefine `ck + 1` \\ simp [Once next_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, result_map_def] + \\ qrefine `ck + 1` \\ simp [apply_closure_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, dest_anyClosure_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, subst1_def] + \\ simp [Once next_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ qrefine `ck + 1` \\ simp [] + \\ first_x_assum irule \\ rw [] + \\ ntac 2 (simp [Once exp_rel_cases]) + \\ simp [monad_cns_def]) + >- ( + Cases_on `eval h` \\ gvs [] >- (Cases_on `x` \\ gvs []) + \\ Cases_on `eval h'` \\ gvs [] >- (Cases_on `x` \\ gvs []) + \\ Cases_on `eval h''` \\ gvs [] >- (Cases_on `x` \\ gvs []) + \\ simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ simp [Once next_def] + \\ qrefine `ck + 1` \\ simp [eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ simp [Once next_def, result_map_def] + \\ imp_res_tac exp_rel_eval \\ gvs [] + \\ Cases_on `eval y` \\ Cases_on `eval y'` \\ Cases_on `eval y''` + \\ gvs [] + \\ qpat_x_assum `v_rel y'3' y'6'` assume_tac + \\ Cases_on `y'3'` \\ Cases_on `y'6'` + \\ rgs [Once v_rel_cases, get_atoms_def, state_rel_delayed_def, + LIST_REL_EL_EQN] + \\ qrefine `ck + 1` \\ simp [Once next_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, result_map_def] + \\ qrefine `ck + 1` \\ simp [apply_closure_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, dest_anyClosure_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def, subst1_def] + \\ simp [Once next_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [eval_to_def] + \\ qrefine `ck + 1` \\ simp [] + \\ first_x_assum irule \\ rw [] + \\ ntac 2 (simp [Once exp_rel_cases]) + \\ simp [monad_cns_def])) +QED + +Theorem undelay_next_action: + ($= +++ v_rel) v w ∧ + cont_rel_delayed exp_rel c d ∧ + state_rel_delayed v_rel s t ⇒ + next_action_delayed v c s ≠ Err ⇒ + next_rel (next_action_delayed v c s) (next_action w d t) +Proof + rw[] + \\ `∀k. next_delayed k v c s ≠ Err` by ( + CCONTR_TAC \\ qpat_x_assum `next_action_delayed _ _ _ ≠ _` mp_tac + \\ gvs [next_action_delayed_def] \\ DEEP_INTRO_TAC some_intro \\ rw [] + >- (drule next_delayed_next_delayed \\ disch_then $ qspec_then `k` mp_tac + \\ simp []) + >- (qexists `k` \\ simp [])) + \\ qpat_x_assum `next_action_delayed _ _ _ ≠ Err` mp_tac + \\ simp [next_action_delayed_def] \\ DEEP_INTRO_TAC some_intro + \\ reverse $ rw [] + >- ( + rw [next_action_def] + \\ DEEP_INTRO_TAC some_intro \\ rw [] + \\ `next_delayed x v c s ≠ Err` by simp [] + \\ drule_all_then assume_tac undelay_next_thm \\ gvs [] + \\ drule next_less_eq \\ disch_then $ qspec_then `ck + x` mp_tac + \\ gvs []) + \\ `next_delayed x v c s ≠ Err` by simp [] + \\ drule_all_then assume_tac undelay_next_thm \\ gvs [] + \\ simp [next_action_def] \\ DEEP_INTRO_TAC some_intro \\ rw [] \\ gvs [] + \\ drule next_next + \\ disch_then $ qspec_then `ck + x` assume_tac + \\ Cases_on `next_delayed x v c s` \\ Cases_on `next (ck + x) w d t` \\ gvs [] +QED + +Triviality interp_action_return: + interp (INR (Monadic Ret [Lit (Str y)])) + (BC (Lam "v" (Monad Ret [Delay (Var "v")])) cont) st = + interp (INR (Monadic Ret [Delay $ Value $ Atom $ Str y])) cont st +Proof + simp [Once interp_def, next_action_def] + \\ DEEP_INTRO_TAC some_intro \\ reverse $ rw [] + >- ( + pop_assum mp_tac + \\ simp [Once next_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ rw [] + \\ gvs [eval_to_def, result_map_def] + \\ pop_assum $ qspec_then `SUC n` $ assume_tac o GEN_ALL \\ gvs [] + \\ pop_assum mp_tac + \\ simp [apply_closure_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ rw [] + \\ gvs [eval_to_def, dest_anyClosure_def] + \\ pop_assum mp_tac + \\ DEEP_INTRO_TAC some_intro \\ rw [] + \\ gvs [eval_to_def, subst1_def] + \\ simp [Once interp_def, next_action_def]) + \\ reverse $ CASE_TAC \\ gvs [] + >- ( + Cases_on `x` \\ gvs [] + >- ( + pop_assum mp_tac + \\ simp [Once next_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ rw [] + \\ gvs [eval_to_def, result_map_def]) + \\ pop_assum mp_tac + \\ simp [Once next_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ rw [] + \\ gvs [eval_to_def, result_map_def] + \\ pop_assum mp_tac + \\ simp [apply_closure_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ rw [] + \\ gvs [eval_to_def, dest_anyClosure_def] + \\ pop_assum mp_tac + \\ DEEP_INTRO_TAC some_intro \\ rw [] + \\ gvs [eval_to_def, subst1_def] + \\ simp [Once interp_def, next_action_def] + \\ DEEP_INTRO_TAC some_intro \\ reverse $ rw [] + >- (qexists `n` \\ rw []) + \\ qmatch_asmsub_abbrev_tac `next _ v _ _ ≠ Div` + \\ `next x v cont st = Err` by ( + `next n v cont st ≠ Div` by gvs [] + \\ dxrule_all next_next + \\ rw []) + \\ unabbrev_all_tac \\ gvs []) + >- ( + Cases_on `x` \\ gvs [] + >- ( + pop_assum mp_tac + \\ simp [Once next_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ rw [] + \\ gvs [eval_to_def, result_map_def]) + \\ pop_assum mp_tac + \\ simp [Once next_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ rw [] + \\ gvs [eval_to_def, result_map_def] + \\ pop_assum mp_tac + \\ simp [apply_closure_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ rw [] + \\ gvs [eval_to_def, dest_anyClosure_def] + \\ pop_assum mp_tac + \\ DEEP_INTRO_TAC some_intro \\ rw [] + \\ gvs [eval_to_def, subst1_def] + \\ simp [Once interp_def, next_action_def] + \\ DEEP_INTRO_TAC some_intro \\ reverse $ rw [] + >- (qexists `n` \\ rw []) + \\ qmatch_asmsub_abbrev_tac `next _ v _ _ ≠ Div` + \\ `next x v cont st = Ret` by ( + `next n v cont st ≠ Div` by gvs [] + \\ dxrule_all next_next + \\ rw []) + \\ unabbrev_all_tac \\ gvs []) + \\ Cases_on `x` \\ gvs [] + >- ( + pop_assum mp_tac + \\ simp [Once next_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ rw [] + \\ gvs [eval_to_def, result_map_def]) + \\ pop_assum mp_tac + \\ simp [Once next_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ rw [] + \\ gvs [eval_to_def, result_map_def] + \\ pop_assum mp_tac + \\ simp [apply_closure_def, with_value_def, eval_def] + \\ DEEP_INTRO_TAC some_intro \\ rw [] + \\ gvs [eval_to_def, dest_anyClosure_def] + \\ pop_assum mp_tac + \\ DEEP_INTRO_TAC some_intro \\ rw [] + \\ gvs [eval_to_def, subst1_def] + \\ simp [SimpRHS, Once interp_def, next_action_def] + \\ DEEP_INTRO_TAC some_intro \\ reverse $ rw [] + >- (qexists `n` \\ rw []) + \\ qmatch_asmsub_abbrev_tac `next _ v _ _ ≠ Div` + \\ `next x v cont st = Act e c l` by ( + `next n v cont st ≠ Div` by gvs [] + \\ dxrule_all next_next + \\ rw []) + \\ unabbrev_all_tac \\ gvs [] +QED + +Theorem undelay_interp[local]: + ($= +++ v_rel) v w ∧ + cont_rel_delayed exp_rel c d ∧ + state_rel_delayed v_rel s t ∧ + safe_itree (interp_delayed v c s) ⇒ + interp_delayed v c s = interp w d t +Proof + rw [Once itreeTheory.itree_bisimulation] + \\ qexists_tac ‘ + λt1 t2. + safe_itree t1 ∧ + (t1 = t2 ∨ + ∃v c s w d t. + t1 = interp_delayed v c s ∧ + t2 = interp w d t ∧ + interp_delayed v c s ≠ Ret Error ∧ + ($= +++ v_rel) v w ∧ + cont_rel_delayed exp_rel c d ∧ state_rel_delayed v_rel s t)’ + \\ rw [] + >- ( + disj2_tac + \\ irule_at Any EQ_REFL + \\ irule_at Any EQ_REFL \\ gs [] + \\ strip_tac + \\ gs [Once safe_itree_cases]) + >- ( + ‘next_action_delayed v' c' s' ≠ Err’ + by (strip_tac + \\ qpat_x_assum ‘interp_delayed v' _ _ ≠ _’ mp_tac + \\ rw [Once interp_delayed_def]) + \\ drule_all_then assume_tac undelay_next_action + \\ qpat_x_assum ‘Ret _ = _’ mp_tac + \\ once_rewrite_tac [interp_def, interp_delayed_def] + \\ Cases_on ‘next_action_delayed v' c' s'’ + \\ Cases_on ‘next_action w' d' t''’ \\ gvs []) + >- ( + ‘next_action_delayed v' c' s' ≠ Err’ + by (strip_tac + \\ qpat_x_assum ‘interp_delayed v' _ _ = _’ mp_tac + \\ rw [Once interp_delayed_def]) + \\ drule_all_then assume_tac undelay_next_action + \\ qpat_x_assum ‘_ = Div’ mp_tac + \\ once_rewrite_tac [interp_def, interp_delayed_def] + \\ Cases_on ‘next_action_delayed v' c' s'’ + \\ Cases_on ‘next_action w' d' t''’ \\ gvs []) + >- ( + rgs [Once safe_itree_cases]) + \\ ‘next_action_delayed v' c' s' ≠ Err’ + by (strip_tac + \\ qpat_x_assum ‘interp_delayed v' _ _ ≠ _’ mp_tac + \\ rw [Once interp_delayed_def]) + \\ drule_all_then assume_tac undelay_next_action + \\ qpat_x_assum ‘Vis _ _ = _’ mp_tac + \\ rw [Once interp_def, Once interp_delayed_def] + \\ Cases_on ‘next_action_delayed v' c' s'’ + \\ Cases_on ‘next_action w' d' t''’ \\ gvs [] + \\ rgs [Once safe_itree_cases] + \\ rw [] \\ CASE_TAC \\ gs [] \\ rw [] + \\ disj2_tac + \\ irule_at Any EQ_REFL + \\ simp [interp_action_return] + \\ irule_at Any EQ_REFL \\ simp[Once exp_rel_cases] + \\ first_x_assum (qspec_then ‘INR y’ assume_tac) + \\ rgs [Once safe_itree_cases] + \\ irule exp_rel_Delay \\ irule exp_rel_LitVal +QED + +Theorem semantics_fail[local]: + safe_itree (semantics_delayed x c s) ⇒ + eval x ≠ INL Type_error +Proof + simp [semantics_delayed_def, Once interp_delayed_def, + next_action_delayed_def] + \\ DEEP_INTRO_TAC some_intro \\ simp [] + \\ rw [] \\ strip_tac \\ gs [] + \\ rgs [Once next_delayed_def] + \\ rgs [Once safe_itree_cases] +QED + +Theorem undelay_semantics: + exp_rel x y ∧ + closed x ∧ + safe_itree (semantics_delayed x Done []) ⇒ + semantics_delayed x Done [] = semantics y Done [] +Proof + strip_tac + \\ drule_then assume_tac semantics_fail + \\ gvs [semantics_delayed_def, semantics_def] + \\ irule undelay_interp \\ gvs [] + \\ simp [state_rel_delayed_def] + \\ irule_at Any exp_rel_eval \\ gs [] +QED diff --git a/compiler/backend/passes/proofs/thunk_unthunkProofScript.sml b/compiler/backend/passes/proofs/thunk_unthunkProofScript.sml index cb039190..093c2d39 100644 --- a/compiler/backend/passes/proofs/thunk_unthunkProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_unthunkProofScript.sml @@ -7,7 +7,7 @@ Ancestors string option sum pair list alist thunkLang_primitives pure_misc thunk_untickProof finite_map pred_set rich_list thunkLang thunk_semantics - thunkLangProps + thunk_semantics_delayed thunkLangProps Libs term_tactic monadsyntax intLib dep_rewrite @@ -33,7 +33,8 @@ Inductive exp_inv: exp_inv (Var v)) [exp_inv_Value:] (∀v. - v_inv v ⇒ + v_inv v ∧ + is_anyThunk v ⇒ exp_inv (Value v)) [exp_inv_App:] (∀f x. @@ -88,6 +89,10 @@ Inductive exp_inv: (∀s vs. EVERY v_inv vs ⇒ v_inv (Constructor s vs)) +[v_inv_Monadic_Value:] + (∀mop x. + exp_inv (Value x) ⇒ + v_inv (Monadic mop [Value x])) [v_inv_Monadic:] (∀mop xs. EVERY exp_inv xs ⇒ @@ -114,7 +119,7 @@ Theorem exp_inv_def: (∀v. exp_inv (Var v) = T) ∧ (∀v. - exp_inv (Value v) = v_inv v) ∧ + exp_inv (Value v) = (v_inv v ∧ is_anyThunk v)) ∧ (∀f x. exp_inv (App f x) = (∃y. x = Delay y ∧ @@ -147,7 +152,7 @@ Theorem exp_inv_def: EVERY exp_inv xs) ∧ (∀mop xs. exp_inv (Monad mop xs) = - EVERY exp_inv xs) ∧ + (EVERY exp_inv xs)) ∧ (∀x. exp_inv (Force x) = exp_inv x) ∧ (∀x. @@ -160,7 +165,9 @@ QED Theorem v_inv_def[simp]: (∀s vs. v_inv (Constructor s vs) = EVERY v_inv vs) ∧ - (∀mop xs. v_inv (Monadic mop xs) = EVERY exp_inv xs) ∧ + (∀mop xs. v_inv (Monadic mop xs) = + ((∃x. xs = [Value x] ∧ exp_inv (Value x)) ∨ + EVERY exp_inv xs)) ∧ (∀s x. v_inv (Closure s x) = exp_inv x) ∧ (∀f n. v_inv (Recclosure f n) = EVERY (λv. ∃x. v = Delay x ∧ exp_inv x) (MAP SND f)) ∧ @@ -218,11 +225,22 @@ Inductive exp_rel: (∀mop xs ys. LIST_REL exp_rel xs ys ⇒ exp_rel (Monad mop xs) (Monad mop ys)) -[exp_rel_Let:] - (∀bv x1 y1 x2 y2. +[exp_rel_Seq:] + (∀x1 y1 x2 y2. exp_rel x1 x2 ∧ exp_rel y1 y2 ⇒ - exp_rel (Let bv x1 y1) (Let bv x2 y2)) + exp_rel (Seq x1 y1) (Seq x2 y2)) +[exp_rel_Let_fresh:] + (∀x1 y1 x2 y2. + exp_rel x1 x2 ∧ + exp_rel y1 y2 ∧ + fresh ∉ freevars y1 ⇒ + exp_rel (Let (SOME fresh) x1 y1) (Let (SOME fresh) x2 y2)) +[exp_rel_Let:] + (∀x1 y1 x2 y2. + exp_rel (Delay x1) x2 ∧ + exp_rel y1 y2 ⇒ + exp_rel (Let (SOME s) (Delay x1) y1) (Let (SOME s) x2 y2)) [exp_rel_Letrec:] (∀f x g y. LIST_REL (λ(f,x) (g,y). @@ -269,7 +287,8 @@ Inductive exp_rel: v_rel (Thunk x) (Thunk y)) [v_rel_Thunk_Changed:] (∀v w. - v_rel v w ⇒ + v_rel v w ∧ + is_anyThunk v ⇒ v_rel (Thunk (Force (Value v))) (DoTick w)) [v_rel_Atom:] (∀x. @@ -295,7 +314,7 @@ Theorem v_rel_def[simp]: v_rel (Constructor s vs) z = (∃ws. z = Constructor s ws ∧ LIST_REL v_rel vs ws)) ∧ - (∀op xs z. + (∀mop xs z. v_rel (Monadic mop xs) z = (∃ys. z = Monadic mop ys ∧ LIST_REL exp_rel xs ys ∧ @@ -315,7 +334,8 @@ Theorem v_rel_Thunk_def: closed w) ∨ (∃v y. x = Force (Value v) ∧ z = DoTick y ∧ - v_rel v y)) + v_rel v y ∧ + is_anyThunk v)) Proof rw [Once exp_rel_cases] \\ rw [EQ_SYM_EQ, AC CONJ_COMM CONJ_ASSOC, EQ_IMP_THM, SF SFY_ss] @@ -337,7 +357,8 @@ Theorem v_rel_rev[simp]: (∀w. v_rel v (DoTick w) = (∃x. v = Thunk (Force (Value x)) ∧ - v_rel x w)) ∧ + v_rel x w ∧ + is_anyThunk x)) ∧ (∀s y. v_rel v (Closure s y) = (∃x. v = Closure s x ∧ @@ -405,8 +426,6 @@ Proof \\ qid_spec_tac ‘ys’ \\ qid_spec_tac ‘xs’ \\ Induct \\ fs [PULL_EXISTS]) - >~ [‘Let opt’] >- - (Cases_on ‘opt’ \\ rw [] \\ fs [freevars_def]) \\ match_mp_tac $ METIS_PROVE [] “s1 = s2 ∧ x1 = x2 ⇒ s UNION (f s1) DIFF x1 = s UNION (f s2) DIFF x2” \\ last_assum mp_tac @@ -490,17 +509,27 @@ Proof >- ((* Let NONE *) rw [Once exp_rel_cases] \\ simp [subst_def] - \\ irule exp_rel_Let \\ fs []) + \\ irule exp_rel_Seq \\ fs []) >- ((* Let SOME *) rw [Once exp_rel_cases] \\ simp [subst_def] - \\ irule exp_rel_Let \\ gs [] - \\ first_x_assum irule - \\ fs [MAP_FST_FILTER, EVERY2_MAP] - \\ qabbrev_tac ‘P = λx. x ≠ s’ \\ fs [] - \\ irule LIST_REL_FILTER \\ fs [] - \\ irule LIST_REL_mono - \\ first_assum (irule_at Any) \\ simp []) + >- ( + irule exp_rel_Let_fresh \\ gvs [] \\ rw [] + >- simp [freevars_subst] + \\ first_x_assum irule + \\ fs [MAP_FST_FILTER, EVERY2_MAP] + \\ qabbrev_tac ‘P = λx. x ≠ s’ \\ fs [] + \\ irule LIST_REL_FILTER \\ fs [] + \\ irule LIST_REL_mono + \\ first_assum (irule_at Any) \\ simp []) + >- ( + irule exp_rel_Let \\ gvs [subst_def] \\ rw [] + \\ first_x_assum irule + \\ fs [MAP_FST_FILTER, EVERY2_MAP] + \\ qabbrev_tac ‘P = λx. x ≠ s’ \\ fs [] + \\ irule LIST_REL_FILTER \\ fs [] + \\ irule LIST_REL_mono + \\ first_assum (irule_at Any) \\ simp [])) >- ((* Letrec *) rw [Once exp_rel_cases] \\ simp [subst_def] @@ -550,12 +579,14 @@ QED Theorem exp_inv_subst: ∀xs x. EVERY v_inv (MAP SND xs) ∧ + EVERY (λ(n,v). n ∈ freevars x ⇒ is_anyThunk v) xs ∧ exp_inv x ⇒ exp_inv (subst xs x) Proof qsuff_tac ‘ (∀x. exp_inv x ⇒ - ∀xs. EVERY v_inv (MAP SND xs) ⇒ + ∀xs. EVERY v_inv (MAP SND xs) ∧ + EVERY (λ(n,v). n ∈ freevars x ⇒ is_anyThunk v) xs ⇒ exp_inv (subst xs x)) ∧ (∀v. v_inv v ⇒ T)’ >- rw [] @@ -565,20 +596,27 @@ Proof \\ CASE_TAC \\ fs [exp_inv_def] \\ dxrule_then strip_assume_tac ALOOKUP_SOME_REVERSE_EL \\ gs [EVERY_EL, EL_MAP] - \\ first_x_assum (drule_then assume_tac) \\ gs []) + \\ first_x_assum (drule_then assume_tac) \\ gs [] + \\ first_x_assum drule \\ gvs [freevars_def]) >- ((* Value *) gvs [subst_def, exp_inv_def]) >- ((* App *) - gvs [subst_def, exp_inv_def]) + gvs [subst_def, exp_inv_def, freevars_def] + \\ rpt (first_x_assum $ qspec_then `xs` assume_tac \\ gvs []) + \\ conj_tac + \\ ( + first_x_assum irule \\ gvs [EVERY_EL] \\ rw [] + \\ pairarg_tac \\ rw [] + \\ first_x_assum drule \\ rw [])) >- ((* Lam *) - gvs [subst_def, exp_inv_def] + gvs [subst_def, exp_inv_def, freevars_def] \\ first_x_assum irule \\ gs [EVERY_MAP, EVERY_FILTER, EVERY_MEM, ELIM_UNCURRY, SF SFY_ss]) >- ((* Letrec *) - gs [subst_def, exp_inv_def] + gs [subst_def, exp_inv_def, freevars_def] \\ gvs [EVERY_MAP, MAP_MAP_o, combinTheory.o_DEF, LAMBDA_PROD, EVERY_FILTER, GSYM FST_THM] - \\ qpat_x_assum ‘∀xs. EVERY _ xs ⇒ _’ (irule_at Any) + \\ first_x_assum $ irule_at Any \\ gvs [EVERY_MEM, FORALL_PROD, subst_def, SF SFY_ss] \\ qmatch_goalsub_abbrev_tac ‘subst m’ \\ qexists_tac ‘MAP (λ(n,x). (n,subst m x)) f’ @@ -590,33 +628,190 @@ Proof rw [MEM_FILTER] \\ first_x_assum (irule_at Any) \\ first_assum (irule_at Any)) + \\ conj_tac + >- ( + rw [MEM_FILTER] + \\ first_x_assum (irule_at Any) + \\ first_assum (irule_at Any) + \\ rw []) \\ rw [] \\ first_x_assum (drule_then strip_assume_tac) \\ first_x_assum irule \\ rw [MEM_FILTER] \\ first_x_assum (irule_at Any) - \\ first_assum (irule_at Any)) + \\ first_assum (irule_at Any) + \\ metis_tac [freevars_def]) >- ((* Let *) - Cases_on ‘bv’ \\ gvs [subst_def, exp_inv_def] - \\ first_x_assum irule - \\ gs [EVERY_MAP, EVERY_MEM, MEM_FILTER]) + Cases_on `bv` \\ gvs [subst_def, exp_inv_def, freevars_def] \\ rw [] + >~ [`subst (FILTER _ _)`] >- ( + rpt (first_x_assum $ qspec_then `FILTER (λ(n,x). n ≠ x'') xs` assume_tac + \\ gvs []) + \\ gvs [EVERY_MAP, EVERY_FILTER] + \\ first_x_assum irule \\ gvs [EVERY_EL] \\ rw [] + \\ rpt (pairarg_tac \\ gvs []) \\ rw [] + \\ first_x_assum drule \\ rw []) + \\ rpt (first_x_assum $ qspec_then `xs` assume_tac \\ gvs []) + \\ first_x_assum irule \\ gvs [EVERY_EL] \\ rw [] + \\ pairarg_tac \\ rw [] + \\ first_x_assum drule \\ rw []) >- ((* If *) - gvs [subst_def, exp_inv_def]) + gvs [subst_def, exp_inv_def, freevars_def] + \\ rpt conj_tac + \\ ( + first_x_assum irule \\ gvs [EVERY_EL] \\ rw [] + \\ pairarg_tac \\ rw [] + \\ first_x_assum drule \\ rw [])) >- ((* Prim Cons *) gs [subst_def, exp_inv_def, EVERY_MAP, EVERY_MEM, SF SFY_ss] \\ rename1 ‘subst ys’ \\ qexists_tac ‘MAP (subst ys) xs’ \\ rw [MAP_MAP_o, combinTheory.o_DEF, subst_def] - \\ gvs [MEM_MAP, PULL_EXISTS, exp_inv_def, subst_def]) + \\ gvs [MEM_MAP, PULL_EXISTS, exp_inv_def, subst_def, freevars_def] + \\ last_x_assum drule \\ rw [] + \\ pop_assum irule \\ rw [] + \\ pairarg_tac \\ rw [] + \\ ntac 2 (first_x_assum drule \\ rw [])) >- ((* Prim *) - gvs [subst_def, exp_inv_def, EVERY_MAP, EVERY_MEM, SF SFY_ss]) + gvs [subst_def, exp_inv_def, freevars_def, EVERY_MAP, EVERY_MEM, SF SFY_ss] + \\ rw [] + \\ last_x_assum drule \\ rw [] + \\ pop_assum irule \\ rw [] + \\ pairarg_tac \\ rw [] + \\ first_x_assum drule \\ rw [] + \\ pop_assum mp_tac \\ impl_tac + >- ( + goal_assum drule \\ simp [MEM_MAP] \\ metis_tac []) + \\ rw []) >- ((* Monad *) - gvs [subst_def, exp_inv_def, EVERY_MAP, EVERY_MEM, SF SFY_ss]) + gvs [subst_def, exp_inv_def, freevars_def, EVERY_MAP, EVERY_MEM, SF SFY_ss] + \\ rw [] + \\ last_x_assum drule \\ rw [] + \\ pop_assum irule \\ rw [] + \\ pairarg_tac \\ rw [] + \\ first_x_assum drule \\ rw [] + \\ pop_assum mp_tac \\ impl_tac + >- ( + goal_assum drule \\ simp [MEM_MAP] \\ metis_tac []) + \\ rw []) >- ((* Delay *) - gvs [subst_def, exp_inv_def]) + gvs [subst_def, exp_inv_def, freevars_def]) >- ((* Force *) simp [subst_def] - \\ irule exp_inv_Force \\ gs []) + \\ irule exp_inv_Force \\ gs [freevars_def]) +QED + +Theorem LIST_REL_ignore: + ∀l l'. + LIST_REL + (λ(fn,v) (gn,w). + fn = gn ∧ is_delay v ∧ is_delay w ∧ exp_rel v w ∧ + freevars v ⊆ set (MAP FST l)) l l' ⇒ + LIST_REL + (λ(fn,v) (gn,w). fn = gn ∧ is_delay v ∧ is_delay w ∧ exp_rel v w) l l' +Proof + gvs [LIST_REL_EL_EQN] \\ rw [] + \\ rpt (pairarg_tac \\ gvs []) + \\ first_x_assum drule \\ rw [] +QED + +Theorem LIST_REL_split: + ∀l l'. + LIST_REL + (λ(fn,v) (gn,w). + fn = gn ∧ is_delay v ∧ is_delay w ∧ exp_rel v w ∧ + freevars v ⊆ set (MAP FST l)) l l' ⇒ + MAP FST l = MAP FST l' ∧ + EVERY is_delay (MAP SND l) ∧ + EVERY is_delay (MAP SND l') ∧ + LIST_REL exp_rel (MAP SND l) (MAP SND l') +Proof + rpt gen_tac \\ strip_tac + \\ dxrule LIST_REL_ignore + \\ map_every qid_spec_tac [‘l'’, ‘l’] + \\ Induct \\ rw [] \\ gvs [] + \\ rpt $ (pairarg_tac \\ gvs []) + \\ gvs [LIST_REL_EL_EQN, EVERY_EL, EL_MAP] \\ rw [] + \\ first_x_assum drule \\ rw [] + \\ rpt (pairarg_tac \\ gvs []) +QED + +Theorem LIST_REL_ALOOKUP_REVERSE: + ∀l l' s. + MAP FST l = MAP FST l' ∧ + LIST_REL exp_rel (MAP SND l) (MAP SND l') ⇒ + (ALOOKUP (REVERSE l) s = NONE ⇒ + ALOOKUP (REVERSE l') s = NONE) ∧ + (∀e. ALOOKUP (REVERSE l) s = SOME e ⇒ + ∃e'. ALOOKUP (REVERSE l') s = SOME e' ∧ + exp_rel e e') +Proof + rw [] + >- gvs [ALOOKUP_NONE, MAP_REVERSE] + \\ ‘MAP FST (REVERSE l) = MAP FST (REVERSE l')’ by gvs [MAP_EQ_EVERY2] + \\ drule_all ALOOKUP_SOME_EL_2 \\ rw [] + \\ gvs [SF SFY_ss, LIST_REL_EL_EQN, EL_MAP, EL_REVERSE] + \\ ‘PRE (LENGTH l' - n) < LENGTH l'’ by gvs [] + \\ first_x_assum drule \\ rw [] +QED + +Theorem v_rel_anyThunk: + ∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w) +Proof + `(∀v w. exp_rel v w ⇒ T) ∧ + (∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w))` + suffices_by gvs [] + \\ ho_match_mp_tac exp_rel_strongind \\ rw [] \\ gvs [] + \\ rw [is_anyThunk_def, dest_anyThunk_def] + \\ dxrule LIST_REL_split \\ rpt strip_tac + \\ rpt CASE_TAC + \\ drule_all_then (qspec_then ‘n’ mp_tac) LIST_REL_ALOOKUP_REVERSE + \\ rpt strip_tac + \\ rgs [Once exp_rel_cases] + \\ imp_res_tac ALOOKUP_MEM + \\ gvs [EVERY_EL, MEM_EL] + \\ first_x_assum drule \\ gvs [EL_MAP] + \\ Cases_on ‘EL n' g’ \\ gvs [] +QED + +Theorem ALOOKUP_EL: + ∀g n q r. + n < LENGTH g ∧ + EL n g = (q,r) ⇒ + ∃r'. ALOOKUP g q = SOME r' +Proof + Induct \\ rw [] \\ gvs [] + \\ Cases_on `h` \\ rw [ALOOKUP_def] + \\ Cases_on `n` \\ gvs [] + \\ first_x_assum drule_all \\ rw [] +QED + +Theorem ALOOKUP_REVERSE_EL: + ∀g q r. + ALOOKUP g q = SOME r ⇒ + ∃x. ALOOKUP (REVERSE g) q = SOME x +Proof + Induct \\ rw [] \\ gvs [] + \\ gvs [ALOOKUP_APPEND] + \\ rpt (CASE_TAC \\ rw []) + \\ Cases_on `h` \\ gvs [] + \\ Cases_on `q = q'` \\ gvs [] + \\ first_x_assum drule \\ rw [] +QED + +Theorem ALOOKUP_REVERSE_Delay: + ∀g n q r. + n < LENGTH g ∧ + EL n g = (q,r) ⇒ + ∃x'. + ALOOKUP (REVERSE (MAP (λx. (FST x,Delay (SND x))) g)) q = + SOME (Delay x') +Proof + Induct \\ rw [] \\ gvs [] + \\ gvs [ALOOKUP_APPEND] + \\ rpt (CASE_TAC \\ rw []) + >- (drule_then assume_tac ALOOKUP_SOME_REVERSE_EL \\ gvs [EL_MAP]) + \\ Cases_on `n` \\ gvs [] + \\ first_x_assum drule_all \\ rw [] QED Theorem exp_rel_eval_to: @@ -657,6 +852,7 @@ Proof \\ irule_at Any exp_inv_subst \\ irule_at Any exp_rel_subst \\ simp [] \\ unabbrev_all_tac \\ gs [exp_inv_def] + \\ gs [is_anyThunk_def, dest_anyThunk_def] \\ (irule_at Any v_rel_Thunk_Changed ORELSE irule_at Any v_rel_Thunk_Same)) >- ((* Recclosure-Recclosure *) @@ -673,26 +869,41 @@ Proof >- ((* Lam *) rw [Once exp_rel_cases, Once exp_inv_cases] \\ fs [exp_inv_def, eval_to_def]) - >- ((* Let NONE *) + >- ((* Seq *) rw [Once exp_rel_cases] \\ gvs [exp_inv_def] - \\ rename1 ‘exp_rel x1 x2’ - \\ rename1 ‘exp_rel y1 y2’ + \\ rename1 `exp_rel x1 x2` + \\ rename1 `exp_rel y1 y2` \\ rw [eval_to_def] - \\ first_x_assum (drule_all_then assume_tac) - \\ first_x_assum (drule_all_then assume_tac) + \\ ntac 2 (first_x_assum $ drule_all_then assume_tac) \\ Cases_on ‘eval_to (k - 1) x1’ \\ Cases_on ‘eval_to (k - 1) x2’ \\ gs []) - >- ((* Let SOME *) + >- ((* Let *) rw [Once exp_rel_cases] - \\ gvs [exp_inv_def] - \\ rename1 ‘exp_rel x1 x2’ - \\ rename1 ‘exp_rel y1 y2’ - \\ rw [eval_to_def] - \\ first_x_assum (drule_all_then assume_tac) - \\ Cases_on ‘eval_to (k - 1) x1’ \\ Cases_on ‘eval_to (k - 1) x2’ \\ gs [] - \\ first_x_assum irule - \\ gs [closed_subst, exp_inv_subst] - \\ irule_at Any exp_rel_subst \\ gs []) + >- ( + gvs [exp_inv_def] + \\ rename1 `exp_rel x1 x2` + \\ rename1 `exp_rel y1 y2` + \\ rw [eval_to_def] + \\ first_x_assum $ drule_all_then assume_tac + \\ Cases_on `eval_to (k − 1) x1` \\ Cases_on `eval_to (k - 1) x2` + \\ gvs [] + \\ first_x_assum irule \\ gvs [closed_subst] + \\ irule_at Any exp_inv_subst \\ gvs [] + \\ irule_at Any exp_rel_subst \\ gvs []) + >- ( + gvs [exp_inv_def] + \\ rename1 `exp_rel (Delay x1) x2` + \\ rename1 `exp_rel y1 y2` + \\ rw [eval_to_def] + \\ first_x_assum $ drule_all_then assume_tac + \\ Cases_on `eval_to (k − 1) (Delay x1)` \\ Cases_on `eval_to (k - 1) x2` + \\ gvs [] + >- gvs [eval_to_def] + \\ first_x_assum irule \\ gvs [closed_subst] + \\ irule_at Any exp_inv_subst \\ gvs [] + \\ irule_at Any exp_rel_subst \\ gvs [] + \\ simp [is_anyThunk_def, dest_anyThunk_def] + \\ gvs [eval_to_def])) >- ((* If *) rw [Once exp_rel_cases] \\ fs [exp_inv_def] \\ rename1 ‘If x y z’ @@ -719,7 +930,16 @@ Proof \\ gvs [LIST_REL_EL_EQN, EL_MAP, BIGUNION_SUBSET, MEM_MAP, PULL_EXISTS, freevars_def, MEM_EL] \\ rw [ELIM_UNCURRY, freevars_def, MAP_MAP_o, combinTheory.o_DEF, - SF ETA_ss]) + SF ETA_ss] + \\ rw [is_anyThunk_def, dest_anyThunk_def, EVERY_EL] + \\ gvs [AllCaseEqs()] + \\ Cases_on `EL n g` \\ gvs [] + \\ simp [PULL_EXISTS] + \\ drule_then assume_tac ALOOKUP_EL \\ gvs [] + \\ `MAP FST g = MAP FST g'` by gvs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] + \\ gvs [] + \\ drule_all_then assume_tac ALOOKUP_SOME_EL_2 \\ gvs [] + \\ irule ALOOKUP_REVERSE_Delay \\ rw [SF SFY_ss]) >- ((* Delay *) rw [Once exp_rel_cases] \\ rgs [eval_to_def, exp_inv_def, v_rel_Thunk_Same]) @@ -744,23 +964,66 @@ Proof \\ gs [LIST_REL_CONJ, ELIM_UNCURRY]) \\ rgs [OPTREL_def] \\ Cases_on ‘_x’ \\ gs [] \\ Cases_on ‘_y’ \\ gs [] - \\ first_x_assum irule - \\ simp [closed_subst, subst_funs_def] - \\ irule_at Any exp_rel_subst - \\ irule_at Any exp_inv_subst - \\ irule_at Any LIST_EQ - \\ simp [EVERY2_MAP, EVERY_MAP, MAP_MAP_o, combinTheory.o_DEF, - LAMBDA_PROD, GSYM FST_THM] - \\ rgs [ELIM_UNCURRY, LIST_REL_CONJ] - \\ drule_then strip_assume_tac ALOOKUP_SOME_REVERSE_EL - \\ rgs [LIST_REL_EL_EQN, EVERY_EL, MEM_EL, PULL_EXISTS, EL_MAP, EVERY_EL, - Once exp_rel_cases, exp_inv_def, SF CONJ_ss] - \\ rpt (first_x_assum (drule_then strip_assume_tac)) - \\ gs [exp_inv_def, freevars_def]) + \\ rw [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) + \\ (`($= +++ (λv w. v_rel v w ∧ v_inv v)) + (eval_to (k - 1) (subst_funs xs e)) + (eval_to (k - 1) (subst_funs ys e'))` + suffices_by ( + gvs [] + \\ disj1_tac + \\ rpt strip_tac + \\ drule v_rel_anyThunk \\ gvs []) + \\ first_x_assum irule + \\ simp [closed_subst, subst_funs_def] + \\ irule_at Any exp_rel_subst + \\ irule_at Any exp_inv_subst + \\ irule_at Any LIST_EQ + \\ simp [EVERY2_MAP, EVERY_MAP, MAP_MAP_o, combinTheory.o_DEF, + LAMBDA_PROD, GSYM FST_THM] + \\ rgs [ELIM_UNCURRY, LIST_REL_CONJ] + \\ drule_then strip_assume_tac ALOOKUP_SOME_REVERSE_EL + \\ rgs [LIST_REL_EL_EQN, EVERY_EL, MEM_EL, PULL_EXISTS, EL_MAP, EVERY_EL, + Once exp_rel_cases, exp_inv_def, SF CONJ_ss] + \\ conj_tac + >- ( + rw [is_anyThunk_def, dest_anyThunk_def] + \\ gvs [AllCaseEqs()] \\ simp [PULL_EXISTS] + \\ Cases_on `EL n' ys` \\ gvs [] + \\ drule_all_then assume_tac ALOOKUP_EL \\ gvs [] + \\ `MAP FST ys = MAP FST xs` + by gvs [MAP_EQ_EVERY2, LIST_REL_EL_EQN] + \\ gvs [] + \\ drule_all_then assume_tac ALOOKUP_SOME_EL_2 \\ gvs [] + \\ drule ALOOKUP_REVERSE_EL \\ rw [] + \\ drule_then assume_tac ALOOKUP_SOME_REVERSE_EL \\ gvs [] + \\ qpat_x_assum + `∀n. n < LENGTH ys ⇒ is_delay (SND (EL n xs))` assume_tac + \\ pop_assum $ drule_then assume_tac \\ gvs [] + \\ rename1 `is_delay xx` + \\ Cases_on `xx` \\ gvs [is_delay_def]) + \\ rpt (first_x_assum (drule_then strip_assume_tac)) + \\ gs [exp_inv_def, freevars_def])) >- ((* Thunk-Thunk *) - first_x_assum irule + rw [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) + \\ `($= +++ (λv w. v_rel v w ∧ v_inv v)) + (eval_to (k - 1) (subst_funs [] e)) + (eval_to (k - 1) (subst_funs [] e'))` + suffices_by ( + gvs [] + \\ disj1_tac + \\ rpt strip_tac + \\ drule v_rel_anyThunk \\ gvs []) + \\ first_x_assum irule \\ gs [subst_funs_def, EVERY_EL]) \\ gs [subst_funs_def, exp_inv_def] + \\ rw [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) + \\ `($= +++ (λv w. v_rel v w ∧ v_inv v)) + (eval_to (k - 1) (Force (Value x'))) + (eval_to (k - 1) (Force (Value v)))` + suffices_by ( + gvs [] + \\ rpt strip_tac + \\ drule eval_to_Force_anyThunk \\ rw []) \\ first_x_assum irule \\ gs [EVERY_EL, EL_MAP, exp_rel_Force, exp_rel_Value_Unchanged]) >- ((* MkTick *) @@ -770,7 +1033,20 @@ Proof \\ simp [eval_to_def] \\ Cases_on ‘op’ \\ gs [exp_inv_def, EVERY_EL, EL_MAP, LIST_REL_EL_EQN] >- ((* Cons *) - rgs [result_map_def, MAP_MAP_o, combinTheory.o_DEF, MEM_MAP, eval_to_def, + `($= +++ (λv w. v_rel v w ∧ v_inv v)) + do + vs <- result_map (λx. eval_to k x) (MAP Delay ys'); + INR (Constructor s vs) + od + do + vs <- result_map (λx. eval_to k x) ys; + INR (Constructor s vs) + od` suffices_by ( + simp [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) + \\ CCONTR_TAC \\ gvs [LIST_REL_EL_EQN] + \\ ntac 2 (first_x_assum drule \\ rpt strip_tac) + \\ drule v_rel_anyThunk \\ rw []) + \\ rgs [result_map_def, MAP_MAP_o, combinTheory.o_DEF, MEM_MAP, eval_to_def, PULL_EXISTS, MEM_EL] \\ IF_CASES_TAC \\ gs [] >- ( @@ -882,8 +1158,7 @@ Proof \\ gs [Abbr ‘f’, PULL_EXISTS, CaseEqs ["sum", "v"]] \\ rpt (first_x_assum (drule_then assume_tac)) \\ gs [])) >- ((* Monad *) - rw[Once exp_rel_cases] >> gvs[eval_to_def, exp_inv_def] - ) + rw[Once exp_rel_cases] >> gvs[eval_to_def, exp_inv_def]) QED Theorem exp_rel_eval: @@ -932,6 +1207,7 @@ Triviality exp_inv_rel_subst: ∀vs x ws y. LIST_REL v_inv_rel (MAP SND vs) (MAP SND ws) ∧ MAP FST vs = MAP FST ws ∧ + EVERY (λ(n,v). n ∈ freevars x ⇒ is_anyThunk v) vs ∧ exp_inv_rel x y ⇒ exp_inv_rel (subst vs x) (subst ws y) Proof @@ -944,10 +1220,11 @@ QED Theorem unthunk_apply_closure[local]: exp_inv_rel x y ∧ v_inv_rel v2 w2 ∧ + is_anyThunk v2 ∧ (∀x y. ($= +++ v_inv_rel) x y ⇒ - next_rel v_inv_rel exp_inv_rel (f x) (g y)) ⇒ - next_rel v_inv_rel exp_inv_rel + next_rel_delayed v_inv_rel exp_inv_rel (f x) (g y)) ⇒ + next_rel_delayed v_inv_rel exp_inv_rel (apply_closure x v2 f) (apply_closure y w2 g) Proof @@ -974,50 +1251,49 @@ Proof \\ CASE_TAC \\ gs [] QED -Theorem unthunk_rel_ok[local]: - rel_ok T v_inv_rel exp_inv_rel +Theorem unthunk_rel_ok_delayed[local]: + rel_ok_delayed T v_inv_rel exp_inv_rel Proof - rw [rel_ok_def] - >- ((* apply_closure preserves rel *) - simp [unthunk_apply_closure]) - >- ((* Thunks go to Thunks or DoTicks *) - Cases_on ‘s’ \\ gs [] - \\ Cases_on ‘w’ \\ gs []) - >- ((* Constructors are related *) - gs [LIST_REL_EL_EQN, EVERY_EL]) - >- ((* exp_inv holds for Lits *) - simp [exp_inv_def]) - >- ((* Equal literals are related *) - simp [exp_rel_Prim]) - >- ((* exp_inv holds for 0-arity conses *) - simp [exp_inv_def]) - >- ((* Equal 0-arity conses are related *) - simp [exp_rel_Prim]) - >- simp[exp_inv_def] (* v_inv v ⇒ exp_inv (Value v) *) - >- simp[exp_rel_Value_Unchanged] (* v_rel v1 v2 ⇒ exp_rel (Value v1) (Value v2) *) - >- gvs[LIST_REL_EL_EQN, EVERY_EL] + rw [rel_ok_delayed_def] + >- simp [v_rel_anyThunk] + >- simp [unthunk_apply_closure] + >- ( + Cases_on `s` \\ gvs [] + \\ Cases_on `w` \\ gvs []) + >- gvs [LIST_REL_EL_EQN, EVERY_EL] + >- simp [exp_inv_def] + >- ntac 2 (simp [Once exp_rel_cases]) + >- simp [exp_inv_def] + >- ntac 2 (simp [Once exp_rel_cases]) + >- simp [exp_inv_def] + >- ntac 2 (simp [Once exp_rel_cases]) + >- ( + gvs [LIST_REL_EL_EQN, EVERY_EL] + \\ simp [Once exp_rel_cases] + \\ Cases_on `y` \\ gvs [Once exp_rel_cases, Once exp_inv_cases]) + >- gvs [LIST_REL_EL_EQN, EVERY_EL] QED -Theorem unthunk_sim_ok[local]: - sim_ok T v_inv_rel exp_inv_rel +Theorem unthunk_sim_ok_delayed[local]: + sim_ok_delayed T v_inv_rel exp_inv_rel Proof - rw [sim_ok_def] + rw [sim_ok_delayed_def] \\ simp [exp_inv_rel_eval] >- (irule exp_inv_subst >> gvs[LIST_REL_EL_EQN, EVERY_EL]) >- gvs[closed_subst, closed_def] >- (irule exp_rel_subst >> gvs[LIST_REL_EL_EQN, EVERY_EL]) QED -Theorem unthunk_semantics: +Theorem unthunk_semantics_delayed: exp_rel x y ∧ exp_inv x ∧ closed x ⇒ - semantics x Done [] = semantics y Done [] + semantics_delayed x Done [] = semantics_delayed y Done [] Proof strip_tac - \\ irule sim_ok_semantics - \\ irule_at Any unthunk_sim_ok - \\ irule_at Any unthunk_rel_ok \\ gs [] + \\ irule sim_ok_delayed_semantics_delayed + \\ irule_at Any unthunk_sim_ok_delayed + \\ irule_at Any unthunk_rel_ok_delayed \\ gs [] QED (* ------------------------------------------------------------------------- @@ -1053,11 +1329,22 @@ Inductive delay_force: (∀mop xs ys. LIST_REL delay_force xs ys ⇒ delay_force (Monad mop xs) (Monad mop ys)) -[delay_force_Let:] - (∀bv x1 y1 x2 y2. +[delay_force_Seq:] + (∀x1 x2 y1 y2. delay_force x1 x2 ∧ delay_force y1 y2 ⇒ - delay_force (Let bv x1 y1) (Let bv x2 y2)) + delay_force (Seq x1 y1) (Seq x2 y2)) +[delay_force_Let_fresh:] + (∀x1 x2 y1 y2. + delay_force x1 x2 ∧ + delay_force y1 y2 ∧ + fresh ∉ freevars y1 ⇒ + delay_force (Let (SOME fresh) x1 y1) (Let (SOME fresh) x2 y2)) +[delay_force_Let:] + (∀x1 y1 x2 y2. + delay_force (Delay x1) x2 ∧ + delay_force y1 y2 ⇒ + delay_force (Let (SOME s) (Delay x1) y1) (Let (SOME s) x2 y2)) [delay_force_Letrec:] (∀f x g y. LIST_REL (λ(f,x) (g,y). @@ -1128,13 +1415,19 @@ Proof irule_at Any exp_rel_Monad >> irule_at Any thunk_untickProofTheory.exp_rel_Monad >> pop_assum mp_tac >> Induct_on `LIST_REL` >> rw[PULL_EXISTS] >> - rpt $ goal_assum drule - ) - >- (* Let *) - (irule_at Any exp_rel_Let \\ fs [exp_inv_def] + qexistsl [`x'`, `xs0`] >> simp []) + >- ((* Seq *) + irule_at Any exp_rel_Seq \\ fs [exp_inv_def] \\ irule_at Any thunk_untickProofTheory.exp_rel_Let - \\ first_assum (irule_at Any) \\ gs [] - \\ first_assum (irule_at Any) \\ gs []) + \\ rpt (first_assum $ irule_at Any)) + >- ((* Let fresh *) + irule_at Any exp_rel_Let_fresh \\ fs [exp_inv_def] + \\ irule_at Any thunk_untickProofTheory.exp_rel_Let + \\ rpt (first_assum $ irule_at Any)) + >- ((* Let *) + irule_at Any exp_rel_Let \\ fs [exp_inv_def] + \\ irule_at Any thunk_untickProofTheory.exp_rel_Let + \\ rpt (first_assum $ irule_at Any)) >- ((* Letrec *) irule_at Any exp_rel_Letrec \\ fs [exp_inv_def] \\ irule_at Any thunk_untickProofTheory.exp_rel_Letrec @@ -1195,17 +1488,26 @@ Proof \\ fs [closed_def] QED -Theorem delay_force_semantics: +Theorem delay_force_freevars: + delay_force x y ⇒ freevars x = freevars y +Proof + rw [] \\ imp_res_tac delay_force_thm + \\ imp_res_tac exp_rel_freevars + \\ imp_res_tac thunk_untickProofTheory.exp_rel_freevars + \\ simp [] +QED + +Theorem delay_force_semantics_delayed: delay_force x y ∧ closed x ∧ - pure_semantics$safe_itree (semantics x Done []) ⇒ - semantics x Done [] = semantics y Done [] + pure_semantics$safe_itree (semantics_delayed x Done []) ⇒ + semantics_delayed x Done [] = semantics_delayed y Done [] Proof strip_tac \\ imp_res_tac delay_force_thm - \\ drule_all unthunk_semantics + \\ drule_all unthunk_semantics_delayed \\ strip_tac \\ fs [] - \\ drule untick_semantics + \\ drule untick_semantics_delayed \\ fs [] \\ disch_then irule \\ imp_res_tac exp_rel_freevars \\ fs [closed_def] diff --git a/compiler/backend/passes/proofs/thunk_untickProofScript.sml b/compiler/backend/passes/proofs/thunk_untickProofScript.sml index 2e64be47..8b68504a 100644 --- a/compiler/backend/passes/proofs/thunk_untickProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_untickProofScript.sml @@ -5,7 +5,7 @@ Theory thunk_untickProof Ancestors string option sum pair list alist thunkLang_primitives - pure_misc thunk_semantics + pure_misc thunk_semantics thunk_semantics_delayed finite_map pred_set rich_list thunkLang thunkLangProps Libs term_tactic monadsyntax dep_rewrite @@ -78,6 +78,11 @@ Inductive exp_rel: (∀s vs ws. LIST_REL v_rel vs ws ⇒ v_rel (Constructor s vs) (Constructor s ws)) +[v_rel_Monadic_Value:] + (∀mop x y. + is_anyThunk x ∧ + exp_rel (Value x) (Value y) ⇒ + v_rel (Monadic mop [Value x]) (Monadic mop [Value y])) [v_rel_Monadic:] (∀mop xs ys. LIST_REL exp_rel xs ys ⇒ @@ -110,8 +115,10 @@ Theorem v_rel_def[simp]: LIST_REL v_rel vs ws) /\ (∀mop xs. v_rel (Monadic mop xs) w = - ∃ys. w = Monadic mop ys ∧ - LIST_REL exp_rel xs ys) /\ + ((∃x y. + xs = [Value x] ∧ w = Monadic mop [Value y] ∧ is_anyThunk x ∧ + exp_rel (Value x) (Value y)) ∨ + (∃ys. w = Monadic mop ys ∧ LIST_REL exp_rel xs ys))) ∧ (∀s x. v_rel (Closure s x) w = ∃y. w = Closure s y ∧ @@ -355,6 +362,85 @@ Proof \\ Cases_on ‘x’ \\ Cases_on ‘y’ \\ rgs [Once exp_rel_cases] QED +Theorem LIST_REL_split: + ∀l l'. + LIST_REL (λ(f,x) (g,y). f = g ∧ ok_bind x ∧ exp_rel x y) l l' ⇒ + MAP FST l = MAP FST l' ∧ EVERY ok_bind (MAP SND l) ∧ + LIST_REL exp_rel (MAP SND l) (MAP SND l') +Proof + Induct \\ rw [] \\ gvs [] + \\ rpt $ (pairarg_tac \\ gvs []) + \\ gvs [LIST_REL_EL_EQN, EVERY_EL, EL_MAP] \\ rw [] + \\ first_x_assum drule \\ rw [] + \\ rpt (pairarg_tac \\ gvs []) +QED + +Theorem LIST_REL_ALOOKUP_REVERSE: + ∀l l'. + MAP FST l = MAP FST l' ∧ + LIST_REL exp_rel (MAP SND l) (MAP SND l') ⇒ + (ALOOKUP (REVERSE l) s = NONE ⇒ + ALOOKUP (REVERSE l') s = NONE) ∧ + (∀e. ALOOKUP (REVERSE l) s = SOME e ⇒ + ∃e'. ALOOKUP (REVERSE l') s = SOME e' ∧ + exp_rel e e') +Proof + rw [] + >- gvs [ALOOKUP_NONE, MAP_REVERSE] + \\ ‘MAP FST (REVERSE l) = MAP FST (REVERSE l')’ by gvs [MAP_EQ_EVERY2] + \\ drule_all ALOOKUP_SOME_EL_2 \\ rw [] + \\ gvs [SF SFY_ss, LIST_REL_EL_EQN, EL_MAP, EL_REVERSE] + \\ ‘PRE (LENGTH l' - n) < LENGTH l'’ by gvs [] + \\ first_x_assum drule \\ rw [] +QED + +Theorem v_rel_anyThunk: + ∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w) +Proof + `(∀v w. exp_rel v w ⇒ T) ∧ + (∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w))` + suffices_by gvs [] + \\ ho_match_mp_tac exp_rel_strongind \\ rw [] \\ gvs [] + \\ rw [is_anyThunk_def, dest_anyThunk_def] + \\ dxrule LIST_REL_split \\ rpt strip_tac + \\ rpt CASE_TAC + \\ drule_all_then (qspec_then ‘n’ mp_tac) LIST_REL_ALOOKUP_REVERSE + \\ rpt strip_tac + \\ rgs [Once exp_rel_cases] + \\ imp_res_tac ALOOKUP_MEM + \\ gvs [EVERY_EL, MEM_EL] + \\ first_x_assum drule \\ gvs [EL_MAP] + \\ Cases_on `EL n'' f` \\ gvs [] +QED + +Triviality exp_rel_result_map_Diverge: + ∀xs ys k. + LENGTH xs = LENGTH ys ∧ + (∀n. n < LENGTH ys ⇒ exp_rel (EL n xs) (EL n ys)) ∧ + (∀n. n < LENGTH ys ⇒ + ∀y. exp_rel (EL n xs) y ⇒ + ∃j. ($= +++ v_rel) (eval_to (j + k) (EL n xs)) (eval_to k y)) ∧ + (∀n. n < LENGTH ys ⇒ eval_to k (EL n ys) ≠ INL Diverge) ⇒ + ∃ck. ∀n. n < LENGTH xs ⇒ eval_to ck (EL n xs) ≠ INL Diverge +Proof + Induct \\ Cases_on ‘ys’ \\ rw [] \\ gvs [] + \\ last_x_assum $ qspecl_then [‘t’, ‘k’] mp_tac \\ gvs [] + \\ impl_tac + >- (rw [] \\ rpt (first_x_assum $ qspec_then ‘SUC n’ assume_tac \\ gvs [])) + \\ rw [] + \\ pop_assum mp_tac + \\ rpt (first_x_assum $ qspec_then ‘0’ assume_tac \\ gvs []) + \\ first_x_assum drule \\ rw [] + \\ ‘eval_to (j + k) h' ≠ INL Diverge’ by ( + Cases_on ‘eval_to (j + k) h'’ \\ Cases_on ‘eval_to k h’ \\ gvs []) + \\ qexists ‘j + k + ck’ \\ rw [] + \\ simp [EL_CONS] + \\ Cases_on ‘n’ \\ gvs [] + >- (drule eval_to_mono \\ rw []) + \\ first_x_assum drule \\ rw [] + \\ drule eval_to_mono \\ rw [] +QED + Theorem exp_rel_eval_to: ∀k x y. exp_rel x y ∧ @@ -852,9 +938,12 @@ Proof by (irule eval_to_mono \\ gs []) \\ qexists_tac ‘1 + k + ck + j1’ \\ gs [Once eval_to_def] - \\ gs [subst_funs_def, ELIM_UNCURRY] - \\ qpat_assum ‘_ = INL Type_error’ (SUBST1_TAC o SYM) - \\ irule eval_to_mono \\ gs []) + \\ Cases_on `eval_to (ck + (j1 + k)) (subst_funs x1 y1)` \\ gvs [] + \\ gvs [subst_funs_def, ELIM_UNCURRY] + \\ qmatch_asmsub_abbrev_tac `ev = INL Type_error` + \\ `ev ≠ INL Diverge` by gvs [] \\ unabbrev_all_tac + \\ drule eval_to_mono \\ rw [] + \\ first_x_assum $ qspec_then `ck + (j1 + k)` assume_tac \\ gvs []) \\ first_x_assum (drule_all_then (qx_choose_then ‘j2’ assume_tac)) \\ Cases_on ‘eval_to (k - 1) (subst_funs x2 y2) = INL Diverge’ \\ gs [] >- ( @@ -868,7 +957,10 @@ Proof \\ drule_then (qspec_then ‘j + k’ assume_tac) eval_to_mono \\ drule_then (qspec_then ‘j1 + k’ assume_tac) eval_to_mono \\ gs []) - \\ gs [SF SFY_ss]) + (*\\ gs [SF SFY_ss]*) + \\ gvs [] + \\ qexists `j2` \\ gvs [] + \\ Cases_on `eval_to (j2 + k - 1) (subst_funs x1 y1)` \\ gvs []) \\ ‘eval_to (j2 + k - 1) (subst_funs x1 y1) ≠ INL Diverge’ by (strip_tac \\ gvs [] \\ Cases_on `eval_to (k - 1) (subst_funs x2 y2)` \\ gvs [v_rel_def]) @@ -877,7 +969,11 @@ Proof \\ simp [Once eval_to_def] \\ ‘eval_to (j1 + j2 + k) x = eval_to (j1 + k) x’ by (irule eval_to_mono \\ gs []) - \\ gs []) + \\ gs [] + \\ Cases_on `eval_to (j2 + k - 1) (subst_funs x1 y1)` \\ gvs [] + \\ Cases_on `eval_to (k − 1) (subst_funs x2 y2)` \\ gvs [] + \\ rpt (IF_CASES_TAC \\ gvs []) + \\ drule v_rel_anyThunk \\ rw []) \\ rw [] \\ drule_all_then assume_tac v_rel_dest_anyThunk \\ gs [arithmeticTheory.FUNPOW_SUC] @@ -928,7 +1024,8 @@ Proof \\ qmatch_asmsub_abbrev_tac ‘(_ +++ _) (eval_to _ bod)’ \\ ‘eval_to (j2 + k) bod ≠ INL Diverge’ by (strip_tac \\ gs [] - \\ Cases_on ‘eval_to (k - 1) (subst_funs x2 y2)’ \\ gs []) + \\ Cases_on ‘eval_to (k - 1) (subst_funs x2 y2)’ \\ gs [] + \\ Cases_on `is_anyThunk y` \\ gvs []) \\ drule_then (qspec_then ‘j1 + j2 + k’ assume_tac) eval_to_mono \\ gs [] \\ ‘eval_to (j1 + j2 + k + 1) x = eval_to (j1 + k) x’ @@ -962,7 +1059,11 @@ Proof disch_then (qx_choose_then ‘j’ assume_tac) \\ qexists_tac ‘j’ \\ Cases_on ‘result_map (f j) xs’ - \\ Cases_on ‘result_map g ys’ \\ gs []) + \\ Cases_on ‘result_map g ys’ \\ gs [] + \\ rpt (IF_CASES_TAC \\ gvs []) + \\ gvs [EVERY_EL, EXISTS_MEM, MEM_EL, LIST_REL_EL_EQN] + \\ ntac 2 (first_x_assum drule \\ rpt strip_tac) + \\ drule v_rel_anyThunk \\ rw []) \\ gvs [LIST_REL_EL_EQN, MEM_EL, MEM_MAP, PULL_EXISTS] \\ ‘∀ck. result_map (eval_to ck) xs ≠ INL Type_error’ by (rpt strip_tac @@ -1017,6 +1118,62 @@ Proof \\ impl_tac >- ( rw [] + >~ [‘eval_to ck (Cons x xs) ≠ INL Type_error’] >- ( + qpat_x_assum ‘∀ck. eval_to _ (Cons _ _) ≠ _’ mp_tac + \\ rw [eval_to_def, oneline sum_bind_def] + \\ CASE_TAC \\ gvs [] + >- ( + Cases_on ‘x''’ \\ gvs [] + \\ first_x_assum $ qspec_then ‘ck’ mp_tac + \\ CASE_TAC \\ gvs [] + >- ( + Cases_on ‘x''’ \\ gvs [] + \\ ntac 2 (pop_assum mp_tac) \\ simp [result_map_def] + \\ IF_CASES_TAC \\ gvs []) + \\ ntac 2 (pop_assum mp_tac) \\ simp [result_map_def] + \\ IF_CASES_TAC \\ gvs []) + \\ rw [EVERY_EL] + \\ qpat_x_assum ‘∀ck. _ ≠ _’ mp_tac + \\ simp [result_map_def] + \\ ‘∀ck n. n < SUC (LENGTH xs) ⇒ + eval_to ck (EL n (x'::xs)) ≠ INL Type_error’ + by gvs [] \\ gvs [] + \\ ‘∃ck. ∀n. n < SUC (LENGTH xs) ⇒ + eval_to ck (EL n (x'::xs)) ≠ INL Diverge’ by ( + qspecl_then [‘x'::xs’, ‘y::ys’] mp_tac + exp_rel_result_map_Diverge \\ simp [] + \\ disch_then drule \\ rw []) + \\ gvs [] + \\ disch_then $ qspec_then ‘k + ck + ck'’ mp_tac + \\ ntac 2 (IF_CASES_TAC \\ gvs []) + >- ( + spose_not_then kall_tac + \\ first_x_assum $ qspec_then ‘0’ assume_tac \\ gvs [] + \\ ‘eval_to ck' x' ≠ INL Diverge’ by gvs [] + \\ drule eval_to_mono \\ rw [] + \\ qexists ‘ck + ck' + k’ \\ simp []) + >- ( + spose_not_then kall_tac + \\ gvs [MEM_MAP, MEM_EL] + \\ first_x_assum $ qspec_then ‘SUC (n')’ assume_tac \\ gvs [] + \\ ‘eval_to ck' (EL n' xs) ≠ INL Diverge’ by gvs [] + \\ drule eval_to_mono \\ rw [] + \\ qexists ‘ck + ck' + k’ \\ simp []) + \\ rw [EVERY_EL, EL_MAP] + \\ qpat_x_assum ‘result_map _ _ = INR _’ mp_tac + \\ rw [result_map_def] + \\ ‘n < LENGTH ys’ by gvs [LENGTH_MAP] + \\ simp [EL_MAP] + \\ Cases_on ‘eval_to ck (EL n xs)’ \\ gvs [] + >- (Cases_on ‘x’ \\ gvs [MEM_MAP, MEM_EL]) + \\ first_x_assum drule \\ rw [] + \\ Cases_on ‘eval_to (ck + ck' + k) (EL n xs)’ \\ gvs [] + >- (Cases_on ‘x’ \\ gvs [MEM_MAP, MEM_EL]) + \\ gvs [] + \\ ‘eval_to ck (EL n xs) ≠ INL Diverge’ by gvs [] + \\ ‘eval_to (ck + ck' + k) (EL n xs) ≠ INL Diverge’ by gvs [] + \\ imp_res_tac eval_to_equals_eval + \\ gvs []) \\ TRY ( rpt (qpat_x_assum ‘∀n. n < SUC _ ⇒ _’ (qspec_then ‘SUC n’ assume_tac)) \\ gs [] @@ -1436,3 +1593,76 @@ Proof \\ irule_at Any untick_sim_ok \\ irule_at Any untick_rel_ok \\ gs [] QED + +Theorem untick_apply_closure_delayed[local]: + exp_rel x y ∧ + v_rel v2 w2 ∧ + apply_closure x v2 f ≠ Err ∧ + f (INL Type_error) = Err ∧ + (∀x y. + ($= +++ v_rel) x y ∧ f x ≠ Err ⇒ + next_rel_delayed v_rel exp_rel (f x) (g y)) ⇒ + next_rel_delayed v_rel exp_rel + (apply_closure x v2 f) + (apply_closure y w2 g) +Proof + rw [apply_closure_def, with_value_def] >> + `eval x ≠ INL Type_error` by (CCONTR_TAC >> gvs[]) >> + dxrule_all_then assume_tac exp_rel_eval >> + Cases_on `eval x` >> Cases_on `eval y` >> gvs[] >- (CASE_TAC >> gvs[]) >> + rename1 `eval x = INR v1` >> rename1 `eval y = INR w1` + \\ Cases_on ‘v1’ \\ Cases_on ‘w1’ \\ gvs [dest_anyClosure_def] + >- ( + first_x_assum irule \\ gs [] + \\ irule exp_rel_eval + \\ gs [closed_subst] + \\ irule_at Any exp_rel_subst \\ gs [] + \\ strip_tac \\ gs []) + \\ rename1 ‘LIST_REL _ xs ys’ + \\ ‘OPTREL (λx y. ok_bind x ∧ exp_rel x y) + (ALOOKUP (REVERSE xs) s) + (ALOOKUP (REVERSE ys) s)’ + by (irule LIST_REL_OPTREL + \\ gvs [LIST_REL_EL_EQN, ELIM_UNCURRY]) + \\ gs [OPTREL_def] + \\ qpat_x_assum ‘exp_rel _ _ ’ mp_tac + \\ rw [Once exp_rel_cases] \\ gs [] + \\ first_x_assum irule \\ gs [] + \\ irule exp_rel_eval + \\ irule_at Any exp_rel_subst + \\ gs [EVERY2_MAP, MAP_MAP_o, combinTheory.o_DEF, LAMBDA_PROD, GSYM FST_THM] + \\ irule_at Any LIST_EQ + \\ gvs [LIST_REL_EL_EQN, EL_MAP, ELIM_UNCURRY] + \\ strip_tac \\ gs [] +QED + +Theorem untick_rel_ok_delayed[local]: + rel_ok_delayed F v_rel exp_rel +Proof + rw [rel_ok_delayed_def] + >- simp [v_rel_anyThunk] + >- simp [untick_apply_closure_delayed] + >- ntac 2 (simp [Once exp_rel_cases]) + >- ntac 2 (simp [Once exp_rel_cases]) + >- simp [Once exp_rel_cases] +QED + +Theorem untick_sim_ok_delayed[local]: + sim_ok_delayed F v_rel exp_rel +Proof + rw [sim_ok_delayed_def] + \\ simp [exp_rel_eval] + \\ irule exp_rel_subst \\ gs [] +QED + +Theorem untick_semantics_delayed: + exp_rel x y ∧ + closed x ∧ + pure_semantics$safe_itree (semantics_delayed x Done []) ⇒ + semantics_delayed x Done [] = semantics_delayed y Done [] +Proof + strip_tac + \\ irule sim_ok_delayed_semantics_delayed + \\ irule_at Any untick_sim_ok_delayed + \\ irule_at Any untick_rel_ok_delayed \\ gs [] +QED diff --git a/compiler/backend/passes/state_to_cakeScript.sml b/compiler/backend/passes/state_to_cakeScript.sml index 52de4b17..cc54ed55 100644 --- a/compiler/backend/passes/state_to_cakeScript.sml +++ b/compiler/backend/passes/state_to_cakeScript.sml @@ -264,16 +264,22 @@ Definition compile_atomop_def: End Definition compile_op_def: - compile_op (AppOp : csop) = CakeOp Opapp ∧ - compile_op (AtomOp aop) = compile_atomop aop ∧ - compile_op Ref = CakeOp AallocFixed ∧ - compile_op Length = CakeOp Alength ∧ - compile_op Sub = CakeOp Asub ∧ - compile_op UnsafeSub = CakeOp Asub_unsafe ∧ - compile_op Update = CakeOp Aupdate ∧ - compile_op UnsafeUpdate = CakeOp Aupdate_unsafe ∧ - compile_op Alloc = TwoArgs alloc ∧ - compile_op _ = Other + compile_op (AppOp : csop) = CakeOp Opapp ∧ + compile_op (AtomOp aop) = compile_atomop aop ∧ + compile_op Length = CakeOp Alength ∧ + compile_op Sub = CakeOp Asub ∧ + compile_op Update = CakeOp Aupdate ∧ + compile_op Alloc = TwoArgs alloc ∧ + compile_op (AllocMutThunk Evaluated) = CakeOp $ ThunkOp $ + AllocThunk Evaluated ∧ + compile_op (AllocMutThunk NotEvaluated) = CakeOp $ ThunkOp $ + AllocThunk NotEvaluated ∧ + compile_op (UpdateMutThunk Evaluated) = CakeOp $ ThunkOp $ + UpdateThunk Evaluated ∧ + compile_op (UpdateMutThunk NotEvaluated) = CakeOp $ ThunkOp $ + UpdateThunk NotEvaluated ∧ + compile_op ForceMutThunk = CakeOp $ ThunkOp ForceThunk ∧ + compile_op _ = Other End Definition compile_def: diff --git a/compiler/binary/pure_backendProgScript.sml b/compiler/binary/pure_backendProgScript.sml index 5a019ed1..becfdeab 100644 --- a/compiler/binary/pure_backendProgScript.sml +++ b/compiler/binary/pure_backendProgScript.sml @@ -106,9 +106,8 @@ val r = translate pure_configTheory.dest_Message_def; val r = translate env_cexpTheory.dest_Delay_def; val r = translate env_cexpTheory.dest_Lam_def; val r = translate state_cexpTheory.Lets_def; -val r = translate env_to_stateTheory.Bool_def; -val r = translate env_to_stateTheory.some_ref_bool_def; -val r = translate env_to_stateTheory.unsafe_update_def; +val r = translate env_to_stateTheory.some_alloc_thunk_def; +val r = translate env_to_stateTheory.update_delay_def; val r = translate (env_to_stateTheory.Letrec_imm_def |> REWRITE_RULE [MEMBER_INTRO]); val r = translate env_to_stateTheory.Letrec_split_def; val r = translate env_to_stateTheory.to_state_def; diff --git a/compiler/parsing/ispegexecScript.sml b/compiler/parsing/ispegexecScript.sml index 7c15e730..25309c30 100644 --- a/compiler/parsing/ispegexecScript.sml +++ b/compiler/parsing/ispegexecScript.sml @@ -207,13 +207,13 @@ End Theorem coreloop_result[simp]: coreloop G (Result x) = SOME (Result x) Proof - simp[coreloop_def, Once whileTheory.OWHILE_THM] + simp[coreloop_def, Once WhileTheory.OWHILE_THM] QED Theorem coreloop_Looped[simp]: coreloop G Looped = NONE Proof - simp[coreloop_def, whileTheory.OWHILE_EQ_NONE] >> Induct >> + simp[coreloop_def, WhileTheory.OWHILE_EQ_NONE] >> Induct >> simp[arithmeticTheory.FUNPOW] QED @@ -238,7 +238,7 @@ Proof QED fun inst_thm def (qs,ths) = - def |> SIMP_RULE (srw_ss()) [Once whileTheory.OWHILE_THM, coreloop_def] + def |> SIMP_RULE (srw_ss()) [Once WhileTheory.OWHILE_THM, coreloop_def] |> SPEC_ALL |> Q.INST qs |> SIMP_RULE (srw_ss()) [] diff --git a/compiler/proofs/pure_end_to_endProofScript.sml b/compiler/proofs/pure_end_to_endProofScript.sml index 33b9821d..5946795a 100644 --- a/compiler/proofs/pure_end_to_endProofScript.sml +++ b/compiler/proofs/pure_end_to_endProofScript.sml @@ -35,3 +35,8 @@ Proof rpt $ goal_assum $ drule_at Any >> simp[] QED +(* Making sure no proofs were cheated on the way here. *) +fun check_tag t = Tag.isEmpty t orelse Tag.isDisk t; +val check_thm = Lib.assert (check_tag o Thm.tag); + +val _ = check_thm end_to_end_correctness; diff --git a/language/pure_valueScript.sml b/language/pure_valueScript.sml index 1620b7ab..b639522f 100644 --- a/language/pure_valueScript.sml +++ b/language/pure_valueScript.sml @@ -740,7 +740,7 @@ Proof gvs[Constructor_rep_def,EVERY_MAP] >> first_x_assum match_mp_tac >> match_mp_tac (MP_CANON EVERY_MONOTONIC) >> - gvs [EVERY_EL] >> rw [] >> + gvs[EVERY_EL] >> rw [] >> first_x_assum drule >> rw [] QED