From cd40e1f8ed4d3b130330c833f53c690b31815406 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Tue, 3 Dec 2024 10:03:44 +0100 Subject: [PATCH 01/42] Start changing stateLang semantics for new thunks --- compiler/backend/languages/semantics/stateLangScript.sml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/compiler/backend/languages/semantics/stateLangScript.sml b/compiler/backend/languages/semantics/stateLangScript.sml index 6949e07b..2f3e61f6 100644 --- a/compiler/backend/languages/semantics/stateLangScript.sml +++ b/compiler/backend/languages/semantics/stateLangScript.sml @@ -75,7 +75,13 @@ End Type env[pp] = ``:(vname # v) list``; (* value environments *) -Type state[pp] = ``:(v list) list``; (* state *) +Datatype: + store_v = + Array (v list) + | ThunkMem bool v +End + +Type state[pp] = ``:store_v list``; (* state *) Datatype: cont = (* continuations *) From bc9103f2fdaec4b44932a565d1886e538d5dcd95 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 12 Dec 2024 13:40:07 +0200 Subject: [PATCH 02/42] Propagate changes in stateLangScript and update state_app_unit_ProofScript --- .../languages/semantics/stateLangScript.sml | 47 +++--- .../proofs/state_app_unit_1ProofScript.sml | 142 +++++++++++++----- .../proofs/state_app_unit_2ProofScript.sml | 130 ++++++++++++---- 3 files changed, 224 insertions(+), 95 deletions(-) diff --git a/compiler/backend/languages/semantics/stateLangScript.sml b/compiler/backend/languages/semantics/stateLangScript.sml index 2f3e61f6..b1d9bcd7 100644 --- a/compiler/backend/languages/semantics/stateLangScript.sml +++ b/compiler/backend/languages/semantics/stateLangScript.sml @@ -257,22 +257,23 @@ 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 + value (Atom $ Loc $ LENGTH stores) + (SOME (SNOC (Array $ REPLICATE n (EL 1 vs)) stores)) + k | _ => error st k) ∧ application Ref vs st k = ( case st of - SOME arrays => - value (Atom $ Loc $ LENGTH arrays) - (SOME (SNOC vs arrays)) k + SOME stores => + value (Atom $ Loc $ LENGTH stores) + (SOME (SNOC (Array 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 = ( @@ -291,9 +292,9 @@ 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 @@ -302,9 +303,9 @@ Definition application_def: | _ => 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 => + (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 @@ -313,13 +314,13 @@ Definition application_def: | _ => 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) @@ -327,13 +328,13 @@ Definition application_def: | _ => 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 => + (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 error st k diff --git a/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml b/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml index 8a33fd49..13ba4b22 100644 --- a/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml +++ b/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml @@ -168,8 +168,17 @@ Definition rec_env_def: MAP (λ(fn,_). (fn,Recclosure f env fn)) f ++ env End +Definition store_rel_def: + store_rel (Array vs1) (Array vs2) = LIST_REL v_rel vs1 vs2 ∧ + store_rel _ _ = F +End + +Definition state_rel_def: + state_rel st1 st2 = LIST_REL store_rel st1 st2 +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) ∧ @@ -237,12 +246,12 @@ 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 ∧ + 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 (LIST_REL (LIST_REL v_rel)) ts1 ss1 ∧ + 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] @@ -297,16 +306,18 @@ 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 [] + \\ 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]) >~ [‘Length’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -315,8 +326,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 @@ -328,11 +343,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) + \\ 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]) >~ [‘UnsafeSub’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -344,9 +368,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 []) + \\ 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 @@ -358,13 +393,27 @@ 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) + \\ 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]) >~ [‘UnsafeUpdate’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -376,12 +425,27 @@ 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] \\ strip_tac \\ 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 [] + \\ 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]) >~ [‘FFI’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -451,12 +515,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 @@ -589,10 +653,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 @@ -616,10 +680,10 @@ 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 @@ -668,11 +732,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 @@ -698,11 +762,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 [] @@ -745,12 +809,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 @@ -777,7 +841,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 @@ -842,7 +906,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 = @@ -852,7 +916,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 ∧ @@ -908,7 +972,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 val _ = export_theory (); diff --git a/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml b/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml index 474616e9..86a8b655 100644 --- a/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml +++ b/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml @@ -187,8 +187,17 @@ Definition rec_env_def: MAP (λ(fn,_). (fn,Recclosure f env fn)) f ++ env End +Definition store_rel_def: + store_rel (Array vs1) (Array vs2) = LIST_REL v_rel vs1 vs2 ∧ + store_rel _ _ = F +End + +Definition state_rel_def: + state_rel st1 st2 = LIST_REL store_rel st1 st2 +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) ∧ @@ -256,12 +265,12 @@ 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 ∧ + 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 (LIST_REL (LIST_REL v_rel)) ts1 ss1 ∧ + 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] @@ -316,16 +325,18 @@ 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 [] + \\ 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]) >~ [‘Length’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -334,8 +345,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 @@ -347,11 +362,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) + \\ 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]) >~ [‘UnsafeSub’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -363,9 +387,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 []) + \\ 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 @@ -377,13 +412,27 @@ 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) + \\ 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]) >~ [‘UnsafeUpdate’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -395,12 +444,27 @@ 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] \\ strip_tac \\ 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 [] + \\ 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]) >~ [‘FFI’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -417,13 +481,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 @@ -504,13 +568,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 @@ -729,13 +793,13 @@ 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 @@ -906,7 +970,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 @@ -971,7 +1035,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 = @@ -981,7 +1045,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 ∧ @@ -1037,7 +1101,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 (* From c374a42f2abe47bc3ecbd0df573fe03a8bcb0b4d Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 12 Dec 2024 23:06:08 +0200 Subject: [PATCH 03/42] Update proofs. unthunk remains --- .../proofs/env_to_state_1ProofScript.sml | 61 ++++++--- .../passes/proofs/state_caseProofScript.sml | 124 ++++++++++++++---- .../proofs/state_names_1ProofScript.sml | 124 ++++++++++++++---- 3 files changed, 233 insertions(+), 76 deletions(-) diff --git a/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml b/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml index f2362c18..0744f282 100644 --- a/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml +++ b/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml @@ -1022,23 +1022,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)) @@ -1051,7 +1060,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 @@ -1394,7 +1403,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`] >- ( @@ -1414,7 +1423,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` >> @@ -1424,7 +1437,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`] >- ( @@ -1455,8 +1468,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[] >> @@ -1469,8 +1486,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[] >> @@ -1483,7 +1500,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`] @@ -1526,13 +1544,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[] @@ -1542,9 +1565,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` >> @@ -1555,14 +1579,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 @@ -1613,7 +1638,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 @@ -1692,7 +1717,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 @@ -1701,7 +1726,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)) ⇒ @@ -1759,7 +1784,7 @@ 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 val _ = export_theory (); diff --git a/compiler/backend/passes/proofs/state_caseProofScript.sml b/compiler/backend/passes/proofs/state_caseProofScript.sml index cf09aa90..eeb5f3e3 100644 --- a/compiler/backend/passes/proofs/state_caseProofScript.sml +++ b/compiler/backend/passes/proofs/state_caseProofScript.sml @@ -191,8 +191,17 @@ Definition rec_env_def: MAP (λ(fn,_). (fn,Recclosure f env fn)) f ++ env End +Definition store_rel_def: + store_rel (Array vs1) (Array vs2) = LIST_REL v_rel vs1 vs2 ∧ + store_rel _ _ = F +End + +Definition state_rel_def: + state_rel st1 st2 = LIST_REL store_rel st1 st2 +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) ∧ @@ -251,12 +260,12 @@ 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 ∧ + 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 (LIST_REL (LIST_REL v_rel)) ts1 ss1 ∧ + 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] @@ -313,16 +322,18 @@ 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 [] + \\ 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]) >~ [‘Length’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -331,8 +342,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 @@ -344,10 +359,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]) + \\ 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]) >~ [‘UnsafeSub’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -359,9 +384,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 []) + \\ 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 @@ -373,12 +409,27 @@ 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] \\ strip_tac \\ 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 [] + \\ 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]) >~ [‘UnsafeUpdate’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -390,12 +441,27 @@ 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] \\ strip_tac \\ 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 [] + \\ 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]) >~ [‘FFI’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -451,12 +517,12 @@ 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 @@ -663,12 +729,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 [] @@ -698,7 +764,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 @@ -753,7 +819,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 = @@ -763,7 +829,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 ∧ @@ -819,7 +885,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 val _ = export_theory (); diff --git a/compiler/backend/passes/proofs/state_names_1ProofScript.sml b/compiler/backend/passes/proofs/state_names_1ProofScript.sml index 2727da4d..c3217445 100644 --- a/compiler/backend/passes/proofs/state_names_1ProofScript.sml +++ b/compiler/backend/passes/proofs/state_names_1ProofScript.sml @@ -174,8 +174,17 @@ Definition rec_env_def: MAP (λ(fn,_). (fn,Recclosure f env fn)) f ++ env End +Definition store_rel_def: + store_rel (Array vs1) (Array vs2) = LIST_REL v_rel vs1 vs2 ∧ + store_rel _ _ = F +End + +Definition state_rel_def: + state_rel st1 st2 = LIST_REL store_rel st1 st2 +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) ∧ @@ -265,12 +274,12 @@ 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 ∧ + 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 (LIST_REL (LIST_REL v_rel)) ts1 ss1 ∧ + 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] @@ -349,16 +358,18 @@ 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 [] + \\ 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]) >~ [‘Length’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -367,8 +378,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 @@ -380,10 +395,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]) + \\ 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]) >~ [‘UnsafeSub’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -395,9 +420,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 []) + \\ 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 @@ -409,12 +445,27 @@ 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] \\ strip_tac \\ 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 [] + \\ 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]) >~ [‘UnsafeUpdate’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -426,12 +477,27 @@ 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] \\ strip_tac \\ 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 [] + \\ 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]) >~ [‘FFI’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -489,11 +555,11 @@ 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 @@ -656,11 +722,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 [] @@ -682,7 +748,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)) @@ -720,7 +786,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 ---> @@ -730,7 +796,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 ∧ @@ -789,7 +855,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 val _ = export_theory (); From 92a07bc960463fcf32257aefa1532161182ea391 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Tue, 17 Dec 2024 16:36:11 +0200 Subject: [PATCH 04/42] Added thunk app primitives to state lang. Proofs need fixing --- .../languages/semantics/stateLangScript.sml | 130 ++++++++++-------- .../backend/languages/state_cexpScript.sml | 10 +- .../backend/passes/env_to_stateScript.sml | 29 ++-- .../proofs/state_app_unit_1ProofScript.sml | 2 +- .../proofs/state_unthunkProofScript.sml | 13 +- 5 files changed, 103 insertions(+), 81 deletions(-) diff --git a/compiler/backend/languages/semantics/stateLangScript.sml b/compiler/backend/languages/semantics/stateLangScript.sml index b1d9bcd7..237b2d9d 100644 --- a/compiler/backend/languages/semantics/stateLangScript.sml +++ b/compiler/backend/languages/semantics/stateLangScript.sml @@ -24,6 +24,10 @@ val _ = numLib.prefer_num(); (******************** Datatypes ********************) +Datatype: + thunk_mode = Evaluated | NotEvaluated +End + Datatype: sop = (* Primitive operations *) | AppOp (* function application *) @@ -32,12 +36,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 @@ -78,7 +82,7 @@ Type env[pp] = ``:(vname # v) list``; (* value environments *) Datatype: store_v = Array (v list) - | ThunkMem bool v + | ThunkMem thunk_mode v End Type state[pp] = ``:store_v list``; (* state *) @@ -95,6 +99,7 @@ Datatype: | RaiseK | HandleK env vname exp | HandleAppK env exp + | ForceMutK num End Datatype: @@ -159,12 +164,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 @@ -234,6 +239,10 @@ Definition dest_anyThunk_def: | _ => NONE End +Definition AppUnit_def: + AppUnit e = App AppOp [e; Unit] +End + (******************** Semantics functions ********************) (* Carry out an application - assumes: @@ -263,12 +272,6 @@ Definition application_def: (SOME (SNOC (Array $ REPLICATE n (EL 1 vs)) stores)) k | _ => error st k) ∧ - application Ref vs st k = ( - case st of - SOME stores => - value (Atom $ Loc $ LENGTH stores) - (SOME (SNOC (Array vs) stores)) k - | _ => error st k) ∧ application Length vs st k = ( case HD vs, st of Atom (Loc n), SOME stores => ( @@ -301,17 +304,6 @@ Definition application_def: (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 stores) => ( - case oEL n stores of - SOME (Array 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 stores) => ( @@ -326,18 +318,31 @@ Definition application_def: (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 stores) => ( + application (AllocMutThunk mode) vs st k = ( + case HD vs, st of + v, SOME stores => + value (Atom $ Loc $ LENGTH stores) + (SOME (SNOC (ThunkMem mode v) stores)) + k + | _ => error st k) ∧ + application (UpdateMutThunk mode) vs st k = ( + case HD vs, st of + (Atom $ Loc n, SOME stores) => ( case oEL n stores of - SOME (Array l) => - if 0 ≤ i ∧ i < & LENGTH l then - value - (Constructor "" []) - (SOME (LUPDATE (Array $ LUPDATE (EL 2 vs) (Num i) l) n stores)) - k - else - error st k + 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 + (Atom $ Loc n, SOME stores) => ( + case oEL n stores of + SOME (ThunkMem Evaluated v) => value v st k + | SOME (ThunkMem NotEvaluated f) => + push [("f",f)] (AppUnit (Var "f")) st (ForceMutK n) k | _ => error st k) | _ => error st k) ∧ application (FFI channel) vs st k = ( @@ -370,7 +375,15 @@ Definition return_def: | 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 st (BoxK :: k) = value (Thunk $ INL v) st k ∧ + return v st (ForceMutK n :: k) = + (case st of + SOME stores => + value + (Constructor "" []) + (SOME (LUPDATE (ThunkMem Evaluated v) n stores)) + k + | NONE => error st k) End Definition find_match_list_def: @@ -656,7 +669,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: @@ -778,12 +791,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] @@ -962,6 +975,10 @@ 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’] >- + (fs [return_def,error_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]) \\ rename [‘AppK env sop vs es’] \\ gvs [] \\ reverse (Cases_on ‘es’) \\ fs [return_def,continue_def] @@ -1011,26 +1028,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’] >- @@ -1081,7 +1100,7 @@ Proof \\ 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] + \\ gvs [application_def,AllCaseEqs(),error_def,continue_def,value_def,push_def] QED Theorem step_inc_nil: @@ -1122,7 +1141,7 @@ Proof 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] + \\ gvs [continue_def,value_def,push_def] QED Theorem step_eq_cont: @@ -1146,7 +1165,7 @@ Proof \\ 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] + \\ gvs [continue_def,value_def,push_def] QED Triviality step_n_cont_swap_lemma: @@ -1568,13 +1587,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/state_cexpScript.sml b/compiler/backend/languages/state_cexpScript.sml index d830c352..4b4df185 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 d6f59144..f694c1f5 100644 --- a/compiler/backend/passes/env_to_stateScript.sml +++ b/compiler/backend/passes/env_to_stateScript.sml @@ -39,12 +39,16 @@ End Definition some_ref_bool_def: some_ref_bool (v:mlstring,b,y:state_cexp$cexp) = - (SOME v, App Ref [Bool b; Bool b]) + (SOME v, App Alloc [IntLit 2; 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: @@ -75,8 +79,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`` @@ -107,25 +109,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) $ 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/state_app_unit_1ProofScript.sml b/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml index 13ba4b22..ee3d0a56 100644 --- a/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml +++ b/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml @@ -328,7 +328,7 @@ Proof \\ 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] + \\ first_assum drule \\ asm_rewrite_tac [store_rel_def] \\ strip_tac \\ simp [Once v_rel_cases] \\ gvs [LIST_REL_EL_EQN,state_rel_def] \\ imp_res_tac LIST_REL_LENGTH \\ fs []) diff --git a/compiler/backend/passes/proofs/state_unthunkProofScript.sml b/compiler/backend/passes/proofs/state_unthunkProofScript.sml index 6a07b021..e0a3b154 100644 --- a/compiler/backend/passes/proofs/state_unthunkProofScript.sml +++ b/compiler/backend/passes/proofs/state_unthunkProofScript.sml @@ -24,20 +24,23 @@ Overload False_v = “stateLang$Constructor "False" []”; (****************************************) -Overload "box" = “λx. App Ref [True; x]” +(*Overload "box" = “λx. App Ref [True; x]”*) +Overload "box" = ``λx. App (AllocMutThunk Evaluated) [x]`` -Overload "delay" = “λx. App Ref [False; Lam NONE x]” +(*Overload "delay" = “λx. App Ref [False; Lam NONE x]”*) +Overload "delay" = ``λx. App (AllocMutThunk NotEvaluated) [Lam NONE x]`` -Overload "force_lets" = “ +(*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"” + Var "wh"”*) -Overload "force" = “λx. Let (SOME "v") x force_lets” +(*Overload "force" = “λx. Let (SOME "v") x force_lets”*) +Overload "force" = ``λx. App ForceMutThunk [x]`` Definition dest_Delay_def: dest_Delay (Delay x) = SOME x ∧ From be5ce297a7b3a0075a9c98838eb6b97bc0abbee8 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Mon, 30 Dec 2024 00:00:41 +0200 Subject: [PATCH 05/42] Fixed proofs and minor style inconsintencies of previous commits. One proof remains cheated in `state_to_cakeProof` --- .../languages/semantics/stateLangScript.sml | 5 +- .../backend/passes/env_to_stateScript.sml | 13 +- .../proofs/env_to_state_2ProofScript.sml | 53 +- .../proofs/state_app_unit_1ProofScript.sml | 152 +++-- .../proofs/state_app_unit_2ProofScript.sml | 159 +++--- .../passes/proofs/state_caseProofScript.sml | 154 +++-- .../proofs/state_names_1ProofScript.sml | 154 +++-- .../proofs/state_to_cakeProofScript.sml | 175 +++--- .../proofs/state_unthunkProofScript.sml | 531 +++++++++++------- .../backend/passes/state_to_cakeScript.sml | 22 +- 10 files changed, 775 insertions(+), 643 deletions(-) diff --git a/compiler/backend/languages/semantics/stateLangScript.sml b/compiler/backend/languages/semantics/stateLangScript.sml index 237b2d9d..ecbc19ae 100644 --- a/compiler/backend/languages/semantics/stateLangScript.sml +++ b/compiler/backend/languages/semantics/stateLangScript.sml @@ -379,10 +379,7 @@ Definition return_def: return v st (ForceMutK n :: k) = (case st of SOME stores => - value - (Constructor "" []) - (SOME (LUPDATE (ThunkMem Evaluated v) n stores)) - k + value v (SOME (LUPDATE (ThunkMem Evaluated v) n stores)) k | NONE => error st k) End diff --git a/compiler/backend/passes/env_to_stateScript.sml b/compiler/backend/passes/env_to_stateScript.sml index f694c1f5..d973c5c8 100644 --- a/compiler/backend/passes/env_to_stateScript.sml +++ b/compiler/backend/passes/env_to_stateScript.sml @@ -32,14 +32,9 @@ Definition Letrec_split_def: | NONE => (xs,ys) End -Definition Bool_def[simp]: - Bool T = (True :state_cexp$cexp) ∧ - Bool F = (False :state_cexp$cexp) -End - -Definition some_ref_bool_def: - some_ref_bool (v:mlstring,b,y:state_cexp$cexp) = - (SOME v, App Alloc [IntLit 2; Bool b]) +Definition some_alloc_thunk_def: + some_alloc_thunk (v:mlstring,b,y:state_cexp$cexp) = + (SOME v, App (AllocMutThunk NotEvaluated) [IntLit 0]) End Definition update_delay_def: @@ -118,7 +113,7 @@ Definition to_state_def: (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 update_delay delays) (to_state y)) ∧ to_state (Let vo x y) = diff --git a/compiler/backend/passes/proofs/env_to_state_2ProofScript.sml b/compiler/backend/passes/proofs/env_to_state_2ProofScript.sml index 6529c6da..c77065b9 100644 --- a/compiler/backend/passes/proofs/env_to_state_2ProofScript.sml +++ b/compiler/backend/passes/proofs/env_to_state_2ProofScript.sml @@ -169,11 +169,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 @@ -256,7 +256,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] @@ -333,8 +333,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] @@ -403,16 +404,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 [] @@ -605,7 +604,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’] >- @@ -810,8 +808,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 [] @@ -829,15 +827,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 [] @@ -857,7 +856,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 @@ -867,8 +866,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 @@ -898,7 +897,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] @@ -1066,10 +1065,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] @@ -1082,7 +1078,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] @@ -1206,11 +1202,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/state_app_unit_1ProofScript.sml b/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml index ee3d0a56..2bd38362 100644 --- a/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml +++ b/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml @@ -115,6 +115,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. @@ -148,7 +159,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: @@ -168,15 +184,6 @@ Definition rec_env_def: MAP (λ(fn,_). (fn,Recclosure f env fn)) f ++ env End -Definition store_rel_def: - store_rel (Array vs1) (Array vs2) = LIST_REL v_rel vs1 vs2 ∧ - store_rel _ _ = F -End - -Definition state_rel_def: - state_rel st1 st2 = LIST_REL store_rel st1 st2 -End - Inductive snext_res_rel: (OPTREL state_rel ts ss ∧ cont_rel tk sk ⇒ snext_res_rel (Act x tk ts) (Act x sk ss)) ∧ @@ -311,13 +318,6 @@ Proof \\ simp [Once v_rel_cases] \\ 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 [] - \\ fs [state_rel_def] - \\ imp_res_tac LIST_REL_LENGTH \\ fs [] - \\ simp [Once v_rel_cases] - \\ fs [LIST_REL_SNOC,store_rel_def]) >~ [‘Length’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -327,7 +327,7 @@ Proof \\ 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] + \\ 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,state_rel_def] @@ -345,41 +345,17 @@ Proof \\ 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] + \\ 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] - \\ Cases_on `0 ≤ i` \\ gvs [] + \\ Cases_on ‘0 ≤ i’ \\ gvs [] >- (imp_res_tac integerTheory.NUM_POSINT_EXISTS - \\ first_x_assum $ qspec_then `&n'` assume_tac + \\ 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]) - >~ [‘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 [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] - \\ 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 [] + \\ 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’] >- @@ -395,57 +371,64 @@ Proof \\ 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] + \\ 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] - \\ Cases_on `0 ≤ i` \\ 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 [] + \\ 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 [] + \\ 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] + \\ 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]) - >~ [‘UnsafeUpdate’] >- + >~ [‘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 [] + \\ 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 [] - \\ qpat_x_assum ‘v_rel _ h'’ mp_tac + \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ 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’] >- + (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 [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] - \\ 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]) + \\ 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 [AppUnit_def] + \\ ntac 3 $ simp [Once compile_rel_cases] + \\ rw [env_rel_def] + \\ simp [Once cont_rel_cases,state_rel_def,LIST_REL_EL_EQN] + \\ metis_tac []) >~ [‘FFI’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -715,6 +698,13 @@ Proof >~ [‘LetK _ n’] >- (Cases_on ‘n’ \\ gvs [step,step_res_rel_cases] \\ irule env_rel_cons \\ simp []) + >~ [‘ForceMutK’] >- + (gvs [step] + \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] + \\ gvs [step_res_rel_cases,state_rel_def,LIST_REL_EL_EQN] + \\ simp [Once v_rel_cases,state_rel_def,LIST_REL_EL_EQN] \\ strip_tac + \\ gvs [EL_LUPDATE] + \\ IF_CASES_TAC \\ rw [store_rel_def]) \\ rename [‘AppK’] \\ reverse (Cases_on ‘tes’) \\ gvs [] \\ gvs [step] >- diff --git a/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml b/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml index 86a8b655..4c941839 100644 --- a/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml +++ b/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml @@ -128,6 +128,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. @@ -167,7 +178,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: @@ -187,15 +203,6 @@ Definition rec_env_def: MAP (λ(fn,_). (fn,Recclosure f env fn)) f ++ env End -Definition store_rel_def: - store_rel (Array vs1) (Array vs2) = LIST_REL v_rel vs1 vs2 ∧ - store_rel _ _ = F -End - -Definition state_rel_def: - state_rel st1 st2 = LIST_REL store_rel st1 st2 -End - Inductive snext_res_rel: (OPTREL state_rel ts ss ∧ cont_rel tk sk ⇒ snext_res_rel (Act x tk ts) (Act x sk ss)) ∧ @@ -330,13 +337,6 @@ Proof \\ simp [Once v_rel_cases] \\ 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 [] - \\ fs [state_rel_def] - \\ imp_res_tac LIST_REL_LENGTH \\ fs [] - \\ simp [Once v_rel_cases] - \\ fs [LIST_REL_SNOC,store_rel_def]) >~ [‘Length’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -346,8 +346,8 @@ Proof \\ 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] + \\ 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,state_rel_def] \\ imp_res_tac LIST_REL_LENGTH \\ fs []) @@ -364,43 +364,18 @@ Proof \\ 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] - \\ 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]) - >~ [‘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 [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] + \\ 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] - \\ Cases_on `0 ≤ i` \\ gvs [] + \\ Cases_on ‘0 ≤ i’ \\ gvs [] >- (imp_res_tac integerTheory.NUM_POSINT_EXISTS - \\ first_x_assum $ qspec_then `&n'` assume_tac + \\ first_x_assum $ qspec_then ‘&n'’ assume_tac \\ gvs [] - \\ Cases_on `n' < LENGTH l'` \\ 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]) + \\ 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 @@ -414,57 +389,63 @@ Proof \\ 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] + \\ 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] - \\ Cases_on `0 ≤ i` \\ 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 [] + \\ 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 [] + \\ 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] + \\ 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]) - >~ [‘UnsafeUpdate’] >- + \\ 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 [] + \\ 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 [] - \\ qpat_x_assum ‘v_rel _ h'’ mp_tac + \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ 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’] >- + (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 [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] - \\ 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]) + \\ 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 [AppUnit_def] + \\ ntac 3 $ simp [Once compile_rel_cases] + \\ rw [env_rel_def] + \\ simp [Once cont_rel_cases,state_rel_def,LIST_REL_EL_EQN] + \\ metis_tac []) >~ [‘FFI’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -946,6 +927,16 @@ Proof \\ first_assum $ irule_at Any \\ fs [] \\ first_x_assum $ irule_at $ Pos hd \\ fs [] \\ simp [Once step_res_rel_cases]) + >~ [‘ForceMutK’] >- + (Q.REFINE_EXISTS_TAC ‘SUC ck’ \\ fs [ADD_CLAUSES,step_n_SUC,step] + \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] + \\ gvs [is_halt_step] + >- (qexists_tac ‘n’ \\ fs [step_res_rel_cases]) + \\ first_assum $ irule_at Any \\ fs [] + \\ first_x_assum $ irule_at $ Pos hd \\ fs [] + \\ simp [Once step_res_rel_cases] + \\ gvs [state_rel_def,LIST_REL_EL_EQN,EL_LUPDATE] + \\ strip_tac \\ IF_CASES_TAC \\ 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] diff --git a/compiler/backend/passes/proofs/state_caseProofScript.sml b/compiler/backend/passes/proofs/state_caseProofScript.sml index eeb5f3e3..6dd2ed82 100644 --- a/compiler/backend/passes/proofs/state_caseProofScript.sml +++ b/compiler/backend/passes/proofs/state_caseProofScript.sml @@ -153,6 +153,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. @@ -183,7 +194,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: @@ -191,15 +207,6 @@ Definition rec_env_def: MAP (λ(fn,_). (fn,Recclosure f env fn)) f ++ env End -Definition store_rel_def: - store_rel (Array vs1) (Array vs2) = LIST_REL v_rel vs1 vs2 ∧ - store_rel _ _ = F -End - -Definition state_rel_def: - state_rel st1 st2 = LIST_REL store_rel st1 st2 -End - Inductive snext_res_rel: (OPTREL state_rel ts ss ∧ cont_rel tk sk ⇒ snext_res_rel (Act x tk ts) (Act x sk ss)) ∧ @@ -327,13 +334,6 @@ Proof \\ simp [Once v_rel_cases] \\ 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 [] - \\ fs [state_rel_def] - \\ imp_res_tac LIST_REL_LENGTH \\ fs [] - \\ simp [Once v_rel_cases] - \\ fs [LIST_REL_SNOC,store_rel_def]) >~ [‘Length’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -343,8 +343,8 @@ Proof \\ 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] + \\ 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,state_rel_def] \\ imp_res_tac LIST_REL_LENGTH \\ fs []) @@ -361,41 +361,17 @@ Proof \\ 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] + \\ 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] - \\ Cases_on `0 ≤ i` \\ gvs [] + \\ Cases_on ‘0 ≤ i’ \\ gvs [] >- (imp_res_tac integerTheory.NUM_POSINT_EXISTS - \\ first_x_assum $ qspec_then `&n'` assume_tac + \\ 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]) - >~ [‘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 [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] - \\ 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 [] + \\ 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’] >- @@ -411,57 +387,64 @@ Proof \\ 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] + \\ 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] - \\ Cases_on `0 ≤ i` \\ 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 [] + \\ 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 [] + \\ 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] + \\ 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]) - >~ [‘UnsafeUpdate’] >- + >~ [‘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 [] + \\ 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 [] - \\ qpat_x_assum ‘v_rel _ h'’ mp_tac + \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ 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’] >- + (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 [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] - \\ 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]) + \\ 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 [AppUnit_def] + \\ ntac 3 $ simp [Once compile_rel_cases] + \\ rw [env_rel_def] + \\ simp [Once cont_rel_cases,state_rel_def,LIST_REL_EL_EQN] + \\ metis_tac []) >~ [‘FFI’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -716,6 +699,13 @@ Proof (Cases_on ‘n’ \\ gvs [step,step_res_rel_cases] \\ irule env_rel_cons \\ simp [] \\ first_assum $ irule_at Any \\ fs []) + >~ [‘ForceMutK’] >- + (gvs [step] + \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] + \\ gvs [step_res_rel_cases,state_rel_def,LIST_REL_EL_EQN] + \\ simp [Once v_rel_cases,state_rel_def,LIST_REL_EL_EQN] \\ strip_tac + \\ gvs [EL_LUPDATE] + \\ IF_CASES_TAC \\ rw [store_rel_def]) \\ rename [‘AppK’] \\ reverse (Cases_on ‘tes’) \\ gvs [] \\ gvs [step] >- (simp [Once cont_rel_cases, step_res_rel_cases] \\ rw []) diff --git a/compiler/backend/passes/proofs/state_names_1ProofScript.sml b/compiler/backend/passes/proofs/state_names_1ProofScript.sml index c3217445..574c4363 100644 --- a/compiler/backend/passes/proofs/state_names_1ProofScript.sml +++ b/compiler/backend/passes/proofs/state_names_1ProofScript.sml @@ -131,6 +131,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. @@ -166,7 +177,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: @@ -174,15 +190,6 @@ Definition rec_env_def: MAP (λ(fn,_). (fn,Recclosure f env fn)) f ++ env End -Definition store_rel_def: - store_rel (Array vs1) (Array vs2) = LIST_REL v_rel vs1 vs2 ∧ - store_rel _ _ = F -End - -Definition state_rel_def: - state_rel st1 st2 = LIST_REL store_rel st1 st2 -End - Inductive snext_res_rel: (OPTREL state_rel ts ss ∧ cont_rel tk sk ⇒ snext_res_rel (Act x tk ts) (Act x sk ss)) ∧ @@ -363,13 +370,6 @@ Proof \\ simp [Once v_rel_cases] \\ 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 [] - \\ fs [state_rel_def] - \\ imp_res_tac LIST_REL_LENGTH \\ fs [] - \\ simp [Once v_rel_cases] - \\ fs [LIST_REL_SNOC,store_rel_def]) >~ [‘Length’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -379,8 +379,8 @@ Proof \\ 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] + \\ 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,state_rel_def] \\ imp_res_tac LIST_REL_LENGTH \\ fs []) @@ -397,41 +397,17 @@ Proof \\ 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] + \\ 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] - \\ Cases_on `0 ≤ i` \\ gvs [] + \\ Cases_on ‘0 ≤ i’ \\ gvs [] >- (imp_res_tac integerTheory.NUM_POSINT_EXISTS - \\ first_x_assum $ qspec_then `&n'` assume_tac + \\ 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]) - >~ [‘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 [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] - \\ 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 [] + \\ 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’] >- @@ -447,57 +423,64 @@ Proof \\ 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] + \\ 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] - \\ Cases_on `0 ≤ i` \\ 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 [] + \\ 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 [] + \\ 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] + \\ 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]) - >~ [‘UnsafeUpdate’] >- + >~ [‘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 [] + \\ 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 [] - \\ qpat_x_assum ‘v_rel _ h'’ mp_tac + \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ 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’] >- + (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 [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] - \\ 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]) + \\ 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 [AppUnit_def] + \\ ntac 3 $ simp [Once compile_rel_cases] + \\ rw [env_rel_def] + \\ simp [Once cont_rel_cases,state_rel_def,LIST_REL_EL_EQN] + \\ metis_tac []) >~ [‘FFI’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac @@ -707,6 +690,13 @@ Proof >- gvs [env_rel_def,SUBSET_DEF] \\ irule env_rel_cons \\ simp [] \\ first_assum $ irule_at Any \\ fs []) + >~ [‘ForceMutK’] >- + (gvs [step] + \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] + \\ gvs [step_res_rel_cases,state_rel_def,LIST_REL_EL_EQN] + \\ simp [Once v_rel_cases,state_rel_def,LIST_REL_EL_EQN] \\ strip_tac + \\ gvs [EL_LUPDATE] + \\ IF_CASES_TAC \\ rw [store_rel_def]) \\ rename [‘AppK’] \\ reverse (Cases_on ‘tes’) \\ gvs [] \\ gvs [step] >- diff --git a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml index f63a72cf..420a3d58 100644 --- a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml +++ b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml @@ -209,12 +209,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 F) ∧ + op_rel (AllocMutThunk NotEvaluated) (ThunkOp $ AllocThunk T) ∧ + op_rel (UpdateMutThunk Evaluated) (ThunkOp $ UpdateThunk F) ∧ + op_rel (UpdateMutThunk NotEvaluated) (ThunkOp $ UpdateThunk T) ∧ + op_rel ForceMutThunk (ThunkOp ForceThunk) End Definition pat_row_def: @@ -392,7 +394,7 @@ Theorem strle_v_def[local] = SRULE [strle_exp_def] strle_v_def; Definition env_ok_def: env_ok env ⇔ - nsLookup env.v (Short "ffi_array") = SOME (semanticPrimitives$Loc 0) ∧ + nsLookup env.v (Short "ffi_array") = SOME (semanticPrimitives$Loc T 0) ∧ (∃env'. nsLookup env.v (Short "strle") = SOME $ strle_v env' ∧ nsLookup env'.c (Short $ "True") = SOME (0n, TypeStamp "True" bool_type_num) ∧ @@ -435,7 +437,7 @@ Inductive v_rel: v_rel cnenv (Atom $ Str s) (Litv $ StrLit s) [~Loc:] - v_rel cnenv (Atom $ Loc n) (Loc (n + 1)) (* leave space for FFI array *) + v_rel cnenv (Atom $ Loc n) (Loc T (n + 1)) (* leave space for FFI array *) [~env_rel:] (cnenv_rel cnenv cenv.c ∧ @@ -598,17 +600,24 @@ Inductive cont_rel: ((Chandle [(Pvar $ var_prefix x, ce)], cenv) :: ck)) End +Definition store_rel_def: + store_rel cnenv (Array svs) (Varray cvs) = LIST_REL (v_rel cnenv) svs cvs ∧ + store_rel cnenv (ThunkMem Evaluated sv) (Thunk F cv) = v_rel cnenv sv cv ∧ + store_rel cnenv (ThunkMem NotEvaluated sv) (Thunk T cv) = v_rel cnenv sv cv ∧ + store_rel cnenv _ _ = 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 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 cst' Proof rw[DefnBase.one_line_ify NONE state_rel_def] >> TOP_CASE_TAC >> simp[] >> TOP_CASE_TAC >> simp[] @@ -709,7 +718,7 @@ Definition get_ffi_ch_def[simp]: End Definition get_ffi_args_def[simp]: - get_ffi_args [Litv (StrLit conf); Loc lnum] = SOME (conf, lnum) ∧ + get_ffi_args [Litv (StrLit conf); Loc b lnum] = SOME (conf, lnum) ∧ get_ffi_args _ = NONE End @@ -740,7 +749,8 @@ Proof rw[application_thm] >> simp[] >> gvs[] >- gvs[AllCaseEqs()] >- rpt (TOP_CASE_TAC >> gvs[]) >> - Cases_on `op` >> gvs[] + Cases_on `op` >> gvs[] >> + TOP_CASE_TAC >> gvs [] QED val creturn_def = itree_semanticsTheory.return_def; @@ -784,7 +794,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 @@ -899,8 +909,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) (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] @@ -914,6 +923,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 T a) ⇒ + store_assign n (Thunk b y) st = + SOME $ LUPDATE (Thunk b 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 @@ -1813,40 +1830,68 @@ 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[] >> + >- ( (* ForceMutThunk *) + cheat + ) + >- ( (* UpdateMutThunk NotEvaluated *) + `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[] >> + simp [thunk_op_def] >> gvs[] >> + Cases_on `z` >> gvs[store_rel_def] >> + Cases_on `b` >> gvs[store_rel_def] >> + drule store_lookup_assign_Thunk >> rw[] >> 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 EVERY2_LUPDATE_same >> simp[store_rel_def] + ) + >- ( (* UpdateMutThunk Evaluated *) + `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[] >> + simp [thunk_op_def] >> gvs[] >> + Cases_on `z` >> gvs[store_rel_def] >> + Cases_on `b` >> gvs[store_rel_def] >> + drule store_lookup_assign_Thunk >> rw[] >> + 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] >> + irule EVERY2_LUPDATE_same >> simp[store_rel_def] + ) + >- ( (* AllocMutThunk NotEvaluated *) + cheat + ) + >- ( (* AllocMutThunk Evaluated *) + cheat + ) >- ( (* 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[]) + ntac 2 (irule EVERY2_LUPDATE_same >> simp[store_rel_def]) ) >- ( (* out of bounds *) qmatch_goalsub_abbrev_tac `cstep_n _ foo` >> @@ -1857,31 +1902,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] @@ -1897,18 +1930,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[] ) >> (* AtomOp *) gvs[application_def, sstep] >> @@ -2128,7 +2155,8 @@ 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[] >> + rpt $ goal_assum $ drule_at Any >> imp_res_tac LIST_REL_LENGTH >> + simp[store_rel_def] >> `ABS i = i` by ARITH_TAC >> simp[LIST_REL_REPLICATE_same] ) >- ( (* Concat *) @@ -2274,7 +2302,7 @@ Proof first_x_assum $ qspec_then `1` assume_tac >> gvs[sstep] >> TOP_CASE_TAC >> gvs[] >> ntac 3 (qrefine `SUC n` >> simp[cstep_n_def, cstep]) >> - `nsLookup cenv'.v (Short "ffi_array") = SOME (Loc 0)` by gvs[env_ok_def] >> + `nsLookup cenv'.v (Short "ffi_array") = SOME (Loc T 0)` by gvs[env_ok_def] >> simp[] >> ntac 3 (qrefine `SUC n` >> simp[cstep_n_def, cstep]) >> `∃ws. store_lookup 0 cst = SOME $ W8array ws ∧ @@ -2432,7 +2460,7 @@ Proof unabbrev_all_tac >> ntac 7 (qrefine `SUC m` >> simp[dstep, cstep]) >> simp[namespaceTheory.nsOptBind_def] >> - `nsLookup cenv.v (Short "ffi_array") = SOME (Loc 0)` by gvs[env_ok_def] >> + `nsLookup cenv.v (Short "ffi_array") = SOME (Loc T 0)` by gvs[env_ok_def] >> simp[] >> qrefine `SUC m` >> simp[dstep, cstep, do_app_def] >> Cases_on `dst.refs` >> gvs[store_lookup_def, LUPDATE_DEF] >> ntac 9 (qrefine `SUC m` >> simp[dstep, cstep, do_app_def]) >> @@ -2492,12 +2520,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 F) ∧ + csop_rel (AllocMutThunk NotEvaluated) (ThunkOp $ AllocThunk T) ∧ + csop_rel (UpdateMutThunk Evaluated) (ThunkOp $ UpdateThunk F) ∧ + csop_rel (UpdateMutThunk NotEvaluated) (ThunkOp $ UpdateThunk T) ∧ + csop_rel ForceMutThunk (ThunkOp ForceThunk) End Inductive cexp_compile_rel: @@ -2706,9 +2736,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: @@ -2791,6 +2824,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] @@ -2816,7 +2851,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] @@ -3238,15 +3277,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] @@ -3283,14 +3322,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 e0a3b154..e1dc12b4 100644 --- a/compiler/backend/passes/proofs/state_unthunkProofScript.sml +++ b/compiler/backend/passes/proofs/state_unthunkProofScript.sml @@ -24,23 +24,9 @@ Overload False_v = “stateLang$Constructor "False" []”; (****************************************) -(*Overload "box" = “λx. App Ref [True; x]”*) -Overload "box" = ``λx. App (AllocMutThunk Evaluated) [x]`` - -(*Overload "delay" = “λx. App Ref [False; Lam NONE x]”*) -Overload "delay" = ``λx. App (AllocMutThunk NotEvaluated) [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 "force" = ``λx. App ForceMutThunk [x]`` +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 ∧ @@ -75,31 +61,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: @@ -313,7 +294,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) @@ -321,7 +302,12 @@ 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: @@ -329,18 +315,29 @@ Definition rec_env_def: MAP (λ(fn,_). (fn,Recclosure f env fn)) f ++ env End +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 = + thunk_rel p (SOME (x,f)) v = case x of - | INL tv => (∃sv. v_rel p tv sv ∧ vs = [True_v; sv]) + | INL tv => (∃sv. v_rel p tv sv ∧ v = ThunkMem Evaluated 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]) ∨ + v = ThunkMem NotEvaluated (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) + v = ThunkMem Evaluated sv ∧ v_rel p tv sv) End Definition state_rel_def: @@ -348,7 +345,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: @@ -433,6 +431,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 ⇒ @@ -444,6 +452,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: @@ -466,7 +486,7 @@ Theorem state_rel_INR: 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)) + (SOME (SNOC (ThunkMem NotEvaluated (Closure NONE env2 se)) ss)) Proof fs [state_rel_def] \\ rw [] \\ gvs [] \\ gvs [thunk_rel_def] @@ -475,12 +495,13 @@ 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 ++ [SOME (INL v1,f)]) ts (SOME (SNOC (ThunkMem Evaluated v2) ss)) Proof fs [state_rel_def] \\ rw [] \\ gvs [] \\ gvs [thunk_rel_def] @@ -488,7 +509,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: @@ -497,7 +519,7 @@ 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’ @@ -508,18 +530,26 @@ 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] \\ 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: @@ -527,7 +557,7 @@ Theorem dest_anyThunk_INL: 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] + oEL loc ss = SOME (ThunkMem Evaluated y) Proof Cases_on ‘v1’ \\ fs [dest_anyThunk_def,dest_Thunk_def,AllCaseEqs()] \\ simp [Once v_rel_cases] @@ -605,9 +635,9 @@ Theorem dest_anyThunk_INR: v2 = Atom (Loc 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]) ∨ + oEL loc ss = SOME (ThunkMem NotEvaluated (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) + 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()]) @@ -641,7 +671,7 @@ QED Theorem dest_anyThunk_INR_abs: v_rel p v1 (Atom (Loc 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 [] @@ -698,7 +728,7 @@ Theorem state_rel_LUPDATE_anyThunk: v_rel p v1 (Atom (Loc 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)) + 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 @@ -707,7 +737,8 @@ Proof \\ 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] @@ -729,7 +760,7 @@ 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()] @@ -757,7 +788,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 @@ -786,31 +817,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] @@ -822,6 +924,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 @@ -871,16 +974,6 @@ Theorem application_thm: step_res_rel (p++q) t_0 s_0 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] @@ -891,7 +984,50 @@ Proof \\ simp [Once SNOC_APPEND] \\ irule_at Any state_rel_Ref \\ simp [] \\ fs [LIST_REL_REPLICATE_same]) + \\ 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 \\ simp [] + \\ gvs [state_rel_def] + \\ imp_res_tac LIST_REL_LENGTH + \\ gvs [GSYM ZIP_APPEND,FILTER_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])) \\ 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 ‘l’ \\ gvs [] + \\ Cases_on ‘ts’ \\ gvs [] + \\ qpat_x_assum ‘v_rel _ (Atom _) _’ 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] + >- + (gvs [push_def,step_res_rel_cases] + \\ simp [env_rel_def] + \\ simp [AppUnit_def] + \\ ntac 3 (simp [Once compile_rel_cases]) + \\ simp [Once cont_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 ‘l’ \\ gvs [] + \\ Cases_on ‘ts’ \\ gvs [] + \\ qpat_x_assum ‘v_rel _ (Atom _) _’ 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]) \\ 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 [] @@ -901,8 +1037,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 [] @@ -913,9 +1048,10 @@ 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])) @@ -952,23 +1088,24 @@ Definition make_let_env_def: make_let_env (x::xs) n env = make_let_env xs (n+1) ((FST x,Atom (Loc 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] @@ -1013,11 +1150,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: @@ -1029,9 +1166,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) = @@ -1040,15 +1178,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] @@ -1068,7 +1206,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] @@ -1087,13 +1225,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,Atom (Loc (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] @@ -1130,15 +1267,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] @@ -1146,7 +1284,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 @@ -1164,7 +1302,7 @@ Proof \\ 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 @@ -1181,13 +1319,12 @@ Proof \\ 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,Atom (Loc (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 @@ -1430,7 +1567,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: @@ -1626,13 +1763,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 [] @@ -1688,31 +1830,40 @@ Proof \\ 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 step_n_thunk: + step_n m (Exp senv se,SOME ss,ForceMutK loc::sk) = (sr1,SOME ss1',sk1) ∧ + n = m + 5 ⇒ + step_n n + (Exp [("f",Closure NONE senv se)] (app (Var "f") Unit), + SOME ss, ForceMutK loc::sk) = (sr1,SOME ss1',sk1) +Proof + rw [] + \\ ntac 5 (irule_at Any step_n_unwind \\ fs [step_n_add,step]) +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) ∧ @@ -1757,11 +1908,10 @@ Proof \\ Cases_on ‘dest_anyThunk v1’ \\ gvs [] \\ 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]) \\ last_x_assum $ drule_at $ Pos $ el 2 \\ fs [] \\ simp [Once step_res_rel_cases,PULL_EXISTS] \\ disch_then drule_all \\ strip_tac \\ gvs [] @@ -1769,8 +1919,7 @@ Proof \\ 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 [GSYM rec_env_def] \\ drule step_n_set_cont \\ strip_tac \\ pop_assum (qspec_then ‘ForceK2 ts::tk’ assume_tac) \\ drule_all step_n_fast_forward @@ -1793,29 +1942,28 @@ 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 [] \\ drule step_n_set_cont \\ strip_tac \\ pop_assum (qspec_then ‘kk3’ assume_tac) \\ 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 [] - \\ Q.REFINE_EXISTS_TAC ‘ck+1+n5’ + step_n m' + (Exp [("f",Closure NONE senv se)] + (AppUnit (Var "f")),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 [] + \\ rw [AppUnit_def] + \\ Q.REFINE_EXISTS_TAC ‘ck+n5+5’ \\ 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]) \\ qmatch_goalsub_abbrev_tac ‘SOME ss3’ \\ gvs [LUPDATE_DEF,LUPDATE_DEF,LUPDATE_LUPDATE] \\ drule_at (Pos $ el 4) state_rel_LUPDATE_anyThunk @@ -1832,10 +1980,13 @@ 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 + \\ drule step_n_thunk \\ rw [step_n_add] + \\ qexists ‘m' + 1’ + \\ rw [step_n_add,step]) >~ [‘BoxK’] >- (Cases_on ‘n’ \\ fs [ADD1,step_n_add,step] - \\ ntac 3 (irule_at Any step_n_unwind \\ fs [step_n_add,step]) + \\ irule_at Any step_n_unwind \\ fs [step_n_add,step] \\ first_x_assum $ drule_at $ Pos $ el 2 \\ fs [] \\ drule_all state_rel_INL \\ disch_then $ qspec_then ‘[]’ assume_tac @@ -1893,6 +2044,17 @@ Proof \\ 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] + \\ Cases_on ‘ts’ \\ gvs [] + \\ 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_at Any) \\ strip_tac + \\ drule_all state_rel_thunk_v_rel \\ strip_tac + \\ res_tac + \\ first_x_assum $ qspec_then ‘zs’ assume_tac + \\ metis_tac []) \\ rename [‘AppK tenv op tvs tes’] \\ Cases_on ‘n’ \\ fs [ADD1,step_n_add,step] \\ irule_at Any step_n_unwind \\ fs [step_n_add,step] @@ -1989,14 +2151,15 @@ Proof >~ [‘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 + (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] @@ -2135,17 +2298,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 [] @@ -2154,10 +2308,7 @@ 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,GSYM rec_env_def] \\ 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)’ @@ -2169,9 +2320,11 @@ Proof \\ pop_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 [] + \\ simp [AppUnit_def] + \\ ntac 5 (rename [‘step_n n’] \\ Cases_on ‘n’ \\ fs [] >- (rw [] \\ fs [is_halt_def]) - \\ rewrite_tac [step_n_add,ADD1] \\ simp [step,get_atoms_def]) + \\ rewrite_tac [step_n_add,ADD1] \\ simp + [step,get_atoms_def]) \\ gvs [ADD1] \\ strip_tac \\ drule_all step_n_cut_cont @@ -2207,9 +2360,10 @@ 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 [ADD1,SOME_THE_pick_opt] @@ -2218,13 +2372,7 @@ Proof \\ 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 @@ -2239,7 +2387,7 @@ Proof (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 @@ -2298,6 +2446,17 @@ 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,ADD1] + \\ Cases_on ‘ts’ \\ gvs [] + >- (qexists ‘0’ \\ fs [is_halt_def]) + \\ gvs [step_n_add,ADD1,step] + \\ last_x_assum irule + \\ gvs [step_res_rel_cases,PULL_EXISTS] + \\ rpt (first_assum $ irule_at Any \\ gvs []) + \\ 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] @@ -2384,27 +2543,13 @@ 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 [] @@ -2448,7 +2593,7 @@ Proof \\ 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 + \\ drule_all step_n_Lets_some_alloc_thunk \\ strip_tac \\ pop_assum mp_tac \\ Cases_on ‘m’ >- (gvs [] \\ rw [] \\ gvs [is_halt_def]) diff --git a/compiler/backend/passes/state_to_cakeScript.sml b/compiler/backend/passes/state_to_cakeScript.sml index 0eb66d33..66b2ed49 100644 --- a/compiler/backend/passes/state_to_cakeScript.sml +++ b/compiler/backend/passes/state_to_cakeScript.sml @@ -268,16 +268,18 @@ 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 F ∧ + compile_op (AllocMutThunk NotEvaluated) = CakeOp $ ThunkOp $ AllocThunk T ∧ + compile_op (UpdateMutThunk Evaluated) = CakeOp $ ThunkOp $ UpdateThunk F ∧ + compile_op (UpdateMutThunk NotEvaluated) = CakeOp $ ThunkOp $ UpdateThunk T ∧ + compile_op ForceMutThunk = CakeOp $ ThunkOp ForceThunk ∧ + compile_op _ = Other End Definition compile_def: From 506feb147598b5ee6dce60e268e0c15e1d77f655 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Mon, 30 Dec 2024 14:20:53 +0200 Subject: [PATCH 06/42] Update `binary/pure_backendProgScript` --- compiler/binary/pure_backendProgScript.sml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/compiler/binary/pure_backendProgScript.sml b/compiler/binary/pure_backendProgScript.sml index 094100ea..54ac4d52 100644 --- a/compiler/binary/pure_backendProgScript.sml +++ b/compiler/binary/pure_backendProgScript.sml @@ -110,9 +110,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; From 109ed6ab3688c0b9f639c1010226d4835312fe38 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Tue, 7 Jan 2025 15:54:52 +0200 Subject: [PATCH 07/42] Fix force semantics and env to ns mapping --- .../languages/semantics/stateLangScript.sml | 14 ++- .../proofs/state_app_unit_1ProofScript.sml | 12 +- .../proofs/state_app_unit_2ProofScript.sml | 18 ++- .../passes/proofs/state_caseProofScript.sml | 12 +- .../proofs/state_names_1ProofScript.sml | 11 +- .../proofs/state_to_cakeProofScript.sml | 111 ++++++++++++------ .../proofs/state_unthunkProofScript.sml | 49 +++++++- 7 files changed, 169 insertions(+), 58 deletions(-) diff --git a/compiler/backend/languages/semantics/stateLangScript.sml b/compiler/backend/languages/semantics/stateLangScript.sml index ecbc19ae..a49f8055 100644 --- a/compiler/backend/languages/semantics/stateLangScript.sml +++ b/compiler/backend/languages/semantics/stateLangScript.sml @@ -85,6 +85,14 @@ Datatype: | 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: @@ -379,7 +387,11 @@ Definition return_def: return v st (ForceMutK n :: k) = (case st of SOME stores => - value v (SOME (LUPDATE (ThunkMem Evaluated v) n stores)) k + 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 | NONE => error st k) End diff --git a/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml b/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml index 2bd38362..06266d6b 100644 --- a/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml +++ b/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml @@ -700,11 +700,15 @@ Proof \\ irule env_rel_cons \\ simp []) >~ [‘ForceMutK’] >- (gvs [step] - \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] + \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [step_res_rel_cases,state_rel_def,LIST_REL_EL_EQN] - \\ simp [Once v_rel_cases,state_rel_def,LIST_REL_EL_EQN] \\ strip_tac - \\ gvs [EL_LUPDATE] - \\ IF_CASES_TAC \\ rw [store_rel_def]) + \\ reverse $ Cases_on ‘n < LENGTH x'’ \\ gvs [] + >- gvs [state_rel_def,LIST_REL_EL_EQN] + \\ IF_CASES_TAC \\ gvs [] + \\ first_assum $ qspec_then ‘n’ assume_tac + \\ Cases_on ‘EL n x’ \\ Cases_on ‘EL n x'’ + \\ gvs [store_rel_def,store_same_type_def,state_rel_def,LIST_REL_EL_EQN] + \\ rw [store_rel_def, EL_LUPDATE]) \\ rename [‘AppK’] \\ reverse (Cases_on ‘tes’) \\ gvs [] \\ gvs [step] >- diff --git a/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml b/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml index 4c941839..e6a7606f 100644 --- a/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml +++ b/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml @@ -929,14 +929,22 @@ Proof \\ simp [Once step_res_rel_cases]) >~ [‘ForceMutK’] >- (Q.REFINE_EXISTS_TAC ‘SUC ck’ \\ fs [ADD_CLAUSES,step_n_SUC,step] - \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] - \\ gvs [is_halt_step] + \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [is_halt_step] >- (qexists_tac ‘n’ \\ fs [step_res_rel_cases]) + \\ gvs [state_rel_def,LIST_REL_EL_EQN] + \\ reverse $ Cases_on ‘n' < LENGTH x'’ \\ gvs [] + >- (first_assum $ irule_at Any \\ fs [] + \\ first_x_assum $ irule_at $ Pos hd \\ fs [] + \\ rw [state_rel_def,LIST_REL_EL_EQN,Once step_res_rel_cases]) + \\ IF_CASES_TAC \\ gvs [] + \\ qpat_assum ‘∀n. n < LENGTH x' => _’ assume_tac + \\ first_x_assum $ qspec_then ‘n'’ assume_tac + \\ Cases_on ‘EL n' x’ \\ Cases_on ‘EL n' x'’ + \\ gvs [store_rel_def,store_same_type_def,state_rel_def,LIST_REL_EL_EQN] \\ first_assum $ irule_at Any \\ fs [] \\ first_x_assum $ irule_at $ Pos hd \\ fs [] - \\ simp [Once step_res_rel_cases] - \\ gvs [state_rel_def,LIST_REL_EL_EQN,EL_LUPDATE] - \\ strip_tac \\ IF_CASES_TAC \\ gvs [store_rel_def]) + \\ simp [state_rel_def,LIST_REL_EL_EQN,Once step_res_rel_cases] + \\ rw [store_rel_def, EL_LUPDATE]) \\ rename [‘AppK’] \\ Q.REFINE_EXISTS_TAC ‘SUC ck’ \\ fs [ADD_CLAUSES,step_n_SUC,step] \\ reverse (Cases_on ‘tes’) \\ gvs [] \\ gvs [step] diff --git a/compiler/backend/passes/proofs/state_caseProofScript.sml b/compiler/backend/passes/proofs/state_caseProofScript.sml index 6dd2ed82..318432eb 100644 --- a/compiler/backend/passes/proofs/state_caseProofScript.sml +++ b/compiler/backend/passes/proofs/state_caseProofScript.sml @@ -701,11 +701,15 @@ Proof \\ first_assum $ irule_at Any \\ fs []) >~ [‘ForceMutK’] >- (gvs [step] - \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] + \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [step_res_rel_cases,state_rel_def,LIST_REL_EL_EQN] - \\ simp [Once v_rel_cases,state_rel_def,LIST_REL_EL_EQN] \\ strip_tac - \\ gvs [EL_LUPDATE] - \\ IF_CASES_TAC \\ rw [store_rel_def]) + \\ reverse $ Cases_on ‘n < LENGTH x'’ \\ gvs [] + >- gvs [state_rel_def,LIST_REL_EL_EQN] + \\ IF_CASES_TAC \\ gvs [] + \\ last_assum $ qspec_then ‘n’ assume_tac + \\ Cases_on ‘EL n x’ \\ Cases_on ‘EL n x'’ + \\ gvs [store_rel_def,store_same_type_def,state_rel_def,LIST_REL_EL_EQN] + \\ rw [store_rel_def, EL_LUPDATE]) \\ rename [‘AppK’] \\ reverse (Cases_on ‘tes’) \\ gvs [] \\ gvs [step] >- (simp [Once cont_rel_cases, step_res_rel_cases] \\ rw []) diff --git a/compiler/backend/passes/proofs/state_names_1ProofScript.sml b/compiler/backend/passes/proofs/state_names_1ProofScript.sml index 574c4363..2b7b762e 100644 --- a/compiler/backend/passes/proofs/state_names_1ProofScript.sml +++ b/compiler/backend/passes/proofs/state_names_1ProofScript.sml @@ -692,11 +692,14 @@ Proof \\ first_assum $ irule_at Any \\ fs []) >~ [‘ForceMutK’] >- (gvs [step] - \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [] + \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [step_res_rel_cases,state_rel_def,LIST_REL_EL_EQN] - \\ simp [Once v_rel_cases,state_rel_def,LIST_REL_EL_EQN] \\ strip_tac - \\ gvs [EL_LUPDATE] - \\ IF_CASES_TAC \\ rw [store_rel_def]) + \\ Cases_on ‘n < LENGTH x'’ \\ gvs [] + \\ IF_CASES_TAC \\ gvs [] + \\ last_assum $ qspec_then ‘n’ assume_tac + \\ Cases_on ‘EL n x’ \\ Cases_on ‘EL n x'’ + \\ gvs [store_rel_def,store_same_type_def,state_rel_def,LIST_REL_EL_EQN] + \\ rw [store_rel_def,EL_LUPDATE]) \\ rename [‘AppK’] \\ reverse (Cases_on ‘tes’) \\ gvs [] \\ gvs [step] >- diff --git a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml index 420a3d58..1192e70f 100644 --- a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml +++ b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml @@ -437,7 +437,7 @@ Inductive v_rel: v_rel cnenv (Atom $ Str s) (Litv $ StrLit s) [~Loc:] - v_rel cnenv (Atom $ Loc n) (Loc T (n + 1)) (* leave space for FFI array *) + v_rel cnenv (Atom $ Loc n) (Loc b (n + 1)) (* leave space for FFI array *) [~env_rel:] (cnenv_rel cnenv cenv.c ∧ @@ -598,6 +598,10 @@ Inductive cont_rel: 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)) + +[~ForceMutK:] + (cont_rel cnenv sk ck + ⇒ cont_rel cnenv (ForceMutK n :: sk) ((Cforce (n + 1), cenv) :: ck)) End Definition store_rel_def: @@ -730,6 +734,18 @@ Theorem capplication_thm: case do_opapp vs of | NONE => Etype_error (fix_fp_state c fp) | SOME (env,e) => Estep (env,s,fp,Exp e,c) + else if op = ThunkOp ForceThunk then + (case vs of + [Loc _ n] => ( + case store_lookup n s of + SOME (Thunk F v) => + return env s fp v c + | SOME (Thunk T f) => + push (env with v := nsBind (var_prefix "f") f env.v) s fp + (AppUnit (var (var_prefix "f"))) (Cforce n) c + | _ => + Etype_error (fix_fp_state c fp)) + | _ => Etype_error (fix_fp_state c fp)) else case get_ffi_ch op of | SOME n => ( case get_ffi_args vs of @@ -746,7 +762,9 @@ Theorem capplication_thm: | SOME (v1,Rval v') => return env v1 fp v' c | SOME (v1,Rraise v) => Estep (env,v1,fp,Exn v,c)) Proof - rw[application_thm] >> simp[] >> gvs[] + rw[application_thm,itree_semanticsTheory.AppUnit_def, + evaluateTheory.AppUnit_def] >> + simp[var_prefix_def] >> gvs[] >- gvs[AllCaseEqs()] >- rpt (TOP_CASE_TAC >> gvs[]) >> Cases_on `op` >> gvs[] >> @@ -1660,16 +1678,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 >> @@ -1748,6 +1759,27 @@ 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] >> + Cases_on `n < LENGTH sst` >> gvs[] >> + Cases_on `store_same_type (EL n sst) (ThunkMem Evaluated sv)` >> 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] + ) + >- ( + first_assum $ irule_at Any >> + gvs[state_rel, LUPDATE_DEF, PRE_SUB1] >> + irule EVERY2_LUPDATE_same >> + gvs[store_rel_def] + ) + ) >- (qexists0 >> simp[step_rel_cases, SF SFY_ss]) (* HandleK *) >- (qexists0 >> simp[step_rel_cases, SF SFY_ss]) (* RaiseK *) >- ( (* IfK *) @@ -1830,17 +1862,22 @@ 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] - >- ( (* ForceMutThunk *) - cheat - ) - >- ( (* UpdateMutThunk NotEvaluated *) + >>~- ([`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] >> + imp_res_tac LIST_REL_LENGTH >> rw[store_rel_def]) + >>~- ([`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[] >> simp [thunk_op_def] >> gvs[] >> Cases_on `z` >> gvs[store_rel_def] >> Cases_on `b` >> gvs[store_rel_def] >> @@ -1848,30 +1885,26 @@ Proof 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] >> - irule EVERY2_LUPDATE_same >> simp[store_rel_def] - ) - >- ( (* UpdateMutThunk Evaluated *) - `LENGTH l0 = 1` by gvs [] >> gvs[LENGTH_EQ_NUM_compute] >> + irule EVERY2_LUPDATE_same >> simp[store_rel_def]) + >~ [`ForceMutThunk`] + >- ( 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[] >> - simp [thunk_op_def] >> gvs[] >> - Cases_on `z` >> gvs[store_rel_def] >> + ntac 4 (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 `b` >> gvs[store_rel_def] >> - drule store_lookup_assign_Thunk >> rw[] >> - 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] >> - irule EVERY2_LUPDATE_same >> simp[store_rel_def] - ) - >- ( (* AllocMutThunk NotEvaluated *) - cheat - ) - >- ( (* AllocMutThunk Evaluated *) - cheat + rw[EL_CONS, PRE_SUB1] >> + qexists0 >> reverse $ rw[step_rel_cases, store_lookup_def] + >- (goal_assum drule >> gvs[state_rel, LIST_REL_EL_EQN]) + >- ( + rw[AppUnit_def, application_thm,itree_semanticsTheory.AppUnit_def] >> + qexists `cnenv` >> rw[] + >- (ntac 2 (rw[Once compile_rel_cases, Once op_rel_cases])) + >- rw[Once cont_rel_cases] + >- gvs[env_rel_def] + >- rw[state_rel_def, LIST_REL_EL_EQN] + ) ) >- ( (* Update *) `LENGTH l0 = 2` by gvs[] >> gvs[LENGTH_EQ_NUM_compute] >> diff --git a/compiler/backend/passes/proofs/state_unthunkProofScript.sml b/compiler/backend/passes/proofs/state_unthunkProofScript.sml index e1dc12b4..87748070 100644 --- a/compiler/backend/passes/proofs/state_unthunkProofScript.sml +++ b/compiler/backend/passes/proofs/state_unthunkProofScript.sml @@ -1864,6 +1864,32 @@ Proof \\ ntac 5 (irule_at Any step_n_unwind \\ fs [step_n_add,step]) 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 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) ∧ @@ -1983,7 +2009,8 @@ Proof \\ rpt $ first_assum $ irule_at Any \\ drule step_n_thunk \\ rw [step_n_add] \\ qexists ‘m' + 1’ - \\ rw [step_n_add,step]) + \\ rw [step_n_add,step] + \\ cheat) >~ [‘BoxK’] >- (Cases_on ‘n’ \\ fs [ADD1,step_n_add,step] \\ irule_at Any step_n_unwind \\ fs [step_n_add,step] @@ -2048,9 +2075,18 @@ Proof (Cases_on ‘n’ \\ fs [ADD1,step_n_add,step] \\ Cases_on ‘ts’ \\ gvs [] \\ irule_at Any step_n_unwind \\ fs [step_n_add,step] + \\ imp_res_tac state_rel_def \\ gvs [LIST_REL_EL_EQN] + \\ imp_res_tac find_loc_length_thm + \\ Cases_on ‘n1 < LENGTH t1’ \\ gvs [] + \\ IF_CASES_TAC \\ gvs [] + \\ imp_res_tac find_loc_el_thm \\ gvs[] + \\ first_assum $ qspec_then ‘n1’ assume_tac + \\ Cases_on ‘EL n1 t1’ \\ Cases_on ‘EL n2 s1’ + \\ gvs [store_rel_def,store_same_type_def] \\ 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 + \\ qpat_x_assum ‘v_rel p v v'’ kall_tac \\ drule_all state_rel_thunk_v_rel \\ strip_tac \\ res_tac \\ first_x_assum $ qspec_then ‘zs’ assume_tac @@ -2375,6 +2411,8 @@ Proof \\ fs [oEL_THM,EL_LUPDATE] \\ qmatch_goalsub_abbrev_tac ‘SOME ss3’ \\ rename [‘step_n nn’] \\ gvs [ADD1] + \\ reverse IF_CASES_TAC \\ gvs [] + >- cheat \\ strip_tac \\ rpt (disch_then kall_tac) \\ last_x_assum irule @@ -2453,9 +2491,18 @@ Proof \\ 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’ From 399be8e037befdf66625435b03d1d3389e0932ae Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Fri, 10 Jan 2025 04:51:12 +0200 Subject: [PATCH 08/42] Changed force semantics to apply function directly instead of going through singleton env --- .../languages/semantics/stateLangScript.sml | 8 +- .../proofs/state_app_unit_1ProofScript.sml | 38 +- .../proofs/state_app_unit_2ProofScript.sml | 38 +- .../passes/proofs/state_caseProofScript.sml | 38 +- .../proofs/state_names_1ProofScript.sml | 38 +- .../proofs/state_to_cakeProofScript.sml | 72 +++- .../proofs/state_unthunkProofScript.sml | 325 +++++++++--------- 7 files changed, 319 insertions(+), 238 deletions(-) diff --git a/compiler/backend/languages/semantics/stateLangScript.sml b/compiler/backend/languages/semantics/stateLangScript.sml index a49f8055..33d24eae 100644 --- a/compiler/backend/languages/semantics/stateLangScript.sml +++ b/compiler/backend/languages/semantics/stateLangScript.sml @@ -247,10 +247,6 @@ Definition dest_anyThunk_def: | _ => NONE End -Definition AppUnit_def: - AppUnit e = App AppOp [e; Unit] -End - (******************** Semantics functions ********************) (* Carry out an application - assumes: @@ -350,13 +346,15 @@ Definition application_def: case oEL n stores of SOME (ThunkMem Evaluated v) => value v st k | SOME (ThunkMem NotEvaluated f) => - push [("f",f)] (AppUnit (Var "f")) st (ForceMutK n) k + application AppOp [f; Constructor "" []] st (ForceMutK n :: k) | _ => error st k) | _ => error st k) ∧ application (FFI channel) vs st k = ( case HD vs, st of (Atom $ Str content, SOME _) => (Action channel content, st, k) | _ => error st k) +Termination + WF_REL_TAC ‘measure (λ(x,_). if x = ForceMutThunk then 1 else 0)’ >> rw[] End (* Return a value and handle a continuation *) diff --git a/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml b/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml index 06266d6b..a8dadcd4 100644 --- a/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml +++ b/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml @@ -252,16 +252,18 @@ Proof QED Theorem application_thm: - 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 + ∀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] + measureInduct_on ‘(λop. if op = ForceMutThunk then 1 else 0) op’ \\ rw [] + \\ Cases_on ‘op’ \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] \\ rw [] \\ gvs [] >~ [‘Cons’] >- (gvs [application_def,step,step_res_rel_cases] @@ -416,19 +418,23 @@ Proof \\ gvs [EL_LUPDATE] \\ IF_CASES_TAC \\ rw [store_rel_def]) >~ [‘ForceMutThunk’] >- - (gvs [application_def,step,step_res_rel_cases] + (once_rewrite_tac [application_def] + \\ gvs [Once application_def] \\ qpat_x_assum ‘v_rel x h’ mp_tac - \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] + \\ simp [Once v_rel_cases] \\ strip_tac + \\ gvs [error_def,step_res_rel_cases] \\ Cases_on ‘a’ \\ gvs [] \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ 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 [AppUnit_def] - \\ ntac 3 $ simp [Once compile_rel_cases] - \\ rw [env_rel_def] - \\ simp [Once cont_rel_cases,state_rel_def,LIST_REL_EL_EQN] - \\ metis_tac []) + \\ gvs [value_def,state_rel_def,LIST_REL_EL_EQN] + \\ first_x_assum $ qspec_then ‘AppOp’ assume_tac \\ gvs [] + \\ pop_assum $ irule_at Any \\ rw [] + \\ qexistsl [‘ForceMutK n::tk’,‘SOME x’,‘[v; Constructor "" []]’] \\ rw [] + >- (‘n' = 0 ∨ n' = 1’ by gvs [] \\ rw [] \\ simp [Once v_rel_cases]) + >- (rw [Once cont_rel_cases,state_rel_def,LIST_REL_EL_EQN] \\ metis_tac []) + >- rw [state_rel_def,LIST_REL_EL_EQN]) >~ [‘FFI’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac diff --git a/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml b/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml index e6a7606f..2e39263b 100644 --- a/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml +++ b/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml @@ -271,16 +271,18 @@ Proof QED Theorem application_thm: - 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 + ∀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] + measureInduct_on ‘(λop. if op = ForceMutThunk then 1 else 0) op’ \\ rw [] + \\ Cases_on ‘op’ \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] \\ rw [] \\ gvs [] >~ [‘Cons’] >- (gvs [application_def,step,step_res_rel_cases] @@ -433,19 +435,23 @@ Proof \\ gvs [EL_LUPDATE] \\ IF_CASES_TAC \\ rw [store_rel_def]) >~ [‘ForceMutThunk’] >- - (gvs [application_def,step,step_res_rel_cases] + (once_rewrite_tac [application_def] + \\ gvs [Once application_def] \\ qpat_x_assum ‘v_rel x h’ mp_tac - \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] + \\ simp [Once v_rel_cases] \\ strip_tac + \\ gvs [error_def,step_res_rel_cases] \\ Cases_on ‘a’ \\ gvs [] \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ 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 [AppUnit_def] - \\ ntac 3 $ simp [Once compile_rel_cases] - \\ rw [env_rel_def] - \\ simp [Once cont_rel_cases,state_rel_def,LIST_REL_EL_EQN] - \\ metis_tac []) + \\ gvs [value_def,state_rel_def,LIST_REL_EL_EQN] + \\ first_x_assum $ qspec_then ‘AppOp’ assume_tac \\ gvs [] + \\ pop_assum $ irule_at Any \\ rw [] + \\ qexistsl [‘ForceMutK n::tk’,‘SOME x’,‘[v; Constructor "" []]’] \\ rw [] + >- (‘n' = 0 ∨ n' = 1’ by gvs [] \\ rw [] \\ simp [Once v_rel_cases]) + >- (rw [Once cont_rel_cases,state_rel_def,LIST_REL_EL_EQN] \\ metis_tac []) + >- rw [state_rel_def,LIST_REL_EL_EQN]) >~ [‘FFI’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac diff --git a/compiler/backend/passes/proofs/state_caseProofScript.sml b/compiler/backend/passes/proofs/state_caseProofScript.sml index 318432eb..bcae85d6 100644 --- a/compiler/backend/passes/proofs/state_caseProofScript.sml +++ b/compiler/backend/passes/proofs/state_caseProofScript.sml @@ -266,16 +266,18 @@ Proof QED Theorem application_thm: - 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 + ∀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] + measureInduct_on ‘(λop. if op = ForceMutThunk then 1 else 0) op’ \\ rw [] + \\ Cases_on ‘op’ \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] \\ rw [] \\ gvs [] >~ [‘Cons’] >- (gvs [application_def,step,step_res_rel_cases] @@ -432,19 +434,23 @@ Proof \\ gvs [EL_LUPDATE] \\ IF_CASES_TAC \\ rw [store_rel_def]) >~ [‘ForceMutThunk’] >- - (gvs [application_def,step,step_res_rel_cases] + (once_rewrite_tac [application_def] + \\ gvs [Once application_def] \\ qpat_x_assum ‘v_rel x h’ mp_tac - \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] + \\ simp [Once v_rel_cases] \\ strip_tac + \\ gvs [error_def,step_res_rel_cases] \\ Cases_on ‘a’ \\ gvs [] \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ 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 [AppUnit_def] - \\ ntac 3 $ simp [Once compile_rel_cases] - \\ rw [env_rel_def] - \\ simp [Once cont_rel_cases,state_rel_def,LIST_REL_EL_EQN] - \\ metis_tac []) + \\ gvs [value_def,state_rel_def,LIST_REL_EL_EQN] + \\ first_x_assum $ qspec_then ‘AppOp’ assume_tac \\ gvs [] + \\ pop_assum $ irule_at Any \\ rw [] + \\ qexistsl [‘ForceMutK n::tk’,‘SOME x’,‘[v; Constructor "" []]’] \\ rw [] + >- (‘n' = 0 ∨ n' = 1’ by gvs [] \\ rw [] \\ simp [Once v_rel_cases]) + >- (rw [Once cont_rel_cases,state_rel_def,LIST_REL_EL_EQN] \\ metis_tac []) + >- rw [state_rel_def,LIST_REL_EL_EQN]) >~ [‘FFI’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac diff --git a/compiler/backend/passes/proofs/state_names_1ProofScript.sml b/compiler/backend/passes/proofs/state_names_1ProofScript.sml index 2b7b762e..d9ad8b04 100644 --- a/compiler/backend/passes/proofs/state_names_1ProofScript.sml +++ b/compiler/backend/passes/proofs/state_names_1ProofScript.sml @@ -280,16 +280,18 @@ Proof QED Theorem application_thm: - 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 + ∀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] + measureInduct_on ‘(λop. if op = ForceMutThunk then 1 else 0) op’ \\ rw [] + \\ Cases_on ‘op’ \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] \\ rw [] \\ gvs [] >~ [‘Cons’] >- (gvs [application_def,step,step_res_rel_cases] @@ -468,19 +470,23 @@ Proof \\ gvs [EL_LUPDATE] \\ IF_CASES_TAC \\ rw [store_rel_def]) >~ [‘ForceMutThunk’] >- - (gvs [application_def,step,step_res_rel_cases] + (once_rewrite_tac [application_def] + \\ gvs [Once application_def] \\ qpat_x_assum ‘v_rel x h’ mp_tac - \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [] + \\ simp [Once v_rel_cases] \\ strip_tac + \\ gvs [error_def,step_res_rel_cases] \\ Cases_on ‘a’ \\ gvs [] \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ 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 [AppUnit_def] - \\ ntac 3 $ simp [Once compile_rel_cases] - \\ rw [env_rel_def] - \\ simp [Once cont_rel_cases,state_rel_def,LIST_REL_EL_EQN] - \\ metis_tac []) + \\ gvs [value_def,state_rel_def,LIST_REL_EL_EQN] + \\ first_x_assum $ qspec_then ‘AppOp’ assume_tac \\ gvs [] + \\ pop_assum $ irule_at Any \\ rw [] + \\ qexistsl [‘ForceMutK n::tk’,‘SOME x’,‘[v; Constructor "" []]’] \\ rw [] + >- (‘n' = 0 ∨ n' = 1’ by gvs [] \\ rw [] \\ simp [Once v_rel_cases]) + >- (rw [Once cont_rel_cases,state_rel_def,LIST_REL_EL_EQN] \\ metis_tac []) + >- rw [state_rel_def,LIST_REL_EL_EQN]) >~ [‘FFI’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac diff --git a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml index 1192e70f..98d4bdd3 100644 --- a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml +++ b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml @@ -741,8 +741,7 @@ Theorem capplication_thm: SOME (Thunk F v) => return env s fp v c | SOME (Thunk T f) => - push (env with v := nsBind (var_prefix "f") f env.v) s fp - (AppUnit (var (var_prefix "f"))) (Cforce n) c + application Opapp env s fp [f; Conv NONE []] ((Cforce n,env)::c) | _ => Etype_error (fix_fp_state c fp)) | _ => Etype_error (fix_fp_state c fp)) @@ -762,9 +761,7 @@ Theorem capplication_thm: | SOME (v1,Rval v') => return env v1 fp v' c | SOME (v1,Rraise v) => Estep (env,v1,fp,Exn v,c)) Proof - rw[application_thm,itree_semanticsTheory.AppUnit_def, - evaluateTheory.AppUnit_def] >> - simp[var_prefix_def] >> gvs[] + rw[application_thm, evaluateTheory.AppUnit_def] >> gvs[] >- gvs[AllCaseEqs()] >- rpt (TOP_CASE_TAC >> gvs[]) >> Cases_on `op` >> gvs[] >> @@ -959,6 +956,13 @@ 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 (***** cnenv_rel / env_rel / env_ok *****) @@ -1898,13 +1902,59 @@ Proof qexists0 >> reverse $ rw[step_rel_cases, store_lookup_def] >- (goal_assum drule >> gvs[state_rel, LIST_REL_EL_EQN]) >- ( - rw[AppUnit_def, application_thm,itree_semanticsTheory.AppUnit_def] >> - qexists `cnenv` >> rw[] - >- (ntac 2 (rw[Once compile_rel_cases, Once op_rel_cases])) - >- rw[Once cont_rel_cases] - >- gvs[env_rel_def] - >- rw[state_rel_def, LIST_REL_EL_EQN] + gvs[do_opapp_def] >> + ntac 4 (FULL_CASE_TAC >> gvs[store_lookup_def]) + ) >> + Cases_on `dest_anyClosure v` >> gvs[] >> + Cases_on `x` >> gvs[] >> + Cases_on `r` >> gvs[] >> + rw [do_opapp_def] >> + Cases_on `a` >> rw[] >> + Cases_on `v` >> gvs[Once v_rel_cases,dest_anyClosure_def] + >- ( + goal_assum $ drule_at Any >> + simp[Once cont_rel_cases,state_rel_def,LIST_REL_EL_EQN,opt_bind_def] >> + gvs [env_rel_def] >> rw[] + ) + >- ( + Cases_on `ALOOKUP l0 s'` >> gvs[] >> + Cases_on `x` >> gvs[] >> + simp[semanticPrimitivesPropsTheory.find_recfun_ALOOKUP] >> + imp_res_tac ALOOKUP_SOME_EL >> + Cases_on `ALOOKUP l' (var_prefix s')` >> gvs[] + >- ( + gvs[LIST_REL_EL_EQN] >> + first_x_assum drule >> rw[] >> pairarg_tac >> gvs[] >> + drule_all ALOOKUP_ALL_DISTINCT_EL >> rpt strip_tac >> gvs[] + ) >> + Cases_on `x` >> gvs[] >> + qexists `cnenv` >> + rw[Once cont_rel_cases,state_rel_def,LIST_REL_EL_EQN] + >- ( + gvs[LIST_REL_EL_EQN] >> + first_x_assum drule >> rw[] >> pairarg_tac >> gvs[] >> + drule_all ALOOKUP_ALL_DISTINCT_EL >> rw[] + ) + >- ( + `v_rel cnenv (Constructor "" []) (Conv NONE [])` + by gvs[Once v_rel_cases] >> + drule_all env_rel_nsBind_Recclosure >> rw[] >> + gvs[LIST_REL_EL_EQN] >> + first_x_assum drule >> rw[] >> pairarg_tac >> gvs[opt_bind_def] >> + drule_all ALOOKUP_ALL_DISTINCT_EL >> rw[] + ) + >- ( + `EVERY (λ(cv,cx,ce). ∃sv. cv = var_prefix sv) l'` + by ( + rw[EVERY_EL] >> pairarg_tac >> gvs[LIST_REL_EL_EQN] >> + first_x_assum drule >> rw[] >> pairarg_tac >> gvs[] + ) >> + drule_all env_ok_nsBind_Recclosure >> rw[] >> gvs[LIST_REL_EL_EQN] >> + first_x_assum drule >> rw[] >> pairarg_tac >> gvs[opt_bind_def] >> + drule_all ALOOKUP_ALL_DISTINCT_EL >> rw[] + ) ) + >- gvs[ALL_DISTINCT_MAP_FSTs] ) >- ( (* Update *) `LENGTH l0 = 2` by gvs[] >> gvs[LENGTH_EQ_NUM_compute] >> diff --git a/compiler/backend/passes/proofs/state_unthunkProofScript.sml b/compiler/backend/passes/proofs/state_unthunkProofScript.sml index 87748070..85f8b72d 100644 --- a/compiler/backend/passes/proofs/state_unthunkProofScript.sml +++ b/compiler/backend/passes/proofs/state_unthunkProofScript.sml @@ -959,6 +959,158 @@ 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 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) ∧ @@ -1009,12 +1161,15 @@ Proof \\ drule_all state_rel_thunk \\ strip_tac \\ gvs [] \\ Cases_on ‘t’ \\ gvs [] >- simp [Once step_res_rel_cases] - >- - (gvs [push_def,step_res_rel_cases] - \\ simp [env_rel_def] - \\ simp [AppUnit_def] - \\ ntac 3 (simp [Once compile_rel_cases]) - \\ simp [Once cont_rel_cases])) + \\ Cases_on ‘dest_anyClosure v’ \\ gvs [] + \\ PairCases_on ‘x'’ + \\ ‘state_rel p (pick_opt x NONE) (SOME ss)’ by gvs [] + \\ drule_all dest_anyClosure_v_rel + \\ strip_tac \\ gvs [LENGTH_EQ_NUM_compute] + \\ simp [Once cont_rel_cases, Once step_res_rel_cases] + \\ ‘v_rel p (Constructor "" []) (Constructor "" [])’ + by simp [Once v_rel_cases] + \\ drule imp_env_rel_opt_bind \\ simp []) \\ Cases_on ‘∃t. op = UpdateMutThunk t’ \\ rw [] THEN1 (gvs [application_def,LENGTH_EQ_NUM_compute,error_def,value_def] \\ Cases_on ‘x’ \\ gvs [] @@ -1363,158 +1518,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 @@ -1929,6 +1932,8 @@ Proof \\ simp [Once cont_rel_cases] \\ strip_tac \\ gvs [] >~ [‘ForceK1’] >- + cheat + (* (Cases_on ‘n’ \\ fs [ADD1,step_n_add,step] \\ rename [‘v_rel p v1 v2’] \\ Cases_on ‘dest_anyThunk v1’ \\ gvs [] @@ -2011,6 +2016,7 @@ Proof \\ qexists ‘m' + 1’ \\ rw [step_n_add,step] \\ cheat) + *) >~ [‘BoxK’] >- (Cases_on ‘n’ \\ fs [ADD1,step_n_add,step] \\ irule_at Any step_n_unwind \\ fs [step_n_add,step] @@ -2323,6 +2329,8 @@ Proof \\ once_rewrite_tac [cont_rel_cases] \\ strip_tac \\ gvs [] >~ [‘ForceK1’] >- + cheat + (* (Q.REFINE_EXISTS_TAC ‘ck+1:num’ \\ qpat_x_assum ‘step_n m _ = _’ mp_tac \\ (Cases_on ‘m’ >- fs []) @@ -2421,6 +2429,7 @@ Proof \\ irule_at Any cont_rel_ext \\ fs [LUPDATE_DEF,LUPDATE_LUPDATE] \\ simp [Abbr‘ss3’] \\ drule_all state_rel_LUPDATE_anyThunk \\ fs []) + *) >~ [‘BoxK’] >- (Q.REFINE_EXISTS_TAC ‘ck1+1’ \\ rewrite_tac [step_n_add,ADD1] \\ simp [step] From 120625430be0877f628063633b4560070eafa272 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Sun, 12 Jan 2025 16:32:22 +0200 Subject: [PATCH 09/42] Changed `measureInduct`s to `application_ind`s --- .../proofs/state_app_unit_1ProofScript.sml | 15 ++++---- .../proofs/state_app_unit_2ProofScript.sml | 15 ++++---- .../passes/proofs/state_caseProofScript.sml | 15 ++++---- .../proofs/state_names_1ProofScript.sml | 15 ++++---- .../proofs/state_unthunkProofScript.sml | 34 +++---------------- 5 files changed, 29 insertions(+), 65 deletions(-) diff --git a/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml b/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml index a8dadcd4..1cf746e7 100644 --- a/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml +++ b/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml @@ -262,8 +262,8 @@ Theorem application_thm: OPTREL state_rel ts1 ss1 ∧ step_res_rel tr1 tk1 sr1 sk1 Proof - measureInduct_on ‘(λop. if op = ForceMutThunk then 1 else 0) op’ \\ rw [] - \\ Cases_on ‘op’ \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] + ho_match_mp_tac application_ind \\ rw [] + \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] \\ rw [] \\ gvs [] >~ [‘Cons’] >- (gvs [application_def,step,step_res_rel_cases] @@ -419,7 +419,7 @@ Proof \\ IF_CASES_TAC \\ rw [store_rel_def]) >~ [‘ForceMutThunk’] >- (once_rewrite_tac [application_def] - \\ gvs [Once 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] @@ -429,12 +429,9 @@ Proof \\ 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] \\ gvs [value_def,state_rel_def,LIST_REL_EL_EQN] - \\ first_x_assum $ qspec_then ‘AppOp’ assume_tac \\ gvs [] - \\ pop_assum $ irule_at Any \\ rw [] - \\ qexistsl [‘ForceMutK n::tk’,‘SOME x’,‘[v; Constructor "" []]’] \\ rw [] - >- (‘n' = 0 ∨ n' = 1’ by gvs [] \\ rw [] \\ simp [Once v_rel_cases]) - >- (rw [Once cont_rel_cases,state_rel_def,LIST_REL_EL_EQN] \\ metis_tac []) - >- rw [state_rel_def,LIST_REL_EL_EQN]) + \\ last_x_assum $ irule_at Any + \\ rw [Once v_rel_cases,Once cont_rel_cases] + \\ metis_tac [state_rel_def,LIST_REL_EL_EQN]) >~ [‘FFI’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac diff --git a/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml b/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml index 2e39263b..23bb6929 100644 --- a/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml +++ b/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml @@ -281,8 +281,8 @@ Theorem application_thm: OPTREL state_rel ts1 ss1 ∧ step_res_rel tr1 tk1 sr1 sk1 Proof - measureInduct_on ‘(λop. if op = ForceMutThunk then 1 else 0) op’ \\ rw [] - \\ Cases_on ‘op’ \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] + ho_match_mp_tac application_ind \\ rw [] + \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] \\ rw [] \\ gvs [] >~ [‘Cons’] >- (gvs [application_def,step,step_res_rel_cases] @@ -436,7 +436,7 @@ Proof \\ IF_CASES_TAC \\ rw [store_rel_def]) >~ [‘ForceMutThunk’] >- (once_rewrite_tac [application_def] - \\ gvs [Once 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] @@ -446,12 +446,9 @@ Proof \\ 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] \\ gvs [value_def,state_rel_def,LIST_REL_EL_EQN] - \\ first_x_assum $ qspec_then ‘AppOp’ assume_tac \\ gvs [] - \\ pop_assum $ irule_at Any \\ rw [] - \\ qexistsl [‘ForceMutK n::tk’,‘SOME x’,‘[v; Constructor "" []]’] \\ rw [] - >- (‘n' = 0 ∨ n' = 1’ by gvs [] \\ rw [] \\ simp [Once v_rel_cases]) - >- (rw [Once cont_rel_cases,state_rel_def,LIST_REL_EL_EQN] \\ metis_tac []) - >- rw [state_rel_def,LIST_REL_EL_EQN]) + \\ last_x_assum $ irule_at Any + \\ rw [Once v_rel_cases,Once cont_rel_cases] + \\ metis_tac [state_rel_def,LIST_REL_EL_EQN]) >~ [‘FFI’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac diff --git a/compiler/backend/passes/proofs/state_caseProofScript.sml b/compiler/backend/passes/proofs/state_caseProofScript.sml index bcae85d6..2b6880b1 100644 --- a/compiler/backend/passes/proofs/state_caseProofScript.sml +++ b/compiler/backend/passes/proofs/state_caseProofScript.sml @@ -276,8 +276,8 @@ Theorem application_thm: cont_rel tk1 sk1 ∧ OPTREL state_rel ts1 ss1 ∧ step_res_rel tr1 sr1 Proof - measureInduct_on ‘(λop. if op = ForceMutThunk then 1 else 0) op’ \\ rw [] - \\ Cases_on ‘op’ \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] + ho_match_mp_tac application_ind \\ rw [] + \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] \\ rw [] \\ gvs [] >~ [‘Cons’] >- (gvs [application_def,step,step_res_rel_cases] @@ -435,7 +435,7 @@ Proof \\ IF_CASES_TAC \\ rw [store_rel_def]) >~ [‘ForceMutThunk’] >- (once_rewrite_tac [application_def] - \\ gvs [Once 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] @@ -445,12 +445,9 @@ Proof \\ 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] \\ gvs [value_def,state_rel_def,LIST_REL_EL_EQN] - \\ first_x_assum $ qspec_then ‘AppOp’ assume_tac \\ gvs [] - \\ pop_assum $ irule_at Any \\ rw [] - \\ qexistsl [‘ForceMutK n::tk’,‘SOME x’,‘[v; Constructor "" []]’] \\ rw [] - >- (‘n' = 0 ∨ n' = 1’ by gvs [] \\ rw [] \\ simp [Once v_rel_cases]) - >- (rw [Once cont_rel_cases,state_rel_def,LIST_REL_EL_EQN] \\ metis_tac []) - >- rw [state_rel_def,LIST_REL_EL_EQN]) + \\ last_x_assum $ irule_at Any + \\ rw [Once v_rel_cases,Once cont_rel_cases] + \\ metis_tac [state_rel_def,LIST_REL_EL_EQN]) >~ [‘FFI’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac diff --git a/compiler/backend/passes/proofs/state_names_1ProofScript.sml b/compiler/backend/passes/proofs/state_names_1ProofScript.sml index d9ad8b04..9c5ea2f8 100644 --- a/compiler/backend/passes/proofs/state_names_1ProofScript.sml +++ b/compiler/backend/passes/proofs/state_names_1ProofScript.sml @@ -290,8 +290,8 @@ Theorem application_thm: cont_rel tk1 sk1 ∧ OPTREL state_rel ts1 ss1 ∧ step_res_rel tr1 sr1 Proof - measureInduct_on ‘(λop. if op = ForceMutThunk then 1 else 0) op’ \\ rw [] - \\ Cases_on ‘op’ \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] + ho_match_mp_tac application_ind \\ rw [] + \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] \\ rw [] \\ gvs [] >~ [‘Cons’] >- (gvs [application_def,step,step_res_rel_cases] @@ -471,7 +471,7 @@ Proof \\ IF_CASES_TAC \\ rw [store_rel_def]) >~ [‘ForceMutThunk’] >- (once_rewrite_tac [application_def] - \\ gvs [Once 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] @@ -481,12 +481,9 @@ Proof \\ 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] \\ gvs [value_def,state_rel_def,LIST_REL_EL_EQN] - \\ first_x_assum $ qspec_then ‘AppOp’ assume_tac \\ gvs [] - \\ pop_assum $ irule_at Any \\ rw [] - \\ qexistsl [‘ForceMutK n::tk’,‘SOME x’,‘[v; Constructor "" []]’] \\ rw [] - >- (‘n' = 0 ∨ n' = 1’ by gvs [] \\ rw [] \\ simp [Once v_rel_cases]) - >- (rw [Once cont_rel_cases,state_rel_def,LIST_REL_EL_EQN] \\ metis_tac []) - >- rw [state_rel_def,LIST_REL_EL_EQN]) + \\ last_x_assum $ irule_at Any + \\ rw [Once v_rel_cases,Once cont_rel_cases] + \\ metis_tac [state_rel_def,LIST_REL_EL_EQN]) >~ [‘FFI’] >- (gvs [application_def,step,step_res_rel_cases] \\ qpat_x_assum ‘v_rel x h’ mp_tac diff --git a/compiler/backend/passes/proofs/state_unthunkProofScript.sml b/compiler/backend/passes/proofs/state_unthunkProofScript.sml index 85f8b72d..3a5f2519 100644 --- a/compiler/backend/passes/proofs/state_unthunkProofScript.sml +++ b/compiler/backend/passes/proofs/state_unthunkProofScript.sml @@ -1856,17 +1856,6 @@ Proof \\ fs [] QED -Theorem step_n_thunk: - step_n m (Exp senv se,SOME ss,ForceMutK loc::sk) = (sr1,SOME ss1',sk1) ∧ - n = m + 5 ⇒ - step_n n - (Exp [("f",Closure NONE senv se)] (app (Var "f") Unit), - SOME ss, ForceMutK loc::sk) = (sr1,SOME ss1',sk1) -Proof - rw [] - \\ ntac 5 (irule_at Any step_n_unwind \\ fs [step_n_add,step]) -QED - Theorem find_loc_length_thm: ∀p n1 n2 (ss:state). find_loc n1 p = SOME n2 ∧ @@ -1932,8 +1921,6 @@ Proof \\ simp [Once cont_rel_cases] \\ strip_tac \\ gvs [] >~ [‘ForceK1’] >- - cheat - (* (Cases_on ‘n’ \\ fs [ADD1,step_n_add,step] \\ rename [‘v_rel p v1 v2’] \\ Cases_on ‘dest_anyThunk v1’ \\ gvs [] @@ -1978,15 +1965,13 @@ Proof \\ simp [Once step_res_rel_cases] \\ strip_tac \\ gvs [] \\ 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 [("f",Closure NONE senv se)] - (AppUnit (Var "f")),SOME ss,kk3) = (sr1',SOME ss1',sk1) ∧ + 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 [] - \\ rw [AppUnit_def] - \\ Q.REFINE_EXISTS_TAC ‘ck+n5+5’ + \\ Q.REFINE_EXISTS_TAC ‘ck+1+n5’ \\ rewrite_tac [step_n_add] \\ fs [] \\ fs [step,Abbr‘kk3’] \\ drule_at (Pos $ el 2) dest_anyThunk_INR_abs \\ fs [] @@ -2012,11 +1997,9 @@ Proof \\ strip_tac \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ rpt $ first_assum $ irule_at Any - \\ drule step_n_thunk \\ rw [step_n_add] - \\ qexists ‘m' + 1’ + \\ qexists ‘m'’ \\ rw [step_n_add,step] \\ cheat) - *) >~ [‘BoxK’] >- (Cases_on ‘n’ \\ fs [ADD1,step_n_add,step] \\ irule_at Any step_n_unwind \\ fs [step_n_add,step] @@ -2329,8 +2312,6 @@ Proof \\ once_rewrite_tac [cont_rel_cases] \\ strip_tac \\ gvs [] >~ [‘ForceK1’] >- - cheat - (* (Q.REFINE_EXISTS_TAC ‘ck+1:num’ \\ qpat_x_assum ‘step_n m _ = _’ mp_tac \\ (Cases_on ‘m’ >- fs []) @@ -2364,11 +2345,7 @@ Proof \\ pop_assum $ irule_at Any \\ fs [] \\ rpt (first_assum $ irule_at Any) \\ simp [step_res_rel_cases]) - \\ simp [AppUnit_def] - \\ ntac 5 (rename [‘step_n n’] \\ Cases_on ‘n’ \\ fs [] - >- (rw [] \\ fs [is_halt_def]) - \\ rewrite_tac [step_n_add,ADD1] \\ simp - [step,get_atoms_def]) + \\ simp [opt_bind_def] \\ gvs [ADD1] \\ strip_tac \\ drule_all step_n_cut_cont @@ -2429,7 +2406,6 @@ Proof \\ irule_at Any cont_rel_ext \\ fs [LUPDATE_DEF,LUPDATE_LUPDATE] \\ simp [Abbr‘ss3’] \\ drule_all state_rel_LUPDATE_anyThunk \\ fs []) - *) >~ [‘BoxK’] >- (Q.REFINE_EXISTS_TAC ‘ck1+1’ \\ rewrite_tac [step_n_add,ADD1] \\ simp [step] From 46c63f655d66d63bf7424b8b7ae0c15c162b29fa Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Wed, 15 Jan 2025 08:56:37 +0100 Subject: [PATCH 10/42] Remove two cheats, but add many more --- .../proofs/state_unthunkProofScript.sml | 223 +++++++++++++++--- 1 file changed, 194 insertions(+), 29 deletions(-) diff --git a/compiler/backend/passes/proofs/state_unthunkProofScript.sml b/compiler/backend/passes/proofs/state_unthunkProofScript.sml index 3a5f2519..bb709f71 100644 --- a/compiler/backend/passes/proofs/state_unthunkProofScript.sml +++ b/compiler/backend/passes/proofs/state_unthunkProofScript.sml @@ -538,7 +538,7 @@ Proof (gvs [LIST_REL_EL_EQN] \\ rw [] \\ irule_at Any thunk_rel_ext \\ fs []) \\ imp_res_tac LIST_REL_LENGTH - \\ ‘ZIP (p ++ [NONE],ss ++ [Array ys]) = + \\ ‘ZIP (p ++ [NONE],ss ++ [Array ys]) = ZIP (p,ss) ++ ZIP ([NONE],[Array ys])’ by (irule $ GSYM ZIP_APPEND \\ fs []) \\ fs [FILTER_APPEND] @@ -1882,9 +1882,144 @@ Proof \\ Cases_on ‘ss’ \\ gvs [ZIP_def,EL_CONS,PRE_SUB1] QED +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: + step_n' (m + n) avoid x = step_n' m avoid (step_n' n avoid x) +Proof + cheat +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_n'_same: + ∀n x. is_halt x ⇒ step_n' n avoid x = x +Proof + cheat (* + Induct \\ fs [FORALL_PROD,step_n'_SUC,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_n'_NONE_split: + 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 + cheat +QED + +Theorem state_rel_LUPDATE_anyThunk': + v_rel p res v2 ∧ state_rel p ts (SOME ss2) ∧ + v_rel p v1 (Atom (Loc loc)) ∧ + dest_anyThunk v1 = SOME (INR (tenv1,te),f) ∧ + step_n' n avoid (Exp (rec_env f tenv1) te,NONE,[]) = (Val res,NONE,[]) ⇒ + state_rel p ts (SOME (LUPDATE (ThunkMem Evaluated v2) loc ss2)) +Proof + cheat +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_lemma: + v_rel p v1 (Atom (Loc loc)) ∧ IS_SOME (dest_anyThunk v1) ∧ + v_rel p v2 (Atom (Loc loc)) ∧ IS_SOME (dest_anyThunk v2) ⇒ + v1 = v2 +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] + \\ TRY (Cases_on ‘tfns’ \\ gvs [] \\ NO_TAC) + \\ dxrule_all LIST_REL_lemma + \\ gvs [EXISTS_PROD,FORALL_PROD] + \\ gvs [loc_rel_def,dest_anyThunk_def] + \\ rpt strip_tac \\ gvs [] + \\ cheat +QED + +Theorem setp_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'_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 + cheat +QED + +Theorem step_n'_INSERT: + step_n' m avoid (Exp (rec_env x1 y0) y1,NONE,[]) = (Val v,NONE,[]) ∧ + dest_anyThunk v1 = SOME (INR (y0,y1),x1) ⇒ + step_n' m (v1 INSERT avoid) (Exp (rec_env x1 y0) y1,NONE,[]) = (Val v,NONE,[]) +Proof + cheat +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 + cheat +QED + +Theorem step_n_IMP_step_n': + step_n n x = y ⇒ step_n' n {} x = y +Proof + cheat +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 ⇒ @@ -1893,19 +2028,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 ∧ v_rel p thk (Atom (Loc loc)) ∧ IS_SOME (dest_anyThunk 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 [] @@ -1921,38 +2060,45 @@ 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 [] \\ irule_at Any step_n_unwind \\ fs [step_n_add,step] >- (drule_all dest_anyThunk_INL \\ strip_tac \\ gvs [] + \\ 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 [] >- (gvs [GSYM rec_env_def] + \\ 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 \\ 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] \\ 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]) + \\ Cases_on ‘v1 ∈ avoid’ \\ gvs [] \\ gvs [GSYM rec_env_def,get_atoms_def] - \\ drule_all step_n_NONE_split + \\ drule_all step_n'_NONE_split \\ strip_tac \\ ntac 2 $ pop_assum mp_tac + \\ simp [opt_bind_def] + \\ drule_all step_n'_INSERT \\ strip_tac \\ last_assum $ drule_at $ Pos $ el 2 \\ fs [cont_rel_nil] \\ simp [Once step_res_rel_cases,PULL_EXISTS] @@ -1963,6 +2109,9 @@ Proof \\ 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 >- gvs [] + \\ strip_tac \\ drule step_n_set_cont \\ strip_tac \\ pop_assum (qspec_then ‘kk3’ assume_tac) \\ simp [opt_bind_def] @@ -1970,7 +2119,11 @@ Proof 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_res_rel (p ++ q') tr1 sr1' ∧ + ∀thk loc. + thk ∈ avoid ∧ v_rel p thk (Atom (Loc loc)) ∧ + IS_SOME (dest_anyThunk 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’] @@ -1979,15 +2132,15 @@ Proof \\ disch_then $ qspec_then ‘loc’ mp_tac \\ impl_keep_tac >- (irule v_rel_ext \\ fs []) \\ strip_tac \\ fs [] - \\ fs [oEL_THM,EL_LUPDATE] + \\ 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 + \\ drule_at (Pos $ el 4) state_rel_LUPDATE_anyThunk' \\ disch_then $ drule_at (Pos $ el 3) \\ 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] + \\ 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 @@ -1997,11 +2150,18 @@ Proof \\ strip_tac \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ rpt $ first_assum $ irule_at Any - \\ qexists ‘m'’ - \\ rw [step_n_add,step] - \\ cheat) + \\ rpt gen_tac \\ disch_tac + \\ gvs [] + \\ ‘v_rel (p ++ q) thk (Atom (Loc loc'))’ by (imp_res_tac v_rel_ext \\ gvs []) + \\ first_x_assum drule_all + \\ strip_tac \\ gvs [Abbr ‘ss3’] + \\ qsuff_tac ‘loc ≠ loc'’ + >- (rpt strip_tac \\ gvs [EL_LUPDATE] \\ metis_tac []) + \\ CCONTR_TAC \\ gvs [EL_LUPDATE] + \\ ‘v1 ≠ thk’ by (CCONTR_TAC \\ gvs []) + \\ metis_tac [v_rel_thunk_lemma,IS_SOME_EXISTS]) >~ [‘BoxK’] >- - (Cases_on ‘n’ \\ fs [ADD1,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] \\ first_x_assum $ drule_at $ Pos $ el 2 \\ fs [] \\ drule_all state_rel_INL @@ -2016,7 +2176,8 @@ 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] \\ cheat) + \\ cheat (* >~ [‘LetK tenv n te’] >- (Cases_on ‘n'’ \\ fs [ADD1,step_n_add,step] \\ irule_at Any step_n_unwind \\ fs [step_n_add,step] @@ -2123,7 +2284,8 @@ 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) *)) + \\ cheat (* >- (Cases_on ‘tk’ \\ gvs [is_halt_def] \\ Cases_on ‘sk’ \\ gvs [is_halt_def,cont_rel_nil_cons] @@ -2278,7 +2440,7 @@ Proof \\ fs [step_res_rel_cases,GSYM rec_env_def] \\ irule state_rel_Letrec \\ fs [] \\ first_x_assum $ irule_at $ Pos last \\ fs [] - \\ drule_all Letrec_split_ALL_DISTINCT \\ fs [] + \\ drule_all Letrec_split_ALL_DISTINCT \\ fs [] *) QED Theorem step_backward: @@ -2371,6 +2533,8 @@ Proof \\ rewrite_tac [step_n_add,ADD1] \\ simp [] \\ simp [step] \\ gvs [] \\ pop_assum mp_tac + \\ drule_then assume_tac step_n_IMP_step_n' + \\ drule_all step_n'_INSERT \\ strip_tac \\ drule step_forward \\ simp [cont_rel_nil,is_halt_def] \\ simp [Once step_res_rel_cases,PULL_EXISTS] @@ -2387,6 +2551,8 @@ Proof \\ 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]) + \\ 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 []) @@ -2396,8 +2562,6 @@ Proof \\ fs [oEL_THM,EL_LUPDATE] \\ qmatch_goalsub_abbrev_tac ‘SOME ss3’ \\ rename [‘step_n nn’] \\ gvs [ADD1] - \\ reverse IF_CASES_TAC \\ gvs [] - >- cheat \\ strip_tac \\ rpt (disch_then kall_tac) \\ last_x_assum irule @@ -2679,6 +2843,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 [] From a2928628c2fec4e1f6620d4c0f18b5f20d401da1 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Wed, 15 Jan 2025 20:25:54 +0100 Subject: [PATCH 11/42] Collect cheats in stateLangTheory --- .../languages/semantics/stateLangScript.sml | 190 +++++++++ .../proofs/state_unthunkProofScript.sml | 388 ++++++++---------- 2 files changed, 358 insertions(+), 220 deletions(-) diff --git a/compiler/backend/languages/semantics/stateLangScript.sml b/compiler/backend/languages/semantics/stateLangScript.sml index 33d24eae..508d2d71 100644 --- a/compiler/backend/languages/semantics/stateLangScript.sml +++ b/compiler/backend/languages/semantics/stateLangScript.sml @@ -1586,6 +1586,196 @@ Proof simp[find_match_def, AllCaseEqs()] >> eq_tac >> rw[] 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_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_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_NONE_split: + 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 + cheat +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'_n_INSERT: + step'_n m avoid (Exp (rec_env x1 y0) y1,NONE,[]) = (Val v,NONE,[]) ∧ + dest_anyThunk v1 = SOME (INR (y0,y1),x1) ⇒ + step'_n m (v1 INSERT avoid) (Exp (rec_env x1 y0) y1,NONE,[]) = (Val v,NONE,[]) +Proof + strip_tac + \\ Cases_on ‘∃n ts. step'_n n avoid (Exp (rec_env x1 y0) y1,NONE,[]) = + (Val v1,NONE,ForceK1::ts)’ \\ gvs [] + >- cheat (* this case leads to contradiction *) + \\ cheat (* this case the goal is provable *) +QED + +Theorem step_n'_mono: + ∀n 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 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 + cheat (* 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] >> + 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 (* meaning of cexp *) diff --git a/compiler/backend/passes/proofs/state_unthunkProofScript.sml b/compiler/backend/passes/proofs/state_unthunkProofScript.sml index bb709f71..f50c2689 100644 --- a/compiler/backend/passes/proofs/state_unthunkProofScript.sml +++ b/compiler/backend/passes/proofs/state_unthunkProofScript.sml @@ -165,10 +165,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 = Atom (Loc n) ∧ oEL n p = SOME (SOME (Recclosure tfns tenv tn)) End Inductive v_rel: @@ -222,7 +220,7 @@ Inductive v_rel: [~Thunk:] (∀p n r. - oEL n p = SOME (SOME (r,[])) ⇒ + oEL n p = SOME (SOME (Thunk r)) ⇒ v_rel p (Thunk r) (Atom (Loc n))) [env_rel:] @@ -328,16 +326,18 @@ End Definition thunk_rel_def: thunk_rel p NONE _ = T ∧ - thunk_rel p (SOME (x,f)) v = - case x of - | INL tv => (∃sv. v_rel p tv sv ∧ v = ThunkMem Evaluated sv) - | INR (tenv,te) => - (∃senv se. - env_rel p (rec_env f tenv) senv ∧ compile_rel te se ∧ - v = ThunkMem NotEvaluated (Closure NONE senv se)) ∨ - (∃tv sv ck. - step_n ck (Exp (rec_env f tenv) te,NONE,[]) = (Val tv,NONE,[]) ∧ - v = ThunkMem Evaluated 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 (rec_env f tenv) senv ∧ compile_rel te se ∧ + v = ThunkMem NotEvaluated (Closure NONE senv se)) ∨ + (∃tv sv ck. + step_n ck (Exp (rec_env f tenv) te,NONE,[]) = (Val tv,NONE,[]) ∧ + v = ThunkMem Evaluated sv ∧ v_rel p tv sv) End Definition state_rel_def: @@ -379,7 +379,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) (Atom (Loc loc)) Proof simp [Once v_rel_cases,oEL_THM,rich_listTheory.EL_LENGTH_APPEND] \\ EVAL_TAC @@ -472,8 +472,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 []) @@ -484,8 +483,9 @@ 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 + 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 [] @@ -499,9 +499,10 @@ Proof QED Theorem state_rel_INL: - state_rel p ts (SOME ss) ∧ v_rel p v1 v2 ⇒ + state_rel p ts (SOME ss) ∧ v_rel p v1 v2 ∧ + dest_anyThunk thk = SOME (INL v1,f) ⇒ state_rel - (p ++ [SOME (INL v1,f)]) ts (SOME (SNOC (ThunkMem Evaluated v2) ss)) + (p ++ [SOME thk]) ts (SOME (SNOC (ThunkMem Evaluated v2) ss)) Proof fs [state_rel_def] \\ rw [] \\ gvs [] \\ gvs [thunk_rel_def] @@ -567,7 +568,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: @@ -650,9 +651,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 @@ -743,7 +742,7 @@ Proof \\ 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 @@ -751,6 +750,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’ @@ -767,15 +767,15 @@ Proof \\ 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 [] @@ -1111,6 +1111,17 @@ Proof \\ 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) ∧ @@ -1123,7 +1134,9 @@ 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 = Alloc’ \\ rw [] THEN1 @@ -1135,7 +1148,10 @@ 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] @@ -1146,7 +1162,9 @@ Proof \\ gvs [GSYM ZIP_APPEND,FILTER_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])) + \\ 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] @@ -1182,7 +1200,9 @@ Proof \\ 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]) + \\ 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 [] @@ -1209,7 +1229,9 @@ Proof \\ 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] @@ -1693,12 +1715,12 @@ 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)) + env_rel (p ++ MAP (λ(fn,_). SOME (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)) Proof @@ -1720,7 +1742,7 @@ 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 @@ -1804,7 +1826,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’ @@ -1882,78 +1904,15 @@ Proof \\ Cases_on ‘ss’ \\ gvs [ZIP_def,EL_CONS,PRE_SUB1] QED -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: - step_n' (m + n) avoid x = step_n' m avoid (step_n' n avoid x) -Proof - cheat -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_n'_same: - ∀n x. is_halt x ⇒ step_n' n avoid x = x -Proof - cheat (* - Induct \\ fs [FORALL_PROD,step_n'_SUC,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_n'_NONE_split: - 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 - cheat -QED - Theorem state_rel_LUPDATE_anyThunk': v_rel p res v2 ∧ state_rel p ts (SOME ss2) ∧ v_rel p v1 (Atom (Loc loc)) ∧ dest_anyThunk v1 = SOME (INR (tenv1,te),f) ∧ - step_n' n avoid (Exp (rec_env f tenv1) te,NONE,[]) = (Val res,NONE,[]) ⇒ + step'_n n avoid (Exp (rec_env f tenv1) te,NONE,[]) = (Val res,NONE,[]) ⇒ state_rel p ts (SOME (LUPDATE (ThunkMem Evaluated v2) loc ss2)) Proof - cheat + rw [] \\ drule step'_n_IMP_step_n \\ strip_tac \\ gvs [] + \\ drule_all state_rel_LUPDATE_anyThunk \\ gvs [] QED Triviality LIST_REL_lemma: @@ -1964,62 +1923,20 @@ Proof \\ gvs [] \\ first_x_assum $ irule_at Any QED -Theorem v_rel_thunk_lemma: - v_rel p v1 (Atom (Loc loc)) ∧ IS_SOME (dest_anyThunk v1) ∧ - v_rel p v2 (Atom (Loc loc)) ∧ IS_SOME (dest_anyThunk v2) ⇒ - v1 = v2 +Theorem v_rel_thunk_IMP_oEL: + v_rel p v1 (Atom (Loc 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] - \\ TRY (Cases_on ‘tfns’ \\ gvs [] \\ NO_TAC) - \\ dxrule_all LIST_REL_lemma - \\ gvs [EXISTS_PROD,FORALL_PROD] - \\ gvs [loc_rel_def,dest_anyThunk_def] - \\ rpt strip_tac \\ gvs [] - \\ cheat -QED - -Theorem setp_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'_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 - cheat -QED - -Theorem step_n'_INSERT: - step_n' m avoid (Exp (rec_env x1 y0) y1,NONE,[]) = (Val v,NONE,[]) ∧ - dest_anyThunk v1 = SOME (INR (y0,y1),x1) ⇒ - step_n' m (v1 INSERT avoid) (Exp (rec_env x1 y0) y1,NONE,[]) = (Val v,NONE,[]) -Proof - cheat -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 - cheat -QED - -Theorem step_n_IMP_step_n': - step_n n x = y ⇒ step_n' n {} x = y -Proof - cheat QED Theorem step_forward: ∀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) ∧ + 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 ⇒ @@ -2030,20 +1947,20 @@ Theorem step_forward: state_rel (p++q) (pick_opt zs ts1) (SOME ss1) ∧ step_res_rel (p++q) tr1 sr1 ∧ ∀thk loc. - thk ∈ avoid ∧ v_rel p thk (Atom (Loc loc)) ∧ IS_SOME (dest_anyThunk thk) ⇒ + thk ∈ avoid ∧ oEL loc p = SOME (SOME thk) ⇒ oEL loc ss1 = oEL loc ss Proof gen_tac \\ completeInduct_on ‘n’ \\ rpt strip_tac \\ gvs [AND_IMP_INTRO] \\ Cases_on ‘n = 0’ >- - (gvs [step_n'_def] \\ 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 avoid (tr,ts,tk)) ∧ - is_halt (step_n' 0 avoid (tr,ts,tk))’ by fs [step_n'_def] + >- (‘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 [] @@ -2060,7 +1977,7 @@ 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 [step'_def,return'_def,error_def] \\ PairCases_on ‘x’ \\ gvs [] @@ -2082,11 +1999,11 @@ Proof \\ 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 \\ strip_tac \\ pop_assum mp_tac \\ Cases_on ‘m3’ \\ fs [] \\ strip_tac \\ gvs [] - \\ gvs [step_n'_add,step,ADD1,step'_def,return'_def] + \\ gvs [step'_n_add,step,ADD1,step'_def,return'_def] \\ last_x_assum $ drule_at $ Pos $ el 2 \\ fs [] \\ simp [Once step_res_rel_cases,PULL_EXISTS] \\ disch_then drule_all \\ strip_tac \\ gvs [] @@ -2094,11 +2011,11 @@ Proof \\ gvs [SF SFY_ss]) \\ Cases_on ‘v1 ∈ avoid’ \\ gvs [] \\ gvs [GSYM rec_env_def,get_atoms_def] - \\ drule_all step_n'_NONE_split + \\ drule_all step'_n_NONE_split \\ strip_tac \\ ntac 2 $ pop_assum mp_tac \\ simp [opt_bind_def] - \\ drule_all step_n'_INSERT \\ strip_tac + \\ drule_all step'_n_INSERT \\ strip_tac \\ last_assum $ drule_at $ Pos $ el 2 \\ fs [cont_rel_nil] \\ simp [Once step_res_rel_cases,PULL_EXISTS] @@ -2110,7 +2027,7 @@ Proof \\ 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 >- gvs [] + \\ 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) @@ -2121,9 +2038,8 @@ Proof state_rel (p ++ q') (pick_opt zs ts1) (SOME ss1') ∧ step_res_rel (p ++ q') tr1 sr1' ∧ ∀thk loc. - thk ∈ avoid ∧ v_rel p thk (Atom (Loc loc)) ∧ - IS_SOME (dest_anyThunk thk) ⇒ - oEL loc ss1' = oEL loc ss’ >- metis_tac [] + 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’] @@ -2139,8 +2055,8 @@ Proof \\ disch_then $ drule_at (Pos $ el 3) \\ disch_then drule_all \\ strip_tac \\ gvs [] \\ Cases_on ‘m2’ \\ gvs [] - \\ gvs [ADD1,step_n'_add,step,step'_def,return'_def] - \\ qpat_x_assum ‘step_n' n avoid (Val v,ts,tk) = (tr1,ts1,tk1)’ assume_tac + \\ gvs [ADD1,step'_n_add,step,step'_def,return'_def] + \\ 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 @@ -2150,22 +2066,24 @@ Proof \\ strip_tac \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ rpt $ first_assum $ irule_at Any - \\ rpt gen_tac \\ disch_tac - \\ gvs [] - \\ ‘v_rel (p ++ q) thk (Atom (Loc loc'))’ by (imp_res_tac v_rel_ext \\ gvs []) + \\ 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 [Abbr ‘ss3’] - \\ qsuff_tac ‘loc ≠ loc'’ + \\ qsuff_tac ‘loc ≠ k’ >- (rpt strip_tac \\ gvs [EL_LUPDATE] \\ metis_tac []) \\ CCONTR_TAC \\ gvs [EL_LUPDATE] \\ ‘v1 ≠ thk’ by (CCONTR_TAC \\ gvs []) - \\ metis_tac [v_rel_thunk_lemma,IS_SOME_EXISTS]) + \\ imp_res_tac v_rel_thunk_IMP_oEL + \\ gvs [oEL_THM]) >~ [‘BoxK’] >- - (Cases_on ‘n’ \\ fs [ADD1,step_n'_add,step,step'_def,return'_def] + (Cases_on ‘n’ \\ fs [ADD1,step'_n_add,step,step'_def,return'_def] \\ irule_at Any step_n_unwind \\ fs [step_n_add,step] \\ 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 @@ -2176,12 +2094,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 [SF SFY_ss] \\ cheat) - \\ cheat (* + \\ 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) @@ -2190,7 +2114,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] @@ -2200,7 +2124,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 [] @@ -2208,27 +2132,27 @@ 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] + (Cases_on ‘n’ \\ fs [ADD1,step'_n_add,step,step'_def,return'_def,return_def] \\ Cases_on ‘ts’ \\ gvs [] \\ irule_at Any step_n_unwind \\ fs [step_n_add,step] \\ imp_res_tac state_rel_def \\ gvs [LIST_REL_EL_EQN] \\ imp_res_tac find_loc_length_thm \\ Cases_on ‘n1 < LENGTH t1’ \\ gvs [] - \\ IF_CASES_TAC \\ gvs [] + \\ IF_CASES_TAC \\ gvs [store_same_type_def] \\ imp_res_tac find_loc_el_thm \\ gvs[] \\ first_assum $ qspec_then ‘n1’ assume_tac \\ Cases_on ‘EL n1 t1’ \\ Cases_on ‘EL n2 s1’ @@ -2238,11 +2162,14 @@ Proof \\ rpt (disch_then $ drule_at Any) \\ strip_tac \\ qpat_x_assum ‘v_rel p v v'’ kall_tac \\ drule_all state_rel_thunk_v_rel \\ strip_tac - \\ res_tac - \\ first_x_assum $ qspec_then ‘zs’ assume_tac - \\ metis_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 *) @@ -2273,7 +2200,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 [] @@ -2284,8 +2212,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) *)) - \\ cheat (* + \\ 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] @@ -2294,10 +2225,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 [] @@ -2308,9 +2239,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 @@ -2333,8 +2264,7 @@ 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 @@ -2342,28 +2272,32 @@ Proof \\ 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),[])]) + \\ ‘step_res_rel (p ++ [SOME (Thunk (INR (env1,te)))]) (Val (Thunk (INR (env1,te)))) (Val (Atom (Loc (LENGTH ss)))) ∧ - state_rel (p ++ [SOME (INR (env1,te),[])]) + 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 []) + \\ 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 [] @@ -2390,7 +2324,11 @@ 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])) \\ strip_tac @@ -2425,7 +2363,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 @@ -2433,14 +2371,20 @@ 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 [] \\ first_x_assum $ irule_at $ Pos last \\ fs [] - \\ drule_all Letrec_split_ALL_DISTINCT \\ fs [] *) + \\ drule_all Letrec_split_ALL_DISTINCT \\ fs [] QED Theorem step_backward: @@ -2533,8 +2477,8 @@ Proof \\ rewrite_tac [step_n_add,ADD1] \\ simp [] \\ simp [step] \\ gvs [] \\ pop_assum mp_tac - \\ drule_then assume_tac step_n_IMP_step_n' - \\ drule_all step_n'_INSERT \\ strip_tac + \\ drule_then assume_tac step_n_IMP_step'_n + \\ drule_all step'_n_INSERT \\ strip_tac \\ drule step_forward \\ simp [cont_rel_nil,is_halt_def] \\ simp [Once step_res_rel_cases,PULL_EXISTS] @@ -2551,6 +2495,8 @@ Proof \\ 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]) + \\ 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] @@ -2586,7 +2532,8 @@ Proof \\ irule_at Any cont_rel_ext \\ pop_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] @@ -2750,12 +2697,13 @@ Proof \\ 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 []) + \\ 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 [] @@ -2817,7 +2765,7 @@ Proof \\ disch_then irule \\ simp [] \\ fs [GSYM rec_env_def] \\ 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 [] @@ -2843,7 +2791,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 step_n_IMP_step'_n \\ strip_tac \\ drule_all step_forward \\ rw [] \\ reverse (DEEP_INTRO_TAC some_intro \\ fs [] \\ rw []) >- metis_tac [] From 20996383f0d64957d632c8195b995114aa88c0c4 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Wed, 15 Jan 2025 21:01:32 +0100 Subject: [PATCH 12/42] Finish my part of state_unthunkProof --- .../languages/semantics/stateLangScript.sml | 290 ++++++++++-------- 1 file changed, 155 insertions(+), 135 deletions(-) diff --git a/compiler/backend/languages/semantics/stateLangScript.sml b/compiler/backend/languages/semantics/stateLangScript.sml index 508d2d71..baebca49 100644 --- a/compiler/backend/languages/semantics/stateLangScript.sml +++ b/compiler/backend/languages/semantics/stateLangScript.sml @@ -1444,125 +1444,6 @@ Proof rw[] QED -Theorem step_NONE_Val: - step 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) = - (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(), - forceK2_none_def |> DefnBase.one_line_ify NONE,AllCaseEqs(), - continue_def,error_def,value_def,push_def] - \\ rename [‘num_args_ok s’] - \\ Cases_on ‘s’ \\ gvs [num_args_ok_def,LENGTH_EQ_NUM_compute] - \\ gvs [application_def,AllCaseEqs(),error_def,continue_def,value_def] -QED - -Theorem step_NONE_Exp: - step NONE xs (Exp l e) = (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 ys (Exp l e) = (x0,x1,MAP forceK2_none xs1 ++ ys) -Proof - Cases_on ‘e’ - >~ [‘Let opt’] >- - (Cases_on ‘opt’ - \\ fs [step_def,AllCaseEqs()] \\ rw [] - \\ gvs [error_def,value_def,continue_def,push_def] - \\ gvs [forceK2_none_def |> DefnBase.one_line_ify NONE,AllCaseEqs()]) - >~ [‘Case _ _ rows’] >- - (Cases_on ‘rows’ - \\ fs [step_def,AllCaseEqs()] \\ rw [] - \\ gvs [error_def,value_def,continue_def,push_def] - \\ gvs [forceK2_none_def |> DefnBase.one_line_ify NONE,AllCaseEqs()]) - >~ [‘App’] >- - (fs [step_def,AllCaseEqs()] \\ rw [] \\ gvs [error_def,push_def] - \\ gvs [forceK2_none_def |> DefnBase.one_line_ify NONE,AllCaseEqs()] - \\ Cases_on ‘s’ \\ gvs [num_args_ok_def] - \\ gvs [application_def,value_def,AllCaseEqs(),error_def,get_atoms_def]) - \\ fs [step_def,AllCaseEqs()] \\ rw [] - \\ gvs [error_def,value_def,continue_def,push_def] - \\ 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 -Proof - qsuff_tac ‘ - ∀n xs te k tk r z. - step_n n (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’ - >- - (rw [] - \\ last_x_assum $ qspecl_then [‘n’,‘[]’] mp_tac \\ fs [] - \\ disch_then drule \\ fs [] - \\ strip_tac - \\ first_x_assum $ irule_at $ Pos $ hd \\ fs [] - \\ first_x_assum $ irule_at $ Pos $ hd \\ fs []) - \\ strip_tac - \\ completeInduct_on ‘n’ \\ rw [] - \\ 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)) - (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’] - \\ full_simp_tac bool_ss [GSYM MAP_APPEND] - \\ Cases_on ‘is_halt (x0,NONE,MAP forceK2_none xs1 ++ MAP forceK2_none t)’ - >- - (Cases_on ‘x0’ \\ gvs [] - \\ qexists_tac ‘0’ \\ fs [] - \\ qexists_tac ‘n’ \\ fs [] - \\ Cases_on ‘n’ \\ gvs []) - \\ first_x_assum $ drule_at $ Pos $ el 2 - \\ impl_tac >- fs [] - \\ rw [] - \\ 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 [] - \\ 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_Exp \\ strip_tac \\ gvs [] - \\ Q.REFINE_EXISTS_TAC ‘SUC m3’ \\ fs [step_n_SUC] - \\ full_simp_tac bool_ss [GSYM MAP_APPEND] - \\ Cases_on ‘is_halt (x0,NONE,MAP forceK2_none xs1 ++ MAP forceK2_none xs)’ - >- - (Cases_on ‘x0’ \\ gvs [] - \\ qexists_tac ‘0’ \\ fs [] - \\ qexists_tac ‘n’ \\ fs [] - \\ Cases_on ‘n’ \\ gvs []) - \\ first_x_assum $ drule_at $ Pos $ el 2 - \\ impl_tac >- fs [] - \\ rw [] - \\ first_x_assum $ irule_at $ Pos hd \\ fs [] - \\ 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. @@ -1614,6 +1495,12 @@ Proof \\ 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 @@ -1656,15 +1543,6 @@ Proof Induct \\ gvs [step'_n_def,FUNPOW,step'_def,step] QED -Theorem step'_n_NONE_split: - 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 - cheat -QED - Theorem step'_n_IMP_step_n: ∀n avoid x r y z. step'_n n avoid x = (r,y,z) ∧ r ≠ Error ⇒ @@ -1684,7 +1562,6 @@ Proof step_def,return_def,error_def] QED - Theorem step'_n_INSERT: step'_n m avoid (Exp (rec_env x1 y0) y1,NONE,[]) = (Val v,NONE,[]) ∧ dest_anyThunk v1 = SOME (INR (y0,y1),x1) ⇒ @@ -1693,8 +1570,13 @@ Proof strip_tac \\ Cases_on ‘∃n ts. step'_n n avoid (Exp (rec_env x1 y0) y1,NONE,[]) = (Val v1,NONE,ForceK1::ts)’ \\ gvs [] - >- cheat (* this case leads to contradiction *) - \\ cheat (* this case the goal is provable *) + >- cheat (* this case leads to contradiction because one can take n+1 steps + to arrive at (Exp (rec_env x1 y0) y1,NONE,...) and then n+1 steps + again and again and again withput terminating. This means that + eventually m steps will be exceeded which means assumption 0 is false *) + \\ cheat (* this case the goal is provable, since assumption 2 states that we + will never encounter the (Val v1,NONE,ForceK1::...) which is the + only configuration that can lead to an attempt to force v1 *) QED Theorem step_n'_mono: @@ -1724,7 +1606,7 @@ Theorem step'_n_fast_forward_gen: ⇒ ∃m3. m3 ≤ n ∧ step'_n m3 avoid (Val v2,ss2,sk2 ++ DROP (LENGTH k') k) = (sr1,ss1,sk1) Proof - cheat (* Induct >> rpt strip_tac + 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] >> @@ -1736,11 +1618,17 @@ Proof reverse strip_tac >- (gvs[] >> metis_tac[]) >> Cases_on ‘n’ - >- (drule_then assume_tac is_halt_step_same >> + >- (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] >> + 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[] >> @@ -1748,7 +1636,7 @@ Proof gvs[rich_listTheory.DROP_APPEND2] >> strip_tac >> first_x_assum(irule_at (Pos last)) >> - simp[] *) + simp[] QED Theorem step'_n_fast_forward: @@ -1777,6 +1665,138 @@ 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' avoid NONE (forceK2_none h::ys) (Val v) = + (x0,x1,MAP forceK2_none xs1 ++ ys) +Proof + 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’] + \\ Cases_on ‘s’ \\ gvs [num_args_ok_def,LENGTH_EQ_NUM_compute] + \\ gvs [application_def,AllCaseEqs(),error_def,continue_def,value_def] +QED + +Theorem step_NONE_Exp: + step NONE xs (Exp l e) = (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 ys (Exp l e) = (x0,x1,MAP forceK2_none xs1 ++ ys) +Proof + Cases_on ‘e’ + >~ [‘Let opt’] >- + (Cases_on ‘opt’ + \\ fs [step_def,AllCaseEqs()] \\ rw [] + \\ gvs [error_def,value_def,continue_def,push_def] + \\ gvs [forceK2_none_def |> DefnBase.one_line_ify NONE,AllCaseEqs()]) + >~ [‘Case _ _ rows’] >- + (Cases_on ‘rows’ + \\ fs [step_def,AllCaseEqs()] \\ rw [] + \\ gvs [error_def,value_def,continue_def,push_def] + \\ gvs [forceK2_none_def |> DefnBase.one_line_ify NONE,AllCaseEqs()]) + >~ [‘App’] >- + (fs [step_def,AllCaseEqs()] \\ rw [] \\ gvs [error_def,push_def] + \\ gvs [forceK2_none_def |> DefnBase.one_line_ify NONE,AllCaseEqs()] + \\ Cases_on ‘s’ \\ gvs [num_args_ok_def] + \\ gvs [application_def,value_def,AllCaseEqs(),error_def,get_atoms_def]) + \\ fs [step_def,AllCaseEqs()] \\ rw [] + \\ gvs [error_def,value_def,continue_def,push_def] + \\ gvs [forceK2_none_def |> DefnBase.one_line_ify NONE,AllCaseEqs()] +QED + +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 + gen_tac + \\ qsuff_tac ‘ + ∀n xs te k tk r z. + 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 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 [] + \\ disch_then drule \\ fs [] + \\ strip_tac + \\ first_x_assum $ irule_at $ Pos $ hd \\ fs [] + \\ first_x_assum $ irule_at $ Pos $ hd \\ fs []) + \\ strip_tac + \\ completeInduct_on ‘n’ \\ rw [] + \\ reverse (Cases_on ‘te’) \\ fs [] + >- + (Cases_on ‘xs’ + \\ 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’] + \\ full_simp_tac bool_ss [GSYM MAP_APPEND] + \\ Cases_on ‘is_halt (x0,NONE,MAP forceK2_none xs1 ++ MAP forceK2_none t)’ + >- + (Cases_on ‘x0’ \\ gvs [] + \\ qexists_tac ‘0’ \\ fs [] + \\ qexists_tac ‘n’ \\ fs [] + \\ Cases_on ‘n’ \\ gvs []) + \\ first_x_assum $ drule_at $ Pos $ el 2 + \\ impl_tac >- fs [] + \\ rw [] + \\ 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' 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 []) + \\ gvs [step'_def] + \\ drule_all step_NONE_Exp \\ strip_tac \\ gvs [] + \\ 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)’ + >- + (Cases_on ‘x0’ \\ gvs [] + \\ qexists_tac ‘0’ \\ fs [] + \\ qexists_tac ‘n’ \\ fs [] + \\ Cases_on ‘n’ \\ gvs []) + \\ first_x_assum $ drule_at $ Pos $ el 2 + \\ impl_tac >- fs [] + \\ rw [] + \\ first_x_assum $ irule_at $ Pos hd \\ fs [] + \\ first_x_assum $ irule_at $ Pos $ hd \\ fs [] +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 +Proof + qspec_then ‘{}’ assume_tac step'_n_NONE_split + \\ gvs [step'_n_eq] +QED + (* meaning of cexp *) Definition sop_of_def[simp]: From 425b4214e6a66de1b13d0544f4f3871b86c7c3ce Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Fri, 17 Jan 2025 10:56:55 +0100 Subject: [PATCH 13/42] Hacking during meeting --- .../languages/semantics/stateLangScript.sml | 43 ++++++++++++++++--- .../proofs/state_unthunkProofScript.sml | 5 --- 2 files changed, 38 insertions(+), 10 deletions(-) diff --git a/compiler/backend/languages/semantics/stateLangScript.sml b/compiler/backend/languages/semantics/stateLangScript.sml index baebca49..4ce83403 100644 --- a/compiler/backend/languages/semantics/stateLangScript.sml +++ b/compiler/backend/languages/semantics/stateLangScript.sml @@ -1299,6 +1299,13 @@ Proof \\ fs [] QED +Theorem step'_n_set_cont: + 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 + cheat +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) @@ -1562,18 +1569,44 @@ Proof step_def,return_def,error_def] QED +Definition rec_env_def: (* TODO: remove dup with mk_rec_env *) + rec_env f env = + MAP (λ(fn,_). (fn,Recclosure f env fn)) f ++ env +End + +Theorem add_to_avoid: + ∀m x k v v1. + step'_n m avoid (x,NONE,k) = (Val v,NONE,[]) ∧ + (∀n ts. step'_n n avoid (x,NONE,k) ≠ (Val v1,NONE,ForceK1::ts)) ⇒ + step'_n m (v1 INSERT avoid) (x,NONE,k) = (Val v,NONE,[]) +Proof + cheat +QED + Theorem step'_n_INSERT: step'_n m avoid (Exp (rec_env x1 y0) y1,NONE,[]) = (Val v,NONE,[]) ∧ dest_anyThunk v1 = SOME (INR (y0,y1),x1) ⇒ step'_n m (v1 INSERT avoid) (Exp (rec_env x1 y0) y1,NONE,[]) = (Val v,NONE,[]) Proof - strip_tac + Cases_on ‘v1 ∈ avoid’ + >- (‘v1 INSERT avoid = avoid’ by (gvs [pred_setTheory.EXTENSION] \\ metis_tac []) \\ gvs []) + \\ strip_tac \\ Cases_on ‘∃n ts. step'_n n avoid (Exp (rec_env x1 y0) y1,NONE,[]) = (Val v1,NONE,ForceK1::ts)’ \\ gvs [] - >- cheat (* this case leads to contradiction because one can take n+1 steps - to arrive at (Exp (rec_env x1 y0) y1,NONE,...) and then n+1 steps - again and again and again withput terminating. This means that - eventually m steps will be exceeded which means assumption 0 is false *) + >- + (dxrule step'_n_set_cont \\ gvs [] \\ strip_tac + \\ ‘∀k2. ∃k3. + step'_n (n+1) avoid (Exp (rec_env x1 y0) y1,NONE,k2) = + (Exp (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,rec_env_def]) + \\ pop_assum mp_tac \\ pop_assum kall_tac \\ strip_tac + \\ qsuff_tac ‘F’ \\ gvs [] + \\ cheat (* this case leads to contradiction because one can take n+1 steps + to arrive at (Exp (rec_env x1 y0) y1,NONE,...) and then n+1 steps + again and again and again withput terminating. This means that + eventually m steps will be exceeded which means assumption 0 is false *)) \\ cheat (* this case the goal is provable, since assumption 2 states that we will never encounter the (Val v1,NONE,ForceK1::...) which is the only configuration that can lead to an attempt to force v1 *) diff --git a/compiler/backend/passes/proofs/state_unthunkProofScript.sml b/compiler/backend/passes/proofs/state_unthunkProofScript.sml index f50c2689..242931c9 100644 --- a/compiler/backend/passes/proofs/state_unthunkProofScript.sml +++ b/compiler/backend/passes/proofs/state_unthunkProofScript.sml @@ -308,11 +308,6 @@ Inductive cont_rel: (ForceMutK n2::sk)) End -Definition rec_env_def: - rec_env f env = - MAP (λ(fn,_). (fn,Recclosure f env fn)) f ++ env -End - Definition store_rel_def: store_rel p (ThunkMem m v1) s2 = (∃v2. From 9849cc802041308adad3d070af2f793d544e145b Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Fri, 14 Feb 2025 11:13:19 +0200 Subject: [PATCH 14/42] Assert thunkLang Force doesn't produce thunks. Proofs updated except thunk_unthunk, thunk_Let_Delay_Var, and thunk_Delay_Lam. --- .../languages/semantics/envLangScript.sml | 13 +- .../semantics/thunkLangPropsScript.sml | 24 +++- .../languages/semantics/thunkLangScript.sml | 12 +- .../proofs/env_to_state_1ProofScript.sml | 18 ++- .../proofs/pure_to_thunk_1ProofScript.sml | 28 ++++- .../passes/proofs/thunk_Delay_LamScript.sml | 65 ++++++++-- .../proofs/thunk_case_d2bProofScript.sml | 101 +++++++++++++-- .../proofs/thunk_case_inlProofScript.sml | 85 +++++++++++++ .../proofs/thunk_case_liftProofScript.sml | 58 +++++++++ .../proofs/thunk_case_projProofScript.sml | 95 +++++++++++++- .../proofs/thunk_let_forceProofScript.sml | 119 ++++++++++++++++-- .../thunk_remove_unuseful_bindingsScript.sml | 75 ++++++++++- .../passes/proofs/thunk_tickProofScript.sml | 47 ++++++- .../proofs/thunk_to_env_1ProofScript.sml | 67 ++++++++++ .../passes/proofs/thunk_untickProofScript.sml | 74 ++++++++++- 15 files changed, 818 insertions(+), 63 deletions(-) diff --git a/compiler/backend/languages/semantics/envLangScript.sml b/compiler/backend/languages/semantics/envLangScript.sml index 357ecfeb..6086d928 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 @@ -252,7 +256,11 @@ 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 @@ -366,7 +374,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 diff --git a/compiler/backend/languages/semantics/thunkLangPropsScript.sml b/compiler/backend/languages/semantics/thunkLangPropsScript.sml index 45b843cf..10336f08 100644 --- a/compiler/backend/languages/semantics/thunkLangPropsScript.sml +++ b/compiler/backend/languages/semantics/thunkLangPropsScript.sml @@ -1176,13 +1176,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 @@ -1197,7 +1209,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 54913737..8f604760 100644 --- a/compiler/backend/languages/semantics/thunkLangScript.sml +++ b/compiler/backend/languages/semantics/thunkLangScript.sml @@ -180,6 +180,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 @@ -284,7 +289,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) = @@ -471,8 +477,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 []) diff --git a/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml b/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml index 0744f282..4c81ecb6 100644 --- a/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml +++ b/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml @@ -626,13 +626,27 @@ 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]) diff --git a/compiler/backend/passes/proofs/pure_to_thunk_1ProofScript.sml b/compiler/backend/passes/proofs/pure_to_thunk_1ProofScript.sml index 1be201c6..c64ce8ff 100644 --- a/compiler/backend/passes/proofs/pure_to_thunk_1ProofScript.sml +++ b/compiler/backend/passes/proofs/pure_to_thunk_1ProofScript.sml @@ -1037,11 +1037,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] @@ -1069,6 +1078,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, @@ -1190,6 +1207,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]) diff --git a/compiler/backend/passes/proofs/thunk_Delay_LamScript.sml b/compiler/backend/passes/proofs/thunk_Delay_LamScript.sml index c710114a..91b47772 100644 --- a/compiler/backend/passes/proofs/thunk_Delay_LamScript.sml +++ b/compiler/backend/passes/proofs/thunk_Delay_LamScript.sml @@ -1603,7 +1603,8 @@ 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’] >- (gvs [dest_anyThunk_def] >> @@ -1641,7 +1642,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 >> + cheat) >> unabbrev_all_tac >> irule v_rel_Closure_Recclosure >> gvs [LIST_REL_EL_EQN, EVERY_CONJ, EL_MAP, MEM_EL] >> @@ -1668,7 +1676,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 +1695,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 +1725,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 []) >> + cheat (* TODO v_rel y' y'' ⇒ is_anyThunk y'' *)) >- (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 +1744,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 []) >> + cheat)) >- (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 +1764,18 @@ 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 + >- cheat (* impl_tac below *) + \\ `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 +1793,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 +1805,9 @@ 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 _ (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 +1829,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 []) + \\ cheat (* TODO v_rel_anyThunk *)) \\ rename1 ‘dest_anyThunk v1 = INR (wx, binds)’ \\ ‘∃wx' binds'. dest_anyThunk w1 = INR (wx', binds') ∧ exp_rel wx wx' ∧ @@ -1839,7 +1875,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 +1885,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 []) + \\ cheat (* TODO v_rel_anyThunk *)) \\ 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]) diff --git a/compiler/backend/passes/proofs/thunk_case_d2bProofScript.sml b/compiler/backend/passes/proofs/thunk_case_d2bProofScript.sml index 0dfa8c19..948e61ac 100644 --- a/compiler/backend/passes/proofs/thunk_case_d2bProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_case_d2bProofScript.sml @@ -160,6 +160,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) ∧ @@ -670,7 +715,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, @@ -684,7 +737,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 [] @@ -697,7 +755,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 @@ -712,8 +772,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’ @@ -729,7 +793,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 @@ -738,8 +809,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 [] @@ -752,7 +826,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’ @@ -762,8 +838,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] diff --git a/compiler/backend/passes/proofs/thunk_case_inlProofScript.sml b/compiler/backend/passes/proofs/thunk_case_inlProofScript.sml index d6cdecca..45b70ca3 100644 --- a/compiler/backend/passes/proofs/thunk_case_inlProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_case_inlProofScript.sml @@ -460,6 +460,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 ∧ @@ -623,6 +694,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 @@ -645,6 +723,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’ diff --git a/compiler/backend/passes/proofs/thunk_case_liftProofScript.sml b/compiler/backend/passes/proofs/thunk_case_liftProofScript.sml index 15994901..b5ba0365 100644 --- a/compiler/backend/passes/proofs/thunk_case_liftProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_case_liftProofScript.sml @@ -296,6 +296,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 ⇒ @@ -430,12 +474,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’ diff --git a/compiler/backend/passes/proofs/thunk_case_projProofScript.sml b/compiler/backend/passes/proofs/thunk_case_projProofScript.sml index 6007c6ae..4e01c5b9 100644 --- a/compiler/backend/passes/proofs/thunk_case_projProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_case_projProofScript.sml @@ -49,7 +49,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: *) @@ -362,6 +363,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 @@ -431,7 +499,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)’ @@ -584,6 +655,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)))’ @@ -607,6 +684,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 @@ -619,6 +704,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’] >- ( diff --git a/compiler/backend/passes/proofs/thunk_let_forceProofScript.sml b/compiler/backend/passes/proofs/thunk_let_forceProofScript.sml index 5cddc93a..ffe507d7 100644 --- a/compiler/backend/passes/proofs/thunk_let_forceProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_let_forceProofScript.sml @@ -679,6 +679,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 @@ -1026,7 +1090,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 @@ -1041,7 +1113,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 [] @@ -1054,7 +1131,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 @@ -1071,7 +1150,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’ @@ -1086,7 +1170,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 @@ -1095,8 +1186,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 [] @@ -1109,7 +1203,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’ @@ -1119,8 +1215,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] diff --git a/compiler/backend/passes/proofs/thunk_remove_unuseful_bindingsScript.sml b/compiler/backend/passes/proofs/thunk_remove_unuseful_bindingsScript.sml index 03479dea..4946b6c5 100644 --- a/compiler/backend/passes/proofs/thunk_remove_unuseful_bindingsScript.sml +++ b/compiler/backend/passes/proofs/thunk_remove_unuseful_bindingsScript.sml @@ -532,6 +532,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 ⇒ @@ -929,7 +977,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 [] @@ -937,7 +986,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)’ @@ -979,7 +1032,8 @@ Proof \\ dxrule_then (qspecl_then [‘j + k’] assume_tac) eval_to_mono \\ gs [REVERSE_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] @@ -989,7 +1043,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] \\ IF_CASES_TAC \\ gvs [] \\ rpt $ dxrule_then assume_tac ALOOKUP_MEM \\ gs [] @@ -1004,7 +1062,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 [] @@ -1012,7 +1071,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’ diff --git a/compiler/backend/passes/proofs/thunk_tickProofScript.sml b/compiler/backend/passes/proofs/thunk_tickProofScript.sml index 8e6f9951..0f774089 100644 --- a/compiler/backend/passes/proofs/thunk_tickProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_tickProofScript.sml @@ -337,6 +337,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 ⇒ @@ -757,7 +791,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 []) @@ -766,7 +801,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]) diff --git a/compiler/backend/passes/proofs/thunk_to_env_1ProofScript.sml b/compiler/backend/passes/proofs/thunk_to_env_1ProofScript.sml index 4826c736..f930d6c5 100644 --- a/compiler/backend/passes/proofs/thunk_to_env_1ProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_to_env_1ProofScript.sml @@ -278,6 +278,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; @@ -401,12 +453,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’] >- ( diff --git a/compiler/backend/passes/proofs/thunk_untickProofScript.sml b/compiler/backend/passes/proofs/thunk_untickProofScript.sml index e9aee55f..9ccae1f9 100644 --- a/compiler/backend/passes/proofs/thunk_untickProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_untickProofScript.sml @@ -358,6 +358,57 @@ 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 + Theorem exp_rel_eval_to: ∀k x y. exp_rel x y ∧ @@ -855,9 +906,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 [] >- ( @@ -871,7 +925,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]) @@ -880,7 +937,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] @@ -931,7 +992,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’ From fc73f0def8a09a2995cf3937d699b64990afe8e5 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Sun, 23 Mar 2025 10:01:04 +0200 Subject: [PATCH 15/42] box doesn't return thunk --- compiler/backend/languages/semantics/envLangScript.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/backend/languages/semantics/envLangScript.sml b/compiler/backend/languages/semantics/envLangScript.sml index 6086d928..0ca16ffb 100644 --- a/compiler/backend/languages/semantics/envLangScript.sml +++ b/compiler/backend/languages/semantics/envLangScript.sml @@ -247,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 From 3cf1bde47349510dc66f1e5d0963df56f52e4e70 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Sun, 23 Mar 2025 10:01:59 +0200 Subject: [PATCH 16/42] ForceK2 and BoxK don't return thunks --- .../languages/semantics/stateLangScript.sml | 24 ++++++++++++++----- 1 file changed, 18 insertions(+), 6 deletions(-) diff --git a/compiler/backend/languages/semantics/stateLangScript.sml b/compiler/backend/languages/semantics/stateLangScript.sml index 4ce83403..f529c884 100644 --- a/compiler/backend/languages/semantics/stateLangScript.sml +++ b/compiler/backend/languages/semantics/stateLangScript.sml @@ -380,8 +380,14 @@ 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) = + (case dest_anyThunk v of + | NONE => value v st k + | SOME _ => error st k) ∧ + return v st (BoxK :: k) = + (case dest_anyThunk v of + | NONE => value (Thunk $ INL v) st k + | SOME _ => error st k) ∧ return v st (ForceMutK n :: k) = (case st of SOME stores => @@ -943,8 +949,11 @@ Proof (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 []) + \\ Cases_on `dest_anyThunk v` \\ 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]) >~ [‘ForceK1’] >- (fs [return_def,continue_def,value_def] \\ CASE_TAC @@ -964,8 +973,11 @@ Proof (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 []) + \\ Cases_on `dest_anyThunk v` \\ 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]) >~ [‘RaiseK’] >- (fs [return_def,error_def] \\ fs [error_def] \\ rw [] \\ gvs [step_n_Val,step_n_Error,error_def,GSYM step_n_def]) From b1848e9795ba474e06124bf846cb80e9efd4fb57 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Sun, 23 Mar 2025 10:05:26 +0200 Subject: [PATCH 17/42] ForceK2 and BoxK don't return thunks --- .../proofs/state_unthunkProofScript.sml | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/compiler/backend/passes/proofs/state_unthunkProofScript.sml b/compiler/backend/passes/proofs/state_unthunkProofScript.sml index 242931c9..5e4a518f 100644 --- a/compiler/backend/passes/proofs/state_unthunkProofScript.sml +++ b/compiler/backend/passes/proofs/state_unthunkProofScript.sml @@ -1999,6 +1999,7 @@ Proof \\ pop_assum mp_tac \\ Cases_on ‘m3’ \\ fs [] \\ strip_tac \\ gvs [] \\ gvs [step'_n_add,step,ADD1,step'_def,return'_def] + \\ Cases_on `dest_anyThunk 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 [] @@ -2051,6 +2052,7 @@ Proof \\ disch_then drule_all \\ strip_tac \\ gvs [] \\ Cases_on ‘m2’ \\ gvs [] \\ gvs [ADD1,step'_n_add,step,step'_def,return'_def] + \\ Cases_on `dest_anyThunk v` \\ 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] @@ -2075,6 +2077,7 @@ Proof >~ [‘BoxK’] >- (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 `dest_anyThunk v1` \\ gvs [] \\ first_x_assum $ drule_at $ Pos $ el 2 \\ fs [] \\ drule_then drule state_rel_INL \\ simp [oneline dest_anyThunk_def,AllCaseEqs(),oneline dest_Thunk_def] @@ -2440,10 +2443,10 @@ Proof \\ Q.REFINE_EXISTS_TAC ‘ck1+(1+n5)’ \\ rewrite_tac [step_n_add,ADD1] \\ fs [] \\ simp [step] + \\ reverse $ Cases_on `dest_anyThunk tv` \\ 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]) \\ simp [opt_bind_def] @@ -2505,8 +2508,10 @@ Proof \\ rename [‘step_n nn’] \\ gvs [ADD1] \\ strip_tac \\ rpt (disch_then kall_tac) + \\ reverse $ Cases_on `dest_anyThunk res` \\ gvs [] + >- (qexists `0` \\ rw []) \\ 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’] @@ -2519,13 +2524,15 @@ Proof >- (rw [] \\ fs [is_halt_def]) \\ fs [] \\ rewrite_tac [step_n_add,ADD1] \\ simp [step,get_atoms_def]) \\ strip_tac + \\ reverse $ Cases_on `dest_anyThunk v1` \\ gvs [] + >- (qexists `0` \\ rw []) \\ 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 [dest_anyThunk_def]) From 9a4649822457033231167845a552a3af8b56b4a3 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Sun, 23 Mar 2025 10:14:41 +0200 Subject: [PATCH 18/42] fix env_to_state proof --- .../proofs/env_to_state_1ProofScript.sml | 53 ++++++++++++++++++- 1 file changed, 51 insertions(+), 2 deletions(-) diff --git a/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml b/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml index 4c81ecb6..3258d58b 100644 --- a/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml +++ b/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml @@ -454,6 +454,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 ∧ @@ -595,7 +640,9 @@ 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 []) >~ [‘Force x’] >- (simp [Once compile_rel_cases] \\ rw [] \\ fs [eval_to_def] @@ -649,7 +696,9 @@ Proof \\ 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 []) >~ [‘Let NONE x1 x2’] >- (simp [Once compile_rel_cases] \\ rw [] \\ fs [eval_to_def] From 37b6ce2d2c7c06c38dd8419ec651d7af870e3d0b Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Wed, 16 Apr 2025 11:27:12 +0300 Subject: [PATCH 19/42] This commit comes after adding the check in the `thunkLang` semantics that `Force` cannot return a thunk: - Proofs regarding `thunkLang` were modified to work with the changes. - A new delayed top-level semantics was added for `thunkLang` to allow the `thunk_unthunk` proof to work, and an `undelay_next` proof was added that converts between these semantics and the normal top-level semantics. - Wrapping of monads with `Ret`s was transferred from `pure_to_thunk_1` to `thunk_unthunk`. - In `pure_to_thunk_2`, the `thunk_unthunk` step now comes right after `pure_to_thunk_1` and the `undelay` step sits between `thunk_unthunk` and the rest of the steps. - A new check that `Cons`' arguments are delayed was added in the semantics. Proofs up to and including `pure_to_thunk2` complete without cheats. There are still cheats in `thunk_Let_Delay_VarScript` and `thunk_Delay_LamScript` whose proofs are trickier. --- .../languages/semantics/envLangScript.sml | 17 +- .../semantics/thunkLangPropsScript.sml | 3 +- .../languages/semantics/thunkLangScript.sml | 14 +- .../thunk_semantics_delayedScript.sml | 861 ++++++++++ .../proofs/env_to_state_1ProofScript.sml | 2 + .../proofs/pure_to_thunkProofScript.sml | 3 +- .../proofs/pure_to_thunk_1ProofScript.sml | 251 ++- .../proofs/pure_to_thunk_2ProofScript.sml | 760 +++++---- .../passes/proofs/thunk_Delay_LamScript.sml | 21 +- .../proofs/thunk_Let_Delay_VarScript.sml | 44 +- .../proofs/thunk_case_liftProofScript.sml | 23 +- .../proofs/thunk_case_projProofScript.sml | 75 +- .../proofs/thunk_let_forceProofScript.sml | 16 +- .../passes/proofs/thunk_tickProofScript.sml | 16 +- .../proofs/thunk_to_env_1ProofScript.sml | 7 +- .../proofs/thunk_undelay_nextProofScript.sml | 1464 +++++++++++++++++ .../proofs/thunk_unthunkProofScript.sml | 537 ++++-- .../passes/proofs/thunk_untickProofScript.sml | 180 +- 18 files changed, 3534 insertions(+), 760 deletions(-) create mode 100644 compiler/backend/languages/semantics/thunk_semantics_delayedScript.sml create mode 100644 compiler/backend/passes/proofs/thunk_undelay_nextProofScript.sml diff --git a/compiler/backend/languages/semantics/envLangScript.sml b/compiler/backend/languages/semantics/envLangScript.sml index 0ca16ffb..9ea5c400 100644 --- a/compiler/backend/languages/semantics/envLangScript.sml +++ b/compiler/backend/languages/semantics/envLangScript.sml @@ -267,7 +267,10 @@ Definition eval_to_def: 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 @@ -396,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/thunkLangPropsScript.sml b/compiler/backend/languages/semantics/thunkLangPropsScript.sml index 10336f08..0db73b45 100644 --- a/compiler/backend/languages/semantics/thunkLangPropsScript.sml +++ b/compiler/backend/languages/semantics/thunkLangPropsScript.sml @@ -933,7 +933,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" diff --git a/compiler/backend/languages/semantics/thunkLangScript.sml b/compiler/backend/languages/semantics/thunkLangScript.sml index 8f604760..af66e8ca 100644 --- a/compiler/backend/languages/semantics/thunkLangScript.sml +++ b/compiler/backend/languages/semantics/thunkLangScript.sml @@ -303,7 +303,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 @@ -502,7 +505,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/passes/proofs/env_to_state_1ProofScript.sml b/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml index 3258d58b..46ba73b3 100644 --- a/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml +++ b/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml @@ -820,6 +820,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 diff --git a/compiler/backend/passes/proofs/pure_to_thunkProofScript.sml b/compiler/backend/passes/proofs/pure_to_thunkProofScript.sml index 761b1802..fe911904 100644 --- a/compiler/backend/passes/proofs/pure_to_thunkProofScript.sml +++ b/compiler/backend/passes/proofs/pure_to_thunkProofScript.sml @@ -667,10 +667,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 diff --git a/compiler/backend/passes/proofs/pure_to_thunk_1ProofScript.sml b/compiler/backend/passes/proofs/pure_to_thunk_1ProofScript.sml index c64ce8ff..46e70b6d 100644 --- a/compiler/backend/passes/proofs/pure_to_thunk_1ProofScript.sml +++ b/compiler/backend/passes/proofs/pure_to_thunk_1ProofScript.sml @@ -6,14 +6,16 @@ open HolKernel Parse boolLib bossLib term_tactic monadsyntax dep_rewrite intLib; open stringTheory optionTheory sumTheory pairTheory listTheory alistTheory finite_mapTheory pred_setTheory rich_listTheory thunkLangTheory - pure_semanticsTheory thunk_semanticsTheory pure_evalTheory pure_configTheory - thunkLang_primitivesTheory pure_exp_lemmasTheory pure_miscTheory; + pure_semanticsTheory thunk_semanticsTheory thunk_semantics_delayedTheory + pure_evalTheory pure_configTheory thunkLang_primitivesTheory + pure_exp_lemmasTheory pure_miscTheory; val _ = new_theory "pure_to_thunk_1Proof"; val _ = set_grammar_ancestry ["finite_map", "pred_set", "rich_list", "pure_semantics", "thunk_semantics", - "pure_exp_lemmas", "pure_misc", "pure_config"]; + "thunk_semantics_delayed", "pure_exp_lemmas", + "pure_misc", "pure_config"]; val _ = numLib.prefer_num (); @@ -164,28 +166,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 ⇒ @@ -239,22 +228,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) ∧ @@ -288,22 +273,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)) = @@ -1124,8 +1105,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[]) @@ -1176,7 +1160,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[]) @@ -1387,9 +1374,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 @@ -2650,7 +2635,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] @@ -2660,7 +2645,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 []) @@ -2668,13 +2653,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 [] >- ( @@ -2704,7 +2690,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 [] >- ( @@ -2734,7 +2724,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 [] >- ( @@ -2764,7 +2755,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 [] >- ( @@ -2795,7 +2789,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] @@ -2806,7 +2800,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] @@ -2817,13 +2811,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)` >> @@ -2837,27 +2831,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] @@ -2866,40 +2857,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, @@ -2918,17 +2906,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] >> @@ -2937,10 +2923,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] @@ -2951,8 +2934,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, @@ -2971,30 +2954,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] @@ -3007,7 +2982,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 ( @@ -3018,39 +2993,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]: @@ -3058,7 +3013,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 ‘ @@ -3067,7 +3022,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)’ @@ -3085,9 +3040,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 @@ -3095,9 +3050,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’ @@ -3106,14 +3061,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] @@ -3124,7 +3078,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 [] @@ -3148,12 +3102,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 @@ -3212,28 +3165,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 ⇒ @@ -3388,7 +3329,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 ec874708..fc2e0402 100644 --- a/compiler/backend/passes/proofs/pure_to_thunk_2ProofScript.sml +++ b/compiler/backend/passes/proofs/pure_to_thunk_2ProofScript.sml @@ -5,10 +5,12 @@ open HolKernel Parse boolLib bossLib term_tactic monadsyntax dep_rewrite; open stringTheory optionTheory sumTheory pairTheory listTheory alistTheory finite_mapTheory pred_setTheory rich_listTheory arithmeticTheory combinTheory - pure_semanticsTheory thunkLangTheory thunk_semanticsTheory pure_evalTheory + pure_semanticsTheory pure_evalTheory + thunkLangTheory thunk_semanticsTheory thunk_semantics_delayedTheory thunkLang_primitivesTheory pure_exp_lemmasTheory pure_miscTheory pure_to_thunk_1ProofTheory pure_cexpTheory pureLangTheory thunk_unthunkProofTheory + thunk_undelay_nextProofTheory thunk_case_liftProofTheory thunk_case_projProofTheory thunk_exp_ofTheory thunk_let_forceProofTheory @@ -121,32 +123,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 @@ -154,53 +166,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: @@ -224,6 +223,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 @@ -243,20 +256,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 @@ -264,68 +267,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 [] @@ -334,28 +326,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] @@ -378,111 +362,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 @@ -500,37 +467,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’ @@ -552,48 +511,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 @@ -605,22 +553,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 @@ -640,129 +590,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: @@ -783,26 +764,21 @@ 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 val _ = export_theory (); diff --git a/compiler/backend/passes/proofs/thunk_Delay_LamScript.sml b/compiler/backend/passes/proofs/thunk_Delay_LamScript.sml index 91b47772..4cf4c92b 100644 --- a/compiler/backend/passes/proofs/thunk_Delay_LamScript.sml +++ b/compiler/backend/passes/proofs/thunk_Delay_LamScript.sml @@ -1107,6 +1107,12 @@ Proof gvs [freevars_def, boundvars_def]) QED +Theorem v_rel_anyThunk: + ∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w) +Proof + cheat +QED + Theorem eval_to_Letrec: ∀k binds e. k ≠ 0 ⇒ eval_to k (Letrec binds e) = @@ -1367,7 +1373,7 @@ Proof \\ gs []) >~ [‘Seq x1 y1’] >- ( gvs [Once exp_rel_def, eval_to_def] - >~ [‘is_Lam _’] >- ( + >~ [‘is_Lam _’] >- cheat(*( IF_CASES_TAC \\ gs [] \\ drule_then assume_tac exp_rel_freevars >- (qexists_tac ‘0’ >> gs []) @@ -1377,7 +1383,7 @@ Proof \\ Cases_on ‘x2’ \\ gs [is_Lam_def] \\ gvs [eval_to_def, subst_def, subst1_notin_frees] \\ rename1 ‘j + _ - 1’ \\ qexists_tac ‘j + 1’ - \\ gs []) + \\ gs [])*) \\ IF_CASES_TAC \\ gs [] >- ( qexists_tac ‘0’ @@ -1408,7 +1414,7 @@ Proof \\ drule_then (qspec_then ‘j + j1 + k - 1’ assume_tac) eval_to_mono \\ gs [] \\ qexists_tac ‘j + j1’ \\ gs [] \\ Cases_on ‘eval_to (j + k - 1) x2’ \\ gs []) - >~ [‘Let (SOME m) x1 y1’] >- ( + >~ [‘Let (SOME m) x1 y1’] >- cheat (*( gvs [Once exp_rel_def, eval_to_def] >~ [‘is_Lam x1’] >- ( @@ -1457,7 +1463,7 @@ Proof \\ ‘eval_to (j + k - 1) x2 ≠ INL Diverge’ by (strip_tac \\ gs []) \\ drule_then (qspec_then ‘j + j1 + k - 1’ assume_tac) eval_to_mono \\ gs [] - \\ qexists_tac ‘j + j1’ \\ gs []) + \\ qexists_tac ‘j + j1’ \\ gs [])*) >~ [‘If x1 y1 z1’] >- ( gvs [Once exp_rel_def, eval_to_def] \\ IF_CASES_TAC \\ gs [] @@ -1923,7 +1929,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 35ee1038..24dd14f2 100644 --- a/compiler/backend/passes/proofs/thunk_Let_Delay_VarScript.sml +++ b/compiler/backend/passes/proofs/thunk_Let_Delay_VarScript.sml @@ -1794,6 +1794,12 @@ Proof fs [] QED +Theorem v_rel_anyThunk: + ∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w) +Proof + cheat +QED + Theorem exp_rel_eval_to: ∀x y. exp_rel x y ⇒ @@ -2108,7 +2114,7 @@ Proof \\ Cases_on ‘eval_to (jy + k - 1) y’ \\ Cases_on ‘eval_to (k - 1) y2’ \\ gs []) \\ qexists_tac ‘jx + jy’ \\ gvs []) - >~ [‘Let (SOME n) x y’] >- ( + >~ [‘Let (SOME n) x y’] >- cheat (*( rw [exp_rel_def] \\ gs [] >~[‘Delay (Var v1)’] >- (gvs [eval_to_def] @@ -2192,7 +2198,7 @@ Proof by (irule eval_to_mono \\ Cases_on ‘eval_to (j2 + k - 1) (subst1 n v1 y)’ \\ Cases_on ‘eval_to (k - 1) (subst1 n v2 y2)’ \\ gs []) - \\ qexists_tac ‘j1 + j2’ \\ gvs []) + \\ qexists_tac ‘j1 + j2’ \\ gvs [])*) >~ [‘Letrec f x’] >- ( rw [exp_rel_def] \\ gs [] >- (simp [eval_to_def] @@ -2288,6 +2294,8 @@ Proof 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] >> + CASE_TAC >> gvs [] + >- (cheat) >> irule v_rel_Recclosure_Delay_Var >> gvs []) >~[‘Force (Value _)’] @@ -2295,7 +2303,9 @@ Proof \\ qexists_tac ‘1’ \\ gvs [] \\ simp [Once eval_to_def] \\ gvs [dest_anyThunk_def] - \\ gvs [subst_funs_def, subst_empty, eval_to_def]) + \\ gvs [subst_funs_def, subst_empty, eval_to_def] + \\ CASE_TAC \\ gvs [] + \\ cheat) \\ rename1 ‘exp_rel x y’ \\ once_rewrite_tac [eval_to_def] \\ IF_CASES_TAC \\ gs [] @@ -2346,7 +2356,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 [] @@ -2354,7 +2365,9 @@ 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 []) + \\ cheat (* TODO v_rel_anyThunk *)) \\ rename1 ‘exp_rel x0 _’ \\ Cases_on ‘x0’ \\ gvs [exp_rel_def] \\ qexists_tac ‘j’ \\ gvs []) >- (rename1 ‘LIST_REL _ (MAP SND xs) (MAP SND ys)’ @@ -2405,7 +2418,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,7 +2428,9 @@ 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 []) + \\ cheat (* TODO v_rel_anyThunk *)) \\ qexists_tac ‘j’ \\ gvs []) >~[‘subst_funs [] y2’] >- (rename1 ‘exp_rel x2 y2’ @@ -2425,7 +2441,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 [] + \\ 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 [] @@ -2433,7 +2450,9 @@ Proof by (irule eval_to_mono \\ Cases_on ‘eval_to (j2 + k - 1) x2’ \\ Cases_on ‘eval_to (k - 1) y2’ \\ gvs []) - \\ gvs []) + \\ gvs [] + \\ rw [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) + \\ cheat (* TODO v_rel_anyThunk *)) \\ qexists_tac ‘j’ \\ gvs []) \\ Cases_on ‘v’ \\ gs [v_rel_def, exp_rel_def, PULL_EXISTS, dest_Tick_def] \\ rename1 ‘v_rel v2 w2’ @@ -2479,7 +2498,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 (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_case_liftProofScript.sml b/compiler/backend/passes/proofs/thunk_case_liftProofScript.sml index b5ba0365..1985379d 100644 --- a/compiler/backend/passes/proofs/thunk_case_liftProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_case_liftProofScript.sml @@ -13,13 +13,13 @@ open stringTheory optionTheory sumTheory pairTheory listTheory alistTheory finite_mapTheory pred_setTheory rich_listTheory thunkLangTheory thunkLang_primitivesTheory dep_rewrite wellorderTheory thunk_tickProofTheory; -open pure_miscTheory thunkLangPropsTheory; +open pure_miscTheory thunkLangPropsTheory thunk_semantics_delayedTheory; val _ = new_theory "thunk_case_liftProof"; val _ = set_grammar_ancestry [ "finite_map", "pred_set", "rich_list", "thunkLang", "wellorder", - "thunk_semantics", "thunkLangProps", + "thunk_semantics", "thunk_semantics_delayed", "thunkLangProps", "thunk_tickProof" ]; val _ = numLib.prefer_num (); @@ -520,7 +520,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 4e01c5b9..0f7cd8cc 100644 --- a/compiler/backend/passes/proofs/thunk_case_projProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_case_projProofScript.sml @@ -13,13 +13,14 @@ open stringTheory optionTheory sumTheory pairTheory listTheory alistTheory finite_mapTheory pred_setTheory rich_listTheory thunkLangTheory thunkLang_primitivesTheory dep_rewrite wellorderTheory; open pure_miscTheory thunkLangPropsTheory thunk_semanticsTheory - thunk_tickProofTheory thunk_untickProofTheory; + thunk_semantics_delayedTheory thunk_tickProofTheory + thunk_untickProofTheory; val _ = new_theory "thunk_case_projProof"; val _ = set_grammar_ancestry [ "finite_map", "pred_set", "rich_list", "thunkLang", "wellorder", - "thunkLangProps", "thunk_semantics" ]; + "thunkLangProps", "thunk_semantics", "thunk_semantics_delayed" ]; val _ = numLib.prefer_num (); @@ -85,13 +86,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:] @@ -122,7 +118,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. @@ -233,11 +229,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] @@ -551,17 +546,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, @@ -589,8 +586,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 [] @@ -766,9 +763,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]: @@ -826,7 +820,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 *) @@ -897,13 +891,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:] @@ -989,38 +978,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_let_forceProofScript.sml b/compiler/backend/passes/proofs/thunk_let_forceProofScript.sml index ffe507d7..acbaff21 100644 --- a/compiler/backend/passes/proofs/thunk_let_forceProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_let_forceProofScript.sml @@ -13,12 +13,13 @@ open HolKernel Parse boolLib bossLib term_tactic monadsyntax; open stringTheory optionTheory sumTheory pairTheory listTheory alistTheory finite_mapTheory pred_setTheory rich_listTheory thunkLangTheory thunkLang_primitivesTheory dep_rewrite wellorderTheory arithmeticTheory; -open pure_miscTheory thunkLangPropsTheory; +open pure_miscTheory thunkLangPropsTheory thunk_semantics_delayedTheory; val _ = new_theory "thunk_let_forceProof"; val _ = set_grammar_ancestry ["finite_map", "pred_set", "rich_list", - "thunkLang", "wellorder", "thunkLangProps"]; + "thunkLang", "wellorder", "thunkLangProps", + "thunk_semantics_delayed"]; Overload safe_itree = “pure_semantics$safe_itree” @@ -610,6 +611,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] @@ -1659,7 +1665,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_tickProofScript.sml b/compiler/backend/passes/proofs/thunk_tickProofScript.sml index 0f774089..143e6582 100644 --- a/compiler/backend/passes/proofs/thunk_tickProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_tickProofScript.sml @@ -6,13 +6,14 @@ open HolKernel Parse boolLib bossLib term_tactic monadsyntax; open stringTheory optionTheory sumTheory pairTheory listTheory alistTheory finite_mapTheory pred_setTheory rich_listTheory thunkLangTheory thunkLang_primitivesTheory dep_rewrite; -open pure_miscTheory thunkLangPropsTheory thunk_semanticsTheory; +open pure_miscTheory thunkLangPropsTheory thunk_semanticsTheory + thunk_semantics_delayedTheory; val _ = new_theory "thunk_tickProof"; val _ = set_grammar_ancestry [ "finite_map", "pred_set", "rich_list", "thunkLang", - "thunkLangProps", "thunk_semantics" ]; + "thunkLangProps", "thunk_semantics", "thunk_semantics_delayed"]; Theorem SUM_REL_THM[local,simp] = sumTheory.SUM_REL_THM; @@ -279,7 +280,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]) @@ -858,7 +860,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 f930d6c5..bbc31672 100644 --- a/compiler/backend/passes/proofs/thunk_to_env_1ProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_to_env_1ProofScript.sml @@ -492,7 +492,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..0abcfe91 --- /dev/null +++ b/compiler/backend/passes/proofs/thunk_undelay_nextProofScript.sml @@ -0,0 +1,1464 @@ +open HolKernel Parse boolLib bossLib term_tactic monadsyntax intLib; +open stringTheory optionTheory sumTheory pairTheory listTheory alistTheory + finite_mapTheory pred_setTheory rich_listTheory; +open pure_miscTheory pure_configTheory pure_semanticsTheory + thunkLang_primitivesTheory thunkLangTheory thunkLangPropsTheory + thunk_semanticsTheory thunk_semantics_delayedTheory; + +val _ = new_theory "thunk_undelay_nextProof"; + +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 [] + \\ 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 + +val _ = export_theory (); diff --git a/compiler/backend/passes/proofs/thunk_unthunkProofScript.sml b/compiler/backend/passes/proofs/thunk_unthunkProofScript.sml index d63f8c05..4cf1cdd5 100644 --- a/compiler/backend/passes/proofs/thunk_unthunkProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_unthunkProofScript.sml @@ -8,12 +8,13 @@ open stringTheory optionTheory sumTheory pairTheory listTheory alistTheory finite_mapTheory pred_setTheory rich_listTheory thunkLangTheory thunkLang_primitivesTheory dep_rewrite; open pure_miscTheory thunkLangPropsTheory thunk_semanticsTheory - thunk_untickProofTheory; + thunk_semantics_delayedTheory thunk_untickProofTheory; val _ = new_theory "thunk_unthunkProof"; val _ = set_grammar_ancestry ["finite_map", "pred_set", "rich_list", - "thunkLang", "thunk_semantics", "thunkLangProps"]; + "thunkLang", "thunk_semantics", + "thunk_semantics_delayed", "thunkLangProps"]; val _ = numLib.prefer_num (); @@ -36,7 +37,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. @@ -91,6 +93,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 ⇒ @@ -117,7 +123,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 ∧ @@ -150,7 +156,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. @@ -163,7 +169,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)) ∧ @@ -221,11 +229,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). @@ -272,7 +291,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. @@ -298,7 +318,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 ∧ @@ -318,7 +338,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] @@ -340,7 +361,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 ∧ @@ -408,8 +430,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 @@ -493,17 +513,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] @@ -553,12 +583,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 [] @@ -568,20 +600,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’ @@ -593,33 +632,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: @@ -660,6 +856,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 *) @@ -676,26 +873,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’ @@ -722,7 +934,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]) @@ -747,23 +968,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 *) @@ -773,7 +1037,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 [] >- ( @@ -885,8 +1162,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: @@ -935,6 +1211,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 @@ -947,10 +1224,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 @@ -977,50 +1255,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 (* ------------------------------------------------------------------------- @@ -1056,11 +1333,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). @@ -1131,13 +1419,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 @@ -1198,17 +1492,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 9ccae1f9..a837844e 100644 --- a/compiler/backend/passes/proofs/thunk_untickProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_untickProofScript.sml @@ -7,12 +7,14 @@ open HolKernel Parse boolLib bossLib term_tactic monadsyntax; open stringTheory optionTheory sumTheory pairTheory listTheory alistTheory finite_mapTheory pred_setTheory rich_listTheory thunkLangTheory thunkLang_primitivesTheory dep_rewrite; -open pure_miscTheory thunkLangPropsTheory thunk_semanticsTheory; +open pure_miscTheory thunkLangPropsTheory thunk_semanticsTheory + thunk_semantics_delayedTheory; val _ = new_theory "thunk_untickProof"; val _ = set_grammar_ancestry ["finite_map", "pred_set", "rich_list", - "thunkLang", "thunkLangProps"]; + "thunkLang", "thunkLangProps", + "thunk_semantics_delayed"]; Theorem SUM_REL_THM[local,simp] = sumTheory.SUM_REL_THM; @@ -81,6 +83,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 ⇒ @@ -113,8 +120,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 ∧ @@ -409,6 +418,34 @@ Proof \\ 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 ∧ @@ -1027,7 +1064,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 @@ -1082,6 +1123,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 [] @@ -1502,4 +1599,77 @@ Proof \\ 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 + val _ = export_theory (); From ae71b07b6dfd49867c785dea8ce69e31179f9ade Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Sun, 20 Apr 2025 21:46:14 +0300 Subject: [PATCH 20/42] Proved a cheat in stateLangScript and removed `rec_env` as a duplicate of `mk_rec_env` --- .../languages/semantics/stateLangScript.sml | 85 +++++++++++++----- .../proofs/state_unthunkProofScript.sml | 86 ++++++++++--------- 2 files changed, 108 insertions(+), 63 deletions(-) diff --git a/compiler/backend/languages/semantics/stateLangScript.sml b/compiler/backend/languages/semantics/stateLangScript.sml index f529c884..65cc3e85 100644 --- a/compiler/backend/languages/semantics/stateLangScript.sml +++ b/compiler/backend/languages/semantics/stateLangScript.sml @@ -1311,13 +1311,6 @@ Proof \\ fs [] QED -Theorem step'_n_set_cont: - 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 - cheat -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) @@ -1371,6 +1364,26 @@ Proof \\ full_simp_tac std_ss [step_n_add,step_n_SUC] \\ gvs [] 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]: ∀v st k' sr k x y z. return v st k' = (x,y,z) ∧ (is_halt (x,y,z) ⇒ ∃v. x = Val v) ∧ k' ≼ k ⇒ @@ -1581,10 +1594,34 @@ Proof step_def,return_def,error_def] QED -Definition rec_env_def: (* TODO: remove dup with mk_rec_env *) - rec_env f env = - MAP (λ(fn,_). (fn,Recclosure f env fn)) f ++ env -End +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 Theorem add_to_avoid: ∀m x k v v1. @@ -1596,23 +1633,27 @@ Proof QED Theorem step'_n_INSERT: - step'_n m avoid (Exp (rec_env x1 y0) y1,NONE,[]) = (Val v,NONE,[]) ∧ + 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 (rec_env x1 y0) y1,NONE,[]) = (Val v,NONE,[]) + 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 []) + >- ( + ‘v1 INSERT avoid = avoid’ by ( + gvs [pred_setTheory.EXTENSION] \\ metis_tac []) + \\ gvs []) \\ strip_tac - \\ Cases_on ‘∃n ts. step'_n n avoid (Exp (rec_env x1 y0) y1,NONE,[]) = + \\ Cases_on ‘∃n ts. step'_n n avoid (Exp (mk_rec_env x1 y0) y1,NONE,[]) = (Val v1,NONE,ForceK1::ts)’ \\ gvs [] - >- - (dxrule step'_n_set_cont \\ gvs [] \\ strip_tac + >- ( + dxrule step'_n_append_cont \\ gvs [] \\ strip_tac \\ ‘∀k2. ∃k3. - step'_n (n+1) avoid (Exp (rec_env x1 y0) y1,NONE,k2) = - (Exp (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,rec_env_def]) + 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 [] \\ cheat (* this case leads to contradiction because one can take n+1 steps diff --git a/compiler/backend/passes/proofs/state_unthunkProofScript.sml b/compiler/backend/passes/proofs/state_unthunkProofScript.sml index 5e4a518f..464b1f6e 100644 --- a/compiler/backend/passes/proofs/state_unthunkProofScript.sml +++ b/compiler/backend/passes/proofs/state_unthunkProofScript.sml @@ -328,10 +328,10 @@ Definition thunk_rel_def: | INL tv => (∃sv. v_rel p tv sv ∧ v = ThunkMem Evaluated sv) | INR (tenv,te) => (∃senv se. - env_rel p (rec_env f tenv) senv ∧ compile_rel te 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 (rec_env f tenv) te,NONE,[]) = (Val tv,NONE,[]) ∧ + step_n ck (Exp (mk_rec_env f tenv) te,NONE,[]) = (Val tv,NONE,[]) ∧ v = ThunkMem Evaluated sv ∧ v_rel p tv sv) End @@ -477,7 +477,7 @@ QED Theorem state_rel_INR: state_rel p ts (SOME ss) ∧ - env_rel p (rec_env f env1) env2 ∧ + 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 @@ -630,10 +630,11 @@ Theorem dest_anyThunk_INR: ∃loc. v2 = Atom (Loc loc) ∧ ((∃senv se. - env_rel p (rec_env f x1) senv ∧ compile_rel x2 se ∧ + 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 (rec_env f x1) x2,NONE,[]) = (Val tv,NONE,[]) ∧ - oEL loc ss = SOME (ThunkMem Evaluated sv) ∧ v_rel p tv sv) + ∃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()]) @@ -721,7 +722,7 @@ Theorem state_rel_LUPDATE_anyThunk: v_rel p res v2 ∧ state_rel p ts (SOME ss2) ∧ v_rel p v1 (Atom (Loc loc)) ∧ dest_anyThunk v1 = SOME (INR (tenv1,te),f) ∧ - step_n n (Exp (rec_env f tenv1) te,NONE,[]) = (Val res,NONE,[]) ⇒ + 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 [] @@ -1713,17 +1714,18 @@ Theorem state_rel_Letrec: (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)) ∧ + (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)) (rec_env tfns env1) - (rec_env funs (make_let_env delays (LENGTH ss) env2)) + (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 [] @@ -1843,7 +1845,7 @@ 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 @@ -1903,11 +1905,12 @@ Theorem state_rel_LUPDATE_anyThunk': v_rel p res v2 ∧ state_rel p ts (SOME ss2) ∧ v_rel p v1 (Atom (Loc loc)) ∧ dest_anyThunk v1 = SOME (INR (tenv1,te),f) ∧ - step'_n n avoid (Exp (rec_env f tenv1) te,NONE,[]) = (Val res,NONE,[]) ⇒ + 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 \\ gvs [] + \\ drule_all (state_rel_LUPDATE_anyThunk |> REWRITE_RULE [mk_rec_env_def]) + \\ gvs [] QED Triviality LIST_REL_lemma: @@ -1990,11 +1993,11 @@ Proof \\ PairCases_on ‘y’ \\ fs [] \\ drule_all dest_anyThunk_INR \\ reverse strip_tac \\ gvs [] >- - (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 [] @@ -2006,12 +2009,13 @@ Proof \\ rpt $ first_assum $ irule_at Any \\ gvs [SF SFY_ss]) \\ Cases_on ‘v1 ∈ avoid’ \\ gvs [] - \\ gvs [GSYM rec_env_def,get_atoms_def] + \\ 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 \\ strip_tac + \\ 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] @@ -2048,7 +2052,7 @@ Proof \\ 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) + \\ 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,step'_def,return'_def] @@ -2277,7 +2281,7 @@ Proof (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] + \\ 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 @@ -2328,7 +2332,7 @@ Proof \\ 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 @@ -2337,10 +2341,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 [] @@ -2379,8 +2382,8 @@ Proof \\ 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 @@ -2437,7 +2440,7 @@ Proof \\ PairCases_on ‘y’ \\ drule_all dest_anyThunk_INR \\ reverse strip_tac \\ gvs [] >- - (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)’ @@ -2456,16 +2459,16 @@ Proof \\ 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 @@ -2476,7 +2479,8 @@ Proof \\ simp [step] \\ gvs [] \\ pop_assum mp_tac \\ drule_then assume_tac step_n_IMP_step'_n - \\ drule_all step'_n_INSERT \\ strip_tac + \\ 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] @@ -2515,7 +2519,8 @@ Proof \\ 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] @@ -2703,7 +2708,7 @@ Proof \\ 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] + \\ 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’] >- @@ -2738,16 +2743,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] + \\ 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) @@ -2764,15 +2769,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,_). 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 From b2dcc52fb3db3e2847046fa35cc24434958cfdb6 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Mon, 21 Apr 2025 16:33:18 +0300 Subject: [PATCH 21/42] Proved remaining cheats in stateLangScript --- .../languages/semantics/stateLangScript.sml | 91 +++++++++++++------ 1 file changed, 65 insertions(+), 26 deletions(-) diff --git a/compiler/backend/languages/semantics/stateLangScript.sml b/compiler/backend/languages/semantics/stateLangScript.sml index 65cc3e85..61d7bd67 100644 --- a/compiler/backend/languages/semantics/stateLangScript.sml +++ b/compiler/backend/languages/semantics/stateLangScript.sml @@ -1558,6 +1558,18 @@ 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 @@ -1623,13 +1635,51 @@ Proof \\ 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 x k v v1. - step'_n m avoid (x,NONE,k) = (Val v,NONE,[]) ∧ - (∀n ts. step'_n n avoid (x,NONE,k) ≠ (Val v1,NONE,ForceK1::ts)) ⇒ - step'_n m (v1 INSERT avoid) (x,NONE,k) = (Val v,NONE,[]) + ∀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 - cheat + 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: @@ -1644,8 +1694,8 @@ Proof gvs [pred_setTheory.EXTENSION] \\ metis_tac []) \\ gvs []) \\ strip_tac - \\ Cases_on ‘∃n ts. step'_n n avoid (Exp (mk_rec_env x1 y0) y1,NONE,[]) = - (Val v1,NONE,ForceK1::ts)’ \\ gvs [] + \\ 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. @@ -1656,24 +1706,13 @@ Proof \\ 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 [] - \\ cheat (* this case leads to contradiction because one can take n+1 steps - to arrive at (Exp (rec_env x1 y0) y1,NONE,...) and then n+1 steps - again and again and again withput terminating. This means that - eventually m steps will be exceeded which means assumption 0 is false *)) - \\ cheat (* this case the goal is provable, since assumption 2 states that we - will never encounter the (Val v1,NONE,ForceK1::...) which is the - only configuration that can lead to an attempt to force v1 *) -QED - -Theorem step_n'_mono: - ∀n 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] + \\ 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': @@ -1681,7 +1720,7 @@ Theorem is_halt_imp_eq': 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] + \\ metis_tac [step'_n_mono] QED Theorem step'_n_fast_forward_gen: From 2876a6ab487078bf5547c59b0f2a1614f4809029 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Sat, 26 Apr 2025 12:03:06 +0300 Subject: [PATCH 22/42] Fixed `Delay_Lam` and `Let_Delay_Var` proofs --- .../passes/proofs/pure_to_cakeProofScript.sml | 1 + .../proofs/pure_to_thunkProofScript.sml | 14 +- .../passes/proofs/thunk_Delay_LamScript.sml | 153 +- .../proofs/thunk_Let_Delay_VarScript.sml | 1311 +++++++++++------ .../thunk_split_Delay_LamProofScript.sml | 2 + 5 files changed, 1032 insertions(+), 449 deletions(-) diff --git a/compiler/backend/passes/proofs/pure_to_cakeProofScript.sml b/compiler/backend/passes/proofs/pure_to_cakeProofScript.sml index a3da9fd2..da9a1306 100644 --- a/compiler/backend/passes/proofs/pure_to_cakeProofScript.sml +++ b/compiler/backend/passes/proofs/pure_to_cakeProofScript.sml @@ -28,6 +28,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 fe911904..e94f68d2 100644 --- a/compiler/backend/passes/proofs/pure_to_thunkProofScript.sml +++ b/compiler/backend/passes/proofs/pure_to_thunkProofScript.sml @@ -656,6 +656,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))) @@ -696,17 +697,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) ∧ @@ -723,8 +727,12 @@ 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/thunk_Delay_LamScript.sml b/compiler/backend/passes/proofs/thunk_Delay_LamScript.sml index 4cf4c92b..6881993f 100644 --- a/compiler/backend/passes/proofs/thunk_Delay_LamScript.sml +++ b/compiler/backend/passes/proofs/thunk_Delay_LamScript.sml @@ -1110,7 +1110,101 @@ QED Theorem v_rel_anyThunk: ∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w) Proof - cheat + ‘(∀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: @@ -1373,7 +1467,7 @@ Proof \\ gs []) >~ [‘Seq x1 y1’] >- ( gvs [Once exp_rel_def, eval_to_def] - >~ [‘is_Lam _’] >- cheat(*( + >~ [‘is_Lam _’] >- ( IF_CASES_TAC \\ gs [] \\ drule_then assume_tac exp_rel_freevars >- (qexists_tac ‘0’ >> gs []) @@ -1383,7 +1477,7 @@ Proof \\ Cases_on ‘x2’ \\ gs [is_Lam_def] \\ gvs [eval_to_def, subst_def, subst1_notin_frees] \\ rename1 ‘j + _ - 1’ \\ qexists_tac ‘j + 1’ - \\ gs [])*) + \\ gs []) \\ IF_CASES_TAC \\ gs [] >- ( qexists_tac ‘0’ @@ -1414,7 +1508,7 @@ Proof \\ drule_then (qspec_then ‘j + j1 + k - 1’ assume_tac) eval_to_mono \\ gs [] \\ qexists_tac ‘j + j1’ \\ gs [] \\ Cases_on ‘eval_to (j + k - 1) x2’ \\ gs []) - >~ [‘Let (SOME m) x1 y1’] >- cheat (*( + >~ [‘Let (SOME m) x1 y1’] >- ( gvs [Once exp_rel_def, eval_to_def] >~ [‘is_Lam x1’] >- ( @@ -1463,7 +1557,7 @@ Proof \\ ‘eval_to (j + k - 1) x2 ≠ INL Diverge’ by (strip_tac \\ gs []) \\ drule_then (qspec_then ‘j + j1 + k - 1’ assume_tac) eval_to_mono \\ gs [] - \\ qexists_tac ‘j + j1’ \\ gs [])*) + \\ qexists_tac ‘j + j1’ \\ gs []) >~ [‘If x1 y1 z1’] >- ( gvs [Once exp_rel_def, eval_to_def] \\ IF_CASES_TAC \\ gs [] @@ -1612,7 +1706,7 @@ Proof \\ 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] >> @@ -1654,8 +1748,8 @@ Proof 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 >> - cheat) >> + 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] >> @@ -1663,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 [] >> @@ -1701,7 +1795,7 @@ 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)` >> 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) @@ -1733,7 +1827,7 @@ Proof gvs []) >> qexists_tac ‘j1’ >> gvs [] >> rw [oneline sum_bind_def] >> rpt (CASE_TAC >> gvs []) >> - cheat (* TODO v_rel y' y'' ⇒ is_anyThunk y'' *)) + 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, @@ -1751,10 +1845,10 @@ Proof Cases_on ‘eval_to (k - 1) (subst_funs binds y1)’ >> 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 [] >> + 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 []) >> - cheat)) + 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 @@ -1770,16 +1864,24 @@ Proof \\ gvs [] \\ rename1 ‘exp_rel x0 _’ \\ Cases_on ‘x0’ \\ gvs [exp_rel_def] - \\ Cases_on `eval_to (k - 1) (subst_funs ys y')` \\ gvs [] + \\ Cases_on ‘eval_to (k - 1) (subst_funs ys y')’ \\ gvs [] \\ rpt (IF_CASES_TAC \\ gvs []) - >>~- ([`is_anyThunk`], + >>~- ([‘is_anyThunk’], last_x_assum $ qspecl_then [‘e’, ‘binds’, ‘subst_funs ys y'`] mp_tac \\ simp [] \\ rpt strip_tac - >- cheat (* impl_tac below *) - \\ `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 [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 + \\ last_x_assum $ qspecl_then [‘e’, ‘binds’, ‘subst_funs ys y'’] mp_tac \\ simp [] \\ rename1 ‘_ (INL Diverge) (eval_to _ (subst_funs binds2 y2))’ \\ impl_tac @@ -1799,7 +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 [] + \\ ‘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’ @@ -1811,9 +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)` + \\ 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 @@ -1837,7 +1938,7 @@ Proof \\ strip_tac \\ Cases_on ‘eval_to (k - 1) (subst_funs binds y1)’ \\ gs []) \\ gvs [] \\ rw [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') ∧ exp_rel wx wx' ∧ @@ -1893,7 +1994,7 @@ Proof \\ CASE_TAC \\ gs [] \\ Cases_on ‘v1’ \\ Cases_on ‘w1’ \\ gvs [dest_anyThunk_def] \\ rw [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]) diff --git a/compiler/backend/passes/proofs/thunk_Let_Delay_VarScript.sml b/compiler/backend/passes/proofs/thunk_Let_Delay_VarScript.sml index 24dd14f2..8690b7a5 100644 --- a/compiler/backend/passes/proofs/thunk_Let_Delay_VarScript.sml +++ b/compiler/backend/passes/proofs/thunk_Let_Delay_VarScript.sml @@ -1797,12 +1797,101 @@ QED Theorem v_rel_anyThunk: ∀v w. v_rel v w ⇒ (is_anyThunk v ⇔ is_anyThunk w) Proof - cheat + ‘(∀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’ @@ -1811,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 [] >- ( @@ -1855,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 [] @@ -1866,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’ @@ -1884,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)’ @@ -1895,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 [] @@ -1906,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 [] @@ -1953,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 [] @@ -1967,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)]) @@ -2020,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’ @@ -2051,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 [] @@ -2061,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 [] @@ -2070,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 [] @@ -2093,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’ @@ -2114,9 +2290,9 @@ Proof \\ Cases_on ‘eval_to (jy + k - 1) y’ \\ Cases_on ‘eval_to (k - 1) y2’ \\ gs []) \\ qexists_tac ‘jx + jy’ \\ gvs []) - >~ [‘Let (SOME n) x y’] >- cheat (*( + >~ [‘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 []) @@ -2126,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 [] @@ -2144,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’ @@ -2175,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’ @@ -2198,7 +2406,7 @@ Proof by (irule eval_to_mono \\ Cases_on ‘eval_to (j2 + k - 1) (subst1 n v1 y)’ \\ Cases_on ‘eval_to (k - 1) (subst1 n v2 y2)’ \\ gs []) - \\ qexists_tac ‘j1 + j2’ \\ gvs [])*) + \\ qexists_tac ‘j1 + j2’ \\ gvs []) >~ [‘Letrec f x’] >- ( rw [exp_rel_def] \\ gs [] >- (simp [eval_to_def] @@ -2206,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 @@ -2225,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’] >- ( @@ -2236,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 [] @@ -2246,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 [] >- ( @@ -2254,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 [] >- ( @@ -2273,47 +2521,62 @@ 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] >> - CASE_TAC >> gvs [] - >- (cheat) >> + 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] - \\ gvs [subst_funs_def, subst_empty, eval_to_def] - \\ CASE_TAC \\ gvs [] - \\ cheat) + \\ gvs [subst_funs_def, subst_empty, eval_to_def]) \\ rename1 ‘exp_rel x y’ \\ once_rewrite_tac [eval_to_def] \\ 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 [] @@ -2323,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) @@ -2333,23 +2596,36 @@ 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’ @@ -2367,7 +2643,13 @@ Proof \\ Cases_on ‘eval_to (k - 1) (subst_funs ys e2)’ \\ gvs []) \\ gvs [] \\ rw [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) - \\ cheat (* TODO v_rel_anyThunk *)) + >- ( + 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)’ @@ -2405,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 [] @@ -2430,11 +2724,28 @@ Proof (replace_Force (Var v2) v1 e2))’ \\ gvs []) \\ gvs [] \\ rw [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) - \\ cheat (* TODO v_rel_anyThunk *)) + >- ( + 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’ @@ -2443,22 +2754,39 @@ Proof \\ Cases_on ‘eval_to (k - 1) x2 = INL Diverge’ \\ 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 [] - \\ ‘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 []) - \\ cheat (* TODO v_rel_anyThunk *)) + \\ 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 [] @@ -2478,323 +2806,466 @@ 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] - \\ rpt (CASE_TAC \\ gvs []) + \\ 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 [result_map_def, MEM_EL, PULL_EXISTS, EL_MAP, SF CONJ_ss] - \\ IF_CASES_TAC \\ gs [] + \\ 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] + \\ first_x_assum (drule_all_then assume_tac) + \\ first_x_assum (drule_then drule) + \\ disch_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) + \\ first_x_assum (drule_all_then assume_tac) + \\ first_x_assum + (drule_then (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 []) - >- (rename1 ‘eval_to _ _ = INR v3’ \\ Cases_on ‘v3’ \\ gvs []) - >- (rpt $ first_x_assum $ qspecl_then [‘n’] assume_tac - \\ rename1 ‘eval_to _ _ = INR v3’ \\ Cases_on ‘v3’ \\ gvs [])) - \\ ‘∀n. n < LENGTH ys ⇒ - ∃x. eval_to k (EL n ys) = INR (Atom x)’ - by (rw [] + \\ 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 [] + >- ( + first_x_assum (drule_all_then assume_tac) + \\ last_x_assum $ qspec_then ‘k - 1’ assume_tac \\ gvs [] + \\ pop_assum drule + \\ impl_tac >- (first_x_assum irule \\ gvs []) + \\ strip_tac + \\ gs [Abbr ‘f’] + \\ first_x_assum (drule_then assume_tac) + \\ Cases_on ‘eval_to (j + k - 1) (EL m xs)’ \\ gs []) + \\ fs [DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”] + \\ first_x_assum (drule_all_then assume_tac) + \\ last_x_assum $ qspec_then ‘k - 1’ assume_tac \\ gvs [] + \\ pop_assum drule + \\ impl_tac >- (first_x_assum irule \\ gvs []) + \\ strip_tac + \\ gs [Abbr ‘f’] \\ 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 + \\ Cases_on ‘eval_to (j + k - 1) (EL m xs)’ \\ gs [] + \\ first_x_assum (drule_then (qspec_then ‘j’ assume_tac)) \\ gs [] + \\ rename1 ‘v_rel v w’ + \\ Cases_on ‘v’ \\ Cases_on ‘w’ \\ gs [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 [] @@ -2821,19 +3292,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 @@ -2843,8 +3317,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] @@ -2856,62 +3331,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 @@ -3386,16 +3856,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_split_Delay_LamProofScript.sml b/compiler/backend/passes/proofs/thunk_split_Delay_LamProofScript.sml index efa54461..aa12cb11 100644 --- a/compiler/backend/passes/proofs/thunk_split_Delay_LamProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_split_Delay_LamProofScript.sml @@ -3600,6 +3600,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 @@ -3624,6 +3625,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 From 98c22f08795ae9a86897a70d19ebfc2c1aa4a09b Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Tue, 29 Apr 2025 00:12:20 +0300 Subject: [PATCH 23/42] Merged master and updated HOL version. Need to check that `pure_lexer_impl` change is correct. `pure_demands_analysisProof` fails due to changes in HOL and needs fixing. HOL commit 48a676cadda70ad7fc2f6c7b17ecd434f84db113. Cake commit 270490bcc6fcf81c10361fdc2cd750058f84df46. --- .../proofs/state_to_cakeProofScript.sml | 26 +++++++------- .../proofs/thunk_Let_Delay_VarScript.sml | 35 +++++++------------ .../proofs/thunk_undelay_nextProofScript.sml | 1 + .../backend/passes/state_to_cakeScript.sml | 8 ++--- compiler/parsing/pure_lexer_implScript.sml | 2 +- 5 files changed, 32 insertions(+), 40 deletions(-) diff --git a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml index 98d4bdd3..a6388544 100644 --- a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml +++ b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml @@ -212,10 +212,10 @@ Inductive op_rel: op_rel Length Alength ∧ op_rel Sub Asub ∧ op_rel Update Aupdate ∧ - op_rel (AllocMutThunk Evaluated) (ThunkOp $ AllocThunk F) ∧ - op_rel (AllocMutThunk NotEvaluated) (ThunkOp $ AllocThunk T) ∧ - op_rel (UpdateMutThunk Evaluated) (ThunkOp $ UpdateThunk F) ∧ - op_rel (UpdateMutThunk NotEvaluated) (ThunkOp $ UpdateThunk T) ∧ + op_rel (AllocMutThunk Evaluated) (ThunkOp $ AllocThunk T) ∧ + op_rel (AllocMutThunk NotEvaluated) (ThunkOp $ AllocThunk F) ∧ + op_rel (UpdateMutThunk Evaluated) (ThunkOp $ UpdateThunk T) ∧ + op_rel (UpdateMutThunk NotEvaluated) (ThunkOp $ UpdateThunk F) ∧ op_rel ForceMutThunk (ThunkOp ForceThunk) End @@ -606,8 +606,8 @@ End Definition store_rel_def: store_rel cnenv (Array svs) (Varray cvs) = LIST_REL (v_rel cnenv) svs cvs ∧ - store_rel cnenv (ThunkMem Evaluated sv) (Thunk F cv) = v_rel cnenv sv cv ∧ - store_rel cnenv (ThunkMem NotEvaluated sv) (Thunk T cv) = v_rel cnenv sv cv ∧ + store_rel cnenv (ThunkMem Evaluated sv) (Thunk T cv) = v_rel cnenv sv cv ∧ + store_rel cnenv (ThunkMem NotEvaluated sv) (Thunk F cv) = v_rel cnenv sv cv ∧ store_rel cnenv _ _ = F End @@ -738,9 +738,9 @@ Theorem capplication_thm: (case vs of [Loc _ n] => ( case store_lookup n s of - SOME (Thunk F v) => + SOME (Thunk T v) => return env s fp v c - | SOME (Thunk T f) => + | SOME (Thunk F f) => application Opapp env s fp [f; Conv NONE []] ((Cforce n,env)::c) | _ => Etype_error (fix_fp_state c fp)) @@ -939,7 +939,7 @@ Proof QED Theorem store_lookup_assign_Thunk: - store_lookup n st = SOME (Thunk T a) ⇒ + store_lookup n st = SOME (Thunk F a) ⇒ store_assign n (Thunk b y) st = SOME $ LUPDATE (Thunk b y) n st Proof @@ -2606,10 +2606,10 @@ Inductive csop_rel: csop_rel Length Alength ∧ csop_rel Sub Asub ∧ csop_rel Update Aupdate ∧ - csop_rel (AllocMutThunk Evaluated) (ThunkOp $ AllocThunk F) ∧ - csop_rel (AllocMutThunk NotEvaluated) (ThunkOp $ AllocThunk T) ∧ - csop_rel (UpdateMutThunk Evaluated) (ThunkOp $ UpdateThunk F) ∧ - csop_rel (UpdateMutThunk NotEvaluated) (ThunkOp $ UpdateThunk T) ∧ + csop_rel (AllocMutThunk Evaluated) (ThunkOp $ AllocThunk T) ∧ + csop_rel (AllocMutThunk NotEvaluated) (ThunkOp $ AllocThunk F) ∧ + csop_rel (UpdateMutThunk Evaluated) (ThunkOp $ UpdateThunk T) ∧ + csop_rel (UpdateMutThunk NotEvaluated) (ThunkOp $ UpdateThunk F) ∧ csop_rel ForceMutThunk (ThunkOp ForceThunk) End diff --git a/compiler/backend/passes/proofs/thunk_Let_Delay_VarScript.sml b/compiler/backend/passes/proofs/thunk_Let_Delay_VarScript.sml index 8690b7a5..4336882e 100644 --- a/compiler/backend/passes/proofs/thunk_Let_Delay_VarScript.sml +++ b/compiler/backend/passes/proofs/thunk_Let_Delay_VarScript.sml @@ -2852,9 +2852,8 @@ Proof \\ gs [result_map_def, CaseEq "bool", MEM_MAP] \\ gs [Once (DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”)] \\ gvs [MEM_EL, PULL_EXISTS] - \\ first_x_assum (drule_all_then assume_tac) - \\ first_x_assum (drule_then drule) - \\ disch_then (qx_choose_then ‘j’ assume_tac) + \\ 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 [] \\ fs [Once (DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”)] @@ -2866,9 +2865,8 @@ Proof \\ 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) - \\ first_x_assum (drule_all_then assume_tac) - \\ first_x_assum - (drule_then (drule_then (qx_choose_then ‘j’ assume_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 []) @@ -3123,26 +3121,19 @@ Proof \\ rename1 ‘m < LENGTH ys’ \\ Cases_on ‘eval_to (k - 1) (EL m ys)’ \\ gvs [] >- ( - first_x_assum (drule_all_then assume_tac) + rpt $ first_x_assum (drule_all_then assume_tac) \\ last_x_assum $ qspec_then ‘k - 1’ assume_tac \\ gvs [] - \\ pop_assum drule - \\ impl_tac >- (first_x_assum irule \\ gvs []) - \\ strip_tac - \\ gs [Abbr ‘f’] - \\ first_x_assum (drule_then assume_tac) - \\ Cases_on ‘eval_to (j + k - 1) (EL m xs)’ \\ gs []) + \\ pop_assum drule_all \\ rw [] \\ strip_tac + \\ Cases_on ‘eval_to (j' + k - 1) (EL m xs)’ \\ gvs []) \\ fs [DECIDE “A ⇒ ¬B ⇔ B ⇒ ¬A”] - \\ first_x_assum (drule_all_then assume_tac) + \\ rpt $ first_x_assum (drule_all_then assume_tac) \\ last_x_assum $ qspec_then ‘k - 1’ assume_tac \\ gvs [] - \\ pop_assum drule - \\ impl_tac >- (first_x_assum irule \\ gvs []) - \\ strip_tac - \\ gs [Abbr ‘f’] - \\ first_x_assum (drule_then assume_tac) - \\ Cases_on ‘eval_to (j + k - 1) (EL m xs)’ \\ gs [] - \\ first_x_assum (drule_then (qspec_then ‘j’ assume_tac)) \\ gs [] + \\ 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’ \\ gs [v_rel_def]) + \\ Cases_on ‘v’ \\ Cases_on ‘w’ \\ gvs [v_rel_def]) \\ ‘∃j. ∀n. n < LENGTH ys ⇒ ($= +++ v_rel) (eval_to (j + k - 1) (EL n xs)) (eval_to (k - 1) (EL n ys))’ diff --git a/compiler/backend/passes/proofs/thunk_undelay_nextProofScript.sml b/compiler/backend/passes/proofs/thunk_undelay_nextProofScript.sml index 0abcfe91..bf674aa3 100644 --- a/compiler/backend/passes/proofs/thunk_undelay_nextProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_undelay_nextProofScript.sml @@ -614,6 +614,7 @@ Proof \\ 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 [] diff --git a/compiler/backend/passes/state_to_cakeScript.sml b/compiler/backend/passes/state_to_cakeScript.sml index 66b2ed49..640702b0 100644 --- a/compiler/backend/passes/state_to_cakeScript.sml +++ b/compiler/backend/passes/state_to_cakeScript.sml @@ -274,10 +274,10 @@ Definition compile_op_def: compile_op Sub = CakeOp Asub ∧ compile_op Update = CakeOp Aupdate ∧ compile_op Alloc = TwoArgs alloc ∧ - compile_op (AllocMutThunk Evaluated) = CakeOp $ ThunkOp $ AllocThunk F ∧ - compile_op (AllocMutThunk NotEvaluated) = CakeOp $ ThunkOp $ AllocThunk T ∧ - compile_op (UpdateMutThunk Evaluated) = CakeOp $ ThunkOp $ UpdateThunk F ∧ - compile_op (UpdateMutThunk NotEvaluated) = CakeOp $ ThunkOp $ UpdateThunk T ∧ + compile_op (AllocMutThunk Evaluated) = CakeOp $ ThunkOp $ AllocThunk T ∧ + compile_op (AllocMutThunk NotEvaluated) = CakeOp $ ThunkOp $ AllocThunk F ∧ + compile_op (UpdateMutThunk Evaluated) = CakeOp $ ThunkOp $ UpdateThunk T ∧ + compile_op (UpdateMutThunk NotEvaluated) = CakeOp $ ThunkOp $ UpdateThunk F ∧ compile_op ForceMutThunk = CakeOp $ ThunkOp ForceThunk ∧ compile_op _ = Other End diff --git a/compiler/parsing/pure_lexer_implScript.sml b/compiler/parsing/pure_lexer_implScript.sml index eacaa890..2f353643 100644 --- a/compiler/parsing/pure_lexer_implScript.sml +++ b/compiler/parsing/pure_lexer_implScript.sml @@ -421,7 +421,7 @@ Definition token_of_sym_def: | NumberS i => IntT i | WordS n => WordT n | LongS s => let (s1,s2) = SPLITP (\x. x = #".") s in - LongidT s1 (case s2 of "" => "" | (c::cs) => cs) + LongidT (Mod s1 End) (case s2 of "" => "" | (c::cs) => cs) | FFIS s => FFIT s | OtherS s => get_token s End From c99346aa2b4509b368f72d40c3508fcf53c54f6c Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Tue, 29 Apr 2025 13:55:04 +0300 Subject: [PATCH 24/42] Fixed state-to-cake pass to account for the new thunk representation in cake. `pure_demands_analysisProof` needs fix. HOL commit 48a676cadda70ad7fc2f6c7b17ecd434f84db113 cake commit 2ef8c9fe897bd690a4c42e65b4c19b3bd461e58a --- .../proofs/state_to_cakeProofScript.sml | 39 ++++++++++--------- .../backend/passes/state_to_cakeScript.sml | 12 ++++-- 2 files changed, 29 insertions(+), 22 deletions(-) diff --git a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml index a6388544..878ded18 100644 --- a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml +++ b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml @@ -212,10 +212,10 @@ Inductive op_rel: op_rel Length Alength ∧ op_rel Sub Asub ∧ op_rel Update Aupdate ∧ - op_rel (AllocMutThunk Evaluated) (ThunkOp $ AllocThunk T) ∧ - op_rel (AllocMutThunk NotEvaluated) (ThunkOp $ AllocThunk F) ∧ - op_rel (UpdateMutThunk Evaluated) (ThunkOp $ UpdateThunk T) ∧ - op_rel (UpdateMutThunk NotEvaluated) (ThunkOp $ UpdateThunk F) ∧ + 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 @@ -606,8 +606,10 @@ End Definition store_rel_def: store_rel cnenv (Array svs) (Varray cvs) = LIST_REL (v_rel cnenv) svs cvs ∧ - store_rel cnenv (ThunkMem Evaluated sv) (Thunk T cv) = v_rel cnenv sv cv ∧ - store_rel cnenv (ThunkMem NotEvaluated sv) (Thunk F cv) = v_rel cnenv sv cv ∧ + store_rel cnenv (ThunkMem Evaluated sv) (Thunk Evaluated cv) = + v_rel cnenv sv cv ∧ + store_rel cnenv (ThunkMem NotEvaluated sv) (Thunk NotEvaluated cv) = + v_rel cnenv sv cv ∧ store_rel cnenv _ _ = F End @@ -738,9 +740,9 @@ Theorem capplication_thm: (case vs of [Loc _ n] => ( case store_lookup n s of - SOME (Thunk T v) => + SOME (Thunk Evaluated v) => return env s fp v c - | SOME (Thunk F f) => + | SOME (Thunk NotEvaluated f) => application Opapp env s fp [f; Conv NONE []] ((Cforce n,env)::c) | _ => Etype_error (fix_fp_state c fp)) @@ -939,9 +941,9 @@ Proof QED Theorem store_lookup_assign_Thunk: - store_lookup n st = SOME (Thunk F a) ⇒ - store_assign n (Thunk b y) st = - SOME $ LUPDATE (Thunk b y) n st + 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 @@ -1775,7 +1777,8 @@ Proof 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] + gvs[store_rel_def] >> + Cases_on `t'` >> gvs[store_rel_def] ) >- ( first_assum $ irule_at Any >> @@ -1884,7 +1887,7 @@ Proof disch_then $ qspec_then `n` assume_tac >> gvs[] >> simp [thunk_op_def] >> gvs[] >> Cases_on `z` >> gvs[store_rel_def] >> - Cases_on `b` >> gvs[store_rel_def] >> + Cases_on `t'` >> gvs[store_rel_def] >> drule store_lookup_assign_Thunk >> rw[] >> qexists0 >> reverse $ rw[step_rel_cases] >- gvs[state_rel, LUPDATE_DEF, store_lookup_def] >> @@ -1897,7 +1900,7 @@ Proof 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 `b` >> gvs[store_rel_def] >> + Cases_on `t'` >> gvs[store_rel_def] >> rw[EL_CONS, PRE_SUB1] >> qexists0 >> reverse $ rw[step_rel_cases, store_lookup_def] >- (goal_assum drule >> gvs[state_rel, LIST_REL_EL_EQN]) @@ -2606,10 +2609,10 @@ Inductive csop_rel: csop_rel Length Alength ∧ csop_rel Sub Asub ∧ csop_rel Update Aupdate ∧ - csop_rel (AllocMutThunk Evaluated) (ThunkOp $ AllocThunk T) ∧ - csop_rel (AllocMutThunk NotEvaluated) (ThunkOp $ AllocThunk F) ∧ - csop_rel (UpdateMutThunk Evaluated) (ThunkOp $ UpdateThunk T) ∧ - csop_rel (UpdateMutThunk NotEvaluated) (ThunkOp $ UpdateThunk F) ∧ + 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 diff --git a/compiler/backend/passes/state_to_cakeScript.sml b/compiler/backend/passes/state_to_cakeScript.sml index 640702b0..79d2cb97 100644 --- a/compiler/backend/passes/state_to_cakeScript.sml +++ b/compiler/backend/passes/state_to_cakeScript.sml @@ -274,10 +274,14 @@ Definition compile_op_def: compile_op Sub = CakeOp Asub ∧ compile_op Update = CakeOp Aupdate ∧ compile_op Alloc = TwoArgs alloc ∧ - compile_op (AllocMutThunk Evaluated) = CakeOp $ ThunkOp $ AllocThunk T ∧ - compile_op (AllocMutThunk NotEvaluated) = CakeOp $ ThunkOp $ AllocThunk F ∧ - compile_op (UpdateMutThunk Evaluated) = CakeOp $ ThunkOp $ UpdateThunk T ∧ - compile_op (UpdateMutThunk NotEvaluated) = CakeOp $ ThunkOp $ UpdateThunk F ∧ + 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 From 0b050f7d4cc3b2e1a9276fe76840fd8ce53fd239 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 21 Aug 2025 02:28:20 +0300 Subject: [PATCH 25/42] Update for HOL changes --- .gitignore | 1 + .../pure_demands_analysisProofScript.sml | 17 ++++--- .../proofs/pure_to_thunk_1ProofScript.sml | 2 +- .../proofs/state_to_cakeProofScript.sml | 4 +- .../proofs/state_unthunkProofScript.sml | 2 +- .../proofs/thunk_Let_Lam_ForcedScript.sml | 49 ++++++++++++++----- .../proofs/thunk_case_d2bProofScript.sml | 7 ++- .../proofs/thunk_let_forceProofScript.sml | 2 +- .../thunk_split_Delay_LamProofScript.sml | 18 ++++--- meta-theory/pure_alpha_equivScript.sml | 3 +- typing/pure_typingScript.sml | 3 +- 11 files changed, 73 insertions(+), 35 deletions(-) diff --git a/.gitignore b/.gitignore index b2db2263..cde28ca4 100644 --- a/.gitignore +++ b/.gitignore @@ -8,6 +8,7 @@ *.o .HOLMK .hollogs +.hol # Sample sample-code/cake diff --git a/compiler/backend/passes/proofs/pure_demands_analysisProofScript.sml b/compiler/backend/passes/proofs/pure_demands_analysisProofScript.sml index f447f5da..a5f8497e 100644 --- a/compiler/backend/passes/proofs/pure_demands_analysisProofScript.sml +++ b/compiler/backend/passes/proofs/pure_demands_analysisProofScript.sml @@ -89,7 +89,8 @@ Theorem FOLDL_delete_ok: Proof Induct_on ‘LENGTH vL’ >> rw [] >> rename1 ‘SUC _ = LENGTH vL’ >> - qspecl_then [‘vL’] assume_tac last_exists >> gvs [FOLDL_APPEND, delete_thm] + qspecl_then [‘vL’] assume_tac last_exists >> + gvs [FOLDL_APPEND, SNOC_APPEND, delete_thm] QED Theorem FOLDL_delete_soundness: @@ -101,7 +102,7 @@ Proof Induct_on ‘LENGTH vL’ >> rw [] >> rename1 ‘SUC _ = LENGTH vL’ >> qspecl_then [‘vL’] assume_tac last_exists >> - gvs [FOLDL_APPEND, delete_thm] >> + gvs [FOLDL_APPEND, SNOC_APPEND, delete_thm] >> simp [SET_EQ_SUBSET, SUBSET_DEF] QED @@ -142,7 +143,7 @@ Theorem demands_map_FOLDL_delete: Proof Induct_on ‘LENGTH vL’ >> rw [] >> rename1 ‘SUC _ = LENGTH vL’ >> - qspecl_then [‘vL’] assume_tac last_exists >> gvs [FOLDL_APPEND] + qspecl_then [‘vL’] assume_tac last_exists >> gvs [FOLDL_APPEND, SNOC_APPEND] >- (irule demands_map_delete2 >> gvs [FOLDL_delete_ok]) >> irule demands_map_delete >> @@ -222,7 +223,7 @@ Theorem fdemands_map_FOLDL_delete: Proof Induct_on ‘LENGTH vL’ >> rw [] >> rename1 ‘SUC _ = LENGTH vL’ >> - qspecl_then [‘vL’] assume_tac last_exists >> gvs [FOLDL_APPEND] + qspecl_then [‘vL’] assume_tac last_exists >> gvs [FOLDL_APPEND, SNOC_APPEND] >- (irule fdemands_map_delete2 >> gvs [FOLDL_delete_ok]) >> irule fdemands_map_delete >> @@ -2360,7 +2361,8 @@ QED Theorem MAPi_implode_MAP_explode: ∀l. MAPi (λi v. (i, implode v)) (MAP explode l) = MAPi (λi v. (i,v)) l Proof - Induct using SNOC_INDUCT \\ gvs [MAP_SNOC, indexedListsTheory.MAPi_APPEND] + Induct using SNOC_INDUCT + \\ gvs [MAP_SNOC, SNOC_APPEND, indexedListsTheory.MAPi_APPEND] QED Theorem find_rows_of_inner: @@ -2444,7 +2446,7 @@ Proof QED Theorem find_subset_aid: - ∀d ps v. (ps, v) ∈ d ⇒ ∃ps'. (ps ++ ps', v) ∈ d + ∀d (ps : 'a list) v. (ps, v) ∈ d ⇒ ∃ps'. (ps ++ ps', v) ∈ d Proof rw [] >> qexists_tac ‘[]’ >> gvs [] QED @@ -3568,7 +3570,8 @@ Proof \\ qpat_x_assum ‘_ ≠ _’ kall_tac \\ qpat_x_assum ‘_ ∈ _’ kall_tac \\ qpat_x_assum ‘¬MEM _ _’ mp_tac \\ qid_spec_tac ‘x’ - \\ Induct_on ‘args’ using SNOC_INDUCT \\ gs [delete_thm, FOLDL_APPEND] + \\ Induct_on ‘args’ using SNOC_INDUCT + \\ gs [delete_thm, FOLDL_APPEND, SNOC_APPEND] \\ rw [] \\ gs [delete_thm] \\ simp [FOLDL_delete_soundness, delete_thm, DOMSUB_FAPPLY_NEQ]) >- ((* handling the optional fall-through expression at the bottom *) diff --git a/compiler/backend/passes/proofs/pure_to_thunk_1ProofScript.sml b/compiler/backend/passes/proofs/pure_to_thunk_1ProofScript.sml index 31abdd41..cb6a8be5 100644 --- a/compiler/backend/passes/proofs/pure_to_thunk_1ProofScript.sml +++ b/compiler/backend/passes/proofs/pure_to_thunk_1ProofScript.sml @@ -343,7 +343,7 @@ Triviality LIST_REL_ALOOKUP_REVERSE_IMP: Proof Induct using SNOC_INDUCT \\ fs [] \\ strip_tac \\ Cases using SNOC_CASES - \\ fs [LIST_REL_SNOC,REVERSE_SNOC] + \\ fs [LIST_REL_SNOC,REVERSE_SNOC,MAP_SNOC] \\ rename [‘FST a = FST b’] \\ PairCases_on ‘a’ \\ PairCases_on ‘b’ \\ fs [] \\ rw [] \\ fs [] diff --git a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml index 878ded18..87e110f7 100644 --- a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml +++ b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml @@ -1876,7 +1876,7 @@ Proof pairarg_tac >> gvs[store_alloc_def] >> qexists0 >> reverse $ rw[step_rel_cases] >- gvs[state_rel, store_lookup_def] >> - qexists `cnenv` >> gvs[state_rel] >> + qexists `cnenv` >> gvs[state_rel, SNOC_APPEND] >> imp_res_tac LIST_REL_LENGTH >> rw[store_rel_def]) >>~- ([`UpdateMutThunk`], `LENGTH l0 = 1` by gvs [] >> gvs[LENGTH_EQ_NUM_compute] >> @@ -2234,7 +2234,7 @@ Proof ) >- ( (* Alloc - ready to evaluate *) last_x_assum $ qspec_then `1` assume_tac >> gvs[sstep] >> - TOP_CASE_TAC >> gvs[] >> + TOP_CASE_TAC >> gvs[SNOC_APPEND] >> ntac 7 (qrefine `SUC n` >> simp[cstep_n_def, cstep]) >> simp[do_app_def, opb_lookup_def] >> IF_CASES_TAC >> gvs[] >> diff --git a/compiler/backend/passes/proofs/state_unthunkProofScript.sml b/compiler/backend/passes/proofs/state_unthunkProofScript.sml index 8df9bf91..ff5c7130 100644 --- a/compiler/backend/passes/proofs/state_unthunkProofScript.sml +++ b/compiler/backend/passes/proofs/state_unthunkProofScript.sml @@ -1155,7 +1155,7 @@ Proof \\ irule_at Any v_rel_Ref \\ simp [] \\ gvs [state_rel_def] \\ imp_res_tac LIST_REL_LENGTH - \\ gvs [GSYM ZIP_APPEND,FILTER_APPEND] + \\ 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]) diff --git a/compiler/backend/passes/proofs/thunk_Let_Lam_ForcedScript.sml b/compiler/backend/passes/proofs/thunk_Let_Lam_ForcedScript.sml index 7a81ee74..a6f3f242 100644 --- a/compiler/backend/passes/proofs/thunk_Let_Lam_ForcedScript.sml +++ b/compiler/backend/passes/proofs/thunk_Let_Lam_ForcedScript.sml @@ -1011,7 +1011,7 @@ Proof qspecl_then [‘eL’] assume_tac SNOC_CASES >> gvs [ADD1] >> rename1 ‘SNOC v vL’ >> Cases_on ‘vL’ >> gvs [] >- gvs [eval_to_def, dest_anyClosure_def] >> - gvs [FOLDR_SNOC, FOLDL_APPEND, eval_to_def] >> + gvs [FOLDR_SNOC, FOLDL_MAP, FOLDL_SNOC, eval_to_def] >> rename1 ‘SUC (LENGTH vL) = LENGTH eL’ >> first_x_assum $ qspecl_then [‘eL’, ‘Lam v e’, ‘k’] assume_tac >> gvs [subst_def, eval_to_def, dest_anyClosure_def] >> @@ -1050,7 +1050,7 @@ Proof qspecl_then [‘l’, ‘subst1 s e1 e2’, ‘{s}’] assume_tac subst_remove >> gvs [freevars_subst]) >> gvs []) >> - gvs [FOLDR_SNOC, FOLDL_APPEND, eval_to_def] >> + gvs [FOLDR_SNOC, FOLDL_MAP, FOLDL_SNOC, eval_to_def] >> rename1 ‘SUC (LENGTH vL) = LENGTH eL’ >> first_x_assum $ qspecl_then [‘eL’, ‘Lam s e’, ‘k’, ‘list’, ‘v’] assume_tac >> gvs [subst_def, eval_to_def, dest_anyClosure_def] >> @@ -1082,7 +1082,7 @@ Proof qspecl_then [‘eL’] assume_tac SNOC_CASES >> gvs [ADD1] >> rename1 ‘SNOC v vL’ >> Cases_on ‘vL’ >> gvs [] >- (gvs [eval_to_def, dest_anyClosure_def]) >> - gvs [FOLDR_SNOC, FOLDL_APPEND, eval_to_def] + gvs [FOLDR_SNOC, FOLDL_MAP, FOLDL_SNOC, eval_to_def] QED Theorem eval_to_Apps_APPEND1: @@ -2228,7 +2228,8 @@ Proof \\ first_x_assum $ qspec_then ‘v3’ assume_tac \\ gvs [MAP_ZIP]) \\ gvs [] \\ once_rewrite_tac [CONS_APPEND] \\ gvs [] - \\ Q.REFINE_EXISTS_TAC ‘SNOC _ _’ \\ gvs [LIST_REL_SNOC, PULL_EXISTS] + \\ Q.REFINE_EXISTS_TAC ‘SNOC _ _’ + \\ gvs [LIST_REL_SNOC, PULL_EXISTS, SNOC_APPEND] \\ irule_at (Pos $ el 2) EQ_REFL \\ first_assum $ irule_at $ Pos last \\ gvs [] \\ first_assum $ irule_at $ Pos last \\ gvs [] @@ -4530,13 +4531,16 @@ Proof \\ dxrule_then (qspec_then ‘j + k’ assume_tac) eval_to_mono \\ Cases_on ‘eval_to k y’ \\ gvs [] \\ Cases_on ‘eval_to (k - 1) (subst_funs ys y2) = INL Diverge’ \\ gvs [] - \\ dxrule_then (qspec_then ‘j1 + k - 1’ assume_tac) eval_to_mono \\ gvs []) + \\ dxrule_then (qspec_then ‘j1 + k - 1’ assume_tac) eval_to_mono \\ gvs [] + \\ simp [oneline sum_bind_def] \\ CASE_TAC \\ gvs []) \\ qexists_tac ‘j + j1’ \\ ‘eval_to (j + k) y ≠ INL Diverge’ by gvs [] \\ dxrule_then (qspec_then ‘j + j1 + k’ assume_tac) eval_to_mono \\ gvs [] \\ ‘eval_to (j1 + k - 1) (subst_funs ys y2) ≠ INL Diverge’ 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 []) + \\ 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 *)) >- (gvs [dest_anyThunk_def, v_rel_def] \\ rename1 ‘LIST_REL _ (MAP SND xs) (MAP SND ys)’ @@ -4599,7 +4603,8 @@ Proof \\ once_rewrite_tac [CONS_APPEND] \\ gvs [] \\ rename1 ‘($= +++ v_rel) _ (eval_to _ expr)’ \\ Cases_on ‘eval_to (k - 1) expr = INL Diverge’ \\ gvs [] - \\ dxrule_then (qspec_then ‘j1 + k - 1’ assume_tac) eval_to_mono \\ gvs []) + \\ dxrule_then (qspec_then ‘j1 + k - 1’ assume_tac) eval_to_mono \\ gvs [] + \\ simp [oneline sum_bind_def] \\ CASE_TAC \\ gvs []) \\ qexists_tac ‘j + j1’ \\ qspecl_then [‘k + j’, ‘y’, ‘j + j1 + k’] assume_tac eval_to_mono \\ gvs [REVERSE_SNOC] @@ -4610,7 +4615,9 @@ Proof \\ ‘eval_to (j1 + k - 1) expr ≠ INL Diverge’ by (strip_tac \\ Cases_on ‘eval_to (k - 1) (subst_funs binds e)’ \\ gvs []) \\ dxrule_then (qspec_then ‘j + j1 + k - 1’ assume_tac) eval_to_mono - \\ gvs []) + \\ gvs [] + \\ simp [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) + \\ cheat (* TODO v_rel_anyThunk *)) >- (gvs [dest_anyThunk_def, v_rel_def] \\ rename1 ‘LIST_REL _ (MAP SND xs) (MAP SND ys)’ @@ -4674,7 +4681,8 @@ Proof \\ once_rewrite_tac [CONS_APPEND] \\ gvs [] \\ rename1 ‘($= +++ v_rel) _ (eval_to _ expr)’ \\ Cases_on ‘eval_to (k - 1) expr = INL Diverge’ \\ gvs [] - \\ dxrule_then (qspec_then ‘j1 + k - 1’ assume_tac) eval_to_mono \\ gvs []) + \\ dxrule_then (qspec_then ‘j1 + k - 1’ assume_tac) eval_to_mono \\ gvs [] + \\ simp [oneline sum_bind_def] \\ CASE_TAC \\ gvs []) \\ qexists_tac ‘j + j1’ \\ qspecl_then [‘k + j’, ‘y’, ‘j + j1 + k’] assume_tac eval_to_mono \\ gvs [REVERSE_SNOC] @@ -4686,7 +4694,9 @@ Proof \\ ‘eval_to (j1 + k - 1) expr ≠ INL Diverge’ by (strip_tac \\ Cases_on ‘eval_to (k - 1) (subst_funs binds e)’ \\ gvs []) \\ dxrule_then (qspec_then ‘j + j1 + k - 1’ assume_tac) eval_to_mono - \\ gvs []) + \\ gvs [] + \\ simp [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) + \\ cheat (* TODO v_rel_anyThunk *)) \\ rename1 ‘dest_anyThunk v1 = INR (wx, binds)’ \\ ‘∃wx' binds'. dest_anyThunk w1 = INR (wx', binds') ∧ force_arg_rel wx wx' ∧ @@ -4718,7 +4728,8 @@ Proof \\ reverse CASE_TAC >- ( Cases_on ‘v1’ \\ Cases_on ‘w1’ \\ gvs [dest_anyThunk_def]) - \\ qexists_tac ‘j2’ \\ gs []) + \\ qexists_tac ‘j2’ \\ gs [] + \\ simp [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 []) @@ -4727,7 +4738,11 @@ 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, subst_funs_def] + \\ simp [oneline sum_bind_def] \\ rpt (CASE_TAC \\ gvs []) + \\ cheat (* TODO v_rel_anyThunk *))) \\ 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]) @@ -4768,7 +4783,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] + \\ rw [v_rel_def] + \\ ( + 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 *))) \\ gvs [result_map_def, MEM_EL, PULL_EXISTS, EL_MAP, SF CONJ_ss] \\ IF_CASES_TAC \\ gs [] >- ( @@ -5231,6 +5252,7 @@ Proof \\ disj2_tac \\ disj2_tac \\ disj2_tac \\ disj2_tac \\ disj2_tac \\ disj1_tac \\ ‘HD (vL1 ++ [s3] ++ vL2) = HD (vL1 ++ [s3])’ by (Cases_on ‘vL1’ \\ gvs []) \\ gvs [] + \\ once_rewrite_tac [CONS_APPEND] \\ gvs [] \\ irule_at (Pos hd) EQ_REFL \\ gvs [subst_Lams] \\ ‘∀l1 l2 e1 e2. l1 = l2 ∧ e1 = e2 ⇒ Lams l1 e1 = Lams l2 e2’ by gvs [] @@ -5373,6 +5395,7 @@ Proof \\ disj2_tac \\ disj2_tac \\ disj2_tac \\ disj2_tac \\ disj2_tac \\ disj2_tac \\ disj1_tac \\ ‘HD (vL1 ++ [s3] ++ vL2) = HD (vL1 ++ [s3])’ by (Cases_on ‘vL1’ \\ gvs []) \\ gvs [] + \\ once_rewrite_tac [CONS_APPEND] \\ gvs [] \\ irule_at (Pos hd) EQ_REFL \\ gvs [subst_Lams] \\ ‘∀l1 l2 e1 e2. l1 = l2 ∧ e1 = e2 ⇒ Lams l1 e1 = Lams l2 e2’ by gvs [] diff --git a/compiler/backend/passes/proofs/thunk_case_d2bProofScript.sml b/compiler/backend/passes/proofs/thunk_case_d2bProofScript.sml index 948e61ac..17ce0e5a 100644 --- a/compiler/backend/passes/proofs/thunk_case_d2bProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_case_d2bProofScript.sml @@ -1302,7 +1302,12 @@ 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 [] + \\ rw [EVERY_EL] + \\ ( + gvs [LIST_REL_EL_EQN] + \\ ntac 2 (first_x_assum drule \\ rw []) + \\ cheat (* TODO v_rel_anyThunk *))) \\ ‘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_let_forceProofScript.sml b/compiler/backend/passes/proofs/thunk_let_forceProofScript.sml index 47f36308..3c53552e 100644 --- a/compiler/backend/passes/proofs/thunk_let_forceProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_let_forceProofScript.sml @@ -290,7 +290,7 @@ Theorem ALOOKUP_REVERSE_REVERSE: Proof Induct using SNOC_INDUCT \\ rw [] \\ Cases_on ‘ws’ using SNOC_CASES - \\ fs [REVERSE_SNOC] + \\ fs [MAP_SNOC, REVERSE_SNOC] \\ rename [‘FST z = FST t’] \\ PairCases_on ‘z’ \\ PairCases_on ‘t’ diff --git a/compiler/backend/passes/proofs/thunk_split_Delay_LamProofScript.sml b/compiler/backend/passes/proofs/thunk_split_Delay_LamProofScript.sml index e04a50a2..884c3bbc 100644 --- a/compiler/backend/passes/proofs/thunk_split_Delay_LamProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_split_Delay_LamProofScript.sml @@ -241,7 +241,8 @@ Proof Cases_on ‘e’ \\ gvs [dest_Var_def, exp_of_def, AllCaseEqs()] >~[‘Apps _ _’] >- (rename1 ‘Apps _ (MAP _ l)’ - \\ qspec_then ‘l’ assume_tac SNOC_CASES \\ gvs [cexp_wf_def, FOLDL_APPEND]) + \\ qspec_then ‘l’ assume_tac SNOC_CASES + \\ gvs [cexp_wf_def, MAP_SNOC, FOLDL_SNOC]) >~[‘Lams _ _’] >- (rename1 ‘Lams (MAP _ l) _’ \\ Cases_on ‘l’ \\ gvs [cexp_wf_def, FOLDL_APPEND]) @@ -521,7 +522,7 @@ Theorem FOLDL_delete_ok: Proof Induct_on ‘LENGTH vL’ >> rw [] >> rename1 ‘SUC _ = LENGTH vL’ >> - qspec_then ‘vL’ assume_tac SNOC_CASES >> gvs [FOLDL_APPEND, delete_thm] + qspec_then ‘vL’ assume_tac SNOC_CASES >> gvs [FOLDL_SNOC, delete_thm] QED Theorem FRANGE_FOLDL_delete: @@ -894,7 +895,7 @@ Proof unfold_Delay_Lam_def, is_Lam_def, dest_Delay_Lam_def] >- (rename1 ‘Apps _ (MAP _ l)’ \\ qspec_then ‘l’ assume_tac SNOC_CASES - \\ gs [exp_rel1_def, exp_rel2_def, is_Lam_def, FOLDL_APPEND]) + \\ gs [exp_rel1_def, exp_rel2_def, is_Lam_def, FOLDL_MAP, FOLDL_SNOC]) >- (rename1 ‘rows_of _ (MAP _ l) (OPTION_MAP _ fall)’ \\ Cases_on ‘l’ \\ gs [exp_rel1_def, exp_rel2_def, is_Lam_def, FOLDL_APPEND, rows_of_def] @@ -919,7 +920,7 @@ Proof unfold_Delay_Lam_def, is_Lam_def, dest_Delay_Lam_def] >- (rename1 ‘Apps _ (MAP _ l)’ \\ qspec_then ‘l’ assume_tac SNOC_CASES - \\ gs [exp_rel1_def, is_Lam_def, FOLDL_APPEND]) + \\ gs [exp_rel1_def, is_Lam_def, FOLDL_MAP, FOLDL_SNOC]) >- (rename1 ‘rows_of _ (MAP _ l) (OPTION_MAP _ fall)’ \\ Cases_on ‘l’ \\ fs [] \\ gs [exp_rel1_def, is_Lam_def, FOLDL_APPEND, rows_of_def] @@ -940,6 +941,7 @@ Proof \\ qspec_then ‘vL’ assume_tac SNOC_CASES \\ gs [LIST_REL_SNOC, MAP_SNOC] \\ once_rewrite_tac [ADD_SYM] \\ gs [GSYM arithmeticTheory.SUC_ONE_ADD, GENLIST, GSYM ZIP_APPEND] + \\ gvs [ZIP_SNOC, SNOC_APPEND] \\ simp [MAP2_APPEND, LIST_REL_EL_EQN] \\ rw [] \\ once_rewrite_tac [GSYM LIST_REL_eq] @@ -1838,7 +1840,8 @@ Proof \\ rename1 ‘cexp_ok_bind e2’ \\ Cases_on ‘e2’ \\ gs [cexp_wf_def, cexp_ok_bind_def] >- (rename1 ‘Apps _ (MAP _ list)’ - \\ qspec_then ‘list’ assume_tac SNOC_CASES \\ gs [exp_of_def, FOLDL_APPEND]) + \\ qspec_then ‘list’ assume_tac SNOC_CASES + \\ gs [exp_of_def, FOLDL_MAP, FOLDL_SNOC]) >- (rename1 ‘rows_of _ (MAP _ list) (OPTION_MAP _ fall)’ \\ Cases_on ‘list’ \\ gs [rows_of_def, FOLDL_APPEND] \\ pairarg_tac \\ gs [rows_of_def])) @@ -1846,7 +1849,8 @@ Proof \\ rename1 ‘cexp_ok_bind e2’ \\ Cases_on ‘e2’ \\ gs [cexp_wf_def, cexp_ok_bind_def] >- (rename1 ‘Apps _ (MAP _ list)’ - \\ qspec_then ‘list’ assume_tac SNOC_CASES \\ gs [exp_of_def, FOLDL_APPEND]) + \\ qspec_then ‘list’ assume_tac SNOC_CASES + \\ gs [exp_of_def, FOLDL_MAP, FOLDL_SNOC]) >- (rename1 ‘rows_of _ (MAP _ list) (OPTION_MAP _ fall)’ \\ Cases_on ‘list’ \\ gs [rows_of_def, FOLDL_APPEND] \\ pairarg_tac \\ gs [rows_of_def]))) @@ -3574,7 +3578,7 @@ Proof \\ Cases_on ‘e’ \\ gvs [exp_rel1_def, dest_Var_def, exp_of_def] >- (rename1 ‘Apps _ (MAP _ l)’ \\ qspec_then ‘l’ assume_tac SNOC_CASES - \\ gvs [FOLDL_APPEND, exp_rel1_def, cexp_wf_def]) + \\ gvs [FOLDL_MAP, FOLDL_SNOC, exp_rel1_def, cexp_wf_def]) >- (rename1 ‘Lams (MAP _ l) _’ \\ Cases_on ‘l’ \\ gvs [exp_rel1_def, cexp_wf_def]) diff --git a/meta-theory/pure_alpha_equivScript.sml b/meta-theory/pure_alpha_equivScript.sml index f175e54e..70749b0a 100644 --- a/meta-theory/pure_alpha_equivScript.sml +++ b/meta-theory/pure_alpha_equivScript.sml @@ -906,7 +906,8 @@ Proof QED Triviality APPEND_EQ_IMP: - a = b ∧ c = d ⇒ a ++ c = b ++ d + ∀(a : 'a list) b c d. + a = b ∧ c = d ⇒ a ++ c = b ++ d Proof rw[] QED diff --git a/typing/pure_typingScript.sml b/typing/pure_typingScript.sml index a4053984..fd80715b 100644 --- a/typing/pure_typingScript.sml +++ b/typing/pure_typingScript.sml @@ -223,7 +223,8 @@ Definition namespace_ok_def: MEM («Subscript»,[]) exndef End -Overload append_ns = ``λns ns'. (FST ns ++ FST ns', SND ns ++ SND ns')``; +Overload append_ns = ``λ(ns : exndef # typedefs) ns'. + (FST ns ++ FST ns', SND ns ++ SND ns')``; Definition namespace_init_ok_def: namespace_init_ok ns ⇔ From 0d6a3a1cde7489d320de3c3981ee2d76cd0340bd Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Tue, 26 Aug 2025 20:59:26 +0300 Subject: [PATCH 26/42] Small fix after master merge --- .../backend/passes/proofs/state_to_cakeProofScript.sml | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml index 37571934..93b459cb 100644 --- a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml +++ b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml @@ -738,12 +738,11 @@ Theorem capplication_thm: [Loc _ n] => ( case store_lookup n s of SOME (Thunk Evaluated v) => - return env s fp v c + return env s v c | SOME (Thunk NotEvaluated f) => - application Opapp env s fp [f; Conv NONE []] ((Cforce n,env)::c) - | _ => - Etype_error (fix_fp_state c fp)) - | _ => Etype_error (fix_fp_state c fp)) + application Opapp env s [f; Conv NONE []] ((Cforce n,env)::c) + | _ => Etype_error) + | _ => Etype_error) else case get_ffi_ch op of | SOME n => ( case get_ffi_args vs of From f446cb7639093cf5a7dd56a356302f2d24cb8e6d Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Wed, 27 Aug 2025 01:06:31 +0300 Subject: [PATCH 27/42] Fixed `thunk_Let_Lam_ForceTheory` for force changes --- .../proofs/thunk_Let_Lam_ForcedScript.sml | 93 ++++++++++++++++++- 1 file changed, 88 insertions(+), 5 deletions(-) diff --git a/compiler/backend/passes/proofs/thunk_Let_Lam_ForcedScript.sml b/compiler/backend/passes/proofs/thunk_Let_Lam_ForcedScript.sml index a6f3f242..f812c9f3 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 [] >- ( From bbf5d0555bb51b7cdfcb7d27f7d420ee33550975 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Wed, 27 Aug 2025 12:06:06 +0300 Subject: [PATCH 28/42] Fix `thunk_case_inl` and `thunk_remove_unuseful_bindings` --- .../passes/proofs/thunk_case_inlProofScript.sml | 15 ++++++++++++++- .../thunk_remove_unuseful_bindingsScript.sml | 7 ++++++- 2 files changed, 20 insertions(+), 2 deletions(-) diff --git a/compiler/backend/passes/proofs/thunk_case_inlProofScript.sml b/compiler/backend/passes/proofs/thunk_case_inlProofScript.sml index 71f93ea3..bb976e5d 100644 --- a/compiler/backend/passes/proofs/thunk_case_inlProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_case_inlProofScript.sml @@ -760,7 +760,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_remove_unuseful_bindingsScript.sml b/compiler/backend/passes/proofs/thunk_remove_unuseful_bindingsScript.sml index ef5373df..2109907d 100644 --- a/compiler/backend/passes/proofs/thunk_remove_unuseful_bindingsScript.sml +++ b/compiler/backend/passes/proofs/thunk_remove_unuseful_bindingsScript.sml @@ -1063,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 [] >- ( From 6379781615219cf5d9fe873e90e2480d588b844f Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Wed, 27 Aug 2025 12:14:31 +0300 Subject: [PATCH 29/42] thunk_case_d2b --- compiler/backend/passes/proofs/thunk_case_d2bProofScript.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/backend/passes/proofs/thunk_case_d2bProofScript.sml b/compiler/backend/passes/proofs/thunk_case_d2bProofScript.sml index 17ce0e5a..b89d8567 100644 --- a/compiler/backend/passes/proofs/thunk_case_d2bProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_case_d2bProofScript.sml @@ -1307,7 +1307,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 From c0b9022b4a561ce9dd2e9f7703699f1034c319b0 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Mon, 1 Sep 2025 01:22:36 +0300 Subject: [PATCH 30/42] Fixes for HOL changes --- compiler/backend/passes/proofs/thunk_to_env_1ProofScript.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/backend/passes/proofs/thunk_to_env_1ProofScript.sml b/compiler/backend/passes/proofs/thunk_to_env_1ProofScript.sml index 8af39887..8e615a6c 100644 --- a/compiler/backend/passes/proofs/thunk_to_env_1ProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_to_env_1ProofScript.sml @@ -251,7 +251,7 @@ Proof gs [subst_def, exp_rel_def, EVERY2_MAP, FILTER_FILTER, LAMBDA_PROD, MAP_MAP_o, combinTheory.o_DEF, GSYM FST_THM, FILTER_APPEND_DISTRIB] \\ first_x_assum (irule_at Any) - \\ qabbrev_tac ‘P = λn. ¬MEM n (MAP FST f)’ \\ gs [] + \\ qabbrev_tac ‘P = λn. ¬MEM n (MAP FST f')’ \\ gs [] \\ gs [MAP_FST_FILTER, MEM_FILTER, FILTER_FILTER, DISJ_EQ_IMP, LAMBDA_PROD] \\ gs [SF CONJ_ss, AC CONJ_COMM CONJ_ASSOC, env_rel_def, GSYM FILTER_REVERSE] From 54a5d980bd70231aabd84d36b4d0a99ae24a4d20 Mon Sep 17 00:00:00 2001 From: Hrutvik Kanabar Date: Fri, 14 Feb 2025 12:44:52 +0000 Subject: [PATCH 31/42] Remove recursion of `application` stateLang --- .../languages/semantics/stateLangScript.sml | 313 +++++++++++++++--- 1 file changed, 264 insertions(+), 49 deletions(-) diff --git a/compiler/backend/languages/semantics/stateLangScript.sml b/compiler/backend/languages/semantics/stateLangScript.sml index 61d7bd67..194283f4 100644 --- a/compiler/backend/languages/semantics/stateLangScript.sml +++ b/compiler/backend/languages/semantics/stateLangScript.sml @@ -346,7 +346,10 @@ Definition application_def: case oEL n stores of SOME (ThunkMem Evaluated v) => value v st k | SOME (ThunkMem NotEvaluated f) => - application AppOp [f; Constructor "" []] st (ForceMutK n :: k) + value + f + st + (AppK [] AppOp [Constructor "" []] [] :: ForceMutK n :: k) | _ => error st k) | _ => error st k) ∧ application (FFI channel) vs st k = ( @@ -1101,7 +1104,7 @@ 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) + ∃k. k2 = k ++ k1 ∧ ∀k3. step ts (k0::k3) te = (x0,x1,k ++ k3) Proof Cases_on ‘te’ \\ fs [step_def] \\ fs [error_def] >~ [‘Exp l e’] >- @@ -1187,6 +1190,7 @@ Proof \\ gvs [continue_def,value_def,push_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) ∧ @@ -1310,58 +1314,258 @@ Proof \\ rewrite_tac [FUNPOW_ADD,FUNPOW] \\ fs [] QED +*) + +Theorem step_inc_cont': + step ts (k0 ++ k1) te = (x0,x1,k2) ∧ 0 < LENGTH k0 ∧ LENGTH (k0 ++ k1) < LENGTH k2 ⇒ + ∃k. k2 = k ++ k1 ∧ ∀k3. step ts (k0 ++ k3) te = (x0,x1,k ++ 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’ >> gvs[continue_def, push_def, step_def] >> + FULL_CASE_TAC >> gvs[continue_def, push_def] + ) >> + rw[] >> Cases_on ‘k0’ >> gvs[] >> + 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, continue_def, value_def, push_def] +QED + +Theorem step_dec_cont': + step ts k1 te = (x0,x1,k2) ∧ LENGTH k2 < LENGTH k1 ⇒ + ∃k. LENGTH k ≥ 1 ∧ k1 = k ++ k2 ∧ ∀k3. step ts (k ++ k3) te = (x0,x1,k3) +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] >> + rw[AllCaseEqs()] >> gvs[step_def, continue_def, push_def, return_def] + ) >> + simp[Once $ oneline return_def] >> + rw[AllCaseEqs()] >> gvs[error_def, return_def, continue_def, value_def] >> + simp[APPEND_EQ_CONS, SF DNF_ss, return_def] >> + Cases_on ‘sop’ >> gvs[num_args_ok_def, LENGTH_EQ_NUM_compute] >> + gvs[application_def, value_def, error_def, return_def, continue_def, AllCaseEqs()] +QED + +Theorem step_eq_cont': + step ts (k ++ k1) te = (x0,x1,x2) ∧ 0 < LENGTH k ∧ 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,get_atoms_def]) + >~ [‘Exn’] + >- ( + rw[] >> Cases_on ‘k’ >> gvs[] >> + gvs[step_def] >> TOP_CASE_TAC >> gvs[continue_def, push_def] + ) >> + rw[] >> Cases_on ‘k’ >> gvs[] >> + 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, continue_def, value_def, push_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) +Proof + Induct_on ‘n’ >> gvs[] >> + rpt gen_tac >> strip_tac >> + first_assum $ qspec_then ‘0’ mp_tac >> simp[] >> strip_tac >> + gvs[step_n_SUC] >> + qmatch_asmsub_abbrev_tac ‘step_n n' x’ >> + PairCases_on ‘x’ >> gvs[] >> + first_assum $ qspec_then ‘SUC 0’ assume_tac >> fs[] >> + reverse $ Cases_on ‘0 < n’ >> fs[] + >- ( + gvs[] >> + drule step_dec_cont' >> simp[] >> + strip_tac >> gvs[APPEND_EQ_APPEND] >> + Cases_on ‘l’ >> gvs[] + ) >> + first_x_assum drule >> strip_tac >> + ‘∃y1 y2. x2 = y1 ++ y2 ∧ LENGTH k2 = LENGTH y2’ by ( + irule_at Any $ GSYM TAKE_DROP >> + qexists ‘LENGTH x2 - LENGTH k2’ >> simp[]) >> + gvs[] >> + last_x_assum drule >> simp[] >> + impl_tac + >- ( + rw[] >> + last_x_assum $ qspec_then ‘SUC m’ mp_tac >> + simp[step_n_SUC] + ) >> + strip_tac >> gvs[GSYM PULL_FORALL] >> + drule step_inc_cont' >> simp[] >> + Cases_on ‘LENGTH k < LENGTH y1’ >> gvs[] + >- (strip_tac >> gvs[APPEND_EQ_APPEND]) >> + drule step_dec_cont' >> simp[] >> + Cases_on ‘LENGTH y1 < LENGTH k’ >> gvs[] + >- ( + strip_tac >> reverse $ gvs[APPEND_EQ_APPEND] + >- ( + gen_tac >> rename1 ‘_ ++ mid ++ right’ >> + pop_assum $ qspec_then ‘mid ++ right’ mp_tac >> simp[] + ) >> + gen_tac >> rename1 ‘_ ++ mid ++ right’ >> + pop_assum $ qspec_then ‘mid ++ right’ mp_tac >> simp[] + ) >> + ‘LENGTH k = LENGTH y1’ by gvs[] >> + drule step_eq_cont' >> simp[] >> + strip_tac >> gvs[APPEND_EQ_APPEND] >> + Cases_on ‘l’ >> gvs[] +QED + +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 + 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_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 + 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_weaken_alt: + step st k sr = (sr', st', k') ∧ + ¬is_halt (sr, st, k) + ⇒ step st (k ++ extra) sr = (sr', st', k' ++ extra) +Proof + 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_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 + 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: @@ -1499,6 +1703,17 @@ 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 [Atom (Loc 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: From 3e75245c037105e23f0b1a0562592ac7f0e7e7ed Mon Sep 17 00:00:00 2001 From: Hrutvik Kanabar Date: Fri, 14 Feb 2025 14:10:03 +0000 Subject: [PATCH 32/42] Delete various unused stateLang theorems --- .../languages/semantics/stateLangScript.sml | 364 ------------------ 1 file changed, 364 deletions(-) diff --git a/compiler/backend/languages/semantics/stateLangScript.sml b/compiler/backend/languages/semantics/stateLangScript.sml index 194283f4..fd2191f1 100644 --- a/compiler/backend/languages/semantics/stateLangScript.sml +++ b/compiler/backend/languages/semantics/stateLangScript.sml @@ -610,17 +610,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) = @@ -1090,359 +1079,6 @@ 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) -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 ++ k1 ∧ ∀k3. step ts (k0::k3) te = (x0,x1,k ++ 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,push_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) -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] -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) -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,push_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,push_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 [] -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) -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 [] -QED -*) - -Theorem step_inc_cont': - step ts (k0 ++ k1) te = (x0,x1,k2) ∧ 0 < LENGTH k0 ∧ LENGTH (k0 ++ k1) < LENGTH k2 ⇒ - ∃k. k2 = k ++ k1 ∧ ∀k3. step ts (k0 ++ k3) te = (x0,x1,k ++ 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’ >> gvs[continue_def, push_def, step_def] >> - FULL_CASE_TAC >> gvs[continue_def, push_def] - ) >> - rw[] >> Cases_on ‘k0’ >> gvs[] >> - 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, continue_def, value_def, push_def] -QED - -Theorem step_dec_cont': - step ts k1 te = (x0,x1,k2) ∧ LENGTH k2 < LENGTH k1 ⇒ - ∃k. LENGTH k ≥ 1 ∧ k1 = k ++ k2 ∧ ∀k3. step ts (k ++ k3) te = (x0,x1,k3) -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] >> - rw[AllCaseEqs()] >> gvs[step_def, continue_def, push_def, return_def] - ) >> - simp[Once $ oneline return_def] >> - rw[AllCaseEqs()] >> gvs[error_def, return_def, continue_def, value_def] >> - simp[APPEND_EQ_CONS, SF DNF_ss, return_def] >> - Cases_on ‘sop’ >> gvs[num_args_ok_def, LENGTH_EQ_NUM_compute] >> - gvs[application_def, value_def, error_def, return_def, continue_def, AllCaseEqs()] -QED - -Theorem step_eq_cont': - step ts (k ++ k1) te = (x0,x1,x2) ∧ 0 < LENGTH k ∧ 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,get_atoms_def]) - >~ [‘Exn’] - >- ( - rw[] >> Cases_on ‘k’ >> gvs[] >> - gvs[step_def] >> TOP_CASE_TAC >> gvs[continue_def, push_def] - ) >> - rw[] >> Cases_on ‘k’ >> gvs[] >> - 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, continue_def, value_def, push_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) -Proof - Induct_on ‘n’ >> gvs[] >> - rpt gen_tac >> strip_tac >> - first_assum $ qspec_then ‘0’ mp_tac >> simp[] >> strip_tac >> - gvs[step_n_SUC] >> - qmatch_asmsub_abbrev_tac ‘step_n n' x’ >> - PairCases_on ‘x’ >> gvs[] >> - first_assum $ qspec_then ‘SUC 0’ assume_tac >> fs[] >> - reverse $ Cases_on ‘0 < n’ >> fs[] - >- ( - gvs[] >> - drule step_dec_cont' >> simp[] >> - strip_tac >> gvs[APPEND_EQ_APPEND] >> - Cases_on ‘l’ >> gvs[] - ) >> - first_x_assum drule >> strip_tac >> - ‘∃y1 y2. x2 = y1 ++ y2 ∧ LENGTH k2 = LENGTH y2’ by ( - irule_at Any $ GSYM TAKE_DROP >> - qexists ‘LENGTH x2 - LENGTH k2’ >> simp[]) >> - gvs[] >> - last_x_assum drule >> simp[] >> - impl_tac - >- ( - rw[] >> - last_x_assum $ qspec_then ‘SUC m’ mp_tac >> - simp[step_n_SUC] - ) >> - strip_tac >> gvs[GSYM PULL_FORALL] >> - drule step_inc_cont' >> simp[] >> - Cases_on ‘LENGTH k < LENGTH y1’ >> gvs[] - >- (strip_tac >> gvs[APPEND_EQ_APPEND]) >> - drule step_dec_cont' >> simp[] >> - Cases_on ‘LENGTH y1 < LENGTH k’ >> gvs[] - >- ( - strip_tac >> reverse $ gvs[APPEND_EQ_APPEND] - >- ( - gen_tac >> rename1 ‘_ ++ mid ++ right’ >> - pop_assum $ qspec_then ‘mid ++ right’ mp_tac >> simp[] - ) >> - gen_tac >> rename1 ‘_ ++ mid ++ right’ >> - pop_assum $ qspec_then ‘mid ++ right’ mp_tac >> simp[] - ) >> - ‘LENGTH k = LENGTH y1’ by gvs[] >> - drule step_eq_cont' >> simp[] >> - strip_tac >> gvs[APPEND_EQ_APPEND] >> - Cases_on ‘l’ >> gvs[] -QED - Theorem step_weaken: step st k sr = (sr', st', k') ∧ ¬is_halt (sr', st', k') From a25e5ee82e3d9ca20c31cc66cabec5b1dd15f510 Mon Sep 17 00:00:00 2001 From: Hrutvik Kanabar Date: Sat, 30 Aug 2025 18:19:54 +0100 Subject: [PATCH 33/42] Update remaining stateLang proofs --- .../languages/semantics/stateLangScript.sml | 2 - .../proofs/state_app_unit_1ProofScript.sml | 20 +++--- .../proofs/state_app_unit_2ProofScript.sml | 19 ++--- .../passes/proofs/state_caseProofScript.sml | 19 ++--- .../proofs/state_names_1ProofScript.sml | 19 ++--- .../proofs/state_to_cakeProofScript.sml | 69 +++---------------- .../proofs/state_unthunkProofScript.sml | 19 +++-- 7 files changed, 59 insertions(+), 108 deletions(-) diff --git a/compiler/backend/languages/semantics/stateLangScript.sml b/compiler/backend/languages/semantics/stateLangScript.sml index fd2191f1..1dcd05b8 100644 --- a/compiler/backend/languages/semantics/stateLangScript.sml +++ b/compiler/backend/languages/semantics/stateLangScript.sml @@ -356,8 +356,6 @@ Definition application_def: case HD vs, st of (Atom $ Str content, SOME _) => (Action channel content, st, k) | _ => error st k) -Termination - WF_REL_TAC ‘measure (λ(x,_). if x = ForceMutThunk then 1 else 0)’ >> rw[] End (* Return a value and handle a continuation *) diff --git a/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml b/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml index 1cf746e7..00aef97c 100644 --- a/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml +++ b/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml @@ -262,7 +262,7 @@ Theorem application_thm: OPTREL state_rel ts1 ss1 ∧ step_res_rel tr1 tk1 sr1 sk1 Proof - ho_match_mp_tac application_ind \\ rw [] + Cases \\ rw [] \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] \\ rw [] \\ gvs [] >~ [‘Cons’] >- @@ -424,14 +424,16 @@ Proof \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [error_def,step_res_rel_cases] \\ Cases_on ‘a’ \\ gvs [] - \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ 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] - \\ gvs [value_def,state_rel_def,LIST_REL_EL_EQN] - \\ last_x_assum $ irule_at Any - \\ rw [Once v_rel_cases,Once cont_rel_cases] - \\ metis_tac [state_rel_def,LIST_REL_EL_EQN]) + \\ 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 diff --git a/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml b/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml index 23bb6929..4a2d3a51 100644 --- a/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml +++ b/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml @@ -281,7 +281,7 @@ Theorem application_thm: OPTREL state_rel ts1 ss1 ∧ step_res_rel tr1 tk1 sr1 sk1 Proof - ho_match_mp_tac application_ind \\ rw [] + Cases \\ rw [] \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] \\ rw [] \\ gvs [] >~ [‘Cons’] >- @@ -441,14 +441,15 @@ Proof \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [error_def,step_res_rel_cases] \\ Cases_on ‘a’ \\ gvs [] - \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ 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] - \\ gvs [value_def,state_rel_def,LIST_REL_EL_EQN] - \\ last_x_assum $ irule_at Any - \\ rw [Once v_rel_cases,Once cont_rel_cases] - \\ metis_tac [state_rel_def,LIST_REL_EL_EQN]) + \\ 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 diff --git a/compiler/backend/passes/proofs/state_caseProofScript.sml b/compiler/backend/passes/proofs/state_caseProofScript.sml index 2b6880b1..e58e0ae5 100644 --- a/compiler/backend/passes/proofs/state_caseProofScript.sml +++ b/compiler/backend/passes/proofs/state_caseProofScript.sml @@ -276,7 +276,7 @@ Theorem application_thm: cont_rel tk1 sk1 ∧ OPTREL state_rel ts1 ss1 ∧ step_res_rel tr1 sr1 Proof - ho_match_mp_tac application_ind \\ rw [] + Cases \\ rw [] \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] \\ rw [] \\ gvs [] >~ [‘Cons’] >- @@ -440,14 +440,15 @@ Proof \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [error_def,step_res_rel_cases] \\ Cases_on ‘a’ \\ gvs [] - \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ 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] - \\ gvs [value_def,state_rel_def,LIST_REL_EL_EQN] - \\ last_x_assum $ irule_at Any - \\ rw [Once v_rel_cases,Once cont_rel_cases] - \\ metis_tac [state_rel_def,LIST_REL_EL_EQN]) + \\ 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 diff --git a/compiler/backend/passes/proofs/state_names_1ProofScript.sml b/compiler/backend/passes/proofs/state_names_1ProofScript.sml index 9c5ea2f8..868e47b7 100644 --- a/compiler/backend/passes/proofs/state_names_1ProofScript.sml +++ b/compiler/backend/passes/proofs/state_names_1ProofScript.sml @@ -290,7 +290,7 @@ Theorem application_thm: cont_rel tk1 sk1 ∧ OPTREL state_rel ts1 ss1 ∧ step_res_rel tr1 sr1 Proof - ho_match_mp_tac application_ind \\ rw [] + Cases \\ rw[] \\ fs [num_args_ok_def,LENGTH_EQ_NUM_compute,PULL_EXISTS] \\ rw [] \\ gvs [] >~ [‘Cons’] >- @@ -476,14 +476,15 @@ Proof \\ simp [Once v_rel_cases] \\ strip_tac \\ gvs [error_def,step_res_rel_cases] \\ Cases_on ‘a’ \\ gvs [] - \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ 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] - \\ gvs [value_def,state_rel_def,LIST_REL_EL_EQN] - \\ last_x_assum $ irule_at Any - \\ rw [Once v_rel_cases,Once cont_rel_cases] - \\ metis_tac [state_rel_def,LIST_REL_EL_EQN]) + \\ 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 diff --git a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml index 93b459cb..7ee337f9 100644 --- a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml +++ b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml @@ -740,7 +740,7 @@ Theorem capplication_thm: SOME (Thunk Evaluated v) => return env s v c | SOME (Thunk NotEvaluated f) => - application Opapp env s [f; Conv NONE []] ((Cforce n,env)::c) + return env s f ((Capp Opapp [Conv NONE []] [], env)::(Cforce n, env)::c) | _ => Etype_error) | _ => Etype_error) else case get_ffi_ch op of @@ -759,11 +759,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, evaluateTheory.AppUnit_def] >> gvs[] + rw[application_thm] >> gvs[] >- gvs[AllCaseEqs()] >- rpt (TOP_CASE_TAC >> gvs[]) >> - Cases_on `op` >> gvs[] >> - TOP_CASE_TAC >> gvs [] + Cases_on `op` >> gvs[] QED val creturn_def = itree_semanticsTheory.return_def; @@ -1892,69 +1891,21 @@ Proof >~ [`ForceMutThunk`] >- ( gvs[application_def, sstep] >> - ntac 4 (TOP_CASE_TAC >> gvs[]) >> + 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'` >> 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] >- (goal_assum drule >> gvs[state_rel, LIST_REL_EL_EQN]) >- ( - gvs[do_opapp_def] >> - ntac 4 (FULL_CASE_TAC >> gvs[store_lookup_def]) - ) >> - Cases_on `dest_anyClosure v` >> gvs[] >> - Cases_on `x` >> gvs[] >> - Cases_on `r` >> gvs[] >> - rw [do_opapp_def] >> - Cases_on `a` >> rw[] >> - Cases_on `v` >> gvs[Once v_rel_cases,dest_anyClosure_def] - >- ( - goal_assum $ drule_at Any >> - simp[Once cont_rel_cases,state_rel_def,LIST_REL_EL_EQN,opt_bind_def] >> - gvs [env_rel_def] >> rw[] - ) - >- ( - Cases_on `ALOOKUP l0 s'` >> gvs[] >> - Cases_on `x` >> gvs[] >> - simp[semanticPrimitivesPropsTheory.find_recfun_ALOOKUP] >> - imp_res_tac ALOOKUP_SOME_EL >> - Cases_on `ALOOKUP l' (var_prefix s')` >> gvs[] - >- ( - gvs[LIST_REL_EL_EQN] >> - first_x_assum drule >> rw[] >> pairarg_tac >> gvs[] >> - drule_all ALOOKUP_ALL_DISTINCT_EL >> rpt strip_tac >> gvs[] - ) >> - Cases_on `x` >> gvs[] >> - qexists `cnenv` >> - rw[Once cont_rel_cases,state_rel_def,LIST_REL_EL_EQN] - >- ( - gvs[LIST_REL_EL_EQN] >> - first_x_assum drule >> rw[] >> pairarg_tac >> gvs[] >> - drule_all ALOOKUP_ALL_DISTINCT_EL >> rw[] - ) - >- ( - `v_rel cnenv (Constructor "" []) (Conv NONE [])` - by gvs[Once v_rel_cases] >> - drule_all env_rel_nsBind_Recclosure >> rw[] >> - gvs[LIST_REL_EL_EQN] >> - first_x_assum drule >> rw[] >> pairarg_tac >> gvs[opt_bind_def] >> - drule_all ALOOKUP_ALL_DISTINCT_EL >> rw[] - ) - >- ( - `EVERY (λ(cv,cx,ce). ∃sv. cv = var_prefix sv) l'` - by ( - rw[EVERY_EL] >> pairarg_tac >> gvs[LIST_REL_EL_EQN] >> - first_x_assum drule >> rw[] >> pairarg_tac >> gvs[] - ) >> - drule_all env_ok_nsBind_Recclosure >> rw[] >> gvs[LIST_REL_EL_EQN] >> - first_x_assum drule >> rw[] >> pairarg_tac >> gvs[opt_bind_def] >> - drule_all ALOOKUP_ALL_DISTINCT_EL >> rw[] - ) + goal_assum drule >> + irule_at Any cont_rel_AppK >> simp[op_rel_cases] >> + irule_at Any cont_rel_ForceMutK >> gvs[env_rel_def] >> + gvs[state_rel, LIST_REL_EL_EQN] ) - >- gvs[ALL_DISTINCT_MAP_FSTs] - ) + ) >- ( (* Update *) `LENGTH l0 = 2` by gvs[] >> gvs[LENGTH_EQ_NUM_compute] >> rename1 `[lnum;idx;elem]` >> gvs[application_def, sstep] >> diff --git a/compiler/backend/passes/proofs/state_unthunkProofScript.sml b/compiler/backend/passes/proofs/state_unthunkProofScript.sml index ff5c7130..7879dce8 100644 --- a/compiler/backend/passes/proofs/state_unthunkProofScript.sml +++ b/compiler/backend/passes/proofs/state_unthunkProofScript.sml @@ -1174,16 +1174,9 @@ Proof \\ Cases_on ‘x'’ \\ gvs [] \\ drule_all state_rel_thunk \\ strip_tac \\ gvs [] \\ Cases_on ‘t’ \\ gvs [] - >- simp [Once step_res_rel_cases] - \\ Cases_on ‘dest_anyClosure v’ \\ gvs [] - \\ PairCases_on ‘x'’ - \\ ‘state_rel p (pick_opt x NONE) (SOME ss)’ by gvs [] - \\ drule_all dest_anyClosure_v_rel - \\ strip_tac \\ gvs [LENGTH_EQ_NUM_compute] - \\ simp [Once cont_rel_cases, Once step_res_rel_cases] - \\ ‘v_rel p (Constructor "" []) (Constructor "" [])’ - by simp [Once v_rel_cases] - \\ drule imp_env_rel_opt_bind \\ simp []) + \\ 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 [] @@ -2009,6 +2002,7 @@ Proof \\ 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 @@ -2451,7 +2445,10 @@ Proof \\ last_x_assum $ irule \\ first_x_assum $ irule_at Any \\ fs [] \\ rpt (first_assum $ irule_at Any) - \\ simp [step_res_rel_cases]) + \\ simp [step_res_rel_cases]) >> + 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 From 82b28597c5fc3a5f52fc3857a3886a5d40c7ba51 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 25 Sep 2025 03:17:49 +0300 Subject: [PATCH 34/42] Update for change in name of while theory --- compiler/parsing/ispegexecScript.sml | 6 +++--- language/pure_valueScript.sml | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/compiler/parsing/ispegexecScript.sml b/compiler/parsing/ispegexecScript.sml index 299d495c..e7d2ccc7 100644 --- a/compiler/parsing/ispegexecScript.sml +++ b/compiler/parsing/ispegexecScript.sml @@ -213,13 +213,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 @@ -244,7 +244,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/language/pure_valueScript.sml b/language/pure_valueScript.sml index 4e9bc84b..d905f418 100644 --- a/language/pure_valueScript.sml +++ b/language/pure_valueScript.sml @@ -740,8 +740,8 @@ Proof gvs[Constructor_rep_def,EVERY_MAP] >> first_x_assum match_mp_tac >> match_mp_tac (MP_CANON EVERY_MONOTONIC) >> - first_x_assum(irule_at (Pos last)) >> - rw[] + gvs[EVERY_EL] >> rw [] >> + first_x_assum drule >> rw [] QED Definition v_take_def: From 41de57090db17715471e268a539bf197dbb9436b Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Fri, 26 Sep 2025 20:57:28 +0300 Subject: [PATCH 35/42] Fixes for theory syntax --- compiler/backend/passes/proofs/pure_to_thunk_1ProofScript.sml | 4 ++-- compiler/backend/passes/proofs/thunk_unthunkProofScript.sml | 2 +- compiler/backend/passes/proofs/thunk_untickProofScript.sml | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/compiler/backend/passes/proofs/pure_to_thunk_1ProofScript.sml b/compiler/backend/passes/proofs/pure_to_thunk_1ProofScript.sml index a8404c70..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 diff --git a/compiler/backend/passes/proofs/thunk_unthunkProofScript.sml b/compiler/backend/passes/proofs/thunk_unthunkProofScript.sml index ec69a84f..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 diff --git a/compiler/backend/passes/proofs/thunk_untickProofScript.sml b/compiler/backend/passes/proofs/thunk_untickProofScript.sml index 0088052d..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 From a6dbd3fd0ab13549516df124f19e138dc8b1aa24 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Fri, 26 Sep 2025 21:02:16 +0300 Subject: [PATCH 36/42] Fixes for theory syntax --- .../proofs/thunk_undelay_nextProofScript.sml | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/compiler/backend/passes/proofs/thunk_undelay_nextProofScript.sml b/compiler/backend/passes/proofs/thunk_undelay_nextProofScript.sml index bf674aa3..6d0f107d 100644 --- a/compiler/backend/passes/proofs/thunk_undelay_nextProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_undelay_nextProofScript.sml @@ -1,11 +1,10 @@ -open HolKernel Parse boolLib bossLib term_tactic monadsyntax intLib; -open stringTheory optionTheory sumTheory pairTheory listTheory alistTheory - finite_mapTheory pred_setTheory rich_listTheory; -open pure_miscTheory pure_configTheory pure_semanticsTheory - thunkLang_primitivesTheory thunkLangTheory thunkLangPropsTheory - thunk_semanticsTheory thunk_semantics_delayedTheory; - -val _ = new_theory "thunk_undelay_nextProof"; +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 (); @@ -1461,5 +1460,3 @@ Proof \\ simp [state_rel_delayed_def] \\ irule_at Any exp_rel_eval \\ gs [] QED - -val _ = export_theory (); From d772e07f38690fe824c073c836ca200f1dd42d07 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Sat, 27 Sep 2025 00:19:57 +0300 Subject: [PATCH 37/42] Added missing check in `ForceMutK` in `stateLang` to fix `state_to_cakeProof`. Updated state proofs. `state_unthunkProof` is cheated. --- .../languages/semantics/stateLangScript.sml | 33 +++++++-- .../proofs/state_app_unit_1ProofScript.sml | 50 ++++++++++--- .../proofs/state_app_unit_2ProofScript.sml | 71 ++++++++++++++----- .../passes/proofs/state_caseProofScript.sml | 50 ++++++++++--- .../proofs/state_names_1ProofScript.sml | 39 +++++++--- .../proofs/state_to_cakeProofScript.sml | 21 +++++- .../proofs/state_unthunkProofScript.sml | 21 +++++- 7 files changed, 230 insertions(+), 55 deletions(-) diff --git a/compiler/backend/languages/semantics/stateLangScript.sml b/compiler/backend/languages/semantics/stateLangScript.sml index ccd5cd09..17076024 100644 --- a/compiler/backend/languages/semantics/stateLangScript.sml +++ b/compiler/backend/languages/semantics/stateLangScript.sml @@ -246,6 +246,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: @@ -390,12 +407,16 @@ Definition return_def: | SOME _ => error st k) ∧ return v st (ForceMutK n :: k) = (case st of - 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 + | SOME stores => + (case dest_thunk_ptr v stores of + | BadRef => error st k + | NotThunk => + 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 + | IsThunk _ _ => error st k) | NONE => error st k) End diff --git a/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml b/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml index 3d9c567a..d070a4f9 100644 --- a/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml +++ b/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml @@ -662,6 +662,29 @@ Proof \\ simp [Once cont_rel_cases] QED +Definition dest_thunk_ptr_res_rel_def[simp]: + dest_thunk_ptr_res_rel BadRef BadRef = T ∧ + dest_thunk_ptr_res_rel NotThunk NotThunk = T ∧ + dest_thunk_ptr_res_rel (IsThunk m1 v1) (IsThunk m2 v2) = + (m1 = m2 ∧ v_rel v1 v2) ∧ + dest_thunk_ptr_res_rel _ _ = F +End + +Theorem dest_thunk_ptr_rel: + state_rel s1 s2 ∧ + v_rel v1 v2 ∧ + dest_thunk_ptr v2 s2 = res2 ⇒ + ∃res1. + dest_thunk_ptr v1 s1 = res1 ∧ + dest_thunk_ptr_res_rel res1 res2 +Proof + rw [oneline dest_thunk_ptr_def, AllCaseEqs()] + \\ gvs [Once v_rel_cases] + \\ rpt (TOP_CASE_TAC \\ gvs []) + \\ gvs [state_rel_def, LIST_REL_EL_EQN, oEL_THM] + \\ first_x_assum drule \\ simp [store_rel_def] +QED + Theorem step_1_Val_forward: ∀ts sk tk sr1 ss1 sk1 ss v1 v2. step ss sk (Val v2) = (sr1,ss1,sk1) ∧ @@ -703,15 +726,24 @@ Proof \\ irule env_rel_cons \\ simp []) >~ [‘ForceMutK’] >- (gvs [step] - \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ - \\ gvs [step_res_rel_cases,state_rel_def,LIST_REL_EL_EQN] - \\ reverse $ Cases_on ‘n < LENGTH x'’ \\ gvs [] - >- gvs [state_rel_def,LIST_REL_EL_EQN] - \\ IF_CASES_TAC \\ gvs [] - \\ first_assum $ qspec_then ‘n’ assume_tac - \\ Cases_on ‘EL n x’ \\ Cases_on ‘EL n x'’ - \\ gvs [store_rel_def,store_same_type_def,state_rel_def,LIST_REL_EL_EQN] - \\ rw [store_rel_def, EL_LUPDATE]) + \\ qpat_x_assum ‘_ = (sr1,ss1,sk1)’ mp_tac + \\ TOP_CASE_TAC \\ gvs [OPTREL_def] >- simp [step_res_rel_cases] + \\ TOP_CASE_TAC \\ gvs [] + \\ drule_all dest_thunk_ptr_rel \\ gvs [] + \\ TOP_CASE_TAC \\ gvs [] + >~ [‘BadRef’] >- rw [step_res_rel_cases] + >~ [‘IsThunk’] >- rw [step_res_rel_cases] + \\ ( + rpt strip_tac \\ gvs [] + \\ ntac 2 (TOP_CASE_TAC \\ gvs []) + \\ 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] >- diff --git a/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml b/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml index 3d74d2c8..c1223685 100644 --- a/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml +++ b/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml @@ -773,6 +773,29 @@ Proof \\ fs []) QED +Definition dest_thunk_ptr_res_rel_def[simp]: + dest_thunk_ptr_res_rel BadRef BadRef = T ∧ + dest_thunk_ptr_res_rel NotThunk NotThunk = T ∧ + dest_thunk_ptr_res_rel (IsThunk m1 v1) (IsThunk m2 v2) = + (m1 = m2 ∧ v_rel v1 v2) ∧ + dest_thunk_ptr_res_rel _ _ = F +End + +Theorem dest_thunk_ptr_rel: + state_rel s1 s2 ∧ + v_rel v1 v2 ∧ + dest_thunk_ptr v1 s1 = res1 ⇒ + ∃res2. + dest_thunk_ptr v2 s2 = res2 ∧ + dest_thunk_ptr_res_rel res1 res2 +Proof + rw [oneline dest_thunk_ptr_def, AllCaseEqs()] + \\ gvs [Once v_rel_cases] + \\ rpt (TOP_CASE_TAC \\ gvs []) + \\ gvs [state_rel_def, LIST_REL_EL_EQN, oEL_THM] + \\ first_x_assum drule \\ simp [store_rel_def] +QED + Theorem step_1_forward: ∀k tr ts tk tr1 ts1 tk1 ss sr sk. step_n k (tr,ts,tk) = (tr1,ts1,tk1) ∧ @@ -930,23 +953,37 @@ Proof \\ first_x_assum $ irule_at $ Pos hd \\ fs [] \\ simp [Once step_res_rel_cases]) >~ [‘ForceMutK’] >- - (Q.REFINE_EXISTS_TAC ‘SUC ck’ \\ fs [ADD_CLAUSES,step_n_SUC,step] - \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ \\ gvs [is_halt_step] - >- (qexists_tac ‘n’ \\ fs [step_res_rel_cases]) - \\ gvs [state_rel_def,LIST_REL_EL_EQN] - \\ reverse $ Cases_on ‘n' < LENGTH x'’ \\ gvs [] - >- (first_assum $ irule_at Any \\ fs [] - \\ first_x_assum $ irule_at $ Pos hd \\ fs [] - \\ rw [state_rel_def,LIST_REL_EL_EQN,Once step_res_rel_cases]) - \\ IF_CASES_TAC \\ gvs [] - \\ qpat_assum ‘∀n. n < LENGTH x' => _’ assume_tac - \\ first_x_assum $ qspec_then ‘n'’ assume_tac - \\ Cases_on ‘EL n' x’ \\ Cases_on ‘EL n' x'’ - \\ gvs [store_rel_def,store_same_type_def,state_rel_def,LIST_REL_EL_EQN] - \\ first_assum $ irule_at Any \\ fs [] - \\ first_x_assum $ irule_at $ Pos hd \\ fs [] - \\ simp [state_rel_def,LIST_REL_EL_EQN,Once step_res_rel_cases] - \\ rw [store_rel_def, EL_LUPDATE]) + (qrefine ‘SUC ck’ \\ gvs [ADD_CLAUSES, step_n_SUC, step] + \\ qpat_x_assum ‘_ = (tr1,ts1,tk1')’ mp_tac + \\ TOP_CASE_TAC \\ gvs [OPTREL_def] + >- ( + strip_tac + \\ last_x_assum irule \\ gvs [] + \\ metis_tac [step_res_rel_cases]) + \\ TOP_CASE_TAC \\ gvs [] + \\ drule_all dest_thunk_ptr_rel \\ gvs [] + \\ TOP_CASE_TAC \\ gvs [] + >~ [‘BadRef’] + >- ( + strip_tac + \\ last_x_assum irule \\ gvs [PULL_EXISTS] + \\ metis_tac [step_res_rel_cases]) + >~ [‘IsThunk’] + >- ( + rpt strip_tac + \\ last_x_assum irule \\ gvs [PULL_EXISTS] + \\ metis_tac [step_res_rel_cases]) + \\ ( + rpt strip_tac \\ gvs [] + \\ ntac 2 (TOP_CASE_TAC \\ gvs []) + \\ 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 []) + \\ first_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] diff --git a/compiler/backend/passes/proofs/state_caseProofScript.sml b/compiler/backend/passes/proofs/state_caseProofScript.sml index c45ba090..11d90427 100644 --- a/compiler/backend/passes/proofs/state_caseProofScript.sml +++ b/compiler/backend/passes/proofs/state_caseProofScript.sml @@ -499,6 +499,29 @@ Proof \\ irule env_rel_cons \\ fs [] QED +Definition dest_thunk_ptr_res_rel_def[simp]: + dest_thunk_ptr_res_rel BadRef BadRef = T ∧ + dest_thunk_ptr_res_rel NotThunk NotThunk = T ∧ + dest_thunk_ptr_res_rel (IsThunk m1 v1) (IsThunk m2 v2) = + (m1 = m2 ∧ v_rel v1 v2) ∧ + dest_thunk_ptr_res_rel _ _ = F +End + +Theorem dest_thunk_ptr_rel: + state_rel s1 s2 ∧ + v_rel v1 v2 ∧ + dest_thunk_ptr v1 s1 = res1 ⇒ + ∃res2. + dest_thunk_ptr v2 s2 = res2 ∧ + dest_thunk_ptr_res_rel res1 res2 +Proof + rw [oneline dest_thunk_ptr_def, AllCaseEqs()] + \\ gvs [Once v_rel_cases] + \\ rpt (TOP_CASE_TAC \\ gvs []) + \\ gvs [state_rel_def, LIST_REL_EL_EQN, oEL_THM] + \\ first_x_assum drule \\ simp [store_rel_def] +QED + Theorem step_1_forward: ∀tr ts tk tr1 ts1 tk1 ss sr sk. step_n 1 (tr,ts,tk) = (tr1,ts1,tk1) ∧ @@ -703,15 +726,24 @@ Proof \\ first_assum $ irule_at Any \\ fs []) >~ [‘ForceMutK’] >- (gvs [step] - \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ - \\ gvs [step_res_rel_cases,state_rel_def,LIST_REL_EL_EQN] - \\ reverse $ Cases_on ‘n < LENGTH x'’ \\ gvs [] - >- gvs [state_rel_def,LIST_REL_EL_EQN] - \\ IF_CASES_TAC \\ gvs [] - \\ last_assum $ qspec_then ‘n’ assume_tac - \\ Cases_on ‘EL n x’ \\ Cases_on ‘EL n x'’ - \\ gvs [store_rel_def,store_same_type_def,state_rel_def,LIST_REL_EL_EQN] - \\ rw [store_rel_def, EL_LUPDATE]) + \\ qpat_x_assum ‘_ = (tr1,ts1,tk1')’ mp_tac + \\ TOP_CASE_TAC \\ gvs [OPTREL_def] >- simp [step_res_rel_cases] + \\ TOP_CASE_TAC \\ gvs [] + \\ drule_all dest_thunk_ptr_rel \\ gvs [] + \\ TOP_CASE_TAC \\ gvs [] + >~ [‘BadRef’] >- rw [step_res_rel_cases] + >~ [‘IsThunk’] >- rw [step_res_rel_cases] + \\ ( + rpt strip_tac \\ gvs [] + \\ ntac 2 (TOP_CASE_TAC \\ gvs []) + \\ 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] >- (simp [Once cont_rel_cases, step_res_rel_cases] \\ rw []) diff --git a/compiler/backend/passes/proofs/state_names_1ProofScript.sml b/compiler/backend/passes/proofs/state_names_1ProofScript.sml index 860aa3ef..e419d16b 100644 --- a/compiler/backend/passes/proofs/state_names_1ProofScript.sml +++ b/compiler/backend/passes/proofs/state_names_1ProofScript.sml @@ -537,6 +537,20 @@ Proof \\ fs [SUBSET_DEF] QED +Theorem dest_thunk_ptr_rel: + state_rel x y ∧ + v_rel v w ∧ + dest_thunk_ptr v x = NotThunk ⇒ + dest_thunk_ptr w y = NotThunk +Proof + rw [oneline dest_thunk_ptr_def, AllCaseEqs()] + \\ gvs [Once v_rel_cases] + \\ gvs [state_rel_def, LIST_REL_EL_EQN, oEL_THM] + \\ first_x_assum drule \\ simp [] + \\ simp [oneline store_rel_def] + \\ TOP_CASE_TAC \\ gvs [] +QED + Theorem step_1_forward: ∀tr ts tk tr1 ts1 tk1 ss sr sk. step_n 1 (tr,ts,tk) = (tr1,ts1,tk1) ∧ @@ -694,14 +708,23 @@ Proof \\ first_assum $ irule_at Any \\ fs []) >~ [‘ForceMutK’] >- (gvs [step] - \\ Cases_on ‘ts’ \\ Cases_on ‘ss’ - \\ gvs [step_res_rel_cases,state_rel_def,LIST_REL_EL_EQN] - \\ Cases_on ‘n < LENGTH x'’ \\ gvs [] - \\ IF_CASES_TAC \\ gvs [] - \\ last_assum $ qspec_then ‘n’ assume_tac - \\ Cases_on ‘EL n x’ \\ Cases_on ‘EL n x'’ - \\ gvs [store_rel_def,store_same_type_def,state_rel_def,LIST_REL_EL_EQN] - \\ rw [store_rel_def,EL_LUPDATE]) + \\ last_x_assum mp_tac + \\ ntac 2 (TOP_CASE_TAC \\ gvs[]) \\ gvs [OPTREL_def] + \\ drule_all_then assume_tac dest_thunk_ptr_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] >- diff --git a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml index 4fb639b1..63752372 100644 --- a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml +++ b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml @@ -759,7 +759,8 @@ Theorem capplication_thm: Proof 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 @@ -1478,6 +1479,20 @@ Proof TOP_CASE_TAC >> gvs[] QED +Theorem dest_thunk_rel: + state_rel cnenv sst cst ∧ + v_rel cnenv sv cv ∧ + dest_thunk_ptr sv sst = NotThunk ⇒ + dest_thunk [cv] cst = NotThunk +Proof + rw [oneline dest_thunk_ptr_def, oneline dest_thunk_def, AllCaseEqs()] + \\ gvs [Once v_rel_cases] + \\ gvs [state_rel, LIST_REL_EL_EQN, oEL_THM] + \\ first_x_assum $ drule_then assume_tac \\ gvs [] + \\ gvs [oneline store_rel_def] + \\ FULL_CASE_TAC \\ gvs [] + \\ simp [store_lookup_def, EL_CONS, PRE_SUB1] +QED (********** Main results **********) @@ -1760,8 +1775,8 @@ Proof reverse TOP_CASE_TAC >> gvs[Once cont_rel_cases, sstep, cstep] >- ( (* ForceMutK *) first_x_assum $ qspec_then `1` assume_tac >> gvs[sstep] >> - Cases_on `n < LENGTH sst` >> gvs[] >> - Cases_on `store_same_type (EL n sst) (ThunkMem Evaluated sv)` >> gvs[] >> + 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] diff --git a/compiler/backend/passes/proofs/state_unthunkProofScript.sml b/compiler/backend/passes/proofs/state_unthunkProofScript.sml index a17e7a8d..45292251 100644 --- a/compiler/backend/passes/proofs/state_unthunkProofScript.sml +++ b/compiler/backend/passes/proofs/state_unthunkProofScript.sml @@ -1923,6 +1923,15 @@ Proof \\ gvs [loc_rel_def,dest_anyThunk_def] QED +Theorem dest_thunk_ptr_rel: + state_rel p (SOME s1) (SOME s2) ∧ + v_rel p v1 v2 ∧ + dest_thunk_ptr v1 s1 = NotThunk ⇒ + dest_thunk_ptr v2 s2 = NotThunk +Proof + cheat +QED + Theorem step_forward: ∀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) ∧ @@ -2040,6 +2049,7 @@ Proof \\ disch_then $ qspec_then ‘loc’ mp_tac \\ impl_keep_tac >- (irule v_rel_ext \\ fs []) \\ strip_tac \\ fs [] + \\ ‘dest_thunk_ptr v2 ss1 = NotThunk’ by cheat \\ gvs [] \\ fs [oEL_THM,EL_LUPDATE,store_same_type_def] \\ qmatch_goalsub_abbrev_tac ‘SOME ss3’ \\ gvs [LUPDATE_DEF,LUPDATE_DEF,LUPDATE_LUPDATE] @@ -2143,6 +2153,8 @@ Proof (Cases_on ‘n’ \\ fs [ADD1,step'_n_add,step,step'_def,return'_def,return_def] \\ Cases_on ‘ts’ \\ gvs [] \\ irule_at Any step_n_unwind \\ fs [step_n_add,step] + \\ Cases_on ‘dest_thunk_ptr v1 x’ \\ gvs [] + \\ drule_all_then assume_tac dest_thunk_ptr_rel \\ gvs [] \\ imp_res_tac state_rel_def \\ gvs [LIST_REL_EL_EQN] \\ imp_res_tac find_loc_length_thm \\ Cases_on ‘n1 < LENGTH t1’ \\ gvs [] @@ -2492,6 +2504,9 @@ Proof \\ 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]) + \\ TOP_CASE_TAC \\ gvs [] + >~ [‘BadRef’] >- cheat + >~ [‘IsThunk’] >- cheat \\ drule v_rel_thunk_IMP_oEL \\ impl_tac >- gvs [] \\ strip_tac \\ first_x_assum drule \\ strip_tac \\ rfs [] @@ -2582,8 +2597,8 @@ 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’ + >~ [‘ForceMutK’] >- cheat + (*Q.REFINE_EXISTS_TAC ‘ck1+1’ \\ rewrite_tac [step_n_add,ADD1] \\ gvs [step] \\ Cases_on ‘m’ \\ gvs [step,ADD1] \\ Cases_on ‘ts’ \\ gvs [] @@ -2601,7 +2616,7 @@ Proof \\ 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 []) + \\ 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] From cc14d6ef307f625200085a83b770c75b53ef5479 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Fri, 10 Oct 2025 19:08:27 +0300 Subject: [PATCH 38/42] Fixes for `state_unthunk` --- .../languages/semantics/stateLangScript.sml | 96 ++++++++---- .../proofs/env_to_state_1ProofScript.sml | 12 +- .../proofs/state_app_unit_1ProofScript.sml | 72 +++++---- .../proofs/state_app_unit_2ProofScript.sml | 84 +++++----- .../passes/proofs/state_caseProofScript.sml | 72 +++++---- .../proofs/state_names_1ProofScript.sml | 24 +-- .../proofs/state_to_cakeProofScript.sml | 2 + .../proofs/state_unthunkProofScript.sml | 148 +++++++++++++----- 8 files changed, 327 insertions(+), 183 deletions(-) diff --git a/compiler/backend/languages/semantics/stateLangScript.sml b/compiler/backend/languages/semantics/stateLangScript.sml index 17076024..8f76a1ee 100644 --- a/compiler/backend/languages/semantics/stateLangScript.sml +++ b/compiler/backend/languages/semantics/stateLangScript.sml @@ -374,6 +374,30 @@ Definition application_def: | _ => error st k) End +Datatype: + check_thunk_v_ret + = CT_Error + | CT_NotThunk + | CT_IsThunk +End + +Definition check_thunk_v_def: + check_thunk_v v st = + case dest_anyThunk v of + | NONE => + (case v of + | Atom (Loc n) => + (case st of + | NONE => CT_Error + | SOME stores => + (case dest_thunk_ptr v stores of + | BadRef => CT_Error + | NotThunk => CT_NotThunk + | IsThunk _ _ => CT_IsThunk)) + | _ => CT_NotThunk) + | SOME _ => CT_IsThunk +End + (* Return a value and handle a continuation *) Definition return_def: return v st [] = value v st [] ∧ @@ -398,26 +422,28 @@ Definition return_def: | 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) = - (case dest_anyThunk v of - | NONE => value v st k - | SOME _ => error st k) ∧ + (case check_thunk_v v st of + | CT_Error => error st k + | CT_NotThunk => value v st k + | CT_IsThunk => error st k) ∧ return v st (BoxK :: k) = - (case dest_anyThunk v of - | NONE => value (Thunk $ INL v) st k - | SOME _ => error st k) ∧ + (case check_thunk_v v st of + | CT_Error => error st k + | CT_NotThunk => value (Thunk $ INL v) st k + | CT_IsThunk => error st k) ∧ return v st (ForceMutK n :: k) = - (case st of - | SOME stores => - (case dest_thunk_ptr v stores of - | BadRef => error st k - | NotThunk => - 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 - | IsThunk _ _ => error st k) - | NONE => error st k) + (case check_thunk_v v st of + | CT_Error => error st k + | CT_NotThunk => + (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) + | CT_IsThunk => error st k) End Definition find_match_list_def: @@ -956,14 +982,15 @@ 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] - \\ Cases_on `dest_anyThunk v` \\ gvs [] + (gvs [return_def,continue_def,value_def,error_def] + \\ gvs [step_n_Val,step_n_Error,error_def,GSYM step_n_def] + \\ rpt (TOP_CASE_TAC \\ gvs []) + \\ gvs [check_thunk_v_def, dest_anyThunk_def, AllCaseEqs()] \\ 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]) + \\ 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 @@ -980,14 +1007,15 @@ 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] - \\ Cases_on `dest_anyThunk v` \\ gvs [] + (gvs [return_def,continue_def,value_def,error_def] + \\ gvs [step_n_Val,step_n_Error,error_def,GSYM step_n_def] + \\ rpt (TOP_CASE_TAC \\ gvs []) + \\ gvs [check_thunk_v_def, dest_anyThunk_def, AllCaseEqs()] \\ 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]) + \\ 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]) @@ -1005,9 +1033,15 @@ Proof \\ last_x_assum $ drule_at $ Pos $ el 2 \\ impl_tac >- fs [] \\ strip_tac \\ fs []) >~ [‘ForceMutK’] >- - (fs [return_def,error_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]) + (gvs [return_def,continue_def,value_def,error_def] + \\ gvs [step_n_Val,step_n_Error,error_def,GSYM step_n_def] + \\ rpt (TOP_CASE_TAC \\ gvs []) + \\ gvs [check_thunk_v_def, dest_anyThunk_def, AllCaseEqs()] + \\ 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]) \\ rename [‘AppK env sop vs es’] \\ gvs [] \\ reverse (Cases_on ‘es’) \\ fs [return_def,continue_def] diff --git a/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml b/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml index a732c71a..8a73dbf2 100644 --- a/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml +++ b/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml @@ -622,8 +622,8 @@ Proof \\ qexists_tac ‘1’ \\ fs [] \\ fs [step_def,value_def] \\ simp [Once v_rel_cases]) - >~ [‘Box x’] >- - (simp [Once compile_rel_cases] \\ rw [] + >~ [‘Box x’] >- cheat + (*simp [Once compile_rel_cases] \\ rw [] \\ fs [eval_to_def] \\ Cases_on ‘eval_to n tenv x = INL Type_error’ >- fs [] \\ fs [] \\ Q.REFINE_EXISTS_TAC ‘ck1+1’ @@ -639,9 +639,9 @@ Proof \\ fs [step_def,push_def,return_def,value_def] \\ simp [Once v_rel_cases] \\ CASE_TAC \\ rw [error_def] - \\ drule v_rel_anyThunk \\ rw []) - >~ [‘Force x’] >- - (simp [Once compile_rel_cases] \\ rw [] + \\ drule v_rel_anyThunk \\ rw []*) + >~ [‘Force x’] >- cheat + (*simp [Once compile_rel_cases] \\ rw [] \\ fs [eval_to_def] \\ IF_CASES_TAC \\ gvs [] >- (qexists_tac ‘0’ \\ fs [is_halt_def]) @@ -695,7 +695,7 @@ Proof \\ rewrite_tac [step_n_add] \\ fs [step_def,push_def] \\ qexists_tac ‘1’ \\ fs [step_def,return_def,value_def] \\ CASE_TAC \\ rw [error_def] - \\ drule v_rel_anyThunk \\ rw []) + \\ drule v_rel_anyThunk \\ rw []*) >~ [‘Let NONE x1 x2’] >- (simp [Once compile_rel_cases] \\ rw [] \\ fs [eval_to_def] diff --git a/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml b/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml index d070a4f9..aedc3675 100644 --- a/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml +++ b/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml @@ -662,27 +662,42 @@ Proof \\ simp [Once cont_rel_cases] QED -Definition dest_thunk_ptr_res_rel_def[simp]: - dest_thunk_ptr_res_rel BadRef BadRef = T ∧ - dest_thunk_ptr_res_rel NotThunk NotThunk = T ∧ - dest_thunk_ptr_res_rel (IsThunk m1 v1) (IsThunk m2 v2) = - (m1 = m2 ∧ v_rel v1 v2) ∧ - dest_thunk_ptr_res_rel _ _ = F -End - -Theorem dest_thunk_ptr_rel: - state_rel s1 s2 ∧ - v_rel v1 v2 ∧ - dest_thunk_ptr v2 s2 = res2 ⇒ - ∃res1. - dest_thunk_ptr v1 s1 = res1 ∧ - dest_thunk_ptr_res_rel res1 res2 +Theorem check_thunk_v_rel: + ∀v1 v2. + v_rel v1 v2 ⇒ + (state_rel s1 s2 ⇒ + check_thunk_v v1 (SOME s1) = r ⇒ + check_thunk_v v2 (SOME s2) = r) Proof - rw [oneline dest_thunk_ptr_def, AllCaseEqs()] - \\ gvs [Once v_rel_cases] - \\ rpt (TOP_CASE_TAC \\ gvs []) - \\ gvs [state_rel_def, LIST_REL_EL_EQN, oEL_THM] - \\ first_x_assum drule \\ simp [store_rel_def] + ‘(∀v1 v2. + v_rel v1 v2 ⇒ + (state_rel s1 s2 ⇒ + check_thunk_v v1 (SOME s1) = r ⇒ + check_thunk_v v2 (SOME s2) = r)) ∧ + (∀x y. env_rel x y ⇒ T)’ + suffices_by gvs [] + \\ ho_match_mp_tac v_rel_strongind \\ rw [] \\ gvs [] + >~ [‘Constructor’] >- gvs [check_thunk_v_def, dest_anyThunk_def] + >~ [‘Closure’] >- gvs [check_thunk_v_def, dest_anyThunk_def] + >~ [‘Atom’] >- ( + gvs [check_thunk_v_def, dest_anyThunk_def] + \\ TOP_CASE_TAC \\ gvs [dest_thunk_ptr_def] + \\ rpt (CASE_TAC \\ gvs []) + \\ gvs [state_rel_def, LIST_REL_EL_EQN, oEL_THM] + \\ first_x_assum drule \\ simp [store_rel_def]) + \\ gvs [check_thunk_v_def, dest_anyThunk_def] + \\ rpt (CASE_TAC \\ gvs []) + >>~ [‘ALOOKUP _ _ = NONE’] + >- (drule_all ALOOKUP_SOME_EL_2 \\ 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] \\ gvs [] + \\ rpt strip_tac \\ gvs [] + \\ drule_then assume_tac ALOOKUP_SOME_EL \\ gvs [EVERY_EL] + \\ first_x_assum drule \\ gvs []) QED Theorem step_1_Val_forward: @@ -727,16 +742,15 @@ Proof >~ [‘ForceMutK’] >- (gvs [step] \\ qpat_x_assum ‘_ = (sr1,ss1,sk1)’ mp_tac - \\ TOP_CASE_TAC \\ gvs [OPTREL_def] >- simp [step_res_rel_cases] - \\ TOP_CASE_TAC \\ gvs [] - \\ drule_all dest_thunk_ptr_rel \\ gvs [] - \\ TOP_CASE_TAC \\ gvs [] - >~ [‘BadRef’] >- rw [step_res_rel_cases] - >~ [‘IsThunk’] >- rw [step_res_rel_cases] + \\ Cases_on ‘ss’ \\ gvs [OPTREL_def] + >- (rpt (TOP_CASE_TAC \\ gvs []) \\ simp [step_res_rel_cases]) + \\ Cases_on ‘check_thunk_v v1 (SOME x0)’ \\ gvs [] + \\ drule_all check_thunk_v_rel \\ gvs [] + >~ [‘CT_Error’] >- rw [step_res_rel_cases] + >~ [‘CT_IsThunk’] >- rw [step_res_rel_cases] + \\ rw [] \\ ( - rpt strip_tac \\ gvs [] - \\ ntac 2 (TOP_CASE_TAC \\ gvs []) - \\ gvs [state_rel_def, LIST_REL_EL_EQN, EL_LUPDATE] \\ 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 diff --git a/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml b/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml index c1223685..77fe0df2 100644 --- a/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml +++ b/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml @@ -773,27 +773,42 @@ Proof \\ fs []) QED -Definition dest_thunk_ptr_res_rel_def[simp]: - dest_thunk_ptr_res_rel BadRef BadRef = T ∧ - dest_thunk_ptr_res_rel NotThunk NotThunk = T ∧ - dest_thunk_ptr_res_rel (IsThunk m1 v1) (IsThunk m2 v2) = - (m1 = m2 ∧ v_rel v1 v2) ∧ - dest_thunk_ptr_res_rel _ _ = F -End - -Theorem dest_thunk_ptr_rel: - state_rel s1 s2 ∧ - v_rel v1 v2 ∧ - dest_thunk_ptr v1 s1 = res1 ⇒ - ∃res2. - dest_thunk_ptr v2 s2 = res2 ∧ - dest_thunk_ptr_res_rel res1 res2 +Theorem check_thunk_v_rel: + ∀v1 v2. + v_rel v1 v2 ⇒ + (state_rel s1 s2 ⇒ + check_thunk_v v1 (SOME s1) = r ⇒ + check_thunk_v v2 (SOME s2) = r) Proof - rw [oneline dest_thunk_ptr_def, AllCaseEqs()] - \\ gvs [Once v_rel_cases] - \\ rpt (TOP_CASE_TAC \\ gvs []) - \\ gvs [state_rel_def, LIST_REL_EL_EQN, oEL_THM] - \\ first_x_assum drule \\ simp [store_rel_def] + ‘(∀v1 v2. + v_rel v1 v2 ⇒ + (state_rel s1 s2 ⇒ + check_thunk_v v1 (SOME s1) = r ⇒ + check_thunk_v v2 (SOME s2) = r)) ∧ + (∀x y. env_rel x y ⇒ T)’ + suffices_by gvs [] + \\ ho_match_mp_tac v_rel_strongind \\ rw [] \\ gvs [] + >~ [‘Constructor’] >- gvs [check_thunk_v_def, dest_anyThunk_def] + >~ [‘Closure’] >- gvs [check_thunk_v_def, dest_anyThunk_def] + >~ [‘Atom’] >- ( + gvs [check_thunk_v_def, dest_anyThunk_def] + \\ TOP_CASE_TAC \\ gvs [dest_thunk_ptr_def] + \\ rpt (CASE_TAC \\ gvs []) + \\ gvs [state_rel_def, LIST_REL_EL_EQN, oEL_THM] + \\ first_x_assum drule \\ simp [store_rel_def]) + \\ gvs [check_thunk_v_def, dest_anyThunk_def] + \\ rpt (CASE_TAC \\ gvs []) + >>~ [‘ALOOKUP _ _ = NONE’] + >- (drule_all ALOOKUP_SOME_EL_2 \\ 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] \\ gvs [] + \\ rpt strip_tac \\ gvs [] + \\ drule_then assume_tac ALOOKUP_SOME_EL \\ gvs [EVERY_EL] + \\ first_x_assum drule \\ gvs []) QED Theorem step_1_forward: @@ -955,35 +970,32 @@ Proof >~ [‘ForceMutK’] >- (qrefine ‘SUC ck’ \\ gvs [ADD_CLAUSES, step_n_SUC, step] \\ qpat_x_assum ‘_ = (tr1,ts1,tk1')’ mp_tac - \\ TOP_CASE_TAC \\ gvs [OPTREL_def] + \\ Cases_on ‘ts’ \\ gvs [OPTREL_def] >- ( - strip_tac + rpt (TOP_CASE_TAC \\ gvs []) + \\ strip_tac \\ last_x_assum irule \\ gvs [] \\ metis_tac [step_res_rel_cases]) \\ TOP_CASE_TAC \\ gvs [] - \\ drule_all dest_thunk_ptr_rel \\ gvs [] - \\ TOP_CASE_TAC \\ gvs [] - >~ [‘BadRef’] - >- ( - strip_tac - \\ last_x_assum irule \\ gvs [PULL_EXISTS] + \\ drule_all check_thunk_v_rel \\ gvs [] + >~ [‘CT_Error’] >- ( + rw [] + \\ last_x_assum irule \\ gvs [] \\ metis_tac [step_res_rel_cases]) - >~ [‘IsThunk’] - >- ( - rpt strip_tac - \\ last_x_assum irule \\ gvs [PULL_EXISTS] + >~ [‘CT_IsThunk’] >- ( + rw [] + \\ last_x_assum irule \\ gvs [] \\ metis_tac [step_res_rel_cases]) + \\ rw [] \\ ( - rpt strip_tac \\ gvs [] - \\ ntac 2 (TOP_CASE_TAC \\ gvs []) - \\ last_x_assum irule \\ gvs [PULL_EXISTS] + 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 []) - \\ first_x_assum drule \\ gvs [store_rel_def])) + \\ 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] diff --git a/compiler/backend/passes/proofs/state_caseProofScript.sml b/compiler/backend/passes/proofs/state_caseProofScript.sml index 11d90427..0a32729a 100644 --- a/compiler/backend/passes/proofs/state_caseProofScript.sml +++ b/compiler/backend/passes/proofs/state_caseProofScript.sml @@ -499,27 +499,42 @@ Proof \\ irule env_rel_cons \\ fs [] QED -Definition dest_thunk_ptr_res_rel_def[simp]: - dest_thunk_ptr_res_rel BadRef BadRef = T ∧ - dest_thunk_ptr_res_rel NotThunk NotThunk = T ∧ - dest_thunk_ptr_res_rel (IsThunk m1 v1) (IsThunk m2 v2) = - (m1 = m2 ∧ v_rel v1 v2) ∧ - dest_thunk_ptr_res_rel _ _ = F -End - -Theorem dest_thunk_ptr_rel: - state_rel s1 s2 ∧ - v_rel v1 v2 ∧ - dest_thunk_ptr v1 s1 = res1 ⇒ - ∃res2. - dest_thunk_ptr v2 s2 = res2 ∧ - dest_thunk_ptr_res_rel res1 res2 +Theorem check_thunk_v_rel: + ∀v1 v2. + v_rel v1 v2 ⇒ + (state_rel s1 s2 ⇒ + check_thunk_v v1 (SOME s1) = r ⇒ + check_thunk_v v2 (SOME s2) = r) Proof - rw [oneline dest_thunk_ptr_def, AllCaseEqs()] - \\ gvs [Once v_rel_cases] - \\ rpt (TOP_CASE_TAC \\ gvs []) - \\ gvs [state_rel_def, LIST_REL_EL_EQN, oEL_THM] - \\ first_x_assum drule \\ simp [store_rel_def] + ‘(∀v1 v2. + v_rel v1 v2 ⇒ + (state_rel s1 s2 ⇒ + check_thunk_v v1 (SOME s1) = r ⇒ + check_thunk_v v2 (SOME s2) = r)) ∧ + (∀x y. env_rel x y ⇒ T)’ + suffices_by gvs [] + \\ ho_match_mp_tac v_rel_strongind \\ rw [] \\ gvs [] + >~ [‘Constructor’] >- gvs [check_thunk_v_def, dest_anyThunk_def] + >~ [‘Closure’] >- gvs [check_thunk_v_def, dest_anyThunk_def] + >~ [‘Atom’] >- ( + gvs [check_thunk_v_def, dest_anyThunk_def] + \\ TOP_CASE_TAC \\ gvs [dest_thunk_ptr_def] + \\ rpt (CASE_TAC \\ gvs []) + \\ gvs [state_rel_def, LIST_REL_EL_EQN, oEL_THM] + \\ first_x_assum drule \\ simp [store_rel_def]) + \\ gvs [check_thunk_v_def, dest_anyThunk_def] + \\ rpt (CASE_TAC \\ gvs []) + >>~ [‘ALOOKUP _ _ = NONE’] + >- (drule_all ALOOKUP_SOME_EL_2 \\ 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] \\ gvs [] + \\ rpt strip_tac \\ gvs [] + \\ drule_then assume_tac ALOOKUP_SOME_EL \\ gvs [EVERY_EL] + \\ first_x_assum drule \\ gvs []) QED Theorem step_1_forward: @@ -727,22 +742,21 @@ Proof >~ [‘ForceMutK’] >- (gvs [step] \\ qpat_x_assum ‘_ = (tr1,ts1,tk1')’ mp_tac - \\ TOP_CASE_TAC \\ gvs [OPTREL_def] >- simp [step_res_rel_cases] + \\ Cases_on ‘ss’ \\ gvs [OPTREL_def] + >- (rpt (TOP_CASE_TAC \\ gvs []) \\ simp [step_res_rel_cases]) \\ TOP_CASE_TAC \\ gvs [] - \\ drule_all dest_thunk_ptr_rel \\ gvs [] - \\ TOP_CASE_TAC \\ gvs [] - >~ [‘BadRef’] >- rw [step_res_rel_cases] - >~ [‘IsThunk’] >- rw [step_res_rel_cases] + \\ drule_all check_thunk_v_rel \\ gvs [] + >~ [‘CT_Error’] >- rw [step_res_rel_cases] + >~ [‘CT_IsThunk’] >- rw [step_res_rel_cases] + \\ rw [] \\ ( - rpt strip_tac \\ gvs [] - \\ ntac 2 (TOP_CASE_TAC \\ gvs []) - \\ gvs [state_rel_def, LIST_REL_EL_EQN, EL_LUPDATE] \\ 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 [] + \\ last_x_assum drule \\ gvs [] \\ simp [store_rel_def])) \\ rename [‘AppK’] \\ reverse (Cases_on ‘tes’) \\ gvs [] \\ gvs [step] diff --git a/compiler/backend/passes/proofs/state_names_1ProofScript.sml b/compiler/backend/passes/proofs/state_names_1ProofScript.sml index e419d16b..e902bb51 100644 --- a/compiler/backend/passes/proofs/state_names_1ProofScript.sml +++ b/compiler/backend/passes/proofs/state_names_1ProofScript.sml @@ -537,18 +537,22 @@ Proof \\ fs [SUBSET_DEF] QED -Theorem dest_thunk_ptr_rel: +Theorem check_thunk_v_rel: state_rel x y ∧ v_rel v w ∧ - dest_thunk_ptr v x = NotThunk ⇒ - dest_thunk_ptr w y = NotThunk + check_thunk_v v (SOME x) = CT_NotThunk ⇒ + check_thunk_v w (SOME y) = CT_NotThunk Proof - rw [oneline dest_thunk_ptr_def, AllCaseEqs()] - \\ gvs [Once v_rel_cases] - \\ gvs [state_rel_def, LIST_REL_EL_EQN, oEL_THM] - \\ first_x_assum drule \\ simp [] - \\ simp [oneline store_rel_def] - \\ TOP_CASE_TAC \\ gvs [] + rw [check_thunk_v_def, dest_anyThunk_def, AllCaseEqs()] \\ gvs [] + \\ rgs [Once v_rel_cases] \\ gvs [dest_thunk_ptr_def, AllCaseEqs()] + >- ( + gvs [state_rel_def, LIST_REL_EL_EQN, oEL_THM] + \\ first_x_assum drule \\ simp [] + \\ simp [oneline store_rel_def] + \\ TOP_CASE_TAC \\ gvs []) + \\ gvs [ALOOKUP_NONE] + \\ drule_all ALOOKUP_list_rel \\ rw [] \\ gvs [] + \\ rgs [Once compile_rel_cases] QED Theorem step_1_forward: @@ -710,7 +714,7 @@ Proof (gvs [step] \\ last_x_assum mp_tac \\ ntac 2 (TOP_CASE_TAC \\ gvs[]) \\ gvs [OPTREL_def] - \\ drule_all_then assume_tac dest_thunk_ptr_rel \\ gvs [] + \\ drule_all_then assume_tac check_thunk_v_rel \\ gvs [] \\ TOP_CASE_TAC \\ gvs [] \\ strip_tac \\ gvs[] \\ gvs [state_rel_def, LIST_REL_EL_EQN, PULL_EXISTS] diff --git a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml index 63752372..4da1e1dd 100644 --- a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml +++ b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml @@ -1776,6 +1776,8 @@ Proof >- ( (* ForceMutK *) first_x_assum $ qspec_then `1` assume_tac >> gvs[sstep] >> ntac 2 (TOP_CASE_TAC >> gvs[]) >> + ‘dest_thunk_ptr sv sst = NotThunk’ by ( + gvs [check_thunk_v_def, AllCaseEqs(), dest_thunk_ptr_def]) >> gvs [] >> drule_all_then assume_tac dest_thunk_rel >> gvs[] >> qexists0 >> simp[step_rel_cases, SF SFY_ss] >> reverse $ rw[store_assign_def] diff --git a/compiler/backend/passes/proofs/state_unthunkProofScript.sml b/compiler/backend/passes/proofs/state_unthunkProofScript.sml index 45292251..b902d625 100644 --- a/compiler/backend/passes/proofs/state_unthunkProofScript.sml +++ b/compiler/backend/passes/proofs/state_unthunkProofScript.sml @@ -1923,13 +1923,65 @@ Proof \\ gvs [loc_rel_def,dest_anyThunk_def] QED -Theorem dest_thunk_ptr_rel: - state_rel p (SOME s1) (SOME s2) ∧ - v_rel p v1 v2 ∧ - dest_thunk_ptr v1 s1 = NotThunk ⇒ - dest_thunk_ptr v2 s2 = NotThunk +Triviality ALOOKUP_SND: + ∀l f x y. ALOOKUP (FILTER (f o SND) l) x = SOME y ⇒ f y Proof - cheat + Induct \\ rw [] \\ gvs [] + >- ( + PairCases_on ‘h’ \\ gvs [ALOOKUP_def, AllCaseEqs()] + \\ last_x_assum drule \\ gvs []) + \\ last_x_assum drule \\ gvs [] +QED + +Theorem check_thunk_forward: + state_rel p (pick_opt zs ts) (SOME ss) ∧ + v_rel p v1 v2 ∧ + check_thunk_v v1 ts = CT_NotThunk ⇒ + check_thunk_v v2 (SOME ss) = CT_NotThunk +Proof + simp [check_thunk_v_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 [] + >- ( + simp [AllCaseEqs()] + \\ simp [dest_anyThunk_def] + \\ rpt (TOP_CASE_TAC \\ gvs []) + \\ drule ALOOKUP_SND \\ gvs [dest_Lam_def]) + \\ ‘ALL_DISTINCT (MAP FST funs)’ by gvs [] + \\ drule_all LIST_REL_loc_rel_alt \\ gvs []) + \\ rgs [Once v_rel_cases] + \\ gvs [AllCaseEqs(), dest_anyThunk_def] + >>~- ([‘MEM (_,Lam _ _) funs’], + qmatch_goalsub_abbrev_tac ‘ALOOKUP ff _ = NONE’ + \\ ‘∀x. ALOOKUP ff fn ≠ SOME (Delay x)’ suffices_by ( + rw [] \\ gvs [] + \\ Cases_on ‘ALOOKUP ff fn’ \\ gvs [] + \\ Cases_on ‘x’ \\ gvs []) + \\ gvs [Abbr ‘ff’] + \\ rpt strip_tac \\ gvs [] + \\ 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]) + \\ rename1 ‘v_rel p (Atom l) v2’ + \\ Cases_on ‘∀n. l ≠ Loc n’ \\ gvs [] + >- (gvs [AllCaseEqs()] \\ rgs [Once v_rel_cases]) + \\ rgs [Once v_rel_cases] \\ gvs [] + \\ qpat_x_assum ‘_ = CT_NotThunk’ mp_tac + \\ ntac 3 (TOP_CASE_TAC \\ gvs []) + \\ ( + drule_then assume_tac find_loc_length_thm \\ gvs [] + \\ drule_then assume_tac find_loc_el_thm \\ gvs [] + \\ gvs [dest_thunk_ptr_def, state_rel_def, LIST_REL_EL_EQN, oEL_THM, + AllCaseEqs()] + \\ first_x_assum $ qspec_then ‘n’ assume_tac \\ gvs [store_rel_def]) QED Theorem step_forward: @@ -2002,7 +2054,7 @@ Proof \\ pop_assum mp_tac \\ Cases_on ‘m3’ \\ fs [] \\ strip_tac \\ gvs [] \\ gvs [step'_n_add,step,ADD1,step'_def,return'_def] - \\ Cases_on `dest_anyThunk tv` \\ gvs [] + \\ Cases_on ‘check_thunk_v tv ts’ \\ 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 [] @@ -2049,7 +2101,6 @@ Proof \\ disch_then $ qspec_then ‘loc’ mp_tac \\ impl_keep_tac >- (irule v_rel_ext \\ fs []) \\ strip_tac \\ fs [] - \\ ‘dest_thunk_ptr v2 ss1 = NotThunk’ by cheat \\ gvs [] \\ fs [oEL_THM,EL_LUPDATE,store_same_type_def] \\ qmatch_goalsub_abbrev_tac ‘SOME ss3’ \\ gvs [LUPDATE_DEF,LUPDATE_DEF,LUPDATE_LUPDATE] @@ -2058,7 +2109,9 @@ Proof \\ disch_then drule_all \\ strip_tac \\ gvs [] \\ Cases_on ‘m2’ \\ gvs [] \\ gvs [ADD1,step'_n_add,step,step'_def,return'_def] - \\ Cases_on `dest_anyThunk v` \\ gvs [] + \\ Cases_on ‘check_thunk_v v ts’ \\ gvs [] + \\ qpat_x_assum ‘state_rel _ _ (SOME (LUPDATE _ _ _))’ mp_tac + \\ drule_all check_thunk_forward \\ 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] @@ -2073,7 +2126,7 @@ Proof \\ 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 [Abbr ‘ss3’] + \\ strip_tac \\ gvs [] \\ qsuff_tac ‘loc ≠ k’ >- (rpt strip_tac \\ gvs [EL_LUPDATE] \\ metis_tac []) \\ CCONTR_TAC \\ gvs [EL_LUPDATE] @@ -2083,7 +2136,7 @@ Proof >~ [‘BoxK’] >- (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 `dest_anyThunk v1` \\ gvs [] + \\ Cases_on ‘check_thunk_v v1 ts’ \\ gvs [] \\ first_x_assum $ drule_at $ Pos $ el 2 \\ fs [] \\ drule_then drule state_rel_INL \\ simp [oneline dest_anyThunk_def,AllCaseEqs(),oneline dest_Thunk_def] @@ -2150,23 +2203,29 @@ Proof \\ 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] - \\ Cases_on ‘ts’ \\ gvs [] + (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] - \\ Cases_on ‘dest_thunk_ptr v1 x’ \\ gvs [] - \\ drule_all_then assume_tac dest_thunk_ptr_rel \\ gvs [] - \\ imp_res_tac state_rel_def \\ gvs [LIST_REL_EL_EQN] - \\ imp_res_tac find_loc_length_thm - \\ Cases_on ‘n1 < LENGTH t1’ \\ gvs [] - \\ IF_CASES_TAC \\ gvs [store_same_type_def] - \\ imp_res_tac find_loc_el_thm \\ gvs[] - \\ first_assum $ qspec_then ‘n1’ assume_tac - \\ Cases_on ‘EL n1 t1’ \\ Cases_on ‘EL n2 s1’ - \\ gvs [store_rel_def,store_same_type_def] + \\ ‘state_rel p (pick_opt ARB (SOME x)) (SOME ss)’ by gvs [] + \\ drule_all check_thunk_forward \\ 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 - \\ qpat_x_assum ‘v_rel p v v'’ kall_tac \\ drule_all state_rel_thunk_v_rel \\ strip_tac \\ first_x_assum drule \\ disch_then $ qspec_then ‘zs’ strip_assume_tac @@ -2450,15 +2509,16 @@ Proof \\ Q.REFINE_EXISTS_TAC ‘ck1+(1+n5)’ \\ rewrite_tac [step_n_add,ADD1] \\ fs [] \\ simp [step] - \\ reverse $ Cases_on `dest_anyThunk tv` \\ gvs [] - >- (qexists `0` \\ rw []) + \\ Cases_on ‘check_thunk_v tv ts’ \\ gvs [] + >~ [‘CT_Error’] >- (qexists ‘0’ \\ rw []) + >~ [‘CT_IsThunk’] >- (qexists ‘0’ \\ rw []) \\ last_x_assum $ irule \\ first_x_assum $ irule_at Any \\ fs [] \\ rpt (first_assum $ irule_at Any) - \\ simp [step_res_rel_cases]) >> - Cases_on ‘n’ >- (strip_tac >> gvs[]) >> - rewrite_tac[step_n_add, ADD1] >> simp[step, error_def] >> - rename1 ‘step_n n’ + \\ simp [step_res_rel_cases]) + \\ 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 @@ -2484,7 +2544,10 @@ Proof \\ qpat_x_assum ‘step_n m _ = _’ mp_tac \\ rewrite_tac [step_n_add,ADD1] \\ simp [] \\ simp [step] \\ gvs [] - \\ pop_assum mp_tac + \\ TOP_CASE_TAC \\ gvs [] + >~ [‘CT_Error’] >- (strip_tac \\ qexists ‘0’ \\ gvs []) + >~ [‘CT_IsThunk’] >- (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 @@ -2504,9 +2567,8 @@ Proof \\ 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]) - \\ TOP_CASE_TAC \\ gvs [] - >~ [‘BadRef’] >- cheat - >~ [‘IsThunk’] >- cheat + \\ gvs [SOME_THE_pick_opt] + \\ drule_all_then assume_tac check_thunk_forward \\ gvs [] \\ drule v_rel_thunk_IMP_oEL \\ impl_tac >- gvs [] \\ strip_tac \\ first_x_assum drule \\ strip_tac \\ rfs [] @@ -2522,8 +2584,6 @@ Proof \\ rename [‘step_n nn’] \\ gvs [ADD1] \\ strip_tac \\ rpt (disch_then kall_tac) - \\ reverse $ Cases_on `dest_anyThunk res` \\ gvs [] - >- (qexists `0` \\ rw []) \\ last_x_assum irule \\ first_x_assum $ irule_at Any \\ fs [] \\ qexists_tac ‘zs’ \\ qexists_tac ‘p++q’ \\ fs [step_res_rel_cases] @@ -2539,8 +2599,9 @@ Proof >- (rw [] \\ fs [is_halt_def]) \\ fs [] \\ rewrite_tac [step_n_add,ADD1] \\ simp [step,get_atoms_def]) \\ strip_tac - \\ reverse $ Cases_on `dest_anyThunk v1` \\ gvs [] - >- (qexists `0` \\ rw []) + \\ TOP_CASE_TAC \\ gvs [] + >~ [‘CT_Error’] >- (qexists ‘0’ \\ gvs []) + >~ [‘CT_IsThunk’] >- (qexists ‘0’ \\ gvs []) \\ first_x_assum irule \\ first_x_assum $ irule_at Any \\ fs [ADD1] \\ qexists_tac ‘zs’ @@ -2597,10 +2658,13 @@ Proof \\ last_x_assum irule \\ gvs [step_res_rel_cases,PULL_EXISTS] \\ rpt (first_assum $ irule_at Any \\ gvs [])) - >~ [‘ForceMutK’] >- cheat - (*Q.REFINE_EXISTS_TAC ‘ck1+1’ + >~ [‘ForceMutK’] >- + (Q.REFINE_EXISTS_TAC ‘ck1+1’ \\ rewrite_tac [step_n_add,ADD1] \\ gvs [step] - \\ Cases_on ‘m’ \\ gvs [step,ADD1] + \\ 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 check_thunk_forward \\ gvs [] \\ Cases_on ‘ts’ \\ gvs [] >- (qexists ‘0’ \\ fs [is_halt_def]) \\ gvs [step_n_add,ADD1,step] @@ -2616,7 +2680,7 @@ Proof \\ 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 []*) + \\ 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] From 2e871066dcda04a3ae84127546760ff82079a809 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Mon, 20 Oct 2025 21:18:36 +0300 Subject: [PATCH 39/42] Fix stateLang --- .../languages/semantics/stateLangScript.sml | 87 +-- .../proofs/env_to_state_1ProofScript.sml | 20 +- .../proofs/state_app_unit_1ProofScript.sml | 45 +- .../proofs/state_app_unit_2ProofScript.sml | 48 +- .../passes/proofs/state_caseProofScript.sml | 43 +- .../proofs/state_names_1ProofScript.sml | 31 +- .../proofs/state_to_cakeProofScript.sml | 568 +++++++++++++----- .../proofs/state_unthunkProofScript.sml | 149 ++--- 8 files changed, 597 insertions(+), 394 deletions(-) diff --git a/compiler/backend/languages/semantics/stateLangScript.sml b/compiler/backend/languages/semantics/stateLangScript.sml index 8f76a1ee..20efafdc 100644 --- a/compiler/backend/languages/semantics/stateLangScript.sml +++ b/compiler/backend/languages/semantics/stateLangScript.sml @@ -74,6 +74,7 @@ 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 *) @@ -341,13 +342,13 @@ Definition application_def: application (AllocMutThunk mode) vs st k = ( case HD vs, st of v, SOME stores => - value (Atom $ Loc $ LENGTH 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 - (Atom $ Loc n, SOME stores) => ( + (ThunkLoc n, SOME stores) => ( case oEL n stores of SOME (ThunkMem NotEvaluated _) => value @@ -358,7 +359,7 @@ Definition application_def: | _ => error st k) ∧ application ForceMutThunk vs st k = ( case HD vs, st of - (Atom $ Loc n, SOME stores) => ( + (ThunkLoc n, SOME stores) => ( case oEL n stores of SOME (ThunkMem Evaluated v) => value v st k | SOME (ThunkMem NotEvaluated f) => @@ -374,28 +375,14 @@ Definition application_def: | _ => error st k) End -Datatype: - check_thunk_v_ret - = CT_Error - | CT_NotThunk - | CT_IsThunk -End - -Definition check_thunk_v_def: - check_thunk_v v st = +Definition thunk_or_thunk_loc_def: + thunk_or_thunk_loc v = case dest_anyThunk v of | NONE => (case v of - | Atom (Loc n) => - (case st of - | NONE => CT_Error - | SOME stores => - (case dest_thunk_ptr v stores of - | BadRef => CT_Error - | NotThunk => CT_NotThunk - | IsThunk _ _ => CT_IsThunk)) - | _ => CT_NotThunk) - | SOME _ => CT_IsThunk + | ThunkLoc _ => T + | _ => F) + | SOME _ => T End (* Return a value and handle a continuation *) @@ -421,29 +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) = - (case check_thunk_v v st of - | CT_Error => error st k - | CT_NotThunk => value v st k - | CT_IsThunk => error st k) ∧ - return v st (BoxK :: k) = - (case check_thunk_v v st of - | CT_Error => error st k - | CT_NotThunk => value (Thunk $ INL v) st k - | CT_IsThunk => error st k) ∧ - return v st (ForceMutK n :: k) = - (case check_thunk_v v st of - | CT_Error => error st k - | CT_NotThunk => - (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) - | CT_IsThunk => error 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: @@ -984,8 +964,7 @@ Proof >~ [‘BoxK’] >- (gvs [return_def,continue_def,value_def,error_def] \\ gvs [step_n_Val,step_n_Error,error_def,GSYM step_n_def] - \\ rpt (TOP_CASE_TAC \\ gvs []) - \\ gvs [check_thunk_v_def, dest_anyThunk_def, AllCaseEqs()] + \\ 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] @@ -1009,8 +988,7 @@ Proof >~ [‘ForceK2’] >- (gvs [return_def,continue_def,value_def,error_def] \\ gvs [step_n_Val,step_n_Error,error_def,GSYM step_n_def] - \\ rpt (TOP_CASE_TAC \\ gvs []) - \\ gvs [check_thunk_v_def, dest_anyThunk_def, AllCaseEqs()] + \\ 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] @@ -1034,14 +1012,7 @@ Proof \\ 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] - \\ rpt (TOP_CASE_TAC \\ gvs []) - \\ gvs [check_thunk_v_def, dest_anyThunk_def, AllCaseEqs()] - \\ 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]) + \\ 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] @@ -1393,7 +1364,7 @@ QED Theorem ForceMutK_sanity: oEL n st = SOME (ThunkMem NotEvaluated f) ⇒ - step_n 1 (application ForceMutThunk [Atom (Loc n)] (SOME st) k) = + 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 >> diff --git a/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml b/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml index 8a73dbf2..4eee649e 100644 --- a/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml +++ b/compiler/backend/passes/proofs/env_to_state_1ProofScript.sml @@ -622,8 +622,8 @@ Proof \\ qexists_tac ‘1’ \\ fs [] \\ fs [step_def,value_def] \\ simp [Once v_rel_cases]) - >~ [‘Box x’] >- cheat - (*simp [Once compile_rel_cases] \\ rw [] + >~ [‘Box x’] >- + (simp [Once compile_rel_cases] \\ rw [] \\ fs [eval_to_def] \\ Cases_on ‘eval_to n tenv x = INL Type_error’ >- fs [] \\ fs [] \\ Q.REFINE_EXISTS_TAC ‘ck1+1’ @@ -639,9 +639,13 @@ Proof \\ fs [step_def,push_def,return_def,value_def] \\ simp [Once v_rel_cases] \\ CASE_TAC \\ rw [error_def] - \\ drule v_rel_anyThunk \\ rw []*) - >~ [‘Force x’] >- cheat - (*simp [Once compile_rel_cases] \\ rw [] + \\ 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] \\ IF_CASES_TAC \\ gvs [] >- (qexists_tac ‘0’ \\ fs [is_halt_def]) @@ -695,7 +699,11 @@ Proof \\ rewrite_tac [step_n_add] \\ fs [step_def,push_def] \\ qexists_tac ‘1’ \\ fs [step_def,return_def,value_def] \\ CASE_TAC \\ rw [error_def] - \\ drule v_rel_anyThunk \\ rw []*) + \\ 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] diff --git a/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml b/compiler/backend/passes/proofs/state_app_unit_1ProofScript.sml index aedc3675..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 ⇒ @@ -114,7 +118,7 @@ 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 (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 @@ -407,7 +411,6 @@ Proof (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 [] \\ gvs [AllCaseEqs(),oEL_THM,state_rel_def,LIST_REL_EL_EQN] \\ first_assum drule \\ asm_rewrite_tac [store_rel_def] \\ strip_tac @@ -421,7 +424,6 @@ Proof \\ 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 ‘a’ \\ gvs [] \\ 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 >> @@ -662,41 +664,28 @@ Proof \\ simp [Once cont_rel_cases] QED -Theorem check_thunk_v_rel: - ∀v1 v2. - v_rel v1 v2 ⇒ - (state_rel s1 s2 ⇒ - check_thunk_v v1 (SOME s1) = r ⇒ - check_thunk_v v2 (SOME s2) = r) +Theorem thunk_or_thunk_loc_rel: + v_rel v w ⇒ + thunk_or_thunk_loc v = thunk_or_thunk_loc w Proof - ‘(∀v1 v2. - v_rel v1 v2 ⇒ - (state_rel s1 s2 ⇒ - check_thunk_v v1 (SOME s1) = r ⇒ - check_thunk_v v2 (SOME s2) = r)) ∧ + ‘(∀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 [check_thunk_v_def, dest_anyThunk_def] - >~ [‘Closure’] >- gvs [check_thunk_v_def, dest_anyThunk_def] - >~ [‘Atom’] >- ( - gvs [check_thunk_v_def, dest_anyThunk_def] - \\ TOP_CASE_TAC \\ gvs [dest_thunk_ptr_def] - \\ rpt (CASE_TAC \\ gvs []) - \\ gvs [state_rel_def, LIST_REL_EL_EQN, oEL_THM] - \\ first_x_assum drule \\ simp [store_rel_def]) - \\ gvs [check_thunk_v_def, dest_anyThunk_def] + >~ [‘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’] - >- (drule_all ALOOKUP_SOME_EL_2 \\ gvs []) >- ( 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 [] - \\ drule_then assume_tac ALOOKUP_SOME_EL \\ gvs [EVERY_EL] + \\ rpt (dxrule_then assume_tac ALOOKUP_SOME_EL) \\ gvs [EVERY_EL] \\ first_x_assum drule \\ gvs []) QED @@ -744,10 +733,8 @@ Proof \\ 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 ‘check_thunk_v v1 (SOME x0)’ \\ gvs [] - \\ drule_all check_thunk_v_rel \\ gvs [] - >~ [‘CT_Error’] >- rw [step_res_rel_cases] - >~ [‘CT_IsThunk’] >- rw [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 [] diff --git a/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml b/compiler/backend/passes/proofs/state_app_unit_2ProofScript.sml index 77fe0df2..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 ⇒ @@ -424,7 +428,6 @@ Proof (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 [] \\ gvs [AllCaseEqs(),oEL_THM,state_rel_def,LIST_REL_EL_EQN] \\ first_assum drule \\ asm_rewrite_tac [store_rel_def] \\ strip_tac @@ -438,7 +441,6 @@ Proof \\ 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 ‘a’ \\ gvs [] \\ 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 >> @@ -773,42 +775,26 @@ Proof \\ fs []) QED -Theorem check_thunk_v_rel: - ∀v1 v2. - v_rel v1 v2 ⇒ - (state_rel s1 s2 ⇒ - check_thunk_v v1 (SOME s1) = r ⇒ - check_thunk_v v2 (SOME s2) = r) +Theorem thunk_or_thunk_loc_rel: + v_rel v w ⇒ + thunk_or_thunk_loc v = thunk_or_thunk_loc w Proof - ‘(∀v1 v2. - v_rel v1 v2 ⇒ - (state_rel s1 s2 ⇒ - check_thunk_v v1 (SOME s1) = r ⇒ - check_thunk_v v2 (SOME s2) = r)) ∧ + ‘(∀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 [check_thunk_v_def, dest_anyThunk_def] - >~ [‘Closure’] >- gvs [check_thunk_v_def, dest_anyThunk_def] - >~ [‘Atom’] >- ( - gvs [check_thunk_v_def, dest_anyThunk_def] - \\ TOP_CASE_TAC \\ gvs [dest_thunk_ptr_def] - \\ rpt (CASE_TAC \\ gvs []) - \\ gvs [state_rel_def, LIST_REL_EL_EQN, oEL_THM] - \\ first_x_assum drule \\ simp [store_rel_def]) - \\ gvs [check_thunk_v_def, dest_anyThunk_def] + >~ [‘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’] - >- (drule_all ALOOKUP_SOME_EL_2 \\ gvs []) >- ( 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 [] - \\ drule_then assume_tac ALOOKUP_SOME_EL \\ gvs [EVERY_EL] - \\ first_x_assum drule \\ gvs []) + \\ rgs [Once compile_rel_cases] \\ gvs []) QED Theorem step_1_forward: @@ -977,12 +963,8 @@ Proof \\ last_x_assum irule \\ gvs [] \\ metis_tac [step_res_rel_cases]) \\ TOP_CASE_TAC \\ gvs [] - \\ drule_all check_thunk_v_rel \\ gvs [] - >~ [‘CT_Error’] >- ( - rw [] - \\ last_x_assum irule \\ gvs [] - \\ metis_tac [step_res_rel_cases]) - >~ [‘CT_IsThunk’] >- ( + \\ drule_all thunk_or_thunk_loc_rel \\ gvs [] + >- ( rw [] \\ last_x_assum irule \\ gvs [] \\ metis_tac [step_res_rel_cases]) diff --git a/compiler/backend/passes/proofs/state_caseProofScript.sml b/compiler/backend/passes/proofs/state_caseProofScript.sml index 0a32729a..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 ⇒ @@ -152,7 +156,7 @@ Inductive step_res_rel: End Definition store_rel_def: - store_rel (Array vs1) (Array vs2) = LIST_REL v_rel vs1 vs2 ∧ + 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 @@ -423,7 +427,6 @@ Proof (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 [] \\ gvs [AllCaseEqs(),oEL_THM,state_rel_def,LIST_REL_EL_EQN] \\ first_assum drule \\ asm_rewrite_tac [store_rel_def] \\ strip_tac @@ -437,7 +440,6 @@ Proof \\ 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 ‘a’ \\ gvs [] \\ 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 >> @@ -499,41 +501,28 @@ Proof \\ irule env_rel_cons \\ fs [] QED -Theorem check_thunk_v_rel: - ∀v1 v2. - v_rel v1 v2 ⇒ - (state_rel s1 s2 ⇒ - check_thunk_v v1 (SOME s1) = r ⇒ - check_thunk_v v2 (SOME s2) = r) +Theorem thunk_or_thunk_loc_rel: + v_rel v w ⇒ + thunk_or_thunk_loc v = thunk_or_thunk_loc w Proof - ‘(∀v1 v2. - v_rel v1 v2 ⇒ - (state_rel s1 s2 ⇒ - check_thunk_v v1 (SOME s1) = r ⇒ - check_thunk_v v2 (SOME s2) = r)) ∧ + ‘(∀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 [check_thunk_v_def, dest_anyThunk_def] - >~ [‘Closure’] >- gvs [check_thunk_v_def, dest_anyThunk_def] - >~ [‘Atom’] >- ( - gvs [check_thunk_v_def, dest_anyThunk_def] - \\ TOP_CASE_TAC \\ gvs [dest_thunk_ptr_def] - \\ rpt (CASE_TAC \\ gvs []) - \\ gvs [state_rel_def, LIST_REL_EL_EQN, oEL_THM] - \\ first_x_assum drule \\ simp [store_rel_def]) - \\ gvs [check_thunk_v_def, dest_anyThunk_def] + >~ [‘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’] - >- (drule_all ALOOKUP_SOME_EL_2 \\ gvs []) >- ( 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 [] - \\ drule_then assume_tac ALOOKUP_SOME_EL \\ gvs [EVERY_EL] + \\ rpt (dxrule_then assume_tac ALOOKUP_SOME_EL) \\ gvs [EVERY_EL] \\ first_x_assum drule \\ gvs []) QED @@ -745,9 +734,7 @@ Proof \\ Cases_on ‘ss’ \\ gvs [OPTREL_def] >- (rpt (TOP_CASE_TAC \\ gvs []) \\ simp [step_res_rel_cases]) \\ TOP_CASE_TAC \\ gvs [] - \\ drule_all check_thunk_v_rel \\ gvs [] - >~ [‘CT_Error’] >- rw [step_res_rel_cases] - >~ [‘CT_IsThunk’] >- rw [step_res_rel_cases] + \\ 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 [] diff --git a/compiler/backend/passes/proofs/state_names_1ProofScript.sml b/compiler/backend/passes/proofs/state_names_1ProofScript.sml index e902bb51..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 ⇒ @@ -130,7 +134,7 @@ Inductive step_res_rel: End Definition store_rel_def: - store_rel (Array vs1) (Array vs2) = LIST_REL v_rel vs1 vs2 ∧ + 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 @@ -459,7 +463,6 @@ Proof (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 [] \\ gvs [AllCaseEqs(),oEL_THM,state_rel_def,LIST_REL_EL_EQN] \\ first_assum drule \\ asm_rewrite_tac [store_rel_def] \\ strip_tac @@ -473,7 +476,6 @@ Proof \\ 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 ‘a’ \\ gvs [] \\ 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 >> @@ -537,20 +539,19 @@ Proof \\ fs [SUBSET_DEF] QED -Theorem check_thunk_v_rel: - state_rel x y ∧ +Theorem thunk_or_thunk_loc_rel: v_rel v w ∧ - check_thunk_v v (SOME x) = CT_NotThunk ⇒ - check_thunk_v w (SOME y) = CT_NotThunk + ¬thunk_or_thunk_loc v ⇒ + ¬thunk_or_thunk_loc w Proof - rw [check_thunk_v_def, dest_anyThunk_def, AllCaseEqs()] \\ gvs [] - \\ rgs [Once v_rel_cases] \\ gvs [dest_thunk_ptr_def, AllCaseEqs()] + 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 [] >- ( - gvs [state_rel_def, LIST_REL_EL_EQN, oEL_THM] - \\ first_x_assum drule \\ simp [] - \\ simp [oneline store_rel_def] - \\ TOP_CASE_TAC \\ gvs []) - \\ gvs [ALOOKUP_NONE] + 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 @@ -714,7 +715,7 @@ Proof (gvs [step] \\ last_x_assum mp_tac \\ ntac 2 (TOP_CASE_TAC \\ gvs[]) \\ gvs [OPTREL_def] - \\ drule_all_then assume_tac check_thunk_v_rel \\ gvs [] + \\ 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] diff --git a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml index 4da1e1dd..7ef6e2cf 100644 --- a/compiler/backend/passes/proofs/state_to_cakeProofScript.sml +++ b/compiler/backend/passes/proofs/state_to_cakeProofScript.sml @@ -403,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 b (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; @@ -461,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 @@ -498,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 @@ -512,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] ++ @@ -548,95 +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 sk ck - ⇒ cont_rel cnenv (ForceMutK n :: sk) ((Cforce (n + 1), cenv) :: ck)) + (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 (Array svs) (Varray cvs) = LIST_REL (v_rel cnenv) svs cvs ∧ - store_rel cnenv (ThunkMem Evaluated sv) (Thunk Evaluated cv) = - v_rel cnenv sv cv ∧ - store_rel cnenv (ThunkMem NotEvaluated sv) (Thunk NotEvaluated cv) = - v_rel cnenv sv cv ∧ - store_rel cnenv _ _ = F + 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 (store_rel cnenv) 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 (store_rel cnenv) 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) @@ -651,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) @@ -920,7 +925,7 @@ QED Theorem state_rel_store_lookup: state_rel cnenv sst cst ⇒ - OPTREL (store_rel cnenv) (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] @@ -960,20 +965,253 @@ Proof 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 @@ -998,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 @@ -1021,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 @@ -1059,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] >> @@ -1086,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 @@ -1103,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)` >> @@ -1123,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 @@ -1138,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) @@ -1296,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) @@ -1304,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 @@ -1323,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 @@ -1481,17 +1719,20 @@ QED Theorem dest_thunk_rel: state_rel cnenv sst cst ∧ - v_rel cnenv sv cv ∧ - dest_thunk_ptr sv sst = NotThunk ⇒ + v_rel cnenv sst sv cv ∧ + ¬thunk_or_thunk_loc sv ⇒ dest_thunk [cv] cst = NotThunk Proof - rw [oneline dest_thunk_ptr_def, oneline dest_thunk_def, AllCaseEqs()] - \\ gvs [Once v_rel_cases] - \\ gvs [state_rel, LIST_REL_EL_EQN, oEL_THM] - \\ first_x_assum $ drule_then assume_tac \\ gvs [] - \\ gvs [oneline store_rel_def] - \\ FULL_CASE_TAC \\ gvs [] - \\ simp [store_lookup_def, EL_CONS, PRE_SUB1] + 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 **********) @@ -1776,8 +2017,6 @@ Proof >- ( (* ForceMutK *) first_x_assum $ qspec_then `1` assume_tac >> gvs[sstep] >> ntac 2 (TOP_CASE_TAC >> gvs[]) >> - ‘dest_thunk_ptr sv sst = NotThunk’ by ( - gvs [check_thunk_v_def, AllCaseEqs(), dest_thunk_ptr_def]) >> gvs [] >> drule_all_then assume_tac dest_thunk_rel >> gvs[] >> qexists0 >> simp[step_rel_cases, SF SFY_ss] >> reverse $ rw[store_assign_def] @@ -1791,10 +2030,11 @@ Proof Cases_on `t'` >> gvs[store_rel_def] ) >- ( - first_assum $ irule_at Any >> - gvs[state_rel, LUPDATE_DEF, PRE_SUB1] >> - irule EVERY2_LUPDATE_same >> - 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 *) @@ -1887,7 +2127,14 @@ Proof qexists0 >> reverse $ rw[step_rel_cases] >- gvs[state_rel, store_lookup_def] >> qexists `cnenv` >> gvs[state_rel, SNOC_APPEND] >> - imp_res_tac LIST_REL_LENGTH >> rw[store_rel_def]) + 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] >> @@ -1899,10 +2146,17 @@ Proof 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] - >- gvs[state_rel, LUPDATE_DEF, store_lookup_def] >> - goal_assum drule >> gvs[state_rel] >> simp[LUPDATE_DEF, GSYM ADD1] >> - irule EVERY2_LUPDATE_same >> simp[store_rel_def]) + 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] >> @@ -1912,14 +2166,16 @@ Proof 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] - >- (goal_assum drule >> gvs[state_rel, LIST_REL_EL_EQN]) + 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 >> - irule_at Any cont_rel_AppK >> simp[op_rel_cases] >> - irule_at Any cont_rel_ForceMutK >> gvs[env_rel_def] >> - gvs[state_rel, LIST_REL_EL_EQN] - ) + 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] >> @@ -1938,8 +2194,11 @@ Proof `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[store_rel_def]) + 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` >> @@ -2204,8 +2463,13 @@ Proof 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[store_rel_def] >> - `ABS i = i` by ARITH_TAC >> simp[LIST_REL_REPLICATE_same] + 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] >> @@ -2541,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: diff --git a/compiler/backend/passes/proofs/state_unthunkProofScript.sml b/compiler/backend/passes/proofs/state_unthunkProofScript.sml index b902d625..f77c8401 100644 --- a/compiler/backend/passes/proofs/state_unthunkProofScript.sml +++ b/compiler/backend/passes/proofs/state_unthunkProofScript.sml @@ -164,7 +164,7 @@ 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 (Recclosure tfns tenv tn)) + sv = ThunkLoc n ∧ oEL n p = SOME (SOME (Recclosure tfns tenv tn)) End Inductive v_rel: @@ -179,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 ⇒ @@ -219,7 +224,7 @@ Inductive v_rel: [~Thunk:] (∀p n r. oEL n p = SOME (SOME (Thunk r)) ⇒ - v_rel p (Thunk r) (Atom (Loc n))) + v_rel p (Thunk r) (ThunkLoc n)) [env_rel:] (∀p tenv senv. @@ -372,7 +377,7 @@ QED Theorem v_rel_new_Thunk: loc = LENGTH p ⇒ - v_rel (p ++ [SOME (Thunk 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 @@ -390,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’ @@ -522,6 +535,21 @@ Proof \\ 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’ + \\ Induct \\ fs [find_loc_def,PULL_EXISTS] + \\ Cases \\ fs [PULL_EXISTS] \\ rw [] + \\ res_tac \\ fs [] +QED + Theorem state_rel_Ref: LIST_REL (v_rel p) xs ys ∧ state_rel p (SOME ts) (SOME ss) ⇒ state_rel @@ -550,7 +578,7 @@ 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 ∧ + 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()] @@ -626,7 +654,7 @@ 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 (mk_rec_env f x1) senv ∧ compile_rel x2 se ∧ oEL loc ss = SOME (ThunkMem NotEvaluated (Closure NONE senv se))) ∨ @@ -662,7 +690,7 @@ 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 (ThunkMem i1 i2) Proof @@ -718,13 +746,13 @@ 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 (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] @@ -755,6 +783,10 @@ Proof \\ Cases_on ‘loc’ \\ fs [LUPDATE_DEF] \\ rw [] \\ fs []) >~ [‘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()] @@ -1150,7 +1182,7 @@ Proof (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 \\ 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] @@ -1163,9 +1195,8 @@ Proof \\ Cases_on ‘op = ForceMutThunk’ \\ rw [] THEN1 (gvs [application_def,LENGTH_EQ_NUM_compute,error_def,value_def] \\ Cases_on ‘x’ \\ gvs [] - \\ Cases_on ‘l’ \\ gvs [] \\ Cases_on ‘ts’ \\ gvs [] - \\ qpat_x_assum ‘v_rel _ (Atom _) _’ mp_tac + \\ 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] @@ -1178,9 +1209,8 @@ Proof \\ 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 ‘l’ \\ gvs [] \\ Cases_on ‘ts’ \\ gvs [] - \\ qpat_x_assum ‘v_rel _ (Atom _) _’ mp_tac + \\ 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] @@ -1249,7 +1279,7 @@ 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_alloc_thunk: @@ -1393,7 +1423,7 @@ Proof \\ simp [] \\ Cases_on ‘ALOOKUP (env1 ++ make_let_env delays (LENGTH ss + 1) - ((h0,Atom (Loc (LENGTH ss)))::env2)) s’ \\ fs [] + ((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]) @@ -1461,7 +1491,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 \\ impl_tac >- fs [Letrec_store_def] \\ strip_tac \\ fs []) \\ Cases_on ‘∃v3 e3. h2 = Lam v3 e3’ \\ gvs [] @@ -1479,7 +1509,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 \\ impl_tac >- fs [Letrec_store_def] \\ strip_tac \\ fs []) \\ Cases_on ‘h2’ \\ gvs [Letrec_imm_def] @@ -1487,7 +1517,7 @@ Proof \\ simp [] \\ Cases_on ‘ALOOKUP (env1 ++ make_let_env delays (LENGTH ss + 1) - ((h0,Atom (Loc (LENGTH ss)))::env2)) s’ \\ fs [] + ((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] @@ -1501,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 @@ -1628,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] @@ -1677,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] @@ -1733,7 +1763,7 @@ Proof 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] @@ -1894,7 +1924,7 @@ 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 avoid (Exp (mk_rec_env f tenv1) te,NONE,[]) = (Val res,NONE,[]) ⇒ state_rel p ts (SOME (LUPDATE (ThunkMem Evaluated v2) loc ss2)) @@ -1913,7 +1943,7 @@ Proof QED Theorem v_rel_thunk_IMP_oEL: - v_rel p v1 (Atom (Loc loc)) ∧ IS_SOME (dest_anyThunk v1) ⇒ + 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 @@ -1933,13 +1963,12 @@ Proof \\ last_x_assum drule \\ gvs [] QED -Theorem check_thunk_forward: - state_rel p (pick_opt zs ts) (SOME ss) ∧ +Theorem thunk_or_thunk_loc_rel: v_rel p v1 v2 ∧ - check_thunk_v v1 ts = CT_NotThunk ⇒ - check_thunk_v v2 (SOME ss) = CT_NotThunk + ¬thunk_or_thunk_loc v1 ⇒ + ¬thunk_or_thunk_loc v2 Proof - simp [check_thunk_v_def] + 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] @@ -1949,39 +1978,19 @@ Proof >- ( rgs [Once v_rel_cases] \\ gvs [] >- ( - simp [AllCaseEqs()] - \\ simp [dest_anyThunk_def] - \\ rpt (TOP_CASE_TAC \\ 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’], - qmatch_goalsub_abbrev_tac ‘ALOOKUP ff _ = NONE’ - \\ ‘∀x. ALOOKUP ff fn ≠ SOME (Delay x)’ suffices_by ( - rw [] \\ gvs [] - \\ Cases_on ‘ALOOKUP ff fn’ \\ gvs [] - \\ Cases_on ‘x’ \\ gvs []) - \\ gvs [Abbr ‘ff’] - \\ rpt strip_tac \\ gvs [] - \\ drule ALOOKUP_SND \\ gvs [dest_Lam_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]) - \\ rename1 ‘v_rel p (Atom l) v2’ - \\ Cases_on ‘∀n. l ≠ Loc n’ \\ gvs [] - >- (gvs [AllCaseEqs()] \\ rgs [Once v_rel_cases]) - \\ rgs [Once v_rel_cases] \\ gvs [] - \\ qpat_x_assum ‘_ = CT_NotThunk’ mp_tac - \\ ntac 3 (TOP_CASE_TAC \\ gvs []) - \\ ( - drule_then assume_tac find_loc_length_thm \\ gvs [] - \\ drule_then assume_tac find_loc_el_thm \\ gvs [] - \\ gvs [dest_thunk_ptr_def, state_rel_def, LIST_REL_EL_EQN, oEL_THM, - AllCaseEqs()] - \\ first_x_assum $ qspec_then ‘n’ assume_tac \\ gvs [store_rel_def]) + >~ [‘v_rel _ (Atom l) v2’] >- rgs [Once v_rel_cases] QED Theorem step_forward: @@ -2054,7 +2063,7 @@ Proof \\ pop_assum mp_tac \\ Cases_on ‘m3’ \\ fs [] \\ strip_tac \\ gvs [] \\ gvs [step'_n_add,step,ADD1,step'_def,return'_def] - \\ Cases_on ‘check_thunk_v tv ts’ \\ gvs [] + \\ 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 [] @@ -2109,9 +2118,9 @@ Proof \\ disch_then drule_all \\ strip_tac \\ gvs [] \\ Cases_on ‘m2’ \\ gvs [] \\ gvs [ADD1,step'_n_add,step,step'_def,return'_def] - \\ Cases_on ‘check_thunk_v v ts’ \\ gvs [] + \\ Cases_on ‘thunk_or_thunk_loc v’ \\ gvs [] \\ qpat_x_assum ‘state_rel _ _ (SOME (LUPDATE _ _ _))’ mp_tac - \\ drule_all check_thunk_forward \\ rw [] \\ gvs [] + \\ 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] @@ -2136,14 +2145,14 @@ Proof >~ [‘BoxK’] >- (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 ‘check_thunk_v v1 ts’ \\ gvs [] + \\ Cases_on ‘thunk_or_thunk_loc v1’ \\ gvs [] \\ first_x_assum $ drule_at $ Pos $ el 2 \\ fs [] \\ 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 @@ -2211,7 +2220,7 @@ Proof \\ 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 check_thunk_forward \\ strip_tac \\ 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 [] @@ -2338,7 +2347,7 @@ Proof \\ simp [step,return_def] \\ last_x_assum $ drule_at $ Pos $ el 2 \\ simp [] \\ ‘step_res_rel (p ++ [SOME (Thunk (INR (env1,te)))]) - (Val (Thunk (INR (env1,te)))) (Val (Atom (Loc (LENGTH ss)))) ∧ + (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 @@ -2509,9 +2518,7 @@ Proof \\ Q.REFINE_EXISTS_TAC ‘ck1+(1+n5)’ \\ rewrite_tac [step_n_add,ADD1] \\ fs [] \\ simp [step] - \\ Cases_on ‘check_thunk_v tv ts’ \\ gvs [] - >~ [‘CT_Error’] >- (qexists ‘0’ \\ rw []) - >~ [‘CT_IsThunk’] >- (qexists ‘0’ \\ rw []) + \\ IF_CASES_TAC \\ gvs [] >- (qexists ‘0’ \\ rw []) \\ last_x_assum $ irule \\ first_x_assum $ irule_at Any \\ fs [] \\ rpt (first_assum $ irule_at Any) @@ -2544,9 +2551,7 @@ Proof \\ qpat_x_assum ‘step_n m _ = _’ mp_tac \\ rewrite_tac [step_n_add,ADD1] \\ simp [] \\ simp [step] \\ gvs [] - \\ TOP_CASE_TAC \\ gvs [] - >~ [‘CT_Error’] >- (strip_tac \\ qexists ‘0’ \\ gvs []) - >~ [‘CT_IsThunk’] >- (strip_tac \\ qexists ‘0’ \\ gvs []) + \\ 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]) @@ -2568,14 +2573,14 @@ Proof >- (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 check_thunk_forward \\ gvs [] + \\ 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 [] @@ -2599,9 +2604,7 @@ Proof >- (rw [] \\ fs [is_halt_def]) \\ fs [] \\ rewrite_tac [step_n_add,ADD1] \\ simp [step,get_atoms_def]) \\ strip_tac - \\ TOP_CASE_TAC \\ gvs [] - >~ [‘CT_Error’] >- (qexists ‘0’ \\ gvs []) - >~ [‘CT_IsThunk’] >- (qexists ‘0’ \\ gvs []) + \\ IF_CASES_TAC \\ gvs [] >- (qexists ‘0’ \\ gvs []) \\ first_x_assum irule \\ first_x_assum $ irule_at Any \\ fs [ADD1] \\ qexists_tac ‘zs’ @@ -2664,7 +2667,7 @@ Proof \\ 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 check_thunk_forward \\ gvs [] + \\ 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] From 94a0e5944eeabf57034591d26ef5acd74fd0389c Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Mon, 20 Oct 2025 23:47:30 +0300 Subject: [PATCH 40/42] Cheated broken unused thunk proofs --- .../backend/passes/proofs/thunk_case_unboxProofScript.sml | 8 ++++---- .../backend/passes/proofs/thunk_force_delayScript.sml | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/compiler/backend/passes/proofs/thunk_case_unboxProofScript.sml b/compiler/backend/passes/proofs/thunk_case_unboxProofScript.sml index dbdfc6f7..69e6da36 100644 --- a/compiler/backend/passes/proofs/thunk_case_unboxProofScript.sml +++ b/compiler/backend/passes/proofs/thunk_case_unboxProofScript.sml @@ -356,7 +356,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 +414,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 +431,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 +487,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..240c41bd 100644 --- a/compiler/backend/passes/proofs/thunk_force_delayScript.sml +++ b/compiler/backend/passes/proofs/thunk_force_delayScript.sml @@ -458,7 +458,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 +506,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 +521,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 +566,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’ From 8ec4058a1eb52be7b329b7cbe2e23bb4c34f3cbc Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 23 Oct 2025 11:20:51 +0300 Subject: [PATCH 41/42] Leave unused proofs cheated --- .../proofs/thunk_case_unboxProofScript.sml | 50 +++++++++++++++++++ .../passes/proofs/thunk_force_delayScript.sml | 3 ++ 2 files changed, 53 insertions(+) diff --git a/compiler/backend/passes/proofs/thunk_case_unboxProofScript.sml b/compiler/backend/passes/proofs/thunk_case_unboxProofScript.sml index 69e6da36..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 ⇒ diff --git a/compiler/backend/passes/proofs/thunk_force_delayScript.sml b/compiler/backend/passes/proofs/thunk_force_delayScript.sml index 240c41bd..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 From 07943e57922246ede87c85917fbe4ee4d8b44ea3 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 23 Oct 2025 11:28:35 +0300 Subject: [PATCH 42/42] Add `check_thm` to top level correctness theorem --- compiler/proofs/pure_end_to_endProofScript.sml | 5 +++++ 1 file changed, 5 insertions(+) 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;